**diff options**

author | harendra <> | 2018-05-13 22:54:00 (GMT) |
---|---|---|

committer | hdiff <hdiff@hdiff.luite.com> | 2018-05-13 22:54:00 (GMT) |

commit | aeaeab63dd1c6dd49653ea63caf99bd4c2a3666c (patch) | |

tree | 880fe48ce5efd2ae2ac029c3e6b931812637fddd | |

parent | 8ced2082b2adef42a267918db581fabb304f3112 (diff) |

version 0.2.00.2.0

35 files changed, 4906 insertions, 2932 deletions

diff --git a/Changelog.md b/Changelog.md index 3d562c7..720e2e8 100644 --- a/Changelog.md +++ b/Changelog.md @@ -1,3 +1,81 @@ +## 0.2.0 + +### Breaking changes +* Changed the semantics of the Semigroup instance for `InterleavedT`, `AsyncT` + and `ParallelT`. The new semantics are as follows: + * For `InterleavedT`, `<>` operation interleaves two streams + * For `AsyncT`, `<>` now concurrently merges two streams in a left biased + manner using demand based concurrency. + * For `ParallelT`, the `<>` operation now concurrently meges the two streams + in a fairly parallel manner. + + To adapt to the new changes, replace `<>` with `serial` wherever it is used + for stream types other than `StreamT`. + +* Remove the `Alternative` instance. To adapt to this change replace any usage + of `<|>` with `parallel` and `empty` with `nil`. +* Stream type now defaults to the `SerialT` type unless explicitly specified + using a type combinator or a monomorphic type. This change reduces puzzling + type errors for beginners. It includes the following two changes: + * Change the type of all stream elimination functions to use `SerialT` + instead of a polymorphic type. This makes sure that the stream type is + always fixed at all exits. + * Change the type combinators (e.g. `parallely`) to only fix the argument + stream type and the output stream type remains polymorphic. + + Stream types may have to be changed or type combinators may have to be added + or removed to adapt to this change. +* Change the type of `foldrM` to make it consistent with `foldrM` in base. +* `async` is renamed to `mkAsync` and `async` is now a new API with a different + meaning. +* `ZipAsync` is renamed to `ZipAsyncM` and `ZipAsync` is now ZipAsyncM + specialized to the IO Monad. +* Remove the `MonadError` instance as it was not working correctly for + parallel compositions. Use `MonadThrow` instead for error propagation. +* Remove Num/Fractional/Floating instances as they are not very useful. Use + `fmap` and `liftA2` instead. + +### Deprecations +* Deprecate and rename the following symbols: + * `Streaming` to `IsStream` + * `runStreaming` to `runStream` + * `StreamT` to `SerialT` + * `InterleavedT` to `WSerialT` + * `ZipStream` to `ZipSerialM` + * `ZipAsync` to `ZipAsyncM` + * `interleaving` to `wSerially` + * `zipping` to `zipSerially` + * `zippingAsync` to `zipAsyncly` + * `<=>` to `wSerial` + * `<|` to `async` + * `each` to `fromFoldable` + * `scan` to `scanx` + * `foldl` to `foldx` + * `foldlM` to `foldxM` +* Deprecate the following symbols for future removal: + * `runStreamT` + * `runInterleavedT` + * `runAsyncT` + * `runParallelT` + * `runZipStream` + * `runZipAsync` + +### Enhancements +* Add the following functions: + * `consM` and `|:` operator to construct streams from monadic actions + * `once` to create a singleton stream from a monadic action + * `repeatM` to construct a stream by repeating a monadic action + * `scanl'` strict left scan + * `foldl'` strict left fold + * `foldlM'` strict left fold with a monadic fold function + * `serial` run two streams serially one after the other + * `async` run two streams asynchronously + * `parallel` run two streams in parallel (replaces `<|>`) + * `WAsyncT` stream type for BFS version of `AsyncT` composition +* Add simpler stream types that are specialized to the IO monad +* Put a bound (1500) on the output buffer used for asynchronous tasks +* Put a limit (1500) on the number of threads used for Async and WAsync types + ## 0.1.2 ### Enhancements @@ -2,36 +2,140 @@ ## Stream`ing` `Concurrent`ly -Streamly is a monad transformer unifying non-determinism -([list-t](https://hackage.haskell.org/package/list-t)/[logict](https://hackage.haskell.org/package/logict)), -concurrency ([async](https://hackage.haskell.org/package/async)), -streaming ([conduit](https://hackage.haskell.org/package/conduit)\/[pipes](https://hackage.haskell.org/package/pipes)), -and FRP ([Yampa](https://hackage.haskell.org/package/Yampa)\/[reflex](https://hackage.haskell.org/package/reflex)) -functionality in a concise and intuitive API. -High level concurrency makes concurrent applications almost indistinguishable -from non-concurrent ones. By changing a single combinator you can control -whether the code runs serially or concurrently. It naturally integrates -concurrency with streaming rather than adding it as an afterthought. -Moreover, it interworks with the popular streaming libraries. - -See the haddock documentation for full reference. It is recommended that you -read `Streamly.Tutorial` first. Also see `Streamly.Examples` for some working -examples. +Streamly, short for streaming concurrently, is a simple yet powerful streaming +library with concurrent merging and concurrent nested looping support. A stream +is just like a list except that it is a list of monadic actions rather than +pure values. Streamly streams can be generated, consumed, combined, or +transformed serially or concurrently. We can loop over a stream serially or +concurrently. We can also have serial or concurrent nesting of loops. For +those familiar with the list transformer concept streamly is a concurrent list +transformer. Streamly uses standard composition abstractions. Concurrent +composition is just the same as serial composition except that we use a simple +combinator to request a concurrent composition instead of serial. The +programmer does not have to be aware of threads, locking or synchronization to +write scalable concurrent programs. + +Streamly provides functionality that is equivalent to streaming libraries +like [pipes](https://hackage.haskell.org/package/pipes) and +[conduit](https://hackage.haskell.org/package/conduit) but with a list like +API. The streaming API of streamly is close to the monadic streams API of the +[vector](https://hackage.haskell.org/package/vector) package and similar in +concept to the [streaming](https://hackage.haskell.org/package/streaming) +package. In addition to providing streaming functionality, streamly subsumes +the functionality of list transformer libraries like `pipes` or +[list-t](https://hackage.haskell.org/package/list-t) and also the logic +programming library [logict](https://hackage.haskell.org/package/logict). On +the concurrency side, it subsumes the functionality of the +[async](https://hackage.haskell.org/package/async) package. Because it supports +streaming with concurrency we can write FRP applications similar in concept to +[Yampa](https://hackage.haskell.org/package/Yampa) or +[reflex](https://hackage.haskell.org/package/reflex). To understand the +streaming library ecosystem and where streamly fits in you may want to read +[streaming libraries](https://github.com/composewell/streaming-benchmarks#streaming-libraries) +as well. Also see the [Comparison with Existing +Packages](https://hackage.haskell.org/package/streamly/docs/Streamly-Tutorial.html) +section in the streamly tutorial. + +Why use streamly? + + * Simple list like streaming API, if you know how to use lists then you know + how to use streamly. + * Powerful yet simple and scalable concurrency. Concurrency is not intrusive, + concurrent programs are written exactly the same way as non-concurrent + ones. There is no other package that provides such high level, simple and + flexible concurrency support. + * It is a general programming framework providing you all the necessary tools + to solve a wide range of programming problems, unifying the functionality + provided by several disparate packages in a concise and simple API. + * Best in class performance. See + [streaming-benchmarks](https://github.com/composewell/streaming-benchmarks) + for a comparison of popular streaming libraries on micro-benchmarks. + + For more information, see: + + * [Streamly.Tutorial](https://hackage.haskell.org/package/streamly/docs/Streamly-Tutorial.html) module in the haddock documentation for a detailed introduction + * [examples](https://github.com/composewell/streamly/tree/master/examples) directory in the package for some simple practical examples + +## Streaming Pipelines + +Unlike `pipes` or `conduit` and like `vector` and `streaming` `streamly` +composes stream data instead of stream processors (functions). A stream is +just like a list and is explicitly passed around to functions that process the +stream. Therefore, no special operator is needed to join stages in a streaming +pipeline, just the standard forward (`$`) or reverse (`&`) function application +operator is enough. Combinators are provided in `Streamly.Prelude` to +transform or fold streams. + +This snippet reads numbers from stdin, prints the squares of even numbers and +exits if an even number more than 9 is entered. -`Streamly` has best in class performance even though it generalizes streaming -to concurrent composition that does not mean it sacrifices non-concurrent -performance. See -[streaming-benchmarks](https://github.com/composewell/streaming-benchmarks) for -detailed performance comparison with regular streaming libraries and the -explanation of the benchmarks. The following graphs show a summary, the first -one measures how four pipeline stages in a series perform, the second one -measures the performance of individual stream operations; in both cases the -stream processes a million elements: +```haskell +import Streamly +import qualified Streamly.Prelude as S +import Data.Function ((&)) + +main = runStream $ + S.repeatM getLine + & fmap read + & S.filter even + & S.takeWhile (<= 9) + & fmap (\x -> x * x) + & S.mapM print +``` + +## Serial and Concurrent Merging + +Semigroup and Monoid instances can be used to fold streams serially or +concurrently. In the following example we are composing ten actions in the +stream each with a delay of 1 to 10 seconds, respectively. Since all the +actions are concurrent we see one output printed every second: + +``` haskell +import Streamly +import qualified Streamly.Prelude as S +import Control.Concurrent (threadDelay) + +main = S.toList $ parallely $ foldMap delay [1..10] + where delay n = S.once $ threadDelay (n * 1000000) >> print n +``` + +Streams can be combined together in many ways. We are providing some examples +below, see the tutorial for more ways. We will use the following `delay` +function in the examples to demonstrate the concurrency aspects: + +``` haskell +import Streamly +import qualified Streamly.Prelude as S +import Control.Concurrent + +delay n = S.once $ do + threadDelay (n * 1000000) + tid <- myThreadId + putStrLn (show tid ++ ": Delay " ++ show n) +``` +### Serial + +```haskell +main = runStream $ delay 3 <> delay 2 <> delay 1 +``` +``` +ThreadId 36: Delay 3 +ThreadId 36: Delay 2 +ThreadId 36: Delay 1 +``` -![Composing Pipeline Stages](charts/ComposingPipelineStages.svg) -![All Operations at a Glance](charts/AllOperationsataGlance.svg) +### Parallel -## Non-determinism +```haskell +main = runStream . parallely $ delay 3 <> delay 2 <> delay 1 +``` +``` +ThreadId 42: Delay 1 +ThreadId 41: Delay 2 +ThreadId 40: Delay 3 +``` + +## Nested Loops (aka List Transformer) The monad instance composes like a list monad. @@ -40,11 +144,11 @@ import Streamly import qualified Streamly.Prelude as S loops = do - x <- S.each [1,2] - y <- S.each [3,4] - liftIO $ putStrLn $ show (x, y) + x <- S.fromFoldable [1,2] + y <- S.fromFoldable [3,4] + S.once $ putStrLn $ show (x, y) -main = runStreaming $ serially $ loops +main = runStream loops ``` ``` (1,3) @@ -53,30 +157,40 @@ main = runStreaming $ serially $ loops (2,4) ``` -## Magical Concurrency +## Concurrent Nested Loops + +To run the above code with demand-driven depth first concurrency i.e. each +iteration in the loops can run concurrently depending on the consumer rate: + +``` haskell +main = runStream $ asyncly $ loops +``` -To run the above code with demand-driven concurrency i.e. each iteration in the -loops can run concurrently depending on the consumer rate: +To run it with demand driven breadth first concurrency: ``` haskell -main = runStreaming $ asyncly $ loops +main = runStream $ wAsyncly $ loops ``` -To run it with full parallelism irrespective of demand: +To run it with strict concurrency irrespective of demand: ``` haskell -main = runStreaming $ parallely $ loops +main = runStream $ parallely $ loops ``` -To run it serially but interleaving the outer and inner loop iterations: +To run it serially but interleaving the outer and inner loop iterations +(breadth first serial): ``` haskell -main = runStreaming $ interleaving $ loops +main = runStream $ wSerially $ loops ``` -You can fold multiple streams or IO actions using parallel combinators like -`<|`, `<|>`. For example, to concurrently generate the squares and then -concurrently sum the square roots of all combinations: +## Magical Concurrency + +Streams can perform semigroup (<>) and monadic bind (>>=) operations +concurrently using combinators like `asyncly`, `parallelly`. For example, +to concurrently generate squares of a stream of numbers and then concurrently +sum the square roots of all combinations of two streams: ``` haskell import Streamly @@ -84,99 +198,64 @@ import qualified Streamly.Prelude as S main = do s <- S.sum $ asyncly $ do - -- Squaring is concurrent (<|) - x2 <- forEachWith (<|) [1..100] $ \x -> return $ x * x - y2 <- forEachWith (<|) [1..100] $ \y -> return $ y * y - -- sqrt is concurrent (asyncly) + -- Each square is performed concurrently, (<>) is concurrent + x2 <- foldMap (\x -> return $ x * x) [1..100] + y2 <- foldMap (\y -> return $ y * y) [1..100] + -- Each addition is performed concurrently, monadic bind is concurrent return $ sqrt (x2 + y2) print s ``` -Of course, the actions running in parallel could be arbitrary IO actions. To -concurrently list the contents of a directory tree recursively: +Of course, the actions running in parallel could be arbitrary IO actions. For +example, to concurrently list the contents of a directory tree recursively: ``` haskell import Path.IO (listDir, getCurrentDir) import Streamly +import qualified Streamly.Prelude as S -main = runStreaming $ serially $ getCurrentDir >>= readdir +main = runStream $ asyncly $ getCurrentDir >>= readdir where readdir d = do - (dirs, files) <- lift $ listDir d - liftIO $ mapM_ putStrLn $ map show files - -- read the subdirs concurrently - foldMapWith (<|>) readdir dirs + (dirs, files) <- S.once $ listDir d + S.once $ mapM_ putStrLn $ map show files + -- read the subdirs concurrently, (<>) is concurrent + foldMap readdir dirs ``` In the above examples we do not think in terms of threads, locking or synchronization, rather we think in terms of what can run in parallel, the rest -is taken care of automatically. With `asyncly` and `<|` the programmer does not -have to worry about how many threads are to be created they are automatically -adjusted based on the demand of the consumer. +is taken care of automatically. When using `asyncly` the programmer does +not have to worry about how many threads are to be created they are +automatically adjusted based on the demand of the consumer. The concurrency facilities provided by streamly can be compared with [OpenMP](https://en.wikipedia.org/wiki/OpenMP) and [Cilk](https://en.wikipedia.org/wiki/Cilk) but with a more declarative -expression. Concurrency support does not compromise performance in -non-concurrent cases, the performance of the library is at par or better than -most of the existing streaming libraries. - -## Streaming - -Streaming is effortless, simple and straightforward. Streamly data type behaves -just like a list and combinators are provided in `Streamly.Prelude` to -transform or fold streamly streams. Unlike other libraries and like `streaming` -library the combinators explicitly consume a stream and produce a stream, -therefore, no special operator is needed to join stream stages, just a forward -(`$`) or reverse (`&`) function application operator is enough. - -```haskell -import Streamly -import qualified Streamly.Prelude as S -import Data.Function ((&)) - -main = S.each [1..10] - & fmap (+ 1) - & S.drop 2 - & S.filter even - & fmap (* 3) - & S.takeWhile (< 25) - & S.mapM (\x -> putStrLn ("saw " ++ show x) >> return x) - & S.toList . serially - >>= print -``` - -Fold style combinators can be used to fold purely or monadically. You can also -use the beautiful `foldl` library for folding. +expression. -```haskell -main = S.each [1..10] - & serially - & S.foldl (+) 0 id - >>= print -``` - -Streams can be combined together in multiple ways: +## Reactive Programming (FRP) -```haskell -main = do - let p s = (toList . serially) s >>= print - p $ return 1 <> return 2 -- serial, combine atoms - p $ S.each [1..10] <> S.each [11..20] -- serial - p $ S.each [1..10] <| S.each [11..20] -- demand driven parallel - p $ S.each [1..10] <=> S.each [11..20] -- serial but interleaved - p $ S.each [1..10] <|> S.each [11..20] -- fully parallel -``` +Streamly is a foundation for first class reactive programming as well by virtue +of integrating concurrency and streaming. See +[AcidRain.hs](https://github.com/composewell/streamly/tree/master/examples/AcidRain.hs) +for a console based FRP game example and +[CirclingSquare.hs](https://github.com/composewell/streamly/tree/master/examples/CirclingSquare.hs) +for an SDL based animation example. -As we have already seen streams can be combined using monadic composition in a -non-deterministic manner. This allows arbitrary manipulation and combining of -streams. See `Streamly.Examples.MergeSortedStreams` for a more complicated -example. +## Performance -## Reactive Programming (FRP) +`Streamly` has best in class performance even though it generalizes streaming +to concurrent composition that does not mean it sacrifices non-concurrent +performance. See +[streaming-benchmarks](https://github.com/composewell/streaming-benchmarks) for +detailed performance comparison with regular streaming libraries and the +explanation of the benchmarks. The following graphs show a summary, the first +one measures how four pipeline stages in a series perform, the second one +measures the performance of individual stream operations; in both cases the +stream processes a million elements: -Streamly is a foundation for first class reactive programming as well by virtue -of integrating concurrency and streaming. See `Streamly.Examples.AcidRainGame` -and `Streamly.Examples.CirclingSquare` for an SDL based animation example. +![Composing Pipeline Stages](charts/comparative/ComposingPipelineStages.svg) +![All Operations at a Glance](charts/comparative/AllOperationsataGlance.svg) ## Contributing diff --git a/bench.sh b/bench.sh new file mode 100755 index 0000000..0162078 --- /dev/null +++ b/bench.sh @@ -0,0 +1,176 @@ +#!/bin/bash + +print_help () { + echo "Usage: $0 " + echo " [--quick] [--append] " + echo " [--no-graphs] [--no-measure]" + echo " [--benchmark <linear|nested>]" + echo " [--compare] [--base commit] [--candidate commit]" + echo " -- <gauge options>" + echo + echo "When using --compare, by default comparative chart of HEAD^ vs HEAD" + echo "commit is generated, in the 'charts' directory." + echo "Use --base and --candidate to select the commits to compare." + echo + echo "Any arguments after a '--' are passed directly to guage" + echo "You can omit '--' if the gauge args used do not start with a '-'." + exit +} + +# $1: message +die () { + >&2 echo -e "Error: $1" + exit 1 +} + +DEFAULT_BENCHMARK=linear +COMPARE=0 + +while test -n "$1" +do + case $1 in + -h|--help|help) print_help ;; + --quick) QUICK=1; shift ;; + --append) APPEND=1; shift ;; + --benchmark) shift; BENCHMARK=$1; shift ;; + --base) shift; BASE=$1; shift ;; + --candidate) shift; CANDIDATE=$1; shift ;; + --compare) COMPARE=1; shift ;; + --no-graphs) GRAPH=0; shift ;; + --no-measure) MEASURE=0; shift ;; + --) shift; break ;; + -*|--*) print_help ;; + *) break ;; + esac +done + +GAUGE_ARGS=$* + +if test -z "$BENCHMARK" +then + BENCHMARK=$DEFAULT_BENCHMARK + echo "Using default benchmark suite [$BENCHMARK], use --benchmark to specify another" +else + echo "Using benchmark suite [$BENCHMARK]" +fi + +STACK=stack +echo "Using stack command [$STACK]" + +# We build it first at the current commit before checking out any other commit +# for benchmarking. +if test "$GRAPH" != "0" +then + CHART_PROG="chart-$BENCHMARK" + prog=$($STACK exec which $CHART_PROG) + if test ! -x "$prog" + then + echo "Building charting executable" + $STACK build --flag "streamly:dev" || die "build failed" + fi + + prog=$($STACK exec which $CHART_PROG) + if test ! -x "$prog" + then + die "Could not find [$CHART_PROG] executable" + fi + CHART_PROG=$prog + echo "Using chart executable [$CHART_PROG]" +fi + +# We run the benchmarks in isolation in a separate process so that different +# benchmarks do not interfere with other. To enable that we need to pass the +# benchmark exe path to guage as an argument. Unfortunately it cannot find its +# own path currently. + +# The path is dependent on the architecture and cabal version. +# Use this command to find the exe if this script fails with an error: +# find .stack-work/ -type f -name "benchmarks" + +find_bench_prog () { + BENCH_PROG=`$STACK path --dist-dir`/build/$BENCHMARK/$BENCHMARK + if test ! -x "$BENCH_PROG" + then + echo + echo "WARNING! benchmark binary [$BENCH_PROG] not found or not executable" + echo "WARNING! not using isolated measurement." + echo + fi +} + +# --min-duration 0 means exactly one iteration per sample. We use a million +# iterations in the benchmarking code explicitly and do not use the iterations +# done by the benchmarking tool. +# +# Benchmarking tool by default discards the first iteration to remove +# aberrations due to initial evaluations etc. We do not discard it because we +# are anyway doing iterations in the benchmarking code and many of them so that +# any constant factor gets amortized and anyway it is a cost that we pay in +# real life. +# +# We can pass --min-samples value from the command line as second argument +# after the benchmark name in case we want to use more than one sample. + +if test "$QUICK" = "1" +then + ENABLE_QUICK="--quick" +fi + +OUTPUT_FILE="charts/results.csv" + +run_bench () { + $STACK build --bench --no-run-benchmarks || die "build failed" + find_bench_prog + mkdir -p charts + + # We set min-samples to 1 so that we run with default benchmark duration of 5 + # seconds, whatever number of samples are possible in that. + # We run just one iteration for each sample. Anyway the default is to run + # for 30 ms and most our benchmarks are close to that or more. + # If we use less than three samples, statistical analysis crashes + $BENCH_PROG $ENABLE_QUICK \ + --include-first-iter \ + --min-samples 3 \ + --min-duration 0 \ + --csvraw=$OUTPUT_FILE \ + -v 2 \ + --measure-with $BENCH_PROG $GAUGE_ARGS || die "Benchmarking failed" +} + +if test "$MEASURE" != "0" + then + if test -e $OUTPUT_FILE -a "$APPEND" != 1 + then + mv -f -v $OUTPUT_FILE ${OUTPUT_FILE}.prev + fi + + if test "$COMPARE" = "0" + then + run_bench + else + if test -z "$CANDIDATE" + then + CANDIDATE=$(git rev-parse HEAD) + fi + if test -z "$BASE" + then + # XXX Should be where the current branch is forked from master + BASE="$CANDIDATE^" + fi + echo "Checking out base commit for benchmarking" + git checkout "$BASE" || die "Checkout of base commit failed" + run_bench + echo "Checking out candidate commit for benchmarking" + git checkout "$CANDIDATE" || die "Checkout of candidate commit failed" + run_bench + fi +fi + +if test "$GRAPH" != "0" +then + echo + echo "Generating charts from ${OUTPUT_FILE}..." + $CHART_PROG +fi + +# XXX reset back to the original commit diff --git a/benchmark/ChartLinear.hs b/benchmark/ChartLinear.hs new file mode 100644 index 0000000..b4d8cbb --- /dev/null +++ b/benchmark/ChartLinear.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Data.List +import Data.List.Split +import BenchGraph (bgraph, defaultConfig, Config(..), ComparisonStyle(..)) +import Control.Exception (handle, catch, SomeException, ErrorCall) + +main :: IO () +main = do + let cfg = defaultConfig + { outputDir = "charts" + , comparisonStyle = CompareDelta + } + + ignoringErr a = catch a (\(_ :: ErrorCall) -> + putStrLn "Failed. Skipping.") + -- bgraph <input> <output> <field in csv file to be plotted> + -- other interesting fields to plot are: + -- allocated + -- bytesCopied + -- mutatorCpuSeconds + -- gcCpuSeconds + ignoringErr $ bgraph "charts/results.csv" "operations" "time" $ cfg + { chartTitle = Just "Streamly operations (time)" + , classifyBenchmark = \b -> + if "compose" `isPrefixOf` b || "/concat" `isSuffixOf` b + then Nothing + else Just ("Streamly", last $ splitOn "/" b) + } + + ignoringErr $ bgraph "charts/results.csv" "composition" "time" $ cfg + { chartTitle = Just "Streamly composition performance (time)" + , classifyBenchmark = fmap ("Streamly",) . stripPrefix "compose/" + } + + ignoringErr $ bgraph "charts/results.csv" "composition-scaling" "time" + $ cfg + { chartTitle = Just "Streamly composition scaling (time)" + , classifyBenchmark = fmap ("Streamly",) . stripPrefix "compose-" + } diff --git a/benchmark/ChartNested.hs b/benchmark/ChartNested.hs new file mode 100644 index 0000000..e1554e8 --- /dev/null +++ b/benchmark/ChartNested.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Data.List +import Data.List.Split +import BenchGraph (bgraph, defaultConfig, Config(..), ComparisonStyle(..)) +import Control.Exception (handle, catch, SomeException, ErrorCall) + +main :: IO () +main = do + let cfg = defaultConfig + { outputDir = "charts" + , comparisonStyle = CompareFull + } + + ignoringErr a = catch a (\(_ :: ErrorCall) -> + putStrLn "Failed. Skipping.") + -- bgraph <input> <output> <field in csv file to be plotted> + -- other interesting fields to plot are: + -- allocated + -- bytesCopied + -- mutatorCpuSeconds + -- gcCpuSeconds + ignoringErr $ bgraph "charts/results.csv" "nested-ops" "time" $ cfg + { chartTitle = Just "Nested operations (time)" + , classifyBenchmark = \b -> + let ls = splitOn "/" b + in case head ls of + "linear" -> Nothing + _ -> Just (head ls, last ls) + , sortBenchmarks = nub + , comparisonStyle = CompareFull + } + + ignoringErr $ bgraph "charts/results.csv" "nested-serial-comparative" "time" $ cfg + { chartTitle = Just "Nested serial diff (time)" + , classifyBenchmark = \b -> + let ls = splitOn "/" b + in case head ls of + "serially" -> Just (head ls, last ls) + _ -> Nothing + , sortBenchmarks = nub + , comparisonStyle = CompareDelta + } diff --git a/benchmark/Linear.hs b/benchmark/Linear.hs new file mode 100644 index 0000000..9e6606d --- /dev/null +++ b/benchmark/Linear.hs @@ -0,0 +1,72 @@ +-- | +-- Module : Main +-- Copyright : (c) 2018 Harendra Kumar +-- +-- License : BSD3 +-- Maintainer : harendra.kumar@gmail.com + +import Control.DeepSeq (NFData) +import Data.Functor.Identity (Identity, runIdentity) +import System.Random (randomRIO) +import qualified LinearOps as Ops + +import Streamly +import Gauge + +-- 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. +benchIO :: (NFData b) => String -> (Ops.Stream m Int -> IO b) -> Benchmark +benchIO name f = bench name $ nfIO $ randomRIO (1,1000) >>= f . Ops.source + +benchIOAppend :: (NFData b) => String -> (Int -> IO b) -> Benchmark +benchIOAppend name f = bench name $ nfIO $ randomRIO (1,1000) >>= f + +_benchId :: (NFData b) => String -> (Ops.Stream m Int -> Identity b) -> Benchmark +_benchId name f = bench name $ nf (runIdentity . f) (Ops.source 10) + +main :: IO () +main = do + defaultMain + [ bgroup "elimination" + [ benchIO "toNull" Ops.toNull + , benchIO "toList" Ops.toList + , benchIO "fold" Ops.foldl + , benchIO "last" Ops.last + ] + , bgroup "transformation" + [ benchIO "scan" Ops.scan + , benchIO "map" Ops.map + , benchIO "mapM" Ops.mapM + , benchIO "concat" Ops.concat + ] + , bgroup "filtering" + [ benchIO "filter-even" Ops.filterEven + , benchIO "filter-all-out" Ops.filterAllOut + , benchIO "filter-all-in" Ops.filterAllIn + , benchIO "take-all" Ops.takeAll + , benchIO "takeWhile-true" Ops.takeWhileTrue + , benchIO "drop-all" Ops.dropAll + , benchIO "dropWhile-true" Ops.dropWhileTrue + ] + , benchIO "zip" Ops.zip + , bgroup "append" + [ benchIOAppend "serially" $ Ops.append serially + , benchIOAppend "wSerially" $ Ops.append wSerially + , benchIOAppend "asyncly" $ Ops.append asyncly + , benchIOAppend "wAsyncly" $ Ops.append wAsyncly + , benchIOAppend "parallely" $ Ops.append parallely + ] + , bgroup "compose" + [ benchIO "mapM" Ops.composeMapM + , benchIO "map-with-all-in-filter" Ops.composeMapAllInFilter + , benchIO "all-in-filters" Ops.composeAllInFilters + , benchIO "all-out-filters" Ops.composeAllOutFilters + ] + , bgroup "compose-scaling" + -- Scaling with same operation in sequence + [ benchIO "1" $ Ops.composeScaling 1 + , benchIO "2" $ Ops.composeScaling 2 + , benchIO "3" $ Ops.composeScaling 3 + , benchIO "4" $ Ops.composeScaling 4 + ] + ] diff --git a/benchmark/LinearOps.hs b/benchmark/LinearOps.hs new file mode 100644 index 0000000..fdbb297 --- /dev/null +++ b/benchmark/LinearOps.hs @@ -0,0 +1,138 @@ +-- | +-- Module : BenchmarkOps +-- Copyright : (c) 2018 Harendra Kumar +-- +-- License : MIT +-- Maintainer : harendra.kumar@gmail.com + +module LinearOps where + +import Prelude + (Monad, Int, (+), ($), (.), return, fmap, even, (>), (<=), + subtract, undefined, Maybe, Monoid, foldMap) + +import qualified Streamly as S +import qualified Streamly.Prelude as S + +value, appendValue, maxValue :: Int +value = 1000000 +appendValue = 100000 +maxValue = value + 1000 + +------------------------------------------------------------------------------- +-- Benchmark ops +------------------------------------------------------------------------------- + +{-# INLINE toNull #-} +{-# INLINE toList #-} +{-# INLINE foldl #-} +{-# INLINE last #-} +{-# INLINE scan #-} +{-# INLINE map #-} +{-# INLINE filterEven #-} +{-# INLINE mapM #-} +{-# INLINE filterAllOut #-} +{-# INLINE filterAllIn #-} +{-# INLINE takeOne #-} +{-# INLINE takeAll #-} +{-# INLINE takeWhileTrue #-} +{-# INLINE dropAll #-} +{-# INLINE dropWhileTrue #-} +{-# INLINE zip #-} +{-# INLINE concat #-} +{-# INLINE composeMapM #-} +{-# INLINE composeAllInFilters #-} +{-# INLINE composeAllOutFilters #-} +{-# INLINE composeMapAllInFilter #-} +toNull, scan, map, filterEven, mapM, filterAllOut, + filterAllIn, takeOne, takeAll, takeWhileTrue, dropAll, dropWhileTrue, zip, + concat, composeMapM, composeAllInFilters, composeAllOutFilters, + composeMapAllInFilter + :: Monad m + => Stream m Int -> m () + +toList :: Monad m => Stream m Int -> m [Int] +foldl :: Monad m => Stream m Int -> m Int +last :: Monad m => Stream m Int -> m (Maybe Int) + +------------------------------------------------------------------------------- +-- Stream generation and elimination +------------------------------------------------------------------------------- + +type Stream m a = S.SerialT m a + +source :: Int -> Stream m Int +source n = S.fromFoldable [n..n+value] + +{-# INLINE runStream #-} +runStream :: Monad m => Stream m a -> m () +runStream = S.runStream + +------------------------------------------------------------------------------- +-- Elimination +------------------------------------------------------------------------------- + +toNull = runStream +toList = S.toList +foldl = S.foldl' (+) 0 +last = S.last + +------------------------------------------------------------------------------- +-- Transformation +------------------------------------------------------------------------------- + +{-# INLINE transform #-} +transform :: Monad m => Stream m a -> m () +transform = runStream + +scan = transform . S.scanl' (+) 0 +map = transform . fmap (+1) +mapM = transform . S.mapM return +filterEven = transform . S.filter even +filterAllOut = transform . S.filter (> maxValue) +filterAllIn = transform . S.filter (<= maxValue) +takeOne = transform . S.take 1 +takeAll = transform . S.take maxValue +takeWhileTrue = transform . S.takeWhile (<= maxValue) +dropAll = transform . S.drop maxValue +dropWhileTrue = transform . S.dropWhile (<= maxValue) + +------------------------------------------------------------------------------- +-- Zipping and concat +------------------------------------------------------------------------------- + +zip src = transform $ (S.zipWith (,) src src) +concat _n = return () + +------------------------------------------------------------------------------- +-- Append +------------------------------------------------------------------------------- + +{-# INLINE append #-} +append + :: (Monoid (t m Int), Monad m, Monad (t m)) + => (t m Int -> S.SerialT m Int) -> Int -> m () +append t n = runStream $ t $ foldMap return [n..n+appendValue] + +------------------------------------------------------------------------------- +-- Composition +------------------------------------------------------------------------------- + +{-# INLINE compose #-} +compose :: Monad m => (Stream m Int -> Stream m Int) -> Stream m Int -> m () +compose f = transform . f . f . f . f + +composeMapM = compose (S.mapM return) +composeAllInFilters = compose (S.filter (<= maxValue)) +composeAllOutFilters = compose (S.filter (> maxValue)) +composeMapAllInFilter = compose (S.filter (<= maxValue) . fmap (subtract 1)) + +composeScaling :: Monad m => Int -> Stream m Int -> m () +composeScaling m = + case m of + 1 -> transform . f + 2 -> transform . f . f + 3 -> transform . f . f . f + 4 -> transform . f . f . f . f + _ -> undefined + where f = S.filter (<= maxValue) diff --git a/benchmark/Main.hs b/benchmark/Main.hs deleted file mode 100644 index 0e64889..0000000 --- a/benchmark/Main.hs +++ /dev/null @@ -1,301 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE RankNTypes #-} - -module Main where - -import Control.Applicative (Alternative(..)) -import Control.Exception (assert) -import Control.Monad (guard) -import Criterion.Main (defaultMain, bgroup, bench, nfIO) -import Data.Function ((&)) - -import qualified Streamly as A -import qualified Streamly.Prelude as A - -#ifdef EXTRA_BENCHMARKS -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Data.Atomics (atomicModifyIORefCAS) -import Data.IORef (IORef, newIORef, writeIORef) -import System.IO.Unsafe (unsafePerformIO) - -import qualified Conduit.Simple as S -import qualified Control.Monad.Logic as LG -import qualified Data.Machine as M -#if MIN_VERSION_transient(0,5,1) -import qualified Transient.Internals as T -import qualified Transient.Indeterminism as T -#endif -import qualified ListT as LT -#endif - -main :: IO () -main = do - -- XXX due to a GHC bug passing bind as an argument causes perf - -- degradation, so we should keep that in account when comparing. - let as = streamly_serial - ai = streamly_interleaved - aa = streamly_async - ap = streamly_parallel - defaultMain [ - bgroup "streamly" - [ bench "function style all serial" $ nfIO streamly_function_style - - , bgroup "serial bind" - [ bench "serial" $ nfIO (as (A.<>)) - , bench "fair serial" $ nfIO (as (A.<=>)) - , bench "left parallel" $ nfIO (as (A.<|)) - , bench "fair parallel" $ nfIO (as (A.<|>)) - ] - - , bgroup "interleaved bind" - [ bench "serial" $ nfIO (ai (A.<>)) - , bench "fair serial" $ nfIO (ai (A.<=>)) - , bench "left parallel" $ nfIO (ai (A.<|)) - , bench "fair parallel" $ nfIO (ai (A.<|>)) - ] - - , bgroup "async bind" - [ bench "serial" $ nfIO (aa (A.<>)) - , bench "fair serial" $ nfIO (aa (A.<=>)) - , bench "left parallel" $ nfIO (aa (A.<|)) - , bench "fair parallel" $ nfIO (aa (A.<|>)) - ] - - , bgroup "parallel bind" - [ bench "serial" $ nfIO (ap (A.<>)) - , bench "fair serial" $ nfIO (ap (A.<=>)) - , bench "left parallel" $ nfIO (ap (A.<|)) - , bench "fair parallel" $ nfIO (ap (A.<|>)) - ] - - -- Benchmark smallest possible actions composed together - , bgroup "serial bind nil" - [ bench "serial" $ nfIO (streamly_nil (A.<>)) - , bench "fair serial" $ nfIO (streamly_nil (A.<=>)) - , bench "left parallel" $ nfIO (streamly_nil (A.<|)) - , bench "fair parallel" $ nfIO (streamly_nil (A.<|>)) - ] - ] -#ifdef EXTRA_BENCHMARKS -#if MIN_VERSION_transient(0,5,1) - , bgroup "others" - [ bench "transient" $ nfIO transient_basic - , bench "transient-nil" $ nfIO transient_nil -#endif - , bench "logict" $ nfIO logict_basic - , bench "list-t" $ nfIO list_t_basic - , bench "simple-conduit" $ nfIO simple_conduit_basic - , bench "simple-conduit-bind" $ nfIO simple_conduit_bind - , bench "machines" $ nfIO machines_basic - ] -#endif - ] - -{-# INLINABLE map #-} -map :: Monad m => (a -> Int) -> a -> m Int -map f x = return $ f x - -{-# INLINABLE filter #-} -filter :: (Monad m, Alternative m) => (a -> Bool) -> a -> m a -filter cond x = guard (not $ cond x) >> return x - -amap :: Monad (s IO) => (Int -> Int) -> Int -> s IO Int -amap = Main.map - -afilter :: (Alternative (s IO), Monad (s IO)) => (Int -> Bool) -> Int -> s IO Int -afilter = Main.filter - -{-# INLINE streamly_basic #-} -streamly_basic - :: (Alternative (t IO), Monad (t IO), A.Streaming t) - => (forall a. t IO a -> IO [a]) - -> (t IO Int -> t IO Int -> t IO Int) - -> IO Int -streamly_basic tl g = do - xs <- tl $ do - A.drop 100 (A.forEachWith g [1..100000 :: Int] $ \x -> - afilter even x >>= amap (+1)) - >>= amap (+1) - >>= afilter (\y -> y `mod` 2 == 0) - assert (Prelude.length xs == 49900) $ - return (Prelude.length xs) - -{-# INLINE streamly_function_style #-} -streamly_function_style :: IO Int -streamly_function_style = do - xs <- A.toList $ A.serially $ - A.each [1..100000 :: Int] - & A.filter even - & fmap (+1) - & A.drop 100 - & fmap (+1) - & A.filter (\y -> y `mod` 2 == 0) - assert (Prelude.length xs == 49900) $ - return (Prelude.length xs) - -{-# INLINE streamly_serial #-} -streamly_serial - :: (A.StreamT IO Int -> A.StreamT IO Int -> A.StreamT IO Int) - -> IO Int -streamly_serial = streamly_basic (A.toList . A.serially) - -{-# INLINE streamly_interleaved #-} -streamly_interleaved - :: (A.InterleavedT IO Int -> A.InterleavedT IO Int -> A.InterleavedT IO Int) - -> IO Int -streamly_interleaved = streamly_basic (A.toList . A.interleaving) - -{-# INLINE streamly_async #-} -streamly_async - :: (A.AsyncT IO Int -> A.AsyncT IO Int -> A.AsyncT IO Int) - -> IO Int -streamly_async = streamly_basic (A.toList . A.asyncly) - -{-# INLINE streamly_parallel #-} -streamly_parallel - :: (A.ParallelT IO Int -> A.ParallelT IO Int -> A.ParallelT IO Int) - -> IO Int -streamly_parallel = streamly_basic (A.toList . A.parallely) - -{-# INLINE streamly_nil #-} -streamly_nil :: (A.StreamT IO Int -> A.StreamT IO Int -> A.StreamT IO Int) - -> IO Int -streamly_nil f = do - xs <- (A.toList . A.serially) $ do - (A.forEachWith f [1..100000:: Int] $ - \x -> return x >>= return . id) - assert (Prelude.length xs == 100000) $ - return (Prelude.length xs) - -#ifdef EXTRA_BENCHMARKS -#if MIN_VERSION_transient(0,5,1) - -{-# NOINLINE count #-} -count :: IORef Int -count = unsafePerformIO $ newIORef 0 - -drop :: (MonadIO m, Alternative m) => Int -> Int -> m Int -drop num x = do - - mn <- liftIO $ atomicModifyIORefCAS count $ \n -> - if n < num then (n + 1, False) else (n, True) - guard mn - return x - -tmap :: (a -> Int) -> a -> T.TransIO Int -tmap = Main.map - -tfilter :: (a -> Bool) -> a -> T.TransIO a -tfilter = Main.filter - -tdrop :: Int -> Int -> T.TransIO Int -tdrop = Main.drop - -transient_basic :: IO (Maybe Int) - -transient_basic = T.keep' $ T.threads 0 $ do - liftIO $ writeIORef count 0 - xs <- T.group 49900 $ do - T.choose [1..100000 :: Int] - >>= tfilter even - >>= tmap (+1) - >>= tdrop 100 - >>= tmap (+1) - >>= tfilter (\x -> x `mod` 2 == 0) - - assert (Prelude.length xs == 49900) $ - T.exit (Prelude.length xs) - -transient_nil :: IO (Maybe Int) -transient_nil = T.keep' $ T.threads 0 $ do - xs <- T.group 49900 $ do - T.choose [1..100000 :: Int] - assert (Prelude.length xs == 49900) $ - T.exit (Prelude.length xs) -#endif - -lfilter :: (Int -> Bool) -> Int -> LT.ListT IO Int -lfilter = Main.filter - -lmap :: (Int -> Int) -> Int -> LT.ListT IO Int -lmap = Main.map - -ldrop :: Int -> Int -> LT.ListT IO Int -ldrop = Main.drop - -list_t_basic :: IO Int -list_t_basic = do - writeIORef count 0 - xs <- LT.toList $ do - LT.fromFoldable [1..100000 :: Int] - >>= lfilter even - >>= lmap (+1) - >>= ldrop 100 - >>= lmap (+1) - >>= lfilter (\x -> x `mod` 2 == 0) - assert (Prelude.length xs == 49900) $ - return (Prelude.length xs) - -lgfilter :: (Int -> Bool) -> Int -> LG.LogicT IO Int -lgfilter = Main.filter - -lgmap :: (Int -> Int) -> Int -> LG.LogicT IO Int -lgmap = Main.map - -lgdrop :: Int -> Int -> LG.LogicT IO Int -lgdrop = Main.drop - -logict_basic :: IO Int -logict_basic = do - writeIORef count 0 - --xs <- LG.observeManyT 2900 $ do - xs <- LG.observeAllT $ do - LG.msum $ Prelude.map return [1..100000] - >>= lgfilter even - >>= lgmap (+1) - >>= lgdrop 100 - >>= lgmap (+1) - >>= lgfilter (\x -> x `mod` 2 == 0) - assert (Prelude.length xs == 49900) $ - return (Prelude.length xs) - -simple_conduit_basic :: IO Int -simple_conduit_basic = do - xs <- S.sourceList [1..100000] - S.$= S.filterC even - S.$= S.mapC ((+1) :: Int -> Int) - S.$= S.dropC 100 - S.$= S.mapC ((+1) :: Int -> Int) - S.$= S.filterC (\x -> x `mod` 2 == 0) - S.$$ S.sinkList - assert (Prelude.length xs == 49900) $ - return (Prelude.length (xs :: [Int])) - -smap :: Monad (s IO) => (Int -> Int) -> Int -> s IO Int -smap = Main.map - -sfilter :: (Alternative (s IO), Monad (s IO)) => (Int -> Bool) -> Int -> s IO Int -sfilter = Main.filter - -{-# INLINE simple_conduit_bind #-} -simple_conduit_bind :: IO Int -simple_conduit_bind = do - xs <- S.sinkList $ do - S.dropC 100 (S.sourceList [1..100000 :: Int] >>= \x -> - sfilter even x >>= smap (+1)) - >>= smap (+1) - >>= sfilter (\y -> y `mod` 2 == 0) - assert (Prelude.length xs == 49900) $ - return (Prelude.length xs) - -machines_basic :: IO Int -machines_basic = do - xs <- M.runT $ M.source [1..100000] - M.~> M.filtered even - M.~> M.mapping (+1) - M.~> M.dropping 100 - M.~> M.mapping (+1) - M.~> M.filtered (\x -> x `mod` 2 == 0) - assert (Prelude.length xs == 49900) $ - return (Prelude.length (xs ::[Int])) -#endif diff --git a/benchmark/Nested.hs b/benchmark/Nested.hs new file mode 100644 index 0000000..4924fa4 --- /dev/null +++ b/benchmark/Nested.hs @@ -0,0 +1,94 @@ +-- | +-- Module : Main +-- Copyright : (c) 2018 Harendra Kumar +-- +-- License : BSD3 +-- Maintainer : harendra.kumar@gmail.com + +import Control.DeepSeq (NFData) +import Data.Functor.Identity (Identity, runIdentity) +import System.Random (randomRIO) +import qualified NestedOps as Ops +import Streamly +import Gauge + +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 + +main :: IO () +main = do + -- TBD Study scaling with 10, 100, 1000 loop iterations + defaultMain + [ bgroup "linear" + [ benchIO "toNullLinear" Ops.toNullLinear + , benchIO "toListLinear" Ops.toListLinear + ] + + , bgroup "serially" + [ benchIO "append" $ Ops.append serially + , benchIO "toNull0" $ Ops.toNull0 serially + , benchIO "toList0" $ Ops.toList0 serially + , benchIO "toNull" $ Ops.toNull serially + , benchIO "toList" $ Ops.toList serially + , benchIO "toListSome" $ Ops.toListSome serially + , benchIO "filterAllOut" $ Ops.filterAllOut serially + , benchIO "filterAllIn" $ Ops.filterAllIn serially + , benchIO "filterSome" $ Ops.filterSome serially + , benchIO "breakAfterSome" $ Ops.breakAfterSome serially + ] + + , bgroup "wSerially" + [ benchIO "append" $ Ops.append wSerially + , benchIO "toNull0" $ Ops.toNull0 wSerially + , benchIO "toList0" $ Ops.toList0 wSerially + , benchIO "toNull" $ Ops.toNull wSerially + , benchIO "toList" $ Ops.toList wSerially + , benchIO "toListSome" $ Ops.toListSome wSerially + , benchIO "filterAllOut" $ Ops.filterAllOut wSerially + , benchIO "filterAllIn" $ Ops.filterAllIn wSerially + , benchIO "filterSome" $ Ops.filterSome wSerially + , benchIO "breakAfterSome" $ Ops.breakAfterSome wSerially + ] + + , bgroup "asyncly" + [ benchIO "append" $ Ops.append asyncly + , benchIO "toNull0" $ Ops.toNull0 asyncly + , benchIO "toList0" $ Ops.toList0 asyncly + , benchIO "toNull" $ Ops.toNull asyncly + , benchIO "toList" $ Ops.toList asyncly + , benchIO "toListSome" $ Ops.toListSome asyncly + , benchIO "filterAllOut" $ Ops.filterAllOut asyncly + , benchIO "filterAllIn" $ Ops.filterAllIn asyncly + , benchIO "filterSome" $ Ops.filterSome asyncly + , benchIO "breakAfterSome" $ Ops.breakAfterSome asyncly + ] + + , bgroup "wAsyncly" + [ benchIO "append" $ Ops.append wAsyncly + , benchIO "toNull0" $ Ops.toNull0 wAsyncly + , benchIO "toList0" $ Ops.toList0 wAsyncly + , benchIO "toNull" $ Ops.toNull wAsyncly + , benchIO "toList" $ Ops.toList wAsyncly + , benchIO "toListSome" $ Ops.toListSome wAsyncly + , benchIO "filterAllOut" $ Ops.filterAllOut wAsyncly + , benchIO "filterAllIn" $ Ops.filterAllIn wAsyncly + , benchIO "filterSome" $ Ops.filterSome wAsyncly + , benchIO "breakAfterSome" $ Ops.breakAfterSome wAsyncly + ] + + , bgroup "parallely" + [ benchIO "append" $ Ops.append parallely + , benchIO "toNull0" $ Ops.toNull0 parallely + , benchIO "toList0" $ Ops.toList0 parallely + , benchIO "toNull" $ Ops.toNull parallely + , benchIO "toList" $ Ops.toList parallely + , benchIO "toListSome" $ Ops.toListSome parallely + , benchIO "filterAllOut" $ Ops.filterAllOut parallely + , benchIO "filterAllIn" $ Ops.filterAllIn parallely + , benchIO "filterSome" $ Ops.filterSome parallely + , benchIO "breakAfterSome" $ Ops.breakAfterSome parallely + ] + ] diff --git a/benchmark/NestedOps.hs b/benchmark/NestedOps.hs new file mode 100644 index 0000000..c2e6381 --- /dev/null +++ b/benchmark/NestedOps.hs @@ -0,0 +1,154 @@ +-- | +-- Module : BenchmarkOps +-- Copyright : (c) 2018 Harendra Kumar +-- +-- License : MIT +-- Maintainer : harendra.kumar@gmail.com + +{-# LANGUAGE ScopedTypeVariables #-} + +module NestedOps where + +import Control.Exception (try) +import GHC.Exception (ErrorCall) + +import qualified Streamly as S +import qualified Streamly.Prelude as S + +sumCount :: Int +sumCount = 1000000 + +prodCount :: Int +prodCount = 1000 + +------------------------------------------------------------------------------- +-- Stream generation and elimination +------------------------------------------------------------------------------- + +type Stream m a = S.SerialT m a + +{-# INLINE source #-} +source :: S.IsStream t => Int -> Int -> t m Int +source start n = S.fromFoldable [start..start+n] + +{-# INLINE runStream #-} +runStream :: Monad m => Stream m a -> m () +runStream = S.runStream + +{-# INLINE runToList #-} +runToList :: Monad m => Stream m a -> m [a] +runToList = S.toList + +------------------------------------------------------------------------------- +-- Benchmark ops +------------------------------------------------------------------------------- + +{-# INLINE toNullLinear #-} +toNullLinear :: Monad m => Int -> m () +toNullLinear start = runStream $ source start sumCount + +{-# INLINE toListLinear #-} +toListLinear :: Monad m => Int -> m [Int] +toListLinear start = runToList $ source start sumCount + +{-# INLINE append #-} +append + :: (Monoid (t m Int), Monad m, Monad (t m)) + => (t m Int -> S.SerialT m Int) -> Int -> m () +append t start = runStream $ t $ foldMap return [start..start+sumCount] + +{-# INLINE toNull0 #-} +toNull0 + :: (S.IsStream t, Monad m, Monad (t m)) + => (t m (Int, Int) -> S.SerialT m (Int, Int)) -> Int -> m () +toNull0 t start = runStream . t $ do + x <- source start prodCount + y <- source start prodCount + return (x,y) + +{-# INLINE toList0 #-} +toList0 + :: (S.IsStream t, Monad m, Monad (t m)) + => (t m (Int, Int) -> S.SerialT m (Int, Int)) -> Int -> m [(Int, Int)] +toList0 t start = runToList . t $ do + x <- source start prodCount + y <- source start prodCount + return (x,y) + +{-# INLINE toNull #-} +toNull + :: (S.IsStream t, Monad m, Monad (t m)) + => (t m Int -> S.SerialT m Int) -> Int -> m () +toNull t start = runStream . t $ do + x <- source start prodCount + y <- source start prodCount + return $ x * x + y * y + +{-# INLINE toList #-} +toList + :: (S.IsStream t, Monad m, Monad (t m)) + => (t m Int -> S.SerialT m Int) -> Int -> m [Int] +toList t start = runToList . t $ do + x <- source start prodCount + y <- source start prodCount + return $ x * x + y * y + +{-# INLINE toListSome #-} +toListSome + :: (S.IsStream t, Monad m, Monad (t m)) + => (t m Int -> S.SerialT m Int) -> Int -> m [Int] +toListSome t start = + runToList . t $ S.take 1000 $ do + x <- source start prodCount + y <- source start prodCount + return $ x * x + y * y + +{-# INLINE filterAllOut #-} +filterAllOut + :: (S.IsStream t, Monad m, Monad (t m)) + => (t m Int -> S.SerialT m Int) -> Int -> m () +filterAllOut t start = runStream . t $ do + x <- source start prodCount + y <- source start prodCount + let s = x * x + y * y + if (s < 1) + then return s + else S.nil + +{-# INLINE filterAllIn #-} +filterAllIn + :: (S.IsStream t, Monad m, Monad (t m)) + => (t m Int -> S.SerialT m Int) -> Int -> m () +filterAllIn t start = runStream . t $ do + x <- source start prodCount + y <- source start prodCount + let s = x * x + y * y + if (s > 1) + then return s + else S.nil + +{-# INLINE filterSome #-} +filterSome + :: (S.IsStream t, Monad m, Monad (t m)) + => (t m Int -> S.SerialT m Int) -> Int -> m () +filterSome t start = runStream . t $ do + x <- source start prodCount + y <- source start prodCount + let s = x * x + y * y + if (s > 1100000) + then return s + else S.nil + +{-# INLINE breakAfterSome #-} +breakAfterSome + :: (S.IsStream t, Monad (t IO)) + => (t IO Int -> S.SerialT IO Int) -> Int -> IO () +breakAfterSome t start = do + (_ :: Either ErrorCall ()) <- try $ runStream . t $ do + x <- source start prodCount + y <- source start prodCount + let s = x * x + y * y + if (s > 1100000) + then error "break" + else return s + return () diff --git a/src/Streamly/Examples/AcidRainGame.hs b/examples/AcidRain.hs index 8f4ce02..7ad9372 100644 --- a/src/Streamly/Examples/AcidRainGame.hs +++ b/examples/AcidRain.hs @@ -3,17 +3,16 @@ -- This example is adapted from Gabriel Gonzalez's pipes-concurrency package. -- https://hackage.haskell.org/package/pipes-concurrency-2.0.8/docs/Pipes-Concurrent-Tutorial.html -module Streamly.Examples.AcidRainGame where - import Streamly import Control.Concurrent (threadDelay) import Control.Monad (when) +import Control.Monad.IO.Class (MonadIO(liftIO)) import Control.Monad.State (MonadState, get, modify, runStateT) import Data.Semigroup (cycle1) data Event = Harm Int | Heal Int | Quit deriving (Show) -userAction :: MonadIO m => StreamT m Event +userAction :: MonadIO m => SerialT m Event userAction = cycle1 $ liftIO askUser where askUser = do @@ -23,12 +22,12 @@ userAction = cycle1 $ liftIO askUser "quit" -> return Quit _ -> putStrLn "What?" >> askUser -acidRain :: MonadIO m => StreamT m Event +acidRain :: MonadIO m => SerialT m Event acidRain = cycle1 $ liftIO (threadDelay 1000000) >> return (Harm 1) -game :: (MonadAsync m, MonadState Int m) => StreamT m () +game :: (MonadAsync m, MonadState Int m) => SerialT m () game = do - event <- userAction <|> acidRain + event <- userAction `parallel` acidRain case event of Harm n -> modify $ \h -> h - n Heal n -> modify $ \h -> h + n @@ -38,9 +37,9 @@ game = do when (h <= 0) $ fail "You die!" liftIO $ putStrLn $ "Health = " ++ show h -acidRainGame :: IO () -acidRainGame = do +main :: IO () +main = do putStrLn "Your health is deteriorating due to acid rain,\ \ type \"potion\" or \"quit\"" - _ <- runStateT (runStreamT game) 60 + _ <- runStateT (runStream game) 60 return () diff --git a/src/Streamly/Examples/CirclingSquare.hs b/examples/CirclingSquare.hs index 08151d6..328caa6 100644 --- a/src/Streamly/Examples/CirclingSquare.hs +++ b/examples/CirclingSquare.hs @@ -1,15 +1,15 @@ -- Adapted from the Yampa package. --- Displays a square moving in a circle. To move the position drag the mouse. +-- Displays a square moving in a circle. To move the position drag it with the +-- mouse. -- -- Requires the SDL package, assuming streamly has already been built, you can -- compile it like this: --- stack ghc --package SDL circle-mouse.hs - -module Streamly.Examples.CirclingSquare where +-- stack ghc --package SDL CirclingSquare.hs import Data.IORef import Graphics.UI.SDL as SDL import Streamly +import Streamly.Prelude (once) import Streamly.Time ------------------------------------------------------------------------------ @@ -83,8 +83,9 @@ updateDisplay cref = withClock clock refreshRate displaySquare let t = (fromIntegral time) * speed / 1000000 in display (x + cos t * radius, y + sin t * radius) -circlingSquare :: IO () -circlingSquare = do +main :: IO () +main = do sdlInit cref <- newIORef (0,0) - runStreamT $ liftIO (updateController cref) <|> liftIO (updateDisplay cref) + runStream $ once (updateController cref) + `parallel` once (updateDisplay cref) diff --git a/examples/ListDir.hs b/examples/ListDir.hs new file mode 100644 index 0000000..446d037 --- /dev/null +++ b/examples/ListDir.hs @@ -0,0 +1,18 @@ +import Control.Monad.IO.Class (liftIO) +import Path.IO (listDir, getCurrentDir) +import System.IO (stdout, hSetBuffering, BufferMode(LineBuffering)) +import Streamly (runStream, asyncly) + +-- | List the current directory recursively using concurrent processing +-- +-- This example demonstrates that there is little difference between regular +-- IO code and concurrent streamly code. You can just remove +-- 'runStream . asyncly' and this becomes your regular IO code. +main :: IO () +main = do + hSetBuffering stdout LineBuffering + runStream . asyncly $ getCurrentDir >>= readdir + where readdir d = do + (ds, fs) <- liftIO $ listDir d + liftIO $ mapM_ putStrLn $ map show fs ++ map show ds + foldMap readdir ds diff --git a/src/Streamly/Examples/MergeSortedStreams.hs b/examples/MergeSort.hs index d39a8a7..504c489 100644 --- a/src/Streamly/Examples/MergeSortedStreams.hs +++ b/examples/MergeSort.hs @@ -1,33 +1,32 @@ {-# LANGUAGE FlexibleContexts #-} -module Streamly.Examples.MergeSortedStreams where - import Data.Word import System.Random (getStdGen, randoms) import Data.List (sort) import Streamly +import Streamly.Prelude (once) import qualified Streamly.Prelude as A -getSorted :: MonadIO m => StreamT m Word16 +getSorted :: Serial Word16 getSorted = do - g <- liftIO getStdGen + g <- once getStdGen let ls = take 100000 (randoms g) :: [Word16] - foldMapWith (<>) return (sort ls) + foldMap return (sort ls) -mergeAsync :: (Ord a, MonadAsync m) - => StreamT m a -> StreamT m a -> StreamT m a +-- | merge two streams generating the elements from each in parallel +mergeAsync :: Ord a => Serial a -> Serial a -> Serial a mergeAsync a b = do - x <- lift $ async a - y <- lift $ async b + x <- once $ mkAsync a + y <- once $ mkAsync b merge x y -merge :: (Ord a, MonadAsync m) => StreamT m a -> StreamT m a -> StreamT m a +merge :: Ord a => Serial a -> Serial a -> Serial a merge a b = do - a1 <- lift $ A.uncons a + a1 <- once $ A.uncons a case a1 of Nothing -> b Just (x, ma) -> do - b1 <- lift $ A.uncons b + b1 <- once $ A.uncons b case b1 of Nothing -> return x <> ma Just (y, mb) -> @@ -35,7 +34,7 @@ merge a b = do then (return y) <> merge (return x <> ma) mb else (return x) <> merge ma (return y <> mb) -mergeSortedStreams :: IO () -mergeSortedStreams = do +main :: IO () +main = do xs <- A.toList $ mergeAsync getSorted getSorted putStrLn $ show $ length xs diff --git a/examples/SearchQuery.hs b/examples/SearchQuery.hs new file mode 100644 index 0000000..401657f --- /dev/null +++ b/examples/SearchQuery.hs @@ -0,0 +1,25 @@ +import Streamly +import Streamly.Prelude (once) +import Network.HTTP.Simple + +-- | Runs three search engine queries in parallel and prints the search engine +-- names in the fastest first order. +-- +-- Does it twice using two different ways. +-- +main :: IO () +main = do + putStrLn "Using parallel semigroup composition" + runStream . parallely $ google <> bing <> duckduckgo + + putStrLn "\nUsing parallel applicative zip" + runStream . zipAsyncly $ (,,) <$> google <*> bing <*> duckduckgo + + where + get :: IsStream t => String -> t IO () + get s = once (httpNoBody (parseRequest_ s) >> putStrLn (show s)) + + google, bing, duckduckgo :: IsStream t => t IO () + google = get "https://www.google.com/search?q=haskell" + bing = get "https://www.bing.com/search?q=haskell" + duckduckgo = get "https://www.duckduckgo.com/?q=haskell" diff --git a/examples/loops.hs b/examples/loops.hs deleted file mode 100644 index d0f149b..0000000 --- a/examples/loops.hs +++ /dev/null @@ -1,88 +0,0 @@ -import Streamly -import System.IO (stdout, hSetBuffering, BufferMode(LineBuffering)) - -main = do - liftIO $ hSetBuffering stdout LineBuffering - - putStrLn $ "\nloopTail:\n" - runStreamT $ do - x <- loopTail 0 - liftIO $ print (x :: Int) - - putStrLn $ "\nloopHead:\n" - runStreamT $ do - x <- loopHead 0 - liftIO $ print (x :: Int) - - putStrLn $ "\nloopTailA:\n" - runStreamT $ do - x <- loopTailA 0 - liftIO $ print (x :: Int) - - putStrLn $ "\nloopHeadA:\n" - runStreamT $ do - x <- loopHeadA 0 - liftIO $ print (x :: Int) - - putStrLn $ "\ninterleave:\n" - runStreamT $ do - x <- return 0 <> return 1 <=> return 100 <> return 101 - liftIO $ print (x :: Int) - - putStrLn $ "\nParallel interleave:\n" - runStreamT $ do - x <- return 0 <> return 1 <|> return 100 <> return 101 - liftIO $ print (x :: Int) - - where - -------------------------------------------------------------------------------- --- Serial (single-threaded) stream generator loops -------------------------------------------------------------------------------- - - -- In a <> composition the action on the left is executed and only after it - -- finished then the action on the right is executed. In other words the - -- actions are run serially. - - -- Generates a value and then loops. Can be used to generate an infinite - -- stream. Interleaves the generator and the consumer. - loopTail :: Int -> StreamT IO Int - loopTail x = do - liftIO $ putStrLn "LoopTail..." - return x <> (if x < 3 then loopTail (x + 1) else empty) - - -- Loops and then generates a value. The consumer can run only after the - -- loop has finished. An infinite generator will not let the consumer run - -- at all. - loopHead :: Int -> StreamT IO Int - loopHead x = do - liftIO $ putStrLn "LoopHead..." - (if x < 3 then loopHead (x + 1) else empty) <> return x - -------------------------------------------------------------------------------- --- Concurrent (multi-threaded) adaptive demand-based stream generator loops -------------------------------------------------------------------------------- - - -- In a <| composition the action on the left is executed first. However, - -- if it is not fast enough to generate results at the consumer's speed - -- then the action on the right is also spawned concurrently. In other - -- words, both actions may run concurrently based on the need. - - loopTailA :: Int -> StreamT IO Int - loopTailA x = do - liftIO $ putStrLn "LoopTailA..." - return x <| (if x < 3 then loopTailA (x + 1) else empty) - - loopHeadA :: Int -> StreamT IO Int - loopHeadA x = do - liftIO $ putStrLn "LoopHeadA..." - (if x < 3 then loopHeadA (x + 1) else empty) <| return x - -------------------------------------------------------------------------------- --- Parallel (fairly scheduled, multi-threaded) stream generator loops -------------------------------------------------------------------------------- - - -- In a <|> composition both actions are run concurrently in a fair - -- manner, no one action is preferred over another. Both actions are - -- spawned right away in their own independent threads. In other words, the - -- actions will run concurrently. diff --git a/examples/nested-loops.hs b/examples/nested-loops.hs deleted file mode 100644 index ea886c5..0000000 --- a/examples/nested-loops.hs +++ /dev/null @@ -1,22 +0,0 @@ -import Control.Applicative ((<|>), empty) -import Control.Concurrent (myThreadId) -import Control.Monad.IO.Class (liftIO) -import System.IO (stdout, hSetBuffering, BufferMode(LineBuffering)) -import System.Random (randomIO) -import Streamly - -main = runStreamT $ do - liftIO $ hSetBuffering stdout LineBuffering - x <- loop "A " 2 - y <- loop "B " 2 - liftIO $ myThreadId >>= putStr . show - >> putStr " " - >> print (x, y) - - where - - loop name n = do - rnd <- liftIO (randomIO :: IO Int) - let result = (name ++ show rnd) - repeat = if n > 1 then loop name (n - 1) else empty - in (return result) <|> repeat diff --git a/examples/parallel-loops.hs b/examples/parallel-loops.hs deleted file mode 100644 index 61e1794..0000000 --- a/examples/parallel-loops.hs +++ /dev/null @@ -1,20 +0,0 @@ -import Control.Applicative ((<|>)) -import Control.Concurrent (myThreadId, threadDelay) -import Control.Monad.IO.Class (liftIO) -import System.IO (stdout, hSetBuffering, BufferMode(LineBuffering)) -import System.Random (randomIO) -import Streamly - -main = runStreamT $ do - liftIO $ hSetBuffering stdout LineBuffering - x <- loop "A" <|> loop "B" - liftIO $ myThreadId >>= putStr . show - >> putStr " " - >> print x - - where - - loop name = do - liftIO $ threadDelay 1000000 - rnd <- liftIO (randomIO :: IO Int) - return (name, rnd) <|> loop name diff --git a/src/Streamly.hs b/src/Streamly.hs index 68efd82..c6728f3 100644 --- a/src/Streamly.hs +++ b/src/Streamly.hs @@ -6,244 +6,193 @@ -- Maintainer : harendra.kumar@gmail.com -- Stability : experimental -- Portability : GHC +-- +-- The way a list represents a sequence of pure values, a stream represents a +-- sequence of monadic actions. The monadic stream API offered by Streamly is +-- very close to the Haskell "Prelude" pure lists' API, it can be considered as +-- a natural extension of lists to monadic actions. Streamly streams provide +-- concurrent composition and merging of streams. It can be considered as a +-- concurrent list transformer. In contrast to the "Prelude" lists, merging or +-- appending streams of arbitrary length is scalable and inexpensive. +-- +-- The basic stream type is 'Serial', it represents a sequence of IO actions, +-- and is a 'Monad'. The type 'SerialT' is a monad transformer that can +-- represent a sequence of actions in an arbitrary monad. The type 'Serial' is +-- in fact a synonym for @SerialT IO@. There are a few more types similar to +-- 'SerialT', all of them represent a stream and differ only in the +-- 'Semigroup', 'Applicative' and 'Monad' compositions of the stream. 'Serial' +-- and 'WSerial' types compose serially whereas 'Async' and 'WAsync' +-- types compose concurrently. All these types can be freely inter-converted +-- using type combinators without any cost. You can freely switch to any type +-- of composition at any point in the program. When no type annotation or +-- explicit stream type combinators are used, the default stream type is +-- inferred as 'Serial'. +-- +-- Here is a simple console echo program example: +-- +-- @ +-- > runStream $ S.repeatM getLine & S.mapM putStrLn +-- @ +-- +-- For more details please see the "Streamly.Tutorial" module and the examples +-- directory in this package. +-- +-- This module exports stream types, instances and some basic operations. +-- Functionality exported by this module include: +-- +-- * Semigroup append ('<>') instances as well as explicit operations for merging streams +-- * Monad and Applicative instances for looping over streams +-- * Zip Applicatives for zipping streams +-- * Stream type combinators to convert between different composition styles +-- * Some basic utilities to run and fold streams +-- +-- See the "Streamly.Prelude" module for comprehensive APIs for construction, +-- generation, elimination and transformation of streams. +-- +-- This module is designed to be imported unqualified: +-- +-- @ +-- import Streamly +-- @ module Streamly ( - -- * Background - -- $background - - -- * Overview - -- $overview - MonadAsync - , Streaming - -- * Product Style Composition - -- $product - , StreamT - , InterleavedT + -- * Stream transformers + -- ** Serial Streams + -- $serial + , SerialT + , WSerialT + + -- ** Parallel Streams + -- $async , AsyncT + , WAsyncT , ParallelT - -- * Zip Style Composition + -- ** Zipping Streams -- $zipping - , ZipStream - , ZipAsync + , ZipSerialM + , ZipAsyncM - -- * Sum Style Composition + -- * Polymorphic Sum Operations -- $sum - , (<=>) - , (<|) - - -- * Transformation + , serial + , wSerial , async + , wAsync + , parallel -- * Stream Type Adapters -- $adapters + , IsStream + , serially - , interleaving + , wSerially , asyncly + , wAsyncly , parallely - , zipping - , zippingAsync + , zipSerially + , zipAsyncly , adapt + -- * IO Streams + , Serial + , WSerial + , Async + , WAsync + , Parallel + , ZipSerial + , ZipAsync + -- * Running Streams - , runStreaming - , runStreamT - , runInterleavedT - , runAsyncT - , runParallelT - , runZipStream - , runZipAsync + , runStream + + -- * Transformation + , mkAsync - -- * Fold Utilities + -- * Polymorphic Fold Utilities -- $foldutils , foldWith , foldMapWith , forEachWith -- * Re-exports - , Monoid (..) , Semigroup (..) - , Alternative (..) - , MonadPlus (..) - , MonadIO (..) - , MonadTrans (..) + -- * Deprecated + , Streaming + , runStreaming + , runStreamT + , runInterleavedT + , runAsyncT + , runParallelT + , runZipStream + , runZipAsync + , StreamT + , InterleavedT + , ZipStream + , interleaving + , zipping + , zippingAsync + , (<=>) + , (<|) ) where import Streamly.Streams import Data.Semigroup (Semigroup(..)) -import Control.Applicative (Alternative(..)) -import Control.Monad (MonadPlus(..)) -import Control.Monad.IO.Class (MonadIO (..)) -import Control.Monad.Trans.Class (MonadTrans (..)) - --- $background --- --- Streamly provides a monad transformer that extends the product style --- composition of monads to streams of many elements of the same type; it is a --- functional programming equivalent of nested loops from imperative --- programming. Composing each element in one stream with each element in the --- other stream generalizes the monadic product of single elements. You can --- think of the IO monad as a special case of the more general @StreamT IO@ --- monad; with single element streams. List transformers and logic programming --- monads also provide a similar product style composition of streams, however --- streamly generalizes it with the time dimension; allowing streams to be --- composed in an asynchronous and concurrent fashion in many different ways. --- It also provides multiple alternative ways of composing streams e.g. --- serial, interleaved or concurrent. --- --- The seemingly simple addition of asynchronicity and concurrency to product --- style streaming composition unifies a number of disparate abstractions into --- one powerful and elegant abstraction. A wide variety of programming --- problems can be solved elegantly with this abstraction. In particular, it --- unifies three major programming domains namely non-deterministic (logic) --- programming, concurrent programming and functional reactive programming. In --- other words, you can do everything with this one abstraction that you could --- with list transformers (e.g. --- <https://hackage.haskell.org/package/list-t list-t>), logic programming --- monads (e.g. <https://hackage.haskell.org/package/logict logict>), --- streaming libraries (a lot of what --- <https://hackage.haskell.org/package/conduit conduit> or --- <https://hackage.haskell.org/package/pipes pipes> can do), concurrency --- libraries (e.g. <https://hackage.haskell.org/package/async async>) and FRP --- libraries (e.g. <https://hackage.haskell.org/package/Yampa Yampa> or --- <https://hackage.haskell.org/package/reflex reflex>). - --- $overview --- --- Streamly provides six distinct stream types i.e. 'StreamT', 'InterleavedT', --- 'AsyncT' and 'ParallelT', 'ZipStream' and 'ZipAsync', each representing a --- stream of elements. All these types have the same underlying representation --- and can be adapted from one to another using type adaptor combinators --- described later. Each of these types belongs to the 'Streaming' type class --- which helps converting the specific type to and from the underlying generic --- stream type. --- --- The types 'StreamT', 'InterleavedT', 'AsyncT' and 'ParallelT' are 'Monad' --- transformers with the monadic bind operation combining streams in a product --- style in much the same way as a list monad or a list transformer i.e. each --- element from one stream is combined with every element of the other stream. --- However, the applicative and monadic composition of these types differ in --- terms of the ordering and time sequence in which the elements from two --- streams are combined. 'StreamT' and 'InterleavedT' compose streams serially --- whereas 'AsyncT' and 'ParallelT' are their concurrent counterparts. See the --- documentation of the respective types for more details. --- --- The types 'ZipStream' and 'ZipAsync' provide 'Applicative' instances to zip --- two streams together i.e. each element in one stream is combined with the --- corresponding element in the other stream. 'ZipStream' generates the streams --- being zipped serially whereas 'ZipAsync' produces both the elements being --- zipped concurrently. --- --- Two streams of the same type can be combined using a sum style composition --- to generate a stream of the same type where the output stream would contain --- all elements of both the streams. However, the sequence in which the --- elements in the resulting stream are produced depends on the combining --- operator. Four distinct sum style operators, '<>', '<=>', '<|' and '<|>' --- combine two streams in different ways, each corresponding to the one of the --- four ways of combining monadically. See the respective section below for --- more details. --- --- Concurrent composition types 'AsyncT', 'ParallelT', 'ZipAsync' and --- concurrent composition operators '<|' and '<|>' require the underlying monad --- of the streaming monad transformer to be 'MonadAsync'. --- --- For more details please see the "Streamly.Tutorial" and "Streamly.Examples" --- (the latter is available only when built with the 'examples' build flag). - --- A simple inline example here illustrating applicative, monad and alternative --- compositions. - --- $product --- --- Streams that compose serially or non-concurrently come in two flavors i.e. --- 'StreamT' and 'InterleavedT'. Both of these serial flavors have --- corresponding concurrent equivalents, those are 'AsyncT' and 'ParallelT' --- respectively. + +-- $serial +-- +-- Serial streams compose serially or non-concurrently. In a composed stream, +-- each action is executed only after the prvious action has finished. The two +-- serial stream types 'SerialT' and 'WSerialT' differ in how they traverse the +-- streams in a 'Semigroup' or 'Monad' composition. + +-- $async +-- +-- The async style streams execute actions asynchronously and consume the +-- outputs as well asynchronously. In a composed stream, at any point of time +-- more than one stream can run concurrently and yield elements. The elements +-- are yielded by the composed stream as they are generated by the constituent +-- streams on a first come first serve basis. Therefore, on each run the +-- stream may yield elements in a different sequence depending on the delays +-- introduced by scheduling. The two async types 'AsyncT' and 'WAsyncT' differ +-- in how they traverse streams in 'Semigroup' or 'Monad' compositions. -- $zipping -- --- 'ZipStream' and 'ZipAsync', provide 'Applicative' instances for zipping the +-- 'ZipSerialM' and 'ZipAsyncM', provide 'Applicative' instances for zipping the -- corresponding elements of two streams together. Note that these types are -- not monads. -- $sum --- --- Just like product style composition there are four distinct ways to combine --- streams in sum style each directly corresponding to one of the product style --- composition. --- --- The standard semigroup append '<>' operator appends two streams serially, --- this style corresponds to the 'StreamT' style of monadic composition. --- --- @ --- main = ('toList' . 'serially' $ (return 1 <> return 2) <> (return 3 <> return 4)) >>= print --- @ --- @ --- [1,2,3,4] --- @ --- --- The standard 'Alternative' operator '<|>' fairly interleaves two streams in --- parallel, this operator corresponds to the 'ParallelT' style. --- --- @ --- main = ('toList' . 'serially' $ (return 1 <> return 2) \<|\> (return 3 <> return 4)) >>= print --- @ --- @ --- [1,3,2,4] --- @ --- --- Unlike '<|', this operator cannot be used to fold infinite containers since --- that might accumulate too many partially drained streams. To be clear, it --- can combine infinite streams but not infinite number of streams. --- --- Two additional sum style composition operators that streamly introduces are --- described below. +-- The 'Semigroup' operation '<>' of each stream type combines two streams in a +-- type specific manner. This section provides polymorphic versions of '<>' +-- which can be used to combine two streams in a predetermined way irrespective +-- of the type. -- $adapters -- --- Code using streamly is usually written such that it is agnostic of any --- specific streaming type. We use a type variable (polymorphic type) with the --- 'Streaming' class constraint. Finally, when running the monad we can specify --- the actual type that we want to use to interpret the code. However, in --- certain cases we may want to use a specific type to force a certain type of --- composition. These combinators can be used to convert the stream types from --- one to another at no cost as all the types have the same underlying --- representation. --- --- If you see an @ambiguous type variable@ error then most likely it is because --- you have not specified the stream type. You either need a type annotation or --- one of the following combinators to specify what type of stream you mean. --- --- This code: --- --- @ --- main = ('toList' $ (return 1 <> return 2)) >>= print --- @ --- --- will result in a type error like this: --- --- @ --- Ambiguous type variable â€˜t0â€™ arising from a use of ... --- @ --- --- To fix the error just tell 'toList' what kind of stream are we feeding it: --- --- @ --- main = ('toList' $ 'serially' $ (return 1 <> return 2)) >>= print --- @ --- @ --- main = ('toList' $ (return 1 <> return 2 :: StreamT IO Int)) >>= print --- @ +-- You may want to use different stream composition styles at different points +-- in your program. Stream types can be freely converted or adapted from one +-- type to another. The 'IsStream' type class facilitates type conversion of +-- one stream type to another. It is not used directly, instead the type +-- combinators provided below are used for conversions. -- --- Note that using the combinators is easier as you do not have to think about --- the specific types, they are just inferred. +-- To adapt from one monomorphic type (e.g. 'AsyncT') to another monomorphic +-- type (e.g. 'SerialT') use the 'adapt' combinator. To give a polymorphic code +-- a specific interpretation or to adapt a specific type to a polymorphic type +-- use the type specific combinators e.g. 'asyncly' or 'wSerially'. You +-- cannot adapt polymorphic code to polymorphic code, as the compiler would not know +-- which specific type you are converting from or to. If you see a an +-- @ambiguous type variable@ error then most likely you are using 'adapt' +-- unnecessarily on polymorphic code. -- -- $foldutils -- --- These are some convenience functions to fold any 'Foldable' container using --- one of the sum composition operators to convert it into a streamly stream. +-- These are variants of standard 'Foldable' fold functions that use a +-- polymorphic stream sum operation (e.g. 'async' or 'wSerial') to fold a +-- container of streams. diff --git a/src/Streamly/Core.hs b/src/Streamly/Core.hs index 8a76311..2609976 100644 --- a/src/Streamly/Core.hs +++ b/src/Streamly/Core.hs @@ -2,8 +2,10 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE UndecidableInstances #-} -- XXX -- | @@ -24,12 +26,30 @@ module Streamly.Core , Stream (..) -- * Construction - , scons - , srepeat - , snil - - -- * Composition - , interleave + , singleton + , once + , cons + , consM + , repeat + , nil + + -- * Semigroup Style Composition + , serial + , wSerial + , async + , wAsync + , parallel + + -- * Alternative + , alt + + -- * zip + , zipWith + , zipAsyncWith + + -- * Transformers + , withLocal + , withCatchError -- * Concurrent Stream Vars (SVars) , SVar @@ -42,40 +62,37 @@ module Streamly.Core , joinStreamVar2 , fromStreamVar , toStreamVar - - -- * Concurrent Streams - , parAlt - , parLeft ) where -import Control.Applicative (Alternative (..)) -import Control.Concurrent (ThreadId, forkIO, - myThreadId, threadDelay) +import Control.Concurrent (ThreadId, myThreadId, threadDelay) import Control.Concurrent.MVar (MVar, newEmptyMVar, tryTakeMVar, - tryPutMVar, takeMVar) + tryPutMVar, takeMVar, readMVar) import Control.Exception (SomeException (..)) import qualified Control.Exception.Lifted as EL -import Control.Monad (MonadPlus(..), mzero, when) -import Control.Monad.Base (MonadBase (..), liftBaseDefault) +import Control.Monad (when) import Control.Monad.Catch (MonadThrow, throwM) import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Reader.Class (MonadReader(..)) -import Control.Monad.State.Class (MonadState(..)) import Control.Monad.Trans.Class (MonadTrans (lift)) import Control.Monad.Trans.Control (MonadBaseControl, liftBaseWith) -import Data.Atomics (atomicModifyIORefCAS, - atomicModifyIORefCAS_) +import Data.Atomics (casIORef, readForCAS, peekTicket + ,atomicModifyIORefCAS_) import Data.Concurrent.Queue.MichaelScott (LinkedQueue, newQ, pushL, tryPopR, nullQ) import Data.Functor (void) import Data.IORef (IORef, modifyIORef, newIORef, - readIORef) -import Data.Maybe (isNothing) + readIORef, atomicModifyIORef) +import Data.Maybe (isNothing, fromJust) import Data.Semigroup (Semigroup(..)) import Data.Set (Set) import qualified Data.Set as S +import Prelude hiding (repeat, zipWith) + +import GHC.Exts +import GHC.Conc (ThreadId(..)) +import GHC.IO (IO(..)) ------------------------------------------------------------------------------ -- Parent child thread communication type @@ -95,9 +112,11 @@ data ChildEvent a = -- SVars so that the scheduling of the two is independent. data SVarTag = Conjunction | Disjunction deriving Eq --- | For fairly interleaved parallel composition the sched policy is FIFO --- whereas for left biased parallel composition it is LIFO. -data SVarSched = LIFO | FIFO deriving Eq +data SVarSched = + LIFO -- depth first concurrent + | FIFO -- breadth first concurrent + | Par -- all parallel + deriving Eq -- | Identify the type of the SVar. Two computations using the same style can -- be scheduled on the same SVar. @@ -128,150 +147,144 @@ data SVarStyle = SVarStyle SVarTag SVarSched deriving Eq -- already enqueued computations get evaluated. See 'joinStreamVar2'. -- data SVar m a = - SVar { outputQueue :: IORef [ChildEvent a] - , doorBell :: MVar Bool -- wakeup mechanism for outQ + SVar { outputQueue :: IORef ([ChildEvent a], Int) + , doorBell :: MVar () -- signal the consumer about output + , siren :: MVar () -- hooter for workers to begin work , enqueue :: Stream m a -> IO () , runqueue :: m () , runningThreads :: IORef (Set ThreadId) , queueEmpty :: m Bool + , activeWorkers :: IORef Int , svarStyle :: SVarStyle } +-- Slightly faster version of CAS. Gained some improvement by avoiding the use +-- of "evaluate" because we know we do not have exceptions in fn. +{-# INLINE atomicModifyIORefCAS #-} +atomicModifyIORefCAS :: IORef a -> (a -> (a,b)) -> IO b +atomicModifyIORefCAS ref fn = do + tkt <- readForCAS ref + loop tkt retries + + where + + retries = 30 :: Int + loop _ 0 = atomicModifyIORef ref fn + loop old tries = do + let (new, result) = fn $ peekTicket old + (success, tkt) <- casIORef ref old new + if success + then return result + else loop tkt (tries - 1) + ------------------------------------------------------------------------------ -- The stream type ------------------------------------------------------------------------------ --- TBD use a functor instead of the bare type a? - -- | The type 'Stream m a' represents a monadic stream of values of type 'a' --- constructed using actions in monad 'm'. It uses a stop continuation and a --- yield continuation. You can consider it a rough equivalent of direct style --- type: --- --- data Stream m a = Stop | Yield a (Maybe (Stream m a)) +-- constructed using actions in monad 'm'. It uses stop, singleton and yield +-- continuations equivalent to the following direct style type: -- --- Our goal is to be able to represent finite as well infinite streams and --- being able to compose a large number of small streams efficiently. In --- addition we want to compose streams in parallel, to facilitate that we --- maintain a local state in an SVar that is shared across and is used for --- synchronization of the streams being composed. +-- data Stream m a = Stop | Singleton a | Yield a (Stream m a) -- --- Using this type, there are two ways to indicate the end of a stream, one is --- by calling the stop continuation and the other one is by yielding the last --- value along with 'Nothing' as the rest of the stream. +-- To facilitate parallel composition we maintain a local state in an SVar that +-- is shared across and is used for synchronization of the streams being +-- composed. -- --- Why do we have this redundancy? Why can't we use (a -> Stream m a -> m r) as --- the type of the yield continuation and always use the stop continuation to --- indicate the end of the stream? The reason is that when we compose a large --- number of short or singleton streams then using the stop continuation --- becomes expensive, just to know that there is no next element we have to --- call the continuation, introducing an indirection, it seems when using CPS --- GHC is not able to optimize this out as efficiently as it can be in direct --- style because of the function call involved. In direct style it will just be --- a constructor check and a memory access instead of a function call. So we --- could use: --- --- data Stream m a = Stop | Yield a (Stream m a) --- --- In CPS style, when we use the 'Maybe' argument of yield to indicate the end --- then just like direct style we can figure out that there is no next element --- without a function call. --- --- Then why not get rid of the stop continuation and use only yield to indicate --- the end of stream? The answer is, in that case to indicate the end of the --- stream we would have to yield at least one element so there is no way to --- represent an empty stream. --- --- Whenever we make a singleton stream or in general when we build a stream --- strictly i.e. when we know all the elements of the stream in advance we can --- use the last yield to indicate th end of the stream, because we know in --- advance at the time of the last yield that the stream is ending. We build --- singleton streams in the implementation of 'pure' for Applicative and Monad, --- and in 'lift' for MonadTrans, in these places we use yield with 'Nothing' to --- indicate the end of the stream. Note that, the only advantage of Maybe is --- when we have to build a large number of singleton or short streams. For --- larger streams anyway the overhead of a separate stop continuation is not --- significant. This could be significant when we breakdown a large stream into --- its elements, process them in some way and then recompose it from the --- pieces. Zipping streams is one such example. Zipping with streamly is the --- fastest among all streaming libraries. --- --- However in a lazy computation we cannot know in advance that the stream is --- ending therefore we cannot use 'Maybe', we use the stop continuation in that --- case. For example when building a stream from a lazy container using a right --- fold. +-- The singleton case can be expressed in terms of stop and yield but we have +-- it as a separate case to optimize composition operations for streams with +-- single element. We build singleton streams in the implementation of 'pure' +-- for Applicative and Monad, and in 'lift' for MonadTrans. -- newtype Stream m a = Stream { runStream :: forall r. - Maybe (SVar m a) -- local state - -> m r -- stop - -> (a -> Maybe (Stream m a) -> m r) -- yield + Maybe (SVar m a) -- local state + -> m r -- stop + -> (a -> m r) -- singleton + -> (a -> Stream m a -> m r) -- yield -> m r } --- | A monad that can perform asynchronous/concurrent IO operations. Streams --- that can be composed concurrently require the underlying monad to be --- 'MonadAsync'. -type MonadAsync m = (MonadIO m, MonadBaseControl IO m, MonadThrow m) +nil :: Stream m a +nil = Stream $ \_ stp _ _ -> stp -scons :: a -> Maybe (Stream m a) -> Stream m a -scons a r = Stream $ \_ _ yld -> yld a r +once :: Monad m => m a -> Stream m a +once m = Stream $ \_ _ single _ -> m >>= single -srepeat :: a -> Stream m a -srepeat a = let x = scons a (Just x) in x +{-# INLINE singleton #-} +-- | Same as @once . return@ +singleton :: a -> Stream m a +singleton a = Stream $ \_ _ single _ -> single a -snil :: Stream m a -snil = Stream $ \_ stp _ -> stp +consM :: Monad m => m a -> Stream m a -> Stream m a +consM m r = Stream $ \_ _ _ yld -> m >>= \a -> yld a r ------------------------------------------------------------------------------- --- Composing streams ------------------------------------------------------------------------------- +-- | Same as @consM . return@ +cons :: a -> Stream m a -> Stream m a +cons a r = Stream $ \_ _ _ yld -> yld a r --- Streams can be composed sequentially or in parallel; in product style --- compositions (monadic bind multiplies streams in a ListT fashion) or in sum --- style compositions like 'Semigroup', 'Monoid', 'Alternative' or variants of --- these. +repeat :: a -> Stream m a +repeat a = let x = cons a x in x ------------------------------------------------------------------------------ -- Semigroup ------------------------------------------------------------------------------ --- | '<>' concatenates two streams sequentially i.e. the first stream is +-- | Concatenates two streams sequentially i.e. the first stream is -- exhausted completely before yielding any element from the second stream. +serial :: Stream m a -> Stream m a -> Stream m a +serial m1 m2 = go m1 + where + go (Stream m) = Stream $ \_ stp sng yld -> + let stop = (runStream m2) Nothing stp sng yld + single a = yld a m2 + yield a r = yld a (go r) + in m Nothing stop single yield + instance Semigroup (Stream m a) where - m1 <> m2 = go m1 - where - go (Stream m) = Stream $ \_ stp yld -> - let stop = (runStream m2) Nothing stp yld - yield a Nothing = yld a (Just m2) - yield a (Just r) = yld a (Just (go r)) - in m Nothing stop yield + (<>) = serial ------------------------------------------------------------------------------ -- Monoid ------------------------------------------------------------------------------ instance Monoid (Stream m a) where - mempty = Stream $ \_ stp _ -> stp + mempty = nil mappend = (<>) ------------------------------------------------------------------------------ -- Interleave ------------------------------------------------------------------------------ --- | Same as '<=>'. -interleave :: Stream m a -> Stream m a -> Stream m a -interleave m1 m2 = Stream $ \_ stp yld -> do - let stop = (runStream m2) Nothing stp yld - yield a Nothing = yld a (Just m2) - yield a (Just r) = yld a (Just (interleave m2 r)) - (runStream m1) Nothing stop yield +wSerial :: Stream m a -> Stream m a -> Stream m a +wSerial m1 m2 = Stream $ \_ stp sng yld -> do + let stop = (runStream m2) Nothing stp sng yld + single a = yld a m2 + yield a r = yld a (wSerial m2 r) + (runStream m1) Nothing stop single yield ------------------------------------------------------------------------------ -- Spawning threads and collecting result in streamed fashion ------------------------------------------------------------------------------ +-- | A monad that can perform concurrent or parallel IO operations. Streams +-- that can be composed concurrently require the underlying monad to be +-- 'MonadAsync'. +-- +-- @since 0.1.0 +type MonadAsync m = (MonadIO m, MonadBaseControl IO m, MonadThrow m) + +-- Stolen from the async package. The perf improvement is modest, 2% on a +-- thread heavy benchmark (parallel composition using noop computations). +-- A version of forkIO that does not include the outer exception +-- handler: saves a bit of time when we will be installing our own +-- exception handler. +{-# INLINE rawForkIO #-} +rawForkIO :: IO () -> IO ThreadId +rawForkIO action = IO $ \ s -> + case (fork# action s) of (# s1, tid #) -> (# s1, ThreadId tid #) + {-# INLINE doFork #-} doFork :: MonadBaseControl IO m => m () @@ -279,21 +292,52 @@ doFork :: MonadBaseControl IO m -> m ThreadId doFork action exHandler = EL.mask $ \restore -> - liftBaseWith $ \runInIO -> forkIO $ do - -- XXX test the exception handling + liftBaseWith $ \runInIO -> rawForkIO $ do _ <- runInIO $ EL.catch (restore action) exHandler -- XXX restore state here? return () -- XXX exception safety of all atomic/MVar operations +-- TBD Each worker can have their own queue and the consumer can empty one +-- queue at a time, that way contention can be reduced. {-# INLINE send #-} send :: MonadIO m => SVar m a -> ChildEvent a -> m () send sv msg = liftIO $ do - atomicModifyIORefCAS_ (outputQueue sv) $ \es -> msg : es - -- XXX need a memory barrier? The wake up must happen only after the - -- store has finished otherwise we can have lost wakeup problems. - void $ tryPutMVar (doorBell sv) True + len <- atomicModifyIORefCAS (outputQueue sv) $ \(es, n) -> + ((msg : es, n + 1), n) + if (len <= 0) then do + -- XXX need a memory barrier? The wake up must happen only after the + -- store has finished otherwise we can have lost wakeup problems. + -- + -- Since multiple workers can try this at the same time, it is possible + -- that we may put a spurious MVar after the consumer has already seen + -- the output. But that's harmless, at worst it may cause the consumer + -- to read the queue again and find it empty. + -- The important point is that the consumer is guaranteed to receive a + -- doorbell if something was added to the queue after it empties it. + void $ tryPutMVar (doorBell sv) () + -- The first worker who notices the output queue was emptied puts the + -- siren off. + void $ tryTakeMVar (siren sv) + else if (len + 1 >= 1500) then do + -- We are guaranteed to receive the siren if the consumer reads the + -- queue because the consumer puts the siren on before reading the + -- queue. + -- + -- We may get the siren between the siren being swicthed on and the + -- queue getting read but that's harmless, at amost everyone will go + -- back to work and will have to sleep again if queue was still not + -- emptied. + -- + -- If even before a worker could read the MVar, the queue gets emptied + -- and another worker queuing on it switches off the siren, then we may + -- sleep here. In that case we are guaranteed to be woken up on the + -- next siren. The next siren is guaranteed as we send a doorbell + -- before switching off the siren, and the consumer switches on the + -- siren after receiving the doorbell. + readMVar (siren sv) + else return () {-# INLINE sendStop #-} sendStop :: MonadIO m => SVar m a -> m () @@ -313,11 +357,11 @@ runqueueLIFO sv q = run work <- dequeue case work of Nothing -> sendStop sv - Just m -> (runStream m) (Just sv) run yield + Just m -> (runStream m) (Just sv) run single yield sendit a = send sv (ChildYield a) - yield a Nothing = sendit a >> run - yield a (Just r) = sendit a >> (runStream r) (Just sv) run yield + single a = sendit a >> run + yield a r = sendit a >> (runStream r) (Just sv) run single yield dequeue = liftIO $ atomicModifyIORefCAS q $ \case [] -> ([], Nothing) @@ -336,31 +380,62 @@ runqueueFIFO sv q = run work <- dequeue case work of Nothing -> sendStop sv - Just m -> (runStream m) (Just sv) run yield + Just m -> (runStream m) (Just sv) run single yield dequeue = liftIO $ tryPopR q sendit a = send sv (ChildYield a) - yield a Nothing = sendit a >> run - yield a (Just r) = sendit a >> liftIO (enqueueFIFO q r) >> run + single a = sendit a >> run + yield a r = sendit a >> liftIO (enqueueFIFO q r) >> run + +{-# INLINE runOne #-} +runOne :: MonadIO m => SVar m a -> Stream m a -> m () +runOne sv m = (runStream m) (Just sv) stop single yield + + where + + stop = sendStop sv + sendit a = send sv (ChildYield a) + single a = sendit a >> stop + yield a r = sendit a >> runOne sv r -- Thread tracking is needed for two reasons: -- --- 1) Killing threads on exceptions. Threads may not be allowed to go away by +-- 1) Killing threads on exceptions. Threads may not be left to go away by -- themselves because they may run for significant times before going away or -- worse they may be stuck in IO and never go away. -- --- 2) To know when all threads are done. +-- 2) To know when all threads are done and the stream has ended. {-# NOINLINE addThread #-} addThread :: MonadIO m => SVar m a -> ThreadId -> m () addThread sv tid = liftIO $ modifyIORef (runningThreads sv) (S.insert tid) +{- {-# INLINE delThread #-} delThread :: MonadIO m => SVar m a -> ThreadId -> m () delThread sv tid = liftIO $ modifyIORef (runningThreads sv) $ (\s -> S.delete tid s) +-} +-- If present then delete else add. This takes care of out of order add and +-- delete i.e. a delete arriving before we even added a thread. +-- This occurs when the forked thread is done even before the 'addThread' right +-- after the fork is executed. +{-# INLINE modifyThread #-} +modifyThread :: MonadIO m => SVar m a -> ThreadId -> m () +modifyThread sv tid = do + changed <- liftIO $ atomicModifyIORefCAS (runningThreads sv) $ \old -> + if (S.member tid old) + then let new = (S.delete tid old) in (new, new) + else let new = (S.insert tid old) in (new, old) + if null changed + then liftIO $ void $ tryPutMVar (doorBell sv) () + else return () + +-- | This is safe even if we are adding more threads concurrently because if +-- a child thread is adding another thread then anyway 'runningThreads' will +-- not be empty. {-# INLINE allThreadsDone #-} allThreadsDone :: MonadIO m => SVar m a -> m Bool allThreadsDone sv = liftIO $ S.null <$> readIORef (runningThreads sv) @@ -373,9 +448,20 @@ handleChildException sv e = do {-# NOINLINE pushWorker #-} pushWorker :: MonadAsync m => SVar m a -> m () -pushWorker sv = +pushWorker sv = do + liftIO $ atomicModifyIORefCAS_ (activeWorkers sv) $ \n -> n + 1 doFork (runqueue sv) (handleChildException sv) >>= addThread sv +-- | In contrast to pushWorker which always happens only from the consumer +-- thread, a pushWorkerPar can happen concurrently from multiple threads on the +-- producer side. So we need to use a thread safe modification of +-- runningThreads. Alternatively, we can use a CreateThread event to avoid +-- using a CAS based modification. +{-# NOINLINE pushWorkerPar #-} +pushWorkerPar :: MonadAsync m => SVar m a -> Stream m a -> m () +pushWorkerPar sv m = + doFork (runOne sv m) (handleChildException sv) >>= modifyThread sv + -- XXX When the queue is LIFO we can put a limit on the number of dispatches. -- Also, if a worker blocks on the output queue we can decide if we want to -- block or make it go away entirely, depending on the number of workers and @@ -383,94 +469,135 @@ pushWorker sv = {-# INLINE sendWorkerWait #-} sendWorkerWait :: MonadAsync m => SVar m a -> m () sendWorkerWait sv = do - case svarStyle sv of - SVarStyle _ LIFO -> liftIO $ threadDelay 200 - SVarStyle _ FIFO -> liftIO $ threadDelay 0 - - output <- liftIO $ readIORef (outputQueue sv) - when (null output) $ do + -- When there is no output seen we dispatch more workers to help out if + -- there is work pending in the work queue. But we wait a little while + -- and check the output again so that we are not too aggressive. + -- If there is no output pending to process and there is no worker to be + -- sent then we block, so that we do not keep looping fruitlessly. + + liftIO $ threadDelay 200 + (_, n) <- liftIO $ readIORef (outputQueue sv) + when (n <= 0) $ do done <- queueEmpty sv if not done - then pushWorker sv >> sendWorkerWait sv - else void (liftIO $ takeMVar (doorBell sv)) + then do + cnt <- liftIO $ readIORef $ activeWorkers sv + if (cnt < 1500) + then do + pushWorker sv + sendWorkerWait sv + else liftIO $ takeMVar (doorBell sv) + else liftIO $ takeMVar (doorBell sv) -- | Pull a stream from an SVar. {-# NOINLINE fromStreamVar #-} fromStreamVar :: MonadAsync m => SVar m a -> Stream m a -fromStreamVar sv = Stream $ \_ stp yld -> do - -- XXX if reading the IORef is costly we can use a flag in the SVar to - -- indicate we are done. - done <- allThreadsDone sv - if done - then stp +fromStreamVar sv = Stream $ \_ stp sng yld -> do + let SVarStyle _ sched = svarStyle sv + if sched == Par + then liftIO $ takeMVar (doorBell sv) else do res <- liftIO $ tryTakeMVar (doorBell sv) when (isNothing res) $ sendWorkerWait sv - list <- liftIO $ atomicModifyIORefCAS (outputQueue sv) $ \x -> ([], x) - -- To avoid lock overhead we read all events at once instead of reading - -- one at a time. We just reverse the list to process the events in the - -- order they arrived. Maybe we can use a queue instead? - (runStream $ processEvents (reverse list)) Nothing stp yld + + void $ liftIO $ tryPutMVar (siren sv) () + (list, _) <- liftIO $ atomicModifyIORefCAS (outputQueue sv) $ \x -> (([],0), x) + -- Reversing the output is important to guarantee that we process the + -- outputs in the same order as they were generated by the constituent + -- streams. + (runStream $ processEvents (reverse list)) Nothing stp sng yld where handleException e tid = do - delThread sv tid + liftIO $ atomicModifyIORefCAS_ (activeWorkers sv) $ \n -> n - 1 + modifyThread sv tid -- XXX implement kill async exception handling -- liftIO $ readIORef (runningThreads sv) >>= mapM_ killThread throwM e {-# INLINE processEvents #-} - processEvents [] = Stream $ \_ stp yld -> do + processEvents [] = Stream $ \_ stp sng yld -> do done <- allThreadsDone sv if not done - then (runStream (fromStreamVar sv)) Nothing stp yld + then (runStream (fromStreamVar sv)) Nothing stp sng yld else stp - processEvents (ev : es) = Stream $ \_ stp yld -> do - let continue = (runStream (processEvents es)) Nothing stp yld - yield a = yld a (Just (processEvents es)) + processEvents (ev : es) = Stream $ \_ stp sng yld -> do + let continue = (runStream (processEvents es)) Nothing stp sng yld + yield a = yld a (processEvents es) case ev of ChildYield a -> yield a ChildStop tid e -> case e of - Nothing -> delThread sv tid >> continue + Nothing -> do + let active = activeWorkers sv + liftIO $ atomicModifyIORefCAS_ active $ \n -> n - 1 + modifyThread sv tid >> continue Just ex -> handleException ex tid getFifoSVar :: MonadIO m => SVarStyle -> IO (SVar m a) getFifoSVar ctype = do - outQ <- newIORef [] + outQ <- newIORef ([], 0) outQMv <- newEmptyMVar + hooter <- newEmptyMVar + active <- newIORef 0 running <- newIORef S.empty q <- newQ let sv = - SVar { outputQueue = outQ - , doorBell = outQMv - , runningThreads = running - , runqueue = runqueueFIFO sv q - , enqueue = pushL q - , queueEmpty = liftIO $ nullQ q - , svarStyle = ctype - } + SVar { outputQueue = outQ + , doorBell = outQMv + , siren = hooter + , runningThreads = running + , runqueue = runqueueFIFO sv q + , enqueue = pushL q + , queueEmpty = liftIO $ nullQ q + , svarStyle = ctype + , activeWorkers = active + } in return sv getLifoSVar :: MonadIO m => SVarStyle -> IO (SVar m a) getLifoSVar ctype = do - outQ <- newIORef [] + outQ <- newIORef ([], 0) outQMv <- newEmptyMVar + hooter <- newEmptyMVar + active <- newIORef 0 running <- newIORef S.empty q <- newIORef [] let checkEmpty = null <$> liftIO (readIORef q) let sv = - SVar { outputQueue = outQ - , doorBell = outQMv - , runningThreads = running - , runqueue = runqueueLIFO sv q - , enqueue = enqueueLIFO q - , queueEmpty = checkEmpty - , svarStyle = ctype - } + SVar { outputQueue = outQ + , doorBell = outQMv + , siren = hooter + , runningThreads = running + , runqueue = runqueueLIFO sv q + , enqueue = enqueueLIFO q + , queueEmpty = checkEmpty + , svarStyle = ctype + , activeWorkers = active + } + in return sv + +getParSVar :: SVarStyle -> IO (SVar m a) +getParSVar style = do + outQ <- newIORef ([], 0) + outQMv <- newEmptyMVar + hooter <- newEmptyMVar + active <- newIORef 0 + running <- newIORef S.empty + let sv = + SVar { outputQueue = outQ + , doorBell = outQMv + , siren = hooter + , runningThreads = running + , runqueue = undefined + , enqueue = undefined + , queueEmpty = undefined + , svarStyle = style + , activeWorkers = active + } in return sv -- | Create a new empty SVar. @@ -480,6 +607,7 @@ newEmptySVar style = do case style of SVarStyle _ FIFO -> getFifoSVar style SVarStyle _ LIFO -> getLifoSVar style + SVarStyle _ Par -> getParSVar style -- | Create a new SVar and enqueue one stream computation on it. newStreamVar1 :: MonadAsync m => SVarStyle -> Stream m a -> m (SVar m a) @@ -509,6 +637,7 @@ newStreamVar2 style m1 m2 = do c <- getLifoSVar style (enqueue c) m2 >> (enqueue c) m1 return c + SVarStyle _ Par -> undefined pushWorker sv return sv @@ -518,74 +647,71 @@ toStreamVar :: MonadAsync m => SVar m a -> Stream m a -> m () toStreamVar sv m = do liftIO $ (enqueue sv) m done <- allThreadsDone sv - -- XXX there may be a race here unless we are running in the consumer - -- thread. This is safe only when called from the consumer thread or when - -- no consumer is present. + -- XXX This is safe only when called from the consumer thread or when no + -- consumer is present. There may be a race if we are not running in the + -- consumer thread. when done $ pushWorker sv ------------------------------------------------------------------------------ -- Running streams concurrently ------------------------------------------------------------------------------ --- Concurrency rate control. Our objective is to create more threads on demand --- if the consumer is running faster than us. As soon as we encounter an --- Alternative composition we create a push pull pair of threads. We use a --- channel for communication between the consumer pulling from the channel and --- the producer who pushing to the channel. The producer creates more threads --- if no output is seen on the channel, that is the consumer is running faster. --- However this mechanism can be problematic if the initial production latency --- is high, we may end up creating too many threads. So we need some way to --- monitor and use the latency as well. +-- Concurrency rate control. -- --- TBD We may run computations at the lower level of the composition tree --- serially even if they are composed using a parallel combinator. We can use --- <> in place of <| and <=> in place of <|>. If we find that a parallel --- channel immediately above a computation becomes empty we can switch to --- parallelizing the computation. For that we can use a state flag to fork the --- rest of the computation at any point of time inside the Monad bind operation --- if the consumer is running at a faster speed. +-- Our objective is to create more threads on demand if the consumer is running +-- faster than us. As soon as we encounter a concurrent composition we create a +-- push pull pair of threads. We use an SVar for communication between the +-- consumer, pulling from the SVar and the producer who is pushing to the SVar. +-- The producer creates more threads if the SVar drains and becomes empty, that +-- is the consumer is running faster. -- --- TBD the alternative composition allows us to dispatch a chunkSize of only 1. --- If we have to dispatch in arbitrary chunksizes we will need to compose the --- parallel actions using a data constructor (Free Alternative) instead so that --- we can divide it in chunks of arbitrary size before dispatch. If the stream --- is composed of hierarchically composed grains of different sizes then we can --- always switch to a desired granularity depending on the consumer speed. +-- XXX Note 1: This mechanism can be problematic if the initial production +-- latency is high, we may end up creating too many threads. So we need some +-- way to monitor and use the latency as well. Having a limit on the dispatches +-- (programmer controlled) may also help. -- --- TBD for pure work (when we are not in the IO monad) we can divide it into --- just the number of CPUs. - -{-# NOINLINE withNewSVar2 #-} -withNewSVar2 :: MonadAsync m - => SVarStyle -> Stream m a -> Stream m a -> Stream m a -withNewSVar2 style m1 m2 = Stream $ \_ stp yld -> do - sv <- newStreamVar2 style m1 m2 - (runStream (fromStreamVar sv)) Nothing stp yld +-- TBD Note 2: We may want to run computations at the lower level of the +-- composition tree serially even when they are composed using a parallel +-- combinator. We can use 'serial' in place of 'async' and 'wSerial' in +-- place of 'wAsync'. If we find that an SVar immediately above a computation +-- gets drained empty we can switch to parallelizing the computation. For that +-- we can use a state flag to fork the rest of the computation at any point of +-- time inside the Monad bind operation if the consumer is running at a faster +-- speed. +-- +-- TBD Note 3: the binary operation ('parallel') composition allows us to +-- dispatch a chunkSize of only 1. If we have to dispatch in arbitrary +-- chunksizes we will need to compose the parallel actions using a data +-- constructor (A Free container) instead so that we can divide it in chunks of +-- arbitrary size before dispatching. If the stream is composed of +-- hierarchically composed grains of different sizes then we can always switch +-- to a desired granularity depending on the consumer speed. +-- +-- TBD Note 4: for pure work (when we are not in the IO monad) we can divide it +-- into just the number of CPUs. -- | Join two computations on the currently running 'SVar' queue for concurrent --- execution. The 'SVarStyle' required by the current composition context is --- passed as one of the parameters. If the style does not match with the style --- of the current 'SVar' we create a new 'SVar' and schedule the computations --- on that. The newly created SVar joins as one of the computations on the --- current SVar queue. +-- execution. When we are using parallel composition, an SVar is passed around +-- as a state variable. We try to schedule a new parallel computation on the +-- SVar passed to us. The first time, when no SVar exists, a new SVar is +-- created. Subsequently, 'joinStreamVar2' may get called when a computation +-- already scheduled on the SVar is further evaluated. For example, when (a +-- `parallel` b) is evaluated it calls a 'joinStreamVar2' to put 'a' and 'b' on +-- the current scheduler queue. -- --- When we are using parallel composition, an SVar is passed around as a state --- variable. We try to schedule a new parallel computation on the SVar passed --- to us. The first time, when no SVar exists, a new SVar is created. --- Subsequently, 'joinStreamVar2' may get called when a computation already --- scheduled on the SVar is further evaluated. For example, when (a \<|> b) is --- evaluated it calls a 'joinStreamVar2' to put 'a' and 'b' on the current scheduler --- queue. However, if the scheduling and composition style of the new +-- The 'SVarStyle' required by the current composition context is passed as one +-- of the parameters. If the scheduling and composition style of the new -- computation being scheduled is different than the style of the current SVar, --- then we create a new SVar and schedule it on that. +-- then we create a new SVar and schedule it on that. The newly created SVar +-- joins as one of the computations on the current SVar queue. -- --- For example: +-- Cases when we need to switch to a new SVar: -- --- * (x \<|> y) \<|> (t \<|> u) -- all of them get scheduled on the same SVar --- * (x \<|> y) \<|> (t \<| u) -- @t@ and @u@ get scheduled on a new child SVar +-- * (x `parallel` y) `parallel` (t `parallel` u) -- all of them get scheduled on the same SVar +-- * (x `parallel` y) `parallel` (t `async` u) -- @t@ and @u@ get scheduled on a new child SVar -- because of the scheduling policy change. --- * if we 'adapt' a stream of type 'AsyncT' to a stream of type --- 'ParallelT', we create a new SVar at the transitioning bind. +-- * if we 'adapt' a stream of type 'async' to a stream of type +-- 'Parallel', we create a new SVar at the transitioning bind. -- * When the stream is switching from disjunctive composition to conjunctive -- composition and vice-versa we create a new SVar to isolate the scheduling -- of the two. @@ -593,118 +719,114 @@ withNewSVar2 style m1 m2 = Stream $ \_ stp yld -> do {-# INLINE joinStreamVar2 #-} joinStreamVar2 :: MonadAsync m => SVarStyle -> Stream m a -> Stream m a -> Stream m a -joinStreamVar2 style m1 m2 = Stream $ \st stp yld -> - case st of +joinStreamVar2 style m1 m2 = Stream $ \svr stp sng yld -> + case svr of Just sv | svarStyle sv == style -> - liftIO ((enqueue sv) m2) >> (runStream m1) st stp yld - _ -> (runStream (withNewSVar2 style m1 m2)) Nothing stp yld + liftIO ((enqueue sv) m2) >> (runStream m1) svr stp sng yld + _ -> do + sv <- newStreamVar1 style (concurrently m1 m2) + (runStream (fromStreamVar sv)) Nothing stp sng yld + where + concurrently ma mb = Stream $ \svr stp sng yld -> do + liftIO $ (enqueue (fromJust svr)) mb + (runStream ma) svr stp sng yld + +{-# INLINE joinStreamVarPar #-} +joinStreamVarPar :: MonadAsync m + => SVarStyle -> Stream m a -> Stream m a -> Stream m a +joinStreamVarPar style m1 m2 = Stream $ \svr stp sng yld -> + case svr of + Just sv | svarStyle sv == style -> do + pushWorkerPar sv m1 >> (runStream m2) svr stp sng yld + _ -> do + sv <- newEmptySVar style + pushWorkerPar sv m1 + pushWorkerPar sv m2 + (runStream (fromStreamVar sv)) Nothing stp sng yld ------------------------------------------------------------------------------ -- Semigroup and Monoid style compositions for parallel actions ------------------------------------------------------------------------------ -{- --- | Same as '<>|'. -parAhead :: Stream m a -> Stream m a -> Stream m a -parAhead = undefined - --- | Sequential composition similar to '<>' except that it can execute the --- action on the right in parallel ahead of time. Returns the results in --- sequential order like '<>' from left to right. -(<>|) :: Stream m a -> Stream m a -> Stream m a -(<>|) = parAhead --} +{-# INLINE async #-} +async :: MonadAsync m => Stream m a -> Stream m a -> Stream m a +async = joinStreamVar2 (SVarStyle Disjunction LIFO) --- | Same as '<|>'. Since this schedules all the composed streams fairly you --- cannot fold infinite number of streams using this operation. -{-# INLINE parAlt #-} -parAlt :: MonadAsync m => Stream m a -> Stream m a -> Stream m a -parAlt = joinStreamVar2 (SVarStyle Disjunction FIFO) - --- | Same as '<|'. Since this schedules the left side computation first you can --- right fold an infinite container using this operator. However a left fold --- will not work well as it first unpeels the whole structure before scheduling --- a computation requiring an amount of memory proportional to the size of the --- structure. -{-# INLINE parLeft #-} -parLeft :: MonadAsync m => Stream m a -> Stream m a -> Stream m a -parLeft = joinStreamVar2 (SVarStyle Disjunction LIFO) +{-# INLINE wAsync #-} +wAsync :: MonadAsync m => Stream m a -> Stream m a -> Stream m a +wAsync = joinStreamVar2 (SVarStyle Disjunction FIFO) + +{-# INLINE parallel #-} +parallel :: MonadAsync m => Stream m a -> Stream m a -> Stream m a +parallel = joinStreamVarPar (SVarStyle Disjunction Par) ------------------------------------------------------------------------------- --- Instances (only used for deriving newtype instances) +-- Functor instace is the same for all types ------------------------------------------------------------------------------- --- Stream type is not exposed, these instances are only for deriving instances --- for the newtype wrappers based on Stream. - --- Dummy Instances, defined to enable the definition of other instances that --- require a Monad constraint. Must be defined by the newtypes. - instance Monad m => Functor (Stream m) where - fmap = undefined - -instance Monad m => Applicative (Stream m) where - pure = undefined - (<*>) = undefined - -instance Monad m => Monad (Stream m) where - return = pure - (>>=) = undefined + fmap f m = Stream $ \_ stp sng yld -> + let single = sng . f + yield a r = yld (f a) (fmap f r) + in (runStream m) Nothing stp single yield ------------------------------------------------------------------------------ -- Alternative & MonadPlus ------------------------------------------------------------------------------ --- | `empty` represents an action that takes non-zero time to complete. Since --- all actions take non-zero time, an `Alternative` composition ('<|>') is a --- monoidal composition executing all actions in parallel, it is similar to --- '<>' except that it runs all the actions in parallel and interleaves their --- results fairly. -instance MonadAsync m => Alternative (Stream m) where - empty = mempty - (<|>) = parAlt +alt :: Stream m a -> Stream m a -> Stream m a +alt m1 m2 = Stream $ \_ stp sng yld -> + let stop = runStream m2 Nothing stp sng yld + in runStream m1 Nothing stop sng yld + +------------------------------------------------------------------------------ +-- Zipping +------------------------------------------------------------------------------ -instance MonadAsync m => MonadPlus (Stream m) where - mzero = empty - mplus = (<|>) +zipWith :: (a -> b -> c) -> Stream m a -> Stream m b -> Stream m c +zipWith f m1 m2 = go m1 m2 + where + go mx my = Stream $ \_ stp sng yld -> do + let merge a ra = + let single2 b = sng (f a b) + yield2 b rb = yld (f a b) (go ra rb) + in (runStream my) Nothing stp single2 yield2 + let single1 a = merge a nil + yield1 a ra = merge a ra + (runStream mx) Nothing stp single1 yield1 + +mkAsync :: MonadAsync m => Stream m a -> m (Stream m a) +mkAsync m = newStreamVar1 (SVarStyle Disjunction LIFO) m + >>= return . fromStreamVar + +zipAsyncWith :: MonadAsync m + => (a -> b -> c) -> Stream m a -> Stream m b -> Stream m c +zipAsyncWith f m1 m2 = Stream $ \_ stp sng yld -> do + ma <- mkAsync m1 + mb <- mkAsync m2 + (runStream (zipWith f ma mb)) Nothing stp sng yld ------------------------------------------------------------------------------- --- Transformer +-- Transformers ------------------------------------------------------------------------------- instance MonadTrans Stream where - lift mx = Stream $ \_ _ yld -> mx >>= (\a -> (yld a Nothing)) - -instance (MonadBase b m, Monad m) => MonadBase b (Stream m) where - liftBase = liftBaseDefault - ------------------------------------------------------------------------------- --- Standard transformer instances ------------------------------------------------------------------------------- - -instance MonadIO m => MonadIO (Stream m) where - liftIO = lift . liftIO + lift = once -instance MonadThrow m => MonadThrow (Stream m) where - throwM = lift . throwM +withLocal :: MonadReader r m => (r -> r) -> Stream m a -> Stream m a +withLocal f m = + Stream $ \svr stp sng yld -> + let single = local f . sng + yield a r = local f $ yld a (withLocal f r) + in (runStream m) svr (local f stp) single yield -- XXX handle and test cross thread state transfer -instance MonadError e m => MonadError e (Stream m) where - throwError = lift . throwError - catchError m h = Stream $ \st stp yld -> - let handle r = r `catchError` \e -> (runStream (h e)) st stp yld - yield a Nothing = yld a Nothing - yield a (Just r) = yld a (Just (catchError r h)) - in handle $ (runStream m) st stp yield - -instance MonadReader r m => MonadReader r (Stream m) where - ask = lift ask - local f m = Stream $ \st stp yld -> - let yield a Nothing = local f $ yld a Nothing - yield a (Just r) = local f $ yld a (Just (local f r)) - in (runStream m) st (local f stp) yield - -instance MonadState s m => MonadState s (Stream m) where - get = lift get - put x = lift (put x) - state k = lift (state k) +withCatchError + :: MonadError e m + => Stream m a -> (e -> Stream m a) -> Stream m a +withCatchError m h = + Stream $ \svr stp sng yld -> + let run x = runStream x svr stp sng yield + handle r = r `catchError` \e -> run $ h e + yield a r = yld a (withCatchError r h) + in handle $ run m diff --git a/src/Streamly/Examples.hs b/src/Streamly/Examples.hs deleted file mode 100644 index e0e3890..0000000 --- a/src/Streamly/Examples.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE CPP #-} --- | --- Module : Streamly.Examples --- Copyright : (c) 2017 Harendra Kumar --- --- License : BSD3 --- Maintainer : harendra.kumar@gmail.com --- Stability : experimental --- Portability : GHC --- --- To run these examples: --- --- You need to build the library with the "examples" flag on e.g. --- @stack build --flag streamly:examples@. To include the SDL examples as well --- use @stack build --flag streamly:examples-sdl@. You will have to make sure --- that you have the SDL OS package installed on your system and the headers --- are visible to Haskell build tool. --- --- You can directly evaluate the respective file and its main function using --- ghc, like this (this may not work when built with @examples-sdl@ flag): --- --- @ --- \$ stack ghc -- -e acidRainGame src\/Streamly\/Examples\/AcidRainGame.hs --- @ --- --- Alternatively, you can create a file calling the main function and compile --- it: --- --- @ --- \$ cat ex.hs --- import Streamly.Examples --- main = acidRainGame --- \$ stack ghc ex.hs --- @ --- --- Alternatively, you can just import "Streamly.Examples" and evaluate the --- respective function in GHCi. --- -module Streamly.Examples - ( - -- Reactive Programming - acidRainGame -#ifdef EXAMPLES_SDL - , circlingSquare -#endif - - -- Concurrent Programming - , listDirRecursive - , mergeSortedStreams - , searchEngineQuery - ) -where - -import Streamly.Examples.AcidRainGame -#ifdef EXAMPLES_SDL -import Streamly.Examples.CirclingSquare -#endif -import Streamly.Examples.ListDirRecursive -import Streamly.Examples.MergeSortedStreams -import Streamly.Examples.SearchEngineQuery diff --git a/src/Streamly/Examples/ListDirRecursive.hs b/src/Streamly/Examples/ListDirRecursive.hs deleted file mode 100644 index e52ac7e..0000000 --- a/src/Streamly/Examples/ListDirRecursive.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Streamly.Examples.ListDirRecursive where - -import Path.IO (listDir, getCurrentDir) -import System.IO (stdout, hSetBuffering, BufferMode(LineBuffering)) -import Streamly - -listDirRecursive :: IO () -listDirRecursive = do - liftIO $ hSetBuffering stdout LineBuffering - runStreamT $ getCurrentDir >>= readdir - where readdir d = do - (ds, fs) <- lift $ listDir d - liftIO $ mapM_ putStrLn $ map show fs ++ map show ds - --foldWith (<>) $ map readdir ds -- serial - --foldWith (<=>) $ map readdir ds -- serial interleaved - foldWith (<|) $ map readdir ds -- concurrent left biased - --foldWith (<|>) $ map readdir ds -- concurrent interleaved diff --git a/src/Streamly/Examples/SearchEngineQuery.hs b/src/Streamly/Examples/SearchEngineQuery.hs deleted file mode 100644 index 313ea5d..0000000 --- a/src/Streamly/Examples/SearchEngineQuery.hs +++ /dev/null @@ -1,19 +0,0 @@ -module Streamly.Examples.SearchEngineQuery where - -import Streamly -import Network.HTTP.Simple - --- Runs three search engine queries in parallel. -searchEngineQuery :: IO () -searchEngineQuery = do - putStrLn "Using parallel alternative" - runStreamT $ google <|> bing <|> duckduckgo - - putStrLn "\nUsing parallel applicative zip" - runZipAsync $ (,,) <$> pure google <*> pure bing <*> pure duckduckgo - - where - get s = liftIO (httpNoBody (parseRequest_ s) >> putStrLn (show s)) - google = get "https://www.google.com/search?q=haskell" - bing = get "https://www.bing.com/search?q=haskell" - duckduckgo = get "https://www.duckduckgo.com/?q=haskell" diff --git a/src/Streamly/Prelude.hs b/src/Streamly/Prelude.hs index 12f73c4..31f088c 100644 --- a/src/Streamly/Prelude.hs +++ b/src/Streamly/Prelude.hs @@ -14,29 +14,62 @@ -- Stability : experimental -- Portability : GHC -- +-- This module is designed to be imported qualified: -- +-- @ +-- import qualified Streamly.Prelude as S +-- @ +-- +-- Functions with the suffix @M@ are general functions that work on monadic +-- arguments. The corresponding functions without the suffix @M@ work on pure +-- arguments and can in general be derived from their monadic versions but are +-- provided for convenience and for consistency with other pure APIs in the +-- @base@ package. +-- +-- Deconstruction and folds accept a 'SerialT' type instead of a polymorphic +-- type to ensure that streams always have a concrete monomorphic type by +-- default, reducing type errors. In case you want to use any other type of +-- stream you can use one of the type combinators provided in the "Streamly" +-- module to convert the stream type. + module Streamly.Prelude ( -- * Construction + -- | Primitives to construct or inspect a stream. nil + , consM + , (|:) , cons , (.:) + + -- * General Unfold , unfoldr , unfoldrM - , each + + -- * Special Generation + -- | Generate a monadic stream from an input structure, a seed or a + -- generation function. + , once + , replicateM + , repeatM , iterate , iterateM + , fromFoldable - -- * Elimination + -- * Deconstruction + , uncons + + -- * Folding -- ** General Folds , foldr , foldrM - , scan - , foldl - , foldlM - , uncons + , foldl' + , foldlM' + , foldx + , foldxM -- ** Special Folds + , mapM_ , toList , all , any @@ -47,12 +80,15 @@ module Streamly.Prelude , length , elem , notElem - , reverse , maximum , minimum , sum , product + -- * Scans + , scanl' + , scanx + -- * Filtering , filter , take @@ -60,11 +96,12 @@ module Streamly.Prelude , drop , dropWhile - -- * Transformation + -- * Reordering + , reverse + + -- * Mapping , mapM - , mapM_ , sequence - , replicateM -- * Zipping , zipWith @@ -76,6 +113,11 @@ module Streamly.Prelude , fromHandle , toHandle + -- * Deprecated + , each + , scan + , foldl + , foldlM ) where @@ -92,351 +134,509 @@ import Prelude hiding (filter, drop, dropWhile, take, import qualified Prelude import qualified System.IO as IO -import Streamly.Core +import qualified Streamly.Core as S +import Streamly.Core (Stream(Stream)) import Streamly.Streams + ------------------------------------------------------------------------------ -- Construction ------------------------------------------------------------------------------ -- | Build a Stream by unfolding pure steps starting from a seed. -unfoldr :: Streaming t => (b -> Maybe (a, b)) -> b -> t m a +-- +-- @since 0.1.0 +unfoldr :: IsStream t => (b -> Maybe (a, b)) -> b -> t m a unfoldr step = fromStream . go where - go s = Stream $ \_ stp yld -> + go s = Stream $ \_ stp _ yld -> case step s of Nothing -> stp - Just (a, b) -> yld a (Just (go b)) + Just (a, b) -> yld a (go b) -- | Build a Stream by unfolding monadic steps starting from a seed. -unfoldrM :: (Streaming t, Monad m) => (b -> m (Maybe (a, b))) -> b -> t m a +-- +-- @since 0.1.0 +unfoldrM :: (IsStream t, Monad m) => (b -> m (Maybe (a, b))) -> b -> t m a unfoldrM step = fromStream . go where - go s = Stream $ \_ stp yld -> do + go s = Stream $ \_ stp _ yld -> do mayb <- step s case mayb of Nothing -> stp - Just (a, b) -> yld a (Just (go b)) + Just (a, b) -> yld a (go b) + +-- | Construct a stream from a 'Foldable' container. +-- +-- @since 0.2.0 +{-# INLINE fromFoldable #-} +fromFoldable :: (IsStream t, Foldable f) => f a -> t m a +fromFoldable = Prelude.foldr cons nil --- XXX need eachInterleaved, eachAsync, eachParallel --- | Same as @foldWith (<>)@ but more efficient. +-- | Same as 'fromFoldable'. +-- +-- @since 0.1.0 +{-# DEPRECATED each "Please use fromFoldable instead." #-} {-# INLINE each #-} -each :: (Streaming t, Foldable f) => f a -> t m a -each = Prelude.foldr cons nil +each :: (IsStream t, Foldable f) => f a -> t m a +each = fromFoldable + +-- | Create a singleton stream by executing a monadic action once. Same as +-- @m \`consM` nil@ but more efficient. +-- +-- @ +-- > toList $ once getLine +-- hello +-- ["hello"] +-- @ +-- +-- @since 0.2.0 +once :: (IsStream t, Monad m) => m a -> t m a +once = fromStream . S.once + +-- | Generate a stream by performing a monadic action @n@ times. +-- +-- @since 0.1.1 +replicateM :: (IsStream t, Monad m) => Int -> m a -> t m a +replicateM n m = fromStream $ go n + where + go cnt = Stream $ \_ stp _ yld -> + if cnt <= 0 + then stp + else m >>= \a -> yld a (go (cnt - 1)) --- | Iterate a pure function from a seed value, streaming the results forever -iterate :: Streaming t => (a -> a) -> a -> t m a +-- | Generate a stream by repeatedly executing a monadic action forever. +-- +-- @since 0.2.0 +repeatM :: (IsStream t, Monad m) => m a -> t m a +repeatM = fromStream . go + where + go m = Stream $ \_ _ _ yld -> + m >>= \a -> yld a (go m) + +-- | Iterate a pure function from a seed value, streaming the results forever. +-- +-- @since 0.1.2 +iterate :: IsStream t => (a -> a) -> a -> t m a iterate step = fromStream . go where - go s = scons s (Just (go (step s))) + go s = S.cons s (go (step s)) --- | Iterate a monadic function from a seed value, streaming the results forever -iterateM :: (Streaming t, Monad m) => (a -> m a) -> a -> t m a +-- | Iterate a monadic function from a seed value, streaming the results +-- forever. +-- +-- @since 0.1.2 +iterateM :: (IsStream t, Monad m) => (a -> m a) -> a -> t m a iterateM step = fromStream . go where - go s = Stream $ \_ _ yld -> do + go s = Stream $ \_ _ _ yld -> do a <- step s - yld s (Just (go a)) + yld s (go a) -- | Read lines from an IO Handle into a stream of Strings. -fromHandle :: (Streaming t, MonadIO m) => IO.Handle -> t m String +-- +-- @since 0.1.0 +fromHandle :: (IsStream t, MonadIO m) => IO.Handle -> t m String fromHandle h = fromStream go where - go = Stream $ \_ stp yld -> do + go = Stream $ \_ stp _ yld -> do eof <- liftIO $ IO.hIsEOF h if eof then stp else do str <- liftIO $ IO.hGetLine h - yld str (Just go) + yld str go ------------------------------------------------------------------------------ -- Elimination ------------------------------------------------------------------------------ --- Parallel variants of folds? - --- | Right fold. -foldr :: (Streaming t, Monad m) => (a -> b -> b) -> b -> t m a -> m b +-- | Lazy right associative fold. For example, to fold a stream into a list: +-- +-- @ +-- >> runIdentity $ foldr (:) [] (serially $ fromFoldable [1,2,3]) +-- [1,2,3] +-- @ +-- +-- @since 0.1.0 +foldr :: Monad m => (a -> b -> b) -> b -> SerialT m a -> m b foldr step acc m = go (toStream m) where go m1 = let stop = return acc - yield a Nothing = return (step a acc) - yield a (Just x) = go x >>= \b -> return (step a b) - in (runStream m1) Nothing stop yield + single a = return (step a acc) + yield a r = go r >>= \b -> return (step a b) + in (S.runStream m1) Nothing stop single yield --- | Right fold with a monadic step function. See 'toList' for an example use. +-- | Lazy right fold with a monadic step function. For example, to fold a +-- stream into a list: +-- +-- @ +-- >> runIdentity $ foldrM (\\x xs -> return (x : xs)) [] (serially $ fromFoldable [1,2,3]) +-- [1,2,3] +-- @ +-- +-- @since 0.2.0 {-# INLINE foldrM #-} -foldrM :: Streaming t => (a -> m b -> m b) -> m b -> t m a -> m b +foldrM :: Monad m => (a -> b -> m b) -> b -> SerialT m a -> m b foldrM step acc m = go (toStream m) where go m1 = - let stop = acc - yield a Nothing = step a acc - yield a (Just x) = step a (go x) - in (runStream m1) Nothing stop yield - --- | Scan left. A strict left fold which accumulates the result of its reduction steps inside a stream, from left. -{-# INLINE scan #-} -scan :: Streaming t => (x -> a -> x) -> x -> (x -> b) -> t m a -> t m b -scan step begin done m = cons (done begin) $ fromStream $ go (toStream m) begin + let stop = return acc + single a = step a acc + yield a r = go r >>= step a + in (S.runStream m1) Nothing stop single yield + +-- | Strict left scan with an extraction function. Like 'scanl'', but applies a +-- user supplied extraction function (the third argument) at each step. This is +-- designed to work with the @foldl@ library. The suffix @x@ is a mnemonic for +-- extraction. +-- +-- @since 0.2.0 +{-# INLINE scanx #-} +scanx :: IsStream t => (x -> a -> x) -> x -> (x -> b) -> t m a -> t m b +scanx step begin done m = cons (done begin) $ fromStream $ go (toStream m) begin where - go m1 !acc = Stream $ \_ stp yld -> - let stop = stp - yield a Nothing = yld (done $ step acc a) Nothing - yield a (Just x) = + go m1 !acc = Stream $ \_ stp sng yld -> + let single a = sng (done $ step acc a) + yield a r = let s = step acc a - in yld (done s) (Just (go x s)) - in runStream m1 Nothing stop yield - --- | Strict left fold. This is typed to work with the foldl package. To use --- it normally just pass 'id' as the third argument. -{-# INLINE foldl #-} -foldl :: (Streaming t, Monad m) - => (x -> a -> x) -> x -> (x -> b) -> t m a -> m b -foldl step begin done m = get $ go (toStream m) begin + in yld (done s) (go r s) + in S.runStream m1 Nothing stp single yield + +-- | +-- @since 0.1.1 +{-# DEPRECATED scan "Please use scanx instead." #-} +scan :: IsStream t => (x -> a -> x) -> x -> (x -> b) -> t m a -> t m b +scan = scanx + +-- | Strict left scan. Like 'foldl'', but returns the folded value at each +-- step, generating a stream of all intermediate fold results. The first +-- element of the stream is the user supplied initial value, and the last +-- element of the stream is the same as the result of 'foldl''. +-- +-- @since 0.2.0 +{-# INLINE scanl' #-} +scanl' :: IsStream t => (b -> a -> b) -> b -> t m a -> t m b +scanl' step begin m = scanx step begin id m + +-- | Strict left fold with an extraction function. Like the standard strict +-- left fold, but applies a user supplied extraction function (the third +-- argument) to the folded value at the end. This is designed to work with the +-- @foldl@ library. The suffix @x@ is a mnemonic for extraction. +-- +-- @since 0.2.0 +{-# INLINE foldx #-} +foldx :: Monad m => (x -> a -> x) -> x -> (x -> b) -> SerialT m a -> m b +foldx step begin done m = get $ go (toStream m) begin where {-# NOINLINE get #-} get m1 = - let yield a Nothing = return $ done a - yield _ _ = undefined - in (runStream m1) Nothing undefined yield + let single = return . done + in (S.runStream m1) Nothing undefined single undefined -- Note, this can be implemented by making a recursive call to "go", -- however that is more expensive because of unnecessary recursion -- that cannot be tail call optimized. Unfolding recursion explicitly via -- continuations is much more efficient. - go m1 !acc = Stream $ \_ _ yld -> - let stop = yld acc Nothing + go m1 !acc = Stream $ \_ _ sng yld -> + let stop = sng acc + single a = sng $ step acc a yield a r = - let s = step acc a - in case r of - Nothing -> yld s Nothing - Just x -> (runStream (go x s)) Nothing undefined yld - in (runStream m1) Nothing stop yield + let stream = go r (step acc a) + in (S.runStream stream) Nothing undefined sng yld + in (S.runStream m1) Nothing stop single yield + +-- | +-- @since 0.1.0 +{-# DEPRECATED foldl "Please use foldx instead." #-} +foldl :: Monad m => (x -> a -> x) -> x -> (x -> b) -> SerialT m a -> m b +foldl = foldx + +-- | Strict left associative fold. +-- +-- @since 0.2.0 +{-# INLINE foldl' #-} +foldl' :: Monad m => (b -> a -> b) -> b -> SerialT m a -> m b +foldl' step begin m = foldx step begin id m -- XXX replace the recursive "go" with explicit continuations. --- | Strict left fold, with monadic step function. This is typed to work --- with the foldl package. To use directly pass 'id' as the third argument. -foldlM :: (Streaming t, Monad m) - => (x -> a -> m x) -> m x -> (x -> m b) -> t m a -> m b -foldlM step begin done m = go begin (toStream m) +-- | Like 'foldx', but with a monadic step function. +-- +-- @since 0.2.0 +foldxM :: Monad m => (x -> a -> m x) -> m x -> (x -> m b) -> SerialT m a -> m b +foldxM step begin done m = go begin (toStream m) where go !acc m1 = let stop = acc >>= done - yield a Nothing = acc >>= \b -> step b a >>= done - yield a (Just x) = acc >>= \b -> go (step b a) x - in (runStream m1) Nothing stop yield + single a = acc >>= \b -> step b a >>= done + yield a r = acc >>= \b -> go (step b a) r + in (S.runStream m1) Nothing stop single yield + +-- | +-- @since 0.1.0 +{-# DEPRECATED foldlM "Please use foldxM instead." #-} +foldlM :: Monad m => (x -> a -> m x) -> m x -> (x -> m b) -> SerialT m a -> m b +foldlM = foldxM + +-- | Like 'foldl'' but with a monadic step function. +-- +-- @since 0.2.0 +foldlM' :: Monad m => (b -> a -> m b) -> b -> SerialT m a -> m b +foldlM' step begin m = foldxM step (return begin) return m -- | Decompose a stream into its head and tail. If the stream is empty, returns -- 'Nothing'. If the stream is non-empty, returns 'Just (a, ma)', where 'a' is -- the head of the stream and 'ma' its tail. -uncons :: (Streaming t, Monad m) => t m a -> m (Maybe (a, t m a)) +-- +-- @since 0.1.0 +uncons :: (IsStream t, Monad m) => SerialT m a -> m (Maybe (a, t m a)) uncons m = let stop = return Nothing - yield a Nothing = return (Just (a, nil)) - yield a (Just x) = return (Just (a, fromStream x)) - in (runStream (toStream m)) Nothing stop yield + single a = return (Just (a, nil)) + yield a r = return (Just (a, fromStream r)) + in (S.runStream (toStream m)) Nothing stop single yield -- | Write a stream of Strings to an IO Handle. -toHandle :: (Streaming t, MonadIO m) => IO.Handle -> t m String -> m () +-- +-- @since 0.1.0 +toHandle :: MonadIO m => IO.Handle -> SerialT m String -> m () toHandle h m = go (toStream m) where go m1 = let stop = return () - yield a Nothing = liftIO (IO.hPutStrLn h a) - yield a (Just x) = liftIO (IO.hPutStrLn h a) >> go x - in (runStream m1) Nothing stop yield + single a = liftIO (IO.hPutStrLn h a) + yield a r = liftIO (IO.hPutStrLn h a) >> go r + in (S.runStream m1) Nothing stop single yield ------------------------------------------------------------------------------ -- Special folds ------------------------------------------------------------------------------ -- | Convert a stream into a list in the underlying monad. +-- +-- @since 0.1.0 {-# INLINABLE toList #-} -toList :: (Streaming t, Monad m) => t m a -> m [a] -toList = foldrM (\a xs -> fmap (a :) xs) (return []) +toList :: Monad m => SerialT m a -> m [a] +toList = foldrM (\a xs -> return (a : xs)) [] -- | Take first 'n' elements from the stream and discard the rest. +-- +-- @since 0.1.0 {-# INLINE take #-} -take :: Streaming t => Int -> t m a -> t m a +take :: IsStream t => Int -> t m a -> t m a take n m = fromStream $ go n (toStream m) where - go n1 m1 = Stream $ \ctx stp yld -> - let yield a Nothing = yld a Nothing - yield a (Just x) = yld a (Just (go (n1 - 1) x)) - in if n1 <= 0 then stp else (runStream m1) ctx stp yield + go n1 m1 = Stream $ \ctx stp sng yld -> + let yield a r = yld a (go (n1 - 1) r) + in if n1 <= 0 then stp else (S.runStream m1) ctx stp sng yield -- | Include only those elements that pass a predicate. +-- +-- @since 0.1.0 {-# INLINE filter #-} -filter :: Streaming t => (a -> Bool) -> t m a -> t m a +filter :: IsStream t => (a -> Bool) -> t m a -> t m a filter p m = fromStream $ go (toStream m) where - go m1 = Stream $ \ctx stp yld -> - let yield a Nothing | p a = yld a Nothing - | otherwise = stp - yield a (Just x) | p a = yld a (Just (go x)) - | otherwise = (runStream x) ctx stp yield - in (runStream m1) ctx stp yield + go m1 = Stream $ \ctx stp sng yld -> + let single a | p a = sng a + | otherwise = stp + yield a r | p a = yld a (go r) + | otherwise = (S.runStream r) ctx stp single yield + in (S.runStream m1) ctx stp single yield -- | End the stream as soon as the predicate fails on an element. +-- +-- @since 0.1.0 {-# INLINE takeWhile #-} -takeWhile :: Streaming t => (a -> Bool) -> t m a -> t m a +takeWhile :: IsStream t => (a -> Bool) -> t m a -> t m a takeWhile p m = fromStream $ go (toStream m) where - go m1 = Stream $ \ctx stp yld -> - let yield a Nothing | p a = yld a Nothing - | otherwise = stp - yield a (Just x) | p a = yld a (Just (go x)) - | otherwise = stp - in (runStream m1) ctx stp yield + go m1 = Stream $ \ctx stp sng yld -> + let single a | p a = sng a + | otherwise = stp + yield a r | p a = yld a (go r) + | otherwise = stp + in (S.runStream m1) ctx stp single yield -- | Discard first 'n' elements from the stream and take the rest. -drop :: Streaming t => Int -> t m a -> t m a +-- +-- @since 0.1.0 +drop :: IsStream t => Int -> t m a -> t m a drop n m = fromStream $ go n (toStream m) where - go n1 m1 = Stream $ \ctx stp yld -> - let yield _ Nothing = stp - yield _ (Just x) = (runStream $ go (n1 - 1) x) ctx stp yld + go n1 m1 = Stream $ \ctx stp sng yld -> + let single _ = stp + yield _ r = (S.runStream $ go (n1 - 1) r) ctx stp sng yld -- Somehow "<=" check performs better than a ">" in if n1 <= 0 - then (runStream m1) ctx stp yld - else (runStream m1) ctx stp yield + then (S.runStream m1) ctx stp sng yld + else (S.runStream m1) ctx stp single yield -- | Drop elements in the stream as long as the predicate succeeds and then -- take the rest of the stream. +-- +-- @since 0.1.0 {-# INLINE dropWhile #-} -dropWhile :: Streaming t => (a -> Bool) -> t m a -> t m a +dropWhile :: IsStream t => (a -> Bool) -> t m a -> t m a dropWhile p m = fromStream $ go (toStream m) where - go m1 = Stream $ \ctx stp yld -> - let yield a Nothing | p a = stp - | otherwise = yld a Nothing - yield a (Just x) | p a = (runStream x) ctx stp yield - | otherwise = yld a (Just x) - in (runStream m1) ctx stp yield + go m1 = Stream $ \ctx stp sng yld -> + let single a | p a = stp + | otherwise = sng a + yield a r | p a = (S.runStream r) ctx stp single yield + | otherwise = yld a r + in (S.runStream m1) ctx stp single yield -- | Determine whether all elements of a stream satisfy a predicate. -all :: (Streaming t, Monad m) => (a -> Bool) -> t m a -> m Bool +-- +-- @since 0.1.0 +all :: Monad m => (a -> Bool) -> SerialT m a -> m Bool all p m = go (toStream m) where go m1 = - let yield a Nothing | p a = return True - | otherwise = return False - yield a (Just x) | p a = go x - | otherwise = return False - in (runStream m1) Nothing (return True) yield + let single a | p a = return True + | otherwise = return False + yield a r | p a = go r + | otherwise = return False + in (S.runStream m1) Nothing (return True) single yield -- | Determine whether any of the elements of a stream satisfy a predicate. -any :: (Streaming t, Monad m) => (a -> Bool) -> t m a -> m Bool +-- +-- @since 0.1.0 +any :: Monad m => (a -> Bool) -> SerialT m a -> m Bool any p m = go (toStream m) where go m1 = - let yield a Nothing | p a = return True - | otherwise = return False - yield a (Just x) | p a = return True - | otherwise = go x - in (runStream m1) Nothing (return False) yield + let single a | p a = return True + | otherwise = return False + yield a r | p a = return True + | otherwise = go r + in (S.runStream m1) Nothing (return False) single yield -- | Determine the sum of all elements of a stream of numbers -sum :: (Streaming t, Monad m, Num a) => t m a -> m a +-- +-- @since 0.1.0 +sum :: (Monad m, Num a) => SerialT m a -> m a sum = foldl (+) 0 id -- | Determine the product of all elements of a stream of numbers -product :: (Streaming t, Monad m, Num a) => t m a -> m a +-- +-- @since 0.1.1 +product :: (Monad m, Num a) => SerialT m a -> m a product = foldl (*) 1 id -- | Extract the first element of the stream, if any. -head :: (Streaming t, Monad m) => t m a -> m (Maybe a) +-- +-- @since 0.1.0 +head :: Monad m => SerialT m a -> m (Maybe a) head m = let stop = return Nothing + single a = return (Just a) yield a _ = return (Just a) - in (runStream (toStream m)) Nothing stop yield + in (S.runStream (toStream m)) Nothing stop single yield -- | Extract all but the first element of the stream, if any. -tail :: (Streaming t, Monad m) => t m a -> m (Maybe (t m a)) +-- +-- @since 0.1.1 +tail :: (IsStream t, Monad m) => SerialT m a -> m (Maybe (t m a)) tail m = - let stop = return Nothing - yield _ Nothing = return $ Just nil - yield _ (Just t) = return $ Just $ fromStream t - in (runStream (toStream m)) Nothing stop yield + let stop = return Nothing + single _ = return $ Just nil + yield _ r = return $ Just $ fromStream r + in (S.runStream (toStream m)) Nothing stop single yield -- | Extract the last element of the stream, if any. +-- +-- @since 0.1.1 {-# INLINE last #-} -last :: (Streaming t, Monad m) => t m a -> m (Maybe a) +last :: Monad m => SerialT m a -> m (Maybe a) last = foldl (\_ y -> Just y) Nothing id -- | Determine whether the stream is empty. -null :: (Streaming t, Monad m) => t m a -> m Bool +-- +-- @since 0.1.1 +null :: Monad m => SerialT m a -> m Bool null m = let stop = return True + single _ = return False yield _ _ = return False - in (runStream (toStream m)) Nothing stop yield + in (S.runStream (toStream m)) Nothing stop single yield -- | Determine whether an element is present in the stream. -elem :: (Streaming t, Monad m, Eq a) => a -> t m a -> m Bool +-- +-- @since 0.1.0 +elem :: (Monad m, Eq a) => a -> SerialT m a -> m Bool elem e m = go (toStream m) where go m1 = - let stop = return False - yield a Nothing = return (a == e) - yield a (Just x) = if a == e then return True else go x - in (runStream m1) Nothing stop yield + let stop = return False + single a = return (a == e) + yield a r = if a == e then return True else go r + in (S.runStream m1) Nothing stop single yield -- | Determine whether an element is not present in the stream. -notElem :: (Streaming t, Monad m, Eq a) => a -> t m a -> m Bool +-- +-- @since 0.1.0 +notElem :: (Monad m, Eq a) => a -> SerialT m a -> m Bool notElem e m = go (toStream m) where go m1 = - let stop = return True - yield a Nothing = return (a /= e) - yield a (Just x) = if a == e then return False else go x - in (runStream m1) Nothing stop yield + let stop = return True + single a = return (a /= e) + yield a r = if a == e then return False else go r + in (S.runStream m1) Nothing stop single yield -- | Determine the length of the stream. -length :: (Streaming t, Monad m) => t m a -> m Int +-- +-- @since 0.1.0 +length :: Monad m => SerialT m a -> m Int length = foldl (\n _ -> n + 1) 0 id -- | Returns the elements of the stream in reverse order. -- The stream must be finite. -reverse :: (Streaming t) => t m a -> t m a -reverse m = fromStream $ go Nothing (toStream m) +-- +-- @since 0.1.1 +reverse :: (IsStream t) => t m a -> t m a +reverse m = fromStream $ go S.nil (toStream m) where - go rev rest = Stream $ \svr stp yld -> - let stop = case rev of - Nothing -> stp - Just str -> runStream str svr stp yld - yield a Nothing = runStream (a `scons` rev) svr stp yld - yield a (Just x) = runStream (go (Just $ a `scons` rev) x) svr stp yld - in runStream rest svr stop yield + go rev rest = Stream $ \svr stp sng yld -> + let run x = S.runStream x svr stp sng yld + stop = run rev + single a = run $ a `S.cons` rev + yield a r = run $ go (a `S.cons` rev) r + in S.runStream rest svr stop single yield -- XXX replace the recursive "go" with continuation -- | Determine the minimum element in a stream. -minimum :: (Streaming t, Monad m, Ord a) => t m a -> m (Maybe a) +-- +-- @since 0.1.0 +minimum :: (Monad m, Ord a) => SerialT m a -> m (Maybe a) minimum m = go Nothing (toStream m) where - go r m1 = - let stop = return r - yield a Nothing = return $ min_ a r - yield a (Just x) = go (min_ a r) x - in (runStream m1) Nothing stop yield + go res m1 = + let stop = return res + single a = return $ min_ a res + yield a r = go (min_ a res) r + in (S.runStream m1) Nothing stop single yield - min_ a r = case r of + min_ a res = case res of Nothing -> Just a Just e -> Just $ min a e -- XXX replace the recursive "go" with continuation -- | Determine the maximum element in a stream. -maximum :: (Streaming t, Monad m, Ord a) => t m a -> m (Maybe a) +-- +-- @since 0.1.0 +maximum :: (Monad m, Ord a) => SerialT m a -> m (Maybe a) maximum m = go Nothing (toStream m) where - go r m1 = - let stop = return r - yield a Nothing = return $ max_ a r - yield a (Just x) = go (max_ a r) x - in (runStream m1) Nothing stop yield + go res m1 = + let stop = return res + single a = return $ max_ a res + yield a r = go (max_ a res) r + in (S.runStream m1) Nothing stop single yield - max_ a r = case r of + max_ a res = case res of Nothing -> Just a Just e -> Just $ max a e @@ -448,75 +648,88 @@ maximum m = go Nothing (toStream m) -- | Replace each element of the stream with the result of a monadic action -- applied on the element. +-- +-- @since 0.1.0 {-# INLINE mapM #-} -mapM :: (Streaming t, Monad m) => (a -> m b) -> t m a -> t m b +mapM :: (IsStream t, Monad m) => (a -> m b) -> t m a -> t m b mapM f m = fromStream $ go (toStream m) where - go m1 = Stream $ \_ stp yld -> - let stop = stp - yield a Nothing = f a >>= \b -> yld b Nothing - yield a (Just x) = f a >>= \b -> yld b (Just (go x)) - in (runStream m1) Nothing stop yield + go m1 = Stream $ \_ stp sng yld -> + let single a = f a >>= sng + yield a r = f a >>= \b -> yld b (go r) + in (S.runStream m1) Nothing stp single yield -- | Apply a monadic action to each element of the stream and discard the -- output of the action. -mapM_ :: (Streaming t, Monad m) => (a -> m b) -> t m a -> m () +-- +-- @since 0.1.0 +mapM_ :: Monad m => (a -> m b) -> SerialT m a -> m () mapM_ f m = go (toStream m) where go m1 = let stop = return () - yield a Nothing = void (f a) - yield a (Just x) = f a >> go x - in (runStream m1) Nothing stop yield + single a = void (f a) + yield a r = f a >> go r + in (S.runStream m1) Nothing stop single yield -- | Reduce a stream of monadic actions to a stream of the output of those -- actions. -sequence :: (Streaming t, Monad m) => t m (m a) -> t m a +-- +-- @since 0.1.0 +sequence :: (IsStream t, Monad m) => t m (m a) -> t m a sequence m = fromStream $ go (toStream m) where - go m1 = Stream $ \_ stp yld -> - let stop = stp - yield a Nothing = a >>= \b -> yld b Nothing - yield a (Just x) = a >>= \b -> yld b (Just (go x)) - in (runStream m1) Nothing stop yield - --- | Generate a stream by performing an action @n@ times. -replicateM :: (Streaming t, Monad m) => Int -> m a -> t m a -replicateM n m = fromStream $ go n - where - go cnt = Stream $ \_ stp yld -> - if cnt <= 0 - then stp - else m >>= \a -> yld a (Just $ go (cnt - 1)) + go m1 = Stream $ \_ stp sng yld -> + let single ma = ma >>= sng + yield ma r = ma >>= \b -> yld b (go r) + in (S.runStream m1) Nothing stp single yield ------------------------------------------------------------------------------ -- Serially Zipping Streams ------------------------------------------------------------------------------ +-- | Zip two streams serially using a pure zipping function. +-- +-- @since 0.1.0 +zipWith :: IsStream t => (a -> b -> c) -> t m a -> t m b -> t m c +zipWith f m1 m2 = fromStream $ S.zipWith f (toStream m1) (toStream m2) + -- | Zip two streams serially using a monadic zipping function. -zipWithM :: Streaming t => (a -> b -> t m c) -> t m a -> t m b -> t m c +-- +-- @since 0.1.0 +zipWithM :: IsStream t => (a -> b -> t m c) -> t m a -> t m b -> t m c zipWithM f m1 m2 = fromStream $ go (toStream m1) (toStream m2) where - go mx my = Stream $ \_ stp yld -> do + go mx my = Stream $ \_ stp sng yld -> do let merge a ra = - let yield2 b Nothing = (runStream (g a b)) Nothing stp yld - yield2 b (Just rb) = - (runStream (g a b <> go ra rb)) Nothing stp yld - in (runStream my) Nothing stp yield2 - let yield1 a Nothing = merge a snil - yield1 a (Just ra) = merge a ra - (runStream mx) Nothing stp yield1 - g a b = toStream $ f a b + let run x = S.runStream x Nothing stp sng yld + single2 b = run $ toStream (f a b) + yield2 b rb = run $ toStream (f a b) <> go ra rb + in (S.runStream my) Nothing stp single2 yield2 + let single1 a = merge a S.nil + yield1 a ra = merge a ra + (S.runStream mx) Nothing stp single1 yield1 ------------------------------------------------------------------------------ -- Parallely Zipping Streams ------------------------------------------------------------------------------ +-- | Zip two streams concurrently (i.e. both the elements being zipped are +-- generated concurrently) using a pure zipping function. +-- +-- @since 0.1.0 +zipAsyncWith :: (IsStream t, MonadAsync m) + => (a -> b -> c) -> t m a -> t m b -> t m c +zipAsyncWith f m1 m2 = + fromStream $ S.zipAsyncWith f (toStream m1) (toStream m2) + -- | Zip two streams asyncly (i.e. both the elements being zipped are generated -- concurrently) using a monadic zipping function. -zipAsyncWithM :: (Streaming t, MonadAsync m) +-- +-- @since 0.1.0 +zipAsyncWithM :: (IsStream t, MonadAsync m) => (a -> b -> t m c) -> t m a -> t m b -> t m c -zipAsyncWithM f m1 m2 = fromStream $ Stream $ \_ stp yld -> do - ma <- async m1 - mb <- async m2 - (runStream (toStream (zipWithM f ma mb))) Nothing stp yld +zipAsyncWithM f m1 m2 = fromStream $ Stream $ \_ stp sng yld -> do + ma <- mkAsync m1 + mb <- mkAsync m2 + (S.runStream (toStream (zipWithM f ma mb))) Nothing stp sng yld diff --git a/src/Streamly/Streams.hs b/src/Streamly/Streams.hs index 0e41076..e9bd427 100644 --- a/src/Streamly/Streams.hs +++ b/src/Streamly/Streams.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving#-} @@ -18,85 +20,107 @@ -- module Streamly.Streams ( - Streaming (..) - , MonadAsync + IsStream (..) + , Streaming -- deprecated + , S.MonadAsync -- * SVars , SVarSched (..) , SVarTag (..) , SVarStyle (..) , SVar - , newEmptySVar + , S.newEmptySVar -- * Construction , nil , cons , (.:) + , consM + , (|:) , streamBuild , fromCallback , fromSVar -- * Elimination , streamFold - , runStreaming + , runStream + , runStreaming -- deprecated , toSVar -- * Transformation + , mkAsync + + -- * Merging Streams + , serial + , wSerial , async + , wAsync + , parallel + , (<=>) --deprecated + , (<|) --deprecated + + -- * IO Streams + , Serial + , WSerial + , Async + , WAsync + , Parallel + , ZipSerial + , ZipAsync - -- * Stream Styles - , StreamT - , InterleavedT + -- * Stream Transformers + , SerialT + , StreamT -- deprecated + , WSerialT + , InterleavedT -- deprecated , AsyncT + , WAsyncT , ParallelT - , ZipStream - , ZipAsync + , ZipStream -- deprecated + , ZipSerialM + , ZipAsyncM -- * Type Adapters - , serially - , interleaving + , serially -- deprecated + , wSerially + , interleaving -- deprecated , asyncly + , wAsyncly , parallely - , zipping - , zippingAsync + , zipSerially + , zipping -- deprecated + , zipAsyncly + , zippingAsync -- deprecated , adapt -- * Running Streams - , runStreamT - , runInterleavedT - , runAsyncT - , runParallelT - , runZipStream - , runZipAsync - - -- * Zipping - , zipWith - , zipAsyncWith - - -- * Sum Style Composition - , (<=>) - , (<|) + , runStreamT -- deprecated + , runInterleavedT -- deprecated + , runAsyncT -- deprecated + , runParallelT -- deprecated + , runZipStream -- deprecated + , runZipAsync -- deprecated -- * Fold Utilities - -- $foldutils , foldWith , foldMapWith , forEachWith ) where -import Control.Applicative (Alternative (..), liftA2) -import Control.Monad (MonadPlus(..), ap) -import Control.Monad.Base (MonadBase (..)) -import Control.Monad.Catch (MonadThrow) -import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad (ap) +import Control.Monad.Base (MonadBase (..), liftBaseDefault) +import Control.Monad.Catch (MonadThrow, throwM) +-- import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Reader.Class (MonadReader(..)) import Control.Monad.State.Class (MonadState(..)) -import Control.Monad.Trans.Class (MonadTrans) +import Control.Monad.Trans.Class (MonadTrans (lift)) import Data.Semigroup (Semigroup(..)) -import Prelude hiding (zipWith) -import Streamly.Core +import Streamly.Core ( MonadAsync + , SVar, SVarStyle(..) + , SVarTag(..), SVarSched(..)) +import qualified Streamly.Core as S ------------------------------------------------------------------------------ -- Types that can behave as a Stream @@ -104,60 +128,89 @@ import Streamly.Core -- | Class of types that can represent a stream of elements of some type 'a' in -- some monad 'm'. -class Streaming t where - toStream :: t m a -> Stream m a - fromStream :: Stream m a -> t m a +-- +-- @since 0.2.0 +class IsStream t where + toStream :: t m a -> S.Stream m a + fromStream :: S.Stream m a -> t m a + +-- | Same as 'IsStream'. +-- +-- @since 0.1.0 +{-# DEPRECATED Streaming "Please use IsStream instead." #-} +type Streaming = IsStream ------------------------------------------------------------------------------ -- Constructing a stream ------------------------------------------------------------------------------ --- | Represesnts an empty stream just like @[]@ represents an empty list. -nil :: Streaming t => t m a -nil = fromStream snil +-- | An empty stream. +-- +-- @ +-- > toList nil +-- [] +-- @ +-- +-- @since 0.1.0 +nil :: IsStream t => t m a +nil = fromStream S.nil -infixr 5 `cons` +infixr 5 `consM` --- | Constructs a stream by adding a pure value at the head of an existing --- stream, just like ':' constructs lists. For example: +-- | Constructs a stream by adding a monadic action at the head of an existing +-- stream. For example: -- -- @ --- > let stream = 1 \`cons` 2 \`cons` 3 \`cons` nil --- > (toList . serially) stream --- [1,2,3] +-- > toList $ getLine \`consM` getLine \`consM` nil +-- hello +-- world +-- ["hello","world"] -- @ -cons :: (Streaming t) => a -> t m a -> t m a -cons a r = fromStream $ scons a (Just (toStream r)) +-- +-- @since 0.2.0 +consM :: (IsStream t, Monad m) => m a -> t m a -> t m a +consM m r = fromStream $ S.consM m (toStream r) -infixr 5 .: +infixr 5 |: --- | Operator equivalent of 'cons' so that you can construct a stream of pure --- values more succinctly like this: +-- | Operator equivalent of 'consM'. -- -- @ --- > let stream = 1 .: 2 .: 3 .: nil --- > (toList . serially) stream --- [1,2,3] +-- > toList $ getLine |: getLine |: nil +-- hello +-- world +-- ["hello","world"] -- @ -- --- '.:' constructs a stream just like ':' constructs a list. --- --- Also note that another equivalent way of building streams from pure values --- is: +-- @since 0.2.0 +(|:) :: (IsStream t, Monad m) => m a -> t m a -> t m a +(|:) = consM + +infixr 5 `cons` + +-- | Construct a stream by adding a pure value at the head of an existing +-- stream. Same as @consM . return@. For example: -- -- @ --- > let stream = pure 1 <> pure 2 <> pure 3 --- > (toList . serially) stream +-- > toList $ 1 \`cons` 2 \`cons` 3 \`cons` nil -- [1,2,3] -- @ -- --- In the first method we construct a stream by adding one element at a time. --- In the second method we first construct singleton streams using 'pure' and --- then compose all those streams together using the 'Semigroup' style --- composition of streams. The former method is a bit more efficient than the --- latter. +-- @since 0.1.0 +cons :: IsStream t => a -> t m a -> t m a +cons a r = fromStream $ S.cons a (toStream r) + +infixr 5 .: + +-- | Operator equivalent of 'cons'. +-- +-- @ +-- > toList $ 1 .: 2 .: 3 .: nil +-- [1,2,3] +-- @ -- -(.:) :: (Streaming t) => a -> t m a -> t m a +-- @since 0.1.1 +(.:) :: IsStream t => a -> t m a -> t m a (.:) = cons -- | Build a stream from its church encoding. The function passed maps @@ -165,24 +218,24 @@ infixr 5 .: -- parameter to the function is the "yield" function yielding a value and the -- remaining stream if any otherwise 'Nothing'. The third parameter is to -- represent an "empty" stream. -streamBuild :: Streaming t +streamBuild :: IsStream t => (forall r. Maybe (SVar m a) - -> (a -> Maybe (t m a) -> m r) + -> (a -> t m a -> m r) + -> (a -> m r) -> m r -> m r) -> t m a -streamBuild k = fromStream $ Stream $ \sv stp yld -> - let yield a Nothing = yld a Nothing - yield a (Just r) = yld a (Just (toStream r)) - in k sv yield stp +streamBuild k = fromStream $ S.Stream $ \svr stp sng yld -> + let yield a r = yld a (toStream r) + in k svr yield sng stp -- | Build a singleton stream from a callback function. -fromCallback :: (Streaming t) => (forall r. (a -> m r) -> m r) -> t m a -fromCallback k = fromStream $ Stream $ \_ _ yld -> k (\a -> yld a Nothing) +fromCallback :: IsStream t => (forall r. (a -> m r) -> m r) -> t m a +fromCallback k = fromStream $ S.Stream $ \_ _ sng _ -> k sng -- | Read an SVar to get a stream. -fromSVar :: (MonadAsync m, Streaming t) => SVar m a -> t m a -fromSVar sv = fromStream $ fromStreamVar sv +fromSVar :: (MonadAsync m, IsStream t) => SVar m a -> t m a +fromSVar sv = fromStream $ S.fromStreamVar sv ------------------------------------------------------------------------------ -- Destroying a stream @@ -191,27 +244,43 @@ fromSVar sv = fromStream $ fromStreamVar sv -- | Fold a stream using its church encoding. The second argument is the "step" -- function consuming an element and the remaining stream, if any. The third -- argument is for consuming an "empty" stream that yields nothing. -streamFold :: Streaming t - => Maybe (SVar m a) -> (a -> Maybe (t m a) -> m r) -> m r -> t m a -> m r -streamFold sv step blank m = - let yield a Nothing = step a Nothing - yield a (Just x) = step a (Just (fromStream x)) - in (runStream (toStream m)) sv blank yield - --- | Run a streaming composition, discard the results. -runStreaming :: (Monad m, Streaming t) => t m a -> m () -runStreaming m = go (toStream m) +streamFold + :: IsStream t + => Maybe (SVar m a) + -> (a -> t m a -> m r) + -> (a -> m r) + -> m r + -> t m a + -> m r +streamFold svr step single blank m = + let yield a x = step a (fromStream x) + in (S.runStream (toStream m)) svr blank single yield + +-- | Run a streaming composition, discard the results. By default it interprets +-- the stream as 'SerialT', to run other types of streams use the type adapting +-- combinators for example @runStream . 'asyncly'@. +-- +-- @since 0.2.0 +runStream :: Monad m => SerialT m a -> m () +runStream m = go (toStream m) where go m1 = let stop = return () - yield _ Nothing = stop - yield _ (Just x) = go x - in (runStream m1) Nothing stop yield + single _ = return () + yield _ r = go r + in (S.runStream m1) Nothing stop single yield + +-- | Same as 'runStream' +-- +-- @since 0.1.0 +{-# DEPRECATED runStreaming "Please use runStream instead." #-} +runStreaming :: (Monad m, IsStream t) => t m a -> m () +runStreaming = runStream . adapt -- | Write a stream to an 'SVar' in a non-blocking manner. The stream can then -- be read back from the SVar using 'fromSVar'. -toSVar :: (Streaming t, MonadAsync m) => SVar m a -> t m a -> m () -toSVar sv m = toStreamVar sv (toStream m) +toSVar :: (IsStream t, MonadAsync m) => SVar m a -> t m a -> m () +toSVar sv m = S.toStreamVar sv (toStream m) ------------------------------------------------------------------------------ -- Transformation @@ -223,21 +292,74 @@ toSVar sv m = toStreamVar sv (toStream m) -- computation. The returned action is exhaustible and must be drained once. If -- not drained fully we may have a thread blocked forever and once exhausted it -- will always return 'empty'. - -async :: (Streaming t, MonadAsync m) => t m a -> m (t m a) -async m = do - sv <- newStreamVar1 (SVarStyle Disjunction LIFO) (toStream m) +-- +-- @since 0.2.0 +mkAsync :: (IsStream t, MonadAsync m) => t m a -> m (t m a) +mkAsync m = do + sv <- S.newStreamVar1 (SVarStyle Disjunction LIFO) (toStream m) return $ fromSVar sv ------------------------------------------------------------------------------ --- StreamT +-- CPP macros for common instances +------------------------------------------------------------------------------ + +-- XXX use template haskell instead and include Monoid and IsStream instances +-- as well. + +#define MONADPARALLEL , MonadAsync m + +#define MONAD_APPLICATIVE_INSTANCE(STREAM,CONSTRAINT) \ +instance (Monad m CONSTRAINT) => Applicative (STREAM m) where { \ + pure = STREAM . S.singleton; \ + (<*>) = ap } + +#define MONAD_COMMON_INSTANCES(STREAM,CONSTRAINT) \ +instance (MonadBase b m, Monad m CONSTRAINT) => MonadBase b (STREAM m) where {\ + liftBase = liftBaseDefault }; \ + \ +instance (MonadIO m CONSTRAINT) => MonadIO (STREAM m) where { \ + liftIO = lift . liftIO }; \ + \ +instance (MonadThrow m CONSTRAINT) => MonadThrow (STREAM m) where { \ + throwM = lift . throwM }; \ + \ +{- \ +instance (MonadError e m CONSTRAINT) => MonadError e (STREAM m) where { \ + throwError = lift . throwError; \ + catchError m h = \ + fromStream $ S.withCatchError (toStream m) (\e -> toStream $ h e) }; \ +-} \ + \ +instance (MonadReader r m CONSTRAINT) => MonadReader r (STREAM m) where { \ + ask = lift ask; \ + local f m = fromStream $ S.withLocal f (toStream m) }; \ + \ +instance (MonadState s m CONSTRAINT) => MonadState s (STREAM m) where { \ + get = lift get; \ + put x = lift (put x); \ + state k = lift (state k) } + +------------------------------------------------------------------------------ +-- SerialT ------------------------------------------------------------------------------ --- | The 'Monad' instance of 'StreamT' runs the /monadic continuation/ for each +-- | Deep serial composition or serial composition with depth first traversal. +-- The 'Semigroup' instance of 'SerialT' appends two streams serially in a +-- depth first manner, yielding all elements from the first stream, and then +-- all elements from the second stream. +-- +-- @ +-- main = ('toList' . 'serially' $ (fromFoldable [1,2]) \<\> (fromFoldable [3,4])) >>= print +-- @ +-- @ +-- [1,2,3,4] +-- @ +-- +-- The 'Monad' instance runs the /monadic continuation/ for each -- element of the stream, serially. -- -- @ --- main = 'runStreamT' $ do +-- main = 'runStream' . 'serially' $ do -- x <- return 1 \<\> return 2 -- liftIO $ print x -- @ @@ -246,10 +368,10 @@ async m = do -- 2 -- @ -- --- 'StreamT' nests streams serially in a depth first manner. +-- 'SerialT' nests streams serially in a depth first manner. -- -- @ --- main = 'runStreamT' $ do +-- main = 'runStream' . 'serially' $ do -- x <- return 1 \<\> return 2 -- y <- return 3 \<\> return 4 -- liftIO $ print (x, y) @@ -261,118 +383,85 @@ async m = do -- (2,4) -- @ -- --- This behavior is exactly like a list transformer. We call the monadic code --- being run for each element of the stream a monadic continuation. In --- imperative paradigm we can think of this composition as nested @for@ loops --- and the monadic continuation is the body of the loop. The loop iterates for --- all elements of the stream. +-- This behavior of 'SerialT' is exactly like a list transformer. We call the +-- monadic code being run for each element of the stream a monadic +-- continuation. In imperative paradigm we can think of this composition as +-- nested @for@ loops and the monadic continuation is the body of the loop. The +-- loop iterates for all elements of the stream. -- -newtype StreamT m a = StreamT {getStreamT :: Stream m a} - deriving (Semigroup, Monoid, MonadTrans, MonadIO, MonadThrow) - -deriving instance MonadAsync m => Alternative (StreamT m) -deriving instance MonadAsync m => MonadPlus (StreamT m) -deriving instance (MonadBase b m, Monad m) => MonadBase b (StreamT m) -deriving instance MonadError e m => MonadError e (StreamT m) -deriving instance MonadReader r m => MonadReader r (StreamT m) -deriving instance MonadState s m => MonadState s (StreamT m) - -instance Streaming StreamT where - toStream = getStreamT - fromStream = StreamT - --- XXX The Functor/Applicative/Num instances for all the types are exactly the --- same, how can we reduce this boilerplate (use TH)? We cannot derive them --- from a single base type because they depend on the Monad instance which is --- different for each type. +-- The 'serially' combinator can be omitted as the default stream type is +-- 'SerialT'. +-- Note that serial composition with depth first traversal can be used to +-- combine an infinite number of streams as it explores only one stream at a +-- time. +-- +-- @since 0.2.0 +newtype SerialT m a = SerialT {getSerialT :: S.Stream m a} + deriving (Semigroup, Monoid, Functor, MonadTrans) ------------------------------------------------------------------------------- --- Monad ------------------------------------------------------------------------------- +-- | +-- @since 0.1.0 +{-# DEPRECATED StreamT "Please use 'SerialT' instead." #-} +type StreamT = SerialT -instance Monad m => Monad (StreamT m) where - return = pure - (StreamT (Stream m)) >>= f = StreamT $ Stream $ \_ stp yld -> - let run x = (runStream x) Nothing stp yld - yield a Nothing = run $ getStreamT (f a) - yield a (Just r) = run $ getStreamT (f a) - <> getStreamT (StreamT r >>= f) - in m Nothing stp yield +instance IsStream SerialT where + toStream = getSerialT + fromStream = SerialT ------------------------------------------------------------------------------ --- Applicative +-- Semigroup ------------------------------------------------------------------------------ -instance Monad m => Applicative (StreamT m) where - pure a = StreamT $ scons a Nothing - (<*>) = ap +-- | Polymorphic version of the 'Semigroup' operation '<>' of 'SerialT'. +-- Appends two streams sequentially, yielding all elements from the first +-- stream, and then all elements from the second stream. +-- +-- @since 0.2.0 +{-# INLINE serial #-} +serial :: IsStream t => t m a -> t m a -> t m a +serial m1 m2 = fromStream $ S.serial (toStream m1) (toStream m2) ------------------------------------------------------------------------------ --- Functor +-- Monad ------------------------------------------------------------------------------ -instance Monad m => Functor (StreamT m) where - fmap f (StreamT (Stream m)) = StreamT $ Stream $ \_ stp yld -> - let yield a Nothing = yld (f a) Nothing - yield a (Just r) = yld (f a) - (Just (getStreamT (fmap f (StreamT r)))) - in m Nothing stp yield +instance Monad m => Monad (SerialT m) where + return = pure + (SerialT (S.Stream m)) >>= f = SerialT $ S.Stream $ \_ stp sng yld -> + let run x = (S.runStream x) Nothing stp sng yld + single a = run $ toStream (f a) + yield a r = run $ toStream $ f a <> (fromStream r >>= f) + in m Nothing stp single yield ------------------------------------------------------------------------------ --- Num +-- Other instances ------------------------------------------------------------------------------ -instance (Monad m, Num a) => Num (StreamT m a) where - fromInteger n = pure (fromInteger n) - - negate = fmap negate - abs = fmap abs - signum = fmap signum - - (+) = liftA2 (+) - (*) = liftA2 (*) - (-) = liftA2 (-) - -instance (Monad m, Fractional a) => Fractional (StreamT m a) where - fromRational n = pure (fromRational n) - - recip = fmap recip - - (/) = liftA2 (/) - -instance (Monad m, Floating a) => Floating (StreamT m a) where - pi = pure pi - - exp = fmap exp - sqrt = fmap sqrt - log = fmap log - sin = fmap sin - tan = fmap tan - cos = fmap cos - asin = fmap asin - atan = fmap atan - acos = fmap acos - sinh = fmap sinh - tanh = fmap tanh - cosh = fmap cosh - asinh = fmap asinh - atanh = fmap atanh - acosh = fmap acosh - - (**) = liftA2 (**) - logBase = liftA2 logBase +MONAD_APPLICATIVE_INSTANCE(SerialT,) +MONAD_COMMON_INSTANCES(SerialT,) ------------------------------------------------------------------------------ --- InterleavedT +-- WSerialT ------------------------------------------------------------------------------ --- | Like 'StreamT' but different in nesting behavior. It fairly interleaves --- the iterations of the inner and the outer loop, nesting loops in a breadth --- first manner. +-- | Wide serial composition or serial composition with a breadth first +-- traversal. The 'Semigroup' instance of 'WSerialT' traverses +-- the two streams in a breadth first manner. In other words, it interleaves +-- two streams, yielding one element from each stream alternately. +-- +-- @ +-- main = ('toList' . 'wSerially' $ (fromFoldable [1,2]) \<\> (fromFoldable [3,4])) >>= print +-- @ +-- @ +-- [1,3,2,4] +-- @ +-- +-- Similarly, the 'Monad' instance interleaves the iterations of the +-- inner and the outer loop, nesting loops in a breadth first manner. -- -- -- @ --- main = 'runInterleavedT' $ do +-- main = 'runStream' . 'wSerially' $ do -- x <- return 1 \<\> return 2 -- y <- return 3 \<\> return 4 -- liftIO $ print (x, y) @@ -384,106 +473,109 @@ instance (Monad m, Floating a) => Floating (StreamT m a) where -- (2,4) -- @ -- -newtype InterleavedT m a = InterleavedT {getInterleavedT :: Stream m a} - deriving (Semigroup, Monoid, MonadTrans, MonadIO, MonadThrow) - -deriving instance MonadAsync m => Alternative (InterleavedT m) -deriving instance MonadAsync m => MonadPlus (InterleavedT m) -deriving instance (MonadBase b m, Monad m) => MonadBase b (InterleavedT m) -deriving instance MonadError e m => MonadError e (InterleavedT m) -deriving instance MonadReader r m => MonadReader r (InterleavedT m) -deriving instance MonadState s m => MonadState s (InterleavedT m) +-- Note that a serial composition with breadth first traversal can only combine +-- a finite number of streams as it needs to retain state for each unfinished +-- stream. +-- +-- @since 0.2.0 +newtype WSerialT m a = WSerialT {getWSerialT :: S.Stream m a} + deriving (Functor, MonadTrans) -instance Streaming InterleavedT where - toStream = getInterleavedT - fromStream = InterleavedT +-- | +-- @since 0.1.0 +{-# DEPRECATED InterleavedT "Please use 'WSerialT' instead." #-} +type InterleavedT = WSerialT -instance Monad m => Monad (InterleavedT m) where - return = pure - (InterleavedT (Stream m)) >>= f = InterleavedT $ Stream $ \_ stp yld -> - let run x = (runStream x) Nothing stp yld - yield a Nothing = run $ getInterleavedT (f a) - yield a (Just r) = run $ getInterleavedT (f a) - `interleave` - getInterleavedT (InterleavedT r >>= f) - in m Nothing stp yield +instance IsStream WSerialT where + toStream = getWSerialT + fromStream = WSerialT ------------------------------------------------------------------------------ --- Applicative +-- Semigroup ------------------------------------------------------------------------------ -instance Monad m => Applicative (InterleavedT m) where - pure a = InterleavedT $ scons a Nothing - (<*>) = ap +-- | Polymorphic version of the 'Semigroup' operation '<>' of 'WSerialT'. +-- Interleaves two streams, yielding one element from each stream alternately. +-- +-- @since 0.2.0 +{-# INLINE wSerial #-} +wSerial :: IsStream t => t m a -> t m a -> t m a +wSerial m1 m2 = fromStream $ S.wSerial (toStream m1) (toStream m2) ------------------------------------------------------------------------------- --- Functor ------------------------------------------------------------------------------- +instance Semigroup (WSerialT m a) where + (<>) = wSerial -instance Monad m => Functor (InterleavedT m) where - fmap f (InterleavedT (Stream m)) = InterleavedT $ Stream $ \_ stp yld -> - let yield a Nothing = yld (f a) Nothing - yield a (Just r) = - yld (f a) (Just (getInterleavedT (fmap f (InterleavedT r)))) - in m Nothing stp yield +infixr 5 <=> + +-- | Same as 'wSerial'. +-- +-- @since 0.1.0 +{-# DEPRECATED (<=>) "Please use 'wSerial' instead." #-} +{-# INLINE (<=>) #-} +(<=>) :: IsStream t => t m a -> t m a -> t m a +(<=>) = wSerial ------------------------------------------------------------------------------ --- Num +-- Monoid ------------------------------------------------------------------------------ -instance (Monad m, Num a) => Num (InterleavedT m a) where - fromInteger n = pure (fromInteger n) - - negate = fmap negate - abs = fmap abs - signum = fmap signum - - (+) = liftA2 (+) - (*) = liftA2 (*) - (-) = liftA2 (-) - -instance (Monad m, Fractional a) => Fractional (InterleavedT m a) where - fromRational n = pure (fromRational n) +instance Monoid (WSerialT m a) where + mempty = nil + mappend = (<>) - recip = fmap recip - - (/) = liftA2 (/) +------------------------------------------------------------------------------ +-- Monad +------------------------------------------------------------------------------ -instance (Monad m, Floating a) => Floating (InterleavedT m a) where - pi = pure pi +instance Monad m => Monad (WSerialT m) where + return = pure + (WSerialT (S.Stream m)) >>= f = WSerialT $ S.Stream $ \_ stp sng yld -> + let run x = (S.runStream x) Nothing stp sng yld + single a = run $ toStream (f a) + yield a r = run $ toStream $ f a <> (fromStream r >>= f) + in m Nothing stp single yield - exp = fmap exp - sqrt = fmap sqrt - log = fmap log - sin = fmap sin - tan = fmap tan - cos = fmap cos - asin = fmap asin - atan = fmap atan - acos = fmap acos - sinh = fmap sinh - tanh = fmap tanh - cosh = fmap cosh - asinh = fmap asinh - atanh = fmap atanh - acosh = fmap acosh +------------------------------------------------------------------------------ +-- Other instances +------------------------------------------------------------------------------ - (**) = liftA2 (**) - logBase = liftA2 logBase +MONAD_APPLICATIVE_INSTANCE(WSerialT,) +MONAD_COMMON_INSTANCES(WSerialT,) ------------------------------------------------------------------------------ -- AsyncT ------------------------------------------------------------------------------ --- | Like 'StreamT' but /may/ run each iteration concurrently using demand --- driven concurrency. More concurrent iterations are started only if the --- previous iterations are not able to produce enough output for the consumer. +-- | Deep async composition or async composition with depth first traversal. In +-- a left to right 'Semigroup' composition it tries to yield elements from the +-- left stream as long as it can, but it can run the right stream in parallel +-- if it needs to, based on demand. The right stream can be run if the left +-- stream blocks on IO or cannot produce elements fast enough for the consumer. +-- +-- @ +-- main = ('toList' . 'asyncly' $ (fromFoldable [1,2]) \<> (fromFoldable [3,4])) >>= print +-- @ +-- @ +-- [1,2,3,4] +-- @ +-- +-- Any exceptions generated by a constituent stream are propagated to the +-- output stream. The output and exceptions from a single stream are guaranteed +-- to arrive in the same order in the resulting stream as they were generated +-- in the input stream. However, the relative ordering of elements from +-- different streams in the resulting stream can vary depending on scheduling +-- and generation delays. +-- +-- Similarly, the monad instance of 'AsyncT' /may/ run each iteration +-- concurrently based on demand. More concurrent iterations are started only +-- if the previous iterations are not able to produce enough output for the +-- consumer. -- -- @ -- import "Streamly" -- import Control.Concurrent -- --- main = 'runAsyncT' $ do +-- main = 'runStream' . 'asyncly' $ do -- n <- return 3 \<\> return 2 \<\> return 1 -- liftIO $ do -- threadDelay (n * 1000000) @@ -496,117 +588,250 @@ instance (Monad m, Floating a) => Floating (InterleavedT m a) where -- @ -- -- All iterations may run in the same thread if they do not block. -newtype AsyncT m a = AsyncT {getAsyncT :: Stream m a} - deriving (Semigroup, Monoid, MonadTrans) - -deriving instance MonadAsync m => Alternative (AsyncT m) -deriving instance MonadAsync m => MonadPlus (AsyncT m) -deriving instance MonadAsync m => MonadIO (AsyncT m) -deriving instance MonadAsync m => MonadThrow (AsyncT m) -deriving instance (MonadBase b m, MonadAsync m) => MonadBase b (AsyncT m) -deriving instance (MonadError e m, MonadAsync m) => MonadError e (AsyncT m) -deriving instance (MonadReader r m, MonadAsync m) => MonadReader r (AsyncT m) -deriving instance (MonadState s m, MonadAsync m) => MonadState s (AsyncT m) - -instance Streaming AsyncT where +-- +-- Note that async composition with depth first traversal can be used to +-- combine infinite number of streams as it explores only a bounded number of +-- streams at a time. +-- +-- @since 0.1.0 +newtype AsyncT m a = AsyncT {getAsyncT :: S.Stream m a} + deriving (Functor, MonadTrans) + +instance IsStream AsyncT where toStream = getAsyncT fromStream = AsyncT +------------------------------------------------------------------------------ +-- Semigroup +------------------------------------------------------------------------------ + +-- | Polymorphic version of the 'Semigroup' operation '<>' of 'AsyncT'. +-- Merges two streams possibly concurrently, preferring the +-- elements from the left one when available. +-- +-- @since 0.2.0 +{-# INLINE async #-} +async :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a +async m1 m2 = fromStream $ S.async (toStream m1) (toStream m2) + +instance MonadAsync m => Semigroup (AsyncT m a) where + (<>) = async + +-- | Same as 'async'. +-- +-- @since 0.1.0 +{-# DEPRECATED (<|) "Please use 'async' instead." #-} +{-# INLINE (<|) #-} +(<|) :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a +(<|) = async + +------------------------------------------------------------------------------ +-- Monoid +------------------------------------------------------------------------------ + +instance MonadAsync m => Monoid (AsyncT m a) where + mempty = nil + mappend = (<>) + +------------------------------------------------------------------------------ +-- Monad +------------------------------------------------------------------------------ + {-# INLINE parbind #-} parbind - :: (forall c. Stream m c -> Stream m c -> Stream m c) - -> Stream m a - -> (a -> Stream m b) - -> Stream m b + :: (forall c. S.Stream m c -> S.Stream m c -> S.Stream m c) + -> S.Stream m a + -> (a -> S.Stream m b) + -> S.Stream m b parbind par m f = go m where - go (Stream g) = - Stream $ \ctx stp yld -> - let run x = (runStream x) ctx stp yld - yield a Nothing = run $ f a - yield a (Just r) = run $ f a `par` go r - in g Nothing stp yield + go (S.Stream g) = + S.Stream $ \ctx stp sng yld -> + let run x = (S.runStream x) ctx stp sng yld + single a = run $ f a + yield a r = run $ f a `par` go r + in g Nothing stp single yield instance MonadAsync m => Monad (AsyncT m) where return = pure - (AsyncT m) >>= f = AsyncT $ parbind par m g - where g x = getAsyncT (f x) - par = joinStreamVar2 (SVarStyle Conjunction LIFO) + (AsyncT m) >>= f = AsyncT $ parbind S.async m (getAsyncT . f) ------------------------------------------------------------------------------ --- Applicative +-- Other instances ------------------------------------------------------------------------------ -instance MonadAsync m => Applicative (AsyncT m) where - pure a = AsyncT $ scons a Nothing - (<*>) = ap +MONAD_APPLICATIVE_INSTANCE(AsyncT,MONADPARALLEL) +MONAD_COMMON_INSTANCES(AsyncT, MONADPARALLEL) ------------------------------------------------------------------------------ --- Functor +-- WAsyncT ------------------------------------------------------------------------------ -instance Monad m => Functor (AsyncT m) where - fmap f (AsyncT (Stream m)) = AsyncT $ Stream $ \_ stp yld -> - let yield a Nothing = yld (f a) Nothing - yield a (Just r) = yld (f a) (Just (getAsyncT (fmap f (AsyncT r)))) - in m Nothing stp yield +-- | Wide async composition or async composition with breadth first traversal. +-- The Semigroup instance of 'WAsyncT' concurrently /traverses/ the composed +-- streams using a depth first travesal or in a round robin fashion, yielding +-- elements from both streams alternately. +-- +-- @ +-- main = ('toList' . 'wAsyncly' $ (fromFoldable [1,2]) \<> (fromFoldable [3,4])) >>= print +-- @ +-- @ +-- [1,3,2,4] +-- @ +-- +-- Any exceptions generated by a constituent stream are propagated to the +-- output stream. The output and exceptions from a single stream are guaranteed +-- to arrive in the same order in the resulting stream as they were generated +-- in the input stream. However, the relative ordering of elements from +-- different streams in the resulting stream can vary depending on scheduling +-- and generation delays. +-- +-- Similarly, the 'Monad' instance of 'WAsyncT' runs /all/ iterations fairly +-- concurrently using a round robin scheduling. +-- +-- @ +-- import "Streamly" +-- import Control.Concurrent +-- +-- main = 'runStream' . 'wAsyncly' $ do +-- n <- return 3 \<\> return 2 \<\> return 1 +-- liftIO $ do +-- threadDelay (n * 1000000) +-- myThreadId >>= \\tid -> putStrLn (show tid ++ ": Delay " ++ show n) +-- @ +-- @ +-- ThreadId 40: Delay 1 +-- ThreadId 39: Delay 2 +-- ThreadId 38: Delay 3 +-- @ +-- +-- Unlike 'AsyncT' all iterations are guaranteed to run fairly +-- concurrently, unconditionally. +-- +-- Note that async composition with breadth first traversal can only combine a +-- finite number of streams as it needs to retain state for each unfinished +-- stream. +-- +-- @since 0.2.0 +newtype WAsyncT m a = WAsyncT {getWAsyncT :: S.Stream m a} + deriving (Functor, MonadTrans) + +instance IsStream WAsyncT where + toStream = getWAsyncT + fromStream = WAsyncT ------------------------------------------------------------------------------ --- Num +-- Semigroup ------------------------------------------------------------------------------ -instance (MonadAsync m, Num a) => Num (AsyncT m a) where - fromInteger n = pure (fromInteger n) - - negate = fmap negate - abs = fmap abs - signum = fmap signum +-- | Polymorphic version of the 'Semigroup' operation '<>' of 'WAsyncT'. +-- Merges two streams concurrently choosing elements from both fairly. +-- +-- @since 0.2.0 +{-# INLINE wAsync #-} +wAsync :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a +wAsync m1 m2 = fromStream $ S.wAsync (toStream m1) (toStream m2) - (+) = liftA2 (+) - (*) = liftA2 (*) - (-) = liftA2 (-) +instance MonadAsync m => Semigroup (WAsyncT m a) where + (<>) = wAsync -instance (MonadAsync m, Fractional a) => Fractional (AsyncT m a) where - fromRational n = pure (fromRational n) +------------------------------------------------------------------------------ +-- Monoid +------------------------------------------------------------------------------ - recip = fmap recip +instance MonadAsync m => Monoid (WAsyncT m a) where + mempty = nil + mappend = (<>) - (/) = liftA2 (/) +------------------------------------------------------------------------------ +-- Monad +------------------------------------------------------------------------------ -instance (MonadAsync m, Floating a) => Floating (AsyncT m a) where - pi = pure pi +instance MonadAsync m => Monad (WAsyncT m) where + return = pure + (WAsyncT m) >>= f = + WAsyncT $ parbind S.wAsync m (getWAsyncT . f) - exp = fmap exp - sqrt = fmap sqrt - log = fmap log - sin = fmap sin - tan = fmap tan - cos = fmap cos - asin = fmap asin - atan = fmap atan - acos = fmap acos - sinh = fmap sinh - tanh = fmap tanh - cosh = fmap cosh - asinh = fmap asinh - atanh = fmap atanh - acosh = fmap acosh +------------------------------------------------------------------------------ +-- Other instances +------------------------------------------------------------------------------ - (**) = liftA2 (**) - logBase = liftA2 logBase +MONAD_APPLICATIVE_INSTANCE(WAsyncT,MONADPARALLEL) +MONAD_COMMON_INSTANCES(WAsyncT, MONADPARALLEL) ------------------------------------------------------------------------------ -- ParallelT ------------------------------------------------------------------------------ --- | Like 'StreamT' but runs /all/ iterations fairly concurrently using a round --- robin scheduling. +-- | Async composition with simultaneous traversal of all streams. +-- +-- The Semigroup instance of 'ParallelT' concurrently /merges/ two streams, +-- running both strictly concurrently and yielding elements from both streams +-- as they arrive. When multiple streams are combined using 'ParallelT' each +-- one is evaluated in its own thread and the results produced are presented in +-- the combined stream on a first come first serve basis. +-- +-- 'AsyncT' and 'WAsyncT' are /concurrent lookahead streams/ each with a +-- specific type of consumption pattern (depth first or breadth first). Since +-- they are lookahead, they may introduce certain default latency in starting +-- more concurrent tasks for efficiency reasons or may put a default limitation +-- on the resource consumption (e.g. number of concurrent threads for +-- lookahead). If we look at the implementation detail, they both can share a +-- pool of worker threads to evaluate the streams in the desired pattern and at +-- the desired rate. However, 'ParallelT' uses a separate runtime thread to +-- evaluate each stream. +-- +-- 'WAsyncT' is similar to 'ParallelT', as both of them evaluate the +-- constituent streams fairly in a round robin fashion. +-- However, the key difference is that 'WAsyncT' is lazy or pull driven +-- whereas 'ParallelT' is strict or push driven. 'ParallelT' immediately +-- starts concurrent evaluation of both the streams (in separate threads) and +-- later picks the results whereas 'WAsyncT' may wait for a certain latency +-- threshold before initiating concurrent evaluation of the next stream. The +-- concurrent scheduling of the next stream or the degree of concurrency is +-- driven by the feedback from the consumer. In case of 'ParallelT' each stream +-- is evaluated in a separate thread and results are /pushed/ to a shared +-- output buffer, the evaluation rate is controlled by blocking when the buffer +-- is full. +-- +-- Concurrent lookahead streams are generally more efficient than +-- 'ParallelT' and can work pretty efficiently even for smaller tasks because +-- they do not necessarily use a separate thread for each task. So they should +-- be preferred over 'ParallelT' especially when efficiency is a concern and +-- simultaneous strict evaluation is not a requirement. 'ParallelT' is useful +-- for cases when the streams are required to be evaluated simultaneously +-- irrespective of how the consumer consumes them e.g. when we want to race +-- two tasks and want to start both strictly at the same time or if we have +-- timers in the parallel tasks and our results depend on the timers being +-- started at the same time. We can say that 'ParallelT' is almost the same +-- (modulo some implementation differences) as 'WAsyncT' when the latter is +-- used with unlimited lookahead and zero latency in initiating lookahead. +-- +-- @ +-- main = ('toList' . 'parallely' $ (fromFoldable [1,2]) \<> (fromFoldable [3,4])) >>= print +-- @ +-- @ +-- [1,3,2,4] +-- @ +-- +-- When streams with more than one element are merged, it yields whichever +-- stream yields first without any bias, unlike the 'Async' style streams. +-- +-- Any exceptions generated by a constituent stream are propagated to the +-- output stream. The output and exceptions from a single stream are guaranteed +-- to arrive in the same order in the resulting stream as they were generated +-- in the input stream. However, the relative ordering of elements from +-- different streams in the resulting stream can vary depending on scheduling +-- and generation delays. +-- +-- Similarly, the 'Monad' instance of 'ParallelT' runs /all/ iterations +-- of the loop concurrently. -- -- @ -- import "Streamly" -- import Control.Concurrent -- --- main = 'runParallelT' $ do +-- main = 'runStream' . 'parallely' $ do -- n <- return 3 \<\> return 2 \<\> return 1 -- liftIO $ do -- threadDelay (n * 1000000) @@ -618,409 +843,320 @@ instance (MonadAsync m, Floating a) => Floating (AsyncT m a) where -- ThreadId 38: Delay 3 -- @ -- --- Unlike 'AsyncT' all iterations are guaranteed to run fairly concurrently, --- unconditionally. -newtype ParallelT m a = ParallelT {getParallelT :: Stream m a} - deriving (Semigroup, Monoid, MonadTrans) - -deriving instance MonadAsync m => Alternative (ParallelT m) -deriving instance MonadAsync m => MonadPlus (ParallelT m) -deriving instance MonadAsync m => MonadIO (ParallelT m) -deriving instance MonadAsync m => MonadThrow (ParallelT m) -deriving instance (MonadBase b m, MonadAsync m) => MonadBase b (ParallelT m) -deriving instance (MonadError e m, MonadAsync m) => MonadError e (ParallelT m) -deriving instance (MonadReader r m, MonadAsync m) => MonadReader r (ParallelT m) -deriving instance (MonadState s m, MonadAsync m) => MonadState s (ParallelT m) - -instance Streaming ParallelT where +-- Note that parallel composition can only combine a finite number of +-- streams as it needs to retain state for each unfinished stream. +-- +-- @since 0.1.0 +newtype ParallelT m a = ParallelT {getParallelT :: S.Stream m a} + deriving (Functor, MonadTrans) + +instance IsStream ParallelT where toStream = getParallelT fromStream = ParallelT -instance MonadAsync m => Monad (ParallelT m) where - return = pure - (ParallelT m) >>= f = ParallelT $ parbind par m g - where g x = getParallelT (f x) - par = joinStreamVar2 (SVarStyle Conjunction FIFO) - ------------------------------------------------------------------------------ --- Applicative +-- Semigroup ------------------------------------------------------------------------------ -instance MonadAsync m => Applicative (ParallelT m) where - pure a = ParallelT $ scons a Nothing - (<*>) = ap +-- | Polymorphic version of the 'Semigroup' operation '<>' of 'ParallelT' +-- Merges two streams concurrently. +-- +-- @since 0.2.0 +{-# INLINE parallel #-} +parallel :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a +parallel m1 m2 = fromStream $ S.parallel (toStream m1) (toStream m2) + +instance MonadAsync m => Semigroup (ParallelT m a) where + (<>) = parallel ------------------------------------------------------------------------------ --- Functor +-- Monoid ------------------------------------------------------------------------------ -instance Monad m => Functor (ParallelT m) where - fmap f (ParallelT (Stream m)) = ParallelT $ Stream $ \_ stp yld -> - let yield a Nothing = yld (f a) Nothing - yield a (Just r) = yld (f a) - (Just (getParallelT (fmap f (ParallelT r)))) - in m Nothing stp yield +instance MonadAsync m => Monoid (ParallelT m a) where + mempty = nil + mappend = (<>) ------------------------------------------------------------------------------ --- Num +-- Monad ------------------------------------------------------------------------------ -instance (MonadAsync m, Num a) => Num (ParallelT m a) where - fromInteger n = pure (fromInteger n) - - negate = fmap negate - abs = fmap abs - signum = fmap signum - - (+) = liftA2 (+) - (*) = liftA2 (*) - (-) = liftA2 (-) - -instance (MonadAsync m, Fractional a) => Fractional (ParallelT m a) where - fromRational n = pure (fromRational n) - - recip = fmap recip - - (/) = liftA2 (/) - -instance (MonadAsync m, Floating a) => Floating (ParallelT m a) where - pi = pure pi +instance MonadAsync m => Monad (ParallelT m) where + return = pure + (ParallelT m) >>= f = ParallelT $ parbind S.parallel m (getParallelT . f) - exp = fmap exp - sqrt = fmap sqrt - log = fmap log - sin = fmap sin - tan = fmap tan - cos = fmap cos - asin = fmap asin - atan = fmap atan - acos = fmap acos - sinh = fmap sinh - tanh = fmap tanh - cosh = fmap cosh - asinh = fmap asinh - atanh = fmap atanh - acosh = fmap acosh +------------------------------------------------------------------------------ +-- Other instances +------------------------------------------------------------------------------ - (**) = liftA2 (**) - logBase = liftA2 logBase +MONAD_APPLICATIVE_INSTANCE(ParallelT,MONADPARALLEL) +MONAD_COMMON_INSTANCES(ParallelT, MONADPARALLEL) ------------------------------------------------------------------------------ -- Serially Zipping Streams ------------------------------------------------------------------------------ --- | Zip two streams serially using a pure zipping function. -zipWith :: Streaming t => (a -> b -> c) -> t m a -> t m b -> t m c -zipWith f m1 m2 = fromStream $ go (toStream m1) (toStream m2) - where - go mx my = Stream $ \_ stp yld -> do - let merge a ra = - let yield2 b Nothing = yld (f a b) Nothing - yield2 b (Just rb) = yld (f a b) (Just (go ra rb)) - in (runStream my) Nothing stp yield2 - let yield1 a Nothing = merge a snil - yield1 a (Just ra) = merge a ra - (runStream mx) Nothing stp yield1 - --- | 'ZipStream' zips serially i.e. it produces one element from each stream --- serially and then zips the two elements. Note, for convenience we have used --- the 'zipping' combinator in the following example instead of using a type --- annotation. +-- | The applicative instance of 'ZipSerialM' zips a number of streams serially +-- i.e. it produces one element from each stream serially and then zips all +-- those elements. -- -- @ --- main = (toList . 'zipping' $ (,) \<$\> s1 \<*\> s2) >>= print --- where s1 = pure 1 <> pure 2 --- s2 = pure 3 <> pure 4 +-- main = (toList . 'zipSerially' $ (,,) \<$\> s1 \<*\> s2 \<*\> s3) >>= print +-- where s1 = fromFoldable [1, 2] +-- s2 = fromFoldable [3, 4] +-- s3 = fromFoldable [5, 6] -- @ -- @ --- [(1,3),(2,4)] +-- [(1,3,5),(2,4,6)] -- @ -- --- This applicative operation can be seen as the zipping equivalent of --- interleaving with '<=>'. -newtype ZipStream m a = ZipStream {getZipStream :: Stream m a} - deriving (Semigroup, Monoid) - -deriving instance MonadAsync m => Alternative (ZipStream m) - -instance Monad m => Functor (ZipStream m) where - fmap f (ZipStream (Stream m)) = ZipStream $ Stream $ \_ stp yld -> - let yield a Nothing = yld (f a) Nothing - yield a (Just r) = yld (f a) - (Just (getZipStream (fmap f (ZipStream r)))) - in m Nothing stp yield - -instance Monad m => Applicative (ZipStream m) where - pure = ZipStream . srepeat - (<*>) = zipWith id - -instance Streaming ZipStream where - toStream = getZipStream - fromStream = ZipStream - -instance (Monad m, Num a) => Num (ZipStream m a) where - fromInteger n = pure (fromInteger n) - - negate = fmap negate - abs = fmap abs - signum = fmap signum - - (+) = liftA2 (+) - (*) = liftA2 (*) - (-) = liftA2 (-) - -instance (Monad m, Fractional a) => Fractional (ZipStream m a) where - fromRational n = pure (fromRational n) - - recip = fmap recip - - (/) = liftA2 (/) +-- The 'Semigroup' instance of this type works the same way as that of +-- 'SerialT'. +-- +-- @since 0.2.0 +newtype ZipSerialM m a = ZipSerialM {getZipSerialM :: S.Stream m a} + deriving (Functor, Semigroup, Monoid) -instance (Monad m, Floating a) => Floating (ZipStream m a) where - pi = pure pi +-- | +-- @since 0.1.0 +{-# DEPRECATED ZipStream "Please use 'ZipSerialM' instead." #-} +type ZipStream = ZipSerialM - exp = fmap exp - sqrt = fmap sqrt - log = fmap log - sin = fmap sin - tan = fmap tan - cos = fmap cos - asin = fmap asin - atan = fmap atan - acos = fmap acos - sinh = fmap sinh - tanh = fmap tanh - cosh = fmap cosh - asinh = fmap asinh - atanh = fmap atanh - acosh = fmap acosh +instance IsStream ZipSerialM where + toStream = getZipSerialM + fromStream = ZipSerialM - (**) = liftA2 (**) - logBase = liftA2 logBase +instance Monad m => Applicative (ZipSerialM m) where + pure = ZipSerialM . S.repeat + m1 <*> m2 = fromStream $ S.zipWith id (toStream m1) (toStream m2) ------------------------------------------------------------------------------ -- Parallely Zipping Streams ------------------------------------------------------------------------------ --- | Zip two streams asyncly (i.e. both the elements being zipped are generated --- concurrently) using a pure zipping function. -zipAsyncWith :: (Streaming t, MonadAsync m) - => (a -> b -> c) -> t m a -> t m b -> t m c -zipAsyncWith f m1 m2 = fromStream $ Stream $ \_ stp yld -> do - ma <- async m1 - mb <- async m2 - (runStream (toStream (zipWith f ma mb))) Nothing stp yld - --- | Like 'ZipStream' but zips in parallel, it generates both the elements to +-- | Like 'ZipSerialM' but zips in parallel, it generates all the elements to -- be zipped concurrently. -- -- @ --- main = (toList . 'zippingAsync' $ (,) \<$\> s1 \<*\> s2) >>= print --- where s1 = pure 1 <> pure 2 --- s2 = pure 3 <> pure 4 +-- main = (toList . 'zipAsyncly' $ (,,) \<$\> s1 \<*\> s2 \<*\> s3) >>= print +-- where s1 = fromFoldable [1, 2] +-- s2 = fromFoldable [3, 4] +-- s3 = fromFoldable [5, 6] -- @ -- @ --- [(1,3),(2,4)] +-- [(1,3,5),(2,4,6)] -- @ -- --- This applicative operation can be seen as the zipping equivalent of --- parallel composition with '<|>'. -newtype ZipAsync m a = ZipAsync {getZipAsync :: Stream m a} - deriving (Semigroup, Monoid) - -deriving instance MonadAsync m => Alternative (ZipAsync m) - -instance Monad m => Functor (ZipAsync m) where - fmap f (ZipAsync (Stream m)) = ZipAsync $ Stream $ \_ stp yld -> - let yield a Nothing = yld (f a) Nothing - yield a (Just r) = yld (f a) - (Just (getZipAsync (fmap f (ZipAsync r)))) - in m Nothing stp yield - -instance MonadAsync m => Applicative (ZipAsync m) where - pure = ZipAsync . srepeat - (<*>) = zipAsyncWith id - -instance Streaming ZipAsync where - toStream = getZipAsync - fromStream = ZipAsync - -instance (MonadAsync m, Num a) => Num (ZipAsync m a) where - fromInteger n = pure (fromInteger n) - - negate = fmap negate - abs = fmap abs - signum = fmap signum - - (+) = liftA2 (+) - (*) = liftA2 (*) - (-) = liftA2 (-) - -instance (MonadAsync m, Fractional a) => Fractional (ZipAsync m a) where - fromRational n = pure (fromRational n) - - recip = fmap recip - - (/) = liftA2 (/) - -instance (MonadAsync m, Floating a) => Floating (ZipAsync m a) where - pi = pure pi +-- The 'Semigroup' instance of this type works the same way as that of +-- 'SerialT'. +-- +-- @since 0.2.0 +newtype ZipAsyncM m a = ZipAsyncM {getZipAsyncM :: S.Stream m a} + deriving (Functor, Semigroup, Monoid) - exp = fmap exp - sqrt = fmap sqrt - log = fmap log - sin = fmap sin - tan = fmap tan - cos = fmap cos - asin = fmap asin - atan = fmap atan - acos = fmap acos - sinh = fmap sinh - tanh = fmap tanh - cosh = fmap cosh - asinh = fmap asinh - atanh = fmap atanh - acosh = fmap acosh +instance IsStream ZipAsyncM where + toStream = getZipAsyncM + fromStream = ZipAsyncM - (**) = liftA2 (**) - logBase = liftA2 logBase +instance MonadAsync m => Applicative (ZipAsyncM m) where + pure = ZipAsyncM . S.repeat + m1 <*> m2 = fromStream $ S.zipAsyncWith id (toStream m1) (toStream m2) ------------------------------------------------------------------------------- -- Type adapting combinators ------------------------------------------------------------------------------- --- | Adapt one streaming type to another. -adapt :: (Streaming t1, Streaming t2) => t1 m a -> t2 m a +-- | Adapt any specific stream type to any other specific stream type. +-- +-- @since 0.1.0 +adapt :: (IsStream t1, IsStream t2) => t1 m a -> t2 m a adapt = fromStream . toStream --- | Interpret an ambiguously typed stream as 'StreamT'. -serially :: StreamT m a -> StreamT m a -serially x = x +-- | Fix the type of a polymorphic stream as 'SerialT'. +-- +-- @since 0.1.0 +serially :: IsStream t => SerialT m a -> t m a +serially = adapt + +-- | Fix the type of a polymorphic stream as 'WSerialT'. +-- +-- @since 0.2.0 +wSerially :: IsStream t => WSerialT m a -> t m a +wSerially = adapt + +-- | Same as 'wSerially'. +-- +-- @since 0.1.0 +{-# DEPRECATED interleaving "Please use wSerially instead." #-} +interleaving :: IsStream t => WSerialT m a -> t m a +interleaving = wSerially + +-- | Fix the type of a polymorphic stream as 'AsyncT'. +-- +-- @since 0.1.0 +asyncly :: IsStream t => AsyncT m a -> t m a +asyncly = adapt + +-- | Fix the type of a polymorphic stream as 'WAsyncT'. +-- +-- @since 0.2.0 +wAsyncly :: IsStream t => WAsyncT m a -> t m a +wAsyncly = adapt --- | Interpret an ambiguously typed stream as 'InterleavedT'. -interleaving :: InterleavedT m a -> InterleavedT m a -interleaving x = x +-- | Fix the type of a polymorphic stream as 'ParallelT'. +-- +-- @since 0.1.0 +parallely :: IsStream t => ParallelT m a -> t m a +parallely = adapt --- | Interpret an ambiguously typed stream as 'AsyncT'. -asyncly :: AsyncT m a -> AsyncT m a -asyncly x = x +-- | Fix the type of a polymorphic stream as 'ZipSerialM'. +-- +-- @since 0.2.0 +zipSerially :: IsStream t => ZipSerialM m a -> t m a +zipSerially = adapt --- | Interpret an ambiguously typed stream as 'ParallelT'. -parallely :: ParallelT m a -> ParallelT m a -parallely x = x +-- | Same as 'zipSerially'. +-- +-- @since 0.1.0 +{-# DEPRECATED zipping "Please use zipSerially instead." #-} +zipping :: IsStream t => ZipSerialM m a -> t m a +zipping = zipSerially --- | Interpret an ambiguously typed stream as 'ZipStream'. -zipping :: ZipStream m a -> ZipStream m a -zipping x = x +-- | Fix the type of a polymorphic stream as 'ZipAsyncM'. +-- +-- @since 0.2.0 +zipAsyncly :: IsStream t => ZipAsyncM m a -> t m a +zipAsyncly = adapt --- | Interpret an ambiguously typed stream as 'ZipAsync'. -zippingAsync :: ZipAsync m a -> ZipAsync m a -zippingAsync x = x +-- | Same as 'zipAsyncly'. +-- +-- @since 0.1.0 +{-# DEPRECATED zippingAsync "Please use zipAsyncly instead." #-} +zippingAsync :: IsStream t => ZipAsyncM m a -> t m a +zippingAsync = zipAsyncly ------------------------------------------------------------------------------- -- Running Streams, convenience functions specialized to types ------------------------------------------------------------------------------- --- | Same as @runStreaming . serially@. -runStreamT :: Monad m => StreamT m a -> m () -runStreamT = runStreaming +-- | Same as @runStream@. +-- +-- @since 0.1.0 +{-# DEPRECATED runStreamT "Please use runStream instead." #-} +runStreamT :: Monad m => SerialT m a -> m () +runStreamT = runStream --- | Same as @runStreaming . interleaving@. +-- | Same as @runStream . wSerially@. +-- +-- @since 0.1.0 +{-# DEPRECATED runInterleavedT "Please use 'runStream . interleaving' instead." #-} runInterleavedT :: Monad m => InterleavedT m a -> m () -runInterleavedT = runStreaming +runInterleavedT = runStream . wSerially --- | Same as @runStreaming . asyncly@. +-- | Same as @runStream . asyncly@. +-- +-- @since 0.1.0 +{-# DEPRECATED runAsyncT "Please use 'runStream . asyncly' instead." #-} runAsyncT :: Monad m => AsyncT m a -> m () -runAsyncT = runStreaming +runAsyncT = runStream . asyncly --- | Same as @runStreaming . parallely@. +-- | Same as @runStream . parallely@. +-- +-- @since 0.1.0 +{-# DEPRECATED runParallelT "Please use 'runStream . parallely' instead." #-} runParallelT :: Monad m => ParallelT m a -> m () -runParallelT = runStreaming +runParallelT = runStream . parallely --- | Same as @runStreaming . zipping@. -runZipStream :: Monad m => ZipStream m a -> m () -runZipStream = runStreaming +-- | Same as @runStream . zipping@. +-- +-- @since 0.1.0 +{-# DEPRECATED runZipStream "Please use 'runStream . zipSerially instead." #-} +runZipStream :: Monad m => ZipSerialM m a -> m () +runZipStream = runStream . zipSerially --- | Same as @runStreaming . zippingAsync@. -runZipAsync :: Monad m => ZipAsync m a -> m () -runZipAsync = runStreaming +-- | Same as @runStream . zippingAsync@. +-- +-- @since 0.1.0 +{-# DEPRECATED runZipAsync "Please use 'runStream . zipAsyncly instead." #-} +runZipAsync :: Monad m => ZipAsyncM m a -> m () +runZipAsync = runStream . zipAsyncly ------------------------------------------------------------------------------ --- Sum Style Composition +-- IO Streams ------------------------------------------------------------------------------ -infixr 5 <=> +-- | A serial IO stream of elements of type @a@. See 'SerialT' documentation +-- for more details. +-- +-- @since 0.2.0 +type Serial a = SerialT IO a --- | Sequential interleaved composition, in contrast to '<>' this operator --- fairly interleaves two streams instead of appending them; yielding one --- element from each stream alternately. +-- | An interleaving serial IO stream of elements of type @a@. See 'WSerialT' +-- documentation for more details. -- --- @ --- main = ('toList' . 'serially' $ (return 1 <> return 2) \<=\> (return 3 <> return 4)) >>= print --- @ --- @ --- [1,3,2,4] --- @ +-- @since 0.2.0 +type WSerial a = WSerialT IO a + +-- | A demand driven left biased parallely composing IO stream of elements of +-- type @a@. See 'AsyncT' documentation for more details. -- --- This operator corresponds to the 'InterleavedT' style. Unlike '<>', this --- operator cannot be used to fold infinite containers since that might --- accumulate too many partially drained streams. To be clear, it can combine --- infinite streams but not infinite number of streams. -{-# INLINE (<=>) #-} -(<=>) :: Streaming t => t m a -> t m a -> t m a -m1 <=> m2 = fromStream $ interleave (toStream m1) (toStream m2) +-- @since 0.2.0 +type Async a = AsyncT IO a --- | Demand driven concurrent composition. In contrast to '<|>' this operator --- concurrently "merges" streams in a left biased manner rather than fairly --- interleaving them. It keeps yielding from the stream on the left as long as --- it can. If the left stream blocks or cannot keep up with the pace of the --- consumer it can concurrently yield from the stream on the right in parallel. +-- | A round robin parallely composing IO stream of elements of type @a@. +-- See 'WAsyncT' documentation for more details. -- --- @ --- main = ('toList' . 'serially' $ (return 1 <> return 2) \<| (return 3 <> return 4)) >>= print --- @ --- @ --- [1,2,3,4] --- @ +-- @since 0.2.0 +type WAsync a = WAsyncT IO a + +-- | A parallely composing IO stream of elements of type @a@. +-- See 'ParallelT' documentation for more details. -- --- Unlike '<|>' it can be used to fold infinite containers of streams. This --- operator corresponds to the 'AsyncT' type for product style composition. +-- @since 0.2.0 +type Parallel a = ParallelT IO a + +-- | An IO stream whose applicative instance zips streams serially. -- -{-# INLINE (<|) #-} -(<|) :: (Streaming t, MonadAsync m) => t m a -> t m a -> t m a -m1 <| m2 = fromStream $ parLeft (toStream m1) (toStream m2) +-- @since 0.2.0 +type ZipSerial a = ZipSerialM IO a + +-- | An IO stream whose applicative instance zips streams wAsyncly. +-- +-- @since 0.2.0 +type ZipAsync a = ZipAsyncM IO a ------------------------------------------------------------------------------ -- Fold Utilities ------------------------------------------------------------------------------ --- $foldutils --- These utilities are designed to pass the first argument as one of the sum --- style composition operators (i.e. '<>', '<=>', '<|', '<|>') to conveniently --- fold a container using any style of stream composition. - --- | Like the 'Prelude' 'fold' but allows you to specify a binary sum style --- stream composition operator to fold a container of streams. +-- | A variant of 'Data.Foldable.fold' that allows you to fold a 'Foldable' +-- container of streams using the specified stream sum operation. +-- +-- @foldWith 'async' $ map return [1..3]@ -- --- @foldWith (<>) $ map return [1..3]@ +-- @since 0.1.0 {-# INLINABLE foldWith #-} -foldWith :: (Streaming t, Foldable f) +foldWith :: (IsStream t, Foldable f) => (t m a -> t m a -> t m a) -> f (t m a) -> t m a foldWith f = foldr f nil --- | Like 'foldMap' but allows you to specify a binary sum style composition --- operator to fold a container of streams. Maps a monadic streaming action on --- the container before folding it. +-- | A variant of 'foldMap' that allows you to map a monadic streaming action +-- on a 'Foldable' container and then fold it using the specified stream sum +-- operation. -- --- @foldMapWith (<>) return [1..3]@ +-- @foldMapWith 'async' return [1..3]@ +-- +-- @since 0.1.0 {-# INLINABLE foldMapWith #-} -foldMapWith :: (Streaming t, Foldable f) +foldMapWith :: (IsStream t, Foldable f) => (t m b -> t m b -> t m b) -> (a -> t m b) -> f a -> t m b foldMapWith f g = foldr (f . g) nil -- | Like 'foldMapWith' but with the last two arguments reversed i.e. the -- monadic streaming function is the last argument. +-- +-- @since 0.1.0 {-# INLINABLE forEachWith #-} -forEachWith :: (Streaming t, Foldable f) +forEachWith :: (IsStream t, Foldable f) => (t m b -> t m b -> t m b) -> f a -> (a -> t m b) -> t m b forEachWith f xs g = foldr (f . g) nil xs diff --git a/src/Streamly/Time.hs b/src/Streamly/Time.hs index e170823..e286272 100644 --- a/src/Streamly/Time.hs +++ b/src/Streamly/Time.hs @@ -20,6 +20,8 @@ import Control.Concurrent (threadDelay) -- | Run an action forever periodically at the given frequency specified in per -- second (Hz). +-- +-- @since 0.1.0 periodic :: Int -> IO () -> IO () periodic freq action = do action @@ -33,6 +35,8 @@ periodic freq action = do -- of time in microseconds. The second argument is the frequency in per second -- (Hz). The third argument is the action to run, the action is provided the -- local time as an argument. +-- +-- @since 0.1.0 withClock :: IO Int -> Int -> (Int -> IO ()) -> IO () withClock clock freq action = do t <- clock diff --git a/src/Streamly/Tutorial.hs b/src/Streamly/Tutorial.hs index 59fa5f3..5b71a13 100644 --- a/src/Streamly/Tutorial.hs +++ b/src/Streamly/Tutorial.hs @@ -6,59 +6,71 @@ -- License : BSD3 -- Maintainer : harendra.kumar@gmail.com -- --- Streamly, short for stream concurrently, combines the essence of --- non-determinism, streaming and concurrency in functional programming. --- Concurrent and non-concurrent applications are almost indistinguisable, --- concurrency capability does not at all impact the performance of --- non-concurrent case. --- Streaming enables writing modular, composable and scalable applications with --- ease and concurrency allows you to make them scale and perform well. --- Streamly enables writing concurrent applications without being aware of --- threads or synchronization. No explicit thread control is needed, where --- applicable the concurrency rate is automatically controlled based on the --- demand by the consumer. However, combinators are provided to fine tune the --- concurrency control. +-- Streamly is a general computing framework based on streaming IO. The IO +-- monad and pure lists are a special case of streamly. On one hand, streamly +-- extends the lists of pure values to lists of monadic actions, on the other +-- hand it extends the IO monad with concurrrent non-determinism. In simple +-- imperative terms we can say that streamly extends the IO monad with @for@ +-- loops and nested @for@ loops with concurrency support. You can understand +-- this analogy better once you can go through this tutorial. +-- +-- Streaming in general enables writing modular, composable and scalable +-- applications with ease, and concurrency allows you to make them scale and +-- perform well. Streamly enables writing scalable concurrent applications +-- without being aware of threads or synchronization. No explicit thread +-- control is needed, where applicable the concurrency rate is automatically +-- controlled based on the demand by the consumer. However, combinators can be +-- used to fine tune the concurrency control. +-- -- Streaming and concurrency together enable expressing reactive applications --- conveniently. See "Streamly.Examples" for a simple SDL based FRP example. --- --- Streamly streams are very much like the Haskell lists and most of the --- functions that work on lists have a counterpart that works on streams. --- However, streamly streams can be generated, consumed or combined --- concurrently. In this tutorial we will go over the basic concepts and how to --- use the library. The documentation of @Streamly@ module has more details on --- core APIs. For more APIs for constructing, folding, filtering, mapping and --- zipping etc. see the documentation of "Streamly.Prelude" module. For --- examples and other ways to use the library see the module --- "Streamly.Examples" as well. +-- conveniently. See the @CirclingSquare@ example in the examples directory for +-- a simple SDL based FRP example. To summarize, streamly provides a unified +-- computing framework for streaming, non-determinism and functional reactive +-- programming in an elegant and simple API that is a natural extension of pure +-- lists to monadic streams. +-- +-- In this tutorial we will go over the basic concepts and how to +-- use the library. See the last section for further reading resources. module Streamly.Tutorial ( -- * Streams -- $streams - -- ** Generating Streams + -- * Flavors of Streams + -- $flavors + + -- * Imports and Supporting Code + -- $imports + + -- * Generating Streams -- $generating - -- ** Eliminating Streams + -- * Eliminating Streams -- $eliminating - -- * Combining Streams - -- $combining + -- * Transforming Streams + -- $transformation + + -- * Merging Streams -- ** Semigroup Style -- $semigroup - -- *** Serial composition ('<>') + -- *** Deep Serial Composition ('Serial') -- $serial - -- *** Async composition ('<|') - -- $parallel - - -- *** Interleaved composition ('<=>') + -- *** Wide Serial Composition ('WSerial') -- $interleaved - -- *** Fair Concurrent composition ('<|>') - -- $fairParallel + -- *** Deep Asynchronous Composition ('Async') + -- $async + + -- *** Wide Asynchronous Composition ('WAsync') + -- $wasync + + -- *** Parallel Asynchronous Composition ('Parallel') + -- $parallel -- *** Custom composition -- $custom @@ -66,23 +78,26 @@ module Streamly.Tutorial -- ** Monoid Style -- $monoid - -- * Transforming Streams - -- $transforming + -- * Nesting Streams + -- $nesting -- ** Monad -- $monad - -- *** Serial Composition ('StreamT') + -- *** Deep Serial Nesting ('Serial') -- $regularSerial - -- *** Async Composition ('AsyncT') + -- *** Wide Serial Nesting ('WSerial') + -- $interleavedNesting + + -- *** Deep Asynchronous Nesting ('Async') -- $concurrentNesting - -- *** Interleaved Composition ('InterleavedT') - -- $interleavedNesting + -- *** Wide Asynchronous Nesting ('WAsync') + -- $wasyncNesting - -- *** Fair Concurrent Composition ('ParallelT') - -- $fairlyConcurrentNesting + -- *** Parallel Asynchronous Nesting ('Parallel') + -- $parallelNesting -- *** Exercise -- $monadExercise @@ -102,8 +117,8 @@ module Streamly.Tutorial -- ** Parallel Zipping -- $parallelzip - -- * Summary of Compositions - -- $compositionSummary + -- * Monad transformers + -- $monadtransformers -- * Concurrent Programming -- $concurrent @@ -119,6 +134,9 @@ module Streamly.Tutorial -- * Comparison with Existing Packages -- $comparison + + -- * Where to go next? + -- $furtherReading ) where @@ -132,80 +150,239 @@ import Control.Monad.Trans.Class (MonadTrans (lift)) -- $streams -- --- Streamly provides many different stream types depending on the desired --- composition style. The simplest type is 'StreamT'. 'StreamT' is a monad --- transformer, the type @StreamT m a@ represents a stream of values of type --- 'a' in some underlying monad 'm'. For example, @StreamT IO Int@ is a stream --- of 'Int' in 'IO' monad. +-- The way a list represents a sequence of pure values, a stream represents a +-- sequence of monadic actions. The monadic stream API offered by Streamly is +-- very close to the Haskell "Prelude" pure lists' API, it can be considered as a +-- natural extension of lists to monadic actions. Streamly streams provide +-- concurrent composition and merging of streams. It can be considered as a +-- concurrent list transformer. In contrast to the "Prelude" lists, merging or +-- appending streams of arbitrary length is scalable and inexpensive. +-- +-- The basic stream type is 'Serial', it represents a sequence of IO actions, +-- and is a 'Monad'. The 'Serial' monad is almost a drop in replacement for +-- the 'IO' monad, IO monad is a special case of the 'Serial' monad; IO monad +-- represents a single IO action whereas the 'Serial' monad represents a series +-- of IO actions. The only change you need to make to go from 'IO' to 'Serial' +-- is to use 'runStream' to run the monad and to prefix the IO actions with +-- either 'once' or 'liftIO'. If you use liftIO you can switch from 'Serial' +-- to IO monad by simply removing the 'runStream' function; no other changes +-- are needed unless you have used some stream specific composition or +-- combinators. +-- +-- Similarly, the 'Serial' type is almost a drop in replacement for pure lists, +-- pure lists are a special case of monadic streams. If you use 'nil' in place +-- of '[]' and '|:' in place ':' you can replace a list with a 'Serial' The +-- only difference is that the elements must be monadic type and to operate on +-- the streams we must use the corresponding functions from "Streamly.Prelude" +-- instead of using the base "Prelude". + +-- $flavors +-- +-- There are a few more types similar to 'Serial' that all represent streams +-- and differ only in the 'Semigroup', 'Applicative' and 'Monad' compositions +-- of the streams. +-- +-- The composition of two or more streams is distinguished based on three +-- characterstics, /traversal order/, /execution order/ and +-- /consumption order/. Traversal of a composition of streams could be @deep@ +-- or @wide@. Deep goes depth first i.e. each stream is traversed fully +-- before we traverse the next stream. Wide goes breadth first i.e. one element +-- from each stream is traversed before coming back to the first stream again. +-- Execution could be serial (i.e. synchronous) or asynchronous. In serial +-- execution we execute an action in the next stream only after the first has +-- finished executing. In asynchronous execution actions in both streams can be +-- executed asynchronously i.e. the next action can start executing even before +-- the first one has finished. The third parameter is consumption order that is +-- in what order the output generated by the composition is consumed. +-- Consumption could be serial or asynchronous. In serial consumption, the +-- outputs are consumed in the traversal order, in asynchronous consumption the +-- outputs are consumed as they arrive i.e. first come first serve order. +-- +-- The following table summarizes different styles of streams based on how they +-- compose. All these types are monads and they differ in 'Semigroup', +-- 'Applicative' and 'Monad' compositions: +-- +-- @ +-- +------------+-----------+--------------+--------------+ +-- | Type | Traversal | Execution | Consumption | +-- +============+===========+==============+==============+ +-- | 'Serial' | Deep | Serial | Serial | +-- +------------+-----------+--------------+--------------+ +-- | 'WSerial' | Wide | Serial | Serial | +-- +------------+-----------+--------------+--------------+ +-- | 'Async' | Deep | Asynchronous | Asynchronous | +-- +------------+-----------+--------------+--------------+ +-- | 'WAsync' | Wide | Asynchronous | Asynchronous | +-- +------------+-----------+--------------+--------------+ +-- | 'Parallel' | Parallel | Asynchronous | Asynchronous | +-- +------------+-----------+--------------+--------------+ +-- @ +-- +-- Other than these types there are also 'ZipSerial' and 'ZipAsync' types that +-- zip streams serially or concurrently using 'Applicative' operation. These +-- types are not monads they are only applicatives and they do not differ in +-- 'Semigroup' composition. +-- +-- All these types can be freely inter-converted using type conversion +-- combinators or type annotations without any cost, to acheive the desired +-- composition style. To force a particular type of composition we coerce the +-- stream type using the corresponding type adapting combinator from +-- 'serially', 'wSerially', 'asyncly', 'wAsyncly', 'parallely', 'zipSerially' +-- or 'zipAsyncly'. The default stream type is inferred as 'Serial' unless you +-- change it by using one of the combinators or using a type annotation. + +-- $monadtransformers +-- +-- To represent streams in an arbitrary monad use the more general monad +-- transformer types for example the monad transformer type corresponding to +-- the 'Serial' type is 'SerialT'. @SerialT m a@ represents a stream of values +-- of type 'a' in some underlying monad 'm'. For example, @SerialT IO Int@ is a +-- stream of 'Int' in 'IO' monad. In fact, the type 'Serial' is a synonym for +-- @SerialT IO@. +-- +-- Similarly we have monad transformer types for other stream types as well viz. +-- 'WSerialT', 'AsyncT', 'WAsyncT' and 'ParallelT'. +-- +-- To lift a value from an underlying monad in a monad transformer stack into a +-- singleton stream use 'lift' and to lift from an IO action use 'liftIO'. +-- +-- @ +-- > 'runStream' $ liftIO $ putStrLn "Hello world!" +-- Hello world! +-- > 'runStream' $ lift $ putStrLn "Hello world!" +-- Hello world! +-- @ +-- -- $generating -- --- Pure values can be placed into the stream type using 'return' or 'pure'. --- Effects in the IO monad can be lifted to the stream type using the 'liftIO' --- combinator. In a transformer stack we can lift actions from the lower monad --- using the 'lift' combinator. Some examples of streams with a single element: +-- We will assume the following imports in this tutorial. Go ahead, fire up a +-- GHCi session and import these lines to start playing. -- -- @ --- return 1 :: 'StreamT' IO Int +-- > import "Streamly" +-- > import "Streamly.Prelude" ((|:)) +-- > import qualified "Streamly.Prelude" as S -- @ +-- +-- 'nil' represents an empty stream and 'consM' or its operator form '|:' adds +-- a monadic action at the head of the stream. +-- -- @ --- liftIO $ putStrLn "Hello world!" :: 'StreamT' IO () +-- > S.'toList' S.'nil' +-- [] +-- > S.'toList' $ 'getLine' |: 'getLine' |: S.'nil' +-- hello +-- world +-- ["hello","world"] -- @ -- --- We can combine streams using '<>' to create streams of many elements: +-- To create a singleton stream from a pure value use 'pure' and to create a +-- singleton stream from a monadic action use 'once'. -- -- @ --- return 1 <> return 2 <> return 3 :: 'StreamT' IO Int +-- > S.'toList' $ 'pure' 1 +-- [1] +-- > S.'toList' $ S.'once' 'getLine' +-- hello +-- ["hello"] -- @ -- --- For more ways to construct or generate a stream see the module --- "Streamly.Prelude". +-- To create a stream from pure values in a 'Foldable' container use +-- 'fromFoldable' which is equivalent to a fold using 'cons' and 'nil': +-- +-- @ +-- > S.'toList' $ S.'fromFoldable' [1..3] +-- [1,2,3] +-- > S.'toList' $ 'Prelude.foldr' S.'cons' S.'nil' [1..3] +-- [1,2,3] +-- @ +-- +-- To create a stream from monadic actions in a 'Foldable' container just use a +-- right fold using 'consM' and 'nil': +-- +-- @ +-- > 'runStream' $ 'Prelude.foldr' ('|:') S.'nil' ['putStr' "Hello ", 'putStrLn' "world!"] +-- Hello world! +-- @ +-- +-- For more ways to construct a stream see the module "Streamly.Prelude". -- $eliminating -- --- 'runStreamT' runs a composed 'StreamT' computation, lowering the type into --- the underlying monad and discarding the result stream: +-- We have already seen 'runStream' and 'toList' to eliminate a stream in the +-- examples above. 'runStream' runs a stream discarding the results i.e. only +-- for effects. 'toList' runs the stream and collects the results in a list. -- --- @ --- import "Streamly" +-- For other ways to eliminate a stream see the @Folding@ section in +-- "Streamly.Prelude" module. + +-- $transformation +-- +-- Transformation over a stream is the equivalent of a @for@ loop construct in +-- imperative paradigm. We iterate over every element in the stream and perform +-- certain transformations for each element. Transformations may involve +-- mapping functions over the elements, filtering elements from the stream or +-- folding all the elements in the stream into a single value. Streamly streams +-- are exactly like lists and you can perform all the transformations in the +-- same way as you would on lists. +-- +-- Here is a simple console echo program that just echoes every input line, +-- forever: -- --- main = 'runStreamT' $ liftIO $ putStrLn "Hello world!" +-- @ +-- > 'runStream' $ S.'repeatM' getLine & S.'mapM' putStrLn -- @ -- --- 'toList' runs a stream computation and collects the result stream in a list --- in the underlying monad. 'toList' is a polymorphic function that works on --- multiple stream types belonging to the class 'Streaming'. Therefore, before --- you run a stream you need to tell how you want to interpret the stream by --- using one of the stream type combinators ('serially', 'asyncly', 'parallely' --- etc.). The combinator 'serially' is equivalent to annotating the type as @:: --- StreamT@. +-- The following code snippet reads lines from standard input, filters blank +-- lines, drops the first non-blank line, takes the next two, up cases them, +-- numbers them and prints them: -- -- @ -- import "Streamly" --- import "Streamly.Prelude" --- --- main = do --- xs \<- 'toList' $ 'serially' $ return 1 <> return 2 --- print xs +-- import qualified "Streamly.Prelude" as S +-- import Data.Char (toUpper) +-- import Data.Function ((&)) +-- +-- main = 'runStream' $ +-- S.'repeatM' getLine +-- & S.'filter' (not . null) +-- & S.'drop' 1 +-- & S.'take' 2 +-- & fmap (map toUpper) +-- & S.'zipWith' (\\n s -> show n ++ " " ++ s) (S.'fromFoldable' [1..]) +-- & S.'mapM' putStrLn -- @ --- --- For other ways to eliminate or fold a stream see the module --- "Streamly.Prelude". -- $semigroup --- Streams of the same type can be combined into a composite stream in many --- different ways using one of the semigroup style binary composition operators --- i.e. '<>', '<=>', '<|', '<|>', 'mplus'. These operators work on all stream --- types ('StreamT', 'AsyncT' etc.) uniformly. -- --- To illustrate the concurrent aspects, we will use the following @delay@ --- function to introduce a delay specified in seconds. +-- We can combine two streams into a single stream using semigroup composition +-- operation '<>'. Streams can be combined in many different ways as described +-- in the following sections, the '<>' operation behaves differently depending +-- on the stream type in effect. The stream type and therefore the composition +-- style can be changed at any point using one of the type combinators as +-- discussed earlier. + +-- $imports +-- +-- In most of example snippets we do not repeat the imports. Where imports are +-- not explicitly specified use the imports shown below. -- -- @ -- import "Streamly" +-- import "Streamly.Prelude" ((|:), nil) +-- import qualified "Streamly.Prelude" as S +-- -- import Control.Concurrent +-- import Control.Monad (forever) +-- @ +-- +-- To illustrate concurrent vs serial composition aspects, we will use the +-- following @delay@ function to introduce a sleep or delay specified in +-- seconds. After the delay it prints the number of seconds it slept. -- --- delay n = liftIO $ do +-- @ +-- delay n = S.'once' $ do -- threadDelay (n * 1000000) -- tid \<- myThreadId -- putStrLn (show tid ++ ": Delay " ++ show n) @@ -213,48 +390,159 @@ import Control.Monad.Trans.Class (MonadTrans (lift)) -- $serial -- --- We have already seen, the '<>' operator. It composes two streams in series --- i.e. the first stream is completely exhausted and then the second stream is --- processed. The following example prints the sequence 3, 2, 1 and takes a --- total of 6 seconds because everything is serial: +-- The 'Semigroup' operation '<>' of the 'Serial' type combines the two streams +-- in a /serial depth first/ manner. We use the 'serially' type combinator to +-- effect 'Serial' style of composition. We can also use an explicit 'Serial' +-- type annotation for the stream to acheive the same effect. However, since +-- 'Serial' is the default type unless explicitly specified by using a +-- combinator, we can omit using an explicit combinator or type annotation for +-- this style of composition. +-- +-- When two streams with multiple elements are combined in this manner, the +-- monadic actions in the two streams are performed sequentially i.e. first all +-- actions in the first stream are performed sequentially and then all actions +-- in the second stream are performed sequentially. We call it +-- /serial depth first/ as the full depth of one stream is fully traversed +-- before we move to the next. The following example prints the sequence 1, 2, +-- 3, 4: +-- +-- @ +-- main = 'runStream' $ (print 1 |: print 2 |: nil) <> (print 3 |: print 4 |: nil) +-- @ +-- @ +-- 1 +-- 2 +-- 3 +-- 4 +-- @ +-- +-- All actions in both the streams are performed serially in the same thread. +-- In the following example we can see that all actions are performed in the +-- same thread and take a combined total of @3 + 2 + 1 = 6@ seconds: -- -- @ --- main = 'runStreamT' $ delay 3 <> delay 2 <> delay 1 +-- main = 'runStream' $ delay 3 <> delay 2 <> delay 1 -- @ -- @ -- ThreadId 36: Delay 3 -- ThreadId 36: Delay 2 -- ThreadId 36: Delay 1 -- @ +-- +-- The polymorphic version of the binary operation '<>' of the 'Serial' type is +-- 'serial'. We can use 'serial' to join streams in a sequential manner +-- irrespective of the type of stream: +-- +-- @ +-- main = 'runStream' $ (print 1 |: print 2 |: nil) \`serial` (print 3 |: print 4 |: nil) +-- @ -- $interleaved --- The '<=>' operator is serial like '<>' but it interleaves the two streams --- i.e. it yields one element from the first stream and then one element from --- the second stream, and so on. The following example prints the sequence 1, --- 3, 2, 4 and takes a total of 10 seconds because everything is serial: +-- +-- The 'Semigroup' operation '<>' of the 'WSerial' type combines the two +-- streams in a /serial breadth first/ manner. We use the 'wSerially' type +-- combinator to effect 'WSerial' style of composition. We can also use the +-- 'WSerial' type annotation for the stream to acheive the same effect. +-- +-- When two streams with multiple elements are combined in this manner, we +-- traverse all the streams in a breadth first manner i.e. one action from each +-- stream is peformed and yielded to the resulting stream before we come back +-- to the first stream again and so on. +-- The following example prints the sequence 1, 3, 2, 4 -- -- @ --- main = 'runStreamT' $ (delay 1 <> delay 2) '<=>' (delay 3 <> delay 4) +-- main = 'runStream' . 'wSerially' $ (print 1 |: print 2 |: nil) <> (print 3 |: print 4 |: nil) +-- @ +-- @ +-- 1 +-- 3 +-- 2 +-- 4 +-- @ +-- +-- Even though the monadic actions of the two streams are performed in an +-- interleaved manner they are all performed serially in the same thread. In +-- the following example we can see that all actions are performed in the same +-- thread and take a combined total of @3 + 2 + 1 = 6@ seconds: +-- +-- @ +-- main = 'runStream' . 'wSerially' $ delay 3 <> delay 2 <> delay 1 -- @ -- @ --- ThreadId 36: Delay 1 -- ThreadId 36: Delay 3 -- ThreadId 36: Delay 2 --- ThreadId 36: Delay 4 +-- ThreadId 36: Delay 1 -- @ -- --- Note that this operator cannot be used to fold infinite containers since it --- requires preserving the state until a stream is finished. To be clear, it --- can combine infinite streams but not infinite number of streams. +-- The polymorphic version of the 'WSerial' binary operation '<>' is called +-- 'wSerial'. We can use 'wSerial' to join streams in an interleaved manner +-- irrespective of the type, notice that we have not used the 'wSerially' +-- combinator in the following example: +-- +-- @ +-- main = 'runStream' $ (print 1 |: print 2 |: nil) \`wSerial` (print 3 |: print 4 |: nil) +-- @ +-- @ +-- 1 +-- 3 +-- 2 +-- 4 +-- @ +-- +-- Note that this composition cannot be used to fold infinite number of streams +-- since it requires preserving the state until a stream is finished. --- $parallel +-- $async +-- +-- The 'Semigroup' operation '<>' of the 'Async' type combines the two +-- streams in a depth first manner with parallel look ahead. We use the +-- 'asyncly' type combinator to effect 'Async' style of composition. We +-- can also use the 'Async' type annotation for the stream type to acheive +-- the same effect. +-- +-- When two streams with multiple elements are combined in this manner, the +-- streams are traversed in depth first manner just like 'Serial', however it +-- can execute the next stream concurrently and return the results from it +-- as they arrive i.e. the results from the next stream may be yielded even +-- before the results from the first stream. Concurrent execution of the next +-- stream(s) is performed if the first stream blocks or if it cannot produce +-- output at the rate that is enough to meet the consumer demand. Multiple +-- streams can be executed concurrently to meet the demand. +-- In the following example the first stream does not block, +-- therefore the first stream is completely exhausted before the second. +-- +-- @ +-- main = 'runStream' . 'asyncly' $ (print 1 |: print 2 |: nil) <> (print 3 |: print 4 |: nil) +-- @ +-- @ +-- 1 +-- 2 +-- 3 +-- 4 +-- @ +-- +-- If the first stream blocks, we can yield from the second. In the example +-- below each yield in the stream has a constant delay of 1 second therefore 1 +-- and 3 would be yielded first and then 2 and 4 would be yielded. +-- +-- @ +-- main = 'runStream' . 'asyncly' $ (p 1 |: p 2 |: nil) <> (p 3 |: p 4 |: nil) +-- where p n = threadDelay 1000000 >> print n +-- @ +-- @ +-- 1 +-- 3 +-- 2 +-- 4 +-- @ -- --- The '<|' operator can run both computations concurrently, /when needed/. --- In the following example since the first computation blocks we start the --- next one in a separate thread and so on: +-- In the following example we can see that new threads are started when a +-- computation blocks. Notice that the output from the stream with the +-- shortest delay is printed first. The whole computation takes @maximum of +-- (3, 2, 1) = 3@ seconds: -- -- @ --- main = 'runStreamT' $ delay 3 '<|' delay 2 '<|' delay 1 +-- main = 'runStream' . 'asyncly' $ delay 3 '<>' delay 2 '<>' delay 1 -- @ -- @ -- ThreadId 42: Delay 1 @@ -262,14 +550,18 @@ import Control.Monad.Trans.Class (MonadTrans (lift)) -- ThreadId 40: Delay 3 -- @ -- --- This is the concurrent version of the '<>' operator. The computations are --- triggered in the same order as '<>' except that they are concurrent. When --- we have a tree of computations composed using this operator, the tree is --- traversed in DFS style just like '<>'. +-- When we have a tree of computations composed using this style, the tree is +-- traversed in DFS style just like the 'Serial' style, the only difference is +-- that here we can move on to executing the next stream if a stream blocks. +-- However, we will not start new threads if we have sufficient output to +-- saturate the consumer. This is why we call it left-biased demand driven or +-- adaptive concurrency style, the concurrency tends to stay on the left side +-- of the composition as long as possible. More threads are started based on +-- the pull rate of the consumer. The following example prints an output every +-- second as all of the actions are concurrent. -- -- @ --- main = 'runStreamT' $ (p 1 '<|' p 2) '<|' (p 3 '<|' p 4) --- where p = liftIO . print +-- main = 'runStream' . 'asyncly' $ (delay 1 <> delay 2) <> (delay 3 <> delay 4) -- @ -- @ -- 1 @@ -278,21 +570,16 @@ import Control.Monad.Trans.Class (MonadTrans (lift)) -- 4 -- @ -- --- Concurrency provided by this operator is demand driven. The second --- computation is run concurrently with the first only if the first computation --- is not producing enough output to keep the stream consumer busy otherwise --- the second computation is run serially after the previous one. The number of --- concurrent threads is adapted dynamically based on the pull rate of the --- consumer of the stream. --- As you can see, in the following example the computations are run in a --- single thread one after another, because none of them blocks. However, if --- the thread consuming the stream were faster than the producer then it would --- have started parallel threads for each computation to keep up even if none --- of them blocks: +-- All the computations may even run in a single thread when more threads are +-- not needed. As you can see, in the following example the computations are +-- run in a single thread one after another, because none of them blocks. +-- However, if the thread consuming the stream were faster than the producer +-- then it would have started parallel threads for each computation to keep up +-- even if none of them blocks: -- -- @ --- main = 'runStreamT' $ traced (sqrt 9) '<|' traced (sqrt 16) '<|' traced (sqrt 25) --- where traced m = liftIO (myThreadId >>= print) >> m +-- main = 'runStream' . 'asyncly' $ traced (sqrt 9) '<>' traced (sqrt 16) '<>' traced (sqrt 25) +-- where traced m = S.'once' (myThreadId >>= print) >> return m -- @ -- @ -- ThreadId 40 @@ -300,123 +587,229 @@ import Control.Monad.Trans.Class (MonadTrans (lift)) -- ThreadId 40 -- @ -- +-- Note that the order of printing in the above examples may change due to +-- variations in scheduling latencies for concurrent threads. +-- +-- The polymorphic version of the 'Async' binary operation '<>' is called +-- 'async'. We can use 'async' to join streams in a left biased +-- adaptively concurrent manner irrespective of the type, notice that we have +-- not used the 'asyncly' combinator in the following example: +-- +-- @ +-- main = 'runStream' $ delay 3 \`async` delay 2 \`async` delay 1 +-- @ +-- @ +-- ThreadId 42: Delay 1 +-- ThreadId 41: Delay 2 +-- ThreadId 40: Delay 3 +-- @ +-- -- Since the concurrency provided by this operator is demand driven it cannot --- be used when the composed computations have timers that are relative to each --- other because all computations may not be started at the same time and +-- be used when the composed computations start timers that are relative to +-- each other because all computations may not be started at the same time and -- therefore timers in all of them may not start at the same time. When -- relative timing among all computations is important or when we need to start --- all computations at once for some reason '<|>' must be used instead. --- However, '<|' is useful in situations when we want to optimally utilize the --- resources and we know that the computations can run in parallel but we do --- not care if they actually run in parallel or not, that decision is left to --- the scheduler. Also, note that this operator can be used to fold infinite --- containers in contrast to '<|>', because it does not require us to run all --- of them at the same time. +-- all computations at once for any reason 'Parallel' style must be used +-- instead. +-- +-- 'Async' style should be preferred over 'Parallel' or 'WAsync' unless you +-- really need those. It utilizes the resources optimally. It should be used +-- when we know that the computations can run in parallel but we do not care if +-- they actually run in parallel or not, that decision can be left to the +-- scheduler based on demand. Also, note that this operator can be used to fold +-- infinite number of streams in contrast to the 'Parallel' or 'WAsync' styles, +-- because it does not require us to run all of them at the same time in a fair +-- manner. + +-- $wasync +-- +-- The 'Semigroup' operation '<>' of the 'WAsync' type combines two streams in +-- a concurrent manner using /breadth first traversal/. We use the 'wAsyncly' +-- type combinator to effect 'WAsync' style of composition. We can also use the +-- 'WAsync' type annotation for the stream to acheive the same effect. +-- +-- When streams with multiple elements are combined in this manner, we traverse +-- all the streams concurrently in a breadth first manner i.e. one action from +-- each stream is peformed and yielded to the resulting stream before we come +-- back to the first stream again and so on. Even though we execute the actions +-- in a breadth first order the outputs may be consumed in a different order +-- because they are consumed on a first come first serve basis. +-- +-- In the following example we can see that outputs are produced in the breadth +-- first travresal order but this is not guaranteed. +-- +-- @ +-- main = 'runStream' . 'wAsyncly' $ (print 1 |: print 2 |: nil) <> (print 3 |: print 4 |: nil) +-- @ +-- @ +-- 1 +-- 3 +-- 2 +-- 4 +-- @ +-- +-- The polymorphic version of the binary operation '<>' of the 'WAsync' type is +-- 'wAsync'. We can use 'wAsync' to join streams using a breadth first +-- concurrent traversal irrespective of the type, notice that we have not used +-- the 'wAsyncly' combinator in the following example: +-- +-- @ +-- main = 'runStream' $ delay 3 \`wAsync` delay 2 \`wAsync` delay 1 +-- @ +-- @ +-- ThreadId 42: Delay 1 +-- ThreadId 41: Delay 2 +-- ThreadId 40: Delay 3 +-- @ +-- +-- Since the concurrency provided by this style is demand driven it may not +-- be used when the composed computations start timers that are relative to +-- each other because all computations may not be started at the same time and +-- therefore timers in all of them may not start at the same time. When +-- relative timing among all computations is important or when we need to start +-- all computations at once for any reason 'Parallel' style must be used +-- instead. -- --- The left bias (or the DFS style) of the operator '<|' is suggested by its --- shape. You can also think of this as an unbalanced version of the fairly --- parallel operator '<|>'. --- $fairParallel +-- $parallel +-- +-- The 'Semigroup' operation '<>' of the 'Parallel' type combines the two +-- streams in a fairly concurrent manner with round robin scheduling. We use +-- the 'parallely' type combinator to effect 'Parallel' style of composition. +-- We can also use the 'Parallel' type annotation for the stream type to +-- acheive the same effect. -- --- The 'Alternative' composition operator '<|>', like '<|', runs the composed --- computations concurrently. However, unlike '<|' it runs all of the --- computations in fairly parallel manner using a round robin scheduling --- mechanism. This can be considered as the concurrent version of the fairly --- interleaved serial operation '<=>'. Note that this cannot be used on --- infinite containers, as it will lead to an infinite sized scheduling queue. +-- When two streams with multiple elements are combined in this manner, the +-- monadic actions in both the streams are performed concurrently with a fair +-- round robin scheduling. The outputs are yielded in the order in which the +-- actions complete. This is pretty similar to the 'WAsync' type, the +-- difference is that 'WAsync' is adaptive to the consumer demand and may or +-- may not execute all actions in parallel depending on the demand, whereas +-- 'Parallel' runs all the streams in parallel irrespective of the demand. -- --- The following example sends a query to three search engines in parallel and --- prints the name of the search engine as a response arrives: +-- The following example sends a query to all the three search engines in +-- parallel and prints the name of the search engines in the order in which the +-- responses arrive: -- -- @ -- import "Streamly" +-- import qualified Streamly.Prelude as S -- import Network.HTTP.Simple -- --- main = 'runStreamT' $ google \<|> bing \<|> duckduckgo +-- main = 'runStream' . 'parallely' $ google \<> bing \<> duckduckgo -- where -- google = get "https://www.google.com/search?q=haskell" -- bing = get "https://www.bing.com/search?q=haskell" -- duckduckgo = get "https://www.duckduckgo.com/?q=haskell" --- get s = liftIO (httpNoBody (parseRequest_ s) >> putStrLn (show s)) +-- get s = S.'once' (httpNoBody (parseRequest_ s) >> putStrLn (show s)) +-- @ +-- +-- The polymorphic version of the binary operation '<>' of the 'Parallel' type +-- is 'parallel'. We can use 'parallel' to join streams in a fairly concurrent +-- manner irrespective of the type, notice that we have not used the +-- 'parallely' combinator in the following example: +-- +-- @ +-- main = 'runStream' $ delay 3 \`parallel` delay 2 \`wAsync` delay 1 +-- @ +-- @ +-- ThreadId 42: Delay 1 +-- ThreadId 41: Delay 2 +-- ThreadId 40: Delay 3 -- @ +-- +-- Note that this style of composition cannot be used to combine infinite +-- number of streams, as it will lead to an infinite sized scheduling queue. +-- -- $custom -- --- The 'async' API can be used to create references to asynchronously running +-- The 'mkAsync' API can be used to create references to asynchronously running -- stream computations. We can then use 'uncons' to explore the streams -- arbitrarily and then recompose individual elements to create a new stream. -- This way we can dynamically decide which stream to explore at any given -- time. Take an example of a merge sort of two sorted streams. We need to -- keep consuming items from the stream which has the lowest item in the sort -- order. This can be achieved using async references to streams. See --- "Streamly.Examples.MergeSortedStreams". +-- "MergeSort.hs" in the examples directory. -- $monoid -- --- Each of the semigroup compositions described has an identity that can be --- used to fold a possibly empty container. An empty stream is represented by --- 'nil' which can be represented in various standard forms as 'mempty', --- 'empty' or 'mzero'. --- Some fold utilities are also provided by the library for convenience: +-- We can use 'Monoid' instances to fold a container of streams in the desired +-- style using 'fold' or 'foldMap'. We have also provided some fold utilities +-- to fold streams using the polymorphic combine operations: -- --- * 'foldWith' folds a 'Foldable' container of stream computations using the --- given composition operator. --- * 'foldMapWith' folds like foldWith but also maps a function before folding. --- * 'forEachWith' is like foldMapwith but the container argument comes before +-- * 'foldWith' is like 'fold', it folds a 'Foldable' container of streams +-- using the given composition operator. +-- * 'foldMapWith' is like 'foldMap', it folds like @foldWith@ but also maps a +-- function before folding. +-- * 'forEachWith' is like @foldMapwith@ but the container argument comes before -- the function argument. --- * The 'each' primitive from "Streamly.Prelude" folds a 'Foldable' container --- using the '<>' operator: -- --- All of the following are equivalent: +-- All of the following are equivalent and start ten concurrent tasks each with +-- a delay from 1 to 10 seconds, resulting in the printing of each number every +-- second: -- -- @ -- import "Streamly" --- import "Streamly.Prelude" +-- import qualified "Streamly.Prelude" as S +-- import Control.Concurrent -- -- main = do --- 'toList' . 'serially' $ 'foldWith' (<>) (map return [1..10]) >>= print --- 'toList' . 'serially' $ 'foldMapWith' (<>) return [1..10] >>= print --- 'toList' . 'serially' $ 'forEachWith' (<>) [1..10] return >>= print --- 'toList' . 'serially' $ 'each' [1..10] >>= print +-- 'runStream' $ 'asyncly' $ foldMap delay [1..10] +-- 'runStream' $ 'foldWith' 'async' (map delay [1..10]) +-- 'runStream' $ 'foldMapWith' 'async' delay [1..10] +-- 'runStream' $ 'forEachWith' 'async' [1..10] delay +-- where delay n = S.'once' $ threadDelay (n * 1000000) >> print n -- @ --- $transforming +-- $nesting +-- +-- Till now we discussed ways to apply transformations on a stream or to merge +-- streams together to create another stream. We mentioned earlier that +-- transforming a stream is similar to a @for@ loop in the imperative paradigm. +-- We will now discuss the concept of a nested composition of streams which is +-- analogous to nested @for@ loops in the imperative paradigm. Functional +-- programmers call this style of composition a list transformer or @ListT@. +-- Logic programmers call it a logic monad or non-deterministic composition, +-- but for ordinary imperative minded people like me it is easier to think in +-- terms of good old nested @for@ loops. -- --- The previous section discussed ways to merge the elements of two streams --- without doing any transformation on them. In this section we will explore --- how to transform streams using 'Functor', 'Applicative' or 'Monad' style --- compositions. The applicative and monad composition of all 'Streaming' types --- behave exactly the same way as a list transformer. For simplicity of --- illustration we are using streams of pure values in the following examples. --- However, the real application of streams arises when these streams are --- generated using monadic actions. - -- $monad -- --- In functional programmer's parlance the 'Monad' instance of 'Streaming' --- types implement non-determinism, exploring all possible combination of --- choices from both the streams. From an imperative programmer's point of view --- it behaves like nested loops i.e. for each element in the first stream and --- for each element in the second stream apply the body of the loop. If you are --- familiar with list transformer this behavior is exactly the same as that of --- a list transformer. +-- In functional programmer's parlance the 'Monad' instances of different +-- 'IsStream' types implement non-determinism, exploring all possible +-- combination of choices from both the streams. From an imperative +-- programmer's point of view it behaves like nested loops i.e. for each +-- element in the first stream and for each element in the second stream +-- execute the body of the loop. +-- +-- The 'Monad' instances of 'Serial', 'WSerial', 'Async' and 'WAsync' +-- stream types support different flavors of nested looping. In other words, +-- they are all variants of list transformer. The nesting behavior of these +-- types correspond exactly to the way they merge streams as we discussed in +-- the previous section. -- --- Just like we saw in sum style compositions earlier, monadic composition also --- has multiple variants each of which exactly corresponds to one of the sum --- style composition variant. -- $regularSerial -- --- When we interpret the monadic composition as 'StreamT' we get a standard --- list transformer like serial composition. +-- The 'Monad' composition of the 'Serial' type behaves like a standard list +-- transformer. This is the default when we do not use an explicit type +-- combinator. However, the 'serially' type combinator can be used to switch to +-- this style of composition. We will see how this style of composition works +-- in the following examples. +-- +-- Let's start with an example with a simple @for@ loop without any nesting. +-- For simplicity of illustration we are using streams of pure values in all +-- the examples. However, the streams could also be made of monadic actions +-- instead. -- -- @ -- import "Streamly" --- import "Streamly.Prelude" +-- import qualified "Streamly.Prelude" as S -- --- main = 'runStreamT' $ do --- x <- 'each' [3,2,1] +-- main = 'runStream' $ do +-- x <- S.'fromFoldable' [3,2,1] -- delay x -- @ -- @ @@ -425,34 +818,34 @@ import Control.Monad.Trans.Class (MonadTrans (lift)) -- ThreadId 30: Delay 1 -- @ -- --- As you can see the code after the @each@ statement is run three times, once --- for each value of @x@. All the three iterations are serial and run in the --- same thread one after another. When compared to imperative programming, this --- can also be viewed as a @for@ loop with three iterations. +-- As we can see, the code after the @fromFoldable@ statement is run three +-- times, once for each value of @x@ drawn from the stream. All the three +-- iterations are serial and run in the same thread one after another. In +-- imperative terms this is equivalent to a @for@ loop with three iterations. -- -- A console echo loop copying standard input to standard output can simply be -- written like this: -- -- @ -- import "Streamly" --- import Data.Semigroup (cycle1) +-- import qualified "Streamly.Prelude" as S -- --- main = 'runStreamT' $ cycle1 (liftIO getLine) >>= liftIO . putStrLn +-- main = 'runStream' $ forever $ S.once getLine >>= S.once . putStrLn -- @ -- -- When multiple streams are composed using this style they nest in a DFS --- manner i.e. nested iterations of an iteration are executed before we proceed --- to the next iteration at higher level. This behaves just like nested @for@ +-- manner i.e. nested iterations of a loop are executed before we proceed to +-- the next iteration of the parent loop. This behaves just like nested @for@ -- loops in imperative programming. -- -- @ -- import "Streamly" --- import "Streamly.Prelude" +-- import qualified "Streamly.Prelude" as S -- --- main = 'runStreamT' $ do --- x <- 'each' [1,2] --- y <- 'each' [3,4] --- liftIO $ putStrLn $ show (x, y) +-- main = 'runStream' $ do +-- x <- S.'fromFoldable' [1,2] +-- y <- S.'fromFoldable' [3,4] +-- S.'once' $ putStrLn $ show (x, y) -- @ -- @ -- (1,3) @@ -461,24 +854,28 @@ import Control.Monad.Trans.Class (MonadTrans (lift)) -- (2,4) -- @ -- --- You will also notice that this is the monadic equivalent of the sum style --- composition using '<>'. +-- Notice that this is analogous to merging streams of type 'Serial' or merging +-- streams using 'serial'. -- $concurrentNesting -- --- When we interpret the monadic composition as 'AsyncT' we get a /concurrent/ --- list-transformer like composition. Multiple monadic continuations (or loop --- iterations) may be started concurrently. Concurrency is demand driven --- i.e. more concurrent iterations are started only if the previous iterations --- are not able to produce enough output for the consumer of the output stream. --- This is the concurrent version of 'StreamT'. +-- The 'Monad' composition of 'Async' type can perform the iterations of a +-- loop concurrently. Concurrency is demand driven i.e. more concurrent +-- iterations are started only if the previous iterations are not able to +-- produce enough output for the consumer of the output stream. This works +-- exactly the same way as the merging of two streams 'asyncly' works. +-- This is the concurrent analogue of 'Serial' style monadic composition. +-- +-- The 'asyncly' type combinator can be used to switch to this style of +-- composition. Alternatively, a type annotation can be used to specify the +-- type of the stream as 'Async'. -- -- @ -- import "Streamly" -- import "Streamly.Prelude" -- --- main = 'runAsyncT' $ do --- x <- 'each' [3,2,1] +-- main = 'runStream' . 'asyncly' $ do +-- x <- S.'fromFoldable' [3,2,1] -- delay x -- @ -- @ @@ -487,27 +884,27 @@ import Control.Monad.Trans.Class (MonadTrans (lift)) -- ThreadId 38: Delay 3 -- @ -- --- As you can see the code after the @each@ statement is run three times, once --- for each value of @x@. All the three iterations are concurrent and run in --- different threads. The iteration with least delay finishes first. When --- compared to imperative programming, this can be viewed as a @for@ loop +-- As we can see the code after the @fromFoldable@ statement is run three +-- times, once for each value of @x@. All the three iterations are concurrent +-- and run in different threads. The iteration with least delay finishes first. +-- When compared to imperative programming, this can be viewed as a @for@ loop -- with three concurrent iterations. -- --- Concurrency is demand driven just as in the case of '<|'. When multiple --- streams are composed using this style the iterations are triggered in a DFS --- manner just like 'StreamT' i.e. nested iterations are executed before we --- proceed to the next iteration at higher level. However, unlike 'StreamT' --- more than one iterations may be started concurrently, and based on the --- demand from the consumer. +-- Concurrency is demand driven just as in the case of 'async' merging. +-- When multiple streams are composed using this style, the iterations are +-- triggered in a depth first manner just like 'Serial' i.e. nested iterations are +-- executed before we proceed to the next iteration at higher level. However, +-- unlike 'Serial' more than one iterations may be started concurrently based +-- on the demand from the consumer of the stream. -- -- @ -- import "Streamly" --- import "Streamly.Prelude" +-- import qualified "Streamly.Prelude" as S -- --- main = 'runAsyncT' $ do --- x <- 'each' [1,2] --- y <- 'each' [3,4] --- liftIO $ putStrLn $ show (x, y) +-- main = 'runStream' . 'asyncly' $ do +-- x <- S.'fromFoldable' [1,2] +-- y <- S.'fromFoldable' [3,4] +-- S.'once' $ putStrLn $ show (x, y) -- @ -- @ -- (1,3) @@ -515,25 +912,24 @@ import Control.Monad.Trans.Class (MonadTrans (lift)) -- (2,3) -- (2,4) -- @ --- --- You will notice that this is the monadic equivalent of the '<|' style --- sum composition. The same caveats apply to this as the '<|' operation. -- $interleavedNesting -- --- When we interpret the monadic composition as 'InterleavedT' we get a serial --- but fairly interleaved list-transformer like composition. The monadic --- continuations or iterations of the outer loop are fairly interleaved with --- the continuations or iterations of the inner loop. +-- The 'Monad' composition of 'WSerial' type interleaves the iterations of +-- outer and inner loops in a nested loop composition. This works exactly the +-- same way as the merging of two streams in 'wSerially' fashion works. The +-- 'wSerially' type combinator can be used to switch to this style of +-- composition. Alternatively, a type annotation can be used to specify the +-- type of the stream as 'WSerial'. -- -- @ -- import "Streamly" --- import "Streamly.Prelude" +-- import qualified "Streamly.Prelude" as S -- --- main = 'runInterleavedT' $ do --- x <- 'each' [1,2] --- y <- 'each' [3,4] --- liftIO $ putStrLn $ show (x, y) +-- main = 'runStream' . 'wSerially' $ do +-- x <- S.'fromFoldable' [1,2] +-- y <- S.'fromFoldable' [3,4] +-- S.once $ putStrLn $ show (x, y) -- @ -- @ -- (1,3) @@ -542,22 +938,50 @@ import Control.Monad.Trans.Class (MonadTrans (lift)) -- (2,4) -- @ -- --- You will notice that this is the monadic equivalent of the '<=>' style --- sum composition. The same caveats apply to this as the '<=>' operation. --- $fairlyConcurrentNesting +-- $wasyncNesting -- --- When we interpret the monadic composition as 'ParallelT' we get a --- /concurrent/ list-transformer like composition just like 'AsyncT'. The --- difference is that this is fully parallel with all iterations starting --- concurrently instead of the demand driven concurrency of 'AsyncT'. +-- Just like 'Async' the 'Monad' composition of 'WAsync' runs the iterations of +-- a loop concurrently. The difference is in the nested loop behavior. The +-- nested loops in this type are traversed and executed in a breadth first +-- manner rather than the depth first manner of 'Async' style. +-- The loop nesting works exactly the same way as the merging of streams +-- 'wAsyncly' works. The 'wAsyncly' type combinator can be used to switch to +-- this style of composition. Alternatively, a type annotation can be used to +-- specify the type of the stream as 'WAsync'. -- -- @ -- import "Streamly" --- import "Streamly.Prelude" +-- import qualified "Streamly.Prelude" as S +-- +-- main = 'runStream' . 'wAsyncly' $ do +-- x <- S.'fromFoldable' [1,2] +-- y <- S.'fromFoldable' [3,4] +-- S.'once' $ putStrLn $ show (x, y) +-- @ +-- @ +-- (1,3) +-- (2,3) +-- (1,4) +-- (2,4) +-- @ + +-- $parallelNesting +-- +-- Just like 'Async' or 'WAsync' the 'Monad' composition of 'Parallel' runs the +-- iterations of a loop concurrently. The difference is in the nested loop +-- behavior. The streams at each nest level is run fully concurrently +-- irrespective of the demand. The loop nesting works exactly the same way as +-- the merging of streams 'parallely' works. The 'parallely' type combinator +-- can be used to switch to this style of composition. Alternatively, a type +-- annotation can be used to specify the type of the stream as 'Parallel'. +-- +-- @ +-- import "Streamly" +-- import qualified "Streamly.Prelude" as S -- --- main = 'runParallelT' $ do --- x <- 'each' [3,2,1] +-- main = 'runStream' . 'parallely' $ do +-- x <- S.'fromFoldable' [3,2,1] -- delay x -- @ -- @ @@ -565,53 +989,40 @@ import Control.Monad.Trans.Class (MonadTrans (lift)) -- ThreadId 39: Delay 2 -- ThreadId 38: Delay 3 -- @ --- --- You will notice that this is the monadic equivalent of the '<|>' style --- sum composition. The same caveats apply to this as the '<|>' operation. -- $monadExercise -- --- The streamly code is usually written in a way that is agnostic of the +-- Streamly code is usually written in a way that is agnostic of the -- specific monadic composition type. We use a polymorphic type with a --- 'Streaming' type class constraint. When running the stream we can choose the --- specific mode of composition. For example look at the following code. +-- 'IsStream' type class constraint. When running the stream we can choose the +-- specific mode of composition. For example take a look at the following code. -- -- @ -- import "Streamly" --- import "Streamly.Prelude" +-- import qualified "Streamly.Prelude" as S -- --- --- composed :: 'Streaming' t => t m a +-- composed :: (IsStream t, Monad (t IO)) => t IO () -- composed = do -- sz <- sizes -- cl <- colors -- sh <- shapes --- liftIO $ putStrLn $ show (sz, cl, sh) +-- S.'once' $ putStrLn $ show (sz, cl, sh) -- -- where -- --- sizes = 'each' [1, 2, 3] --- colors = 'each' ["red", "green", "blue"] --- shapes = 'each' ["triangle", "square", "circle"] +-- sizes = S.'fromFoldable' [1, 2, 3] +-- colors = S.'fromFoldable' ["red", "green", "blue"] +-- shapes = S.'fromFoldable' ["triangle", "square", "circle"] -- @ -- -- Now we can interpret this in whatever way we want: -- -- @ --- main = 'runStreamT' composed --- main = 'runAsyncT' composed --- main = 'runInterleavedT' composed --- main = 'runParallelT' composed --- @ --- --- Equivalently, we can also write it using the type adapter combinators, like --- this: --- --- @ --- main = 'runStreaming' $ 'serially' $ composed --- main = 'runStreaming' $ 'asyncly' $ composed --- main = 'runStreaming' $ 'interleaving' $ composed --- main = 'runStreaming' $ 'parallely' $ composed +-- main = 'runStream' . 'serially' $ composed +-- main = 'runStream' . 'wSerially' $ composed +-- main = 'runStream' . 'asyncly' $ composed +-- main = 'runStream' . 'wAsyncly' $ composed +-- main = 'runStream' . 'parallely' $ composed -- @ -- -- As an exercise try to figure out the output of this code for each mode of @@ -620,15 +1031,14 @@ import Control.Monad.Trans.Class (MonadTrans (lift)) -- $functor -- -- 'fmap' transforms a stream by mapping a function on all elements of the --- stream. The functor instance of each stream type defines 'fmap' to be --- precisely the same as 'liftM', and therefore 'fmap' is always serial --- irrespective of the type. For concurrent mapping, alternative versions of --- 'fmap', namely, 'asyncMap' and 'parMap' are provided. +-- stream. 'fmap' behaves in the same way for all stream types, it is always +-- serial. -- -- @ -- import "Streamly" +-- import qualified "Streamly.Prelude" as S -- --- main = ('toList' $ 'serially' $ fmap show $ 'each' [1..10]) >>= print +-- main = (S.'toList' $ fmap show $ S.'fromFoldable' [1..10]) >>= print -- @ -- -- Also see the 'mapM' and 'sequence' functions for mapping actions, in the @@ -637,22 +1047,22 @@ import Control.Monad.Trans.Class (MonadTrans (lift)) -- $applicative -- -- Applicative is precisely the same as the 'ap' operation of 'Monad'. For --- zipping and parallel applicatives separate types 'ZipStream' and 'ZipAsync' --- are provided. +-- zipping applicatives separate types 'ZipSerial' and 'ZipAsync' are +-- provided. -- --- The following example runs all iterations serially and takes a total 17 --- seconds (1 + 3 + 4 + 2 + 3 + 4): +-- The following example uses the 'Serial' applicative, it runs all iterations +-- serially and takes a total 17 seconds (1 + 3 + 4 + 2 + 3 + 4): -- -- @ -- import "Streamly" --- import "Streamly.Prelude" +-- import qualified "Streamly.Prelude" as S -- import Control.Concurrent -- -- s1 = d 1 <> d 2 -- s2 = d 3 <> d 4 -- d n = delay n >> return n -- --- main = ('toList' . 'serially' $ (,) \<$> s1 \<*> s2) >>= print +-- main = (S.'toList' . 'serially' $ (,) \<$> s1 \<*> s2) >>= print -- @ -- @ -- ThreadId 36: Delay 1 @@ -664,11 +1074,11 @@ import Control.Monad.Trans.Class (MonadTrans (lift)) -- [(1,3),(1,4),(2,3),(2,4)] -- @ -- --- Similalrly interleaving runs the iterations in an interleaved order but --- since it is serial it takes a total of 17 seconds: +-- Similalrly 'WSerial' applicative runs the iterations in an interleaved +-- order but since it is serial it takes a total of 17 seconds: -- -- @ --- main = ('toList' . 'interleaving' $ (,) \<$> s1 \<*> s2) >>= print +-- main = (S.'toList' . 'wSerially' $ (,) \<$> s1 \<*> s2) >>= print -- @ -- @ -- ThreadId 36: Delay 1 @@ -680,11 +1090,11 @@ import Control.Monad.Trans.Class (MonadTrans (lift)) -- [(1,3),(2,3),(1,4),(2,4)] -- @ -- --- 'AsyncT' can run the iterations concurrently and therefore takes a total +-- 'Async' can run the iterations concurrently and therefore takes a total -- of 10 seconds (1 + 2 + 3 + 4): -- -- @ --- main = ('toList' . 'asyncly' $ (,) \<$> s1 \<*> s2) >>= print +-- main = (S.'toList' . 'asyncly' $ (,) \<$> s1 \<*> s2) >>= print -- @ -- @ -- ThreadId 34: Delay 1 @@ -696,11 +1106,11 @@ import Control.Monad.Trans.Class (MonadTrans (lift)) -- [(1,3),(2,3),(1,4),(2,4)] -- @ -- --- Similalrly 'ParallelT' as well can run the iterations concurrently and +-- Similalrly 'WAsync' as well can run the iterations concurrently and -- therefore takes a total of 10 seconds (1 + 2 + 3 + 4): -- -- @ --- main = ('toList' . 'parallely' $ (,) \<$> s1 \<*> s2) >>= print +-- main = (S.'toList' . 'wAsyncly' $ (,) \<$> s1 \<*> s2) >>= print -- @ -- @ -- ThreadId 34: Delay 1 @@ -712,48 +1122,31 @@ import Control.Monad.Trans.Class (MonadTrans (lift)) -- [(1,3),(2,3),(1,4),(2,4)] -- @ --- $compositionSummary --- --- The following table summarizes the types for monadic compositions and the --- operators for sum style compositions. This table captures the essence of --- streamly. --- --- @ --- +-----+--------------+------------+ --- | | Serial | Concurrent | --- +=====+==============+============+ --- | DFS | 'StreamT' | 'AsyncT' | --- | +--------------+------------+ --- | | '<>' | '<|' | --- +-----+--------------+------------+ --- | BFS | 'InterleavedT' | 'ParallelT' | --- | +--------------+------------+ --- | | '<=>' | '<|>' | --- +-----+--------------+------------+ --- @ - -- $zipping -- -- Zipping is a special transformation where the corresponding elements of two -- streams are combined together using a zip function producing a new stream of -- outputs. Two different types are provided for serial and concurrent zipping. --- These types provide an applicative instance that zips the argument streams. --- Also see the zipping function in the "Streamly.Prelude" module. +-- These types provide an applicative instance that can be used to lift +-- functions to zip the argument streams. +-- Also see the zipping functions in the "Streamly.Prelude" module. -- $serialzip -- --- 'ZipStream' zips streams serially: +-- The applicative instance of 'ZipSerial' type zips streams serially. +-- 'zipSerially' type combinator can be used to switch to serial applicative +-- zip composition: -- -- @ -- import "Streamly" --- import "Streamly.Prelude" +-- import qualified "Streamly.Prelude" as S -- import Control.Concurrent -- -- d n = delay n >> return n --- s1 = 'adapt' . 'serially' $ d 1 <> d 2 --- s2 = 'adapt' . 'serially' $ d 3 <> d 4 +-- s1 = 'serially' $ d 1 <> d 2 +-- s2 = 'serially' $ d 3 <> d 4 -- --- main = ('toList' . 'zipping' $ (,) \<$> s1 \<*> s2) >>= print +-- main = (S.'toList' . 'zipSerially' $ (,) \<$> s1 \<*> s2) >>= print -- @ -- -- This takes total 10 seconds to zip, which is (1 + 2 + 3 + 4) since @@ -769,21 +1162,24 @@ import Control.Monad.Trans.Class (MonadTrans (lift)) -- $parallelzip -- --- 'ZipAsync' zips streams concurrently: +-- The applicative instance of 'ZipAsync' type zips streams concurrently. +-- 'zipAsyncly' type combinator can be used to switch to parallel applicative +-- zip composition: +-- -- -- @ -- import "Streamly" --- import "Streamly.Prelude" +-- import qualified "Streamly.Prelude" as S -- import Control.Concurrent -- import System.IO (stdout, hSetBuffering, BufferMode(LineBuffering)) -- -- d n = delay n >> return n --- s1 = 'adapt' . 'serially' $ d 1 <> d 2 --- s2 = 'adapt' . 'serially' $ d 3 <> d 4 +-- s1 = 'serially' $ d 1 <> d 2 +-- s2 = 'serially' $ d 3 <> d 4 -- -- main = do --- liftIO $ hSetBuffering stdout LineBuffering --- ('toList' . 'zippingAsync' $ (,) \<$> s1 \<*> s2) >>= print +-- hSetBuffering stdout LineBuffering +-- (S.'toList' . 'zipAsyncly' $ (,) \<$> s1 \<*> s2) >>= print -- @ -- -- This takes 7 seconds to zip, which is max (1,3) + max (2,4) because 1 and 3 @@ -800,41 +1196,42 @@ import Control.Monad.Trans.Class (MonadTrans (lift)) -- $concurrent -- -- When writing concurrent programs there are two distinct places where the --- programmer chooses the type of concurrency. First, when /generating/ a --- stream by combining other streams we can use one of the sum style operators --- to combine them concurrently or serially. Second, when /processing/ a stream --- in a monadic composition we can choose one of the monad composition types to +-- programmer can control the concurrency. First, when /composing/ a stream by +-- merging multiple streams we can choose an appropriate sum style operators to +-- combine them concurrently or serially. Second, when /processing/ a stream in +-- a monadic composition we can choose one of the monad composition types to -- choose the desired type of concurrency. -- -- In the following example the squares of @x@ and @y@ are computed --- concurrently using the '<|' operator and the square roots of their sum are --- also computed concurrently by using the 'asyncly' combinator. We can choose --- different combinators e.g. '<>' and 'serially', to control the concurrency. +-- concurrently using the 'async' operation and the square roots of their +-- sum are computed serially because of the 'streamly' combinator. We can +-- choose different combinators for the monadic processing and the stream +-- generation, to control the concurrency. We can also use the 'asyncly' +-- combinator instead of explicitly folding with 'async'. -- -- @ -- import "Streamly" --- import "Streamly.Prelude" (toList) +-- import qualified "Streamly.Prelude" as S -- import Data.List (sum) -- -- main = do --- z \<- 'toList' --- $ 'asyncly' -- Concurrent monadic processing (sqrt below) +-- z \<- S.'toList' +-- $ 'serially' -- Serial monadic processing (sqrt below) -- $ do --- x2 \<- 'forEachWith' ('<|') [1..100] $ -- Concurrent @"for"@ loop +-- x2 \<- 'forEachWith' 'async' [1..100] $ -- Concurrent @"for"@ loop -- \\x -> return $ x * x -- body of the loop --- y2 \<- 'forEachWith' ('<|') [1..100] $ +-- y2 \<- 'forEachWith' 'async' [1..100] $ -- \\y -> return $ y * y -- return $ sqrt (x2 + y2) -- print $ sum z -- @ -- --- You can see how this directly maps to the imperative style +-- We can see how this directly maps to the imperative style -- <https://en.wikipedia.org/wiki/OpenMP OpenMP> model, we use combinators -- and operators instead of the ugly pragmas. -- -- For more concurrent programming examples see, --- "Streamly.Examples.ListDirRecursive", "Streamly.Examples.MergeSortedStreams" --- and "Streamly.Examples.SearchEngineQuery". +-- "ListDir.hs", "MergeSort.hs" and "SearchQuery.hs" in the examples directory. -- $reactive -- @@ -847,12 +1244,11 @@ import Control.Monad.Trans.Class (MonadTrans (lift)) -- (active hyperlinks are the streamly APIs) and yet it is a reactive -- application. -- --- -- This application has two independent and concurrent sources of event -- streams, @acidRain@ and @userAction@. @acidRain@ continuously generates --- events that deteriorate the health of the game character. @userAction@ can --- be "potion" or "quit". When the user types "potion" the health improves and --- the game continues. +-- events that deteriorate the health of the character in the game. +-- @userAction@ can be "potion" or "quit". When the user types "potion" the +-- health improves and the game continues. -- -- @ -- {-\# LANGUAGE FlexibleContexts #-} @@ -860,12 +1256,13 @@ import Control.Monad.Trans.Class (MonadTrans (lift)) -- import "Streamly" -- import Control.Concurrent (threadDelay) -- import Control.Monad (when) --- import Control.Monad.State +-- import Control.Monad.IO.Class (MonadIO(..)) +-- import Control.Monad.State (MonadState, get, modify, runStateT) -- import Data.Semigroup (cycle1) -- -- data Event = Harm Int | Heal Int | Quit deriving (Show) -- --- userAction :: MonadIO m => 'StreamT' m Event +-- userAction :: MonadIO m => 'SerialT' m Event -- userAction = cycle1 $ liftIO askUser -- where -- askUser = do @@ -875,12 +1272,12 @@ import Control.Monad.Trans.Class (MonadTrans (lift)) -- "quit" -> return Quit -- _ -> putStrLn "What?" >> askUser -- --- acidRain :: MonadIO m => 'StreamT' m Event +-- acidRain :: MonadIO m => 'SerialT' m Event -- acidRain = cycle1 $ liftIO (threadDelay 1000000) >> return (Harm 1) -- --- game :: ('MonadAsync' m, MonadState Int m) => 'StreamT' m () +-- game :: ('MonadAsync' m, MonadState Int m) => 'SerialT' m () -- game = do --- event \<- userAction \<|> acidRain +-- event \<- userAction \`parallel` acidRain -- case event of -- Harm n -> modify $ \\h -> h - n -- Heal n -> modify $ \\h -> h + n @@ -893,12 +1290,12 @@ import Control.Monad.Trans.Class (MonadTrans (lift)) -- main = do -- putStrLn "Your health is deteriorating due to acid rain,\\ -- \\ type \\"potion\\" or \\"quit\\"" --- _ <- runStateT ('runStreamT' game) 60 +-- _ <- runStateT ('runStream' game) 60 -- return () -- @ -- --- You can also find the source of this example in --- "Streamly.Examples.AcidRainGame". It has been adapted from Gabriel's +-- You can also find the source of this example in the examples directory as +-- "AcidRain.hs". It has been adapted from Gabriel's -- <https://hackage.haskell.org/package/pipes-concurrency-2.0.8/docs/Pipes-Concurrent-Tutorial.html pipes-concurrency> -- package. -- This is much simpler compared to the pipes version because of the builtin @@ -913,87 +1310,132 @@ import Control.Monad.Trans.Class (MonadTrans (lift)) -- package which is specifically and carefully designed to measure the -- performance of Haskell streaming libraries fairly and squarely in the right -- way. Streamly performs at par or even better than most streaming libraries --- for common operations even though it needs to deal with the concurrency +-- for serial operations even though it needs to deal with the concurrency -- capability. -- $interop -- -- We can use @unfoldr@ and @uncons@ to convert one streaming type to another. --- We will assume the following common code to be available in the examples --- demonstrated below. +-- +-- Interop with @vector@: -- -- @ --- import "Streamly" --- import "Streamly.Prelude" --- import System.IO (stdin) +-- import Streamly +-- import qualified Streamly.Prelude as S +-- import qualified Data.Vector.Fusion.Stream.Monadic as V +-- +-- main = do +-- -- streamly to vector +-- V.toList (V.unfoldrM S.uncons (S.fromFoldable [1..3])) >>= print +-- +-- -- vector to streamly +-- S.toList (S.unfoldrM unconsV (V.fromList [1..3])) >>= print -- --- -- Adapt uncons to return an Either instead of Maybe --- unconsE s = 'uncons' s >>= maybe (return $ Left ()) (return . Right) --- stdinLn = 'serially' $ 'fromHandle' stdin +-- where +-- unconsV v = do +-- r <- V.null v +-- if r +-- then return Nothing +-- else do +-- h <- V.head v +-- return $ Just (h, V.tail v) -- @ -- -- Interop with @pipes@: -- -- @ +-- import "Streamly" +-- import qualified "Streamly.Prelude" as S -- import qualified Pipes as P -- import qualified Pipes.Prelude as P -- -- main = do -- -- streamly to pipe --- P.runEffect $ P.for (P.unfoldr unconsE stdinLn) (lift . putStrLn) +-- P.toListM (P.unfoldr unconsS (S.'fromFoldable' [1..3])) >>= print -- -- -- pipe to streamly +-- S.'toList' (S.'unfoldrM' unconsP (P.each [1..3])) >>= print +-- +-- where -- -- Adapt P.next to return a Maybe instead of Either --- let nextM p = P.next p >>= either (\\_ -> return Nothing) (return . Just) --- 'runStreamT' $ 'unfoldrM' nextM P.stdinLn >>= lift . putStrLn +-- unconsP p = P.next p >>= either (\\_ -> return Nothing) (return . Just) +-- +-- -- Adapt S.uncons to return an Either instead of Maybe +-- unconsS s = S.'uncons' s >>= maybe (return $ Left ()) (return . Right) -- @ -- -- Interop with @streaming@: -- -- @ --- import qualified Streaming as S --- import qualified Streaming.Prelude as S +-- import "Streamly" +-- import qualified "Streamly.Prelude" as S +-- import qualified Streaming as SG +-- import qualified Streaming.Prelude as SG -- -- main = do -- -- streamly to streaming --- S.stdoutLn $ S.unfoldr unconsE stdinLn +-- SG.toList (SG.unfoldr unconsS (S.'fromFoldable' [1..3])) >>= print -- -- -- streaming to streamly --- 'runStreamT' $ unfoldrM S.uncons S.stdinLn >>= lift . putStrLn +-- S.'toList' (S.unfoldrM SG.uncons (SG.each [1..3])) >>= print -- +-- where +-- +-- -- Adapt S.uncons to return an Either instead of Maybe +-- unconsS s = S.'uncons' s >>= maybe (return $ Left ()) (return . Right) -- @ -- -- Interop with @conduit@: -- -- @ +-- import "Streamly" +-- import qualified "Streamly.Prelude" as S -- import qualified Data.Conduit as C -- import qualified Data.Conduit.List as C -- import qualified Data.Conduit.Combinators as C -- --- -- streamly to conduit --- main = (C.unfoldM 'uncons' stdinLn) C.$$ C.print +-- main = do +-- -- streamly to conduit +-- C.runConduit (C.unfoldM S.'uncons' (S.'fromFoldable' [1..3]) C..| C.sinkList) >>= print +-- +-- -- It seems there is no way out of a conduit as it does not provide an +-- -- uncons or a tail function. -- @ -- $comparison -- --- Streamly unifies non-determinism, streaming, concurrency and FRP --- functionality that is otherwise covered by several disparate packages, and --- it does that with a surprisingly concise API. Here is a list of popular and --- well-known packages in all these areas: +-- List transformers and logic programming monads also provide a product style +-- composition similar to streamly, however streamly generalizes it with the +-- time dimension; allowing streams to be composed in an asynchronous and +-- concurrent fashion in many different ways. It also provides multiple +-- alternative ways of composing streams e.g. serial, interleaved or +-- concurrent. +-- +-- This seemingly simple addition of asynchronicity and concurrency to product +-- style streaming composition unifies a number of disparate abstractions into +-- one powerful, concise and elegant abstraction. A wide variety of +-- programming problems can be solved elegantly with this abstraction. In +-- particular, it unifies three major programming domains namely +-- non-deterministic (logic) programming, concurrent programming and functional +-- reactive programming. In other words, you can do everything with this one +-- abstraction that you could do with the popular libraries listed under these +-- categories in the list below. -- -- @ -- +-----------------+----------------+ --- | Non-determinism | <https://hackage.haskell.org/package/list-t list-t> | +-- | Non-determinism | <https://hackage.haskell.org/package/pipes pipes> | +-- | +----------------+ +-- | | <https://hackage.haskell.org/package/list-t list-t> | -- | +----------------+ -- | | <https://hackage.haskell.org/package/logict logict> | -- +-----------------+----------------+ --- | Streaming | <https://hackage.haskell.org/package/streaming streaming> | +-- | Streaming | <https://hackage.haskell.org/package/vector vector> | -- | +----------------+ --- | | <https://hackage.haskell.org/package/conduit conduit> | +-- | | <https://hackage.haskell.org/package/streaming streaming> | -- | +----------------+ -- | | <https://hackage.haskell.org/package/pipes pipes> | -- | +----------------+ --- | | <https://hackage.haskell.org/package/simple-conduit simple-conduit> | +-- | | <https://hackage.haskell.org/package/conduit conduit> | -- +-----------------+----------------+ -- | Concurrency | <https://hackage.haskell.org/package/async async> | -- | +----------------+ @@ -1007,31 +1449,30 @@ import Control.Monad.Trans.Class (MonadTrans (lift)) -- +-----------------+----------------+ -- @ -- --- Streamly covers all the functionality provided by both the non-determinism --- packages listed above and provides better performance in comparison to --- those. In fact, at the core streamly is a list transformer but it naturally --- integrates the concurrency dimension to the basic list transformer --- functionality. +-- Streamly is a list-transformer. It provides all the functionality provided +-- by any of the list transformer and logic programming packages listed above. +-- In addition, Streamly naturally integrates the concurrency dimension to the +-- basic list transformer functionality. -- --- When it comes to streaming, in terms of core concepts, @simple-conduit@ is --- the package that is closest to streamly if we set aside the concurrency --- dimension, both are streaming packages with list transformer like monad --- composition. However, in terms of API @streamly@ is more like the @streaming@ --- package. Streamly can be used to achieve more or less the functionality --- provided by any of the streaming packages listed above. The types and API of --- streamly are much simpler in comparison to conduit and pipes. It is more or --- less like the standard Haskell list APIs. +-- When it comes to streaming, in terms of the streaming API streamly is almost +-- identical to the vector package. Streamly, vector and streaming packages all +-- represent a stream as data and are therefore similar in the fundamental +-- approach to streaming. The fundamental difference is that streamly adds +-- concurrency support and the monad instance provides concurrent looping. +-- Other streaming libraries like pipes, conduit and machines represent and +-- compose stream processors rather than the stream data and therefore fall in +-- another class of streaming libraries and have comparatively more complicated +-- types. -- -- When it comes to concurrency, streamly can do everything that the @async@ -- package can do and more. async provides applicative concurrency whereas --- streamly provides both applicative and monadic concurrency. The 'ZipAsync' --- type behaves like the applicative instance of async. This work was --- originally inspired by the concurrency implementation in @transient@ though --- it has no resemblence with that. Streamly provides concurrency as transient --- does but in a sort of dual manner, it can lazily stream the output. In +-- streamly provides both applicative and monadic concurrency. The +-- 'ZipAsync' type behaves like the applicative instance of async. In -- comparison to transient streamly has a first class streaming interface and -- is a monad transformer that can be used universally in any Haskell monad --- transformer stack. +-- transformer stack. Streamly was in fact originally inspired by the +-- concurrency implementation in @transient@ though it has no resemblence with +-- that and takes a lazy pull approach versus transient's strict push approach. -- -- The non-determinism, concurrency and streaming combination make streamly a -- strong FRP capable library as well. FRP is fundamentally stream of events @@ -1041,3 +1482,10 @@ import Control.Monad.Trans.Class (MonadTrans (lift)) -- similar to @dunai@. dunai was designed from a FRP perspective and streamly -- was originally designed from a concurrency perspective. However, both have -- similarity at the core. + +-- $furtherReading +-- +-- * Read the documentation of "Streamly" module +-- * Read the documentation of "Streamly.Prelude" module +-- * See the examples in the "examples" directory of the package +-- * See the tests in the "test" directory of the package diff --git a/stack-7.10.yaml b/stack-7.10.yaml index b8e2d6a..323d136 100644 --- a/stack-7.10.yaml +++ b/stack-7.10.yaml @@ -9,6 +9,8 @@ extra-deps: - http-client-0.5.0 - http-client-tls-0.3.0 - SDL-0.6.5.1 + - gauge-0.2.1 + - basement-0.0.7 flags: {} extra-package-dbs: [] # For mac ports installed SDL library on Mac OS X @@ -1,12 +1,32 @@ resolver: lts-11.0 packages: - '.' +#- location: ../bench-graph +# extra-dep: true extra-deps: - simple-conduit-0.6.0 - SDL-0.6.5.1 + + - git: https://github.com/composewell/bench-graph + commit: b6d6c69f76c0d951aecd257866cede9467bd166d + + - git: https://github.com/harendra-kumar/hs-gauge + commit: f3bb4a1fc801c581224843759b7e6dabb0aef3dc + + - Chart-diagrams-1.8.3 + - SVGFonts-1.6.0.3 + - diagrams-core-1.4.0.1 + - diagrams-lib-1.4.2 + - diagrams-postscript-1.4 + - diagrams-svg-1.4.1.1 + - diagrams-solve-0.1.1 + - dual-tree-0.2.1 + - lens-4.15.4 + - free-4.12.4 + flags: {} extra-package-dbs: [] rebuild-ghc-options: true # For mac ports installed SDL library on Mac OS X -#extra-include-dirs: -#- /opt/local/include +extra-include-dirs: +- /opt/local/include diff --git a/streamly.cabal b/streamly.cabal index dd2e7f6..56b1cd9 100644 --- a/streamly.cabal +++ b/streamly.cabal @@ -1,29 +1,56 @@ name: streamly -version: 0.1.2 +version: 0.2.0 synopsis: Beautiful Streaming, Concurrent and Reactive Composition description: - Streamly is a monad transformer unifying non-determinism - (<https://hackage.haskell.org/package/list-t list-t>\/<https://hackage.haskell.org/package/logict logict>), - concurrency (<https://hackage.haskell.org/package/async async>), - streaming (<https://hackage.haskell.org/package/conduit conduit>\/<https://hackage.haskell.org/package/pipes pipes>), - and FRP (<https://hackage.haskell.org/package/Yampa Yampa>\/<https://hackage.haskell.org/package/reflex reflex>) - functionality in a concise and intuitive API. - High level concurrency makes concurrent applications almost indistinguishable - from non-concurrent ones. By changing a single combinator you can control - whether the code runs serially or concurrently. It naturally integrates - concurrency with streaming rather than adding it as an afterthought. - Moreover, it interworks with the popular streaming libraries. + Streamly, short for streaming concurrently, is a simple yet powerful + streaming library with concurrent merging and concurrent nested looping + support. A stream is just like a list except that it is a list of monadic + actions rather than pure values. Streamly streams can be generated, + consumed, combined, or transformed serially or concurrently. We can loop over + a stream serially or concurrently. We can also have serial or concurrent + nesting of loops. For those familiar with list transformer concept streamly + is a concurrent list transformer. Streamly uses standard composition + abstractions. Concurrent composition is just the same as serial composition + except that we use a simple combinator to request a concurrent composition + instead of serial. The programmer does not have to be aware of threads, + locking or synchronization to write scalable concurrent programs. . - See the README for an overview and the haddock documentation for full - reference. It is recommended to read the comprehensive tutorial module - "Streamly.Tutorial" first. Also see "Streamly.Examples" for some working - examples. + Streamly provides functionality that is equivalent to streaming libraries + like <https://hackage.haskell.org/package/pipes pipes> and + <https://hackage.haskell.org/package/conduit conduit> but with a simple list + like API. The streaming API of streamly is close to the monadic streams API + of the <https://hackage.haskell.org/package/vector vector> package and + similar in concept to the + <https://hackage.haskell.org/package/streaming streaming> package. In + addition to the streaming functionality, streamly subsumes the functionality + of list transformer libraries like @pipes@ or + <https://hackage.haskell.org/package/list-t list-t> and also the logic + programming library <https://hackage.haskell.org/package/logict logict>. On + the concurrency side, it subsumes the functionality of the + <https://hackage.haskell.org/package/async async> package. Because it + supports streaming with concurrency we can write FRP applications similar in + concept to <https://hackage.haskell.org/package/Yampa Yampa> or + <https://hackage.haskell.org/package/reflex reflex>. + . + Streamly has excellent performance, see + <https://github.com/composewell/streaming-benchmarks streaming-benchmarks> + for a comparison of popular streaming libraries on micro-benchmarks. For + file IO, currently the library provides only one API to stream the lines in + the file as Strings. Future versions will provide better streaming file IO + options. Streamly interworks with the popular streaming libraries, see the + interworking section in "Streamly.Tutorial". + . + Where to find more information: + . + * @README@ shipped with the package for a quick overview + * "Streamly.Tutorial" module in the haddock documentation for a detailed introduction + * @examples@ directory in the package for some simple practical examples homepage: https://github.com/composewell/streamly bug-reports: https://github.com/composewell/streamly/issues license: BSD3 license-file: LICENSE -tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.1 +tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.2 author: Harendra Kumar maintainer: harendra.kumar@gmail.com copyright: 2017 Harendra Kumar @@ -35,6 +62,7 @@ cabal-version: >= 1.10 extra-source-files: Changelog.md README.md + bench.sh stack-7.10.yaml stack.yaml @@ -47,11 +75,6 @@ flag dev manual: True default: False -flag extra-benchmarks - description: Include comparative benchmarks - manual: True - default: False - flag examples description: Build examples manual: True @@ -62,6 +85,10 @@ flag examples-sdl manual: True default: False +------------------------------------------------------------------------------- +-- Library +------------------------------------------------------------------------------- + library hs-source-dirs: src other-modules: Streamly.Core @@ -72,16 +99,6 @@ library , Streamly.Tutorial , Streamly - if flag(examples) || flag(examples-sdl) - exposed-modules: Streamly.Examples - , Streamly.Examples.SearchEngineQuery - , Streamly.Examples.ListDirRecursive - , Streamly.Examples.MergeSortedStreams - , Streamly.Examples.AcidRainGame - - if flag(examples-sdl) - exposed-modules: Streamly.Examples.CirclingSquare - default-language: Haskell2010 ghc-options: -Wall @@ -98,8 +115,6 @@ library -Wredundant-constraints -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances - if flag(examples-sdl) - cpp-options: -DEXAMPLES_SDL build-depends: base >= 4.8 && < 5 , atomic-primops >= 0.8 && < 0.9 @@ -117,15 +132,9 @@ library build-depends: semigroups >= 0.18 && < 0.19 - if flag(examples) || flag(examples-sdl) - build-Depends: - http-conduit >= 2.2.2 && < 2.4 - , path-io >= 0.1.0 && < 1.4 - , random >= 1.0.0 && < 1.2 - - if flag(examples-sdl) - build-Depends: - SDL >= 0.6.5 && < 0.7 +------------------------------------------------------------------------------- +-- Test suites +------------------------------------------------------------------------------- test-suite test type: exitcode-stdio-1.0 @@ -149,15 +158,74 @@ test-suite test , base >= 4.8 && < 5 , hspec >= 2.0 && < 3 , containers >= 0.5 && < 0.6 - if impl(ghc < 8.0) - build-depends: - transformers >= 0.4 && < 0.6 + , transformers >= 0.4 && < 0.6 + , mtl >= 2.2 && < 3 + , exceptions >= 0.8 && < 0.11 default-language: Haskell2010 -benchmark bench +test-suite properties + type: exitcode-stdio-1.0 + main-is: Prop.hs + hs-source-dirs: test + ghc-options: -O0 -Wall + if flag(dev) + ghc-options: -Wmissed-specialisations + -Wall-missed-specialisations + if impl(ghc >= 8.0) + ghc-options: -Wcompat + -Wunrecognised-warning-flags + -Widentities + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wredundant-constraints + -Wnoncanonical-monad-instances + -Wnoncanonical-monadfail-instances + build-depends: + streamly + , base >= 4.8 && < 5 + , QuickCheck >= 2.8 && < 2.12 + , hspec >= 2.0 && < 3 + default-language: Haskell2010 + +test-suite loops + type: exitcode-stdio-1.0 + default-language: Haskell2010 + main-is: loops.hs + hs-source-dirs: test + build-Depends: + streamly + , base >= 4.8 && < 5 + +test-suite nested-loops + type: exitcode-stdio-1.0 + default-language: Haskell2010 + main-is: nested-loops.hs + hs-source-dirs: test + build-Depends: + streamly + , base >= 4.8 && < 5 + , random >= 1.0.0 && < 1.2 + +test-suite parallel-loops + type: exitcode-stdio-1.0 + default-language: Haskell2010 + main-is: parallel-loops.hs + hs-source-dirs: test + build-Depends: + streamly + , base >= 4.8 && < 5 + , random >= 1.0.0 && < 1.2 + +------------------------------------------------------------------------------- +-- Benchmarks +------------------------------------------------------------------------------- + +benchmark linear type: exitcode-stdio-1.0 - main-is: Main.hs hs-source-dirs: benchmark + main-is: Linear.hs + other-modules: LinearOps + default-language: Haskell2010 ghc-options: -O2 -Wall if flag(dev) ghc-options: -Wmissed-specialisations @@ -174,59 +242,102 @@ benchmark bench -Wnoncanonical-monadfail-instances build-depends: streamly - , atomic-primops >= 0.8 && < 0.9 , base >= 4.8 && < 5 - , criterion >= 1 && < 2 - , mtl >= 2.2 && < 3 + , deepseq >= 1.4.0 && < 1.5 + , random >= 1.0 && < 2.0 + , gauge >= 0.2.1 && < 0.3 - if impl(ghc < 8.0) - build-depends: - transformers >= 0.4 && < 0.6 +benchmark nested + type: exitcode-stdio-1.0 + hs-source-dirs: benchmark + main-is: Nested.hs + other-modules: NestedOps + default-language: Haskell2010 + ghc-options: -O2 -Wall + if flag(dev) + ghc-options: -Wmissed-specialisations + -Wall-missed-specialisations + -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 + -Wnoncanonical-monadfail-instances + build-depends: + streamly + , base >= 4.8 && < 5 + , deepseq >= 1.4.0 && < 1.5 + , random >= 1.0 && < 2.0 + , gauge >= 0.2.1 && < 0.3 - if flag(extra-benchmarks) - cpp-options: -DEXTRA_BENCHMARKS - build-depends: - list-t >= 0.4 && < 2 - , logict >= 0.6 && < 0.7 - , machines >= 0.5 && < 0.7 - , simple-conduit >= 0.6 && < 0.7 - , transient >= 0.4 && < 0.6 +executable chart-linear default-language: Haskell2010 + hs-source-dirs: benchmark + main-is: ChartLinear.hs + if flag(dev) + buildable: True + build-Depends: + base >= 4.8 && < 5 + , bench-graph + , split + else + buildable: False + +executable chart-nested + default-language: Haskell2010 + hs-source-dirs: benchmark + main-is: ChartNested.hs + if flag(dev) + buildable: True + build-Depends: + base >= 4.8 && < 5 + , bench-graph + , split + else + buildable: False ------------------------------------------------------------------------------- -- Examples ------------------------------------------------------------------------------- -executable loops +executable SearchQuery default-language: Haskell2010 - main-is: loops.hs + main-is: SearchQuery.hs hs-source-dirs: examples - if flag(examples) + if flag(examples) || flag(examples-sdl) buildable: True build-Depends: streamly - , base >= 4.8 && < 5 + , base >= 4.8 && < 5 + , http-conduit >= 2.2.2 && < 2.4 else buildable: False -executable nested-loops +executable ListDir default-language: Haskell2010 - main-is: nested-loops.hs + main-is: ListDir.hs hs-source-dirs: examples - if flag(examples) + if flag(examples) || flag(examples-sdl) buildable: True build-Depends: streamly - , base >= 4.8 && < 5 - , random >= 1.0.0 && < 1.2 + , base >= 4.8 && < 5 + , path-io >= 0.1.0 && < 1.4 + if impl(ghc < 8.0) + build-depends: + transformers >= 0.4 && < 0.6 else buildable: False -executable parallel-loops +executable MergeSort default-language: Haskell2010 - main-is: parallel-loops.hs + main-is: MergeSort.hs hs-source-dirs: examples - if flag(examples) + if flag(examples) || flag(examples-sdl) buildable: True build-Depends: streamly @@ -234,3 +345,33 @@ executable parallel-loops , random >= 1.0.0 && < 1.2 else buildable: False + +executable AcidRain + default-language: Haskell2010 + main-is: AcidRain.hs + hs-source-dirs: examples + if flag(examples) || flag(examples-sdl) + buildable: True + build-Depends: + streamly + , base >= 4.8 && < 5 + , mtl >= 2.2 && < 3 + if impl(ghc < 8.0) + build-depends: + semigroups >= 0.18 && < 0.19 + , transformers >= 0.4 && < 0.6 + else + buildable: False + +executable CirclingSquare + default-language: Haskell2010 + main-is: CirclingSquare.hs + hs-source-dirs: examples + if flag(examples-sdl) + buildable: True + build-Depends: + streamly + , base >= 4.8 && < 5 + , SDL >= 0.6.5 && < 0.7 + else + buildable: False diff --git a/test/Main.hs b/test/Main.hs index 1907faa..c8eb1af 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,60 +1,68 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} module Main (main) where import Control.Concurrent (threadDelay) -import Control.Monad (replicateM) -import Data.Foldable (forM_) +import Control.Exception (Exception, try) +import Control.Monad.Catch (throwM, MonadThrow) +import Control.Monad.Error.Class (throwError, MonadError) +import Control.Monad.Trans.Except (runExceptT, ExceptT) +import Data.Foldable (forM_, fold) import Data.List (sort) -import Data.Maybe (fromJust) import Test.Hspec import Streamly +import Streamly.Prelude ((.:), nil) import qualified Streamly.Prelude as A -toListSerial :: StreamT IO a -> IO [a] +singleton :: IsStream t => a -> t m a +singleton a = a .: nil + +toListSerial :: SerialT IO a -> IO [a] toListSerial = A.toList . serially -toListInterleaved :: InterleavedT IO a -> IO [a] -toListInterleaved = A.toList . interleaving +toListInterleaved :: WSerialT IO a -> IO [a] +toListInterleaved = A.toList . wSerially toListAsync :: AsyncT IO a -> IO [a] toListAsync = A.toList . asyncly -toListParallel :: Ord a => ParallelT IO a -> IO [a] -toListParallel = fmap sort . A.toList . parallely +toListParallel :: WAsyncT IO a -> IO [a] +toListParallel = A.toList . wAsyncly main :: IO () main = hspec $ do describe "Runners" $ do + -- XXX move these to property tests + -- XXX use an IORef to store and check the side effects it "simple serially" $ - (runStreaming . serially) (return (0 :: Int)) `shouldReturn` () + (runStream . serially) (return (0 :: Int)) `shouldReturn` () it "simple serially with IO" $ - (runStreaming . serially) (liftIO $ putStrLn "hello") `shouldReturn` () - it "Captures a return value using toList" $ - toListSerial (return 0) `shouldReturn` ([0] :: [Int]) + (runStream . serially) (A.once $ putStrLn "hello") `shouldReturn` () describe "Empty" $ do it "Monoid - mempty" $ (toListSerial mempty) `shouldReturn` ([] :: [Int]) - it "Alternative - empty" $ - (toListSerial empty) `shouldReturn` ([] :: [Int]) - it "MonadPlus - mzero" $ - (toListSerial mzero) `shouldReturn` ([] :: [Int]) + -- it "Alternative - empty" $ + -- (toListSerial empty) `shouldReturn` ([] :: [Int]) + -- it "MonadPlus - mzero" $ + -- (toListSerial mzero) `shouldReturn` ([] :: [Int]) --------------------------------------------------------------------------- -- Functor --------------------------------------------------------------------------- describe "Functor (fmap)" $ do - it "Simple fmap" $ - (toListSerial $ fmap (+1) (return 1)) `shouldReturn` ([2] :: [Int]) + -- XXX we should do these through property tests by using a + -- construction via list fold construction method. it "fmap on composed (<>)" $ (toListSerial $ fmap (+1) (return 1 <> return 2)) `shouldReturn` ([2,3] :: [Int]) - it "fmap on composed (<|>)" $ - (toListSerial $ fmap (+1) (return 1 <|> return 2)) + + it "fmap on composed (<>)" $ + ((toListParallel $ fmap (+1) (return 1 <> return 2)) >>= return . sort) `shouldReturn` ([2,3] :: [Int]) --------------------------------------------------------------------------- @@ -62,10 +70,8 @@ main = hspec $ do --------------------------------------------------------------------------- describe "Applicative" $ do - it "Simple apply" $ - (toListSerial $ (,) <$> (return 1) <*> (return 2)) - `shouldReturn` ([(1,2)] :: [(Int, Int)]) - + -- XXX we should do these through property tests by using a + -- construction via list fold construction method. it "Apply - serial composed first argument" $ (toListSerial $ (,) <$> (return 1 <> return 2) <*> (return 3)) `shouldReturn` ([(1,3),(2,3)] :: [(Int, Int)]) @@ -75,58 +81,58 @@ main = hspec $ do `shouldReturn` ([(1,2),(1,3)] :: [(Int, Int)]) it "Apply - parallel composed first argument" $ - (toListSerial $ (,) <$> (return 1 <|> return 2) <*> (return 3)) + (toListParallel ((,) <$> (return 1 <> return 2) <*> (return 3)) >>= return . sort) `shouldReturn` ([(1,3),(2,3)] :: [(Int, Int)]) it "Apply - parallel composed second argument" $ - (toListSerial $ (,) <$> (return 1) <*> (return 2 <|> return 3)) + (toListParallel ((,) <$> (return 1) <*> (return 2 <> return 3)) >>= return . sort) `shouldReturn` ([(1,2),(1,3)] :: [(Int, Int)]) --------------------------------------------------------------------------- - -- Binds + -- Semigroup/Monoidal Composition strict ordering checks --------------------------------------------------------------------------- - describe "Bind then" thenBind - describe "Pure bind serial" $ pureBind toListSerial - describe "Pure bind serial interleaved" $ pureBind toListInterleaved - describe "Pure bind parallel DFS" $ pureBind toListAsync - describe "Pure bind parallel BFS" $ pureBind toListParallel + -- test both (<>) and mappend to make sure we are using correct instance + -- for Monoid that is using the right version of semigroup. Instance + -- deriving can cause us to pick wrong instances sometimes. - describe "Bind (>>=) with empty" $ bindEmpty toListSerial - describe "Bind (>->) with empty" $ bindEmpty toListInterleaved - describe "Bind (>|>) with empty" $ bindEmpty toListAsync - describe "Bind (>>|) with empty" $ bindEmpty toListParallel + describe "Serial interleaved (<>) ordering check" $ interleaveCheck wSerially (<>) + describe "Serial interleaved mappend ordering check" $ interleaveCheck wSerially mappend - --------------------------------------------------------------------------- - -- Monoidal Compositions - --------------------------------------------------------------------------- + describe "Parallel interleaved (<>) ordering check" $ interleaveCheck wAsyncly (<>) + describe "Parallel interleaved mappend ordering check" $ interleaveCheck wAsyncly mappend + + -- describe "Parallel (<>) ordering check" $ interleaveCheck parallely (<>) + -- describe "Parallel mappend ordering check" $ interleaveCheck parallely mappend - describe "Serial Composition (<>)" $ compose (<>) id - describe "Serial Composition (mappend)" $ compose mappend id - describe "Interleaved Composition (<>)" $ compose (<=>) sort - describe "Left biased parallel Composition (<|)" $ compose (<|) sort - describe "Fair parallel Composition (<|>)" $ compose (<|>) sort - describe "Fair parallel Composition (mplus)" $ compose mplus sort + describe "Async (<>) time order check" $ parallelCheck asyncly (<>) + describe "Async mappend time order check" $ parallelCheck asyncly mappend + describe "WAsync (<>) time order check" $ parallelCheck wAsyncly (<>) + describe "WAsync mappend time order check" $ parallelCheck wAsyncly mappend --------------------------------------------------------------------------- - -- Monoidal Composition ordering checks + -- Monoidal Compositions, multiset equality checks --------------------------------------------------------------------------- - describe "Serial interleaved ordering check (<=>)" $ interleaveCheck (<=>) - describe "Parallel interleaved ordering check (<|>)" $ interleaveCheck (<|>) - describe "Left biased parallel time order check" $ parallelCheck (<|) - describe "Fair parallel time order check" $ parallelCheck (<|>) + describe "Serial Composition" $ compose serially mempty id + describe "WSerial Composition" $ compose wSerially mempty sort + describe "Async Composition" $ compose asyncly mempty sort + describe "WAsync Composition" $ compose wAsyncly mempty sort + describe "Parallel Composition" $ compose parallely mempty sort + describe "Semigroup Composition for ZipSerial" $ compose zipSerially mempty id + describe "Semigroup Composition for ZipAsync" $ compose zipAsyncly mempty id + -- XXX need to check alternative compositions as well --------------------------------------------------------------------------- -- TBD Monoidal composition combinations --------------------------------------------------------------------------- -- TBD need more such combinations to be tested. - describe "<> and <>" $ composeAndComposeSimple (<>) (<>) (cycle [[1 .. 9]]) + describe "<> and <>" $ composeAndComposeSimple serially serially (cycle [[1 .. 9]]) describe "<> and <=>" $ composeAndComposeSimple - (<>) - (<=>) + serially + wSerially ([ [1 .. 9] , [1 .. 9] , [1, 3, 2, 4, 6, 5, 7, 9, 8] @@ -134,8 +140,8 @@ main = hspec $ do ]) describe "<=> and <=>" $ composeAndComposeSimple - (<=>) - (<=>) + wSerially + wSerially ([ [1, 4, 2, 7, 3, 5, 8, 6, 9] , [1, 7, 4, 8, 2, 9, 5, 3, 6] , [1, 4, 3, 7, 2, 6, 9, 5, 8] @@ -143,8 +149,8 @@ main = hspec $ do ]) describe "<=> and <>" $ composeAndComposeSimple - (<=>) - (<>) + wSerially + serially ([ [1, 4, 2, 7, 3, 5, 8, 6, 9] , [1, 7, 4, 8, 2, 9, 5, 3, 6] , [1, 4, 2, 7, 3, 5, 8, 6, 9] @@ -152,6 +158,9 @@ main = hspec $ do ]) describe "Nested parallel and serial compositions" $ do + let t = timed + p = wAsyncly + s = serially {- -- This is not correct, the result can also be [4,4,8,0,8,0,2,2] -- because of parallelism of [8,0] and [8,0]. @@ -163,10 +172,9 @@ main = hspec $ do `shouldReturn` ([4,4,8,8,0,0,2,2]) -} it "Nest <|>, <>, <|> (2)" $ - let t = timed - in toListSerial ( - ((t 4 <|> t 8) <> (t 1 <|> t 2)) - <|> ((t 4 <|> t 8) <> (t 1 <|> t 2))) + (A.toList . wAsyncly) ( + s (p (t 4 <> t 8) <> p (t 1 <> t 2)) + <> s (p (t 4 <> t 8) <> p (t 1 <> t 2))) `shouldReturn` ([4,4,8,8,1,1,2,2]) -- FIXME: These two keep failing intermittently on Mac OS X -- Need to examine and fix the tests. @@ -185,121 +193,234 @@ main = hspec $ do `shouldReturn` ([4,4,1,1,8,2,9,2]) -} it "Nest <|>, <|>, <|>" $ - let t = timed - in toListSerial ( - ((t 4 <|> t 8) <|> (t 0 <|> t 2)) - <|> ((t 4 <|> t 8) <|> (t 0 <|> t 2))) + (A.toList . wAsyncly) ( + ((t 4 <> t 8) <> (t 0 <> t 2)) + <> ((t 4 <> t 8) <> (t 0 <> t 2))) `shouldReturn` ([0,0,2,2,4,4,8,8]) --------------------------------------------------------------------------- -- Monoidal composition recursion loops --------------------------------------------------------------------------- - describe "Serial loops (<>)" $ loops (<>) id reverse - describe "Left biased parallel loops (<|)" $ loops (<|) sort sort - describe "Fair parallel loops (<|>)" $ loops (<|>) sort sort + describe "Serial loops" $ loops serially id reverse + describe "Async parallel loops" $ loops asyncly sort sort + describe "WAsync loops" $ loops wAsyncly sort sort + describe "parallel loops" $ loops parallely sort sort --------------------------------------------------------------------------- -- Bind and monoidal composition combinations --------------------------------------------------------------------------- - forM_ [(<>), (<=>), (<|), (<|>)] $ \g -> - describe "Bind and compose" $ bindAndComposeSimple toListSerial g - - forM_ [(<>), (<=>), (<|), (<|>)] $ \g -> - describe "Bind and compose" $ bindAndComposeSimple toListInterleaved g - - forM_ [(<>), (<=>), (<|), (<|>)] $ \g -> - describe "Bind and compose" $ bindAndComposeSimple toListAsync g - - forM_ [(<>), (<=>), (<|), (<|>)] $ \g -> - describe "Bind and compose" $ bindAndComposeSimple toListParallel g - - let fldr f = foldr f empty - fldl f = foldl f empty - in do - forM_ [(<>), (<=>), (<|), (<|>)] $ \g -> - forM_ [fldr, fldl] $ \k -> - describe "Bind and compose" $ - bindAndComposeHierarchy toListSerial (k g) - forM_ [(<>), (<=>), (<|), (<|>)] $ \g -> - forM_ [fldr, fldl] $ \k -> - describe "Bind and compose" $ - bindAndComposeHierarchy toListInterleaved (k g) - forM_ [(<>), (<=>), (<|), (<|>)] $ \g -> - forM_ [fldr, fldl] $ \k -> - describe "Bind and compose" $ - bindAndComposeHierarchy toListAsync (k g) - forM_ [(<>), (<=>), (<|), (<|>)] $ \g -> - forM_ [fldr, fldl] $ \k -> - describe "Bind and compose" $ - bindAndComposeHierarchy toListParallel (k g) + describe "Bind and compose Stream 1" $ bindAndComposeSimple serially serially + describe "Bind and compose Stream 2" $ bindAndComposeSimple serially wSerially + describe "Bind and compose Stream 3" $ bindAndComposeSimple serially asyncly + describe "Bind and compose Stream 4" $ bindAndComposeSimple serially wAsyncly + describe "Bind and compose Stream 5" $ bindAndComposeSimple serially parallely + + describe "Bind and compose Costream 1" $ bindAndComposeSimple wSerially serially + describe "Bind and compose Costream 2" $ bindAndComposeSimple wSerially wSerially + describe "Bind and compose Costream 3" $ bindAndComposeSimple wSerially asyncly + describe "Bind and compose Costream 4" $ bindAndComposeSimple wSerially wAsyncly + describe "Bind and compose Costream 5" $ bindAndComposeSimple wSerially parallely + + describe "Bind and compose Async 1" $ bindAndComposeSimple asyncly serially + describe "Bind and compose Async 2" $ bindAndComposeSimple asyncly wSerially + describe "Bind and compose Async 3" $ bindAndComposeSimple asyncly asyncly + describe "Bind and compose Async 4" $ bindAndComposeSimple asyncly wAsyncly + describe "Bind and compose Async 5" $ bindAndComposeSimple asyncly parallely + + describe "Bind and compose WAsync 1" $ bindAndComposeSimple wAsyncly serially + describe "Bind and compose WAsync 2" $ bindAndComposeSimple wAsyncly wSerially + describe "Bind and compose WAsync 3" $ bindAndComposeSimple wAsyncly asyncly + describe "Bind and compose WAsync 4" $ bindAndComposeSimple wAsyncly wAsyncly + describe "Bind and compose WAsync 5" $ bindAndComposeSimple wAsyncly parallely + + describe "Bind and compose Parallel 1" $ bindAndComposeSimple parallely serially + describe "Bind and compose Parallel 2" $ bindAndComposeSimple parallely wSerially + describe "Bind and compose Parallel 3" $ bindAndComposeSimple parallely asyncly + describe "Bind and compose Parallel 4" $ bindAndComposeSimple parallely wAsyncly + describe "Bind and compose Parallel 5" $ bindAndComposeSimple parallely parallely + + let fldr, fldl :: (IsStream t, Semigroup (t IO Int)) => [t IO Int] -> t IO Int + fldr = foldr (<>) nil + fldl = foldl (<>) nil + + forM_ [fldr, fldl] $ \k -> + describe "Bind and compose" $ bindAndComposeHierarchy serially serially k + forM_ [fldr, fldl] $ \k -> + describe "Bind and compose" $ bindAndComposeHierarchy serially wSerially k + forM_ [fldr, fldl] $ \k -> + describe "Bind and compose" $ bindAndComposeHierarchy serially asyncly k + forM_ [fldr, fldl] $ \k -> + describe "Bind and compose" $ bindAndComposeHierarchy serially wAsyncly k + forM_ [fldr, fldl] $ \k -> + describe "Bind and compose" $ bindAndComposeHierarchy serially parallely k + + forM_ [fldr, fldl] $ \k -> + describe "Bind and compose" $ bindAndComposeHierarchy wSerially serially k + forM_ [fldr, fldl] $ \k -> + describe "Bind and compose" $ bindAndComposeHierarchy wSerially wSerially k + forM_ [fldr, fldl] $ \k -> + describe "Bind and compose" $ bindAndComposeHierarchy wSerially asyncly k + forM_ [fldr, fldl] $ \k -> + describe "Bind and compose" $ bindAndComposeHierarchy wSerially wAsyncly k + forM_ [fldr, fldl] $ \k -> + describe "Bind and compose" $ bindAndComposeHierarchy wSerially parallely k + + forM_ [fldr, fldl] $ \k -> + describe "Bind and compose" $ bindAndComposeHierarchy asyncly serially k + forM_ [fldr, fldl] $ \k -> + describe "Bind and compose" $ bindAndComposeHierarchy asyncly wSerially k + forM_ [fldr, fldl] $ \k -> + describe "Bind and compose" $ bindAndComposeHierarchy asyncly asyncly k + forM_ [fldr, fldl] $ \k -> + describe "Bind and compose" $ bindAndComposeHierarchy asyncly wAsyncly k + forM_ [fldr, fldl] $ \k -> + describe "Bind and compose" $ bindAndComposeHierarchy asyncly parallely k + + forM_ [fldr, fldl] $ \k -> + describe "Bind and compose" $ bindAndComposeHierarchy wAsyncly serially k + forM_ [fldr, fldl] $ \k -> + describe "Bind and compose" $ bindAndComposeHierarchy wAsyncly wSerially k + forM_ [fldr, fldl] $ \k -> + describe "Bind and compose" $ bindAndComposeHierarchy wAsyncly asyncly k + forM_ [fldr, fldl] $ \k -> + describe "Bind and compose" $ bindAndComposeHierarchy wAsyncly wAsyncly k + forM_ [fldr, fldl] $ \k -> + describe "Bind and compose" $ bindAndComposeHierarchy wAsyncly parallely k + + forM_ [fldr, fldl] $ \k -> + describe "Bind and compose" $ bindAndComposeHierarchy parallely serially k + forM_ [fldr, fldl] $ \k -> + describe "Bind and compose" $ bindAndComposeHierarchy parallely wSerially k + forM_ [fldr, fldl] $ \k -> + describe "Bind and compose" $ bindAndComposeHierarchy parallely asyncly k + forM_ [fldr, fldl] $ \k -> + describe "Bind and compose" $ bindAndComposeHierarchy parallely wAsyncly k + forM_ [fldr, fldl] $ \k -> + describe "Bind and compose" $ bindAndComposeHierarchy parallely parallely k -- Nest two lists using different styles of product compositions it "Nests two streams using monadic serial composition" nestTwoSerial it "Nests two streams using monadic interleaved composition" nestTwoInterleaved - it "Nests two streams using monadic async composition" nestTwoAsync + it "Nests two streams using monadic Async composition" nestTwoAsync + it "Nests two streams using monadic WAsync composition" nestTwoWAsync it "Nests two streams using monadic parallel composition" nestTwoParallel it "Nests two streams using applicative serial composition" nestTwoSerialApp it "Nests two streams using applicative interleaved composition" nestTwoInterleavedApp - it "Nests two streams using applicative async composition" nestTwoAsyncApp + it "Nests two streams using applicative Async composition" nestTwoAsyncApp + it "Nests two streams using applicative WAsync composition" nestTwoWAsyncApp it "Nests two streams using applicative parallel composition" nestTwoParallelApp - it "Nests two streams using Num serial composition" nestTwoSerialNum - it "Nests two streams using Num interleaved composition" nestTwoInterleavedNum - it "Nests two streams using Num async composition" nestTwoAsyncNum - -- This test fails intermittently, need to investigate - -- it "Nests two streams using Num parallel composition" nestTwoParallelNum - --------------------------------------------------------------------------- -- TBD Bind and Bind combinations --------------------------------------------------------------------------- -- TBD combine all binds and all compose in one example describe "Miscellaneous combined examples" mixedOps + describe "Simple MonadError and MonadThrow" simpleMonadError - --------------------------------------------------------------------------- - -- Stream operations - --------------------------------------------------------------------------- + {- + describe "Composed MonadError serially" $ composeWithMonadError serially + describe "Composed MonadError wSerially" $ composeWithMonadError wSerially + describe "Composed MonadError asyncly" $ composeWithMonadError asyncly + describe "Composed MonadError wAsyncly" $ composeWithMonadError wAsyncly + -} + + describe "Composed MonadThrow serially" $ composeWithMonadThrow serially + describe "Composed MonadThrow wSerially" $ composeWithMonadThrow wSerially + describe "Composed MonadThrow asyncly" $ composeWithMonadThrow asyncly + describe "Composed MonadThrow wAsyncly" $ composeWithMonadThrow wAsyncly + describe "Composed MonadThrow parallely" $ composeWithMonadThrow parallely + + it "Crosses thread limit (2000 threads)" $ + runStream (asyncly $ fold $ + replicate 2000 $ A.once $ threadDelay 1000000) + `shouldReturn` () + +-- XXX need to test that we have promptly cleaned up everything after the error +-- XXX We can also check the output that we are expected to get before the +-- error occurs. - -- XXX for streams other than StreamT - describe "Stream Ops empty" $ streamOperations makeEmptyStream - describe "Stream ops singleton constr" $ streamOperations makeSingletonStream1 - describe "Stream ops singleton folded" $ streamOperations makeSingletonStream2 - describe "Stream Ops constr" $ streamOperations makeStream1 - describe "Stream Ops folded" $ streamOperations $ makeStream2 - ((<>) :: StreamT IO Int -> StreamT IO Int -> StreamT IO Int) - - describe "Serial zipping" $ - zipOps A.zipWith A.zipWithM zipping - describe "Async zipping" $ - zipOps A.zipAsyncWith A.zipAsyncWithM zippingAsync - -makeEmptyStream :: (StreamT IO Int, [Int], Int) -makeEmptyStream = (A.nil, [], 0) - -makeSingletonStream1 :: (StreamT IO Int, [Int], Int) -makeSingletonStream1 = (1 `A.cons` A.nil, [1], 1) - -makeSingletonStream2 :: (StreamT IO Int, [Int], Int) -makeSingletonStream2 = (return 1, [1], 1) - --- Streams that indicate an end via the stop continuation -makeStream1 :: (StreamT IO Int, [Int], Int) -makeStream1 = - let list = [1..10] - stream = A.each list - in (stream, list, 10) - --- Streams that indicate an end via the yield continuation -makeStream2 :: (Streaming t, Monad (t IO)) - => (t IO Int -> t IO Int -> t IO Int) - -> (t IO Int, [Int], Int) -makeStream2 f = - let list = [1..10] - stream = foldMapWith f return list - in (stream, list, 10) +data ExampleException = ExampleException String deriving (Eq, Show) + +instance Exception ExampleException + +simpleMonadError :: Spec +simpleMonadError = do +{- + it "simple runExceptT" $ do + (runExceptT $ runStream $ return ()) + `shouldReturn` (Right () :: Either String ()) + it "simple runExceptT with error" $ do + (runExceptT $ runStream $ throwError "E") `shouldReturn` Left "E" + -} + it "simple try" $ do + (try $ runStream $ return ()) + `shouldReturn` (Right () :: Either ExampleException ()) + it "simple try with throw error" $ do + (try $ runStream $ throwM $ ExampleException "E") + `shouldReturn` (Left (ExampleException "E") :: Either ExampleException ()) + +composeWithMonadThrow + :: ( IsStream t + , Semigroup (t IO Int) + , MonadThrow (t IO) + ) + => (t IO Int -> SerialT IO Int) -> Spec +composeWithMonadThrow t = do + it "Compose throwM, nil" $ + (try $ tl (throwM (ExampleException "E") <> A.nil)) + `shouldReturn` (Left (ExampleException "E") :: Either ExampleException [Int]) + it "Compose nil, throwM" $ + (try $ tl (A.nil <> throwM (ExampleException "E"))) + `shouldReturn` (Left (ExampleException "E") :: Either ExampleException [Int]) + oneLevelNestedSum "serially" serially + oneLevelNestedSum "wSerially" wSerially + oneLevelNestedSum "asyncly" asyncly + oneLevelNestedSum "wAsyncly" wAsyncly + -- XXX add two level nesting + + oneLevelNestedProduct "serially" serially + oneLevelNestedProduct "wSerially" wSerially + oneLevelNestedProduct "asyncly" asyncly + oneLevelNestedProduct "wAsyncly" wAsyncly + + where + tl = A.toList . t + oneLevelNestedSum desc t1 = + it ("One level nested sum " ++ desc) $ do + let nested = (A.fromFoldable [1..10] <> throwM (ExampleException "E") + <> A.fromFoldable [1..10]) + (try $ tl (A.nil <> t1 nested <> A.fromFoldable [1..10])) + `shouldReturn` (Left (ExampleException "E") :: Either ExampleException [Int]) + + oneLevelNestedProduct desc t1 = + it ("One level nested product" ++ desc) $ do + let s1 = t $ foldMapWith (<>) return [1..4] + s2 = t1 $ foldMapWith (<>) return [5..8] + try $ tl (do + x <- adapt s1 + y <- s2 + if (x + y > 10) + then throwM (ExampleException "E") + else return (x + y) + ) + `shouldReturn` (Left (ExampleException "E") :: Either ExampleException [Int]) + +_composeWithMonadError + :: ( IsStream t + , Semigroup (t (ExceptT String IO) Int) + , MonadError String (t (ExceptT String IO)) + ) + => (t (ExceptT String IO) Int -> SerialT (ExceptT String IO) Int) -> Spec +_composeWithMonadError t = do + let tl = A.toList . t + it "Compose throwError, nil" $ + (runExceptT $ tl (throwError "E" <> A.nil)) `shouldReturn` Left "E" + it "Compose nil, error" $ + (runExceptT $ tl (A.nil <> throwError "E")) `shouldReturn` Left "E" nestTwoSerial :: Expectation nestTwoSerial = @@ -318,13 +439,6 @@ nestTwoSerialApp = in toListSerial ((+) <$> s1 <*> s2) `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int]) -nestTwoSerialNum :: Expectation -nestTwoSerialNum = - let s1 = foldMapWith (<>) return [1..4] - s2 = foldMapWith (<>) return [5..8] - in toListSerial (s1 + s2) - `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int]) - nestTwoInterleaved :: Expectation nestTwoInterleaved = let s1 = foldMapWith (<>) return [1..4] @@ -342,245 +456,199 @@ nestTwoInterleavedApp = in toListInterleaved ((+) <$> s1 <*> s2) `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int]) -nestTwoInterleavedNum :: Expectation -nestTwoInterleavedNum = - let s1 = foldMapWith (<>) return [1..4] - s2 = foldMapWith (<>) return [5..8] - in toListInterleaved (s1 + s2) - `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int]) - nestTwoAsync :: Expectation nestTwoAsync = let s1 = foldMapWith (<>) return [1..4] s2 = foldMapWith (<>) return [5..8] - in toListAsync (do + in (toListAsync (do x <- s1 y <- s2 return (x + y) - ) `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int]) + ) >>= return . sort) + `shouldReturn` sort ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int]) nestTwoAsyncApp :: Expectation nestTwoAsyncApp = let s1 = foldMapWith (<>) return [1..4] s2 = foldMapWith (<>) return [5..8] - in toListAsync ((+) <$> s1 <*> s2) - `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int]) + in (toListAsync ((+) <$> s1 <*> s2) >>= return . sort) + `shouldReturn` sort ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int]) -nestTwoAsyncNum :: Expectation -nestTwoAsyncNum = +nestTwoWAsync :: Expectation +nestTwoWAsync = let s1 = foldMapWith (<>) return [1..4] s2 = foldMapWith (<>) return [5..8] - in toListAsync (s1 + s2) - `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int]) + in ((A.toList . wAsyncly) (do + x <- s1 + y <- s2 + return (x + y) + ) >>= return . sort) + `shouldReturn` sort ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int]) nestTwoParallel :: Expectation nestTwoParallel = let s1 = foldMapWith (<>) return [1..4] s2 = foldMapWith (<>) return [5..8] - in toListParallel (do + in ((A.toList . parallely) (do x <- s1 y <- s2 return (x + y) - ) `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int]) + ) >>= return . sort) + `shouldReturn` sort ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int]) -nestTwoParallelApp :: Expectation -nestTwoParallelApp = +nestTwoWAsyncApp :: Expectation +nestTwoWAsyncApp = let s1 = foldMapWith (<>) return [1..4] s2 = foldMapWith (<>) return [5..8] - in toListParallel ((+) <$> s1 <*> s2) - `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int]) + in ((A.toList . wAsyncly) ((+) <$> s1 <*> s2) >>= return . sort) + `shouldReturn` sort ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int]) -{- -nestTwoParallelNum :: Expectation -nestTwoParallelNum = +nestTwoParallelApp :: Expectation +nestTwoParallelApp = let s1 = foldMapWith (<>) return [1..4] s2 = foldMapWith (<>) return [5..8] - in toListParallel (s1 + s2) - `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int]) --} - -zipOps :: (Streaming t, Applicative (t IO)) - => (forall a b c. (a -> b -> c) - -> StreamT IO a -> StreamT IO b -> StreamT IO c) - -> (forall a b c. (a -> b -> StreamT IO c) - -> StreamT IO a -> StreamT IO b -> StreamT IO c) - -> (forall a. t IO a -> t IO a) - -> Spec -zipOps z zM app = do - it "zipWith" $ - let s1 = foldMapWith (<>) return [1..10] - s2 = foldMapWith (<>) return [1..] - in toListSerial (z (+) s1 s2) - `shouldReturn` ([2,4..20] :: [Int]) - - it "zipWithM" $ - let s1 = foldMapWith (<>) return [1..10] - s2 = foldMapWith (<>) return [1..] - in toListSerial (zM (\a b -> return (a + b)) s1 s2) - `shouldReturn` ([2,4..20] :: [Int]) - - it "Applicative zip" $ - let s1 = adapt $ serially $ foldMapWith (<>) return [1..10] - s2 = adapt $ serially $ foldMapWith (<>) return [1..] - f = A.toList . app - functorial = f $ (+) <$> s1 <*> s2 - applicative = f $ pure (+) <*> s1 <*> s2 - expected = ([2,4..20] :: [Int]) - in (,) <$> functorial <*> applicative - `shouldReturn` (expected, expected) - -timed :: Int -> StreamT IO Int -timed x = liftIO (threadDelay (x * 100000)) >> return x - -thenBind :: Spec -thenBind = do - it "Simple runStreaming and 'then' with IO" $ - (runStreaming . serially) (liftIO (putStrLn "hello") >> liftIO (putStrLn "world")) - `shouldReturn` () - it "Then and toList" $ - toListSerial (return (1 :: Int) >> return 2) `shouldReturn` ([2] :: [Int]) - -type ToListType s = (forall a. Ord a => s IO a -> IO [a]) -pureBind :: Monad (s IO) => ToListType s -> Spec -pureBind l = do - it "Bind and toList" $ - l (return 1 `f` \x -> return 2 `f` \y -> return (x + y)) - `shouldReturn` ([3] :: [Int]) - where f = (>>=) - -bindEmpty :: (Monad (s IO), Alternative (s IO)) => ToListType s -> Spec -bindEmpty l = it "Binds with empty" $ - (l (return (1 :: Int) `f` \_ -> empty `f` \_ -> return 2)) - `shouldReturn` ([] :: [Int]) - where f = (>>=) - -interleaveCheck - :: (StreamT IO Int -> StreamT IO Int -> StreamT IO Int) + in ((A.toList . parallely) ((+) <$> s1 <*> s2) >>= return . sort) + `shouldReturn` sort ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int]) + +timed :: (IsStream t, Monad (t IO)) => Int -> t IO Int +timed x = A.once (threadDelay (x * 100000)) >> return x + +interleaveCheck :: IsStream t + => (t IO Int -> SerialT IO Int) + -> (t IO Int -> t IO Int -> t IO Int) -> Spec -interleaveCheck f = +interleaveCheck t f = it "Interleave four" $ - toListSerial ((return 0 <> return 1) `f` (return 100 <> return 101)) + (A.toList . t) ((singleton 0 `f` singleton 1) `f` (singleton 100 `f` singleton 101)) `shouldReturn` ([0, 100, 1, 101]) -parallelCheck :: (StreamT IO Int -> StreamT IO Int -> StreamT IO Int) -> Spec -parallelCheck f = do +parallelCheck :: (IsStream t, Monad (t IO)) + => (t IO Int -> SerialT IO Int) + -> (t IO Int -> t IO Int -> t IO Int) + -> Spec +parallelCheck t f = do it "Parallel ordering left associated" $ - toListSerial (((event 4 `f` event 3) `f` event 2) `f` event 1) + (A.toList . t) (((event 4 `f` event 3) `f` event 2) `f` event 1) `shouldReturn` ([1..4]) it "Parallel ordering right associated" $ - toListSerial (event 4 `f` (event 3 `f` (event 2 `f` event 1))) + (A.toList . t) (event 4 `f` (event 3 `f` (event 2 `f` event 1))) `shouldReturn` ([1..4]) - where event n = (liftIO $ threadDelay (n * 100000)) >> (return n) + where event n = (A.once $ threadDelay (n * 100000)) >> (return n) -compose - :: (StreamT IO Int -> StreamT IO Int -> StreamT IO Int) - -> ([Int] -> [Int]) - -> Spec -compose f srt = do +compose :: (IsStream t, Semigroup (t IO Int)) + => (t IO Int -> SerialT IO Int) -> t IO Int -> ([Int] -> [Int]) -> Spec +compose t z srt = do + -- XXX these should get covered by the property tests it "Compose mempty, mempty" $ - (tl (mempty `f` mempty)) `shouldReturn` [] - it "Compose empty, empty" $ - (tl (empty `f` empty)) `shouldReturn` [] + (tl (z <> z)) `shouldReturn` ([] :: [Int]) it "Compose empty at the beginning" $ - (tl $ (empty `f` return 1)) `shouldReturn` [1] + (tl $ (z <> singleton 1)) `shouldReturn` [1] it "Compose empty at the end" $ - (tl $ (return 1 `f` empty)) `shouldReturn` [1] + (tl $ (singleton 1 <> z)) `shouldReturn` [1] it "Compose two" $ - (tl (return 0 `f` return 1) >>= return . srt) + (tl (singleton 0 <> singleton 1) >>= return . srt) `shouldReturn` [0, 1] + it "Compose many" $ + ((tl $ forEachWith (<>) [1..100] singleton) >>= return . srt) + `shouldReturn` [1..100] + + -- These are not covered by the property tests it "Compose three - empty in the middle" $ - ((tl $ (return 0 `f` empty `f` return 1)) >>= return . srt) + ((tl $ (singleton 0 <> z <> singleton 1)) >>= return . srt) `shouldReturn` [0, 1] it "Compose left associated" $ - ((tl $ (((return 0 `f` return 1) `f` return 2) `f` return 3)) + ((tl $ (((singleton 0 <> singleton 1) <> singleton 2) <> singleton 3)) >>= return . srt) `shouldReturn` [0, 1, 2, 3] it "Compose right associated" $ - ((tl $ (return 0 `f` (return 1 `f` (return 2 `f` return 3)))) + ((tl $ (singleton 0 <> (singleton 1 <> (singleton 2 <> singleton 3)))) >>= return . srt) `shouldReturn` [0, 1, 2, 3] - it "Compose many" $ - ((tl $ forEachWith f [1..100] return) >>= return . srt) - `shouldReturn` [1..100] it "Compose hierarchical (multiple levels)" $ - ((tl $ (((return 0 `f` return 1) `f` (return 2 `f` return 3)) - `f` ((return 4 `f` return 5) `f` (return 6 `f` return 7))) + ((tl $ (((singleton 0 <> singleton 1) <> (singleton 2 <> singleton 3)) + <> ((singleton 4 <> singleton 5) <> (singleton 6 <> singleton 7))) ) >>= return . srt) `shouldReturn` [0..7] - where tl = toListSerial + where tl = A.toList . t composeAndComposeSimple - :: (StreamT IO Int -> StreamT IO Int -> StreamT IO Int) - -> (StreamT IO Int -> StreamT IO Int -> StreamT IO Int) - -> [[Int]] - -> Spec -composeAndComposeSimple f g answer = do + :: ( IsStream t1, Semigroup (t1 IO Int) + , IsStream t2, Monoid (t2 IO Int), Monad (t2 IO) +#if __GLASGOW_HASKELL__ < 804 + , Semigroup (t2 IO Int) +#endif + ) + => (t1 IO Int -> SerialT IO Int) + -> (t2 IO Int -> t2 IO Int) + -> [[Int]] -> Spec +composeAndComposeSimple t1 t2 answer = do + let rfold = adapt . t2 . foldMapWith (<>) return it "Compose right associated outer expr, right folded inner" $ - let fold = foldMapWith g return - in (toListSerial (fold [1,2,3] `f` (fold [4,5,6] `f` fold [7,8,9]))) + ((A.toList . t1) (rfold [1,2,3] <> (rfold [4,5,6] <> rfold [7,8,9]))) `shouldReturn` (answer !! 0) it "Compose left associated outer expr, right folded inner" $ - let fold = foldMapWith g return - in (toListSerial ((fold [1,2,3] `f` fold [4,5,6]) `f` fold [7,8,9])) + ((A.toList . t1) ((rfold [1,2,3] <> rfold [4,5,6]) <> rfold [7,8,9])) `shouldReturn` (answer !! 1) + let lfold xs = adapt $ t2 $ foldl (<>) mempty $ map return xs it "Compose right associated outer expr, left folded inner" $ - let fold xs = foldl g empty $ map return xs - in (toListSerial (fold [1,2,3] `f` (fold [4,5,6] `f` fold [7,8,9]))) + ((A.toList . t1) (lfold [1,2,3] <> (lfold [4,5,6] <> lfold [7,8,9]))) `shouldReturn` (answer !! 2) it "Compose left associated outer expr, left folded inner" $ - let fold xs = foldl g empty $ map return xs - in (toListSerial ((fold [1,2,3] `f` fold [4,5,6]) `f` fold [7,8,9])) + ((A.toList . t1) ((lfold [1,2,3] <> lfold [4,5,6]) <> lfold [7,8,9])) `shouldReturn` (answer !! 3) - loops - :: (StreamT IO Int -> StreamT IO Int -> StreamT IO Int) + :: (IsStream t, Semigroup (t IO Int), Monad (t IO)) + => (t IO Int -> t IO Int) -> ([Int] -> [Int]) -> ([Int] -> [Int]) -> Spec -loops f tsrt hsrt = do - it "Tail recursive loop" $ (toListSerial (loopTail 0) >>= return . tsrt) +loops t tsrt hsrt = do + it "Tail recursive loop" $ ((A.toList . adapt) (loopTail 0) >>= return . tsrt) `shouldReturn` [0..3] - it "Head recursive loop" $ (toListSerial (loopHead 0) >>= return . hsrt) + it "Head recursive loop" $ ((A.toList . adapt) (loopHead 0) >>= return . hsrt) `shouldReturn` [0..3] where loopHead x = do -- this print line is important for the test (causes a bind) - liftIO $ putStrLn "LoopHead..." - (if x < 3 then loopHead (x + 1) else empty) `f` return x + A.once $ putStrLn "LoopHead..." + t $ (if x < 3 then loopHead (x + 1) else nil) <> return x loopTail x = do -- this print line is important for the test (causes a bind) - liftIO $ putStrLn "LoopTail..." - return x `f` (if x < 3 then loopTail (x + 1) else empty) + A.once $ putStrLn "LoopTail..." + t $ return x <> (if x < 3 then loopTail (x + 1) else nil) bindAndComposeSimple - :: (Streaming t, Alternative (t IO), Monad (t IO)) - => (forall a. Ord a => t IO a -> IO [a]) - -> (t IO Int -> t IO Int -> t IO Int) + :: ( IsStream t1, IsStream t2, Semigroup (t2 IO Int), Monad (t2 IO)) + => (t1 IO Int -> SerialT IO Int) + -> (t2 IO Int -> t2 IO Int) -> Spec -bindAndComposeSimple tl g = do +bindAndComposeSimple t1 t2 = do + -- XXX need a bind in the body of forEachWith instead of a simple return it "Compose many (right fold) with bind" $ - (tl (forEachWith g [1..10 :: Int] $ \x -> return x `f` (return . id)) + ((A.toList . t1) (adapt . t2 $ forEachWith (<>) [1..10 :: Int] return) >>= return . sort) `shouldReturn` [1..10] it "Compose many (left fold) with bind" $ - let forL xs k = foldl g empty $ map k xs - in (tl (forL [1..10 :: Int] $ \x -> return x `f` (return . id)) + let forL xs k = foldl (<>) nil $ map k xs + in ((A.toList . t1) (adapt . t2 $ forL [1..10 :: Int] return) >>= return . sort) `shouldReturn` [1..10] - where f = (>>=) bindAndComposeHierarchy - :: Monad (s IO) => (forall a. Ord a => s IO a -> IO [a]) - -> ([s IO Int] -> s IO Int) + :: ( IsStream t1, Monad (t1 IO) + , IsStream t2, Monad (t2 IO)) + => (t1 IO Int -> SerialT IO Int) + -> (t2 IO Int -> t2 IO Int) + -> ([t2 IO Int] -> t2 IO Int) -> Spec -bindAndComposeHierarchy tl g = do +bindAndComposeHierarchy t1 t2 g = do it "Bind and compose nested" $ - (tl bindComposeNested >>= return . sort) + ((A.toList . t1) bindComposeNested >>= return . sort) `shouldReturn` (sort ( [12, 18] ++ replicate 3 13 @@ -591,7 +659,7 @@ bindAndComposeHierarchy tl g = do where - -- bindComposeNested :: AsyncT IO Int + -- bindComposeNested :: WAsyncT IO Int bindComposeNested = let c1 = tripleCompose (return 1) (return 2) (return 3) c2 = tripleCompose (return 4) (return 5) (return 6) @@ -603,12 +671,11 @@ bindAndComposeHierarchy tl g = do -- in m in b - tripleCompose a b c = g [a, b, c] + tripleCompose a b c = adapt . t2 $ g [a, b, c] tripleBind mx my mz = - mx `f` \x -> my - `f` \y -> mz - `f` \z -> return (x + y + z) - f = (>>=) + mx >>= \x -> my + >>= \y -> mz + >>= \z -> return (x + y + z) mixedOps :: Spec mixedOps = do @@ -619,116 +686,23 @@ mixedOps = do ] :: [Int]) where - composeMixed :: StreamT IO Int + composeMixed :: SerialT IO Int composeMixed = do - liftIO $ return () - liftIO $ putStr "" + A.once $ return () + A.once $ putStr "" x <- return 1 y <- return 2 z <- do - x1 <- return 1 <|> return 2 - liftIO $ return () - liftIO $ putStr "" - y1 <- return 1 <| return 2 + x1 <- wAsyncly $ return 1 <> return 2 + A.once $ return () + A.once $ putStr "" + y1 <- asyncly $ return 1 <> return 2 z1 <- do x11 <- return 1 <> return 2 - y11 <- return 1 <| return 2 - z11 <- return 1 <=> return 2 - liftIO $ return () - liftIO $ putStr "" + y11 <- asyncly $ return 1 <> return 2 + z11 <- wSerially $ return 1 <> return 2 + A.once $ return () + A.once $ putStr "" return (x11 + y11 + z11) return (x1 + y1 + z1) return (x + y + z) - -streamOperations :: Streaming t => (t IO Int, [Int], Int) -> Spec -streamOperations (stream, list, len) = do - - -- Generation - it "replicateM" $ do - let x = return (1 :: Int) - str <- A.toList . serially $ A.replicateM len x - lst <- replicateM len x - return $ str == lst - `shouldReturn` True - - it "iterate" $ - (A.toList . serially . (A.take len) $ (A.iterate (+ 1) (0 :: Int))) - `shouldReturn` (take len $ iterate (+ 1) 0) - - it "iterateM" $ do - let addM = (\ y -> return (y + 1)) - A.toList . serially . (A.take len) $ A.iterateM addM (0 :: Int) - `shouldReturn` (take len $ iterate (+ 1) 0) - - - -- Filtering - it "filter all out" $ transform (A.filter (> len)) (filter (> len)) - it "filter all in" $ transform (A.filter (<= len)) (filter (<= len)) - it "filter even" $ transform (A.filter even) (filter even) - - it "take all" $ transform (A.take len) (take len) - it "take none" $ transform (A.take 0) (take 0) - it "take some" $ transform (A.take $ len - 1) (take $ len - 1) - it "take one" $ transform (A.take 1) (take 1) - - it "takeWhile true" $ transform (A.takeWhile (const True)) - (takeWhile (const True)) - it "takeWhile false" $ transform (A.takeWhile (const False)) - (takeWhile (const False)) - it "takeWhile < some" $ transform (A.takeWhile (< (len `div` 2))) - (takeWhile (< (len `div` 2))) - - it "drop all" $ transform (A.drop len) (drop len) - it "drop none" $ transform (A.drop 0) (drop 0) - it "drop some" $ transform (A.drop $ len - 1) (drop $ len - 1) - it "drop one" $ transform (A.drop 1) (drop 1) - - it "dropWhile true" $ transform (A.dropWhile (const True)) - (dropWhile (const True)) - it "dropWhile false" $ transform (A.dropWhile (const False)) - (dropWhile (const False)) - it "dropWhile < some" $ transform (A.dropWhile (< (len `div` 2))) - (dropWhile (< (len `div` 2))) - - -- Transformations - it "scan left" $ transform (A.scan (+) 0 id) (scanl (+) 0) - it "reverse" $ transform A.reverse reverse - - -- Elimination - it "foldl" $ elimination (A.foldl (+) 0 id) (foldl (+) 0) - it "all" $ elimination (A.all even) (all even) - it "any" $ elimination (A.any even) (any even) - it "length" $ elimination A.length length - it "elem" $ elimination (A.elem (len - 1)) (elem (len - 1)) - it "elem" $ elimination (A.elem (len + 1)) (elem (len + 1)) - it "notElem" $ elimination (A.notElem (len - 1)) (notElem (len - 1)) - it "notElem" $ elimination (A.notElem (len + 1)) (notElem (len + 1)) - it "sum" $ elimination A.sum sum - it "product" $ elimination A.product product - - if list == [] - then do - it "head empty" $ A.head stream `shouldReturn` Nothing - it "last empty" $ A.last stream `shouldReturn` Nothing - it "maximum empty" $ A.maximum stream `shouldReturn` Nothing - it "minimum empty" $ A.minimum stream `shouldReturn` Nothing - it "null empty" $ A.null stream `shouldReturn` True - it "tail empty" $ (A.tail stream >>= return . maybe True (const False)) - `shouldReturn` True - else do - it "head nonEmpty" $ A.head stream `shouldReturn` Just (head list) - it "last nonEmpty" $ A.last stream `shouldReturn` Just (last list) - it "maximum nonEmpty" $ A.maximum stream - `shouldReturn` Just (maximum list) - it "minimum nonEmpty" $ A.minimum stream - `shouldReturn` Just (minimum list) - it "null nonEmpty" $ A.null stream `shouldReturn` False - it "tail nonEmpty" $ (A.tail stream >>= A.toList . fromJust) - `shouldReturn` tail list - - where - -- XXX run on empty stream as well - transform streamOp listOp = - (A.toList $ streamOp stream) `shouldReturn` listOp list - - elimination streamOp listOp = (streamOp stream) `shouldReturn` listOp list diff --git a/test/Prop.hs b/test/Prop.hs new file mode 100644 index 0000000..fa9bf28 --- /dev/null +++ b/test/Prop.hs @@ -0,0 +1,447 @@ +{-# LANGUAGE CPP #-} + +module Main (main) where + +import Control.Monad (when) +import Control.Applicative (ZipList(..)) +import Control.Monad (replicateM) +import Data.List (sort, foldl', scanl') +import GHC.Word (Word8) + +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck (counterexample, Property) +import Test.QuickCheck.Monadic (run, monadicIO, monitor, assert, PropertyM) + +import Test.Hspec + +import Streamly +import Streamly.Prelude ((.:), nil) +import qualified Streamly.Prelude as A + +singleton :: IsStream t => a -> t m a +singleton a = a .: nil + +sortEq :: Ord a => [a] -> [a] -> Bool +sortEq a b = sort a == sort b + +equals + :: (Show a, Monad m) + => (a -> a -> Bool) -> a -> a -> PropertyM m () +equals eq stream list = do + when (not $ stream `eq` list) $ + monitor + (counterexample $ + "stream " ++ show stream ++ " /= list " ++ show list) + assert (stream `eq` list) + +constructWithReplicateM + :: IsStream t + => (t IO Int -> SerialT IO Int) + -> Word8 + -> Property +constructWithReplicateM op len = + monadicIO $ do + let x = return (1 :: Int) + stream <- run $ (A.toList . op) (A.replicateM (fromIntegral len) x) + list <- run $ replicateM (fromIntegral len) x + equals (==) stream list + +transformFromList + :: ([Int] -> t IO Int) + -> ([Int] -> [Int] -> Bool) + -> ([Int] -> [Int]) + -> (t IO Int -> SerialT IO Int) + -> [Int] + -> Property +transformFromList constr eq listOp op a = + monadicIO $ do + stream <- run ((A.toList . op) (constr a)) + let list = listOp a + equals eq stream list + +foldFromList + :: ([Int] -> t IO Int) + -> (t IO Int -> SerialT IO Int) + -> ([Int] -> [Int] -> Bool) + -> [Int] + -> Property +foldFromList constr op eq a = transformFromList constr eq id op a + +eliminateOp + :: (Show a, Eq a) + => ([Int] -> t IO Int) + -> ([Int] -> a) + -> (t IO Int -> IO a) + -> [Int] + -> Property +eliminateOp constr listOp op a = + monadicIO $ do + stream <- run $ op (constr a) + let list = listOp a + equals (==) stream list + +elemOp + :: ([Word8] -> t IO Word8) + -> (t IO Word8 -> SerialT IO Word8) + -> (Word8 -> SerialT IO Word8 -> IO Bool) + -> (Word8 -> [Word8] -> Bool) + -> (Word8, [Word8]) + -> Property +elemOp constr op streamOp listOp (x, xs) = + monadicIO $ do + stream <- run $ (streamOp x . op) (constr xs) + let list = listOp x xs + equals (==) stream list + +functorOps + :: Functor (t IO) + => ([Int] -> t IO Int) + -> String + -> (t IO Int -> SerialT IO Int) + -> ([Int] -> [Int] -> Bool) + -> Spec +functorOps constr desc t eq = do + prop (desc ++ " id") $ transformFromList constr eq id $ t + prop (desc ++ " fmap (+1)") $ transformFromList constr eq (fmap (+1)) $ t . (fmap (+1)) + +transformOps + :: IsStream t + => ([Int] -> t IO Int) + -> String + -> (t IO Int -> SerialT IO Int) + -> ([Int] -> [Int] -> Bool) + -> Spec +transformOps constr desc t eq = do + let transform = transformFromList constr eq + -- Filtering + prop (desc ++ " filter False") $ + transform (filter (const False)) $ t . (A.filter (const False)) + prop (desc ++ " filter True") $ + transform (filter (const True)) $ t . (A.filter (const True)) + prop (desc ++ " filter even") $ + transform (filter even) $ t . (A.filter even) + + prop (desc ++ " take maxBound") $ + transform (take maxBound) $ t . (A.take maxBound) + prop (desc ++ " take 0") $ transform (take 0) $ t . (A.take 0) + prop (desc ++ " take 1") $ transform (take 1) $ t . (A.take 1) + prop (desc ++ " take 10") $ transform (take 10) $ t . (A.take 10) + + prop (desc ++ " takeWhile True") $ + transform (takeWhile (const True)) $ t . (A.takeWhile (const True)) + prop (desc ++ " takeWhile False") $ + transform (takeWhile (const False)) $ t . (A.takeWhile (const False)) + prop (desc ++ " takeWhile > 0") $ + transform (takeWhile (> 0)) $ t . (A.takeWhile (> 0)) + + prop (desc ++ " drop maxBound") $ + transform (drop maxBound) $ t . (A.drop maxBound) + prop (desc ++ " drop 0") $ transform (drop 0) $ t . (A.drop 0) + prop (desc ++ " drop 1") $ transform (drop 1) $ t . (A.drop 1) + prop (desc ++ " drop 10") $ transform (drop 10) $ t . (A.drop 10) + + prop (desc ++ " dropWhile True") $ + transform (dropWhile (const True)) $ t . (A.dropWhile (const True)) + prop (desc ++ " dropWhile False") $ + transform (dropWhile (const False)) $ t . (A.dropWhile (const False)) + prop (desc ++ " dropWhile > 0") $ + transform (dropWhile (> 0)) $ t . (A.dropWhile (> 0)) + prop (desc ++ " scan") $ transform (scanl' (+) 0) $ t . (A.scanl' (+) 0) + prop (desc ++ "reverse") $ transform reverse $ t . A.reverse + +wrapMaybe :: Eq a1 => ([a1] -> a2) -> [a1] -> Maybe a2 +wrapMaybe f = + \x -> + if x == [] + then Nothing + else Just (f x) + +eliminationOps + :: ([Int] -> t IO Int) + -> String + -> (t IO Int -> SerialT IO Int) + -> Spec +eliminationOps constr desc t = do + -- Elimination + prop (desc ++ " null") $ eliminateOp constr null $ A.null . t + prop (desc ++ " foldl") $ + eliminateOp constr (foldl' (+) 0) $ (A.foldl' (+) 0) . t + prop (desc ++ " all") $ eliminateOp constr (all even) $ (A.all even) . t + prop (desc ++ " any") $ eliminateOp constr (any even) $ (A.any even) . t + prop (desc ++ " length") $ eliminateOp constr length $ A.length . t + prop (desc ++ " sum") $ eliminateOp constr sum $ A.sum . t + prop (desc ++ " product") $ eliminateOp constr product $ A.product . t + + prop (desc ++ " maximum") $ eliminateOp constr (wrapMaybe maximum) $ A.maximum . t + prop (desc ++ " minimum") $ eliminateOp constr (wrapMaybe minimum) $ A.minimum . t + +-- head/tail/last may depend on the order in case of parallel streams +-- so we test these only for serial streams. +serialEliminationOps + :: ([Int] -> t IO Int) + -> String + -> (t IO Int -> SerialT IO Int) + -> Spec +serialEliminationOps constr desc t = do + prop (desc ++ " head") $ eliminateOp constr (wrapMaybe head) $ A.head . t + prop (desc ++ " tail") $ eliminateOp constr (wrapMaybe tail) $ \x -> do + r <- A.tail (t x) + case r of + Nothing -> return Nothing + Just s -> A.toList s >>= return . Just + prop (desc ++ " last") $ eliminateOp constr (wrapMaybe last) $ A.last . t + +transformOpsWord8 + :: ([Word8] -> t IO Word8) + -> String + -> (t IO Word8 -> SerialT IO Word8) + -> Spec +transformOpsWord8 constr desc t = do + prop (desc ++ " elem") $ elemOp constr t A.elem elem + prop (desc ++ " elem") $ elemOp constr t A.notElem notElem + +-- XXX concatenate streams of multiple elements rather than single elements +semigroupOps + :: (IsStream t + +#if __GLASGOW_HASKELL__ < 804 + , Semigroup (t IO Int) +#endif + , Monoid (t IO Int)) + => String + -> (t IO Int -> SerialT IO Int) + -> ([Int] -> [Int] -> Bool) + -> Spec +semigroupOps desc t eq = do + prop (desc ++ " <>") $ foldFromList (foldMapWith (<>) singleton) t eq + prop (desc ++ " mappend") $ foldFromList (foldMapWith mappend singleton) t eq + +applicativeOps + :: Applicative (t IO) + => ([Int] -> t IO Int) + -> (t IO (Int, Int) -> SerialT IO (Int, Int)) + -> ([(Int, Int)] -> [(Int, Int)] -> Bool) + -> ([Int], [Int]) + -> Property +applicativeOps constr t eq (a, b) = monadicIO $ do + stream <- run ((A.toList . t) ((,) <$> (constr a) <*> (constr b))) + let list = (,) <$> a <*> b + equals eq stream list + +zipApplicative + :: (IsStream t, Applicative (t IO)) + => ([Int] -> t IO Int) + -> (t IO (Int, Int) -> SerialT IO (Int, Int)) + -> ([(Int, Int)] -> [(Int, Int)] -> Bool) + -> ([Int], [Int]) + -> Property +zipApplicative constr t eq (a, b) = monadicIO $ do + stream1 <- run ((A.toList . t) ((,) <$> (constr a) <*> (constr b))) + stream2 <- run ((A.toList . t) (pure (,) <*> (constr a) <*> (constr b))) + stream3 <- run ((A.toList . t) (A.zipWith (,) (constr a) (constr b))) + let list = getZipList $ (,) <$> ZipList a <*> ZipList b + equals eq stream1 list + equals eq stream2 list + equals eq stream3 list + +zipMonadic + :: (IsStream t, Monad (t IO)) + => ([Int] -> t IO Int) + -> (t IO (Int, Int) -> SerialT IO (Int, Int)) + -> ([(Int, Int)] -> [(Int, Int)] -> Bool) + -> ([Int], [Int]) + -> Property +zipMonadic constr t eq (a, b) = + monadicIO $ do + stream1 <- + run + ((A.toList . t) + (A.zipWithM (\x y -> return (x, y)) (constr a) (constr b))) + stream2 <- + run + ((A.toList . t) + (A.zipAsyncWithM (\x y -> return (x, y)) (constr a) (constr b))) + let list = getZipList $ (,) <$> ZipList a <*> ZipList b + equals eq stream1 list + equals eq stream2 list + +monadThen + :: Monad (t IO) + => ([Int] -> t IO Int) + -> (t IO Int -> SerialT IO Int) + -> ([Int] -> [Int] -> Bool) + -> ([Int], [Int]) + -> Property +monadThen constr t eq (a, b) = monadicIO $ do + stream <- run ((A.toList . t) ((constr a) >> (constr b))) + let list = a >> b + equals eq stream list + +monadBind + :: Monad (t IO) + => ([Int] -> t IO Int) + -> (t IO Int -> SerialT IO Int) + -> ([Int] -> [Int] -> Bool) + -> ([Int], [Int]) + -> Property +monadBind constr t eq (a, b) = + monadicIO $ do + stream <- + run + ((A.toList . t) + ((constr a) >>= \x -> (constr b) >>= return . (+ x))) + let list = a >>= \x -> b >>= return . (+ x) + equals eq stream list + +main :: IO () +main = hspec $ do + describe "Construction" $ do + -- XXX test for all types of streams + prop "serially replicateM" $ constructWithReplicateM serially + it "iterate" $ + (A.toList . serially . (A.take 100) $ (A.iterate (+ 1) (0 :: Int))) + `shouldReturn` (take 100 $ iterate (+ 1) 0) + + it "iterateM" $ do + let addM = (\ y -> return (y + 1)) + A.toList . serially . (A.take 100) $ A.iterateM addM (0 :: Int) + `shouldReturn` (take 100 $ iterate (+ 1) 0) + + let folded :: IsStream t => [a] -> t IO a + folded = serially . (\xs -> + case xs of + [x] -> return x -- singleton stream case + _ -> foldMapWith (<>) return xs + ) + describe "Functor operations" $ do + functorOps A.fromFoldable "serially" serially (==) + functorOps folded "serially folded" serially (==) + functorOps A.fromFoldable "wSerially" wSerially (==) + functorOps folded "wSerially folded" wSerially (==) + functorOps A.fromFoldable "asyncly" asyncly sortEq + functorOps folded "asyncly folded" asyncly sortEq + functorOps A.fromFoldable "wAsyncly" wAsyncly sortEq + functorOps folded "wAsyncly folded" wAsyncly sortEq + functorOps A.fromFoldable "parallely" parallely sortEq + functorOps folded "parallely folded" parallely sortEq + functorOps A.fromFoldable "zipSerially" zipSerially (==) + functorOps folded "zipSerially folded" zipSerially (==) + functorOps A.fromFoldable "zipAsyncly" zipAsyncly (==) + functorOps folded "zipAsyncly folded" zipAsyncly (==) + + describe "Semigroup operations" $ do + semigroupOps "serially" serially (==) + semigroupOps "wSerially" wSerially (==) + semigroupOps "asyncly" asyncly sortEq + semigroupOps "wAsyncly" wAsyncly sortEq + semigroupOps "parallely" parallely sortEq + semigroupOps "zipSerially" zipSerially (==) + semigroupOps "zipAsyncly" zipAsyncly (==) + + describe "Applicative operations" $ do + -- The tests using sorted equality are weaker tests + -- We need to have stronger unit tests for all those + -- XXX applicative with three arguments + prop "serially applicative" $ applicativeOps A.fromFoldable serially (==) + prop "serially applicative folded" $ applicativeOps folded serially (==) + prop "wSerially applicative" $ applicativeOps A.fromFoldable wSerially sortEq + prop "wSerially applicative folded" $ applicativeOps folded wSerially sortEq + prop "asyncly applicative" $ applicativeOps A.fromFoldable asyncly sortEq + prop "asyncly applicative folded" $ applicativeOps folded asyncly sortEq + prop "wAsyncly applicative folded" $ applicativeOps folded wAsyncly sortEq + prop "parallely applicative folded" $ applicativeOps folded parallely sortEq + + describe "Zip operations" $ do + prop "zipSerially applicative" $ zipApplicative A.fromFoldable zipSerially (==) + -- XXX this hangs + -- prop "zipAsyncly applicative" $ zipApplicative zipAsyncly (==) + prop "zip monadic serially" $ zipMonadic A.fromFoldable serially (==) + prop "zip monadic serially folded" $ zipMonadic folded serially (==) + prop "zip monadic wSerially" $ zipMonadic A.fromFoldable wSerially (==) + prop "zip monadic wSerially folded" $ zipMonadic folded wSerially (==) + prop "zip monadic asyncly" $ zipMonadic A.fromFoldable asyncly (==) + prop "zip monadic asyncly folded" $ zipMonadic folded asyncly (==) + prop "zip monadic wAsyncly" $ zipMonadic A.fromFoldable wAsyncly (==) + prop "zip monadic wAsyncly folded" $ zipMonadic folded wAsyncly (==) + prop "zip monadic parallely" $ zipMonadic A.fromFoldable parallely (==) + prop "zip monadic parallely folded" $ zipMonadic folded parallely (==) + + describe "Monad operations" $ do + prop "serially monad then" $ monadThen A.fromFoldable serially (==) + prop "wSerially monad then" $ monadThen A.fromFoldable wSerially sortEq + prop "asyncly monad then" $ monadThen A.fromFoldable asyncly sortEq + prop "wAsyncly monad then" $ monadThen A.fromFoldable wAsyncly sortEq + prop "parallely monad then" $ monadThen A.fromFoldable parallely sortEq + + prop "serially monad then folded" $ monadThen folded serially (==) + prop "wSerially monad then folded" $ monadThen folded wSerially sortEq + prop "asyncly monad then folded" $ monadThen folded asyncly sortEq + prop "wAsyncly monad then folded" $ monadThen folded wAsyncly sortEq + prop "parallely monad then folded" $ monadThen folded parallely sortEq + + prop "serially monad bind" $ monadBind A.fromFoldable serially (==) + prop "wSerially monad bind" $ monadBind A.fromFoldable wSerially sortEq + prop "asyncly monad bind" $ monadBind A.fromFoldable asyncly sortEq + prop "wAsyncly monad bind" $ monadBind A.fromFoldable wAsyncly sortEq + prop "parallely monad bind" $ monadBind A.fromFoldable parallely sortEq + + describe "Stream transform operations" $ do + transformOps A.fromFoldable "serially" serially (==) + transformOps A.fromFoldable "wSerially" wSerially (==) + transformOps A.fromFoldable "zipSerially" zipSerially (==) + transformOps A.fromFoldable "zipAsyncly" zipAsyncly (==) + transformOps A.fromFoldable "asyncly" asyncly sortEq + transformOps A.fromFoldable "wAsyncly" wAsyncly sortEq + transformOps A.fromFoldable "parallely" parallely sortEq + + transformOps folded "serially folded" serially (==) + transformOps folded "wSerially folded" wSerially (==) + transformOps folded "zipSerially folded" zipSerially (==) + transformOps folded "zipAsyncly folded" zipAsyncly (==) + transformOps folded "asyncly folded" asyncly sortEq + transformOps folded "wAsyncly folded" wAsyncly sortEq + transformOps folded "parallely folded" parallely sortEq + + transformOpsWord8 A.fromFoldable "serially" serially + transformOpsWord8 A.fromFoldable "wSerially" wSerially + transformOpsWord8 A.fromFoldable "zipSerially" zipSerially + transformOpsWord8 A.fromFoldable "zipAsyncly" zipAsyncly + transformOpsWord8 A.fromFoldable "asyncly" asyncly + transformOpsWord8 A.fromFoldable "wAsyncly" wAsyncly + transformOpsWord8 A.fromFoldable "parallely" parallely + + transformOpsWord8 folded "serially folded" serially + transformOpsWord8 folded "wSerially folded" wSerially + transformOpsWord8 folded "zipSerially folded" zipSerially + transformOpsWord8 folded "zipAsyncly folded" zipAsyncly + transformOpsWord8 folded "asyncly folded" asyncly + transformOpsWord8 folded "wAsyncly folded" wAsyncly + transformOpsWord8 folded "parallely folded" parallely + + describe "Stream elimination operations" $ do + eliminationOps A.fromFoldable "serially" serially + eliminationOps A.fromFoldable "wSerially" wSerially + eliminationOps A.fromFoldable "zipSerially" zipSerially + eliminationOps A.fromFoldable "zipAsyncly" zipAsyncly + eliminationOps A.fromFoldable "asyncly" asyncly + eliminationOps A.fromFoldable "wAsyncly" wAsyncly + eliminationOps A.fromFoldable "parallely" parallely + + eliminationOps folded "serially folded" serially + eliminationOps folded "wSerially folded" wSerially + eliminationOps folded "zipSerially folded" zipSerially + eliminationOps folded "zipAsyncly folded" zipAsyncly + eliminationOps folded "asyncly folded" asyncly + eliminationOps folded "wAsyncly folded" wAsyncly + eliminationOps folded "parallely folded" parallely + + describe "Stream elimination operations" $ do + serialEliminationOps A.fromFoldable "serially" serially + serialEliminationOps A.fromFoldable "wSerially" wSerially + serialEliminationOps A.fromFoldable "zipSerially" zipSerially + serialEliminationOps A.fromFoldable "zipAsyncly" zipAsyncly + + serialEliminationOps folded "serially folded" serially + serialEliminationOps folded "wSerially folded" wSerially + serialEliminationOps folded "zipSerially folded" zipSerially + serialEliminationOps folded "zipAsyncly folded" zipAsyncly diff --git a/test/loops.hs b/test/loops.hs new file mode 100644 index 0000000..1c03013 --- /dev/null +++ b/test/loops.hs @@ -0,0 +1,75 @@ +import Streamly +import System.IO (stdout, hSetBuffering, BufferMode(LineBuffering)) +import Streamly.Prelude (nil, once) + +main = do + hSetBuffering stdout LineBuffering + + putStrLn $ "\nloopTail:\n" + runStream $ do + x <- loopTail 0 + once $ print (x :: Int) + + putStrLn $ "\nloopHead:\n" + runStream $ do + x <- loopHead 0 + once $ print (x :: Int) + + putStrLn $ "\nloopTailA:\n" + runStream $ do + x <- loopTailA 0 + once $ print (x :: Int) + + putStrLn $ "\nloopHeadA:\n" + runStream $ do + x <- loopHeadA 0 + once $ print (x :: Int) + + putStrLn $ "\nwSerial:\n" + runStream $ do + x <- (return 0 <> return 1) `wSerial` (return 100 <> return 101) + once $ print (x :: Int) + + putStrLn $ "\nParallel interleave:\n" + runStream $ do + x <- (return 0 <> return 1) `wAsync` (return 100 <> return 101) + once $ print (x :: Int) + + where + +------------------------------------------------------------------------------- +-- Serial (single-threaded) stream generator loops +------------------------------------------------------------------------------- + + -- Generates a value and then loops. Can be used to generate an infinite + -- stream. Interleaves the generator and the consumer. + loopTail :: Int -> Serial Int + loopTail x = do + once $ putStrLn "LoopTail..." + return x <> (if x < 3 then loopTail (x + 1) else nil) + + -- Loops and then generates a value. The consumer can run only after the + -- loop has finished. An infinite generator will not let the consumer run + -- at all. + loopHead :: Int -> Serial Int + loopHead x = do + once $ putStrLn "LoopHead..." + (if x < 3 then loopHead (x + 1) else nil) <> return x + +------------------------------------------------------------------------------- +-- Concurrent (multi-threaded) adaptive demand-based stream generator loops +------------------------------------------------------------------------------- + + loopTailA :: Int -> Serial Int + loopTailA x = do + once $ putStrLn "LoopTailA..." + return x `async` (if x < 3 then loopTailA (x + 1) else nil) + + loopHeadA :: Int -> Serial Int + loopHeadA x = do + once $ putStrLn "LoopHeadA..." + (if x < 3 then loopHeadA (x + 1) else nil) `async` return x + +------------------------------------------------------------------------------- +-- Parallel (fairly scheduled, multi-threaded) stream generator loops +------------------------------------------------------------------------------- diff --git a/test/nested-loops.hs b/test/nested-loops.hs new file mode 100644 index 0000000..2d38990 --- /dev/null +++ b/test/nested-loops.hs @@ -0,0 +1,24 @@ +import Control.Concurrent (myThreadId) +import System.IO (stdout, hSetBuffering, BufferMode(LineBuffering)) +import System.Random (randomIO) +import Streamly +import Streamly.Prelude (nil, once) + +main = runStream $ do + once $ hSetBuffering stdout LineBuffering + x <- loop "A " 2 + y <- loop "B " 2 + once $ myThreadId >>= putStr . show + >> putStr " " + >> print (x, y) + + where + + -- we can just use + -- parallely $ mconcat $ replicate n $ once (...) + loop :: String -> Int -> SerialT IO String + loop name n = do + rnd <- once (randomIO :: IO Int) + let result = (name ++ show rnd) + repeat = if n > 1 then loop name (n - 1) else nil + in (return result) `wAsync` repeat diff --git a/test/parallel-loops.hs b/test/parallel-loops.hs new file mode 100644 index 0000000..d98e94a --- /dev/null +++ b/test/parallel-loops.hs @@ -0,0 +1,26 @@ +import Control.Concurrent (myThreadId, threadDelay) +import System.IO (stdout, hSetBuffering, BufferMode(LineBuffering)) +import System.Random (randomIO) +import Streamly +import qualified Streamly.Prelude as S + +main = do + hSetBuffering stdout LineBuffering + runStream $ do + x <- S.take 10 $ loop "A" `parallel` loop "B" + S.once $ myThreadId >>= putStr . show + >> putStr " got " + >> print x + + where + + -- we can just use + -- parallely $ cycle1 $ once (...) + loop :: String -> Serial (String, Int) + loop name = do + S.once $ threadDelay 1000000 + rnd <- S.once (randomIO :: IO Int) + S.once $ myThreadId >>= putStr . show + >> putStr " yielding " + >> print rnd + return (name, rnd) `parallel` loop name |