diff --git a/Changelog.md b/Changelog.md --- 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 --- a/bench.sh +++ b/bench.sh @@ -2,23 +2,26 @@ print_help () { echo "Usage: $0 " - echo " [--compare] [--base commit] [--candidate commit]" echo " [--benchmarks ]" + echo " [--group-diff]" echo " [--graphs]" - echo " [--slow]" echo " [--no-measure]" echo " [--append] " + echo " [--compare] [--base commit] [--candidate commit]" + echo " [--slow]" echo " -- " 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 @@ 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 @@ 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 @@ DEFAULT_BENCHMARKS="linear" ALL_BENCHMARKS="linear linear-async linear-rate nested base" +GROUP_DIFF=0 COMPARE=0 BASE= @@ -240,13 +246,16 @@ 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 @@ 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 @@ 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 @@ 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 --- /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 --- a/benchmark/BaseStreams.hs +++ b/benchmark/BaseStreams.hs @@ -19,12 +19,21 @@ -- 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 _benchId name f = bench name $ nf (runIdentity . f) (Ops.source 10) @@ -37,46 +46,109 @@ [ 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 "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 ] - , 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 + , 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 ] - -- 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 + , 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" [ bgroup "generation" @@ -93,42 +165,99 @@ ] , 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 "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 ] - , 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 + , 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 ] - -- 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 + , 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 --- a/benchmark/Chart.hs +++ b/benchmark/Chart.hs @@ -7,8 +7,10 @@ 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 @@ ------------------------------------------------------------------------------ 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 = 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,97 +102,198 @@ ------------------------------------------------------------------------------ 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 "composition-scaling" + ignoringErr $ graph inputFile "transformationX4" $ cfg + { title = (++) <$> title <*> Just " Transformation x 4" + , classifyBenchmark = + fmap ("Streamly",) . stripPrefix "serially/transformationX4/" + } + + ignoringErr $ graph inputFile "filteringX4" $ cfg - { title = Just "Streamly composition scaling" - , classifyBenchmark = fmap ("Streamly",) . stripPrefix "serially/compose-" + { title = (++) <$> title <*> Just " Filtering x 4" + , classifyBenchmark = + fmap ("Streamly",) . stripPrefix "serially/filteringX4/" } + ignoringErr $ graph inputFile "mixedX4" + $ cfg + { 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/" + } + ------------------------------------------------------------------------------ -- Nested composition charts ------------------------------------------------------------------------------ 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 putStrLn "Not implemented" 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 @@ 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 --- 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 -{- -_benchId :: NFData b => String -> (Ops.Stream m Int -> Identity b) -> Benchmark -_benchId name f = bench name $ nf (runIdentity . f) (Ops.source 10) --} +{-# INLINE benchPure #-} +benchPure :: 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 + +{-# 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 - , 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 + , 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 + ] + ] + + , 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 --- a/benchmark/LinearAsync.hs +++ b/benchmark/LinearAsync.hs @@ -40,36 +40,45 @@ 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 @@ ] -- 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 --- 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,9 +50,31 @@ {-# 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 sourceFromList n = S.fromList [n..n+value] @@ -68,6 +101,11 @@ => 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 @@ 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 = 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,16 +171,33 @@ {-# 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 foldl1'Reduce #-} +{-# INLINE foldr1Reduce #-} +last, minimum, maximum, find, findIndex, elemIndex, foldl1'Reduce, foldr1Reduce + :: Monad m => Stream m Int -> m (Maybe Int) -{-# INLINE foldl' #-} +{-# 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 #-} {-# INLINE and #-} @@ -142,7 +207,7 @@ 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 @@ _ <- 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 @@ minimum = S.minimum sum = S.sum product = S.product +minimumBy = S.minimumBy compare +maximumBy = S.maximumBy compare ------------------------------------------------------------------------------- -- Transformation @@ -200,8 +277,33 @@ 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,63 +314,117 @@ {-# 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 ------------------------------------------------------------------------------- {-# 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 @@ 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 () -{-# 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 () +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) -composeMapM = compose (S.mapM return) -composeAllInFilters = compose (S.filter (<= maxValue)) -composeAllOutFilters = compose (S.filter (> maxValue)) -composeMapAllInFilter = - compose (S.filter (<= maxValue) . Prelude.fmap (subtract 1)) +data Pair a b = Pair !a !b deriving (Generic, NFData) -{-# 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 sumProductFold #-} +sumProductFold :: Monad m => Stream m Int -> m (Int, Int) +sumProductFold = S.foldl' (\(s,p) x -> (s + x, p P.* x)) (0,1) + +{-# INLINE sumProductScan #-} +sumProductScan :: Monad m => Stream m Int -> m (Pair Int Int) +sumProductScan = S.foldl' (\(Pair _ p) (s0,x) -> Pair s0 (p P.* x)) (Pair 0 1) + . S.scanl' (\(s,_) x -> (s + x,x)) (0,0) + +------------------------------------------------------------------------------- +-- Pure stream operations +------------------------------------------------------------------------------- + +{-# INLINE eqInstance #-} +eqInstance :: Stream 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 --- /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 --- a/benchmark/Nested.hs +++ b/benchmark/Nested.hs @@ -23,7 +23,8 @@ -- 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 @@ ] , 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 @@ ] , 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 @@ ] , 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 @@ ] , 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 @@ ] , 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 --- a/benchmark/NestedOps.hs +++ b/benchmark/NestedOps.hs @@ -62,6 +62,13 @@ -- 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 --- 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 --- 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 @@ {-# 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 @@ {-# 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 @@ 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 @@ {-# 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 @@ 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,20 +131,20 @@ 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 last = S.last @@ -161,19 +157,96 @@ 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 @@ 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)) +{-# 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 () -{-# 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) +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 --- a/docs/streamly-vs-async.md +++ b/docs/streamly-vs-async.md @@ -228,3 +228,8 @@ 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 --- 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 @@ 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 + Harm n -> modify (\h -> h - n) >> return Check + Heal n -> modify (\h -> h + n) >> return Check + Quit -> return Done - h <- get - when (h <= 0) $ fail "You die!" - liftIO $ putStrLn $ "Health = " <> show h +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 --- a/examples/ControlFlow.hs +++ b/examples/ControlFlow.hs @@ -48,7 +48,7 @@ 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 @@ 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 @@ 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 @@ , 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 @@ >> 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 @@ 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 @@ 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 @@ 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 @@ 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 --- 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 --- 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 @@ , ZipAsyncM -- * Running Streams - , runStream - + , P.runStream -- * Parallel Function Application -- $application , (|$) @@ -153,6 +152,7 @@ -- * Re-exports , Semigroup (..) + -- * Deprecated , Streaming , runStreaming @@ -173,18 +173,18 @@ ) 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 @@ -- 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 --- /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 --- a/src/Streamly/Internal.hs +++ b/src/Streamly/Internal.hs @@ -16,4 +16,4 @@ ) 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 --- /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 for more details and +-- 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 --- a/src/Streamly/Prelude.hs +++ b/src/Streamly/Prelude.hs @@ -1,1039 +1,1849 @@ {-# 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" - --- | --- Module : Streamly.Prelude --- Copyright : (c) 2017 Harendra Kumar --- --- License : BSD3 --- Maintainer : harendra.kumar@gmail.com --- Stability : experimental --- Portability : GHC --- --- This module is designed to be imported qualified: --- --- @ --- import qualified Streamly.Prelude as S --- @ --- --- Functions with the suffix @M@ are general functions that work on monadic --- arguments. The corresponding functions without the suffix @M@ work on pure --- arguments and can in general be derived from their monadic versions but are --- provided for convenience and for consistency with other pure APIs in the --- @base@ package. --- --- Functions having a 'MonadAsync' constraint work concurrently when used with --- appropriate stream type combinator. Please be careful to not use 'parallely' --- with infinite streams. --- --- Deconstruction and folds accept a 'SerialT' type instead of a polymorphic --- type to ensure that streams always have a concrete monomorphic type by --- default, reducing type errors. In case you want to use any other type of --- stream you can use one of the type combinators provided in the "Streamly" --- module to convert the stream type. - -module Streamly.Prelude - ( - -- * Construction - -- | 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 to construct a stream from pure values or monadic actions. - K.nil - , K.cons - , (K..:) - , consM - , (|:) - , yield - , yieldM - - -- ** 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. - , unfoldr - , unfoldrM - , iterate - , iterateM - - -- ** 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 - -- | Convert an input structure, container or source into a stream. All of - -- these can be expressed in terms of primitives. - , fromList - , fromListM - , K.fromFoldable - , fromFoldableM - , fromHandle - - -- * Deconstruction - , uncons - - -- * Elimination - - -- ** 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. - , foldr - , foldr1 - , foldrM - , foldl' - , foldl1' - , foldlM' - , 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. - - -- Filtering folds: extract parts of the stream - , head - , tail - , last - , init - - -- Conditional folds: may terminate early based on a condition - , null - , elem - , elemIndex - , notElem - , lookup - , find - , findIndex - , all - , any - , and - , or - - -- Full folds - need to go through all elements - , length - , maximum - , minimum - , sum - , product - - -- ** Fold To - -- | 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. - , scanl' - , scanlM' - , scanx - - -- ** Mapping - -- | Map is a special form of scan where no state is carried from one step - -- to the next. - , Serial.map - , mapM - - -- ** Flattening - , sequence - - -- * Filtering and Insertion - -- | Adding or removing elements from the stream thus changing the length - -- of the stream. - - -- ** Filtering - , filter - , filterM - , take - , takeWhile - , takeWhileM - , drop - , dropWhile - , dropWhileM - - -- ** Inserting - , intersperseM - - -- * Reordering - , reverse - - -- * Hybrid Operations - -- ** Map and Fold - , mapM_ - - -- ** Map and Filter - , mapMaybe - , mapMaybeM - - -- ** Scan and filter - , findIndices - , elemIndices - - -- * Zipping - , zipWith - , zipWithM - , Z.zipAsyncWith - , Z.zipAsyncWithM - - -- * Deprecated - , K.once - , each - , scan - , foldl - , foldlM - ) -where - -import Control.Monad.IO.Class (MonadIO(..)) -import Data.Maybe (isJust, fromJust) -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) -import qualified Prelude -import qualified System.IO as IO - -import Streamly.SVar (MonadAsync, defState, rstState) -import Streamly.Streams.SVar (maxYields) -import Streamly.Streams.StreamK (IsStream(..)) -import Streamly.Streams.Serial (SerialT) - -import qualified Streamly.Streams.StreamK as K -import qualified Streamly.Streams.StreamD as D -import qualified Streamly.Streams.Zip as Z - -#ifdef USE_STREAMK_ONLY -import qualified Streamly.Streams.StreamK as S -import qualified Streamly.Streams.Zip as S -#else -import qualified Streamly.Streams.StreamD as S -#endif - -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 ------------------------------------------------------------------------------- - --- | Decompose a stream into its head and tail. If the stream is empty, returns --- 'Nothing'. If the stream is non-empty, returns @Just (a, ma)@, where @a@ is --- the head of the stream and @ma@ its tail. --- --- @since 0.1.0 -uncons :: (IsStream t, Monad m) => SerialT m a -> m (Maybe (a, t m a)) -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, --- --- @ --- let f b = --- if b > 3 --- then Nothing --- else Just (b, b + 1) --- in toList $ unfoldr f 0 --- @ --- @ --- [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 -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 #-} - --- | Build a stream by unfolding a /monadic/ 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, --- --- @ --- let f b = --- if b > 3 --- then return Nothing --- else print b >> return (Just (b, b + 1)) --- in runStream $ unfoldrM f 0 --- @ --- @ --- 0 --- 1 --- 2 --- 3 --- @ --- When run concurrently, the next unfold step can run concurrently with the --- processing of the output of the previous step. Note that more than one step --- cannot run concurrently as the next step depends on the output of the --- previous step. --- --- @ --- (asyncly $ S.unfoldrM (\\n -> liftIO (threadDelay 1000000) >> return (Just (n, n + 1))) 0) --- & S.foldlM' (\\_ a -> threadDelay 1000000 >> print a) () --- @ --- --- /Concurrent/ --- --- /Since: 0.1.0/ -{-# INLINE_EARLY unfoldrM #-} -unfoldrM :: (IsStream t, MonadAsync m) => (b -> m (Maybe (a, b))) -> b -> t m a -unfoldrM = K.unfoldrM - -{-# RULES "unfoldrM serial" unfoldrM = unfoldrMSerial #-} -{-# INLINE_EARLY unfoldrMSerial #-} -unfoldrMSerial :: MonadAsync m => (b -> m (Maybe (a, b))) -> b -> SerialT m a -unfoldrMSerial step seed = fromStreamS (S.unfoldrM step seed) - ------------------------------------------------------------------------------- --- Specialized Generation ------------------------------------------------------------------------------- - --- 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. --- --- @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. --- --- @ --- > toList $ yieldM getLine --- hello --- ["hello"] --- @ --- --- @since 0.4.0 -{-# INLINE yieldM #-} -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)@. --- --- --- @ --- runStream $ serially $ S.replicateM 10 $ (threadDelay 1000000 >> print 1) --- runStream $ asyncly $ S.replicateM 10 $ (threadDelay 1000000 >> print 1) --- @ --- --- /Concurrent/ --- --- @since 0.1.1 -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) - --- | Generate a stream by repeatedly executing a monadic action forever. Can be --- expressed as @cycle1 . yieldM@. --- --- @ --- runStream $ serially $ S.take 10 $ S.repeatM $ (threadDelay 1000000 >> print 1) --- runStream $ asyncly $ S.take 10 $ S.repeatM $ (threadDelay 1000000 >> print 1) --- @ --- --- /Concurrent, infinite (do not use with 'parallely')/ --- --- @since 0.2.0 -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. --- --- @since 0.1.2 -iterate :: IsStream t => (a -> a) -> a -> t m a -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. --- --- When run concurrently, the next iteration can run concurrently with the --- processing of the previous iteration. Note that more than one iteration --- cannot run concurrently as the next iteration depends on the output of the --- previous iteration. --- --- @ --- runStream $ serially $ S.take 10 $ S.iterateM --- (\\x -> threadDelay 1000000 >> print x >> return (x + 1)) 0 --- --- runStream $ asyncly $ S.take 10 $ S.iterateM --- (\\x -> threadDelay 1000000 >> print x >> return (x + 1)) 0 --- @ --- --- /Concurrent/ --- --- @since 0.1.2 -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 - next <- step s - K.unStream (toStream (return s |: go next)) svr stp sng yld - ------------------------------------------------------------------------------- --- 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. --- --- @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. --- --- @since 0.4.0 -{-# INLINE_EARLY fromListM #-} -fromListM :: (MonadAsync m, IsStream t) => [m a] -> t m a -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'@. --- --- @ --- runStream $ serially $ S.fromFoldableM $ replicate 10 (threadDelay 1000000 >> print 1) --- runStream $ asyncly $ S.fromFoldableM $ replicate 10 (threadDelay 1000000 >> print 1) --- @ --- --- /Concurrent (do not use with 'parallely' on infinite containers)/ --- --- @since 0.3.0 -{-# INLINE fromFoldableM #-} -fromFoldableM :: (IsStream t, MonadAsync m, Foldable f) => f (m a) -> t m a -fromFoldableM = Prelude.foldr consM K.nil - --- | Same as 'fromFoldable'. --- --- @since 0.1.0 -{-# DEPRECATED each "Please use fromFoldable instead." #-} -{-# INLINE each #-} -each :: (IsStream t, Foldable f) => f a -> t m a -each = K.fromFoldable - --- | Read lines from an IO Handle into a stream of Strings. --- --- @since 0.1.0 -fromHandle :: (IsStream t, MonadIO m) => IO.Handle -> t m String -fromHandle h = fromStream go - where - go = K.Stream $ \_ stp _ yld -> do - eof <- liftIO $ IO.hIsEOF h - if eof - then stp - else do - str <- liftIO $ IO.hGetLine h - yld str go - ------------------------------------------------------------------------------- --- Elimination by Folding ------------------------------------------------------------------------------- - --- | Lazy right fold with a monadic step function. For example, to fold a --- stream into a list: --- --- @ --- >> runIdentity $ foldrM (\\x xs -> return (x : xs)) [] (serially $ fromFoldable [1,2,3]) --- [1,2,3] --- @ --- --- @since 0.2.0 -{-# INLINE foldrM #-} -foldrM :: Monad m => (a -> b -> m b) -> b -> SerialT m a -> m b -foldrM step acc m = S.foldrM step acc $ toStreamS m - --- | Lazy right associative fold. For example, to fold a stream into a list: --- --- @ --- >> runIdentity $ foldr (:) [] (serially $ fromFoldable [1,2,3]) --- [1,2,3] --- @ --- --- @since 0.1.0 -{-# 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)) - --- | 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 - --- | Strict left fold with an extraction function. Like the standard strict --- left fold, but applies a user supplied extraction function (the third --- argument) to the folded value at the end. This is designed to work with the --- @foldl@ library. The suffix @x@ is a mnemonic for extraction. --- --- @since 0.2.0 -{-# INLINE foldx #-} -foldx :: Monad m => (x -> a -> x) -> x -> (x -> b) -> SerialT m a -> m b -foldx = K.foldx - --- | --- @since 0.1.0 -{-# DEPRECATED foldl "Please use foldx instead." #-} -foldl :: Monad m => (x -> a -> x) -> x -> (x -> b) -> SerialT m a -> m b -foldl = foldx - --- | Strict left associative fold. --- --- @since 0.2.0 -{-# INLINE foldl' #-} -foldl' :: Monad m => (b -> a -> b) -> b -> SerialT m a -> m b -foldl' step begin m = S.foldl' step begin $ toStreamS m - --- | 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 -foldl1' :: Monad m => (a -> a -> a) -> SerialT m a -> m (Maybe a) -foldl1' step m = do - r <- uncons m - case r of - Nothing -> return Nothing - Just (h, t) -> 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 -foldxM :: Monad m => (x -> a -> m x) -> m x -> (x -> m b) -> SerialT m a -> m b -foldxM = K.foldxM - --- | --- @since 0.1.0 -{-# DEPRECATED foldlM "Please use foldxM instead." #-} -foldlM :: Monad m => (x -> a -> m x) -> m x -> (x -> m b) -> SerialT m a -> m b -foldlM = foldxM - --- | Like 'foldl'' but with a monadic step function. --- --- @since 0.2.0 -foldlM' :: Monad m => (b -> a -> m b) -> b -> SerialT m a -> m b -foldlM' step begin m = S.foldlM' step begin $ toStreamS m - ------------------------------------------------------------------------------- --- Specialized folds ------------------------------------------------------------------------------- - --- | Determine whether the stream is empty. --- --- @since 0.1.1 -{-# INLINE null #-} -null :: Monad m => SerialT m a -> m Bool -null = K.null - --- | Extract the first element of the stream, if any. --- --- @since 0.1.0 -{-# INLINE head #-} -head :: Monad m => SerialT m a -> m (Maybe a) -head = K.head - --- | Extract all but the first element of the stream, if any. --- --- @since 0.1.1 -{-# INLINE tail #-} -tail :: (IsStream t, Monad m) => SerialT m a -> m (Maybe (t m a)) -tail m = K.tail (K.adapt m) - --- | Extract all but the last element of the stream, if any. --- --- @since 0.5.0 -{-# INLINE init #-} -init :: (IsStream t, Monad m) => SerialT m a -> m (Maybe (t m a)) -init m = K.init (K.adapt m) - --- | Extract the last element of the stream, if any. --- --- @since 0.1.1 -{-# INLINE last #-} -last :: Monad m => SerialT m a -> m (Maybe a) -last m = S.last $ toStreamS m - --- | Determine whether an element is present in the stream. --- --- @since 0.1.0 -{-# INLINE elem #-} -elem :: (Monad m, Eq a) => a -> SerialT m a -> m Bool -elem e m = S.elem e (toStreamS m) - --- | Determine whether an element is not present in the stream. --- --- @since 0.1.0 -{-# INLINE notElem #-} -notElem :: (Monad m, Eq a) => a -> SerialT m a -> m Bool -notElem e m = S.notElem e (toStreamS m) - --- | Determine the length of the stream. --- --- @since 0.1.0 -{-# INLINE length #-} -length :: Monad m => SerialT m a -> m Int -length = foldl' (\n _ -> n + 1) 0 - --- | Determine whether all elements of a stream satisfy a predicate. --- --- @since 0.1.0 -{-# INLINE all #-} -all :: Monad m => (a -> Bool) -> SerialT m a -> m Bool -all p m = S.all p (toStreamS m) - --- | Determine whether any of the elements of a stream satisfy a predicate. --- --- @since 0.1.0 -{-# INLINE any #-} -any :: Monad m => (a -> Bool) -> SerialT m a -> m Bool -any p m = S.any p (toStreamS m) - --- | Determines if all elements of a boolean stream are True. --- --- @since 0.5.0 -{-# INLINE and #-} -and :: Monad m => SerialT m Bool -> m Bool -and = all (==True) - --- | Determines wheter 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 --- --- @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 --- --- @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. --- --- @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. --- --- @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. --- --- @since 0.5.0 -{-# INLINE lookup #-} -lookup :: (Monad m, Eq a) => a -> SerialT m (a, b) -> m (Maybe b) -lookup = K.lookup - --- | Returns the first element of the stream satisfying the given predicate, --- if any. --- --- @since 0.5.0 -{-# INLINE find #-} -find :: Monad m => (a -> Bool) -> SerialT m a -> m (Maybe a) -find = K.find - --- | 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 - --- | Gives the index of the first stream element satisfying the given --- preficate. --- --- @since 0.5.0 -{-# INLINE findIndex #-} -findIndex :: Monad m => (a -> Bool) -> SerialT m a -> m (Maybe Int) -findIndex p = head . findIndices p - --- | Find all the indices where the value of the element in the stream is equal --- to the given value. --- --- @since 0.5.0 -{-# INLINE elemIndices #-} -elemIndices :: (IsStream t, Eq a) => 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. --- --- @since 0.5.0 -{-# INLINE elemIndex #-} -elemIndex :: (Monad m, Eq a) => a -> SerialT m a -> m (Maybe Int) -elemIndex a = findIndex (==a) - ------------------------------------------------------------------------------- --- Map and Fold ------------------------------------------------------------------------------- - --- XXX this can utilize parallel mapping if we implement it as runStream . mapM --- | Apply a monadic action to each element of the stream and discard the --- output of the action. --- --- @since 0.1.0 -{-# INLINE mapM_ #-} -mapM_ :: Monad m => (a -> m b) -> SerialT m a -> m () -mapM_ f m = S.mapM_ f $ toStreamS m - ------------------------------------------------------------------------------- --- Conversions ------------------------------------------------------------------------------- - --- | Convert a stream into a list in the underlying monad. --- --- @since 0.1.0 -{-# INLINE toList #-} -toList :: Monad m => SerialT m a -> m [a] -toList m = S.toList $ toStreamS m - --- | 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) - 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 - ------------------------------------------------------------------------------- --- Transformation by Folding (Scans) ------------------------------------------------------------------------------- - --- | Strict left scan with an extraction function. Like 'scanl'', but applies a --- user supplied extraction function (the third argument) at each step. This is --- designed to work with the @foldl@ library. The suffix @x@ is a mnemonic for --- extraction. --- --- @since 0.2.0 -{-# INLINE scanx #-} -scanx :: IsStream t => (x -> a -> x) -> x -> (x -> b) -> t m a -> t m b -scanx = K.scanx - --- | --- @since 0.1.1 -{-# DEPRECATED scan "Please use scanx instead." #-} -scan :: IsStream t => (x -> a -> x) -> x -> (x -> b) -> t m a -> t m b -scan = scanx - --- | Like 'scanl'' but with a monadic step 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''. --- --- @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)) - ------------------------------------------------------------------------------- --- Transformation by Filtering ------------------------------------------------------------------------------- - --- | Include only those elements that pass a predicate. --- --- @since 0.1.0 -{-# INLINE filter #-} -#if __GLASGOW_HASKELL__ != 802 --- GHC 8.2.2 crashes with this code, when used with "stack" -filter :: (IsStream t, Monad m) => (a -> Bool) -> t m a -> t m a -filter p m = fromStreamS $ S.filter p $ toStreamS m -#else -filter :: IsStream t => (a -> Bool) -> t m a -> t m a -filter = K.filter -#endif - --- | Same as 'filter' but with a monadic predicate. --- --- @since 0.4.0 -{-# INLINE filterM #-} -filterM :: (IsStream t, Monad m) => (a -> m Bool) -> t m a -> t m a -filterM p m = fromStreamD $ D.filterM p $ toStreamD m - --- | Take first 'n' elements from the stream and discard the rest. --- --- @since 0.1.0 -{-# INLINE take #-} -take :: (IsStream t, Monad m) => Int -> t m a -> t m a -take n m = fromStreamS $ S.take n $ toStreamS - (maxYields (Just (fromIntegral n)) m) - --- | End the stream as soon as the predicate fails on an element. --- --- @since 0.1.0 -{-# INLINE takeWhile #-} -takeWhile :: (IsStream t, Monad m) => (a -> Bool) -> t m a -> t m a -takeWhile p m = fromStreamS $ S.takeWhile p $ toStreamS m - --- | Same as 'takeWhile' but with a monadic predicate. --- --- @since 0.4.0 -{-# INLINE takeWhileM #-} -takeWhileM :: (IsStream t, Monad m) => (a -> m Bool) -> t m a -> t m a -takeWhileM p m = fromStreamD $ D.takeWhileM p $ toStreamD m - --- | Discard first 'n' elements from the stream and take the rest. --- --- @since 0.1.0 -{-# INLINE drop #-} -drop :: (IsStream t, Monad m) => Int -> t m a -> t m a -drop n m = fromStreamS $ S.drop n $ toStreamS m - --- | Drop elements in the stream as long as the predicate succeeds and then --- take the rest of the stream. --- --- @since 0.1.0 -{-# INLINE dropWhile #-} -dropWhile :: (IsStream t, Monad m) => (a -> Bool) -> t m a -> t m a -dropWhile p m = fromStreamS $ S.dropWhile p $ toStreamS m - --- | Same as 'dropWhile' but with a monadic predicate. --- --- @since 0.4.0 -{-# INLINE dropWhileM #-} -dropWhileM :: (IsStream t, Monad m) => (a -> m Bool) -> t m a -> t m a -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. --- --- @ --- runStream $ S.replicateM 10 (return 1) --- & (serially . S.mapM (\\x -> threadDelay 1000000 >> print x)) --- --- runStream $ S.replicateM 10 (return 1) --- & (asyncly . S.mapM (\\x -> threadDelay 1000000 >> print x)) --- @ --- --- /Concurrent (do not use with 'parallely' on infinite streams)/ --- --- @since 0.1.0 -{-# INLINE_EARLY mapM #-} -mapM :: (IsStream t, MonadAsync m) => (a -> m b) -> t m a -> t m b -mapM = K.mapM - -{-# RULES "mapM serial" mapM = mapMSerial #-} -{-# INLINE mapMSerial #-} -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. --- --- @ --- runStream $ S.replicateM 10 (return $ threadDelay 1000000 >> print 1) --- & (serially . S.sequence) --- --- runStream $ S.replicateM 10 (return $ threadDelay 1000000 >> print 1) --- & (asyncly . S.sequence) --- @ --- --- /Concurrent (do not use with 'parallely' on infinite streams)/ --- --- @since 0.1.0 -{-# INLINE sequence #-} -sequence :: (IsStream t, MonadAsync m) => t m (m a) -> t m a -sequence = K.sequence - ------------------------------------------------------------------------------- --- Transformation by Map and Filter ------------------------------------------------------------------------------- - --- | Map a 'Maybe' returning function to a stream, filter out the 'Nothing' --- elements, and return a stream of values extracted from 'Just'. --- --- @since 0.3.0 -{-# INLINE mapMaybe #-} -mapMaybe :: (IsStream t, Monad m) => (a -> Maybe b) -> t m a -> t m b -mapMaybe f m = fromStreamS $ S.mapMaybe f $ toStreamS m - --- | Like 'mapMaybe' but maps a monadic function. --- --- /Concurrent (do not use with 'parallely' on infinite streams)/ --- --- @since 0.3.0 -{-# INLINE 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 - ------------------------------------------------------------------------------- --- Transformation by Reordering ------------------------------------------------------------------------------- - --- XXX to scale this we need to use a slab allocated array backed --- representation for temporary storage. --- --- | Returns the elements of the stream in reverse order. --- The stream must be finite. --- --- @since 0.1.1 -reverse :: (IsStream t) => t m a -> t m a -reverse m = fromStream $ go K.nil (toStream m) - where - go rev rest = K.Stream $ \st stp sng yld -> - let runIt x = K.unStream x (rstState st) stp sng yld - 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 - ------------------------------------------------------------------------------- --- Transformation by Inserting ------------------------------------------------------------------------------- - --- | Generate a stream by performing the monadic action inbetween all elements --- of the given stream. --- --- @since 0.5.0 -{-# INLINE intersperseM #-} -intersperseM :: (IsStream t, MonadAsync m) => m a -> t m a -> t m a -intersperseM = K.intersperseM - ------------------------------------------------------------------------------- --- Zipping ------------------------------------------------------------------------------- - --- | Zip two streams serially using a monadic zipping function. --- --- @since 0.4.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 = fromStreamS $ S.zipWithM f (toStreamS m1) (toStreamS m2) - --- | Zip two streams serially using a pure zipping function. --- --- @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) + +#if __GLASGOW_HASKELL__ >= 800 +{-# OPTIONS_GHC -Wno-orphans #-} +#endif + +#include "Streams/inline.hs" + +-- | +-- Module : Streamly.Prelude +-- Copyright : (c) 2017 Harendra Kumar +-- +-- License : BSD3 +-- Maintainer : harendra.kumar@gmail.com +-- Stability : experimental +-- Portability : GHC +-- +-- This module is designed to be imported qualified: +-- +-- @ +-- import qualified Streamly.Prelude as S +-- @ +-- +-- Functions with the suffix @M@ are general functions that work on monadic +-- arguments. The corresponding functions without the suffix @M@ work on pure +-- arguments and can in general be derived from their monadic versions but are +-- provided for convenience and for consistency with other pure APIs in the +-- @base@ package. +-- +-- 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. +-- +-- Deconstruction and folds accept a 'SerialT' type instead of a polymorphic +-- type to ensure that streams always have a concrete monomorphic type by +-- default, reducing type errors. In case you want to use any other type of +-- stream you can use one of the type combinators provided in the "Streamly" +-- module to convert the stream type. + +module Streamly.Prelude + ( + -- * Construction + -- ** Primitives + -- | 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 + + -- 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 + + -- ** From Containers + -- | Convert an input structure, container or source into a stream. All of + -- these can be expressed in terms of primitives. + , P.fromList + , fromListM + , K.fromFoldable + , fromFoldableM + + -- ** 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 +-- | 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 + , foldl' + , foldl1' + , foldlM' + , foldx + , foldxM + + -- ** Run Effects + , runStream + , runN + , runWhile + + -- ** To Elements + -- | Folds that extract selected elements of a stream or their properties. + , (!!) + , head + , last + , findM + , find + , lookup + , findIndex + , elemIndex + + -- ** To Parts + -- | Folds that extract selected parts of a stream. + , tail + , init + + -- ** To Boolean + -- | Folds that summarize the stream to a boolean value. + , null + , elem + , notElem + , all + , any + , and + , or + + -- ** To Summary + -- | Folds that summarize the stream to a single value. + , length + , sum + , product + + -- ** 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 + + -- ** Scanning + -- | 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 strictly one-to-one transformation of stream elements. It + -- cannot add or remove elements from the stream, just transforms them. + , Serial.map + + -- ** Flattening + , sequence + , mapM + + -- ** Filtering + -- | Filtering may remove some elements from the stream. + + , filter + , filterM + , take + , takeWhile + , takeWhileM + , drop + , dropWhile + , dropWhileM + , deleteBy + , uniq + + -- ** Insertion + -- | Insertion adds more elements to the stream. + + , insertBy + , intersperseM + + -- ** Reordering + , reverse + + -- * Hybrid Operations + -- ** Map and Fold + , mapM_ + + -- ** Map and Filter + , mapMaybe + , mapMaybeM + + -- ** Scan and filter + , findIndices + , elemIndices + + -- * 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 + , scan + , foldl + , foldlM + ) +where + +import Control.Monad.IO.Class (MonadIO(..)) +import Data.Maybe (isJust, fromJust) +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, (!!), + scanl, scanl1, replicate, concatMap) + +import qualified Prelude +import qualified System.IO as IO + +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 + +#ifdef USE_STREAMK_ONLY +import qualified Streamly.Streams.StreamK as S +import qualified Streamly.Streams.Zip as S +#else +import qualified Streamly.Streams.StreamD as S +#endif + +import qualified Streamly.Streams.Serial as Serial + +------------------------------------------------------------------------------ +-- Deconstruction +------------------------------------------------------------------------------ + +-- | Decompose a stream into its head and tail. If the stream is empty, returns +-- 'Nothing'. If the stream is non-empty, returns @Just (a, ma)@, where @a@ is +-- the head of the stream and @ma@ its tail. +-- +-- @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) + +------------------------------------------------------------------------------ +-- Generation by Unfolding +------------------------------------------------------------------------------ + +-- | +-- @ +-- 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 = +-- if b > 3 +-- then Nothing +-- else Just (b, b + 1) +-- in toList $ unfoldr f 0 +-- @ +-- @ +-- [0,1,2,3] +-- @ +-- +-- @since 0.1.0 +{-# 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 #-} + +-- | Build a stream by unfolding a /monadic/ 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, +-- +-- @ +-- let f b = +-- if b > 3 +-- then return Nothing +-- else print b >> return (Just (b, b + 1)) +-- in runStream $ unfoldrM f 0 +-- @ +-- @ +-- 0 +-- 1 +-- 2 +-- 3 +-- @ +-- When run concurrently, the next unfold step can run concurrently with the +-- processing of the output of the previous step. Note that more than one step +-- cannot run concurrently as the next step depends on the output of the +-- previous step. +-- +-- @ +-- (asyncly $ S.unfoldrM (\\n -> liftIO (threadDelay 1000000) >> return (Just (n, n + 1))) 0) +-- & S.foldlM' (\\_ a -> threadDelay 1000000 >> print a) () +-- @ +-- +-- /Concurrent/ +-- +-- /Since: 0.1.0/ +{-# INLINE_EARLY unfoldrM #-} +unfoldrM :: (IsStream t, MonadAsync m) => (b -> m (Maybe (a, b))) -> b -> t m a +unfoldrM = K.unfoldrM + +{-# RULES "unfoldrM serial" unfoldrM = unfoldrMSerial #-} +{-# INLINE_EARLY unfoldrMSerial #-} +unfoldrMSerial :: MonadAsync m => (b -> m (Maybe (a, b))) -> b -> SerialT m a +unfoldrMSerial step seed = fromStreamS (S.unfoldrM step seed) + +------------------------------------------------------------------------------ +-- Specialized Generation +------------------------------------------------------------------------------ + +-- Faster than yieldM because there is no bind. +-- +-- | +-- @ +-- 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 + +-- | +-- @ +-- yieldM m = m \`consM` nil +-- @ +-- +-- Create a singleton stream from a monadic action. +-- +-- @ +-- > toList $ yieldM getLine +-- hello +-- ["hello"] +-- @ +-- +-- @since 0.4.0 +{-# INLINE yieldM #-} +yieldM :: (Monad m, IsStream t) => m a -> t m a +yieldM = K.yieldM + +-- | +-- @ +-- 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) +-- runStream $ asyncly $ S.replicateM 10 $ (threadDelay 1000000 >> print 1) +-- @ +-- +-- /Concurrent/ +-- +-- @since 0.1.1 +{-# INLINE_EARLY replicateM #-} +replicateM :: (IsStream t, MonadAsync m) => Int -> m a -> t m a +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 + +-- | +-- @ +-- 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) +-- runStream $ asyncly $ S.take 10 $ S.repeatM $ (threadDelay 1000000 >> print 1) +-- @ +-- +-- /Concurrent, infinite (do not use with 'parallely')/ +-- +-- @since 0.2.0 +repeatM :: (IsStream t, MonadAsync m) => m a -> t m a +repeatM = go + where go m = m |: go m + +-- | +-- @ +-- 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 +iterate step = fromStream . go + where + go s = K.cons s (go (step s)) + +-- | +-- @ +-- 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 +-- cannot run concurrently as the next iteration depends on the output of the +-- previous iteration. +-- +-- @ +-- runStream $ serially $ S.take 10 $ S.iterateM +-- (\\x -> threadDelay 1000000 >> print x >> return (x + 1)) 0 +-- +-- runStream $ asyncly $ S.take 10 $ S.iterateM +-- (\\x -> threadDelay 1000000 >> print x >> return (x + 1)) 0 +-- @ +-- +-- /Concurrent/ +-- +-- @since 0.1.2 +iterateM :: (IsStream t, MonadAsync m) => (a -> m a) -> a -> t m a +iterateM step = go + where + go s = K.mkStream $ \st stp sng yld -> do + next <- step s + K.foldStreamShared st stp sng yld (return s |: go next) + +------------------------------------------------------------------------------ +-- Conversions +------------------------------------------------------------------------------ + +-- | +-- @ +-- fromListM = 'Prelude.foldr' 'K.consM' 'K.nil' +-- @ +-- +-- 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 #-} +fromListM :: (MonadAsync m, IsStream t) => [m a] -> t m a +fromListM = fromStreamD . D.fromListM +{-# RULES "fromListM fallback to StreamK" [1] + forall a. D.toStreamK (D.fromListM a) = fromFoldableM a #-} + +-- | +-- @ +-- fromFoldableM = 'Prelude.foldr' 'consM' 'K.nil' +-- @ +-- +-- Construct a stream from a 'Foldable' containing monadic actions. +-- +-- @ +-- 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)/ +-- +-- @since 0.3.0 +{-# INLINE fromFoldableM #-} +fromFoldableM :: (IsStream t, MonadAsync m, Foldable f) => f (m a) -> t m a +fromFoldableM = Prelude.foldr consM K.nil + +-- | Same as 'fromFoldable'. +-- +-- @since 0.1.0 +{-# DEPRECATED each "Please use fromFoldable instead." #-} +{-# INLINE each #-} +each :: (IsStream t, Foldable f) => f a -> t m a +each = K.fromFoldable + +-- | Read lines from an IO Handle into a stream of Strings. +-- +-- @since 0.1.0 +fromHandle :: (IsStream t, MonadIO m) => IO.Handle -> t m String +fromHandle h = go + where + go = K.mkStream $ \_ yld _ stp -> do + eof <- liftIO $ IO.hIsEOF h + if eof + then stp + else do + str <- liftIO $ IO.hGetLine h + yld str go + +------------------------------------------------------------------------------ +-- Elimination by Folding +------------------------------------------------------------------------------ + +-- | Lazy right fold with a monadic step function. For example, to fold a +-- stream into a list: +-- +-- @ +-- >> 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 = P.foldrM + +-- | Lazy right associative fold. +-- +-- For lists a @foldr@ looks like: +-- +-- @ +-- 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 +foldr = P.foldr + +-- 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 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 +-- argument) to the folded value at the end. This is designed to work with the +-- @foldl@ library. The suffix @x@ is a mnemonic for extraction. +-- +-- @since 0.2.0 +{-# INLINE foldx #-} +foldx :: Monad m => (x -> a -> x) -> x -> (x -> b) -> SerialT m a -> m b +foldx = K.foldx + +-- | +-- @since 0.1.0 +{-# DEPRECATED foldl "Please use foldx instead." #-} +foldl :: Monad m => (x -> a -> x) -> x -> (x -> b) -> SerialT m a -> m b +foldl = foldx + +-- | Strict left associative fold. +-- +-- 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' = 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 + case r of + Nothing -> return Nothing + Just (h, t) -> do + res <- foldl' step h t + return $ Just res + +-- | 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 + +-- | +-- @since 0.1.0 +{-# DEPRECATED foldlM "Please use foldxM instead." #-} +foldlM :: Monad m => (x -> a -> m x) -> m x -> (x -> m b) -> SerialT m a -> m b +foldlM = foldxM + +-- | Like 'foldl'' but with a monadic step function. +-- +-- @since 0.2.0 +{-# 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 + +------------------------------------------------------------------------------ +-- 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 +{-# INLINE null #-} +null :: Monad m => SerialT m a -> m Bool +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) +head = K.head + +-- | Extract all but the first element of the stream, if any. +-- +-- @since 0.1.1 +{-# INLINE tail #-} +tail :: (IsStream t, Monad m) => SerialT m a -> m (Maybe (t m a)) +tail m = K.tail (K.adapt m) + +-- | Extract all but the last element of the stream, if any. +-- +-- @since 0.5.0 +{-# INLINE init #-} +init :: (IsStream t, Monad m) => SerialT m a -> m (Maybe (t m a)) +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) +last m = S.last $ toStreamS m + +-- | Determine whether an element is present in the stream. +-- +-- @since 0.1.0 +{-# INLINE elem #-} +elem :: (Monad m, Eq a) => a -> SerialT m a -> m Bool +elem e m = S.elem e (toStreamS m) + +-- | Determine whether an element is not present in the stream. +-- +-- @since 0.1.0 +{-# INLINE notElem #-} +notElem :: (Monad m, Eq a) => a -> SerialT m a -> m Bool +notElem e m = S.notElem e (toStreamS m) + +-- | Determine the length of the stream. +-- +-- @since 0.1.0 +{-# INLINE length #-} +length :: Monad m => SerialT m a -> m Int +length = foldl' (\n _ -> n + 1) 0 + +-- | Determine whether all elements of a stream satisfy a predicate. +-- +-- @since 0.1.0 +{-# INLINE all #-} +all :: Monad m => (a -> Bool) -> SerialT m a -> m Bool +all p m = S.all p (toStreamS m) + +-- | Determine whether any of the elements of a stream satisfy a predicate. +-- +-- @since 0.1.0 +{-# INLINE any #-} +any :: Monad m => (a -> Bool) -> SerialT m a -> m Bool +any p m = S.any p (toStreamS m) + +-- | Determines if all elements of a boolean stream are True. +-- +-- @since 0.5.0 +{-# INLINE and #-} +and :: Monad m => SerialT m Bool -> m Bool +and = all (==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. 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. 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 + +-- | +-- @ +-- 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 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) + +-- | 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 a m = S.lookup a (toStreamS m) + +-- | 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 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, Monad m) => (a -> Bool) -> t m a -> t m Int +findIndices p m = fromStreamS $ S.findIndices p (toStreamS m) + +-- | Returns the first index that satisfies the given predicate. +-- +-- @since 0.5.0 +{-# INLINE findIndex #-} +findIndex :: Monad m => (a -> Bool) -> SerialT m a -> m (Maybe Int) +findIndex p = head . findIndices p + +-- | Find all the indices where the value of the element in the stream is equal +-- to the given value. +-- +-- @since 0.5.0 +{-# INLINE elemIndices #-} +elemIndices :: (IsStream t, Eq a, Monad m) => a -> t m a -> t m Int +elemIndices a = findIndices (==a) + +-- | 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) + +-- | 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 +------------------------------------------------------------------------------ + +-- XXX this can utilize parallel mapping if we implement it as runStream . mapM +-- | Apply a monadic action to each element of the stream and discard the +-- output of the action. +-- +-- @since 0.1.0 +{-# INLINE mapM_ #-} +mapM_ :: Monad m => (a -> m b) -> SerialT m a -> m () +mapM_ f m = S.mapM_ f $ toStreamS m + +------------------------------------------------------------------------------ +-- Conversions +------------------------------------------------------------------------------ + +-- | +-- @ +-- 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 = P.toList + +-- | +-- @ +-- 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 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.foldStream defState yieldk single stop m1 + +------------------------------------------------------------------------------ +-- Transformation by Folding (Scans) +------------------------------------------------------------------------------ + +-- | Strict left scan with an extraction function. Like 'scanl'', but applies a +-- user supplied extraction function (the third argument) at each step. This is +-- designed to work with the @foldl@ library. The suffix @x@ is a mnemonic for +-- extraction. +-- +-- @since 0.2.0 +{-# INLINE scanx #-} +scanx :: IsStream t => (x -> a -> x) -> x -> (x -> b) -> t m a -> t m b +scanx = K.scanx + +-- | +-- @since 0.1.1 +{-# DEPRECATED scan "Please use scanx instead." #-} +scan :: IsStream t => (x -> a -> x) -> x -> (x -> b) -> t m a -> t m b +scan = scanx + +-- 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. +-- +-- @ +-- > 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 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 +------------------------------------------------------------------------------ + +-- | Include only those elements that pass a predicate. +-- +-- @since 0.1.0 +{-# INLINE filter #-} +#if __GLASGOW_HASKELL__ != 802 +-- GHC 8.2.2 crashes with this code, when used with "stack" +filter :: (IsStream t, Monad m) => (a -> Bool) -> t m a -> t m a +filter p m = fromStreamS $ S.filter p $ toStreamS m +#else +filter :: IsStream t => (a -> Bool) -> t m a -> t m a +filter = K.filter +#endif + +-- | Same as 'filter' but with a monadic predicate. +-- +-- @since 0.4.0 +{-# INLINE filterM #-} +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 +{-# INLINE take #-} +take :: (IsStream t, Monad m) => Int -> t m a -> t m a +take n m = fromStreamS $ S.take n $ toStreamS + (maxYields (Just (fromIntegral n)) m) + +-- | End the stream as soon as the predicate fails on an element. +-- +-- @since 0.1.0 +{-# INLINE takeWhile #-} +takeWhile :: (IsStream t, Monad m) => (a -> Bool) -> t m a -> t m a +takeWhile p m = fromStreamS $ S.takeWhile p $ toStreamS m + +-- | Same as 'takeWhile' but with a monadic predicate. +-- +-- @since 0.4.0 +{-# INLINE takeWhileM #-} +takeWhileM :: (IsStream t, Monad m) => (a -> m Bool) -> t m a -> t m a +takeWhileM p m = fromStreamD $ D.takeWhileM p $ toStreamD m + +-- | Discard first 'n' elements from the stream and take the rest. +-- +-- @since 0.1.0 +{-# INLINE drop #-} +drop :: (IsStream t, Monad m) => Int -> t m a -> t m a +drop n m = fromStreamS $ S.drop n $ toStreamS m + +-- | Drop elements in the stream as long as the predicate succeeds and then +-- take the rest of the stream. +-- +-- @since 0.1.0 +{-# INLINE dropWhile #-} +dropWhile :: (IsStream t, Monad m) => (a -> Bool) -> t m a -> t m a +dropWhile p m = fromStreamS $ S.dropWhile p $ toStreamS m + +-- | Same as 'dropWhile' but with a monadic predicate. +-- +-- @since 0.4.0 +{-# INLINE dropWhileM #-} +dropWhileM :: (IsStream t, Monad m) => (a -> m Bool) -> t m a -> t m a +dropWhileM p m = fromStreamD $ D.dropWhileM p $ toStreamD m + +------------------------------------------------------------------------------ +-- Transformation by Mapping +------------------------------------------------------------------------------ + +-- | +-- @ +-- 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)) +-- +-- runStream $ S.replicateM 10 (return 1) +-- & (asyncly . S.mapM (\\x -> threadDelay 1000000 >> print x)) +-- @ +-- +-- /Concurrent (do not use with 'parallely' on infinite streams)/ +-- +-- @since 0.1.0 +{-# INLINE_EARLY mapM #-} +mapM :: (IsStream t, MonadAsync m) => (a -> m b) -> t m a -> t m b +mapM = K.mapM + +{-# RULES "mapM serial" mapM = mapMSerial #-} +{-# INLINE mapMSerial #-} +mapMSerial :: Monad m => (a -> m b) -> SerialT m a -> SerialT m b +mapMSerial = Serial.mapM + +-- | +-- @ +-- 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) +-- +-- runStream $ S.replicateM 10 (return $ threadDelay 1000000 >> print 1) +-- & (asyncly . S.sequence) +-- @ +-- +-- /Concurrent (do not use with 'parallely' on infinite streams)/ +-- +-- @since 0.1.0 +{-# INLINE sequence #-} +sequence :: (IsStream t, MonadAsync m) => t m (m a) -> t m a +sequence m = fromStreamS $ S.sequence (toStreamS m) + +------------------------------------------------------------------------------ +-- Transformation by Map and Filter +------------------------------------------------------------------------------ + +-- | Map a 'Maybe' returning function to a stream, filter out the 'Nothing' +-- elements, and return a stream of values extracted from 'Just'. +-- +-- @since 0.3.0 +{-# INLINE mapMaybe #-} +mapMaybe :: (IsStream t, Monad m) => (a -> Maybe b) -> t m a -> t m b +mapMaybe f m = fromStreamS $ S.mapMaybe f $ toStreamS m + +-- | Like 'mapMaybe' but maps a monadic function. +-- +-- /Concurrent (do not use with 'parallely' on infinite streams)/ +-- +-- @since 0.3.0 +{-# 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 . 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 +------------------------------------------------------------------------------ + +-- XXX to scale this we need to use a slab allocated array backed +-- representation for temporary storage. +-- +-- | Returns the elements of the stream in reverse order. +-- The stream must be finite. +-- +-- @since 0.1.1 +reverse :: (IsStream t) => t m a -> t m a +reverse m = go K.nil m + where + 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.foldStream st yieldk single stop rest + +------------------------------------------------------------------------------ +-- Transformation by Inserting +------------------------------------------------------------------------------ + +-- | 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 +------------------------------------------------------------------------------ + +-- | +-- > 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 #-} +zipWithM :: (IsStream t, Monad m) => (a -> b -> m c) -> t m a -> t m b -> t m c +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 --- a/src/Streamly/SVar.hs +++ b/src/Streamly/SVar.hs @@ -31,7 +31,7 @@ , Limit (..) , State (streamVar) , defState - , rstState + , adaptState , getMaxThreads , setMaxThreads , getMaxBuffer @@ -433,8 +433,15 @@ -- 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 @@ , 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 --- a/src/Streamly/Streams/Ahead.hs +++ b/src/Streamly/Streams/Ahead.hs @@ -48,8 +48,8 @@ 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 @@ 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 @@ -- 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 @@ 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 @@ 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 @@ 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 @@ -- 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 @@ 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 @@ -- 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 --- a/src/Streamly/Streams/Async.hs +++ b/src/Streamly/Streams/Async.hs @@ -57,7 +57,9 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ -- 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 @@ -- @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 @@ (<|) :: (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 @@ 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 @@ -- 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 @@ -- @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 @@ 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 @@ -- 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 --- /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 --- a/src/Streamly/Streams/Instances.hs +++ b/src/Streamly/Streams/Instances.hs @@ -41,3 +41,81 @@ 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 --- a/src/Streamly/Streams/Parallel.hs +++ b/src/Streamly/Streams/Parallel.hs @@ -49,7 +49,8 @@ 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 @@ 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 @@ >> 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 @@ -- @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 @@ {-# 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 @@ {-# 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 @@ -- 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 @@ -- 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 --- a/src/Streamly/Streams/Prelude.hs +++ b/src/Streamly/Streams/Prelude.hs @@ -1,12 +1,11 @@ {-# 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 -- Copyright : (c) 2017 Harendra Kumar @@ -19,17 +18,135 @@ -- 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 @@ {-# 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 @@ {-# 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 @@ {-# 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 --- a/src/Streamly/Streams/SVar.hs +++ b/src/Streamly/Streams/SVar.hs @@ -1,13 +1,5 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE UndecidableInstances #-} -- XXX -#include "inline.h" - -- | -- Module : Streamly.Streams.SVar -- Copyright : (c) 2017 Harendra Kumar @@ -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.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 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 @@ 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 @@ -- 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 --- 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 @@ SerialT , StreamT -- deprecated , Serial - , serial + , K.serial , serially -- * Serial interleaving stream @@ -41,6 +42,8 @@ ) 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.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 @@ 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 @@ 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,8 +176,18 @@ 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 #-} map :: (IsStream t, Monad m) => (a -> b) -> t m a -> t m b @@ -198,6 +195,9 @@ MONAD_APPLICATIVE_INSTANCE(SerialT,) MONAD_COMMON_INSTANCES(SerialT,) +LIST_INSTANCES(SerialT) +FOLDABLE_INSTANCE(SerialT) +TRAVERSABLE_INSTANCE(SerialT) ------------------------------------------------------------------------------ -- WSerialT @@ -267,6 +267,9 @@ 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 @@ {-# 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 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 @@ 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 --- a/src/Streamly/Streams/StreamD.hs +++ b/src/Streamly/Streams/StreamD.hs @@ -5,665 +5,1460 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} - -#include "inline.h" - --- | --- Module : Streamly.Streams.StreamD --- Copyright : (c) 2018 Harendra Kumar --- --- License : BSD3 --- Maintainer : harendra.kumar@gmail.com --- Stability : experimental --- Portability : GHC --- --- Direct style re-implementation of CPS style stream in StreamK module. The --- symbol or suffix 'D' in this module denotes the "Direct" style. GHC is able --- to INLINE and fuse direct style better, providing better performance than --- CPS implementation. --- --- @ --- import qualified Streamly.Streams.StreamD as D --- @ - --- Some of functions in this file have been adapted from the vector --- library, https://hackage.haskell.org/package/vector. - -module Streamly.Streams.StreamD - ( - -- * The stream type - Step (..) - , Stream (..) - - -- * Construction - , nil - , cons - - -- * Deconstruction - , uncons - - -- * Generation - -- ** Unfolds - , unfoldr - , unfoldrM - - -- ** Specialized Generation - -- | Generate a monadic stream from a seed. - , repeat - , enumFromStepN - - -- ** Conversions - -- | Transform an input structure into a stream. - -- | Direct style stream does not support @fromFoldable@. - , yield - , yieldM - , fromList - , fromListM - , fromStreamK - - -- * Elimination - -- ** General Folds - , foldr - , foldrM - , foldl' - , foldlM' - - -- ** Specialized Folds - , runStream - , null - , head - , tail - , last - , elem - , notElem - , all - , any - , maximum - , minimum - - -- ** Map and Fold - , mapM_ - - -- ** Conversions - -- | Transform a stream into another type. - , toList - , toStreamK - - -- * Transformation - -- ** By folding (scans) - , scanlM' - - -- * Filtering - , filter - , filterM - , take - , takeWhile - , takeWhileM - , drop - , dropWhile - , dropWhileM - - -- * Mapping - , map - , mapM - - -- ** Map and Filter - , mapMaybe - , mapMaybeM - - -- * Zipping - , zipWith - , zipWithM - ) -where - -import Data.Maybe (fromJust, isJust) -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) - -import Streamly.SVar (MonadAsync, State(..), defState, rstState) -import qualified Streamly.Streams.StreamK as K - ------------------------------------------------------------------------------- --- 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 - ------------------------------------------------------------------------------- --- Construction ------------------------------------------------------------------------------- - --- | An empty 'Stream'. -{-# INLINE_NORMAL nil #-} -nil :: Monad m => Stream m a -nil = Stream (\_ _ -> return Stop) () - --- | Can fuse but has O(n^2) complexity. -cons :: Monad m => a -> Stream m a -> Stream m a -cons x (Stream step state) = Stream step1 Nothing - where - 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 - -------------------------------------------------------------------------------- --- Deconstruction -------------------------------------------------------------------------------- - --- 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 - where - go st = do - r <- step defState st - return $ case r of - Yield x s -> Just (x, Stream step s) - Stop -> Nothing - ------------------------------------------------------------------------------- --- Generation by unfold ------------------------------------------------------------------------------- - -{-# INLINE_NORMAL unfoldrM #-} -unfoldrM :: Monad m => (s -> m (Maybe (a, s))) -> s -> Stream m a -unfoldrM next state = Stream step state - where - {-# INLINE_LATE step #-} - step _ st = do - r <- next st - return $ case r of - Just (x, s) -> Yield x s - Nothing -> Stop - -{-# INLINE_LATE unfoldr #-} -unfoldr :: Monad m => (s -> Maybe (a, s)) -> s -> Stream m a -unfoldr f = unfoldrM (return . f) - ------------------------------------------------------------------------------- --- Specialized Generation ------------------------------------------------------------------------------- - -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) - where - {-# INLINE_LATE step #-} - step _ (x, i) | i > 0 = return $ Yield x (x + stride, i - 1) - | otherwise = return Stop - -------------------------------------------------------------------------------- --- Generation by Conversion -------------------------------------------------------------------------------- - --- | Create a singleton 'Stream' from a pure value. -{-# INLINE_NORMAL yield #-} -yield :: Monad m => a -> Stream m a -yield x = Stream (\_ s -> return $ step undefined s) True - where - {-# INLINE_LATE step #-} - step _ True = Yield x False - step _ False = Stop - --- | Create a singleton 'Stream' from a monadic action. -{-# INLINE_NORMAL yieldM #-} -yieldM :: Monad m => m a -> Stream m a -yieldM m = Stream step True - where - {-# INLINE_LATE step #-} - step _ True = m >>= \x -> return $ Yield x False - step _ False = return Stop - --- XXX we need the MonadAsync constraint because of a rewrite rule. --- | Convert a list of monadic actions to a 'Stream' -{-# INLINE_LATE fromListM #-} -fromListM :: MonadAsync m => [m a] -> Stream m a -fromListM = Stream step - where - {-# INLINE_LATE step #-} - step _ (m:ms) = m >>= \x -> return $ Yield x ms - step _ [] = return Stop - --- | Convert a list of pure values to a 'Stream' -{-# INLINE_LATE fromList #-} -fromList :: Monad m => [a] -> Stream m a -fromList = Stream step - where - {-# INLINE_LATE 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 - where - step gst m1 = - 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 - ------------------------------------------------------------------------------- --- Elimination by Folds ------------------------------------------------------------------------------- - -{-# INLINE_NORMAL foldrM #-} -foldrM :: Monad m => (a -> b -> m b) -> b -> Stream m a -> m b -foldrM f z (Stream step state) = go SPEC state - where - go !_ st = do - r <- step defState st - case r of - Yield x s -> go SPEC s >>= f x - 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 foldlM' #-} -foldlM' :: Monad m => (b -> a -> m b) -> b -> Stream m a -> m b -foldlM' fstep begin (Stream step state) = go SPEC begin state - where - go !_ acc st = acc `seq` do - r <- step defState st - case r of - Yield x s -> do - acc' <- fstep acc x - go SPEC acc' s - Stop -> return acc - -{-# INLINE foldl' #-} -foldl' :: Monad m => (b -> a -> b) -> b -> Stream m a -> m b -foldl' fstep = foldlM' (\b a -> return (fstep b a)) - ------------------------------------------------------------------------------- --- Specialized Folds ------------------------------------------------------------------------------- - --- | Run a streaming composition, discard the results. -{-# INLINE_LATE runStream #-} -runStream :: Monad m => Stream m a -> m () -runStream (Stream step state) = go SPEC state - where - go !_ st = do - r <- step defState st - case r of - Yield _ s -> go SPEC s - Stop -> return () - -{-# INLINE_NORMAL null #-} -null :: Monad m => Stream m a -> m Bool -null (Stream step state) = go state - where - go st = do - r <- step defState st - case r of - Yield _ _ -> return False - Stop -> return True - --- XXX SPEC? -{-# INLINE_NORMAL head #-} -head :: Monad m => Stream m a -> m (Maybe a) -head (Stream step state) = go state - where - go st = do - r <- step defState st - case r of - Yield x _ -> return (Just x) - 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 - where - go st = do - r <- step defState st - case r of - Yield _ s -> return (Just $ Stream step s) - Stop -> return Nothing - --- XXX will it fuse? need custom impl? -{-# INLINE_NORMAL last #-} -last :: Monad m => Stream m a -> m (Maybe a) -last = foldl' (\_ y -> Just y) Nothing - -{-# INLINE_NORMAL elem #-} -elem :: (Monad m, Eq a) => a -> Stream m a -> m Bool -elem 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 True - else 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 - -{-# INLINE_NORMAL all #-} -all :: Monad m => (a -> Bool) -> Stream m a -> m Bool -all p (Stream step state) = go state - where - 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 - -{-# INLINE_NORMAL any #-} -any :: Monad m => (a -> Bool) -> Stream m a -> m Bool -any p (Stream step state) = go state - where - 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 - -{-# INLINE_NORMAL maximum #-} -maximum :: (Monad m, Ord a) => Stream m a -> m (Maybe a) -maximum (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 - 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) - -{-# INLINE_NORMAL minimum #-} -minimum :: (Monad m, Ord a) => Stream m a -> m (Maybe a) -minimum (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 - 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) - ------------------------------------------------------------------------------- --- Map and Fold ------------------------------------------------------------------------------- - --- | Execute a monadic action for each element of the 'Stream' -{-# INLINE_NORMAL mapM_ #-} -mapM_ :: Monad m => (a -> m b) -> Stream m a -> m () -mapM_ m = runStream . mapM m - ------------------------------------------------------------------------------- --- Converting folds ------------------------------------------------------------------------------- - -{-# INLINE toList #-} -toList :: Monad m => Stream m a -> m [a] -toList = foldr (:) [] - --- Convert a direct stream to and from CPS encoded stream -{-# INLINE_LATE toStreamK #-} -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 - r <- step gst st - case r of - Yield x s -> yld x (go s) - Stop -> stp - -#ifndef DISABLE_FUSION -{-# RULES "fromStreamK/toStreamK fusion" - forall s. toStreamK (fromStreamK s) = s #-} -{-# RULES "toStreamK/fromStreamK fusion" - forall s. fromStreamK (toStreamK s) = s #-} -#endif - ------------------------------------------------------------------------------- --- Transformation by Folding (Scans) ------------------------------------------------------------------------------- - -{-# INLINE_NORMAL postscanlM' #-} -postscanlM' :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b -postscanlM' fstep begin (Stream step state) = - begin `seq` Stream step' (state, begin) - where - {-# INLINE_LATE step' #-} - step' gst (st, acc) = acc `seq` do - r <- step (rstState gst) st - case r of - Yield x s -> do - y <- fstep acc x - y `seq` return (Yield y (s, y)) - Stop -> return Stop - -{-# INLINE 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) - -------------------------------------------------------------------------------- --- Filtering -------------------------------------------------------------------------------- - -{-# INLINE_NORMAL take #-} -take :: Monad m => Int -> Stream m a -> Stream m a -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 - return $ case r of - Yield x s -> Yield x (s, i + 1) - Stop -> Stop - step' _ (_, _) = return Stop - -{-# INLINE_NORMAL takeWhileM #-} -takeWhileM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a -takeWhileM f (Stream step state) = Stream step' state - where - {-# INLINE_LATE step' #-} - step' gst st = do - r <- step (rstState gst) st - case r of - Yield x s -> do - b <- f x - return $ if b then Yield x s else Stop - Stop -> return Stop - -{-# INLINE takeWhile #-} -takeWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a -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) - where - {-# INLINE_LATE step' #-} - step' gst (st, i) = do - r <- step (rstState gst) st - case r of - Yield _ s | i > 0 -> step' gst (s, i - 1) - Yield x s -> return $ Yield x (s, 0) - Stop -> return Stop - -data DropWhileState s a - = DropWhileDrop s - | DropWhileYield a s - | DropWhileNext s - -{-# INLINE_NORMAL dropWhileM #-} -dropWhileM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a -dropWhileM f (Stream step state) = Stream step' (DropWhileDrop state) - where - {-# INLINE_LATE step' #-} - step' gst (DropWhileDrop st) = do - r <- step (rstState 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) - Stop -> return Stop - - step' gst (DropWhileNext st) = do - r <- step (rstState gst) st - case r of - Yield x s -> step' gst (DropWhileYield x s) - Stop -> return Stop - - step' _ (DropWhileYield x st) = return $ Yield x (DropWhileNext st) - -{-# INLINE dropWhile #-} -dropWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a -dropWhile f = dropWhileM (return . f) - -{-# INLINE_NORMAL filterM #-} -filterM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a -filterM f (Stream step state) = Stream step' state - where - {-# INLINE_LATE step' #-} - step' gst st = do - r <- step (rstState 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 - -{-# INLINE filter #-} -filter :: Monad m => (a -> Bool) -> Stream m a -> Stream m a -filter f = filterM (return . f) - ------------------------------------------------------------------------------- --- 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 - where - {-# INLINE_LATE step' #-} - step' gst st = do - r <- step (rstState gst) st - case r of - Yield x s -> f x >>= \a -> return $ Yield a s - Stop -> return Stop - -{-# INLINE map #-} -map :: Monad m => (a -> b) -> Stream m a -> Stream m b -map f = mapM (return . f) - ------------------------------------------------------------------------------- --- Transformation by Map and Filter ------------------------------------------------------------------------------- - --- XXX Will this always fuse properly? -{-# INLINE_NORMAL mapMaybe #-} -mapMaybe :: Monad m => (a -> Maybe b) -> Stream m a -> Stream m b -mapMaybe f = fmap fromJust . filter isJust . map f - -{-# INLINE_NORMAL mapMaybeM #-} -mapMaybeM :: Monad m => (a -> m (Maybe b)) -> Stream m a -> Stream m b -mapMaybeM f = fmap fromJust . filter isJust . mapM f - ------------------------------------------------------------------------------- --- Instances ------------------------------------------------------------------------------- - -{-# INLINE_NORMAL zipWithM #-} -zipWithM :: Monad m - => (a -> b -> m c) -> Stream m a -> Stream m b -> Stream m c -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 - - step gst (sa, sb, Just x) = do - r <- stepb (rstState gst) sb - case r of - Yield y sb' -> do - z <- f x y - return $ Yield z (sa, sb', Nothing) - Stop -> return Stop - -{-# RULES "zipWithM xs xs" - forall f xs. zipWithM f xs xs = mapM (\x -> f x x) xs #-} - -{-# INLINE zipWith #-} -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 ------------------------------------------------------------------------------- - -instance Monad m => Functor (Stream m) where - {-# INLINE fmap #-} - fmap = map +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RankNTypes #-} + +#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 +-- Stability : experimental +-- Portability : GHC +-- +-- Direct style re-implementation of CPS style stream in StreamK module. The +-- symbol or suffix 'D' in this module denotes the "Direct" style. GHC is able +-- to INLINE and fuse direct style better, providing better performance than +-- CPS implementation. +-- +-- @ +-- import qualified Streamly.Streams.StreamD as D +-- @ + +-- Some of the functions in this file have been adapted from the vector +-- library, https://hackage.haskell.org/package/vector. + +module Streamly.Streams.StreamD + ( + -- * The stream type + Step (..) + , Stream (..) + + -- * Construction + , nil + , cons + + -- * Deconstruction + , uncons + + -- * Generation + -- ** Unfolds + , unfoldr + , unfoldrM + + -- ** Specialized Generation + -- | Generate a monadic stream from a seed. + , repeat + , 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. + -- | Direct style stream does not support @fromFoldable@. + , yield + , yieldM + , fromList + , fromListM + , fromStreamK + , fromStreamD + + -- * Elimination + -- ** General Folds + , foldr + , foldrM + , foldr1 + , foldl' + , foldlM' + + -- ** Specialized Folds + , runStream + , null + , head + , tail + , last + , elem + , notElem + , all + , any + , maximum + , maximumBy + , minimum + , minimumBy + , findIndices + , lookup + , findM + , find + , (!!) + , concatMapM + , concatMap + + -- ** Substreams + , isPrefixOf + , isSubsequenceOf + , stripPrefix + + -- ** Map and Fold + , mapM_ + + -- ** Conversions + -- | 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 + , drop + , dropWhile + , dropWhileM + + -- * 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 + +import Data.Maybe (fromJust, isJust) +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, lookup, foldr1, sequence, + (!!), scanl, scanl1, concatMap, replicate, enumFromTo) + +import Streamly.SVar (MonadAsync, defState, adaptState) + +import Streamly.Streams.StreamD.Type +import qualified Streamly.Streams.StreamK as K + +------------------------------------------------------------------------------ +-- Construction +------------------------------------------------------------------------------ + +-- | An empty 'Stream'. +{-# INLINE_NORMAL nil #-} +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 gst st + return $ + case r of + Yield a s -> Yield a (Just s) + Skip s -> Skip (Just s) + Stop -> Stop + +------------------------------------------------------------------------------- +-- Deconstruction +------------------------------------------------------------------------------- + +-- 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 (UnStream step state) = go state + where + go st = do + r <- step defState st + case r of + Yield x s -> return $ Just (x, Stream step s) + Skip s -> go s + Stop -> return Nothing + +------------------------------------------------------------------------------ +-- Generation by unfold +------------------------------------------------------------------------------ + +{-# INLINE_NORMAL unfoldrM #-} +unfoldrM :: Monad m => (s -> m (Maybe (a, s))) -> s -> Stream m a +unfoldrM next state = Stream step state + where + {-# INLINE_LATE step #-} + step _ st = do + r <- next st + return $ case r of + Just (x, s) -> Yield x s + Nothing -> Stop + +{-# INLINE_LATE unfoldr #-} +unfoldr :: Monad m => (s -> Maybe (a, s)) -> s -> Stream m a +unfoldr f = unfoldrM (return . f) + +------------------------------------------------------------------------------ +-- Specialized Generation +------------------------------------------------------------------------------ + +repeat :: Monad m => a -> Stream m a +repeat x = Stream (\_ _ -> return $ Yield x ()) () + +{-# 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 = 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 +------------------------------------------------------------------------------- + +-- | Create a singleton 'Stream' from a pure value. +{-# INLINE_NORMAL yield #-} +yield :: Monad m => a -> Stream m a +yield x = Stream (\_ s -> return $ step undefined s) True + where + {-# INLINE_LATE step #-} + step _ True = Yield x False + step _ False = Stop + +-- | Create a singleton 'Stream' from a monadic action. +{-# INLINE_NORMAL yieldM #-} +yieldM :: Monad m => m a -> Stream m a +yieldM m = Stream step True + where + {-# INLINE_LATE step #-} + 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 #-} +fromListM :: MonadAsync m => [m a] -> Stream m a +fromListM = Stream step + where + {-# INLINE_LATE step #-} + step _ (m:ms) = m >>= \x -> return $ Yield x ms + step _ [] = return Stop + +-- | Convert a list of pure values to a 'Stream' +{-# INLINE_LATE fromList #-} +fromList :: Monad m => [a] -> Stream m a +fromList = Stream step + where + {-# INLINE_LATE step #-} + step _ (x:xs) = return $ Yield x xs + step _ [] = return Stop + +{-# INLINE_LATE fromStreamK #-} +fromStreamK :: Monad m => K.Stream m a -> Stream m a +fromStreamK = Stream step + where + step gst m1 = + let stop = return Stop + single a = return $ Yield a K.nil + yieldk a r = return $ Yield a r + 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 +------------------------------------------------------------------------------ + +{-# INLINE_NORMAL foldrM #-} +foldrM :: Monad m => (a -> b -> m b) -> b -> Stream m a -> m b +foldrM f z (Stream step state) = go SPEC state + where + go !_ st = do + 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 + where + go !_ acc st = acc `seq` do + r <- step defState st + case r of + Yield x s -> do + acc' <- fstep acc x + go SPEC acc' s + Skip s -> go SPEC acc s + Stop -> return acc + +{-# INLINE foldl' #-} +foldl' :: Monad m => (b -> a -> b) -> b -> Stream m a -> m b +foldl' fstep = foldlM' (\b a -> return (fstep b a)) + +------------------------------------------------------------------------------ +-- Specialized Folds +------------------------------------------------------------------------------ + +-- | Run a streaming composition, discard the results. +{-# INLINE_LATE runStream #-} +runStream :: Monad m => Stream m a -> m () +runStream (Stream step state) = go SPEC state + where + go !_ st = do + r <- step defState st + case r of + Yield _ s -> go SPEC s + Skip s -> go SPEC s + Stop -> return () + +{-# INLINE_NORMAL null #-} +null :: Monad m => Stream m a -> m Bool +null (Stream step state) = go state + where + go st = do + r <- step defState st + case r of + Yield _ _ -> return False + Skip s -> go s + Stop -> return True + +-- XXX SPEC? +{-# INLINE_NORMAL head #-} +head :: Monad m => Stream m a -> m (Maybe a) +head (Stream step state) = go state + where + go st = do + r <- step defState st + case r of + Yield x _ -> return (Just x) + 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 (UnStream step state) = go state + where + go st = do + r <- step defState st + case r of + Yield _ s -> return (Just $ Stream step s) + Skip s -> go s + Stop -> return Nothing + +-- XXX will it fuse? need custom impl? +{-# INLINE_NORMAL last #-} +last :: Monad m => Stream m a -> m (Maybe a) +last = foldl' (\_ y -> Just y) Nothing + +{-# INLINE_NORMAL elem #-} +elem :: (Monad m, Eq a) => a -> Stream m a -> m Bool +elem e (Stream step state) = go state + where + go st = do + r <- step defState st + case r of + 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 s = fmap not (elem e s) + +{-# INLINE_NORMAL all #-} +all :: Monad m => (a -> Bool) -> Stream m a -> m Bool +all p (Stream step state) = go state + where + go st = do + r <- step defState st + case r of + 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 +any p (Stream step state) = go state + where + go st = do + r <- step defState st + case r of + 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) +maximum (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 + | 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 -> 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) +minimum (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 + | 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 +------------------------------------------------------------------------------ + +-- | Execute a monadic action for each element of the 'Stream' +{-# INLINE_NORMAL mapM_ #-} +mapM_ :: Monad m => (a -> m b) -> Stream m a -> m () +mapM_ m = runStream . mapM m + +------------------------------------------------------------------------------ +-- Converting folds +------------------------------------------------------------------------------ + +{-# INLINE toList #-} +toList :: Monad m => Stream m a -> m [a] +toList = foldr (:) [] + +-- Convert a direct stream to and from CPS encoded stream +{-# INLINE_LATE toStreamK #-} +toStreamK :: Monad m => Stream m a -> K.Stream m a +toStreamK (Stream step state) = go state + where + 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 +{-# RULES "fromStreamK/toStreamK fusion" + forall s. toStreamK (fromStreamK s) = s #-} +{-# RULES "toStreamK/fromStreamK fusion" + 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) = + begin `seq` Stream step' (state, begin) + where + {-# INLINE_LATE step' #-} + step' gst (st, acc) = acc `seq` do + r <- step (adaptState gst) st + case r of + Yield x s -> do + y <- fstep acc x + y `seq` 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 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 +------------------------------------------------------------------------------- + +{-# INLINE_NORMAL take #-} +take :: Monad m => Int -> Stream m a -> Stream m a +take n (Stream step state) = n `seq` Stream step' (state, 0) + where + {-# INLINE_LATE step' #-} + step' gst (st, i) | i < n = do + 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 + +{-# INLINE_NORMAL takeWhileM #-} +takeWhileM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a +takeWhileM f (Stream step state) = Stream step' state + where + {-# INLINE_LATE step' #-} + step' gst st = do + r <- step gst st + case r of + Yield x s -> do + b <- f x + return $ if b then Yield x s else Stop + Skip s -> return $ Skip s + Stop -> return Stop + +{-# INLINE takeWhile #-} +takeWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a +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, Just n) + where + {-# INLINE_LATE step' #-} + 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 x s -> Yield x (s, Nothing) + Skip s -> Skip (s, Nothing) + Stop -> Stop + +data DropWhileState s a + = DropWhileDrop s + | DropWhileYield a s + | DropWhileNext s + +{-# INLINE_NORMAL dropWhileM #-} +dropWhileM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a +dropWhileM f (Stream step state) = Stream step' (DropWhileDrop state) + where + {-# INLINE_LATE step' #-} + step' gst (DropWhileDrop st) = do + r <- step gst st + case r of + Yield x s -> do + b <- f x + if b + 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 gst st + case r of + 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) + +{-# INLINE dropWhile #-} +dropWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a +dropWhile f = dropWhileM (return . f) + +{-# INLINE_NORMAL filterM #-} +filterM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a +filterM f (Stream step state) = Stream step' state + where + {-# INLINE_LATE step' #-} + step' gst st = do + r <- step gst st + case r of + Yield x s -> do + b <- f x + 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 +------------------------------------------------------------------------------ + +{-# 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 (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 -> 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 + + 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 +------------------------------------------------------------------------------ + +-- XXX Will this always fuse properly? +{-# INLINE_NORMAL mapMaybe #-} +mapMaybe :: Monad m => (a -> Maybe b) -> Stream m a -> Stream m b +mapMaybe f = fmap fromJust . filter isJust . map f + +{-# INLINE_NORMAL mapMaybeM #-} +mapMaybeM :: Monad m => (a -> m (Maybe b)) -> Stream m a -> Stream m b +mapMaybeM f = fmap fromJust . filter isJust . mapM f + +------------------------------------------------------------------------------ +-- 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 +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 (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 (adaptState gst) sb + case r of + Yield y sb' -> do + z <- f x y + return $ Yield z (sa, sb', Nothing) + 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 #-} + +{-# INLINE zipWith #-} +zipWith :: Monad m => (a -> b -> c) -> Stream m a -> Stream m b -> Stream m c +zipWith f = zipWithM (\a b -> return (f a b)) + +------------------------------------------------------------------------------ +-- Comparisions +------------------------------------------------------------------------------ + +{-# 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 --- /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 --- 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,23 +35,22 @@ , 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 @@ -- ** Specialized Generation , repeat + , replicate + , replicateM -- ** Conversions , yield @@ -69,7 +73,6 @@ -- * Elimination -- ** General Folds - , foldStream , foldr , foldrM , foldr1 @@ -90,10 +93,14 @@ , any , last , minimum + , minimumBy , maximum + , maximumBy , findIndices , lookup + , findM , find + , (!!) -- ** Map and Fold , mapM_ @@ -121,7 +128,11 @@ -- ** Inserting , intersperseM + , insertBy + -- ** Deleting + , deleteBy + -- ** Map and Filter , mapMaybe @@ -129,11 +140,18 @@ , zipWith , zipWithM + -- ** Merging + , mergeBy + , mergeByM + + -- ** Transformation comprehensions + , the + -- * Semigroup Style Composition , serial -- * Utilities - , consMSerial + , consMStream , bindWith , withLocal @@ -144,194 +162,27 @@ 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 - ------------------------------------------------------------------------------- --- 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 ------------------------------------------------------------------------------- +import Streamly.Streams.StreamK.Type --- | 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 @@ -- @ -- -- @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,51 +211,11 @@ -- @ -- -- @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 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,20 +283,42 @@ 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 #-} fromFoldable :: (IsStream t, Foldable f) => f a -> t m a @@ -482,47 +329,34 @@ 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 @@ 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 @@ -- 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 @@ -- 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 @@ 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 @@ 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 @@ {-# 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 @@ 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 @@ 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 @@ -- | 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 @@ {-# 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 @@ {-# 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,106 +807,152 @@ {-# INLINE intersperseM #-} intersperseM :: (IsStream t, MonadAsync m) => m a -> t m a -> t m a -intersperseM a m = fromStream $ prependingStart (toStream m) +intersperseM a m = prependingStart 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 + 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 ------------------------------------------------------------------------------- {-# 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 +{-# 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 (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 + 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 -instance Semigroup (Stream m a) where - (<>) = serial +{-# 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 @@ {-# 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 @@ :: 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 --- /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 --- 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 @@ ) 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 @@ 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 @@ {-# 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 @@ {-# 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 @@ {-# 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 --- 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 --- /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 --- /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", for more details and +-- 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 --- 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 @@ -- *** Parallel Asynchronous Composition ('Parallel') -- $parallel - -- *** Custom composition - -- $custom + -- XXX we should deprecate and remove the mkAsync API + -- Custom composition + -- custom -- ** Monoid Style -- $monoid @@ -199,13 +200,19 @@ -- $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 -- they can speculatively execute multiple stream actions concurrently in @@ -229,35 +236,37 @@ -- 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 @@ -- $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 @@ -- 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 @@ -- 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 @@ -- 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 @@ -- 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 @@ -- 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 @@ -- 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 @@ -- [(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 @@ -- [(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 @@ -- and operators instead of the ugly pragmas. -- -- For more concurrent programming examples see, --- "ListDir.hs", "MergeSort.hs" and "SearchQuery.hs" in the examples directory. +-- , +-- and +-- in the examples directory. -- $reactive -- @@ -1454,52 +1466,65 @@ -- {-\# 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 -- --- 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 --- Quit -> fail "quit" +-- Harm n -> modify (\\h -> h - n) >> return Check +-- Heal n -> modify (\\h -> h + n) >> return Check +-- Quit -> return Done -- --- h <- get --- when (h <= 0) $ fail "You die!" --- liftIO $ putStrLn $ "Health = " ++ show h +-- 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 +-- . It has been adapted from Gabriel's -- -- 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 +-- . -- $performance -- @@ -1684,7 +1709,7 @@ -- 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 --- a/stack-7.10.yaml +++ b/stack-7.10.yaml @@ -12,6 +12,7 @@ - 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 --- a/stack-8.0.yaml +++ b/stack-8.0.yaml @@ -8,6 +8,7 @@ - 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 --- 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 --- 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 @@ . The basic streaming functionality of streamly is equivalent to that provided by streaming libraries like - , , , and . @@ -31,8 +30,8 @@ . 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 @@ 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 @@ 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 @@ 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 @@ , 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 @@ 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 @@ , 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 @@ , 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 @@ 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 @@ build-Depends: streamly , base >= 4.8 && < 5 - , random >= 1.0.0 && < 1.2 + , random >= 1.0.0 && < 2 ------------------------------------------------------------------------------- -- Benchmarks @@ -307,7 +369,7 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ , 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,31 +509,84 @@ -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 hs-source-dirs: benchmark @@ -510,7 +627,7 @@ 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 @@ 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 --- a/test/Prop.hs +++ b/test/Prop.hs @@ -13,12 +13,15 @@ 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,32 +75,87 @@ ) 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 = error $ label <> " " <> "BlockedIndefinitelyOnMVar\n" @@ -199,6 +257,32 @@ 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 @@ 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 @@ 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 @@ -> 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 @@ 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 @@ -> 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 @@ 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 @@ 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 <> " 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 <> " 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,15 +629,54 @@ 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 :: (IsStream t @@ -583,6 +693,25 @@ 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 @@ let list = (,) <$> a <*> b listEquals eq stream list +------------------------------------------------------------------------------- +-- Zip operations +------------------------------------------------------------------------------- + zipApplicative :: (IsStream t, Applicative (t IO)) => ([Int] -> t IO Int) @@ -650,6 +783,10 @@ listEquals eq stream1 list listEquals eq stream2 list +------------------------------------------------------------------------------- +-- Monad operations +------------------------------------------------------------------------------- + monadThen :: Monad (t IO) => ([Int] -> t IO Int) @@ -678,16 +815,6 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 $ 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 $ 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 folded "serially folded" + wSerialOps $ eliminationOpsOrdered folded "wSerially folded" + aheadOps $ eliminationOpsOrdered folded "aheadly folded" + zipSerialOps $ eliminationOpsOrdered folded "zipSerially folded" + zipAsyncOps $ eliminationOpsOrdered folded "zipAsyncly folded"