summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorharendra <>2018-12-31 06:11:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2018-12-31 06:11:00 (GMT)
commit34bfb30864ec4630fb02eefc34911548a6dcaca1 (patch)
tree33b4b62d67eaab02d0a74b521421459cc97b984d
parent31acd2a2ea16885665c1b2bec291c62c88a94824 (diff)
version 0.6.00.6.0
-rw-r--r--Changelog.md28
-rwxr-xr-xbench.sh32
-rw-r--r--benchmark/Adaptive.hs132
-rw-r--r--benchmark/BaseStreams.hs243
-rw-r--r--benchmark/Chart.hs255
-rw-r--r--benchmark/Linear.hs302
-rw-r--r--benchmark/LinearAsync.hs45
-rw-r--r--benchmark/LinearOps.hs433
-rw-r--r--benchmark/NanoBenchmarks.hs96
-rw-r--r--benchmark/Nested.hs18
-rw-r--r--benchmark/NestedOps.hs7
-rw-r--r--benchmark/StreamDOps.hs269
-rw-r--r--benchmark/StreamKOps.hs214
-rw-r--r--docs/streamly-vs-async.md5
-rw-r--r--examples/AcidRain.hs40
-rw-r--r--examples/ControlFlow.hs56
-rw-r--r--examples/MergeSort.hs38
-rw-r--r--src/Streamly.hs47
-rw-r--r--src/Streamly/Enumeration.hs550
-rw-r--r--src/Streamly/Internal.hs2
-rw-r--r--src/Streamly/List.hs188
-rw-r--r--src/Streamly/Prelude.hs1224
-rw-r--r--src/Streamly/SVar.hs14
-rw-r--r--src/Streamly/Streams/Ahead.hs121
-rw-r--r--src/Streamly/Streams/Async.hs149
-rw-r--r--src/Streamly/Streams/Combinators.hs216
-rw-r--r--src/Streamly/Streams/Instances.hs78
-rw-r--r--src/Streamly/Streams/Parallel.hs65
-rw-r--r--src/Streamly/Streams/Prelude.hs139
-rw-r--r--src/Streamly/Streams/SVar.hs224
-rw-r--r--src/Streamly/Streams/Serial.hs102
-rw-r--r--src/Streamly/Streams/StreamD.hs1047
-rw-r--r--src/Streamly/Streams/StreamD/Type.hs100
-rw-r--r--src/Streamly/Streams/StreamK.hs826
-rw-r--r--src/Streamly/Streams/StreamK/Type.hs418
-rw-r--r--src/Streamly/Streams/Zip.hs61
-rw-r--r--src/Streamly/Streams/inline.h3
-rw-r--r--src/Streamly/Streams/inline.hs27
-rw-r--r--src/Streamly/String.hs28
-rw-r--r--src/Streamly/Tutorial.hs151
-rw-r--r--stack-7.10.yaml1
-rw-r--r--stack-8.0.yaml1
-rw-r--r--stack.yaml6
-rw-r--r--streamly.cabal203
-rw-r--r--test/Prop.hs556
45 files changed, 6638 insertions, 2122 deletions
diff --git a/Changelog.md b/Changelog.md
index d246c09..1721c8b 100644
--- a/Changelog.md
+++ b/Changelog.md
@@ -1,3 +1,31 @@
+## 0.6.0
+
+### Breaking changes
+
+* `Monad` constraint may be needed on some of the existing APIs (`findIndices`
+ and `elemIndices`).
+
+### Enhancements
+
+* Add the following functions to Streamly.Prelude:
+ * Generation: `replicate`, `fromIndices`, `fromIndicesM`
+ * Enumeration: `Enumerable` type class, `enumerateFrom`, `enumerateFromTo`,
+ `enumerateFromThen`, `enumerateFromThenTo`, `enumerate`, `enumerateTo`
+ * Running: `runN`, `runWhile`
+ * Folds: `(!!)`, `maximumBy`, `minimumBy`, `the`
+ * Scans: `scanl1'`, `scanl1M'
+ * Filters: `uniq`, `insertBy`, `deleteBy`, `findM`
+ * Multi-stream: `eqBy`, `cmpBy`, `mergeBy`, `mergeByM`, `mergeAsyncBy`,
+ `mergeAsyncByM`, `isPrefixOf`, `isSubsequenceOf`, `stripPrefix`,
+ `concatMap`, `concatMapM`, `indexed`, `indexedR`
+* Following instances were added for `SerialT m`, `WSerialT m` and
+ `ZipSerialM m`:
+ * When `m` ~ `Identity`: IsList, Eq, Ord, Show, Read, IsString, NFData,
+ NFData1, Traversable
+ * When `m` is `Foldable`: Foldable
+* Performance improvements
+* Add benchmarks to measure composed and iterated operations
+
## 0.5.2
### Bug Fixes
diff --git a/bench.sh b/bench.sh
index ee63912..c45dc72 100755
--- a/bench.sh
+++ b/bench.sh
@@ -2,23 +2,26 @@
print_help () {
echo "Usage: $0 "
- echo " [--compare] [--base commit] [--candidate commit]"
echo " [--benchmarks <all|linear|linear-async|linear-rate|nested|base>]"
+ echo " [--group-diff]"
echo " [--graphs]"
- echo " [--slow]"
echo " [--no-measure]"
echo " [--append] "
+ echo " [--compare] [--base commit] [--candidate commit]"
+ echo " [--slow]"
echo " -- <gauge options>"
echo
echo "Multiple benchmarks can be specified as a space separate list"
echo " e.g. --benchmarks \"linear nested\""
echo
+ echo "--group-diff is used to compare groups within a single benchmark"
+ echo " e.g. StreamD vs StreamK in base benchmark."
+ 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
}
@@ -159,14 +162,14 @@ run_benches_comparing() {
echo "Checking out base commit [$BASE] for benchmarking"
git checkout "$BASE" || die "Checkout of base commit [$BASE] failed"
- $STACK build --bench --no-run-benchmarks || die "build failed"
+ $STACK build $STACK_BUILD_FLAGS --bench --no-run-benchmarks || die "build failed"
run_benches "$bench_list"
echo "Checking out candidate commit [$CANDIDATE] for benchmarking"
git checkout "$CANDIDATE" || \
die "Checkout of candidate [$CANDIDATE] commit failed"
- $STACK build --bench --no-run-benchmarks || die "build failed"
+ $STACK build $STACK_BUILD_FLAGS --bench --no-run-benchmarks || die "build failed"
run_benches "$bench_list"
# XXX reset back to the original commit
}
@@ -206,7 +209,9 @@ run_reports() {
for i in $1
do
echo "Generating reports for ${i}..."
- $prog --benchmark $i
+ $prog $(test "$GRAPH" = 1 && echo "--graphs") \
+ $(test "$GROUP_DIFF" = 1 && echo "--group-diff") \
+ --benchmark $i
done
}
@@ -216,6 +221,7 @@ run_reports() {
DEFAULT_BENCHMARKS="linear"
ALL_BENCHMARKS="linear linear-async linear-rate nested base"
+GROUP_DIFF=0
COMPARE=0
BASE=
@@ -240,13 +246,16 @@ while test -n "$1"
do
case $1 in
-h|--help|help) print_help ;;
+ # options with arguments
--slow) SPEED_OPTIONS="--min-duration 0"; shift ;;
- --append) APPEND=1; shift ;;
--benchmarks) shift; BENCHMARKS=$1; shift ;;
--base) shift; BASE=$1; shift ;;
--candidate) shift; CANDIDATE=$1; shift ;;
+ # flags
--compare) COMPARE=1; shift ;;
--raw) RAW=1; shift ;;
+ --append) APPEND=1; shift ;;
+ --group-diff) GROUP_DIFF=1; shift ;;
--graphs) GRAPH=1; shift ;;
--no-measure) MEASURE=0; shift ;;
--) shift; break ;;
@@ -259,6 +268,11 @@ GAUGE_ARGS=$*
echo "Using stack command [$STACK]"
set_benchmarks
+if echo "$BENCHMARKS" | grep -q base
+then
+ STACK_BUILD_FLAGS="--flag streamly:dev"
+fi
+
#-----------------------------------------------------------------------------
# Build stuff
#-----------------------------------------------------------------------------
@@ -273,7 +287,7 @@ build_report_progs "$BENCHMARKS"
if test "$MEASURE" = "1"
then
- $STACK build --bench --no-run-benchmarks || die "build failed"
+ $STACK build $STACK_BUILD_FLAGS --bench --no-run-benchmarks || die "build failed"
run_measurements "$BENCHMARKS"
fi
@@ -283,5 +297,5 @@ fi
if test "$RAW" = "0"
then
- run_reports "$BENCHMARKS"
+ run_reports "$BENCHMARKS"
fi
diff --git a/benchmark/Adaptive.hs b/benchmark/Adaptive.hs
new file mode 100644
index 0000000..48fe9b0
--- /dev/null
+++ b/benchmark/Adaptive.hs
@@ -0,0 +1,132 @@
+-- |
+-- Module : Main
+-- Copyright : (c) 2018 Harendra Kumar
+--
+-- License : BSD3
+-- Maintainer : harendra.kumar@gmail.com
+
+import Control.Concurrent (threadDelay)
+import Control.Monad (when)
+import Control.Monad.IO.Class (liftIO)
+import Gauge
+import Streamly
+import Streamly.Prelude as S
+import System.Random (randomRIO)
+
+-- Note that we should also compare the cpuTime especially when threaded
+-- runtime is used with this benchmark because thread scheduling is not
+-- predictable and can add non-deterministic delay to the total time measured.
+--
+-- Also, the worker dispatch depends on the worker dispatch latency which is
+-- set to fixed 200 us. We need to keep that in mind when designing tests.
+
+value :: Int
+value = 1000
+
+{-# INLINE source #-}
+source :: IsStream t => (Int, Int) -> t IO Int
+source range = S.replicateM value $ do
+ r <- randomRIO range
+ when (r /= 0) $ liftIO $ threadDelay r
+ return r
+
+{-# INLINE run #-}
+run :: IsStream t => (Int, Int) -> (Int, Int) -> (t IO Int -> SerialT IO Int) -> IO ()
+run srange crange t = runStream $ do
+ n <- t $ source srange
+ d <- liftIO (randomRIO crange)
+ when (d /= 0) $ liftIO $ threadDelay d
+ return n
+
+low, medium, high :: Int
+low = 10
+medium = 20
+high = 30
+
+{-# INLINE noDelay #-}
+noDelay :: IsStream t => (t IO Int -> SerialT IO Int) -> IO ()
+noDelay = run (0,0) (0,0)
+
+{-# INLINE alwaysConstSlowSerial #-}
+alwaysConstSlowSerial :: IsStream t => (t IO Int -> SerialT IO Int) -> IO ()
+alwaysConstSlowSerial = run (0,0) (medium,medium)
+
+{-# INLINE alwaysConstSlow #-}
+alwaysConstSlow :: IsStream t => (t IO Int -> SerialT IO Int) -> IO ()
+alwaysConstSlow = run (low,low) (medium,medium)
+
+{-# INLINE alwaysConstFast #-}
+alwaysConstFast :: IsStream t => (t IO Int -> SerialT IO Int) -> IO ()
+alwaysConstFast = run (high,high) (medium,medium)
+
+{-# INLINE alwaysVarSlow #-}
+alwaysVarSlow :: IsStream t => (t IO Int -> SerialT IO Int) -> IO ()
+alwaysVarSlow = run (low,low) (low,high)
+
+{-# INLINE alwaysVarFast #-}
+alwaysVarFast :: IsStream t => (t IO Int -> SerialT IO Int) -> IO ()
+alwaysVarFast = run (high,high) (low,high)
+
+-- XXX add variable producer tests as well
+
+{-# INLINE runVarSometimesFast #-}
+runVarSometimesFast :: IsStream t => (t IO Int -> SerialT IO Int) -> IO ()
+runVarSometimesFast = run (medium,medium) (low,high)
+
+{-# INLINE randomVar #-}
+randomVar :: IsStream t => (t IO Int -> SerialT IO Int) -> IO ()
+randomVar = run (low,high) (low,high)
+
+main :: IO ()
+main =
+ defaultMain
+ [
+ bgroup "serialConstantSlowConsumer"
+ [ bench "serially" $ nfIO $ alwaysConstSlowSerial serially
+ , bench "wSerially" $ nfIO $ alwaysConstSlowSerial wSerially
+ ]
+ , bgroup "default"
+ [ bench "serially" $ nfIO $ noDelay serially
+ , bench "wSerially" $ nfIO $ noDelay wSerially
+ , bench "aheadly" $ nfIO $ noDelay aheadly
+ , bench "asyncly" $ nfIO $ noDelay asyncly
+ , bench "wAsyncly" $ nfIO $ noDelay wAsyncly
+ , bench "parallely" $ nfIO $ noDelay parallely
+ ]
+ , bgroup "constantSlowConsumer"
+ [ bench "aheadly" $ nfIO $ alwaysConstSlow aheadly
+ , bench "asyncly" $ nfIO $ alwaysConstSlow asyncly
+ , bench "wAsyncly" $ nfIO $ alwaysConstSlow wAsyncly
+ , bench "parallely" $ nfIO $ alwaysConstSlow parallely
+ ]
+ , bgroup "constantFastConsumer"
+ [ bench "aheadly" $ nfIO $ alwaysConstFast aheadly
+ , bench "asyncly" $ nfIO $ alwaysConstFast asyncly
+ , bench "wAsyncly" $ nfIO $ alwaysConstFast wAsyncly
+ , bench "parallely" $ nfIO $ alwaysConstFast parallely
+ ]
+ , bgroup "variableSlowConsumer"
+ [ bench "aheadly" $ nfIO $ alwaysVarSlow aheadly
+ , bench "asyncly" $ nfIO $ alwaysVarSlow asyncly
+ , bench "wAsyncly" $ nfIO $ alwaysVarSlow wAsyncly
+ , bench "parallely" $ nfIO $ alwaysVarSlow parallely
+ ]
+ , bgroup "variableFastConsumer"
+ [ bench "aheadly" $ nfIO $ alwaysVarFast aheadly
+ , bench "asyncly" $ nfIO $ alwaysVarFast asyncly
+ , bench "wAsyncly" $ nfIO $ alwaysVarFast wAsyncly
+ , bench "parallely" $ nfIO $ alwaysVarFast parallely
+ ]
+ , bgroup "variableSometimesFastConsumer"
+ [ bench "aheadly" $ nfIO $ runVarSometimesFast aheadly
+ , bench "asyncly" $ nfIO $ runVarSometimesFast asyncly
+ , bench "wAsyncly" $ nfIO $ runVarSometimesFast wAsyncly
+ , bench "parallely" $ nfIO $ runVarSometimesFast parallely
+ ]
+ , bgroup "variableFullOverlap"
+ [ bench "aheadly" $ nfIO $ randomVar aheadly
+ , bench "asyncly" $ nfIO $ randomVar asyncly
+ , bench "wAsyncly" $ nfIO $ randomVar wAsyncly
+ , bench "parallely" $ nfIO $ randomVar parallely
+ ]
+ ]
diff --git a/benchmark/BaseStreams.hs b/benchmark/BaseStreams.hs
index 86a7e99..df1646b 100644
--- a/benchmark/BaseStreams.hs
+++ b/benchmark/BaseStreams.hs
@@ -19,11 +19,20 @@ import qualified StreamKOps as K
-- completely optimized out by the compiler in some cases.
{-# INLINE benchIO #-}
benchIO :: String -> (a IO Int -> IO ()) -> (Int -> a IO Int) -> Benchmark
-benchIO name run f = bench name $ nfIO $ randomRIO (1,1000) >>= run . f
+benchIO name run f = bench name $ nfIO $ randomRIO (1,1) >>= run . f
benchFold :: NFData b
=> String -> (t IO Int -> IO b) -> (Int -> t IO Int) -> Benchmark
-benchFold name f src = bench name $ nfIO $ randomRIO (1,1000) >>= f . src
+benchFold name f src = bench name $ nfIO $ randomRIO (1,1) >>= f . src
+
+-- | Takes a source, and uses it with a default drain/fold method.
+{-# INLINE benchD #-}
+benchD :: String -> (Int -> D.Stream IO Int) -> Benchmark
+benchD name f = bench name $ nfIO $ randomRIO (1,1) >>= D.toNull . f
+
+{-# INLINE benchK #-}
+benchK :: String -> (Int -> K.Stream IO Int) -> Benchmark
+benchK name f = bench name $ nfIO $ randomRIO (1,1) >>= K.toNull . f
{-
_benchId :: NFData b => String -> (Ops.Stream m Int -> Identity b) -> Benchmark
@@ -37,45 +46,108 @@ main =
[ bgroup "generation"
[ benchIO "unfoldr" D.toNull D.sourceUnfoldr
, benchIO "unfoldrM" D.toNull D.sourceUnfoldrM
- , benchIO "fromEnum" D.toNull D.sourceFromEnum
+ , benchIO "intFromTo" D.toNull D.sourceIntFromTo
, benchIO "fromList" D.toNull D.sourceFromList
-- , benchIO "fromFoldableM" D.sourceFromFoldableM
]
, bgroup "elimination"
- [ benchIO "toNull" D.toNull D.sourceUnfoldrM
- , benchIO "uncons" D.uncons D.sourceUnfoldrM
- , benchIO "nullHeadTail" D.nullHeadTail D.sourceUnfoldrM
+ [ benchIO "toNull" D.toNull D.sourceUnfoldrM
+ , benchIO "uncons" D.uncons D.sourceUnfoldrM
+ , benchFold "tail" D.tail D.sourceUnfoldrM
+ , benchIO "nullTail" D.nullTail D.sourceUnfoldrM
+ , benchIO "headTail" D.headTail D.sourceUnfoldrM
+ , benchFold "toList" K.toList K.sourceUnfoldrM
+ , benchFold "fold" K.foldl K.sourceUnfoldrM
+ , benchFold "last" K.last K.sourceUnfoldrM
]
, bgroup "transformation"
- [ benchIO "scanlM'" D.scan D.sourceUnfoldrM
- , benchIO "map" D.map D.sourceUnfoldrM
- , benchIO "mapM" D.mapM D.sourceUnfoldrM
+ [ benchIO "scan" (D.scan 1) D.sourceUnfoldrM
+ , benchIO "map" (D.map 1) D.sourceUnfoldrM
+ , benchIO "fmap" (D.fmap 1) D.sourceUnfoldrM
+ , benchIO "mapM" (D.mapM 1) D.sourceUnfoldrM
+ , benchIO "mapMaybe" (D.mapMaybe 1) D.sourceUnfoldrM
+ , benchIO "mapMaybeM" (D.mapMaybeM 1) D.sourceUnfoldrM
+ ]
+ , bgroup "transformationX4"
+ [ benchIO "scan" (D.scan 4) D.sourceUnfoldrM
+ , benchIO "map" (D.map 4) D.sourceUnfoldrM
+ , benchIO "fmap" (D.fmap 4) D.sourceUnfoldrM
+ , benchIO "mapM" (D.mapM 4) D.sourceUnfoldrM
+ , benchIO "mapMaybe" (D.mapMaybe 4) D.sourceUnfoldrM
+ , benchIO "mapMaybeM" (D.mapMaybeM 4) D.sourceUnfoldrM
]
, bgroup "filtering"
- [ benchIO "filter-even" D.filterEven D.sourceUnfoldrM
- , benchIO "filter-all-out" D.filterAllOut D.sourceUnfoldrM
- , benchIO "filter-all-in" D.filterAllIn D.sourceUnfoldrM
- , benchIO "take-all" D.takeAll D.sourceUnfoldrM
- , benchIO "takeWhile-true" D.takeWhileTrue D.sourceUnfoldrM
- , benchIO "drop-all" D.dropAll D.sourceUnfoldrM
- , benchIO "dropWhile-true" D.dropWhileTrue D.sourceUnfoldrM
- ]
- , benchIO "zip" D.zip D.sourceUnfoldrM
- , bgroup "compose"
- [ benchIO "mapM" D.composeMapM D.sourceUnfoldrM
-#if __GLASGOW_HASKELL__ != 802
- , benchIO "map-with-all-in-filter" D.composeMapAllInFilter D.sourceUnfoldrM
- , benchIO "all-in-filters" D.composeAllInFilters D.sourceUnfoldrM
- , benchIO "all-out-filters" D.composeAllOutFilters D.sourceUnfoldrM
-#endif
- ]
- -- Scaling with same operation in sequence
- , bgroup "compose-scaling"
- [ benchIO "1" (D.composeScaling 1) D.sourceUnfoldrM
- , benchIO "2" (D.composeScaling 2) D.sourceUnfoldrM
- , benchIO "3" (D.composeScaling 3) D.sourceUnfoldrM
- , benchIO "4" (D.composeScaling 4) D.sourceUnfoldrM
+ [ benchIO "filter-even" (D.filterEven 1) D.sourceUnfoldrM
+ , benchIO "filter-all-out" (D.filterAllOut 1) D.sourceUnfoldrM
+ , benchIO "filter-all-in" (D.filterAllIn 1) D.sourceUnfoldrM
+ , benchIO "take-all" (D.takeAll 1) D.sourceUnfoldrM
+ , benchIO "takeWhile-true" (D.takeWhileTrue 1) D.sourceUnfoldrM
+ , benchIO "drop-one" (D.dropOne 1) D.sourceUnfoldrM
+ , benchIO "drop-all" (D.dropAll 1) D.sourceUnfoldrM
+ , benchIO "dropWhile-true" (D.dropWhileTrue 1) D.sourceUnfoldrM
+ , benchIO "dropWhile-false" (D.dropWhileFalse 1) D.sourceUnfoldrM
+ ]
+ , bgroup "filteringX4"
+ [ benchIO "filter-even" (D.filterEven 4) D.sourceUnfoldrM
+ , benchIO "filter-all-out" (D.filterAllOut 4) D.sourceUnfoldrM
+ , benchIO "filter-all-in" (D.filterAllIn 4) D.sourceUnfoldrM
+ , benchIO "take-all" (D.takeAll 4) D.sourceUnfoldrM
+ , benchIO "takeWhile-true" (D.takeWhileTrue 4) D.sourceUnfoldrM
+ , benchIO "drop-one" (D.dropOne 4) D.sourceUnfoldrM
+ , benchIO "drop-all" (D.dropAll 4) D.sourceUnfoldrM
+ , benchIO "dropWhile-true" (D.dropWhileTrue 4) D.sourceUnfoldrM
+ , benchIO "dropWhile-false" (D.dropWhileFalse 4) D.sourceUnfoldrM
+ ]
+ , bgroup "zipping"
+ [ benchFold "eqBy" D.eqBy D.sourceUnfoldrM
+ , benchFold "cmpBy" D.cmpBy D.sourceUnfoldrM
+ , benchIO "zip" D.zip D.sourceUnfoldrM
+ ]
+ , bgroup "mixed"
+ [ benchIO "scan-map" (D.scanMap 1) D.sourceUnfoldrM
+ , benchIO "drop-map" (D.dropMap 1) D.sourceUnfoldrM
+ , benchIO "drop-scan" (D.dropScan 1) D.sourceUnfoldrM
+ , benchIO "take-drop" (D.takeDrop 1) D.sourceUnfoldrM
+ , benchIO "take-scan" (D.takeScan 1) D.sourceUnfoldrM
+ , benchIO "take-map" (D.takeMap 1) D.sourceUnfoldrM
+ , benchIO "filter-drop" (D.filterDrop 1) D.sourceUnfoldrM
+ , benchIO "filter-take" (D.filterTake 1) D.sourceUnfoldrM
+ , benchIO "filter-scan" (D.filterScan 1) D.sourceUnfoldrM
+ , benchIO "filter-map" (D.filterMap 1) D.sourceUnfoldrM
+ ]
+ , bgroup "mixedX2"
+ [ benchIO "scan-map" (D.scanMap 2) D.sourceUnfoldrM
+ , benchIO "drop-map" (D.dropMap 2) D.sourceUnfoldrM
+ , benchIO "drop-scan" (D.dropScan 2) D.sourceUnfoldrM
+ , benchIO "take-drop" (D.takeDrop 2) D.sourceUnfoldrM
+ , benchIO "take-scan" (D.takeScan 2) D.sourceUnfoldrM
+ , benchIO "take-map" (D.takeMap 2) D.sourceUnfoldrM
+ , benchIO "filter-drop" (D.filterDrop 2) D.sourceUnfoldrM
+ , benchIO "filter-take" (D.filterTake 2) D.sourceUnfoldrM
+ , benchIO "filter-scan" (D.filterScan 2) D.sourceUnfoldrM
+ , benchIO "filter-map" (D.filterMap 2) D.sourceUnfoldrM
+ ]
+ , bgroup "mixedX4"
+ [ benchIO "scan-map" (D.scanMap 4) D.sourceUnfoldrM
+ , benchIO "drop-map" (D.dropMap 4) D.sourceUnfoldrM
+ , benchIO "drop-scan" (D.dropScan 4) D.sourceUnfoldrM
+ , benchIO "take-drop" (D.takeDrop 4) D.sourceUnfoldrM
+ , benchIO "take-scan" (D.takeScan 4) D.sourceUnfoldrM
+ , benchIO "take-map" (D.takeMap 4) D.sourceUnfoldrM
+ , benchIO "filter-drop" (D.filterDrop 4) D.sourceUnfoldrM
+ , benchIO "filter-take" (D.filterTake 4) D.sourceUnfoldrM
+ , benchIO "filter-scan" (D.filterScan 4) D.sourceUnfoldrM
+ , benchIO "filter-map" (D.filterMap 4) D.sourceUnfoldrM
+ ]
+ , bgroup "iterated"
+ [ benchD "mapM" D.iterateMapM
+ , benchD "scan(1/10)" D.iterateScan
+ , benchD "filterEven" D.iterateFilterEven
+ , benchD "takeAll" D.iterateTakeAll
+ , benchD "dropOne" D.iterateDropOne
+ , benchD "dropWhileFalse(1/10)" D.iterateDropWhileFalse
+ , benchD "dropWhileTrue" D.iterateDropWhileTrue
]
]
, bgroup "streamK"
@@ -93,42 +165,99 @@ main =
]
, bgroup "elimination"
[ benchIO "toNull" K.toNull K.sourceUnfoldrM
+ , benchIO "mapM_" K.mapM_ K.sourceUnfoldrM
, benchIO "uncons" K.uncons K.sourceUnfoldrM
, benchFold "init" K.init K.sourceUnfoldrM
, benchFold "tail" K.tail K.sourceUnfoldrM
- , benchIO "nullHeadTail" K.nullHeadTail K.sourceUnfoldrM
+ , benchIO "nullTail" K.nullTail K.sourceUnfoldrM
+ , benchIO "headTail" K.headTail K.sourceUnfoldrM
, benchFold "toList" K.toList K.sourceUnfoldrM
, benchFold "fold" K.foldl K.sourceUnfoldrM
, benchFold "last" K.last K.sourceUnfoldrM
]
, bgroup "transformation"
- [ benchIO "scan" K.scan K.sourceUnfoldrM
- , benchIO "map" K.map K.sourceUnfoldrM
- , benchIO "mapM" K.mapM K.sourceUnfoldrM
+ [ benchIO "scan" (K.scan 1) K.sourceUnfoldrM
+ , benchIO "map" (K.map 1) K.sourceUnfoldrM
+ , benchIO "fmap" (K.fmap 1) K.sourceUnfoldrM
+ , benchIO "mapM" (K.mapM 1) K.sourceUnfoldrM
+ -- , benchIO "concat" K.concat K.sourceUnfoldrM
+ ]
+ , bgroup "transformationX4"
+ [ benchIO "scan" (K.scan 4) K.sourceUnfoldrM
+ , benchIO "map" (K.map 4) K.sourceUnfoldrM
+ , benchIO "fmap" (K.fmap 4) K.sourceUnfoldrM
+ , benchIO "mapM" (K.mapM 4) K.sourceUnfoldrM
-- , benchIO "concat" K.concat K.sourceUnfoldrM
]
, bgroup "filtering"
- [ benchIO "filter-even" K.filterEven K.sourceUnfoldrM
- , benchIO "filter-all-out" K.filterAllOut K.sourceUnfoldrM
- , benchIO "filter-all-in" K.filterAllIn K.sourceUnfoldrM
- , benchIO "take-all" K.takeAll K.sourceUnfoldrM
- , benchIO "takeWhile-true" K.takeWhileTrue K.sourceUnfoldrM
- , benchIO "drop-all" K.dropAll K.sourceUnfoldrM
- , benchIO "dropWhile-true" K.dropWhileTrue K.sourceUnfoldrM
- ]
- , benchIO "zip" K.zip K.sourceUnfoldrM
- , bgroup "compose"
- [ benchIO "mapM" K.composeMapM K.sourceUnfoldrM
- , benchIO "map-with-all-in-filter" K.composeMapAllInFilter K.sourceUnfoldrM
- , benchIO "all-in-filters" K.composeAllInFilters K.sourceUnfoldrM
- , benchIO "all-out-filters" K.composeAllOutFilters K.sourceUnfoldrM
- ]
- -- Scaling with same operation in sequence
- , bgroup "compose-scaling"
- [ benchIO "1" (K.composeScaling 1) K.sourceUnfoldrM
- , benchIO "2" (K.composeScaling 2) K.sourceUnfoldrM
- , benchIO "3" (K.composeScaling 3) K.sourceUnfoldrM
- , benchIO "4" (K.composeScaling 4) K.sourceUnfoldrM
+ [ benchIO "filter-even" (K.filterEven 1) K.sourceUnfoldrM
+ , benchIO "filter-all-out" (K.filterAllOut 1) K.sourceUnfoldrM
+ , benchIO "filter-all-in" (K.filterAllIn 1) K.sourceUnfoldrM
+ , benchIO "take-all" (K.takeAll 1) K.sourceUnfoldrM
+ , benchIO "takeWhile-true" (K.takeWhileTrue 1) K.sourceUnfoldrM
+ , benchIO "drop-one" (K.dropOne 1) K.sourceUnfoldrM
+ , benchIO "drop-all" (K.dropAll 1) K.sourceUnfoldrM
+ , benchIO "dropWhile-true" (K.dropWhileTrue 1) K.sourceUnfoldrM
+ , benchIO "dropWhile-false" (K.dropWhileFalse 1) K.sourceUnfoldrM
+ ]
+ , bgroup "filteringX4"
+ [ benchIO "filter-even" (K.filterEven 4) K.sourceUnfoldrM
+ , benchIO "filter-all-out" (K.filterAllOut 4) K.sourceUnfoldrM
+ , benchIO "filter-all-in" (K.filterAllIn 4) K.sourceUnfoldrM
+ , benchIO "take-all" (K.takeAll 4) K.sourceUnfoldrM
+ , benchIO "takeWhile-true" (K.takeWhileTrue 4) K.sourceUnfoldrM
+ , benchIO "drop-one" (K.dropOne 4) K.sourceUnfoldrM
+ , benchIO "drop-all" (K.dropAll 4) K.sourceUnfoldrM
+ , benchIO "dropWhile-true" (K.dropWhileTrue 4) K.sourceUnfoldrM
+ , benchIO "dropWhile-false" (K.dropWhileFalse 4) K.sourceUnfoldrM
+ ]
+ , bgroup "zipping"
+ [ benchIO "zip" K.zip K.sourceUnfoldrM
+ ]
+ , bgroup "mixed"
+ [ benchIO "scan-map" (K.scanMap 1) K.sourceUnfoldrM
+ , benchIO "drop-map" (K.dropMap 1) K.sourceUnfoldrM
+ , benchIO "drop-scan" (K.dropScan 1) K.sourceUnfoldrM
+ , benchIO "take-drop" (K.takeDrop 1) K.sourceUnfoldrM
+ , benchIO "take-scan" (K.takeScan 1) K.sourceUnfoldrM
+ , benchIO "take-map" (K.takeMap 1) K.sourceUnfoldrM
+ , benchIO "filter-drop" (K.filterDrop 1) K.sourceUnfoldrM
+ , benchIO "filter-take" (K.filterTake 1) K.sourceUnfoldrM
+ , benchIO "filter-scan" (K.filterScan 1) K.sourceUnfoldrM
+ , benchIO "filter-map" (K.filterMap 1) K.sourceUnfoldrM
+ ]
+ , bgroup "mixedX2"
+ [ benchIO "scan-map" (K.scanMap 2) K.sourceUnfoldrM
+ , benchIO "drop-map" (K.dropMap 2) K.sourceUnfoldrM
+ , benchIO "drop-scan" (K.dropScan 2) K.sourceUnfoldrM
+ , benchIO "take-drop" (K.takeDrop 2) K.sourceUnfoldrM
+ , benchIO "take-scan" (K.takeScan 2) K.sourceUnfoldrM
+ , benchIO "take-map" (K.takeMap 2) K.sourceUnfoldrM
+ , benchIO "filter-drop" (K.filterDrop 2) K.sourceUnfoldrM
+ , benchIO "filter-take" (K.filterTake 2) K.sourceUnfoldrM
+ , benchIO "filter-scan" (K.filterScan 2) K.sourceUnfoldrM
+ , benchIO "filter-map" (K.filterMap 2) K.sourceUnfoldrM
+ ]
+ , bgroup "mixedX4"
+ [ benchIO "scan-map" (K.scanMap 4) K.sourceUnfoldrM
+ , benchIO "drop-map" (K.dropMap 4) K.sourceUnfoldrM
+ , benchIO "drop-scan" (K.dropScan 4) K.sourceUnfoldrM
+ , benchIO "take-drop" (K.takeDrop 4) K.sourceUnfoldrM
+ , benchIO "take-scan" (K.takeScan 4) K.sourceUnfoldrM
+ , benchIO "take-map" (K.takeMap 4) K.sourceUnfoldrM
+ , benchIO "filter-drop" (K.filterDrop 4) K.sourceUnfoldrM
+ , benchIO "filter-take" (K.filterTake 4) K.sourceUnfoldrM
+ , benchIO "filter-scan" (K.filterScan 4) K.sourceUnfoldrM
+ , benchIO "filter-map" (K.filterMap 4) K.sourceUnfoldrM
+ ]
+ , bgroup "iterated"
+ [ benchK "mapM" K.iterateMapM
+ , benchK "scan(1/10)" K.iterateScan
+ , benchK "filterEven" K.iterateFilterEven
+ , benchK "takeAll" K.iterateTakeAll
+ , benchK "dropOne" K.iterateDropOne
+ , benchK "dropWhileFalse(1/10)" K.iterateDropWhileFalse
+ , benchK "dropWhileTrue" K.iterateDropWhileTrue
]
]
]
diff --git a/benchmark/Chart.hs b/benchmark/Chart.hs
index cf0c37d..f18deb0 100644
--- a/benchmark/Chart.hs
+++ b/benchmark/Chart.hs
@@ -7,8 +7,10 @@ module Main where
import Control.Exception (handle, catch, SomeException, ErrorCall(..))
import Control.Monad.Trans.State
import Control.Monad.Trans.Maybe
+import Data.Function (on, (&))
import Data.List
import Data.List.Split
+import Data.Maybe (mapMaybe)
import Data.Ord (comparing)
import System.Environment (getArgs)
import Control.Monad.IO.Class (liftIO)
@@ -21,18 +23,24 @@ import BenchShow
------------------------------------------------------------------------------
data BenchType = Linear | LinearAsync | LinearRate | Nested | Base
+ deriving Show
data Options = Options
{ genGraphs :: Bool
+ , groupDiff :: Bool
, benchType :: BenchType
- }
+ } deriving Show
-defaultOptions = Options False Linear
+defaultOptions = Options False False Linear
setGenGraphs val = do
(args, opts) <- get
put (args, opts { genGraphs = val })
+setGroupDiff val = do
+ (args, opts) <- get
+ put (args, opts { groupDiff = val })
+
setBenchType val = do
(args, opts) <- get
put (args, opts { benchType = val })
@@ -66,15 +74,25 @@ parseOptions :: IO (Maybe Options)
parseOptions = do
args <- getArgs
runMaybeT $ flip evalStateT (args, defaultOptions) $ do
- x <- shift
- case x of
- Just "--graphs" -> setGenGraphs True
- Just "--benchmark" -> parseBench
- Just str -> do
+ parseLoop
+ fmap snd get
+
+ where
+
+ parseOpt opt =
+ case opt of
+ "--graphs" -> setGenGraphs True
+ "--group-diff" -> setGroupDiff True
+ "--benchmark" -> parseBench
+ str -> do
liftIO $ putStrLn $ "Unrecognized option " <> str
mzero
+
+ parseLoop = do
+ next <- shift
+ case next of
+ Just opt -> parseOpt opt >> parseLoop
Nothing -> return ()
- fmap snd get
ignoringErr a = catch a (\(ErrorCall err :: ErrorCall) ->
putStrLn $ "Failed with error:\n" <> err <> "\nSkipping.")
@@ -84,35 +102,59 @@ ignoringErr a = catch a (\(ErrorCall err :: ErrorCall) ->
------------------------------------------------------------------------------
makeLinearGraphs :: Config -> String -> IO ()
-makeLinearGraphs cfg inputFile = do
- ignoringErr $ graph inputFile "operations" $ cfg
- { title = Just "Streamly operations"
- , classifyBenchmark = \b ->
- if not ("serially/" `isPrefixOf` b)
- || "/generation" `isInfixOf` b
- || "/compose" `isInfixOf` b
- || "/concat" `isSuffixOf` b
- then Nothing
- else Just ("Streamly", last $ splitOn "/" b)
+makeLinearGraphs cfg@Config{..} inputFile = do
+ ignoringErr $ graph inputFile "generation" $ cfg
+ { title = (++) <$> title <*> Just " generation"
+ , classifyBenchmark =
+ fmap ("Streamly",) . stripPrefix "serially/generation/"
}
- ignoringErr $ graph inputFile "generation" $ cfg
- { title = Just "Stream generation"
+ ignoringErr $ graph inputFile "elimination" $ cfg
+ { title = (++) <$> title <*> Just " Elimination"
+ , classifyBenchmark =
+ fmap ("Streamly",) . stripPrefix "serially/elimination/"
+ }
+
+ ignoringErr $ graph inputFile "transformation-zip" $ cfg
+ { title = (++) <$> title <*> Just " Transformation & Zip"
, classifyBenchmark = \b ->
- if "serially/generation" `isPrefixOf` b
+ if "serially/transformation/" `isPrefixOf` b
+ || "serially/zipping" `isPrefixOf` b
then Just ("Streamly", last $ splitOn "/" b)
else Nothing
}
- ignoringErr $ graph inputFile "composition" $ cfg
- { title = Just "Streamly composition performance"
- , classifyBenchmark = fmap ("Streamly",) . stripPrefix "serially/compose/"
+ ignoringErr $ graph inputFile "filtering" $ cfg
+ { title = (++) <$> title <*> Just " Filtering"
+ , classifyBenchmark =
+ fmap ("Streamly",) . stripPrefix "serially/filtering/"
+ }
+
+ ignoringErr $ graph inputFile "transformationX4" $ cfg
+ { title = (++) <$> title <*> Just " Transformation x 4"
+ , classifyBenchmark =
+ fmap ("Streamly",) . stripPrefix "serially/transformationX4/"
+ }
+
+ ignoringErr $ graph inputFile "filteringX4"
+ $ cfg
+ { title = (++) <$> title <*> Just " Filtering x 4"
+ , classifyBenchmark =
+ fmap ("Streamly",) . stripPrefix "serially/filteringX4/"
}
- ignoringErr $ graph inputFile "composition-scaling"
+ ignoringErr $ graph inputFile "mixedX4"
$ cfg
- { title = Just "Streamly composition scaling"
- , classifyBenchmark = fmap ("Streamly",) . stripPrefix "serially/compose-"
+ { title = (++) <$> title <*> Just " Mixed x 4"
+ , classifyBenchmark =
+ fmap ("Streamly",) . stripPrefix "serially/mixedX4/"
+ }
+
+ ignoringErr $ graph inputFile "iterated"
+ $ cfg
+ { title = Just "iterate 10,000 times over 10 elems"
+ , classifyBenchmark =
+ fmap ("Streamly",) . stripPrefix "serially/iterated/"
}
------------------------------------------------------------------------------
@@ -121,23 +163,61 @@ makeLinearGraphs cfg inputFile = do
makeNestedGraphs :: Config -> String -> IO ()
makeNestedGraphs cfg inputFile =
- ignoringErr $ graph inputFile "nested-serial-diff" $ cfg
- { title = Just "Nested serial"
- , classifyBenchmark = \b ->
- let ls = splitOn "/" b
- in case head ls of
- "serially" -> Just (head ls, last ls)
- _ -> Nothing
+ ignoringErr $ graph inputFile "nested-all" $ cfg
+ { presentation = Groups Absolute
+ , classifyBenchmark = classifyNested
+ , selectGroups = \gs ->
+ groupBy ((==) `on` snd) gs
+ & fmap (\xs -> mapMaybe (\x -> (x,) <$> lookup x xs) order)
+ & concat
}
+ where
+
+ order = ["serially", "asyncly", "wAsyncly", "aheadly", "parallely"]
+
+ classifyNested b
+ | "serially/" `isPrefixOf` b =
+ ("serially",) <$> stripPrefix "serially/" b
+ | "asyncly/" `isPrefixOf` b =
+ ("asyncly",) <$> stripPrefix "asyncly/" b
+ | "wAsyncly/" `isPrefixOf` b =
+ ("wAsyncly",) <$> stripPrefix "wAsyncly/" b
+ | "aheadly/" `isPrefixOf` b =
+ ("aheadly",) <$> stripPrefix "aheadly/" b
+ | "parallely/" `isPrefixOf` b =
+ ("parallely",) <$> stripPrefix "parallely/" b
+ | otherwise = Nothing
+
------------------------------------------------------------------------------
-- Charts for parallel streams
------------------------------------------------------------------------------
makeLinearAsyncGraphs :: Config -> String -> IO ()
-makeLinearAsyncGraphs cfg inputFile = do
- putStrLn "Not implemented"
- return ()
+makeLinearAsyncGraphs cfg inputFile =
+ ignoringErr $ graph inputFile "linear-async" cfg
+ { presentation = Groups Absolute
+ , classifyBenchmark = classifyAsync
+ , selectGroups = \gs ->
+ groupBy ((==) `on` snd) gs
+ & fmap (\xs -> mapMaybe (\x -> (x,) <$> lookup x xs) order)
+ & concat
+ }
+
+ where
+
+ order = ["asyncly", "wAsyncly", "aheadly", "parallely"]
+
+ classifyAsync b
+ | "asyncly/" `isPrefixOf` b =
+ ("asyncly",) <$> stripPrefix "asyncly/" b
+ | "wAsyncly/" `isPrefixOf` b =
+ ("wAsyncly",) <$> stripPrefix "wAsyncly/" b
+ | "aheadly/" `isPrefixOf` b =
+ ("aheadly",) <$> stripPrefix "aheadly/" b
+ | "parallely/" `isPrefixOf` b =
+ ("parallely",) <$> stripPrefix "parallely/" b
+ | otherwise = Nothing
makeLinearRateGraphs :: Config -> String -> IO ()
makeLinearRateGraphs cfg inputFile = do
@@ -145,36 +225,75 @@ makeLinearRateGraphs cfg inputFile = do
return ()
------------------------------------------------------------------------------
--- Charts for base streams
+-- Reports/Charts for base streams
------------------------------------------------------------------------------
-makeBaseGraphs :: Config -> String -> IO ()
-makeBaseGraphs cfg inputFile = do
- putStrLn "Not implemented"
- return ()
+showStreamDVsK Options{..} cfg inp out =
+ let cfg' = cfg { classifyBenchmark = classifyBase }
+ in if genGraphs
+ then ignoringErr $ graph inp "streamD-vs-streamK"
+ cfg' { outputDir = Just out
+ , presentation = Groups Absolute
+ }
+ else ignoringErr $ report inp Nothing cfg'
+
+ where
+
+ classifyBase b
+ | "streamD/" `isPrefixOf` b = ("streamD",) <$> stripPrefix "streamD/" b
+ | "streamK/" `isPrefixOf` b = ("streamK",) <$> stripPrefix "streamK/" b
+ | otherwise = Nothing
+
+showStreamD Options{..} cfg inp out =
+ let cfg' = cfg { classifyBenchmark = classifyStreamD }
+ in if genGraphs
+ then ignoringErr $ graph inp "streamD"
+ cfg' {outputDir = Just out}
+ else ignoringErr $ report inp Nothing cfg'
+
+ where
+
+ classifyStreamD b
+ | "streamD/" `isPrefixOf` b = ("streamD",) <$> stripPrefix "streamD/" b
+ | otherwise = Nothing
+
+showStreamK Options{..} cfg inp out =
+ let cfg' = cfg { classifyBenchmark = classifyStreamK }
+ in if genGraphs
+ then ignoringErr $ graph inp "streamK"
+ cfg' {outputDir = Just out}
+ else ignoringErr $ report inp Nothing cfg'
+
+ where
+
+ classifyStreamK b
+ | "streamK/" `isPrefixOf` b = ("streamK",) <$> stripPrefix "streamK/" b
+ | otherwise = Nothing
------------------------------------------------------------------------------
-- text reports
------------------------------------------------------------------------------
+selectBench :: (SortColumn -> Either String [(String, Double)]) -> [String]
+selectBench f =
+ reverse
+ $ fmap fst
+ $ either
+ (const $ either error (sortOn snd) $ f $ ColumnIndex 0)
+ (sortOn snd)
+ $ f $ ColumnIndex 1
+
benchShow Options{..} cfg func inp out =
if genGraphs
then func cfg {outputDir = Just out} inp
- else
- ignoringErr $ report inp Nothing $ cfg
- { selectBenchmarks =
- \f ->
- reverse
- $ fmap fst
- $ either
- (const $ either error id $ f $ ColumnIndex 0)
- (sortOn snd)
- $ f $ ColumnIndex 1
- }
+ else ignoringErr $ report inp Nothing cfg
main :: IO ()
main = do
- let cfg = defaultConfig { presentation = Groups PercentDiff }
+ let cfg = defaultConfig
+ { presentation = Groups PercentDiff
+ , selectBenchmarks = selectBench
+ }
res <- parseOptions
case res of
@@ -183,18 +302,34 @@ main = do
return ()
Just opts@Options{..} ->
case benchType of
- Linear -> benchShow opts cfg makeLinearGraphs
+ Linear -> benchShow opts cfg
+ { title = Just "100,000 elems" }
+ makeLinearGraphs
"charts/linear/results.csv"
"charts/linear"
- LinearAsync -> benchShow opts cfg makeLinearAsyncGraphs
+ LinearAsync -> benchShow opts cfg
+ { title = Just "Async 10,000 elems" }
+ makeLinearAsyncGraphs
"charts/linear-async/results.csv"
"charts/linear-async"
LinearRate -> benchShow opts cfg makeLinearRateGraphs
"charts/linear-rate/results.csv"
"charts/linear-rate"
- Nested -> benchShow opts cfg makeNestedGraphs
+ Nested -> benchShow opts cfg
+ { title = Just "Nested loops 100 x 100 elems" }
+ makeNestedGraphs
"charts/nested/results.csv"
"charts/nested"
- Base -> benchShow opts cfg makeBaseGraphs
- "charts/base/results.csv"
- "charts/base"
+ Base -> do
+ let cfg' = cfg { title = Just "100,000 elems" }
+ if groupDiff
+ then showStreamDVsK opts cfg'
+ "charts/base/results.csv"
+ "charts/base"
+ else do
+ showStreamD opts cfg'
+ "charts/base/results.csv"
+ "charts/base"
+ showStreamK opts cfg'
+ "charts/base/results.csv"
+ "charts/base"
diff --git a/benchmark/Linear.hs b/benchmark/Linear.hs
index c982327..219cff3 100644
--- a/benchmark/Linear.hs
+++ b/benchmark/Linear.hs
@@ -6,121 +6,259 @@
-- Maintainer : harendra.kumar@gmail.com
import Control.DeepSeq (NFData)
--- import Data.Functor.Identity (Identity, runIdentity)
+import Data.Functor.Identity (Identity, runIdentity)
import System.Random (randomRIO)
+
+import qualified GHC.Exts as GHC
import qualified LinearOps as Ops
import Streamly
+import qualified Streamly.Prelude as S
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.
---
+
-- | Takes a fold method, and uses it with a default source.
-{-# INLINE benchIO #-}
-benchIO :: (IsStream t, NFData b) => String -> (t IO Int -> IO b) -> Benchmark
-benchIO name f = bench name $ nfIO $ randomRIO (1,1) >>= f . Ops.source
+{-# INLINE benchIOSink #-}
+benchIOSink
+ :: (IsStream t, NFData b)
+ => String -> (t IO Int -> IO b) -> Benchmark
+benchIOSink name f = bench name $ nfIO $ randomRIO (1,1) >>= f . Ops.source
+
+-- XXX We should be using sourceUnfoldrM for fair comparison with IO monad, but
+-- we can't use it as it requires MonadAsync constraint.
+{-# INLINE benchIdentitySink #-}
+benchIdentitySink
+ :: (IsStream t, NFData b)
+ => String -> (t Identity Int -> Identity b) -> Benchmark
+benchIdentitySink name f = bench name $ nf (f . Ops.sourceUnfoldr) 1
-- | Takes a source, and uses it with a default drain/fold method.
-{-# INLINE benchSrcIO #-}
-benchSrcIO
- :: (t IO Int -> SerialT IO Int)
+{-# INLINE benchIOSrc #-}
+benchIOSrc
+ :: (t IO a -> SerialT IO a)
-> String
- -> (Int -> t IO Int)
+ -> (Int -> t IO a)
-> Benchmark
-benchSrcIO t name f
- = bench name $ nfIO $ randomRIO (1,1) >>= Ops.toNull t . f
+benchIOSrc t name f =
+ bench name $ nfIO $ randomRIO (1,1) >>= Ops.toNull t . f
+
+{-# INLINE benchPure #-}
+benchPure :: NFData b => String -> (Int -> a) -> (a -> b) -> Benchmark
+benchPure name src f = bench name $ nfIO $ randomRIO (1,1) >>= return . f . src
+
+{-# INLINE benchPureSink #-}
+benchPureSink :: NFData b => String -> (SerialT Identity Int -> b) -> Benchmark
+benchPureSink name f = benchPure name Ops.sourceUnfoldr f
+
+{-# INLINE benchPureSinkIO #-}
+benchPureSinkIO
+ :: NFData b
+ => String -> (SerialT Identity Int -> IO b) -> Benchmark
+benchPureSinkIO name f =
+ bench name $ nfIO $ randomRIO (1, 1) >>= f . Ops.sourceUnfoldr
-{-
-_benchId :: NFData b => String -> (Ops.Stream m Int -> Identity b) -> Benchmark
-_benchId name f = bench name $ nf (runIdentity . f) (Ops.source 10)
--}
+{-# INLINE benchPureSrc #-}
+benchPureSrc :: String -> (Int -> SerialT Identity a) -> Benchmark
+benchPureSrc name src = benchPure name src (runIdentity . runStream)
main :: IO ()
main =
defaultMain
[ bgroup "serially"
- [ bgroup "generation"
+ [ bgroup "pure"
+ [ benchPureSink "id" id
+ , benchPureSink "eqBy" Ops.eqBy
+ , benchPureSink "==" Ops.eqInstance
+ , benchPureSink "/=" Ops.eqInstanceNotEq
+ , benchPureSink "cmpBy" Ops.cmpBy
+ , benchPureSink "<" Ops.ordInstance
+ , benchPureSink "min" Ops.ordInstanceMin
+ , benchPureSrc "IsList.fromList" Ops.sourceIsList
+ , benchPureSink "IsList.toList" GHC.toList
+ , benchPureSrc "IsString.fromString" Ops.sourceIsString
+ , benchPure "readsPrec" (\n -> S.fromList [1..n :: Int])
+ Ops.readInstance
+ , benchPureSink "showsPrec" Ops.showInstance
+ , benchPure "showsPrecList" (\n -> S.fromList [1..n :: Int])
+ Ops.showInstanceList
+ , benchPureSink "foldl'" Ops.pureFoldl'
+ , benchPureSink "foldable/foldl'" Ops.foldableFoldl'
+ , benchPureSink "foldable/sum" Ops.foldableSum
+ , benchPureSinkIO "traversable/mapM" Ops.traversableMapM
+ ]
+ , bgroup "generation"
[ -- Most basic, barely stream continuations running
- benchSrcIO serially "unfoldr" Ops.sourceUnfoldr
- , benchSrcIO serially "unfoldrM" Ops.sourceUnfoldrM
- , benchSrcIO serially "fromList" Ops.sourceFromList
- , benchSrcIO serially "fromListM" Ops.sourceFromListM
+ benchIOSrc serially "unfoldr" Ops.sourceUnfoldr
+ , benchIOSrc serially "unfoldrM" Ops.sourceUnfoldrM
+ , benchIOSrc serially "intFromTo" Ops.sourceIntFromTo
+ , benchIOSrc serially "intFromThenTo" Ops.sourceIntFromThenTo
+ , benchIOSrc serially "integerFromStep" Ops.sourceIntegerFromStep
+ , benchIOSrc serially "fracFromThenTo" Ops.sourceFracFromThenTo
+ , benchIOSrc serially "fracFromTo" Ops.sourceFracFromTo
+ , benchIOSrc serially "fromList" Ops.sourceFromList
+ , benchIOSrc serially "fromListM" Ops.sourceFromListM
-- These are essentially cons and consM
- , benchSrcIO serially "fromFoldable" Ops.sourceFromFoldable
- , benchSrcIO serially "fromFoldableM" Ops.sourceFromFoldableM
+ , benchIOSrc serially "fromFoldable" Ops.sourceFromFoldable
+ , benchIOSrc serially "fromFoldableM" Ops.sourceFromFoldableM
-- These are essentially appends
- , benchSrcIO serially "foldMapWith" Ops.sourceFoldMapWith
- , benchSrcIO serially "foldMapWithM" Ops.sourceFoldMapWithM
+ , benchIOSrc serially "foldMapWith" Ops.sourceFoldMapWith
+ , benchIOSrc serially "foldMapWithM" Ops.sourceFoldMapWithM
+ , benchIOSrc serially "foldMapM" Ops.sourceFoldMapM
]
, bgroup "elimination"
- [ benchIO "toNull" $ Ops.toNull serially
- , benchIO "uncons" Ops.uncons
- , benchIO "init" Ops.init
- , benchIO "tail" Ops.tail
- , benchIO "nullHeadTail" Ops.nullHeadTail
- , benchIO "mapM_" Ops.mapM_
- , benchIO "toList" Ops.toList
- , benchIO "foldr" Ops.foldr
- , benchIO "foldr1" Ops.foldr1
- , benchIO "foldrM" Ops.foldrM
- , benchIO "foldl'" Ops.foldl'
- , benchIO "foldl1'" Ops.foldl1'
+ [ benchIOSink "toNull" $ Ops.toNull serially
+ , benchIOSink "uncons" Ops.uncons
+ , benchIOSink "init" Ops.init
+ , benchIOSink "tail" Ops.tail
+ , benchIOSink "nullHeadTail" Ops.nullHeadTail
+ , benchIOSink "mapM_" Ops.mapM_
+ , benchIOSink "toList" Ops.toList
+
+ , bgroup "reduce"
+ [ bgroup "IO"
+ [ benchIOSink "foldr" Ops.foldrReduce
+ , benchIOSink "foldr1" Ops.foldr1Reduce
+ , benchIOSink "foldl'" Ops.foldl'Reduce
+ , benchIOSink "foldl1'" Ops.foldl1'Reduce
+ , benchIOSink "foldlM'" Ops.foldlM'Reduce
+ ]
+ , bgroup "Identity"
+ [ benchIdentitySink "foldr" Ops.foldrReduce
+ , benchIdentitySink "foldr1" Ops.foldr1Reduce
+ , benchIdentitySink "foldl'" Ops.foldl'Reduce
+ , benchIdentitySink "foldl1'" Ops.foldl1'Reduce
+ , benchIdentitySink "foldlM'" Ops.foldlM'Reduce
+ ]
+ ]
+
+ , bgroup "build"
+ [ bgroup "IO"
+ [ benchIOSink "foldr" Ops.foldrBuild
+ , benchIOSink "foldrM" Ops.foldrMBuild
+ , benchIOSink "foldl'" Ops.foldl'Build
+ , benchIOSink "foldlM'" Ops.foldlM'Build
+ ]
+ , bgroup "Identity"
+ [ benchIdentitySink "foldr" Ops.foldrBuild
+ , benchIdentitySink "foldrM" Ops.foldrMBuild
+ , benchIdentitySink "foldl'" Ops.foldl'Build
+ , benchIdentitySink "foldlM'" Ops.foldlM'Build
+ ]
+ ]
- , benchIO "last" Ops.last
- , benchIO "length" Ops.length
- , benchIO "elem" Ops.elem
- , benchIO "notElem" Ops.notElem
- , benchIO "all" Ops.all
- , benchIO "any" Ops.any
- , benchIO "and" Ops.and
- , benchIO "or" Ops.or
- , benchIO "find" Ops.find
- , benchIO "findIndex" Ops.findIndex
- , benchIO "elemIndex" Ops.elemIndex
- , benchIO "maximum" Ops.maximum
- , benchIO "minimum" Ops.minimum
- , benchIO "sum" Ops.sum
- , benchIO "product" Ops.product
+ , benchIOSink "last" Ops.last
+ , benchIOSink "length" Ops.length
+ , benchIOSink "elem" Ops.elem
+ , benchIOSink "notElem" Ops.notElem
+ , benchIOSink "all" Ops.all
+ , benchIOSink "any" Ops.any
+ , benchIOSink "and" Ops.and
+ , benchIOSink "or" Ops.or
+ , benchIOSink "find" Ops.find
+ , benchIOSink "findIndex" Ops.findIndex
+ , benchIOSink "elemIndex" Ops.elemIndex
+ , benchIOSink "maximum" Ops.maximum
+ , benchIOSink "maximumBy" Ops.maximumBy
+ , benchIOSink "minimum" Ops.minimum
+ , benchIOSink "minimumBy" Ops.minimumBy
+ , benchIOSink "sum" Ops.sum
+ , benchIOSink "product" Ops.product
]
, bgroup "transformation"
- [ benchIO "scan" Ops.scan
- , benchIO "map" Ops.map
- , benchIO "fmap" Ops.fmap
- , benchIO "mapM" (Ops.mapM serially)
- , benchIO "mapMaybe" Ops.mapMaybe
- , benchIO "mapMaybeM" Ops.mapMaybeM
+ [ benchIOSink "scan" (Ops.scan 1)
+ , benchIOSink "scanl1'" (Ops.scanl1' 1)
+ , benchIOSink "map" (Ops.map 1)
+ , benchIOSink "fmap" (Ops.fmap 1)
+ , benchIOSink "mapM" (Ops.mapM serially 1)
+ , benchIOSink "mapMaybe" (Ops.mapMaybe 1)
+ , benchIOSink "mapMaybeM" (Ops.mapMaybeM 1)
, bench "sequence" $ nfIO $ randomRIO (1,1000) >>= \n ->
Ops.sequence serially (Ops.sourceUnfoldrMAction n)
- , benchIO "findIndices" Ops.findIndices
- , benchIO "elemIndices" Ops.elemIndices
- -- , benchIO "concat" Ops.concat
+ , benchIOSink "findIndices" (Ops.findIndices 1)
+ , benchIOSink "elemIndices" (Ops.elemIndices 1)
+ ]
+ , bgroup "transformationX4"
+ [ benchIOSink "scan" (Ops.scan 4)
+ , benchIOSink "scanl1'" (Ops.scanl1' 4)
+ , benchIOSink "map" (Ops.map 4)
+ , benchIOSink "fmap" (Ops.fmap 4)
+ , benchIOSink "mapM" (Ops.mapM serially 4)
+ , benchIOSink "mapMaybe" (Ops.mapMaybe 4)
+ , benchIOSink "mapMaybeM" (Ops.mapMaybeM 4)
+ -- , bench "sequence" $ nfIO $ randomRIO (1,1000) >>= \n ->
+ -- Ops.sequence serially (Ops.sourceUnfoldrMAction n)
+ , benchIOSink "findIndices" (Ops.findIndices 4)
+ , benchIOSink "elemIndices" (Ops.elemIndices 4)
]
, 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 "takeWhileM-true" Ops.takeWhileMTrue
- , benchIO "drop-all" Ops.dropAll
- , benchIO "dropWhile-true" Ops.dropWhileTrue
- , benchIO "dropWhileM-true" Ops.dropWhileMTrue
+ [ benchIOSink "filter-even" (Ops.filterEven 1)
+ , benchIOSink "filter-all-out" (Ops.filterAllOut 1)
+ , benchIOSink "filter-all-in" (Ops.filterAllIn 1)
+ , benchIOSink "take-all" (Ops.takeAll 1)
+ , benchIOSink "takeWhile-true" (Ops.takeWhileTrue 1)
+ --, benchIOSink "takeWhileM-true" (Ops.takeWhileMTrue 1)
+ , benchIOSink "drop-one" (Ops.dropOne 1)
+ , benchIOSink "drop-all" (Ops.dropAll 1)
+ , benchIOSink "dropWhile-true" (Ops.dropWhileTrue 1)
+ --, benchIOSink "dropWhileM-true" (Ops.dropWhileMTrue 1)
+ , benchIOSink "dropWhile-false" (Ops.dropWhileFalse 1)
+ , benchIOSink "deleteBy" (Ops.deleteBy 1)
+ , benchIOSink "insertBy" (Ops.insertBy 1)
]
- , benchIO "zip" Ops.zip
- , benchIO "zipM" Ops.zipM
- , 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 "filteringX4"
+ [ benchIOSink "filter-even" (Ops.filterEven 4)
+ , benchIOSink "filter-all-out" (Ops.filterAllOut 4)
+ , benchIOSink "filter-all-in" (Ops.filterAllIn 4)
+ , benchIOSink "take-all" (Ops.takeAll 4)
+ , benchIOSink "takeWhile-true" (Ops.takeWhileTrue 4)
+ --, benchIOSink "takeWhileM-true" (Ops.takeWhileMTrue 4)
+ , benchIOSink "drop-one" (Ops.dropOne 4)
+ , benchIOSink "drop-all" (Ops.dropAll 4)
+ , benchIOSink "dropWhile-true" (Ops.dropWhileTrue 4)
+ --, benchIOSink "dropWhileM-true" (Ops.dropWhileMTrue 4)
+ , benchIOSink "dropWhile-false" (Ops.dropWhileFalse 4)
+ , benchIOSink "deleteBy" (Ops.deleteBy 4)
+ , benchIOSink "insertBy" (Ops.insertBy 4)
]
- -- Scaling with same operation in sequence
- , bgroup "compose-scaling"
- [ benchIO "1" $ Ops.composeScaling 1
- , benchIO "2" $ Ops.composeScaling 2
- , benchIO "3" $ Ops.composeScaling 3
- , benchIO "4" $ Ops.composeScaling 4
+ , bgroup "multi-stream"
+ [ benchIOSink "eqBy" Ops.eqBy
+ , benchIOSink "cmpBy" Ops.cmpBy
+ , benchIOSink "zip" Ops.zip
+ , benchIOSink "zipM" Ops.zipM
+ , benchIOSink "mergeBy" Ops.mergeBy
+ , benchIOSink "isPrefixOf" Ops.isPrefixOf
+ , benchIOSink "isSubsequenceOf" Ops.isSubsequenceOf
+ , benchIOSink "stripPrefix" Ops.stripPrefix
+ , benchIOSrc serially "concatMap" Ops.concatMap
]
+ , bgroup "mixed"
+ [ benchIOSink "sum-product-fold" Ops.sumProductFold
+ , benchIOSink "sum-product-scan" Ops.sumProductScan
+ ]
+ , bgroup "mixedX4"
+ [ benchIOSink "scan-map" (Ops.scanMap 4)
+ , benchIOSink "drop-map" (Ops.dropMap 4)
+ , benchIOSink "drop-scan" (Ops.dropScan 4)
+ , benchIOSink "take-drop" (Ops.takeDrop 4)
+ , benchIOSink "take-scan" (Ops.takeScan 4)
+ , benchIOSink "take-map" (Ops.takeMap 4)
+ , benchIOSink "filter-drop" (Ops.filterDrop 4)
+ , benchIOSink "filter-take" (Ops.filterTake 4)
+ , benchIOSink "filter-scan" (Ops.filterScan 4)
+ , benchIOSink "filter-scanl1" (Ops.filterScanl1 4)
+ , benchIOSink "filter-map" (Ops.filterMap 4)
+ ]
+ , bgroup "iterated"
+ [ benchIOSrc serially "mapM" Ops.iterateMapM
+ , benchIOSrc serially "scan(1/100)" Ops.iterateScan
+ , benchIOSrc serially "scanl1(1/100)" Ops.iterateScanl1
+ , benchIOSrc serially "filterEven" Ops.iterateFilterEven
+ , benchIOSrc serially "takeAll" Ops.iterateTakeAll
+ , benchIOSrc serially "dropOne" Ops.iterateDropOne
+ , benchIOSrc serially "dropWhileFalse" Ops.iterateDropWhileFalse
+ , benchIOSrc serially "dropWhileTrue" Ops.iterateDropWhileTrue
]
]
+ ]
diff --git a/benchmark/LinearAsync.hs b/benchmark/LinearAsync.hs
index 29a3f40..52f49b8 100644
--- a/benchmark/LinearAsync.hs
+++ b/benchmark/LinearAsync.hs
@@ -40,36 +40,45 @@ main :: IO ()
main =
defaultMain
[ bgroup "asyncly"
- [ -- benchIO "unfoldr" $ Ops.toNull asyncly
- benchSrcIO asyncly "unfoldrM" Ops.sourceUnfoldrM
- -- , benchSrcIO asyncly "fromFoldable" Ops.sourceFromFoldable
+ [ benchSrcIO asyncly "unfoldr" Ops.sourceUnfoldr
+ , benchSrcIO asyncly "unfoldrM" Ops.sourceUnfoldrM
+ , benchSrcIO asyncly "fromFoldable" Ops.sourceFromFoldable
, benchSrcIO asyncly "fromFoldableM" Ops.sourceFromFoldableM
- -- , benchSrcIO asyncly "foldMapWith" Ops.sourceFoldMapWith
+ , benchSrcIO asyncly "foldMapWith" Ops.sourceFoldMapWith
, benchSrcIO asyncly "foldMapWithM" Ops.sourceFoldMapWithM
- , benchIO "mapM" $ Ops.mapM asyncly
+ , benchSrcIO asyncly "foldMapM" Ops.sourceFoldMapM
+ , benchIO "map" $ Ops.map' asyncly 1
+ , benchIO "fmap" $ Ops.fmap' asyncly 1
+ , benchIO "mapM" $ Ops.mapM asyncly 1
, benchSrcIO asyncly "unfoldrM maxThreads 1"
(maxThreads 1 . Ops.sourceUnfoldrM)
, benchSrcIO asyncly "unfoldrM maxBuffer 1 (1000 ops)"
(maxBuffer 1 . Ops.sourceUnfoldrMN 1000)
]
, bgroup "wAsyncly"
- [ -- benchIO "unfoldr" $ Ops.toNull wAsyncly
- benchSrcIO wAsyncly "unfoldrM" Ops.sourceUnfoldrM
- -- , benchSrcIO wAsyncly "fromFoldable" Ops.sourceFromFoldable
+ [ benchSrcIO wAsyncly "unfoldr" Ops.sourceUnfoldr
+ , benchSrcIO wAsyncly "unfoldrM" Ops.sourceUnfoldrM
+ , benchSrcIO wAsyncly "fromFoldable" Ops.sourceFromFoldable
, benchSrcIO wAsyncly "fromFoldableM" Ops.sourceFromFoldableM
- -- , benchSrcIO wAsyncly "foldMapWith" Ops.sourceFoldMapWith
+ , benchSrcIO wAsyncly "foldMapWith" Ops.sourceFoldMapWith
, benchSrcIO wAsyncly "foldMapWithM" Ops.sourceFoldMapWithM
- , benchIO "mapM" $ Ops.mapM wAsyncly
+ , benchSrcIO wAsyncly "foldMapM" Ops.sourceFoldMapM
+ , benchIO "map" $ Ops.map' wAsyncly 1
+ , benchIO "fmap" $ Ops.fmap' wAsyncly 1
+ , benchIO "mapM" $ Ops.mapM wAsyncly 1
]
-- unfoldr and fromFoldable are always serial and thereofore the same for
-- all stream types.
, bgroup "aheadly"
- [ -- benchIO "unfoldr" $ Ops.toNull aheadly
- benchSrcIO aheadly "unfoldrM" Ops.sourceUnfoldrM
+ [ benchSrcIO aheadly "unfoldr" Ops.sourceUnfoldr
+ , benchSrcIO aheadly "unfoldrM" Ops.sourceUnfoldrM
, benchSrcIO aheadly "fromFoldableM" Ops.sourceFromFoldableM
-- , benchSrcIO aheadly "foldMapWith" Ops.sourceFoldMapWith
, benchSrcIO aheadly "foldMapWithM" Ops.sourceFoldMapWithM
- , benchIO "mapM" $ Ops.mapM aheadly
+ , benchSrcIO aheadly "foldMapM" Ops.sourceFoldMapM
+ , benchIO "map" $ Ops.map' aheadly 1
+ , benchIO "fmap" $ Ops.fmap' aheadly 1
+ , benchIO "mapM" $ Ops.mapM aheadly 1
, benchSrcIO aheadly "unfoldrM maxThreads 1"
(maxThreads 1 . Ops.sourceUnfoldrM)
, benchSrcIO aheadly "unfoldrM maxBuffer 1 (1000 ops)"
@@ -78,15 +87,19 @@ main =
]
-- XXX need to use smaller streams to finish in reasonable time
, bgroup "parallely"
- [ --benchIO "unfoldr" $ Ops.toNull parallely
- benchSrcIO parallely "unfoldrM" Ops.sourceUnfoldrM
+ [ benchSrcIO parallely "unfoldr" Ops.sourceUnfoldr
+ , benchSrcIO parallely "unfoldrM" Ops.sourceUnfoldrM
--, benchSrcIO parallely "fromFoldable" Ops.sourceFromFoldable
, benchSrcIO parallely "fromFoldableM" Ops.sourceFromFoldableM
-- , benchSrcIO parallely "foldMapWith" Ops.sourceFoldMapWith
, benchSrcIO parallely "foldMapWithM" Ops.sourceFoldMapWithM
- , benchIO "mapM" $ Ops.mapM parallely
+ , benchSrcIO parallely "foldMapM" Ops.sourceFoldMapM
+ , benchIO "map" $ Ops.map' parallely 1
+ , benchIO "fmap" $ Ops.fmap' parallely 1
+ , benchIO "mapM" $ Ops.mapM parallely 1
-- Zip has only one parallel flavor
, benchIO "zip" Ops.zipAsync
, benchIO "zipM" Ops.zipAsyncM
+ , benchIO "zipAp" Ops.zipAsyncAp
]
]
diff --git a/benchmark/LinearOps.hs b/benchmark/LinearOps.hs
index a0f63b9..ae8743d 100644
--- a/benchmark/LinearOps.hs
+++ b/benchmark/LinearOps.hs
@@ -7,14 +7,25 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
module LinearOps where
import Control.Monad (when)
+import Data.Functor.Identity (Identity, runIdentity)
import Data.Maybe (fromJust)
import Prelude
- (Monad, Int, (+), ($), (.), return, fmap, even, (>), (<=), (==), (<=),
- subtract, undefined, Maybe(..), odd, Bool, not, (>>=), mapM_, curry)
+ (Monad, Int, (+), ($), (.), return, fmap, even, (>), (<=), (==), (>=),
+ subtract, undefined, Maybe(..), odd, Bool, not, (>>=), mapM_, curry,
+ maxBound, div, IO, compare, Double, fromIntegral, Integer, (<$>),
+ (<*>), flip)
+import qualified Prelude as P
+import qualified Data.Foldable as F
+import qualified GHC.Exts as GHC
+import Control.DeepSeq (NFData)
+import GHC.Generics (Generic)
import qualified Streamly as S
import qualified Streamly.Prelude as S
@@ -39,8 +50,30 @@ type Stream m a = S.SerialT m a
{-# INLINE source #-}
source :: (S.MonadAsync m, S.IsStream t) => Int -> t m Int
-source n = S.serially $ sourceUnfoldrM n
--- source n = S.serially $ sourceFromList n
+source n = sourceUnfoldrM n
+
+{-# INLINE sourceIntFromTo #-}
+sourceIntFromTo :: (Monad m, S.IsStream t) => Int -> t m Int
+sourceIntFromTo n = S.enumerateFromTo n (n + value)
+
+{-# INLINE sourceIntFromThenTo #-}
+sourceIntFromThenTo :: (Monad m, S.IsStream t) => Int -> t m Int
+sourceIntFromThenTo n = S.enumerateFromThenTo n (n + 1) (n + value)
+
+{-# INLINE sourceFracFromTo #-}
+sourceFracFromTo :: (Monad m, S.IsStream t) => Int -> t m Double
+sourceFracFromTo n =
+ S.enumerateFromTo (fromIntegral n) (fromIntegral (n + value))
+
+{-# INLINE sourceFracFromThenTo #-}
+sourceFracFromThenTo :: (Monad m, S.IsStream t) => Int -> t m Double
+sourceFracFromThenTo n = S.enumerateFromThenTo (fromIntegral n)
+ (fromIntegral n + 1.0001) (fromIntegral (n + value))
+
+{-# INLINE sourceIntegerFromStep #-}
+sourceIntegerFromStep :: (Monad m, S.IsStream t) => Int -> t m Integer
+sourceIntegerFromStep n =
+ S.take value $ S.enumerateFromThen (fromIntegral n) (fromIntegral n + 1)
{-# INLINE sourceFromList #-}
sourceFromList :: (Monad m, S.IsStream t) => Int -> t m Int
@@ -68,6 +101,11 @@ sourceFoldMapWithM :: (S.IsStream t, Monad m, S.Semigroup (t m Int))
=> Int -> t m Int
sourceFoldMapWithM n = S.foldMapWith (S.<>) (S.yieldM . return) [n..n+value]
+{-# INLINE sourceFoldMapM #-}
+sourceFoldMapM :: (S.IsStream t, Monad m, P.Monoid (t m Int))
+ => Int -> t m Int
+sourceFoldMapM n = F.foldMap (S.yieldM . return) [n..n+value]
+
{-# INLINE sourceUnfoldr #-}
sourceUnfoldr :: (Monad m, S.IsStream t) => Int -> t m Int
sourceUnfoldr n = S.unfoldr step n
@@ -105,6 +143,18 @@ sourceUnfoldrMAction n = S.serially $ S.unfoldrM step n
else return (Just (return cnt, cnt + 1))
-------------------------------------------------------------------------------
+-- Pure stream generation
+-------------------------------------------------------------------------------
+
+{-# INLINE sourceIsList #-}
+sourceIsList :: Int -> S.SerialT Identity Int
+sourceIsList n = GHC.fromList [n..n+value]
+
+{-# INLINE sourceIsString #-}
+sourceIsString :: Int -> S.SerialT Identity P.Char
+sourceIsString n = GHC.fromString (P.replicate (n + value) 'a')
+
+-------------------------------------------------------------------------------
-- Elimination
-------------------------------------------------------------------------------
@@ -113,9 +163,7 @@ runStream :: Monad m => Stream m a -> m ()
runStream = S.runStream
{-# INLINE toList #-}
-{-# INLINE foldr #-}
-{-# INLINE foldrM #-}
-toList, foldr, foldrM :: Monad m => Stream m Int -> m [Int]
+toList :: Monad m => Stream m Int -> m [Int]
{-# INLINE last #-}
{-# INLINE maximum #-}
@@ -123,15 +171,32 @@ toList, foldr, foldrM :: Monad m => Stream m Int -> m [Int]
{-# INLINE find #-}
{-# INLINE findIndex #-}
{-# INLINE elemIndex #-}
-{-# INLINE foldl1' #-}
-{-# INLINE foldr1 #-}
-last, minimum, maximum, find, findIndex, elemIndex, foldl1', foldr1 :: Monad m => Stream m Int -> m (Maybe Int)
-
-{-# INLINE foldl' #-}
+{-# INLINE foldl1'Reduce #-}
+{-# INLINE foldr1Reduce #-}
+last, minimum, maximum, find, findIndex, elemIndex, foldl1'Reduce, foldr1Reduce
+ :: Monad m => Stream m Int -> m (Maybe Int)
+
+{-# INLINE minimumBy #-}
+{-# INLINE maximumBy #-}
+minimumBy, maximumBy :: Monad m => Stream m Int -> m (Maybe Int)
+
+{-# INLINE foldl'Reduce #-}
+{-# INLINE foldlM'Reduce #-}
+{-# INLINE foldrReduce #-}
{-# INLINE length #-}
{-# INLINE sum #-}
{-# INLINE product #-}
-foldl', length, sum, product :: Monad m => Stream m Int -> m Int
+foldl'Reduce, foldlM'Reduce, foldrReduce, length, sum, product
+ :: Monad m
+ => Stream m Int -> m Int
+
+{-# INLINE foldl'Build #-}
+{-# INLINE foldlM'Build #-}
+{-# INLINE foldrBuild #-}
+{-# INLINE foldrMBuild #-}
+foldrBuild, foldrMBuild, foldl'Build, foldlM'Build
+ :: Monad m
+ => Stream m Int -> m [Int]
{-# INLINE all #-}
{-# INLINE any #-}
@@ -142,7 +207,7 @@ foldl', length, sum, product :: Monad m => Stream m Int -> m Int
elem, notElem, all, any, and, or :: Monad m => Stream m Int -> m Bool
{-# INLINE toNull #-}
-toNull :: Monad m => (t m Int -> S.SerialT m Int) -> t m Int -> m ()
+toNull :: Monad m => (t m a -> S.SerialT m a) -> t m a -> m ()
toNull t = runStream . t
{-# INLINE uncons #-}
@@ -169,13 +234,23 @@ nullHeadTail s = do
_ <- S.head s
S.tail s >>= Prelude.mapM_ nullHeadTail
+{-# INLINE mapM_ #-}
+mapM_ :: Monad m => Stream m Int -> m ()
mapM_ = S.mapM_ (\_ -> return ())
+
toList = S.toList
-foldr = S.foldr (:) []
-foldr1 = S.foldr1 (+)
-foldrM = S.foldrM (\a xs -> return (a : xs)) []
-foldl' = S.foldl' (+) 0
-foldl1' = S.foldl1' (+)
+
+foldl'Build = S.foldl' (flip (:)) []
+foldrBuild = S.foldr (:) []
+foldlM'Build = S.foldlM' (\xs x -> return $ x : xs) []
+foldrMBuild = S.foldrM (\x xs -> return $ x : xs) []
+
+foldrReduce = S.foldr (+) 0
+foldr1Reduce = S.foldr1 (+)
+foldl'Reduce = S.foldl' (+) 0
+foldl1'Reduce = S.foldl1' (+)
+foldlM'Reduce = S.foldlM' (\xs a -> return $ a + xs) 0
+
last = S.last
elem = S.elem maxValue
notElem = S.notElem maxValue
@@ -191,6 +266,8 @@ maximum = S.maximum
minimum = S.minimum
sum = S.sum
product = S.product
+minimumBy = S.minimumBy compare
+maximumBy = S.maximumBy compare
-------------------------------------------------------------------------------
-- Transformation
@@ -200,8 +277,33 @@ product = S.product
transform :: Monad m => Stream m a -> m ()
transform = runStream
+{-# INLINE composeN #-}
+composeN
+ :: Monad m
+ => Int -> (Stream m Int -> Stream m Int) -> Stream m Int -> m ()
+composeN n f =
+ case n of
+ 1 -> transform . f
+ 2 -> transform . f . f
+ 3 -> transform . f . f . f
+ 4 -> transform . f . f . f . f
+ _ -> undefined
+
+-- polymorphic stream version of composeN
+{-# INLINE composeN' #-}
+composeN'
+ :: (S.IsStream t, Monad m)
+ => Int -> (t m Int -> Stream m Int) -> t m Int -> m ()
+composeN' n f =
+ case n of
+ 1 -> transform . f
+ 2 -> transform . f . S.adapt . f
+ 3 -> transform . f . S.adapt . f . S.adapt . f
+ 4 -> transform . f . S.adapt . f . S.adapt . f . S.adapt . f
+ _ -> undefined
+
{-# INLINE scan #-}
-{-# INLINE mapM_ #-}
+{-# INLINE scanl1' #-}
{-# INLINE map #-}
{-# INLINE fmap #-}
{-# INLINE mapMaybe #-}
@@ -212,50 +314,108 @@ transform = runStream
{-# INLINE takeAll #-}
{-# INLINE takeWhileTrue #-}
{-# INLINE takeWhileMTrue #-}
+{-# INLINE dropOne #-}
{-# INLINE dropAll #-}
{-# INLINE dropWhileTrue #-}
{-# INLINE dropWhileMTrue #-}
+{-# INLINE dropWhileFalse #-}
{-# INLINE findIndices #-}
{-# INLINE elemIndices #-}
-scan, mapM_, map, fmap, mapMaybe, filterEven, filterAllOut,
- filterAllIn, takeOne, takeAll, takeWhileTrue, takeWhileMTrue, dropAll,
- dropWhileTrue, dropWhileMTrue,
- findIndices, elemIndices
+{-# INLINE insertBy #-}
+{-# INLINE deleteBy #-}
+scan, scanl1', map, fmap, mapMaybe, filterEven, filterAllOut,
+ filterAllIn, takeOne, takeAll, takeWhileTrue, takeWhileMTrue, dropOne,
+ dropAll, dropWhileTrue, dropWhileMTrue, dropWhileFalse,
+ findIndices, elemIndices, insertBy, deleteBy
:: Monad m
- => Stream m Int -> m ()
+ => Int -> Stream m Int -> m ()
{-# INLINE mapMaybeM #-}
-mapMaybeM :: S.MonadAsync m => Stream m Int -> m ()
+mapMaybeM :: S.MonadAsync m => Int -> Stream m Int -> m ()
{-# INLINE mapM #-}
-mapM :: (S.IsStream t, S.MonadAsync m)
- => (t m Int -> S.SerialT m Int) -> t m Int -> m ()
+{-# INLINE map' #-}
+{-# INLINE fmap' #-}
+mapM, map' :: (S.IsStream t, S.MonadAsync m)
+ => (t m Int -> S.SerialT m Int) -> Int -> t m Int -> m ()
+
+fmap' :: (S.IsStream t, S.MonadAsync m, P.Functor (t m))
+ => (t m Int -> S.SerialT m Int) -> Int -> t m Int -> m ()
{-# INLINE sequence #-}
sequence :: (S.IsStream t, S.MonadAsync m)
=> (t m Int -> S.SerialT m Int) -> t m (m Int) -> m ()
-scan = transform . S.scanl' (+) 0
-fmap = transform . Prelude.fmap (+1)
-map = transform . S.map (+1)
-mapM t = transform . t . S.mapM return
-mapMaybe = transform . S.mapMaybe
- (\x -> if Prelude.odd x then Nothing else Just ())
-mapMaybeM = transform . S.mapMaybeM
- (\x -> if Prelude.odd x then return Nothing else return $ Just ())
+scan n = composeN n $ S.scanl' (+) 0
+scanl1' n = composeN n $ S.scanl1' (+)
+fmap n = composeN n $ Prelude.fmap (+1)
+fmap' t n = composeN' n $ t . Prelude.fmap (+1)
+map n = composeN n $ S.map (+1)
+map' t n = composeN' n $ t . S.map (+1)
+mapM t n = composeN' n $ t . S.mapM return
+mapMaybe n = composeN n $ S.mapMaybe
+ (\x -> if Prelude.odd x then Nothing else Just x)
+mapMaybeM n = composeN n $ S.mapMaybeM
+ (\x -> if Prelude.odd x then return Nothing else return $ Just x)
sequence t = transform . t . S.sequence
-filterEven = 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)
-takeWhileMTrue = transform . S.takeWhileM (return . (<= maxValue))
-dropAll = transform . S.drop maxValue
-dropWhileTrue = transform . S.dropWhile (<= maxValue)
-dropWhileMTrue = transform . S.dropWhileM (return . (<= maxValue))
-findIndices = transform . S.findIndices (== maxValue)
-elemIndices = transform . S.elemIndices maxValue
+filterEven n = composeN n $ S.filter even
+filterAllOut n = composeN n $ S.filter (> maxValue)
+filterAllIn n = composeN n $ S.filter (<= maxValue)
+takeOne n = composeN n $ S.take 1
+takeAll n = composeN n $ S.take maxValue
+takeWhileTrue n = composeN n $ S.takeWhile (<= maxValue)
+takeWhileMTrue n = composeN n $ S.takeWhileM (return . (<= maxValue))
+dropOne n = composeN n $ S.drop 1
+dropAll n = composeN n $ S.drop maxValue
+dropWhileTrue n = composeN n $ S.dropWhile (<= maxValue)
+dropWhileMTrue n = composeN n $ S.dropWhileM (return . (<= maxValue))
+dropWhileFalse n = composeN n $ S.dropWhile (> maxValue)
+findIndices n = composeN n $ S.findIndices (== maxValue)
+elemIndices n = composeN n $ S.elemIndices maxValue
+insertBy n = composeN n $ S.insertBy compare maxValue
+deleteBy n = composeN n $ S.deleteBy (>=) maxValue
+
+-------------------------------------------------------------------------------
+-- Iteration
+-------------------------------------------------------------------------------
+
+iterStreamLen, maxIters :: Int
+iterStreamLen = 10
+maxIters = 10000
+
+{-# INLINE iterateSource #-}
+iterateSource
+ :: S.MonadAsync m
+ => (Stream m Int -> Stream m Int) -> Int -> Int -> Stream m Int
+iterateSource g i n = f i (sourceUnfoldrMN iterStreamLen n)
+ where
+ f (0 :: Int) m = g m
+ f x m = g (f (x P.- 1) m)
+
+{-# INLINE iterateMapM #-}
+{-# INLINE iterateScan #-}
+{-# INLINE iterateScanl1 #-}
+{-# INLINE iterateFilterEven #-}
+{-# INLINE iterateTakeAll #-}
+{-# INLINE iterateDropOne #-}
+{-# INLINE iterateDropWhileFalse #-}
+{-# INLINE iterateDropWhileTrue #-}
+iterateMapM, iterateScan, iterateScanl1, iterateFilterEven, iterateTakeAll,
+ iterateDropOne, iterateDropWhileFalse, iterateDropWhileTrue
+ :: S.MonadAsync m
+ => Int -> Stream m Int
+
+-- this is quadratic
+iterateScan = iterateSource (S.scanl' (+) 0) (maxIters `div` 10)
+-- so is this
+iterateScanl1 = iterateSource (S.scanl1' (+)) (maxIters `div` 10)
+
+iterateMapM = iterateSource (S.mapM return) maxIters
+iterateFilterEven = iterateSource (S.filter even) maxIters
+iterateTakeAll = iterateSource (S.take maxValue) maxIters
+iterateDropOne = iterateSource (S.drop 1) maxIters
+iterateDropWhileFalse = iterateSource (S.dropWhile (> maxValue)) maxIters
+iterateDropWhileTrue = iterateSource (S.dropWhile (<= maxValue)) maxIters
-------------------------------------------------------------------------------
-- Zipping and concat
@@ -263,12 +423,8 @@ elemIndices = transform . S.elemIndices maxValue
{-# INLINE zip #-}
{-# INLINE zipM #-}
-{-# INLINE concat #-}
-zip, zipM, concat :: Monad m => Stream m Int -> m ()
-
-{-# INLINE zipAsync #-}
-{-# INLINE zipAsyncM #-}
-zipAsync, zipAsyncM :: S.MonadAsync m => Stream m Int -> m ()
+{-# INLINE mergeBy #-}
+zip, zipM, mergeBy :: Monad m => Stream m Int -> m ()
zip src = do
r <- S.tail src
@@ -278,47 +434,154 @@ zipM src = do
r <- S.tail src
let src1 = fromJust r
transform (S.zipWithM (curry return) src src1)
+
+mergeBy src = do
+ r <- S.tail src
+ let src1 = fromJust r
+ transform (S.mergeBy P.compare src src1)
+
+{-# INLINE isPrefixOf #-}
+{-# INLINE isSubsequenceOf #-}
+isPrefixOf, isSubsequenceOf :: Monad m => Stream m Int -> m Bool
+
+isPrefixOf src = S.isPrefixOf src src
+isSubsequenceOf src = S.isSubsequenceOf src src
+
+{-# INLINE stripPrefix #-}
+stripPrefix :: Monad m => Stream m Int -> m ()
+stripPrefix src = do
+ _ <- S.stripPrefix src src
+ return ()
+
+{-# INLINE zipAsync #-}
+{-# INLINE zipAsyncM #-}
+{-# INLINE zipAsyncAp #-}
+zipAsync, zipAsyncAp, zipAsyncM :: S.MonadAsync m => Stream m Int -> m ()
+
zipAsync src = do
r <- S.tail src
let src1 = fromJust r
transform (S.zipAsyncWith (,) src src1)
+
zipAsyncM src = do
r <- S.tail src
let src1 = fromJust r
transform (S.zipAsyncWithM (curry return) src src1)
-concat _n = return ()
+
+zipAsyncAp src = do
+ r <- S.tail src
+ let src1 = fromJust r
+ transform (S.zipAsyncly $ (,) <$> S.serially src
+ <*> S.serially src1)
+
+{-# INLINE eqBy #-}
+eqBy :: (Monad m, P.Eq a) => Stream m a -> m P.Bool
+eqBy src = S.eqBy (==) src src
+
+{-# INLINE cmpBy #-}
+cmpBy :: (Monad m, P.Ord a) => Stream m a -> m P.Ordering
+cmpBy src = S.cmpBy P.compare src src
+
+concatStreamLen, maxNested :: Int
+concatStreamLen = 1
+maxNested = 100000
+
+{-# INLINE concatMap #-}
+concatMap :: S.MonadAsync m => Int -> Stream m Int
+concatMap n = S.concatMap (\_ -> sourceUnfoldrMN maxNested n)
+ (sourceUnfoldrMN concatStreamLen n)
-------------------------------------------------------------------------------
--- Composition
+-- Mixed Composition
-------------------------------------------------------------------------------
-{-# INLINE compose #-}
-compose :: Monad m => (Stream m Int -> Stream m Int) -> Stream m Int -> m ()
-compose f = transform . f . f . f . f
+{-# INLINE scanMap #-}
+{-# INLINE dropMap #-}
+{-# INLINE dropScan #-}
+{-# INLINE takeDrop #-}
+{-# INLINE takeScan #-}
+{-# INLINE takeMap #-}
+{-# INLINE filterDrop #-}
+{-# INLINE filterTake #-}
+{-# INLINE filterScan #-}
+{-# INLINE filterScanl1 #-}
+{-# INLINE filterMap #-}
+scanMap, dropMap, dropScan, takeDrop, takeScan, takeMap, filterDrop,
+ filterTake, filterScan, filterScanl1, filterMap
+ :: Monad m => Int -> Stream m Int -> m ()
+
+scanMap n = composeN n $ S.map (subtract 1) . S.scanl' (+) 0
+dropMap n = composeN n $ S.map (subtract 1) . S.drop 1
+dropScan n = composeN n $ S.scanl' (+) 0 . S.drop 1
+takeDrop n = composeN n $ S.drop 1 . S.take maxValue
+takeScan n = composeN n $ S.scanl' (+) 0 . S.take maxValue
+takeMap n = composeN n $ S.map (subtract 1) . S.take maxValue
+filterDrop n = composeN n $ S.drop 1 . S.filter (<= maxValue)
+filterTake n = composeN n $ S.take maxValue . S.filter (<= maxValue)
+filterScan n = composeN n $ S.scanl' (+) 0 . S.filter (<= maxBound)
+filterScanl1 n = composeN n $ S.scanl1' (+) . S.filter (<= maxBound)
+filterMap n = composeN n $ S.map (subtract 1) . S.filter (<= maxValue)
+
+data Pair a b = Pair !a !b deriving (Generic, NFData)
+
+{-# INLINE sumProductFold #-}
+sumProductFold :: Monad m => Stream m Int -> m (Int, Int)
+sumProductFold = S.foldl' (\(s,p) x -> (s + x, p P.* x)) (0,1)
+
+{-# INLINE sumProductScan #-}
+sumProductScan :: Monad m => Stream m Int -> m (Pair Int Int)
+sumProductScan = S.foldl' (\(Pair _ p) (s0,x) -> Pair s0 (p P.* x)) (Pair 0 1)
+ . S.scanl' (\(s,_) x -> (s + x,x)) (0,0)
-{-# INLINE composeMapM #-}
-{-# INLINE composeAllInFilters #-}
-{-# INLINE composeAllOutFilters #-}
-{-# INLINE composeMapAllInFilter #-}
-composeAllInFilters, composeAllOutFilters,
- composeMapAllInFilter
- :: Monad m
- => Stream m Int -> m ()
-composeMapM :: S.MonadAsync m => Stream m Int -> m ()
-
-composeMapM = compose (S.mapM return)
-composeAllInFilters = compose (S.filter (<= maxValue))
-composeAllOutFilters = compose (S.filter (> maxValue))
-composeMapAllInFilter =
- compose (S.filter (<= maxValue) . Prelude.fmap (subtract 1))
-
-{-# INLINABLE composeScaling #-}
-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)
+-------------------------------------------------------------------------------
+-- Pure stream operations
+-------------------------------------------------------------------------------
+
+{-# INLINE eqInstance #-}
+eqInstance :: Stream Identity Int -> Bool
+eqInstance src = src == src
+
+{-# INLINE eqInstanceNotEq #-}
+eqInstanceNotEq :: Stream Identity Int -> Bool
+eqInstanceNotEq src = src P./= src
+
+{-# INLINE ordInstance #-}
+ordInstance :: Stream Identity Int -> Bool
+ordInstance src = src P.< src
+
+{-# INLINE ordInstanceMin #-}
+ordInstanceMin :: Stream Identity Int -> Stream Identity Int
+ordInstanceMin src = P.min src src
+
+{-# INLINE showInstance #-}
+showInstance :: Stream Identity Int -> P.String
+showInstance src = P.show src
+
+{-# INLINE showInstanceList #-}
+showInstanceList :: Stream Identity Int -> P.String
+showInstanceList src = P.show (GHC.toList src P.++ [2..value])
+
+{-# INLINE readInstance #-}
+readInstance :: Stream Identity Int -> Stream Identity Int
+readInstance src =
+ let r = P.reads ("fromList [1"
+ P.++ P.concat (P.replicate value ",1") P.++ "]")
+ in case r of
+ [(x,"")] -> src S.<> x
+ _ -> P.error "readInstance: no parse"
+
+{-# INLINE pureFoldl' #-}
+pureFoldl' :: Stream Identity Int -> Int
+pureFoldl' = runIdentity . S.foldl' (+) 0
+
+{-# INLINE foldableFoldl' #-}
+foldableFoldl' :: Stream Identity Int -> Int
+foldableFoldl' = F.foldl' (+) 0
+
+{-# INLINE foldableSum #-}
+foldableSum :: Stream Identity Int -> Int
+foldableSum = P.sum
+
+{-# INLINE traversableMapM #-}
+traversableMapM :: Stream Identity Int -> IO (Stream Identity Int)
+traversableMapM = P.mapM return
diff --git a/benchmark/NanoBenchmarks.hs b/benchmark/NanoBenchmarks.hs
new file mode 100644
index 0000000..04820fc
--- /dev/null
+++ b/benchmark/NanoBenchmarks.hs
@@ -0,0 +1,96 @@
+-------------------------------------------------------------------------------
+-- Investigate specific benchmarks more closely in isolation, possibly looking
+-- at GHC generated code for optimizing specific problematic cases.
+-------------------------------------------------------------------------------
+
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+import Streamly.SVar (MonadAsync)
+import qualified Streamly.Streams.StreamK as S
+import Gauge
+import System.Random
+
+maxValue :: Int
+maxValue = 100000
+
+{-# INLINE sourceUnfoldrM #-}
+sourceUnfoldrM :: MonadAsync m => S.Stream m Int
+sourceUnfoldrM = S.unfoldrM step 0
+ where
+ step cnt =
+ if cnt > maxValue
+ then return Nothing
+ else return (Just (cnt, cnt + 1))
+
+{-# INLINE sourceUnfoldrMN #-}
+sourceUnfoldrMN :: MonadAsync m => Int -> S.Stream m Int
+sourceUnfoldrMN n = S.unfoldrM step n
+ where
+ step cnt =
+ if cnt > n
+ then return Nothing
+ else return (Just (cnt, cnt + 1))
+
+{-# INLINE sourceUnfoldr #-}
+sourceUnfoldr :: Monad m => Int -> S.Stream m Int
+sourceUnfoldr n = S.unfoldr step n
+ where
+ step cnt =
+ if cnt > n + maxValue
+ then Nothing
+ else Just (cnt, cnt + 1)
+
+-------------------------------------------------------------------------------
+-- take-drop composition
+-------------------------------------------------------------------------------
+
+takeAllDropOne :: Monad m => S.Stream m Int -> S.Stream m Int
+takeAllDropOne = S.drop 1 . S.take maxValue
+
+-- Requires -fspec-constr-recursive=5 for better fused code
+-- The number depends on how many times we compose it
+
+{-# INLINE takeDrop #-}
+takeDrop :: Monad m => S.Stream m Int -> m ()
+takeDrop = S.runStream .
+ takeAllDropOne . takeAllDropOne . takeAllDropOne . takeAllDropOne
+
+-------------------------------------------------------------------------------
+-- dropWhileFalse composition
+-------------------------------------------------------------------------------
+
+dropWhileFalse :: Monad m => S.Stream m Int -> S.Stream m Int
+dropWhileFalse = S.dropWhile (> maxValue)
+
+-- Requires -fspec-constr-recursive=5 for better fused code
+-- The number depends on how many times we compose it
+
+{-# INLINE dropWhileFalseX4 #-}
+dropWhileFalseX4 :: Monad m => S.Stream m Int -> m ()
+dropWhileFalseX4 = S.runStream
+ . dropWhileFalse . dropWhileFalse . dropWhileFalse . dropWhileFalse
+
+-------------------------------------------------------------------------------
+-- iteration
+-------------------------------------------------------------------------------
+
+{-# INLINE iterateSource #-}
+iterateSource
+ :: MonadAsync m
+ => (S.Stream m Int -> S.Stream m Int) -> Int -> Int -> S.Stream m Int
+iterateSource g i n = f i (sourceUnfoldrMN n)
+ where
+ f (0 :: Int) m = g m
+ f x m = g (f (x - 1) m)
+
+-- Keep only the benchmark that is to be investiagted and comment out the rest.
+-- We keep all of them enabled by default for testing the build.
+main :: IO ()
+main = do
+ defaultMain [bench "unfoldr" $ nfIO $
+ randomRIO (1,1) >>= \n -> S.runStream (sourceUnfoldr n)]
+ defaultMain [bench "take-drop" $ nfIO $ takeDrop sourceUnfoldrM]
+ defaultMain [bench "dropWhileFalseX4" $
+ nfIO $ dropWhileFalseX4 sourceUnfoldrM]
+ defaultMain [bench "iterate-mapM" $
+ nfIO $ S.runStream $ iterateSource (S.mapM return) 100000 10]
diff --git a/benchmark/Nested.hs b/benchmark/Nested.hs
index 38b24ec..8f7d331 100644
--- a/benchmark/Nested.hs
+++ b/benchmark/Nested.hs
@@ -23,7 +23,8 @@ main =
-- TBD Study scaling with 10, 100, 1000 loop iterations
defaultMain
[ bgroup "serially"
- [ benchIO "toNull" $ Ops.toNull serially
+ [ benchIO "toNullAp" $ Ops.toNullAp serially
+ , benchIO "toNull" $ Ops.toNull serially
, benchIO "toList" $ Ops.toList serially
-- , benchIO "toListSome" $ Ops.toListSome serially
, benchIO "filterAllOut" $ Ops.filterAllOut serially
@@ -33,7 +34,8 @@ main =
]
, bgroup "wSerially"
- [ benchIO "toNull" $ Ops.toNull wSerially
+ [ benchIO "toNullAp" $ Ops.toNullAp wSerially
+ , benchIO "toNull" $ Ops.toNull wSerially
, benchIO "toList" $ Ops.toList wSerially
-- , benchIO "toListSome" $ Ops.toListSome wSerially
, benchIO "filterAllOut" $ Ops.filterAllOut wSerially
@@ -43,7 +45,8 @@ main =
]
, bgroup "aheadly"
- [ benchIO "toNull" $ Ops.toNull aheadly
+ [ benchIO "toNullAp" $ Ops.toNullAp aheadly
+ , benchIO "toNull" $ Ops.toNull aheadly
, benchIO "toList" $ Ops.toList aheadly
-- , benchIO "toListSome" $ Ops.toListSome aheadly
, benchIO "filterAllOut" $ Ops.filterAllOut aheadly
@@ -53,7 +56,8 @@ main =
]
, bgroup "asyncly"
- [ benchIO "toNull" $ Ops.toNull asyncly
+ [ benchIO "toNullAp" $ Ops.toNullAp asyncly
+ , benchIO "toNull" $ Ops.toNull asyncly
, benchIO "toList" $ Ops.toList asyncly
-- , benchIO "toListSome" $ Ops.toListSome asyncly
, benchIO "filterAllOut" $ Ops.filterAllOut asyncly
@@ -63,7 +67,8 @@ main =
]
, bgroup "wAsyncly"
- [ benchIO "toNull" $ Ops.toNull wAsyncly
+ [ benchIO "toNullAp" $ Ops.toNullAp wAsyncly
+ , benchIO "toNull" $ Ops.toNull wAsyncly
, benchIO "toList" $ Ops.toList wAsyncly
-- , benchIO "toListSome" $ Ops.toListSome wAsyncly
, benchIO "filterAllOut" $ Ops.filterAllOut wAsyncly
@@ -73,7 +78,8 @@ main =
]
, bgroup "parallely"
- [ benchIO "toNull" $ Ops.toNull parallely
+ [ benchIO "toNullAp" $ Ops.toNullAp parallely
+ , benchIO "toNull" $ Ops.toNull parallely
, benchIO "toList" $ Ops.toList parallely
--, benchIO "toListSome" $ Ops.toListSome parallely
, benchIO "filterAllOut" $ Ops.filterAllOut parallely
diff --git a/benchmark/NestedOps.hs b/benchmark/NestedOps.hs
index f41aa56..7d72a4c 100644
--- a/benchmark/NestedOps.hs
+++ b/benchmark/NestedOps.hs
@@ -62,6 +62,13 @@ runToList = S.toList
-- Benchmark ops
-------------------------------------------------------------------------------
+{-# INLINE toNullAp #-}
+toNullAp
+ :: (S.IsStream t, S.MonadAsync m, Monad (t m))
+ => (t m Int -> S.SerialT m Int) -> Int -> m ()
+toNullAp t start = runStream . t $
+ (+) <$> source start prodCount <*> source start prodCount
+
{-# INLINE toNull #-}
toNull
:: (S.IsStream t, S.MonadAsync m, Monad (t m))
diff --git a/benchmark/StreamDOps.hs b/benchmark/StreamDOps.hs
index 4b028f3..43a95aa 100644
--- a/benchmark/StreamDOps.hs
+++ b/benchmark/StreamDOps.hs
@@ -6,13 +6,17 @@
-- Maintainer : harendra.kumar@gmail.com
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module StreamDOps where
import Control.Monad (when)
+import Data.Maybe (isJust)
import Prelude
- (Monad, Int, (+), ($), (.), return, (>), even, (<=),
- subtract, undefined, Maybe(..), not, mapM_, (>>=))
+ (Monad, Int, (+), ($), (.), return, (>), even, (<=), div,
+ subtract, undefined, Maybe(..), not, mapM_, (>>=),
+ maxBound, fmap, odd, (==))
+import qualified Prelude as P
import qualified Streamly.Streams.StreamD as S
@@ -21,50 +25,6 @@ value = 100000
maxValue = value + 1000
-------------------------------------------------------------------------------
--- Benchmark ops
--------------------------------------------------------------------------------
-
-{-# INLINE uncons #-}
-{-# INLINE nullHeadTail #-}
-{-# INLINE scan #-}
-{-# INLINE map #-}
-{-# INLINE filterEven #-}
-{-# INLINE filterAllOut #-}
-{-# INLINE filterAllIn #-}
-{-# INLINE takeOne #-}
-{-# INLINE takeAll #-}
-{-# INLINE takeWhileTrue #-}
-{-# INLINE dropAll #-}
-{-# INLINE dropWhileTrue #-}
-{-# INLINE zip #-}
-{-
-{-# INLINE concat #-}
--}
-{-# INLINE composeAllInFilters #-}
-{-# INLINE composeAllOutFilters #-}
-{-# INLINE composeMapAllInFilter #-}
-uncons, nullHeadTail, map, scan, filterEven, filterAllOut,
- filterAllIn, takeOne, takeAll, takeWhileTrue, dropAll, dropWhileTrue, zip,
- -- concat,
- composeAllInFilters, composeAllOutFilters, composeMapAllInFilter
- :: Monad m
- => Stream m Int -> m ()
-
-{-# INLINE composeMapM #-}
-composeMapM :: Monad m => Stream m Int -> m ()
-
-{-# INLINE toList #-}
-toList :: Monad m => Stream m Int -> m [Int]
-{-# INLINE foldl #-}
-foldl :: Monad m => Stream m Int -> m Int
-{-# INLINE last #-}
-last :: Monad m => Stream m Int -> m (Maybe Int)
-
-{-# INLINE toNull #-}
-{-# INLINE mapM #-}
-toNull, mapM :: Monad m => Stream m Int -> m ()
-
--------------------------------------------------------------------------------
-- Stream generation and elimination
-------------------------------------------------------------------------------
@@ -79,6 +39,15 @@ sourceUnfoldr n = S.unfoldr step n
then Nothing
else Just (cnt, cnt + 1)
+{-# INLINE sourceUnfoldrMN #-}
+sourceUnfoldrMN :: Monad m => Int -> Int -> Stream m Int
+sourceUnfoldrMN m n = S.unfoldrM step n
+ where
+ step cnt =
+ if cnt > n + m
+ then return Nothing
+ else return (Just (cnt, cnt + 1))
+
{-# INLINE sourceUnfoldrM #-}
sourceUnfoldrM :: Monad m => Int -> Stream m Int
sourceUnfoldrM n = S.unfoldrM step n
@@ -88,9 +57,9 @@ sourceUnfoldrM n = S.unfoldrM step n
then return Nothing
else return (Just (cnt, cnt + 1))
-{-# INLINE sourceFromEnum #-}
-sourceFromEnum :: Monad m => Int -> Stream m Int
-sourceFromEnum n = S.enumFromStepN n 1 value
+{-# INLINE sourceIntFromTo #-}
+sourceIntFromTo :: Monad m => Int -> Stream m Int
+sourceIntFromTo n = S.enumerateFromToIntegral n (n + value)
{-# INLINE sourceFromList #-}
sourceFromList :: Monad m => Int -> Stream m Int
@@ -108,19 +77,45 @@ source = sourceUnfoldrM
runStream :: Monad m => Stream m a -> m ()
runStream = S.runStream
+{-# INLINE toNull #-}
+toNull :: Monad m => Stream m Int -> m ()
toNull = runStream
+
+{-# INLINE uncons #-}
+{-# INLINE nullTail #-}
+{-# INLINE headTail #-}
+uncons, nullTail, headTail
+ :: Monad m
+ => Stream m Int -> m ()
+
uncons s = do
r <- S.uncons s
case r of
Nothing -> return ()
Just (_, t) -> uncons t
-nullHeadTail s = do
+
+{-# INLINE tail #-}
+tail :: Monad m => Stream m a -> m ()
+tail s = S.tail s >>= mapM_ tail
+
+nullTail s = do
r <- S.null s
- when (not r) $ do
- _ <- S.head s
- S.tail s >>= mapM_ nullHeadTail
+ when (not r) $ S.tail s >>= mapM_ nullTail
+
+headTail s = do
+ h <- S.head s
+ when (isJust h) $ S.tail s >>= mapM_ headTail
+
+{-# INLINE toList #-}
+toList :: Monad m => Stream m Int -> m [Int]
toList = S.toList
+
+{-# INLINE foldl #-}
+foldl :: Monad m => Stream m Int -> m Int
foldl = S.foldl' (+) 0
+
+{-# INLINE last #-}
+last :: Monad m => Stream m Int -> m (Maybe Int)
last = S.last
-------------------------------------------------------------------------------
@@ -131,45 +126,149 @@ last = S.last
transform :: Monad m => Stream m a -> m ()
transform = runStream
-scan = transform . S.scanlM' (\a b -> return (a + b)) 0
-map = transform . S.map (+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)
+{-# INLINE composeN #-}
+composeN
+ :: Monad m
+ => Int -> (Stream m Int -> Stream m Int) -> Stream m Int -> m ()
+composeN n f =
+ case n of
+ 1 -> transform . f
+ 2 -> transform . f . f
+ 3 -> transform . f . f . f
+ 4 -> transform . f . f . f . f
+ _ -> undefined
+
+{-# INLINE scan #-}
+{-# INLINE map #-}
+{-# INLINE fmap #-}
+{-# INLINE mapM #-}
+{-# INLINE mapMaybe #-}
+{-# INLINE mapMaybeM #-}
+{-# INLINE filterEven #-}
+{-# INLINE filterAllOut #-}
+{-# INLINE filterAllIn #-}
+{-# INLINE takeOne #-}
+{-# INLINE takeAll #-}
+{-# INLINE takeWhileTrue #-}
+{-# INLINE takeWhileMTrue #-}
+{-# INLINE dropOne #-}
+{-# INLINE dropAll #-}
+{-# INLINE dropWhileTrue #-}
+{-# INLINE dropWhileMTrue #-}
+{-# INLINE dropWhileFalse #-}
+scan, map, fmap, mapM, mapMaybe, mapMaybeM, filterEven, filterAllOut,
+ filterAllIn, takeOne, takeAll, takeWhileTrue, takeWhileMTrue, dropOne,
+ dropAll, dropWhileTrue, dropWhileMTrue, dropWhileFalse
+ :: Monad m
+ => Int -> Stream m Int -> m ()
+
+scan n = composeN n $ S.scanl' (+) 0
+fmap n = composeN n $ Prelude.fmap (+1)
+map n = composeN n $ S.map (+1)
+mapM n = composeN n $ S.mapM return
+mapMaybe n = composeN n $ S.mapMaybe
+ (\x -> if Prelude.odd x then Nothing else Just x)
+mapMaybeM n = composeN n $ S.mapMaybeM
+ (\x -> if Prelude.odd x then return Nothing else return $ Just x)
+filterEven n = composeN n $ S.filter even
+filterAllOut n = composeN n $ S.filter (> maxValue)
+filterAllIn n = composeN n $ S.filter (<= maxValue)
+takeOne n = composeN n $ S.take 1
+takeAll n = composeN n $ S.take maxValue
+takeWhileTrue n = composeN n $ S.takeWhile (<= maxValue)
+takeWhileMTrue n = composeN n $ S.takeWhileM (return . (<= maxValue))
+dropOne n = composeN n $ S.drop 1
+dropAll n = composeN n $ S.drop maxValue
+dropWhileTrue n = composeN n $ S.dropWhile (<= maxValue)
+dropWhileMTrue n = composeN n $ S.dropWhileM (return . (<= maxValue))
+dropWhileFalse n = composeN n $ S.dropWhile (> maxValue)
-------------------------------------------------------------------------------
--- Zipping and concat
+-- Iteration
-------------------------------------------------------------------------------
-zip src = transform $ S.zipWith (,) src src
--- concat _n = return ()
+iterStreamLen, maxIters :: Int
+iterStreamLen = 10
+maxIters = 10000
+
+{-# INLINE iterateSource #-}
+iterateSource
+ :: Monad m
+ => (Stream m Int -> Stream m Int) -> Int -> Int -> Stream m Int
+iterateSource g i n = f i (sourceUnfoldrMN iterStreamLen n)
+ where
+ f (0 :: Int) m = g m
+ f x m = g (f (x P.- 1) m)
+
+{-# INLINE iterateMapM #-}
+{-# INLINE iterateScan #-}
+{-# INLINE iterateFilterEven #-}
+{-# INLINE iterateTakeAll #-}
+{-# INLINE iterateDropOne #-}
+{-# INLINE iterateDropWhileFalse #-}
+{-# INLINE iterateDropWhileTrue #-}
+iterateMapM, iterateScan, iterateFilterEven, iterateTakeAll, iterateDropOne,
+ iterateDropWhileFalse, iterateDropWhileTrue
+ :: Monad m
+ => Int -> Stream m Int
+
+-- this is quadratic
+iterateScan = iterateSource (S.scanl' (+) 0) (maxIters `div` 10)
+iterateDropWhileFalse = iterateSource (S.dropWhile (> maxValue))
+ (maxIters `div` 10)
+
+iterateMapM = iterateSource (S.mapM return) maxIters
+iterateFilterEven = iterateSource (S.filter even) maxIters
+iterateTakeAll = iterateSource (S.take maxValue) maxIters
+iterateDropOne = iterateSource (S.drop 1) maxIters
+iterateDropWhileTrue = iterateSource (S.dropWhile (<= maxValue)) maxIters
-------------------------------------------------------------------------------
--- Composition
+-- Zipping and concat
-------------------------------------------------------------------------------
-{-# INLINE compose #-}
-compose :: Monad m => (Stream m Int -> Stream m Int) -> Stream m Int -> m ()
-compose f = transform . f . f . f . f
+{-# INLINE eqBy #-}
+eqBy :: (Monad m, P.Eq a) => S.Stream m a -> m P.Bool
+eqBy src = S.eqBy (==) src src
-composeMapM = compose (S.mapM return)
-composeAllInFilters = compose (S.filter (<= maxValue))
-composeAllOutFilters = compose (S.filter (> maxValue))
-composeMapAllInFilter = compose (S.filter (<= maxValue) . S.map (subtract 1))
+{-# INLINE cmpBy #-}
+cmpBy :: (Monad m, P.Ord a) => S.Stream m a -> m P.Ordering
+cmpBy src = S.cmpBy P.compare src src
-{-# INLINABLE composeScaling #-}
-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)
+{-# INLINE zip #-}
+zip :: Monad m => Stream m Int -> m ()
+zip src = transform $ S.zipWith (,) src src
+
+{-
+{-# INLINE concat #-}
+concat _n = return ()
+-}
+
+-------------------------------------------------------------------------------
+-- Mixed Composition
+-------------------------------------------------------------------------------
+
+{-# INLINE scanMap #-}
+{-# INLINE dropMap #-}
+{-# INLINE dropScan #-}
+{-# INLINE takeDrop #-}
+{-# INLINE takeScan #-}
+{-# INLINE takeMap #-}
+{-# INLINE filterDrop #-}
+{-# INLINE filterTake #-}
+{-# INLINE filterScan #-}
+{-# INLINE filterMap #-}
+scanMap, dropMap, dropScan, takeDrop, takeScan, takeMap, filterDrop,
+ filterTake, filterScan, filterMap
+ :: Monad m => Int -> Stream m Int -> m ()
+
+scanMap n = composeN n $ S.map (subtract 1) . S.scanl' (+) 0
+dropMap n = composeN n $ S.map (subtract 1) . S.drop 1
+dropScan n = composeN n $ S.scanl' (+) 0 . S.drop 1
+takeDrop n = composeN n $ S.drop 1 . S.take maxValue
+takeScan n = composeN n $ S.scanl' (+) 0 . S.take maxValue
+takeMap n = composeN n $ S.map (subtract 1) . S.take maxValue
+filterDrop n = composeN n $ S.drop 1 . S.filter (<= maxValue)
+filterTake n = composeN n $ S.take maxValue . S.filter (<= maxValue)
+filterScan n = composeN n $ S.scanl' (+) 0 . S.filter (<= maxBound)
+filterMap n = composeN n $ S.map (subtract 1) . S.filter (<= maxValue)
diff --git a/benchmark/StreamKOps.hs b/benchmark/StreamKOps.hs
index 534198e..95c036f 100644
--- a/benchmark/StreamKOps.hs
+++ b/benchmark/StreamKOps.hs
@@ -6,16 +6,20 @@
-- Maintainer : harendra.kumar@gmail.com
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module StreamKOps where
import Control.Monad (when)
+import Data.Maybe (isJust)
import Prelude
- (Monad, Int, (+), ($), (.), return, fmap, even, (>), (<=),
- subtract, undefined, Maybe(..), not, mapM_, (>>=))
+ (Monad, Int, (+), ($), (.), return, even, (>), (<=), div,
+ subtract, undefined, Maybe(..), not, (>>=),
+ maxBound)
+import qualified Prelude as P
import qualified Streamly.Streams.StreamK as S
-import qualified Streamly.Streams.Prelude as S
+import qualified Streamly.Streams.Prelude as SP
import qualified Streamly.SVar as S
value, maxValue :: Int
@@ -28,32 +32,14 @@ maxValue = value + 1000
{-# INLINE toNull #-}
{-# INLINE uncons #-}
-{-# INLINE nullHeadTail #-}
-{-# INLINE scan #-}
-{-# INLINE map #-}
-{-# INLINE filterEven #-}
-{-# INLINE filterAllOut #-}
-{-# INLINE filterAllIn #-}
-{-# INLINE takeOne #-}
-{-# INLINE takeAll #-}
-{-# INLINE takeWhileTrue #-}
-{-# INLINE dropAll #-}
-{-# INLINE dropWhileTrue #-}
+{-# INLINE nullTail #-}
+{-# INLINE headTail #-}
{-# INLINE zip #-}
{-# INLINE concat #-}
-{-# INLINE composeAllInFilters #-}
-{-# INLINE composeAllOutFilters #-}
-{-# INLINE composeMapAllInFilter #-}
-toNull, uncons, nullHeadTail, scan, map, filterEven, filterAllOut,
- filterAllIn, takeOne, takeAll, takeWhileTrue, dropAll, dropWhileTrue, zip,
- concat, composeAllInFilters, composeAllOutFilters,
- composeMapAllInFilter
+toNull, uncons, nullTail, headTail, zip, concat
:: Monad m
=> Stream m Int -> m ()
-{-# INLINE composeMapM #-}
-composeMapM :: S.MonadAsync m => Stream m Int -> m ()
-
{-# INLINE toList #-}
toList :: Monad m => Stream m Int -> m [Int]
{-# INLINE foldl #-}
@@ -61,9 +47,6 @@ foldl :: Monad m => Stream m Int -> m Int
{-# INLINE last #-}
last :: Monad m => Stream m Int -> m (Maybe Int)
-{-# INLINE mapM #-}
-mapM :: S.MonadAsync m => Stream m Int -> m ()
-
-------------------------------------------------------------------------------
-- Stream generation and elimination
-------------------------------------------------------------------------------
@@ -88,6 +71,15 @@ sourceUnfoldrM n = S.unfoldrM step n
then return Nothing
else return (Just (cnt, cnt + 1))
+{-# INLINE sourceUnfoldrMN #-}
+sourceUnfoldrMN :: S.MonadAsync m => Int -> Int -> Stream m Int
+sourceUnfoldrMN m n = S.unfoldrM step n
+ where
+ step cnt =
+ if cnt > n + m
+ then return Nothing
+ else return (Just (cnt, cnt + 1))
+
{-
{-# INLINE sourceFromEnum #-}
sourceFromEnum :: Monad m => Int -> Stream m Int
@@ -106,11 +98,11 @@ sourceFromFoldableM n = S.fromFoldableM (Prelude.fmap return [n..n+value])
{-# INLINE sourceFoldMapWith #-}
sourceFoldMapWith :: Int -> Stream m Int
-sourceFoldMapWith n = S.foldMapWith S.serial S.yield [n..n+value]
+sourceFoldMapWith n = SP.foldMapWith S.serial S.yield [n..n+value]
{-# INLINE sourceFoldMapWithM #-}
sourceFoldMapWithM :: Monad m => Int -> Stream m Int
-sourceFoldMapWithM n = S.foldMapWith S.serial (S.yieldM . return) [n..n+value]
+sourceFoldMapWithM n = SP.foldMapWith S.serial (S.yieldM . return) [n..n+value]
{-# INLINE source #-}
source :: S.MonadAsync m => Int -> Stream m Int
@@ -124,6 +116,10 @@ source = sourceUnfoldrM
runStream :: Monad m => Stream m a -> m ()
runStream = S.runStream
+{-# INLINE mapM_ #-}
+mapM_ :: Monad m => Stream m a -> m ()
+mapM_ = S.mapM_ (\_ -> return ())
+
toNull = runStream
uncons s = do
r <- S.uncons s
@@ -135,19 +131,19 @@ uncons s = do
init :: (Monad m, S.IsStream t) => t m a -> m ()
init s = do
t <- S.init s
- mapM_ S.runStream t
+ P.mapM_ S.runStream t
{-# INLINE tail #-}
tail :: (Monad m, S.IsStream t) => t m a -> m ()
-tail s = S.tail s >>= mapM_ tail
+tail s = S.tail s >>= P.mapM_ tail
--- | If the stream is not null get its head and tail and then do the same to
--- the tail.
-nullHeadTail s = do
+nullTail s = do
r <- S.null s
- when (not r) $ do
- _ <- S.head s
- S.tail s >>= mapM_ nullHeadTail
+ when (not r) $ S.tail s >>= P.mapM_ nullTail
+
+headTail s = do
+ h <- S.head s
+ when (isJust h) $ S.tail s >>= P.mapM_ headTail
toList = S.toList
foldl = S.foldl' (+) 0
@@ -161,17 +157,94 @@ last = S.last
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)
+{-# INLINE composeN #-}
+composeN
+ :: Monad m
+ => Int -> (Stream m Int -> Stream m Int) -> Stream m Int -> m ()
+composeN n f =
+ case n of
+ 1 -> transform . f
+ 2 -> transform . f . f
+ 3 -> transform . f . f . f
+ 4 -> transform . f . f . f . f
+ _ -> undefined
+
+{-# INLINE scan #-}
+{-# INLINE map #-}
+{-# INLINE fmap #-}
+{-# INLINE filterEven #-}
+{-# INLINE filterAllOut #-}
+{-# INLINE filterAllIn #-}
+{-# INLINE takeOne #-}
+{-# INLINE takeAll #-}
+{-# INLINE takeWhileTrue #-}
+{-# INLINE dropOne #-}
+{-# INLINE dropAll #-}
+{-# INLINE dropWhileTrue #-}
+{-# INLINE dropWhileFalse #-}
+scan, map, fmap, filterEven, filterAllOut,
+ filterAllIn, takeOne, takeAll, takeWhileTrue, dropAll, dropOne,
+ dropWhileTrue, dropWhileFalse
+ :: Monad m
+ => Int -> Stream m Int -> m ()
+
+{-# INLINE mapM #-}
+mapM :: S.MonadAsync m => Int -> Stream m Int -> m ()
+
+scan n = composeN n $ S.scanl' (+) 0
+map n = composeN n $ P.fmap (+1)
+fmap n = composeN n $ P.fmap (+1)
+mapM n = composeN n $ S.mapM return
+filterEven n = composeN n $ S.filter even
+filterAllOut n = composeN n $ S.filter (> maxValue)
+filterAllIn n = composeN n $ S.filter (<= maxValue)
+takeOne n = composeN n $ S.take 1
+takeAll n = composeN n $ S.take maxValue
+takeWhileTrue n = composeN n $ S.takeWhile (<= maxValue)
+dropOne n = composeN n $ S.drop 1
+dropAll n = composeN n $ S.drop maxValue
+dropWhileTrue n = composeN n $ S.dropWhile (<= maxValue)
+dropWhileFalse n = composeN n $ S.dropWhile (<= 1)
+
+-------------------------------------------------------------------------------
+-- Iteration
+-------------------------------------------------------------------------------
+
+iterStreamLen, maxIters :: Int
+iterStreamLen = 10
+maxIters = 10000
+
+{-# INLINE iterateSource #-}
+iterateSource
+ :: S.MonadAsync m
+ => (Stream m Int -> Stream m Int) -> Int -> Int -> Stream m Int
+iterateSource g i n = f i (sourceUnfoldrMN iterStreamLen n)
+ where
+ f (0 :: Int) m = g m
+ f x m = g (f (x P.- 1) m)
+
+{-# INLINE iterateMapM #-}
+{-# INLINE iterateScan #-}
+{-# INLINE iterateFilterEven #-}
+{-# INLINE iterateTakeAll #-}
+{-# INLINE iterateDropOne #-}
+{-# INLINE iterateDropWhileFalse #-}
+{-# INLINE iterateDropWhileTrue #-}
+iterateMapM, iterateScan, iterateFilterEven, iterateTakeAll, iterateDropOne,
+ iterateDropWhileFalse, iterateDropWhileTrue
+ :: S.MonadAsync m
+ => Int -> Stream m Int
+
+-- this is quadratic
+iterateScan = iterateSource (S.scanl' (+) 0) (maxIters `div` 10)
+iterateDropWhileFalse = iterateSource (S.dropWhile (> maxValue))
+ (maxIters `div` 10)
+
+iterateMapM = iterateSource (S.mapM return) maxIters
+iterateFilterEven = iterateSource (S.filter even) maxIters
+iterateTakeAll = iterateSource (S.take maxValue) maxIters
+iterateDropOne = iterateSource (S.drop 1) maxIters
+iterateDropWhileTrue = iterateSource (S.dropWhile (<= maxValue)) maxIters
-------------------------------------------------------------------------------
-- Zipping and concat
@@ -181,25 +254,30 @@ zip src = transform $ S.zipWith (,) src src
concat _n = return ()
-------------------------------------------------------------------------------
--- Composition
+-- Mixed 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))
-
-{-# INLINABLE composeScaling #-}
-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)
+{-# INLINE scanMap #-}
+{-# INLINE dropMap #-}
+{-# INLINE dropScan #-}
+{-# INLINE takeDrop #-}
+{-# INLINE takeScan #-}
+{-# INLINE takeMap #-}
+{-# INLINE filterDrop #-}
+{-# INLINE filterTake #-}
+{-# INLINE filterScan #-}
+{-# INLINE filterMap #-}
+scanMap, dropMap, dropScan, takeDrop, takeScan, takeMap, filterDrop,
+ filterTake, filterScan, filterMap
+ :: Monad m => Int -> Stream m Int -> m ()
+
+scanMap n = composeN n $ S.map (subtract 1) . S.scanl' (+) 0
+dropMap n = composeN n $ S.map (subtract 1) . S.drop 1
+dropScan n = composeN n $ S.scanl' (+) 0 . S.drop 1
+takeDrop n = composeN n $ S.drop 1 . S.take maxValue
+takeScan n = composeN n $ S.scanl' (+) 0 . S.take maxValue
+takeMap n = composeN n $ S.map (subtract 1) . S.take maxValue
+filterDrop n = composeN n $ S.drop 1 . S.filter (<= maxValue)
+filterTake n = composeN n $ S.take maxValue . S.filter (<= maxValue)
+filterScan n = composeN n $ S.scanl' (+) 0 . S.filter (<= maxBound)
+filterMap n = composeN n $ S.map (subtract 1) . S.filter (<= maxValue)
diff --git a/docs/streamly-vs-async.md b/docs/streamly-vs-async.md
index 1b35512..7e45cad 100644
--- a/docs/streamly-vs-async.md
+++ b/docs/streamly-vs-async.md
@@ -228,3 +228,8 @@ the concurrent actions are executed.
See the [haddock documentation on
hackage](https://hackage.haskell.org/package/streamly) and [a comprehensive tutorial
here](https://hackage.haskell.org/package/streamly/docs/Streamly-Tutorial.html).
+
+## References
+
+* https://hackage.haskell.org/package/async
+* https://hackage.haskell.org/package/lifted-async
diff --git a/examples/AcidRain.hs b/examples/AcidRain.hs
index c2b59fa..b39c9ce 100644
--- a/examples/AcidRain.hs
+++ b/examples/AcidRain.hs
@@ -5,11 +5,11 @@
import Streamly
import Streamly.Prelude as S
-import Control.Monad (when)
+import Control.Monad (void, when)
import Control.Monad.IO.Class (MonadIO(liftIO))
import Control.Monad.State (MonadState, get, modify, runStateT, put)
-data Event = Harm Int | Heal Int deriving (Show)
+data Event = Quit | Harm Int | Heal Int deriving (Show)
userAction :: MonadAsync m => SerialT m Event
userAction = S.repeatM $ liftIO askUser
@@ -18,26 +18,38 @@ userAction = S.repeatM $ liftIO askUser
command <- getLine
case command of
"potion" -> return (Heal 10)
- "quit" -> fail "quit"
- _ -> putStrLn "What?" >> askUser
+ "harm" -> return (Harm 10)
+ "quit" -> return Quit
+ _ -> putStrLn "Type potion or harm or quit" >> askUser
acidRain :: MonadAsync m => SerialT m Event
acidRain = asyncly $ constRate 1 $ S.repeatM $ liftIO $ return $ Harm 1
-game :: (MonadAsync m, MonadState Int m) => SerialT m ()
-game = do
+data Result = Check | Done
+
+runEvents :: (MonadAsync m, MonadState Int m) => SerialT m Result
+runEvents = do
event <- userAction `parallel` acidRain
case event of
- Harm n -> modify $ \h -> h - n
- Heal n -> modify $ \h -> h + n
-
- h <- get
- when (h <= 0) $ fail "You die!"
- liftIO $ putStrLn $ "Health = " <> show h
+ Harm n -> modify (\h -> h - n) >> return Check
+ Heal n -> modify (\h -> h + n) >> return Check
+ Quit -> return Done
+
+data Status = Alive | GameOver deriving Eq
+
+getStatus :: (MonadAsync m, MonadState Int m) => Result -> m Status
+getStatus result =
+ case result of
+ Done -> liftIO $ putStrLn "You quit!" >> return GameOver
+ Check -> do
+ h <- get
+ liftIO $ if (h <= 0)
+ then putStrLn "You die!" >> return GameOver
+ else putStrLn ("Health = " <> show h) >> return Alive
main :: IO ()
main = do
putStrLn "Your health is deteriorating due to acid rain,\
\ type \"potion\" or \"quit\""
- _ <- runStateT (runStream game) 60
- return ()
+ let runGame = S.runWhile (== Alive) $ S.mapM getStatus runEvents
+ void $ runStateT runGame 60
diff --git a/examples/ControlFlow.hs b/examples/ControlFlow.hs
index 5361aed..d54cbfd 100644
--- a/examples/ControlFlow.hs
+++ b/examples/ControlFlow.hs
@@ -48,7 +48,7 @@ getSequenceMaybeBelow = do
liftIO $ putStrLn "MaybeT below streamly: Enter one char per line: "
i <- S.fromFoldable [1..2 :: Int]
- liftIO $ putStrLn $ "iteration = " ++ show i
+ liftIO $ putStrLn $ "iteration = " <> show i
r1 <- liftIO getLine
when (r1 /= "x") $ lift mzero
@@ -78,13 +78,13 @@ getSequenceMaybeAbove = do
liftIO $ putStrLn "MaybeT above streamly: Enter one char per line: "
i <- lift $ S.fromFoldable [1..2 :: Int]
- liftIO $ putStrLn $ "iteration = " ++ show i
+ liftIO $ putStrLn $ "iteration = " <> show i
r1 <- liftIO getLine
- when (r1 /= "x") $ mzero
+ when (r1 /= "x") mzero
r2 <- liftIO getLine
- when (r2 /= "y") $ mzero
+ when (r2 /= "y") mzero
mainMaybeAbove :: (IsStream t, MonadIO (t m)) => MaybeT (t m) ()
mainMaybeAbove = do
@@ -111,13 +111,13 @@ getSequenceEitherBelow = do
liftIO $ putStrLn "ExceptT below streamly: Enter one char per line: "
i <- S.fromFoldable [1..2 :: Int]
- liftIO $ putStrLn $ "iteration = " ++ show i
+ liftIO $ putStrLn $ "iteration = " <> show i
r1 <- liftIO getLine
- when (r1 /= "x") $ lift $ throwE $ "Expecting x got: " ++ r1
+ when (r1 /= "x") $ lift $ throwE $ "Expecting x got: " <> r1
r2 <- liftIO getLine
- when (r2 /= "y") $ lift $ throwE $ "Expecting y got: " ++ r2
+ when (r2 /= "y") $ lift $ throwE $ "Expecting y got: " <> r2
mainEitherBelow :: IO ()
mainEitherBelow = do
@@ -140,7 +140,7 @@ getSequenceEitherAsyncBelow
, MonadAsync m
, MonadIO (t m)
, MonadIO (t (ExceptT String m))
- , Semigroup (t (ExceptT [Char] m) Integer)
+ , Semigroup (t (ExceptT String m) Integer)
)
=> t (ExceptT String m) ()
getSequenceEitherAsyncBelow = do
@@ -151,11 +151,11 @@ getSequenceEitherAsyncBelow = do
>> return 1)
<> (lift (throwE "Second task") >> return 2)
<> S.yield (3 :: Integer)
- liftIO $ putStrLn $ "iteration = " ++ show i
+ liftIO $ putStrLn $ "iteration = " <> show i
mainEitherAsyncBelow :: IO ()
mainEitherAsyncBelow = do
- r <- runExceptT (runStream $ asyncly $ getSequenceEitherAsyncBelow)
+ r <- runExceptT (runStream $ asyncly getSequenceEitherAsyncBelow)
case r of
Right _ -> liftIO $ putStrLn "Bingo"
Left s -> liftIO $ putStrLn s
@@ -178,25 +178,25 @@ getSequenceEitherAbove = do
liftIO $ putStrLn "ExceptT above streamly: Enter one char per line: "
i <- lift $ S.fromFoldable [1..2 :: Int]
- liftIO $ putStrLn $ "iteration = " ++ show i
+ liftIO $ putStrLn $ "iteration = " <> show i
r1 <- liftIO getLine
- when (r1 /= "x") $ throwE $ "Expecting x got: " ++ r1
+ when (r1 /= "x") $ throwE $ "Expecting x got: " <> r1
r2 <- liftIO getLine
- when (r2 /= "y") $ throwE $ "Expecting y got: " ++ r2
+ when (r2 /= "y") $ throwE $ "Expecting y got: " <> r2
mainEitherAbove :: (IsStream t, Monad m, MonadIO (t m))
=> ExceptT String (t m) ()
-mainEitherAbove = do
+mainEitherAbove =
catchE (getSequenceEitherAbove >> liftIO (putStrLn "Bingo"))
- (\e -> liftIO $ putStrLn e)
+ (liftIO . putStrLn)
-------------------------------------------------------------------------------
-- Using MonadThrow to throw exceptions in streamly
-------------------------------------------------------------------------------
--
-data Unexpected = Unexpected String deriving Show
+newtype Unexpected = Unexpected String deriving Show
instance Exception Unexpected
@@ -209,18 +209,18 @@ getSequenceMonadThrow = do
liftIO $ putStrLn "MonadThrow in streamly: Enter one char per line: "
i <- S.fromFoldable [1..2 :: Int]
- liftIO $ putStrLn $ "iteration = " ++ show i
+ liftIO $ putStrLn $ "iteration = " <> show i
r1 <- liftIO getLine
- when (r1 /= "x") $ throwM $ Unexpected $ "Expecting x got: " ++ r1
+ when (r1 /= "x") $ throwM $ Unexpected $ "Expecting x got: " <> r1
r2 <- liftIO getLine
- when (r2 /= "y") $ throwM $ Unexpected $ "Expecting y got: " ++ r2
+ when (r2 /= "y") $ throwM $ Unexpected $ "Expecting y got: " <> r2
mainMonadThrow :: IO ()
-mainMonadThrow = do
+mainMonadThrow =
catch (runStream getSequenceMonadThrow >> liftIO (putStrLn "Bingo"))
- (\(e :: SomeException) -> liftIO $ putStrLn $ show e)
+ (\(e :: SomeException) -> liftIO $ print e)
-------------------------------------------------------------------------------
-- Using ContT below streamly
@@ -238,19 +238,19 @@ getSequenceContBelow = do
liftIO $ putStrLn "ContT below streamly: Enter one char per line: "
i <- S.fromFoldable [1..2 :: Int]
- liftIO $ putStrLn $ "iteration = " ++ show i
+ liftIO $ putStrLn $ "iteration = " <> show i
r <- lift $ callCC $ \exit -> do
r1 <- liftIO getLine
_ <- if r1 /= "x"
- then exit $ Left $ "Expecting x got: " ++ r1
+ then exit $ Left $ "Expecting x got: " <> r1
else return $ Right ()
r2 <- liftIO getLine
if r2 /= "y"
- then exit $ Left $ "Expecting y got: " ++ r2
+ then exit $ Left $ "Expecting y got: " <> r2
else return $ Right ()
- liftIO $ putStrLn $ "done iteration = " ++ show i
+ liftIO $ putStrLn $ "done iteration = " <> show i
return r
mainContBelow
@@ -272,17 +272,17 @@ getSequenceContAbove = do
liftIO $ putStrLn "ContT above streamly: Enter one char per line: "
i <- lift $ S.fromFoldable [1..2 :: Int]
- liftIO $ putStrLn $ "iteration = " ++ show i
+ liftIO $ putStrLn $ "iteration = " <> show i
callCC $ \exit -> do
r1 <- liftIO getLine
_ <- if r1 /= "x"
- then exit $ Left $ "Expecting x got: " ++ r1
+ then exit $ Left $ "Expecting x got: " <> r1
else return $ Right ()
r2 <- liftIO getLine
if r2 /= "y"
- then exit $ Left $ "Expecting y got: " ++ r2
+ then exit $ Left $ "Expecting y got: " <> r2
else return $ Right ()
mainContAbove :: (IsStream t, Monad m, MonadIO (t m)) => ContT r (t m) ()
diff --git a/examples/MergeSort.hs b/examples/MergeSort.hs
index f0f78c3..80c696a 100644
--- a/examples/MergeSort.hs
+++ b/examples/MergeSort.hs
@@ -1,40 +1,24 @@
{-# LANGUAGE FlexibleContexts #-}
+-- | This example generates two streams sorted in ascending order and merges
+-- them in ascending order, concurrently.
+--
+-- Compile with '-threaded -with-rtsopts "-N"' GHC options to use the
+-- parallelism.
+
import Data.Word
import System.Random (getStdGen, randoms)
import Data.List (sort)
+import Data.Ord (compare)
+
import Streamly
-import Streamly.Prelude (yieldM)
-import qualified Streamly.Prelude as A
+import qualified Streamly.Prelude as S
getSorted :: Serial Word16
getSorted = do
- g <- yieldM getStdGen
+ g <- S.yieldM getStdGen
let ls = take 100000 (randoms g) :: [Word16]
foldMap return (sort ls)
--- | merge two streams generating the elements from each in parallel
-mergeAsync :: Ord a => Serial a -> Serial a -> Serial a
-mergeAsync a b = do
- x <- yieldM $ mkAsync a
- y <- yieldM $ mkAsync b
- merge x y
-
-merge :: Ord a => Serial a -> Serial a -> Serial a
-merge a b = do
- a1 <- yieldM $ A.uncons a
- case a1 of
- Nothing -> b
- Just (x, ma) -> do
- b1 <- yieldM $ A.uncons b
- case b1 of
- Nothing -> return x <> ma
- Just (y, mb) ->
- if y < x
- then return y <> merge (return x <> ma) mb
- else return x <> merge ma (return y <> mb)
-
main :: IO ()
-main = do
- xs <- A.toList $ mergeAsync getSorted getSorted
- print $ length xs
+main = S.last (S.mergeAsyncBy compare getSorted getSorted) >>= print
diff --git a/src/Streamly.hs b/src/Streamly.hs
index d3c8367..cb00ac8 100644
--- a/src/Streamly.hs
+++ b/src/Streamly.hs
@@ -61,7 +61,7 @@
{-# OPTIONS_GHC -Wno-orphans #-}
#endif
-#include "Streamly/Streams/inline.h"
+#include "Streamly/Streams/inline.hs"
module Streamly
(
@@ -89,8 +89,7 @@ module Streamly
, ZipAsyncM
-- * Running Streams
- , runStream
-
+ , P.runStream
-- * Parallel Function Application
-- $application
, (|$)
@@ -153,6 +152,7 @@ module Streamly
-- * Re-exports
, Semigroup (..)
+
-- * Deprecated
, Streaming
, runStreaming
@@ -173,18 +173,18 @@ module Streamly
)
where
-import Streamly.Streams.StreamK hiding (runStream, serial)
-import Streamly.Streams.Serial
-import Streamly.Streams.Async
+import Data.Semigroup (Semigroup(..))
+import Streamly.SVar (MonadAsync, Rate(..))
import Streamly.Streams.Ahead
+import Streamly.Streams.Async
+import Streamly.Streams.Combinators
import Streamly.Streams.Parallel
-import Streamly.Streams.Zip
import Streamly.Streams.Prelude
-import Streamly.Streams.SVar
-import Streamly.SVar (MonadAsync, Rate (..))
-import Data.Semigroup (Semigroup(..))
+import Streamly.Streams.Serial
+import Streamly.Streams.StreamK hiding (runStream, serial)
+import Streamly.Streams.Zip
-import qualified Streamly.Streams.StreamD as D
+import qualified Streamly.Prelude as P
import qualified Streamly.Streams.StreamK as K
-- XXX This should perhaps be moved to Prelude.
@@ -193,65 +193,54 @@ import qualified Streamly.Streams.StreamK as K
-- Eliminating a stream
------------------------------------------------------------------------------
--- | 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
-{-# INLINE_EARLY runStream #-}
-runStream :: Monad m => SerialT m a -> m ()
-runStream m = D.runStream $ D.fromStreamK (toStream m)
-{-# RULES "runStream fallback to CPS" [1]
- forall a. D.runStream (D.fromStreamK a) = K.runStream a #-}
-
-- | Same as 'runStream'
--
-- @since 0.1.0
{-# DEPRECATED runStreaming "Please use runStream instead." #-}
runStreaming :: (Monad m, IsStream t) => t m a -> m ()
-runStreaming = runStream . K.adapt
+runStreaming = P.runStream . K.adapt
-- | Same as @runStream@.
--
-- @since 0.1.0
{-# DEPRECATED runStreamT "Please use runStream instead." #-}
runStreamT :: Monad m => SerialT m a -> m ()
-runStreamT = runStream
+runStreamT = P.runStream
-- | Same as @runStream . wSerially@.
--
-- @since 0.1.0
{-# DEPRECATED runInterleavedT "Please use 'runStream . interleaving' instead." #-}
runInterleavedT :: Monad m => WSerialT m a -> m ()
-runInterleavedT = runStream . K.adapt
+runInterleavedT = P.runStream . K.adapt
-- | Same as @runStream . parallely@.
--
-- @since 0.1.0
{-# DEPRECATED runParallelT "Please use 'runStream . parallely' instead." #-}
runParallelT :: Monad m => ParallelT m a -> m ()
-runParallelT = runStream . K.adapt
+runParallelT = P.runStream . K.adapt
-- | Same as @runStream . asyncly@.
--
-- @since 0.1.0
{-# DEPRECATED runAsyncT "Please use 'runStream . asyncly' instead." #-}
runAsyncT :: Monad m => AsyncT m a -> m ()
-runAsyncT = runStream . K.adapt
+runAsyncT = P.runStream . K.adapt
-- | Same as @runStream . zipping@.
--
-- @since 0.1.0
{-# DEPRECATED runZipStream "Please use 'runStream . zipSerially instead." #-}
runZipStream :: Monad m => ZipSerialM m a -> m ()
-runZipStream = runStream . K.adapt
+runZipStream = P.runStream . K.adapt
-- | Same as @runStream . zippingAsync@.
--
-- @since 0.1.0
{-# DEPRECATED runZipAsync "Please use 'runStream . zipAsyncly instead." #-}
runZipAsync :: Monad m => ZipAsyncM m a -> m ()
-runZipAsync = runStream . K.adapt
+runZipAsync = P.runStream . K.adapt
------------------------------------------------------------------------------
-- Documentation
diff --git a/src/Streamly/Enumeration.hs b/src/Streamly/Enumeration.hs
new file mode 100644
index 0000000..eed7b15
--- /dev/null
+++ b/src/Streamly/Enumeration.hs
@@ -0,0 +1,550 @@
+{-# LANGUAGE CPP #-}
+
+-- |
+-- Module : Streamly.Enumeration
+-- Copyright : (c) 2018 Harendra Kumar
+--
+-- License : BSD3
+-- Maintainer : harendra.kumar@gmail.com
+-- Stability : experimental
+-- Portability : GHC
+--
+-- The functions defined in this module should be rarely needed for direct use,
+-- try to use the operations from the 'Enumerable' type class
+-- instances instead.
+--
+-- This module provides an 'Enumerable' type class to enumerate 'Enum' types
+-- into a stream. The operations in this type class correspond to similar
+-- perations in the 'Enum' type class, the only difference is that they produce
+-- a stream instead of a list. These operations cannot be defined generically
+-- based on the 'Enum' type class. We provide instances for commonly used
+-- types. If instances for other types are needed convenience functions defined
+-- in this module can be used to define them. Alternatively, these functions
+-- can be used directly.
+
+module Streamly.Enumeration
+ (
+ Enumerable (..)
+
+ -- ** Enumerating 'Bounded' 'Enum' Types
+ , enumerate
+ , enumerateTo
+ , enumerateFromBounded
+
+ -- ** Enumerating 'Enum' Types not larger than 'Int'
+ , enumerateFromToSmall
+ , enumerateFromThenToSmall
+ , enumerateFromThenSmallBounded
+
+ -- ** Enumerating 'Bounded' 'Integral' Types
+ , enumerateFromIntegral
+ , enumerateFromThenIntegral
+
+ -- ** Enumerating 'Integral' Types
+ , enumerateFromToIntegral
+ , enumerateFromThenToIntegral
+
+ -- ** Enumerating unbounded 'Integral' Types
+ , enumerateFromStepIntegral
+
+ -- ** Enumerating 'Fractional' Types
+ , enumerateFromFractional
+ , enumerateFromToFractional
+ , enumerateFromThenFractional
+ , enumerateFromThenToFractional
+ )
+where
+
+import Data.Fixed
+import Data.Int
+import Data.Ratio
+import Data.Word
+import Numeric.Natural
+import Data.Functor.Identity (Identity(..))
+
+import Streamly.Streams.StreamD (fromStreamD)
+import Streamly.Streams.StreamK (IsStream(..))
+
+import qualified Streamly.Streams.StreamD as D
+import qualified Streamly.Streams.Serial as Serial
+
+-------------------------------------------------------------------------------
+-- Enumeration of Integral types
+-------------------------------------------------------------------------------
+--
+-- | @enumerateFromStepIntegral from step@ generates an infinite stream whose
+-- first element is @from@ and the successive elements are in increments of
+-- @step@.
+--
+-- CAUTION: This function is not safe for finite integral types. It does not
+-- check for overflow, underflow or bounds.
+--
+-- @
+-- > S.toList $ S.take 4 $ S.enumerateFromStepIntegral 0 2
+-- [0,2,4,6]
+-- > S.toList $ S.take 3 $ S.enumerateFromStepIntegral 0 (-2)
+-- [0,-2,-4]
+-- @
+--
+-- @since 0.6.0
+{-# INLINE enumerateFromStepIntegral #-}
+enumerateFromStepIntegral
+ :: (IsStream t, Monad m, Integral a)
+ => a -> a -> t m a
+enumerateFromStepIntegral from stride =
+ fromStreamD $ D.enumerateFromStepIntegral from stride
+
+-- | Enumerate an 'Integral' type. @enumerateFromIntegral from@ generates a
+-- stream whose first element is @from@ and the successive elements are in
+-- increments of @1@. The stream is bounded by the size of the 'Integral' type.
+--
+-- @
+-- > S.toList $ S.take 4 $ S.enumerateFromIntegral (0 :: Int)
+-- [0,1,2,3]
+-- @
+--
+-- @since 0.6.0
+{-# INLINE enumerateFromIntegral #-}
+enumerateFromIntegral
+ :: (IsStream t, Monad m, Integral a, Bounded a)
+ => a -> t m a
+enumerateFromIntegral from = fromStreamD $ D.enumerateFromIntegral from
+
+-- | Enumerate an 'Integral' type in steps. @enumerateFromThenIntegral from
+-- then@ generates a stream whose first element is @from@, the second element
+-- is @then@ and the successive elements are in increments of @then - from@.
+-- The stream is bounded by the size of the 'Integral' type.
+--
+-- @
+-- > S.toList $ S.take 4 $ S.enumerateFromThenIntegral (0 :: Int) 2
+-- [0,2,4,6]
+-- > S.toList $ S.take 4 $ S.enumerateFromThenIntegral (0 :: Int) (-2)
+-- [0,-2,-4,-6]
+-- @
+--
+-- @since 0.6.0
+{-# INLINE enumerateFromThenIntegral #-}
+enumerateFromThenIntegral
+ :: (IsStream t, Monad m, Integral a, Bounded a)
+ => a -> a -> t m a
+enumerateFromThenIntegral from next =
+ fromStreamD $ D.enumerateFromThenIntegral from next
+
+-- | Enumerate an 'Integral' type up to a given limit.
+-- @enumerateFromToIntegral from to@ generates a finite stream whose first
+-- element is @from@ and successive elements are in increments of @1@ up to
+-- @to@.
+--
+-- @
+-- > S.toList $ S.enumerateFromToIntegral 0 4
+-- [0,1,2,3,4]
+-- @
+--
+-- @since 0.6.0
+{-# INLINE enumerateFromToIntegral #-}
+enumerateFromToIntegral :: (IsStream t, Monad m, Integral a) => a -> a -> t m a
+enumerateFromToIntegral from to =
+ fromStreamD $ D.enumerateFromToIntegral from to
+
+-- | Enumerate an 'Integral' type in steps up to a given limit.
+-- @enumerateFromThenToIntegral from then to@ generates a finite stream whose
+-- first element is @from@, the second element is @then@ and the successive
+-- elements are in increments of @then - from@ up to @to@.
+--
+-- @
+-- > S.toList $ S.enumerateFromThenToIntegral 0 2 6
+-- [0,2,4,6]
+-- > S.toList $ S.enumerateFromThenToIntegral 0 (-2) (-6)
+-- [0,-2,-4,-6]
+-- @
+--
+-- @since 0.6.0
+{-# INLINE enumerateFromThenToIntegral #-}
+enumerateFromThenToIntegral
+ :: (IsStream t, Monad m, Integral a)
+ => a -> a -> a -> t m a
+enumerateFromThenToIntegral from next to =
+ fromStreamD $ D.enumerateFromThenToIntegral from next to
+
+-------------------------------------------------------------------------------
+-- Enumeration of Fractional types
+-------------------------------------------------------------------------------
+--
+-- Even though the underlying implementation of enumerateFromFractional and
+-- enumerateFromThenFractional works for any 'Num' we have restricted these to
+-- 'Fractional' because these do not perform any bounds check, in contrast to
+-- integral versions and are therefore not equivalent substitutes for those.
+--
+-- | Numerically stable enumeration from a 'Fractional' number in steps of size
+-- @1@. @enumerateFromFractional from@ generates a stream whose first element
+-- is @from@ and the successive elements are in increments of @1@. No overflow
+-- or underflow checks are performed.
+--
+-- This is the equivalent to 'enumFrom' for 'Fractional' types. For example:
+--
+-- @
+-- > S.toList $ S.take 4 $ S.enumerateFromFractional 1.1
+-- [1.1,2.1,3.1,4.1]
+-- @
+--
+--
+-- @since 0.6.0
+{-# INLINE enumerateFromFractional #-}
+enumerateFromFractional :: (IsStream t, Monad m, Fractional a) => a -> t m a
+enumerateFromFractional from = fromStreamD $ D.numFrom from
+
+-- | Numerically stable enumeration from a 'Fractional' number in steps.
+-- @enumerateFromThenFractional from then@ generates a stream whose first
+-- element is @from@, the second element is @then@ and the successive elements
+-- are in increments of @then - from@. No overflow or underflow checks are
+-- performed.
+--
+-- This is the equivalent of 'enumFromThen' for 'Fractional' types. For
+-- example:
+--
+-- @
+-- > S.toList $ S.take 4 $ S.enumerateFromThenFractional 1.1 2.1
+-- [1.1,2.1,3.1,4.1]
+-- > S.toList $ S.take 4 $ S.enumerateFromThenFractional 1.1 (-2.1)
+-- [1.1,-2.1,-5.300000000000001,-8.500000000000002]
+-- @
+--
+-- @since 0.6.0
+{-# INLINE enumerateFromThenFractional #-}
+enumerateFromThenFractional
+ :: (IsStream t, Monad m, Fractional a)
+ => a -> a -> t m a
+enumerateFromThenFractional from next = fromStreamD $ D.numFromThen from next
+
+-- | Numerically stable enumeration from a 'Fractional' number to a given
+-- limit. @enumerateFromToFractional from to@ generates a finite stream whose
+-- first element is @from@ and successive elements are in increments of @1@ up
+-- to @to@.
+--
+-- This is the equivalent of 'enumFromTo' for 'Fractional' types. For
+-- example:
+--
+-- @
+-- > S.toList $ S.enumerateFromToFractional 1.1 4
+-- [1.1,2.1,3.1,4.1]
+-- > S.toList $ S.enumerateFromToFractional 1.1 4.6
+-- [1.1,2.1,3.1,4.1,5.1]
+-- @
+--
+-- Notice that the last element is equal to the specified @to@ value after
+-- rounding to the nearest integer.
+--
+-- @since 0.6.0
+{-# INLINE enumerateFromToFractional #-}
+enumerateFromToFractional
+ :: (IsStream t, Monad m, Fractional a, Ord a)
+ => a -> a -> t m a
+enumerateFromToFractional from to =
+ fromStreamD $ D.enumerateFromToFractional from to
+
+-- | Numerically stable enumeration from a 'Fractional' number in steps up to a
+-- given limit. @enumerateFromThenToFractional from then to@ generates a
+-- finite stream whose first element is @from@, the second element is @then@
+-- and the successive elements are in increments of @then - from@ up to @to@.
+--
+-- This is the equivalent of 'enumFromThenTo' for 'Fractional' types. For
+-- example:
+--
+-- @
+-- > S.toList $ S.enumerateFromThenToFractional 0.1 2 6
+-- [0.1,2.0,3.9,5.799999999999999]
+-- > S.toList $ S.enumerateFromThenToFractional 0.1 (-2) (-6)
+-- [0.1,-2.0,-4.1000000000000005,-6.200000000000001]
+-- @
+--
+--
+-- @since 0.6.0
+{-# INLINE enumerateFromThenToFractional #-}
+enumerateFromThenToFractional
+ :: (IsStream t, Monad m, Fractional a, Ord a)
+ => a -> a -> a -> t m a
+enumerateFromThenToFractional from next to =
+ fromStreamD $ D.enumerateFromThenToFractional from next to
+
+-------------------------------------------------------------------------------
+-- Enumeration of Enum types not larger than Int
+-------------------------------------------------------------------------------
+--
+-- | 'enumerateFromTo' for 'Enum' types not larger than 'Int'.
+--
+-- @since 0.6.0
+{-# INLINE enumerateFromToSmall #-}
+enumerateFromToSmall :: (IsStream t, Monad m, Enum a) => a -> a -> t m a
+enumerateFromToSmall from to = Serial.map toEnum $
+ enumerateFromToIntegral (fromEnum from) (fromEnum to)
+
+-- | 'enumerateFromThenTo' for 'Enum' types not larger than 'Int'.
+--
+-- @since 0.6.0
+{-# INLINE enumerateFromThenToSmall #-}
+enumerateFromThenToSmall :: (IsStream t, Monad m, Enum a)
+ => a -> a -> a -> t m a
+enumerateFromThenToSmall from next to = Serial.map toEnum $
+ enumerateFromThenToIntegral (fromEnum from) (fromEnum next) (fromEnum to)
+
+-- | 'enumerateFromThen' for 'Enum' types not larger than 'Int'.
+--
+-- Note: We convert the 'Enum' to 'Int' and enumerate the 'Int'. If a
+-- type is bounded but does not have a 'Bounded' instance then we can go on
+-- enumerating it beyond the legal values of the type, resulting in the failure
+-- of 'toEnum' when converting back to 'Enum'. Therefore we require a 'Bounded'
+-- instance for this function to be safely used.
+--
+-- @since 0.6.0
+{-# INLINE enumerateFromThenSmallBounded #-}
+enumerateFromThenSmallBounded :: (IsStream t, Monad m, Enumerable a, Bounded a)
+ => a -> a -> t m a
+enumerateFromThenSmallBounded from next =
+ case fromEnum next >= fromEnum from of
+ True -> enumerateFromThenTo from next maxBound
+ False -> enumerateFromThenTo from next minBound
+
+-------------------------------------------------------------------------------
+-- Enumerable type class
+-------------------------------------------------------------------------------
+--
+-- NOTE: We would like to rewrite calls to fromList [1..] etc. to stream
+-- enumerations like this:
+--
+-- {-# RULES "fromList enumFrom" [1]
+-- forall (a :: Int). D.fromList (enumFrom a) = D.enumerateFromIntegral a #-}
+--
+-- But this does not work because enumFrom is a class method and GHC rewrites
+-- it quickly, so we do not get a chance to have our rule fired.
+
+-- | Types that can be enumerated as a stream. The operations in this type
+-- class are equivalent to those in the 'Enum' type class, except that these
+-- generate a stream instead of a list. Use the functions in
+-- "Streamly.Enumeration" module to define new instances.
+--
+-- @since 0.6.0
+class Enum a => Enumerable a where
+ -- | @enumerateFrom from@ generates a stream starting with the element
+ -- @from@, enumerating up to 'maxBound' when the type is 'Bounded' or
+ -- generating an infinite stream when the type is not 'Bounded'.
+ --
+ -- @
+ -- > S.toList $ S.take 4 $ S.enumerateFrom (0 :: Int)
+ -- [0,1,2,3]
+ -- @
+ --
+ -- For 'Fractional' types, enumeration is numerically stable. However, no
+ -- overflow or underflow checks are performed.
+ --
+ -- @
+ -- > S.toList $ S.take 4 $ S.enumerateFrom 1.1
+ -- [1.1,2.1,3.1,4.1]
+ -- @
+ --
+ -- @since 0.6.0
+ enumerateFrom :: (IsStream t, Monad m) => a -> t m a
+
+ -- | Generate a finite stream starting with the element @from@, enumerating
+ -- the type up to the value @to@. If @to@ is smaller than @from@ then an
+ -- empty stream is returned.
+ --
+ -- @
+ -- > S.toList $ S.enumerateFromTo 0 4
+ -- [0,1,2,3,4]
+ -- @
+ --
+ -- For 'Fractional' types, the last element is equal to the specified @to@
+ -- value after rounding to the nearest integral value.
+ --
+ -- @
+ -- > S.toList $ S.enumerateFromTo 1.1 4
+ -- [1.1,2.1,3.1,4.1]
+ -- > S.toList $ S.enumerateFromTo 1.1 4.6
+ -- [1.1,2.1,3.1,4.1,5.1]
+ -- @
+ --
+ -- @since 0.6.0
+ enumerateFromTo :: (IsStream t, Monad m) => a -> a -> t m a
+
+ -- | @enumerateFromThen from then@ generates a stream whose first element
+ -- is @from@, the second element is @then@ and the successive elements are
+ -- in increments of @then - from@. Enumeration can occur downwards or
+ -- upwards depending on whether @then@ comes before or after @from@. For
+ -- 'Bounded' types the stream ends when 'maxBound' is reached, for
+ -- unbounded types it keeps enumerating infinitely.
+ --
+ -- @
+ -- > S.toList $ S.take 4 $ S.enumerateFromThen 0 2
+ -- [0,2,4,6]
+ -- > S.toList $ S.take 4 $ S.enumerateFromThen 0 (-2)
+ -- [0,-2,-4,-6]
+ -- @
+ --
+ -- @since 0.6.0
+ enumerateFromThen :: (IsStream t, Monad m) => a -> a -> t m a
+
+ -- | @enumerateFromThenTo from then to@ generates a finite stream whose
+ -- first element is @from@, the second element is @then@ and the successive
+ -- elements are in increments of @then - from@ up to @to@. Enumeration can
+ -- occur downwards or upwards depending on whether @then@ comes before or
+ -- after @from@.
+ --
+ -- @
+ -- > S.toList $ S.enumerateFromThenTo 0 2 6
+ -- [0,2,4,6]
+ -- > S.toList $ S.enumerateFromThenTo 0 (-2) (-6)
+ -- [0,-2,-4,-6]
+ -- @
+ --
+ -- @since 0.6.0
+ enumerateFromThenTo :: (IsStream t, Monad m) => a -> a -> a -> t m a
+
+-- MAYBE: Sometimes it is more convenient to know the count rather then the
+-- ending or starting element. For those cases we can define the folllowing
+-- APIs. All of these will work only for bounded types if we represent the
+-- count by Int.
+--
+-- enumerateN
+-- enumerateFromN
+-- enumerateToN
+-- enumerateFromStep
+-- enumerateFromStepN
+
+-------------------------------------------------------------------------------
+-- Convenient functions for bounded types
+-------------------------------------------------------------------------------
+--
+-- |
+-- > enumerate = enumerateFrom minBound
+--
+-- Enumerate a 'Bounded' type from its 'minBound' to 'maxBound'
+--
+-- @since 0.6.0
+{-# INLINE enumerate #-}
+enumerate :: (IsStream t, Monad m, Bounded a, Enumerable a) => t m a
+enumerate = enumerateFrom minBound
+
+-- |
+-- > enumerateTo = enumerateFromTo minBound
+--
+-- Enumerate a 'Bounded' type from its 'minBound' to specified value.
+--
+-- @since 0.6.0
+{-# INLINE enumerateTo #-}
+enumerateTo :: (IsStream t, Monad m, Bounded a, Enumerable a) => a -> t m a
+enumerateTo = enumerateFromTo minBound
+
+-- |
+-- > enumerateFromBounded = enumerateFromTo from maxBound
+--
+-- 'enumerateFrom' for 'Bounded' 'Enum' types.
+--
+-- @since 0.6.0
+{-# INLINE enumerateFromBounded #-}
+enumerateFromBounded :: (IsStream t, Monad m, Enumerable a, Bounded a)
+ => a -> t m a
+enumerateFromBounded from = enumerateFromTo from maxBound
+
+-------------------------------------------------------------------------------
+-- Enumerable Instances
+-------------------------------------------------------------------------------
+--
+-- For Enum types smaller than or equal to Int size.
+#define ENUMERABLE_BOUNDED_SMALL(SMALL_TYPE) \
+instance Enumerable SMALL_TYPE where { \
+ {-# INLINE enumerateFrom #-}; \
+ enumerateFrom = enumerateFromBounded; \
+ {-# INLINE enumerateFromThen #-}; \
+ enumerateFromThen = enumerateFromThenSmallBounded; \
+ {-# INLINE enumerateFromTo #-}; \
+ enumerateFromTo = enumerateFromToSmall; \
+ {-# INLINE enumerateFromThenTo #-}; \
+ enumerateFromThenTo = enumerateFromThenToSmall }
+
+
+ENUMERABLE_BOUNDED_SMALL(())
+ENUMERABLE_BOUNDED_SMALL(Bool)
+ENUMERABLE_BOUNDED_SMALL(Ordering)
+ENUMERABLE_BOUNDED_SMALL(Char)
+
+-- For bounded Integral Enum types, may be larger than Int.
+#define ENUMERABLE_BOUNDED_INTEGRAL(INTEGRAL_TYPE) \
+instance Enumerable INTEGRAL_TYPE where { \
+ {-# INLINE enumerateFrom #-}; \
+ enumerateFrom = enumerateFromIntegral; \
+ {-# INLINE enumerateFromThen #-}; \
+ enumerateFromThen = enumerateFromThenIntegral; \
+ {-# INLINE enumerateFromTo #-}; \
+ enumerateFromTo = enumerateFromToIntegral; \
+ {-# INLINE enumerateFromThenTo #-}; \
+ enumerateFromThenTo = enumerateFromThenToIntegral }
+
+ENUMERABLE_BOUNDED_INTEGRAL(Int)
+ENUMERABLE_BOUNDED_INTEGRAL(Int8)
+ENUMERABLE_BOUNDED_INTEGRAL(Int16)
+ENUMERABLE_BOUNDED_INTEGRAL(Int32)
+ENUMERABLE_BOUNDED_INTEGRAL(Int64)
+ENUMERABLE_BOUNDED_INTEGRAL(Word)
+ENUMERABLE_BOUNDED_INTEGRAL(Word8)
+ENUMERABLE_BOUNDED_INTEGRAL(Word16)
+ENUMERABLE_BOUNDED_INTEGRAL(Word32)
+ENUMERABLE_BOUNDED_INTEGRAL(Word64)
+
+-- For unbounded Integral Enum types.
+#define ENUMERABLE_UNBOUNDED_INTEGRAL(INTEGRAL_TYPE) \
+instance Enumerable INTEGRAL_TYPE where { \
+ {-# INLINE enumerateFrom #-}; \
+ enumerateFrom from = enumerateFromStepIntegral from 1; \
+ {-# INLINE enumerateFromThen #-}; \
+ enumerateFromThen from next = \
+ enumerateFromStepIntegral from (next - from); \
+ {-# INLINE enumerateFromTo #-}; \
+ enumerateFromTo = enumerateFromToIntegral; \
+ {-# INLINE enumerateFromThenTo #-}; \
+ enumerateFromThenTo = enumerateFromThenToIntegral }
+
+ENUMERABLE_UNBOUNDED_INTEGRAL(Integer)
+ENUMERABLE_UNBOUNDED_INTEGRAL(Natural)
+
+#define ENUMERABLE_FRACTIONAL(FRACTIONAL_TYPE,CONSTRAINT) \
+instance (CONSTRAINT) => Enumerable (FRACTIONAL_TYPE) where { \
+ {-# INLINE enumerateFrom #-}; \
+ enumerateFrom = enumerateFromFractional; \
+ {-# INLINE enumerateFromThen #-}; \
+ enumerateFromThen = enumerateFromThenFractional; \
+ {-# INLINE enumerateFromTo #-}; \
+ enumerateFromTo = enumerateFromToFractional; \
+ {-# INLINE enumerateFromThenTo #-}; \
+ enumerateFromThenTo = enumerateFromThenToFractional }
+
+ENUMERABLE_FRACTIONAL(Float,)
+ENUMERABLE_FRACTIONAL(Double,)
+ENUMERABLE_FRACTIONAL(Fixed a,HasResolution a)
+ENUMERABLE_FRACTIONAL(Ratio a,Integral a)
+
+#if __GLASGOW_HASKELL__ >= 800
+instance Enumerable a => Enumerable (Identity a) where
+ {-# INLINE enumerateFrom #-}
+ enumerateFrom (Identity from) = Serial.map Identity $
+ enumerateFrom from
+ {-# INLINE enumerateFromThen #-}
+ enumerateFromThen (Identity from) (Identity next) = Serial.map Identity $
+ enumerateFromThen from next
+ {-# INLINE enumerateFromTo #-}
+ enumerateFromTo (Identity from) (Identity to) = Serial.map Identity $
+ enumerateFromTo from to
+ {-# INLINE enumerateFromThenTo #-}
+ enumerateFromThenTo (Identity from) (Identity next) (Identity to) =
+ Serial.map Identity $ enumerateFromThenTo from next to
+#endif
+
+-- TODO
+{-
+instance Enumerable a => Enumerable (Last a)
+instance Enumerable a => Enumerable (First a)
+instance Enumerable a => Enumerable (Max a)
+instance Enumerable a => Enumerable (Min a)
+instance Enumerable a => Enumerable (Const a b)
+instance Enumerable (f a) => Enumerable (Alt f a)
+instance Enumerable (f a) => Enumerable (Ap f a)
+-}
diff --git a/src/Streamly/Internal.hs b/src/Streamly/Internal.hs
index 6f05dfd..9283bee 100644
--- a/src/Streamly/Internal.hs
+++ b/src/Streamly/Internal.hs
@@ -16,4 +16,4 @@ module Streamly.Internal
)
where
-import Streamly.Streams.SVar
+import Streamly.Streams.Combinators (inspectMode)
diff --git a/src/Streamly/List.hs b/src/Streamly/List.hs
new file mode 100644
index 0000000..210fa2c
--- /dev/null
+++ b/src/Streamly/List.hs
@@ -0,0 +1,188 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-} -- XXX
+{-# LANGUAGE ViewPatterns #-}
+
+-- |
+-- Module : Streamly.List
+-- Copyright : (c) 2018 Composewell Technologies
+--
+-- License : BSD3
+-- Maintainer : harendra.kumar@gmail.com
+-- Stability : experimental
+-- Portability : GHC
+--
+-- Lists are just a special case of monadic streams. The stream type @SerialT
+-- Identity a@ can be used as a replacement for @[a]@. The 'List' type in this
+-- module is just a newtype wrapper around @SerialT Identity@ for better type
+-- inference when using the 'OverloadedLists' GHC extension. @List a@ provides
+-- better performance compared to @[a]@. Standard list, string and list
+-- comprehension syntax can be used with the 'List' type by enabling
+-- 'OverloadedLists', 'OverloadedStrings' and 'MonadComprehensions' GHC
+-- extensions. There would be a slight difference in the 'Show' and 'Read'
+-- strings of streamly list as compared to regular lists.
+--
+-- Conversion to stream types is free, any stream combinator can be used on
+-- lists by converting them to streams. However, for convenience, this module
+-- provides combinators that work directly on the 'List' type.
+--
+--
+-- @
+-- List $ S.map (+ 1) $ toSerial (1 \`Cons\` Nil)
+-- @
+--
+-- To convert a 'List' to regular lists, you can use any of the following:
+--
+-- * @toList . toSerial@ and @toSerial . fromList@
+-- * 'Data.Foldable.toList' from "Data.Foldable"
+-- * 'GHC.Exts.toList' and 'GHC.Exts.fromList' from 'IsList' in "GHC.Exts"
+--
+-- If you have made use of 'Nil' and 'Cons' constructors in the code and you
+-- want to replace streamly lists with standard lists, all you need to do is
+-- import these definitions:
+--
+-- @
+-- type List = []
+-- pattern Nil <- [] where Nil = []
+-- pattern Cons x xs = x : xs
+-- infixr 5 `Cons`
+-- {-\# COMPLETE Cons, Nil #-}
+-- @
+--
+-- See <src/docs/streamly-vs-lists.md> for more details and
+-- <src/test/PureStreams.hs> for comprehensive usage examples.
+--
+module Streamly.List
+ (
+#if __GLASGOW_HASKELL__ >= 800
+ List (.., Nil, Cons)
+#else
+ List (..)
+ , pattern Nil
+ , pattern Cons
+#endif
+ -- XXX we may want to use rebindable syntax for variants instead of using
+ -- different types (applicative do and apWith).
+ , ZipList (..)
+ , fromZipList
+ , toZipList
+ )
+where
+
+import Control.Arrow (second)
+import Control.DeepSeq (NFData(..), NFData1(..))
+import Data.Functor.Identity (Identity, runIdentity)
+import Data.Semigroup (Semigroup(..))
+import GHC.Exts (IsList(..), IsString(..))
+
+import Streamly.Streams.Serial (SerialT)
+import Streamly.Streams.Zip (ZipSerialM)
+
+import qualified Streamly.Streams.Prelude as P
+import qualified Streamly.Streams.StreamK as K
+
+-- We implement list as a newtype instead of a type synonym to make type
+-- inference easier when using -XOverloadedLists and -XOverloadedStrings. When
+-- using a stream type the programmer needs to specify the Monad otherwise the
+-- type remains ambiguous.
+--
+-- XXX once we separate consM from IsStream or remove the MonadIO and
+-- MonadBaseControlIO dependency from it, then we can make this an instance of
+-- IsStream and use the regular polymorphic functions on Lists as well. Once
+-- that happens we can change the Show and Read instances as well to use "1 >:
+-- 2 >: nil" etc. or should we use a separate constructor indicating the "List"
+-- type ":>" for better inference?
+--
+-- | @List a@ is a replacement for @[a]@.
+--
+-- @since 0.6.0
+newtype List a = List { toSerial :: SerialT Identity a }
+ deriving (Show, Read, Eq, Ord, NFData, NFData1
+ , Semigroup, Monoid, Functor, Foldable
+ , Applicative, Traversable, Monad)
+
+instance (a ~ Char) => IsString (List a) where
+ {-# INLINE fromString #-}
+ fromString = List . P.fromList
+
+-- GHC versions 8.0 and below cannot derive IsList
+instance IsList (List a) where
+ type (Item (List a)) = a
+ {-# INLINE fromList #-}
+ fromList = List . P.fromList
+ {-# INLINE toList #-}
+ toList = runIdentity . P.toList . toSerial
+
+------------------------------------------------------------------------------
+-- Patterns
+------------------------------------------------------------------------------
+
+-- Note: When using the OverloadedLists extension we should be able to pattern
+-- match using the regular list contructors. OverloadedLists uses 'toList' to
+-- perform the pattern match, it should not be too bad as it works lazily in
+-- the Identity monad. We need these patterns only when not using that
+-- extension.
+--
+-- | An empty list constructor and pattern that matches an empty 'List'.
+-- Corresponds to '[]' for Haskell lists.
+--
+-- @since 0.6.0
+pattern Nil :: List a
+pattern Nil <- (runIdentity . K.null . toSerial -> True) where
+ Nil = List K.nil
+
+infixr 5 `Cons`
+
+-- | A list constructor and pattern that deconstructs a 'List' into its head
+-- and tail. Corresponds to ':' for Haskell lists.
+--
+-- @since 0.6.0
+pattern Cons :: a -> List a -> List a
+pattern Cons x xs <-
+ (fmap (second List) . runIdentity . K.uncons . toSerial
+ -> Just (x, xs)) where
+ Cons x xs = List $ K.cons x (toSerial xs)
+
+#if __GLASGOW_HASKELL__ >= 802
+{-# COMPLETE Nil, Cons #-}
+#endif
+
+------------------------------------------------------------------------------
+-- ZipList
+------------------------------------------------------------------------------
+
+-- | Just like 'List' except that it has a zipping 'Applicative' instance
+-- and no 'Monad' instance.
+--
+-- @since 0.6.0
+newtype ZipList a = ZipList { toZipSerial :: ZipSerialM Identity a }
+ deriving (Show, Read, Eq, Ord, NFData, NFData1
+ , Semigroup, Monoid, Functor, Foldable
+ , Applicative, Traversable)
+
+instance (a ~ Char) => IsString (ZipList a) where
+ {-# INLINE fromString #-}
+ fromString = ZipList . P.fromList
+
+-- GHC versions 8.0 and below cannot derive IsList
+instance IsList (ZipList a) where
+ type (Item (ZipList a)) = a
+ {-# INLINE fromList #-}
+ fromList = ZipList . P.fromList
+ {-# INLINE toList #-}
+ toList = runIdentity . P.toList . toZipSerial
+
+-- | Convert a 'ZipList' to a regular 'List'
+--
+-- @since 0.6.0
+fromZipList :: ZipList a -> List a
+fromZipList = List . K.adapt . toZipSerial
+
+-- | Convert a regular 'List' to a 'ZipList'
+--
+-- @since 0.6.0
+toZipList :: List a -> ZipList a
+toZipList = ZipList . K.adapt . toSerial
diff --git a/src/Streamly/Prelude.hs b/src/Streamly/Prelude.hs
index 4ddc00d..9a655f6 100644
--- a/src/Streamly/Prelude.hs
+++ b/src/Streamly/Prelude.hs
@@ -1,15 +1,11 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE UndecidableInstances #-} -- XXX
#if __GLASGOW_HASKELL__ >= 800
{-# OPTIONS_GHC -Wno-orphans #-}
#endif
-#include "Streams/inline.h"
+#include "Streams/inline.hs"
-- |
-- Module : Streamly.Prelude
@@ -32,6 +28,10 @@
-- provided for convenience and for consistency with other pure APIs in the
-- @base@ package.
--
+-- In many cases, short definitions of the combinators are provided in the
+-- documentation for illustration. The actual implementation may differ for
+-- performance reasons.
+--
-- Functions having a 'MonadAsync' constraint work concurrently when used with
-- appropriate stream type combinator. Please be careful to not use 'parallely'
-- with infinite streams.
@@ -45,70 +45,116 @@
module Streamly.Prelude
(
-- * Construction
- -- | All other stream construction and generation combinators described
- -- later, and even more custom combinators can be expressed in terms of
- -- these primitives. However, the special versions provided in this module
- -- can be more efficient in some situations.
-
- -- ** From Elements
+ -- ** Primitives
-- | Primitives to construct a stream from pure values or monadic actions.
+ -- All other stream construction and generation combinators described later
+ -- can be expressed in terms of these primitives. However, the special
+ -- versions provided in this module can be much more efficient in most
+ -- cases. Users can create custom combinators using these primitives.
+
K.nil
, K.cons
, (K..:)
+
, consM
, (|:)
+
+ -- ** From Values
+ -- | Generate a monadic stream from a seed value or values.
, yield
, yieldM
+ , K.repeat
+ , repeatM
+ , replicate
+ , replicateM
- -- ** From Streams
- -- | You can construct streams by appending or merging existing streams.
- -- When constructing streams from streams, '<>' and 'mempty' are the
- -- intuitive equivalents of 'K.cons' and 'K.nil', respectively. These
- -- primitives can be very useful when constructing your own custom stream
- -- combinators. Also see the variants of '<>' defined in the "Streamly"
- -- module. Note that appending streams is inexpensive, it is much more
- -- efficient than appending lists.
-
- -- * Generation
- -- ** Unfold and Iterate
- -- | Note that the generative steps of unfold and iterate are inherently
- -- serial as the next step depends on the result of the previous step.
- -- However, consumption of the result from the previous step can happen in
- -- parallel with the generation by the next step.
+ -- Note: Using enumeration functions e.g. 'Prelude.enumFromThen' turns out
+ -- to be slightly faster than the idioms like @[from, then..]@.
+ --
+ -- ** Enumeration
+ -- | We can use the 'Enum' type class to enumerate a type producing a list
+ -- and then convert it to a stream:
+ --
+ -- @
+ -- 'fromList' $ 'Prelude.enumFromThen' from then
+ -- @
+ --
+ -- However, this is not particularly efficient.
+ -- The 'Enumerable' type class provides corresponding functions that
+ -- generate a stream instead of a list, efficiently.
+
+ , Enumerable (..)
+ , enumerate
+ , enumerateTo
+
+ -- ** From Generators
+ -- | Generate a monadic stream from a seed value and a generator function.
, unfoldr
, unfoldrM
, iterate
, iterateM
+ , fromIndices
+ , fromIndicesM
- -- ** Replicate and Repeat
- -- | Generate a monadic stream from a seed value or function. Note that
- -- these functions can generate a stream fully concurrently as, unlike
- -- unfolds, there is no dependency between steps, therefore, an unbounded
- -- number of steps can run concurrently. All of these can be expressed in
- -- terms of 'K.cons' and 'K.nil' primitives.
- , replicateM
- , K.repeat
- , repeatM
-
- -- ** Generate From
+ -- ** From Containers
-- | Convert an input structure, container or source into a stream. All of
-- these can be expressed in terms of primitives.
- , fromList
+ , P.fromList
, fromListM
, K.fromFoldable
, fromFoldableM
- , fromHandle
- -- * Deconstruction
- , uncons
+ -- ** From External Containers
+ , fromHandle
-- * Elimination
+ -- ** Primitives
+ -- | It is easy to express all the folds in terms of the 'uncons' primitive,
+ -- however the specific implementations provided later are generally more
+ -- efficient. Folds are inherently serial as each step needs to use the
+ -- result of the previous step.
+ , uncons
+
-- ** General Folds
- -- | All the folds can be implemented in terms of 'uncons', however the
- -- specific implementations provided here are generally more efficient.
- -- Folds are inherently serial as each step needs to use the result of
- -- the previous step.
+-- | Right and left folds.
+-- As a simple rule, always use lazy right fold for construction and strict
+-- left fold for reduction. By construction we mean using a constructor as the
+-- outermost operation in the fold function, by reduction we mean using a
+-- function as the outermost operation in the fold function.
+--
+-- +-----------------------------------+--------------------------------------+
+-- | Right Fold | Left Fold |
+-- +===================================+======================================+
+-- | Construction consumes input | Construction consumes all input, |
+-- | lazily and streams it in FIFO | and constructs in reverse (LIFO) |
+-- | order | order |
+-- +-----------------------------------+--------------------------------------+
+-- | Reduction ends up buffering all | Strict reduction works |
+-- | input before it can be reduced | incrementally, without buffering. |
+-- +-----------------------------------+--------------------------------------+
+--
+-- Almost always, we need lazy construction and strict reduction, therefore,
+-- strict @foldr@ and lazy @foldl@ are rarely useful. If needed, strict @foldr@
+-- and lazy @foldl@ can be expressed in terms of the available versions. For
+-- example, a lazy @foldl@ can be replaced by a strict @foldl@ to reverse the
+-- structure followed by a @foldr@.
+--
+-- The following equations may help understand the relation between the two
+-- folds for lists:
+--
+-- @
+-- foldr f z xs = foldl (flip f) z (reverse xs)
+-- foldl f z xs = foldr (flip f) z (reverse xs)
+-- @
+--
+-- More generally:
+--
+-- @
+-- foldl f z xs = foldr g id xs z where g x k = k . flip f x
+-- foldr f z xs = foldl g id xs z where g k x = k . f x
+-- @
+
, foldr
, foldr1
, foldrM
@@ -118,71 +164,100 @@ module Streamly.Prelude
, foldx
, foldxM
- -- ** Specialized Folds
- -- | These folds can be expressed in terms of the general fold routines but
- -- the special versions here can be more efficient in many cases.
+ -- ** Run Effects
+ , runStream
+ , runN
+ , runWhile
- -- Filtering folds: extract parts of the stream
+ -- ** To Elements
+ -- | Folds that extract selected elements of a stream or their properties.
+ , (!!)
, head
- , tail
, last
+ , findM
+ , find
+ , lookup
+ , findIndex
+ , elemIndex
+
+ -- ** To Parts
+ -- | Folds that extract selected parts of a stream.
+ , tail
, init
- -- Conditional folds: may terminate early based on a condition
+ -- ** To Boolean
+ -- | Folds that summarize the stream to a boolean value.
, null
, elem
- , elemIndex
, notElem
- , lookup
- , find
- , findIndex
, all
, any
, and
, or
- -- Full folds - need to go through all elements
+ -- ** To Summary
+ -- | Folds that summarize the stream to a single value.
, length
- , maximum
- , minimum
, sum
, product
- -- ** Fold To
+ -- ** To Summary (Maybe)
+ -- | Folds that summarize a non-empty stream to a 'Just' value and return
+ -- 'Nothing' for an empty stream.
+ , maximumBy
+ , maximum
+ , minimumBy
+ , minimum
+ , the
+
+ -- ** To Containers
-- | Convert or divert a stream into an output structure, container or
-- sink.
, toList
, toHandle
-- * Transformation
- -- | One to one transformations, each element in the input stream is
- -- transformed into a corresponding element in the output stream.
- -- Therefore, the length of the stream and the ordering of elements in the
- -- stream remains unchanged after the transformation.
-- ** Scanning
- -- | Scan is a transformation by continuously folding the result with the
- -- next element of the stream. This is the generalized way to transform a
- -- stream carrying state from previous transformation steps, other forms of
- -- transformation like map can be expressed in terms of this.
+ -- | Scans stream all the intermediate reduction steps of the corresponding
+ -- folds. The following equations hold for lists:
+ --
+ -- > scanl f z xs == map (foldl f z) $ inits xs
+ -- > scanr f z xs == map (foldr f z) $ tails
+ --
+ -- We do not provide a right associative scan, it can be recovered from a
+ -- 'scanl'' as follows:
+ --
+ -- > scanr f z xs == reverse $ scanl' (flip f) z (reverse xs)
+ --
+ -- Scan is like a stateful map. If we discard the state, we get the map:
+ --
+ -- > S.drop 1 $ S.scanl' (\_ x -> f x) z xs == map f xs
+
+ -- > S.postscanl' (\_ x -> f x) z xs == map f xs
+
, scanl'
, scanlM'
+ -- , postscanl'
+ -- , postscanlM'
+ -- , prescanl'
+ -- , prescanlM'
+ , scanl1'
+ , scanl1M'
, scanx
-- ** Mapping
- -- | Map is a special form of scan where no state is carried from one step
- -- to the next.
+ -- | Map is a strictly one-to-one transformation of stream elements. It
+ -- cannot add or remove elements from the stream, just transforms them.
, Serial.map
- , mapM
-- ** Flattening
, sequence
-
- -- * Filtering and Insertion
- -- | Adding or removing elements from the stream thus changing the length
- -- of the stream.
+ , mapM
-- ** Filtering
+ -- | Filtering may remove some elements from the stream.
+
, filter
, filterM
, take
@@ -191,11 +266,16 @@ module Streamly.Prelude
, drop
, dropWhile
, dropWhileM
+ , deleteBy
+ , uniq
- -- ** Inserting
+ -- ** Insertion
+ -- | Insertion adds more elements to the stream.
+
+ , insertBy
, intersperseM
- -- * Reordering
+ -- ** Reordering
, reverse
-- * Hybrid Operations
@@ -210,12 +290,52 @@ module Streamly.Prelude
, findIndices
, elemIndices
- -- * Zipping
+ -- * Multi-Stream Operations
+ -- | New streams can be constructed by appending, merging or zipping
+ -- existing streams.
+
+ -- ** Appending
+ -- | Streams form a 'Semigroup' and a 'Monoid' under the append
+ -- operation.
+ --
+ -- @
+ -- >> S.toList $ S.fromList [1,2] \<> S.fromList [3,4]
+ -- [1,2,3,4]
+ -- >> S.toList $ fold $ [S.fromList [1,2], S.fromList [3,4]]
+ -- [1,2,3,4]
+ -- @
+
+ -- ** Merging
+ -- | Streams form a commutative semigroup under the merge
+ -- operation.
+
+ -- , merge
+ , mergeBy
+ , mergeByM
+ , mergeAsyncBy
+ , mergeAsyncByM
+
+ -- ** Zipping
, zipWith
, zipWithM
, Z.zipAsyncWith
, Z.zipAsyncWithM
+ -- Special zips
+ , indexed
+ , indexedR
+
+ -- ** Flattening
+ , concatMapM
+ , concatMap
+
+ -- ** Folds
+ , eqBy
+ , cmpBy
+ , isPrefixOf
+ , isSubsequenceOf
+ , stripPrefix
+
-- * Deprecated
, K.once
, each
@@ -231,15 +351,22 @@ import Prelude
hiding (filter, drop, dropWhile, take, takeWhile, zipWith, foldr,
foldl, mapM, mapM_, sequence, all, any, sum, product, elem,
notElem, maximum, minimum, head, last, tail, length, null,
- reverse, iterate, init, and, or, lookup, foldr1)
+ reverse, iterate, init, and, or, lookup, foldr1, (!!),
+ scanl, scanl1, replicate, concatMap)
+
import qualified Prelude
import qualified System.IO as IO
-import Streamly.SVar (MonadAsync, defState, rstState)
-import Streamly.Streams.SVar (maxYields)
+import Streamly.Enumeration (Enumerable(..), enumerate, enumerateTo)
+import Streamly.SVar (MonadAsync, defState)
+import Streamly.Streams.Async (mkAsync')
+import Streamly.Streams.Combinators (maxYields)
+import Streamly.Streams.Prelude (fromStreamS, toStreamS)
+import Streamly.Streams.StreamD (fromStreamD, toStreamD)
import Streamly.Streams.StreamK (IsStream(..))
import Streamly.Streams.Serial (SerialT)
+import qualified Streamly.Streams.Prelude as P
import qualified Streamly.Streams.StreamK as K
import qualified Streamly.Streams.StreamD as D
import qualified Streamly.Streams.Zip as Z
@@ -254,27 +381,6 @@ import qualified Streamly.Streams.StreamD as S
import qualified Streamly.Streams.Serial as Serial
------------------------------------------------------------------------------
--- Conversion to and from direct style stream
-------------------------------------------------------------------------------
-
--- These definitions are dependent on what is imported as S
-{-# INLINE fromStreamS #-}
-fromStreamS :: (IsStream t, Monad m) => S.Stream m a -> t m a
-fromStreamS = fromStream . S.toStreamK
-
-{-# INLINE toStreamS #-}
-toStreamS :: (IsStream t, Monad m) => t m a -> S.Stream m a
-toStreamS = S.fromStreamK . toStream
-
-{-# INLINE fromStreamD #-}
-fromStreamD :: (IsStream t, Monad m) => D.Stream m a -> t m a
-fromStreamD = fromStream . D.toStreamK
-
-{-# INLINE toStreamD #-}
-toStreamD :: (IsStream t, Monad m) => t m a -> D.Stream m a
-toStreamD = D.fromStreamK . toStream
-
-------------------------------------------------------------------------------
-- Deconstruction
------------------------------------------------------------------------------
@@ -283,6 +389,7 @@ toStreamD = D.fromStreamK . toStream
-- the head of the stream and @ma@ its tail.
--
-- @since 0.1.0
+{-# INLINE uncons #-}
uncons :: (IsStream t, Monad m) => SerialT m a -> m (Maybe (a, t m a))
uncons m = K.uncons (K.adapt m)
@@ -290,10 +397,18 @@ uncons m = K.uncons (K.adapt m)
-- Generation by Unfolding
------------------------------------------------------------------------------
--- | Build a stream by unfolding a /pure/ step function starting from a seed.
--- The step function returns the next element in the stream and the next seed
--- value. When it is done it returns 'Nothing' and the stream ends. For
--- example,
+-- |
+-- @
+-- unfoldr step s =
+-- case step s of
+-- Nothing -> 'K.nil'
+-- Just (a, b) -> a \`cons` unfoldr step b
+-- @
+--
+-- Build a stream by unfolding a /pure/ step function @step@ starting from a
+-- seed @s@. The step function returns the next element in the stream and the
+-- next seed value. When it is done it returns 'Nothing' and the stream ends.
+-- For example,
--
-- @
-- let f b =
@@ -306,15 +421,6 @@ uncons m = K.uncons (K.adapt m)
-- [0,1,2,3]
-- @
--
--- unfoldr can be expressed in terms of 'yield' and '<>' as follows:
---
--- @
--- unfoldr step s =
--- case step s of
--- Nothing -> mempty
--- Just (a, b) -> 'yield' a '<>' (unfoldr step b)
--- @
---
-- @since 0.1.0
{-# INLINE_EARLY unfoldr #-}
unfoldr :: (Monad m, IsStream t) => (b -> Maybe (a, b)) -> b -> t m a
@@ -368,20 +474,36 @@ unfoldrMSerial step seed = fromStreamS (S.unfoldrM step seed)
-- Faster than yieldM because there is no bind.
--
--- | Create a singleton stream from a pure value. Same as @a `cons` nil@ but
--- slighly more efficient. Note that in monadic streams, 'yield' is the same
--- as 'pure' or 'return', however, in Zip applicative streams it is not the
--- same as 'pure' because in that case 'pure' is equivalent to 'repeat'
--- instead. In all other stream types, 'yield' is the same as @yieldM . pure@
--- but more efficient.
+-- |
+-- @
+-- yield a = a \`cons` nil
+-- @
+--
+-- Create a singleton stream from a pure value.
+--
+-- The following holds in monadic streams, but not in Zip streams:
+--
+-- @
+-- yield = pure
+-- yield = yieldM . pure
+-- @
+--
+-- In Zip applicative streams 'yield' is not the same as 'pure' because in that
+-- case 'pure' is equivalent to 'repeat' instead. 'yield' and 'pure' are
+-- equally efficient, in other cases 'yield' may be slightly more efficient
+-- than the other equivalent definitions.
--
-- @since 0.4.0
{-# INLINE yield #-}
yield :: IsStream t => a -> t m a
yield = K.yield
--- | Create a singleton stream from a monadic action. Same as @m \`consM` nil@
--- but more efficient.
+-- |
+-- @
+-- yieldM m = m \`consM` nil
+-- @
+--
+-- Create a singleton stream from a monadic action.
--
-- @
-- > toList $ yieldM getLine
@@ -394,9 +516,45 @@ yield = K.yield
yieldM :: (Monad m, IsStream t) => m a -> t m a
yieldM = K.yieldM
--- | Generate a stream by performing a monadic action @n@ times. Can be
--- expressed as @stimes n (yieldM m)@.
+-- |
+-- @
+-- fromIndices f = let g i = f i \`cons` g (i + 1) in g 0
+-- @
--
+-- Generate an infinite stream, whose values are the output of a function @f@
+-- applied on the corresponding index. Index starts at 0.
+--
+-- @
+-- > S.toList $ S.take 5 $ S.fromIndices id
+-- [0,1,2,3,4]
+-- @
+--
+-- @since 0.6.0
+{-# INLINE fromIndices #-}
+fromIndices :: (IsStream t, Monad m) => (Int -> a) -> t m a
+fromIndices = fromStreamD . D.fromIndices
+
+-- XXX this needs to be concurrent
+--
+-- |
+-- @
+-- fromIndicesM f = let g i = f i \`consM` g (i + 1) in g 0
+-- @
+--
+-- Generate an infinite stream, whose values are the output of a monadic
+-- function @f@ applied on the corresponding index. Index starts at 0.
+--
+-- @since 0.6.0
+{-# INLINE fromIndicesM #-}
+fromIndicesM :: (IsStream t, Monad m) => (Int -> m a) -> t m a
+fromIndicesM = fromStreamD . D.fromIndicesM
+
+-- |
+-- @
+-- replicateM = take n . repeatM
+-- @
+--
+-- Generate a stream by performing a monadic action @n@ times. Same as:
--
-- @
-- runStream $ serially $ S.replicateM 10 $ (threadDelay 1000000 >> print 1)
@@ -406,13 +564,33 @@ yieldM = K.yieldM
-- /Concurrent/
--
-- @since 0.1.1
+{-# INLINE_EARLY replicateM #-}
replicateM :: (IsStream t, MonadAsync m) => Int -> m a -> t m a
-replicateM n m = go n
- where
- go cnt = if cnt <= 0 then K.nil else m |: go (cnt - 1)
+replicateM = K.replicateM
+
+{-# RULES "replicateM serial" replicateM = replicateMSerial #-}
+{-# INLINE replicateMSerial #-}
+replicateMSerial :: MonadAsync m => Int -> m a -> SerialT m a
+replicateMSerial n = fromStreamS . S.replicateM n
--- | Generate a stream by repeatedly executing a monadic action forever. Can be
--- expressed as @cycle1 . yieldM@.
+-- |
+-- @
+-- replicate = take n . repeat
+-- @
+--
+-- Generate a stream of length @n@ by repeating a value @n@ times.
+--
+-- @since 0.6.0
+replicate :: (IsStream t, Monad m) => Int -> a -> t m a
+replicate n = fromStreamS . S.replicate n
+
+-- |
+-- @
+-- repeatM = fix . consM
+-- repeatM = cycle1 . yieldM
+-- @
+--
+-- Generate a stream by repeatedly executing a monadic action forever.
--
-- @
-- runStream $ serially $ S.take 10 $ S.repeatM $ (threadDelay 1000000 >> print 1)
@@ -426,7 +604,19 @@ repeatM :: (IsStream t, MonadAsync m) => m a -> t m a
repeatM = go
where go m = m |: go m
--- | Iterate a pure function from a seed value, streaming the results forever.
+-- |
+-- @
+-- iterate f x = x \`cons` iterate f x
+-- @
+--
+-- Generate an infinite stream with @x@ as the first element and each
+-- successive element derived by applying the function @f@ on the previous
+-- element.
+--
+-- @
+-- > S.toList $ S.take 5 $ S.iterate (+1) 1
+-- [1,2,3,4,5]
+-- @
--
-- @since 0.1.2
iterate :: IsStream t => (a -> a) -> a -> t m a
@@ -434,8 +624,14 @@ iterate step = fromStream . go
where
go s = K.cons s (go (step s))
--- | Iterate a monadic function from a seed value, streaming the results
--- forever.
+-- |
+-- @
+-- iterateM f m = m \`consM` iterateM f m
+-- @
+--
+-- Generate an infinite stream with the first element generated by the action
+-- @m@ and each successive element derived by applying the monadic function
+-- @f@ on the previous element.
--
-- When run concurrently, the next iteration can run concurrently with the
-- processing of the previous iteration. Note that more than one iteration
@@ -456,28 +652,21 @@ iterate step = fromStream . go
iterateM :: (IsStream t, MonadAsync m) => (a -> m a) -> a -> t m a
iterateM step = go
where
- go s = fromStream $ K.Stream $ \svr stp sng yld -> do
+ go s = K.mkStream $ \st stp sng yld -> do
next <- step s
- K.unStream (toStream (return s |: go next)) svr stp sng yld
+ K.foldStreamShared st stp sng yld (return s |: go next)
------------------------------------------------------------------------------
-- Conversions
------------------------------------------------------------------------------
--- | Construct a stream from a list containing pure values. More efficient list
--- specific implementation of 'K.fromFoldable' as it works well with fusion
--- optimization.
+-- |
+-- @
+-- fromListM = 'Prelude.foldr' 'K.consM' 'K.nil'
+-- @
--
--- @since 0.4.0
-{-# INLINE_EARLY fromList #-}
-fromList :: (Monad m, IsStream t) => [a] -> t m a
-fromList = fromStreamS . S.fromList
-{-# RULES "fromList fallback to StreamK" [1]
- forall a. S.toStreamK (S.fromList a) = K.fromFoldable a #-}
-
--- | Construct a stream from a list containing monadic actions. More efficient
--- list specific implementation of 'fromFoldableM' especially for serial
--- streams as it works well with fusion optimization.
+-- Construct a stream from a list of monadic actions. This is more efficient
+-- than 'fromFoldableM' for serial streams.
--
-- @since 0.4.0
{-# INLINE_EARLY fromListM #-}
@@ -486,12 +675,16 @@ fromListM = fromStreamD . D.fromListM
{-# RULES "fromListM fallback to StreamK" [1]
forall a. D.toStreamK (D.fromListM a) = fromFoldableM a #-}
--- | Construct a stream from a 'Foldable' containing monadic actions. Same as
--- @'Prelude.foldr' 'consM' 'K.nil'@.
+-- |
+-- @
+-- fromFoldableM = 'Prelude.foldr' 'consM' 'K.nil'
+-- @
+--
+-- Construct a stream from a 'Foldable' containing monadic actions.
--
-- @
--- runStream $ serially $ S.fromFoldableM $ replicate 10 (threadDelay 1000000 >> print 1)
--- runStream $ asyncly $ S.fromFoldableM $ replicate 10 (threadDelay 1000000 >> print 1)
+-- runStream $ serially $ S.fromFoldableM $ replicateM 10 (threadDelay 1000000 >> print 1)
+-- runStream $ asyncly $ S.fromFoldableM $ replicateM 10 (threadDelay 1000000 >> print 1)
-- @
--
-- /Concurrent (do not use with 'parallely' on infinite containers)/
@@ -513,9 +706,9 @@ each = K.fromFoldable
--
-- @since 0.1.0
fromHandle :: (IsStream t, MonadIO m) => IO.Handle -> t m String
-fromHandle h = fromStream go
+fromHandle h = go
where
- go = K.Stream $ \_ stp _ yld -> do
+ go = K.mkStream $ \_ yld _ stp -> do
eof <- liftIO $ IO.hIsEOF h
if eof
then stp
@@ -531,36 +724,101 @@ fromHandle h = fromStream go
-- stream into a list:
--
-- @
--- >> runIdentity $ foldrM (\\x xs -> return (x : xs)) [] (serially $ fromFoldable [1,2,3])
+-- >> S.foldrM (\\x xs -> return (x : xs)) [] $ fromList [1,2,3]
-- [1,2,3]
-- @
--
-- @since 0.2.0
{-# INLINE foldrM #-}
foldrM :: Monad m => (a -> b -> m b) -> b -> SerialT m a -> m b
-foldrM step acc m = S.foldrM step acc $ toStreamS m
+foldrM = P.foldrM
--- | Lazy right associative fold. For example, to fold a stream into a list:
+-- | Lazy right associative fold.
+--
+-- For lists a @foldr@ looks like:
--
-- @
--- >> runIdentity $ foldr (:) [] (serially $ fromFoldable [1,2,3])
--- [1,2,3]
+-- foldr f z [] = z
+-- foldr f z (x:xs) = x \`f` foldr f z xs
-- @
--
+-- The recursive expression is the second argument of the fold step `f`.
+-- Therefore, the evaluation of the recursive call depends on `f`. It can
+-- terminate recursion by not inspecting the second argument based on a
+-- condition. When expanded fully, it results in the following right associated
+-- expression:
+--
+-- @
+-- foldr f z xs == x1 \`f` (x2 \`f` ...(xn \`f` z))
+-- @
+--
+-- When `f` is a constructor, we can see that the first deconstruction of this
+-- expression would be @x1@ on the left and the recursive expression on the
+-- right. Therefore, we can deconstruct it to access the input elements in the
+-- first-in-first-out (FIFO) order and consume the reconstructed structure
+-- lazily. The recursive expression on the right gets evaluated incrementall
+-- as demanded by the consumer. For example:
+--
+-- @
+-- > S.foldr (:) [] $ S.fromList [1,2,3,4]
+-- [1,2,3,4]
+-- @
+--
+-- When `f` is a function strict in its second argument, the right side of the
+-- expression gets evaluated as follows:
+--
+-- @
+-- foldr f z xs == x1 \`f` tail1
+-- tail1 == x2 \`f` tail2
+-- tail2 == x3 \`f` tail3
+-- ...
+-- tailn == xn \`f` z
+-- @
+--
+-- In @foldl'@ we have both the arguments of `f` available at each step,
+-- therefore, each step can be reduced immediately. However, in @foldr@ the
+-- second argument to `f` is a recursive call, therefore, it ends up building
+-- the whole expression in memory before it can be reduced, consuming the whole
+-- input. This makes @foldr@ much less efficient for reduction compared to
+-- @foldl'@. For example:
+--
+-- @
+-- > S.foldr (+) 0 $ S.fromList [1,2,3,4]
+-- 10
+-- @
+--
+-- When the underlying monad @m@ is strict (e.g. IO), then @foldr@ ends up
+-- evaluating all of its input because of strict evaluation of the recursive
+-- call:
+--
+-- >> S.foldr (\_ _ -> []) [] $ S.fromList (1:undefined)
+-- >*** Exception: Prelude.undefined
+--
+-- In a lazy monad, we can consume the input lazily, and terminate the fold
+-- by conditionally not inspecting the recursive expression.
+--
+-- >> runIdentity $ S.foldr (\x rest -> if x == 3 then [] else x : rest) [] $ S.fromList (4:1:3:undefined)
+-- >[4,1]
+--
+-- The arguments to the folding function (@a -> b -> b@) are in the head and
+-- tail order of the output, @a@ is the head and @b@ is the tail. Remember, in
+-- a right fold the zero is on the right, it is the tail end.
+--
-- @since 0.1.0
{-# INLINE foldr #-}
foldr :: Monad m => (a -> b -> b) -> b -> SerialT m a -> m b
--- XXX somehow this definition does not perform well, need to investigate
--- foldr step acc m = S.foldr step acc $ S.fromStreamK (toStream m)
-foldr f = foldrM (\a b -> return (f a b))
+foldr = P.foldr
--- | Right fold, for non-empty streams, using first element as the starting
+-- XXX This seems to be of limited use as it cannot be used to construct
+-- recursive structures and for reduction foldl1' is better.
+--
+-- | Lazy right fold for non-empty streams, using first element as the starting
-- value. Returns 'Nothing' if the stream is empty.
--
-- @since 0.5.0
{-# INLINE foldr1 #-}
foldr1 :: Monad m => (a -> a -> a) -> SerialT m a -> m (Maybe a)
-foldr1 = K.foldr1
+foldr1 f m = S.foldr1 f (toStreamS m)
-- | Strict left fold with an extraction function. Like the standard strict
-- left fold, but applies a user supplied extraction function (the third
@@ -580,15 +838,86 @@ foldl = foldx
-- | Strict left associative fold.
--
+-- For lists a @foldl@ looks like:
+--
+-- @
+-- foldl f z [] = z
+-- foldl f z (x:xs) = foldl f (z \`f` x) xs
+-- @
+--
+-- The recursive call at the head of the output expression is bound to be
+-- evaluated until recursion terminates,
+-- /deconstructing the whole input container/ and building the following left
+-- associated expression:
+--
+-- @
+-- foldl f z xs == (((z \`f` x1) \`f` x2) ...) \`f` xn
+-- @
+--
+-- When `f` is a constructor, we can see that the first deconstruction of this
+-- expression would be the recursive expression on the left and `xn` on the
+-- right. Therefore, it can access the input elements only in the reverse
+-- (LIFO) order. For example:
+--
+-- @
+-- > S.foldl' (flip (:)) [] $ S.fromList [1,2,3,4]
+-- [4,3,2,1]
+-- @
+--
+-- The strict left fold @foldl'@ forces the reduction of its argument @z \`f`
+-- x@ before using it, therefore it never builds the whole expression in
+-- memory. Thus, @z \`f` x1@ would get reduced to @z1@ and then @z1 \`f` x2@
+-- would get reduced to @z2@ and so on, incrementally reducing the expression
+-- as it recurses. However, it evaluates the accumulator only to WHNF, it may
+-- further help to use a strict data structure as accumulator. For example:
+--
+-- @
+-- > S.foldl' (+) 0 $ S.fromList [1,2,3,4]
+-- 10
+-- @
+--
+-- @
+-- 0 + 1
+-- (0 + 1) + 2
+-- ((0 + 1) + 2) + 3
+-- (((0 + 1) + 2) + 3) + 4
+-- @
+--
+-- @foldl@ strictly deconstructs the whole input container irrespective of
+-- whether it needs it or not:
+--
+-- >> S.foldl' (\acc x -> if x == 3 then acc else x : acc) [] $ S.fromList (4:1:3:undefined)
+-- >*** Exception: Prelude.undefined
+--
+-- However, evaluation of the items contained in the input container is lazy as
+-- demanded by the fold step function:
+--
+-- >> S.foldl' (\acc x -> if x == 3 then acc else x : acc) [] $ S.fromList [4,1,3,undefined]
+-- >[4,1]
+--
+-- To perform a left fold without consuming all the input one can use @scanl@
+-- to stream the intermediate results of the fold and use them lazily.
+--
+-- In stateful or event-driven programming, we can consider @z@ as the initial
+-- state and the stream being folded as a stream of events, thus @foldl'@
+-- processes all the events in the stream updating the state on each event and
+-- then ultimately returning the final state.
+--
+-- The arguments to the folding function (@b -> a -> b@) are in the head and
+-- tail order of the output expression, @b@ is the head and @a@ is the tail.
+-- Remember, in a left fold the zero is on the left, at the head of the
+-- expression.
+--
-- @since 0.2.0
{-# INLINE foldl' #-}
foldl' :: Monad m => (b -> a -> b) -> b -> SerialT m a -> m b
-foldl' step begin m = S.foldl' step begin $ toStreamS m
+foldl' = P.foldl'
-- | Strict left fold, for non-empty streams, using first element as the
-- starting value. Returns 'Nothing' if the stream is empty.
--
-- @since 0.5.0
+{-# INLINE foldl1' #-}
foldl1' :: Monad m => (a -> a -> a) -> SerialT m a -> m (Maybe a)
foldl1' step m = do
r <- uncons m
@@ -598,10 +927,10 @@ foldl1' step m = do
res <- foldl' step h t
return $ Just res
--- XXX replace the recursive "go" with explicit continuations.
-- | Like 'foldx', but with a monadic step function.
--
-- @since 0.2.0
+{-# INLINE foldxM #-}
foldxM :: Monad m => (x -> a -> m x) -> m x -> (x -> m b) -> SerialT m a -> m b
foldxM = K.foldxM
@@ -614,6 +943,7 @@ foldlM = foldxM
-- | Like 'foldl'' but with a monadic step function.
--
-- @since 0.2.0
+{-# INLINE foldlM' #-}
foldlM' :: Monad m => (b -> a -> m b) -> b -> SerialT m a -> m b
foldlM' step begin m = S.foldlM' step begin $ toStreamS m
@@ -621,6 +951,35 @@ foldlM' step begin m = S.foldlM' step begin $ toStreamS m
-- Specialized folds
------------------------------------------------------------------------------
+-- | Run a stream, discarding 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
+{-# INLINE runStream #-}
+runStream :: Monad m => SerialT m a -> m ()
+runStream = P.runStream
+
+-- |
+-- > runN n = runStream . take n
+--
+-- Run maximum up to @n@ iterations of a stream.
+--
+-- @since 0.6.0
+{-# INLINE runN #-}
+runN :: Monad m => Int -> SerialT m a -> m ()
+runN n = runStream . take n
+
+-- |
+-- > runWhile p = runStream . takeWhile p
+--
+-- Run a stream as long as the predicate holds true.
+--
+-- @since 0.6.0
+{-# INLINE runWhile #-}
+runWhile :: Monad m => (a -> Bool) -> SerialT m a -> m ()
+runWhile p = runStream . takeWhile p
+
-- | Determine whether the stream is empty.
--
-- @since 0.1.1
@@ -630,6 +989,8 @@ null = K.null
-- | Extract the first element of the stream, if any.
--
+-- > head = (!! 0)
+--
-- @since 0.1.0
{-# INLINE head #-}
head :: Monad m => SerialT m a -> m (Maybe a)
@@ -651,6 +1012,8 @@ init m = K.init (K.adapt m)
-- | Extract the last element of the stream, if any.
--
+-- > last xs = xs !! (length xs - 1)
+--
-- @since 0.1.1
{-# INLINE last #-}
last :: Monad m => SerialT m a -> m (Maybe a)
@@ -698,66 +1061,112 @@ any p m = S.any p (toStreamS m)
and :: Monad m => SerialT m Bool -> m Bool
and = all (==True)
--- | Determines wheter at least one element of a boolean stream is True.
+-- | Determines whether at least one element of a boolean stream is True.
--
-- @since 0.5.0
{-# INLINE or #-}
or :: Monad m => SerialT m Bool -> m Bool
or = any (==True)
--- | Determine the sum of all elements of a stream of numbers
+-- | Determine the sum of all elements of a stream of numbers. Returns @0@ when
+-- the stream is empty. Note that this is not numerically stable for floating
+-- point numbers.
--
-- @since 0.1.0
{-# INLINE sum #-}
sum :: (Monad m, Num a) => SerialT m a -> m a
sum = foldl' (+) 0
--- | Determine the product of all elements of a stream of numbers
+-- | Determine the product of all elements of a stream of numbers. Returns @1@
+-- when the stream is empty.
--
-- @since 0.1.1
{-# INLINE product #-}
product :: (Monad m, Num a) => SerialT m a -> m a
product = foldl' (*) 1
--- | Determine the minimum element in a stream.
+-- |
+-- @
+-- minimum = 'minimumBy' compare
+-- @
+--
+-- Determine the minimum element in a stream.
--
-- @since 0.1.0
{-# INLINE minimum #-}
minimum :: (Monad m, Ord a) => SerialT m a -> m (Maybe a)
minimum m = S.minimum (toStreamS m)
--- | Determine the maximum element in a stream.
+-- | Determine the minimum element in a stream using the supplied comparison
+-- function.
+--
+-- @since 0.6.0
+{-# INLINE minimumBy #-}
+minimumBy :: Monad m => (a -> a -> Ordering) -> SerialT m a -> m (Maybe a)
+minimumBy cmp m = S.minimumBy cmp (toStreamS m)
+
+-- |
+-- @
+-- maximum = 'maximumBy' compare
+-- @
+--
+-- Determine the maximum element in a stream.
--
-- @since 0.1.0
{-# INLINE maximum #-}
maximum :: (Monad m, Ord a) => SerialT m a -> m (Maybe a)
maximum m = S.maximum (toStreamS m)
--- | Looks the given key up, treating the given stream as an association list.
+-- | Determine the maximum element in a stream using the supplied comparison
+-- function.
+--
+-- @since 0.6.0
+{-# INLINE maximumBy #-}
+maximumBy :: Monad m => (a -> a -> Ordering) -> SerialT m a -> m (Maybe a)
+maximumBy cmp m = S.maximumBy cmp (toStreamS m)
+
+-- | Lookup the element at the given index.
+--
+-- @since 0.6.0
+{-# INLINE (!!) #-}
+(!!) :: Monad m => SerialT m a -> Int -> m (Maybe a)
+m !! i = toStreamS m S.!! i
+
+-- | In a stream of (key-value) pairs @(a, b)@, return the value @b@ of the
+-- first pair where the key equals the given value @a@.
+--
+-- > lookup = snd <$> find ((==) . fst)
--
-- @since 0.5.0
{-# INLINE lookup #-}
lookup :: (Monad m, Eq a) => a -> SerialT m (a, b) -> m (Maybe b)
-lookup = K.lookup
+lookup a m = S.lookup a (toStreamS m)
--- | Returns the first element of the stream satisfying the given predicate,
--- if any.
+-- | Like 'findM' but with a non-monadic predicate.
+--
+-- > find p = findM (return . p)
--
-- @since 0.5.0
{-# INLINE find #-}
find :: Monad m => (a -> Bool) -> SerialT m a -> m (Maybe a)
-find = K.find
+find p m = S.find p (toStreamS m)
+
+-- | Returns the first element that satisfies the given predicate.
+--
+-- @since 0.6.0
+{-# INLINE findM #-}
+findM :: Monad m => (a -> m Bool) -> SerialT m a -> m (Maybe a)
+findM p m = S.findM p (toStreamS m)
-- | Find all the indices where the element in the stream satisfies the given
-- predicate.
--
-- @since 0.5.0
{-# INLINE findIndices #-}
-findIndices :: IsStream t => (a -> Bool) -> t m a -> t m Int
-findIndices = K.findIndices
+findIndices :: (IsStream t, Monad m) => (a -> Bool) -> t m a -> t m Int
+findIndices p m = fromStreamS $ S.findIndices p (toStreamS m)
--- | Gives the index of the first stream element satisfying the given
--- preficate.
+-- | Returns the first index that satisfies the given predicate.
--
-- @since 0.5.0
{-# INLINE findIndex #-}
@@ -769,15 +1178,78 @@ findIndex p = head . findIndices p
--
-- @since 0.5.0
{-# INLINE elemIndices #-}
-elemIndices :: (IsStream t, Eq a) => a -> t m a -> t m Int
+elemIndices :: (IsStream t, Eq a, Monad m) => a -> t m a -> t m Int
elemIndices a = findIndices (==a)
--- | Gives the first index of an element in the stream, which equals the given.
+-- | Returns the first index where a given value is found in the stream.
+--
+-- > elemIndex a = findIndex (== a)
--
-- @since 0.5.0
{-# INLINE elemIndex #-}
elemIndex :: (Monad m, Eq a) => a -> SerialT m a -> m (Maybe Int)
-elemIndex a = findIndex (==a)
+elemIndex a = findIndex (== a)
+
+-- | Map each element to a stream and then flatten the results into a single
+-- stream.
+--
+-- > concatMap f = concatMapM (return . f)
+--
+-- @since 0.6.0
+{-# INLINE concatMap #-}
+concatMap ::(IsStream t, Monad m) => (a -> t m b) -> t m a -> t m b
+concatMap f m = fromStreamD $ D.concatMap (toStreamD . f) (toStreamD m)
+
+-- | Map each element to a stream using a monadic function and then flatten the
+-- results into a single stream.
+--
+-- @since 0.6.0
+{-# INLINE concatMapM #-}
+concatMapM :: (IsStream t, Monad m) => (a -> m (t m b)) -> t m a -> t m b
+concatMapM f m = fromStreamD $ D.concatMapM (fmap toStreamD . f) (toStreamD m)
+
+------------------------------------------------------------------------------
+-- Substreams
+------------------------------------------------------------------------------
+
+-- | Returns 'True' if the first stream is the same as or a prefix of the
+-- second.
+--
+-- @
+-- > S.isPrefixOf (S.fromList "hello") (S.fromList "hello" :: SerialT IO Char)
+-- True
+-- @
+--
+-- @since 0.6.0
+{-# INLINE isPrefixOf #-}
+isPrefixOf :: (Eq a, IsStream t, Monad m) => t m a -> t m a -> m Bool
+isPrefixOf m1 m2 = D.isPrefixOf (toStreamD m1) (toStreamD m2)
+
+-- | Returns 'True' if all the elements of the first stream occur, in order, in
+-- the second stream. The elements do not have to occur consecutively. A stream
+-- is treated as a subsequence of itself.
+--
+-- @
+-- > S.isSubsequenceOf (S.fromList "hlo") (S.fromList "hello" :: SerialT IO Char)
+-- True
+-- @
+--
+-- @since 0.6.0
+{-# INLINE isSubsequenceOf #-}
+isSubsequenceOf :: (Eq a, IsStream t, Monad m) => t m a -> t m a -> m Bool
+isSubsequenceOf m1 m2 = D.isSubsequenceOf (toStreamD m1) (toStreamD m2)
+
+-- | Drops the given prefix from a stream. Returns 'Nothing' if the stream does
+-- not start with the given prefix. Returns @Just nil@ when the prefix is the
+-- same as the stream.
+--
+-- @since 0.6.0
+{-# INLINE stripPrefix #-}
+stripPrefix
+ :: (Eq a, IsStream t, Monad m)
+ => t m a -> t m a -> m (Maybe (t m a))
+stripPrefix m1 m2 = fmap fromStreamD <$>
+ D.stripPrefix (toStreamD m1) (toStreamD m2)
------------------------------------------------------------------------------
-- Map and Fold
@@ -796,24 +1268,34 @@ mapM_ f m = S.mapM_ f $ toStreamS m
-- Conversions
------------------------------------------------------------------------------
--- | Convert a stream into a list in the underlying monad.
+-- |
+-- @
+-- toList = S.foldr (:) []
+-- @
+--
+-- Convert a stream into a list in the underlying monad. Same as:
--
-- @since 0.1.0
{-# INLINE toList #-}
toList :: Monad m => SerialT m a -> m [a]
-toList m = S.toList $ toStreamS m
+toList = P.toList
--- | Write a stream of Strings to an IO Handle.
+-- |
+-- @
+-- toHandle h = S.mapM_ $ hPutStrLn h
+-- @
+--
+-- Write a stream of Strings to an IO Handle.
--
-- @since 0.1.0
toHandle :: MonadIO m => IO.Handle -> SerialT m String -> m ()
-toHandle h m = go (toStream m)
+toHandle h m = go m
where
go m1 =
let stop = return ()
single a = liftIO (IO.hPutStrLn h a)
yieldk a r = liftIO (IO.hPutStrLn h a) >> go r
- in K.unStream m1 defState stop single yieldk
+ in K.foldStream defState yieldk single stop m1
------------------------------------------------------------------------------
-- Transformation by Folding (Scans)
@@ -835,22 +1317,119 @@ scanx = K.scanx
scan :: IsStream t => (x -> a -> x) -> x -> (x -> b) -> t m a -> t m b
scan = scanx
--- | Like 'scanl'' but with a monadic step function.
+-- XXX this needs to be concurrent
+-- | Like 'scanl'' but with a monadic fold function.
--
-- @since 0.4.0
{-# INLINE scanlM' #-}
scanlM' :: (IsStream t, Monad m) => (b -> a -> m b) -> b -> t m a -> t m b
scanlM' step begin m = fromStreamD $ D.scanlM' step begin $ toStreamD m
--- | 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''.
+-- | Strict left scan.
+--
+-- @
+-- > S.toList $ S.scanl' (+) 0 $ fromList [1,2,3,4]
+-- [0,1,3,6,10]
+-- @
+--
+-- @
+-- > S.toList $ S.scanl' (flip (:)) [] $ S.fromList [1,2,3,4]
+-- [[],[1],[2,1],[3,2,1],[4,3,2,1]]
+-- @
+--
+-- The output of 'scanl'' is the initial value of the accumulator followed by
+-- all the intermediate steps and the final result of 'foldl''.
+--
+-- By streaming the accumulated state after each fold step, we can share the
+-- state across multiple stages of stream composition. Each stage can modify or
+-- extend the state, do some processing with it and emit it for the next stage,
+-- thus modularizing the stream processing. This can be useful in
+-- stateful or event-driven programming.
+--
+-- Consider the following example, computing the sum and the product of the
+-- elements in a stream in one go using a @foldl'@:
+--
+-- @
+-- > S.foldl' (\\(s, p) x -> (s + x, p * x)) (0,1) $ S.fromList \[1,2,3,4]
+-- (10,24)
+-- @
+--
+-- Using @scanl'@ we can compute the sum in the first stage and pass it down to
+-- the next stage for computing the product:
+--
+-- @
+-- > S.foldl' (\\(_, p) (s, x) -> (s, p * x)) (0,1)
+-- $ S.scanl' (\\(s, _) x -> (s + x, x)) (0,1)
+-- $ S.fromList \[1,2,3,4]
+-- (10,24)
+-- @
+--
+-- IMPORTANT: 'scanl'' evaluates the accumulator to WHNF. To avoid building
+-- lazy expressions inside the accumulator, it is recommended that a strict
+-- data structure is used for accumulator.
--
-- @since 0.2.0
{-# INLINE scanl' #-}
scanl' :: (IsStream t, Monad m) => (b -> a -> b) -> b -> t m a -> t m b
-scanl' step = scanlM' (\a b -> return (step a b))
+scanl' step z m = fromStreamS $ S.scanl' step z $ toStreamS m
+
+-- XXX enable once the signature (monadic zero) change is settled
+-- | Like scanl' but does not stream the initial value of the accumulator.
+--
+-- > postscanl' f z xs = S.drop 1 $ scanl' f z xs
+--
+-- @since 0.6.0
+{-# INLINE _postscanl' #-}
+_postscanl' :: (IsStream t, Monad m) => (b -> a -> b) -> b -> t m a -> t m b
+_postscanl' step z m = fromStreamD $ D.postscanl' step z $ toStreamD m
+
+-- XXX this needs to be concurrent
+-- | Like postscanl' but with a monadic step function.
+--
+-- @since 0.6.0
+{-# INLINE _postscanlM' #-}
+_postscanlM' :: (IsStream t, Monad m) => (b -> a -> m b) -> b -> t m a -> t m b
+_postscanlM' step z m = fromStreamD $ D.postscanlM' step z $ toStreamD m
+
+-- XXX prescanl does not sound very useful, enable only if there is a
+-- compelling use case.
+--
+-- | Like scanl' but does not stream the final value of the accumulator.
+--
+-- @since 0.6.0
+{-# INLINE _prescanl' #-}
+_prescanl' :: (IsStream t, Monad m) => (b -> a -> b) -> b -> t m a -> t m b
+_prescanl' step z m = fromStreamD $ D.prescanl' step z $ toStreamD m
+
+-- XXX this needs to be concurrent
+-- | Like postscanl' but with a monadic step function.
+--
+-- @since 0.6.0
+{-# INLINE _prescanlM' #-}
+_prescanlM' :: (IsStream t, Monad m) => (b -> a -> m b) -> m b -> t m a -> t m b
+_prescanlM' step z m = fromStreamD $ D.prescanlM' step z $ toStreamD m
+
+-- XXX this needs to be concurrent
+-- | Like 'scanl1'' but with a monadic step function.
+--
+-- @since 0.6.0
+{-# INLINE scanl1M' #-}
+scanl1M' :: (IsStream t, Monad m) => (a -> a -> m a) -> t m a -> t m a
+scanl1M' step m = fromStreamD $ D.scanl1M' step $ toStreamD m
+
+-- | Like 'scanl'' but for a non-empty stream. The first element of the stream
+-- is used as the initial value of the accumulator. Does nothing if the stream
+-- is empty.
+--
+-- @
+-- > S.toList $ S.scanl1 (+) $ fromList [1,2,3,4]
+-- [1,3,6,10]
+-- @
+--
+-- @since 0.6.0
+{-# INLINE scanl1' #-}
+scanl1' :: (IsStream t, Monad m) => (a -> a -> a) -> t m a -> t m a
+scanl1' step m = fromStreamD $ D.scanl1' step $ toStreamD m
------------------------------------------------------------------------------
-- Transformation by Filtering
@@ -876,6 +1455,21 @@ filter = K.filter
filterM :: (IsStream t, Monad m) => (a -> m Bool) -> t m a -> t m a
filterM p m = fromStreamD $ D.filterM p $ toStreamD m
+-- | Drop repeated elements that are adjacent to each other.
+--
+-- @since 0.6.0
+{-# INLINE uniq #-}
+uniq :: (Eq a, IsStream t, Monad m) => t m a -> t m a
+uniq = fromStreamD . D.uniq . toStreamD
+
+-- | Ensures that all the elements of the stream are identical and then returns
+-- that unique element.
+--
+-- @since 0.6.0
+{-# INLINE the #-}
+the :: (Eq a, Monad m) => SerialT m a -> m (Maybe a)
+the m = S.the (toStreamS m)
+
-- | Take first 'n' elements from the stream and discard the rest.
--
-- @since 0.1.0
@@ -924,10 +1518,18 @@ dropWhileM p m = fromStreamD $ D.dropWhileM p $ toStreamD m
-- Transformation by Mapping
------------------------------------------------------------------------------
--- | Replace each element of the stream with the result of a monadic action
--- applied on the element.
+-- |
+-- @
+-- mapM f = sequence . map f
+-- @
+--
+-- Apply a monadic function to each element of the stream and replace it with
+-- the output of the resulting action.
--
-- @
+-- > runStream $ S.mapM putStr $ S.fromList ["a", "b", "c"]
+-- abc
+--
-- runStream $ S.replicateM 10 (return 1)
-- & (serially . S.mapM (\\x -> threadDelay 1000000 >> print x))
--
@@ -947,10 +1549,18 @@ mapM = K.mapM
mapMSerial :: Monad m => (a -> m b) -> SerialT m a -> SerialT m b
mapMSerial = Serial.mapM
--- | Reduce a stream of monadic actions to a stream of the output of those
--- actions.
+-- |
+-- @
+-- sequence = mapM id
+-- @
+--
+-- Replace the elements of a stream of monadic actions with the outputs of
+-- those actions.
--
-- @
+-- > runStream $ S.sequence $ S.fromList [putStr "a", putStr "b", putStrLn "c"]
+-- abc
+--
-- runStream $ S.replicateM 10 (return $ threadDelay 1000000 >> print 1)
-- & (serially . S.sequence)
--
@@ -963,7 +1573,7 @@ mapMSerial = Serial.mapM
-- @since 0.1.0
{-# INLINE sequence #-}
sequence :: (IsStream t, MonadAsync m) => t m (m a) -> t m a
-sequence = K.sequence
+sequence m = fromStreamS $ S.sequence (toStreamS m)
------------------------------------------------------------------------------
-- Transformation by Map and Filter
@@ -982,10 +1592,15 @@ mapMaybe f m = fromStreamS $ S.mapMaybe f $ toStreamS m
-- /Concurrent (do not use with 'parallely' on infinite streams)/
--
-- @since 0.3.0
-{-# INLINE mapMaybeM #-}
+{-# INLINE_EARLY mapMaybeM #-}
mapMaybeM :: (IsStream t, MonadAsync m, Functor (t m))
=> (a -> m (Maybe b)) -> t m a -> t m b
-mapMaybeM f = fmap fromJust . filter isJust . mapM f
+mapMaybeM f = fmap fromJust . filter isJust . K.mapM f
+
+{-# RULES "mapMaybeM serial" mapMaybeM = mapMaybeMSerial #-}
+{-# INLINE mapMaybeMSerial #-}
+mapMaybeMSerial :: Monad m => (a -> m (Maybe b)) -> SerialT m a -> SerialT m b
+mapMaybeMSerial f m = fromStreamD $ D.mapMaybeM f $ toStreamD m
------------------------------------------------------------------------------
-- Transformation by Reordering
@@ -999,32 +1614,105 @@ mapMaybeM f = fmap fromJust . filter isJust . mapM f
--
-- @since 0.1.1
reverse :: (IsStream t) => t m a -> t m a
-reverse m = fromStream $ go K.nil (toStream m)
+reverse m = go K.nil m
where
- go rev rest = K.Stream $ \st stp sng yld ->
- let runIt x = K.unStream x (rstState st) stp sng yld
+ go rev rest = K.mkStream $ \st yld sng stp ->
+ let runIt x = K.foldStream st yld sng stp x
stop = runIt rev
single a = runIt $ a `K.cons` rev
yieldk a r = runIt $ go (a `K.cons` rev) r
- in K.unStream rest (rstState st) stop single yieldk
+ in K.foldStream st yieldk single stop rest
------------------------------------------------------------------------------
-- Transformation by Inserting
------------------------------------------------------------------------------
--- | Generate a stream by performing the monadic action inbetween all elements
--- of the given stream.
+-- | Generate a stream by performing a monadic action between consecutive
+-- elements of the given stream.
+--
+-- /Concurrent (do not use with 'parallely' on infinite streams)/
+--
+-- @
+-- > S.toList $ S.intersperseM (putChar \'a' >> return ',') $ S.fromList "hello"
+-- aaaa"h,e,l,l,o"
+-- @
--
-- @since 0.5.0
{-# INLINE intersperseM #-}
intersperseM :: (IsStream t, MonadAsync m) => m a -> t m a -> t m a
intersperseM = K.intersperseM
+-- | @insertBy cmp elem stream@ inserts @elem@ before the first element in
+-- @stream@ that is less than @elem@ when compared using @cmp@.
+--
+-- @
+-- insertBy cmp x = 'mergeBy' cmp ('yield' x)
+-- @
+--
+-- @
+-- > S.toList $ S.insertBy compare 2 $ S.fromList [1,3,5]
+-- [1,2,3,5]
+-- @
+--
+-- @since 0.6.0
+{-# INLINE insertBy #-}
+insertBy ::
+ (IsStream t, Monad m) => (a -> a -> Ordering) -> a -> t m a -> t m a
+insertBy cmp x m = fromStreamS $ S.insertBy cmp x (toStreamS m)
+
+------------------------------------------------------------------------------
+-- Deleting
+------------------------------------------------------------------------------
+
+-- | Deletes the first occurence of the element in the stream that satisfies
+-- the given equality predicate.
+--
+-- @
+-- > S.toList $ S.deleteBy (==) 3 $ S.fromList [1,3,3,5]
+-- [1,3,5]
+-- @
+--
+-- @since 0.6.0
+{-# INLINE deleteBy #-}
+deleteBy :: (IsStream t, Monad m) => (a -> a -> Bool) -> a -> t m a -> t m a
+deleteBy cmp x m = fromStreamS $ S.deleteBy cmp x (toStreamS m)
+
------------------------------------------------------------------------------
-- Zipping
------------------------------------------------------------------------------
--- | Zip two streams serially using a monadic zipping function.
+-- |
+-- > indexed = S.zipWith (,) (S.intFrom 0)
+--
+-- Pair each element in a stream with its index.
+--
+-- @
+-- > S.toList $ S.indexed $ S.fromList "hello"
+-- [(0,'h'),(1,'e'),(2,'l'),(3,'l'),(4,'o')]
+-- @
+--
+-- @since 0.6.0
+{-# INLINE indexed #-}
+indexed :: (IsStream t, Monad m) => t m a -> t m (Int, a)
+indexed = fromStreamD . D.indexed . toStreamD
+
+-- |
+-- > indexedR n = S.zipWith (,) (S.intFromThen n (n - 1))
+--
+-- Pair each element in a stream with its index, starting from the
+-- given index @n@ and counting down.
+--
+-- @
+-- > S.toList $ S.indexedR 10 $ S.fromList "hello"
+-- [(9,'h'),(8,'e'),(7,'l'),(6,'l'),(5,'o')]
+-- @
+--
+-- @since 0.6.0
+{-# INLINE indexedR #-}
+indexedR :: (IsStream t, Monad m) => Int -> t m a -> t m (Int, a)
+indexedR n = fromStreamD . D.indexedR n . toStreamD
+
+-- | Like 'zipWith' but using a monadic zipping function.
--
-- @since 0.4.0
{-# INLINABLE zipWithM #-}
@@ -1033,7 +1721,129 @@ zipWithM f m1 m2 = fromStreamS $ S.zipWithM f (toStreamS m1) (toStreamS m2)
-- | Zip two streams serially using a pure zipping function.
--
+-- @
+-- > S.toList $ S.zipWith (+) (S.fromList [1,2,3]) (S.fromList [4,5,6])
+-- [5,7,9]
+-- @
+--
-- @since 0.1.0
{-# INLINABLE zipWith #-}
zipWith :: (IsStream t, Monad m) => (a -> b -> c) -> t m a -> t m b -> t m c
zipWith f m1 m2 = fromStreamS $ S.zipWith f (toStreamS m1) (toStreamS m2)
+
+------------------------------------------------------------------------------
+-- Comparison
+------------------------------------------------------------------------------
+
+-- | Compare two streams for equality using an equality function.
+--
+-- @since 0.6.0
+{-# INLINABLE eqBy #-}
+eqBy :: (IsStream t, Monad m) => (a -> b -> Bool) -> t m a -> t m b -> m Bool
+eqBy = P.eqBy
+
+-- | Compare two streams lexicographically using a comparison function.
+--
+-- @since 0.6.0
+{-# INLINABLE cmpBy #-}
+cmpBy
+ :: (IsStream t, Monad m)
+ => (a -> b -> Ordering) -> t m a -> t m b -> m Ordering
+cmpBy = P.cmpBy
+
+------------------------------------------------------------------------------
+-- Merge
+------------------------------------------------------------------------------
+
+-- | Merge two streams using a comparison function. The head elements of both
+-- the streams are compared and the smaller of the two elements is emitted, if
+-- both elements are equal then the element from the first stream is used
+-- first.
+--
+-- If the streams are sorted in ascending order, the resulting stream would
+-- also remain sorted in ascending order.
+--
+-- @
+-- > S.toList $ S.mergeBy compare (S.fromList [1,3,5]) (S.fromList [2,4,6,8])
+-- [1,2,3,4,5,6,8]
+-- @
+--
+-- @since 0.6.0
+{-# INLINABLE mergeBy #-}
+mergeBy ::
+ (IsStream t, Monad m) => (a -> a -> Ordering) -> t m a -> t m a -> t m a
+mergeBy f m1 m2 = fromStreamS $ S.mergeBy f (toStreamS m1) (toStreamS m2)
+
+-- | Like 'mergeBy' but with a monadic comparison function.
+--
+-- Merge two streams randomly:
+--
+-- @
+-- > randomly _ _ = randomIO >>= \x -> return $ if x then LT else GT
+-- > S.toList $ S.mergeByM randomly (S.fromList [1,1,1,1]) (S.fromList [2,2,2,2])
+-- [2,1,2,2,2,1,1,1]
+-- @
+--
+-- Merge two streams in a proportion of 2:1:
+--
+-- @
+-- proportionately m n = do
+-- ref <- newIORef $ cycle $ concat [replicate m LT, replicate n GT]
+-- return $ \\_ _ -> do
+-- r <- readIORef ref
+-- writeIORef ref $ tail r
+-- return $ head r
+--
+-- main = do
+-- f <- proportionately 2 1
+-- xs <- S.toList $ S.mergeByM f (S.fromList [1,1,1,1,1,1]) (S.fromList [2,2,2])
+-- print xs
+-- @
+-- @
+-- [1,1,2,1,1,2,1,1,2]
+-- @
+--
+-- @since 0.6.0
+{-# INLINABLE mergeByM #-}
+mergeByM
+ :: (IsStream t, Monad m)
+ => (a -> a -> m Ordering) -> t m a -> t m a -> t m a
+mergeByM f m1 m2 = fromStreamS $ S.mergeByM f (toStreamS m1) (toStreamS m2)
+
+-- Holding this back for now, we may want to use the name "merge" differently
+{-
+-- | Same as @'mergeBy' 'compare'@.
+--
+-- @
+-- > S.toList $ S.merge (S.fromList [1,3,5]) (S.fromList [2,4,6,8])
+-- [1,2,3,4,5,6,8]
+-- @
+--
+-- @since 0.6.0
+{-# INLINABLE merge #-}
+merge ::
+ (IsStream t, Monad m, Ord a) => t m a -> t m a -> t m a
+merge = mergeBy compare
+-}
+
+-- | Like 'mergeBy' but merges concurrently (i.e. both the elements being
+-- merged are generated concurrently).
+--
+-- @since 0.6.0
+mergeAsyncBy :: (IsStream t, MonadAsync m)
+ => (a -> a -> Ordering) -> t m a -> t m a -> t m a
+mergeAsyncBy f m1 m2 = K.mkStream $ \st stp sng yld -> do
+ ma <- mkAsync' st m1
+ mb <- mkAsync' st m2
+ K.foldStream st stp sng yld (K.mergeBy f ma mb)
+
+-- | Like 'mergeByM' but merges concurrently (i.e. both the elements being
+-- merged are generated concurrently).
+--
+-- @since 0.6.0
+mergeAsyncByM :: (IsStream t, MonadAsync m)
+ => (a -> a -> m Ordering) -> t m a -> t m a -> t m a
+mergeAsyncByM f m1 m2 = K.mkStream $ \st stp sng yld -> do
+ ma <- mkAsync' st m1
+ mb <- mkAsync' st m2
+ K.foldStream st stp sng yld (K.mergeByM f ma mb)
diff --git a/src/Streamly/SVar.hs b/src/Streamly/SVar.hs
index 94183f1..0903806 100644
--- a/src/Streamly/SVar.hs
+++ b/src/Streamly/SVar.hs
@@ -31,7 +31,7 @@ module Streamly.SVar
, Limit (..)
, State (streamVar)
, defState
- , rstState
+ , adaptState
, getMaxThreads
, setMaxThreads
, getMaxBuffer
@@ -433,8 +433,15 @@ defState = State
-- We can optimize this so that we clear it only if it is a Just value, it
-- results in slightly better perf for zip/zipM but the performance of scan
-- worsens a lot, it does not fuse.
-rstState :: State t m a -> State t m b
-rstState st = st
+--
+-- XXX This has a side effect of clearing the SVar and yieldLimit, therefore it
+-- should not be used to convert from the same type to the same type, unless
+-- you want to clear the SVar. For clearing the SVar you should be using the
+-- appropriate unStream functions instead.
+--
+-- | Adapt the stream state from one type to another.
+adaptState :: State t m a -> State t m b
+adaptState st = st
{ streamVar = Nothing
, _yieldLimit = Nothing
}
@@ -2009,6 +2016,7 @@ newSVarStats = do
, svarStopTime = stpTime
}
+-- XXX remove polymorphism in t, inline f
getAheadSVar :: MonadAsync m
=> State t m a
-> ( IORef ([t m a], Int)
diff --git a/src/Streamly/Streams/Ahead.hs b/src/Streamly/Streams/Ahead.hs
index e7d5fe4..c4ffb3d 100644
--- a/src/Streamly/Streams/Ahead.hs
+++ b/src/Streamly/Streams/Ahead.hs
@@ -48,8 +48,8 @@ import Streamly.Streams.SVar (fromSVar)
import Streamly.Streams.Serial (map)
import Streamly.SVar
import Streamly.Streams.StreamK
- (IsStream(..), Stream(..), unstreamShared, unStreamIsolated,
- runStreamSVar)
+ (IsStream(..), Stream, mkStream, foldStream, foldStreamShared,
+ foldStreamSVar)
import qualified Streamly.Streams.StreamK as K
import Prelude hiding (map)
@@ -298,9 +298,11 @@ processHeap q heap st sv winfo entry sno stopping = loopHeap sno entry
let stop = do
liftIO (incrementYieldLimit sv)
nextHeap seqNo
- runStreamSVar sv r st stop
- (singleStreamFromHeap seqNo)
+ foldStreamSVar sv st
(yieldStreamFromHeap seqNo)
+ (singleStreamFromHeap seqNo)
+ stop
+ r
else liftIO $ do
let ent = Entry seqNo (AheadEntryStream r)
liftIO $ requeueOnHeapTop heap ent seqNo
@@ -348,9 +350,11 @@ processWithoutToken q heap st sv winfo m seqNo = do
-- we stop.
toHeap AheadEntryNull
- runStreamSVar sv m st stop
- (toHeap . AheadEntryPure)
+ foldStreamSVar sv st
(\a r -> toHeap $ AheadEntryStream $ K.cons a r)
+ (toHeap . AheadEntryPure)
+ stop
+ m
where
@@ -408,7 +412,7 @@ processWithToken q heap st sv winfo action sno = do
liftIO (incrementYieldLimit sv)
loopWithToken (sno + 1)
- runStreamSVar sv action st stop (singleOutput sno) (yieldOutput sno)
+ foldStreamSVar sv st (yieldOutput sno) (singleOutput sno) stop action
where
@@ -431,9 +435,11 @@ processWithToken q heap st sv winfo action sno = do
let stop = do
liftIO (incrementYieldLimit sv)
loopWithToken (seqNo + 1)
- runStreamSVar sv r st stop
- (singleOutput seqNo)
+ foldStreamSVar sv st
(yieldOutput seqNo)
+ (singleOutput seqNo)
+ stop
+ r
else do
let ent = Entry seqNo (AheadEntryStream r)
liftIO $ requeueOnHeapTop heap ent seqNo
@@ -460,9 +466,11 @@ processWithToken q heap st sv winfo action sno = do
let stop = do
liftIO (incrementYieldLimit sv)
loopWithToken (seqNo + 1)
- runStreamSVar sv m st stop
- (singleOutput seqNo)
+ foldStreamSVar sv st
(yieldOutput seqNo)
+ (singleOutput seqNo)
+ stop
+ m
else
-- To avoid a race when another thread puts something
-- on the heap and goes away, the consumer will not get
@@ -543,32 +551,38 @@ workLoopAhead q heap st sv winfo = do
-- The only difference between forkSVarAsync and this is that we run the left
-- computation without a shared SVar.
-forkSVarAhead :: MonadAsync m => Stream m a -> Stream m a -> Stream m a
-forkSVarAhead m1 m2 = Stream $ \st stp sng yld -> do
- sv <- newAheadVar st (concurrently m1 m2) workLoopAhead
- unStream (fromSVar sv) (rstState st) stp sng yld
+forkSVarAhead :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a
+forkSVarAhead m1 m2 = mkStream $ \st stp sng yld -> do
+ sv <- newAheadVar st (concurrently (toStream m1) (toStream m2))
+ workLoopAhead
+ foldStream st stp sng yld (fromSVar sv)
where
- concurrently ma mb = Stream $ \st stp sng yld -> do
+ concurrently ma mb = mkStream $ \st stp sng yld -> do
liftIO $ enqueue (fromJust $ streamVar st) mb
- unStream ma (rstState st) stp sng yld
+ foldStream st stp sng yld ma
-{-# INLINE aheadS #-}
-aheadS :: MonadAsync m => Stream m a -> Stream m a -> Stream m a
-aheadS m1 m2 = Stream $ \st stp sng yld ->
+-- | Polymorphic version of the 'Semigroup' operation '<>' of 'AheadT'.
+-- Merges two streams sequentially but with concurrent lookahead.
+--
+-- @since 0.3.0
+{-# INLINE ahead #-}
+ahead :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a
+ahead m1 m2 = mkStream $ \st stp sng yld ->
case streamVar st of
Just sv | svarStyle sv == AheadVar -> do
- liftIO $ enqueue sv m2
+ liftIO $ enqueue sv (toStream m2)
-- Always run the left side on a new SVar to avoid complexity in
-- sequencing results. This means the left side cannot further
-- split into more ahead computations on the same SVar.
- unStream m1 (rstState st) stp sng yld
- _ -> unStream (forkSVarAhead m1 m2) st stp sng yld
+ foldStream st stp sng yld m1
+ _ -> foldStreamShared st stp sng yld (forkSVarAhead m1 m2)
-- | XXX we can implement it more efficienty by directly implementing instead
-- of combining streams using ahead.
{-# INLINE consMAhead #-}
-consMAhead :: MonadAsync m => m a -> Stream m a -> Stream m a
-consMAhead m r = K.yieldM m `aheadS` r
+{-# SPECIALIZE consMAhead :: IO a -> AheadT IO a -> AheadT IO a #-}
+consMAhead :: MonadAsync m => m a -> AheadT m a -> AheadT m a
+consMAhead m r = fromStream $ K.yieldM m `ahead` (toStream r)
------------------------------------------------------------------------------
-- AheadT
@@ -636,30 +650,20 @@ aheadly = K.adapt
instance IsStream AheadT where
toStream = getAheadT
fromStream = AheadT
-
- {-# INLINE consM #-}
- {-# SPECIALIZE consM :: IO a -> AheadT IO a -> AheadT IO a #-}
- consM m r = fromStream $ consMAhead m (toStream r)
-
- {-# INLINE (|:) #-}
- {-# SPECIALIZE (|:) :: IO a -> AheadT IO a -> AheadT IO a #-}
- (|:) = consM
+ consM = consMAhead
+ (|:) = consMAhead
------------------------------------------------------------------------------
-- Semigroup
------------------------------------------------------------------------------
--- | Polymorphic version of the 'Semigroup' operation '<>' of 'AheadT'.
--- Merges two streams sequentially but with concurrent lookahead.
---
--- @since 0.3.0
-{-# INLINE ahead #-}
-ahead :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a
-ahead m1 m2 = fromStream $ Stream $ \st stp sng yld ->
- unStream (aheadS (toStream m1) (toStream m2)) st stp sng yld
+{-# INLINE mappendAhead #-}
+{-# SPECIALIZE mappendAhead :: AheadT IO a -> AheadT IO a -> AheadT IO a #-}
+mappendAhead :: MonadAsync m => AheadT m a -> AheadT m a -> AheadT m a
+mappendAhead m1 m2 = fromStream $ ahead (toStream m1) (toStream m2)
instance MonadAsync m => Semigroup (AheadT m a) where
- (<>) = ahead
+ (<>) = mappendAhead
------------------------------------------------------------------------------
-- Monoid
@@ -673,31 +677,26 @@ instance MonadAsync m => Monoid (AheadT m a) where
-- Monad
------------------------------------------------------------------------------
-{-# INLINE aheadbind #-}
-aheadbind
- :: MonadAsync m
- => Stream m a
- -> (a -> Stream m b)
- -> Stream m b
-aheadbind m f = go m
- where
- go (Stream g) =
- Stream $ \st stp sng yld ->
- let runShared x = unstreamShared x st stp sng yld
- runIsolated x = unStreamIsolated x st stp sng yld
-
- single a = runIsolated $ f a
- yieldk a r = runShared $
- K.isolateStream (f a) `aheadS` go r
- in g (rstState st) stp single yieldk
+{-# INLINE bindAhead #-}
+{-# SPECIALIZE bindAhead :: AheadT IO a -> (a -> AheadT IO b) -> AheadT IO b #-}
+bindAhead :: MonadAsync m => AheadT m a -> (a -> AheadT m b) -> AheadT m b
+bindAhead m f = fromStream $ K.bindWith ahead (K.adapt m) (\a -> K.adapt $ f a)
instance MonadAsync m => Monad (AheadT m) where
return = pure
- (AheadT m) >>= f = AheadT $ aheadbind m (getAheadT . f)
+ (>>=) = bindAhead
+
+{-# INLINE apAhead #-}
+{-# SPECIALIZE apAhead :: AheadT IO (a -> b) -> AheadT IO a -> AheadT IO b #-}
+apAhead :: MonadAsync m => AheadT m (a -> b) -> AheadT m a -> AheadT m b
+apAhead mf m = ap (K.adapt mf) (K.adapt m)
+
+instance (Monad m, MonadAsync m) => Applicative (AheadT m) where
+ pure = AheadT . K.yield
+ (<*>) = apAhead
------------------------------------------------------------------------------
-- Other instances
------------------------------------------------------------------------------
-MONAD_APPLICATIVE_INSTANCE(AheadT,MONADPARALLEL)
MONAD_COMMON_INSTANCES(AheadT, MONADPARALLEL)
diff --git a/src/Streamly/Streams/Async.hs b/src/Streamly/Streams/Async.hs
index 8577db9..9ac3f26 100644
--- a/src/Streamly/Streams/Async.hs
+++ b/src/Streamly/Streams/Async.hs
@@ -57,7 +57,9 @@ import qualified Data.Set as S
import Streamly.Streams.SVar (fromSVar)
import Streamly.Streams.Serial (map)
import Streamly.SVar
-import Streamly.Streams.StreamK (IsStream(..), Stream(..), adapt, runStreamSVar)
+import Streamly.Streams.StreamK
+ (IsStream(..), Stream, mkStream, foldStream, adapt, foldStreamShared,
+ foldStreamSVar)
import qualified Streamly.Streams.StreamK as K
#include "Instances.hs"
@@ -82,7 +84,7 @@ workLoopLIFO q st sv winfo = run
work <- dequeue
case work of
Nothing -> liftIO $ sendStop sv winfo
- Just m -> runStreamSVar sv m st run single yieldk
+ Just m -> foldStreamSVar sv st yieldk single run m
single a = do
res <- liftIO $ sendYield sv winfo (ChildYield a)
@@ -91,7 +93,7 @@ workLoopLIFO q st sv winfo = run
yieldk a r = do
res <- liftIO $ sendYield sv winfo (ChildYield a)
if res
- then runStreamSVar sv r st run single yieldk
+ then foldStreamSVar sv st yieldk single run r
else liftIO $ do
enqueueLIFO sv q r
sendStop sv winfo
@@ -132,7 +134,7 @@ workLoopLIFOLimited q st sv winfo = run
if yieldLimitOk
then do
let stop = liftIO (incrementYieldLimit sv) >> run
- runStreamSVar sv m st stop single yieldk
+ foldStreamSVar sv st yieldk single stop m
-- Avoid any side effects, undo the yield limit decrement if we
-- never yielded anything.
else liftIO $ do
@@ -151,7 +153,7 @@ workLoopLIFOLimited q st sv winfo = run
yieldLimitOk <- liftIO $ decrementYieldLimit sv
let stop = liftIO (incrementYieldLimit sv) >> run
if res && yieldLimitOk
- then runStreamSVar sv r st stop single yieldk
+ then foldStreamSVar sv st yieldk single stop r
else liftIO $ do
incrementYieldLimit sv
enqueueLIFO sv q r
@@ -183,7 +185,7 @@ workLoopFIFO q st sv winfo = run
work <- liftIO $ tryPopR q
case work of
Nothing -> liftIO $ sendStop sv winfo
- Just m -> runStreamSVar sv m st run single yieldk
+ Just m -> foldStreamSVar sv st yieldk single run m
single a = do
res <- liftIO $ sendYield sv winfo (ChildYield a)
@@ -192,7 +194,7 @@ workLoopFIFO q st sv winfo = run
yieldk a r = do
res <- liftIO $ sendYield sv winfo (ChildYield a)
if res
- then runStreamSVar sv r st run single yieldk
+ then foldStreamSVar sv st yieldk single run r
else liftIO $ do
enqueueFIFO sv q r
sendStop sv winfo
@@ -218,7 +220,7 @@ workLoopFIFOLimited q st sv winfo = run
if yieldLimitOk
then do
let stop = liftIO (incrementYieldLimit sv) >> run
- runStreamSVar sv m st stop single yieldk
+ foldStreamSVar sv st yieldk single stop m
else liftIO $ do
enqueueFIFO sv q m
incrementYieldLimit sv
@@ -233,7 +235,7 @@ workLoopFIFOLimited q st sv winfo = run
yieldLimitOk <- liftIO $ decrementYieldLimit sv
let stop = liftIO (incrementYieldLimit sv) >> run
if res && yieldLimitOk
- then runStreamSVar sv r st stop single yieldk
+ then foldStreamSVar sv st yieldk single stop r
else liftIO $ do
incrementYieldLimit sv
enqueueFIFO sv q r
@@ -526,36 +528,33 @@ newWAsyncVar st m = do
-- composition and vice-versa we create a new SVar to isolate the scheduling
-- of the two.
-forkSVarAsync :: MonadAsync m
- => SVarStyle -> Stream m a -> Stream m a -> Stream m a
-forkSVarAsync style m1 m2 = Stream $ \st stp sng yld -> do
+forkSVarAsync :: (IsStream t, MonadAsync m)
+ => SVarStyle -> t m a -> t m a -> t m a
+forkSVarAsync style m1 m2 = mkStream $ \st stp sng yld -> do
sv <- case style of
- AsyncVar -> newAsyncVar st (concurrently m1 m2)
- WAsyncVar -> newWAsyncVar st (concurrently m1 m2)
+ AsyncVar -> newAsyncVar st (concurrently (toStream m1) (toStream m2))
+ WAsyncVar -> newWAsyncVar st (concurrently (toStream m1) (toStream m2))
_ -> error "illegal svar type"
- unStream (fromSVar sv) (rstState st) stp sng yld
+ foldStream st stp sng yld $ fromSVar sv
where
- concurrently ma mb = Stream $ \st stp sng yld -> do
+ concurrently ma mb = mkStream $ \st stp sng yld -> do
liftIO $ enqueue (fromJust $ streamVar st) mb
- unStream ma st stp sng yld
+ foldStreamShared st stp sng yld ma
{-# INLINE joinStreamVarAsync #-}
-joinStreamVarAsync :: MonadAsync m
- => SVarStyle -> Stream m a -> Stream m a -> Stream m a
-joinStreamVarAsync style m1 m2 = Stream $ \st stp sng yld ->
+joinStreamVarAsync :: (IsStream t, MonadAsync m)
+ => SVarStyle -> t m a -> t m a -> t m a
+joinStreamVarAsync style m1 m2 = mkStream $ \st stp sng yld ->
case streamVar st of
- Just sv | svarStyle sv == style ->
- liftIO (enqueue sv m2) >> unStream m1 st stp sng yld
- _ -> unStream (forkSVarAsync style m1 m2) st stp sng yld
+ Just sv | svarStyle sv == style -> do
+ liftIO $ enqueue sv (toStream m2)
+ foldStreamShared st stp sng yld m1
+ _ -> foldStreamShared st stp sng yld (forkSVarAsync style m1 m2)
------------------------------------------------------------------------------
-- Semigroup and Monoid style compositions for parallel actions
------------------------------------------------------------------------------
-{-# INLINE asyncS #-}
-asyncS :: MonadAsync m => Stream m a -> Stream m a -> Stream m a
-asyncS = joinStreamVarAsync AsyncVar
-
-- | Polymorphic version of the 'Semigroup' operation '<>' of 'AsyncT'.
-- Merges two streams possibly concurrently, preferring the
-- elements from the left one when available.
@@ -563,9 +562,7 @@ asyncS = joinStreamVarAsync AsyncVar
-- @since 0.2.0
{-# INLINE async #-}
async :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a
-async m1 m2 = fromStream $ Stream $ \st stp sng yld ->
- unStream (joinStreamVarAsync AsyncVar (toStream m1) (toStream m2))
- st stp sng yld
+async = joinStreamVarAsync AsyncVar
-- | Same as 'async'.
--
@@ -575,11 +572,16 @@ async m1 m2 = fromStream $ Stream $ \st stp sng yld ->
(<|) :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a
(<|) = async
+-- IMPORTANT: using a monomorphically typed and SPECIALIZED consMAsync makes a
+-- huge difference in the performance of consM in IsStream instance even we
+-- have a SPECIALIZE in the instance.
+--
-- | XXX we can implement it more efficienty by directly implementing instead
-- of combining streams using async.
{-# INLINE consMAsync #-}
-consMAsync :: MonadAsync m => m a -> Stream m a -> Stream m a
-consMAsync m r = K.yieldM m `asyncS` r
+{-# SPECIALIZE consMAsync :: IO a -> AsyncT IO a -> AsyncT IO a #-}
+consMAsync :: MonadAsync m => m a -> AsyncT m a -> AsyncT m a
+consMAsync m r = fromStream $ K.yieldM m `async` (toStream r)
------------------------------------------------------------------------------
-- AsyncT
@@ -652,21 +654,22 @@ asyncly = adapt
instance IsStream AsyncT where
toStream = getAsyncT
fromStream = AsyncT
-
- {-# INLINE consM #-}
- {-# SPECIALIZE consM :: IO a -> AsyncT IO a -> AsyncT IO a #-}
- consM m r = fromStream $ consMAsync m (toStream r)
-
- {-# INLINE (|:) #-}
- {-# SPECIALIZE (|:) :: IO a -> AsyncT IO a -> AsyncT IO a #-}
- (|:) = consM
+ consM = consMAsync
+ (|:) = consMAsync
------------------------------------------------------------------------------
-- Semigroup
------------------------------------------------------------------------------
+-- Monomorphically typed version of "async" for better performance of Semigroup
+-- instance.
+{-# INLINE mappendAsync #-}
+{-# SPECIALIZE mappendAsync :: AsyncT IO a -> AsyncT IO a -> AsyncT IO a #-}
+mappendAsync :: MonadAsync m => AsyncT m a -> AsyncT m a -> AsyncT m a
+mappendAsync m1 m2 = fromStream $ async (toStream m1) (toStream m2)
+
instance MonadAsync m => Semigroup (AsyncT m a) where
- (<>) = async
+ (<>) = mappendAsync
------------------------------------------------------------------------------
-- Monoid
@@ -680,30 +683,40 @@ instance MonadAsync m => Monoid (AsyncT m a) where
-- Monad
------------------------------------------------------------------------------
+{-# INLINE bindAsync #-}
+{-# SPECIALIZE bindAsync :: AsyncT IO a -> (a -> AsyncT IO b) -> AsyncT IO b #-}
+bindAsync :: MonadAsync m => AsyncT m a -> (a -> AsyncT m b) -> AsyncT m b
+bindAsync m f = fromStream $ K.bindWith async (adapt m) (\a -> adapt $ f a)
+
instance MonadAsync m => Monad (AsyncT m) where
return = pure
- (AsyncT m) >>= f = AsyncT $ K.bindWith asyncS m (getAsyncT . f)
+ (>>=) = bindAsync
+
+{-# INLINE apAsync #-}
+{-# SPECIALIZE apAsync :: AsyncT IO (a -> b) -> AsyncT IO a -> AsyncT IO b #-}
+apAsync :: MonadAsync m => AsyncT m (a -> b) -> AsyncT m a -> AsyncT m b
+apAsync mf m = ap (adapt mf) (adapt m)
+
+instance (Monad m, MonadAsync m) => Applicative (AsyncT m) where
+ pure = AsyncT . K.yield
+ (<*>) = apAsync
------------------------------------------------------------------------------
-- Other instances
------------------------------------------------------------------------------
-MONAD_APPLICATIVE_INSTANCE(AsyncT,MONADPARALLEL)
MONAD_COMMON_INSTANCES(AsyncT, MONADPARALLEL)
------------------------------------------------------------------------------
-- WAsyncT
------------------------------------------------------------------------------
-{-# INLINE wAsyncS #-}
-wAsyncS :: MonadAsync m => Stream m a -> Stream m a -> Stream m a
-wAsyncS = joinStreamVarAsync WAsyncVar
-
-- | XXX we can implement it more efficienty by directly implementing instead
-- of combining streams using wAsync.
{-# INLINE consMWAsync #-}
-consMWAsync :: MonadAsync m => m a -> Stream m a -> Stream m a
-consMWAsync m r = K.yieldM m `wAsyncS` r
+{-# SPECIALIZE consMWAsync :: IO a -> WAsyncT IO a -> WAsyncT IO a #-}
+consMWAsync :: MonadAsync m => m a -> WAsyncT m a -> WAsyncT m a
+consMWAsync m r = fromStream $ K.yieldM m `wAsync` (toStream r)
-- | Polymorphic version of the 'Semigroup' operation '<>' of 'WAsyncT'.
-- Merges two streams concurrently choosing elements from both fairly.
@@ -711,8 +724,7 @@ consMWAsync m r = K.yieldM m `wAsyncS` r
-- @since 0.2.0
{-# INLINE wAsync #-}
wAsync :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a
-wAsync m1 m2 = fromStream $ Stream $ \st stp sng yld ->
- unStream (wAsyncS (toStream m1) (toStream m2)) st stp sng yld
+wAsync = joinStreamVarAsync WAsyncVar
-- | Wide async composition or async composition with breadth first traversal.
-- The Semigroup instance of 'WAsyncT' concurrently /traverses/ the composed
@@ -779,21 +791,20 @@ wAsyncly = adapt
instance IsStream WAsyncT where
toStream = getWAsyncT
fromStream = WAsyncT
-
- {-# INLINE consM #-}
- {-# SPECIALIZE consM :: IO a -> WAsyncT IO a -> WAsyncT IO a #-}
- consM m r = fromStream $ consMWAsync m (toStream r)
-
- {-# INLINE (|:) #-}
- {-# SPECIALIZE (|:) :: IO a -> WAsyncT IO a -> WAsyncT IO a #-}
- (|:) = consM
+ consM = consMWAsync
+ (|:) = consMWAsync
------------------------------------------------------------------------------
-- Semigroup
------------------------------------------------------------------------------
+{-# INLINE mappendWAsync #-}
+{-# SPECIALIZE mappendWAsync :: WAsyncT IO a -> WAsyncT IO a -> WAsyncT IO a #-}
+mappendWAsync :: MonadAsync m => WAsyncT m a -> WAsyncT m a -> WAsyncT m a
+mappendWAsync m1 m2 = fromStream $ wAsync (toStream m1) (toStream m2)
+
instance MonadAsync m => Semigroup (WAsyncT m a) where
- (<>) = wAsync
+ (<>) = mappendWAsync
------------------------------------------------------------------------------
-- Monoid
@@ -807,14 +818,26 @@ instance MonadAsync m => Monoid (WAsyncT m a) where
-- Monad
------------------------------------------------------------------------------
+{-# INLINE bindWAsync #-}
+{-# SPECIALIZE bindWAsync :: WAsyncT IO a -> (a -> WAsyncT IO b) -> WAsyncT IO b #-}
+bindWAsync :: MonadAsync m => WAsyncT m a -> (a -> WAsyncT m b) -> WAsyncT m b
+bindWAsync m f = fromStream $ K.bindWith wAsync (adapt m) (\a -> adapt $ f a)
+
instance MonadAsync m => Monad (WAsyncT m) where
return = pure
- (WAsyncT m) >>= f =
- WAsyncT $ K.bindWith wAsyncS m (getWAsyncT . f)
+ (>>=) = bindWAsync
+
+{-# INLINE apWAsync #-}
+{-# SPECIALIZE apWAsync :: WAsyncT IO (a -> b) -> WAsyncT IO a -> WAsyncT IO b #-}
+apWAsync :: MonadAsync m => WAsyncT m (a -> b) -> WAsyncT m a -> WAsyncT m b
+apWAsync mf m = ap (adapt mf) (adapt m)
+
+instance (Monad m, MonadAsync m) => Applicative (WAsyncT m) where
+ pure = WAsyncT . K.yield
+ (<*>) = apWAsync
------------------------------------------------------------------------------
-- Other instances
------------------------------------------------------------------------------
-MONAD_APPLICATIVE_INSTANCE(WAsyncT,MONADPARALLEL)
MONAD_COMMON_INSTANCES(WAsyncT, MONADPARALLEL)
diff --git a/src/Streamly/Streams/Combinators.hs b/src/Streamly/Streams/Combinators.hs
new file mode 100644
index 0000000..9ba7283
--- /dev/null
+++ b/src/Streamly/Streams/Combinators.hs
@@ -0,0 +1,216 @@
+{-# LANGUAGE CPP #-}
+
+#include "inline.hs"
+
+-- |
+-- Module : Streamly.Streams.Combinators
+-- Copyright : (c) 2017 Harendra Kumar
+--
+-- License : BSD3
+-- Maintainer : harendra.kumar@gmail.com
+-- Stability : experimental
+-- Portability : GHC
+--
+--
+module Streamly.Streams.Combinators
+ ( maxThreads
+ , maxBuffer
+ , maxYields
+ , rate
+ , avgRate
+ , minRate
+ , maxRate
+ , constRate
+ , inspectMode
+ , printState
+ )
+where
+
+import Control.Monad.IO.Class (MonadIO(liftIO))
+import Data.Int (Int64)
+
+import Streamly.SVar
+import Streamly.Streams.StreamK
+import Streamly.Streams.Serial (SerialT)
+
+-------------------------------------------------------------------------------
+-- Concurrency control
+-------------------------------------------------------------------------------
+--
+-- XXX need to write these in direct style otherwise they will break fusion.
+--
+-- | Specify the maximum number of threads that can be spawned concurrently for
+-- any concurrent combinator in a stream.
+-- A value of 0 resets the thread limit to default, a negative value means
+-- there is no limit. The default value is 1500.
+--
+-- When the actions in a stream are IO bound, having blocking IO calls, this
+-- option can be used to control the maximum number of in-flight IO requests.
+-- When the actions are CPU bound this option can be used to
+-- control the amount of CPU used by the stream.
+--
+-- @since 0.4.0
+{-# INLINE_NORMAL maxThreads #-}
+maxThreads :: IsStream t => Int -> t m a -> t m a
+maxThreads n m = mkStream $ \st stp sng yld ->
+ foldStreamShared (setMaxThreads n st) stp sng yld m
+
+{-
+{-# RULES "maxThreadsSerial serial" maxThreads = maxThreadsSerial #-}
+maxThreadsSerial :: Int -> SerialT m a -> SerialT m a
+maxThreadsSerial _ = id
+-}
+
+-- | Specify the maximum size of the buffer for storing the results from
+-- concurrent computations. If the buffer becomes full we stop spawning more
+-- concurrent tasks until there is space in the buffer.
+-- A value of 0 resets the buffer size to default, a negative value means
+-- there is no limit. The default value is 1500.
+--
+-- CAUTION! using an unbounded 'maxBuffer' value (i.e. a negative value)
+-- coupled with an unbounded 'maxThreads' value is a recipe for disaster in
+-- presence of infinite streams, or very large streams. Especially, it must
+-- not be used when 'pure' is used in 'ZipAsyncM' streams as 'pure' in
+-- applicative zip streams generates an infinite stream causing unbounded
+-- concurrent generation with no limit on the buffer or threads.
+--
+-- @since 0.4.0
+{-# INLINE_NORMAL maxBuffer #-}
+maxBuffer :: IsStream t => Int -> t m a -> t m a
+maxBuffer n m = mkStream $ \st stp sng yld ->
+ foldStreamShared (setMaxBuffer n st) stp sng yld m
+
+{-
+{-# RULES "maxBuffer serial" maxBuffer = maxBufferSerial #-}
+maxBufferSerial :: Int -> SerialT m a -> SerialT m a
+maxBufferSerial _ = id
+-}
+
+-- | Specify the pull rate of a stream.
+-- A 'Nothing' value resets the rate to default which is unlimited. When the
+-- rate is specified, concurrent production may be ramped up or down
+-- automatically to achieve the specified yield rate. The specific behavior for
+-- different styles of 'Rate' specifications is documented under 'Rate'. The
+-- effective maximum production rate achieved by a stream is governed by:
+--
+-- * The 'maxThreads' limit
+-- * The 'maxBuffer' limit
+-- * The maximum rate that the stream producer can achieve
+-- * The maximum rate that the stream consumer can achieve
+--
+-- @since 0.5.0
+{-# INLINE_NORMAL rate #-}
+rate :: IsStream t => Maybe Rate -> t m a -> t m a
+rate r m = mkStream $ \st stp sng yld ->
+ case r of
+ Just (Rate low goal _ _) | goal < low ->
+ error "rate: Target rate cannot be lower than minimum rate."
+ Just (Rate _ goal high _) | goal > high ->
+ error "rate: Target rate cannot be greater than maximum rate."
+ Just (Rate low _ high _) | low > high ->
+ error "rate: Minimum rate cannot be greater than maximum rate."
+ _ -> foldStreamShared (setStreamRate r st) stp sng yld m
+
+-- XXX implement for serial streams as well, as a simple delay
+
+{-
+{-# RULES "rate serial" rate = yieldRateSerial #-}
+yieldRateSerial :: Double -> SerialT m a -> SerialT m a
+yieldRateSerial _ = id
+-}
+
+-- | Same as @rate (Just $ Rate (r/2) r (2*r) maxBound)@
+--
+-- Specifies the average production rate of a stream in number of yields
+-- per second (i.e. @Hertz@). Concurrent production is ramped up or down
+-- automatically to achieve the specified average yield rate. The rate can
+-- go down to half of the specified rate on the lower side and double of
+-- the specified rate on the higher side.
+--
+-- @since 0.5.0
+avgRate :: IsStream t => Double -> t m a -> t m a
+avgRate r = rate (Just $ Rate (r/2) r (2*r) maxBound)
+
+-- | Same as @rate (Just $ Rate r r (2*r) maxBound)@
+--
+-- Specifies the minimum rate at which the stream should yield values. As
+-- far as possible the yield rate would never be allowed to go below the
+-- specified rate, even though it may possibly go above it at times, the
+-- upper limit is double of the specified rate.
+--
+-- @since 0.5.0
+minRate :: IsStream t => Double -> t m a -> t m a
+minRate r = rate (Just $ Rate r r (2*r) maxBound)
+
+-- | Same as @rate (Just $ Rate (r/2) r r maxBound)@
+--
+-- Specifies the maximum rate at which the stream should yield values. As
+-- far as possible the yield rate would never be allowed to go above the
+-- specified rate, even though it may possibly go below it at times, the
+-- lower limit is half of the specified rate. This can be useful in
+-- applications where certain resource usage must not be allowed to go
+-- beyond certain limits.
+--
+-- @since 0.5.0
+maxRate :: IsStream t => Double -> t m a -> t m a
+maxRate r = rate (Just $ Rate (r/2) r r maxBound)
+
+-- | Same as @rate (Just $ Rate r r r 0)@
+--
+-- Specifies a constant yield rate. If for some reason the actual rate
+-- goes above or below the specified rate we do not try to recover it by
+-- increasing or decreasing the rate in future. This can be useful in
+-- applications like graphics frame refresh where we need to maintain a
+-- constant refresh rate.
+--
+-- @since 0.5.0
+constRate :: IsStream t => Double -> t m a -> t m a
+constRate r = rate (Just $ Rate r r r 0)
+
+-- | Specify the average latency, in nanoseconds, of a single threaded action
+-- in a concurrent composition. Streamly can measure the latencies, but that is
+-- possible only after at least one task has completed. This combinator can be
+-- used to provide a latency hint so that rate control using 'rate' can take
+-- that into account right from the beginning. When not specified then a
+-- default behavior is chosen which could be too slow or too fast, and would be
+-- restricted by any other control parameters configured.
+-- A value of 0 indicates default behavior, a negative value means there is no
+-- limit i.e. zero latency.
+-- This would normally be useful only in high latency and high throughput
+-- cases.
+--
+{-# INLINE_NORMAL _serialLatency #-}
+_serialLatency :: IsStream t => Int -> t m a -> t m a
+_serialLatency n m = mkStream $ \st stp sng yld ->
+ foldStreamShared (setStreamLatency n st) stp sng yld m
+
+{-
+{-# RULES "serialLatency serial" _serialLatency = serialLatencySerial #-}
+serialLatencySerial :: Int -> SerialT m a -> SerialT m a
+serialLatencySerial _ = id
+-}
+
+-- Stop concurrent dispatches after this limit. This is useful in API's like
+-- "take" where we want to dispatch only upto the number of elements "take"
+-- needs. This value applies only to the immediate next level and is not
+-- inherited by everything in enclosed scope.
+{-# INLINE_NORMAL maxYields #-}
+maxYields :: IsStream t => Maybe Int64 -> t m a -> t m a
+maxYields n m = mkStream $ \st stp sng yld ->
+ foldStreamShared (setYieldLimit n st) stp sng yld m
+
+{-# RULES "maxYields serial" maxYields = maxYieldsSerial #-}
+maxYieldsSerial :: Maybe Int64 -> SerialT m a -> SerialT m a
+maxYieldsSerial _ = id
+
+printState :: MonadIO m => State Stream m a -> m ()
+printState st = liftIO $ do
+ let msv = streamVar st
+ case msv of
+ Just sv -> dumpSVar sv >>= putStrLn
+ Nothing -> putStrLn "No SVar"
+
+-- | Print debug information about an SVar when the stream ends
+inspectMode :: IsStream t => t m a -> t m a
+inspectMode m = mkStream $ \st stp sng yld ->
+ foldStreamShared (setInspectMode st) stp sng yld m
diff --git a/src/Streamly/Streams/Instances.hs b/src/Streamly/Streams/Instances.hs
index 1430704..c308183 100644
--- a/src/Streamly/Streams/Instances.hs
+++ b/src/Streamly/Streams/Instances.hs
@@ -41,3 +41,81 @@ instance (MonadState s m CONSTRAINT) => MonadState s (STREAM m) where { \
put x = lift (put x); \
state k = lift (state k) }
+------------------------------------------------------------------------------
+-- Lists
+------------------------------------------------------------------------------
+
+-- Serial streams can act like regular lists using the Identity monad
+
+-- XXX Show instance is 10x slower compared to read, we can do much better.
+-- The list show instance itself is really slow.
+
+-- XXX The default definitions of "<" in the Ord instance etc. do not perform
+-- well, because they do not get inlined. Need to add INLINE in Ord class in
+-- base?
+
+#define LIST_INSTANCES(STREAM) \
+instance IsList (STREAM Identity a) where { \
+ type (Item (STREAM Identity a)) = a; \
+ {-# INLINE fromList #-}; \
+ fromList = P.fromList; \
+ {-# INLINE toList #-}; \
+ toList = runIdentity . P.toList }; \
+ \
+instance Eq a => Eq (STREAM Identity a) where { \
+ {-# INLINE (==) #-}; \
+ (==) xs ys = runIdentity $ P.eqBy (==) xs ys }; \
+ \
+instance Ord a => Ord (STREAM Identity a) where { \
+ {-# INLINE compare #-}; \
+ compare xs ys = runIdentity $ P.cmpBy compare xs ys; \
+ {-# INLINE (<) #-}; \
+ x < y = case compare x y of { LT -> True; _ -> False }; \
+ {-# INLINE (<=) #-}; \
+ x <= y = case compare x y of { GT -> False; _ -> True }; \
+ {-# INLINE (>) #-}; \
+ x > y = case compare x y of { GT -> True; _ -> False }; \
+ {-# INLINE (>=) #-}; \
+ x >= y = case compare x y of { LT -> False; _ -> True }; \
+ {-# INLINE max #-}; \
+ max x y = if x <= y then y else x; \
+ {-# INLINE min #-}; \
+ min x y = if x <= y then x else y; }; \
+ \
+instance Show a => Show (STREAM Identity a) where { \
+ showsPrec p dl = showParen (p > 10) $ \
+ showString "fromList " . shows (toList dl) }; \
+ \
+instance Read a => Read (STREAM Identity a) where { \
+ readPrec = parens $ prec 10 $ do { \
+ Ident "fromList" <- lexP; \
+ fromList <$> readPrec }; \
+ readListPrec = readListPrecDefault }; \
+ \
+instance (a ~ Char) => IsString (STREAM Identity a) where { \
+ {-# INLINE fromString #-}; \
+ fromString = P.fromList }; \
+ \
+instance NFData a => NFData (STREAM Identity a) where { rnf = rnf1 }; \
+instance NFData1 (STREAM Identity) where { \
+ {-# INLINE liftRnf #-}; \
+ liftRnf r = runIdentity . P.foldl' (\_ x -> r x) () }
+
+-------------------------------------------------------------------------------
+-- Foldable
+-------------------------------------------------------------------------------
+
+#define FOLDABLE_INSTANCE(STREAM) \
+instance (Foldable m, Monad m) => Foldable (STREAM m) where { \
+ {-# INLINE foldMap #-}; \
+ foldMap f = fold . P.foldr mappend mempty . fmap f }
+
+-------------------------------------------------------------------------------
+-- Traversable
+-------------------------------------------------------------------------------
+
+#define TRAVERSABLE_INSTANCE(STREAM) \
+instance Traversable (STREAM Identity) where { \
+ {-# INLINE traverse #-}; \
+ traverse f s = runIdentity $ P.foldr consA (pure mempty) s \
+ where { consA x ys = liftA2 K.cons (f x) ys }}
diff --git a/src/Streamly/Streams/Parallel.hs b/src/Streamly/Streams/Parallel.hs
index e99c3a4..a291152 100644
--- a/src/Streamly/Streams/Parallel.hs
+++ b/src/Streamly/Streams/Parallel.hs
@@ -49,7 +49,8 @@ import Prelude hiding (map)
import Streamly.Streams.SVar (fromSVar)
import Streamly.Streams.Serial (map)
import Streamly.SVar
-import Streamly.Streams.StreamK (IsStream(..), Stream(..), adapt)
+import Streamly.Streams.StreamK (IsStream(..), Stream, mkStream, foldStream,
+ foldStreamShared, adapt)
import qualified Streamly.Streams.StreamK as K
#include "Instances.hs"
@@ -62,7 +63,7 @@ import qualified Streamly.Streams.StreamK as K
runOne
:: MonadIO m
=> State Stream m a -> Stream m a -> Maybe WorkerInfo -> m ()
-runOne st m winfo = unStream m st stop single yieldk
+runOne st m winfo = foldStreamShared st yieldk single stop m
where
@@ -87,32 +88,29 @@ runOne st m winfo = unStream m st stop single yieldk
>> withLimitCheck (void $ liftIO $ mrun $ runOne st r winfo)
{-# NOINLINE forkSVarPar #-}
-forkSVarPar :: MonadAsync m => Stream m a -> Stream m a -> Stream m a
-forkSVarPar m r = Stream $ \st stp sng yld -> do
+forkSVarPar :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a
+forkSVarPar m r = mkStream $ \st yld sng stp -> do
sv <- newParallelVar st
- pushWorkerPar sv (runOne st{streamVar = Just sv} m)
- pushWorkerPar sv (runOne st{streamVar = Just sv} r)
- unStream (fromSVar sv) (rstState st) stp sng yld
+ pushWorkerPar sv (runOne st{streamVar = Just sv} $ toStream m)
+ pushWorkerPar sv (runOne st{streamVar = Just sv} $ toStream r)
+ foldStream st yld sng stp (fromSVar sv)
{-# INLINE joinStreamVarPar #-}
-joinStreamVarPar :: MonadAsync m
- => SVarStyle -> Stream m a -> Stream m a -> Stream m a
-joinStreamVarPar style m1 m2 = Stream $ \st stp sng yld ->
+joinStreamVarPar :: (IsStream t, MonadAsync m)
+ => SVarStyle -> t m a -> t m a -> t m a
+joinStreamVarPar style m1 m2 = mkStream $ \st yld sng stp ->
case streamVar st of
Just sv | svarStyle sv == style -> do
- pushWorkerPar sv (runOne st m1)
- unStream m2 st stp sng yld
- _ -> unStream (forkSVarPar m1 m2) st stp sng yld
-
-{-# INLINE parallelStream #-}
-parallelStream :: MonadAsync m => Stream m a -> Stream m a -> Stream m a
-parallelStream = joinStreamVarPar ParallelVar
+ pushWorkerPar sv (runOne st $ toStream m1)
+ foldStreamShared st yld sng stp m2
+ _ -> foldStreamShared st yld sng stp (forkSVarPar m1 m2)
-- | XXX we can implement it more efficienty by directly implementing instead
-- of combining streams using parallel.
{-# INLINE consMParallel #-}
-consMParallel :: MonadAsync m => m a -> Stream m a -> Stream m a
-consMParallel m r = K.yieldM m `parallelStream` r
+{-# SPECIALIZE consMParallel :: IO a -> ParallelT IO a -> ParallelT IO a #-}
+consMParallel :: MonadAsync m => m a -> ParallelT m a -> ParallelT m a
+consMParallel m r = fromStream $ K.yieldM m `parallel` (toStream r)
-- | Polymorphic version of the 'Semigroup' operation '<>' of 'ParallelT'
-- Merges two streams concurrently.
@@ -120,9 +118,7 @@ consMParallel m r = K.yieldM m `parallelStream` r
-- @since 0.2.0
{-# INLINE parallel #-}
parallel :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a
-parallel m1 m2 = fromStream $ Stream $ \st stp sng yld ->
- unStream (parallelStream (toStream m1) (toStream m2))
- st stp sng yld
+parallel = joinStreamVarPar ParallelVar
------------------------------------------------------------------------------
-- Convert a stream to parallel
@@ -140,10 +136,10 @@ mkParallel m = do
{-# INLINE applyWith #-}
applyWith :: (IsStream t, MonadAsync m) => (t m a -> t m b) -> t m a -> t m b
-applyWith f m = fromStream $ Stream $ \st stp sng yld -> do
- sv <- newParallelVar (rstState st)
+applyWith f m = mkStream $ \st yld sng stp -> do
+ sv <- newParallelVar (adaptState st)
pushWorkerPar sv (runOne st{streamVar = Just sv} (toStream m))
- unStream (toStream $ f $ fromSVar sv) (rstState st) stp sng yld
+ foldStream st yld sng stp $ f $ fromSVar sv
------------------------------------------------------------------------------
-- Stream runner concurrent function application
@@ -345,7 +341,7 @@ instance IsStream ParallelT where
{-# INLINE consM #-}
{-# SPECIALIZE consM :: IO a -> ParallelT IO a -> ParallelT IO a #-}
- consM m r = fromStream $ consMParallel m (toStream r)
+ consM = consMParallel
{-# INLINE (|:) #-}
{-# SPECIALIZE (|:) :: IO a -> ParallelT IO a -> ParallelT IO a #-}
@@ -355,8 +351,13 @@ instance IsStream ParallelT where
-- Semigroup
------------------------------------------------------------------------------
+{-# INLINE mappendParallel #-}
+{-# SPECIALIZE mappendParallel :: ParallelT IO a -> ParallelT IO a -> ParallelT IO a #-}
+mappendParallel :: MonadAsync m => ParallelT m a -> ParallelT m a -> ParallelT m a
+mappendParallel m1 m2 = fromStream $ parallel (toStream m1) (toStream m2)
+
instance MonadAsync m => Semigroup (ParallelT m a) where
- (<>) = parallel
+ (<>) = mappendParallel
------------------------------------------------------------------------------
-- Monoid
@@ -370,10 +371,16 @@ instance MonadAsync m => Monoid (ParallelT m a) where
-- Monad
------------------------------------------------------------------------------
+{-# INLINE bindParallel #-}
+{-# SPECIALIZE bindParallel :: ParallelT IO a -> (a -> ParallelT IO b) -> ParallelT IO b #-}
+bindParallel :: MonadAsync m => ParallelT m a -> (a -> ParallelT m b) -> ParallelT m b
+bindParallel m f = fromStream $ K.bindWith parallel (K.adapt m) (\a -> K.adapt $ f a)
+
instance MonadAsync m => Monad (ParallelT m) where
return = pure
- (ParallelT m) >>= f
- = ParallelT $ K.bindWith parallelStream m (getParallelT . f)
+ (>>=) = bindParallel
+
+-- XXX Specialize the applicative instance
------------------------------------------------------------------------------
-- Other instances
diff --git a/src/Streamly/Streams/Prelude.hs b/src/Streamly/Streams/Prelude.hs
index b6a2695..5700280 100644
--- a/src/Streamly/Streams/Prelude.hs
+++ b/src/Streamly/Streams/Prelude.hs
@@ -1,11 +1,10 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE InstanceSigs #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE UndecidableInstances #-} -- XXX
+
+#if __GLASGOW_HASKELL__ >= 800
+{-# OPTIONS_GHC -Wno-orphans #-}
+#endif
+
+#include "inline.hs"
-- |
-- Module : Streamly.Streams.Prelude
@@ -19,15 +18,133 @@
--
module Streamly.Streams.Prelude
(
+ -- * Stream Conversion
+ fromStreamS
+ , toStreamS
+
+ -- * Running Effects
+ , runStream
+
+ -- * Conversion operations
+ , fromList
+ , toList
+
+ -- * Fold operations
+ , foldrM
+ , foldr
+ , foldl'
+
+ -- * Zip style operations
+ , eqBy
+ , cmpBy
+
-- * Fold Utilities
- foldWith
+ , foldWith
, foldMapWith
, forEachWith
)
where
+import Prelude hiding (foldr)
+import qualified Prelude
+
+#ifdef USE_STREAMK_ONLY
+import qualified Streamly.Streams.StreamK as S
+#else
+import qualified Streamly.Streams.StreamD as S
+#endif
+
import Streamly.Streams.StreamK (IsStream(..))
import qualified Streamly.Streams.StreamK as K
+import qualified Streamly.Streams.StreamD as D
+
+------------------------------------------------------------------------------
+-- Conversion to and from direct style stream
+------------------------------------------------------------------------------
+
+-- These definitions are dependent on what is imported as S
+{-# INLINE fromStreamS #-}
+fromStreamS :: (IsStream t, Monad m) => S.Stream m a -> t m a
+fromStreamS = fromStream . S.toStreamK
+
+{-# INLINE toStreamS #-}
+toStreamS :: (IsStream t, Monad m) => t m a -> S.Stream m a
+toStreamS = S.fromStreamK . toStream
+
+------------------------------------------------------------------------------
+-- Conversions
+------------------------------------------------------------------------------
+
+{-# INLINE_EARLY runStream #-}
+runStream :: (IsStream t, Monad m) => t m a -> m ()
+runStream m = D.runStream $ D.fromStreamK (toStream m)
+{-# RULES "runStream fallback to CPS" [1]
+ forall a. D.runStream (D.fromStreamK a) = K.runStream a #-}
+
+------------------------------------------------------------------------------
+-- Conversions
+------------------------------------------------------------------------------
+
+-- |
+-- @
+-- fromList = 'Prelude.foldr' 'K.cons' 'K.nil'
+-- @
+--
+-- Construct a stream from a list of pure values. This is more efficient than
+-- 'K.fromFoldable' for serial streams.
+--
+-- @since 0.4.0
+{-# INLINE_EARLY fromList #-}
+fromList :: (Monad m, IsStream t) => [a] -> t m a
+fromList = fromStreamS . S.fromList
+{-# RULES "fromList fallback to StreamK" [1]
+ forall a. S.toStreamK (S.fromList a) = K.fromFoldable a #-}
+
+-- | Convert a stream into a list in the underlying monad.
+--
+-- @since 0.1.0
+{-# INLINE toList #-}
+toList :: (Monad m, IsStream t) => t m a -> m [a]
+toList m = S.toList $ toStreamS m
+
+------------------------------------------------------------------------------
+-- Folds
+------------------------------------------------------------------------------
+
+{-# INLINE foldrM #-}
+foldrM :: (Monad m, IsStream t) => (a -> b -> m b) -> b -> t m a -> m b
+foldrM step acc m = S.foldrM step acc $ toStreamS m
+
+{-# INLINE foldr #-}
+foldr :: (Monad m, IsStream t) => (a -> b -> b) -> b -> t m a -> m b
+foldr f = foldrM (\a b -> return (f a b))
+
+-- | Strict left associative fold.
+--
+-- @since 0.2.0
+{-# INLINE foldl' #-}
+foldl' :: (Monad m, IsStream t) => (b -> a -> b) -> b -> t m a -> m b
+foldl' step begin m = S.foldl' step begin $ toStreamS m
+
+------------------------------------------------------------------------------
+-- Comparison
+------------------------------------------------------------------------------
+
+-- | Compare two streams for equality
+--
+-- @since 0.5.3
+{-# INLINE eqBy #-}
+eqBy :: (IsStream t, Monad m) => (a -> b -> Bool) -> t m a -> t m b -> m Bool
+eqBy f m1 m2 = D.eqBy f (D.toStreamD m1) (D.toStreamD m2)
+
+-- | Compare two streams
+--
+-- @since 0.5.3
+{-# INLINE cmpBy #-}
+cmpBy
+ :: (IsStream t, Monad m)
+ => (a -> b -> Ordering) -> t m a -> t m b -> m Ordering
+cmpBy f m1 m2 = D.cmpBy f (D.toStreamD m1) (D.toStreamD m2)
------------------------------------------------------------------------------
-- Fold Utilities
@@ -42,7 +159,7 @@ import qualified Streamly.Streams.StreamK as K
{-# INLINABLE foldWith #-}
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 K.nil
+foldWith f = Prelude.foldr f K.nil
-- | 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
@@ -54,7 +171,7 @@ foldWith f = foldr f K.nil
{-# INLINABLE foldMapWith #-}
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) K.nil
+foldMapWith f g = Prelude.foldr (f . g) K.nil
-- | Like 'foldMapWith' but with the last two arguments reversed i.e. the
-- monadic streaming function is the last argument.
@@ -63,4 +180,4 @@ foldMapWith f g = foldr (f . g) K.nil
{-# INLINABLE forEachWith #-}
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) K.nil xs
+forEachWith f xs g = Prelude.foldr (f . g) K.nil xs
diff --git a/src/Streamly/Streams/SVar.hs b/src/Streamly/Streams/SVar.hs
index 1b244c9..7d30e09 100644
--- a/src/Streamly/Streams/SVar.hs
+++ b/src/Streamly/Streams/SVar.hs
@@ -1,12 +1,4 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE UndecidableInstances #-} -- XXX
-
-#include "inline.h"
-- |
-- Module : Streamly.Streams.SVar
@@ -19,19 +11,8 @@
--
--
module Streamly.Streams.SVar
- (
- fromSVar
+ ( fromSVar
, toSVar
- , maxThreads
- , maxBuffer
- , maxYields
- , rate
- , avgRate
- , minRate
- , maxRate
- , constRate
- , inspectMode
- , printState
)
where
@@ -39,7 +20,6 @@ import Control.Exception (fromException)
import Control.Monad (when)
import Control.Monad.Catch (throwM)
import Control.Monad.IO.Class (MonadIO(liftIO))
-import Data.Int (Int64)
import Data.IORef (newIORef, readIORef, mkWeakIORef, writeIORef)
import Data.Maybe (isNothing)
import Data.Semigroup ((<>))
@@ -49,29 +29,21 @@ import System.Mem (performMajorGC)
import Streamly.SVar
import Streamly.Streams.StreamK
-import Streamly.Streams.Serial (SerialT)
printSVar :: SVar t m a -> String -> IO ()
printSVar sv how = do
svInfo <- dumpSVar sv
hPutStrLn stderr $ "\n" <> how <> "\n" <> svInfo
-printState :: MonadIO m => State Stream m a -> m ()
-printState st = liftIO $ do
- let msv = streamVar st
- case msv of
- Just sv -> dumpSVar sv >>= putStrLn
- Nothing -> putStrLn "No SVar"
-
-- | Pull a stream from an SVar.
{-# NOINLINE fromStreamVar #-}
fromStreamVar :: MonadAsync m => SVar Stream m a -> Stream m a
-fromStreamVar sv = Stream $ \st stp sng yld -> do
+fromStreamVar sv = mkStream $ \st yld sng stp -> do
list <- readOutputQ sv
-- Reversing the output is important to guarantee that we process the
-- outputs in the same order as they were generated by the constituent
-- streams.
- unStream (processEvents $ reverse list) (rstState st) stp sng yld
+ foldStream st yld sng stp $ processEvents $ reverse list
where
@@ -83,36 +55,37 @@ fromStreamVar sv = Stream $ \st stp sng yld -> do
stp
{-# INLINE processEvents #-}
- processEvents [] = Stream $ \st stp sng yld -> do
+ processEvents [] = mkStream $ \st yld sng stp -> do
done <- postProcess sv
if done
then allDone stp
- else unStream (fromStreamVar sv) (rstState st) stp sng yld
+ else foldStream st yld sng stp $ fromStreamVar sv
- processEvents (ev : es) = Stream $ \st stp sng yld -> do
+ processEvents (ev : es) = mkStream $ \st yld sng stp -> do
let rest = processEvents es
case ev of
ChildYield a -> yld a rest
ChildStop tid e -> do
accountThread sv tid
case e of
- Nothing -> unStream rest (rstState st) stp sng yld
+ Nothing -> foldStream st yld sng stp rest
Just ex ->
case fromException ex of
Just ThreadAbort ->
- unStream rest (rstState st) stp sng yld
+ foldStream st yld sng stp rest
Nothing -> liftIO (cleanupSVar sv) >> throwM ex
{-# INLINE fromSVar #-}
fromSVar :: (MonadAsync m, IsStream t) => SVar Stream m a -> t m a
fromSVar sv =
- fromStream $ Stream $ \st stp sng yld -> do
+ mkStream $ \st yld sng stp -> do
ref <- liftIO $ newIORef ()
_ <- liftIO $ mkWeakIORef ref hook
-- We pass a copy of sv to fromStreamVar, so that we know that it has
-- no other references, when that copy gets garbage collected "ref"
-- will get garbage collected and our hook will be called.
- unStream (fromStreamVar sv{svarRef = Just ref}) st stp sng yld
+ foldStreamShared st yld sng stp $
+ fromStream $ fromStreamVar sv{svarRef = Just ref}
where
hook = do
@@ -129,178 +102,3 @@ fromSVar sv =
-- be read back from the SVar using 'fromSVar'.
toSVar :: (IsStream t, MonadAsync m) => SVar Stream m a -> t m a -> m ()
toSVar sv m = toStreamVar sv (toStream m)
-
--------------------------------------------------------------------------------
--- Concurrency control
--------------------------------------------------------------------------------
---
--- XXX need to write these in direct style otherwise they will break fusion.
---
--- | Specify the maximum number of threads that can be spawned concurrently for
--- any concurrent combinator in a stream.
--- A value of 0 resets the thread limit to default, a negative value means
--- there is no limit. The default value is 1500.
---
--- When the actions in a stream are IO bound, having blocking IO calls, this
--- option can be used to control the maximum number of in-flight IO requests.
--- When the actions are CPU bound this option can be used to
--- control the amount of CPU used by the stream.
---
--- @since 0.4.0
-{-# INLINE_NORMAL maxThreads #-}
-maxThreads :: IsStream t => Int -> t m a -> t m a
-maxThreads n m = fromStream $ Stream $ \st stp sng yld ->
- unStream (toStream m) (setMaxThreads n st) stp sng yld
-
-{-
-{-# RULES "maxThreadsSerial serial" maxThreads = maxThreadsSerial #-}
-maxThreadsSerial :: Int -> SerialT m a -> SerialT m a
-maxThreadsSerial _ = id
--}
-
--- | Specify the maximum size of the buffer for storing the results from
--- concurrent computations. If the buffer becomes full we stop spawning more
--- concurrent tasks until there is space in the buffer.
--- A value of 0 resets the buffer size to default, a negative value means
--- there is no limit. The default value is 1500.
---
--- CAUTION! using an unbounded 'maxBuffer' value (i.e. a negative value)
--- coupled with an unbounded 'maxThreads' value is a recipe for disaster in
--- presence of infinite streams, or very large streams. Especially, it must
--- not be used when 'pure' is used in 'ZipAsyncM' streams as 'pure' in
--- applicative zip streams generates an infinite stream causing unbounded
--- concurrent generation with no limit on the buffer or threads.
---
--- @since 0.4.0
-{-# INLINE_NORMAL maxBuffer #-}
-maxBuffer :: IsStream t => Int -> t m a -> t m a
-maxBuffer n m = fromStream $ Stream $ \st stp sng yld ->
- unStream (toStream m) (setMaxBuffer n st) stp sng yld
-
-{-
-{-# RULES "maxBuffer serial" maxBuffer = maxBufferSerial #-}
-maxBufferSerial :: Int -> SerialT m a -> SerialT m a
-maxBufferSerial _ = id
--}
-
--- | Specify the pull rate of a stream.
--- A 'Nothing' value resets the rate to default which is unlimited. When the
--- rate is specified, concurrent production may be ramped up or down
--- automatically to achieve the specified yield rate. The specific behavior for
--- different styles of 'Rate' specifications is documented under 'Rate'. The
--- effective maximum production rate achieved by a stream is governed by:
---
--- * The 'maxThreads' limit
--- * The 'maxBuffer' limit
--- * The maximum rate that the stream producer can achieve
--- * The maximum rate that the stream consumer can achieve
---
--- @since 0.5.0
-{-# INLINE_NORMAL rate #-}
-rate :: IsStream t => Maybe Rate -> t m a -> t m a
-rate r m = fromStream $ Stream $ \st stp sng yld ->
- case r of
- Just (Rate low goal _ _) | goal < low ->
- error "rate: Target rate cannot be lower than minimum rate."
- Just (Rate _ goal high _) | goal > high ->
- error "rate: Target rate cannot be greater than maximum rate."
- Just (Rate low _ high _) | low > high ->
- error "rate: Minimum rate cannot be greater than maximum rate."
- _ -> unStream (toStream m) (setStreamRate r st) stp sng yld
-
--- XXX implement for serial streams as well, as a simple delay
-
-{-
-{-# RULES "rate serial" rate = yieldRateSerial #-}
-yieldRateSerial :: Double -> SerialT m a -> SerialT m a
-yieldRateSerial _ = id
--}
-
--- | Same as @rate (Just $ Rate (r/2) r (2*r) maxBound)@
---
--- Specifies the average production rate of a stream in number of yields
--- per second (i.e. @Hertz@). Concurrent production is ramped up or down
--- automatically to achieve the specified average yield rate. The rate can
--- go down to half of the specified rate on the lower side and double of
--- the specified rate on the higher side.
---
--- @since 0.5.0
-avgRate :: IsStream t => Double -> t m a -> t m a
-avgRate r = rate (Just $ Rate (r/2) r (2*r) maxBound)
-
--- | Same as @rate (Just $ Rate r r (2*r) maxBound)@
---
--- Specifies the minimum rate at which the stream should yield values. As
--- far as possible the yield rate would never be allowed to go below the
--- specified rate, even though it may possibly go above it at times, the
--- upper limit is double of the specified rate.
---
--- @since 0.5.0
-minRate :: IsStream t => Double -> t m a -> t m a
-minRate r = rate (Just $ Rate r r (2*r) maxBound)
-
--- | Same as @rate (Just $ Rate (r/2) r r maxBound)@
---
--- Specifies the maximum rate at which the stream should yield values. As
--- far as possible the yield rate would never be allowed to go above the
--- specified rate, even though it may possibly go below it at times, the
--- lower limit is half of the specified rate. This can be useful in
--- applications where certain resource usage must not be allowed to go
--- beyond certain limits.
---
--- @since 0.5.0
-maxRate :: IsStream t => Double -> t m a -> t m a
-maxRate r = rate (Just $ Rate (r/2) r r maxBound)
-
--- | Same as @rate (Just $ Rate r r r 0)@
---
--- Specifies a constant yield rate. If for some reason the actual rate
--- goes above or below the specified rate we do not try to recover it by
--- increasing or decreasing the rate in future. This can be useful in
--- applications like graphics frame refresh where we need to maintain a
--- constant refresh rate.
---
--- @since 0.5.0
-constRate :: IsStream t => Double -> t m a -> t m a
-constRate r = rate (Just $ Rate r r r 0)
-
--- | Specify the average latency, in nanoseconds, of a single threaded action
--- in a concurrent composition. Streamly can measure the latencies, but that is
--- possible only after at least one task has completed. This combinator can be
--- used to provide a latency hint so that rate control using 'rate' can take
--- that into account right from the beginning. When not specified then a
--- default behavior is chosen which could be too slow or too fast, and would be
--- restricted by any other control parameters configured.
--- A value of 0 indicates default behavior, a negative value means there is no
--- limit i.e. zero latency.
--- This would normally be useful only in high latency and high throughput
--- cases.
---
-{-# INLINE_NORMAL _serialLatency #-}
-_serialLatency :: IsStream t => Int -> t m a -> t m a
-_serialLatency n m = fromStream $ Stream $ \st stp sng yld ->
- unStream (toStream m) (setStreamLatency n st) stp sng yld
-
-{-
-{-# RULES "serialLatency serial" _serialLatency = serialLatencySerial #-}
-serialLatencySerial :: Int -> SerialT m a -> SerialT m a
-serialLatencySerial _ = id
--}
-
--- Stop concurrent dispatches after this limit. This is useful in API's like
--- "take" where we want to dispatch only upto the number of elements "take"
--- needs. This value applies only to the immediate next level and is not
--- inherited by everything in enclosed scope.
-{-# INLINE_NORMAL maxYields #-}
-maxYields :: IsStream t => Maybe Int64 -> t m a -> t m a
-maxYields n m = fromStream $ Stream $ \st stp sng yld ->
- unStream (toStream m) (setYieldLimit n st) stp sng yld
-
-{-# RULES "maxYields serial" maxYields = maxYieldsSerial #-}
-maxYieldsSerial :: Maybe Int64 -> SerialT m a -> SerialT m a
-maxYieldsSerial _ = id
-
--- | Print debug information about an SVar when the stream ends
-inspectMode :: IsStream t => t m a -> t m a
-inspectMode m = fromStream $ Stream $ \st stp sng yld ->
- unStream (toStream m) (setInspectMode st) stp sng yld
diff --git a/src/Streamly/Streams/Serial.hs b/src/Streamly/Streams/Serial.hs
index ec7a5ba..97a0b16 100644
--- a/src/Streamly/Streams/Serial.hs
+++ b/src/Streamly/Streams/Serial.hs
@@ -5,6 +5,7 @@
{-# LANGUAGE GeneralizedNewtypeDeriving#-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-} -- XXX
-- |
@@ -23,7 +24,7 @@ module Streamly.Streams.Serial
SerialT
, StreamT -- deprecated
, Serial
- , serial
+ , K.serial
, serially
-- * Serial interleaving stream
@@ -41,6 +42,8 @@ module Streamly.Streams.Serial
)
where
+import Control.Applicative (liftA2)
+import Control.DeepSeq (NFData(..), NFData1(..), rnf1)
import Control.Monad (ap)
import Control.Monad.Base (MonadBase(..), liftBaseDefault)
import Control.Monad.Catch (MonadThrow, throwM)
@@ -49,16 +52,22 @@ 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 Data.Functor.Identity (Identity(..), runIdentity)
+import Data.Foldable (fold)
import Data.Semigroup (Semigroup(..))
+import GHC.Exts (IsList(..), IsString(..))
+import Text.Read (Lexeme(Ident), lexP, parens, prec, readPrec, readListPrec,
+ readListPrecDefault)
import Prelude hiding (map, mapM)
-import Streamly.SVar (rstState)
-import Streamly.Streams.StreamK (IsStream(..), adapt, Stream(..))
+import Streamly.Streams.StreamK (IsStream(..), adapt, Stream, mkStream,
+ foldStream)
+import qualified Streamly.Streams.Prelude as P
import qualified Streamly.Streams.StreamK as K
import qualified Streamly.Streams.StreamD as D
#include "Instances.hs"
-#include "inline.h"
+#include "inline.hs"
------------------------------------------------------------------------------
-- SerialT
@@ -140,34 +149,16 @@ type StreamT = SerialT
serially :: IsStream t => SerialT m a -> t m a
serially = adapt
+{-# INLINE consMSerial #-}
+{-# SPECIALIZE consMSerial :: IO a -> SerialT IO a -> SerialT IO a #-}
+consMSerial :: Monad m => m a -> SerialT m a -> SerialT m a
+consMSerial m ms = fromStream $ K.consMStream m (toStream ms)
+
instance IsStream SerialT where
toStream = getSerialT
fromStream = SerialT
-
- {-# INLINE consM #-}
- {-# SPECIALIZE consM :: IO a -> SerialT IO a -> SerialT IO a #-}
- consM :: Monad m => m a -> SerialT m a -> SerialT m a
- consM m r = fromStream $ K.consMSerial m (toStream r)
-
- {-# INLINE (|:) #-}
- {-# SPECIALIZE (|:) :: IO a -> SerialT IO a -> SerialT IO a #-}
- (|:) :: Monad m => m a -> SerialT m a -> SerialT m a
- m |: r = fromStream $ K.consMSerial m (toStream r)
-
-------------------------------------------------------------------------------
--- Semigroup
-------------------------------------------------------------------------------
-
--- | 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 $ Stream $ \st stp sng yld ->
- unStream (K.serial (toStream m1) (toStream m2))
- (rstState st) stp sng yld
+ consM = consMSerial
+ (|:) = consMSerial
------------------------------------------------------------------------------
-- Monad
@@ -175,11 +166,7 @@ serial m1 m2 = fromStream $ Stream $ \st stp sng yld ->
instance Monad m => Monad (SerialT m) where
return = pure
- (SerialT (Stream m)) >>= f = SerialT $ Stream $ \st stp sng yld ->
- let run x = unStream x (rstState st) stp sng yld
- single a = run $ toStream (f a)
- yieldk a r = run $ toStream $ f a <> (fromStream r >>= f)
- in m (rstState st) stp single yieldk
+ (>>=) = K.bindWith K.serial
------------------------------------------------------------------------------
-- Other instances
@@ -189,7 +176,17 @@ instance Monad m => Monad (SerialT m) where
mapM :: (IsStream t, Monad m) => (a -> m b) -> t m a -> t m b
mapM f m = fromStream $ D.toStreamK $ D.mapM f $ D.fromStreamK (toStream m)
--- | Same as 'fmap'.
+-- |
+-- @
+-- map = fmap
+-- @
+--
+-- Same as 'fmap'.
+--
+-- @
+-- > S.toList $ S.map (+1) $ S.fromList [1,2,3]
+-- [2,3,4]
+-- @
--
-- @since 0.4.0
{-# INLINE map #-}
@@ -198,6 +195,9 @@ map f = mapM (return . f)
MONAD_APPLICATIVE_INSTANCE(SerialT,)
MONAD_COMMON_INSTANCES(SerialT,)
+LIST_INSTANCES(SerialT)
+FOLDABLE_INSTANCE(SerialT)
+TRAVERSABLE_INSTANCE(SerialT)
------------------------------------------------------------------------------
-- WSerialT
@@ -267,6 +267,9 @@ wSerially = adapt
interleaving :: IsStream t => WSerialT m a -> t m a
interleaving = wSerially
+consMWSerial :: Monad m => m a -> WSerialT m a -> WSerialT m a
+consMWSerial m ms = fromStream $ K.consMStream m (toStream ms)
+
instance IsStream WSerialT where
toStream = getWSerialT
fromStream = WSerialT
@@ -274,34 +277,28 @@ instance IsStream WSerialT where
{-# INLINE consM #-}
{-# SPECIALIZE consM :: IO a -> WSerialT IO a -> WSerialT IO a #-}
consM :: Monad m => m a -> WSerialT m a -> WSerialT m a
- consM m r = fromStream $ K.consMSerial m (toStream r)
+ consM = consMWSerial
{-# INLINE (|:) #-}
{-# SPECIALIZE (|:) :: IO a -> WSerialT IO a -> WSerialT IO a #-}
(|:) :: Monad m => m a -> WSerialT m a -> WSerialT m a
- m |: r = fromStream $ K.consMSerial m (toStream r)
+ (|:) = consMWSerial
------------------------------------------------------------------------------
-- Semigroup
------------------------------------------------------------------------------
-{-# INLINE interleave #-}
-interleave :: Stream m a -> Stream m a -> Stream m a
-interleave m1 m2 = Stream $ \st stp sng yld -> do
- let stop = unStream m2 (rstState st) stp sng yld
- single a = yld a m2
- yieldk a r = yld a (interleave m2 r)
- unStream m1 (rstState st) stop single yieldk
-
-- | 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 $ Stream $ \st stp sng yld ->
- unStream (interleave (toStream m1) (toStream m2))
- (rstState st) stp sng yld
+wSerial m1 m2 = mkStream $ \st yld sng stp -> do
+ let stop = foldStream st yld sng stp m2
+ single a = yld a m2
+ yieldk a r = yld a (wSerial m2 r)
+ foldStream st yieldk single stop m1
instance Semigroup (WSerialT m a) where
(<>) = wSerial
@@ -330,11 +327,7 @@ instance Monoid (WSerialT m a) where
instance Monad m => Monad (WSerialT m) where
return = pure
- (WSerialT (Stream m)) >>= f = WSerialT $ Stream $ \st stp sng yld ->
- let run x = unStream x (rstState st) stp sng yld
- single a = run $ toStream (f a)
- yieldk a r = run $ toStream $ f a <> (fromStream r >>= f)
- in m (rstState st) stp single yieldk
+ (>>=) = K.bindWith wSerial
------------------------------------------------------------------------------
-- Other instances
@@ -342,3 +335,6 @@ instance Monad m => Monad (WSerialT m) where
MONAD_APPLICATIVE_INSTANCE(WSerialT,)
MONAD_COMMON_INSTANCES(WSerialT,)
+LIST_INSTANCES(WSerialT)
+FOLDABLE_INSTANCE(WSerialT)
+TRAVERSABLE_INSTANCE(WSerialT)
diff --git a/src/Streamly/Streams/StreamD.hs b/src/Streamly/Streams/StreamD.hs
index ee94ab4..498a0fc 100644
--- a/src/Streamly/Streams/StreamD.hs
+++ b/src/Streamly/Streams/StreamD.hs
@@ -5,13 +5,16 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RankNTypes #-}
-#include "inline.h"
+#include "inline.hs"
-- |
-- Module : Streamly.Streams.StreamD
-- Copyright : (c) 2018 Harendra Kumar
+-- Copyright : (c) Roman Leshchinskiy 2008-2010
--
-- License : BSD3
-- Maintainer : harendra.kumar@gmail.com
@@ -27,7 +30,7 @@
-- import qualified Streamly.Streams.StreamD as D
-- @
--- Some of functions in this file have been adapted from the vector
+-- Some of the functions in this file have been adapted from the vector
-- library, https://hackage.haskell.org/package/vector.
module Streamly.Streams.StreamD
@@ -51,7 +54,25 @@ module Streamly.Streams.StreamD
-- ** Specialized Generation
-- | Generate a monadic stream from a seed.
, repeat
- , enumFromStepN
+ , replicate
+ , replicateM
+ , fromIndices
+ , fromIndicesM
+ , generate
+ , generateM
+
+ -- ** Enumerations
+ , enumerateFromStepIntegral
+ , enumerateFromIntegral
+ , enumerateFromThenIntegral
+ , enumerateFromToIntegral
+ , enumerateFromThenToIntegral
+
+ , enumerateFromStepNum
+ , numFrom
+ , numFromThen
+ , enumerateFromToFractional
+ , enumerateFromThenToFractional
-- ** Conversions
-- | Transform an input structure into a stream.
@@ -61,11 +82,13 @@ module Streamly.Streams.StreamD
, fromList
, fromListM
, fromStreamK
+ , fromStreamD
-- * Elimination
-- ** General Folds
, foldr
, foldrM
+ , foldr1
, foldl'
, foldlM'
@@ -80,7 +103,21 @@ module Streamly.Streams.StreamD
, all
, any
, maximum
+ , maximumBy
, minimum
+ , minimumBy
+ , findIndices
+ , lookup
+ , findM
+ , find
+ , (!!)
+ , concatMapM
+ , concatMap
+
+ -- ** Substreams
+ , isPrefixOf
+ , isSubsequenceOf
+ , stripPrefix
-- ** Map and Fold
, mapM_
@@ -89,14 +126,30 @@ module Streamly.Streams.StreamD
-- | Transform a stream into another type.
, toList
, toStreamK
+ , toStreamD
-- * Transformation
-- ** By folding (scans)
, scanlM'
+ , scanl'
+ , scanlM
+ , scanl
+ , scanl1M'
+ , scanl1'
+ , scanl1M
+ , scanl1
+
+ , prescanl'
+ , prescanlM'
+ , postscanl
+ , postscanlM
+ , postscanl'
+ , postscanlM'
-- * Filtering
, filter
, filterM
+ , uniq
, take
, takeWhile
, takeWhileM
@@ -107,14 +160,34 @@ module Streamly.Streams.StreamD
-- * Mapping
, map
, mapM
+ , sequence
+
+ -- * Inserting
+ , insertBy
+
+ -- * Deleting
+ , deleteBy
-- ** Map and Filter
, mapMaybe
, mapMaybeM
-- * Zipping
+ , indexed
+ , indexedR
, zipWith
, zipWithM
+
+ -- * Comparisions
+ , eqBy
+ , cmpBy
+
+ -- * Merging
+ , mergeBy
+ , mergeByM
+
+ -- * Transformation comprehensions
+ , the
)
where
@@ -123,29 +196,13 @@ import GHC.Types ( SPEC(..) )
import Prelude
hiding (map, mapM, mapM_, repeat, foldr, last, take, filter,
takeWhile, drop, dropWhile, all, any, maximum, minimum, elem,
- notElem, null, head, tail, zipWith)
+ notElem, null, head, tail, zipWith, lookup, foldr1, sequence,
+ (!!), scanl, scanl1, concatMap, replicate, enumFromTo)
-import Streamly.SVar (MonadAsync, State(..), defState, rstState)
-import qualified Streamly.Streams.StreamK as K
+import Streamly.SVar (MonadAsync, defState, adaptState)
-------------------------------------------------------------------------------
--- The direct style stream type
-------------------------------------------------------------------------------
-
--- | A stream is a succession of 'Step's. A 'Yield' produces a single value and
--- the next state of the stream. 'Stop' indicates there are no more values in
--- the stream.
-data Step s a = Yield a s | Stop
-
-instance Functor (Step s) where
- {-# INLINE fmap #-}
- fmap f (Yield x s) = Yield (f x) s
- fmap _ Stop = Stop
-
--- gst = global state
--- | A stream consists of a step function that generates the next step given a
--- current state, and the current state.
-data Stream m a = forall s. Stream (State K.Stream m a -> s -> m (Step s a)) s
+import Streamly.Streams.StreamD.Type
+import qualified Streamly.Streams.StreamK as K
------------------------------------------------------------------------------
-- Construction
@@ -157,15 +214,19 @@ nil :: Monad m => Stream m a
nil = Stream (\_ _ -> return Stop) ()
-- | Can fuse but has O(n^2) complexity.
+{-# INLINE_NORMAL cons #-}
cons :: Monad m => a -> Stream m a -> Stream m a
cons x (Stream step state) = Stream step1 Nothing
where
+ {-# INLINE_LATE step1 #-}
step1 _ Nothing = return $ Yield x (Just state)
step1 gst (Just st) = do
- r <- step (rstState gst) st
- case r of
- Yield a s -> return $ Yield a (Just s)
- Stop -> return Stop
+ r <- step gst st
+ return $
+ case r of
+ Yield a s -> Yield a (Just s)
+ Skip s -> Skip (Just s)
+ Stop -> Stop
-------------------------------------------------------------------------------
-- Deconstruction
@@ -174,13 +235,14 @@ cons x (Stream step state) = Stream step1 Nothing
-- Does not fuse, has the same performance as the StreamK version.
{-# INLINE_NORMAL uncons #-}
uncons :: Monad m => Stream m a -> m (Maybe (a, Stream m a))
-uncons (Stream step state) = go state
+uncons (UnStream step state) = go state
where
go st = do
r <- step defState st
- return $ case r of
- Yield x s -> Just (x, Stream step s)
- Stop -> Nothing
+ case r of
+ Yield x s -> return $ Just (x, Stream step s)
+ Skip s -> go s
+ Stop -> return Nothing
------------------------------------------------------------------------------
-- Generation by unfold
@@ -208,14 +270,157 @@ unfoldr f = unfoldrM (return . f)
repeat :: Monad m => a -> Stream m a
repeat x = Stream (\_ _ -> return $ Yield x ()) ()
-{-# INLINE_NORMAL enumFromStepN #-}
-enumFromStepN :: (Num a, Monad m) => a -> a -> Int -> Stream m a
-enumFromStepN from stride n =
- from `seq` stride `seq` n `seq` Stream step (from, n)
+{-# INLINE_NORMAL replicateM #-}
+replicateM :: Monad m => Int -> m a -> Stream m a
+replicateM n p = Stream step n
+ where
+ {-# INLINE_LATE step #-}
+ step _ i | i <= 0 = return Stop
+ | otherwise = do
+ x <- p
+ return $ Yield x (i - 1)
+
+{-# INLINE_NORMAL replicate #-}
+replicate :: Monad m => Int -> a -> Stream m a
+replicate n x = replicateM n (return x)
+
+-- This would not work properly for floats, therefore we put an Integral
+-- constraint.
+-- | Can be used to enumerate unbounded integrals. This does not check for
+-- overflow or underflow for bounded integrals.
+{-# INLINE_NORMAL enumerateFromStepIntegral #-}
+enumerateFromStepIntegral :: (Integral a, Monad m) => a -> a -> Stream m a
+enumerateFromStepIntegral from stride =
+ from `seq` stride `seq` Stream step from
where
{-# INLINE_LATE step #-}
- step _ (x, i) | i > 0 = return $ Yield x (x + stride, i - 1)
- | otherwise = return Stop
+ step _ !x = return $ Yield x $! (x + stride)
+
+-- We are assuming that "to" is constrained by the type to be within
+-- max/min bounds.
+{-# INLINE enumerateFromToIntegral #-}
+enumerateFromToIntegral :: (Monad m, Integral a) => a -> a -> Stream m a
+enumerateFromToIntegral from to =
+ takeWhile (<= to) $ enumerateFromStepIntegral from 1
+
+{-# INLINE enumerateFromIntegral #-}
+enumerateFromIntegral :: (Monad m, Integral a, Bounded a) => a -> Stream m a
+enumerateFromIntegral from = enumerateFromToIntegral from maxBound
+
+data EnumState a = EnumInit | EnumYield a a a | EnumStop
+
+{-# INLINE_NORMAL enumerateFromThenToIntegralUp #-}
+enumerateFromThenToIntegralUp
+ :: (Monad m, Integral a)
+ => a -> a -> a -> Stream m a
+enumerateFromThenToIntegralUp from next to = Stream step EnumInit
+ where
+ {-# INLINE_LATE step #-}
+ step _ EnumInit =
+ return $
+ if to < next
+ then if to < from
+ then Stop
+ else Yield from EnumStop
+ else -- from <= next <= to
+ let stride = next - from
+ in Skip $ EnumYield from stride (to - stride)
+
+ step _ (EnumYield x stride toMinus) =
+ return $
+ if x > toMinus
+ then Yield x EnumStop
+ else Yield x $ EnumYield (x + stride) stride toMinus
+
+ step _ EnumStop = return Stop
+
+{-# INLINE_NORMAL enumerateFromThenToIntegralDn #-}
+enumerateFromThenToIntegralDn
+ :: (Monad m, Integral a)
+ => a -> a -> a -> Stream m a
+enumerateFromThenToIntegralDn from next to = Stream step EnumInit
+ where
+ {-# INLINE_LATE step #-}
+ step _ EnumInit =
+ return $ if to > next
+ then if to > from
+ then Stop
+ else Yield from EnumStop
+ else -- from >= next >= to
+ let stride = next - from
+ in Skip $ EnumYield from stride (to - stride)
+
+ step _ (EnumYield x stride toMinus) =
+ return $
+ if x < toMinus
+ then Yield x EnumStop
+ else Yield x $ EnumYield (x + stride) stride toMinus
+
+ step _ EnumStop = return Stop
+
+{-# INLINE_NORMAL enumerateFromThenToIntegral #-}
+enumerateFromThenToIntegral
+ :: (Monad m, Integral a)
+ => a -> a -> a -> Stream m a
+enumerateFromThenToIntegral from next to
+ | next >= from = enumerateFromThenToIntegralUp from next to
+ | otherwise = enumerateFromThenToIntegralDn from next to
+
+{-# INLINE_NORMAL enumerateFromThenIntegral #-}
+enumerateFromThenIntegral
+ :: (Monad m, Integral a, Bounded a)
+ => a -> a -> Stream m a
+enumerateFromThenIntegral from next =
+ if next > from
+ then enumerateFromThenToIntegralUp from next maxBound
+ else enumerateFromThenToIntegralDn from next minBound
+
+-- For floating point numbers if the increment is less than the precision then
+-- it just gets lost. Therefore we cannot always increment it correctly by just
+-- repeated addition.
+-- 9007199254740992 + 1 + 1 :: Double => 9.007199254740992e15
+-- 9007199254740992 + 2 :: Double => 9.007199254740994e15
+
+-- Instead we accumulate the increment counter and compute the increment
+-- everytime before adding it to the starting number.
+--
+-- This works for Integrals as well as floating point numbers, but
+-- enumerateFromStepIntegral is faster for integrals.
+{-# INLINE_NORMAL enumerateFromStepNum #-}
+enumerateFromStepNum :: (Monad m, Num a) => a -> a -> Stream m a
+enumerateFromStepNum from stride = Stream step 0
+ where
+ {-# INLINE_LATE step #-}
+ step _ !i = return $ (Yield $! (from + i * stride)) $! (i + 1)
+
+{-# INLINE_NORMAL numFrom #-}
+numFrom :: (Monad m, Num a) => a -> Stream m a
+numFrom from = enumerateFromStepNum from 1
+
+{-# INLINE_NORMAL numFromThen #-}
+numFromThen :: (Monad m, Num a) => a -> a -> Stream m a
+numFromThen from next = enumerateFromStepNum from (next - from)
+
+-- We cannot write a general function for Num. The only way to write code
+-- portable between the two is to use a 'Real' constraint and convert between
+-- Fractional and Integral using fromRational which is horribly slow.
+{-# INLINE_NORMAL enumerateFromToFractional #-}
+enumerateFromToFractional
+ :: (Monad m, Fractional a, Ord a)
+ => a -> a -> Stream m a
+enumerateFromToFractional from to =
+ takeWhile (<= to + 1 / 2) $ enumerateFromStepNum from 1
+
+{-# INLINE_NORMAL enumerateFromThenToFractional #-}
+enumerateFromThenToFractional
+ :: (Monad m, Fractional a, Ord a)
+ => a -> a -> a -> Stream m a
+enumerateFromThenToFractional from next to =
+ takeWhile predicate $ numFromThen from next
+ where
+ mid = (next - from) / 2
+ predicate | next >= from = (<= to + mid)
+ | otherwise = (>= to + mid)
-------------------------------------------------------------------------------
-- Generation by Conversion
@@ -239,6 +444,33 @@ yieldM m = Stream step True
step _ True = m >>= \x -> return $ Yield x False
step _ False = return Stop
+{-# INLINE_NORMAL fromIndicesM #-}
+fromIndicesM :: Monad m => (Int -> m a) -> Stream m a
+fromIndicesM gen = Stream step 0
+ where
+ {-# INLINE_LATE step #-}
+ step _ i = do
+ x <- gen i
+ return $ Yield x (i + 1)
+
+{-# INLINE fromIndices #-}
+fromIndices :: Monad m => (Int -> a) -> Stream m a
+fromIndices gen = fromIndicesM (return . gen)
+
+{-# INLINE_NORMAL generateM #-}
+generateM :: Monad m => Int -> (Int -> m a) -> Stream m a
+generateM n gen = n `seq` Stream step 0
+ where
+ {-# INLINE_LATE step #-}
+ step _ i | i < n = do
+ x <- gen i
+ return $ Yield x (i + 1)
+ | otherwise = return Stop
+
+{-# INLINE generate #-}
+generate :: Monad m => Int -> (Int -> a) -> Stream m a
+generate n gen = generateM n (return . gen)
+
-- XXX we need the MonadAsync constraint because of a rewrite rule.
-- | Convert a list of monadic actions to a 'Stream'
{-# INLINE_LATE fromListM #-}
@@ -258,7 +490,6 @@ fromList = Stream step
step _ (x:xs) = return $ Yield x xs
step _ [] = return Stop
--- XXX pass the state to streamD
{-# INLINE_LATE fromStreamK #-}
fromStreamK :: Monad m => K.Stream m a -> Stream m a
fromStreamK = Stream step
@@ -267,7 +498,11 @@ fromStreamK = Stream step
let stop = return Stop
single a = return $ Yield a K.nil
yieldk a r = return $ Yield a r
- in K.unStream m1 gst stop single yieldk
+ in K.foldStreamShared gst yieldk single stop m1
+
+{-# INLINE toStreamD #-}
+toStreamD :: (K.IsStream t, Monad m) => t m a -> Stream m a
+toStreamD = fromStreamK . K.toStream
------------------------------------------------------------------------------
-- Elimination by Folds
@@ -281,12 +516,21 @@ foldrM f z (Stream step state) = go SPEC state
r <- step defState st
case r of
Yield x s -> go SPEC s >>= f x
+ Skip s -> go SPEC s
Stop -> return z
{-# INLINE_NORMAL foldr #-}
foldr :: Monad m => (a -> b -> b) -> b -> Stream m a -> m b
foldr f = foldrM (\a b -> return (f a b))
+{-# INLINE_NORMAL foldr1 #-}
+foldr1 :: Monad m => (a -> a -> a) -> Stream m a -> m (Maybe a)
+foldr1 f m = do
+ r <- uncons m
+ case r of
+ Nothing -> return Nothing
+ Just (h, t) -> fmap Just (foldr f h t)
+
{-# INLINE_NORMAL foldlM' #-}
foldlM' :: Monad m => (b -> a -> m b) -> b -> Stream m a -> m b
foldlM' fstep begin (Stream step state) = go SPEC begin state
@@ -297,7 +541,8 @@ foldlM' fstep begin (Stream step state) = go SPEC begin state
Yield x s -> do
acc' <- fstep acc x
go SPEC acc' s
- Stop -> return acc
+ Skip s -> go SPEC acc s
+ Stop -> return acc
{-# INLINE foldl' #-}
foldl' :: Monad m => (b -> a -> b) -> b -> Stream m a -> m b
@@ -316,6 +561,7 @@ runStream (Stream step state) = go SPEC state
r <- step defState st
case r of
Yield _ s -> go SPEC s
+ Skip s -> go SPEC s
Stop -> return ()
{-# INLINE_NORMAL null #-}
@@ -326,7 +572,8 @@ null (Stream step state) = go state
r <- step defState st
case r of
Yield _ _ -> return False
- Stop -> return True
+ Skip s -> go s
+ Stop -> return True
-- XXX SPEC?
{-# INLINE_NORMAL head #-}
@@ -337,18 +584,20 @@ head (Stream step state) = go state
r <- step defState st
case r of
Yield x _ -> return (Just x)
- Stop -> return Nothing
+ Skip s -> go s
+ Stop -> return Nothing
-- Does not fuse, has the same performance as the StreamK version.
{-# INLINE_NORMAL tail #-}
tail :: Monad m => Stream m a -> m (Maybe (Stream m a))
-tail (Stream step state) = go state
+tail (UnStream step state) = go state
where
go st = do
r <- step defState st
case r of
Yield _ s -> return (Just $ Stream step s)
- Stop -> return Nothing
+ Skip s -> go s
+ Stop -> return Nothing
-- XXX will it fuse? need custom impl?
{-# INLINE_NORMAL last #-}
@@ -362,24 +611,15 @@ elem e (Stream step state) = go state
go st = do
r <- step defState st
case r of
- Yield x s ->
- if x == e
- then return True
- else go s
- Stop -> return False
+ Yield x s
+ | x == e -> return True
+ | otherwise -> go s
+ Skip s -> go s
+ Stop -> return False
{-# INLINE_NORMAL notElem #-}
notElem :: (Monad m, Eq a) => a -> Stream m a -> m Bool
-notElem e (Stream step state) = go state
- where
- go st = do
- r <- step defState st
- case r of
- Yield x s ->
- if x == e
- then return False
- else go s
- Stop -> return True
+notElem e s = fmap not (elem e s)
{-# INLINE_NORMAL all #-}
all :: Monad m => (a -> Bool) -> Stream m a -> m Bool
@@ -388,11 +628,11 @@ all p (Stream step state) = go state
go st = do
r <- step defState st
case r of
- Yield x s ->
- if p x
- then go s
- else return False
- Stop -> return True
+ Yield x s
+ | p x -> go s
+ | otherwise -> return False
+ Skip s -> go s
+ Stop -> return True
{-# INLINE_NORMAL any #-}
any :: Monad m => (a -> Bool) -> Stream m a -> m Bool
@@ -401,11 +641,11 @@ any p (Stream step state) = go state
go st = do
r <- step defState st
case r of
- Yield x s ->
- if p x
- then return True
- else go s
- Stop -> return False
+ Yield x s
+ | p x -> return True
+ | otherwise -> go s
+ Skip s -> go s
+ Stop -> return False
{-# INLINE_NORMAL maximum #-}
maximum :: (Monad m, Ord a) => Stream m a -> m (Maybe a)
@@ -415,15 +655,35 @@ maximum (Stream step state) = go Nothing state
r <- step defState st
case r of
Yield x s -> go (Just x) s
- Stop -> return Nothing
+ Skip s -> go Nothing s
+ Stop -> return Nothing
+ go (Just acc) st = do
+ r <- step defState st
+ case r of
+ Yield x s
+ | acc <= x -> go (Just x) s
+ | otherwise -> go (Just acc) s
+ Skip s -> go (Just acc) s
+ Stop -> return (Just acc)
+
+{-# INLINE_NORMAL maximumBy #-}
+maximumBy :: Monad m => (a -> a -> Ordering) -> Stream m a -> m (Maybe a)
+maximumBy cmp (Stream step state) = go Nothing state
+ where
+ go Nothing st = do
+ r <- step defState st
+ case r of
+ Yield x s -> go (Just x) s
+ Skip s -> go Nothing s
+ Stop -> return Nothing
go (Just acc) st = do
r <- step defState st
case r of
- Yield x s ->
- if acc <= x
- then go (Just x) s
- else go (Just acc) s
- Stop -> return (Just acc)
+ Yield x s -> case cmp acc x of
+ GT -> go (Just acc) s
+ _ -> go (Just x) s
+ Skip s -> go (Just acc) s
+ Stop -> return (Just acc)
{-# INLINE_NORMAL minimum #-}
minimum :: (Monad m, Ord a) => Stream m a -> m (Maybe a)
@@ -433,15 +693,187 @@ minimum (Stream step state) = go Nothing state
r <- step defState st
case r of
Yield x s -> go (Just x) s
- Stop -> return Nothing
+ Skip s -> go Nothing s
+ Stop -> return Nothing
go (Just acc) st = do
r <- step defState st
case r of
- Yield x s ->
- if acc <= x
- then go (Just acc) s
- else go (Just x) s
- Stop -> return (Just acc)
+ Yield x s
+ | acc <= x -> go (Just acc) s
+ | otherwise -> go (Just x) s
+ Skip s -> go (Just acc) s
+ Stop -> return (Just acc)
+
+{-# INLINE_NORMAL minimumBy #-}
+minimumBy :: Monad m => (a -> a -> Ordering) -> Stream m a -> m (Maybe a)
+minimumBy cmp (Stream step state) = go Nothing state
+ where
+ go Nothing st = do
+ r <- step defState st
+ case r of
+ Yield x s -> go (Just x) s
+ Skip s -> go Nothing s
+ Stop -> return Nothing
+ go (Just acc) st = do
+ r <- step defState st
+ case r of
+ Yield x s -> case cmp acc x of
+ GT -> go (Just x) s
+ _ -> go (Just acc) s
+ Skip s -> go (Just acc) s
+ Stop -> return (Just acc)
+
+{-# INLINE_NORMAL (!!) #-}
+(!!) :: (Monad m) => Stream m a -> Int -> m (Maybe a)
+(Stream step state) !! i = go i state
+ where
+ go n st = do
+ r <- step defState st
+ case r of
+ Yield x s | n < 0 -> return Nothing
+ | n == 0 -> return $ Just x
+ | otherwise -> go (n - 1) s
+ Skip s -> go n s
+ Stop -> return Nothing
+
+{-# INLINE_NORMAL lookup #-}
+lookup :: (Monad m, Eq a) => a -> Stream m (a, b) -> m (Maybe b)
+lookup e (Stream step state) = go state
+ where
+ go st = do
+ r <- step defState st
+ case r of
+ Yield (a, b) s -> if e == a then return (Just b) else go s
+ Skip s -> go s
+ Stop -> return Nothing
+
+{-# INLINE_NORMAL findM #-}
+findM :: Monad m => (a -> m Bool) -> Stream m a -> m (Maybe a)
+findM p (Stream step state) = go SPEC state
+ where
+ go !_ st = do
+ r <- step defState st
+ case r of
+ Yield x s -> do
+ b <- p x
+ if b then return (Just x) else go SPEC s
+ Skip s -> go SPEC s
+ Stop -> return Nothing
+
+{-# INLINE find #-}
+find :: Monad m => (a -> Bool) -> Stream m a -> m (Maybe a)
+find p = findM (return . p)
+
+{-# INLINE_NORMAL findIndices #-}
+findIndices :: Monad m => (a -> Bool) -> Stream m a -> Stream m Int
+findIndices p (Stream step state) = Stream step' (state, 0)
+ where
+ {-# INLINE_LATE step' #-}
+ step' gst (st, i) = do
+ r <- step (adaptState gst) st
+ return $ case r of
+ Yield x s -> if p x then Yield i (s, i+1) else Skip (s, i+1)
+ Skip s -> Skip (s, i+1)
+ Stop -> Stop
+
+{-# INLINE_NORMAL concatMapM #-}
+concatMapM :: Monad m => (a -> m (Stream m b)) -> Stream m a -> Stream m b
+concatMapM f (Stream step state) = Stream step' (Left state)
+ where
+ {-# INLINE_LATE step' #-}
+ step' gst (Left st) = do
+ r <- step (adaptState gst) st
+ case r of
+ Yield a s -> do
+ b_stream <- f a
+ return $ Skip (Right (b_stream, s))
+ Skip s -> return $ Skip (Left s)
+ Stop -> return Stop
+
+ -- XXX using the pattern synonym Stream causes a major performance issue
+ -- here even if the synonym does not include a adaptState call. Need to
+ -- find out why. Is that something to be fixed in GHC?
+ step' _ (Right (UnStream inner_step inner_st, st)) = do
+ r <- inner_step defState inner_st
+ case r of
+ Yield b inner_s ->
+ return $ Yield b (Right (Stream inner_step inner_s, st))
+ Skip inner_s ->
+ return $ Skip (Right (Stream inner_step inner_s, st))
+ Stop -> return $ Skip (Left st)
+
+{-# INLINE concatMap #-}
+concatMap :: Monad m => (a -> Stream m b) -> Stream m a -> Stream m b
+concatMap f = concatMapM (return . f)
+
+------------------------------------------------------------------------------
+-- Substreams
+------------------------------------------------------------------------------
+
+{-# INLINE_NORMAL isPrefixOf #-}
+isPrefixOf :: (Eq a, Monad m) => Stream m a -> Stream m a -> m Bool
+isPrefixOf (Stream stepa ta) (Stream stepb tb) = go (ta, tb, Nothing)
+ where
+ go (sa, sb, Nothing) = do
+ r <- stepa defState sa
+ case r of
+ Yield x sa' -> go (sa', sb, Just x)
+ Skip sa' -> go (sa', sb, Nothing)
+ Stop -> return True
+
+ go (sa, sb, Just x) = do
+ r <- stepb defState sb
+ case r of
+ Yield y sb' ->
+ if x == y
+ then go (sa, sb', Nothing)
+ else return False
+ Skip sb' -> go (sa, sb', Just x)
+ Stop -> return False
+
+{-# INLINE_NORMAL isSubsequenceOf #-}
+isSubsequenceOf :: (Eq a, Monad m) => Stream m a -> Stream m a -> m Bool
+isSubsequenceOf (Stream stepa ta) (Stream stepb tb) = go (ta, tb, Nothing)
+ where
+ go (sa, sb, Nothing) = do
+ r <- stepa defState sa
+ case r of
+ Yield x sa' -> go (sa', sb, Just x)
+ Skip sa' -> go (sa', sb, Nothing)
+ Stop -> return True
+
+ go (sa, sb, Just x) = do
+ r <- stepb defState sb
+ case r of
+ Yield y sb' ->
+ if x == y
+ then go (sa, sb', Nothing)
+ else go (sa, sb', Just x)
+ Skip sb' -> go (sa, sb', Just x)
+ Stop -> return False
+
+{-# INLINE_NORMAL stripPrefix #-}
+stripPrefix
+ :: (Eq a, Monad m)
+ => Stream m a -> Stream m a -> m (Maybe (Stream m a))
+stripPrefix (Stream stepa ta) (Stream stepb tb) = go (ta, tb, Nothing)
+ where
+ go (sa, sb, Nothing) = do
+ r <- stepa defState sa
+ case r of
+ Yield x sa' -> go (sa', sb, Just x)
+ Skip sa' -> go (sa', sb, Nothing)
+ Stop -> return $ Just (Stream stepb sb)
+
+ go (sa, sb, Just x) = do
+ r <- stepb defState sb
+ case r of
+ Yield y sb' ->
+ if x == y
+ then go (sa, sb', Nothing)
+ else return Nothing
+ Skip sb' -> go (sa, sb', Just x)
+ Stop -> return Nothing
------------------------------------------------------------------------------
-- Map and Fold
@@ -465,10 +897,11 @@ toList = foldr (:) []
toStreamK :: Monad m => Stream m a -> K.Stream m a
toStreamK (Stream step state) = go state
where
- go st = K.Stream $ \gst stp _ yld -> do
+ go st = K.mkStream $ \gst yld sng stp -> do
r <- step gst st
case r of
Yield x s -> yld x (go s)
+ Skip s -> K.foldStreamShared gst yld sng stp $ go s
Stop -> stp
#ifndef DISABLE_FUSION
@@ -478,10 +911,51 @@ toStreamK (Stream step state) = go state
forall s. fromStreamK (toStreamK s) = s #-}
#endif
+{-# INLINE fromStreamD #-}
+fromStreamD :: (K.IsStream t, Monad m) => Stream m a -> t m a
+fromStreamD = K.fromStream . toStreamK
+
------------------------------------------------------------------------------
-- Transformation by Folding (Scans)
------------------------------------------------------------------------------
+-- XXX Is a prescan useful, discarding the last step does not sound useful? I
+-- am not sure about the utility of this function, so this is implemented but
+-- not exposed. We can expose it if someone provides good reasons why this is
+-- useful.
+--
+-- XXX We have to execute the stream one step ahead to know that we are at the
+-- last step. The vector implementation of prescan executes the last fold step
+-- but does not yield the result. This means we have executed the effect but
+-- discarded value. This does not sound right. In this implementation we are
+-- not executing the last fold step.
+{-# INLINE_NORMAL prescanlM' #-}
+prescanlM' :: Monad m => (b -> a -> m b) -> m b -> Stream m a -> Stream m b
+prescanlM' f mz (Stream step state) = Stream step' (state, mz)
+ where
+ {-# INLINE_LATE step' #-}
+ step' gst (st, prev) = do
+ r <- step (adaptState gst) st
+ case r of
+ Yield x s -> do
+ acc <- prev
+ return $ Yield acc (s, f acc x)
+ Skip s -> return $ Skip (s, prev)
+ Stop -> return Stop
+
+{-# INLINE prescanl' #-}
+prescanl' :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b
+prescanl' f z = prescanlM' (\a b -> return (f a b)) (return z)
+
+-- XXX if we make the initial value of the accumulator monadic then should we
+-- execute it even if the stream is empty? In that case we would have generated
+-- the effect but discarded the value, but that is what a fold does when the
+-- stream is empty. Whatever we decide, need to reconcile this with prescan.
+-- If we execute the initial value here without even using it then it is ok to
+-- execute the last step there as well without using the value.
+-- Looking at the duality with right fold, in case of right fold we always
+-- perform the action when the construction terminates, so in case of left fold
+-- we should perform it only when the reduction starts.
{-# INLINE_NORMAL postscanlM' #-}
postscanlM' :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b
postscanlM' fstep begin (Stream step state) =
@@ -489,17 +963,102 @@ postscanlM' fstep begin (Stream step state) =
where
{-# INLINE_LATE step' #-}
step' gst (st, acc) = acc `seq` do
- r <- step (rstState gst) st
+ r <- step (adaptState gst) st
case r of
Yield x s -> do
y <- fstep acc x
y `seq` return (Yield y (s, y))
- Stop -> return Stop
+ Skip s -> return $ Skip (s, acc)
+ Stop -> return Stop
+
+{-# INLINE_NORMAL postscanl' #-}
+postscanl' :: Monad m => (a -> b -> a) -> a -> Stream m b -> Stream m a
+postscanl' f = postscanlM' (\a b -> return (f a b))
-{-# INLINE scanlM' #-}
+{-# INLINE_NORMAL postscanlM #-}
+postscanlM :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b
+postscanlM fstep begin (Stream step state) = Stream step' (state, begin)
+ where
+ {-# INLINE_LATE step' #-}
+ step' gst (st, acc) = do
+ r <- step (adaptState gst) st
+ case r of
+ Yield x s -> do
+ y <- fstep acc x
+ return (Yield y (s, y))
+ Skip s -> return $ Skip (s, acc)
+ Stop -> return Stop
+
+{-# INLINE_NORMAL postscanl #-}
+postscanl :: Monad m => (a -> b -> a) -> a -> Stream m b -> Stream m a
+postscanl f = postscanlM (\a b -> return (f a b))
+
+{-# INLINE_NORMAL scanlM' #-}
scanlM' :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b
scanlM' fstep begin s = begin `seq` (begin `cons` postscanlM' fstep begin s)
+{-# INLINE scanl' #-}
+scanl' :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b
+scanl' f = scanlM' (\a b -> return (f a b))
+
+{-# INLINE_NORMAL scanlM #-}
+scanlM :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b
+scanlM fstep begin s = begin `cons` postscanlM fstep begin s
+
+{-# INLINE scanl #-}
+scanl :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b
+scanl f = scanlM (\a b -> return (f a b))
+
+{-# INLINE_NORMAL scanl1M #-}
+scanl1M :: Monad m => (a -> a -> m a) -> Stream m a -> Stream m a
+scanl1M fstep (Stream step state) = Stream step' (state, Nothing)
+ where
+ {-# INLINE_LATE step' #-}
+ step' gst (st, Nothing) = do
+ r <- step gst st
+ case r of
+ Yield x s -> return $ Yield x (s, Just x)
+ Skip s -> return $ Skip (s, Nothing)
+ Stop -> return Stop
+
+ step' gst (st, Just acc) = do
+ r <- step gst st
+ case r of
+ Yield y s -> do
+ z <- fstep acc y
+ return $ Yield z (s, Just z)
+ Skip s -> return $ Skip (s, Just acc)
+ Stop -> return Stop
+
+{-# INLINE scanl1 #-}
+scanl1 :: Monad m => (a -> a -> a) -> Stream m a -> Stream m a
+scanl1 f = scanl1M (\x y -> return (f x y))
+
+{-# INLINE_NORMAL scanl1M' #-}
+scanl1M' :: Monad m => (a -> a -> m a) -> Stream m a -> Stream m a
+scanl1M' fstep (Stream step state) = Stream step' (state, Nothing)
+ where
+ {-# INLINE_LATE step' #-}
+ step' gst (st, Nothing) = do
+ r <- step gst st
+ case r of
+ Yield x s -> x `seq` return $ Yield x (s, Just x)
+ Skip s -> return $ Skip (s, Nothing)
+ Stop -> return Stop
+
+ step' gst (st, Just acc) = acc `seq` do
+ r <- step gst st
+ case r of
+ Yield y s -> do
+ z <- fstep acc y
+ z `seq` return $ Yield z (s, Just z)
+ Skip s -> return $ Skip (s, Just acc)
+ Stop -> return Stop
+
+{-# INLINE scanl1' #-}
+scanl1' :: Monad m => (a -> a -> a) -> Stream m a -> Stream m a
+scanl1' f = scanl1M' (\x y -> return (f x y))
+
-------------------------------------------------------------------------------
-- Filtering
-------------------------------------------------------------------------------
@@ -510,9 +1069,10 @@ take n (Stream step state) = n `seq` Stream step' (state, 0)
where
{-# INLINE_LATE step' #-}
step' gst (st, i) | i < n = do
- r <- step (rstState gst) st
+ r <- step gst st
return $ case r of
Yield x s -> Yield x (s, i + 1)
+ Skip s -> Skip (s, i)
Stop -> Stop
step' _ (_, _) = return Stop
@@ -522,12 +1082,13 @@ takeWhileM f (Stream step state) = Stream step' state
where
{-# INLINE_LATE step' #-}
step' gst st = do
- r <- step (rstState gst) st
+ r <- step gst st
case r of
Yield x s -> do
b <- f x
return $ if b then Yield x s else Stop
- Stop -> return Stop
+ Skip s -> return $ Skip s
+ Stop -> return Stop
{-# INLINE takeWhile #-}
takeWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a
@@ -535,15 +1096,26 @@ takeWhile f = takeWhileM (return . f)
{-# INLINE_NORMAL drop #-}
drop :: Monad m => Int -> Stream m a -> Stream m a
-drop n (Stream step state) = Stream step' (state, n)
+drop n (Stream step state) = Stream step' (state, Just n)
where
{-# INLINE_LATE step' #-}
- step' gst (st, i) = do
- r <- step (rstState gst) st
+ step' gst (st, Just i)
+ | i > 0 = do
+ r <- step gst st
+ return $
+ case r of
+ Yield _ s -> Skip (s, Just (i - 1))
+ Skip s -> Skip (s, Just i)
+ Stop -> Stop
+ | otherwise = return $ Skip (st, Nothing)
+
+ step' gst (st, Nothing) = do
+ r <- step gst st
+ return $
case r of
- Yield _ s | i > 0 -> step' gst (s, i - 1)
- Yield x s -> return $ Yield x (s, 0)
- Stop -> return Stop
+ Yield x s -> Yield x (s, Nothing)
+ Skip s -> Skip (s, Nothing)
+ Stop -> Stop
data DropWhileState s a
= DropWhileDrop s
@@ -556,19 +1128,21 @@ dropWhileM f (Stream step state) = Stream step' (DropWhileDrop state)
where
{-# INLINE_LATE step' #-}
step' gst (DropWhileDrop st) = do
- r <- step (rstState gst) st
+ r <- step gst st
case r of
Yield x s -> do
b <- f x
if b
- then step' gst (DropWhileDrop s)
- else step' gst (DropWhileYield x s)
+ then return $ Skip (DropWhileDrop s)
+ else return $ Skip (DropWhileYield x s)
+ Skip s -> return $ Skip (DropWhileDrop s)
Stop -> return Stop
step' gst (DropWhileNext st) = do
- r <- step (rstState gst) st
+ r <- step gst st
case r of
- Yield x s -> step' gst (DropWhileYield x s)
+ Yield x s -> return $ Skip (DropWhileYield x s)
+ Skip s -> return $ Skip (DropWhileNext s)
Stop -> return Stop
step' _ (DropWhileYield x st) = return $ Yield x (DropWhileNext st)
@@ -583,38 +1157,105 @@ filterM f (Stream step state) = Stream step' state
where
{-# INLINE_LATE step' #-}
step' gst st = do
- r <- step (rstState gst) st
+ r <- step gst st
case r of
Yield x s -> do
b <- f x
- if b
- then return $ Yield x s
- else step' gst s
- Stop -> return Stop
+ return $ if b
+ then Yield x s
+ else Skip s
+ Skip s -> return $ Skip s
+ Stop -> return Stop
{-# INLINE filter #-}
filter :: Monad m => (a -> Bool) -> Stream m a -> Stream m a
filter f = filterM (return . f)
+{-# INLINE_NORMAL uniq #-}
+uniq :: (Eq a, Monad m) => Stream m a -> Stream m a
+uniq (Stream step state) = Stream step' (Nothing, state)
+ where
+ {-# INLINE_LATE step' #-}
+ step' gst (Nothing, st) = do
+ r <- step gst st
+ case r of
+ Yield x s -> return $ Yield x (Just x, s)
+ Skip s -> return $ Skip (Nothing, s)
+ Stop -> return Stop
+ step' gst (Just x, st) = do
+ r <- step gst st
+ case r of
+ Yield y s | x == y -> return $ Skip (Just x, s)
+ | otherwise -> return $ Yield x (Just y, s)
+ Skip s -> return $ Skip (Just x, s)
+ Stop -> return Stop
+
------------------------------------------------------------------------------
-- Transformation by Mapping
------------------------------------------------------------------------------
--- | Map a monadic function over a 'Stream'
-{-# INLINE_NORMAL mapM #-}
-mapM :: Monad m => (a -> m b) -> Stream m a -> Stream m b
-mapM f (Stream step state) = Stream step' state
+{-# INLINE_NORMAL sequence #-}
+sequence :: Monad m => Stream m (m a) -> Stream m a
+sequence (Stream step state) = Stream step' state
where
{-# INLINE_LATE step' #-}
step' gst st = do
- r <- step (rstState gst) st
+ r <- step (adaptState gst) st
+ case r of
+ Yield x s -> x >>= \a -> return (Yield a s)
+ Skip s -> return $ Skip s
+ Stop -> return Stop
+
+------------------------------------------------------------------------------
+-- Inserting
+------------------------------------------------------------------------------
+
+{-# INLINE_NORMAL insertBy #-}
+insertBy :: Monad m => (a -> a -> Ordering) -> a -> Stream m a -> Stream m a
+insertBy cmp a (Stream step state) = Stream step' (state, False, Nothing)
+ where
+ {-# INLINE_LATE step' #-}
+ step' gst (st, False, _) = do
+ r <- step gst st
case r of
- Yield x s -> f x >>= \a -> return $ Yield a s
- Stop -> return Stop
+ Yield x s -> case cmp a x of
+ GT -> return $ Yield x (s, False, Nothing)
+ _ -> return $ Yield a (s, True, Just x)
+ Skip s -> return $ Skip (s, False, Nothing)
+ Stop -> return $ Yield a (st, True, Nothing)
+
+ step' _ (_, True, Nothing) = return Stop
+
+ step' gst (st, True, Just prev) = do
+ r <- step gst st
+ case r of
+ Yield x s -> return $ Yield prev (s, True, Just x)
+ Skip s -> return $ Skip (s, True, Just prev)
+ Stop -> return $ Yield prev (st, True, Nothing)
+
+------------------------------------------------------------------------------
+-- Deleting
+------------------------------------------------------------------------------
+
+{-# INLINE_NORMAL deleteBy #-}
+deleteBy :: Monad m => (a -> a -> Bool) -> a -> Stream m a -> Stream m a
+deleteBy eq x (Stream step state) = Stream step' (state, False)
+ where
+ {-# INLINE_LATE step' #-}
+ step' gst (st, False) = do
+ r <- step gst st
+ case r of
+ Yield y s -> return $
+ if eq x y then Skip (s, True) else Yield y (s, False)
+ Skip s -> return $ Skip (s, False)
+ Stop -> return Stop
-{-# INLINE map #-}
-map :: Monad m => (a -> b) -> Stream m a -> Stream m b
-map f = mapM (return . f)
+ step' gst (st, True) = do
+ r <- step gst st
+ case r of
+ Yield y s -> return $ Yield y (s, True)
+ Skip s -> return $ Skip (s, True)
+ Stop -> return Stop
------------------------------------------------------------------------------
-- Transformation by Map and Filter
@@ -630,9 +1271,35 @@ mapMaybeM :: Monad m => (a -> m (Maybe b)) -> Stream m a -> Stream m b
mapMaybeM f = fmap fromJust . filter isJust . mapM f
------------------------------------------------------------------------------
--- Instances
+-- Zipping
------------------------------------------------------------------------------
+{-# INLINE_NORMAL indexed #-}
+indexed :: Monad m => Stream m a -> Stream m (Int, a)
+indexed (Stream step state) = Stream step' (state, 0)
+ where
+ {-# INLINE_LATE step' #-}
+ step' gst (st, i) = i `seq` do
+ r <- step (adaptState gst) st
+ case r of
+ Yield x s -> return $ Yield (i, x) (s, i+1)
+ Skip s -> return $ Skip (s, i)
+ Stop -> return Stop
+
+{-# INLINE_NORMAL indexedR #-}
+indexedR :: Monad m => Int -> Stream m a -> Stream m (Int, a)
+indexedR m (Stream step state) = Stream step' (state, m)
+ where
+ {-# INLINE_LATE step' #-}
+ step' gst (st, i) = i `seq` do
+ r <- step (adaptState gst) st
+ case r of
+ Yield x s -> let i' = i - 1
+ in
+ return $ Yield (i', x) (s, i')
+ Skip s -> return $ Skip (s, i)
+ Stop -> return Stop
+
{-# INLINE_NORMAL zipWithM #-}
zipWithM :: Monad m
=> (a -> b -> m c) -> Stream m a -> Stream m b -> Stream m c
@@ -640,18 +1307,21 @@ zipWithM f (Stream stepa ta) (Stream stepb tb) = Stream step (ta, tb, Nothing)
where
{-# INLINE_LATE step #-}
step gst (sa, sb, Nothing) = do
- r <- stepa (rstState gst) sa
- case r of
- Yield x sa' -> step gst (sa', sb, Just x)
- Stop -> return Stop
+ r <- stepa (adaptState gst) sa
+ return $
+ case r of
+ Yield x sa' -> Skip (sa', sb, Just x)
+ Skip sa' -> Skip (sa', sb, Nothing)
+ Stop -> Stop
step gst (sa, sb, Just x) = do
- r <- stepb (rstState gst) sb
+ r <- stepb (adaptState gst) sb
case r of
Yield y sb' -> do
z <- f x y
return $ Yield z (sa, sb', Nothing)
- Stop -> return Stop
+ Skip sb' -> return $ Skip (sa, sb', Just x)
+ Stop -> return Stop
{-# RULES "zipWithM xs xs"
forall f xs. zipWithM f xs xs = mapM (\x -> f x x) xs #-}
@@ -661,9 +1331,134 @@ zipWith :: Monad m => (a -> b -> c) -> Stream m a -> Stream m b -> Stream m c
zipWith f = zipWithM (\a b -> return (f a b))
------------------------------------------------------------------------------
--- Instances
+-- Comparisions
------------------------------------------------------------------------------
-instance Monad m => Functor (Stream m) where
- {-# INLINE fmap #-}
- fmap = map
+{-# INLINE_NORMAL eqBy #-}
+eqBy :: Monad m => (a -> b -> Bool) -> Stream m a -> Stream m b -> m Bool
+eqBy eq (Stream step1 t1) (Stream step2 t2) = eq_loop0 SPEC t1 t2
+ where
+ eq_loop0 !_ s1 s2 = do
+ r <- step1 defState s1
+ case r of
+ Yield x s1' -> eq_loop1 SPEC x s1' s2
+ Skip s1' -> eq_loop0 SPEC s1' s2
+ Stop -> eq_null s2
+
+ eq_loop1 !_ x s1 s2 = do
+ r <- step2 defState s2
+ case r of
+ Yield y s2'
+ | eq x y -> eq_loop0 SPEC s1 s2'
+ | otherwise -> return False
+ Skip s2' -> eq_loop1 SPEC x s1 s2'
+ Stop -> return False
+
+ eq_null s2 = do
+ r <- step2 defState s2
+ case r of
+ Yield _ _ -> return False
+ Skip s2' -> eq_null s2'
+ Stop -> return True
+
+-- | Compare two streams lexicographically
+{-# INLINE_NORMAL cmpBy #-}
+cmpBy
+ :: Monad m
+ => (a -> b -> Ordering) -> Stream m a -> Stream m b -> m Ordering
+cmpBy cmp (Stream step1 t1) (Stream step2 t2) = cmp_loop0 SPEC t1 t2
+ where
+ cmp_loop0 !_ s1 s2 = do
+ r <- step1 defState s1
+ case r of
+ Yield x s1' -> cmp_loop1 SPEC x s1' s2
+ Skip s1' -> cmp_loop0 SPEC s1' s2
+ Stop -> cmp_null s2
+
+ cmp_loop1 !_ x s1 s2 = do
+ r <- step2 defState s2
+ case r of
+ Yield y s2' -> case x `cmp` y of
+ EQ -> cmp_loop0 SPEC s1 s2'
+ c -> return c
+ Skip s2' -> cmp_loop1 SPEC x s1 s2'
+ Stop -> return GT
+
+ cmp_null s2 = do
+ r <- step2 defState s2
+ case r of
+ Yield _ _ -> return LT
+ Skip s2' -> cmp_null s2'
+ Stop -> return EQ
+
+------------------------------------------------------------------------------
+-- Merging
+------------------------------------------------------------------------------
+
+{-# INLINE_NORMAL mergeByM #-}
+mergeByM
+ :: (Monad m)
+ => (a -> a -> m Ordering) -> Stream m a -> Stream m a -> Stream m a
+mergeByM cmp (Stream stepa ta) (Stream stepb tb) =
+ Stream step (Just ta, Just tb, Nothing, Nothing)
+ where
+ {-# INLINE_LATE step #-}
+
+ -- one of the values is missing, and the corresponding stream is running
+ step gst (Just sa, sb, Nothing, b) = do
+ r <- stepa gst sa
+ return $ case r of
+ Yield a sa' -> Skip (Just sa', sb, Just a, b)
+ Skip sa' -> Skip (Just sa', sb, Nothing, b)
+ Stop -> Skip (Nothing, sb, Nothing, b)
+
+ step gst (sa, Just sb, a, Nothing) = do
+ r <- stepb gst sb
+ return $ case r of
+ Yield b sb' -> Skip (sa, Just sb', a, Just b)
+ Skip sb' -> Skip (sa, Just sb', a, Nothing)
+ Stop -> Skip (sa, Nothing, a, Nothing)
+
+ -- both the values are available
+ step _ (sa, sb, Just a, Just b) = do
+ res <- cmp a b
+ return $ case res of
+ GT -> Yield b (sa, sb, Just a, Nothing)
+ _ -> Yield a (sa, sb, Nothing, Just b)
+
+ -- one of the values is missing, corresponding stream is done
+ step _ (Nothing, sb, Nothing, Just b) =
+ return $ Yield b (Nothing, sb, Nothing, Nothing)
+
+ step _ (sa, Nothing, Just a, Nothing) =
+ return $ Yield a (sa, Nothing, Nothing, Nothing)
+
+ step _ (Nothing, Nothing, Nothing, Nothing) = return Stop
+
+{-# INLINE mergeBy #-}
+mergeBy
+ :: (Monad m)
+ => (a -> a -> Ordering) -> Stream m a -> Stream m a -> Stream m a
+mergeBy cmp = mergeByM (\a b -> return $ cmp a b)
+
+------------------------------------------------------------------------------
+-- Transformation comprehensions
+------------------------------------------------------------------------------
+
+{-# INLINE_NORMAL the #-}
+the :: (Eq a, Monad m) => Stream m a -> m (Maybe a)
+the (Stream step state) = go state
+ where
+ go st = do
+ r <- step defState st
+ case r of
+ Yield x s -> go' x s
+ Skip s -> go s
+ Stop -> return Nothing
+ go' n st = do
+ r <- step defState st
+ case r of
+ Yield x s | x == n -> go' n s
+ | otherwise -> return Nothing
+ Skip s -> go' n s
+ Stop -> return (Just n)
diff --git a/src/Streamly/Streams/StreamD/Type.hs b/src/Streamly/Streams/StreamD/Type.hs
new file mode 100644
index 0000000..f42ed3f
--- /dev/null
+++ b/src/Streamly/Streams/StreamD/Type.hs
@@ -0,0 +1,100 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE RankNTypes #-}
+
+#include "../inline.hs"
+
+-- |
+-- Module : Streamly.Streams.StreamD.Type
+-- Copyright : (c) 2018 Harendra Kumar
+--
+-- License : BSD3
+-- Maintainer : harendra.kumar@gmail.com
+-- Stability : experimental
+-- Portability : GHC
+
+module Streamly.Streams.StreamD.Type
+ (
+ -- * The stream type
+ Step (..)
+ -- XXX UnStream is exported to avoid a performance issue in concatMap if we
+ -- use the pattern synonym "Stream".
+#if __GLASGOW_HASKELL__ >= 800
+ , Stream (Stream, UnStream)
+#else
+ , Stream (UnStream)
+ , pattern Stream
+#endif
+ , map
+ , mapM
+ )
+where
+
+import Streamly.SVar (State(..), adaptState)
+import qualified Streamly.Streams.StreamK as K
+import Prelude hiding (map, mapM)
+
+------------------------------------------------------------------------------
+-- The direct style stream type
+------------------------------------------------------------------------------
+
+-- | A stream is a succession of 'Step's. A 'Yield' produces a single value and
+-- the next state of the stream. 'Stop' indicates there are no more values in
+-- the stream.
+data Step s a = Yield a s | Skip s | Stop
+
+instance Functor (Step s) where
+ {-# INLINE fmap #-}
+ fmap f (Yield x s) = Yield (f x) s
+ fmap _ (Skip s) = Skip s
+ fmap _ Stop = Stop
+
+-- gst = global state
+-- | A stream consists of a step function that generates the next step given a
+-- current state, and the current state.
+data Stream m a =
+ forall s. UnStream (State K.Stream m a -> s -> m (Step s a)) s
+
+unShare :: Stream m a -> Stream m a
+unShare (UnStream step state) = UnStream step' state
+ where step' gst = step (adaptState gst)
+
+pattern Stream :: (State K.Stream m a -> s -> m (Step s a)) -> s -> Stream m a
+pattern Stream step state <- (unShare -> UnStream step state)
+ where Stream = UnStream
+
+#if __GLASGOW_HASKELL__ >= 802
+{-# COMPLETE Stream #-}
+#endif
+
+------------------------------------------------------------------------------
+-- Instances
+------------------------------------------------------------------------------
+
+-- | Map a monadic function over a 'Stream'
+{-# INLINE_NORMAL mapM #-}
+mapM :: Monad m => (a -> m b) -> Stream m a -> Stream m b
+mapM f (Stream step state) = Stream step' state
+ where
+ {-# INLINE_LATE step' #-}
+ step' gst st = do
+ r <- step (adaptState gst) st
+ case r of
+ Yield x s -> f x >>= \a -> return $ Yield a s
+ Skip s -> return $ Skip s
+ Stop -> return Stop
+
+{-# INLINE map #-}
+map :: Monad m => (a -> b) -> Stream m a -> Stream m b
+map f = mapM (return . f)
+
+instance Monad m => Functor (Stream m) where
+ {-# INLINE fmap #-}
+ fmap = map
diff --git a/src/Streamly/Streams/StreamK.hs b/src/Streamly/Streams/StreamK.hs
index 9c6a4d3..ae9f2e9 100644
--- a/src/Streamly/Streams/StreamK.hs
+++ b/src/Streamly/Streams/StreamK.hs
@@ -6,8 +6,11 @@
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-} -- XXX
+#include "inline.hs"
+
-- |
-- Module : Streamly.Streams.StreamK
-- Copyright : (c) 2017 Harendra Kumar
@@ -32,22 +35,21 @@ module Streamly.Streams.StreamK
, adapt
-- * The stream type
- , Stream (..)
- , unStreamIsolated
- , isolateStream
- , unstreamShared
- , runStreamSVar
+ , Stream
- -- * Construction
+ -- * Construction Primitives
, mkStream
, nil
, cons
, (.:)
- -- * Asynchronous construction
- , nilK
- , yieldK
- , consK
+ -- * Elimination Primitives
+ , foldStream
+ , foldStreamShared
+ , foldStreamSVar
+
+ -- * Transformation Primitives
+ , unShare
-- * Deconstruction
, uncons
@@ -59,6 +61,8 @@ module Streamly.Streams.StreamK
-- ** Specialized Generation
, repeat
+ , replicate
+ , replicateM
-- ** Conversions
, yield
@@ -69,7 +73,6 @@ module Streamly.Streams.StreamK
-- * Elimination
-- ** General Folds
- , foldStream
, foldr
, foldrM
, foldr1
@@ -90,10 +93,14 @@ module Streamly.Streams.StreamK
, any
, last
, minimum
+ , minimumBy
, maximum
+ , maximumBy
, findIndices
, lookup
+ , findM
, find
+ , (!!)
-- ** Map and Fold
, mapM_
@@ -121,6 +128,10 @@ module Streamly.Streams.StreamK
-- ** Inserting
, intersperseM
+ , insertBy
+
+ -- ** Deleting
+ , deleteBy
-- ** Map and Filter
, mapMaybe
@@ -129,11 +140,18 @@ module Streamly.Streams.StreamK
, zipWith
, zipWithM
+ -- ** Merging
+ , mergeBy
+ , mergeByM
+
+ -- ** Transformation comprehensions
+ , the
+
-- * Semigroup Style Composition
, serial
-- * Utilities
- , consMSerial
+ , consMStream
, bindWith
, withLocal
@@ -144,194 +162,27 @@ module Streamly.Streams.StreamK
where
import Control.Monad (void)
-import Control.Monad.IO.Class (MonadIO(liftIO))
import Control.Monad.Reader.Class (MonadReader(..))
-import Control.Monad.Trans.Class (MonadTrans(lift))
-import Data.Semigroup (Semigroup(..))
import Prelude
hiding (foldl, foldr, last, map, mapM, mapM_, repeat, sequence,
take, filter, all, any, takeWhile, drop, dropWhile, minimum,
maximum, elem, notElem, null, head, tail, init, zipWith, lookup,
- foldr1)
+ foldr1, (!!), replicate)
import qualified Prelude
import Streamly.SVar
+import Streamly.Streams.StreamK.Type
-------------------------------------------------------------------------------
--- The basic stream type
-------------------------------------------------------------------------------
-
--- | The type @Stream m a@ represents a monadic stream of values of type 'a'
--- constructed using actions in monad 'm'. It uses stop, singleton and yield
--- continuations equivalent to the following direct style type:
---
--- @
--- data Stream m a = Stop | Singleton a | Yield a (Stream m a)
--- @
---
--- 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.
---
--- 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 {
- unStream :: forall r.
- State Stream m a -- state
- -> m r -- stop
- -> (a -> m r) -- singleton
- -> (a -> Stream m a -> m r) -- yield
- -> m r
- }
-
--- XXX make this the default "unStream"
--- | unwraps the Stream type producing the stream function that can be run with
--- continuations.
-{-# INLINE unStreamIsolated #-}
-unStreamIsolated ::
- Stream m a
- -> State Stream m a -- state
- -> m r -- stop
- -> (a -> m r) -- singleton
- -> (a -> Stream m a -> m r) -- yield
- -> m r
-unStreamIsolated x st = unStream x (rstState st)
-
-{-# INLINE isolateStream #-}
-isolateStream :: Stream m a -> Stream m a
-isolateStream x = Stream $ \st stp sng yld ->
- unStreamIsolated x st stp sng yld
-
--- | Like unstream, but passes a shared SVar across continuations.
-{-# INLINE unstreamShared #-}
-unstreamShared ::
- Stream m a
- -> State Stream m a -- state
- -> m r -- stop
- -> (a -> m r) -- singleton
- -> (a -> Stream m a -> m r) -- yield
- -> m r
-unstreamShared = unStream
-
--- Run the stream using a run function associated with the SVar that runs the
--- streams with a captured snapshot of the monadic state.
-{-# INLINE runStreamSVar #-}
-runStreamSVar
- :: MonadIO m
- => SVar Stream m a
- -> Stream m a
- -> State Stream m a -- state
- -> m r -- stop
- -> (a -> m r) -- singleton
- -> (a -> Stream m a -> m r) -- yield
- -> m ()
-runStreamSVar sv m st stp sng yld =
- let mrun = runInIO $ svarMrun sv
- in void $ liftIO $ mrun $ unStream m st stp sng yld
-
-------------------------------------------------------------------------------
--- Types that can behave as a Stream
-------------------------------------------------------------------------------
-
-infixr 5 `consM`
-infixr 5 |:
-
--- | Class of types that can represent a stream of elements of some type 'a' in
--- some monad 'm'.
---
--- @since 0.2.0
-class IsStream t where
- toStream :: t m a -> Stream m a
- fromStream :: Stream m a -> t m a
- -- | Constructs a stream by adding a monadic action at the head of an
- -- existing stream. For example:
- --
- -- @
- -- > toList $ getLine \`consM` getLine \`consM` nil
- -- hello
- -- world
- -- ["hello","world"]
- -- @
- --
- -- /Concurrent (do not use 'parallely' to construct infinite streams)/
- --
- -- @since 0.2.0
- consM :: MonadAsync m => m a -> t m a -> t m a
- -- | Operator equivalent of 'consM'. We can read it as "@parallel colon@"
- -- to remember that @|@ comes before ':'.
- --
- -- @
- -- > toList $ getLine |: getLine |: nil
- -- hello
- -- world
- -- ["hello","world"]
- -- @
- --
- -- @
- -- let delay = threadDelay 1000000 >> print 1
- -- runStream $ serially $ delay |: delay |: delay |: nil
- -- runStream $ parallely $ delay |: delay |: delay |: nil
- -- @
- --
- -- /Concurrent (do not use 'parallely' to construct infinite streams)/
- --
- -- @since 0.2.0
- (|:) :: MonadAsync m => m a -> t m a -> t m a
- -- We can define (|:) just as 'consM' but it is defined explicitly for each
- -- type because we want to use SPECIALIZE pragma on the definition.
-
--- | Same as 'IsStream'.
---
--- @since 0.1.0
-{-# DEPRECATED Streaming "Please use IsStream instead." #-}
-type Streaming = IsStream
-
--------------------------------------------------------------------------------
--- Type adapting combinators
--------------------------------------------------------------------------------
-
--- | 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
-
-------------------------------------------------------------------------------
--- Building a stream
-------------------------------------------------------------------------------
-
--- | Build a stream from an 'SVar', a stop continuation, a singleton stream
--- continuation and a yield continuation.
-mkStream:: IsStream t
- => (forall r. State Stream m a
- -> m r
- -> (a -> m r)
- -> (a -> t m a -> m r)
- -> m r)
- -> t m a
-mkStream k = fromStream $ Stream $ \st stp sng yld ->
- let yieldk a r = yld a (toStream r)
- in k (rstState st) stp sng yieldk
+-- | Detach a stream from an SVar
+{-# INLINE unShare #-}
+unShare :: IsStream t => t m a -> t m a
+unShare x = mkStream $ \st yld sng stp ->
+ foldStream st yld sng stp x
------------------------------------------------------------------------------
-- Construction
------------------------------------------------------------------------------
--- | An empty stream.
---
--- @
--- > toList nil
--- []
--- @
---
--- @since 0.1.0
-nil :: IsStream t => t m a
-nil = fromStream $ Stream $ \_ stp _ _ -> stp
-
infixr 5 `cons`
-- faster than consM because there is no bind.
@@ -346,8 +197,9 @@ infixr 5 `cons`
-- @
--
-- @since 0.1.0
+{-# INLINE cons #-}
cons :: IsStream t => a -> t m a -> t m a
-cons a r = fromStream $ Stream $ \_ _ _ yld -> yld a (toStream r)
+cons a r = mkStream $ \_ yld _ _ -> yld a r
infixr 5 .:
@@ -359,50 +211,10 @@ infixr 5 .:
-- @
--
-- @since 0.1.1
+{-# INLINE (.:) #-}
(.:) :: IsStream t => a -> t m a -> t m a
(.:) = cons
-{-# INLINE consMSerial #-}
-consMSerial :: (Monad m) => m a -> Stream m a -> Stream m a
-consMSerial m r = Stream $ \_ _ _ yld -> m >>= \a -> yld a r
-
-------------------------------------------------------------------------------
--- Asynchronous construction
-------------------------------------------------------------------------------
-
--- | Make an empty stream from a callback function.
-nilK :: IsStream t => (forall r. m r -> m r) -> t m a
-nilK k = fromStream $ Stream $ \_ stp _ _ -> k stp
-
--- | Make a singleton stream from a one shot callback function.
-yieldK :: IsStream t => (forall r. (a -> m r) -> m r) -> t m a
-yieldK k = fromStream $ Stream $ \_ _ sng _ -> k sng
-
--- | Construct a stream from a callback function.
-consK :: IsStream t => (forall r. (a -> m r) -> m r) -> t m a -> t m a
-consK k r = fromStream $ Stream $ \_ _ _ yld -> k (\x -> yld x (toStream r))
-
--- XXX consK with concurrent callbacks
--- XXX Build a stream from a repeating callback function.
-
--------------------------------------------------------------------------------
--- IsStream Stream
--------------------------------------------------------------------------------
-
-instance IsStream Stream where
- toStream = id
- fromStream = id
-
- {-# INLINE consM #-}
- {-# SPECIALIZE consM :: IO a -> Stream IO a -> Stream IO a #-}
- consM :: Monad m => m a -> Stream m a -> Stream m a
- consM = consMSerial
-
- {-# INLINE (|:) #-}
- {-# SPECIALIZE (|:) :: IO a -> Stream IO a -> Stream IO a #-}
- (|:) :: Monad m => m a -> Stream m a -> Stream m a
- (|:) = consMSerial
-
-------------------------------------------------------------------------------
-- Deconstruction
-------------------------------------------------------------------------------
@@ -412,43 +224,56 @@ uncons :: (IsStream t, Monad m) => t m a -> m (Maybe (a, t m a))
uncons m =
let stop = return Nothing
single a = return (Just (a, nil))
- yieldk a r = return (Just (a, fromStream r))
- in unStream (toStream m) defState stop single yieldk
+ yieldk a r = return (Just (a, r))
+ in foldStream defState yieldk single stop m
-------------------------------------------------------------------------------
-- Generation
-------------------------------------------------------------------------------
+{-# INLINE_NORMAL build #-}
+build :: IsStream t => forall a. (forall b. (a -> b -> b) -> b -> b) -> t m a
+build g = g cons nil
+
+{-# INLINE_NORMAL _augment #-}
+_augment
+ :: IsStream t
+ => forall a. (forall b. (a -> b -> b) -> b -> b) -> t m a -> t m a
+_augment g xs = g cons xs
+
+{-# INLINE_NORMAL _buildM #-}
+_buildM
+ :: (IsStream t, MonadAsync m)
+ => forall a. ((m a -> t m a -> t m a) -> t m a -> t m a) -> t m a
+_buildM g = g consM nil
+
{-# INLINE unfoldr #-}
unfoldr :: IsStream t => (b -> Maybe (a, b)) -> b -> t m a
-unfoldr step = fromStream . go
- where
- go s = Stream $ \_ stp _ yld ->
- case step s of
- Nothing -> stp
- Just (a, b) -> yld a (go b)
+unfoldr step b0 = build $ \cns nl ->
+ let go s =
+ case step s of
+ Just (a, b) -> a `cns` go b
+ Nothing -> nl
+ in go b0
{-# INLINE unfoldrM #-}
unfoldrM :: (IsStream t, MonadAsync m) => (b -> m (Maybe (a, b))) -> b -> t m a
unfoldrM step = go
where
- go s = fromStream $ Stream $ \svr stp sng yld -> do
+ go s = mkStream $ \st yld sng stp -> do
mayb <- step s
case mayb of
Nothing -> stp
Just (a, b) ->
- unStream (toStream (return a |: go b)) svr stp sng yld
+ foldStreamShared st yld sng stp $ return a |: go b
-------------------------------------------------------------------------------
-- Special generation
-------------------------------------------------------------------------------
+{-# INLINE yield #-}
yield :: IsStream t => a -> t m a
-yield a = fromStream $ Stream $ \_ _ single _ -> single a
-
-{-# INLINE yieldM #-}
-yieldM :: (Monad m, IsStream t) => m a -> t m a
-yieldM m = fromStream $ Stream $ \_ _ single _ -> m >>= single
+yield a = mkStream $ \_ _ single _ -> single a
-- | Same as yieldM
--
@@ -458,19 +283,41 @@ yieldM m = fromStream $ Stream $ \_ _ single _ -> m >>= single
once :: (Monad m, IsStream t) => m a -> t m a
once = yieldM
--- | Generate an infinite stream by repeating a pure value.
--- Can be expressed as @cycle1 . yield@.
+-- |
+-- @
+-- repeatM = fix . cons
+-- repeatM = cycle1 . yield
+-- @
+--
+-- Generate an infinite stream by repeating a pure value.
--
-- @since 0.4.0
+{-# INLINE repeat #-}
repeat :: IsStream t => a -> t m a
repeat a = let x = cons a x in x
+{-# INLINE replicateM #-}
+replicateM :: (IsStream t, MonadAsync m) => Int -> m a -> t m a
+replicateM n m = go n
+ where
+ go cnt = if cnt <= 0 then nil else m |: go (cnt - 1)
+
+{-# INLINE replicate #-}
+replicate :: IsStream t => Int -> a -> t m a
+replicate n a = go n
+ where
+ go cnt = if cnt <= 0 then nil else a `cons` go (cnt - 1)
+
-------------------------------------------------------------------------------
-- Conversions
-------------------------------------------------------------------------------
--- | Construct a stream from a 'Foldable' containing pure values. Same as
--- @'Prelude.foldr' 'cons' 'nil'@.
+-- |
+-- @
+-- fromFoldable = 'Prelude.foldr' 'cons' 'nil'
+-- @
+--
+-- Construct a stream from a 'Foldable' containing pure values:
--
-- @since 0.2.0
{-# INLINE fromFoldable #-}
@@ -482,47 +329,34 @@ fromList :: IsStream t => [a] -> t m a
fromList = fromFoldable
{-# INLINE fromStreamK #-}
-fromStreamK :: Stream m a -> Stream m a
-fromStreamK = id
+fromStreamK :: IsStream t => Stream m a -> t m a
+fromStreamK = fromStream
-------------------------------------------------------------------------------
-- Elimination by Folding
-------------------------------------------------------------------------------
--- | Fold a stream by providing an SVar, a stop continuation, a singleton
--- continuation and a yield continuation.
-foldStream
- :: IsStream t
- => State Stream m a
- -> m r
- -> (a -> m r)
- -> (a -> t m a -> m r)
- -> t m a
- -> m r
-foldStream st blank single step m =
- let yieldk a x = step a (fromStream x)
- in unStream (toStream m) st blank single yieldk
-
-- | Lazy right associative fold.
+{-# INLINE foldr #-}
foldr :: (IsStream t, Monad m) => (a -> b -> b) -> b -> t m a -> m b
-foldr step acc m = go (toStream m)
+foldr step acc m = go m
where
go m1 =
let stop = return acc
single a = return (step a acc)
yieldk a r = go r >>= \b -> return (step a b)
- in unStream m1 defState stop single yieldk
+ in foldStream defState yieldk single stop m1
-- | Lazy right fold with a monadic step function.
{-# INLINE foldrM #-}
foldrM :: (IsStream t, Monad m) => (a -> b -> m b) -> b -> t m a -> m b
-foldrM step acc m = go (toStream m)
+foldrM step acc m = go m
where
go m1 =
let stop = return acc
single a = step a acc
yieldk a r = go r >>= step a
- in unStream m1 defState stop single yieldk
+ in foldStream defState yieldk single stop m1
{-# INLINE foldr1 #-}
foldr1 :: (IsStream t, Monad m) => (a -> a -> a) -> t m a -> m (Maybe a)
@@ -530,39 +364,46 @@ foldr1 step m = do
r <- uncons m
case r of
Nothing -> return Nothing
- Just (h, t) -> fmap Just (go h (toStream t))
+ Just (h, t) -> fmap Just (go h t)
where
go p m1 =
let stp = return p
single a = return $ step a p
yieldk a r = fmap (step p) (go a r)
- in unStream m1 defState stp single yieldk
+ in foldStream defState yieldk single stp m1
-- | 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.
+--
+-- Note that the accumulator is always evaluated including the initial value.
{-# INLINE foldx #-}
-foldx :: (IsStream t, Monad m)
+foldx :: forall t m a b x. (IsStream t, Monad m)
=> (x -> a -> x) -> x -> (x -> b) -> t m a -> m b
-foldx step begin done m = get $ go (toStream m) begin
+foldx step begin done m = get $ go m begin
where
{-# NOINLINE get #-}
+ get :: t m x -> m b
get m1 =
+ -- XXX we are not strictly evaluating the accumulator here. Is this
+ -- okay?
let single = return . done
- in unStream m1 undefined undefined single undefined
+ -- XXX this is foldSingleton. why foldStreamShared?
+ in foldStreamShared undefined undefined single undefined m1
-- 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 $ \_ _ sng yld ->
+ go :: t m a -> x -> t m x
+ go m1 !acc = mkStream $ \_ yld sng _ ->
let stop = sng acc
single a = sng $ step acc a
- yieldk a r =
- let stream = go r (step acc a)
- in unStream stream defState undefined sng yld
- in unStream m1 defState stop single yieldk
+ -- XXX this is foldNonEmptyStream
+ yieldk a r = foldStream defState yld sng undefined $
+ go r (step acc a)
+ in foldStream defState yieldk single stop m1
-- | Strict left associative fold.
{-# INLINE foldl' #-}
@@ -571,17 +412,19 @@ foldl' step begin = foldx step begin id
-- XXX replace the recursive "go" with explicit continuations.
-- | Like 'foldx', but with a monadic step function.
+{-# INLINABLE foldxM #-}
foldxM :: (IsStream t, Monad m)
=> (x -> a -> m x) -> m x -> (x -> m b) -> t m a -> m b
-foldxM step begin done m = go begin (toStream m)
+foldxM step begin done m = go begin m
where
go !acc m1 =
let stop = acc >>= done
single a = acc >>= \b -> step b a >>= done
yieldk a r = acc >>= \b -> step b a >>= \x -> go (return x) r
- in unStream m1 defState stop single yieldk
+ in foldStream defState yieldk single stop m1
-- | Like 'foldl'' but with a monadic step function.
+{-# INLINE foldlM' #-}
foldlM' :: (IsStream t, Monad m) => (b -> a -> m b) -> b -> t m a -> m b
foldlM' step begin = foldxM step (return begin) return
@@ -589,15 +432,18 @@ foldlM' step begin = foldxM step (return begin) return
-- Specialized folds
------------------------------------------------------------------------------
+-- |
+-- > runStream = foldl' (\_ _ -> ()) ()
+-- > runStream = mapM_ (\_ -> return ())
{-# INLINE runStream #-}
runStream :: (Monad m, IsStream t) => t m a -> m ()
-runStream m = go (toStream m)
+runStream = go
where
go m1 =
let stop = return ()
single _ = return ()
- yieldk _ r = go (toStream r)
- in unStream m1 defState stop single yieldk
+ yieldk _ r = go r
+ in foldStream defState yieldk single stop m1
{-# INLINE null #-}
null :: (IsStream t, Monad m) => t m a -> m Bool
@@ -605,7 +451,7 @@ null m =
let stop = return True
single _ = return False
yieldk _ _ = return False
- in unStream (toStream m) defState stop single yieldk
+ in foldStream defState yieldk single stop m
{-# INLINE head #-}
head :: (IsStream t, Monad m) => t m a -> m (Maybe a)
@@ -613,69 +459,71 @@ head m =
let stop = return Nothing
single a = return (Just a)
yieldk a _ = return (Just a)
- in unStream (toStream m) defState stop single yieldk
+ in foldStream defState yieldk single stop m
{-# INLINE tail #-}
tail :: (IsStream t, Monad m) => t m a -> m (Maybe (t m a))
tail m =
let stop = return Nothing
single _ = return $ Just nil
- yieldk _ r = return $ Just $ fromStream r
- in unStream (toStream m) defState stop single yieldk
+ yieldk _ r = return $ Just r
+ in foldStream defState yieldk single stop m
{-# INLINE init #-}
init :: (IsStream t, Monad m) => t m a -> m (Maybe (t m a))
-init m = go1 (toStream m)
+init m = go1 m
where
go1 m1 = do
r <- uncons m1
case r of
Nothing -> return Nothing
- Just (h, t) -> return . Just . fromStream $ go h t
- go p m1 = Stream $ \_ stp sng yld ->
+ Just (h, t) -> return . Just $ go h t
+ go p m1 = mkStream $ \_ yld sng stp ->
let single _ = sng p
yieldk a x = yld p $ go a x
- in unStream m1 defState stp single yieldk
+ in foldStream defState yieldk single stp m1
{-# INLINE elem #-}
elem :: (IsStream t, Monad m, Eq a) => a -> t m a -> m Bool
-elem e m = go (toStream m)
+elem e m = go m
where
go m1 =
let stop = return False
single a = return (a == e)
yieldk a r = if a == e then return True else go r
- in unStream m1 defState stop single yieldk
+ in foldStream defState yieldk single stop m1
{-# INLINE notElem #-}
notElem :: (IsStream t, Monad m, Eq a) => a -> t m a -> m Bool
-notElem e m = go (toStream m)
+notElem e m = go m
where
go m1 =
let stop = return True
single a = return (a /= e)
yieldk a r = if a == e then return False else go r
- in unStream m1 defState stop single yieldk
+ in foldStream defState yieldk single stop m1
+{-# INLINABLE all #-}
all :: (IsStream t, Monad m) => (a -> Bool) -> t m a -> m Bool
-all p m = go (toStream m)
+all p m = go m
where
go m1 =
let single a | p a = return True
| otherwise = return False
yieldk a r | p a = go r
| otherwise = return False
- in unStream m1 defState (return True) single yieldk
+ in foldStream defState yieldk single (return True) m1
+{-# INLINABLE any #-}
any :: (IsStream t, Monad m) => (a -> Bool) -> t m a -> m Bool
-any p m = go (toStream m)
+any p m = go m
where
go m1 =
let single a | p a = return True
| otherwise = return False
yieldk a r | p a = return True
| otherwise = go r
- in unStream m1 defState (return False) single yieldk
+ in foldStream defState yieldk single (return False) m1
-- | Extract the last element of the stream, if any.
{-# INLINE last #-}
@@ -684,13 +532,13 @@ last = foldx (\_ y -> Just y) Nothing id
{-# INLINE minimum #-}
minimum :: (IsStream t, Monad m, Ord a) => t m a -> m (Maybe a)
-minimum m = go Nothing (toStream m)
+minimum m = go Nothing m
where
go Nothing m1 =
let stop = return Nothing
single a = return (Just a)
yieldk a r = go (Just a) r
- in unStream m1 defState stop single yieldk
+ in foldStream defState yieldk single stop m1
go (Just res) m1 =
let stop = return (Just res)
@@ -702,17 +550,39 @@ minimum m = go Nothing (toStream m)
if res <= a
then go (Just res) r
else go (Just a) r
- in unStream m1 defState stop single yieldk
+ in foldStream defState yieldk single stop m1
+
+{-# INLINE minimumBy #-}
+minimumBy
+ :: (IsStream t, Monad m)
+ => (a -> a -> Ordering) -> t m a -> m (Maybe a)
+minimumBy cmp m = go Nothing m
+ where
+ go Nothing m1 =
+ let stop = return Nothing
+ single a = return (Just a)
+ yieldk a r = go (Just a) r
+ in foldStream defState yieldk single stop m1
+
+ go (Just res) m1 =
+ let stop = return (Just res)
+ single a = case cmp res a of
+ GT -> return (Just a)
+ _ -> return (Just res)
+ yieldk a r = case cmp res a of
+ GT -> go (Just a) r
+ _ -> go (Just res) r
+ in foldStream defState yieldk single stop m1
{-# INLINE maximum #-}
maximum :: (IsStream t, Monad m, Ord a) => t m a -> m (Maybe a)
-maximum m = go Nothing (toStream m)
+maximum m = go Nothing m
where
go Nothing m1 =
let stop = return Nothing
single a = return (Just a)
yieldk a r = go (Just a) r
- in unStream m1 defState stop single yieldk
+ in foldStream defState yieldk single stop m1
go (Just res) m1 =
let stop = return (Just res)
@@ -724,40 +594,79 @@ maximum m = go Nothing (toStream m)
if res <= a
then go (Just a) r
else go (Just res) r
- in unStream m1 defState stop single yieldk
+ in foldStream defState yieldk single stop m1
+
+{-# INLINE maximumBy #-}
+maximumBy :: (IsStream t, Monad m) => (a -> a -> Ordering) -> t m a -> m (Maybe a)
+maximumBy cmp m = go Nothing m
+ where
+ go Nothing m1 =
+ let stop = return Nothing
+ single a = return (Just a)
+ yieldk a r = go (Just a) r
+ in foldStream defState yieldk single stop m1
+
+ go (Just res) m1 =
+ let stop = return (Just res)
+ single a = case cmp res a of
+ GT -> return (Just res)
+ _ -> return (Just a)
+ yieldk a r = case cmp res a of
+ GT -> go (Just res) r
+ _ -> go (Just a) r
+ in foldStream defState yieldk single stop m1
+
+{-# INLINE (!!) #-}
+(!!) :: (IsStream t, Monad m) => t m a -> Int -> m (Maybe a)
+m !! i = go i m
+ where
+ go n m1 =
+ let single a | n == 0 = return $ Just a
+ | otherwise = return Nothing
+ yieldk a x | n < 0 = return Nothing
+ | n == 0 = return $ Just a
+ | otherwise = go (n - 1) x
+ in foldStream defState yieldk single (return Nothing) m1
{-# INLINE lookup #-}
lookup :: (IsStream t, Monad m, Eq a) => a -> t m (a, b) -> m (Maybe b)
-lookup e m = go (toStream m)
+lookup e m = go m
where
go m1 =
let single (a, b) | a == e = return $ Just b
| otherwise = return Nothing
yieldk (a, b) x | a == e = return $ Just b
| otherwise = go x
- in unStream m1 defState (return Nothing) single yieldk
+ in foldStream defState yieldk single (return Nothing) m1
-{-# INLINE find #-}
-find :: (IsStream t, Monad m) => (a -> Bool) -> t m a -> m (Maybe a)
-find p m = go (toStream m)
+{-# INLINE findM #-}
+findM :: (IsStream t, Monad m) => (a -> m Bool) -> t m a -> m (Maybe a)
+findM p m = go m
where
go m1 =
- let single a | p a = return $ Just a
- | otherwise = return Nothing
- yieldk a x | p a = return $ Just a
- | otherwise = go x
- in unStream m1 defState (return Nothing) single yieldk
+ let single a = do
+ b <- p a
+ if b then return $ Just a else return Nothing
+ yieldk a x = do
+ b <- p a
+ if b then return $ Just a else go x
+ in foldStream defState yieldk single (return Nothing) m1
+
+{-# INLINE find #-}
+find :: (IsStream t, Monad m) => (a -> Bool) -> t m a -> m (Maybe a)
+find p = findM (return . p)
{-# INLINE findIndices #-}
findIndices :: IsStream t => (a -> Bool) -> t m a -> t m Int
-findIndices p = fromStream . go 0 . toStream
+findIndices p = go 0
where
- go offset m1 = Stream $ \st stp sng yld ->
+ go offset m1 = mkStream $ \st yld sng stp ->
let single a | p a = sng offset
| otherwise = stp
yieldk a x | p a = yld offset $ go (offset + 1) x
- | otherwise = unStream (go (offset + 1) x) st stp sng yld
- in unStream m1 (rstState st) stp single yieldk
+ | otherwise = foldStream (adaptState st) yld sng stp $
+ go (offset + 1) x
+ in foldStream (adaptState st) yieldk single stp m1
------------------------------------------------------------------------------
-- Map and Fold
@@ -765,14 +674,15 @@ findIndices p = fromStream . go 0 . toStream
-- | Apply a monadic action to each element of the stream and discard the
-- output of the action.
+{-# INLINE mapM_ #-}
mapM_ :: (IsStream t, Monad m) => (a -> m b) -> t m a -> m ()
-mapM_ f m = go (toStream m)
+mapM_ f m = go m
where
go m1 =
let stop = return ()
single a = void (f a)
yieldk a r = f a >> go r
- in unStream m1 defState stop single yieldk
+ in foldStream defState yieldk single stop m1
------------------------------------------------------------------------------
-- Converting folds
@@ -793,14 +703,14 @@ toStreamK = id
{-# 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
+ cons (done begin) $ go m begin
where
- go m1 !acc = Stream $ \st stp sng yld ->
+ go m1 !acc = mkStream $ \st yld sng stp ->
let single a = sng (done $ step acc a)
yieldk a r =
let s = step acc a
in yld (done s) (go r s)
- in unStream m1 (rstState st) stp single yieldk
+ in foldStream (adaptState st) yieldk single stp m1
{-# INLINE scanl' #-}
scanl' :: IsStream t => (b -> a -> b) -> b -> t m a -> t m b
@@ -812,91 +722,84 @@ scanl' step begin = scanx step begin id
{-# INLINE filter #-}
filter :: IsStream t => (a -> Bool) -> t m a -> t m a
-filter p m = fromStream $ go (toStream m)
+filter p m = go m
where
- go m1 = Stream $ \st stp sng yld ->
+ go m1 = mkStream $ \st yld sng stp ->
let single a | p a = sng a
| otherwise = stp
yieldk a r | p a = yld a (go r)
- | otherwise = unStream r (rstState st) stp single yieldk
- in unStream m1 (rstState st) stp single yieldk
+ | otherwise = foldStream st yieldk single stp r
+ in foldStream st yieldk single stp m1
{-# INLINE take #-}
take :: IsStream t => Int -> t m a -> t m a
-take n m = fromStream $ go n (toStream m)
+take n m = go n m
where
- go n1 m1 = Stream $ \st stp sng yld ->
+ go n1 m1 = mkStream $ \st yld sng stp ->
let yieldk a r = yld a (go (n1 - 1) r)
in if n1 <= 0
then stp
- else unStream m1 (rstState st) stp sng yieldk
+ else foldStream st yieldk sng stp m1
{-# INLINE takeWhile #-}
takeWhile :: IsStream t => (a -> Bool) -> t m a -> t m a
-takeWhile p m = fromStream $ go (toStream m)
+takeWhile p m = go m
where
- go m1 = Stream $ \st stp sng yld ->
+ go m1 = mkStream $ \st yld sng stp ->
let single a | p a = sng a
| otherwise = stp
yieldk a r | p a = yld a (go r)
| otherwise = stp
- in unStream m1 (rstState st) stp single yieldk
+ in foldStream st yieldk single stp m1
+{-# INLINE drop #-}
drop :: IsStream t => Int -> t m a -> t m a
-drop n m = fromStream $ Stream $ \st stp sng yld ->
- unStream (go n (toStream m)) (rstState st) stp sng yld
+drop n m = fromStream $ unShare (go n (toStream m))
where
- go n1 m1 = Stream $ \st stp sng yld ->
+ go n1 m1 = mkStream $ \st yld sng stp ->
let single _ = stp
- yieldk _ r = (unStream $ go (n1 - 1) r) st stp sng yld
+ yieldk _ r = foldStreamShared st yld sng stp $ go (n1 - 1) r
-- Somehow "<=" check performs better than a ">"
in if n1 <= 0
- then unStream m1 st stp sng yld
- else unStream m1 st stp single yieldk
+ then foldStreamShared st yld sng stp m1
+ else foldStreamShared st yieldk single stp m1
{-# INLINE dropWhile #-}
dropWhile :: IsStream t => (a -> Bool) -> t m a -> t m a
-dropWhile p m = fromStream $ go (toStream m)
+dropWhile p m = go m
where
- go m1 = Stream $ \st stp sng yld ->
+ go m1 = mkStream $ \st yld sng stp ->
let single a | p a = stp
| otherwise = sng a
- yieldk a r | p a = unStream r (rstState st) stp single yieldk
+ yieldk a r | p a = foldStream st yieldk single stp r
| otherwise = yld a r
- in unStream m1 (rstState st) stp single yieldk
+ in foldStream st yieldk single stp m1
-------------------------------------------------------------------------------
-- Mapping
-------------------------------------------------------------------------------
-{-# INLINE map #-}
-map :: (IsStream t, Monad m) => (a -> b) -> t m a -> t m b
-map f m = fromStream $ Stream $ \st stp sng yld ->
- let single = sng . f
- yieldk a r = yld (f a) (fmap f r)
- in unStream (toStream m) (rstState st) stp single yieldk
-
-- Be careful when modifying this, this uses a consM (|:) deliberately to allow
-- other stream types to overload it.
{-# INLINE mapM #-}
mapM :: (IsStream t, MonadAsync m) => (a -> m b) -> t m a -> t m b
-mapM f m = go (toStream m)
+mapM f m = go m
where
- go m1 = fromStream $ Stream $ \st stp sng yld ->
+ go m1 = mkStream $ \st yld sng stp ->
let single a = f a >>= sng
- yieldk a r = unStream (toStream (f a |: go r)) st stp sng yld
- in unStream m1 (rstState st) stp single yieldk
+ yieldk a r = foldStreamShared st yld sng stp $ f a |: go r
+ in foldStream (adaptState st) yieldk single stp m1
-- Be careful when modifying this, this uses a consM (|:) deliberately to allow
-- other stream types to overload it.
{-# INLINE sequence #-}
sequence :: (IsStream t, MonadAsync m) => t m (m a) -> t m a
-sequence m = go (toStream m)
+sequence m = go m
where
- go m1 = fromStream $ Stream $ \st stp sng yld ->
+ go m1 = mkStream $ \st yld sng stp ->
let single ma = ma >>= sng
- yieldk ma r = unStream (toStream $ ma |: go r) st stp sng yld
- in unStream m1 (rstState st) stp single yieldk
+ yieldk ma r = foldStreamShared st yld sng stp $ ma |: go r
+ in foldStream (adaptState st) yieldk single stp m1
-------------------------------------------------------------------------------
-- Inserting
@@ -904,15 +807,44 @@ sequence m = go (toStream m)
{-# INLINE intersperseM #-}
intersperseM :: (IsStream t, MonadAsync m) => m a -> t m a -> t m a
-intersperseM a m = fromStream $ prependingStart (toStream m)
- where
- prependingStart m1 = Stream $ \st stp sng yld ->
- let yieldk i x = unStream (return i |: go x) st stp sng yld
- in unStream m1 (rstState st) stp sng yieldk
- go m2 = fromStream $ Stream $ \st stp sng yld ->
- let single i = unStream (a |: yield i) st stp sng yld
- yieldk i x = unStream (a |: return i |: go x) st stp sng yld
- in unStream m2 (rstState st) stp single yieldk
+intersperseM a m = prependingStart m
+ where
+ prependingStart m1 = mkStream $ \st yld sng stp ->
+ let yieldk i x = foldStreamShared st yld sng stp $ return i |: go x
+ in foldStream st yieldk sng stp m1
+ go m2 = mkStream $ \st yld sng stp ->
+ let single i = foldStreamShared st yld sng stp $ a |: yield i
+ yieldk i x = foldStreamShared st yld sng stp $ a |: return i |: go x
+ in foldStream st yieldk single stp m2
+
+{-# INLINE insertBy #-}
+insertBy :: IsStream t => (a -> a -> Ordering) -> a -> t m a -> t m a
+insertBy cmp x m = go m
+ where
+ go m1 = mkStream $ \st yld _ _ ->
+ let single a = case cmp x a of
+ GT -> yld a (yield x)
+ _ -> yld x (yield a)
+ stop = yld x nil
+ yieldk a r = case cmp x a of
+ GT -> yld a (go r)
+ _ -> yld x (a `cons` r)
+ in foldStream st yieldk single stop m1
+
+------------------------------------------------------------------------------
+-- Deleting
+------------------------------------------------------------------------------
+
+{-# INLINE deleteBy #-}
+deleteBy :: IsStream t => (a -> a -> Bool) -> a -> t m a -> t m a
+deleteBy eq x m = go m
+ where
+ go m1 = mkStream $ \st yld sng stp ->
+ let single a = if eq x a then stp else sng a
+ yieldk a r = if eq x a
+ then foldStream st yld sng stp r
+ else yld a (go r)
+ in foldStream st yieldk single stp m1
-------------------------------------------------------------------------------
-- Map and Filter
@@ -920,90 +852,107 @@ intersperseM a m = fromStream $ prependingStart (toStream m)
{-# INLINE mapMaybe #-}
mapMaybe :: IsStream t => (a -> Maybe b) -> t m a -> t m b
-mapMaybe f m = go (toStream m)
+mapMaybe f m = go m
where
- go m1 = fromStream $ Stream $ \st stp sng yld ->
+ go m1 = mkStream $ \st yld sng stp ->
let single a = case f a of
Just b -> sng b
Nothing -> stp
yieldk a r = case f a of
- Just b -> yld b (toStream $ go r)
- Nothing -> unStream r (rstState st) stp single yieldk
- in unStream m1 (rstState st) stp single yieldk
+ Just b -> yld b $ go r
+ Nothing -> foldStream (adaptState st) yieldk single stp r
+ in foldStream (adaptState st) yieldk single stp m1
------------------------------------------------------------------------------
-- Serial Zipping
------------------------------------------------------------------------------
-{-# INLINE zipWithS #-}
-zipWithS :: (a -> b -> c) -> Stream m a -> Stream m b -> Stream m c
-zipWithS f = go
+-- | Zip two streams serially using a pure zipping function.
+--
+-- @since 0.1.0
+{-# INLINABLE zipWith #-}
+zipWith :: IsStream t => (a -> b -> c) -> t m a -> t m b -> t m c
+zipWith f = go
where
- go mx my = Stream $ \st stp sng yld -> do
+ go mx my = mkStream $ \st yld sng stp -> do
let merge a ra =
let single2 b = sng (f a b)
yield2 b rb = yld (f a b) (go ra rb)
- in unStream my (rstState st) stp single2 yield2
+ in foldStream (adaptState st) yield2 single2 stp my
let single1 a = merge a nil
yield1 = merge
- unStream mx (rstState st) stp single1 yield1
-
--- | Zip two streams serially using a pure zipping function.
---
--- @since 0.1.0
-{-# INLINABLE zipWith #-}
-zipWith :: IsStream t => (a -> b -> c) -> t m a -> t m b -> t m c
-zipWith f m1 m2 = fromStream $ zipWithS f (toStream m1) (toStream m2)
+ foldStream (adaptState st) yield1 single1 stp mx
-- | Zip two streams serially using a monadic zipping function.
--
-- @since 0.1.0
+{-# INLINABLE zipWithM #-}
zipWithM :: (IsStream t, Monad m) => (a -> b -> m c) -> t m a -> t m b -> t m c
-zipWithM f m1 m2 = fromStream $ go (toStream m1) (toStream m2)
+zipWithM f m1 m2 = go m1 m2
where
- go mx my = Stream $ \st stp sng yld -> do
+ go mx my = mkStream $ \st yld sng stp -> do
let merge a ra =
- let runIt x = unStream x (rstState st) stp sng yld
+ let runIt x = foldStream st yld sng stp x
single2 b = f a b >>= sng
yield2 b rb = f a b >>= \x -> runIt (x `cons` go ra rb)
- in unStream my (rstState st) stp single2 yield2
+ in foldStream (adaptState st) yield2 single2 stp my
let single1 a = merge a nil
yield1 = merge
- unStream mx (rstState st) stp single1 yield1
+ foldStream (adaptState st) yield1 single1 stp mx
------------------------------------------------------------------------------
--- Semigroup
+-- Merging
------------------------------------------------------------------------------
--- | Concatenates two streams sequentially i.e. the first stream is
--- exhausted completely before yielding any element from the second stream.
-{-# INLINE serial #-}
-serial :: Stream m a -> Stream m a -> Stream m a
-serial m1 m2 = go m1
- where
- go (Stream m) = Stream $ \st stp sng yld ->
- let stop = unStream m2 (rstState st) stp sng yld
- single a = yld a m2
- yieldk a r = yld a (go r)
- in m (rstState st) stop single yieldk
-
-instance Semigroup (Stream m a) where
- (<>) = serial
+{-# INLINE mergeByM #-}
+mergeByM
+ :: (IsStream t, Monad m)
+ => (a -> a -> m Ordering) -> t m a -> t m a -> t m a
+mergeByM cmp = go
+ where
+ go mx my = mkStream $ \st yld sng stp -> do
+ let mergeWithY a ra =
+ let stop2 = foldStream st yld sng stp mx
+ single2 b = do
+ r <- cmp a b
+ case r of
+ GT -> yld b (go (a `cons` ra) nil)
+ _ -> yld a (go ra (b `cons` nil))
+ yield2 b rb = do
+ r <- cmp a b
+ case r of
+ GT -> yld b (go (a `cons` ra) rb)
+ _ -> yld a (go ra (b `cons` rb))
+ in foldStream st yield2 single2 stop2 my
+ let stopX = foldStream st yld sng stp my
+ singleX a = mergeWithY a nil
+ yieldX = mergeWithY
+ foldStream st yieldX singleX stopX mx
+
+{-# INLINABLE mergeBy #-}
+mergeBy
+ :: (IsStream t, Monad m)
+ => (a -> a -> Ordering) -> t m a -> t m a -> t m a
+mergeBy cmp = mergeByM (\a b -> return $ cmp a b)
------------------------------------------------------------------------------
--- Monoid
+-- Transformation comprehensions
------------------------------------------------------------------------------
-instance Monoid (Stream m a) where
- mempty = nil
- mappend = (<>)
-
--------------------------------------------------------------------------------
--- Functor
--------------------------------------------------------------------------------
-
-instance Monad m => Functor (Stream m) where
- fmap = map
+{-# INLINE the #-}
+the :: (Eq a, IsStream t, Monad m) => t m a -> m (Maybe a)
+the m = do
+ r <- uncons m
+ case r of
+ Nothing -> return Nothing
+ Just (h, t) -> go h t
+ where
+ go h m1 =
+ let single a | h == a = return $ Just h
+ | otherwise = return Nothing
+ yieldk a r | h == a = go h r
+ | otherwise = return Nothing
+ in foldStream defState yieldk single (return $ Just h) m1
-------------------------------------------------------------------------------
-- Bind utility
@@ -1011,40 +960,40 @@ instance Monad m => Functor (Stream m) where
{-# INLINE bindWith #-}
bindWith
- :: (forall c. Stream m c -> Stream m c -> Stream m c)
- -> Stream m a
- -> (a -> Stream m b)
- -> Stream m b
-bindWith par m f = go m
+ :: IsStream t
+ => (forall c. t m c -> t m c -> t m c)
+ -> t m a
+ -> (a -> t m b)
+ -> t m b
+bindWith par m1 f = go m1
where
- go (Stream g) =
- Stream $ \st stp sng yld ->
- let runShared x = unstreamShared x st stp sng yld
- runIsolated x = unStreamIsolated x st stp sng yld
-
- single a = runIsolated $ f a
- yieldk a r = runShared $ isolateStream (f a) `par` go r
- in g (rstState st) stp single yieldk
+ go m =
+ mkStream $ \st yld sng stp ->
+ let foldShared = foldStreamShared st yld sng stp
+ single a = foldShared $ unShare (f a)
+ yieldk a r = foldShared $ unShare (f a) `par` go r
+ in foldStream (adaptState st) yieldk single stp m
------------------------------------------------------------------------------
-- Alternative & MonadPlus
------------------------------------------------------------------------------
_alt :: Stream m a -> Stream m a -> Stream m a
-_alt m1 m2 = Stream $ \st stp sng yld ->
- let stop = unStream m2 (rstState st) stp sng yld
- in unStream m1 (rstState st) stop sng yld
+_alt m1 m2 = mkStream $ \st yld sng stp ->
+ let stop = foldStream st yld sng stp m2
+ in foldStream st yld sng stop m1
------------------------------------------------------------------------------
-- MonadReader
------------------------------------------------------------------------------
+{-# INLINABLE withLocal #-}
withLocal :: MonadReader r m => (r -> r) -> Stream m a -> Stream m a
withLocal f m =
- Stream $ \st stp sng yld ->
+ mkStream $ \st yld sng stp ->
let single = local f . sng
yieldk a r = local f $ yld a (withLocal f r)
- in unStream m (rstState st) (local f stp) single yieldk
+ in foldStream st yieldk single (local f stp) m
------------------------------------------------------------------------------
-- MonadError
@@ -1056,16 +1005,9 @@ withCatchError
:: MonadError e m
=> Stream m a -> (e -> Stream m a) -> Stream m a
withCatchError m h =
- Stream $ \_ stp sng yld ->
+ mkStream $ \_ stp sng yld ->
let run x = unStream x Nothing stp sng yieldk
handle r = r `catchError` \e -> run $ h e
yieldk a r = yld a (withCatchError r h)
in handle $ run m
-}
-
--------------------------------------------------------------------------------
--- Transformers
--------------------------------------------------------------------------------
-
-instance MonadTrans Stream where
- lift = yieldM
diff --git a/src/Streamly/Streams/StreamK/Type.hs b/src/Streamly/Streams/StreamK/Type.hs
new file mode 100644
index 0000000..3fc3811
--- /dev/null
+++ b/src/Streamly/Streams/StreamK/Type.hs
@@ -0,0 +1,418 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE UndecidableInstances #-} -- XXX
+
+#include "../inline.hs"
+
+-- |
+-- Module : Streamly.Streams.StreamK.Type
+-- Copyright : (c) 2017 Harendra Kumar
+--
+-- License : BSD3
+-- Maintainer : harendra.kumar@gmail.com
+-- Stability : experimental
+-- Portability : GHC
+--
+--
+-- Continuation passing style (CPS) stream implementation. The symbol 'K' below
+-- denotes a function as well as a Kontinuation.
+--
+module Streamly.Streams.StreamK.Type
+ (
+ -- * A class for streams
+ IsStream (..)
+ , adapt
+
+ -- * The stream type
+ , Stream ()
+
+ -- * Construction
+ , mkStream
+ , fromStopK
+ , fromYieldK
+ , consK
+
+ -- * Elimination
+ , foldStream
+ , foldStreamShared
+ , foldStreamSVar
+
+ -- instances
+ , consMStream
+
+ , nil
+ , serial
+ , map
+ , yieldM
+
+ , Streaming -- deprecated
+ )
+where
+
+import Control.Monad (void)
+import Control.Monad.IO.Class (MonadIO(liftIO))
+import Control.Monad.Trans.Class (MonadTrans(lift))
+import Data.Semigroup (Semigroup(..))
+import Prelude hiding (map)
+
+import Streamly.SVar
+
+------------------------------------------------------------------------------
+-- Basic stream type
+------------------------------------------------------------------------------
+
+-- | The type @Stream m a@ represents a monadic stream of values of type 'a'
+-- constructed using actions in monad 'm'. It uses stop, singleton and yield
+-- continuations equivalent to the following direct style type:
+--
+-- @
+-- data Stream m a = Stop | Singleton a | Yield a (Stream m a)
+-- @
+--
+-- 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.
+--
+-- 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.
+--
+-- XXX remove the Stream type parameter from State as it is always constant.
+-- We can remove it from SVar as well
+--
+newtype Stream m a =
+ MkStream (forall r.
+ State Stream m a -- state
+ -> (a -> Stream m a -> m r) -- yield
+ -> (a -> m r) -- singleton
+ -> m r -- stop
+ -> m r
+ )
+
+------------------------------------------------------------------------------
+-- Types that can behave as a Stream
+------------------------------------------------------------------------------
+
+infixr 5 `consM`
+infixr 5 |:
+
+-- XXX Use a different SVar based on the stream type. But we need to make sure
+-- that we do not lose performance due to polymorphism.
+--
+-- | Class of types that can represent a stream of elements of some type 'a' in
+-- some monad 'm'.
+--
+-- @since 0.2.0
+class IsStream t where
+ toStream :: t m a -> Stream m a
+ fromStream :: Stream m a -> t m a
+ -- | Constructs a stream by adding a monadic action at the head of an
+ -- existing stream. For example:
+ --
+ -- @
+ -- > toList $ getLine \`consM` getLine \`consM` nil
+ -- hello
+ -- world
+ -- ["hello","world"]
+ -- @
+ --
+ -- /Concurrent (do not use 'parallely' to construct infinite streams)/
+ --
+ -- @since 0.2.0
+ consM :: MonadAsync m => m a -> t m a -> t m a
+ -- | Operator equivalent of 'consM'. We can read it as "@parallel colon@"
+ -- to remember that @|@ comes before ':'.
+ --
+ -- @
+ -- > toList $ getLine |: getLine |: nil
+ -- hello
+ -- world
+ -- ["hello","world"]
+ -- @
+ --
+ -- @
+ -- let delay = threadDelay 1000000 >> print 1
+ -- runStream $ serially $ delay |: delay |: delay |: nil
+ -- runStream $ parallely $ delay |: delay |: delay |: nil
+ -- @
+ --
+ -- /Concurrent (do not use 'parallely' to construct infinite streams)/
+ --
+ -- @since 0.2.0
+ (|:) :: MonadAsync m => m a -> t m a -> t m a
+ -- We can define (|:) just as 'consM' but it is defined explicitly for each
+ -- type because we want to use SPECIALIZE pragma on the definition.
+
+-- | Same as 'IsStream'.
+--
+-- @since 0.1.0
+{-# DEPRECATED Streaming "Please use IsStream instead." #-}
+type Streaming = IsStream
+
+-------------------------------------------------------------------------------
+-- Type adapting combinators
+-------------------------------------------------------------------------------
+
+-- XXX Move/reset the State here by reconstructing the stream with cleared
+-- state. Can we make sure we do not do that when t1 = t2? If we do this then
+-- we do not need to do that explicitly using svarStyle. It would act as
+-- unShare when the stream type is the same.
+--
+-- | 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
+
+------------------------------------------------------------------------------
+-- Building a stream
+------------------------------------------------------------------------------
+
+-- XXX The State is always parameterized by "Stream" which means State is not
+-- different for different stream types. So we have to manually make sure that
+-- when converting from one stream to another we migrate the state correctly.
+-- This can be fixed if we use a different SVar type for different streams.
+-- Currently we always use "SVar Stream" and therefore a different State type
+-- parameterized by that stream.
+--
+-- XXX Since t is coercible we should be able to coerce k
+-- mkStream k = fromStream $ MkStream $ coerce k
+--
+-- | Build a stream from an 'SVar', a stop continuation, a singleton stream
+-- continuation and a yield continuation.
+{-# INLINE_EARLY mkStream #-}
+mkStream :: IsStream t
+ => (forall r. State Stream m a
+ -> (a -> t m a -> m r)
+ -> (a -> m r)
+ -> m r
+ -> m r)
+ -> t m a
+mkStream k = fromStream $ MkStream $ \st yld sng stp ->
+ let yieldk a r = yld a (toStream r)
+ in k st yieldk sng stp
+
+{-# RULES "mkStream from stream" mkStream = mkStreamFromStream #-}
+mkStreamFromStream :: IsStream t
+ => (forall r. State Stream m a
+ -> (a -> Stream m a -> m r)
+ -> (a -> m r)
+ -> m r
+ -> m r)
+ -> t m a
+mkStreamFromStream k = fromStream $ MkStream k
+
+{-# RULES "mkStream stream" mkStream = mkStreamStream #-}
+mkStreamStream
+ :: (forall r. State Stream m a
+ -> (a -> Stream m a -> m r)
+ -> (a -> m r)
+ -> m r
+ -> m r)
+ -> Stream m a
+mkStreamStream = MkStream
+
+-- | A terminal function that has no continuation to follow.
+type StopK m = forall r. m r -> m r
+
+-- | A monadic continuation, it is a function that yields a value of type "a"
+-- and calls the argument (a -> m r) as a continuation with that value. We can
+-- also think of it as a callback with a handler (a -> m r). Category
+-- theorists call it a codensity type, a special type of right kan extension.
+type YieldK m a = forall r. (a -> m r) -> m r
+
+_wrapM :: Monad m => m a -> YieldK m a
+_wrapM m = \k -> m >>= k
+
+-- | Make an empty stream from a stop function.
+fromStopK :: IsStream t => StopK m -> t m a
+fromStopK k = mkStream $ \_ _ _ stp -> k stp
+
+-- | Make a singleton stream from a yield function.
+fromYieldK :: IsStream t => YieldK m a -> t m a
+fromYieldK k = mkStream $ \_ _ sng _ -> k sng
+
+-- | Add a yield function at the head of the stream.
+consK :: IsStream t => YieldK m a -> t m a -> t m a
+consK k r = mkStream $ \_ yld _ _ -> k (\x -> yld x r)
+
+-- XXX Build a stream from a repeating callback function.
+
+------------------------------------------------------------------------------
+-- Folding a stream
+------------------------------------------------------------------------------
+
+-- | Fold a stream by providing an SVar, a stop continuation, a singleton
+-- continuation and a yield continuation. The stream would share the current
+-- SVar passed via the State.
+{-# INLINE_EARLY foldStreamShared #-}
+foldStreamShared
+ :: IsStream t
+ => State Stream m a
+ -> (a -> t m a -> m r)
+ -> (a -> m r)
+ -> m r
+ -> t m a
+ -> m r
+foldStreamShared st yld sng stp m =
+ let yieldk a x = yld a (fromStream x)
+ MkStream k = toStream m
+ in k st yieldk sng stp
+
+-- XXX write a similar rule for foldStream as well?
+{-# RULES "foldStreamShared from stream"
+ foldStreamShared = foldStreamSharedStream #-}
+foldStreamSharedStream
+ :: State Stream m a
+ -> (a -> Stream m a -> m r)
+ -> (a -> m r)
+ -> m r
+ -> Stream m a
+ -> m r
+foldStreamSharedStream st yld sng stp m =
+ let MkStream k = toStream m
+ in k st yld sng stp
+
+-- | Fold a stream by providing a State, stop continuation, a singleton
+-- continuation and a yield continuation. The stream will not use the SVar
+-- passed via State.
+{-# INLINE foldStream #-}
+foldStream
+ :: IsStream t
+ => State Stream m a
+ -> (a -> t m a -> m r)
+ -> (a -> m r)
+ -> m r
+ -> t m a
+ -> m r
+foldStream st yld sng stp m =
+ let yieldk a x = yld a (fromStream x)
+ MkStream k = toStream m
+ in k (adaptState st) yieldk sng stp
+
+-- Run the stream using a run function associated with the SVar that runs the
+-- streams with a captured snapshot of the monadic state.
+{-# INLINE foldStreamSVar #-}
+foldStreamSVar
+ :: (IsStream t, MonadIO m)
+ => SVar Stream m a
+ -> State Stream m a -- state
+ -> (a -> t m a -> m r) -- yield
+ -> (a -> m r) -- singleton
+ -> m r -- stop
+ -> t m a
+ -> m ()
+foldStreamSVar sv st yld sng stp m =
+ let mrun = runInIO $ svarMrun sv
+ in void $ liftIO $ mrun $ foldStreamShared st yld sng stp m
+
+-------------------------------------------------------------------------------
+-- Instances
+-------------------------------------------------------------------------------
+
+-- NOTE: specializing the function outside the instance definition seems to
+-- improve performance quite a bit at times, even if we have the same
+-- SPECIALIZE in the instance definition.
+{-# INLINE consMStream #-}
+{-# SPECIALIZE consMStream :: IO a -> Stream IO a -> Stream IO a #-}
+consMStream :: (Monad m) => m a -> Stream m a -> Stream m a
+consMStream m r = MkStream $ \_ yld _ _ -> m >>= \a -> yld a r
+
+-------------------------------------------------------------------------------
+-- IsStream Stream
+-------------------------------------------------------------------------------
+
+instance IsStream Stream where
+ toStream = id
+ fromStream = id
+
+ {-# INLINE consM #-}
+ {-# SPECIALIZE consM :: IO a -> Stream IO a -> Stream IO a #-}
+ consM :: Monad m => m a -> Stream m a -> Stream m a
+ consM = consMStream
+
+ {-# INLINE (|:) #-}
+ {-# SPECIALIZE (|:) :: IO a -> Stream IO a -> Stream IO a #-}
+ (|:) :: Monad m => m a -> Stream m a -> Stream m a
+ (|:) = consMStream
+
+------------------------------------------------------------------------------
+-- Semigroup
+------------------------------------------------------------------------------
+
+-- | 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 = go m1
+ where
+ go m = mkStream $ \st yld sng stp ->
+ let stop = foldStream st yld sng stp m2
+ single a = yld a m2
+ yieldk a r = yld a (go r)
+ in foldStream st yieldk single stop m
+
+instance Semigroup (Stream m a) where
+ (<>) = serial
+
+------------------------------------------------------------------------------
+-- Monoid
+------------------------------------------------------------------------------
+
+-- | An empty stream.
+--
+-- @
+-- > toList nil
+-- []
+-- @
+--
+-- @since 0.1.0
+{-# INLINE nil #-}
+nil :: IsStream t => t m a
+nil = mkStream $ \_ _ _ stp -> stp
+
+instance Monoid (Stream m a) where
+ mempty = nil
+ mappend = (<>)
+
+-------------------------------------------------------------------------------
+-- Functor
+-------------------------------------------------------------------------------
+
+{-# INLINE map #-}
+map :: IsStream t => (a -> b) -> t m a -> t m b
+map f m = go m
+ where
+ go m1 =
+ mkStream $ \st yld sng stp ->
+ let single = sng . f
+ yieldk a r = yld (f a) (go r)
+ in foldStream (adaptState st) yieldk single stp m1
+
+-- in fact use the Stream type everywhere and only use polymorphism in the high
+-- level modules/prelude.
+instance Monad m => Functor (Stream m) where
+ fmap = map
+
+-------------------------------------------------------------------------------
+-- Transformers
+-------------------------------------------------------------------------------
+
+{-# INLINE yieldM #-}
+yieldM :: (Monad m, IsStream t) => m a -> t m a
+yieldM m = fromStream $ mkStream $ \_ _ single _ -> m >>= single
+
+instance MonadTrans Stream where
+ lift = yieldM
diff --git a/src/Streamly/Streams/Zip.hs b/src/Streamly/Streams/Zip.hs
index 1e5ad7c..b5b337f 100644
--- a/src/Streamly/Streams/Zip.hs
+++ b/src/Streamly/Streams/Zip.hs
@@ -5,6 +5,7 @@
{-# LANGUAGE GeneralizedNewtypeDeriving#-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-} -- XXX
-- |
@@ -37,14 +38,22 @@ module Streamly.Streams.Zip
)
where
+import Control.Applicative (liftA2)
+import Control.DeepSeq (NFData(..), NFData1(..), rnf1)
+import Data.Functor.Identity (Identity, runIdentity)
+import Data.Foldable (fold)
import Data.Semigroup (Semigroup(..))
+import GHC.Exts (IsList(..), IsString(..))
+import Text.Read (Lexeme(Ident), lexP, parens, prec, readPrec, readListPrec,
+ readListPrecDefault)
import Prelude hiding (map, repeat, zipWith)
-import Streamly.Streams.StreamK (IsStream(..), Stream(..))
+import Streamly.Streams.StreamK (IsStream(..), Stream, mkStream, foldStream)
import Streamly.Streams.Async (mkAsync')
import Streamly.Streams.Serial (map)
-import Streamly.SVar (MonadAsync, rstState)
+import Streamly.SVar (MonadAsync, adaptState)
+import qualified Streamly.Streams.Prelude as P
import qualified Streamly.Streams.StreamK as K
#include "Instances.hs"
@@ -97,6 +106,9 @@ zipSerially = K.adapt
zipping :: IsStream t => ZipSerialM m a -> t m a
zipping = zipSerially
+consMZip :: Monad m => m a -> ZipSerialM m a -> ZipSerialM m a
+consMZip m ms = fromStream $ K.consMStream m (toStream ms)
+
instance IsStream ZipSerialM where
toStream = getZipSerialM
fromStream = ZipSerialM
@@ -104,45 +116,52 @@ instance IsStream ZipSerialM where
{-# INLINE consM #-}
{-# SPECIALIZE consM :: IO a -> ZipSerialM IO a -> ZipSerialM IO a #-}
consM :: Monad m => m a -> ZipSerialM m a -> ZipSerialM m a
- consM m r = fromStream $ K.consMSerial m (toStream r)
+ consM = consMZip
{-# INLINE (|:) #-}
{-# SPECIALIZE (|:) :: IO a -> ZipSerialM IO a -> ZipSerialM IO a #-}
(|:) :: Monad m => m a -> ZipSerialM m a -> ZipSerialM m a
- m |: r = fromStream $ K.consMSerial m (toStream r)
+ (|:) = consMZip
+
+LIST_INSTANCES(ZipSerialM)
instance Monad m => Functor (ZipSerialM m) where
fmap = map
instance Monad m => Applicative (ZipSerialM m) where
pure = ZipSerialM . K.repeat
- m1 <*> m2 = fromStream $ K.zipWith id (toStream m1) (toStream m2)
+ (<*>) = K.zipWith id
+
+FOLDABLE_INSTANCE(ZipSerialM)
+TRAVERSABLE_INSTANCE(ZipSerialM)
------------------------------------------------------------------------------
-- Parallel Zipping
------------------------------------------------------------------------------
--- | Zip two streams concurrently (i.e. both the elements being zipped are
--- generated concurrently) using a pure zipping function.
+-- | Like 'zipWith' but zips concurrently i.e. both the streams being zipped
+-- are generated concurrently.
--
-- @since 0.1.0
+{-# INLINABLE zipAsyncWith #-}
zipAsyncWith :: (IsStream t, MonadAsync m)
=> (a -> b -> c) -> t m a -> t m b -> t m c
-zipAsyncWith f m1 m2 = fromStream $ Stream $ \st stp sng yld -> do
- ma <- mkAsync' (rstState st) m1
- mb <- mkAsync' (rstState st) m2
- unStream (toStream (K.zipWith f ma mb)) (rstState st) stp sng yld
+zipAsyncWith f m1 m2 = mkStream $ \st stp sng yld -> do
+ ma <- mkAsync' (adaptState st) m1
+ mb <- mkAsync' (adaptState st) m2
+ foldStream st stp sng yld (K.zipWith f ma mb)
--- | Zip two streams asyncly (i.e. both the elements being zipped are generated
--- concurrently) using a monadic zipping function.
+-- | Like 'zipWithM' but zips concurrently i.e. both the streams being zipped
+-- are generated concurrently.
--
-- @since 0.4.0
+{-# INLINABLE zipAsyncWithM #-}
zipAsyncWithM :: (IsStream t, MonadAsync m)
=> (a -> b -> m c) -> t m a -> t m b -> t m c
-zipAsyncWithM f m1 m2 = fromStream $ Stream $ \st stp sng yld -> do
- ma <- mkAsync' (rstState st) m1
- mb <- mkAsync' (rstState st) m2
- unStream (toStream (K.zipWithM f ma mb)) (rstState st) stp sng yld
+zipAsyncWithM f m1 m2 = mkStream $ \st stp sng yld -> do
+ ma <- mkAsync' (adaptState st) m1
+ mb <- mkAsync' (adaptState st) m2
+ foldStream st stp sng yld (K.zipWithM f ma mb)
------------------------------------------------------------------------------
-- Parallely Zipping Streams
@@ -185,6 +204,10 @@ zipAsyncly = K.adapt
{-# DEPRECATED zippingAsync "Please use zipAsyncly instead." #-}
zippingAsync :: IsStream t => ZipAsyncM m a -> t m a
zippingAsync = zipAsyncly
+
+consMZipAsync :: Monad m => m a -> ZipAsyncM m a -> ZipAsyncM m a
+consMZipAsync m ms = fromStream $ K.consMStream m (toStream ms)
+
instance IsStream ZipAsyncM where
toStream = getZipAsyncM
fromStream = ZipAsyncM
@@ -192,12 +215,12 @@ instance IsStream ZipAsyncM where
{-# INLINE consM #-}
{-# SPECIALIZE consM :: IO a -> ZipAsyncM IO a -> ZipAsyncM IO a #-}
consM :: Monad m => m a -> ZipAsyncM m a -> ZipAsyncM m a
- consM m r = fromStream $ K.consMSerial m (toStream r)
+ consM = consMZipAsync
{-# INLINE (|:) #-}
{-# SPECIALIZE (|:) :: IO a -> ZipAsyncM IO a -> ZipAsyncM IO a #-}
(|:) :: Monad m => m a -> ZipAsyncM m a -> ZipAsyncM m a
- m |: r = fromStream $ K.consMSerial m (toStream r)
+ (|:) = consMZipAsync
instance Monad m => Functor (ZipAsyncM m) where
fmap = map
diff --git a/src/Streamly/Streams/inline.h b/src/Streamly/Streams/inline.h
deleted file mode 100644
index 40a0765..0000000
--- a/src/Streamly/Streams/inline.h
+++ /dev/null
@@ -1,3 +0,0 @@
-#define INLINE_EARLY INLINE [2]
-#define INLINE_NORMAL INLINE [1]
-#define INLINE_LATE INLINE [0]
diff --git a/src/Streamly/Streams/inline.hs b/src/Streamly/Streams/inline.hs
new file mode 100644
index 0000000..daa7ec6
--- /dev/null
+++ b/src/Streamly/Streams/inline.hs
@@ -0,0 +1,27 @@
+-- We use fromStreamK/toStreamK to convert the direct style stream to CPS
+-- style. In the first phase we try fusing the fromStreamK/toStreamK using:
+--
+-- {-# RULES "fromStreamK/toStreamK fusion"
+-- forall s. toStreamK (fromStreamK s) = s #-}
+--
+-- If for some reason some of the operations could not be fused then we have
+-- fallback rules in the second phase. For example:
+--
+-- {-# INLINE_EARLY unfoldr #-}
+-- unfoldr :: (Monad m, IsStream t) => (b -> Maybe (a, b)) -> b -> t m a
+-- unfoldr step seed = fromStreamS (S.unfoldr step seed)
+-- {-# RULES "unfoldr fallback to StreamK" [1]
+-- forall a b. S.toStreamK (S.unfoldr a b) = K.unfoldr a b #-}```
+--
+-- Then, fromStreamK/toStreamK are inlined in the last phase:
+--
+-- {-# INLINE_LATE toStreamK #-}
+-- toStreamK :: Monad m => Stream m a -> K.Stream m a```
+--
+-- The fallback rules make sure that if we could not fuse the direct style
+-- operations then better use the CPS style operation, because unfused direct
+-- style would have worse performance than the CPS style ops.
+
+#define INLINE_EARLY INLINE [2]
+#define INLINE_NORMAL INLINE [1]
+#define INLINE_LATE INLINE [0]
diff --git a/src/Streamly/String.hs b/src/Streamly/String.hs
new file mode 100644
index 0000000..c6dffe3
--- /dev/null
+++ b/src/Streamly/String.hs
@@ -0,0 +1,28 @@
+-- |
+-- Module : Streamly.String
+-- Copyright : (c) 2018 Composewell Technologies
+--
+-- License : BSD3
+-- Maintainer : harendra.kumar@gmail.com
+-- Stability : experimental
+-- Portability : GHC
+--
+-- The 'String' type in this module is just a synonym for the type @List Char@.
+-- It provides better performance compared to the standard Haskell @String@
+-- type and can be used almost as a drop-in replacement, especially when used
+-- with @OverloadedStrings@ extension, with little differences.
+--
+-- See "Streamly.List", <src/docs/streamly-vs-lists.md> for more details and
+-- <src/test/PureStreams.hs> for comprehensive usage examples.
+--
+--
+module Streamly.String
+ (
+ String
+ )
+where
+
+import Streamly.List (List)
+import Prelude hiding (String)
+
+type String = List Char
diff --git a/src/Streamly/Tutorial.hs b/src/Streamly/Tutorial.hs
index 500226c..cd6a935 100644
--- a/src/Streamly/Tutorial.hs
+++ b/src/Streamly/Tutorial.hs
@@ -9,7 +9,7 @@
-- 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
+-- hand it extends the IO monad with concurrent 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.
@@ -87,8 +87,9 @@ module Streamly.Tutorial
-- *** Parallel Asynchronous Composition ('Parallel')
-- $parallel
- -- *** Custom composition
- -- $custom
+ -- XXX we should deprecate and remove the mkAsync API
+ -- Custom composition
+ -- custom
-- ** Monoid Style
-- $monoid
@@ -199,12 +200,18 @@ import Control.Monad.Trans.Class (MonadTrans (lift))
-- $concurrentStreams
--
--- Streams can be generated concurrently, even infnite streams can be generated
--- concurrently using controlled concurrency, streams can be merged
--- concurrently, multiple stages in a streaming pipeline can run concurrently,
--- streams can be mapped concurrently, they can be zipped concurrently, and in
--- a monadic composition they combine like a list transformer providing
--- concurrent non-determinism.
+-- Many stream operations can be done concurrently:
+--
+-- * Streams can be generated concurrently.
+--
+-- * Streams can be merged concurrently.
+--
+-- * Multiple stages in a streaming pipeline can run concurrently.
+--
+-- * Streams can be mapped and zipped concurrently.
+--
+-- * In monadic composition they combine like a list transformer,
+-- providing concurrent non-determinism.
--
-- There are three basic concurrent stream styles, 'Ahead', 'Async', and
-- 'Parallel'. The 'Ahead' style streams are similar to 'Serial' except that
@@ -229,35 +236,37 @@ import Control.Monad.Trans.Class (MonadTrans (lift))
-- asynchronous consumption the outputs are consumed as they arrive i.e. first
-- come first serve order.
--
--- @
-- +------------+--------------+--------------+--------------+
-- | Type | Execution | Consumption | Concurrency |
-- +============+==============+==============+==============+
--- | 'Serial' | Serial | Serial | None |
+-- | 'Serial' | Serial | Serial | None |
-- +------------+--------------+--------------+--------------+
--- | 'Ahead' | Asynchronous | Serial | bounded |
+-- | 'Ahead' | Asynchronous | Serial | bounded |
-- +------------+--------------+--------------+--------------+
--- | 'Async' | Asynchronous | Asynchronous | bounded |
+-- | 'Async' | Asynchronous | Asynchronous | bounded |
-- +------------+--------------+--------------+--------------+
--- | 'Parallel' | Asynchronous | Asynchronous | unbounded |
+-- | 'Parallel' | Asynchronous | Asynchronous | unbounded |
-- +------------+--------------+--------------+--------------+
--- @
--
-- 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
+-- combinators or type annotations, without any cost, to achieve the desired
+-- composition style. To force a particular type of composition, we coerce the
-- stream type using the corresponding type adapting combinator from
-- 'serially', 'aheadly', 'asyncly', or 'parallely'. The default stream type
-- is inferred as 'Serial' unless you change it by using one of the combinators
--- or using a type annotation.
+-- or by using a type annotation.
-- $flavors
--
--- Streams can be combined using semigroup or monoid composition to form a
--- composite stream. 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.
+-- Streams can be combined using '<>' or 'mappend' to form a
+-- composite. Composite streams can be interpreted in a depth first or
+-- breadth first manner using an appropriate type conversion before
+-- consumption. Deep (e.g. 'Serial') stream type variants traverse a
+-- composite stream in a depth first manner, such that each stream is
+-- traversed fully before traversing the next stream. Wide
+-- (e.g. 'WSerial') stream types traverse it in a breadth first
+-- manner, such that one element from each stream is traversed before
+-- coming back to the first stream again.
--
-- Each stream type has a wide traversal variant prefixed by 'W'. The wide
-- variant differs only in the Semigroup\/Monoid, Applicative\/Monad
@@ -384,12 +393,12 @@ import Control.Monad.Trans.Class (MonadTrans (lift))
-- $generatingConcurrently
--
--- Monadic construction and generation functions e.g. 'consM', 'unfoldrM',
--- 'replicateM', 'repeatM', 'iterateM' and 'fromFoldableM' etc work
--- concurrently when used with appropriate stream type combinator. The pure
--- versions of these APIs are not concurrent, however you can use the monadic
--- versions even for pure computations by wrapping the pure value in a monad to
--- get the concurrent generation capability where required.
+-- Monadic construction and generation functions like 'consM', 'unfoldrM',
+-- 'replicateM', 'repeatM', 'iterateM' and 'fromFoldableM' work concurrently
+-- when used with appropriate stream type combinator. The pure versions of
+-- these APIs are not concurrent, however you can use the monadic versions even
+-- for pure computations by wrapping the pure value in a monad to get the
+-- concurrent generation capability where required.
--
-- The following code finishes in 3 seconds (6 seconds when serial):
--
@@ -521,7 +530,7 @@ import Control.Monad.Trans.Class (MonadTrans (lift))
-- 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
+-- type annotation for the stream to achieve 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.
@@ -570,11 +579,11 @@ import Control.Monad.Trans.Class (MonadTrans (lift))
-- 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.
+-- 'WSerial' type annotation for the stream to achieve 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
+-- stream is performed 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
--
@@ -625,7 +634,7 @@ import Control.Monad.Trans.Class (MonadTrans (lift))
-- The 'Semigroup' operation '<>' of the 'Ahead' type combines two streams in a
-- /serial depth first/ manner with concurrent lookahead. We use the 'aheadly'
-- type combinator to effect 'Ahead' style of composition. We can also use an
--- explicit 'Ahead' type annotation for the stream to acheive the same effect.
+-- explicit 'Ahead' type annotation for the stream to achieve the same effect.
--
-- When two streams are combined in this manner, the streams are traversed in
-- depth first manner just like 'Serial', however it can execute the next
@@ -658,7 +667,7 @@ import Control.Monad.Trans.Class (MonadTrans (lift))
-- 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
+-- can also use the 'Async' type annotation for the stream type to achieve
-- the same effect.
--
-- When two streams with multiple elements are combined in this manner, the
@@ -839,7 +848,7 @@ import Control.Monad.Trans.Class (MonadTrans (lift))
-- 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.
+-- achieve the same effect.
--
-- When two streams with multiple elements are combined in this manner, the
-- monadic actions in both the streams are performed concurrently with a fair
@@ -884,6 +893,7 @@ import Control.Monad.Trans.Class (MonadTrans (lift))
-- number of streams, as it will lead to an infinite sized scheduling queue.
--
+-- XXX to be removed
-- $custom
--
-- The 'mkAsync' API can be used to create references to asynchronously running
@@ -1274,7 +1284,7 @@ import Control.Monad.Trans.Class (MonadTrans (lift))
-- [(1,3),(1,4),(2,3),(2,4)]
-- @
--
--- Similalrly 'WSerial' applicative runs the iterations in an interleaved
+-- Similarly 'WSerial' applicative runs the iterations in an interleaved
-- order but since it is serial it takes a total of 17 seconds:
--
-- @
@@ -1306,7 +1316,7 @@ import Control.Monad.Trans.Class (MonadTrans (lift))
-- [(1,3),(2,3),(1,4),(2,4)]
-- @
--
--- Similalrly 'WAsync' as well can run the iterations concurrently and
+-- Similarly 'WAsync' as well can run the iterations concurrently and
-- therefore takes a total of 10 seconds (1 + 2 + 3 + 4):
--
-- @
@@ -1431,7 +1441,9 @@ import Control.Monad.Trans.Class (MonadTrans (lift))
-- and operators instead of the ugly pragmas.
--
-- For more concurrent programming examples see,
--- "ListDir.hs", "MergeSort.hs" and "SearchQuery.hs" in the examples directory.
+-- <src/examples/ListDir.hs ListDir.hs>,
+-- <src/examples/MergeSort.hs MergeSort.hs> and
+-- <src/examples/SearchQuery.hs SearchQuery.hs> in the examples directory.
-- $reactive
--
@@ -1454,52 +1466,65 @@ import Control.Monad.Trans.Class (MonadTrans (lift))
-- {-\# LANGUAGE FlexibleContexts #-}
--
-- import "Streamly"
--- import Streamly.Prelude as S
--- import Control.Monad (when)
--- import Control.Monad.IO.Class (MonadIO(..))
--- import Control.Monad.State (MonadState, get, modify, runStateT)
+-- import "Streamly.Prelude" as S
+-- import Control.Monad (void, when)
+-- import Control.Monad.IO.Class (MonadIO(liftIO))
+-- import Control.Monad.State (MonadState, get, modify, runStateT, put)
--
--- data Event = Harm Int | Heal Int | Quit deriving (Show)
+-- data Event = Quit | Harm Int | Heal Int deriving (Show)
--
-- userAction :: MonadAsync m => 'SerialT' m Event
--- userAction = S.repeatM $ liftIO askUser
+-- userAction = S.'repeatM' $ liftIO askUser
-- where
-- askUser = do
-- command <- getLine
-- case command of
-- "potion" -> return (Heal 10)
--- "quit" -> return Quit
--- _ -> putStrLn "What?" >> askUser
+-- "harm" -> return (Harm 10)
+-- "quit" -> return Quit
+-- _ -> putStrLn "Type potion or harm or quit" >> askUser
+--
+-- acidRain :: MonadAsync m => 'SerialT' m Event
+-- acidRain = 'asyncly' $ 'constRate' 1 $ S.'repeatM' $ liftIO $ return $ Harm 1
--
--- acidRain :: MonadAsync m => SerialT m Event
--- acidRain = asyncly $ constRate 1 $ S.repeatM $ liftIO $ return $ Harm 1
+-- data Result = Check | Done
--
--- game :: ('MonadAsync' m, MonadState Int m) => 'SerialT' m ()
--- game = do
+-- runEvents :: (MonadAsync m, MonadState Int m) => 'SerialT' m Result
+-- runEvents = do
-- event \<- userAction \`parallel` acidRain
-- case event of
--- Harm n -> modify $ \\h -> h - n
--- Heal n -> modify $ \\h -> h + n
--- Quit -> fail "quit"
---
--- h <- get
--- when (h <= 0) $ fail "You die!"
--- liftIO $ putStrLn $ "Health = " ++ show h
---
+-- Harm n -> modify (\\h -> h - n) >> return Check
+-- Heal n -> modify (\\h -> h + n) >> return Check
+-- Quit -> return Done
+--
+-- data Status = Alive | GameOver deriving Eq
+--
+-- getStatus :: (MonadAsync m, MonadState Int m) => Result -> m Status
+-- getStatus result =
+-- case result of
+-- Done -> liftIO $ putStrLn "You quit!" >> return GameOver
+-- Check -> do
+-- h <- get
+-- liftIO $ if (h <= 0)
+-- then putStrLn "You die!" >> return GameOver
+-- else putStrLn ("Health = " <> show h) >> return Alive
+--
+-- main :: IO ()
-- main = do
-- putStrLn "Your health is deteriorating due to acid rain,\\
-- \\ type \\"potion\\" or \\"quit\\""
--- _ <- runStateT ('runStream' game) 60
--- return ()
+-- let runGame = S.'runWhile' (== Alive) $ S.'mapM' getStatus runEvents
+-- void $ runStateT runGame 60
-- @
--
-- You can also find the source of this example in the examples directory as
--- "AcidRain.hs". It has been adapted from Gabriel's
+-- <src/examples/AcidRain.hs 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
-- concurrency in streamly. You can also find a SDL based reactive programming
--- example adapted from Yampa in "Streamly.Examples.CirclingSquare".
+-- example adapted from Yampa in
+-- <src/examples/CirclingSquare.hs CirclingSquare.hs>.
-- $performance
--
@@ -1684,7 +1709,7 @@ import Control.Monad.Trans.Class (MonadTrans (lift))
-- 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. Streamly was in fact originally inspired by the
--- concurrency implementation in @transient@ though it has no resemblence with
+-- concurrency implementation in @transient@ though it has no resemblance with
-- that and takes a lazy pull approach versus transient's strict push approach.
--
-- The non-determinism, concurrency and streaming combination make streamly a
diff --git a/stack-7.10.yaml b/stack-7.10.yaml
index 64796c4..f0449ab 100644
--- a/stack-7.10.yaml
+++ b/stack-7.10.yaml
@@ -12,6 +12,7 @@ extra-deps:
- SDL-0.6.5.1
- gauge-0.2.4
- basement-0.0.7
+ - deepseq-1.4.4.0
flags: {}
extra-package-dbs: []
# For mac ports installed SDL library on Mac OS X
diff --git a/stack-8.0.yaml b/stack-8.0.yaml
index 3517879..ea2b290 100644
--- a/stack-8.0.yaml
+++ b/stack-8.0.yaml
@@ -8,6 +8,7 @@ extra-deps:
- SDL-0.6.5.1
- gauge-0.2.4
- basement-0.0.4
+ - deepseq-1.4.4.0
flags: {}
extra-package-dbs: []
rebuild-ghc-options: true
diff --git a/stack.yaml b/stack.yaml
index 22b9601..ff1b430 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -1,14 +1,16 @@
resolver: lts-12.11
packages:
- '.'
-allow-newer: true
extra-deps:
- SDL-0.6.6.0
- gauge-0.2.4
- Chart-1.9
- Chart-diagrams-1.9
- SVGFonts-1.6.0.3
- - bench-show-0.2.1
+ - bench-show-0.2.2
+ - statistics-0.15.0.0
+ - dense-linear-algebra-0.1.0.0
+ - math-functions-0.3.0.2
flags: {}
extra-package-dbs: []
diff --git a/streamly.cabal b/streamly.cabal
index 9dbabdf..1d9dedb 100644
--- a/streamly.cabal
+++ b/streamly.cabal
@@ -1,5 +1,5 @@
name: streamly
-version: 0.5.2
+version: 0.6.0
synopsis: Beautiful Streaming, Concurrent and Reactive Composition
description:
Streamly, short for streaming concurrently, provides monadic streams, with a
@@ -15,7 +15,6 @@ description:
.
The basic streaming functionality of streamly is equivalent to that provided by
streaming libraries like
- <https://hackage.haskell.org/package/vector vector>,
<https://hackage.haskell.org/package/streaming streaming>,
<https://hackage.haskell.org/package/pipes pipes>, and
<https://hackage.haskell.org/package/conduit conduit>.
@@ -31,8 +30,8 @@ description:
.
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".
+ IO options. Streamly interoperates with the popular streaming libraries, see
+ the interoperation section in "Streamly.Tutorial".
.
Why use streamly?
.
@@ -69,7 +68,10 @@ 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.3
+tested-with: GHC==7.10.3
+ , GHC==8.0.2
+ , GHC==8.4.4
+ , GHC==8.6.3
author: Harendra Kumar
maintainer: harendra.kumar@gmail.com
copyright: 2017 Harendra Kumar
@@ -88,7 +90,7 @@ extra-source-files:
stack-8.0.yaml
stack.yaml
src/Streamly/Streams/Instances.hs
- src/Streamly/Streams/inline.h
+ src/Streamly/Streams/inline.hs
source-repository head
type: git
@@ -126,15 +128,25 @@ flag examples-sdl
library
hs-source-dirs: src
other-modules: Streamly.SVar
+
+ -- Base streams
+ , Streamly.Streams.StreamK.Type
, Streamly.Streams.StreamK
+ , Streamly.Streams.StreamD.Type
, Streamly.Streams.StreamD
- , Streamly.Streams.Serial
+ , Streamly.Streams.Prelude
+
+ -- Higher level streams
, Streamly.Streams.SVar
+ , Streamly.Streams.Serial
, Streamly.Streams.Async
, Streamly.Streams.Parallel
, Streamly.Streams.Ahead
, Streamly.Streams.Zip
- , Streamly.Streams.Prelude
+ , Streamly.Streams.Combinators
+ , Streamly.List
+ , Streamly.String
+ , Streamly.Enumeration
exposed-modules: Streamly.Prelude
, Streamly.Time
@@ -143,7 +155,7 @@ library
, Streamly.Internal
default-language: Haskell2010
- ghc-options: -Wall
+ ghc-options: -Wall -fspec-constr-recursive=10
if flag(streamk)
cpp-options: -DUSE_STREAMK_ONLY
@@ -167,6 +179,7 @@ library
build-depends: base >= 4.8 && < 5
, ghc-prim >= 0.2 && < 0.6
+ , deepseq >= 1.4.3 && < 1.5
, containers >= 0.5 && < 0.7
, heaps >= 0.3 && < 0.4
@@ -220,6 +233,55 @@ test-suite test
, exceptions >= 0.8 && < 0.11
default-language: Haskell2010
+-- test-suite pure-streams-base
+-- type: exitcode-stdio-1.0
+-- main-is: PureStreams.hs
+-- hs-source-dirs: test
+-- ghc-options: -O0 -Wall -threaded -with-rtsopts=-N -fno-ignore-asserts
+-- if flag(dev)
+-- cpp-options: -DDEVBUILD
+-- 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
+-- , hspec >= 2.0 && < 3
+-- default-language: Haskell2010
+--
+-- test-suite pure-streams-streamly
+-- type: exitcode-stdio-1.0
+-- main-is: PureStreams.hs
+-- hs-source-dirs: test
+-- cpp-options: -DUSE_STREAMLY_LIST
+-- ghc-options: -O0 -Wall -threaded -with-rtsopts=-N -fno-ignore-asserts
+-- if flag(dev)
+-- cpp-options: -DDEVBUILD
+-- 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
+-- , hspec >= 2.0 && < 3
+-- default-language: Haskell2010
+
test-suite properties
type: exitcode-stdio-1.0
main-is: Prop.hs
@@ -261,7 +323,7 @@ test-suite maxrate
, base >= 4.8 && < 5
, clock >= 0.7.1 && < 0.8
, hspec >= 2.0 && < 3
- , random >= 1.0.0 && < 1.2
+ , random >= 1.0.0 && < 2
else
buildable: False
@@ -284,7 +346,7 @@ test-suite nested-loops
build-Depends:
streamly
, base >= 4.8 && < 5
- , random >= 1.0.0 && < 1.2
+ , random >= 1.0.0 && < 2
test-suite parallel-loops
type: exitcode-stdio-1.0
@@ -295,7 +357,7 @@ test-suite parallel-loops
build-Depends:
streamly
, base >= 4.8 && < 5
- , random >= 1.0.0 && < 1.2
+ , random >= 1.0.0 && < 2
-------------------------------------------------------------------------------
-- Benchmarks
@@ -307,7 +369,7 @@ benchmark linear
main-is: Linear.hs
other-modules: LinearOps
default-language: Haskell2010
- ghc-options: -O2 -Wall
+ ghc-options: -O2 -Wall -fspec-constr-recursive=10
if flag(dev)
ghc-options: -Wmissed-specialisations
-Wall-missed-specialisations
@@ -324,7 +386,7 @@ benchmark linear
build-depends:
streamly
, base >= 4.8 && < 5
- , deepseq >= 1.4.0 && < 1.5
+ , deepseq >= 1.4.3 && < 1.5
, random >= 1.0 && < 2.0
, gauge >= 0.2.4 && < 0.3
@@ -334,7 +396,7 @@ benchmark linear-async
main-is: LinearAsync.hs
other-modules: LinearOps
default-language: Haskell2010
- ghc-options: -O2 -Wall
+ ghc-options: -O2 -Wall -fspec-constr-recursive=10
cpp-options: -DLINEAR_ASYNC
if flag(dev)
ghc-options: -Wmissed-specialisations
@@ -352,7 +414,7 @@ benchmark linear-async
build-depends:
streamly
, base >= 4.8 && < 5
- , deepseq >= 1.4.0 && < 1.5
+ , deepseq >= 1.4.3 && < 1.5
, random >= 1.0 && < 2.0
, gauge >= 0.2.4 && < 0.3
@@ -362,7 +424,7 @@ benchmark linear-rate
main-is: LinearRate.hs
other-modules: LinearOps
default-language: Haskell2010
- ghc-options: -O2 -Wall
+ ghc-options: -O2 -Wall -fspec-constr-recursive=10
if flag(dev)
ghc-options: -Wmissed-specialisations
-Wall-missed-specialisations
@@ -379,7 +441,7 @@ benchmark linear-rate
build-depends:
streamly
, base >= 4.8 && < 5
- , deepseq >= 1.4.0 && < 1.5
+ , deepseq >= 1.4.3 && < 1.5
, random >= 1.0 && < 2.0
, gauge >= 0.2.4 && < 0.3
@@ -389,7 +451,7 @@ benchmark nested
main-is: Nested.hs
other-modules: NestedOps
default-language: Haskell2010
- ghc-options: -O2 -Wall
+ ghc-options: -O2 -Wall -fspec-constr-recursive=10
if flag(dev)
ghc-options: -Wmissed-specialisations
-Wall-missed-specialisations
@@ -406,7 +468,7 @@ benchmark nested
build-depends:
streamly
, base >= 4.8 && < 5
- , deepseq >= 1.4.0 && < 1.5
+ , deepseq >= 1.4.3 && < 1.5
, random >= 1.0 && < 2.0
, gauge >= 0.2.4 && < 0.3
@@ -422,7 +484,9 @@ benchmark base
hs-source-dirs: benchmark, src
main-is: BaseStreams.hs
other-modules: Streamly.SVar
+ , Streamly.Streams.StreamK.Type
, Streamly.Streams.StreamK
+ , Streamly.Streams.StreamD.Type
, Streamly.Streams.StreamD
, Streamly.Streams.Prelude
@@ -430,7 +494,7 @@ benchmark base
, StreamKOps
default-language: Haskell2010
- ghc-options: -O2 -Wall
+ ghc-options: -O2 -Wall -fspec-constr-recursive=10
if flag(dev)
ghc-options: -Wmissed-specialisations
-Wall-missed-specialisations
@@ -445,30 +509,83 @@ benchmark base
-Wnoncanonical-monad-instances
-Wnoncanonical-monadfail-instances
- build-depends:
- base >= 4.8 && < 5
- , deepseq >= 1.4.0 && < 1.5
- , random >= 1.0 && < 2.0
- , gauge >= 0.2.4 && < 0.3
+ if flag(dev)
+ buildable: True
+ build-depends:
+ base >= 4.8 && < 5
+ , deepseq >= 1.4.3 && < 1.5
+ , random >= 1.0 && < 2.0
+ , gauge >= 0.2.4 && < 0.3
- , ghc-prim >= 0.2 && < 0.6
- , containers >= 0.5 && < 0.7
- , heaps >= 0.3 && < 0.4
+ , ghc-prim >= 0.2 && < 0.6
+ , containers >= 0.5 && < 0.7
+ , heaps >= 0.3 && < 0.4
- -- concurrency
- , atomic-primops >= 0.8 && < 0.9
- , lockfree-queue >= 0.2.3 && < 0.3
- , clock >= 0.7.1 && < 0.8
+ -- concurrency
+ , atomic-primops >= 0.8 && < 0.9
+ , lockfree-queue >= 0.2.3 && < 0.3
+ , clock >= 0.7.1 && < 0.8
- , exceptions >= 0.8 && < 0.11
- , monad-control >= 1.0 && < 2
- , mtl >= 2.2 && < 3
- , transformers >= 0.4 && < 0.6
- , transformers-base >= 0.4 && < 0.5
+ , exceptions >= 0.8 && < 0.11
+ , monad-control >= 1.0 && < 2
+ , mtl >= 2.2 && < 3
+ , transformers >= 0.4 && < 0.6
+ , transformers-base >= 0.4 && < 0.5
- if impl(ghc < 8.0)
- build-depends:
- semigroups >= 0.18 && < 0.19
+ if impl(ghc < 8.0)
+ build-depends:
+ semigroups >= 0.18 && < 0.19
+ else
+ buildable: False
+
+executable nano-bench
+ hs-source-dirs: benchmark, src
+ main-is: NanoBenchmarks.hs
+ other-modules: Streamly.SVar
+ , Streamly.Streams.StreamK.Type
+ , Streamly.Streams.StreamK
+ , Streamly.Streams.StreamD.Type
+ , Streamly.Streams.StreamD
+ default-language: Haskell2010
+ ghc-options: -O2 -Wall
+
+ if flag(dev)
+ buildable: True
+ build-depends:
+ base >= 4.8 && < 5
+ , gauge >= 0.2.4 && < 0.3
+ , ghc-prim >= 0.2 && < 0.6
+ , containers >= 0.5 && < 0.7
+ , heaps >= 0.3 && < 0.4
+ , random >= 1.0 && < 2.0
+
+ -- concurrency
+ , atomic-primops >= 0.8 && < 0.9
+ , lockfree-queue >= 0.2.3 && < 0.3
+ , clock >= 0.7.1 && < 0.8
+
+ , exceptions >= 0.8 && < 0.11
+ , monad-control >= 1.0 && < 2
+ , mtl >= 2.2 && < 3
+ , transformers >= 0.4 && < 0.6
+ else
+ buildable: False
+
+executable adaptive
+ hs-source-dirs: benchmark
+ main-is: Adaptive.hs
+ default-language: Haskell2010
+ ghc-options: -O2 -Wall
+
+ if flag(dev)
+ buildable: True
+ build-depends:
+ streamly
+ , base >= 4.8 && < 5
+ , gauge >= 0.2.4 && < 0.3
+ , random >= 1.0 && < 2.0
+ else
+ buildable: False
executable chart
default-language: Haskell2010
@@ -510,7 +627,7 @@ executable ListDir
build-Depends:
streamly
, base >= 4.8 && < 5
- , path-io >= 0.1.0 && < 1.4
+ , path-io >= 0.1.0 && < 1.5
if impl(ghc < 8.0)
build-depends:
transformers >= 0.4 && < 0.6
@@ -526,7 +643,7 @@ executable MergeSort
build-Depends:
streamly
, base >= 4.8 && < 5
- , random >= 1.0.0 && < 1.2
+ , random >= 1.0.0 && < 2
else
buildable: False
diff --git a/test/Prop.hs b/test/Prop.hs
index 419328d..694af3a 100644
--- a/test/Prop.hs
+++ b/test/Prop.hs
@@ -13,12 +13,15 @@ import Data.Function ((&))
import Data.IORef (readIORef, modifyIORef, newIORef)
import Data.List
(sort, foldl', scanl', findIndices, findIndex, elemIndices,
- elemIndex, find, intersperse, foldl1', (\\))
+ elemIndex, find, insertBy, intersperse, foldl1', (\\),
+ maximumBy, minimumBy, deleteBy, isPrefixOf, isSubsequenceOf,
+ stripPrefix)
import Data.Maybe (mapMaybe)
import GHC.Word (Word8)
import Test.Hspec.QuickCheck
-import Test.QuickCheck (counterexample, Property, withMaxSuccess)
+import Test.QuickCheck
+ (counterexample, Property, withMaxSuccess, forAll, choose)
import Test.QuickCheck.Monadic (run, monadicIO, monitor, assert, PropertyM)
import Test.Hspec as H
@@ -72,31 +75,86 @@ listEquals eq stream list = do
)
assert (stream `eq` list)
-constructWithReplicateM
- :: IsStream t
- => (t IO Int -> SerialT IO Int)
+-------------------------------------------------------------------------------
+-- Construction operations
+-------------------------------------------------------------------------------
+
+constructWithLen
+ :: (Show a, Eq a)
+ => (Int -> t IO a)
+ -> (Int -> [a])
+ -> (t IO a -> SerialT IO a)
-> Word8
-> Property
-constructWithReplicateM op len = withMaxSuccess maxTestCount $
+constructWithLen mkStream mkList op len = withMaxSuccess maxTestCount $
monadicIO $ do
- let x = return (1 :: Int)
- stream <- run $ (S.toList . op) (S.replicateM (fromIntegral len) x)
- list <- run $ replicateM (fromIntegral len) x
+ stream <- run $ (S.toList . op) (mkStream (fromIntegral len))
+ let list = mkList (fromIntegral len)
listEquals (==) stream list
-transformFromList
- :: (Eq b, Show b) =>
- ([a] -> t IO a)
- -> ([b] -> [b] -> Bool)
- -> ([a] -> [b])
- -> (t IO a -> SerialT IO b)
- -> [a]
+constructWithLenM
+ :: (Int -> t IO Int)
+ -> (Int -> IO [Int])
+ -> (t IO Int -> SerialT IO Int)
+ -> Word8
-> Property
-transformFromList constr eq listOp op a =
+constructWithLenM mkStream mkList op len = withMaxSuccess maxTestCount $
monadicIO $ do
- stream <- run ((S.toList . op) (constr a))
- let list = listOp a
- listEquals eq stream list
+ stream <- run $ (S.toList . op) (mkStream (fromIntegral len))
+ list <- run $ mkList (fromIntegral len)
+ listEquals (==) stream list
+
+constructWithReplicate, constructWithReplicateM, constructWithIntFromThenTo
+ :: IsStream t
+ => (t IO Int -> SerialT IO Int)
+ -> Word8
+ -> Property
+
+constructWithReplicateM = constructWithLenM stream list
+ where list = flip replicateM (return 1 :: IO Int)
+ stream = flip S.replicateM (return 1 :: IO Int)
+
+constructWithReplicate = constructWithLen stream list
+ where list = flip replicate (1 :: Int)
+ stream = flip S.replicate (1 :: Int)
+
+constructWithIntFromThenTo op l =
+ forAll (choose (minBound, maxBound)) $ \from ->
+ forAll (choose (minBound, maxBound)) $ \next ->
+ forAll (choose (minBound, maxBound)) $ \to ->
+ let list len = take len [from,next..to]
+ stream len = S.take len $ S.enumerateFromThenTo from next to
+ in constructWithLen stream list op l
+
+#if __GLASGOW_HASKELL__ >= 806
+-- XXX try very small steps close to 0
+constructWithDoubleFromThenTo
+ :: IsStream t
+ => (t IO Double -> SerialT IO Double)
+ -> Word8
+ -> Property
+constructWithDoubleFromThenTo op l =
+ forAll (choose (-9007199254740999,9007199254740999)) $ \from ->
+ forAll (choose (-9007199254740999,9007199254740999)) $ \next ->
+ forAll (choose (-9007199254740999,9007199254740999)) $ \to ->
+ let list len = take len [from,next..to]
+ stream len = S.take len $ S.enumerateFromThenTo from next to
+ in constructWithLen stream list op l
+#endif
+
+constructWithIterate :: IsStream t => (t IO Int -> SerialT IO Int) -> Spec
+constructWithIterate t = do
+ it "iterate" $
+ (S.toList . t . S.take 100) (S.iterate (+ 1) (0 :: Int))
+ `shouldReturn` take 100 (iterate (+ 1) 0)
+ it "iterateM" $ do
+ let addM y = return (y + 1)
+ S.toList . t . S.take 100 $ S.iterateM addM (0 :: Int)
+ `shouldReturn` take 100 (iterate (+ 1) 0)
+
+-------------------------------------------------------------------------------
+-- Concurrent generation
+-------------------------------------------------------------------------------
mvarExcHandler :: String -> BlockedIndefinitelyOnMVar -> IO ()
mvarExcHandler label BlockedIndefinitelyOnMVar =
@@ -199,6 +257,32 @@ concurrentUnfoldrM eq op n =
return x
listEquals eq stream list
+concurrentOps
+ :: IsStream t
+ => ([Word8] -> t IO Word8)
+ -> String
+ -> ([Word8] -> [Word8] -> Bool)
+ -> (t IO Word8 -> SerialT IO Word8)
+ -> Spec
+concurrentOps constr desc eq t = do
+ let prop1 d p = prop d $ withMaxSuccess maxTestCount p
+
+ prop1 (desc <> " fromFoldableM") $ concurrentFromFoldable eq t
+ prop1 (desc <> " unfoldrM") $ concurrentUnfoldrM eq t
+ -- we pass it the length of the stream n and an mvar mv.
+ -- The stream is [0..n]. The threads communicate in such a way that the
+ -- actions coming first in the stream are dependent on the last action. So
+ -- if the stream is not processed concurrently it will block forever.
+ -- Note that if the size of the stream is bigger than the thread limit
+ -- then it will block even if it is concurrent.
+ prop1 (desc <> " mapM") $
+ concurrentMapM constr eq $ \n mv stream ->
+ t $ S.mapM (mvarSequenceOp mv n) stream
+
+-------------------------------------------------------------------------------
+-- Concurrent Application
+-------------------------------------------------------------------------------
+
concurrentApplication :: IsStream t
=> ([Word8] -> [Word8] -> Bool)
-> (t IO Word8 -> SerialT IO Word8)
@@ -255,6 +339,10 @@ concurrentFoldrApplication n =
sourceUnfoldrM1 n |&. S.foldrM (\x xs -> return (x : xs)) []
listEquals (==) stream list
+-------------------------------------------------------------------------------
+-- Transformation operations
+-------------------------------------------------------------------------------
+
transformCombineFromList
:: Semigroup (t IO Int)
=> ([Int] -> t IO Int)
@@ -274,129 +362,13 @@ transformCombineFromList constr eq listOp t op a b c =
let list = a <> listOp (b <> c)
listEquals eq stream list
-foldFromList
- :: ([Int] -> t IO Int)
- -> (t IO Int -> SerialT IO Int)
- -> ([Int] -> [Int] -> Bool)
- -> [Int]
- -> Property
-foldFromList constr op eq = transformFromList constr eq id op
-
-eliminateOp
- :: (Show a, Eq a)
- => ([s] -> t IO s)
- -> ([s] -> a)
- -> (t IO s -> IO a)
- -> [s]
- -> 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
- -> ([Int] -> [Int] -> Bool)
- -> (t IO Int -> SerialT IO Int)
- -> Spec
-functorOps constr desc eq t = 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
- -> ([Int] -> [Int] -> Bool)
- -> (t IO Int -> SerialT IO Int)
- -> Spec
-transformOps constr desc eq t = do
- let transform = transformFromList constr eq
- -- Filtering
- prop (desc <> " filter False") $
- transform (filter (const False)) $ t . S.filter (const False)
- prop (desc <> " filter True") $
- transform (filter (const True)) $ t . S.filter (const True)
- prop (desc <> " filter even") $
- transform (filter even) $ t . S.filter even
-
- prop (desc <> " take maxBound") $
- transform (take maxBound) $ t . S.take maxBound
- prop (desc <> " take 0") $ transform (take 0) $ t . S.take 0
- prop (desc <> " take 1") $ transform (take 1) $ t . S.take 1
- prop (desc <> " take 10") $ transform (take 10) $ t . S.take 10
-
- prop (desc <> " takeWhile True") $
- transform (takeWhile (const True)) $ t . S.takeWhile (const True)
- prop (desc <> " takeWhile False") $
- transform (takeWhile (const False)) $ t . S.takeWhile (const False)
- prop (desc <> " takeWhile > 0") $
- transform (takeWhile (> 0)) $ t . S.takeWhile (> 0)
-
- let f x = if odd x then Just (x + 100) else Nothing
- prop (desc <> " mapMaybe") $ transform (mapMaybe f) $ t . S.mapMaybe f
-
- prop (desc <> " drop maxBound") $
- transform (drop maxBound) $ t . S.drop maxBound
- prop (desc <> " drop 0") $ transform (drop 0) $ t . S.drop 0
- prop (desc <> " drop 1") $ transform (drop 1) $ t . S.drop 1
- prop (desc <> " drop 10") $ transform (drop 10) $ t . S.drop 10
-
- prop (desc <> " dropWhile True") $
- transform (dropWhile (const True)) $ t . S.dropWhile (const True)
- prop (desc <> " dropWhile False") $
- transform (dropWhile (const False)) $ t . S.dropWhile (const False)
- prop (desc <> " dropWhile > 0") $
- transform (dropWhile (> 0)) $ t . S.dropWhile (> 0)
- prop (desc <> " scan") $ transform (scanl' (+) 0) $ t . S.scanl' (+) 0
- prop (desc <> " reverse") $ transform reverse $ t . S.reverse
-
- prop (desc <> " findIndices") $ transform (findIndices odd) $ t . S.findIndices odd
- prop (desc <> " elemIndices") $ transform (elemIndices 3) $ t . S.elemIndices 3
-
- prop (desc <> " intersperseM") $ transform (intersperse 3) $ t . S.intersperseM (return 3)
-
-
-concurrentOps
- :: IsStream t
- => ([Word8] -> t IO Word8)
- -> String
- -> ([Word8] -> [Word8] -> Bool)
- -> (t IO Word8 -> SerialT IO Word8)
- -> Spec
-concurrentOps constr desc eq t = do
- let prop1 d p = prop d $ withMaxSuccess maxTestCount p
-
- prop1 (desc <> " fromFoldableM") $ concurrentFromFoldable eq t
- prop1 (desc <> " unfoldrM") $ concurrentUnfoldrM eq t
- -- we pass it the length of the stream n and an mvar mv.
- -- The stream is [0..n]. The threads communicate in such a way that the
- -- actions coming first in the stream are dependent on the last action. So
- -- if the stream is not processed concurrently it will block forever.
- -- Note that if the size of the stream is bigger than the thread limit
- -- then it will block even if it is concurrent.
- prop1 (desc <> " mapM") $
- concurrentMapM constr eq $ \n mv stream ->
- t $ S.mapM (mvarSequenceOp mv n) stream
-
-- XXX add tests for MonadReader and MonadError etc. In case an SVar is
-- accidentally passed through them.
+--
+-- This tests transform ops along with detecting illegal sharing of SVar across
+-- conurrent streams. These tests work for all stream types whereas
+-- transformCombineOpsOrdered work only for ordered stream types i.e. excluding
+-- the Async type.
transformCombineOpsCommon
:: (IsStream t, Semigroup (t IO Int))
=> ([Int] -> t IO Int)
@@ -406,6 +378,7 @@ transformCombineOpsCommon
-> Spec
transformCombineOpsCommon constr desc eq t = do
let transform = transformCombineFromList constr eq
+
-- Filtering
prop (desc <> " filter False") $
transform (filter (const False)) t (S.filter (const False))
@@ -449,18 +422,49 @@ transformCombineOpsCommon constr desc eq t = do
prop (desc <> " dropWhileM False") $
transform (dropWhile (const False)) t (S.dropWhileM (const $ return False))
+ prop (desc <> " deleteBy (<=) maxBound") $
+ transform (deleteBy (<=) maxBound) t (S.deleteBy (<=) maxBound)
+ prop (desc <> " deleteBy (==) 4") $
+ transform (deleteBy (==) 4) t (S.deleteBy (==) 4)
+
+ -- transformation
prop (desc <> " mapM (+1)") $
transform (fmap (+1)) t (S.mapM (\x -> return (x + 1)))
- prop (desc <> " scan") $ transform (scanl' (flip const) 0) t
+ prop (desc <> " scanl'") $ transform (scanl' (flip const) 0) t
(S.scanl' (flip const) 0)
prop (desc <> " scanlM'") $ transform (scanl' (flip const) 0) t
(S.scanlM' (\_ a -> return a) 0)
+ prop (desc <> " scanl") $ transform (scanl' (flip const) 0) t
+ (S.scanl' (flip const) 0)
+ prop (desc <> " scanl1'") $ transform (scanl1 (flip const)) t
+ (S.scanl1' (flip const))
+ prop (desc <> " scanl1M'") $ transform (scanl1 (flip const)) t
+ (S.scanl1M' (\_ a -> return a))
+
+ let f x = if odd x then Just (x + 100) else Nothing
+ prop (desc <> " mapMaybe") $ transform (mapMaybe f) t (S.mapMaybe f)
+
+ -- reordering
prop (desc <> " reverse") $ transform reverse t S.reverse
+ -- inserting
prop (desc <> " intersperseM") $
- transform (intersperse 3) t (S.intersperseM $ return 3)
-
+ forAll (choose (minBound, maxBound)) $ \n ->
+ transform (intersperse n) t (S.intersperseM $ return n)
+ prop (desc <> " insertBy 0") $
+ forAll (choose (minBound, maxBound)) $ \n ->
+ transform (insertBy compare n) t (S.insertBy compare n)
+
+ -- multi-stream
+ prop (desc <> " concatMap") $
+ forAll (choose (0, 100)) $ \n ->
+ transform (concatMap (const [1..n]))
+ t (S.concatMap (const (S.fromList [1..n])))
+
+-- transformation tests that can only work reliably for ordered streams i.e.
+-- Serial, Ahead and Zip. For example if we use "take 1" on an async stream, it
+-- might yield a different result every time.
transformCombineOpsOrdered
:: (IsStream t, Semigroup (t IO Int))
=> ([Int] -> t IO Int)
@@ -470,6 +474,7 @@ transformCombineOpsOrdered
-> Spec
transformCombineOpsOrdered constr desc eq t = do
let transform = transformCombineFromList constr eq
+
-- Filtering
prop (desc <> " take 1") $ transform (take 1) t (S.take 1)
#ifdef DEVBUILD
@@ -490,18 +495,49 @@ transformCombineOpsOrdered constr desc eq t = do
transform (dropWhile (> 0)) t (S.dropWhile (> 0))
prop (desc <> " scan") $ transform (scanl' (+) 0) t (S.scanl' (+) 0)
- -- XXX this does not fail when the SVar is shared, need to fix.
- prop (desc <> " concurrent application") $
- transform (& fmap (+1)) t (|& S.map (+1))
+ -- XXX add uniq
+ prop (desc <> " deleteBy (<=) 0") $
+ transform (deleteBy (<=) 0) t (S.deleteBy (<=) 0)
prop (desc <> " findIndices") $
transform (findIndices odd) t (S.findIndices odd)
prop (desc <> " elemIndices") $
transform (elemIndices 0) t (S.elemIndices 0)
+ -- XXX this does not fail when the SVar is shared, need to fix.
+ prop (desc <> " concurrent application") $
+ transform (& fmap (+1)) t (|& S.map (+1))
+
+-------------------------------------------------------------------------------
+-- Elimination operations
+-------------------------------------------------------------------------------
+
+eliminateOp
+ :: (Show a, Eq a)
+ => ([s] -> t IO s)
+ -> ([s] -> a)
+ -> (t IO s -> IO a)
+ -> [s]
+ -> Property
+eliminateOp constr listOp op a =
+ monadicIO $ do
+ stream <- run $ op (constr a)
+ let list = listOp a
+ equals (==) stream list
+
wrapMaybe :: ([a1] -> a2) -> [a1] -> Maybe a2
wrapMaybe f x = if null x then Nothing else Just (f x)
+wrapOutOfBounds :: ([a1] -> Int -> a2) -> Int -> [a1] -> Maybe a2
+wrapOutOfBounds f i x | null x = Nothing
+ | i >= length x = Nothing
+ | otherwise = Just (f x i)
+
+wrapThe :: Eq a => [a] -> Maybe a
+wrapThe (x:xs) | all (x ==) xs = Just x
+ | otherwise = Nothing
+wrapThe [] = Nothing
+
eliminationOps
:: ([Int] -> t IO Int)
-> String
@@ -526,25 +562,60 @@ eliminationOps constr desc t = do
prop (desc <> " sum") $ eliminateOp constr sum $ S.sum . t
prop (desc <> " product") $ eliminateOp constr product $ S.product . t
- prop (desc <> " maximum") $ eliminateOp constr (wrapMaybe maximum) $ S.maximum . t
- prop (desc <> " minimum") $ eliminateOp constr (wrapMaybe minimum) $ S.minimum . t
-
- prop (desc <> " findIndex") $ eliminateOp constr (findIndex odd) $ S.findIndex odd . t
- prop (desc <> " elemIndex") $ eliminateOp constr (elemIndex 3) $ S.elemIndex 3 . t
+ prop (desc <> " maximum") $
+ eliminateOp constr (wrapMaybe maximum) $ S.maximum . t
+ prop (desc <> " minimum") $
+ eliminateOp constr (wrapMaybe minimum) $ S.minimum . t
+
+ prop (desc <> " maximumBy compare") $
+ eliminateOp constr (wrapMaybe $ maximumBy compare) $
+ S.maximumBy compare . t
+ prop (desc <> " maximumBy flip compare") $
+ eliminateOp constr (wrapMaybe $ maximumBy $ flip compare) $
+ S.maximumBy (flip compare) . t
+ prop (desc <> " minimumBy compare") $
+ eliminateOp constr (wrapMaybe $ minimumBy compare) $
+ S.minimumBy compare . t
+ prop (desc <> " minimumBy flip compare") $
+ eliminateOp constr (wrapMaybe $ minimumBy $ flip compare) $
+ S.minimumBy (flip compare) . t
+
+ prop (desc <> " findIndex") $
+ eliminateOp constr (findIndex odd) $ S.findIndex odd . t
+ prop (desc <> " elemIndex") $
+ eliminateOp constr (elemIndex 3) $ S.elemIndex 3 . t
+
+ prop (desc <> " !! 5") $
+ eliminateOp constr (wrapOutOfBounds (!!) 5) $ (S.!! 5) . t
+ prop (desc <> " !! 4") $
+ eliminateOp constr (wrapOutOfBounds (!!) 0) $ (S.!! 0) . t
prop (desc <> " find") $ eliminateOp constr (find even) $ S.find even . t
prop (desc <> " lookup") $
eliminateOp constr (lookup 3 . flip zip [1..]) $
S.lookup 3 . S.zipWith (\a b -> (b, a)) (S.fromList [(1::Int)..]) . t
+ prop (desc <> " the") $ eliminateOp constr wrapThe $ S.the . t
+
+ -- Multi-stream eliminations
+ -- Add eqBy, cmpBy
+ -- XXX Write better tests for substreams.
+ prop (desc <> " isPrefixOf 10") $ eliminateOp constr (isPrefixOf [1..10]) $
+ S.isPrefixOf (S.fromList [(1::Int)..10]) . t
+ prop (desc <> " isSubsequenceOf 10") $
+ eliminateOp constr (isSubsequenceOf $ filter even [1..10]) $
+ S.isSubsequenceOf (S.fromList $ filter even [(1::Int)..10]) . t
+ prop (desc <> " stripPrefix 10") $ eliminateOp constr (stripPrefix [1..10]) $
+ (\s -> s >>= maybe (return Nothing) (fmap Just . S.toList)) .
+ S.stripPrefix (S.fromList [(1::Int)..10]) . t
-- head/tail/last may depend on the order in case of parallel streams
-- so we test these only for serial streams.
-serialEliminationOps
+eliminationOpsOrdered
:: ([Int] -> t IO Int)
-> String
-> (t IO Int -> SerialT IO Int)
-> Spec
-serialEliminationOps constr desc t = do
+eliminationOpsOrdered constr desc t = do
prop (desc <> " head") $ eliminateOp constr (wrapMaybe head) $ S.head . t
prop (desc <> " tail") $ eliminateOp constr (wrapMaybe tail) $ \x -> do
r <- S.tail (t x)
@@ -558,14 +629,53 @@ serialEliminationOps constr desc t = do
Nothing -> return Nothing
Just s -> Just <$> S.toList s
-transformOpsWord8
+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
+
+eliminationOpsWord8
:: ([Word8] -> t IO Word8)
-> String
-> (t IO Word8 -> SerialT IO Word8)
-> Spec
-transformOpsWord8 constr desc t = do
+eliminationOpsWord8 constr desc t = do
prop (desc <> " elem") $ elemOp constr t S.elem elem
- prop (desc <> " elem") $ elemOp constr t S.notElem notElem
+ prop (desc <> " notElem") $ elemOp constr t S.notElem notElem
+
+-------------------------------------------------------------------------------
+-- Semigroup operations
+-------------------------------------------------------------------------------
+
+transformFromList
+ :: (Eq b, Show b) =>
+ ([a] -> t IO a)
+ -> ([b] -> [b] -> Bool)
+ -> ([a] -> [b])
+ -> (t IO a -> SerialT IO b)
+ -> [a]
+ -> Property
+transformFromList constr eq listOp op a =
+ monadicIO $ do
+ stream <- run ((S.toList . op) (constr a))
+ let list = listOp a
+ listEquals eq stream list
+
+foldFromList
+ :: ([Int] -> t IO Int)
+ -> (t IO Int -> SerialT IO Int)
+ -> ([Int] -> [Int] -> Bool)
+ -> [Int]
+ -> Property
+foldFromList constr op eq = transformFromList constr eq id op
-- XXX concatenate streams of multiple elements rather than single elements
semigroupOps
@@ -583,6 +693,25 @@ semigroupOps desc eq t = do
prop (desc <> " <>") $ foldFromList (foldMapWith (<>) singleton) t eq
prop (desc <> " mappend") $ foldFromList (foldMapWith mappend singleton) t eq
+-------------------------------------------------------------------------------
+-- Functor operations
+-------------------------------------------------------------------------------
+
+functorOps
+ :: Functor (t IO)
+ => ([Int] -> t IO Int)
+ -> String
+ -> ([Int] -> [Int] -> Bool)
+ -> (t IO Int -> SerialT IO Int)
+ -> Spec
+functorOps constr desc eq t = do
+ prop (desc <> " id") $ transformFromList constr eq id t
+ prop (desc <> " fmap (+1)") $ transformFromList constr eq (fmap (+1)) $ t . fmap (+1)
+
+-------------------------------------------------------------------------------
+-- Applicative operations
+-------------------------------------------------------------------------------
+
applicativeOps
:: Applicative (t IO)
=> ([Int] -> t IO Int)
@@ -596,6 +725,10 @@ applicativeOps constr eq t (a, b) = withMaxSuccess maxTestCount $
let list = (,) <$> a <*> b
listEquals eq stream list
+-------------------------------------------------------------------------------
+-- Zip operations
+-------------------------------------------------------------------------------
+
zipApplicative
:: (IsStream t, Applicative (t IO))
=> ([Int] -> t IO Int)
@@ -650,6 +783,10 @@ zipAsyncMonadic constr eq t (a, b) = withMaxSuccess maxTestCount $
listEquals eq stream1 list
listEquals eq stream2 list
+-------------------------------------------------------------------------------
+-- Monad operations
+-------------------------------------------------------------------------------
+
monadThen
:: Monad (t IO)
=> ([Int] -> t IO Int)
@@ -678,16 +815,6 @@ monadBind constr eq t (a, b) = withMaxSuccess maxTestCount $
let list = a >>= \x -> (+ x) <$> b
listEquals eq stream list
-constructWithIterate :: IsStream t => (t IO Int -> SerialT IO Int) -> Spec
-constructWithIterate t = do
- it "iterate" $
- (S.toList . t . S.take 100) (S.iterate (+ 1) (0 :: Int))
- `shouldReturn` take 100 (iterate (+ 1) 0)
- it "iterateM" $ do
- let addM y = return (y + 1)
- S.toList . t . S.take 100 $ S.iterateM addM (0 :: Int)
- `shouldReturn` take 100 (iterate (+ 1) 0)
-
main :: IO ()
main = hspec
$ H.parallel
@@ -761,14 +888,24 @@ main = hspec
zipAsyncOps spec = mapOps spec $ makeOps zipAsyncly
describe "Construction" $ do
+ serialOps $ prop "serially replicate" . constructWithReplicate
+
serialOps $ prop "serially replicateM" . constructWithReplicateM
wSerialOps $ prop "wSerially replicateM" . constructWithReplicateM
aheadOps $ prop "aheadly replicateM" . constructWithReplicateM
asyncOps $ prop "asyncly replicateM" . constructWithReplicateM
wAsyncOps $ prop "wAsyncly replicateM" . constructWithReplicateM
parallelOps $ prop "parallely replicateM" . constructWithReplicateM
+
+ serialOps $ prop "serially intFromThenTo" .
+ constructWithIntFromThenTo
+#if __GLASGOW_HASKELL__ >= 806
+ serialOps $ prop "serially DoubleFromThenTo" .
+ constructWithDoubleFromThenTo
+#endif
-- XXX test for all types of streams
constructWithIterate serially
+ -- XXX add tests for fromIndices
describe "Functor operations" $ do
serialOps $ functorOps S.fromFoldable "serially" (==)
@@ -814,6 +951,7 @@ main = hspec
wAsyncOps $ prop "wAsyncly applicative folded" . applicativeOps folded sortEq
parallelOps $ prop "parallely applicative folded" . applicativeOps folded sortEq
+ -- XXX add tests for indexed/indexedR
describe "Zip operations" $ do
zipSerialOps $ prop "zipSerially applicative" . zipApplicative S.fromFoldable (==)
zipSerialOps $ prop "zipSerially applicative folded" . zipApplicative folded (==)
@@ -836,6 +974,11 @@ main = hspec
parallelOps $ prop "zip monadic parallely" . zipMonadic S.fromFoldable (==)
parallelOps $ prop "zip monadic parallely folded" . zipMonadic folded (==)
+ -- XXX add merge tests like zip tests
+ -- for mergeBy, we can split a list randomly into two lists and
+ -- then merge them, it should result in original list
+ -- describe "Merge operations" $ do
+
describe "Monad operations" $ do
serialOps $ prop "serially monad then" . monadThen S.fromFoldable (==)
wSerialOps $ prop "wSerially monad then" . monadThen S.fromFoldable sortEq
@@ -865,43 +1008,6 @@ main = hspec
wAsyncOps $ prop "wAsyncly monad bind folded" . monadBind folded sortEq
parallelOps $ prop "parallely monad bind folded" . monadBind folded sortEq
- describe "Stream transform operations" $ do
- serialOps $ transformOps S.fromFoldable "serially" (==)
- wSerialOps $ transformOps S.fromFoldable "wSerially" (==)
- aheadOps $ transformOps S.fromFoldable "aheadly" (==)
- asyncOps $ transformOps S.fromFoldable "asyncly" sortEq
- wAsyncOps $ transformOps S.fromFoldable "wAsyncly" sortEq
- parallelOps $ transformOps S.fromFoldable "parallely" sortEq
- zipSerialOps $ transformOps S.fromFoldable "zipSerially" (==)
- zipAsyncOps $ transformOps S.fromFoldable "zipAsyncly" (==)
-
- serialOps $ transformOps folded "serially folded" (==)
- wSerialOps $ transformOps folded "wSerially folded" (==)
- aheadOps $ transformOps folded "aheadly folded" (==)
- asyncOps $ transformOps folded "asyncly folded" sortEq
- wAsyncOps $ transformOps folded "wAsyncly folded" sortEq
- parallelOps $ transformOps folded "parallely folded" sortEq
- zipSerialOps $ transformOps folded "zipSerially folded" (==)
- zipAsyncOps $ transformOps folded "zipAsyncly folded" (==)
-
- serialOps $ transformOpsWord8 S.fromFoldable "serially"
- wSerialOps $ transformOpsWord8 S.fromFoldable "wSerially"
- aheadOps $ transformOpsWord8 S.fromFoldable "aheadly"
- asyncOps $ transformOpsWord8 S.fromFoldable "asyncly"
- wAsyncOps $ transformOpsWord8 S.fromFoldable "wAsyncly"
- parallelOps $ transformOpsWord8 S.fromFoldable "parallely"
- zipSerialOps $ transformOpsWord8 S.fromFoldable "zipSerially"
- zipAsyncOps $ transformOpsWord8 S.fromFoldable "zipAsyncly"
-
- serialOps $ transformOpsWord8 folded "serially folded"
- wSerialOps $ transformOpsWord8 folded "wSerially folded"
- aheadOps $ transformOpsWord8 folded "aheadly folded"
- asyncOps $ transformOpsWord8 folded "asyncly folded"
- wAsyncOps $ transformOpsWord8 folded "wAsyncly folded"
- parallelOps $ transformOpsWord8 folded "parallely folded"
- zipSerialOps $ transformOpsWord8 folded "zipSerially folded"
- zipAsyncOps $ transformOpsWord8 folded "zipAsyncly folded"
-
-- These tests won't work with maxBuffer or maxThreads set to 1, so we
-- exclude those cases from these.
let mkOps t =
@@ -937,8 +1043,6 @@ main = hspec
prop "concurrent foldl application" $ withMaxSuccess maxTestCount
concurrentFoldlApplication
- -- These tests are specifically targeted towards detecting illegal sharing
- -- of SVar across conurrent streams. All transform ops must be added here.
describe "Stream transform and combine operations" $ do
serialOps $ transformCombineOpsCommon S.fromFoldable "serially" (==)
wSerialOps $ transformCombineOpsCommon S.fromFoldable "wSerially" sortEq
@@ -987,17 +1091,35 @@ main = hspec
zipSerialOps $ eliminationOps folded "zipSerially folded"
zipAsyncOps $ eliminationOps folded "zipAsyncly folded"
+ serialOps $ eliminationOpsWord8 S.fromFoldable "serially"
+ wSerialOps $ eliminationOpsWord8 S.fromFoldable "wSerially"
+ aheadOps $ eliminationOpsWord8 S.fromFoldable "aheadly"
+ asyncOps $ eliminationOpsWord8 S.fromFoldable "asyncly"
+ wAsyncOps $ eliminationOpsWord8 S.fromFoldable "wAsyncly"
+ parallelOps $ eliminationOpsWord8 S.fromFoldable "parallely"
+ zipSerialOps $ eliminationOpsWord8 S.fromFoldable "zipSerially"
+ zipAsyncOps $ eliminationOpsWord8 S.fromFoldable "zipAsyncly"
+
+ serialOps $ eliminationOpsWord8 folded "serially folded"
+ wSerialOps $ eliminationOpsWord8 folded "wSerially folded"
+ aheadOps $ eliminationOpsWord8 folded "aheadly folded"
+ asyncOps $ eliminationOpsWord8 folded "asyncly folded"
+ wAsyncOps $ eliminationOpsWord8 folded "wAsyncly folded"
+ parallelOps $ eliminationOpsWord8 folded "parallely folded"
+ zipSerialOps $ eliminationOpsWord8 folded "zipSerially folded"
+ zipAsyncOps $ eliminationOpsWord8 folded "zipAsyncly folded"
+
-- XXX Add a test where we chain all transformation APIs and make sure that
-- the state is being passed through all of them.
describe "Stream serial elimination operations" $ do
- serialOps $ serialEliminationOps S.fromFoldable "serially"
- wSerialOps $ serialEliminationOps S.fromFoldable "wSerially"
- aheadOps $ serialEliminationOps S.fromFoldable "aheadly"
- zipSerialOps $ serialEliminationOps S.fromFoldable "zipSerially"
- zipAsyncOps $ serialEliminationOps S.fromFoldable "zipAsyncly"
-
- serialOps $ serialEliminationOps folded "serially folded"
- wSerialOps $ serialEliminationOps folded "wSerially folded"
- aheadOps $ serialEliminationOps folded "aheadly folded"
- zipSerialOps $ serialEliminationOps folded "zipSerially folded"
- zipAsyncOps $ serialEliminationOps folded "zipAsyncly folded"
+ serialOps $ eliminationOpsOrdered S.fromFoldable "serially"
+ wSerialOps $ eliminationOpsOrdered S.fromFoldable "wSerially"
+ aheadOps $ eliminationOpsOrdered S.fromFoldable "aheadly"
+ zipSerialOps $ eliminationOpsOrdered S.fromFoldable "zipSerially"
+ zipAsyncOps $ eliminationOpsOrdered S.fromFoldable "zipAsyncly"
+
+ serialOps $ eliminationOpsOrdered folded "serially folded"
+ wSerialOps $ eliminationOpsOrdered folded "wSerially folded"
+ aheadOps $ eliminationOpsOrdered folded "aheadly folded"
+ zipSerialOps $ eliminationOpsOrdered folded "zipSerially folded"
+ zipAsyncOps $ eliminationOpsOrdered folded "zipAsyncly folded"