diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,3 +1,32 @@ +## 0.7.1 + +### Bug Fixes + +* Fix a bug that caused `findIndices` to return wrong indices in some + cases. +* Fix a bug in `tap`, `chunksOf` that caused memory consumption to + increase in some cases. +* Fix a space leak in concurrent streams (`async`, `wAsync`, and `ahead`) that + caused memory consumption to increase with the number of elements in the + stream, especially when built with `-threaded` and used with `-N` RTS option. + The issue occurs only in cases when a worker thread happens to be used + continuously for a long time. +* Fix scheduling of WAsyncT stream style to be in round-robin fashion. +* Now builds with `containers` package version < 0.5.8. +* Now builds with `network` package version >= 3.0.0.0 && < 3.1.0.0. + +### Behavior change + +* Combinators in `Streamly.Network.Inet.TCP` no longer use TCP `NoDelay` and + `ReuseAddr` socket options by default. These options can now be specified + using appropriate combinators. + +### Performance + +* Now uses `fusion-plugin` package for predictable stream fusion optimizations +* Significant improvement in performance of concurrent stream operations. +* Improved space and time performance of `Foldable` instance. + ## 0.7.0 ### Breaking changes @@ -43,6 +72,8 @@ * Fix a bug that caused `uniq` function to yield the same element twice. * Fix a bug that caused "thread blocked indefinitely in an MVar operation" exception in a parallel stream. +* Fix unbounded memory usage (leak) in `parallel` combinator. The bug manifests + when large streams are combined using `parallel`. ### Major Enhancements @@ -348,7 +379,7 @@ * Add `iterate`, `iterateM` stream operations ### Bug Fixes -* Fixed a bug that casued unexpected behavior when `pure` was used to inject +* Fixed a bug that caused unexpected behavior when `pure` was used to inject values in Applicative composition of `ZipStream` and `ZipAsync` types. ## 0.1.1 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,20 @@ # Streamly +[![Hackage](https://img.shields.io/hackage/v/streamly.svg?style=flat)](https://hackage.haskell.org/package/streamly) +[![Gitter chat](https://badges.gitter.im/composewell/gitter.svg)](https://gitter.im/composewell/streamly) +[![Travis](https://travis-ci.com/composewell/streamly.svg?branch=master)](https://travis-ci.com/composewell/streamly) +[![Appveyor](https://ci.appveyor.com/api/projects/status/ajxg0c79raou9ned?svg=true)](https://ci.appveyor.com/project/harendra-kumar/streamly) +[![CircleCI](https://circleci.com/gh/composewell/streamly/tree/master.svg?style=svg)](https://circleci.com/gh/composewell/streamly/tree/master) +[![Coverage Status](https://coveralls.io/repos/composewell/streamly/badge.svg?branch=master&service=github)](https://coveralls.io/github/composewell/streamly?branch=master) + +## Learning Materials + +* Documentation: [Quick](#streaming-concurrently) | [Tutorial](https://hackage.haskell.org/package/streamly/docs/Streamly-Tutorial.html) | [Reference (Hackage)](https://hackage.haskell.org/package/streamly) | [Reference (Latest)](https://composewell.github.io/streamly) | [Guides](docs) +* Installing: [Installing](./INSTALL.md) | [Building for optimal performance](docs/Build.md) +* Examples: [streamly](examples) | [streamly-examples](https://github.com/composewell/streamly-examples) +* Benchmarks: [Streaming](https://github.com/composewell/streaming-benchmarks) | [Concurrency](https://github.com/composewell/concurrency-benchmarks) +* Talks: [Functional Conf 2019 Video](https://www.youtube.com/watch?v=uzsqgdMMgtk) | [Functional Conf 2019 Slides](https://www.slideshare.net/HarendraKumar10/streamly-concurrent-data-flow-programming) + ## Streaming Concurrently Haskell lists express pure computations using composable stream operations like @@ -87,7 +102,7 @@ ## Installing and using -Please see [INSTALL.md](INSTALL.md) for instructions on how to use streamly +Please see [INSTALL.md](./INSTALL.md) for instructions on how to use streamly with your Haskell build tool or package manager. You may want to go through it before jumping to run the examples below. @@ -500,7 +515,7 @@ supposed to work in non-concurrent code. When concurrent streams are combined together, exceptions from the constituent streams are propagated to the consumer stream. When an exception occurs in any of the constituent -streams other concurrent streams are promptly terminated. +streams other concurrent streams are promptly terminated. There is no notion of explicit threads in streamly, therefore, no asynchronous exceptions to deal with. You can just ignore the zillions of @@ -568,24 +583,6 @@ See the `Comparison with existing packages` section at the end of the [tutorial](https://hackage.haskell.org/package/streamly/docs/Streamly-Tutorial.html). - -## Further Reading - -For more information, see: - - * [Detailed tutorial](https://hackage.haskell.org/package/streamly/docs/Streamly-Tutorial.html) - * [Reference documentation](https://hackage.haskell.org/package/streamly) - * [Examples](examples) - * [Guides](docs) - * [Streaming benchmarks](https://github.com/composewell/streaming-benchmarks) - * [Concurrency benchmarks](https://github.com/composewell/concurrency-benchmarks) - -For additional unreleased/experimental APIs, build the haddock docs using: - -``` -$ cabal haddock --haddock-option="--show-all" -$ stack haddock --haddock-arguments "--show-all" --no-haddock-deps -``` ## Support diff --git a/bench.sh b/bench.sh --- a/bench.sh +++ b/bench.sh @@ -1,17 +1,41 @@ #!/bin/bash +SERIAL_BENCHMARKS="linear linear-rate nested nested-unfold base" +# parallel benchmark-suite is separated because we run it with a higher +# heap size limit. +CONCURRENT_BENCHMARKS="linear-async nested-concurrent parallel concurrent adaptive" +ARRAY_BENCHMARKS="array unpinned-array prim-array small-array" + +INFINITE_BENCHMARKS="$SERIAL_BENCHMARKS linear-async nested-concurrent" +FINITE_BENCHMARKS="$ARRAY_BENCHMARKS fileio parallel concurrent adaptive" + +QUICK_BENCHMARKS="linear-rate concurrent adaptive" +VIRTUAL_BENCHMARKS="array-cmp" + +ALL_BENCHMARKS="$SERIAL_BENCHMARKS $CONCURRENT_BENCHMARKS $ARRAY_BENCHMARKS $VIRTUAL_BENCHMARKS" + +list_benches () { + for i in $ALL_BENCHMARKS + do + echo -n "|$i" + done +} + print_help () { echo "Usage: $0 " - echo " [--benchmarks ]" + echo " [--benchmarks ]" echo " [--group-diff]" echo " [--graphs]" echo " [--no-measure]" - echo " [--append] " - echo " [--compare] [--base commit] [--candidate commit]" + echo " [--append]" + echo " [--long]" echo " [--slow]" - echo " -- " + echo " [--quick]" + echo " [--compare] [--base commit] [--candidate commit]" + echo " [--cabal-build-flags]" + echo " -- " echo - echo "Multiple benchmarks can be specified as a space separate list" + echo "Multiple benchmarks can be specified as a space separated list" echo " e.g. --benchmarks \"linear nested\"" echo echo "--group-diff is used to compare groups within a single benchmark" @@ -21,7 +45,7 @@ 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 "Any arguments after a '--' are passed directly to gauge" exit } @@ -34,12 +58,23 @@ set_benchmarks() { if test -z "$BENCHMARKS" then - BENCHMARKS=$DEFAULT_BENCHMARKS - elif test "$BENCHMARKS" = "all" - then - BENCHMARKS=$ALL_BENCHMARKS + echo $DEFAULT_BENCHMARKS + else + for i in $(echo $BENCHMARKS) + do + case $i in + ALL) echo -n $ALL_BENCHMARKS ;; + SERIAL) echo -n $SERIAL_BENCHMARKS ;; + CONCURRENT) echo -n $CONCURRENT_BENCHMARKS ;; + ARRAY) echo -n $ARRAY_BENCHMARKS ;; + INFINITE) echo -n $INFINITE_BENCHMARKS ;; + FINITE) echo -n $FINITE_BENCHMARKS ;; + array-cmp) echo -n "$ARRAY_BENCHMARKS array-cmp" ;; + *) echo -n $i ;; + esac + echo -n " " + done fi - echo "Using benchmark suites [$BENCHMARKS]" } # $1: benchmark name (linear, nested, base) @@ -86,7 +121,7 @@ # We run the benchmarks in isolation in a separate process so that different # benchmarks do not interfere with other. To enable that we need to pass the -# benchmark exe path to guage as an argument. Unfortunately it cannot find its +# benchmark exe path to gauge as an argument. Unfortunately it cannot find its # own path currently. # The path is dependent on the architecture and cabal version. @@ -137,6 +172,7 @@ local bench_name=$1 local output_file=$(bench_output_file $bench_name) local bench_prog + local quick_bench=0 bench_prog=$($GET_BENCH_PROG $bench_name) || \ die "Cannot find benchmark executable for benchmark $bench_name" @@ -144,6 +180,35 @@ echo "Running benchmark $bench_name ..." + for i in $QUICK_BENCHMARKS + do + if test "$(has_benchmark $i)" = "$bench_name" + then + quick_bench=1 + fi + done + + local QUICK_OPTS="--quick --time-limit 1 --min-duration 0" + local SPEED_OPTIONS + if test "$LONG" -eq 0 + then + if test "$SLOW" -eq 0 + then + if test "$QUICK" -eq 0 -a "$quick_bench" -eq 0 + then + # reasonably quick + SPEED_OPTIONS="$QUICK_OPTS --min-samples 10" + else + # super quick but less accurate + SPEED_OPTIONS="$QUICK_OPTS --include-first-iter" + fi + else + SPEED_OPTIONS="--min-duration 0" + fi + else + SPEED_OPTIONS="--stream-size 10000000 $QUICK_OPTS --include-first-iter" + fi + $bench_prog $SPEED_OPTIONS \ --csvraw=$output_file \ -v 2 \ @@ -231,7 +296,6 @@ #----------------------------------------------------------------------------- DEFAULT_BENCHMARKS="linear" -ALL_BENCHMARKS="linear linear-async linear-rate nested concurrrent fileio array base" GROUP_DIFF=0 COMPARE=0 @@ -239,14 +303,17 @@ CANDIDATE= APPEND=0 +SLOW=0 +QUICK=0 +LONG=0 RAW=0 GRAPH=0 MEASURE=1 -SPEED_OPTIONS="--quick --min-samples 10 --time-limit 1 --min-duration 0" GAUGE_ARGS= BUILD_ONCE=0 USE_STACK=0 +CABAL_BUILD_FLAGS="" GHC_VERSION=$(ghc --numeric-version) @@ -263,14 +330,17 @@ case $1 in -h|--help|help) print_help ;; # options with arguments - --slow) SPEED_OPTIONS="--min-duration 0"; shift ;; --benchmarks) shift; BENCHMARKS=$1; shift ;; --base) shift; BASE=$1; shift ;; --candidate) shift; CANDIDATE=$1; shift ;; + --cabal-build-flags) shift; CABAL_BUILD_FLAGS=$1; shift ;; # flags + --slow) SLOW=1; shift ;; + --quick) QUICK=1; shift ;; --compare) COMPARE=1; shift ;; --raw) RAW=1; shift ;; --append) APPEND=1; shift ;; + --long) LONG=1; shift ;; --group-diff) GROUP_DIFF=1; shift ;; --graphs) GRAPH=1; shift ;; --no-measure) MEASURE=0; shift ;; @@ -281,34 +351,58 @@ done GAUGE_ARGS=$* -echo "Using stack command [$STACK]" -set_benchmarks - -if echo "$BENCHMARKS" | grep -q base +BENCHMARKS=$(set_benchmarks) +if test "$LONG" -ne 0 then - STACK_BUILD_FLAGS="--flag streamly:dev" - CABAL_BUILD_FLAGS="--flags dev" + BENCHMARKS=$INFINITE_BENCHMARKS fi -if echo "$BENCHMARKS" | grep -q concurrent -then - STACK_BUILD_FLAGS="--flag streamly:dev" - CABAL_BUILD_FLAGS="--flags dev" -fi +only_real_benchmarks () { + for i in $BENCHMARKS + do + local SKIP=0 + for j in $VIRTUAL_BENCHMARKS + do + if test $i == $j + then + SKIP=1 + fi + done + if test "$SKIP" -eq 0 + then + echo -n "$i " + fi + done +} +BENCHMARKS_ORIG=$BENCHMARKS +BENCHMARKS=$(only_real_benchmarks) +echo "Using benchmark suites [$BENCHMARKS]" + +has_benchmark () { + for i in $BENCHMARKS_ORIG + do + if test "$i" = "$1" + then + echo "$i" + break + fi + done +} + if test "$USE_STACK" = "1" then WHICH_COMMAND="stack exec which" BUILD_CHART_EXE="stack build --flag streamly:dev" GET_BENCH_PROG=stack_bench_prog - BUILD_BENCH="stack build $STACK_BUILD_FLAGS --flags "streamly:benchmark" --bench --no-run-benchmarks" + BUILD_BENCH="stack build $STACK_BUILD_FLAGS --bench --no-run-benchmarks" else # XXX cabal issue "cabal v2-exec which" cannot find benchmark/test executables #WHICH_COMMAND="cabal v2-exec which" WHICH_COMMAND=cabal_which BUILD_CHART_EXE="cabal v2-build --flags dev chart" GET_BENCH_PROG=cabal_bench_prog - BUILD_BENCH="cabal v2-build $CABAL_BUILD_FLAGS --flag benchmark --enable-benchmarks" + BUILD_BENCH="cabal v2-build $CABAL_BUILD_FLAGS --enable-benchmarks" fi #----------------------------------------------------------------------------- @@ -326,7 +420,12 @@ if test "$MEASURE" = "1" then echo $BUILD_BENCH - $BUILD_BENCH || die "build failed" + if test "$USE_STACK" = "1" + then + $BUILD_BENCH || die "build failed" + else + $BUILD_BENCH $BENCHMARKS || die "build failed" + fi run_measurements "$BENCHMARKS" fi @@ -334,7 +433,18 @@ # Run reports #----------------------------------------------------------------------------- +VIRTUAL_REPORTS="" +if test "$(has_benchmark 'array-cmp')" = "array-cmp" +then + VIRTUAL_REPORTS="$VIRTUAL_REPORTS array-cmp" + mkdir -p "charts/array-cmp" + cat "charts/array/results.csv" \ + "charts/prim-array/results.csv" \ + "charts/unpinned-array/results.csv" > "charts/array-cmp/results.csv" +fi + if test "$RAW" = "0" then run_reports "$BENCHMARKS" + run_reports "$VIRTUAL_REPORTS" fi diff --git a/benchmark/BaseStreams.hs b/benchmark/BaseStreams.hs --- a/benchmark/BaseStreams.hs +++ b/benchmark/BaseStreams.hs @@ -7,7 +7,7 @@ {-# LANGUAGE CPP #-} -import Control.DeepSeq (NFData) +import Control.DeepSeq (NFData(..)) -- import Data.Functor.Identity (Identity, runIdentity) import System.Random (randomRIO) @@ -17,6 +17,10 @@ import qualified StreamDKOps as DK import qualified Data.List as List +#if !MIN_VERSION_deepseq(1,4,3) +instance NFData Ordering where rnf = (`seq` ()) +#endif + -- We need a monadic bind here to make sure that the function f does not get -- completely optimized out by the compiler in some cases. {-# INLINE benchIO #-} @@ -41,6 +45,7 @@ => String -> (t IO Int -> IO b) -> (Int -> t IO Int) -> Benchmark benchFold name f src = bench name $ nfIO $ randomRIO (1,1) >>= f . src +#ifdef DEVBUILD -- | Takes a source, and uses it with a default drain/fold method. {-# INLINE benchD #-} benchD :: String -> (Int -> D.Stream IO Int) -> Benchmark @@ -49,6 +54,7 @@ {-# INLINE benchK #-} benchK :: String -> (Int -> K.Stream IO Int) -> Benchmark benchK name f = bench name $ nfIO $ randomRIO (1,1) >>= K.toNull . f +#endif {- _benchId :: NFData b => String -> (Ops.Stream m Int -> Identity b) -> Benchmark @@ -75,10 +81,14 @@ [ benchIO "toNull" D.toNull D.sourceUnfoldrM , benchIO "mapM_" D.mapM_ D.sourceUnfoldrM , benchIO "uncons" D.uncons D.sourceUnfoldrM +#ifdef DEVBUILD + -- XXX these consume too much stack space, need to fix or segregate in + -- another benchmark. , benchFold "tail" D.tail D.sourceUnfoldrM , benchIO "nullTail" D.nullTail D.sourceUnfoldrM , benchIO "headTail" D.headTail D.sourceUnfoldrM , benchFold "toList" D.toList D.sourceUnfoldrM +#endif , benchFold "foldl'" D.foldl D.sourceUnfoldrM , benchFold "last" D.last D.sourceUnfoldrM ] @@ -186,6 +196,9 @@ , benchIO "filter-scan" (D.filterScan 4) D.sourceUnfoldrM , benchIO "filter-map" (D.filterMap 4) D.sourceUnfoldrM ] +#ifdef DEVBUILD + -- XXX these consume too much stack space, need to fix or segregate in + -- another benchmark. , bgroup "iterated" [ benchD "mapM" D.iterateMapM , benchD "scan(1/10)" D.iterateScan @@ -194,7 +207,10 @@ , benchD "dropOne" D.iterateDropOne , benchD "dropWhileFalse(1/10)" D.iterateDropWhileFalse , benchD "dropWhileTrue" D.iterateDropWhileTrue + , benchD "iterateM" D.iterateM + ] +#endif ] , bgroup "list" [ bgroup "elimination" @@ -226,10 +242,14 @@ , benchIO "mapM_" K.mapM_ K.sourceUnfoldrM , benchIO "uncons" K.uncons K.sourceUnfoldrM , benchFold "init" K.init K.sourceUnfoldrM +#ifdef DEVBUILD + -- XXX these consume too much stack space, need to fix or segregate in + -- another benchmark. , benchFold "tail" K.tail K.sourceUnfoldrM , benchIO "nullTail" K.nullTail K.sourceUnfoldrM , benchIO "headTail" K.headTail K.sourceUnfoldrM , benchFold "toList" K.toList K.sourceUnfoldrM +#endif , benchFold "foldl'" K.foldl K.sourceUnfoldrM , benchFold "last" K.last K.sourceUnfoldrM ] @@ -258,7 +278,10 @@ (K.sourceUnfoldrMN (K.value `div` 4)) , benchIO "intersperse" (K.intersperse 1) (K.sourceUnfoldrMN K.value2) , benchIO "interspersePure" (K.intersperse 1) (K.sourceUnfoldrN K.value2) +#ifdef DEVBUILD + -- XXX this consumes too much heap , benchIO "foldlS" (K.foldlS 1) K.sourceUnfoldrM +#endif ] , bgroup "transformationX4" [ benchIO "scan" (K.scan 4) K.sourceUnfoldrM @@ -330,6 +353,9 @@ , benchIO "filter-scan" (K.filterScan 4) K.sourceUnfoldrM , benchIO "filter-map" (K.filterMap 4) K.sourceUnfoldrM ] +#ifdef DEVBUILD + -- XXX these consume too much stack space, need to fix or segregate in + -- another benchmark. , bgroup "iterated" [ benchK "mapM" K.iterateMapM , benchK "scan(1/10)" K.iterateScan @@ -339,6 +365,7 @@ , benchK "dropWhileFalse(1/10)" K.iterateDropWhileFalse , benchK "dropWhileTrue" K.iterateDropWhileTrue ] +#endif ] , bgroup "streamDK" [ bgroup "generation" diff --git a/benchmark/Chart.hs b/benchmark/Chart.hs --- a/benchmark/Chart.hs +++ b/benchmark/Chart.hs @@ -7,6 +7,7 @@ import Control.Exception (handle, catch, SomeException, ErrorCall(..)) import Control.Monad.Trans.State import Control.Monad.Trans.Maybe +import Data.Char (toLower) import Data.Function (on, (&)) import Data.List import Data.List.Split @@ -27,10 +28,18 @@ | LinearAsync | LinearRate | Nested + | NestedConcurrent + | NestedUnfold | Base | FileIO | Array + | ArrayCmp + | UnpinnedArray + | SmallArray + | PrimArray | Concurrent + | Parallel + | Adaptive deriving Show data Options = Options @@ -69,10 +78,18 @@ Just "linear-async" -> setBenchType LinearAsync Just "linear-rate" -> setBenchType LinearRate Just "nested" -> setBenchType Nested + Just "nested-concurrent" -> setBenchType NestedConcurrent + Just "nested-unfold" -> setBenchType NestedUnfold Just "base" -> setBenchType Base Just "fileio" -> setBenchType FileIO + Just "array-cmp" -> setBenchType ArrayCmp Just "array" -> setBenchType Array + Just "unpinned-array" -> setBenchType UnpinnedArray + Just "small-array" -> setBenchType SmallArray + Just "prim-array" -> setBenchType PrimArray Just "concurrent" -> setBenchType Concurrent + Just "parallel" -> setBenchType Parallel + Just "adaptive" -> setBenchType Adaptive Just str -> do liftIO $ putStrLn $ "unrecognized benchmark type " <> str mzero @@ -243,15 +260,39 @@ makeFileIOGraphs cfg@Config{..} inputFile = ignoringErr $ graph inputFile "fileIO" cfg -makeArrayGraphs :: Config -> String -> IO () -makeArrayGraphs cfg@Config{..} inputFile = - ignoringErr $ graph inputFile "array" cfg +------------------------------------------------------------------------------ +-- Generic +------------------------------------------------------------------------------ -makeConcurrentGraphs :: Config -> String -> IO () -makeConcurrentGraphs cfg@Config{..} inputFile = - ignoringErr $ graph inputFile "concurrent" cfg +makeGraphs :: String -> Config -> String -> IO () +makeGraphs name cfg@Config{..} inputFile = + ignoringErr $ graph inputFile name cfg ------------------------------------------------------------------------------ +-- Arrays +------------------------------------------------------------------------------ + +showArrayComparisons Options{..} cfg inp out = + let cfg' = cfg { classifyBenchmark = classifyArray } + in if genGraphs + then ignoringErr $ graph inp "Arrays Comparison" + cfg' { outputDir = Just out + , presentation = Groups Absolute + } + else ignoringErr $ report inp Nothing cfg' + + where + + classifyArray b + -- SmallArray uses a small number of elements therefore cannot be + -- compared + -- | "SmallArray/" `isPrefixOf` b = ("SmallArray",) <$> stripPrefix "SmallArray/" b + | "Data.Prim.Array/" `isPrefixOf` b = ("Data.Prim.Array",) <$> stripPrefix "Data.Prim.Array/" b + | "Data.Array/" `isPrefixOf` b = ("Data.Array",) <$> stripPrefix "Data.Array/" b + | "array/" `isPrefixOf` b = ("array",) <$> stripPrefix "array/" b + | otherwise = Nothing + +------------------------------------------------------------------------------ -- Reports/Charts for base streams ------------------------------------------------------------------------------ @@ -322,6 +363,12 @@ let cfg = defaultConfig { presentation = Groups PercentDiff , selectBenchmarks = selectBench + , selectFields = filter + ( flip elem ["time" , "mean" + , "maxrss", "cputime" + ] + . map toLower + ) } res <- parseOptions @@ -332,23 +379,35 @@ Just opts@Options{..} -> case benchType of Linear -> benchShow opts cfg - { title = Just "100,000 elems" } + { title = Just "Linear" } makeLinearGraphs "charts/linear/results.csv" "charts/linear" LinearAsync -> benchShow opts cfg - { title = Just "Async 10,000 elems" } + { title = Just "Linear Async" } makeLinearAsyncGraphs "charts/linear-async/results.csv" "charts/linear-async" - LinearRate -> benchShow opts cfg makeLinearRateGraphs + LinearRate -> benchShow opts cfg + { title = Just "Linear Rate" } + makeLinearRateGraphs "charts/linear-rate/results.csv" "charts/linear-rate" Nested -> benchShow opts cfg - { title = Just "Nested loops 100 x 100 elems" } + { title = Just "Nested loops" } makeNestedGraphs "charts/nested/results.csv" "charts/nested" + NestedConcurrent -> benchShow opts cfg + { title = Just "Nested concurrent loops" } + makeNestedGraphs + "charts/nested-concurrent/results.csv" + "charts/nested-concurrent" + NestedUnfold -> benchShow opts cfg + { title = Just "Nested unfold loops" } + makeNestedGraphs + "charts/nested-unfold/results.csv" + "charts/nested-unfold" FileIO -> benchShow opts cfg { title = Just "File IO" } makeFileIOGraphs @@ -356,16 +415,45 @@ "charts/fileio" Array -> benchShow opts cfg { title = Just "Array" } - makeArrayGraphs + (makeGraphs "array") "charts/array/results.csv" "charts/array" + UnpinnedArray -> benchShow opts cfg + { title = Just "Unpinned Array" } + (makeGraphs "unpinned-array") + "charts/unpinned-array/results.csv" + "charts/unpinned-array" + SmallArray -> benchShow opts cfg + { title = Just "Small Array" } + (makeGraphs "small-array") + "charts/small-array/results.csv" + "charts/small-array" + PrimArray -> benchShow opts cfg + { title = Just "Prim Array" } + (makeGraphs "prim-array") + "charts/prim-array/results.csv" + "charts/prim-array" + ArrayCmp -> showArrayComparisons opts cfg + { title = Just "Arrays Comparison" } + "charts/array-cmp/results.csv" + "charts/array-cmp" Concurrent -> benchShow opts cfg { title = Just "Concurrent Ops" } - makeConcurrentGraphs + (makeGraphs "Concurrent") "charts/concurrent/results.csv" "charts/concurrent" + Parallel -> benchShow opts cfg + { title = Just "Parallel" } + (makeGraphs "parallel") + "charts/parallel/results.csv" + "charts/parallel" + Adaptive -> benchShow opts cfg + { title = Just "Adaptive" } + (makeGraphs "adaptive") + "charts/adaptive/results.csv" + "charts/adaptive" Base -> do - let cfg' = cfg { title = Just "100,000 elems" } + let cfg' = cfg { title = Just "Base stream" } if groupDiff then showStreamDVsK opts cfg' "charts/base/results.csv" diff --git a/benchmark/Common.hs b/benchmark/Common.hs new file mode 100644 --- /dev/null +++ b/benchmark/Common.hs @@ -0,0 +1,95 @@ +-- | +-- Module : Main +-- Copyright : (c) 2019 Composewell Technologies +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com + +module Common (parseCLIOpts) where + +import Control.Exception (evaluate) +import Control.Monad (when) +import Data.List (scanl') +import Data.Maybe (catMaybes) +import System.Console.GetOpt + (OptDescr(..), ArgDescr(..), ArgOrder(..), getOpt') +import System.Environment (getArgs, lookupEnv, setEnv) +import Text.Read (readMaybe) + +import Gauge + +------------------------------------------------------------------------------- +-- Parse custom CLI options +------------------------------------------------------------------------------- + +data BenchOpts = StreamSize Int deriving Show + +getStreamSize :: String -> Int +getStreamSize size = + case (readMaybe size :: Maybe Int) of + Just x -> x + Nothing -> error "Stream size must be numeric" + +options :: [OptDescr BenchOpts] +options = + [ + Option [] ["stream-size"] (ReqArg getSize "COUNT") "Stream element count" + ] + + where + + getSize = StreamSize . getStreamSize + +deleteOptArgs + :: (Maybe String, Maybe String) -- (prev, yielded) + -> String + -> (Maybe String, Maybe String) +deleteOptArgs (Nothing, _) opt = + if opt == "--stream-size" + then (Just opt, Nothing) + else (Just opt, Just opt) + +deleteOptArgs (Just prev, _) opt = + if opt == "--stream-size" || prev == "--stream-size" + then (Just opt, Nothing) + else (Just opt, Just opt) + +parseCLIOpts :: Int -> IO (Int, Config, [String]) +parseCLIOpts defaultStreamSize = do + args <- getArgs + + -- Parse custom options + let (opts, _, _, errs) = getOpt' Permute options args + when (not $ null errs) $ error $ concat errs + (streamSize, args') <- + case opts of + StreamSize x : _ -> do + -- When using the gauge "--measure-with" option we need to make + -- sure that we pass the stream size to child process forked by + -- gauge. So we use this env var for that purpose. + setEnv "STREAM_SIZE" (show x) + -- Hack! remove the option and its argument from args + -- getOpt should have a way to return the unconsumed args in + -- correct order. + newArgs <- + evaluate + $ catMaybes + $ map snd + $ scanl' deleteOptArgs (Nothing, Nothing) args + return (x, newArgs) + _ -> do + r <- lookupEnv "STREAM_SIZE" + case r of + Just x -> do + s <- evaluate $ getStreamSize x + return (s, args) + Nothing -> return (defaultStreamSize, args) + + -- Parse gauge options + let config = defaultConfig + { timeLimit = Just 1 + , minDuration = 0 + , includeFirstIter = streamSize > defaultStreamSize + } + let (cfg, benches) = parseWith config args' + streamSize `seq` return (streamSize, cfg, benches) diff --git a/benchmark/Concurrent.hs b/benchmark/Concurrent.hs --- a/benchmark/Concurrent.hs +++ b/benchmark/Concurrent.hs @@ -7,8 +7,7 @@ -- Maintainer : streamly@composewell.com import Control.Concurrent -import Control.Monad (when) --- import Data.IORef +import Control.Monad (when, replicateM) import Gauge import Streamly @@ -18,7 +17,10 @@ -- Append ------------------------------------------------------------------------------- --- Single work item yielded per thread +-- | Run @tcount@ number of actions concurrently using the given concurrency +-- style. Each thread produces a single output after a delay of @d@ +-- microseconds. +-- {-# INLINE append #-} append :: IsStream t => Int -> Int -> Int -> (t IO Int -> SerialT IO Int) -> IO () @@ -30,11 +32,22 @@ $ maxThreads (-1) $ S.fromFoldableM $ map work [1..tcount] --- Big stream of items yielded per thread +-- | Run @threads@ concurrently, each producing streams of @elems@ elements +-- with a delay of @d@ microseconds between successive elements, and merge +-- their outputs in a single output stream. The individual streams are produced +-- serially but merged using the provided concurrency style. +-- {-# INLINE concated #-} -concated :: Int -> Int -> Int -> Int -> (forall a. SerialT IO a -> SerialT IO a -> SerialT IO a) -> IO () +concated + :: Int + -> Int + -> Int + -> Int + -> (forall a. SerialT IO a -> SerialT IO a -> SerialT IO a) + -> IO () concated buflen threads d elems t = - let work = (\i -> (S.replicateM i ((when (d /= 0) (threadDelay d)) >> return i))) + let work = \i -> S.replicateM i + ((when (d /= 0) (threadDelay d)) >> return i) in S.drain $ adapt $ maxThreads (-1) @@ -72,25 +85,19 @@ [ -- bgroup "append/buf-1-threads-10k-0sec" (appendGroup 1 10000 0) -- , bgroup "append/buf-100-threads-100k-0sec" (appendGroup 100 100000 0) - bgroup "append/buf-10k-threads-10k-5sec" (appendGroup 10000 10000 5000000) + bgroup "stream1x10k/buf10k-threads10k-5sec" (appendGroup 10000 10000 5000000) -- bgroup "concat/buf-1-threads-100k-count-1" (concatGroup 1 100000 0 1) -- bgroup "concat/buf-1-threads-1-count-10m" (concatGroup 1 1 0 10000000) - , bgroup "concat/buf-100-threads-100-count-500k" (concatGroup 100 100 0 500000) - {- - , bgroup "forkIO-5000ms-10k" $ - let delay = threadDelay 5000000 - count = 10000 :: Int - list = [1..count] - work i = delay >> return i - in - [ bench "discard" $ nfIO $ do - mapM_ (\i -> forkIO $ work i >> return ()) list - threadDelay 6000000 - , bench "collect" $ nfIO $ do - ref <- newIORef [] - mapM_ (\i -> forkIO $ work i >>= - \j -> atomicModifyIORef ref $ \xs -> (j : xs, ())) list - threadDelay 6000000 - ] - -} + , bgroup "streams100x500k/buf100-threads100" (concatGroup 100 100 0 500000) + + , bench "forkIO/threads10k-5sec" $ + let delay = threadDelay 5000000 + count = 10000 :: Int + list = [1..count] + work i = delay >> return i + in nfIO $ do + ref <- newEmptyMVar + mapM_ (\i -> forkIO $ work i >>= + \j -> putMVar ref j) list + replicateM 10000 (takeMVar ref) ] diff --git a/benchmark/FileIO.hs b/benchmark/FileIO.hs --- a/benchmark/FileIO.hs +++ b/benchmark/FileIO.hs @@ -30,6 +30,9 @@ blockSize = 32768 blockCount = 3200 +fileSize :: Int +fileSize = blockSize * blockCount + #ifdef DEVBUILD -- This is a 500MB text file for text processing benchmarks. We cannot -- have it in the repo, therefore we use it locally with DEVBUILD @@ -38,9 +41,6 @@ infile :: String infile = "benchmark/text-processing/gutenberg-500.txt" -fileSize :: Int -fileSize = blockSize * blockCount - #else infile :: String infile = scratchDir ++ "in-100MB.txt" @@ -91,9 +91,15 @@ , mkBench "catBracket" href $ do Handles inh _ <- readIORef href BFA.catBracket devNull inh + , mkBench "catBracketIO" href $ do + Handles inh _ <- readIORef href + BFA.catBracketIO devNull inh , mkBench "catBracketStream" href $ do Handles inh _ <- readIORef href BFA.catBracketStream devNull inh + , mkBench "catBracketStreamIO" href $ do + Handles inh _ <- readIORef href + BFA.catBracketStreamIO devNull inh , mkBench "catOnException" href $ do Handles inh _ <- readIORef href BFA.catOnException devNull inh @@ -142,15 +148,27 @@ , mkBench "catFinally" href $ do Handles inh _ <- readIORef href BFS.catFinally devNull inh + , mkBench "catFinallyIO" href $ do + Handles inh _ <- readIORef href + BFS.catFinallyIO devNull inh , mkBench "catFinallyStream" href $ do Handles inh _ <- readIORef href BFS.catFinallyStream devNull inh + , mkBench "catFinallyStreamIO" href $ do + Handles inh _ <- readIORef href + BFS.catFinallyStreamIO devNull inh , mkBench "catBracketStream" href $ do Handles inh _ <- readIORef href BFS.catBracketStream devNull inh + , mkBench "catBracketStreamIO" href $ do + Handles inh _ <- readIORef href + BFS.catBracketStreamIO devNull inh , mkBench "catBracket" href $ do Handles inh _ <- readIORef href BFS.catBracket devNull inh + , mkBench "catBracketIO" href $ do + Handles inh _ <- readIORef href + BFS.catBracketIO devNull inh #endif , mkBench "read-word8" href $ do Handles inh _ <- readIORef href @@ -186,21 +204,26 @@ Handles inh outh <- readIORef href BFS.copyCodecUtf8Lenient inh outh ] - , bgroup "grouping" - [ mkBench "chunksOf (single chunk)" href $ do +#endif + , bgroup "grouping-chunks" + [ mkBench "sumChunksOf (single chunk)" href $ do Handles inh _ <- readIORef href - BFS.chunksOf fileSize inh + BFS.chunksOfSum fileSize inh + , mkBench "sumChunksOf 1" href $ do + Handles inh _ <- readIORef href + BFS.chunksOfSum 1 inh - , mkBench "chunksOf 1" href $ do + , mkBench "arraysOf 1" href $ do Handles inh _ <- readIORef href BFS.chunksOf 1 inh - , mkBench "chunksOf 10" href $ do + , mkBench "arraysOf 10" href $ do Handles inh _ <- readIORef href BFS.chunksOf 10 inh - , mkBench "chunksOf 1000" href $ do + , mkBench "arraysOf 1000" href $ do Handles inh _ <- readIORef href BFS.chunksOf 1000 inh ] +#ifdef DEVBUILD , bgroup "group-ungroup-stream" [ mkBench "lines-unlines-[Char]" href $ do Handles inh outh <- readIORef href diff --git a/benchmark/Linear.hs b/benchmark/Linear.hs --- a/benchmark/Linear.hs +++ b/benchmark/Linear.hs @@ -11,10 +11,13 @@ -- Maintainer : streamly@composewell.com import Control.DeepSeq (NFData(..), deepseq) +import Control.Monad (when) import Data.Functor.Identity (Identity, runIdentity) -import System.Random (randomRIO) import Data.Monoid (Last(..)) +import System.Random (randomRIO) +import Common (parseCLIOpts) + import qualified GHC.Exts as GHC import qualified Streamly.Benchmark.Prelude as Ops @@ -24,6 +27,8 @@ import qualified Streamly.Prelude as S import qualified Streamly.Internal.Data.Sink as Sink +import Streamly.Internal.Data.Time.Units +import qualified Streamly.Internal.Memory.Array as IA import qualified Streamly.Internal.Data.Fold as IFL import qualified Streamly.Internal.Prelude as IP import qualified Streamly.Internal.Data.Pipe as Pipe @@ -45,15 +50,15 @@ {-# 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 + => Int -> String -> (t IO Int -> IO b) -> Benchmark +benchIOSink value name f = bench name $ nfIO $ randomRIO (1,1) >>= f . Ops.source value {-# INLINE benchHoistSink #-} benchHoistSink :: (IsStream t, NFData b) - => String -> (t Identity Int -> IO b) -> Benchmark -benchHoistSink name f = - bench name $ nfIO $ randomRIO (1,1) >>= f . Ops.sourceUnfoldr + => Int -> String -> (t Identity Int -> IO b) -> Benchmark +benchHoistSink value name f = + bench name $ nfIO $ randomRIO (1,1) >>= f . Ops.sourceUnfoldr value -- XXX once we convert all the functions to use this we can rename this to -- benchIOSink @@ -66,8 +71,8 @@ {-# INLINE benchIdentitySink #-} benchIdentitySink :: (IsStream t, NFData b) - => String -> (t Identity Int -> Identity b) -> Benchmark -benchIdentitySink name f = bench name $ nf (f . Ops.sourceUnfoldr) 1 + => Int -> String -> (t Identity Int -> Identity b) -> Benchmark +benchIdentitySink value name f = bench name $ nf (f . Ops.sourceUnfoldr value) 1 -- | Takes a source, and uses it with a default drain/fold method. {-# INLINE benchIOSrc #-} @@ -88,8 +93,8 @@ 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 +benchPureSink :: NFData b => Int -> String -> (SerialT Identity Int -> b) -> Benchmark +benchPureSink value name f = benchPure name (Ops.sourceUnfoldr value) f -- XXX once we convert all the functions to use this we can rename this to -- benchPureSink @@ -101,343 +106,470 @@ {-# INLINE benchPureSinkIO #-} benchPureSinkIO :: NFData b - => String -> (SerialT Identity Int -> IO b) -> Benchmark -benchPureSinkIO name f = - bench name $ nfIO $ randomRIO (1, 1) >>= f . Ops.sourceUnfoldr + => Int -> String -> (SerialT Identity Int -> IO b) -> Benchmark +benchPureSinkIO value name f = + bench name $ nfIO $ randomRIO (1, 1) >>= f . Ops.sourceUnfoldr value {-# INLINE benchPureSrc #-} benchPureSrc :: String -> (Int -> SerialT Identity a) -> Benchmark benchPureSrc name src = benchPure name src (runIdentity . S.drain) -mkString :: String -mkString = "fromList [1" ++ concat (replicate Ops.value ",1") ++ "]" +mkString :: Int -> String +mkString value = "fromList [1" ++ concat (replicate value ",1") ++ "]" -mkListString :: String -mkListString = "[1" ++ concat (replicate Ops.value ",1") ++ "]" +mkListString :: Int -> String +mkListString value = "[1" ++ concat (replicate value ",1") ++ "]" -mkList :: [Int] -mkList = [1..Ops.value] +mkList :: Int -> [Int] +mkList value = [1..value] +defaultStreamSize :: Int +defaultStreamSize = 100000 + main :: IO () -main = - defaultMain +main = do + -- XXX Fix indentation + (value, cfg, benches) <- parseCLIOpts defaultStreamSize + let bufValue = min value defaultStreamSize + when (bufValue /= value) $ + putStrLn $ "Limiting stream size to " + ++ show defaultStreamSize + ++ " for buffered operations" + + bufValue `seq` value `seq` runMode (mode cfg) cfg benches [ bgroup "serially" [ bgroup "pure" - [ benchPureSink "id" id - , benchPureSink1 "eqBy" Ops.eqByPure - , benchPureSink "==" Ops.eqInstance - , benchPureSink "/=" Ops.eqInstanceNotEq - , benchPureSink1 "cmpBy" Ops.cmpByPure - , benchPureSink "<" Ops.ordInstance - , benchPureSink "min" Ops.ordInstanceMin - , benchPureSrc "IsList.fromList" Ops.sourceIsList + [ benchPureSink value "id" id + , benchPureSink1 "eqBy" (Ops.eqByPure value) + , benchPureSink value "==" Ops.eqInstance + , benchPureSink value "/=" Ops.eqInstanceNotEq + , benchPureSink1 "cmpBy" (Ops.cmpByPure value) + , benchPureSink value "<" Ops.ordInstance + , benchPureSink value "min" Ops.ordInstanceMin + , benchPureSrc "IsList.fromList" (Ops.sourceIsList value) -- length is used to check for foldr/build fusion - , benchPureSink "length . IsList.toList" (length . GHC.toList) - , benchPureSrc "IsString.fromString" Ops.sourceIsString - , mkString `deepseq` (bench "readsPrec pure streams" $ - nf Ops.readInstance mkString) - , mkString `deepseq` (bench "readsPrec Haskell lists" $ - nf Ops.readInstanceList mkListString) - , benchPureSink "showsPrec pure streams" Ops.showInstance - , mkList `deepseq` (bench "showPrec Haskell lists" $ - nf Ops.showInstanceList mkList) - , benchPureSink "foldl'" Ops.pureFoldl' - , benchPureSink "foldable/foldl'" Ops.foldableFoldl' - , benchPureSink "foldable/sum" Ops.foldableSum - , benchPureSinkIO "traversable/mapM" Ops.traversableMapM + , benchPureSink value "length . IsList.toList" (length . GHC.toList) + , benchPureSrc "IsString.fromString" (Ops.sourceIsString value) + , benchPureSink value "showsPrec pure streams" Ops.showInstance + , benchPureSink value "foldl'" Ops.pureFoldl' ] + , bgroup "foldable" + [ -- Foldable instance + -- type class operations + bench "foldl'" $ nf (Ops.foldableFoldl' value) 1 + , bench "foldrElem" $ nf (Ops.foldableFoldrElem value) 1 + -- , bench "null" $ nf (Ops.foldableNull value) 1 + , bench "elem" $ nf (Ops.foldableElem value) 1 + , bench "length" $ nf (Ops.foldableLength value) 1 + , bench "sum" $ nf (Ops.foldableSum value) 1 + , bench "product" $ nf (Ops.foldableProduct value) 1 + , bench "minimum" $ nf (Ops.foldableMin value) 1 + , bench "maximum" $ nf (Ops.foldableMax value) 1 + , bench "length . toList" $ + nf (length . Ops.foldableToList value) 1 + + -- folds + , bench "notElem" $ nf (Ops.foldableNotElem value) 1 + , bench "find" $ nf (Ops.foldableFind value) 1 + , bench "all" $ nf (Ops.foldableAll value) 1 + , bench "any" $ nf (Ops.foldableAny value) 1 + , bench "and" $ nf (Ops.foldableAnd value) 1 + , bench "or" $ nf (Ops.foldableOr value) 1 + + -- Note: minimumBy/maximumBy do not work in constant memory they are in + -- the O(n) group of benchmarks down below in this file. + + -- Applicative and Traversable operations + -- TBD: traverse_ + , benchIOSink1 "mapM_" (Ops.foldableMapM_ value) + -- TBD: for_ + -- TBD: forM_ + , benchIOSink1 "sequence_" (Ops.foldableSequence_ value) + -- TBD: sequenceA_ + -- TBD: asum + -- , benchIOSink1 "msum" (Ops.foldableMsum value) + ] , bgroup "generation" [ -- Most basic, barely stream continuations running - benchIOSrc serially "unfoldr" Ops.sourceUnfoldr - , 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 + benchIOSrc serially "unfoldr" (Ops.sourceUnfoldr value) + , benchIOSrc serially "unfoldrM" (Ops.sourceUnfoldrM value) + , benchIOSrc serially "intFromTo" (Ops.sourceIntFromTo value) + , benchIOSrc serially "intFromThenTo" (Ops.sourceIntFromThenTo value) + , benchIOSrc serially "integerFromStep" (Ops.sourceIntegerFromStep value) + , benchIOSrc serially "fracFromThenTo" (Ops.sourceFracFromThenTo value) + , benchIOSrc serially "fracFromTo" (Ops.sourceFracFromTo value) + , benchIOSrc serially "fromList" (Ops.sourceFromList value) + , benchIOSrc serially "fromListM" (Ops.sourceFromListM value) -- These are essentially cons and consM - , benchIOSrc serially "fromFoldable" Ops.sourceFromFoldable - , benchIOSrc serially "fromFoldableM" Ops.sourceFromFoldableM + , benchIOSrc serially "fromFoldable" (Ops.sourceFromFoldable value) + , benchIOSrc serially "fromFoldableM" (Ops.sourceFromFoldableM value) + , benchIOSrc serially "currentTime/0.00001s" + $ Ops.currentTime value 0.00001 ] , bgroup "elimination" [ bgroup "reduce" [ bgroup "IO" - [ benchIOSink "foldrM" Ops.foldrMReduce - , benchIOSink "foldl'" Ops.foldl'Reduce - , benchIOSink "foldl1'" Ops.foldl1'Reduce - , benchIOSink "foldlM'" Ops.foldlM'Reduce + [ + benchIOSink value "foldl'" Ops.foldl'Reduce + , benchIOSink value "foldl1'" Ops.foldl1'Reduce + , benchIOSink value "foldlM'" Ops.foldlM'Reduce ] , bgroup "Identity" - [ benchIdentitySink "foldrM" Ops.foldrMReduce - , benchIdentitySink "foldl'" Ops.foldl'Reduce - , benchIdentitySink "foldl1'" Ops.foldl1'Reduce - , benchIdentitySink "foldlM'" Ops.foldlM'Reduce + [ + benchIdentitySink value "foldl'" Ops.foldl'Reduce + , benchIdentitySink value "foldl1'" Ops.foldl1'Reduce + , benchIdentitySink value "foldlM'" Ops.foldlM'Reduce ] ] , bgroup "build" - [ bgroup "IO" - [ benchIOSink "foldrM" Ops.foldrMBuild - , benchIOSink "foldl'" Ops.foldl'Build - , benchIOSink "foldlM'" Ops.foldlM'Build - ] - , bgroup "Identity" - [ benchIdentitySink "foldrM" Ops.foldrMBuild - , benchIdentitySink "foldl'" Ops.foldl'Build - , benchIdentitySink "foldlM'" Ops.foldlM'Build + [ bgroup "Identity" + [ benchIdentitySink value "foldrM" Ops.foldrMBuild ] ] - , benchIOSink "uncons" Ops.uncons - , benchIOSink "toNull" $ Ops.toNull serially - , benchIOSink "mapM_" Ops.mapM_ + , benchIOSink value "uncons" Ops.uncons + , benchIOSink value "toNull" $ Ops.toNull serially + , benchIOSink value "mapM_" Ops.mapM_ - , benchIOSink "init" Ops.init - , benchIOSink "tail" Ops.tail - , benchIOSink "nullHeadTail" Ops.nullHeadTail + , benchIOSink value "init" Ops.init -- this is too low and causes all benchmarks reported in ns - -- , benchIOSink "head" Ops.head - , benchIOSink "last" Ops.last - -- , benchIOSink "lookup" Ops.lookup - , benchIOSink "find" Ops.find - , benchIOSink "findIndex" Ops.findIndex - , benchIOSink "elemIndex" Ops.elemIndex + -- , benchIOSink value "head" Ops.head + , benchIOSink value "last" Ops.last + -- , benchIOSink value "lookup" Ops.lookup + , benchIOSink value "find" (Ops.find value) + , benchIOSink value "findIndex" (Ops.findIndex value) + , benchIOSink value "elemIndex" (Ops.elemIndex value) -- this is too low and causes all benchmarks reported in ns - -- , benchIOSink "null" Ops.null - , 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 value "null" Ops.null + , benchIOSink value "elem" (Ops.elem value) + , benchIOSink value "notElem" (Ops.notElem value) + , benchIOSink value "all" (Ops.all value) + , benchIOSink value "any" (Ops.any value) + , benchIOSink value "and" (Ops.and value) + , benchIOSink value "or" (Ops.or value) - , benchIOSink "length" Ops.length - , benchHoistSink "length . generally" (Ops.length . IP.generally) - , benchIOSink "sum" Ops.sum - , benchIOSink "product" Ops.product + , benchIOSink value "length" Ops.length + , benchHoistSink value "length . generally" (Ops.length . IP.generally) + , benchIOSink value "sum" Ops.sum + , benchIOSink value "product" Ops.product - , benchIOSink "maximumBy" Ops.maximumBy - , benchIOSink "maximum" Ops.maximum - , benchIOSink "minimumBy" Ops.minimumBy - , benchIOSink "minimum" Ops.minimum + , benchIOSink value "maximumBy" Ops.maximumBy + , benchIOSink value "maximum" Ops.maximum + , benchIOSink value "minimumBy" Ops.minimumBy + , benchIOSink value "minimum" Ops.minimum - , benchIOSink "toList" Ops.toList - , benchIOSink "toListRev" Ops.toListRev ] , bgroup "folds" - [ benchIOSink "drain" (S.fold FL.drain) - , benchIOSink "sink" (S.fold $ Sink.toFold Sink.drain) - , benchIOSink "last" (S.fold FL.last) - , benchIOSink "length" (S.fold FL.length) - , benchIOSink "sum" (S.fold FL.sum) - , benchIOSink "product" (S.fold FL.product) - , benchIOSink "maximumBy" (S.fold (FL.maximumBy compare)) - , benchIOSink "maximum" (S.fold FL.maximum) - , benchIOSink "minimumBy" (S.fold (FL.minimumBy compare)) - , benchIOSink "minimum" (S.fold FL.minimum) - , benchIOSink "mean" (\s -> S.fold FL.mean (S.map (fromIntegral :: Int -> Double) s)) - , benchIOSink "variance" (\s -> S.fold FL.variance (S.map (fromIntegral :: Int -> Double) s)) - , benchIOSink "stdDev" (\s -> S.fold FL.stdDev (S.map (fromIntegral :: Int -> Double) s)) - - , benchIOSink "mconcat" (S.fold FL.mconcat . (S.map (Last . Just))) - , benchIOSink "foldMap" (S.fold (FL.foldMap (Last . Just))) + [ benchIOSink value "drain" (S.fold FL.drain) + , benchIOSink value "drainN" (S.fold (IFL.drainN value)) + , benchIOSink value "drainWhileTrue" (S.fold (IFL.drainWhile $ (<=) (value + 1))) + , benchIOSink value "drainWhileFalse" (S.fold (IFL.drainWhile $ (>=) (value + 1))) + , benchIOSink value "sink" (S.fold $ Sink.toFold Sink.drain) + , benchIOSink value "last" (S.fold FL.last) + , benchIOSink value "lastN.1" (S.fold (IA.lastN 1)) + , benchIOSink value "lastN.10" (S.fold (IA.lastN 10)) + , benchIOSink value "length" (S.fold FL.length) + , benchIOSink value "sum" (S.fold FL.sum) + , benchIOSink value "product" (S.fold FL.product) + , benchIOSink value "maximumBy" (S.fold (FL.maximumBy compare)) + , benchIOSink value "maximum" (S.fold FL.maximum) + , benchIOSink value "minimumBy" (S.fold (FL.minimumBy compare)) + , benchIOSink value "minimum" (S.fold FL.minimum) + , benchIOSink value "mean" (\s -> S.fold FL.mean (S.map (fromIntegral :: Int -> Double) s)) + , benchIOSink value "variance" (\s -> S.fold FL.variance (S.map (fromIntegral :: Int -> Double) s)) + , benchIOSink value "stdDev" (\s -> S.fold FL.stdDev (S.map (fromIntegral :: Int -> Double) s)) - , benchIOSink "toList" (S.fold FL.toList) - , benchIOSink "toListRevF" (S.fold IFL.toListRevF) - , benchIOSink "toStream" (S.fold IP.toStream) - , benchIOSink "toStreamRev" (S.fold IP.toStreamRev) - , benchIOSink "writeN" (S.fold (A.writeN Ops.value)) + , benchIOSink value "mconcat" (S.fold FL.mconcat . (S.map (Last . Just))) + , benchIOSink value "foldMap" (S.fold (FL.foldMap (Last . Just))) - , benchIOSink "index" (S.fold (FL.index Ops.maxValue)) - , benchIOSink "head" (S.fold FL.head) - , benchIOSink "find" (S.fold (FL.find (== Ops.maxValue))) - , benchIOSink "findIndex" (S.fold (FL.findIndex (== Ops.maxValue))) - , benchIOSink "elemIndex" (S.fold (FL.elemIndex Ops.maxValue)) + , benchIOSink value "index" (S.fold (FL.index (value + 1))) + , benchIOSink value "head" (S.fold FL.head) + , benchIOSink value "find" (S.fold (FL.find (== (value + 1)))) + , benchIOSink value "findIndex" (S.fold (FL.findIndex (== (value + 1)))) + , benchIOSink value "elemIndex" (S.fold (FL.elemIndex (value + 1))) - , benchIOSink "null" (S.fold FL.null) - , benchIOSink "elem" (S.fold (FL.elem Ops.maxValue)) - , benchIOSink "notElem" (S.fold (FL.notElem Ops.maxValue)) - , benchIOSink "all" (S.fold (FL.all (<= Ops.maxValue))) - , benchIOSink "any" (S.fold (FL.any (> Ops.maxValue))) - , benchIOSink "and" (\s -> S.fold FL.and (S.map (<= Ops.maxValue) s)) - , benchIOSink "or" (\s -> S.fold FL.or (S.map (> Ops.maxValue) s)) + , benchIOSink value "null" (S.fold FL.null) + , benchIOSink value "elem" (S.fold (FL.elem (value + 1))) + , benchIOSink value "notElem" (S.fold (FL.notElem (value + 1))) + , benchIOSink value "all" (S.fold (FL.all (<= (value + 1)))) + , benchIOSink value "any" (S.fold (FL.any (> (value + 1)))) + , benchIOSink value "and" (\s -> S.fold FL.and (S.map (<= (value + 1)) s)) + , benchIOSink value "or" (\s -> S.fold FL.or (S.map (> (value + 1)) s)) ] , bgroup "fold-multi-stream" - [ benchIOSink1 "eqBy" Ops.eqBy - , benchIOSink1 "cmpBy" Ops.cmpBy - , benchIOSink "isPrefixOf" Ops.isPrefixOf - , benchIOSink "isSubsequenceOf" Ops.isSubsequenceOf - , benchIOSink "stripPrefix" Ops.stripPrefix + [ benchIOSink1 "eqBy" (Ops.eqBy value) + , benchIOSink1 "cmpBy" (Ops.cmpBy value) + , benchIOSink value "isPrefixOf" Ops.isPrefixOf + , benchIOSink value "isSubsequenceOf" Ops.isSubsequenceOf + , benchIOSink value "stripPrefix" Ops.stripPrefix ] , bgroup "folds-transforms" - [ benchIOSink "drain" (S.fold FL.drain) - , benchIOSink "lmap" (S.fold (IFL.lmap (+1) FL.drain)) - , benchIOSink "pipe-mapM" + [ benchIOSink value "drain" (S.fold FL.drain) + , benchIOSink value "lmap" (S.fold (IFL.lmap (+1) FL.drain)) + , benchIOSink value "pipe-mapM" (S.fold (IFL.transform (Pipe.mapM (\x -> return $ x + 1)) FL.drain)) ] , bgroup "folds-compositions" -- Applicative [ - benchIOSink "all,any" (S.fold ((,) <$> FL.all (<= Ops.maxValue) - <*> FL.any (> Ops.maxValue))) - , benchIOSink "sum,length" (S.fold ((,) <$> FL.sum <*> FL.length)) + benchIOSink value "all,any" (S.fold ((,) <$> FL.all (<= (value + 1)) + <*> FL.any (> (value + 1)))) + , benchIOSink value "sum,length" (S.fold ((,) <$> FL.sum <*> FL.length)) ] , bgroup "pipes" - [ benchIOSink "mapM" (Ops.transformMapM serially 1) - , benchIOSink "compose" (Ops.transformComposeMapM serially 1) - , benchIOSink "tee" (Ops.transformTeeMapM serially 1) - , benchIOSink "zip" (Ops.transformZipMapM serially 1) + [ benchIOSink value "mapM" (Ops.transformMapM serially 1) + , benchIOSink value "compose" (Ops.transformComposeMapM serially 1) + , benchIOSink value "tee" (Ops.transformTeeMapM serially 1) + , benchIOSink value "zip" (Ops.transformZipMapM serially 1) ] , bgroup "pipesX4" - [ benchIOSink "mapM" (Ops.transformMapM serially 4) - , benchIOSink "compose" (Ops.transformComposeMapM serially 4) - , benchIOSink "tee" (Ops.transformTeeMapM serially 4) - , benchIOSink "zip" (Ops.transformZipMapM serially 4) + [ benchIOSink value "mapM" (Ops.transformMapM serially 4) + , benchIOSink value "compose" (Ops.transformComposeMapM serially 4) + , benchIOSink value "tee" (Ops.transformTeeMapM serially 4) + , benchIOSink value "zip" (Ops.transformZipMapM serially 4) ] , bgroup "transformer" - [ benchIOSrc serially "evalState" Ops.evalStateT - , benchIOSrc serially "withState" Ops.withState + [ benchIOSrc serially "evalState" (Ops.evalStateT value) + , benchIOSrc serially "withState" (Ops.withState value) ] , bgroup "transformation" - [ benchIOSink "scanl" (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) + [ benchIOSink value "scanl" (Ops.scan 1) + , benchIOSink value "scanl1'" (Ops.scanl1' 1) + , benchIOSink value "map" (Ops.map 1) + , benchIOSink value "fmap" (Ops.fmap 1) + , benchIOSink value "mapM" (Ops.mapM serially 1) + , benchIOSink value "mapMaybe" (Ops.mapMaybe 1) + , benchIOSink value "mapMaybeM" (Ops.mapMaybeM 1) , bench "sequence" $ nfIO $ randomRIO (1,1000) >>= \n -> - Ops.sequence serially (Ops.sourceUnfoldrMAction n) - , benchIOSink "findIndices" (Ops.findIndices 1) - , benchIOSink "elemIndices" (Ops.elemIndices 1) - , benchIOSink "reverse" (Ops.reverse 1) - , benchIOSink "reverse'" (Ops.reverse' 1) - , benchIOSink "foldrS" (Ops.foldrS 1) - , benchIOSink "foldrSMap" (Ops.foldrSMap 1) - , benchIOSink "foldrT" (Ops.foldrT 1) - , benchIOSink "foldrTMap" (Ops.foldrTMap 1) + Ops.sequence serially (Ops.sourceUnfoldrMAction value n) + , benchIOSink value "findIndices" (Ops.findIndices value 1) + , benchIOSink value "elemIndices" (Ops.elemIndices value 1) + , benchIOSink value "foldrS" (Ops.foldrS 1) + , benchIOSink value "foldrSMap" (Ops.foldrSMap 1) + , benchIOSink value "foldrT" (Ops.foldrT 1) + , benchIOSink value "foldrTMap" (Ops.foldrTMap 1) + , benchIOSink value "tap" (Ops.tap 1) + , benchIOSink value "tapRate 1 second" (Ops.tapRate 1) + , benchIOSink value "pollCounts 1 second" (Ops.pollCounts 1) + , benchIOSink value "tapAsync" (Ops.tapAsync 1) + , benchIOSink value "tapAsyncS" (Ops.tapAsyncS 1) ] , bgroup "transformationX4" - [ benchIOSink "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) + [ benchIOSink value "scan" (Ops.scan 4) + , benchIOSink value "scanl1'" (Ops.scanl1' 4) + , benchIOSink value "map" (Ops.map 4) + , benchIOSink value "fmap" (Ops.fmap 4) + , benchIOSink value "mapM" (Ops.mapM serially 4) + , benchIOSink value "mapMaybe" (Ops.mapMaybe 4) + , benchIOSink value "mapMaybeM" (Ops.mapMaybeM 4) -- , bench "sequence" $ nfIO $ randomRIO (1,1000) >>= \n -> -- Ops.sequence serially (Ops.sourceUnfoldrMAction n) - , benchIOSink "findIndices" (Ops.findIndices 4) - , benchIOSink "elemIndices" (Ops.elemIndices 4) + , benchIOSink value "findIndices" (Ops.findIndices value 4) + , benchIOSink value "elemIndices" (Ops.elemIndices value 4) ] , bgroup "filtering" - [ 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 "intersperse" (Ops.intersperse 1) - , benchIOSink "insertBy" (Ops.insertBy 1) + [ benchIOSink value "filter-even" (Ops.filterEven 1) + , benchIOSink value "filter-all-out" (Ops.filterAllOut value 1) + , benchIOSink value "filter-all-in" (Ops.filterAllIn value 1) + + , benchIOSink value "take-all" (Ops.takeAll value 1) + , benchIOSink value "takeByTime-all" + (Ops.takeByTime (NanoSecond64 maxBound) 1) + , benchIOSink value "takeWhile-true" (Ops.takeWhileTrue value 1) + --, benchIOSink value "takeWhileM-true" (Ops.takeWhileMTrue 1) + + -- "drop-one" is dual to "last" + , benchIOSink value "drop-one" (Ops.dropOne 1) + , benchIOSink value "drop-all" (Ops.dropAll value 1) + , benchIOSink value "dropByTime-all" + (Ops.dropByTime (NanoSecond64 maxBound) 1) + , benchIOSink value "dropWhile-true" (Ops.dropWhileTrue value 1) + --, benchIOSink value "dropWhileM-true" (Ops.dropWhileMTrue 1) + , benchIOSink value "dropWhile-false" (Ops.dropWhileFalse value 1) + + , benchIOSink value "deleteBy" (Ops.deleteBy value 1) + , benchIOSink value "intersperse" (Ops.intersperse value 1) + , benchIOSink value "insertBy" (Ops.insertBy value 1) ] , bgroup "filteringX4" - [ benchIOSink "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 "intersperse" (Ops.intersperse 4) - , benchIOSink "insertBy" (Ops.insertBy 4) + [ benchIOSink value "filter-even" (Ops.filterEven 4) + , benchIOSink value "filter-all-out" (Ops.filterAllOut value 4) + , benchIOSink value "filter-all-in" (Ops.filterAllIn value 4) + , benchIOSink value "take-all" (Ops.takeAll value 4) + , benchIOSink value "takeWhile-true" (Ops.takeWhileTrue value 4) + --, benchIOSink value "takeWhileM-true" (Ops.takeWhileMTrue 4) + , benchIOSink value "drop-one" (Ops.dropOne 4) + , benchIOSink value "drop-all" (Ops.dropAll value 4) + , benchIOSink value "dropWhile-true" (Ops.dropWhileTrue value 4) + --, benchIOSink value "dropWhileM-true" (Ops.dropWhileMTrue 4) + , benchIOSink value "dropWhile-false" (Ops.dropWhileFalse value 4) + , benchIOSink value "deleteBy" (Ops.deleteBy value 4) + , benchIOSink value "intersperse" (Ops.intersperse value 4) + , benchIOSink value "insertBy" (Ops.insertBy value 4) ] , bgroup "joining" - [ benchIOSrc1 "zip (2x50K)" (Ops.zip 50000) - , benchIOSrc1 "zipM (2x50K)" (Ops.zipM 50000) - , benchIOSrc1 "mergeBy (2x50K)" (Ops.mergeBy 50000) - , benchIOSrc1 "serial (2x50K)" (Ops.serial2 50000) - , benchIOSrc1 "append (2x50K)" (Ops.append2 50000) - , benchIOSrc1 "serial (2x2x25K)" (Ops.serial4 25000) - , benchIOSrc1 "append (2x2x25K)" (Ops.append4 25000) - , benchIOSrc1 "wSerial (2x50K)" Ops.wSerial2 - , benchIOSrc1 "interleave (2x50K)" Ops.interleave2 - , benchIOSrc1 "roundRobin (2x50K)" Ops.roundRobin2 + [ benchIOSrc1 "zip (2,x/2)" (Ops.zip (value `div` 2)) + , benchIOSrc1 "zipM (2,x/2)" (Ops.zipM (value `div` 2)) + , benchIOSrc1 "mergeBy (2,x/2)" (Ops.mergeBy (value `div` 2)) + , benchIOSrc1 "serial (2,x/2)" (Ops.serial2 (value `div` 2)) + , benchIOSrc1 "append (2,x/2)" (Ops.append2 (value `div` 2)) + , benchIOSrc1 "serial (2,2,x/4)" (Ops.serial4 (value `div` 4)) + , benchIOSrc1 "append (2,2,x/4)" (Ops.append4 (value `div` 4)) + , benchIOSrc1 "wSerial (2,x/2)" (Ops.wSerial2 value) + , benchIOSrc1 "interleave (2,x/2)" (Ops.interleave2 value) + , benchIOSrc1 "roundRobin (2,x/2)" (Ops.roundRobin2 value) ] , bgroup "concat-foldable" - [ benchIOSrc serially "foldMapWith (1x100K)" Ops.sourceFoldMapWith - , benchIOSrc serially "foldMapWithM (1x100K)" Ops.sourceFoldMapWithM - , benchIOSrc serially "foldMapM (1x100K)" Ops.sourceFoldMapM - , benchIOSrc serially "foldWithConcatMapId (1x100K)" Ops.sourceConcatMapId + [ benchIOSrc serially "foldMapWith" (Ops.sourceFoldMapWith value) + , benchIOSrc serially "foldMapWithM" (Ops.sourceFoldMapWithM value) + , benchIOSrc serially "foldMapM" (Ops.sourceFoldMapM value) + , benchIOSrc serially "foldWithConcatMapId" (Ops.sourceConcatMapId value) ] , bgroup "concat-serial" - [ benchIOSrc1 "concatMapPure (2x50K)" (Ops.concatMapPure 2 50000) - , benchIOSrc1 "concatMap (2x50K)" (Ops.concatMap 2 50000) - , benchIOSrc1 "concatMap (50Kx2)" (Ops.concatMap 50000 2) - , benchIOSrc1 "concatMapRepl (25Kx4)" Ops.concatMapRepl4xN - , benchIOSrc1 "concatUnfoldRepl (25Kx4)" Ops.concatUnfoldRepl4xN + [ benchIOSrc1 "concatMapPure (2,x/2)" (Ops.concatMapPure 2 (value `div` 2)) + , benchIOSrc1 "concatMap (2,x/2)" (Ops.concatMap 2 (value `div` 2)) + , benchIOSrc1 "concatMap (x/2,2)" (Ops.concatMap (value `div` 2) 2) + , benchIOSrc1 "concatMapRepl (x/4,4)" (Ops.concatMapRepl4xN value) + , benchIOSrc1 "concatUnfoldRepl (x/4,4)" (Ops.concatUnfoldRepl4xN value) - , benchIOSrc1 "concatMapWithSerial (2x50K)" - (Ops.concatMapWithSerial 2 50000) - , benchIOSrc1 "concatMapWithSerial (50Kx2)" - (Ops.concatMapWithSerial 50000 2) + , benchIOSrc1 "concatMapWithSerial (2,x/2)" + (Ops.concatMapWithSerial 2 (value `div` 2)) + , benchIOSrc1 "concatMapWithSerial (x/2,2)" + (Ops.concatMapWithSerial (value `div` 2) 2) - , benchIOSrc1 "concatMapWithAppend (2x50K)" - (Ops.concatMapWithAppend 2 50000) + , benchIOSrc1 "concatMapWithAppend (2,x/2)" + (Ops.concatMapWithAppend 2 (value `div` 2)) ] , bgroup "concat-interleave" - [ benchIOSrc1 "concatMapWithWSerial (2x50K)" - (Ops.concatMapWithWSerial 2 50000) - , benchIOSrc1 "concatMapWithWSerial (50Kx2)" - (Ops.concatMapWithWSerial 50000 2) - , benchIOSrc1 "concatUnfoldInterleaveRepl (25Kx4)" - Ops.concatUnfoldInterleaveRepl4xN - , benchIOSrc1 "concatUnfoldRoundrobinRepl (25Kx4)" - Ops.concatUnfoldRoundrobinRepl4xN + [ benchIOSrc1 "concatMapWithWSerial (2,x/2)" + (Ops.concatMapWithWSerial 2 (value `div` 2)) + , benchIOSrc1 "concatMapWithWSerial (x/2,2)" + (Ops.concatMapWithWSerial (value `div` 2) 2) ] -- scanl-map and foldl-map are equivalent to the scan and fold in the foldl -- library. If scan/fold followed by a map is efficient enough we may not -- need monolithic implementations of these. , bgroup "mixed" - [ benchIOSink "scanl-map" (Ops.scanMap 1) - , benchIOSink "foldl-map" Ops.foldl'ReduceMap - , benchIOSink "sum-product-fold" Ops.sumProductFold - , benchIOSink "sum-product-scan" Ops.sumProductScan + [ benchIOSink value "scanl-map" (Ops.scanMap 1) + , benchIOSink value "foldl-map" Ops.foldl'ReduceMap + , benchIOSink value "sum-product-fold" Ops.sumProductFold + , benchIOSink value "sum-product-scan" Ops.sumProductScan ] , bgroup "mixedX4" - [ benchIOSink "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) + [ benchIOSink value "scan-map" (Ops.scanMap 4) + , benchIOSink value "drop-map" (Ops.dropMap 4) + , benchIOSink value "drop-scan" (Ops.dropScan 4) + , benchIOSink value "take-drop" (Ops.takeDrop value 4) + , benchIOSink value "take-scan" (Ops.takeScan value 4) + , benchIOSink value "take-map" (Ops.takeMap value 4) + , benchIOSink value "filter-drop" (Ops.filterDrop value 4) + , benchIOSink value "filter-take" (Ops.filterTake value 4) + , benchIOSink value "filter-scan" (Ops.filterScan 4) + , benchIOSink value "filter-scanl1" (Ops.filterScanl1 4) + , benchIOSink value "filter-map" (Ops.filterMap value 4) ] + ] + , bgroup "wSerially" + [ bgroup "transformation" + [ benchIOSink value "fmap" $ Ops.fmap' wSerially 1 + ] + ] + , bgroup "zipSerially" + [ bgroup "transformation" + [ benchIOSink value "fmap" $ Ops.fmap' zipSerially 1 + ] + ] + -- Non-streaming operations. We keep these in a spearate group so that we + -- can run these conveniently with smaller stream size. + -- + -- These are also the operations that programmers should be aware of and + -- should avoid using in a streaming application. + + -- XXX stack dominant (upto 1M), segregate? , bgroup "iterated" [ benchIOSrc serially "mapM" Ops.iterateMapM , benchIOSrc serially "scan(1/100)" Ops.iterateScan , benchIOSrc serially "scanl1(1/100)" Ops.iterateScanl1 , benchIOSrc serially "filterEven" Ops.iterateFilterEven - , benchIOSrc serially "takeAll" Ops.iterateTakeAll + , benchIOSrc serially "takeAll" (Ops.iterateTakeAll value) , benchIOSrc serially "dropOne" Ops.iterateDropOne - , benchIOSrc serially "dropWhileFalse" Ops.iterateDropWhileFalse - , benchIOSrc serially "dropWhileTrue" Ops.iterateDropWhileTrue + , benchIOSrc serially "dropWhileFalse" (Ops.iterateDropWhileFalse value) + , benchIOSrc serially "dropWhileTrue" (Ops.iterateDropWhileTrue value) ] + , bgroup "buffered" + [ -- Inherently non-streaming operations + + -- Right folds for reducing are inherently non-streaming as the + -- expression needs to be fully built before it can be reduced. + -- XXX Stack dominant (up to 4MB), segregate? + benchIOSink bufValue "foldrM/reduce/IO" Ops.foldrMReduce + , benchIdentitySink bufValue "foldrM/reduce/Identity" Ops.foldrMReduce + + -- Left folds for building a structure are inherently non-streaming as + -- the structure cannot be lazily consumed until fully built. + , benchIOSink bufValue "foldl'/build/IO" Ops.foldl'Build + , benchIdentitySink bufValue "foldl'/build/Identity" Ops.foldl'Build + , benchIOSink bufValue "foldlM'/build/IO" Ops.foldlM'Build + , benchIdentitySink bufValue "foldlM'/build/Identity" Ops.foldlM'Build + + -- accumulation due to strictness of IO monad + -- XXX Stack dominant, segregate? + , benchIOSink bufValue "foldrM/build/IO" Ops.foldrMBuild + , benchPureSinkIO bufValue "traversable/mapM" Ops.traversableMapM + + -- Converting the stream to a list or pure stream + -- XXX Stack dominant, segregate? + , benchIOSink bufValue "toList" Ops.toList + , benchIOSink bufValue "toListRev" Ops.toListRev + + , benchIOSink bufValue "toStream" (S.fold IP.toStream) + , benchIOSink bufValue "toStreamRev" (S.fold IP.toStreamRev) + + , benchIOSink bufValue "folds/toList" (S.fold FL.toList) + , benchIOSink bufValue "folds/toListRevF" (S.fold IFL.toListRevF) + + -- Converting the stream to an array + , benchIOSink bufValue "folds/lastN.Max" (S.fold (IA.lastN (bufValue + 1))) + , benchIOSink bufValue "folds/writeN" (S.fold (A.writeN bufValue)) + + -- Reversing/sorting a stream + , benchIOSink bufValue "reverse" (Ops.reverse 1) + , benchIOSink bufValue "reverse'" (Ops.reverse' 1) + + -- XXX the definitions of minimumBy and maximumBy in Data.Foldable use + -- foldl1 which does not work in constant memory for our implementation. + -- It works in constant memory for lists but even for lists it takes 15x + -- more time compared to our foldl' based implementation. + , bench "minimumBy" $ nf (flip Ops.foldableMinBy 1) value + , bench "maximumBy" $ nf (flip Ops.foldableMaxBy 1) value + , bench "minimumByList" $ nf (flip Ops.foldableListMinBy 1) value + + -- XXX can these be streaming? Can we have special read/show style type + -- classes supporting streaming? + , mkString bufValue `deepseq` (bench "readsPrec pure streams" $ + nf Ops.readInstance (mkString bufValue)) + , mkString bufValue `deepseq` (bench "readsPrec Haskell lists" $ + nf Ops.readInstanceList (mkListString bufValue)) + , mkList bufValue `deepseq` (bench "showPrec Haskell lists" $ + nf Ops.showInstanceList (mkList bufValue)) + + -- XXX streaming operations that can potentially be fixed + + -- XXX These consume a lot of stack, fix or segregate + , benchIOSink bufValue "tail" Ops.tail + , benchIOSink bufValue "nullHeadTail" Ops.nullHeadTail + + , benchIOSrc1 "concatUnfoldInterleaveRepl (x/4,4)" + (Ops.concatUnfoldInterleaveRepl4xN bufValue) + , benchIOSrc1 "concatUnfoldRoundrobinRepl (x/4,4)" + (Ops.concatUnfoldRoundrobinRepl4xN bufValue) + ] + , bgroup "traversable" + [ -- Traversable instance + benchPureSinkIO bufValue "traverse" Ops.traversableTraverse + , benchPureSinkIO bufValue "sequenceA" Ops.traversableSequenceA + , benchPureSinkIO bufValue "mapM" Ops.traversableMapM + , benchPureSinkIO bufValue "sequence" Ops.traversableSequence ] ] diff --git a/benchmark/LinearAsync.hs b/benchmark/LinearAsync.hs --- a/benchmark/LinearAsync.hs +++ b/benchmark/LinearAsync.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} -- | -- Module : Main -- Copyright : (c) 2018 Harendra Kumar @@ -8,98 +9,139 @@ import Control.DeepSeq (NFData) -- import Data.Functor.Identity (Identity, runIdentity) import System.Random (randomRIO) -import qualified Streamly.Benchmark.Prelude as Ops +import Common (parseCLIOpts) + import Streamly import Gauge +import qualified Streamly.Benchmark.Prelude as Ops + -- We need a monadic bind here to make sure that the function f does not get -- completely optimized out by the compiler in some cases. -- -- | Takes a fold method, and uses it with a default source. {-# INLINE benchIO #-} -benchIO :: (IsStream t, NFData b) => String -> (t IO Int -> IO b) -> Benchmark -benchIO name f = bench name $ nfIO $ randomRIO (1,1) >>= f . Ops.source +benchIO :: (IsStream t, NFData b) => Int -> String -> (t IO Int -> IO b) -> Benchmark +benchIO value name f = bench name $ nfIO $ randomRIO (1,1) >>= f . Ops.source value -- | Takes a source, and uses it with a default drain/fold method. {-# INLINE benchSrcIO #-} benchSrcIO - :: (t IO Int -> SerialT IO Int) + :: (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 +{-# INLINE benchMonadicSrcIO #-} +benchMonadicSrcIO :: String -> (Int -> IO ()) -> Benchmark +benchMonadicSrcIO name f = bench name $ nfIO $ randomRIO (1,1) >>= f + {- _benchId :: NFData b => String -> (Ops.Stream m Int -> Identity b) -> Benchmark _benchId name f = bench name $ nf (runIdentity . f) (Ops.source 10) -} +defaultStreamSize :: Int +defaultStreamSize = 100000 + main :: IO () -main = - defaultMain +main = do + -- XXX Fix indentation + (value, cfg, benches) <- parseCLIOpts defaultStreamSize + let value2 = round $ sqrt $ (fromIntegral value :: Double) + value2 `seq` value `seq` runMode (mode cfg) cfg benches [ bgroup "asyncly" - [ benchSrcIO asyncly "unfoldr" Ops.sourceUnfoldr - , benchSrcIO asyncly "unfoldrM" Ops.sourceUnfoldrM - , benchSrcIO asyncly "fromFoldable" Ops.sourceFromFoldable - , benchSrcIO asyncly "fromFoldableM" Ops.sourceFromFoldableM - , benchSrcIO asyncly "foldMapWith" Ops.sourceFoldMapWith - , benchSrcIO asyncly "foldMapWithM" Ops.sourceFoldMapWithM - , 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 "unfoldr" (Ops.sourceUnfoldr value) + , benchSrcIO asyncly "unfoldrM" (Ops.sourceUnfoldrM value) + , benchSrcIO asyncly "fromFoldable" (Ops.sourceFromFoldable value) + , benchSrcIO asyncly "fromFoldableM" (Ops.sourceFromFoldableM value) + , benchSrcIO asyncly "foldMapWith" (Ops.sourceFoldMapWith value) + , benchSrcIO asyncly "foldMapWithM" (Ops.sourceFoldMapWithM value) + , benchSrcIO asyncly "foldMapM" (Ops.sourceFoldMapM value) + , benchIO value "map" $ Ops.map' asyncly 1 + , benchIO value "fmap" $ Ops.fmap' asyncly 1 + , benchIO value "mapM" $ Ops.mapM asyncly 1 , benchSrcIO asyncly "unfoldrM maxThreads 1" - (maxThreads 1 . Ops.sourceUnfoldrM) - , benchSrcIO asyncly "unfoldrM maxBuffer 1 (1000 ops)" - (maxBuffer 1 . Ops.sourceUnfoldrMN 1000) + (maxThreads 1 . Ops.sourceUnfoldrM value) + , benchSrcIO asyncly "unfoldrM maxBuffer 1 (x/10 ops)" + (maxBuffer 1 . Ops.sourceUnfoldrMN (value `div` 10)) + , benchMonadicSrcIO "concatMapWith (2,x/2)" + (Ops.concatStreamsWith async 2 (value `div` 2)) + , benchMonadicSrcIO "concatMapWith (sqrt x,sqrt x)" + (Ops.concatStreamsWith async value2 value2) + , benchMonadicSrcIO "concatMapWith (sqrt x * 2,sqrt x / 2)" + (Ops.concatStreamsWith async (value2 * 2) (value2 `div` 2)) ] , bgroup "wAsyncly" - [ benchSrcIO wAsyncly "unfoldr" Ops.sourceUnfoldr - , benchSrcIO wAsyncly "unfoldrM" Ops.sourceUnfoldrM - , benchSrcIO wAsyncly "fromFoldable" Ops.sourceFromFoldable - , benchSrcIO wAsyncly "fromFoldableM" Ops.sourceFromFoldableM - , benchSrcIO wAsyncly "foldMapWith" Ops.sourceFoldMapWith - , benchSrcIO wAsyncly "foldMapWithM" Ops.sourceFoldMapWithM - , benchSrcIO wAsyncly "foldMapM" Ops.sourceFoldMapM - , benchIO "map" $ Ops.map' wAsyncly 1 - , benchIO "fmap" $ Ops.fmap' wAsyncly 1 - , benchIO "mapM" $ Ops.mapM wAsyncly 1 + [ benchSrcIO wAsyncly "unfoldr" (Ops.sourceUnfoldr value) + , benchSrcIO wAsyncly "unfoldrM" (Ops.sourceUnfoldrM value) + , benchSrcIO wAsyncly "fromFoldable" (Ops.sourceFromFoldable value) + , benchSrcIO wAsyncly "fromFoldableM" (Ops.sourceFromFoldableM value) + , benchSrcIO wAsyncly "foldMapWith" (Ops.sourceFoldMapWith value) + , benchSrcIO wAsyncly "foldMapWithM" (Ops.sourceFoldMapWithM value) + , benchSrcIO wAsyncly "foldMapM" (Ops.sourceFoldMapM value) + , benchIO value "map" $ Ops.map' wAsyncly 1 + , benchIO value "fmap" $ Ops.fmap' wAsyncly 1 + , benchIO value "mapM" $ Ops.mapM wAsyncly 1 + , benchSrcIO wAsyncly "unfoldrM maxThreads 1" + (maxThreads 1 . Ops.sourceUnfoldrM value) + , benchSrcIO wAsyncly "unfoldrM maxBuffer 1 (x/10 ops)" + (maxBuffer 1 . Ops.sourceUnfoldrMN (value `div` 10)) + -- When we merge streams using wAsync the size of the queue increases + -- slowly because of the binary composition adding just one more item + -- to the work queue only after every scheduling pass through the + -- work queue. + -- + -- We should see the memory consumption increasing slowly if these + -- benchmarks are left to run on infinite number of streams of infinite + -- sizes. + , benchMonadicSrcIO "concatMapWith (2,x/2)" + (Ops.concatStreamsWith wAsync 2 (value `div` 2)) + , benchMonadicSrcIO "concatMapWith (sqrt x,sqrt x)" + (Ops.concatStreamsWith wAsync value2 value2) + , benchMonadicSrcIO "concatMapWith (sqrt x * 2,sqrt x / 2)" + (Ops.concatStreamsWith wAsync (value2 * 2) (value2 `div` 2)) ] - -- unfoldr and fromFoldable are always serial and thereofore the same for + -- unfoldr and fromFoldable are always serial and therefore the same for -- all stream types. , bgroup "aheadly" - [ 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 - , 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 "unfoldr" (Ops.sourceUnfoldr value) + , benchSrcIO aheadly "unfoldrM" (Ops.sourceUnfoldrM value) + , benchSrcIO aheadly "fromFoldableM" (Ops.sourceFromFoldableM value) + , benchSrcIO aheadly "foldMapWith" (Ops.sourceFoldMapWith value) + , benchSrcIO aheadly "foldMapWithM" (Ops.sourceFoldMapWithM value) + , benchSrcIO aheadly "foldMapM" (Ops.sourceFoldMapM value) + , benchIO value "map" $ Ops.map' aheadly 1 + , benchIO value "fmap" $ Ops.fmap' aheadly 1 + , benchIO value "mapM" $ Ops.mapM aheadly 1 , benchSrcIO aheadly "unfoldrM maxThreads 1" - (maxThreads 1 . Ops.sourceUnfoldrM) - , benchSrcIO aheadly "unfoldrM maxBuffer 1 (1000 ops)" - (maxBuffer 1 . Ops.sourceUnfoldrMN 1000) - -- , benchSrcIO aheadly "fromFoldable" Ops.sourceFromFoldable + (maxThreads 1 . Ops.sourceUnfoldrM value) + , benchSrcIO aheadly "unfoldrM maxBuffer 1 (x/10 ops)" + (maxBuffer 1 . Ops.sourceUnfoldrMN (value `div` 10)) + , benchSrcIO aheadly "fromFoldable" (Ops.sourceFromFoldable value) + , benchMonadicSrcIO "concatMapWith (2,x/2)" + (Ops.concatStreamsWith ahead 2 (value `div` 2)) + , benchMonadicSrcIO "concatMapWith (sqrt x,sqrt x)" + (Ops.concatStreamsWith ahead value2 value2) + , benchMonadicSrcIO "concatMapWith (sqrt x * 2,sqrt x / 2)" + (Ops.concatStreamsWith ahead (value2 * 2) (value2 `div` 2)) ] - -- XXX need to use smaller streams to finish in reasonable time - , bgroup "parallely" - [ 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 - , 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 + , bgroup "zip" + [ benchSrcIO serially "zipAsync (2,x/2)" (Ops.zipAsync (value `div` 2)) + , benchSrcIO serially "zipAsyncM (2,x/2)" + (Ops.zipAsyncM (value `div` 2)) + , benchSrcIO serially "zipAsyncAp (2,x/2)" + (Ops.zipAsyncAp (value `div` 2)) + , benchIO value "fmap zipAsyncly" $ Ops.fmap' zipAsyncly 1 + , benchSrcIO serially "mergeAsyncBy (2,x/2)" + (Ops.mergeAsyncBy (value `div` 2)) + , benchSrcIO serially "mergeAsyncByM (2,x/2)" + (Ops.mergeAsyncByM (value `div` 2)) + -- Parallel stages in a pipeline + , benchIO value "parAppMap" Ops.parAppMap + , benchIO value "parAppSum" Ops.parAppSum ] ] diff --git a/benchmark/LinearRate.hs b/benchmark/LinearRate.hs --- a/benchmark/LinearRate.hs +++ b/benchmark/LinearRate.hs @@ -10,11 +10,14 @@ -- import Data.Functor.Identity (Identity, runIdentity) import System.Random (randomRIO) -import qualified Streamly.Benchmark.Prelude as Ops +import Common (parseCLIOpts) + import Streamly import Gauge +import qualified Streamly.Benchmark.Prelude as Ops + -- | Takes a source, and uses it with a default drain/fold method. {-# INLINE benchSrcIO #-} benchSrcIO @@ -30,31 +33,36 @@ _benchId name f = bench name $ nf (runIdentity . f) (Ops.source 10) -} +defaultStreamSize :: Int +defaultStreamSize = 100000 + main :: IO () -main = - defaultMain +main = do + -- XXX Fix indentation + (value, cfg, benches) <- parseCLIOpts defaultStreamSize + value `seq` runMode (mode cfg) cfg benches -- XXX arbitrarily large rate should be the same as rate Nothing [ bgroup "avgrate" [ bgroup "asyncly" [ -- benchIO "unfoldr" $ Ops.toNull asyncly - benchSrcIO asyncly "unfoldrM" Ops.sourceUnfoldrM + benchSrcIO asyncly "unfoldrM" (Ops.sourceUnfoldrM value) , benchSrcIO asyncly "unfoldrM/Nothing" - (rate Nothing . Ops.sourceUnfoldrM) + (rate Nothing . Ops.sourceUnfoldrM value) , benchSrcIO asyncly "unfoldrM/1,000,000" - (avgRate 1000000 . Ops.sourceUnfoldrM) + (avgRate 1000000 . Ops.sourceUnfoldrM value) , benchSrcIO asyncly "unfoldrM/3,000,000" - (avgRate 3000000 . Ops.sourceUnfoldrM) + (avgRate 3000000 . Ops.sourceUnfoldrM value) , benchSrcIO asyncly "unfoldrM/10,000,000/maxThreads1" - (maxThreads 1 . avgRate 10000000 . Ops.sourceUnfoldrM) + (maxThreads 1 . avgRate 10000000 . Ops.sourceUnfoldrM value) , benchSrcIO asyncly "unfoldrM/10,000,000" - (avgRate 10000000 . Ops.sourceUnfoldrM) + (avgRate 10000000 . Ops.sourceUnfoldrM value) , benchSrcIO asyncly "unfoldrM/20,000,000" - (avgRate 20000000 . Ops.sourceUnfoldrM) + (avgRate 20000000 . Ops.sourceUnfoldrM value) ] , bgroup "aheadly" [ benchSrcIO aheadly "unfoldrM/1,000,000" - (avgRate 1000000 . Ops.sourceUnfoldrM) + (avgRate 1000000 . Ops.sourceUnfoldrM value) ] ] ] diff --git a/benchmark/NanoBenchmarks.hs b/benchmark/NanoBenchmarks.hs --- a/benchmark/NanoBenchmarks.hs +++ b/benchmark/NanoBenchmarks.hs @@ -15,7 +15,7 @@ import qualified Streamly.Data.Fold as FL import qualified Streamly.Internal.Prelude as Internal import qualified Streamly.Prelude as S -import qualified Streamly.Streams.StreamK as K +import qualified Streamly.Internal.Data.Stream.StreamK as K import Data.Char (ord) import Gauge @@ -114,7 +114,7 @@ defaultMain [mkBenchText "splitOn abc...xyz" inText $ do (S.length $ Internal.splitOnSeq (A.fromList $ map (fromIntegral . ord) "abcdefghijklmnopqrstuvwxyz") FL.drain - $ IFH.toStream inText) >>= print + $ IFH.toBytes inText) >>= print ] where diff --git a/benchmark/Nested.hs b/benchmark/Nested.hs --- a/benchmark/Nested.hs +++ b/benchmark/Nested.hs @@ -8,89 +8,54 @@ import Control.DeepSeq (NFData) import Data.Functor.Identity (Identity, runIdentity) import System.Random (randomRIO) -import qualified NestedOps as Ops + +import Common (parseCLIOpts) + import Streamly import Gauge +import qualified NestedOps as Ops + benchIO :: (NFData b) => String -> (Int -> IO b) -> Benchmark benchIO name f = bench name $ nfIO $ randomRIO (1,1) >>= f _benchId :: (NFData b) => String -> (Int -> Identity b) -> Benchmark _benchId name f = bench name $ nf (\g -> runIdentity (g 1)) f +defaultStreamSize :: Int +defaultStreamSize = 100000 + main :: IO () -main = - -- TBD Study scaling with 10, 100, 1000 loop iterations - defaultMain +main = do + -- XXX Fix indentation + (linearCount, cfg, benches) <- parseCLIOpts defaultStreamSize + linearCount `seq` runMode (mode cfg) cfg benches [ bgroup "serially" - [ benchIO "toNullAp" $ Ops.toNullAp serially - , benchIO "toNull" $ Ops.toNull serially - , benchIO "toNull3" $ Ops.toNull3 serially - , benchIO "toList" $ Ops.toList serially - -- , benchIO "toListSome" $ Ops.toListSome serially - , benchIO "filterAllOut" $ Ops.filterAllOut serially - , benchIO "filterAllIn" $ Ops.filterAllIn serially - , benchIO "filterSome" $ Ops.filterSome serially - , benchIO "breakAfterSome" $ Ops.breakAfterSome serially + [ benchIO "toNullAp" $ Ops.toNullAp linearCount serially + , benchIO "toNull" $ Ops.toNull linearCount serially + , benchIO "toNull3" $ Ops.toNull3 linearCount serially + -- , benchIO "toList" $ Ops.toList linearCount serially + -- XXX takes too much stack space + , benchIO "toListSome" $ Ops.toListSome linearCount serially + , benchIO "filterAllOut" $ Ops.filterAllOut linearCount serially + , benchIO "filterAllIn" $ Ops.filterAllIn linearCount serially + , benchIO "filterSome" $ Ops.filterSome linearCount serially + , benchIO "breakAfterSome" $ Ops.breakAfterSome linearCount serially ] , bgroup "wSerially" - [ benchIO "toNullAp" $ Ops.toNullAp wSerially - , benchIO "toNull" $ Ops.toNull wSerially - , benchIO "toNull3" $ Ops.toNull3 wSerially - , benchIO "toList" $ Ops.toList wSerially - -- , benchIO "toListSome" $ Ops.toListSome wSerially - , benchIO "filterAllOut" $ Ops.filterAllOut wSerially - , benchIO "filterAllIn" $ Ops.filterAllIn wSerially - , benchIO "filterSome" $ Ops.filterSome wSerially - , benchIO "breakAfterSome" $ Ops.breakAfterSome wSerially - ] - - , bgroup "aheadly" - [ benchIO "toNullAp" $ Ops.toNullAp aheadly - , benchIO "toNull" $ Ops.toNull aheadly - , benchIO "toNull3" $ Ops.toNull3 aheadly - , benchIO "toList" $ Ops.toList aheadly - -- , benchIO "toListSome" $ Ops.toListSome aheadly - , benchIO "filterAllOut" $ Ops.filterAllOut aheadly - , benchIO "filterAllIn" $ Ops.filterAllIn aheadly - , benchIO "filterSome" $ Ops.filterSome aheadly - , benchIO "breakAfterSome" $ Ops.breakAfterSome aheadly - ] - - , bgroup "asyncly" - [ benchIO "toNullAp" $ Ops.toNullAp asyncly - , benchIO "toNull" $ Ops.toNull asyncly - , benchIO "toNull3" $ Ops.toNull3 asyncly - , benchIO "toList" $ Ops.toList asyncly - -- , benchIO "toListSome" $ Ops.toListSome asyncly - , benchIO "filterAllOut" $ Ops.filterAllOut asyncly - , benchIO "filterAllIn" $ Ops.filterAllIn asyncly - , benchIO "filterSome" $ Ops.filterSome asyncly - , benchIO "breakAfterSome" $ Ops.breakAfterSome asyncly - ] - - , bgroup "wAsyncly" - [ benchIO "toNullAp" $ Ops.toNullAp wAsyncly - , benchIO "toNull" $ Ops.toNull wAsyncly - , benchIO "toNull3" $ Ops.toNull3 wAsyncly - , benchIO "toList" $ Ops.toList wAsyncly - -- , benchIO "toListSome" $ Ops.toListSome wAsyncly - , benchIO "filterAllOut" $ Ops.filterAllOut wAsyncly - , benchIO "filterAllIn" $ Ops.filterAllIn wAsyncly - , benchIO "filterSome" $ Ops.filterSome wAsyncly - , benchIO "breakAfterSome" $ Ops.breakAfterSome wAsyncly + [ benchIO "toNullAp" $ Ops.toNullAp linearCount wSerially + , benchIO "toNull" $ Ops.toNull linearCount wSerially + , benchIO "toNull3" $ Ops.toNull3 linearCount wSerially + -- , benchIO "toList" $ Ops.toList linearCount wSerially + , benchIO "toListSome" $ Ops.toListSome linearCount wSerially + , benchIO "filterAllOut" $ Ops.filterAllOut linearCount wSerially + , benchIO "filterAllIn" $ Ops.filterAllIn linearCount wSerially + , benchIO "filterSome" $ Ops.filterSome linearCount wSerially + , benchIO "breakAfterSome" $ Ops.breakAfterSome linearCount wSerially ] - , bgroup "parallely" - [ benchIO "toNullAp" $ Ops.toNullAp parallely - , benchIO "toNull" $ Ops.toNull parallely - , benchIO "toNull3" $ Ops.toNull3 parallely - , benchIO "toList" $ Ops.toList parallely - --, benchIO "toListSome" $ Ops.toListSome parallely - , benchIO "filterAllOut" $ Ops.filterAllOut parallely - , benchIO "filterAllIn" $ Ops.filterAllIn parallely - , benchIO "filterSome" $ Ops.filterSome parallely - , benchIO "breakAfterSome" $ Ops.breakAfterSome parallely + , bgroup "zipSerially" + [ benchIO "toNullAp" $ Ops.toNullAp linearCount zipSerially ] ] diff --git a/benchmark/NestedConcurrent.hs b/benchmark/NestedConcurrent.hs new file mode 100644 --- /dev/null +++ b/benchmark/NestedConcurrent.hs @@ -0,0 +1,84 @@ +-- | +-- Module : Main +-- Copyright : (c) 2018 Harendra Kumar +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com + +import Control.DeepSeq (NFData) +import Control.Monad (when) +import Data.Functor.Identity (Identity, runIdentity) +import System.Random (randomRIO) + +import Common (parseCLIOpts) + +import Streamly +import Gauge + +import qualified NestedOps as Ops + +benchIO :: (NFData b) => String -> (Int -> IO b) -> Benchmark +benchIO name f = bench name $ nfIO $ randomRIO (1,1) >>= f + +_benchId :: (NFData b) => String -> (Int -> Identity b) -> Benchmark +_benchId name f = bench name $ nf (\g -> runIdentity (g 1)) f + +defaultStreamSize :: Int +defaultStreamSize = 100000 + +main :: IO () +main = do + -- XXX Fix indentation + (linearCount, cfg, benches) <- parseCLIOpts defaultStreamSize + let finiteCount = min linearCount defaultStreamSize + when (finiteCount /= linearCount) $ + putStrLn $ "Limiting stream size to " + ++ show defaultStreamSize + ++ " for finite stream operations only" + + finiteCount `seq` linearCount `seq` runMode (mode cfg) cfg benches + [ + bgroup "aheadly" + [ benchIO "toNullAp" $ Ops.toNullAp linearCount aheadly + , benchIO "toNull" $ Ops.toNull linearCount aheadly + , benchIO "toNull3" $ Ops.toNull3 linearCount aheadly + -- , benchIO "toList" $ Ops.toList linearCount aheadly + -- XXX consumes too much stack space + , benchIO "toListSome" $ Ops.toListSome linearCount aheadly + , benchIO "filterAllOut" $ Ops.filterAllOut linearCount aheadly + , benchIO "filterAllIn" $ Ops.filterAllIn linearCount aheadly + , benchIO "filterSome" $ Ops.filterSome linearCount aheadly + , benchIO "breakAfterSome" $ Ops.breakAfterSome linearCount aheadly + ] + + , bgroup "asyncly" + [ benchIO "toNullAp" $ Ops.toNullAp linearCount asyncly + , benchIO "toNull" $ Ops.toNull linearCount asyncly + , benchIO "toNull3" $ Ops.toNull3 linearCount asyncly + -- , benchIO "toList" $ Ops.toList linearCount asyncly + , benchIO "toListSome" $ Ops.toListSome linearCount asyncly + , benchIO "filterAllOut" $ Ops.filterAllOut linearCount asyncly + , benchIO "filterAllIn" $ Ops.filterAllIn linearCount asyncly + , benchIO "filterSome" $ Ops.filterSome linearCount asyncly + , benchIO "breakAfterSome" $ Ops.breakAfterSome linearCount asyncly + ] + + , bgroup "zipAsyncly" + [ benchIO "toNullAp" $ Ops.toNullAp linearCount zipAsyncly + ] + + -- Operations that are not scalable to infinite streams + , bgroup "finite" + [ bgroup "wAsyncly" + [ benchIO "toNullAp" $ Ops.toNullAp finiteCount wAsyncly + , benchIO "toNull" $ Ops.toNull finiteCount wAsyncly + , benchIO "toNull3" $ Ops.toNull3 finiteCount wAsyncly + -- , benchIO "toList" $ Ops.toList finiteCount wAsyncly + , benchIO "toListSome" $ Ops.toListSome finiteCount wAsyncly + , benchIO "filterAllOut" $ Ops.filterAllOut finiteCount wAsyncly + -- , benchIO "filterAllIn" $ Ops.filterAllIn finiteCount wAsyncly + , benchIO "filterSome" $ Ops.filterSome finiteCount wAsyncly + , benchIO "breakAfterSome" $ Ops.breakAfterSome finiteCount wAsyncly + ] + ] + ] diff --git a/benchmark/NestedOps.hs b/benchmark/NestedOps.hs --- a/benchmark/NestedOps.hs +++ b/benchmark/NestedOps.hs @@ -5,6 +5,7 @@ -- License : MIT -- Maintainer : streamly@composewell.com +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -16,18 +17,6 @@ import qualified Streamly as S hiding (runStream) import qualified Streamly.Prelude as S -linearCount :: Int -linearCount = 100000 - --- double nested loop -nestedCount2 :: Int --- nestedCount2 = round (fromIntegral linearCount**(1/2::Double)) -nestedCount2 = 100 - --- triple nested loop -nestedCount3 :: Int -nestedCount3 = round (fromIntegral linearCount**(1/3::Double)) - ------------------------------------------------------------------------------- -- Stream generation and elimination ------------------------------------------------------------------------------- @@ -38,6 +27,7 @@ source :: (S.MonadAsync m, S.IsStream t) => Int -> Int -> t m Int source = sourceUnfoldrM +-- Change this to "sourceUnfoldrM value n" for consistency {-# INLINE sourceUnfoldrM #-} sourceUnfoldrM :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m Int sourceUnfoldrM n value = S.serially $ S.unfoldrM step n @@ -70,90 +60,108 @@ {-# 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 $ + :: (S.IsStream t, S.MonadAsync m, Applicative (t m)) + => Int -> (t m Int -> S.SerialT m Int) -> Int -> m () +toNullAp linearCount t start = runStream . t $ (+) <$> source start nestedCount2 <*> source start nestedCount2 + where + nestedCount2 = round (fromIntegral linearCount**(1/2::Double)) {-# INLINE toNull #-} toNull :: (S.IsStream t, S.MonadAsync m, Monad (t m)) - => (t m Int -> S.SerialT m Int) -> Int -> m () -toNull t start = runStream . t $ do + => Int -> (t m Int -> S.SerialT m Int) -> Int -> m () +toNull linearCount t start = runStream . t $ do x <- source start nestedCount2 y <- source start nestedCount2 return $ x + y + where + nestedCount2 = round (fromIntegral linearCount**(1/2::Double)) {-# INLINE toNull3 #-} toNull3 :: (S.IsStream t, S.MonadAsync m, Monad (t m)) - => (t m Int -> S.SerialT m Int) -> Int -> m () -toNull3 t start = runStream . t $ do + => Int -> (t m Int -> S.SerialT m Int) -> Int -> m () +toNull3 linearCount t start = runStream . t $ do x <- source start nestedCount3 y <- source start nestedCount3 z <- source start nestedCount3 return $ x + y + z + where + nestedCount3 = round (fromIntegral linearCount**(1/3::Double)) {-# INLINE toList #-} toList :: (S.IsStream t, S.MonadAsync m, Monad (t m)) - => (t m Int -> S.SerialT m Int) -> Int -> m [Int] -toList t start = runToList . t $ do + => Int -> (t m Int -> S.SerialT m Int) -> Int -> m [Int] +toList linearCount t start = runToList . t $ do x <- source start nestedCount2 y <- source start nestedCount2 return $ x + y + where + nestedCount2 = round (fromIntegral linearCount**(1/2::Double)) +-- Taking a specified number of elements is very expensive in logict so we have +-- a test to measure the same. {-# INLINE toListSome #-} toListSome :: (S.IsStream t, S.MonadAsync m, Monad (t m)) - => (t m Int -> S.SerialT m Int) -> Int -> m [Int] -toListSome t start = - runToList . t $ S.take 1000 $ do + => Int -> (t m Int -> S.SerialT m Int) -> Int -> m [Int] +toListSome linearCount t start = + runToList . t $ S.take 10000 $ do x <- source start nestedCount2 y <- source start nestedCount2 return $ x + y + where + nestedCount2 = round (fromIntegral linearCount**(1/2::Double)) {-# INLINE filterAllOut #-} filterAllOut :: (S.IsStream t, S.MonadAsync m, Monad (t m)) - => (t m Int -> S.SerialT m Int) -> Int -> m () -filterAllOut t start = runStream . t $ do + => Int -> (t m Int -> S.SerialT m Int) -> Int -> m () +filterAllOut linearCount t start = runStream . t $ do x <- source start nestedCount2 y <- source start nestedCount2 let s = x + y if s < 0 then return s else S.nil + where + nestedCount2 = round (fromIntegral linearCount**(1/2::Double)) {-# INLINE filterAllIn #-} filterAllIn :: (S.IsStream t, S.MonadAsync m, Monad (t m)) - => (t m Int -> S.SerialT m Int) -> Int -> m () -filterAllIn t start = runStream . t $ do + => Int -> (t m Int -> S.SerialT m Int) -> Int -> m () +filterAllIn linearCount t start = runStream . t $ do x <- source start nestedCount2 y <- source start nestedCount2 let s = x + y if s > 0 then return s else S.nil + where + nestedCount2 = round (fromIntegral linearCount**(1/2::Double)) {-# INLINE filterSome #-} filterSome :: (S.IsStream t, S.MonadAsync m, Monad (t m)) - => (t m Int -> S.SerialT m Int) -> Int -> m () -filterSome t start = runStream . t $ do + => Int -> (t m Int -> S.SerialT m Int) -> Int -> m () +filterSome linearCount t start = runStream . t $ do x <- source start nestedCount2 y <- source start nestedCount2 let s = x + y if s > 1100000 then return s else S.nil + where + nestedCount2 = round (fromIntegral linearCount**(1/2::Double)) {-# INLINE breakAfterSome #-} breakAfterSome :: (S.IsStream t, Monad (t IO)) - => (t IO Int -> S.SerialT IO Int) -> Int -> IO () -breakAfterSome t start = do + => Int -> (t IO Int -> S.SerialT IO Int) -> Int -> IO () +breakAfterSome linearCount t start = do (_ :: Either ErrorCall ()) <- try $ runStream . t $ do x <- source start nestedCount2 y <- source start nestedCount2 @@ -162,3 +170,5 @@ then error "break" else return s return () + where + nestedCount2 = round (fromIntegral linearCount**(1/2::Double)) diff --git a/benchmark/NestedUnfold.hs b/benchmark/NestedUnfold.hs --- a/benchmark/NestedUnfold.hs +++ b/benchmark/NestedUnfold.hs @@ -8,6 +8,8 @@ import Control.DeepSeq (NFData) import System.Random (randomRIO) +import Common (parseCLIOpts) + import qualified NestedUnfoldOps as Ops import Gauge @@ -15,18 +17,22 @@ benchIO :: (NFData b) => String -> (Int -> IO b) -> Benchmark benchIO name f = bench name $ nfIO $ randomRIO (1,1) >>= f +defaultStreamSize :: Int +defaultStreamSize = 100000 + main :: IO () -main = - defaultMain +main = do + (linearCount, cfg, benches) <- parseCLIOpts defaultStreamSize + linearCount `seq` runMode (mode cfg) cfg benches [ bgroup "unfold" - [ benchIO "toNull" $ Ops.toNull - , benchIO "toNull3" $ Ops.toNull3 - , benchIO "concat" $ Ops.concat - , benchIO "toList" $ Ops.toList - , benchIO "toListSome" $ Ops.toListSome - , benchIO "filterAllOut" $ Ops.filterAllOut - , benchIO "filterAllIn" $ Ops.filterAllIn - , benchIO "filterSome" $ Ops.filterSome - , benchIO "breakAfterSome" $ Ops.breakAfterSome + [ benchIO "toNull" $ Ops.toNull linearCount + , benchIO "toNull3" $ Ops.toNull3 linearCount + , benchIO "concat" $ Ops.concat linearCount + -- , benchIO "toList" $ Ops.toList + , benchIO "toListSome" $ Ops.toListSome linearCount + , benchIO "filterAllOut" $ Ops.filterAllOut linearCount + , benchIO "filterAllIn" $ Ops.filterAllIn linearCount + , benchIO "filterSome" $ Ops.filterSome linearCount + , benchIO "breakAfterSome" $ Ops.breakAfterSome linearCount ] ] diff --git a/benchmark/NestedUnfoldOps.hs b/benchmark/NestedUnfoldOps.hs --- a/benchmark/NestedUnfoldOps.hs +++ b/benchmark/NestedUnfoldOps.hs @@ -13,20 +13,18 @@ import qualified Streamly.Internal.Data.Unfold as UF import qualified Streamly.Internal.Data.Fold as FL -linearCount :: Int -linearCount = 100000 - -- n * (n + 1) / 2 == linearCount -concatCount :: Int -concatCount = 450 +concatCount :: Int -> Int +concatCount linearCount = + round (((1 + 8 * fromIntegral linearCount)**(1/2::Double) - 1) / 2) -- double nested loop -nestedCount2 :: Int -nestedCount2 = round (fromIntegral linearCount**(1/2::Double)) +nestedCount2 :: Int -> Int +nestedCount2 linearCount = round (fromIntegral linearCount**(1/2::Double)) -- triple nested loop -nestedCount3 :: Int -nestedCount3 = round (fromIntegral linearCount**(1/3::Double)) +nestedCount3 :: Int -> Int +nestedCount3 linearCount = round (fromIntegral linearCount**(1/3::Double)) ------------------------------------------------------------------------------- -- Stream generation and elimination @@ -42,18 +40,18 @@ ------------------------------------------------------------------------------- {-# INLINE toNull #-} -toNull :: MonadIO m => Int -> m () -toNull start = do - let end = start + nestedCount2 +toNull :: MonadIO m => Int -> Int -> m () +toNull linearCount start = do + let end = start + nestedCount2 linearCount UF.fold (UF.map (\(x, y) -> x + y) $ UF.outerProduct (source end) (source end)) FL.drain (start, start) {-# INLINE toNull3 #-} -toNull3 :: MonadIO m => Int -> m () -toNull3 start = do - let end = start + nestedCount3 +toNull3 :: MonadIO m => Int -> Int -> m () +toNull3 linearCount start = do + let end = start + nestedCount3 linearCount UF.fold (UF.map (\(x, y) -> x + y) $ UF.outerProduct (source end) @@ -62,35 +60,35 @@ FL.drain (start, (start, start)) {-# INLINE concat #-} -concat :: MonadIO m => Int -> m () -concat start = do - let end = start + concatCount +concat :: MonadIO m => Int -> Int -> m () +concat linearCount start = do + let end = start + concatCount linearCount UF.fold (UF.concat (source end) (source end)) FL.drain start {-# INLINE toList #-} -toList :: MonadIO m => Int -> m [Int] -toList start = do - let end = start + nestedCount2 +toList :: MonadIO m => Int -> Int -> m [Int] +toList linearCount start = do + let end = start + nestedCount2 linearCount UF.fold (UF.map (\(x, y) -> x + y) $ UF.outerProduct (source end) (source end)) FL.toList (start, start) {-# INLINE toListSome #-} -toListSome :: MonadIO m => Int -> m [Int] -toListSome start = do - let end = start + nestedCount2 +toListSome :: MonadIO m => Int -> Int -> m [Int] +toListSome linearCount start = do + let end = start + nestedCount2 linearCount UF.fold (UF.take 1000 $ (UF.map (\(x, y) -> x + y) $ UF.outerProduct (source end) (source end))) FL.toList (start, start) {-# INLINE filterAllOut #-} -filterAllOut :: MonadIO m => Int -> m () -filterAllOut start = do - let end = start + nestedCount2 +filterAllOut :: MonadIO m => Int -> Int -> m () +filterAllOut linearCount start = do + let end = start + nestedCount2 linearCount UF.fold (UF.filter (< 0) $ UF.map (\(x, y) -> x + y) @@ -98,9 +96,9 @@ FL.drain (start, start) {-# INLINE filterAllIn #-} -filterAllIn :: MonadIO m => Int -> m () -filterAllIn start = do - let end = start + nestedCount2 +filterAllIn :: MonadIO m => Int -> Int -> m () +filterAllIn linearCount start = do + let end = start + nestedCount2 linearCount UF.fold (UF.filter (> 0) $ UF.map (\(x, y) -> x + y) @@ -108,9 +106,9 @@ FL.drain (start, start) {-# INLINE filterSome #-} -filterSome :: MonadIO m => Int -> m () -filterSome start = do - let end = start + nestedCount2 +filterSome :: MonadIO m => Int -> Int -> m () +filterSome linearCount start = do + let end = start + nestedCount2 linearCount UF.fold (UF.filter (> 1100000) $ UF.map (\(x, y) -> x + y) @@ -118,9 +116,9 @@ FL.drain (start, start) {-# INLINE breakAfterSome #-} -breakAfterSome :: MonadIO m => Int -> m () -breakAfterSome start = do - let end = start + nestedCount2 +breakAfterSome :: MonadIO m => Int -> Int -> m () +breakAfterSome linearCount start = do + let end = start + nestedCount2 linearCount UF.fold (UF.takeWhile (<= 1100000) $ UF.map (\(x, y) -> x + y) diff --git a/benchmark/Parallel.hs b/benchmark/Parallel.hs new file mode 100644 --- /dev/null +++ b/benchmark/Parallel.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : Main +-- Copyright : (c) 2018 Harendra Kumar +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com + +import Control.DeepSeq (NFData) +-- import Data.Functor.Identity (Identity, runIdentity) +import System.Random (randomRIO) + +import Common (parseCLIOpts) + +import Streamly +import Gauge + +import qualified Streamly.Benchmark.Prelude as Ops +import qualified NestedOps as Nested + +{-# INLINE benchIONested #-} +benchIONested :: (NFData b) => String -> (Int -> IO b) -> Benchmark +benchIONested name f = bench name $ nfIO $ randomRIO (1,1) >>= f + +-- We need a monadic bind here to make sure that the function f does not get +-- completely optimized out by the compiler in some cases. +-- +-- | Takes a fold method, and uses it with a default source. +{-# INLINE benchIO #-} +benchIO :: (IsStream t, NFData b) => Int -> String -> (t IO Int -> IO b) -> Benchmark +benchIO value name f = bench name $ nfIO $ randomRIO (1,1) >>= f . Ops.source value + +-- | Takes a source, and uses it with a default drain/fold method. +{-# INLINE benchSrcIO #-} +benchSrcIO + :: (t IO Int -> SerialT IO Int) + -> String + -> (Int -> t IO Int) + -> Benchmark +benchSrcIO t name f + = bench name $ nfIO $ randomRIO (1,1) >>= Ops.toNull t . f + +defaultStreamSize :: Int +defaultStreamSize = 100000 + +linear :: Int -> Int -> [Benchmark] +linear value value2 = + [ -- unfoldr is pure and works serially irrespective of the stream type + benchSrcIO parallely "unfoldr" (Ops.sourceUnfoldr value) + , benchSrcIO parallely "unfoldrM" (Ops.sourceUnfoldrM value) + , benchSrcIO parallely "fromFoldable" (Ops.sourceFromFoldable value) + , benchSrcIO parallely "fromFoldableM" (Ops.sourceFromFoldableM value) + , benchSrcIO parallely "foldMapWith" (Ops.sourceFoldMapWith value) + , benchSrcIO parallely "foldMapWithM" (Ops.sourceFoldMapWithM value) + , benchSrcIO parallely "foldMapM" (Ops.sourceFoldMapM value) + -- map/fmap are pure and therefore no concurrency would be added on top + -- of what the source stream (i.e. unfoldrM) provides. + , benchIO value "map" $ Ops.map' parallely 1 + , benchIO value "fmap" $ Ops.fmap' parallely 1 + , benchIO value "mapM" $ Ops.mapM parallely 1 + , benchIONested "concatMapWith (2,x/2)" + (Ops.concatStreamsWith parallel 2 (value `div` 2)) + , benchIONested "concatMapWith (sqrt x,sqrt x)" + (Ops.concatStreamsWith parallel value2 value2) + , benchIONested "concatMapWith (sqrt x * 2,sqrt x / 2)" + (Ops.concatStreamsWith parallel (value2 * 2) (value2 `div` 2)) + ] + +nested :: Int -> [Benchmark] +nested value = + [ benchIONested "toNullAp" $ Nested.toNullAp value parallely + , benchIONested "toNull" $ Nested.toNull value parallely + , benchIONested "toNull3" $ Nested.toNull3 value parallely + -- , benchIO "toList" $ Ops.toList value parallely + -- XXX fix thread blocked indefinitely in MVar + -- , benchIO "toListSome" $ Ops.toListSome value parallely + , benchIONested "filterAllOut" $ Nested.filterAllOut value parallely + , benchIONested "filterAllIn" $ Nested.filterAllIn value parallely + , benchIONested "filterSome" $ Nested.filterSome value parallely + , benchIONested "breakAfterSome" $ Nested.breakAfterSome value parallely + ] + +main :: IO () +main = do + (value, cfg, benches) <- parseCLIOpts defaultStreamSize + let value2 = round $ sqrt $ (fromIntegral value :: Double) + value2 `seq` value `seq` + runMode (mode cfg) cfg benches $ + [ bgroup "parallelly" + [ bgroup "linear" $ linear value value2 + , bgroup "nested" $ nested value + ] + ] diff --git a/benchmark/StreamDKOps.hs b/benchmark/StreamDKOps.hs --- a/benchmark/StreamDKOps.hs +++ b/benchmark/StreamDKOps.hs @@ -13,14 +13,13 @@ -- import Control.Monad (when) -- import Data.Maybe (isJust) import Prelude - (Monad, Int, (+), ($), (.), return, even, (>), (<=), div, - subtract, undefined, Maybe(..), not, (>>=), - maxBound, flip, (<$>), (<*>), round, (/), (**), (<)) + (Monad, Int, (+), (.), return, undefined, Maybe(..), round, (/), + (**), (>)) import qualified Prelude as P -- import qualified Data.List as List -import qualified Streamly.Streams.StreamDK as S --- import qualified Streamly.Streams.Prelude as SP +import qualified Streamly.Internal.Data.Stream.StreamDK as S +-- import qualified Streamly.Internal.Data.Stream.Prelude as SP -- import qualified Streamly.Internal.Data.SVar as S value, value2, value3, value16, maxValue :: Int diff --git a/benchmark/StreamDOps.hs b/benchmark/StreamDOps.hs --- a/benchmark/StreamDOps.hs +++ b/benchmark/StreamDOps.hs @@ -18,7 +18,7 @@ maxBound, fmap, odd, (==), flip, (<$>), (<*>), round, (/), (**), (<)) import qualified Prelude as P -import qualified Streamly.Streams.StreamD as S +import qualified Streamly.Internal.Data.Stream.StreamD as S import qualified Streamly.Internal.Data.Unfold as UF -- We try to keep the total number of iterations same irrespective of nesting @@ -250,6 +250,10 @@ iterateTakeAll = iterateSource (S.take maxValue) maxIters iterateDropOne = iterateSource (S.drop 1) maxIters iterateDropWhileTrue = iterateSource (S.dropWhile (<= maxValue)) maxIters + +{-# INLINE iterateM #-} +iterateM :: Monad m => Int -> Stream m Int +iterateM i = S.take maxIters (S.iterateM (\x -> return (x + 1)) (return i)) ------------------------------------------------------------------------------- -- Zipping and concat diff --git a/benchmark/StreamKOps.hs b/benchmark/StreamKOps.hs --- a/benchmark/StreamKOps.hs +++ b/benchmark/StreamKOps.hs @@ -19,8 +19,8 @@ import qualified Prelude as P import qualified Data.List as List -import qualified Streamly.Streams.StreamK as S -import qualified Streamly.Streams.Prelude as SP +import qualified Streamly.Internal.Data.Stream.StreamK as S +import qualified Streamly.Internal.Data.Stream.Prelude as SP import qualified Streamly.Internal.Data.SVar as S value, value2, value3, value16, maxValue :: Int diff --git a/benchmark/Streamly/Benchmark/Data/Array.hs b/benchmark/Streamly/Benchmark/Data/Array.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Data/Array.hs @@ -0,0 +1,96 @@ +-- | +-- Module : Main +-- Copyright : (c) 2019 Composewell Technologies +-- +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +{-# LANGUAGE CPP #-} + +module Main (main) where + +import Control.DeepSeq (NFData(..), deepseq) +import System.Random (randomRIO) + +import qualified Streamly.Benchmark.Data.ArrayOps as Ops +import qualified Streamly.Internal.Data.Array as A +import qualified Streamly.Prelude as S + +import Gauge + +------------------------------------------------------------------------------- +-- +------------------------------------------------------------------------------- + +{-# INLINE benchIO #-} +benchIO :: NFData b => String -> (Int -> IO a) -> (a -> b) -> Benchmark +benchIO name src f = bench name $ nfIO $ + randomRIO (1,1) >>= src >>= return . f + +-- Drain a source that generates an array in the IO monad +{-# INLINE benchIOSrc #-} +benchIOSrc :: (NFData a) + => String -> (Int -> IO (Ops.Stream a)) -> Benchmark +benchIOSrc name src = benchIO name src id + +{-# INLINE benchPureSink #-} +benchPureSink :: NFData b => String -> (Ops.Stream Int -> b) -> Benchmark +benchPureSink name f = benchIO name Ops.sourceIntFromTo f + +{-# INLINE benchIO' #-} +benchIO' :: NFData b => String -> (Int -> IO a) -> (a -> IO b) -> Benchmark +benchIO' name src f = bench name $ nfIO $ + randomRIO (1,1) >>= src >>= f + +{-# INLINE benchIOSink #-} +benchIOSink :: NFData b => String -> (Ops.Stream Int -> IO b) -> Benchmark +benchIOSink name f = benchIO' name Ops.sourceIntFromTo f + +mkString :: String +mkString = "[1" ++ concat (replicate Ops.value ",1") ++ "]" + +main :: IO () +main = + defaultMain + [ bgroup "Data.Array" + [ bgroup "generation" + [ benchIOSrc "writeN . intFromTo" Ops.sourceIntFromTo + , benchIOSrc "write . intFromTo" Ops.sourceIntFromToFromStream + , benchIOSrc "fromList . intFromTo" Ops.sourceIntFromToFromList + , benchIOSrc "writeN . unfoldr" Ops.sourceUnfoldr + , benchIOSrc "writeN . fromList" Ops.sourceFromList + -- , benchPureSrc "writeN . IsList.fromList" Ops.sourceIsList + -- , benchPureSrc "writeN . IsString.fromString" Ops.sourceIsString + , mkString `deepseq` (bench "read" $ nf Ops.readInstance mkString) + , benchPureSink "show" Ops.showInstance + ] + , bgroup "elimination" + [ benchPureSink "id" id + , benchPureSink "==" Ops.eqInstance + , benchPureSink "/=" Ops.eqInstanceNotEq + , benchPureSink "<" Ops.ordInstance + , benchPureSink "min" Ops.ordInstanceMin + -- length is used to check for foldr/build fusion + -- , benchPureSink "length . IsList.toList" (length . GHC.toList) + , benchIOSink "foldl'" Ops.pureFoldl' + , benchIOSink "read" (S.drain . S.unfold A.read) + , benchIOSink "toStreamRev" (S.drain . A.toStreamRev) +#ifdef DEVBUILD + , benchPureSink "foldable/foldl'" Ops.foldableFoldl' + , benchPureSink "foldable/sum" Ops.foldableSum +#endif + ] + , bgroup "transformation" + [ benchIOSink "scanl'" (Ops.scanl' 1) + , benchIOSink "scanl1'" (Ops.scanl1' 1) + , benchIOSink "map" (Ops.map 1) + ] + , bgroup "transformationX4" + [ benchIOSink "scanl'" (Ops.scanl' 4) + , benchIOSink "scanl1'" (Ops.scanl1' 4) + , benchIOSink "map" (Ops.map 4) + ] + ] + ] diff --git a/benchmark/Streamly/Benchmark/Data/ArrayOps.hs b/benchmark/Streamly/Benchmark/Data/ArrayOps.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Data/ArrayOps.hs @@ -0,0 +1,148 @@ +-- | +-- Module : Streamly.Benchmark.Data.ArrayOps +-- Copyright : (c) 2019 Composewell Technologies +-- +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Streamly.Benchmark.Data.ArrayOps where + +import Control.Monad.IO.Class (MonadIO) +import Prelude (Int, Bool, (+), ($), (==), (>), (.), Maybe(..), undefined) +import qualified Prelude as P +#ifdef DEVBUILD +import qualified Data.Foldable as F +#endif + +import qualified Streamly as S hiding (foldMapWith, runStream) +import qualified Streamly.Internal.Data.Array as A +import qualified Streamly.Prelude as S + +value :: Int +value = 100000 + +------------------------------------------------------------------------------- +-- Benchmark ops +------------------------------------------------------------------------------- + +------------------------------------------------------------------------------- +-- Stream generation and elimination +------------------------------------------------------------------------------- + +type Stream = A.Array + +{-# INLINE sourceUnfoldr #-} +sourceUnfoldr :: MonadIO m => Int -> m (Stream Int) +sourceUnfoldr n = S.fold (A.writeN value) $ S.unfoldr step n + where + step cnt = + if cnt > n + value + then Nothing + else (Just (cnt, cnt + 1)) + +{-# INLINE sourceIntFromTo #-} +sourceIntFromTo :: MonadIO m => Int -> m (Stream Int) +sourceIntFromTo n = S.fold (A.writeN value) $ S.enumerateFromTo n (n + value) + +{-# INLINE sourceIntFromToFromStream #-} +sourceIntFromToFromStream :: MonadIO m => Int -> m (Stream Int) +sourceIntFromToFromStream n = S.fold A.write $ S.enumerateFromTo n (n + value) + +{-# INLINE sourceIntFromToFromList #-} +sourceIntFromToFromList :: MonadIO m => Int -> m (Stream Int) +sourceIntFromToFromList n = P.return $ A.fromList $ [n..n + value] + +{-# INLINE sourceFromList #-} +sourceFromList :: MonadIO m => Int -> m (Stream Int) +sourceFromList n = S.fold (A.writeN value) $ S.fromList [n..n+value] +{- +{-# INLINE sourceIsList #-} +sourceIsList :: Int -> Stream Int +sourceIsList n = GHC.fromList [n..n+value] + +{-# INLINE sourceIsString #-} +sourceIsString :: Int -> Stream P.Char +sourceIsString n = GHC.fromString (P.replicate (n + value) 'a') +-} +------------------------------------------------------------------------------- +-- Transformation +------------------------------------------------------------------------------- + +{-# INLINE composeN #-} +composeN :: P.Monad m + => Int -> (Stream Int -> m (Stream Int)) -> Stream Int -> m (Stream Int) +composeN n f x = + case n of + 1 -> f x + 2 -> f x P.>>= f + 3 -> f x P.>>= f P.>>= f + 4 -> f x P.>>= f P.>>= f P.>>= f + _ -> undefined + +{-# INLINE scanl' #-} +{-# INLINE scanl1' #-} +{-# INLINE map #-} + +scanl', scanl1', map + :: MonadIO m => Int -> Stream Int -> m (Stream Int) + +{-# INLINE onArray #-} +onArray + :: MonadIO m => (S.SerialT m Int -> S.SerialT m Int) + -> Stream Int + -> m (Stream Int) +onArray f arr = S.fold (A.writeN value) $ f $ (S.unfold A.read arr) + +scanl' n = composeN n $ onArray $ S.scanl' (+) 0 +scanl1' n = composeN n $ onArray $ S.scanl1' (+) +map n = composeN n $ onArray $ S.map (+1) + +{-# INLINE eqInstance #-} +eqInstance :: Stream Int -> Bool +eqInstance src = src == src + +{-# INLINE eqInstanceNotEq #-} +eqInstanceNotEq :: Stream Int -> Bool +eqInstanceNotEq src = src P./= src + +{-# INLINE ordInstance #-} +ordInstance :: Stream Int -> Bool +ordInstance src = src P.< src + +{-# INLINE ordInstanceMin #-} +ordInstanceMin :: Stream Int -> Stream Int +ordInstanceMin src = P.min src src + +{-# INLINE showInstance #-} +showInstance :: Stream Int -> P.String +showInstance src = P.show src + +{-# INLINE readInstance #-} +readInstance :: P.String -> Stream Int +readInstance str = + let r = P.reads str + in case r of + [(x,"")] -> x + _ -> P.error "readInstance: no parse" + +{-# INLINE pureFoldl' #-} +pureFoldl' :: MonadIO m => Stream Int -> m Int +pureFoldl' = S.foldl' (+) 0 . S.unfold A.read + +#ifdef DEVBUILD +{-# INLINE foldableFoldl' #-} +foldableFoldl' :: Stream Int -> Int +foldableFoldl' = F.foldl' (+) 0 + +{-# INLINE foldableSum #-} +foldableSum :: Stream Int -> Int +foldableSum = P.sum +#endif diff --git a/benchmark/Streamly/Benchmark/Data/Prim/Array.hs b/benchmark/Streamly/Benchmark/Data/Prim/Array.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Data/Prim/Array.hs @@ -0,0 +1,100 @@ +-- | +-- Module : Main +-- Copyright : (c) 2019 Composewell Technologies +-- +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +{-# LANGUAGE CPP #-} + +module Main (main) where + +import Control.DeepSeq (NFData(..)) +import System.Random (randomRIO) + +import qualified Streamly.Benchmark.Data.Prim.ArrayOps as Ops +import qualified Streamly.Internal.Data.Prim.Array as A +import qualified Streamly.Prelude as S + +import Gauge + +------------------------------------------------------------------------------- +-- +------------------------------------------------------------------------------- + +{-# INLINE benchIO #-} +benchIO :: NFData b => String -> (Int -> IO a) -> (a -> b) -> Benchmark +benchIO name src f = bench name $ nfIO $ + randomRIO (1,1) >>= src >>= return . f + +-- Drain a source that generates an array in the IO monad +{-# INLINE benchIOSrc #-} +benchIOSrc :: A.Prim a => String -> (Int -> IO (Ops.Stream a)) -> Benchmark +benchIOSrc name src = benchIO name src id + +{-# INLINE benchPureSink #-} +benchPureSink :: NFData b => String -> (Ops.Stream Int -> b) -> Benchmark +benchPureSink name f = benchIO name Ops.sourceIntFromTo f + +{-# INLINE benchIO' #-} +benchIO' :: NFData b => String -> (Int -> IO a) -> (a -> IO b) -> Benchmark +benchIO' name src f = bench name $ nfIO $ + randomRIO (1,1) >>= src >>= f + +{-# INLINE benchIOSink #-} +benchIOSink :: NFData b => String -> (Ops.Stream Int -> IO b) -> Benchmark +benchIOSink name f = benchIO' name Ops.sourceIntFromTo f + +{- +mkString :: String +mkString = "[1" ++ concat (replicate Ops.value ",1") ++ "]" +-} + +main :: IO () +main = + defaultMain + [ bgroup "Data.Prim.Array" + [ bgroup "generation" + [ benchIOSrc "writeN . intFromTo" Ops.sourceIntFromTo + , benchIOSrc "write . intFromTo" Ops.sourceIntFromToFromStream + , benchIOSrc "fromList . intFromTo" Ops.sourceIntFromToFromList + , benchIOSrc "writeN . unfoldr" Ops.sourceUnfoldr + , benchIOSrc "writeN . fromList" Ops.sourceFromList + -- , benchPureSrc "writeN . IsList.fromList" Ops.sourceIsList + -- , benchPureSrc "writeN . IsString.fromString" Ops.sourceIsString + -- , mkString `deepseq` (bench "read" $ nf Ops.readInstance mkString) + , benchPureSink "show" Ops.showInstance + ] + , bgroup "elimination" + [ benchPureSink "id" id + , benchPureSink "==" Ops.eqInstance + , benchPureSink "/=" Ops.eqInstanceNotEq + , benchPureSink "<" Ops.ordInstance + , benchPureSink "min" Ops.ordInstanceMin + -- length is used to check for foldr/build fusion + -- , benchPureSink "length . IsList.toList" (length . GHC.toList) + , benchIOSink "foldl'" Ops.pureFoldl' + , benchIOSink "read" (S.drain . S.unfold A.read) + , benchIOSink "toStreamRev" (S.drain . A.toStreamRev) +#if 0 + -- PrimArray does not have a Foldable instance because it requires a + -- Prim constraint. Though it should be possible to make an instance in + -- the same way as we do in Memory.Array. + , benchPureSink "foldable/foldl'" Ops.foldableFoldl' + , benchPureSink "foldable/sum" Ops.foldableSum +#endif + ] + , bgroup "transformation" + [ benchIOSink "scanl'" (Ops.scanl' 1) + , benchIOSink "scanl1'" (Ops.scanl1' 1) + , benchIOSink "map" (Ops.map 1) + ] + , bgroup "transformationX4" + [ benchIOSink "scanl'" (Ops.scanl' 4) + , benchIOSink "scanl1'" (Ops.scanl1' 4) + , benchIOSink "map" (Ops.map 4) + ] + ] + ] diff --git a/benchmark/Streamly/Benchmark/Data/Prim/ArrayOps.hs b/benchmark/Streamly/Benchmark/Data/Prim/ArrayOps.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Data/Prim/ArrayOps.hs @@ -0,0 +1,153 @@ +-- | +-- Module : Streamly.Benchmark.Data.Prim.ArrayOps +-- Copyright : (c) 2019 Composewell Technologies +-- +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Streamly.Benchmark.Data.Prim.ArrayOps where + +import Control.Monad.IO.Class (MonadIO) +import Prelude (Int, Bool, (+), ($), (==), (>), (.), Maybe(..), undefined) +import qualified Prelude as P +#ifdef DEVBUILD +-- import qualified Data.Foldable as F +#endif + +import qualified Streamly as S hiding (foldMapWith, runStream) +import qualified Streamly.Internal.Data.Prim.Array as A +import qualified Streamly.Prelude as S + +value :: Int +value = 100000 + +------------------------------------------------------------------------------- +-- Benchmark ops +------------------------------------------------------------------------------- + +------------------------------------------------------------------------------- +-- Stream generation and elimination +------------------------------------------------------------------------------- + +type Stream = A.PrimArray + +{-# INLINE sourceUnfoldr #-} +sourceUnfoldr :: MonadIO m => Int -> m (Stream Int) +sourceUnfoldr n = S.fold (A.writeN value) $ S.unfoldr step n + where + step cnt = + if cnt > n + value + then Nothing + else (Just (cnt, cnt + 1)) + +{-# INLINE sourceIntFromTo #-} +sourceIntFromTo :: MonadIO m => Int -> m (Stream Int) +sourceIntFromTo n = S.fold (A.writeN value) $ S.enumerateFromTo n (n + value) + +{-# INLINE sourceIntFromToFromStream #-} +sourceIntFromToFromStream :: MonadIO m => Int -> m (Stream Int) +sourceIntFromToFromStream n = S.fold A.write $ S.enumerateFromTo n (n + value) + +{-# INLINE sourceIntFromToFromList #-} +sourceIntFromToFromList :: MonadIO m => Int -> m (Stream Int) +sourceIntFromToFromList n = P.return $ A.fromList $ [n..n + value] + +{-# INLINE sourceFromList #-} +sourceFromList :: MonadIO m => Int -> m (Stream Int) +sourceFromList n = S.fold (A.writeN value) $ S.fromList [n..n+value] +{- +{-# INLINE sourceIsList #-} +sourceIsList :: Int -> Stream Int +sourceIsList n = GHC.fromList [n..n+value] + +{-# INLINE sourceIsString #-} +sourceIsString :: Int -> Stream P.Char +sourceIsString n = GHC.fromString (P.replicate (n + value) 'a') +-} +------------------------------------------------------------------------------- +-- Transformation +------------------------------------------------------------------------------- + +{-# INLINE composeN #-} +composeN :: P.Monad m + => Int -> (Stream Int -> m (Stream Int)) -> Stream Int -> m (Stream Int) +composeN n f x = + case n of + 1 -> f x + 2 -> f x P.>>= f + 3 -> f x P.>>= f P.>>= f + 4 -> f x P.>>= f P.>>= f P.>>= f + _ -> undefined + +{-# INLINE scanl' #-} +{-# INLINE scanl1' #-} +{-# INLINE map #-} + +scanl', scanl1', map + :: MonadIO m => Int -> Stream Int -> m (Stream Int) + +{-# INLINE onArray #-} +onArray + :: MonadIO m => (S.SerialT m Int -> S.SerialT m Int) + -> Stream Int + -> m (Stream Int) +onArray f arr = S.fold (A.writeN value) $ f $ (S.unfold A.read arr) + +scanl' n = composeN n $ onArray $ S.scanl' (+) 0 +scanl1' n = composeN n $ onArray $ S.scanl1' (+) +map n = composeN n $ onArray $ S.map (+1) + +{-# INLINE eqInstance #-} +eqInstance :: Stream Int -> Bool +eqInstance src = src == src + +{-# INLINE eqInstanceNotEq #-} +eqInstanceNotEq :: Stream Int -> Bool +eqInstanceNotEq src = src P./= src + +{-# INLINE ordInstance #-} +ordInstance :: Stream Int -> Bool +ordInstance src = src P.< src + +{-# INLINE ordInstanceMin #-} +ordInstanceMin :: Stream Int -> Stream Int +ordInstanceMin src = P.min src src + +{-# INLINE showInstance #-} +showInstance :: Stream Int -> P.String +showInstance src = P.show src + +{- +{-# INLINE readInstance #-} +readInstance :: P.String -> Stream Int +readInstance str = + let r = P.reads str + in case r of + [(x,"")] -> x + _ -> P.error "readInstance: no parse" +-} + +{-# INLINE pureFoldl' #-} +pureFoldl' :: MonadIO m => Stream Int -> m Int +pureFoldl' = S.foldl' (+) 0 . S.unfold A.read + +#if 0 +-- PrimArray does not have a Foldable instance because it reuqires a Prim +-- constraint. Though it should be possible to make an instance in the same way +-- as we do in Memory.Array. +{-# INLINE foldableFoldl' #-} +foldableFoldl' :: Stream Int -> Int +foldableFoldl' = F.foldl' (+) 0 + +{-# INLINE foldableSum #-} +foldableSum :: Stream Int -> Int +foldableSum = P.sum +#endif diff --git a/benchmark/Streamly/Benchmark/Data/SmallArray.hs b/benchmark/Streamly/Benchmark/Data/SmallArray.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Data/SmallArray.hs @@ -0,0 +1,95 @@ +-- | +-- Module : Main +-- Copyright : (c) 2019 Composewell Technologies +-- +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +{-# LANGUAGE CPP #-} + +module Main (main) where + +import Control.DeepSeq (NFData(..), deepseq) +import System.Random (randomRIO) + +import qualified Streamly.Benchmark.Data.SmallArrayOps as Ops +import qualified Streamly.Internal.Data.SmallArray as A +import qualified Streamly.Prelude as S + +import Gauge + +------------------------------------------------------------------------------- +-- +------------------------------------------------------------------------------- + +{-# INLINE benchIO #-} +benchIO :: NFData b => String -> (Int -> IO a) -> (a -> b) -> Benchmark +benchIO name src f = bench name $ nfIO $ + randomRIO (1,1) >>= src >>= return . f + +-- Drain a source that generates an array in the IO monad +{-# INLINE benchIOSrc #-} +benchIOSrc :: (NFData a) + => String -> (Int -> IO (Ops.Stream a)) -> Benchmark +benchIOSrc name src = benchIO name src id + +{-# INLINE benchPureSink #-} +benchPureSink :: NFData b => String -> (Ops.Stream Int -> b) -> Benchmark +benchPureSink name f = benchIO name Ops.sourceIntFromTo f + +{-# INLINE benchIO' #-} +benchIO' :: NFData b => String -> (Int -> IO a) -> (a -> IO b) -> Benchmark +benchIO' name src f = bench name $ nfIO $ + randomRIO (1,1) >>= src >>= f + +{-# INLINE benchIOSink #-} +benchIOSink :: NFData b => String -> (Ops.Stream Int -> IO b) -> Benchmark +benchIOSink name f = benchIO' name Ops.sourceIntFromTo f + +mkString :: String +mkString = + "fromListN " ++ + show (Ops.value + 1) ++ " [1" ++ concat (replicate Ops.value ",1") ++ "]" + +main :: IO () +main = + defaultMain + [ bgroup "SmallArray" + [ bgroup "generation" + [ benchIOSrc "writeN . intFromTo" Ops.sourceIntFromTo + , benchIOSrc "fromList . intFromTo" Ops.sourceIntFromToFromList + , benchIOSrc "writeN . unfoldr" Ops.sourceUnfoldr + , benchIOSrc "writeN . fromList" Ops.sourceFromList + , mkString `deepseq` (bench "read" $ nf Ops.readInstance mkString) + , benchPureSink "show" Ops.showInstance + ] + , bgroup "elimination" + [ benchPureSink "id" id + , benchPureSink "==" Ops.eqInstance + , benchPureSink "/=" Ops.eqInstanceNotEq + , benchPureSink "<" Ops.ordInstance + , benchPureSink "min" Ops.ordInstanceMin + -- length is used to check for foldr/build fusion + -- , benchPureSink "length . IsList.toList" (length . GHC.toList) + , benchIOSink "foldl'" Ops.pureFoldl' + , benchIOSink "read" (S.drain . S.unfold A.read) + , benchIOSink "toStreamRev" (S.drain . A.toStreamRev) +#ifdef DEVBUILD + , benchPureSink "foldable/foldl'" Ops.foldableFoldl' + , benchPureSink "foldable/sum" Ops.foldableSum +#endif + ] + , bgroup "transformation" + [ benchIOSink "scanl'" (Ops.scanl' 1) + , benchIOSink "scanl1'" (Ops.scanl1' 1) + , benchIOSink "map" (Ops.map 1) + ] + , bgroup "transformationX4" + [ benchIOSink "scanl'" (Ops.scanl' 4) + , benchIOSink "scanl1'" (Ops.scanl1' 4) + , benchIOSink "map" (Ops.map 4) + ] + ] + ] diff --git a/benchmark/Streamly/Benchmark/Data/SmallArrayOps.hs b/benchmark/Streamly/Benchmark/Data/SmallArrayOps.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Data/SmallArrayOps.hs @@ -0,0 +1,136 @@ +-- | +-- Module : Streamly.Benchmark.Data.SmallArrayOps +-- Copyright : (c) 2019 Composewell Technologies +-- +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Streamly.Benchmark.Data.SmallArrayOps where + +import Control.Monad.IO.Class (MonadIO) +import Prelude (Int, Bool, (+), ($), (==), (>), (.), Maybe(..), undefined) +import qualified Prelude as P +#ifdef DEVBUILD +import qualified Data.Foldable as F +#endif + +import qualified Streamly as S hiding (foldMapWith, runStream) +import qualified Streamly.Internal.Data.SmallArray as A +import qualified Streamly.Prelude as S + +value :: Int +value = 128 + +------------------------------------------------------------------------------- +-- Benchmark ops +------------------------------------------------------------------------------- + +------------------------------------------------------------------------------- +-- Stream generation and elimination +------------------------------------------------------------------------------- + +type Stream = A.SmallArray + +{-# INLINE sourceUnfoldr #-} +sourceUnfoldr :: MonadIO m => Int -> m (Stream Int) +sourceUnfoldr n = S.fold (A.writeN value) $ S.unfoldr step n + where + step cnt = + if cnt > n + value + then Nothing + else (Just (cnt, cnt + 1)) + +{-# INLINE sourceIntFromTo #-} +sourceIntFromTo :: MonadIO m => Int -> m (Stream Int) +sourceIntFromTo n = S.fold (A.writeN value) $ S.enumerateFromTo n (n + value) + +{-# INLINE sourceIntFromToFromList #-} +sourceIntFromToFromList :: MonadIO m => Int -> m (Stream Int) +sourceIntFromToFromList n = P.return $ (A.fromListN value) $ [n..n + value] + +{-# INLINE sourceFromList #-} +sourceFromList :: MonadIO m => Int -> m (Stream Int) +sourceFromList n = S.fold (A.writeN value) $ S.fromList [n..n+value] + +------------------------------------------------------------------------------- +-- Transformation +------------------------------------------------------------------------------- + +{-# INLINE composeN #-} +composeN :: P.Monad m + => Int -> (Stream Int -> m (Stream Int)) -> Stream Int -> m (Stream Int) +composeN n f x = + case n of + 1 -> f x + 2 -> f x P.>>= f + 3 -> f x P.>>= f P.>>= f + 4 -> f x P.>>= f P.>>= f P.>>= f + _ -> undefined + +{-# INLINE scanl' #-} +{-# INLINE scanl1' #-} +{-# INLINE map #-} + +scanl', scanl1', map + :: MonadIO m => Int -> Stream Int -> m (Stream Int) + +{-# INLINE onArray #-} +onArray + :: MonadIO m => (S.SerialT m Int -> S.SerialT m Int) + -> Stream Int + -> m (Stream Int) +onArray f arr = S.fold (A.writeN value) $ f $ (S.unfold A.read arr) + +scanl' n = composeN n $ onArray $ S.scanl' (+) 0 +scanl1' n = composeN n $ onArray $ S.scanl1' (+) +map n = composeN n $ onArray $ S.map (+1) + +{-# INLINE eqInstance #-} +eqInstance :: Stream Int -> Bool +eqInstance src = src == src + +{-# INLINE eqInstanceNotEq #-} +eqInstanceNotEq :: Stream Int -> Bool +eqInstanceNotEq src = src P./= src + +{-# INLINE ordInstance #-} +ordInstance :: Stream Int -> Bool +ordInstance src = src P.< src + +{-# INLINE ordInstanceMin #-} +ordInstanceMin :: Stream Int -> Stream Int +ordInstanceMin src = P.min src src + +{-# INLINE showInstance #-} +showInstance :: Stream Int -> P.String +showInstance src = P.show src + +{-# INLINE readInstance #-} +readInstance :: P.String -> Stream Int +readInstance str = + let r = P.reads str + in case r of + [(x,"")] -> x + _ -> P.error "readInstance: no parse" + +{-# INLINE pureFoldl' #-} +pureFoldl' :: MonadIO m => Stream Int -> m Int +pureFoldl' = S.foldl' (+) 0 . S.unfold A.read + +#ifdef DEVBUILD +{-# INLINE foldableFoldl' #-} +foldableFoldl' :: Stream Int -> Int +foldableFoldl' = F.foldl' (+) 0 + +{-# INLINE foldableSum #-} +foldableSum :: Stream Int -> Int +foldableSum = P.sum +#endif diff --git a/benchmark/Streamly/Benchmark/FileIO/Array.hs b/benchmark/Streamly/Benchmark/FileIO/Array.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/FileIO/Array.hs @@ -0,0 +1,259 @@ +-- | +-- Module : Streamly.Benchmark.FileIO.Array +-- Copyright : (c) 2019 Composewell Technologies +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +{-# LANGUAGE CPP #-} + +#ifdef __HADDOCK_VERSION__ +#undef INSPECTION +#endif + +#ifdef INSPECTION +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-} +#endif + +module Streamly.Benchmark.FileIO.Array + ( + last + , countBytes + , countLines + , countWords + , sumBytes + , cat + , catOnException + , catBracket + , catBracketIO + , catBracketStream + , catBracketStreamIO + , copy + , linesUnlinesCopy + , wordsUnwordsCopy + , decodeUtf8Lenient + , copyCodecUtf8Lenient + ) +where + +import Data.Functor.Identity (runIdentity) +import Data.Word (Word8) +import System.IO (Handle, hClose) +import Prelude hiding (last) + +import qualified Streamly.FileSystem.Handle as FH +import qualified Streamly.Memory.Array as A +import qualified Streamly.Prelude as S +import qualified Streamly.Data.Unicode.Stream as SS +import qualified Streamly.Internal.Data.Unicode.Stream as IUS + +import qualified Streamly.Internal.FileSystem.Handle as IFH +import qualified Streamly.Internal.Memory.Array as IA +import qualified Streamly.Internal.Memory.ArrayStream as AS +import qualified Streamly.Internal.Data.Unfold as IUF +import qualified Streamly.Internal.Prelude as IP + +#ifdef INSPECTION +import Foreign.Storable (Storable) +import Streamly.Internal.Data.Stream.StreamD.Type (Step(..)) +import Test.Inspection +#endif + +-- | Get the last byte from a file bytestream. +{-# INLINE last #-} +last :: Handle -> IO (Maybe Word8) +last inh = do + let s = IFH.toChunks inh + larr <- S.last s + return $ case larr of + Nothing -> Nothing + Just arr -> IA.readIndex arr (A.length arr - 1) + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'last +inspect $ 'last `hasNoType` ''Step +#endif + +-- | Count the number of bytes in a file. +{-# INLINE countBytes #-} +countBytes :: Handle -> IO Int +countBytes inh = + let s = IFH.toChunks inh + in S.sum (S.map A.length s) + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'countBytes +inspect $ 'countBytes `hasNoType` ''Step +#endif + +-- | Count the number of lines in a file. +{-# INLINE countLines #-} +countLines :: Handle -> IO Int +countLines = S.length . AS.splitOnSuffix 10 . IFH.toChunks + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'countLines +inspect $ 'countLines `hasNoType` ''Step +#endif + +-- XXX use a word splitting combinator instead of splitOn and test it. +-- | Count the number of lines in a file. +{-# INLINE countWords #-} +countWords :: Handle -> IO Int +countWords = S.length . AS.splitOn 32 . IFH.toChunks + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'countWords +inspect $ 'countWords `hasNoType` ''Step +#endif + +-- | Sum the bytes in a file. +{-# INLINE sumBytes #-} +sumBytes :: Handle -> IO Word8 +sumBytes inh = do + let foldlArr' f z = runIdentity . S.foldl' f z . IA.toStream + let s = IFH.toChunks inh + S.foldl' (\acc arr -> acc + foldlArr' (+) 0 arr) 0 s + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'sumBytes +inspect $ 'sumBytes `hasNoType` ''Step +#endif + +-- | Send the file contents to /dev/null +{-# INLINE cat #-} +cat :: Handle -> Handle -> IO () +cat devNull inh = + S.fold (IFH.writeChunks devNull) $ IFH.toChunksWithBufferOf (256*1024) inh + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'cat +inspect $ 'cat `hasNoType` ''Step +#endif + +-- | Send the file contents to /dev/null with exception handling +{-# INLINE catBracket #-} +catBracket :: Handle -> Handle -> IO () +catBracket devNull inh = + let readEx = IUF.bracket return (\_ -> hClose inh) + (IUF.supplyFirst FH.readChunksWithBufferOf (256*1024)) + in IUF.fold readEx (IFH.writeChunks devNull) inh + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'catBracket +-- inspect $ 'catBracket `hasNoType` ''Step +#endif + +{-# INLINE catBracketIO #-} +catBracketIO :: Handle -> Handle -> IO () +catBracketIO devNull inh = + let readEx = IUF.bracketIO return (\_ -> hClose inh) + (IUF.supplyFirst FH.readChunksWithBufferOf (256*1024)) + in IUF.fold readEx (IFH.writeChunks devNull) inh + +-- | Send the file contents to /dev/null with exception handling +{-# INLINE catBracketStream #-} +catBracketStream :: Handle -> Handle -> IO () +catBracketStream devNull inh = + let readEx = S.bracket (return ()) (\_ -> hClose inh) + (\_ -> IFH.toChunksWithBufferOf (256*1024) inh) + in S.fold (IFH.writeChunks devNull) $ readEx + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'catBracketStream +-- inspect $ 'catBracketStream `hasNoType` ''Step +#endif + +{-# INLINE catBracketStreamIO #-} +catBracketStreamIO :: Handle -> Handle -> IO () +catBracketStreamIO devNull inh = + let readEx = IP.bracketIO (return ()) (\_ -> hClose inh) + (\_ -> IFH.toChunksWithBufferOf (256*1024) inh) + in S.fold (IFH.writeChunks devNull) $ readEx + +-- | Send the file contents to /dev/null with exception handling +{-# INLINE catOnException #-} +catOnException :: Handle -> Handle -> IO () +catOnException devNull inh = + let readEx = IUF.onException (\_ -> hClose inh) + (IUF.supplyFirst FH.readChunksWithBufferOf (256*1024)) + in IUF.fold readEx (IFH.writeChunks devNull) inh + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'catOnException +-- inspect $ 'catOnException `hasNoType` ''Step +#endif + +-- | Copy file +{-# INLINE copy #-} +copy :: Handle -> Handle -> IO () +copy inh outh = + let s = IFH.toChunks inh + in S.fold (IFH.writeChunks outh) s + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'copy +inspect $ 'copy `hasNoType` ''Step +#endif + +-- | Lines and unlines +{-# INLINE linesUnlinesCopy #-} +linesUnlinesCopy :: Handle -> Handle -> IO () +linesUnlinesCopy inh outh = + S.fold (IFH.writeWithBufferOf (1024*1024) outh) + $ AS.interposeSuffix 10 + $ AS.splitOnSuffix 10 + $ IFH.toChunksWithBufferOf (1024*1024) inh + +#ifdef INSPECTION +inspect $ hasNoTypeClassesExcept 'linesUnlinesCopy [''Storable] +-- inspect $ 'linesUnlinesCopy `hasNoType` ''Step +#endif + +-- | Words and unwords +{-# INLINE wordsUnwordsCopy #-} +wordsUnwordsCopy :: Handle -> Handle -> IO () +wordsUnwordsCopy inh outh = + S.fold (IFH.writeWithBufferOf (1024*1024) outh) + $ AS.interpose 32 + -- XXX this is not correct word splitting combinator + $ AS.splitOn 32 + $ IFH.toChunksWithBufferOf (1024*1024) inh + +#ifdef INSPECTION +inspect $ hasNoTypeClassesExcept 'wordsUnwordsCopy [''Storable] +-- inspect $ 'wordsUnwordsCopy `hasNoType` ''Step +#endif + +{-# INLINE decodeUtf8Lenient #-} +decodeUtf8Lenient :: Handle -> IO () +decodeUtf8Lenient inh = + S.drain + $ IUS.decodeUtf8ArraysLenient + $ IFH.toChunksWithBufferOf (1024*1024) inh + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'decodeUtf8Lenient +-- inspect $ 'decodeUtf8Lenient `hasNoType` ''Step +-- inspect $ 'decodeUtf8Lenient `hasNoType` ''AT.FlattenState +-- inspect $ 'decodeUtf8Lenient `hasNoType` ''D.ConcatMapUState +#endif + +-- | Copy file +{-# INLINE copyCodecUtf8Lenient #-} +copyCodecUtf8Lenient :: Handle -> Handle -> IO () +copyCodecUtf8Lenient inh outh = + S.fold (FH.write outh) + $ SS.encodeUtf8 + $ IUS.decodeUtf8ArraysLenient + $ IFH.toChunksWithBufferOf (1024*1024) inh + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'copyCodecUtf8Lenient +-- inspect $ 'copyCodecUtf8Lenient `hasNoType` ''Step +-- inspect $ 'copyCodecUtf8Lenient `hasNoType` ''AT.FlattenState +-- inspect $ 'copyCodecUtf8Lenient `hasNoType` ''D.ConcatMapUState +#endif diff --git a/benchmark/Streamly/Benchmark/FileIO/Stream.hs b/benchmark/Streamly/Benchmark/FileIO/Stream.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/FileIO/Stream.hs @@ -0,0 +1,651 @@ +-- | +-- Module : Streamly.Benchmark.FileIO.Stream +-- Copyright : (c) 2019 Composewell Technologies +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} + +#ifdef __HADDOCK_VERSION__ +#undef INSPECTION +#endif + +#ifdef INSPECTION +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-} +#endif + +module Streamly.Benchmark.FileIO.Stream + ( + -- * FileIO + last + , countBytes + , countLines + , countLinesU + , countWords + , sumBytes + , cat + , catStreamWrite + , catBracket + , catBracketIO + , catBracketStream + , catBracketStreamIO + , catOnException + , catOnExceptionStream + , catHandle + , catHandleStream + , catFinally + , catFinallyIO + , catFinallyStream + , catFinallyStreamIO + , copy + , linesUnlinesCopy + , linesUnlinesArrayWord8Copy + , linesUnlinesArrayCharCopy + -- , linesUnlinesArrayUtf8Copy + , wordsUnwordsCopyWord8 + , wordsUnwordsCopy + , wordsUnwordsCharArrayCopy + , readWord8 + , decodeLatin1 + , copyCodecChar8 + , copyCodecUtf8 + , decodeUtf8Lax + , copyCodecUtf8Lenient + , chunksOfSum + , chunksOf + , chunksOfD + , splitOn + , splitOnSuffix + , wordsBy + , splitOnSeq + , splitOnSeqUtf8 + , splitOnSuffixSeq + ) +where + +import Control.Exception (SomeException) +import Data.Char (ord, chr) +import Data.Word (Word8) +import System.IO (Handle, hClose) +import Prelude hiding (last, length) + +import qualified Streamly.FileSystem.Handle as FH +import qualified Streamly.Internal.FileSystem.Handle as IFH +import qualified Streamly.Memory.Array as A +-- import qualified Streamly.Internal.Memory.Array as IA +import qualified Streamly.Internal.Memory.Array.Types as AT +import qualified Streamly.Prelude as S +import qualified Streamly.Data.Fold as FL +-- import qualified Streamly.Internal.Data.Fold as IFL +import qualified Streamly.Data.Unicode.Stream as SS +import qualified Streamly.Internal.Data.Unicode.Stream as IUS +import qualified Streamly.Internal.Memory.Unicode.Array as IUA +import qualified Streamly.Internal.Data.Unfold as IUF +import qualified Streamly.Internal.Prelude as IP +import qualified Streamly.Internal.Data.Stream.StreamD as D + +#ifdef INSPECTION +import Foreign.Storable (Storable) +import Streamly.Internal.Data.Stream.StreamD.Type (Step(..), GroupState) +import Test.Inspection +#endif + +-- | Get the last byte from a file bytestream. +{-# INLINE last #-} +last :: Handle -> IO (Maybe Word8) +last = S.last . S.unfold FH.read + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'last +inspect $ 'last `hasNoType` ''Step +inspect $ 'last `hasNoType` ''AT.FlattenState +inspect $ 'last `hasNoType` ''D.ConcatMapUState +#endif + +-- assert that flattenArrays constructors are not present +-- | Count the number of bytes in a file. +{-# INLINE countBytes #-} +countBytes :: Handle -> IO Int +countBytes = S.length . S.unfold FH.read + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'countBytes +inspect $ 'countBytes `hasNoType` ''Step +inspect $ 'countBytes `hasNoType` ''AT.FlattenState +inspect $ 'countBytes `hasNoType` ''D.ConcatMapUState +#endif + +-- | Count the number of lines in a file. +{-# INLINE countLines #-} +countLines :: Handle -> IO Int +countLines = + S.length + . IUS.lines FL.drain + . SS.decodeLatin1 + . S.unfold FH.read + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'countLines +inspect $ 'countLines `hasNoType` ''Step +inspect $ 'countLines `hasNoType` ''AT.FlattenState +inspect $ 'countLines `hasNoType` ''D.ConcatMapUState +#endif + +-- | Count the number of words in a file. +{-# INLINE countWords #-} +countWords :: Handle -> IO Int +countWords = + S.length + . IUS.words FL.drain + . SS.decodeLatin1 + . S.unfold FH.read + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'countWords +-- inspect $ 'countWords `hasNoType` ''Step +-- inspect $ 'countWords `hasNoType` ''D.ConcatMapUState +#endif + +-- | Count the number of lines in a file. +{-# INLINE countLinesU #-} +countLinesU :: Handle -> IO Int +countLinesU inh = + S.length + $ IUS.lines FL.drain + $ SS.decodeLatin1 + $ S.concatUnfold A.read (IFH.toChunks inh) + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'countLinesU +inspect $ 'countLinesU `hasNoType` ''Step +inspect $ 'countLinesU `hasNoType` ''D.ConcatMapUState +#endif + +-- | Sum the bytes in a file. +{-# INLINE sumBytes #-} +sumBytes :: Handle -> IO Word8 +sumBytes = S.sum . S.unfold FH.read + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'sumBytes +inspect $ 'sumBytes `hasNoType` ''Step +inspect $ 'sumBytes `hasNoType` ''AT.FlattenState +inspect $ 'sumBytes `hasNoType` ''D.ConcatMapUState +#endif + +-- | Send the file contents to /dev/null +{-# INLINE cat #-} +cat :: Handle -> Handle -> IO () +cat devNull inh = S.fold (FH.write devNull) $ S.unfold FH.read inh + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'cat +inspect $ 'cat `hasNoType` ''Step +inspect $ 'cat `hasNoType` ''AT.FlattenState +inspect $ 'cat `hasNoType` ''D.ConcatMapUState +#endif + +-- | Send the file contents to /dev/null +{-# INLINE catStreamWrite #-} +catStreamWrite :: Handle -> Handle -> IO () +catStreamWrite devNull inh = IFH.fromBytes devNull $ S.unfold FH.read inh + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'catStreamWrite +inspect $ 'catStreamWrite `hasNoType` ''Step +inspect $ 'catStreamWrite `hasNoType` ''AT.FlattenState +inspect $ 'catStreamWrite `hasNoType` ''D.ConcatMapUState +#endif + +-- | Send the file contents to /dev/null with exception handling +{-# INLINE catBracket #-} +catBracket :: Handle -> Handle -> IO () +catBracket devNull inh = + let readEx = IUF.bracket return (\_ -> hClose inh) FH.read + in S.fold (FH.write devNull) $ S.unfold readEx inh + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'catBracket +-- inspect $ 'catBracket `hasNoType` ''Step +-- inspect $ 'catBracket `hasNoType` ''AT.FlattenState +-- inspect $ 'catBracket `hasNoType` ''D.ConcatMapUState +#endif + +{-# INLINE catBracketIO #-} +catBracketIO :: Handle -> Handle -> IO () +catBracketIO devNull inh = + let readEx = IUF.bracketIO return (\_ -> hClose inh) FH.read + in S.fold (FH.write devNull) $ S.unfold readEx inh + +-- | Send the file contents to /dev/null with exception handling +{-# INLINE catBracketStream #-} +catBracketStream :: Handle -> Handle -> IO () +catBracketStream devNull inh = + let readEx = S.bracket (return ()) (\_ -> hClose inh) + (\_ -> IFH.toBytes inh) + in IFH.fromBytes devNull $ readEx + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'catBracketStream +-- inspect $ 'catBracketStream `hasNoType` ''Step +#endif + +{-# INLINE catBracketStreamIO #-} +catBracketStreamIO :: Handle -> Handle -> IO () +catBracketStreamIO devNull inh = + let readEx = IP.bracketIO (return ()) (\_ -> hClose inh) + (\_ -> IFH.toBytes inh) + in IFH.fromBytes devNull $ readEx + +-- | Send the file contents to /dev/null with exception handling +{-# INLINE catOnException #-} +catOnException :: Handle -> Handle -> IO () +catOnException devNull inh = + let readEx = IUF.onException (\_ -> hClose inh) FH.read + in S.fold (FH.write devNull) $ S.unfold readEx inh + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'catOnException +-- inspect $ 'catOnException `hasNoType` ''Step +-- inspect $ 'catOnException `hasNoType` ''AT.FlattenState +-- inspect $ 'catOnException `hasNoType` ''D.ConcatMapUState +#endif + +-- | Send the file contents to /dev/null with exception handling +{-# INLINE catOnExceptionStream #-} +catOnExceptionStream :: Handle -> Handle -> IO () +catOnExceptionStream devNull inh = + let readEx = S.onException (hClose inh) (S.unfold FH.read inh) + in S.fold (FH.write devNull) $ readEx + +-- | Send the file contents to /dev/null with exception handling +{-# INLINE catFinally #-} +catFinally :: Handle -> Handle -> IO () +catFinally devNull inh = + let readEx = IUF.finally (\_ -> hClose inh) FH.read + in S.fold (FH.write devNull) $ S.unfold readEx inh + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'catFinally +-- inspect $ 'catFinally `hasNoType` ''Step +-- inspect $ 'catFinally `hasNoType` ''AT.FlattenState +-- inspect $ 'catFinally `hasNoType` ''D.ConcatMapUState +#endif + +{-# INLINE catFinallyIO #-} +catFinallyIO :: Handle -> Handle -> IO () +catFinallyIO devNull inh = + let readEx = IUF.finallyIO (\_ -> hClose inh) FH.read + in S.fold (FH.write devNull) $ S.unfold readEx inh + +-- | Send the file contents to /dev/null with exception handling +{-# INLINE catFinallyStream #-} +catFinallyStream :: Handle -> Handle -> IO () +catFinallyStream devNull inh = + let readEx = S.finally (hClose inh) (S.unfold FH.read inh) + in S.fold (FH.write devNull) readEx + +{-# INLINE catFinallyStreamIO #-} +catFinallyStreamIO :: Handle -> Handle -> IO () +catFinallyStreamIO devNull inh = + let readEx = IP.finallyIO (hClose inh) (S.unfold FH.read inh) + in S.fold (FH.write devNull) readEx + +-- | Send the file contents to /dev/null with exception handling +{-# INLINE catHandle #-} +catHandle :: Handle -> Handle -> IO () +catHandle devNull inh = + let handler (_e :: SomeException) = hClose inh >> return 10 + readEx = IUF.handle (IUF.singleton handler) FH.read + in S.fold (FH.write devNull) $ S.unfold readEx inh + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'catHandle +-- inspect $ 'catHandle `hasNoType` ''Step +-- inspect $ 'catHandle `hasNoType` ''AT.FlattenState +-- inspect $ 'catHandle `hasNoType` ''D.ConcatMapUState +#endif + +-- | Send the file contents to /dev/null with exception handling +{-# INLINE catHandleStream #-} +catHandleStream :: Handle -> Handle -> IO () +catHandleStream devNull inh = + let handler (_e :: SomeException) = S.yieldM (hClose inh >> return 10) + readEx = S.handle handler (S.unfold FH.read inh) + in S.fold (FH.write devNull) $ readEx + +-- | Copy file +{-# INLINE copy #-} +copy :: Handle -> Handle -> IO () +copy inh outh = S.fold (FH.write outh) (S.unfold FH.read inh) + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'copy +inspect $ 'copy `hasNoType` ''Step +inspect $ 'copy `hasNoType` ''AT.FlattenState +inspect $ 'copy `hasNoType` ''D.ConcatMapUState +#endif + +{-# INLINE readWord8 #-} +readWord8 :: Handle -> IO () +readWord8 inh = S.drain $ S.unfold FH.read inh + +{-# INLINE decodeLatin1 #-} +decodeLatin1 :: Handle -> IO () +decodeLatin1 inh = + S.drain + $ SS.decodeLatin1 + $ S.unfold FH.read inh + +-- | Copy file +{-# INLINE copyCodecChar8 #-} +copyCodecChar8 :: Handle -> Handle -> IO () +copyCodecChar8 inh outh = + S.fold (FH.write outh) + $ SS.encodeLatin1 + $ SS.decodeLatin1 + $ S.unfold FH.read inh + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'copyCodecChar8 +inspect $ 'copyCodecChar8 `hasNoType` ''Step +inspect $ 'copyCodecChar8 `hasNoType` ''AT.FlattenState +inspect $ 'copyCodecChar8 `hasNoType` ''D.ConcatMapUState +#endif + +{-# INLINE decodeUtf8Lax #-} +decodeUtf8Lax :: Handle -> IO () +decodeUtf8Lax inh = + S.drain + $ SS.decodeUtf8Lax + $ S.unfold FH.read inh + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'decodeUtf8Lax +-- inspect $ 'decodeUtf8Lax `hasNoType` ''Step +-- inspect $ 'decodeUtf8Lax `hasNoType` ''AT.FlattenState +-- inspect $ 'decodeUtf8Lax `hasNoType` ''D.ConcatMapUState +#endif + +-- | Copy file +{-# INLINE copyCodecUtf8 #-} +copyCodecUtf8 :: Handle -> Handle -> IO () +copyCodecUtf8 inh outh = + S.fold (FH.write outh) + $ SS.encodeUtf8 + $ SS.decodeUtf8 + $ S.unfold FH.read inh + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'copyCodecUtf8 +-- inspect $ 'copyCodecUtf8 `hasNoType` ''Step +-- inspect $ 'copyCodecUtf8 `hasNoType` ''AT.FlattenState +-- inspect $ 'copyCodecUtf8 `hasNoType` ''D.ConcatMapUState +#endif + +-- | Copy file +{-# INLINE copyCodecUtf8Lenient #-} +copyCodecUtf8Lenient :: Handle -> Handle -> IO () +copyCodecUtf8Lenient inh outh = + S.fold (FH.write outh) + $ SS.encodeUtf8 + $ SS.decodeUtf8Lax + $ S.unfold FH.read inh + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'copyCodecUtf8Lenient +-- inspect $ 'copyCodecUtf8Lenient `hasNoType` ''Step +-- inspect $ 'copyCodecUtf8Lenient `hasNoType` ''AT.FlattenState +-- inspect $ 'copyCodecUtf8Lenient `hasNoType` ''D.ConcatMapUState +#endif + +{-# INLINE chunksOfSum #-} +chunksOfSum :: Int -> Handle -> IO Int +chunksOfSum n inh = S.length $ S.chunksOf n FL.sum (S.unfold FH.read inh) + +-- | Slice in chunks of size n and get the count of chunks. +{-# INLINE chunksOf #-} +chunksOf :: Int -> Handle -> IO Int +chunksOf n inh = + -- writeNUnsafe gives 2.5x boost here over writeN. + S.length $ S.chunksOf n (AT.writeNUnsafe n) (S.unfold FH.read inh) + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'chunksOf +inspect $ 'chunksOf `hasNoType` ''Step +inspect $ 'chunksOf `hasNoType` ''AT.FlattenState +inspect $ 'chunksOf `hasNoType` ''D.ConcatMapUState +inspect $ 'chunksOf `hasNoType` ''GroupState +#endif + +-- This is to make sure that the concatMap in FH.read, groupsOf and foldlM' +-- together can fuse. +-- +-- | Slice in chunks of size n and get the count of chunks. +{-# INLINE chunksOfD #-} +chunksOfD :: Int -> Handle -> IO Int +chunksOfD n inh = + D.foldlM' (\i _ -> return $ i + 1) 0 + $ D.groupsOf n (AT.writeNUnsafe n) + $ D.fromStreamK (S.unfold FH.read inh) + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'chunksOf +inspect $ 'chunksOf `hasNoType` ''Step +inspect $ 'chunksOfD `hasNoType` ''GroupState +inspect $ 'chunksOfD `hasNoType` ''AT.FlattenState +inspect $ 'chunksOfD `hasNoType` ''D.ConcatMapUState +#endif + +{-# INLINE linesUnlinesCopy #-} +linesUnlinesCopy :: Handle -> Handle -> IO () +linesUnlinesCopy inh outh = + S.fold (FH.write outh) + $ SS.encodeLatin1 + $ IUS.unlines IUF.fromList + $ S.splitOnSuffix (== '\n') FL.toList + $ SS.decodeLatin1 + $ S.unfold FH.read inh + +{-# INLINE linesUnlinesArrayWord8Copy #-} +linesUnlinesArrayWord8Copy :: Handle -> Handle -> IO () +linesUnlinesArrayWord8Copy inh outh = + S.fold (FH.write outh) + $ IP.interposeSuffix 10 A.read + $ S.splitOnSuffix (== 10) A.write + $ S.unfold FH.read inh + +-- XXX splitSuffixOn requires -funfolding-use-threshold=150 for better fusion +-- | Lines and unlines +{-# INLINE linesUnlinesArrayCharCopy #-} +linesUnlinesArrayCharCopy :: Handle -> Handle -> IO () +linesUnlinesArrayCharCopy inh outh = + S.fold (FH.write outh) + $ SS.encodeLatin1 + $ IUA.unlines + $ IUA.lines + $ SS.decodeLatin1 + $ S.unfold FH.read inh + +#ifdef INSPECTION +inspect $ hasNoTypeClassesExcept 'linesUnlinesArrayCharCopy [''Storable] +-- inspect $ 'linesUnlinesArrayCharCopy `hasNoType` ''Step +-- inspect $ 'linesUnlinesArrayCharCopy `hasNoType` ''AT.FlattenState +-- inspect $ 'linesUnlinesArrayCharCopy `hasNoType` ''D.ConcatMapUState +#endif + +-- XXX to write this we need to be able to map decodeUtf8 on the A.read fold. +-- For that we have to write decodeUtf8 as a Pipe. +{- +{-# INLINE linesUnlinesArrayUtf8Copy #-} +linesUnlinesArrayUtf8Copy :: Handle -> Handle -> IO () +linesUnlinesArrayUtf8Copy inh outh = + S.fold (FH.write outh) + $ SS.encodeLatin1 + $ IP.intercalate (A.fromList [10]) (pipe SS.decodeUtf8P A.read) + $ S.splitOnSuffix (== '\n') (IFL.lmap SS.encodeUtf8 A.write) + $ SS.decodeLatin1 + $ S.unfold FH.read inh +-} + +foreign import ccall unsafe "u_iswspace" + iswspace :: Int -> Int + +-- Code copied from base/Data.Char to INLINE it +{-# INLINE isSpace #-} +isSpace :: Char -> Bool +-- isSpace includes non-breaking space +-- The magic 0x377 isn't really that magical. As of 2014, all the codepoints +-- at or below 0x377 have been assigned, so we shouldn't have to worry about +-- any new spaces appearing below there. It would probably be best to +-- use branchless ||, but currently the eqLit transformation will undo that, +-- so we'll do it like this until there's a way around that. +isSpace c + | uc <= 0x377 = uc == 32 || uc - 0x9 <= 4 || uc == 0xa0 + | otherwise = iswspace (ord c) /= 0 + where + uc = fromIntegral (ord c) :: Word + +{-# INLINE isSp #-} +isSp :: Word8 -> Bool +isSp = isSpace . chr . fromIntegral + +-- | Word, unwords and copy +{-# INLINE wordsUnwordsCopyWord8 #-} +wordsUnwordsCopyWord8 :: Handle -> Handle -> IO () +wordsUnwordsCopyWord8 inh outh = + S.fold (FH.write outh) + $ IP.interposeSuffix 32 IUF.fromList + $ S.wordsBy isSp FL.toList + $ S.unfold FH.read inh + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'wordsUnwordsCopyWord8 +-- inspect $ 'wordsUnwordsCopyWord8 `hasNoType` ''Step +-- inspect $ 'wordsUnwordsCopyWord8 `hasNoType` ''D.ConcatMapUState +#endif + +-- | Word, unwords and copy +{-# INLINE wordsUnwordsCopy #-} +wordsUnwordsCopy :: Handle -> Handle -> IO () +wordsUnwordsCopy inh outh = + S.fold (FH.write outh) + $ SS.encodeLatin1 + $ IUS.unwords IUF.fromList + -- XXX This pipeline does not fuse with wordsBy but fuses with splitOn + -- with -funfolding-use-threshold=300. With wordsBy it does not fuse + -- even with high limits for inlining and spec-constr ghc options. With + -- -funfolding-use-threshold=400 it performs pretty well and there + -- is no evidence in the core that a join point involving Step + -- constructors is not getting inlined. Not being able to fuse at all in + -- this case could be an unknown issue, need more investigation. + $ S.wordsBy isSpace FL.toList + -- -- $ S.splitOn isSpace FL.toList + $ SS.decodeLatin1 + $ S.unfold FH.read inh + +#ifdef INSPECTION +-- inspect $ hasNoTypeClasses 'wordsUnwordsCopy +-- inspect $ 'wordsUnwordsCopy `hasNoType` ''Step +-- inspect $ 'wordsUnwordsCopy `hasNoType` ''AT.FlattenState +-- inspect $ 'wordsUnwordsCopy `hasNoType` ''D.ConcatMapUState +#endif + +{-# INLINE wordsUnwordsCharArrayCopy #-} +wordsUnwordsCharArrayCopy :: Handle -> Handle -> IO () +wordsUnwordsCharArrayCopy inh outh = + S.fold (FH.write outh) + $ SS.encodeLatin1 + $ IUA.unwords + $ IUA.words + $ SS.decodeLatin1 + $ S.unfold FH.read inh + +lf :: Word8 +lf = fromIntegral (ord '\n') + +toarr :: String -> A.Array Word8 +toarr = A.fromList . map (fromIntegral . ord) + +-- | Split on line feed. +{-# INLINE splitOn #-} +splitOn :: Handle -> IO Int +splitOn inh = + (S.length $ S.splitOn (== lf) FL.drain + $ S.unfold FH.read inh) -- >>= print + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'splitOn +inspect $ 'splitOn `hasNoType` ''Step +inspect $ 'splitOn `hasNoType` ''AT.FlattenState +inspect $ 'splitOn `hasNoType` ''D.ConcatMapUState +#endif + +-- | Split suffix on line feed. +{-# INLINE splitOnSuffix #-} +splitOnSuffix :: Handle -> IO Int +splitOnSuffix inh = + (S.length $ S.splitOnSuffix (== lf) FL.drain + $ S.unfold FH.read inh) -- >>= print + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'splitOnSuffix +inspect $ 'splitOnSuffix `hasNoType` ''Step +inspect $ 'splitOnSuffix `hasNoType` ''AT.FlattenState +inspect $ 'splitOnSuffix `hasNoType` ''D.ConcatMapUState +#endif + +-- | Words by space +{-# INLINE wordsBy #-} +wordsBy :: Handle -> IO Int +wordsBy inh = + (S.length $ S.wordsBy isSp FL.drain + $ S.unfold FH.read inh) -- >>= print + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'wordsBy +inspect $ 'wordsBy `hasNoType` ''Step +inspect $ 'wordsBy `hasNoType` ''AT.FlattenState +inspect $ 'wordsBy `hasNoType` ''D.ConcatMapUState +#endif + +-- | Split on a word8 sequence. +{-# INLINE splitOnSeq #-} +splitOnSeq :: String -> Handle -> IO Int +splitOnSeq str inh = + (S.length $ IP.splitOnSeq (toarr str) FL.drain + $ S.unfold FH.read inh) -- >>= print + +#ifdef INSPECTION +-- inspect $ hasNoTypeClasses 'splitOnSeq +-- inspect $ 'splitOnSeq `hasNoType` ''Step +-- inspect $ 'splitOnSeq `hasNoType` ''AT.FlattenState +-- inspect $ 'splitOnSeq `hasNoType` ''D.ConcatMapUState +#endif + +-- | Split on a character sequence. +{-# INLINE splitOnSeqUtf8 #-} +splitOnSeqUtf8 :: String -> Handle -> IO Int +splitOnSeqUtf8 str inh = + (S.length $ IP.splitOnSeq (A.fromList str) FL.drain + $ IUS.decodeUtf8ArraysLenient + $ IFH.toChunks inh) -- >>= print + +-- | Split on suffix sequence. +{-# INLINE splitOnSuffixSeq #-} +splitOnSuffixSeq :: String -> Handle -> IO Int +splitOnSuffixSeq str inh = + (S.length $ IP.splitOnSuffixSeq (toarr str) FL.drain + $ S.unfold FH.read inh) -- >>= print + +#ifdef INSPECTION +-- inspect $ hasNoTypeClasses 'splitOnSuffixSeq +-- inspect $ 'splitOnSuffixSeq `hasNoType` ''Step +-- inspect $ 'splitOnSuffixSeq `hasNoType` ''AT.FlattenState +-- inspect $ 'splitOnSuffixSeq `hasNoType` ''D.ConcatMapUState +#endif diff --git a/benchmark/Streamly/Benchmark/Prelude.hs b/benchmark/Streamly/Benchmark/Prelude.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Prelude.hs @@ -0,0 +1,1202 @@ +-- | +-- Module : Streamly.Benchmark.Prelude +-- Copyright : (c) 2018 Harendra Kumar +-- +-- License : MIT +-- Maintainer : streamly@composewell.com + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RankNTypes #-} + +#ifdef __HADDOCK_VERSION__ +#undef INSPECTION +#endif + +#ifdef INSPECTION +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-} +#endif + +module Streamly.Benchmark.Prelude where + +import Control.DeepSeq (NFData) +import Control.Monad (when) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.State.Strict (StateT, get, put) +import Data.Functor.Identity (Identity, runIdentity) +import Data.IORef (newIORef, modifyIORef') +import GHC.Generics (Generic) +import Prelude + (Monad, Int, (+), ($), (.), return, fmap, even, (>), (<=), (==), (>=), + subtract, undefined, Maybe(..), odd, Bool, not, (>>=), mapM_, curry, + maxBound, div, IO, compare, Double, fromIntegral, Integer, (<$>), + (<*>), flip) +import qualified Prelude as P +import qualified Data.Foldable as F +import qualified GHC.Exts as GHC + +#ifdef INSPECTION +import Test.Inspection + +import qualified Streamly.Internal.Data.Stream.StreamD as D +#endif + +import qualified Streamly as S hiding (runStream) +import qualified Streamly.Prelude as S +import qualified Streamly.Internal.Prelude as Internal +import qualified Streamly.Internal.Data.Fold as FL +import qualified Streamly.Internal.Data.Unfold as UF +import qualified Streamly.Internal.Data.Pipe as Pipe +import qualified Streamly.Internal.Data.Stream.Parallel as Par +import Streamly.Internal.Data.Time.Units + +type Stream m a = S.SerialT m a + +------------------------------------------------------------------------------- +-- Stream generation +------------------------------------------------------------------------------- + +-- enumerate + +{-# INLINE sourceIntFromTo #-} +sourceIntFromTo :: (Monad m, S.IsStream t) => Int -> Int -> t m Int +sourceIntFromTo value n = S.enumerateFromTo n (n + value) + +{-# INLINE sourceIntFromThenTo #-} +sourceIntFromThenTo :: (Monad m, S.IsStream t) => Int -> Int -> t m Int +sourceIntFromThenTo value n = S.enumerateFromThenTo n (n + 1) (n + value) + +{-# INLINE sourceFracFromTo #-} +sourceFracFromTo :: (Monad m, S.IsStream t) => Int -> Int -> t m Double +sourceFracFromTo value n = + S.enumerateFromTo (fromIntegral n) (fromIntegral (n + value)) + +{-# INLINE sourceFracFromThenTo #-} +sourceFracFromThenTo :: (Monad m, S.IsStream t) => Int -> Int -> t m Double +sourceFracFromThenTo value n = S.enumerateFromThenTo (fromIntegral n) + (fromIntegral n + 1.0001) (fromIntegral (n + value)) + +{-# INLINE sourceIntegerFromStep #-} +sourceIntegerFromStep :: (Monad m, S.IsStream t) => Int -> Int -> t m Integer +sourceIntegerFromStep value n = + S.take value $ S.enumerateFromThen (fromIntegral n) (fromIntegral n + 1) + +-- unfoldr + +{-# INLINE sourceUnfoldr #-} +sourceUnfoldr :: (Monad m, S.IsStream t) => Int -> Int -> t m Int +sourceUnfoldr value n = S.unfoldr step n + where + step cnt = + if cnt > n + value + then Nothing + else Just (cnt, cnt + 1) + +{-# INLINE sourceUnfoldrN #-} +sourceUnfoldrN :: (Monad m, S.IsStream t) => Int -> Int -> t m Int +sourceUnfoldrN upto start = S.unfoldr step start + where + step cnt = + if cnt > start + upto + then Nothing + else Just (cnt, cnt + 1) + +{-# INLINE sourceUnfoldrM #-} +sourceUnfoldrM :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m Int +sourceUnfoldrM value n = S.unfoldrM step n + where + step cnt = + if cnt > n + value + then return Nothing + else return (Just (cnt, cnt + 1)) + +{-# INLINE source #-} +source :: (S.MonadAsync m, S.IsStream t) => Int -> Int -> t m Int +source = sourceUnfoldrM + +{-# INLINE sourceUnfoldrMN #-} +sourceUnfoldrMN :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m Int +sourceUnfoldrMN upto start = S.unfoldrM step start + where + step cnt = + if cnt > start + upto + then return Nothing + else return (Just (cnt, cnt + 1)) + +{-# INLINE sourceUnfoldrMAction #-} +sourceUnfoldrMAction :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m (m Int) +sourceUnfoldrMAction value n = S.serially $ S.unfoldrM step n + where + step cnt = + if cnt > n + value + then return Nothing + else return (Just (return cnt, cnt + 1)) + +{-# INLINE sourceUnfoldrAction #-} +sourceUnfoldrAction :: (S.IsStream t, Monad m, Monad m1) + => Int -> Int -> t m (m1 Int) +sourceUnfoldrAction value n = S.serially $ S.unfoldr step n + where + step cnt = + if cnt > n + value + then Nothing + else (Just (return cnt, cnt + 1)) + +-- fromIndices + +{-# INLINE sourceFromIndices #-} +sourceFromIndices :: (Monad m, S.IsStream t) => Int -> Int -> t m Int +sourceFromIndices value n = S.take value $ S.fromIndices (+ n) + +{-# INLINE sourceFromIndicesM #-} +sourceFromIndicesM :: (S.MonadAsync m, S.IsStream t) => Int -> Int -> t m Int +sourceFromIndicesM value n = S.take value $ S.fromIndicesM (Prelude.fmap return (+ n)) + +-- fromList + +{-# INLINE sourceFromList #-} +sourceFromList :: (Monad m, S.IsStream t) => Int -> Int -> t m Int +sourceFromList value n = S.fromList [n..n+value] + +{-# INLINE sourceFromListM #-} +sourceFromListM :: (S.MonadAsync m, S.IsStream t) => Int -> Int -> t m Int +sourceFromListM value n = S.fromListM (Prelude.fmap return [n..n+value]) + +{-# INLINE sourceIsList #-} +sourceIsList :: Int -> Int -> S.SerialT Identity Int +sourceIsList value n = GHC.fromList [n..n+value] + +{-# INLINE sourceIsString #-} +sourceIsString :: Int -> Int -> S.SerialT Identity P.Char +sourceIsString value n = GHC.fromString (P.replicate (n + value) 'a') + +-- fromFoldable + +{-# INLINE sourceFromFoldable #-} +sourceFromFoldable :: S.IsStream t => Int -> Int -> t m Int +sourceFromFoldable value n = S.fromFoldable [n..n+value] + +{-# INLINE sourceFromFoldableM #-} +sourceFromFoldableM :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m Int +sourceFromFoldableM value n = S.fromFoldableM (Prelude.fmap return [n..n+value]) + +{-# INLINE currentTime #-} +currentTime :: (S.IsStream t, S.MonadAsync m) + => Int -> Double -> Int -> t m AbsTime +currentTime value g _ = S.take value $ Internal.currentTime g + +------------------------------------------------------------------------------- +-- Elimination +------------------------------------------------------------------------------- + +{-# INLINE runStream #-} +runStream :: Monad m => Stream m a -> m () +runStream = S.drain + +{-# INLINE toList #-} +toList :: Monad m => Stream m Int -> m [Int] + +{-# INLINE head #-} +{-# INLINE last #-} +{-# INLINE maximum #-} +{-# INLINE minimum #-} +{-# INLINE find #-} +{-# INLINE findIndex #-} +{-# INLINE elemIndex #-} +{-# INLINE foldl1'Reduce #-} +head, last, minimum, maximum, foldl1'Reduce + :: Monad m => Stream m Int -> m (Maybe Int) + +find, findIndex, elemIndex + :: Monad m => Int -> Stream m Int -> m (Maybe Int) + +{-# INLINE minimumBy #-} +{-# INLINE maximumBy #-} +minimumBy, maximumBy :: Monad m => Stream m Int -> m (Maybe Int) + +{-# INLINE foldl'Reduce #-} +{-# INLINE foldl'ReduceMap #-} +{-# INLINE foldlM'Reduce #-} +{-# INLINE foldrMReduce #-} +{-# INLINE length #-} +{-# INLINE sum #-} +{-# INLINE product #-} +foldl'Reduce, foldl'ReduceMap, foldlM'Reduce, foldrMReduce, length, sum, product + :: Monad m + => Stream m Int -> m Int + +{-# INLINE foldl'Build #-} +{-# INLINE foldlM'Build #-} +{-# INLINE foldrMBuild #-} +foldrMBuild, foldl'Build, foldlM'Build + :: Monad m + => Stream m Int -> m [Int] + +{-# INLINE all #-} +{-# INLINE any #-} +{-# INLINE and #-} +{-# INLINE or #-} +{-# INLINE null #-} +{-# INLINE elem #-} +{-# INLINE notElem #-} +null :: Monad m => Stream m Int -> m Bool + +elem, notElem, all, any, and, or :: Monad m => Int -> Stream m Int -> m Bool + +{-# INLINE toNull #-} +toNull :: Monad m => (t m a -> S.SerialT m a) -> t m a -> m () +toNull t = runStream . t + +{-# INLINE uncons #-} +uncons :: Monad m => Stream m Int -> m () +uncons s = do + r <- S.uncons s + case r of + Nothing -> return () + Just (_, t) -> uncons t + +{-# INLINE init #-} +init :: Monad m => Stream m a -> m () +init s = S.init s >>= Prelude.mapM_ S.drain + +{-# INLINE tail #-} +tail :: Monad m => Stream m a -> m () +tail s = S.tail s >>= Prelude.mapM_ tail + +{-# INLINE nullHeadTail #-} +nullHeadTail :: Monad m => Stream m Int -> m () +nullHeadTail s = do + r <- S.null s + when (not r) $ do + _ <- S.head s + S.tail s >>= Prelude.mapM_ nullHeadTail + +{-# INLINE mapM_ #-} +mapM_ :: Monad m => Stream m Int -> m () +mapM_ = S.mapM_ (\_ -> return ()) + +toList = S.toList + +{-# INLINE toListRev #-} +toListRev :: Monad m => Stream m Int -> m [Int] +toListRev = Internal.toListRev + +{-# INLINE foldrMElem #-} +foldrMElem :: Monad m => Int -> Stream m Int -> m Bool +foldrMElem e m = S.foldrM (\x xs -> if x == e then return P.True else xs) + (return P.False) m + +{-# INLINE foldrMToStream #-} +foldrMToStream :: Monad m => Stream m Int -> m (Stream Identity Int) +foldrMToStream = S.foldr S.cons S.nil + +foldrMBuild = S.foldrM (\x xs -> xs >>= return . (x :)) (return []) +foldl'Build = S.foldl' (flip (:)) [] +foldlM'Build = S.foldlM' (\xs x -> return $ x : xs) [] + +foldrMReduce = S.foldrM (\x xs -> xs >>= return . (x +)) (return 0) +foldl'Reduce = S.foldl' (+) 0 +foldl'ReduceMap = P.fmap (+1) . S.foldl' (+) 0 +foldl1'Reduce = S.foldl1' (+) +foldlM'Reduce = S.foldlM' (\xs a -> return $ a + xs) 0 + +last = S.last +null = S.null +head = S.head +elem value = S.elem (value + 1) +notElem value = S.notElem (value + 1) +length = S.length +all value = S.all (<= (value + 1)) +any value = S.any (> (value + 1)) +and value = S.and . S.map (<= (value + 1)) +or value = S.or . S.map (> (value + 1)) +find value = S.find (== (value + 1)) +findIndex value = S.findIndex (== (value + 1)) +elemIndex value = S.elemIndex (value + 1) +maximum = S.maximum +minimum = S.minimum +sum = S.sum +product = S.product +minimumBy = S.minimumBy compare +maximumBy = S.maximumBy compare + +------------------------------------------------------------------------------- +-- Transformation +------------------------------------------------------------------------------- + +{-# INLINE transform #-} +transform :: Monad m => Stream m a -> m () +transform = runStream + +{-# INLINE composeN #-} +composeN + :: MonadIO m + => Int -> (Stream m Int -> Stream m Int) -> Stream m Int -> m () +composeN n f = + case n of + 1 -> transform . f + 2 -> transform . f . f + 3 -> transform . f . f . f + 4 -> transform . f . f . f . f + _ -> undefined + +-- polymorphic stream version of composeN +{-# INLINE composeN' #-} +composeN' + :: (S.IsStream t, Monad m) + => Int -> (t m Int -> Stream m Int) -> t m Int -> m () +composeN' n f = + case n of + 1 -> transform . f + 2 -> transform . f . S.adapt . f + 3 -> transform . f . S.adapt . f . S.adapt . f + 4 -> transform . f . S.adapt . f . S.adapt . f . S.adapt . f + _ -> undefined + +{-# INLINE scan #-} +{-# INLINE scanl1' #-} +{-# INLINE map #-} +{-# INLINE fmap #-} +{-# INLINE mapMaybe #-} +{-# INLINE filterEven #-} +{-# INLINE filterAllOut #-} +{-# INLINE filterAllIn #-} +{-# INLINE takeOne #-} +{-# INLINE takeAll #-} +{-# INLINE takeWhileTrue #-} +{-# INLINE takeWhileMTrue #-} +{-# INLINE dropOne #-} +{-# INLINE dropAll #-} +{-# INLINE dropWhileTrue #-} +{-# INLINE dropWhileMTrue #-} +{-# INLINE dropWhileFalse #-} +{-# INLINE findIndices #-} +{-# INLINE elemIndices #-} +{-# INLINE insertBy #-} +{-# INLINE deleteBy #-} +{-# INLINE reverse #-} +{-# INLINE reverse' #-} +{-# INLINE foldrS #-} +{-# INLINE foldrSMap #-} +{-# INLINE foldrT #-} +{-# INLINE foldrTMap #-} +scan, scanl1', map, fmap, mapMaybe, filterEven, + takeOne, dropOne, + reverse, reverse', + foldrS, foldrSMap, foldrT, foldrTMap + :: MonadIO m + => Int -> Stream m Int -> m () + +filterAllOut, + filterAllIn, takeAll, takeWhileTrue, takeWhileMTrue, + dropAll, dropWhileTrue, dropWhileMTrue, dropWhileFalse, + findIndices, elemIndices, insertBy, deleteBy + :: MonadIO m + => Int -> Int -> Stream m Int -> m () + +{-# INLINE mapMaybeM #-} +{-# INLINE intersperse #-} +mapMaybeM :: S.MonadAsync m => Int -> Stream m Int -> m () +intersperse :: S.MonadAsync m => Int -> Int -> Stream m Int -> m () + +{-# INLINE mapM #-} +{-# INLINE map' #-} +{-# INLINE fmap' #-} +mapM, map' :: (S.IsStream t, S.MonadAsync m) + => (t m Int -> S.SerialT m Int) -> Int -> t m Int -> m () + +fmap' :: (S.IsStream t, S.MonadAsync m, P.Functor (t m)) + => (t m Int -> S.SerialT m Int) -> Int -> t m Int -> m () + +{-# INLINE sequence #-} +sequence :: (S.IsStream t, S.MonadAsync m) + => (t m Int -> S.SerialT m Int) -> t m (m Int) -> m () + +scan n = composeN n $ S.scanl' (+) 0 +scanl1' n = composeN n $ S.scanl1' (+) +fmap n = composeN n $ Prelude.fmap (+1) +fmap' t n = composeN' n $ t . Prelude.fmap (+1) +map n = composeN n $ S.map (+1) +map' t n = composeN' n $ t . S.map (+1) +mapM t n = composeN' n $ t . S.mapM return + +{-# INLINE tap #-} +tap :: MonadIO m => Int -> Stream m Int -> m () +tap n = composeN n $ S.tap FL.sum + +{-# INLINE tapRate #-} +tapRate :: Int -> Stream IO Int -> IO () +tapRate n str = do + cref <- newIORef 0 + composeN n (Internal.tapRate 1 (\c -> modifyIORef' cref (c +))) str + +{-# INLINE pollCounts #-} +pollCounts :: Int -> Stream IO Int -> IO () +pollCounts n str = do + composeN n (Internal.pollCounts (P.const P.True) f FL.drain) str + where f = Internal.rollingMap (P.-) . Internal.delayPost 1 + +{-# INLINE tapAsyncS #-} +tapAsyncS :: S.MonadAsync m => Int -> Stream m Int -> m () +tapAsyncS n = composeN n $ Par.tapAsync S.sum + +{-# INLINE tapAsync #-} +tapAsync :: S.MonadAsync m => Int -> Stream m Int -> m () +tapAsync n = composeN n $ Internal.tapAsync FL.sum + +mapMaybe n = composeN n $ S.mapMaybe + (\x -> if Prelude.odd x then Nothing else Just x) +mapMaybeM n = composeN n $ S.mapMaybeM + (\x -> if Prelude.odd x then return Nothing else return $ Just x) +sequence t = transform . t . S.sequence +filterEven n = composeN n $ S.filter even +filterAllOut value n = composeN n $ S.filter (> (value + 1)) +filterAllIn value n = composeN n $ S.filter (<= (value + 1)) +takeOne n = composeN n $ S.take 1 +takeAll value n = composeN n $ S.take (value + 1) +takeWhileTrue value n = composeN n $ S.takeWhile (<= (value + 1)) +takeWhileMTrue value n = composeN n $ S.takeWhileM (return . (<= (value + 1))) +dropOne n = composeN n $ S.drop 1 +dropAll value n = composeN n $ S.drop (value + 1) +dropWhileTrue value n = composeN n $ S.dropWhile (<= (value + 1)) +dropWhileMTrue value n = composeN n $ S.dropWhileM (return . (<= (value + 1))) +dropWhileFalse value n = composeN n $ S.dropWhile (> (value + 1)) +findIndices value n = composeN n $ S.findIndices (== (value + 1)) +elemIndices value n = composeN n $ S.elemIndices (value + 1) +intersperse value n = composeN n $ S.intersperse (value + 1) +insertBy value n = composeN n $ S.insertBy compare (value + 1) +deleteBy value n = composeN n $ S.deleteBy (>=) (value + 1) +reverse n = composeN n $ S.reverse +reverse' n = composeN n $ Internal.reverse' +foldrS n = composeN n $ Internal.foldrS S.cons S.nil +foldrSMap n = composeN n $ Internal.foldrS (\x xs -> x + 1 `S.cons` xs) S.nil +foldrT n = composeN n $ Internal.foldrT S.cons S.nil +foldrTMap n = composeN n $ Internal.foldrT (\x xs -> x + 1 `S.cons` xs) S.nil + +{-# INLINE takeByTime #-} +takeByTime :: NanoSecond64 -> Int -> Stream IO Int -> IO () +takeByTime i n = composeN n (Internal.takeByTime i) + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'takeByTime +-- inspect $ 'takeByTime `hasNoType` ''D.Step +#endif + +{-# INLINE dropByTime #-} +dropByTime :: NanoSecond64 -> Int -> Stream IO Int -> IO () +dropByTime i n = composeN n (Internal.dropByTime i) + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'dropByTime +-- inspect $ 'dropByTime `hasNoType` ''D.Step +#endif + +------------------------------------------------------------------------------- +-- Pipes +------------------------------------------------------------------------------- + +{-# INLINE transformMapM #-} +{-# INLINE transformComposeMapM #-} +{-# INLINE transformTeeMapM #-} +{-# INLINE transformZipMapM #-} + +transformMapM, transformComposeMapM, transformTeeMapM, + transformZipMapM :: (S.IsStream t, S.MonadAsync m) + => (t m Int -> S.SerialT m Int) -> Int -> t m Int -> m () + +transformMapM t n = composeN' n $ t . Internal.transform (Pipe.mapM return) +transformComposeMapM t n = composeN' n $ t . Internal.transform + (Pipe.mapM (\x -> return (x + 1)) + `Pipe.compose` Pipe.mapM (\x -> return (x + 2))) +transformTeeMapM t n = composeN' n $ t . Internal.transform + (Pipe.mapM (\x -> return (x + 1)) + `Pipe.tee` Pipe.mapM (\x -> return (x + 2))) +transformZipMapM t n = composeN' n $ t . Internal.transform + (Pipe.zipWith (+) (Pipe.mapM (\x -> return (x + 1))) + (Pipe.mapM (\x -> return (x + 2)))) + +------------------------------------------------------------------------------- +-- Mixed Transformation +------------------------------------------------------------------------------- + +{-# INLINE scanMap #-} +{-# INLINE dropMap #-} +{-# INLINE dropScan #-} +{-# INLINE takeDrop #-} +{-# INLINE takeScan #-} +{-# INLINE takeMap #-} +{-# INLINE filterDrop #-} +{-# INLINE filterTake #-} +{-# INLINE filterScan #-} +{-# INLINE filterScanl1 #-} +{-# INLINE filterMap #-} +scanMap, dropMap, dropScan, + filterScan, filterScanl1 + :: MonadIO m => Int -> Stream m Int -> m () + +takeDrop, takeScan, takeMap, filterDrop, + filterTake, filterMap + :: MonadIO m => Int -> Int -> Stream m Int -> m () + +scanMap n = composeN n $ S.map (subtract 1) . S.scanl' (+) 0 +dropMap n = composeN n $ S.map (subtract 1) . S.drop 1 +dropScan n = composeN n $ S.scanl' (+) 0 . S.drop 1 +takeDrop value n = composeN n $ S.drop 1 . S.take (value + 1) +takeScan value n = composeN n $ S.scanl' (+) 0 . S.take (value + 1) +takeMap value n = composeN n $ S.map (subtract 1) . S.take (value + 1) +filterDrop value n = composeN n $ S.drop 1 . S.filter (<= (value + 1)) +filterTake value n = composeN n $ S.take (value + 1) . S.filter (<= (value + 1)) +filterScan n = composeN n $ S.scanl' (+) 0 . S.filter (<= maxBound) +filterScanl1 n = composeN n $ S.scanl1' (+) . S.filter (<= maxBound) +filterMap value n = composeN n $ S.map (subtract 1) . S.filter (<= (value + 1)) + +------------------------------------------------------------------------------- +-- Scan and fold +------------------------------------------------------------------------------- + +data Pair a b = Pair !a !b deriving (Generic, NFData) + +{-# INLINE sumProductFold #-} +sumProductFold :: Monad m => Stream m Int -> m (Int, Int) +sumProductFold = S.foldl' (\(s,p) x -> (s + x, p P.* x)) (0,1) + +{-# INLINE sumProductScan #-} +sumProductScan :: Monad m => Stream m Int -> m (Pair Int Int) +sumProductScan = S.foldl' (\(Pair _ p) (s0,x) -> Pair s0 (p P.* x)) (Pair 0 1) + . S.scanl' (\(s,_) x -> (s + x,x)) (0,0) + +------------------------------------------------------------------------------- +-- Iteration +------------------------------------------------------------------------------- + +iterStreamLen, maxIters :: Int +iterStreamLen = 10 +maxIters = 10000 + +{-# INLINE iterateSource #-} +iterateSource + :: S.MonadAsync m + => (Stream m Int -> Stream m Int) -> Int -> Int -> Stream m Int +iterateSource g i n = f i (sourceUnfoldrMN iterStreamLen n) + where + f (0 :: Int) m = g m + f x m = g (f (x P.- 1) m) + +{-# INLINE iterateMapM #-} +{-# INLINE iterateScan #-} +{-# INLINE iterateScanl1 #-} +{-# INLINE iterateFilterEven #-} +{-# INLINE iterateTakeAll #-} +{-# INLINE iterateDropOne #-} +{-# INLINE iterateDropWhileFalse #-} +{-# INLINE iterateDropWhileTrue #-} +iterateMapM, iterateScan, iterateScanl1, iterateFilterEven, + iterateDropOne + :: S.MonadAsync m + => Int -> Stream m Int + +iterateTakeAll, + iterateDropWhileFalse, iterateDropWhileTrue + :: S.MonadAsync m + => Int -> Int -> Stream m Int + +-- this is quadratic +iterateScan = iterateSource (S.scanl' (+) 0) (maxIters `div` 10) +-- so is this +iterateScanl1 = iterateSource (S.scanl1' (+)) (maxIters `div` 10) + +iterateMapM = iterateSource (S.mapM return) maxIters +iterateFilterEven = iterateSource (S.filter even) maxIters +iterateTakeAll value = iterateSource (S.take (value + 1)) maxIters +iterateDropOne = iterateSource (S.drop 1) maxIters +iterateDropWhileFalse value = iterateSource (S.dropWhile (> (value + 1))) maxIters +iterateDropWhileTrue value = iterateSource (S.dropWhile (<= (value + 1))) maxIters + +------------------------------------------------------------------------------- +-- Combining streams +------------------------------------------------------------------------------- + +------------------------------------------------------------------------------- +-- Appending +------------------------------------------------------------------------------- + +{-# INLINE serial2 #-} +serial2 :: Int -> Int -> IO () +serial2 count n = + S.drain $ S.serial + (sourceUnfoldrMN count n) + (sourceUnfoldrMN count (n + 1)) + +{-# INLINE serial4 #-} +serial4 :: Int -> Int -> IO () +serial4 count n = + S.drain $ S.serial + ((S.serial (sourceUnfoldrMN count n) + (sourceUnfoldrMN count (n + 1)))) + ((S.serial (sourceUnfoldrMN count (n+2)) + (sourceUnfoldrMN count (n + 3)))) + +{-# INLINE append2 #-} +append2 :: Int -> Int -> IO () +append2 count n = + S.drain $ Internal.append + (sourceUnfoldrMN count n) + (sourceUnfoldrMN count (n + 1)) + +{-# INLINE append4 #-} +append4 :: Int -> Int -> IO () +append4 count n = + S.drain $ Internal.append + ((Internal.append (sourceUnfoldrMN count n) + (sourceUnfoldrMN count (n + 1)))) + ((Internal.append (sourceUnfoldrMN count (n+2)) + (sourceUnfoldrMN count (n + 3)))) + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'append2 +inspect $ 'append2 `hasNoType` ''D.AppendState +#endif + +------------------------------------------------------------------------------- +-- Interleaving +------------------------------------------------------------------------------- + +{-# INLINE wSerial2 #-} +wSerial2 :: Int -> Int -> IO () +wSerial2 value n = S.drain $ S.wSerial + (sourceUnfoldrMN (value `div` 2) n) + (sourceUnfoldrMN (value `div` 2) (n + 1)) + +{-# INLINE interleave2 #-} +interleave2 :: Int -> Int -> IO () +interleave2 value n = S.drain $ Internal.interleave + (sourceUnfoldrMN (value `div` 2) n) + (sourceUnfoldrMN (value `div` 2) (n + 1)) + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'interleave2 +inspect $ 'interleave2 `hasNoType` ''D.InterleaveState +#endif + +{-# INLINE roundRobin2 #-} +roundRobin2 :: Int -> Int -> IO () +roundRobin2 value n = S.drain $ Internal.roundrobin + (sourceUnfoldrMN (value `div` 2) n) + (sourceUnfoldrMN (value `div` 2) (n + 1)) + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'roundRobin2 +inspect $ 'roundRobin2 `hasNoType` ''D.InterleaveState +#endif + +------------------------------------------------------------------------------- +-- Merging +------------------------------------------------------------------------------- + +{-# INLINE mergeBy #-} +mergeBy :: Int -> Int -> IO () +mergeBy count n = + S.drain $ S.mergeBy P.compare + (sourceUnfoldrMN count n) + (sourceUnfoldrMN count (n + 1)) + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'mergeBy +inspect $ 'mergeBy `hasNoType` ''D.Step +#endif + +------------------------------------------------------------------------------- +-- Zipping +------------------------------------------------------------------------------- + +{-# INLINE zip #-} +zip :: Int -> Int -> IO () +zip count n = + S.drain $ S.zipWith (,) + (sourceUnfoldrMN count n) + (sourceUnfoldrMN count (n + 1)) + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'zip +inspect $ 'zip `hasNoType` ''D.Step +#endif + +{-# INLINE zipM #-} +zipM :: Int -> Int -> IO () +zipM count n = + S.drain $ S.zipWithM (curry return) + (sourceUnfoldrMN count n) + (sourceUnfoldrMN count (n + 1)) + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'zipM +inspect $ 'zipM `hasNoType` ''D.Step +#endif + +{-# INLINE zipAsync #-} +zipAsync :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m (Int, Int) +zipAsync count n = do + S.zipAsyncWith (,) + (sourceUnfoldrMN count n) + (sourceUnfoldrMN count (n + 1)) + +{-# INLINE zipAsyncM #-} +zipAsyncM :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m (Int, Int) +zipAsyncM count n = do + S.zipAsyncWithM (curry return) + (sourceUnfoldrMN count n) + (sourceUnfoldrMN count (n + 1)) + +{-# INLINE zipAsyncAp #-} +zipAsyncAp :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m (Int, Int) +zipAsyncAp count n = do + S.zipAsyncly $ (,) + <$> (sourceUnfoldrMN count n) + <*> (sourceUnfoldrMN count (n + 1)) + +{-# INLINE mergeAsyncByM #-} +mergeAsyncByM :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m Int +mergeAsyncByM count n = do + S.mergeAsyncByM (\a b -> return (a `compare` b)) + (sourceUnfoldrMN count n) + (sourceUnfoldrMN count (n + 1)) + +{-# INLINE mergeAsyncBy #-} +mergeAsyncBy :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m Int +mergeAsyncBy count n = do + S.mergeAsyncBy compare + (sourceUnfoldrMN count n) + (sourceUnfoldrMN count (n + 1)) + +------------------------------------------------------------------------------- +-- Multi-stream folds +------------------------------------------------------------------------------- + +{-# INLINE isPrefixOf #-} +{-# INLINE isSubsequenceOf #-} +isPrefixOf, isSubsequenceOf :: Monad m => Stream m Int -> m Bool + +isPrefixOf src = S.isPrefixOf src src +isSubsequenceOf src = S.isSubsequenceOf src src + +{-# INLINE stripPrefix #-} +stripPrefix :: Monad m => Stream m Int -> m () +stripPrefix src = do + _ <- S.stripPrefix src src + return () + +{-# INLINE eqBy' #-} +eqBy' :: (Monad m, P.Eq a) => Stream m a -> m P.Bool +eqBy' src = S.eqBy (==) src src + +{-# INLINE eqBy #-} +eqBy :: Int -> Int -> IO Bool +eqBy value n = eqBy' (source value n) + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'eqBy +inspect $ 'eqBy `hasNoType` ''D.Step +#endif + + +{-# INLINE eqByPure #-} +eqByPure :: Int -> Int -> Identity Bool +eqByPure value n = eqBy' (sourceUnfoldr value n) + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'eqByPure +inspect $ 'eqByPure `hasNoType` ''D.Step +#endif + +{-# INLINE cmpBy' #-} +cmpBy' :: (Monad m, P.Ord a) => Stream m a -> m P.Ordering +cmpBy' src = S.cmpBy P.compare src src + +{-# INLINE cmpBy #-} +cmpBy :: Int -> Int -> IO P.Ordering +cmpBy value n = cmpBy' (source value n) + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'cmpBy +inspect $ 'cmpBy `hasNoType` ''D.Step +#endif + +{-# INLINE cmpByPure #-} +cmpByPure :: Int -> Int -> Identity P.Ordering +cmpByPure value n = cmpBy' (sourceUnfoldr value n) + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'cmpByPure +inspect $ 'cmpByPure `hasNoType` ''D.Step +#endif + +------------------------------------------------------------------------------- +-- Streams of streams +------------------------------------------------------------------------------- + +-- Special cases of concatMap + +{-# INLINE sourceFoldMapWith #-} +sourceFoldMapWith :: (S.IsStream t, S.Semigroup (t m Int)) + => Int -> Int -> t m Int +sourceFoldMapWith value n = S.foldMapWith (S.<>) S.yield [n..n+value] + +{-# INLINE sourceFoldMapWithM #-} +sourceFoldMapWithM :: (S.IsStream t, Monad m, S.Semigroup (t m Int)) + => Int -> Int -> t m Int +sourceFoldMapWithM value n = S.foldMapWith (S.<>) (S.yieldM . return) [n..n+value] + +{-# INLINE sourceFoldMapM #-} +sourceFoldMapM :: (S.IsStream t, Monad m, P.Monoid (t m Int)) + => Int -> Int -> t m Int +sourceFoldMapM value n = F.foldMap (S.yieldM . return) [n..n+value] + +{-# INLINE sourceConcatMapId #-} +sourceConcatMapId :: (S.IsStream t, Monad m) + => Int -> Int -> t m Int +sourceConcatMapId value n = + S.concatMap P.id $ S.fromFoldable $ P.map (S.yieldM . return) [n..n+value] + +-- concatMap unfoldrM/unfoldrM + +{-# INLINE concatMap #-} +concatMap :: Int -> Int -> Int -> IO () +concatMap outer inner n = + S.drain $ S.concatMap + (\_ -> sourceUnfoldrMN inner n) + (sourceUnfoldrMN outer n) + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'concatMap +#endif + +-- concatMap unfoldr/unfoldr + +{-# INLINE concatMapPure #-} +concatMapPure :: Int -> Int -> Int -> IO () +concatMapPure outer inner n = + S.drain $ S.concatMap + (\_ -> sourceUnfoldrN inner n) + (sourceUnfoldrN outer n) + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'concatMapPure +#endif + +-- concatMap replicate/unfoldrM + +{-# INLINE concatMapRepl4xN #-} +concatMapRepl4xN :: Int -> Int -> IO () +concatMapRepl4xN value n = S.drain $ S.concatMap (S.replicate 4) + (sourceUnfoldrMN (value `div` 4) n) + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'concatMapRepl4xN +#endif + +-- concatMapWith + +{-# INLINE concatStreamsWith #-} +concatStreamsWith + :: (forall c. S.SerialT IO c -> S.SerialT IO c -> S.SerialT IO c) + -> Int + -> Int + -> Int + -> IO () +concatStreamsWith op outer inner n = + S.drain $ S.concatMapWith op + (\i -> sourceUnfoldrMN inner i) + (sourceUnfoldrMN outer n) + +{-# INLINE concatMapWithSerial #-} +concatMapWithSerial :: Int -> Int -> Int -> IO () +concatMapWithSerial = concatStreamsWith S.serial + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'concatMapWithSerial +#endif + +{-# INLINE concatMapWithAppend #-} +concatMapWithAppend :: Int -> Int -> Int -> IO () +concatMapWithAppend = concatStreamsWith Internal.append + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'concatMapWithAppend +#endif + +{-# INLINE concatMapWithWSerial #-} +concatMapWithWSerial :: Int -> Int -> Int -> IO () +concatMapWithWSerial = concatStreamsWith S.wSerial + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'concatMapWithWSerial +#endif + +-- concatUnfold + +-- concatUnfold replicate/unfoldrM + +{-# INLINE concatUnfoldRepl4xN #-} +concatUnfoldRepl4xN :: Int -> Int -> IO () +concatUnfoldRepl4xN value n = + S.drain $ S.concatUnfold + (UF.replicateM 4) + (sourceUnfoldrMN (value `div` 4) n) + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'concatUnfoldRepl4xN +inspect $ 'concatUnfoldRepl4xN `hasNoType` ''D.ConcatMapUState +#endif + +{-# INLINE concatUnfoldInterleaveRepl4xN #-} +concatUnfoldInterleaveRepl4xN :: Int -> Int -> IO () +concatUnfoldInterleaveRepl4xN value n = + S.drain $ Internal.concatUnfoldInterleave + (UF.replicateM 4) + (sourceUnfoldrMN (value `div` 4) n) + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'concatUnfoldInterleaveRepl4xN +-- inspect $ 'concatUnfoldInterleaveRepl4xN `hasNoType` ''D.ConcatUnfoldInterleaveState +#endif + +{-# INLINE concatUnfoldRoundrobinRepl4xN #-} +concatUnfoldRoundrobinRepl4xN :: Int -> Int -> IO () +concatUnfoldRoundrobinRepl4xN value n = + S.drain $ Internal.concatUnfoldRoundrobin + (UF.replicateM 4) + (sourceUnfoldrMN (value `div` 4) n) + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'concatUnfoldRoundrobinRepl4xN +-- inspect $ 'concatUnfoldRoundrobinRepl4xN `hasNoType` ''D.ConcatUnfoldInterleaveState +#endif + +------------------------------------------------------------------------------- +-- Monad transformation (hoisting etc.) +------------------------------------------------------------------------------- + +{-# INLINE sourceUnfoldrState #-} +sourceUnfoldrState :: (S.IsStream t, S.MonadAsync m) + => Int -> Int -> t (StateT Int m) Int +sourceUnfoldrState value n = S.unfoldrM step n + where + step cnt = + if cnt > n + value + then return Nothing + else do + s <- get + put (s + 1) + return (Just (s, cnt + 1)) + +{-# INLINE evalStateT #-} +evalStateT :: S.MonadAsync m => Int -> Int -> Stream m Int +evalStateT value n = Internal.evalStateT 0 (sourceUnfoldrState value n) + +{-# INLINE withState #-} +withState :: S.MonadAsync m => Int -> Int -> Stream m Int +withState value n = + Internal.evalStateT (0 :: Int) (Internal.liftInner (sourceUnfoldrM value n)) + +------------------------------------------------------------------------------- +-- Concurrent application/fold +------------------------------------------------------------------------------- + +{-# INLINE parAppMap #-} +parAppMap :: S.MonadAsync m => Stream m Int -> m () +parAppMap src = S.drain $ S.map (+1) S.|$ src + +{-# INLINE parAppSum #-} +parAppSum :: S.MonadAsync m => Stream m Int -> m () +parAppSum src = (S.sum S.|$. src) >>= \x -> P.seq x (return ()) + +------------------------------------------------------------------------------- +-- Type class instances +------------------------------------------------------------------------------- + +{-# INLINE eqInstance #-} +eqInstance :: Stream Identity Int -> Bool +eqInstance src = src == src + +{-# INLINE eqInstanceNotEq #-} +eqInstanceNotEq :: Stream Identity Int -> Bool +eqInstanceNotEq src = src P./= src + +{-# INLINE ordInstance #-} +ordInstance :: Stream Identity Int -> Bool +ordInstance src = src P.< src + +{-# INLINE ordInstanceMin #-} +ordInstanceMin :: Stream Identity Int -> Stream Identity Int +ordInstanceMin src = P.min src src + +{-# INLINE showInstance #-} +showInstance :: Stream Identity Int -> P.String +showInstance src = P.show src + +{-# INLINE showInstanceList #-} +showInstanceList :: [Int] -> P.String +showInstanceList src = P.show src + +{-# INLINE readInstance #-} +readInstance :: P.String -> Stream Identity Int +readInstance str = + let r = P.reads str + in case r of + [(x,"")] -> x + _ -> P.error "readInstance: no parse" + +{-# INLINE readInstanceList #-} +readInstanceList :: P.String -> [Int] +readInstanceList str = + let r = P.reads str + in case r of + [(x,"")] -> x + _ -> P.error "readInstance: no parse" + +------------------------------------------------------------------------------- +-- Pure (Identity) streams +------------------------------------------------------------------------------- + +{-# INLINE pureFoldl' #-} +pureFoldl' :: Stream Identity Int -> Int +pureFoldl' = runIdentity . S.foldl' (+) 0 + +------------------------------------------------------------------------------- +-- Foldable Instance +------------------------------------------------------------------------------- + +{-# INLINE foldableFoldl' #-} +foldableFoldl' :: Int -> Int -> Int +foldableFoldl' value n = + F.foldl' (+) 0 (sourceUnfoldr value n :: S.SerialT Identity Int) + +{-# INLINE foldableFoldrElem #-} +foldableFoldrElem :: Int -> Int -> Bool +foldableFoldrElem value n = + F.foldr (\x xs -> if x == value then P.True else xs) + (P.False) + (sourceUnfoldr value n :: S.SerialT Identity Int) + +{-# INLINE foldableSum #-} +foldableSum :: Int -> Int -> Int +foldableSum value n = + P.sum (sourceUnfoldr value n :: S.SerialT Identity Int) + +{-# INLINE foldableProduct #-} +foldableProduct :: Int -> Int -> Int +foldableProduct value n = + P.product (sourceUnfoldr value n :: S.SerialT Identity Int) + +{-# INLINE foldableNull #-} +foldableNull :: Int -> Int -> Bool +foldableNull value n = + P.null (sourceUnfoldr value n :: S.SerialT Identity Int) + +{-# INLINE foldableElem #-} +foldableElem :: Int -> Int -> Bool +foldableElem value n = + P.elem value (sourceUnfoldr value n :: S.SerialT Identity Int) + +{-# INLINE foldableNotElem #-} +foldableNotElem :: Int -> Int -> Bool +foldableNotElem value n = + P.notElem value (sourceUnfoldr value n :: S.SerialT Identity Int) + +{-# INLINE foldableFind #-} +foldableFind :: Int -> Int -> Maybe Int +foldableFind value n = + F.find (== (value + 1)) (sourceUnfoldr value n :: S.SerialT Identity Int) + +{-# INLINE foldableAll #-} +foldableAll :: Int -> Int -> Bool +foldableAll value n = + P.all (<= (value + 1)) (sourceUnfoldr value n :: S.SerialT Identity Int) + +{-# INLINE foldableAny #-} +foldableAny :: Int -> Int -> Bool +foldableAny value n = + P.any (> (value + 1)) (sourceUnfoldr value n :: S.SerialT Identity Int) + +{-# INLINE foldableAnd #-} +foldableAnd :: Int -> Int -> Bool +foldableAnd value n = + P.and $ S.map (<= (value + 1)) (sourceUnfoldr value n :: S.SerialT Identity Int) + +{-# INLINE foldableOr #-} +foldableOr :: Int -> Int -> Bool +foldableOr value n = + P.or $ S.map (> (value + 1)) (sourceUnfoldr value n :: S.SerialT Identity Int) + +{-# INLINE foldableLength #-} +foldableLength :: Int -> Int -> Int +foldableLength value n = + P.length (sourceUnfoldr value n :: S.SerialT Identity Int) + +{-# INLINE foldableMin #-} +foldableMin :: Int -> Int -> Int +foldableMin value n = + P.minimum (sourceUnfoldr value n :: S.SerialT Identity Int) + +{-# INLINE foldableMax #-} +foldableMax :: Int -> Int -> Int +foldableMax value n = + P.maximum (sourceUnfoldr value n :: S.SerialT Identity Int) + +{-# INLINE foldableMinBy #-} +foldableMinBy :: Int -> Int -> Int +foldableMinBy value n = + F.minimumBy compare (sourceUnfoldr value n :: S.SerialT Identity Int) + +{-# INLINE foldableListMinBy #-} +foldableListMinBy :: Int -> Int -> Int +foldableListMinBy value n = F.minimumBy compare [1..value+n] + +{-# INLINE foldableMaxBy #-} +foldableMaxBy :: Int -> Int -> Int +foldableMaxBy value n = + F.maximumBy compare (sourceUnfoldr value n :: S.SerialT Identity Int) + +{-# INLINE foldableToList #-} +foldableToList :: Int -> Int -> [Int] +foldableToList value n = + F.toList (sourceUnfoldr value n :: S.SerialT Identity Int) + +{-# INLINE foldableMapM_ #-} +foldableMapM_ :: Monad m => Int -> Int -> m () +foldableMapM_ value n = + F.mapM_ (\_ -> return ()) (sourceUnfoldr value n :: S.SerialT Identity Int) + +{-# INLINE foldableSequence_ #-} +foldableSequence_ :: Int -> Int -> IO () +foldableSequence_ value n = + F.sequence_ (sourceUnfoldrAction value n :: S.SerialT Identity (IO Int)) + +{-# INLINE foldableMsum #-} +foldableMsum :: Int -> Int -> IO Int +foldableMsum value n = + F.msum (sourceUnfoldrAction value n :: S.SerialT Identity (IO Int)) + +------------------------------------------------------------------------------- +-- Traversable Instance +------------------------------------------------------------------------------- + +{-# INLINE traversableTraverse #-} +traversableTraverse :: Stream Identity Int -> IO (Stream Identity Int) +traversableTraverse = P.traverse return + +{-# INLINE traversableSequenceA #-} +traversableSequenceA :: Stream Identity Int -> IO (Stream Identity Int) +traversableSequenceA = P.sequenceA . P.fmap return + +{-# INLINE traversableMapM #-} +traversableMapM :: Stream Identity Int -> IO (Stream Identity Int) +traversableMapM = P.mapM return + +{-# INLINE traversableSequence #-} +traversableSequence :: Stream Identity Int -> IO (Stream Identity Int) +traversableSequence = P.sequence . P.fmap return diff --git a/credits/CONTRIBUTORS.md b/credits/CONTRIBUTORS.md --- a/credits/CONTRIBUTORS.md +++ b/credits/CONTRIBUTORS.md @@ -4,21 +4,31 @@ Use `git shortlog -sn tag1...tag2` on the git repository to get a list of contributors between two repository tags. +## 0.7.1 + +* Harendra Kumar +* Pranay Sashank +* Adithya Kumar +* Sanchayan Maity +* Brian Wignall +* Julian Ospald +* Lucian Ursu + ## 0.7.0 -Harendra Kumar -Pranay Sashank -Artyom Kazak -David Feuer -Adithya Kumar -Aravind Gopal +* Harendra Kumar +* Pranay Sashank +* Artyom Kazak +* David Feuer +* Adithya Kumar +* Aravind Gopal ## 0.6.1 -Harendra Kumar -Mariusz Ryndzionek -Luke Clifton -Nicolas Henin +* Harendra Kumar +* Mariusz Ryndzionek +* Luke Clifton +* Nicolas Henin ## 0.6.0 diff --git a/credits/COPYRIGHTS.md b/credits/COPYRIGHTS.md --- a/credits/COPYRIGHTS.md +++ b/credits/COPYRIGHTS.md @@ -3,6 +3,15 @@ original or modified code has been included please search for the copyright notices in the individual files. +## 0.7.1 + +* For compatibility with older GHC versions portions of PrimArray and + SmallArray code is taken from "primitive" package. + * Copyright (c) 2009-2012 Roman Leshchinskiy + * Copyright (c) 2015 Dan Doel + * https://hackage.haskell.org/package/primitive-0.7.0.0 + * See primitive-0.7.0.0.txt for the original license. + ## 0.7.0 * Composable folds include code from the "foldl" package. diff --git a/credits/pipes-concurrency.txt b/credits/pipes-concurrency.txt deleted file mode 100644 --- a/credits/pipes-concurrency.txt +++ /dev/null @@ -1,24 +0,0 @@ -Copyright (c) 2014 Gabriel Gonzalez -All rights reserved. - -Redistribution and use in source and binary forms, with or without modification, -are permitted provided that the following conditions are met: - * Redistributions of source code must retain the above copyright notice, - this list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above copyright notice, - this list of conditions and the following disclaimer in the documentation - and/or other materials provided with the distribution. - * Neither the name of Gabriel Gonzalez nor the names of other contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR -ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES -(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; -LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON -ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/credits/primitive-0.7.0.0.txt b/credits/primitive-0.7.0.0.txt new file mode 100644 --- /dev/null +++ b/credits/primitive-0.7.0.0.txt @@ -0,0 +1,30 @@ +Copyright (c) 2008-2009, Roman Leshchinskiy +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +- Neither name of the University nor the names of its contributors may be +used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF +GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +DAMAGE. + diff --git a/design/dfa-bytes.png b/design/dfa-bytes.png new file mode 100644 Binary files /dev/null and b/design/dfa-bytes.png differ diff --git a/design/dfa-classes.png b/design/dfa-classes.png new file mode 100644 Binary files /dev/null and b/design/dfa-classes.png differ diff --git a/design/dfa-rearr.png b/design/dfa-rearr.png new file mode 100644 Binary files /dev/null and b/design/dfa-rearr.png differ diff --git a/design/inlining.md b/design/inlining.md new file mode 100644 --- /dev/null +++ b/design/inlining.md @@ -0,0 +1,123 @@ +## INLINE Phases + +A missing inline or inline in an incorrect GHC simplifier phase can adversely +impact performance. We use three builtin phases of GHC simplifier for inlining +i.e. phase 0, 1 and 2. We have defined them as follows in `inline.h`: + +``` +#define INLINE_EARLY INLINE [2] +#define INLINE_NORMAL INLINE [1] +#define INLINE_LATE INLINE [0] +``` + +## Low Level `fromStreamD/toStreamD` Fusion + +The combinators in `Streamly.Prelude` are defined in terms of combinators in +`Streamly.Internal.Data.Stream.StreamD` (Direct style streams) or `Streamly.Internal.Data.Stream.StreamK` +(CPS style streams). We convert the stream from `StreamD` to `StreamK` +representation or vice versa in some cases. + +In the first inlining phase (INLINE_EARLY or INLINE) we expand +the combinators in `Streamly.Prelude` into +fromStreamD/fromStreamK/toStreamD/toStreamK and combinators defined in StreamD +or StreamK modules. Once we do that fromStreamD/toStreamD get exposed and we +can apply rewrite rules to rewrite transformations like `fromStreamK . +toStreamK` to `id`. A plain `INLINE` pragma is usually enough on combinators in +`Streamly.Prelude`. + +``` +{-# RULES "fromStreamK/toStreamK fusion" + forall s. toStreamK (fromStreamK s) = s #-} +``` + +Also, we have to prevent fromStreamK and toStreamK themselves from inlining in +this phase so that rewrite rules can be applied on them, therefore, we annotate +these functions with `INLINE_LATE`. + +## Fallback Rules + +In some cases, if the operation could not fuse we want to use a fallback +rewrite rule in the next phase. For such cases we use the INLINE_EARLY phase +for the first rewrite and the INLINE_NORMAL phase for the fallback rules. + +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. + +``` +{-# 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 #-} +``` + +## High Level Operation Fusion + +Since each high level combinator in `Streamly.Prelude` is wrapped in +`fromStreamD/toStreamD` etc. the combinator fusion cannot work unless we have +removed those and exposed consecutive operations e.g. a `map` followed by +another `map`. Assuming that redundant `fromStreamK/toStreamK` have been +removed in the `INLINE_EARLY` phase, we can then apply the combinator fusion +rules in the `INLINE_NORMAL` phase. For example, we can fuse two `map` +operations into a single `map` operation. Note that now we have exposed the +`StreamD/StreamK` implementations of combinators and the rules would apply on +those. + +## Inlining Higher Order Functions + +Note that partially applied functions cannot be inlined. So if we have a code +like this: + +``` +concatMap1 src = runStream $ S.concatMap (S.replicate 3) src +``` + +We want to ensure that `concatMap` gets inlined before `replicate` so that +`replicate` becomes fully applied before it gets inlined. Currently ensuring +that both of them are inlined in the same phase (`INLINE_NORMAL`) seems to be +enough to achieve that. In general, we should try to ensure that higher order +functions are inlined before or in the same phase as the functions they can +consume as arguments. This means `StreamD` combinators should not be marked +as `INLINE` or `INLINE_EARLY`, instead they should all be marked as +`INLINE_NORMAL` because higher order funcitons like `concatMap`/`map`/`mapM` +etc are marked as `INLINE_NORMAL`. `StreamD` functions in other modules like +`Streamly.Memory.Array` should also follow the same rules. + +## Stream Fusion + +In StreamD combinators, inlining the inner step or loop functions too early +i.e. in the same pahse or before the outer function is inlined may block stream +fusion opportunities. Therefore, the inner step functions and folding loops are +marked as INLINE_LATE. + +## Specialization + +In some cases, the `step` function in `StreamD` does not get specialized when +inlined unless it is provided with an explicit signature or made a lambda, for +example, in the `replicate/replicateM` combinator we need the type annotation +on `i` to get it specialized: + +``` + {-# INLINE_LATE step #-} + step _ (i :: Int) = + if i <= 0 + then return Stop + else do + x <- action + return $ Yield x (i - 1) +``` + +`-flate-specialise` also helps in this case. + +## Stream and Fold State Data Structures + +Since state is an internal data structure threaded around in the loop, it is a +good practice to use strict unboxed fields for state data structures where +possible. In most cases it is not necessary, but in some cases it may affect +fusion and make a difference of 10x performance or more. For example, using +non-strict fields can increase the code size for internal join points and +functions created during transformations, which can affect the inlining of +these code blocks which in turn can affect stream fusion. + +See https://gitlab.haskell.org/ghc/ghc/issues/17075 . diff --git a/design/linked-lists.md b/design/linked-lists.md new file mode 100644 --- /dev/null +++ b/design/linked-lists.md @@ -0,0 +1,32 @@ +# Linked Lists + +The immutable Haskell lists or streams are great for stream processing. +However, they may not be suitable for purposes where we need to store data for +a longer while. In such cases we need mutable linked lists in pinned memory for +high performance applications i.e. we need the C like linked lists. Here are +some cases where linked-lists may be warranted instead of immutable lists: + +* Let's say we want to buffer incoming data in a list. The buffered data may be + millions of elements. When we are buffering we may allocate cells from + different areas of the GC heap. When there are other activities going on we + may have to keep copying this buffered data during GCs. When we consume this + buffer, again it creates a fragmented heap and we may have to copy some other + long-lived data to defragment the heap. The point is that we should not have + long-lived data in the GC heap. + +* When we delete a node in the list, Haskell lists have to be recreated + generating a lot of garbage. We cannot take a reference to the unmodified + segments and reuse them in the new list. On the other hand with mutable + linked-lists we can delete a node cheaply. This could be a common case in a + hash table collision chain which requires deletion of elements. + +* Similar to deletion, if we need to insert an element in the middle of the + list, an immutable list has to be re-created. + +* To implement a queue, two lists in the immutable model can be used + efficiently if we are strictly adding at the end and deleting from the front + and if there is sufficient batching so that swapping of the lists is not a + common operation. If we have to insert elements in the middle or if we have + to swap too many times again we will have the same GC issues as stated above. + For example, in implementations of priority search queues or timer wheels we + have to mutate the lists. diff --git a/design/module-organization.md b/design/module-organization.md new file mode 100644 --- /dev/null +++ b/design/module-organization.md @@ -0,0 +1,134 @@ +# Internal vs External Modules + +We keep all modules exposed to facilitate convenient exposure of experimental +APIs and constructors to users. It allows users of the library to experiment +much more easily and carry a caveat that these APIs can change in future +without notice. Since everything is exposed, maintainers do not have to think +about what to expose as experimental and what remains completely hidden every +time something is added to the library. + +We expose the internal modules via `Streamly.Internal` namespace to keep all +the internal modules together under one module tree and to have their +documentation also separated under one head in haddock docs. + +Another decision point is about two choices: + +1) Keep the implementation of all the APIs in an internal module and just +reexport selected APIs through the external module. The disadvantages of this +are: +a) users may not be able to easily figure out what unexposed APIs are available +other than the ones exposed through the external module. To avoid this problem +we can mark the unexposed APIs in the docs with a special comment. +b) In tests and benchmarks we will be using internal modules to test internal +and unexposed APIs. Since exposed APIs are exported via both internal and +external modules we will have to be careful in not using the internal module +for testing accidentally, instead we should always be using the exposed module +so that we are always testing exactly the way users will be using the APIs. + +2) Keep the implementations of unexposed modules in the internal module file +and exposed module in the external module file. In this approach, users can +easily figure out the unexposed vs exposed APIs. But maintaining this would +require us to move the APIs from internal to external module file whenever we +expose an API. + +We choose the first approach. + +# Module Name Spaces + +We use the "Streamly" prefix to all the module names so that they do not +conflict with any other module on Hackage. + +We have the following module hierarchy under Streamly: + +* Data: All the data structures that make use of the unpinned GC memory to + store data. These data structures are suitable for stream processing but + may not be suitable for storing large amounts of data in memory for longer + durations. These are suitable for short lived and smaller structures + because they can be moved by the GC to defragment the heap. + +* Memory: This name space is for data structures that make use of the memory as + a persistent storage device. The memory may be allocated by foreign + allocators or pinned memory allocated by GHC. Because the memory is pinned it + can be used for interfacing with the system/kernel. These structures are + efficient for storing large amounts of data for longer durations because it + does not have to be copied by the GC. These structures may not be suitable + for small, short lived data because that is likely to fragment the heap. + +* FileSystem: This name space is for data structures that reside in files + provided by a file system interface on top of storage devices. + +* Network: This name space is for APIs that access data from remote computers + over the network. + +## Data and Memory + +As explained above, we distinguish two types of data structures under "Data" +and "Memory". Alternatively, we could have used a "Memory" namespace under +each data structure e.g. "Streamly.Data.Array.Memory" instead of using a top +level "Streamly.Memory", however, we chose to distinguish such data structures +using a top level "Memory" name space because it enforces consistent naming by +fitting all such data structures under this top level hierarchy. It also makes +it easier to find out what all data structures fall in this category. + +# Module Types and Naming + +## Abstract modules + +Abstract modules are meant to represent an abstract interface (e.g. a type +class). Concrete modules can make use of this interface and possibly +extend it to provide concrete functionality. + +The general convention in the Haskell ecosystem for naming an abstract +interface module is to name it as "Module.Class" (e.g. Control.Monad.IO.Class). +An alternative name could be "Module.Interface". + +In some other cases such modules are named after the class name (e.g. see the +array package for an example). This is more appropriate when there is no single +hierarchy where we can place the ".Class" module. For example, we have arrays +in Data.Array, Memory.Array, we have to choose one over the other to place the +".Class" module for an array abstraction. Alternatively, we can choose +"Data.IsArray" instead. + +Yet another way could be to use the parent module as an interface module and +the child modules as concrete modules. For example, "Streamly.Data.Stream" +module could provide the common "Stream" type and the "IsStream" type class. +The submodule "Streamly.Data.Stream.Serial" can provide a concrete "Serial" +stream type importing the "Streamly.Data.Stream" abstract module. + +## Common Modules + +Some modules represent common types or utility functions that are shared across +multiple modules. The general convention is to name such modules as +"Module.Types", "Module.Common", or "Module.Core". + +## Constrained Modules + +Some modules represent operations on a type which constrain a type using a type +class or a specific instance of a general type. For example, we may have a +module representing operations on a stream of any type and another module that +specifically deals with operations on a Char stream. There are two ways to deal +with this. + +First is to use a submodule for the constrained type. For example, +`Streamly.Data.Stream` represents a general stream type whereas +`Streamly.Data.Stream.Char` represents operations on a stream of Char type. +This makes sense where the type we are constraining to is a specific type +rather than a type constrained using a type class. + +Second is to use a separate hierarchy for the constrained type. For example, we +could use `Streamly.Data.Array` for a general array and `Streamly.Prim.Array` +for an array that works on `Prim` types. This makes sense when the type is +constrained by a type class, we may have more data structures for that +constrained type to be bundled under that hierarchy. + +## Aggregate modules + +In some cases we may want to aggregate the functionality of several small +modules in a combined aggregate module. In many cases, the aggregate module is +made a parent module of the constituent modules. The parent module depends on +the child modules and exposes the functionality from the constituent modules. + +## Placeholder Modules + +In some cases a parent module is just a placeholder in the namespace and does +not export any functionality. diff --git a/design/utf8-decoder.md b/design/utf8-decoder.md new file mode 100644 --- /dev/null +++ b/design/utf8-decoder.md @@ -0,0 +1,603 @@ +Flexible and Economical UTF-8 Decoder +===================================== + +Systems with elaborate Unicode support usually confront programmers with +a multitude of different functions and macros to process UTF-8 encoded +strings, often with different ideas on handling buffer boundaries, state +between calls, error conditions, and performance characteristics, making +them difficult to use correctly and efficiently. Implementations also +tend to be very long and complicated; one popular library has over 500 +lines of code just for one version of the decoder. This page presents +one that is very easy to use correctly, short, small, fast, and free. + +Implementation in C (C99) +------------------------- + + // Copyright (c) 2008-2009 Bjoern Hoehrmann + // See http://bjoern.hoehrmann.de/utf-8/decoder/dfa/ for details. + + #define UTF8_ACCEPT 0 + #define UTF8_REJECT 1 + + static const uint8_t utf8d[] = { + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 00..1f + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 20..3f + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 40..5f + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, // 60..7f + 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9, // 80..9f + 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, // a0..bf + 8,8,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, // c0..df + 0xa,0x3,0x3,0x3,0x3,0x3,0x3,0x3,0x3,0x3,0x3,0x3,0x3,0x4,0x3,0x3, // e0..ef + 0xb,0x6,0x6,0x6,0x5,0x8,0x8,0x8,0x8,0x8,0x8,0x8,0x8,0x8,0x8,0x8, // f0..ff + 0x0,0x1,0x2,0x3,0x5,0x8,0x7,0x1,0x1,0x1,0x4,0x6,0x1,0x1,0x1,0x1, // s0..s0 + 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,1,1,1,1,1,0,1,0,1,1,1,1,1,1, // s1..s2 + 1,2,1,1,1,1,1,2,1,2,1,1,1,1,1,1,1,1,1,1,1,1,1,2,1,1,1,1,1,1,1,1, // s3..s4 + 1,2,1,1,1,1,1,1,1,2,1,1,1,1,1,1,1,1,1,1,1,1,1,3,1,3,1,1,1,1,1,1, // s5..s6 + 1,3,1,1,1,1,1,3,1,3,1,1,1,1,1,1,1,3,1,1,1,1,1,1,1,1,1,1,1,1,1,1, // s7..s8 + }; + + uint32_t inline + decode(uint32_t* state, uint32_t* codep, uint32_t byte) { + uint32_t type = utf8d[byte]; + + *codep = (*state != UTF8_ACCEPT) ? + (byte & 0x3fu) | (*codep << 6) : + (0xff >> type) & (byte); + + *state = utf8d[256 + *state*16 + type]; + return *state; + } + +Usage +----- + +UTF-8 is a variable length character encoding. To decode a character one +or more bytes have to be read from a string. The `decode` function +implements a single step in this process. It takes two parameters +maintaining state and a byte, and returns the state achieved after +processing the byte. Specifically, it returns the value `UTF8_ACCEPT` +(0) if enough bytes have been read for a character, `UTF8_REJECT` (1) if +the byte is not allowed to occur at its position, and some other +positive value if more bytes have to be read. + +When decoding the first byte of a string, the caller must set the state +variable to `UTF8_ACCEPT`. If, after decoding one or more bytes the +state `UTF8_ACCEPT` is reached again, then the decoded Unicode character +value is available through the `codep` parameter. If the state +`UTF8_REJECT` is entered, that state will never be exited unless the +caller intervenes. See the examples below for more information on usage +and error handling, and the section on implementation details for how +the decoder is constructed. + +Examples +-------- + +### Validating and counting characters + +This function checks if a null-terminated string is a well-formed UTF-8 +sequence and counts how many code points are in the string. + + int + countCodePoints(uint8_t* s, size_t* count) { + uint32_t codepoint; + uint32_t state = 0; + + for (*count = 0; *s; ++s) + if (!decode(&state, &codepoint, *s)) + *count += 1; + + return state != UTF8_ACCEPT; + } + +It could be used like so: + + if (countCodePoints(s, &count)) { + printf("The string is malformed\n"); + } else { + printf("The string is %u characters long\n", count); + } + +### Printing code point values + +This function prints out all code points in the string and an error +message if unexpected bytes are encountered, or if the string ends with +an incomplete sequence. + + void + printCodePoints(uint8_t* s) { + uint32_t codepoint; + uint32_t state = 0; + + for (; *s; ++s) + if (!decode(&state, &codepoint, *s)) + printf("U+%04X\n", codepoint); + + if (state != UTF8_ACCEPT) + printf("The string is not well-formed\n"); + + } + +### Printing UTF-16 code units + +This loop prints out UTF-16 code units for the characters in a +null-terminated UTF-8 encoded string. + + for (; *s; ++s) { + + if (decode(&state, &codepoint, *s)) + continue; + + if (codepoint <= 0xFFFF) { + printf("0x%04X\n", codepoint); + continue; + } + + // Encode code points above U+FFFF as surrogate pair. + printf("0x%04X\n", (0xD7C0 + (codepoint >> 10))); + printf("0x%04X\n", (0xDC00 + (codepoint & 0x3FF))); + } + +### Error recovery + +It is sometimes desirable to recover from errors when decoding strings +that are supposed to be UTF-8 encoded. Programmers should be aware that +this can negatively affect the security properties of their application. +A common recovery method is to replace malformed sequences with a +substitute character like `U+FFFD REPLACEMENT CHARACTER`. + +Decoder implementations differ in which octets they replace and where +they restart. Consider for instance the sequence `0xED 0xA0 0x80`. It +encodes a surrogate code point which is prohibited in UTF-8. A +recovering decoder may replace the whole sequence and restart with the +next byte, or it may replace the first byte and restart with the second +byte, replace it, restart with the third, and replace the third byte +aswell. + +The following code implements one such recovery strategy. When an +unexpected byte is encountered, the sequence up to that point will be +replaced and, if the error occurred in the middle of a sequence, will +retry the byte as if it occurred at the beginning of a string. Note that +the decode function detects errors as early as possible, so the sequence +`0xED 0xA0 0x80` would result in three replacement characters. + + for (prev = 0, current = 0; *s; prev = current, ++s) { + + switch (decode(¤t, &codepoint, *s)) { + case UTF8_ACCEPT: + // A properly encoded character has been found. + printf("U+%04X\n", codepoint); + break; + + case UTF8_REJECT: + // The byte is invalid, replace it and restart. + printf("U+FFFD (Bad UTF-8 sequence)\n"); + current = UTF8_ACCEPT; + if (prev != UTF8_ACCEPT) + s--; + break; + ... + +For some recovery strategies it may be useful to determine the number of +bytes expected. The states in the automaton are numbered such that, +assuming C\'s division operator, `state / 3 + 1` is that number. Of +course, this will only work for states other than `UTF8_ACCEPT` and +`UTF8_REJECT`. This number could then be used, for instance, to skip the +continuation octets in the illegal sequence `0xED 0xA0 0x80` so it will +be replaced by a single replacement character. + +### Transcoding to UTF-16 buffer + +This is a rough outline of a UTF-16 transcoder. Actual applications +would add code for error reporting, reporting of words written, required +buffer size in the case of a small buffer, and possibly other things. +Note that in order to avoid checking for free space in the inner loop, +we determine how many bytes can be read without running out of space. +This is one utf-8 byte per available utf-16 word, with one exception: if +the last byte read was the third byte in a four byte sequence we would +get two words for the next byte; so we read one byte less than we have +words available. This additional word is also needed for +null-termination, so it\'s never wrong to read one less. + + int + toUtf16(uint8_t* src, size_t srcBytes, uint16_t* dst, size_t dstWords, ...) { + + uint8_t* src_actual_end = src + srcBytes; + uint8_t* s = src; + uint16_t* d = dst; + uint32_t codepoint; + uint32_t state = 0; + + while (s < src_actual_end) { + + size_t dst_words_free = dstWords - (d - dst); + uint8_t* src_current_end = s + dst_words_free - 1; + + if (src_actual_end < src_current_end) + src_current_end = src_actual_end; + + if (src_current_end <= s) + goto toosmall; + + while (s < src_current_end) { + + if (decode(&state, &codepoint, *s++)) + continue; + + if (codepoint > 0xffff) { + *d++ = (uint16_t)(0xD7C0 + (codepoint >> 10)); + *d++ = (uint16_t)(0xDC00 + (codepoint & 0x3FF)); + } else { + *d++ = (uint16_t)codepoint; + } + } + } + + if (state != UTF8_ACCEPT) { + ... + } + + if ((dstWords - (d - dst)) == 0) + goto toosmall; + + *d++ = 0; + ... + + toosmall: + ... + } + +Implementation details +---------------------- + +The `utf8d` table consists of two parts. The first part maps bytes to +character classes, the second part encodes a deterministic finite +automaton using these character classes as transitions. This section +details the composition of the table. + +### Canonical UTF-8 automaton + +UTF-8 is a variable length character encoding. That means state has to +be maintained while processing a string. The following transition graph +illustrates the process. We start in state zero, and whenever we come +back to it, we\'ve seen a whole Unicode character. Transitions not in +the graph are disallowed; they all lead to state one, which has been +omitted for readability. + +![DFA with range transitions](/design/dfa-bytes.png) + +### Automaton with character class transitions + +The byte ranges in the transition graph above are not easily encoded in +the automaton in a manner that would allow fast lookup. Instead of +encoding the ranges directly, the ranges are split such that each byte +belongs to exactly one character class. Then the transitions go over +these character classes. + +![DFA with class transitions](/design/dfa-classes.png) + +### Mapping bytes to character classes + +Primarily to save space in the transition table, bytes are mapped to +character classes. This is the mapping: + +||||| +|-|-|-|-| +| 00..7f | 0 | 80..8f | 1 | +| 90..9f | 9 | a0..bf | 7 | +| c0..c1 | 8 | c2..df | 2 | +| e0..e0 | 10 | e1..ec | 3 | +| ed..ed | 4 | ee..ef | 3 | +| f0..f0 | 11 | f1..f3 | 6 | +| f4..f4 | 5 | f5..ff | 8 | + + +For bytes that may occur at the beginning of a multibyte sequence, the +character class number is also used to remove the most significant bits +from the byte, which do not contribute to the actual code point value. +Note that `0xc0`, `0xc1`, and `0xf5` .. `0xff` have all their bits +removed. These bytes cannot occur in well-formed sequences, so it does +not matter which bits, if any, are retained. + +||||||||||||| +|-|-|-|-|-|-|-|-|-|-|-|-| +| c0 | 8 | **11000000** | d0 | 2 | **11**010000 | e0 | 10 | **11100000** | f0 | 11 | **11110000** | +| c1 | 8 | **11000001** | d1 | 2 | **11**010001 | e1 | 3 | **111**00001 | f1 | 6 | **111100**01 | +| c2 | 2 | **11**000010 | d2 | 2 | **11**010010 | e2 | 3 | **111**00010 | f2 | 6 | **111100**10 | +| c3 | 2 | **11**000011 | d3 | 2 | **11**010011 | e3 | 3 | **111**00011 | f3 | 6 | **111100**11 | +| c4 | 2 | **11**000100 | d4 | 2 | **11**010100 | e4 | 3 | **111**00100 | f4 | 5 | **11110**100 | +| c5 | 2 | **11**000101 | d5 | 2 | **11**010101 | e5 | 3 | **111**00101 | f5 | 8 | **11110101** | +| c6 | 2 | **11**000110 | d6 | 2 | **11**010110 | e6 | 3 | **111**00110 | f6 | 8 | **11110110** | +| c7 | 2 | **11**000111 | d7 | 2 | **11**010111 | e7 | 3 | **111**00111 | f7 | 8 | **11110111** | +| c8 | 2 | **11**001000 | d8 | 2 | **11**011000 | e8 | 3 | **111**01000 | f8 | 8 | **11111000** | +| c9 | 2 | **11**001001 | d9 | 2 | **11**011001 | e9 | 3 | **111**01001 | f9 | 8 | **11111001** | +| ca | 2 | **11**001010 | da | 2 | **11**011010 | ea | 3 | **111**01010 | fa | 8 | **11111010** | +| cb | 2 | **11**001011 | db | 2 | **11**011011 | eb | 3 | **111**01011 | fb | 8 | **11111011** | +| cc | 2 | **11**001100 | dc | 2 | **11**011100 | ec | 3 | **111**01100 | fc | 8 | **11111100** | +| cd | 2 | **11**001101 | dd | 2 | **11**011101 | ed | 4 | **1110**1101 | fd | 8 | **11111101** | +| ce | 2 | **11**001110 | de | 2 | **11**011110 | ee | 3 | **111**01110 | fe | 8 | **11111110** | +| cf | 2 | **11**001111 | df | 2 | **11**011111 | ef | 3 | **111**01111 | ff | 8 | **11111111** | + + +Notes on Variations +------------------- + +There are several ways to change the implementation of this decoder. For +example, the size of the data table can be reduced, at the cost of a +couple more instructions, so it omits the mapping of bytes in the +US-ASCII range, and since all entries in the table are 4 bit values, two +values could be stored in a single byte. + +In some situations it may be beneficial to have a separate start state. +This is easily achieved by copying the s0 state in the array to the end, +and using the new state 9 as start state as needed. + +Where callers require the code point values, compilers tend to generate +slightly better code if the state calculation is moved into the +branches, for example + + if (*state != UTF8_ACCEPT) { + *state = utf8d[256 + *state*16 + type]; + *codep = (*codep << 6) | (byte & 63); + } else { + *state = utf8d[256 + *state*16 + type]; + *codep = (byte) & (255 >> type); + } + +As the state will be zero in the else branch, this saves a shift and an +addition for each starter. Unfortunately, compilers will then typically +generate worse code if the codepoint value is not needed. Naturally, +then, two functions could be used, one that only calculates the states +for validation, counting, and similar applications, and one for full +decoding. For the sample UTF-16 transcoder a more substantial increase +in performance can be achieved by manually including the decode code in +the inner loop; then it is also worthwhile to make code points in the +US-ASCII range a special case: + + while (s < src_current_end) { + + uint32_t byte = *s++; + uint32_t type = utf8d[byte]; + + if (state != UTF8_ACCEPT) { + codep = (codep << 6) | (byte & 63); + state = utf8d[256 + state*16 + type]; + + if (state) + continue; + + } else if (byte > 0x7f) { + codep = (byte) & (255 >> type); + state = utf8d[256 + type]; + continue; + + } else { + *d++ = (uint16_t)byte; + continue; + } + ... + +Another variation worth of note is changing the comparison when setting +the code point value to this: + + *codep = (*state > UTF8_REJECT) ? + (byte & 0x3fu) | (*codep << 6) : + (0xff >> type) & (byte); + +This ensures that the code point value does not exceed the value `0xff` +after some malformed sequence is encountered. + +As written, the decoder disallows encoding of surrogate code points, +overlong 2, 3, and 4 byte sequences, and 4 byte sequences outside the +Unicode range. Allowing them can have serious security implications, but +can easily be achieved by changing the character class assignments in +the table. + +The code samples have generally been written to perform well on my +system when compiled with Visual C++ 7.1 and GCC 3.4.5. Slight changes +may improve performance, for example, Visual C++ 7.1 will produce +slightly faster code when, in the manually inlined version of the +transcoder discussed above, the type assignment is moved into the +branches where it is needed, and the state and codepoint assignments in +the non-ASCII starter is swapped (approximately a 5% increase), but GCC +3.4.5 will produce considerably slower code (approximately 10%). + +I have experimented with various rearrangements of states and character +classes. A seemingly promising one is the following: + +![Re-arranged DFA with class transitions](/design/dfa-rearr.png) + +One of the continuation ranges has been split into two, the other +changes are just renamings. This arrangement allows, when a continuation +octet is expected, to compute the character class with a shift instead +of a table lookup, and when looking at a non-ASCII starter, the next +state is simply the character class. On my system the change in +performance is in the area of +/- 1%. This encoding would have a number +of downsides: more rejecting states are required to account for +continuation octets where starters are expected, the table formatting +would use more hex notation making it longer, and calculating the number +of expected continuation octets from a given state is more difficult. +One thing I\'d still like to try out is if, perhaps by adding a couple +of additional states, for continuation states the next state can be +computed without any table lookup with a few easily paired instructions. + +On 24th June 2010 Rich Felker pointed out that the state values in the +transition table can be pre-multiplied with 16 which would save a shift +instruction for every byte. D\'oh! We actually just need 12 and can +throw away the filler values previously in the table making the table 36 +bytes shorter and save the shift in the code. + + // Copyright (c) 2008-2010 Bjoern Hoehrmann + // See http://bjoern.hoehrmann.de/utf-8/decoder/dfa/ for details. + + #define UTF8_ACCEPT 0 + #define UTF8_REJECT 12 + + static const uint8_t utf8d[] = { + // The first part of the table maps bytes to character classes that + // to reduce the size of the transition table and create bitmasks. + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9, + 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, + 8,8,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, + 10,3,3,3,3,3,3,3,3,3,3,3,3,4,3,3, 11,6,6,6,5,8,8,8,8,8,8,8,8,8,8,8, + + // The second part is a transition table that maps a combination + // of a state of the automaton and a character class to a state. + 0,12,24,36,60,96,84,12,12,12,48,72, 12,12,12,12,12,12,12,12,12,12,12,12, + 12, 0,12,12,12,12,12, 0,12, 0,12,12, 12,24,12,12,12,12,12,24,12,24,12,12, + 12,12,12,12,12,12,12,24,12,12,12,12, 12,24,12,12,12,12,12,12,12,24,12,12, + 12,12,12,12,12,12,12,36,12,36,12,12, 12,36,12,12,12,12,12,36,12,36,12,12, + 12,36,12,12,12,12,12,12,12,12,12,12, + }; + + uint32_t inline + decode(uint32_t* state, uint32_t* codep, uint32_t byte) { + uint32_t type = utf8d[byte]; + + *codep = (*state != UTF8_ACCEPT) ? + (byte & 0x3fu) | (*codep << 6) : + (0xff >> type) & (byte); + + *state = utf8d[256 + *state + type]; + return *state; + } + +Notes on performance +-------------------- + +To conduct some ad-hoc performance testing I\'ve used three different +UTF-8 encoded buffers and passed them through a couple of UTF-8 to +UTF-16 transcoders. The large buffer is a April 2009 Hindi Wikipedia +article XML dump, the medium buffer Markus Kuhn\'s UTF-8-demo.txt, and +the tiny buffer my name, each about the number of times required for +about 1GB of data. All tests ran on a [Intel Prescott +Celeron](http://en.wikipedia.org/wiki/Celeron#Prescott-256) at 2666 MHz. +See [Changes](#changes) for some additional details. + + | | Large | Medium | Tiny | + |---------------------------------------------------------------------------|---------| ---------|----------| + |`NS_CStringToUTF16()` Mozilla 1.9 (*includes malloc/free time*) | 36924ms| 39773ms| 107958ms| + |`iconv()` 1.9 compiled with Visual C++ (Cygwin iconv 1.11 similar) | 22740ms| 21765ms| 32595ms| + |`g_utf8_to_utf16()` Cygwin Glib 2.0 (*includes malloc/free time*) | 21599ms| 20345ms| 98782ms| + |`ConvertUTF8toUTF16()` Unicode Inc., Visual C++ 7.1 -Ox -Ot -G7 | 11183ms| 11251ms| 19453ms| + |`MultiByteToWideChar()` Windows API (Server 2003 SP2) | 9857ms| 10779ms| 12771ms| + |`u_strFromUTF8` from ICU 4.0.1 (Visual Studio 2008, web site distribution) | 8778ms| 5223ms| 5419ms| + |`PyUnicode_DecodeUTF8Stateful` (3.1a2), Visual C++ 7.1 -Ox -Ot -G7 | 4523ms| 5686ms| 3138ms| + |Example section transcoder, Visual C++ 7.1 -Ox -Ot -G7 | 5397ms| 5789ms| 6250ms| + |Manually inlined transcoder (see above), Visual C++ 7.1 -Ox -Ot -G7 | 4277ms| 4998ms| 4640ms| + |Same, Cygwin GCC 3.4.5 -march=prescott -fomit-frame-pointer -O3 | 4492ms| 5154ms| 4432ms| + |Same, Cygwin GCC 4.3.2 -march=prescott -fomit-frame-pointer -O3 | 5439ms| 6322ms| 5567ms| + |Same, Visual C++ 6.0 -TP -O2 | 5398ms| 6259ms| 6446ms| + |Same, Visual C++ 7.1 -Ox -Ot -G7 (*includes malloc/free time*) | 5498ms| 5086ms| 25852ms| + +I have also timed functions that `xor` all code points in the large +buffer. In Visual Studio 2008 ICU\'s `U8_NEXT` macro comes out at +\~8000ms, the `U8_NEXT_UNSAFE` macro, which requires complete and +well-formed input, at \~4000ms, and the `decode` function is at +\~5900ms. Using the same manual inlining as for the transcode function, +Cygwin GCC 3.4.5 -march=prescott -O3 -fomit-frame-pointer brings it down +to roughly the same times as the transcode function for all three +buffers. + +While these results do not model real-world applications well, it seems +reasonable to suggest that the reduced complexity does not come at the +price of reduced performance. Note that instructions that compute the +code point values will generally be optimized away when not needed. For +example, checking if a null-terminated string is properly UTF-8 encoded +\... + + int + IsUTF8(uint8_t* s) { + uint32_t codepoint, state = 0; + + while (*s) + decode(&state, &codepoint, *s++); + + return state == UTF8_ACCEPT; + } + +\... does not require the individual code point values, and so the loop +becomes something like this: + + l1: movzx eax,al + shl edx,4 + add ecx,1 + movzx eax,byte ptr [eax+404000h] + movzx edx,byte ptr [eax+edx+256+404000h] + movzx eax,byte ptr [ecx] + test al,al + jne l1 + +For comparison, this is a typical `strlen` loop: + + l1: mov cl,byte ptr [eax] + add eax,1 + test cl,cl + jne l1 + +With the large buffer and the same number of times as above, `strlen` +takes 1507ms while `IsUTF8` takes 2514ms. + +License +------- + +Copyright (c) 2008-2009 [Bjoern Hoehrmann](http://bjoern.hoehrmann.de/) +\<\> + +Permission is hereby granted, free of charge, to any person obtaining a +copy of this software and associated documentation files (the +\"Software\"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +::: + +Changes +------- + +25 Jun 2010 +: Added an improved variation based on an observation from Rich + Felker. + +30 April 2009 +: Added some more items to the performance table: the manually inlined + transcoder allocating worst case memory for each run and freeing it + before the next run; and results for Mozilla\'s NS\_CStringToUTF16 + (a new nsAutoString is created for each run, and truncated before + the next). This used the XULRunner SDK 1.9.0.7 binary distribution + from the Mozilla website. + +18 April 2009 +: Added notes to the Variations section on handling malformed + sequences and failed optimization attempts. + +14 April 2009 +: Added PyUnicode\_DecodeUTF8Stateful times; the function has been + modified slightly so it works outside Python and so it uses a + pre-allocated buffer. Normally does not check output buffer + boundaries but rather allocates a worst case buffer, then resizes + it. Apparently the decoder [allows encodings of surrogate code + points](http://bugs.python.org/issue3672). + +Author +------ + +[Björn Höhrmann](http://bjoern.hoehrmann.de)  +([Donate via +SourceForge](http://sourceforge.net/developer/user_donations.php?user_id=188003), +[PayPal](https://www.paypal.com/cgi-bin/webscr?cmd=_xclick&business=bjoern@hoehrmann.de&item_name=Support+Bjoern+Hoehrmann)) diff --git a/docs/Build.md b/docs/Build.md new file mode 100644 --- /dev/null +++ b/docs/Build.md @@ -0,0 +1,91 @@ +# Compilation Options + +## Recommended Options + +Benchmarks show that GHC 8.8 has significantly better performance than GHC 8.6 +in many cases. + +Use the following GHC options: + +``` + -O2 + -fdicts-strict + -fspec-constr-recursive=16 + -fmax-worker-args=16 +``` + +## Using Fusion Plugin + +In many cases `fusion-plugin` can improve performance by better stream +fusion. However, in some cases performance may also regress. Please note +that the `fusion-plugin` package works only for GHC >= 8.6. + +* Install the +[fusion-plugin](https://hackage.haskell.org/package/fusion-plugin) +package or add it to the `build-depends` section of your program in the +cabal file. + +* Use the following GHC option in addition to the options listed in the + previous section: + +``` + -fplugin=Fusion.Plugin +``` + +## Minimal + +At the very least `-O -fdicts-strict` compilation options are +required. If these options are not used, the program may exhibit memory +hog. For example, the following program, if compiled without an +optimization option, is known to hog memory: + +``` +main = S.drain $ S.concatMap S.fromList $ S.repeat [] +``` + +## Explanation + +* `-fdicts-strict` is needed to avoid [a GHC +issue](https://gitlab.haskell.org/ghc/ghc/issues/17745) leading to +memory leak in some cases. + +* `-fspec-constr-recursive` is needed for better stream fusion by enabling +the `SpecConstr` optimization in more cases. + +* `-fmax-worker-args` is needed for better stream fusion by enabling the +`SpecConstr` optimization in some important cases. + +* `-fplugin=Fusion.Plugin` enables predictable stream fusion +optimization in certain cases by helping the compiler inline internal +bindings and therefore enabling case-of-case optimization. In some +cases, especially in some fileio benchmarks, it can make a difference of +5-10x better performance. + +# Multi-core Parallelism + +Concurrency without a threaded runtime may be a bit more efficient. Do not use +threaded runtime unless you really need multi-core parallelism. To get +multi-core parallelism use the following GHC options: + + `-threaded -with-rtsopts "-N"` + +# Compiler Versions + +Use GHC 8.8 for best performance. + +GHC 8.2.2 may hog memory and hang when building certain application using +streamly (particularly the benchmark programs in the streamly package). +Therefore we recommend avoiding using the GHC version 8.2.x. + +# Performance Optimizations + +If performance is below expectations: + +* Look for inlining functions in the fast path +* Strictness annotations on data, specially the data used as accumulator in + folds and scans, can help in improving performance. +* Strictness annotations on function arguments can help the compiler unbox + constructors in certain cases, improving performance. +* Sometimes using `-XStrict` extension can help improve performance, if so you + may be missing some strictness annotations. +* Use tail recursion for streaming data or for large loops diff --git a/examples/ControlFlow.hs b/examples/ControlFlow.hs --- a/examples/ControlFlow.hs +++ b/examples/ControlFlow.hs @@ -69,7 +69,7 @@ -- of non-determinism below. -- -- Note that this is redundant configuration as the same behavior can be --- acheived with just streamly, using mzero. +-- achieved with just streamly, using mzero. -- getSequenceMaybeAbove :: (IsStream t, MonadIO (t m)) => MaybeT (t m) () getSequenceMaybeAbove = do diff --git a/examples/HandleIO.hs b/examples/HandleIO.hs --- a/examples/HandleIO.hs +++ b/examples/HandleIO.hs @@ -1,55 +1,80 @@ -import qualified Streamly.Prelude as S +import Data.Char (ord) +import System.Environment (getArgs) +import System.IO (IOMode(..), hSeek, SeekMode(..)) + import qualified Streamly.Data.Fold as FL --- import qualified Streamly.Memory.Array as A import qualified Streamly.FileSystem.Handle as FH import qualified System.IO as FH +import qualified Streamly.Memory.Array as A +import qualified Streamly.Prelude as S -- import qualified Streamly.FileSystem.FD as FH --- import qualified Streamly.Data.Unicode.Stream as US import qualified Streamly.Internal.Data.Fold as FL +import qualified Streamly.Internal.Data.Unicode.Stream as US import qualified Streamly.Internal.Memory.ArrayStream as AS -import qualified Streamly.Internal.FileSystem.Handle as IFH +import qualified Streamly.Internal.Prelude as S -import Data.Char (ord) -import System.Environment (getArgs) -import System.IO (IOMode(..), hSeek, SeekMode(..)) +-- Read the contents of a file to stdout. +-- +-- FH.read reads the file in 32KB chunks and converts the chunks into a byte +-- stream. FH.write takes the byte stream as input, converts it into chunks of +-- 32KB and writes those chunks to stdout. +-- +_cat :: FH.Handle -> IO () +_cat src = S.fold (FH.write FH.stdout) $ S.unfold FH.read src +-- Chunked version, more efficient than the byte stream version above. Reads +-- the file in 256KB chunks and writes those chunks to stdout. cat :: FH.Handle -> IO () cat src = S.fold (FH.writeChunks FH.stdout) - $ IFH.toChunksWithBufferOf (256*1024) src --- byte stream version --- cat src = S.fold (FH.write FH.stdout) $ FH.read src + $ S.unfold FH.readChunksWithBufferOf ((256*1024), src) +-- Copy a source file to a destination file. +-- +-- FH.read reads the file in 32KB chunks and converts the chunks into a byte +-- stream. FH.write takes the byte stream as input, converts it into chunks of +-- 32KB and writes those chunks to the destination file. +_cp :: FH.Handle -> FH.Handle -> IO () +_cp src dst = S.fold (FH.write dst) $ S.unfold FH.read src + +-- Chunked version, more efficient than the byte stream version above. Reads +-- the file in 256KB chunks and writes those chunks to stdout. cp :: FH.Handle -> FH.Handle -> IO () cp src dst = S.fold (FH.writeChunks dst) - $ IFH.toChunksWithBufferOf (256*1024) src --- byte stream version --- cp src dst = S.fold (FH.write dst) $ FH.read src + $ S.unfold FH.readChunksWithBufferOf ((256*1024), src) ord' :: Num a => Char -> a ord' = (fromIntegral . ord) +-- Count lines like wc -l. +-- +-- Char stream version. Reads the input as a byte stream, splits it into lines +-- and counts the lines.. +_wcl :: FH.Handle -> IO () +_wcl src = print =<< (S.length + $ US.lines FL.drain + $ US.decodeLatin1 + $ S.unfold FH.read src) + +-- More efficient chunked version. Reads chunks from the input handles and +-- splits the chunks directly instead of converting them into byte stream +-- first. wcl :: FH.Handle -> IO () wcl src = print =<< (S.length $ AS.splitOn 10 - $ IFH.toChunks src) -{- --- Char stream version -wcl src = print =<< (S.length - $ flip US.lines FL.drain - $ US.decodeLatin1 - $ FH.read src) --} + $ S.unfold FH.readChunks src) -{- +-- grep -c +-- +-- count the occurrences of a pattern in a file. grepc :: String -> FH.Handle -> IO () grepc pat src = print . (subtract 1) =<< (S.length - $ FL.splitOnSeq (A.fromList (map ord' pat)) FL.drain - $ FH.read src) --} + $ S.splitOnSeq (A.fromList (map ord' pat)) FL.drain + $ S.unfold FH.read src) +-- Compute the average line length in a file. avgll :: FH.Handle -> IO () avgll src = print =<< (S.fold avg $ S.splitWithSuffix (== ord' '\n') FL.length @@ -57,6 +82,7 @@ where avg = (/) <$> toDouble FL.sum <*> toDouble FL.length toDouble = fmap (fromIntegral :: Int -> Double) +-- histogram of line lengths in a file llhisto :: FH.Handle -> IO () llhisto src = print =<< (S.fold (FL.classify FL.length) $ S.map bucket @@ -73,7 +99,7 @@ rewind >> putStrLn "cat" >> cat src -- Unix cat program rewind >> putStr "wcl " >> wcl src -- Unix wc -l program - -- rewind >> putStr "grepc " >> grepc "aaaa" src -- Unix grep -c program + rewind >> putStr "grepc " >> grepc "aaaa" src -- Unix grep -c program rewind >> putStr "avgll " >> avgll src -- get average line length rewind >> putStr "llhisto " >> llhisto src -- get line length histogram diff --git a/examples/ListDir.hs b/examples/ListDir.hs --- a/examples/ListDir.hs +++ b/examples/ListDir.hs @@ -1,8 +1,12 @@ -import System.IO (stdout, hSetBuffering, BufferMode(LineBuffering)) -import Streamly (aheadly, ahead, AheadT) +module Main (main) where + +import Data.Bifunctor (bimap) import Data.Function ((&)) +import System.IO (stdout, hSetBuffering, BufferMode(LineBuffering)) +import Streamly (ahead) import qualified Streamly.Prelude as S +import qualified Streamly.Internal.Prelude as S import qualified Streamly.Internal.FileSystem.Dir as Dir -- | List the current directory recursively using concurrent processing @@ -10,22 +14,12 @@ main :: IO () main = do hSetBuffering stdout LineBuffering - S.mapM_ print $ aheadly $ recursePath (Left ".") + S.mapM_ print $ S.concatMapTreeWith ahead listDir + (S.yieldM $ return (Left ".")) where - -- XXX Fix bug in enqueueAhead when mixing serial with ahead: - -- (\x -> S.yield dir <> S.concatMapWith ahead recursePath x) - -- :: SerialT IO String - -- or S.cons dir . S.concatMapWith ahead recursePath - recursePath :: Either String String -> AheadT IO String - recursePath (Left dir) = - Dir.toEither dir -- SerialT IO (Either String String) - & S.map (prefixDir dir) -- SerialT IO (Either String String) - & S.consM (return dir) - . S.concatMapWith ahead recursePath -- SerialT IO String - recursePath (Right file) = S.yield file -- SerialT IO String - - prefixDir :: String -> Either String String -> Either String String - prefixDir dir (Right x) = Right $ dir ++ "/" ++ x - prefixDir dir (Left x) = Left $ dir ++ "/" ++ x + listDir dir = + Dir.toEither dir -- SerialT IO (Either String String) + & S.map (bimap prefix prefix) -- SerialT IO (Either String String) + where prefix x = dir ++ "/" ++ x diff --git a/src/Streamly.hs b/src/Streamly.hs --- a/src/Streamly.hs +++ b/src/Streamly.hs @@ -52,13 +52,14 @@ -- package. {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} #if __GLASGOW_HASKELL__ >= 800 {-# OPTIONS_GHC -Wno-orphans #-} #endif -#include "Streamly/Streams/inline.hs" +#include "inline.hs" module Streamly ( @@ -128,10 +129,10 @@ -- * Parallel Function Application -- $application - , (|$) - , (|&) - , (|$.) - , (|&.) + , (IP.|$) + , (IP.|&) + , (IP.|$.) + , (IP.|&.) , mkAsync -- * Merging Streams @@ -224,19 +225,20 @@ import Data.Semigroup (Semigroup(..)) import Streamly.Internal.Data.SVar (MonadAsync, Rate(..)) -import Streamly.Streams.Ahead -import Streamly.Streams.Async -import Streamly.Streams.Combinators -import Streamly.Streams.Parallel -import Streamly.Streams.Serial -import Streamly.Streams.StreamK hiding (serial) -import Streamly.Streams.Zip +import Streamly.Internal.Data.Stream.Ahead +import Streamly.Internal.Data.Stream.Async hiding (mkAsync) +import Streamly.Internal.Data.Stream.Combinators +import Streamly.Internal.Data.Stream.Parallel +import Streamly.Internal.Data.Stream.Serial +import Streamly.Internal.Data.Stream.StreamK hiding (serial) +import Streamly.Internal.Data.Stream.Zip import qualified Streamly.Prelude as P import qualified Streamly.Internal.Prelude as IP -import qualified Streamly.Streams.StreamK as K +import qualified Streamly.Internal.Data.Stream.StreamK as K +import qualified Streamly.Internal.Data.Stream.Async as Async --- XXX provide good succinct examples of pipelining, merging, splitting ect. +-- XXX provide good succinct examples of pipelining, merging, splitting etc. -- below. -- -- $streams @@ -451,6 +453,19 @@ forEachWith = P.forEachWith -} +-- XXX Deprecate it in 0.8.0 +-- +-- | Make a stream asynchronous, triggers the computation and returns a stream +-- in the underlying monad representing the output generated by the original +-- computation. The returned action is exhaustible and must be drained once. If +-- not drained fully we may have a thread blocked forever and once exhausted it +-- will always return 'empty'. +-- +-- @since 0.2.0 +{-# INLINABLE mkAsync #-} +mkAsync :: (IsStream t, MonadAsync m) => t m a -> m (t m a) +mkAsync = return . Async.mkAsync + ------------------------------------------------------------------------------ -- Documentation ------------------------------------------------------------------------------ @@ -511,39 +526,43 @@ -- $async -- --- When a stream consumer demands an element from an asynchronous stream, --- constructed as @a \`consM` b \`consM` ... nil@, the action @a@ along with --- multiple following at the head of the stream sequence are executed --- concurrently and the output of the one that completes first is supplied to --- the consumer. As more actions complete, their results are buffered in the --- order of completion. When the next element is demanded it may be served --- from the buffer and we may initiate execution of more actions in the --- sequence to keep the buffer adequately filled. Thus, the actions are --- executed concurrently and their results are consumed in the order of --- completion. `consM` can be used to fold an infinite lazy container of --- effects, as the number of concurrent executions is limited. +-- /Scheduling and execution:/ In an asynchronous stream @a \`consM` b \`consM` +-- c ...@, the actions @a@, @b@, and @c@ are executed concurrently with the +-- consumer of the stream. The actions are /scheduled/ for execution in the +-- same order as they are specified in the stream. Multiple scheduled actions +-- may be /executed/ concurrently in parallel threads of execution. The +-- actions may be executed out of order and they may complete at arbitrary +-- times. Therefore, the /effects/ of the actions may be observed out of +-- order. -- --- Similar to 'consM', the monadic stream generation (e.g. replicateM) and --- transformation operations (e.g. mapM) on asynchronous streams can execute --- multiple effects concurrently in an asynchronous manner. +-- /Buffering:/ The /results/ from multiple threads of execution are queued in +-- a buffer as soon as they become available. The consumer of the stream is +-- served from this buffer. Therefore, the consumer may observe the results to +-- be out of order. In other words, an asynchronous stream is an unordered +-- stream i.e. order does not matter. -- --- How many effects can be executed concurrently and how many results can be --- buffered are controlled by 'maxThreads' and 'maxBuffer' combinators --- respectively. The actual number of concurrent threads is adjusted according --- to the rate at which the consumer is consuming the stream. It may even --- execute actions serially in a single thread if that is enough to match the --- consumer's speed. +-- /Concurrency control:/ Threads are suspended if the `maxBuffer` limit is +-- reached, and resumed when the consumer makes space in the buffer. The +-- maximum number of concurrent threads depends on `maxThreads`. Number of +-- threads is increased or decreased based on the speed of the consumer. -- --- Asynchronous streams do not enforce any spatial order on the side effects or --- on the results of the actions. However there is a partial ordering as the --- actions to be executed are picked from the head of stream. The results are --- presented to the consumer in the completion time order. Therefore, the --- semigroup operation for asynchronous streams is commutative i.e. the stream --- is considered unordered. +-- /Generation operations:/ Concurrent stream generation operations e.g. +-- 'Streamly.Prelude.replicateM' when used in async style schedule and execute +-- the stream generating actions in the manner described above. The generation +-- actions run concurrently, effects and results of the actions as observed by +-- the consumer of the stream may be out of order. -- --- There are two asynchronous stream types 'AsyncT' and 'WAsyncT'. The stream --- evaluation of both the variants works in the same way as described above, --- they differ only in the 'Semigroup' and 'Monad' implementaitons. +-- /Transformation operations:/ Concurrent stream transformation operations +-- e.g. 'Streamly.Prelude.mapM', when used in async style, schedule and +-- execute transformation actions in the manner described above. Transformation +-- actions run concurrently, effects and results of the actions may be +-- observed by the consumer out of order. +-- +-- /Variants:/ There are two asynchronous stream types 'AsyncT' and 'WAsyncT'. +-- They are identical with respect to single stream evaluation behavior. Their +-- behaviors differ in how they combine multiple streams using 'Semigroup' or +-- 'Monad' composition. Since the order of elements does not matter in +-- asynchronous streams the 'Semigroup' operation is effectively commutative. -- $zipping -- diff --git a/src/Streamly/Benchmark/FileIO/Array.hs b/src/Streamly/Benchmark/FileIO/Array.hs deleted file mode 100644 --- a/src/Streamly/Benchmark/FileIO/Array.hs +++ /dev/null @@ -1,242 +0,0 @@ --- | --- Module : Streamly.Benchmark.FileIO.Array --- Copyright : (c) 2019 Composewell Technologies --- --- License : BSD3 --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC - -{-# LANGUAGE CPP #-} - -#ifdef __HADDOCK_VERSION__ -#undef INSPECTION -#endif - -#ifdef INSPECTION -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-} -#endif - -module Streamly.Benchmark.FileIO.Array - ( - last - , countBytes - , countLines - , countWords - , sumBytes - , cat - , catOnException - , catBracket - , catBracketStream - , copy - , linesUnlinesCopy - , wordsUnwordsCopy - , decodeUtf8Lenient - , copyCodecUtf8Lenient - ) -where - -import Data.Functor.Identity (runIdentity) -import Data.Word (Word8) -import System.IO (Handle, hClose) -import Prelude hiding (last) - -import qualified Streamly.FileSystem.Handle as FH -import qualified Streamly.Memory.Array as A -import qualified Streamly.Prelude as S -import qualified Streamly.Data.Unicode.Stream as SS -import qualified Streamly.Internal.Data.Unicode.Stream as IUS - -import qualified Streamly.Internal.FileSystem.Handle as IFH -import qualified Streamly.Internal.Memory.Array as IA -import qualified Streamly.Internal.Memory.ArrayStream as AS -import qualified Streamly.Internal.Data.Unfold as IUF - -#ifdef INSPECTION -import Foreign.Storable (Storable) -import Streamly.Internal.Data.Stream.StreamD.Type (Step(..)) -import Test.Inspection -#endif - --- | Get the last byte from a file bytestream. -{-# INLINE last #-} -last :: Handle -> IO (Maybe Word8) -last inh = do - let s = IFH.toChunks inh - larr <- S.last s - return $ case larr of - Nothing -> Nothing - Just arr -> IA.readIndex arr (A.length arr - 1) - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'last -inspect $ 'last `hasNoType` ''Step -#endif - --- | Count the number of bytes in a file. -{-# INLINE countBytes #-} -countBytes :: Handle -> IO Int -countBytes inh = - let s = IFH.toChunks inh - in S.sum (S.map A.length s) - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'countBytes -inspect $ 'countBytes `hasNoType` ''Step -#endif - --- | Count the number of lines in a file. -{-# INLINE countLines #-} -countLines :: Handle -> IO Int -countLines = S.length . AS.splitOnSuffix 10 . IFH.toChunks - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'countLines -inspect $ 'countLines `hasNoType` ''Step -#endif - --- XXX use a word splitting combinator instead of splitOn and test it. --- | Count the number of lines in a file. -{-# INLINE countWords #-} -countWords :: Handle -> IO Int -countWords = S.length . AS.splitOn 32 . IFH.toChunks - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'countWords -inspect $ 'countWords `hasNoType` ''Step -#endif - --- | Sum the bytes in a file. -{-# INLINE sumBytes #-} -sumBytes :: Handle -> IO Word8 -sumBytes inh = do - let foldlArr' f z = runIdentity . S.foldl' f z . IA.toStream - let s = IFH.toChunks inh - S.foldl' (\acc arr -> acc + foldlArr' (+) 0 arr) 0 s - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'sumBytes -inspect $ 'sumBytes `hasNoType` ''Step -#endif - --- | Send the file contents to /dev/null -{-# INLINE cat #-} -cat :: Handle -> Handle -> IO () -cat devNull inh = - S.fold (IFH.writeChunks devNull) $ IFH.toChunksWithBufferOf (256*1024) inh - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'cat -inspect $ 'cat `hasNoType` ''Step -#endif - --- | Send the file contents to /dev/null with exception handling -{-# INLINE catBracket #-} -catBracket :: Handle -> Handle -> IO () -catBracket devNull inh = - let readEx = IUF.bracket return (\_ -> hClose inh) - (IUF.supplyFirst FH.readChunksWithBufferOf (256*1024)) - in IUF.fold readEx (IFH.writeChunks devNull) inh - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'catBracket --- inspect $ 'catBracket `hasNoType` ''Step -#endif - --- | Send the file contents to /dev/null with exception handling -{-# INLINE catBracketStream #-} -catBracketStream :: Handle -> Handle -> IO () -catBracketStream devNull inh = - let readEx = S.bracket (return ()) (\_ -> hClose inh) - (\_ -> IFH.toChunksWithBufferOf (256*1024) inh) - in S.fold (IFH.writeChunks devNull) $ readEx - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'catBracketStream --- inspect $ 'catBracketStream `hasNoType` ''Step -#endif - --- | Send the file contents to /dev/null with exception handling -{-# INLINE catOnException #-} -catOnException :: Handle -> Handle -> IO () -catOnException devNull inh = - let readEx = IUF.onException (\_ -> hClose inh) - (IUF.supplyFirst FH.readChunksWithBufferOf (256*1024)) - in IUF.fold readEx (IFH.writeChunks devNull) inh - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'catOnException --- inspect $ 'catOnException `hasNoType` ''Step -#endif - --- | Copy file -{-# INLINE copy #-} -copy :: Handle -> Handle -> IO () -copy inh outh = - let s = IFH.toChunks inh - in S.fold (IFH.writeChunks outh) s - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'copy -inspect $ 'copy `hasNoType` ''Step -#endif - --- | Lines and unlines -{-# INLINE linesUnlinesCopy #-} -linesUnlinesCopy :: Handle -> Handle -> IO () -linesUnlinesCopy inh outh = - S.fold (IFH.writeWithBufferOf (1024*1024) outh) - $ AS.interposeSuffix 10 - $ AS.splitOnSuffix 10 - $ IFH.toChunksWithBufferOf (1024*1024) inh - -#ifdef INSPECTION -inspect $ hasNoTypeClassesExcept 'linesUnlinesCopy [''Storable] --- inspect $ 'linesUnlinesCopy `hasNoType` ''Step -#endif - --- | Words and unwords -{-# INLINE wordsUnwordsCopy #-} -wordsUnwordsCopy :: Handle -> Handle -> IO () -wordsUnwordsCopy inh outh = - S.fold (IFH.writeWithBufferOf (1024*1024) outh) - $ AS.interpose 32 - -- XXX this is not correct word splitting combinator - $ AS.splitOn 32 - $ IFH.toChunksWithBufferOf (1024*1024) inh - -#ifdef INSPECTION -inspect $ hasNoTypeClassesExcept 'wordsUnwordsCopy [''Storable] --- inspect $ 'wordsUnwordsCopy `hasNoType` ''Step -#endif - -{-# INLINE decodeUtf8Lenient #-} -decodeUtf8Lenient :: Handle -> IO () -decodeUtf8Lenient inh = - S.drain - $ IUS.decodeUtf8ArraysLenient - $ IFH.toChunksWithBufferOf (1024*1024) inh - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'decodeUtf8Lenient --- inspect $ 'decodeUtf8Lenient `hasNoType` ''Step --- inspect $ 'decodeUtf8Lenient `hasNoType` ''AT.FlattenState --- inspect $ 'decodeUtf8Lenient `hasNoType` ''D.ConcatMapUState -#endif - --- | Copy file -{-# INLINE copyCodecUtf8Lenient #-} -copyCodecUtf8Lenient :: Handle -> Handle -> IO () -copyCodecUtf8Lenient inh outh = - S.fold (FH.write outh) - $ SS.encodeUtf8 - $ IUS.decodeUtf8ArraysLenient - $ IFH.toChunksWithBufferOf (1024*1024) inh - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'copyCodecUtf8Lenient --- inspect $ 'copyCodecUtf8Lenient `hasNoType` ''Step --- inspect $ 'copyCodecUtf8Lenient `hasNoType` ''AT.FlattenState --- inspect $ 'copyCodecUtf8Lenient `hasNoType` ''D.ConcatMapUState -#endif diff --git a/src/Streamly/Benchmark/FileIO/Stream.hs b/src/Streamly/Benchmark/FileIO/Stream.hs deleted file mode 100644 --- a/src/Streamly/Benchmark/FileIO/Stream.hs +++ /dev/null @@ -1,617 +0,0 @@ --- | --- Module : Streamly.Benchmark.FileIO.Stream --- Copyright : (c) 2019 Composewell Technologies --- --- License : BSD3 --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC - -{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} - -#ifdef __HADDOCK_VERSION__ -#undef INSPECTION -#endif - -#ifdef INSPECTION -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-} -#endif - -module Streamly.Benchmark.FileIO.Stream - ( - -- * FileIO - last - , countBytes - , countLines - , countLinesU - , countWords - , sumBytes - , cat - , catStreamWrite - , catBracket - , catBracketStream - , catOnException - , catOnExceptionStream - , catHandle - , catHandleStream - , catFinally - , catFinallyStream - , copy - , linesUnlinesCopy - , linesUnlinesArrayWord8Copy - , linesUnlinesArrayCharCopy - -- , linesUnlinesArrayUtf8Copy - , wordsUnwordsCopyWord8 - , wordsUnwordsCopy - , wordsUnwordsCharArrayCopy - , readWord8 - , decodeLatin1 - , copyCodecChar8 - , copyCodecUtf8 - , decodeUtf8Lax - , copyCodecUtf8Lenient - , chunksOf - , chunksOfD - , splitOn - , splitOnSuffix - , wordsBy - , splitOnSeq - , splitOnSeqUtf8 - , splitOnSuffixSeq - ) -where - -import Control.Exception (SomeException) -import Data.Char (ord, chr) -import Data.Word (Word8) -import System.IO (Handle, hClose) -import Prelude hiding (last, length) - -import qualified Streamly.FileSystem.Handle as FH -import qualified Streamly.Internal.FileSystem.Handle as IFH -import qualified Streamly.Memory.Array as A --- import qualified Streamly.Internal.Memory.Array as IA -import qualified Streamly.Internal.Memory.Array.Types as AT -import qualified Streamly.Prelude as S -import qualified Streamly.Data.Fold as FL --- import qualified Streamly.Internal.Data.Fold as IFL -import qualified Streamly.Data.Unicode.Stream as SS -import qualified Streamly.Internal.Data.Unicode.Stream as IUS -import qualified Streamly.Internal.Memory.Unicode.Array as IUA -import qualified Streamly.Internal.Data.Unfold as IUF -import qualified Streamly.Internal.Prelude as IP -import qualified Streamly.Streams.StreamD as D - -#ifdef INSPECTION -import Foreign.Storable (Storable) -import Streamly.Internal.Data.Stream.StreamD.Type (Step(..), GroupState) -import Test.Inspection -#endif - --- | Get the last byte from a file bytestream. -{-# INLINE last #-} -last :: Handle -> IO (Maybe Word8) -last = S.last . S.unfold FH.read - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'last -inspect $ 'last `hasNoType` ''Step -inspect $ 'last `hasNoType` ''AT.FlattenState -inspect $ 'last `hasNoType` ''D.ConcatMapUState -#endif - --- assert that flattenArrays constructors are not present --- | Count the number of bytes in a file. -{-# INLINE countBytes #-} -countBytes :: Handle -> IO Int -countBytes = S.length . S.unfold FH.read - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'countBytes -inspect $ 'countBytes `hasNoType` ''Step -inspect $ 'countBytes `hasNoType` ''AT.FlattenState -inspect $ 'countBytes `hasNoType` ''D.ConcatMapUState -#endif - --- | Count the number of lines in a file. -{-# INLINE countLines #-} -countLines :: Handle -> IO Int -countLines = - S.length - . IUS.lines FL.drain - . SS.decodeLatin1 - . S.unfold FH.read - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'countLines -inspect $ 'countLines `hasNoType` ''Step -inspect $ 'countLines `hasNoType` ''AT.FlattenState -inspect $ 'countLines `hasNoType` ''D.ConcatMapUState -#endif - --- | Count the number of words in a file. -{-# INLINE countWords #-} -countWords :: Handle -> IO Int -countWords = - S.length - . IUS.words FL.drain - . SS.decodeLatin1 - . S.unfold FH.read - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'countWords --- inspect $ 'countWords `hasNoType` ''Step --- inspect $ 'countWords `hasNoType` ''D.ConcatMapUState -#endif - --- | Count the number of lines in a file. -{-# INLINE countLinesU #-} -countLinesU :: Handle -> IO Int -countLinesU inh = - S.length - $ IUS.lines FL.drain - $ SS.decodeLatin1 - $ S.concatUnfold A.read (IFH.toChunks inh) - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'countLinesU -inspect $ 'countLinesU `hasNoType` ''Step -inspect $ 'countLinesU `hasNoType` ''D.ConcatMapUState -#endif - --- | Sum the bytes in a file. -{-# INLINE sumBytes #-} -sumBytes :: Handle -> IO Word8 -sumBytes = S.sum . S.unfold FH.read - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'sumBytes -inspect $ 'sumBytes `hasNoType` ''Step -inspect $ 'sumBytes `hasNoType` ''AT.FlattenState -inspect $ 'sumBytes `hasNoType` ''D.ConcatMapUState -#endif - --- | Send the file contents to /dev/null -{-# INLINE cat #-} -cat :: Handle -> Handle -> IO () -cat devNull inh = S.fold (FH.write devNull) $ S.unfold FH.read inh - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'cat -inspect $ 'cat `hasNoType` ''Step -inspect $ 'cat `hasNoType` ''AT.FlattenState -inspect $ 'cat `hasNoType` ''D.ConcatMapUState -#endif - --- | Send the file contents to /dev/null -{-# INLINE catStreamWrite #-} -catStreamWrite :: Handle -> Handle -> IO () -catStreamWrite devNull inh = IFH.fromBytes devNull $ S.unfold FH.read inh - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'catStreamWrite -inspect $ 'catStreamWrite `hasNoType` ''Step -inspect $ 'catStreamWrite `hasNoType` ''AT.FlattenState -inspect $ 'catStreamWrite `hasNoType` ''D.ConcatMapUState -#endif - --- | Send the file contents to /dev/null with exception handling -{-# INLINE catBracket #-} -catBracket :: Handle -> Handle -> IO () -catBracket devNull inh = - let readEx = IUF.bracket return (\_ -> hClose inh) FH.read - in S.fold (FH.write devNull) $ S.unfold readEx inh - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'catBracket --- inspect $ 'catBracket `hasNoType` ''Step --- inspect $ 'catBracket `hasNoType` ''AT.FlattenState --- inspect $ 'catBracket `hasNoType` ''D.ConcatMapUState -#endif - --- | Send the file contents to /dev/null with exception handling -{-# INLINE catBracketStream #-} -catBracketStream :: Handle -> Handle -> IO () -catBracketStream devNull inh = - let readEx = S.bracket (return ()) (\_ -> hClose inh) - (\_ -> IFH.toBytes inh) - in IFH.fromBytes devNull $ readEx - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'catBracketStream --- inspect $ 'catBracketStream `hasNoType` ''Step -#endif - --- | Send the file contents to /dev/null with exception handling -{-# INLINE catOnException #-} -catOnException :: Handle -> Handle -> IO () -catOnException devNull inh = - let readEx = IUF.onException (\_ -> hClose inh) FH.read - in S.fold (FH.write devNull) $ S.unfold readEx inh - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'catOnException --- inspect $ 'catOnException `hasNoType` ''Step --- inspect $ 'catOnException `hasNoType` ''AT.FlattenState --- inspect $ 'catOnException `hasNoType` ''D.ConcatMapUState -#endif - --- | Send the file contents to /dev/null with exception handling -{-# INLINE catOnExceptionStream #-} -catOnExceptionStream :: Handle -> Handle -> IO () -catOnExceptionStream devNull inh = - let readEx = S.onException (hClose inh) (S.unfold FH.read inh) - in S.fold (FH.write devNull) $ readEx - --- | Send the file contents to /dev/null with exception handling -{-# INLINE catFinally #-} -catFinally :: Handle -> Handle -> IO () -catFinally devNull inh = - let readEx = IUF.finally (\_ -> hClose inh) FH.read - in S.fold (FH.write devNull) $ S.unfold readEx inh - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'catFinally --- inspect $ 'catFinally `hasNoType` ''Step --- inspect $ 'catFinally `hasNoType` ''AT.FlattenState --- inspect $ 'catFinally `hasNoType` ''D.ConcatMapUState -#endif - --- | Send the file contents to /dev/null with exception handling -{-# INLINE catFinallyStream #-} -catFinallyStream :: Handle -> Handle -> IO () -catFinallyStream devNull inh = - let readEx = S.finally (hClose inh) (S.unfold FH.read inh) - in S.fold (FH.write devNull) readEx - --- | Send the file contents to /dev/null with exception handling -{-# INLINE catHandle #-} -catHandle :: Handle -> Handle -> IO () -catHandle devNull inh = - let handler (_e :: SomeException) = hClose inh >> return 10 - readEx = IUF.handle (IUF.singleton handler) FH.read - in S.fold (FH.write devNull) $ S.unfold readEx inh - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'catHandle --- inspect $ 'catHandle `hasNoType` ''Step --- inspect $ 'catHandle `hasNoType` ''AT.FlattenState --- inspect $ 'catHandle `hasNoType` ''D.ConcatMapUState -#endif - --- | Send the file contents to /dev/null with exception handling -{-# INLINE catHandleStream #-} -catHandleStream :: Handle -> Handle -> IO () -catHandleStream devNull inh = - let handler (_e :: SomeException) = S.yieldM (hClose inh >> return 10) - readEx = S.handle handler (S.unfold FH.read inh) - in S.fold (FH.write devNull) $ readEx - --- | Copy file -{-# INLINE copy #-} -copy :: Handle -> Handle -> IO () -copy inh outh = S.fold (FH.write outh) (S.unfold FH.read inh) - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'copy -inspect $ 'copy `hasNoType` ''Step -inspect $ 'copy `hasNoType` ''AT.FlattenState -inspect $ 'copy `hasNoType` ''D.ConcatMapUState -#endif - -{-# INLINE readWord8 #-} -readWord8 :: Handle -> IO () -readWord8 inh = S.drain $ S.unfold FH.read inh - -{-# INLINE decodeLatin1 #-} -decodeLatin1 :: Handle -> IO () -decodeLatin1 inh = - S.drain - $ SS.decodeLatin1 - $ S.unfold FH.read inh - --- | Copy file -{-# INLINE copyCodecChar8 #-} -copyCodecChar8 :: Handle -> Handle -> IO () -copyCodecChar8 inh outh = - S.fold (FH.write outh) - $ SS.encodeLatin1 - $ SS.decodeLatin1 - $ S.unfold FH.read inh - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'copyCodecChar8 -inspect $ 'copyCodecChar8 `hasNoType` ''Step -inspect $ 'copyCodecChar8 `hasNoType` ''AT.FlattenState -inspect $ 'copyCodecChar8 `hasNoType` ''D.ConcatMapUState -#endif - -{-# INLINE decodeUtf8Lax #-} -decodeUtf8Lax :: Handle -> IO () -decodeUtf8Lax inh = - S.drain - $ SS.decodeUtf8Lax - $ S.unfold FH.read inh - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'decodeUtf8Lax --- inspect $ 'decodeUtf8Lax `hasNoType` ''Step --- inspect $ 'decodeUtf8Lax `hasNoType` ''AT.FlattenState --- inspect $ 'decodeUtf8Lax `hasNoType` ''D.ConcatMapUState -#endif - --- | Copy file -{-# INLINE copyCodecUtf8 #-} -copyCodecUtf8 :: Handle -> Handle -> IO () -copyCodecUtf8 inh outh = - S.fold (FH.write outh) - $ SS.encodeUtf8 - $ SS.decodeUtf8 - $ S.unfold FH.read inh - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'copyCodecUtf8 --- inspect $ 'copyCodecUtf8 `hasNoType` ''Step --- inspect $ 'copyCodecUtf8 `hasNoType` ''AT.FlattenState --- inspect $ 'copyCodecUtf8 `hasNoType` ''D.ConcatMapUState -#endif - --- | Copy file -{-# INLINE copyCodecUtf8Lenient #-} -copyCodecUtf8Lenient :: Handle -> Handle -> IO () -copyCodecUtf8Lenient inh outh = - S.fold (FH.write outh) - $ SS.encodeUtf8 - $ SS.decodeUtf8Lax - $ S.unfold FH.read inh - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'copyCodecUtf8Lenient --- inspect $ 'copyCodecUtf8Lenient `hasNoType` ''Step --- inspect $ 'copyCodecUtf8Lenient `hasNoType` ''AT.FlattenState --- inspect $ 'copyCodecUtf8Lenient `hasNoType` ''D.ConcatMapUState -#endif - --- | Slice in chunks of size n and get the count of chunks. -{-# INLINE chunksOf #-} -chunksOf :: Int -> Handle -> IO Int -chunksOf n inh = - -- writeNUnsafe gives 2.5x boost here over writeN. - S.length $ S.chunksOf n (AT.writeNUnsafe n) (S.unfold FH.read inh) - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'chunksOf -inspect $ 'chunksOf `hasNoType` ''Step -inspect $ 'chunksOf `hasNoType` ''AT.FlattenState -inspect $ 'chunksOf `hasNoType` ''D.ConcatMapUState -inspect $ 'chunksOf `hasNoType` ''GroupState -#endif - --- This is to make sure that the concatMap in FH.read, groupsOf and foldlM' --- together can fuse. --- --- | Slice in chunks of size n and get the count of chunks. -{-# INLINE chunksOfD #-} -chunksOfD :: Int -> Handle -> IO Int -chunksOfD n inh = - D.foldlM' (\i _ -> return $ i + 1) 0 - $ D.groupsOf n (AT.writeNUnsafe n) - $ D.fromStreamK (S.unfold FH.read inh) - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'chunksOf -inspect $ 'chunksOf `hasNoType` ''Step -inspect $ 'chunksOfD `hasNoType` ''GroupState -inspect $ 'chunksOfD `hasNoType` ''AT.FlattenState -inspect $ 'chunksOfD `hasNoType` ''D.ConcatMapUState -#endif - -{-# INLINE linesUnlinesCopy #-} -linesUnlinesCopy :: Handle -> Handle -> IO () -linesUnlinesCopy inh outh = - S.fold (FH.write outh) - $ SS.encodeLatin1 - $ IUS.unlines IUF.fromList - $ S.splitOnSuffix (== '\n') FL.toList - $ SS.decodeLatin1 - $ S.unfold FH.read inh - -{-# INLINE linesUnlinesArrayWord8Copy #-} -linesUnlinesArrayWord8Copy :: Handle -> Handle -> IO () -linesUnlinesArrayWord8Copy inh outh = - S.fold (FH.write outh) - $ IP.interposeSuffix 10 A.read - $ S.splitOnSuffix (== 10) A.write - $ S.unfold FH.read inh - --- XXX splitSuffixOn requires -funfolding-use-threshold=150 for better fusion --- | Lines and unlines -{-# INLINE linesUnlinesArrayCharCopy #-} -linesUnlinesArrayCharCopy :: Handle -> Handle -> IO () -linesUnlinesArrayCharCopy inh outh = - S.fold (FH.write outh) - $ SS.encodeLatin1 - $ IUA.unlines - $ IUA.lines - $ SS.decodeLatin1 - $ S.unfold FH.read inh - -#ifdef INSPECTION -inspect $ hasNoTypeClassesExcept 'linesUnlinesArrayCharCopy [''Storable] --- inspect $ 'linesUnlinesArrayCharCopy `hasNoType` ''Step --- inspect $ 'linesUnlinesArrayCharCopy `hasNoType` ''AT.FlattenState --- inspect $ 'linesUnlinesArrayCharCopy `hasNoType` ''D.ConcatMapUState -#endif - --- XXX to write this we need to be able to map decodeUtf8 on the A.read fold. --- For that we have to write decodeUtf8 as a Pipe. -{- -{-# INLINE linesUnlinesArrayUtf8Copy #-} -linesUnlinesArrayUtf8Copy :: Handle -> Handle -> IO () -linesUnlinesArrayUtf8Copy inh outh = - S.fold (FH.write outh) - $ SS.encodeLatin1 - $ IP.intercalate (A.fromList [10]) (pipe SS.decodeUtf8P A.read) - $ S.splitOnSuffix (== '\n') (IFL.lmap SS.encodeUtf8 A.write) - $ SS.decodeLatin1 - $ S.unfold FH.read inh --} - -foreign import ccall unsafe "u_iswspace" - iswspace :: Int -> Int - --- Code copied from base/Data.Char to INLINE it -{-# INLINE isSpace #-} -isSpace :: Char -> Bool --- isSpace includes non-breaking space --- The magic 0x377 isn't really that magical. As of 2014, all the codepoints --- at or below 0x377 have been assigned, so we shouldn't have to worry about --- any new spaces appearing below there. It would probably be best to --- use branchless ||, but currently the eqLit transformation will undo that, --- so we'll do it like this until there's a way around that. -isSpace c - | uc <= 0x377 = uc == 32 || uc - 0x9 <= 4 || uc == 0xa0 - | otherwise = iswspace (ord c) /= 0 - where - uc = fromIntegral (ord c) :: Word - -{-# INLINE isSp #-} -isSp :: Word8 -> Bool -isSp = isSpace . chr . fromIntegral - --- | Word, unwords and copy -{-# INLINE wordsUnwordsCopyWord8 #-} -wordsUnwordsCopyWord8 :: Handle -> Handle -> IO () -wordsUnwordsCopyWord8 inh outh = - S.fold (FH.write outh) - $ IP.interposeSuffix 32 IUF.fromList - $ S.wordsBy isSp FL.toList - $ S.unfold FH.read inh - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'wordsUnwordsCopyWord8 --- inspect $ 'wordsUnwordsCopyWord8 `hasNoType` ''Step --- inspect $ 'wordsUnwordsCopyWord8 `hasNoType` ''D.ConcatMapUState -#endif - --- | Word, unwords and copy -{-# INLINE wordsUnwordsCopy #-} -wordsUnwordsCopy :: Handle -> Handle -> IO () -wordsUnwordsCopy inh outh = - S.fold (FH.write outh) - $ SS.encodeLatin1 - $ IUS.unwords IUF.fromList - -- XXX This pipeline does not fuse with wordsBy but fuses with splitOn - -- with -funfolding-use-threshold=300. With wordsBy it does not fuse - -- even with high limits for inlining and spec-constr ghc options. With - -- -funfolding-use-threshold=400 it performs pretty well and there - -- is no evidence in the core that a join point involving Step - -- constructors is not getting inlined. Not being able to fuse at all in - -- this case could be an unknown issue, need more investigation. - $ S.wordsBy isSpace FL.toList - -- -- $ S.splitOn isSpace FL.toList - $ SS.decodeLatin1 - $ S.unfold FH.read inh - -#ifdef INSPECTION --- inspect $ hasNoTypeClasses 'wordsUnwordsCopy --- inspect $ 'wordsUnwordsCopy `hasNoType` ''Step --- inspect $ 'wordsUnwordsCopy `hasNoType` ''AT.FlattenState --- inspect $ 'wordsUnwordsCopy `hasNoType` ''D.ConcatMapUState -#endif - -{-# INLINE wordsUnwordsCharArrayCopy #-} -wordsUnwordsCharArrayCopy :: Handle -> Handle -> IO () -wordsUnwordsCharArrayCopy inh outh = - S.fold (FH.write outh) - $ SS.encodeLatin1 - $ IUA.unwords - $ IUA.words - $ SS.decodeLatin1 - $ S.unfold FH.read inh - -lf :: Word8 -lf = fromIntegral (ord '\n') - -toarr :: String -> A.Array Word8 -toarr = A.fromList . map (fromIntegral . ord) - --- | Split on line feed. -{-# INLINE splitOn #-} -splitOn :: Handle -> IO Int -splitOn inh = - (S.length $ S.splitOn (== lf) FL.drain - $ S.unfold FH.read inh) -- >>= print - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'splitOn -inspect $ 'splitOn `hasNoType` ''Step -inspect $ 'splitOn `hasNoType` ''AT.FlattenState -inspect $ 'splitOn `hasNoType` ''D.ConcatMapUState -#endif - --- | Split suffix on line feed. -{-# INLINE splitOnSuffix #-} -splitOnSuffix :: Handle -> IO Int -splitOnSuffix inh = - (S.length $ S.splitOnSuffix (== lf) FL.drain - $ S.unfold FH.read inh) -- >>= print - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'splitOnSuffix -inspect $ 'splitOnSuffix `hasNoType` ''Step -inspect $ 'splitOnSuffix `hasNoType` ''AT.FlattenState -inspect $ 'splitOnSuffix `hasNoType` ''D.ConcatMapUState -#endif - --- | Words by space -{-# INLINE wordsBy #-} -wordsBy :: Handle -> IO Int -wordsBy inh = - (S.length $ S.wordsBy isSp FL.drain - $ S.unfold FH.read inh) -- >>= print - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'wordsBy -inspect $ 'wordsBy `hasNoType` ''Step -inspect $ 'wordsBy `hasNoType` ''AT.FlattenState -inspect $ 'wordsBy `hasNoType` ''D.ConcatMapUState -#endif - --- | Split on a word8 sequence. -{-# INLINE splitOnSeq #-} -splitOnSeq :: String -> Handle -> IO Int -splitOnSeq str inh = - (S.length $ IP.splitOnSeq (toarr str) FL.drain - $ S.unfold FH.read inh) -- >>= print - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'splitOnSeq --- inspect $ 'splitOnSeq `hasNoType` ''Step --- inspect $ 'splitOnSeq `hasNoType` ''AT.FlattenState --- inspect $ 'splitOnSeq `hasNoType` ''D.ConcatMapUState -#endif - --- | Split on a character sequence. -{-# INLINE splitOnSeqUtf8 #-} -splitOnSeqUtf8 :: String -> Handle -> IO Int -splitOnSeqUtf8 str inh = - (S.length $ IP.splitOnSeq (A.fromList str) FL.drain - $ IUS.decodeUtf8ArraysLenient - $ IFH.toChunks inh) -- >>= print - --- | Split on suffix sequence. -{-# INLINE splitOnSuffixSeq #-} -splitOnSuffixSeq :: String -> Handle -> IO Int -splitOnSuffixSeq str inh = - (S.length $ IP.splitOnSuffixSeq (toarr str) FL.drain - $ S.unfold FH.read inh) -- >>= print - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'splitOnSuffixSeq --- inspect $ 'splitOnSuffixSeq `hasNoType` ''Step --- inspect $ 'splitOnSuffixSeq `hasNoType` ''AT.FlattenState --- inspect $ 'splitOnSuffixSeq `hasNoType` ''D.ConcatMapUState -#endif diff --git a/src/Streamly/Benchmark/Prelude.hs b/src/Streamly/Benchmark/Prelude.hs deleted file mode 100644 --- a/src/Streamly/Benchmark/Prelude.hs +++ /dev/null @@ -1,912 +0,0 @@ --- | --- Module : Streamly.Benchmark.Prelude --- Copyright : (c) 2018 Harendra Kumar --- --- License : MIT --- Maintainer : streamly@composewell.com - -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} - -#ifdef __HADDOCK_VERSION__ -#undef INSPECTION -#endif - -#ifdef INSPECTION -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-} -#endif - -module Streamly.Benchmark.Prelude where - -import Control.DeepSeq (NFData) -import Control.Monad (when) -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.State.Strict (StateT, get, put) -import Data.Functor.Identity (Identity, runIdentity) -import Data.Maybe (fromJust) -import GHC.Generics (Generic) -import Prelude - (Monad, Int, (+), ($), (.), return, fmap, even, (>), (<=), (==), (>=), - subtract, undefined, Maybe(..), odd, Bool, not, (>>=), mapM_, curry, - maxBound, div, IO, compare, Double, fromIntegral, Integer, (<$>), - (<*>), flip, (**), (/)) -import qualified Prelude as P -import qualified Data.Foldable as F -import qualified GHC.Exts as GHC - -#ifdef INSPECTION -import Test.Inspection - -import qualified Streamly.Streams.StreamD as D -#endif - -import qualified Streamly as S hiding (runStream) -import qualified Streamly.Prelude as S -import qualified Streamly.Internal.Prelude as Internal -import qualified Streamly.Internal.Data.Unfold as UF -import qualified Streamly.Internal.Data.Pipe as Pipe - -value, maxValue, value2 :: Int -#ifdef LINEAR_ASYNC -value = 10000 -#else -value = 100000 -#endif -maxValue = value + 1 -value2 = P.round (P.fromIntegral value**(1/2::P.Double)) -- double nested loop - -------------------------------------------------------------------------------- --- Benchmark ops -------------------------------------------------------------------------------- - -------------------------------------------------------------------------------- --- Stream generation and elimination -------------------------------------------------------------------------------- - -type Stream m a = S.SerialT m a - -{-# INLINE source #-} -source :: (S.MonadAsync m, S.IsStream t) => Int -> t m Int -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] - -{-# INLINE sourceFromListM #-} -sourceFromListM :: (S.MonadAsync m, S.IsStream t) => Int -> t m Int -sourceFromListM n = S.fromListM (Prelude.fmap return [n..n+value]) - -{-# INLINE sourceFromIndices #-} -sourceFromIndices :: (Monad m, S.IsStream t) => Int -> t m Int -sourceFromIndices n = S.take value $ S.fromIndices (+ n) - -{-# INLINE sourceFromIndicesM #-} -sourceFromIndicesM :: (S.MonadAsync m, S.IsStream t) => Int -> t m Int -sourceFromIndicesM n = S.take value $ S.fromIndicesM (Prelude.fmap return (+ n)) - -{-# INLINE sourceFromFoldable #-} -sourceFromFoldable :: S.IsStream t => Int -> t m Int -sourceFromFoldable n = S.fromFoldable [n..n+value] - -{-# INLINE sourceFromFoldableM #-} -sourceFromFoldableM :: (S.IsStream t, S.MonadAsync m) => Int -> t m Int -sourceFromFoldableM n = S.fromFoldableM (Prelude.fmap return [n..n+value]) - -{-# INLINE sourceFoldMapWith #-} -sourceFoldMapWith :: (S.IsStream t, S.Semigroup (t m Int)) - => Int -> t m Int -sourceFoldMapWith n = S.foldMapWith (S.<>) S.yield [n..n+value] - -{-# INLINE sourceFoldMapWithM #-} -sourceFoldMapWithM :: (S.IsStream t, Monad m, S.Semigroup (t m Int)) - => Int -> t m Int -sourceFoldMapWithM n = S.foldMapWith (S.<>) (S.yieldM . return) [n..n+value] - -{-# INLINE sourceFoldMapM #-} -sourceFoldMapM :: (S.IsStream t, Monad m, P.Monoid (t m Int)) - => Int -> t m Int -sourceFoldMapM n = F.foldMap (S.yieldM . return) [n..n+value] - -{-# INLINE sourceConcatMapId #-} -sourceConcatMapId :: (S.IsStream t, Monad m) - => Int -> t m Int -sourceConcatMapId n = - S.concatMap P.id $ S.fromFoldable $ P.map (S.yieldM . return) [n..n+value] - -{-# INLINE sourceUnfoldr #-} -sourceUnfoldr :: (Monad m, S.IsStream t) => Int -> t m Int -sourceUnfoldr n = S.unfoldr step n - where - step cnt = - if cnt > n + value - then Nothing - else Just (cnt, cnt + 1) - -{-# INLINE sourceUnfoldrN #-} -sourceUnfoldrN :: (Monad m, S.IsStream t) => Int -> Int -> t m Int -sourceUnfoldrN upto start = S.unfoldr step start - where - step cnt = - if cnt > start + upto - then Nothing - else Just (cnt, cnt + 1) - -{-# INLINE sourceUnfoldrM #-} -sourceUnfoldrM :: (S.IsStream t, S.MonadAsync m) => Int -> t m Int -sourceUnfoldrM n = S.unfoldrM step n - where - step cnt = - if cnt > n + value - then return Nothing - else return (Just (cnt, cnt + 1)) - -{-# INLINE sourceUnfoldrState #-} -sourceUnfoldrState :: (S.IsStream t, S.MonadAsync m) - => Int -> t (StateT Int m) Int -sourceUnfoldrState n = S.unfoldrM step n - where - step cnt = - if cnt > n + value - then return Nothing - else do - s <- get - put (s + 1) - return (Just (s, cnt + 1)) - -{-# INLINE sourceUnfoldrMN #-} -sourceUnfoldrMN :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m Int -sourceUnfoldrMN upto start = S.unfoldrM step start - where - step cnt = - if cnt > start + upto - then return Nothing - else return (Just (cnt, cnt + 1)) - -{-# INLINE sourceUnfoldrMAction #-} -sourceUnfoldrMAction :: (S.IsStream t, S.MonadAsync m) => Int -> t m (m Int) -sourceUnfoldrMAction n = S.serially $ S.unfoldrM step n - where - step cnt = - if cnt > n + value - then return Nothing - 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 -------------------------------------------------------------------------------- - -{-# INLINE runStream #-} -runStream :: Monad m => Stream m a -> m () -runStream = S.drain - -{-# INLINE toList #-} -toList :: Monad m => Stream m Int -> m [Int] - -{-# INLINE evalStateT #-} -evalStateT :: S.MonadAsync m => Int -> Stream m Int -evalStateT n = Internal.evalStateT 0 (sourceUnfoldrState n) - -{-# INLINE withState #-} -withState :: S.MonadAsync m => Int -> Stream m Int -withState n = - Internal.evalStateT (0 :: Int) (Internal.liftInner (sourceUnfoldrM n)) - -{-# INLINE head #-} -{-# INLINE last #-} -{-# INLINE maximum #-} -{-# INLINE minimum #-} -{-# INLINE find #-} -{-# INLINE findIndex #-} -{-# INLINE elemIndex #-} -{-# INLINE foldl1'Reduce #-} -head, last, minimum, maximum, find, findIndex, elemIndex, foldl1'Reduce - :: Monad m => Stream m Int -> m (Maybe Int) - -{-# INLINE minimumBy #-} -{-# INLINE maximumBy #-} -minimumBy, maximumBy :: Monad m => Stream m Int -> m (Maybe Int) - -{-# INLINE foldl'Reduce #-} -{-# INLINE foldl'ReduceMap #-} -{-# INLINE foldlM'Reduce #-} -{-# INLINE foldrMReduce #-} -{-# INLINE length #-} -{-# INLINE sum #-} -{-# INLINE product #-} -foldl'Reduce, foldl'ReduceMap, foldlM'Reduce, foldrMReduce, length, sum, product - :: Monad m - => Stream m Int -> m Int - -{-# INLINE foldl'Build #-} -{-# INLINE foldlM'Build #-} -{-# INLINE foldrMBuild #-} -foldrMBuild, foldl'Build, foldlM'Build - :: Monad m - => Stream m Int -> m [Int] - -{-# INLINE all #-} -{-# INLINE any #-} -{-# INLINE and #-} -{-# INLINE or #-} -{-# INLINE null #-} -{-# INLINE elem #-} -{-# INLINE notElem #-} -null, elem, notElem, all, any, and, or :: Monad m => Stream m Int -> m Bool - -{-# INLINE toNull #-} -toNull :: Monad m => (t m a -> S.SerialT m a) -> t m a -> m () -toNull t = runStream . t - -{-# INLINE uncons #-} -uncons :: Monad m => Stream m Int -> m () -uncons s = do - r <- S.uncons s - case r of - Nothing -> return () - Just (_, t) -> uncons t - -{-# INLINE init #-} -init :: Monad m => Stream m a -> m () -init s = S.init s >>= Prelude.mapM_ S.drain - -{-# INLINE tail #-} -tail :: Monad m => Stream m a -> m () -tail s = S.tail s >>= Prelude.mapM_ tail - -{-# INLINE nullHeadTail #-} -nullHeadTail :: Monad m => Stream m Int -> m () -nullHeadTail s = do - r <- S.null s - when (not r) $ do - _ <- S.head s - S.tail s >>= Prelude.mapM_ nullHeadTail - -{-# INLINE mapM_ #-} -mapM_ :: Monad m => Stream m Int -> m () -mapM_ = S.mapM_ (\_ -> return ()) - -toList = S.toList - -{-# INLINE toListRev #-} -toListRev :: Monad m => Stream m Int -> m [Int] -toListRev = Internal.toListRev - -foldrMBuild = S.foldrM (\x xs -> xs >>= return . (x :)) (return []) -foldl'Build = S.foldl' (flip (:)) [] -foldlM'Build = S.foldlM' (\xs x -> return $ x : xs) [] - -foldrMReduce = S.foldrM (\x xs -> xs >>= return . (x +)) (return 0) -foldl'Reduce = S.foldl' (+) 0 -foldl'ReduceMap = P.fmap (+1) . S.foldl' (+) 0 -foldl1'Reduce = S.foldl1' (+) -foldlM'Reduce = S.foldlM' (\xs a -> return $ a + xs) 0 - -last = S.last -null = S.null -head = S.head -elem = S.elem maxValue -notElem = S.notElem maxValue -length = S.length -all = S.all (<= maxValue) -any = S.any (> maxValue) -and = S.and . S.map (<= maxValue) -or = S.or . S.map (> maxValue) -find = S.find (== maxValue) -findIndex = S.findIndex (== maxValue) -elemIndex = S.elemIndex maxValue -maximum = S.maximum -minimum = S.minimum -sum = S.sum -product = S.product -minimumBy = S.minimumBy compare -maximumBy = S.maximumBy compare - -------------------------------------------------------------------------------- --- Transformation -------------------------------------------------------------------------------- - -{-# INLINE transform #-} -transform :: Monad m => Stream m a -> m () -transform = runStream - -{-# INLINE composeN #-} -composeN - :: MonadIO m - => Int -> (Stream m Int -> Stream m Int) -> Stream m Int -> m () -composeN n f = - case n of - 1 -> transform . f - 2 -> transform . f . f - 3 -> transform . f . f . f - 4 -> transform . f . f . f . f - _ -> undefined - --- polymorphic stream version of composeN -{-# INLINE composeN' #-} -composeN' - :: (S.IsStream t, Monad m) - => Int -> (t m Int -> Stream m Int) -> t m Int -> m () -composeN' n f = - case n of - 1 -> transform . f - 2 -> transform . f . S.adapt . f - 3 -> transform . f . S.adapt . f . S.adapt . f - 4 -> transform . f . S.adapt . f . S.adapt . f . S.adapt . f - _ -> undefined - -{-# INLINE scan #-} -{-# INLINE scanl1' #-} -{-# INLINE map #-} -{-# INLINE fmap #-} -{-# INLINE mapMaybe #-} -{-# INLINE filterEven #-} -{-# INLINE filterAllOut #-} -{-# INLINE filterAllIn #-} -{-# INLINE takeOne #-} -{-# INLINE takeAll #-} -{-# INLINE takeWhileTrue #-} -{-# INLINE takeWhileMTrue #-} -{-# INLINE dropOne #-} -{-# INLINE dropAll #-} -{-# INLINE dropWhileTrue #-} -{-# INLINE dropWhileMTrue #-} -{-# INLINE dropWhileFalse #-} -{-# INLINE findIndices #-} -{-# INLINE elemIndices #-} -{-# INLINE insertBy #-} -{-# INLINE deleteBy #-} -{-# INLINE reverse #-} -{-# INLINE reverse' #-} -{-# INLINE foldrS #-} -{-# INLINE foldrSMap #-} -{-# INLINE foldrT #-} -{-# INLINE foldrTMap #-} -scan, scanl1', map, fmap, mapMaybe, filterEven, filterAllOut, - filterAllIn, takeOne, takeAll, takeWhileTrue, takeWhileMTrue, dropOne, - dropAll, dropWhileTrue, dropWhileMTrue, dropWhileFalse, - findIndices, elemIndices, insertBy, deleteBy, reverse, reverse', - foldrS, foldrSMap, foldrT, foldrTMap - :: MonadIO m - => Int -> Stream m Int -> m () - -{-# INLINE mapMaybeM #-} -{-# INLINE intersperse #-} -mapMaybeM, intersperse :: S.MonadAsync m => Int -> Stream m Int -> m () - -{-# INLINE mapM #-} -{-# INLINE map' #-} -{-# INLINE fmap' #-} -mapM, map' :: (S.IsStream t, S.MonadAsync m) - => (t m Int -> S.SerialT m Int) -> Int -> t m Int -> m () - -fmap' :: (S.IsStream t, S.MonadAsync m, P.Functor (t m)) - => (t m Int -> S.SerialT m Int) -> Int -> t m Int -> m () - -{-# INLINE sequence #-} -sequence :: (S.IsStream t, S.MonadAsync m) - => (t m Int -> S.SerialT m Int) -> t m (m Int) -> m () - -scan n = composeN n $ S.scanl' (+) 0 -scanl1' n = composeN n $ S.scanl1' (+) -fmap n = composeN n $ Prelude.fmap (+1) -fmap' t n = composeN' n $ t . Prelude.fmap (+1) -map n = composeN n $ S.map (+1) -map' t n = composeN' n $ t . S.map (+1) -mapM t n = composeN' n $ t . S.mapM return - -{-# INLINE transformMapM #-} -{-# INLINE transformComposeMapM #-} -{-# INLINE transformTeeMapM #-} -{-# INLINE transformZipMapM #-} - -transformMapM, transformComposeMapM, transformTeeMapM, - transformZipMapM :: (S.IsStream t, S.MonadAsync m) - => (t m Int -> S.SerialT m Int) -> Int -> t m Int -> m () - -transformMapM t n = composeN' n $ t . Internal.transform (Pipe.mapM return) -transformComposeMapM t n = composeN' n $ t . Internal.transform - (Pipe.mapM (\x -> return (x + 1)) - `Pipe.compose` Pipe.mapM (\x -> return (x + 2))) -transformTeeMapM t n = composeN' n $ t . Internal.transform - (Pipe.mapM (\x -> return (x + 1)) - `Pipe.tee` Pipe.mapM (\x -> return (x + 2))) -transformZipMapM t n = composeN' n $ t . Internal.transform - (Pipe.zipWith (+) (Pipe.mapM (\x -> return (x + 1))) - (Pipe.mapM (\x -> return (x + 2)))) - -mapMaybe n = composeN n $ S.mapMaybe - (\x -> if Prelude.odd x then Nothing else Just x) -mapMaybeM n = composeN n $ S.mapMaybeM - (\x -> if Prelude.odd x then return Nothing else return $ Just x) -sequence t = transform . t . S.sequence -filterEven n = composeN n $ S.filter even -filterAllOut n = composeN n $ S.filter (> maxValue) -filterAllIn n = composeN n $ S.filter (<= maxValue) -takeOne n = composeN n $ S.take 1 -takeAll n = composeN n $ S.take maxValue -takeWhileTrue n = composeN n $ S.takeWhile (<= maxValue) -takeWhileMTrue n = composeN n $ S.takeWhileM (return . (<= maxValue)) -dropOne n = composeN n $ S.drop 1 -dropAll n = composeN n $ S.drop maxValue -dropWhileTrue n = composeN n $ S.dropWhile (<= maxValue) -dropWhileMTrue n = composeN n $ S.dropWhileM (return . (<= maxValue)) -dropWhileFalse n = composeN n $ S.dropWhile (> maxValue) -findIndices n = composeN n $ S.findIndices (== maxValue) -elemIndices n = composeN n $ S.elemIndices maxValue -intersperse n = composeN n $ S.intersperse maxValue -insertBy n = composeN n $ S.insertBy compare maxValue -deleteBy n = composeN n $ S.deleteBy (>=) maxValue -reverse n = composeN n $ S.reverse -reverse' n = composeN n $ Internal.reverse' -foldrS n = composeN n $ Internal.foldrS S.cons S.nil -foldrSMap n = composeN n $ Internal.foldrS (\x xs -> x + 1 `S.cons` xs) S.nil -foldrT n = composeN n $ Internal.foldrT S.cons S.nil -foldrTMap n = composeN n $ Internal.foldrT (\x xs -> x + 1 `S.cons` xs) S.nil - -------------------------------------------------------------------------------- --- 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 #-} -zip :: Int -> Int -> IO () -zip count n = - S.drain $ S.zipWith (,) - (sourceUnfoldrMN count n) - (sourceUnfoldrMN count (n + 1)) - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'zip -inspect $ 'zip `hasNoType` ''D.Step -#endif - -{-# INLINE zipM #-} -zipM :: Int -> Int -> IO () -zipM count n = - S.drain $ S.zipWithM (curry return) - (sourceUnfoldrMN count n) - (sourceUnfoldrMN count (n + 1)) - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'zipM -inspect $ 'zipM `hasNoType` ''D.Step -#endif - -{-# INLINE mergeBy #-} -mergeBy :: Int -> Int -> IO () -mergeBy count n = - S.drain $ S.mergeBy P.compare - (sourceUnfoldrMN count n) - (sourceUnfoldrMN count (n + 1)) - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'mergeBy -inspect $ 'mergeBy `hasNoType` ''D.Step -#endif - -{-# INLINE serial2 #-} -serial2 :: Int -> Int -> IO () -serial2 count n = - S.drain $ S.serial - (sourceUnfoldrMN count n) - (sourceUnfoldrMN count (n + 1)) - -{-# INLINE serial4 #-} -serial4 :: Int -> Int -> IO () -serial4 count n = - S.drain $ S.serial - ((S.serial (sourceUnfoldrMN count n) - (sourceUnfoldrMN count (n + 1)))) - ((S.serial (sourceUnfoldrMN count (n+2)) - (sourceUnfoldrMN count (n + 3)))) - -{-# INLINE append2 #-} -append2 :: Int -> Int -> IO () -append2 count n = - S.drain $ Internal.append - (sourceUnfoldrMN count n) - (sourceUnfoldrMN count (n + 1)) - -{-# INLINE append4 #-} -append4 :: Int -> Int -> IO () -append4 count n = - S.drain $ Internal.append - ((Internal.append (sourceUnfoldrMN count n) - (sourceUnfoldrMN count (n + 1)))) - ((Internal.append (sourceUnfoldrMN count (n+2)) - (sourceUnfoldrMN count (n + 3)))) - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'append2 -inspect $ 'append2 `hasNoType` ''D.AppendState -#endif - -{-# INLINE wSerial2 #-} -wSerial2 :: Int -> IO () -wSerial2 n = S.drain $ S.wSerial - (sourceUnfoldrMN (value `div` 2) n) - (sourceUnfoldrMN (value `div` 2) (n + 1)) - -{-# INLINE interleave2 #-} -interleave2 :: Int -> IO () -interleave2 n = S.drain $ Internal.interleave - (sourceUnfoldrMN (value `div` 2) n) - (sourceUnfoldrMN (value `div` 2) (n + 1)) - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'interleave2 -inspect $ 'interleave2 `hasNoType` ''D.InterleaveState -#endif - -{-# INLINE roundRobin2 #-} -roundRobin2 :: Int -> IO () -roundRobin2 n = S.drain $ Internal.roundrobin - (sourceUnfoldrMN (value `div` 2) n) - (sourceUnfoldrMN (value `div` 2) (n + 1)) - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'roundRobin2 -inspect $ 'roundRobin2 `hasNoType` ''D.InterleaveState -#endif - -{-# INLINE isPrefixOf #-} -{-# INLINE isSubsequenceOf #-} -isPrefixOf, isSubsequenceOf :: Monad m => Stream m Int -> m Bool - -isPrefixOf src = S.isPrefixOf src src -isSubsequenceOf src = S.isSubsequenceOf src src - -{-# INLINE stripPrefix #-} -stripPrefix :: Monad m => Stream m Int -> m () -stripPrefix src = do - _ <- S.stripPrefix src src - return () - -{-# INLINE zipAsync #-} -{-# INLINE zipAsyncM #-} -{-# INLINE zipAsyncAp #-} -zipAsync, zipAsyncAp, zipAsyncM :: S.MonadAsync m => Stream m Int -> m () - -zipAsync src = do - r <- S.tail src - let src1 = fromJust r - transform (S.zipAsyncWith (,) src src1) - -zipAsyncM src = do - r <- S.tail src - let src1 = fromJust r - transform (S.zipAsyncWithM (curry return) src src1) - -zipAsyncAp src = do - r <- S.tail src - let src1 = fromJust r - transform (S.zipAsyncly $ (,) <$> S.serially src - <*> S.serially src1) - -{-# INLINE eqBy' #-} -eqBy' :: (Monad m, P.Eq a) => Stream m a -> m P.Bool -eqBy' src = S.eqBy (==) src src - -{-# INLINE eqBy #-} -eqBy :: Int -> IO Bool -eqBy n = eqBy' (source n) - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'eqBy -inspect $ 'eqBy `hasNoType` ''D.Step -#endif - - -{-# INLINE eqByPure #-} -eqByPure :: Int -> Identity Bool -eqByPure n = eqBy' (sourceUnfoldr n) - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'eqByPure -inspect $ 'eqByPure `hasNoType` ''D.Step -#endif - -{-# INLINE cmpBy' #-} -cmpBy' :: (Monad m, P.Ord a) => Stream m a -> m P.Ordering -cmpBy' src = S.cmpBy P.compare src src - -{-# INLINE cmpBy #-} -cmpBy :: Int -> IO P.Ordering -cmpBy n = cmpBy' (source n) - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'cmpBy -inspect $ 'cmpBy `hasNoType` ''D.Step -#endif - -{-# INLINE cmpByPure #-} -cmpByPure :: Int -> Identity P.Ordering -cmpByPure n = cmpBy' (sourceUnfoldr n) - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'cmpByPure -inspect $ 'cmpByPure `hasNoType` ''D.Step -#endif - -{-# INLINE concatMap #-} -concatMap :: Int -> Int -> Int -> IO () -concatMap outer inner n = - S.drain $ S.concatMap - (\_ -> sourceUnfoldrMN inner n) - (sourceUnfoldrMN outer n) - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'concatMap -#endif - -{-# INLINE concatMapPure #-} -concatMapPure :: Int -> Int -> Int -> IO () -concatMapPure outer inner n = - S.drain $ S.concatMap - (\_ -> sourceUnfoldrN inner n) - (sourceUnfoldrN outer n) - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'concatMapPure -#endif - -{-# INLINE concatMapRepl4xN #-} -concatMapRepl4xN :: Int -> IO () -concatMapRepl4xN n = S.drain $ S.concatMap (S.replicate 4) - (sourceUnfoldrMN (value `div` 4) n) - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'concatMapRepl4xN -#endif - -{-# INLINE concatUnfoldRepl4xN #-} -concatUnfoldRepl4xN :: Int -> IO () -concatUnfoldRepl4xN n = - S.drain $ S.concatUnfold - (UF.replicateM 4) - (sourceUnfoldrMN (value `div` 4) n) - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'concatUnfoldRepl4xN -inspect $ 'concatUnfoldRepl4xN `hasNoType` ''D.ConcatMapUState -#endif - -{-# INLINE concatMapWithSerial #-} -concatMapWithSerial :: Int -> Int -> Int -> IO () -concatMapWithSerial outer inner n = - S.drain $ S.concatMapWith S.serial - (\_ -> sourceUnfoldrMN inner n) - (sourceUnfoldrMN outer n) - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'concatMapWithSerial -#endif - -{-# INLINE concatMapWithAppend #-} -concatMapWithAppend :: Int -> Int -> Int -> IO () -concatMapWithAppend outer inner n = - S.drain $ S.concatMapWith Internal.append - (\_ -> sourceUnfoldrMN inner n) - (sourceUnfoldrMN outer n) - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'concatMapWithAppend -#endif - -{-# INLINE concatMapWithWSerial #-} -concatMapWithWSerial :: Int -> Int -> Int -> IO () -concatMapWithWSerial outer inner n = - S.drain $ S.concatMapWith S.wSerial - (\_ -> sourceUnfoldrMN inner n) - (sourceUnfoldrMN outer n) - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'concatMapWithWSerial -#endif - -{-# INLINE concatUnfoldInterleaveRepl4xN #-} -concatUnfoldInterleaveRepl4xN :: Int -> IO () -concatUnfoldInterleaveRepl4xN n = - S.drain $ Internal.concatUnfoldInterleave - (UF.replicateM 4) - (sourceUnfoldrMN (value `div` 4) n) - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'concatUnfoldInterleaveRepl4xN --- inspect $ 'concatUnfoldInterleaveRepl4xN `hasNoType` ''D.ConcatUnfoldInterleaveState -#endif - -{-# INLINE concatUnfoldRoundrobinRepl4xN #-} -concatUnfoldRoundrobinRepl4xN :: Int -> IO () -concatUnfoldRoundrobinRepl4xN n = - S.drain $ Internal.concatUnfoldRoundrobin - (UF.replicateM 4) - (sourceUnfoldrMN (value `div` 4) n) - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'concatUnfoldRoundrobinRepl4xN --- inspect $ 'concatUnfoldRoundrobinRepl4xN `hasNoType` ''D.ConcatUnfoldInterleaveState -#endif - -------------------------------------------------------------------------------- --- Mixed Composition -------------------------------------------------------------------------------- - -{-# INLINE scanMap #-} -{-# INLINE dropMap #-} -{-# INLINE dropScan #-} -{-# INLINE takeDrop #-} -{-# INLINE takeScan #-} -{-# INLINE takeMap #-} -{-# INLINE filterDrop #-} -{-# INLINE filterTake #-} -{-# INLINE filterScan #-} -{-# INLINE filterScanl1 #-} -{-# INLINE filterMap #-} -scanMap, dropMap, dropScan, takeDrop, takeScan, takeMap, filterDrop, - filterTake, filterScan, filterScanl1, filterMap - :: MonadIO m => Int -> Stream m Int -> m () - -scanMap n = composeN n $ S.map (subtract 1) . S.scanl' (+) 0 -dropMap n = composeN n $ S.map (subtract 1) . S.drop 1 -dropScan n = composeN n $ S.scanl' (+) 0 . S.drop 1 -takeDrop n = composeN n $ S.drop 1 . S.take maxValue -takeScan n = composeN n $ S.scanl' (+) 0 . S.take maxValue -takeMap n = composeN n $ S.map (subtract 1) . S.take maxValue -filterDrop n = composeN n $ S.drop 1 . S.filter (<= maxValue) -filterTake n = composeN n $ S.take maxValue . S.filter (<= maxValue) -filterScan n = composeN n $ S.scanl' (+) 0 . S.filter (<= maxBound) -filterScanl1 n = composeN n $ S.scanl1' (+) . S.filter (<= maxBound) -filterMap n = composeN n $ S.map (subtract 1) . S.filter (<= maxValue) - -data Pair a b = Pair !a !b deriving (Generic, NFData) - -{-# INLINE sumProductFold #-} -sumProductFold :: Monad m => Stream m Int -> m (Int, Int) -sumProductFold = S.foldl' (\(s,p) x -> (s + x, p P.* x)) (0,1) - -{-# INLINE sumProductScan #-} -sumProductScan :: Monad m => Stream m Int -> m (Pair Int Int) -sumProductScan = S.foldl' (\(Pair _ p) (s0,x) -> Pair s0 (p P.* x)) (Pair 0 1) - . S.scanl' (\(s,_) x -> (s + x,x)) (0,0) - -------------------------------------------------------------------------------- --- Pure stream operations -------------------------------------------------------------------------------- - -{-# INLINE eqInstance #-} -eqInstance :: Stream Identity Int -> Bool -eqInstance src = src == src - -{-# INLINE eqInstanceNotEq #-} -eqInstanceNotEq :: Stream Identity Int -> Bool -eqInstanceNotEq src = src P./= src - -{-# INLINE ordInstance #-} -ordInstance :: Stream Identity Int -> Bool -ordInstance src = src P.< src - -{-# INLINE ordInstanceMin #-} -ordInstanceMin :: Stream Identity Int -> Stream Identity Int -ordInstanceMin src = P.min src src - -{-# INLINE showInstance #-} -showInstance :: Stream Identity Int -> P.String -showInstance src = P.show src - -{-# INLINE showInstanceList #-} -showInstanceList :: [Int] -> P.String -showInstanceList src = P.show src - -{-# INLINE readInstance #-} -readInstance :: P.String -> Stream Identity Int -readInstance str = - let r = P.reads str - in case r of - [(x,"")] -> x - _ -> P.error "readInstance: no parse" - -{-# INLINE readInstanceList #-} -readInstanceList :: P.String -> [Int] -readInstanceList str = - let r = P.reads str - in case r of - [(x,"")] -> x - _ -> P.error "readInstance: no parse" - -{-# 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/src/Streamly/Data/Array.hs b/src/Streamly/Data/Array.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Data/Array.hs @@ -0,0 +1,43 @@ +-- | +-- Module : Streamly.Data.Array +-- Copyright : (c) 2019 Composewell Technologies +-- +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +module Streamly.Data.Array + ( Array + + -- * Construction + , A.fromListN + , A.fromList + + -- Stream Folds + , A.fromStreamN + , A.fromStream + + -- MonadicAPIs + , A.writeN + , A.write + + -- * Elimination + + , A.toStream + , A.toStreamRev + , A.read + + -- * Random Access + + -- * Folding Arrays + , A.streamFold + , A.fold + + , A.length + ) +where + +import Streamly.Internal.Data.Array (Array) + +import qualified Streamly.Internal.Data.Array as A diff --git a/src/Streamly/Data/Fold.hs b/src/Streamly/Data/Fold.hs --- a/src/Streamly/Data/Fold.hs +++ b/src/Streamly/Data/Fold.hs @@ -37,6 +37,15 @@ -- on stream types can be as efficient as transformations on 'Fold' (e.g. -- 'Streamly.Internal.Data.Fold.lmap'). -- +-- = Left folds vs Right Folds +-- +-- The folds in this module are left folds, therefore, even partial folds, e.g. +-- @head@ in this module, would drain the whole stream. On the other hand, the +-- partial folds in "Streamly.Prelude" module are lazy right folds and would +-- terminate as soon as the result is determined. However, the folds in this +-- module can be composed but the folds in "Streamly.Prelude" cannot be +-- composed. +-- -- = Programmer Notes -- -- > import qualified Streamly.Data.Fold as FL @@ -190,7 +199,7 @@ -- ... -- @ -- - -- To compute the average of numbers in a stream without going throught he + -- To compute the average of numbers in a stream without going through the -- stream twice: -- -- >>> let avg = (/) <$> FL.sum <*> fmap fromIntegral FL.length diff --git a/src/Streamly/Data/Prim/Array.hs b/src/Streamly/Data/Prim/Array.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Data/Prim/Array.hs @@ -0,0 +1,44 @@ +-- | +-- Module : Streamly.Data.Prim.Array +-- Copyright : (c) 2019 Composewell Technologies +-- +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +module Streamly.Data.Prim.Array + ( PrimArray + , Prim + + -- * Construction + , A.fromListN + , A.fromList + + -- Stream Folds + -- , A.fromStreamN + -- , A.fromStream + + -- MonadicAPIs + , A.writeN + , A.write + + -- * Elimination + + -- , A.toStream + -- , A.toStreamRev + , A.read + + -- * Random Access + + -- * Folding Arrays + -- , A.streamFold + -- , A.fold + + , A.length + ) +where + +import Streamly.Internal.Data.Prim.Array (PrimArray, Prim) + +import qualified Streamly.Internal.Data.Prim.Array as A diff --git a/src/Streamly/Data/SmallArray.hs b/src/Streamly/Data/SmallArray.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Data/SmallArray.hs @@ -0,0 +1,34 @@ +-- | +-- Module : Streamly.Data.SmallArray +-- Copyright : (c) 2019 Composewell Technologies +-- +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +module Streamly.Data.SmallArray + ( SmallArray + + -- * Construction + , A.fromListN + , A.fromStreamN + + , A.writeN + + -- * Elimination + , A.toStream + , A.toStreamRev + , A.read + + -- * Folding Arrays + , A.streamFold + , A.fold + + , A.length + ) +where + +import Streamly.Internal.Data.SmallArray (SmallArray) + +import qualified Streamly.Internal.Data.SmallArray as A diff --git a/src/Streamly/Data/Unfold.hs b/src/Streamly/Data/Unfold.hs --- a/src/Streamly/Data/Unfold.hs +++ b/src/Streamly/Data/Unfold.hs @@ -1,12 +1,9 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} #include "inline.hs" @@ -22,8 +19,8 @@ -- values from a single starting value often called a seed value. Values can be -- generated and /pulled/ from the 'Unfold' one at a time. It can also be -- called a producer or a source of stream. It is a data representation of the --- standard 'S.unfoldr' function. An 'Unfold' can be converted into a stream --- type using 'S.unfold' by supplying the seed. +-- standard 'Streamly.Prelude.unfoldr' function. An 'Unfold' can be converted +-- into a stream type using 'Streamly.Prelude.unfold' by supplying the seed. -- -- = Performance Notes -- @@ -34,13 +31,13 @@ -- @Unfold m a b@ can be considered roughly equivalent to an action @a -> t m -- b@ (where @t@ is a stream type). Instead of using an 'Unfold' one could just -- use a function of the shape @a -> t m b@. However, working with stream types --- like 'S.SerialT' does not allow the compiler to perform stream fusion +-- like t'Streamly.SerialT' does not allow the compiler to perform stream fusion -- optimization when merging, appending or concatenating multiple streams. -- Even though stream based combinator have excellent performance, they are -- much less efficient when compared to combinators using 'Unfold'. For --- example, the 'S.concatMap' combinator which uses @a -> t m b@ (where @t@ is --- a stream type) to generate streams is much less efficient compared to --- 'S.concatUnfold'. +-- example, the 'Streamly.Prelude.concatMap' combinator which uses @a -> t m b@ +-- (where @t@ is a stream type) to generate streams is much less efficient +-- compared to 'Streamly.Prelude.concatUnfold'. -- -- On the other hand, transformation operations on stream types are as -- efficient as transformations on 'Unfold'. @@ -58,8 +55,8 @@ -- More, not yet exposed, unfold combinators can be found in -- "Streamly.Internal.Data.Unfold". --- The stream types (e.g. 'S.SerialT') can be considered as a special case of --- 'Unfold' with no starting seed. +-- The stream types (e.g. t'Streamly.SerialT') can be considered as a special +-- case of 'Unfold' with no starting seed. -- module Streamly.Data.Unfold ( diff --git a/src/Streamly/Data/Unicode/Stream.hs b/src/Streamly/Data/Unicode/Stream.hs --- a/src/Streamly/Data/Unicode/Stream.hs +++ b/src/Streamly/Data/Unicode/Stream.hs @@ -58,8 +58,9 @@ -- -- = Experimental APIs -- --- Some experimental APIs to conveniently process text using the @Array Char@ --- represenation directly can be found in "Streamly.Internal.Unicode.Array". +-- Some experimental APIs to conveniently process text using the +-- @Array Char@ represenation directly can be found in +-- "Streamly.Internal.Memory.Unicode.Array". -- XXX an unpinned array representation can be useful to store short and short -- lived strings in memory. diff --git a/src/Streamly/FileSystem/FD.hs b/src/Streamly/FileSystem/FD.hs --- a/src/Streamly/FileSystem/FD.hs +++ b/src/Streamly/FileSystem/FD.hs @@ -1,8 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE UnboxedTuples #-} #include "inline.hs" @@ -137,12 +133,12 @@ import qualified GHC.IO.Device as RawIO import Streamly.Internal.Memory.Array.Types (Array(..), byteLength, defaultChunkSize) -import Streamly.Streams.Serial (SerialT) -import Streamly.Streams.StreamK.Type (IsStream, mkStream) +import Streamly.Internal.Data.Stream.Serial (SerialT) +import Streamly.Internal.Data.Stream.StreamK.Type (IsStream, mkStream) #if !defined(mingw32_HOST_OS) import Streamly.Internal.Memory.Array.Types (groupIOVecsOf) -import Streamly.Streams.StreamD (toStreamD) +import Streamly.Internal.Data.Stream.StreamD (toStreamD) import Streamly.Internal.Data.Stream.StreamD.Type (fromStreamD) import qualified Streamly.FileSystem.FDIO as RawIO hiding (write) #endif @@ -204,7 +200,7 @@ -- the same absolute path name and neither has been renamed, for example. -- openFile :: FilePath -> IOMode -> IO Handle -openFile path mode = fmap (Handle . fst) $ FD.openFile path mode True +openFile path mode = Handle . fst <$> FD.openFile path mode True ------------------------------------------------------------------------------- -- Array IO (Input) @@ -241,7 +237,7 @@ {-# INLINABLE writeArray #-} writeArray :: Storable a => Handle -> Array a -> IO () writeArray _ arr | A.length arr == 0 = return () -writeArray (Handle fd) arr = withForeignPtr (aStart arr) $ \p -> do +writeArray (Handle fd) arr = withForeignPtr (aStart arr) $ \p -> -- RawIO.writeAll fd (castPtr p) aLen RawIO.write fd (castPtr p) aLen {- @@ -349,7 +345,7 @@ -- @since 0.7.0 {-# INLINE writeArrays #-} writeArrays :: (MonadIO m, Storable a) => Handle -> SerialT m (Array a) -> m () -writeArrays h m = S.mapM_ (liftIO . writeArray h) m +writeArrays h = S.mapM_ (liftIO . writeArray h) -- | Write a stream of arrays to a handle after coalescing them in chunks of -- specified size. The chunk size is only a maximum and the actual writes could @@ -369,7 +365,7 @@ -- @since 0.7.0 {-# INLINE writev #-} writev :: MonadIO m => Handle -> SerialT m (Array RawIO.IOVec) -> m () -writev h m = S.mapM_ (liftIO . writeIOVec h) m +writev h = S.mapM_ (liftIO . writeIOVec h) -- XXX this is incomplete -- | Write a stream of arrays to a handle after grouping them in 'IOVec' arrays diff --git a/src/Streamly/FileSystem/FDIO.hs b/src/Streamly/FileSystem/FDIO.hs --- a/src/Streamly/FileSystem/FDIO.hs +++ b/src/Streamly/FileSystem/FDIO.hs @@ -1,8 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE UnboxedTuples #-} #include "inline.hs" diff --git a/src/Streamly/FileSystem/Handle.hs b/src/Streamly/FileSystem/Handle.hs --- a/src/Streamly/FileSystem/Handle.hs +++ b/src/Streamly/FileSystem/Handle.hs @@ -1,8 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE UnboxedTuples #-} #include "inline.hs" diff --git a/src/Streamly/Internal/BaseCompat.hs b/src/Streamly/Internal/BaseCompat.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/BaseCompat.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE CPP #-} + +-- | +-- Module : Streamly.Internal.BaseCompat +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- Compatibility functions for "base" package. +-- +module Streamly.Internal.BaseCompat + ( + (#.) + , errorWithoutStackTrace + ) +where + +import Data.Coerce (Coercible, coerce) + +{-# INLINE (#.) #-} +(#.) :: Coercible b c => (b -> c) -> (a -> b) -> (a -> c) +(#.) _f = coerce + +#if !(MIN_VERSION_base(4,9,0)) +{-# NOINLINE errorWithoutStackTrace #-} +errorWithoutStackTrace :: [Char] -> a +errorWithoutStackTrace s = error s +#endif diff --git a/src/Streamly/Internal/Control/Monad.hs b/src/Streamly/Internal/Control/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Control/Monad.hs @@ -0,0 +1,28 @@ +-- | +-- Module : Streamly.Internal.Control.Monad +-- Copyright : (c) 2019 Composewell Technologies +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- Additional "Control.Monad" utilities. + +{-# LANGUAGE ScopedTypeVariables #-} + +module Streamly.Internal.Control.Monad + ( discard + ) +where + +import Control.Monad (void) +import Control.Monad.Catch (MonadCatch, catch, SomeException) + +-- | Discard any exceptions or value returned by an effectful action. +-- +-- /Internal/ +-- +{-# INLINE discard #-} +discard :: MonadCatch m => m b -> m () +discard action = (void $ action) `catch` (\(_ :: SomeException) -> return ()) diff --git a/src/Streamly/Internal/Data/Array.hs b/src/Streamly/Internal/Data/Array.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Array.hs @@ -0,0 +1,203 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +#include "inline.hs" + +-- | +-- Module : Streamly.Internal.Data.Array +-- Copyright : (c) 2019 Composewell Technologies +-- +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +module Streamly.Internal.Data.Array + ( Array(..) + + , foldl' + , foldr + + , length + + , writeN + , write + + , toStreamD + , toStreamDRev + + , toStream + , toStreamRev + , read + + , fromListN + , fromList + , fromStreamDN + , fromStreamD + + , fromStreamN + , fromStream + + , streamFold + , fold + ) +where + +import Prelude hiding (foldr, length, read) +import Control.DeepSeq (NFData(..)) +import Control.Monad (when) +import Control.Monad.IO.Class (liftIO, MonadIO) +import GHC.IO (unsafePerformIO) +import GHC.Base (Int(..)) +import Data.Functor.Identity (runIdentity) +import Data.Primitive.Array hiding (fromList, fromListN) +import qualified GHC.Exts as Exts + +import Streamly.Internal.Data.Unfold.Types (Unfold(..)) +import Streamly.Internal.Data.Fold.Types (Fold(..)) +import Streamly.Internal.Data.Stream.StreamK.Type (IsStream) +import Streamly.Internal.Data.Stream.Serial (SerialT) + +import qualified Streamly.Internal.Data.Stream.StreamD as D + +{-# NOINLINE bottomElement #-} +bottomElement :: a +bottomElement = undefined + +{-# INLINE_NORMAL toStreamD #-} +toStreamD :: Monad m => Array a -> D.Stream m a +toStreamD arr = D.Stream step 0 + where + {-# INLINE_LATE step #-} + step _ i + | i == length arr = return D.Stop + step _ (I# i) = + return $ + case Exts.indexArray# (array# arr) i of + (# x #) -> D.Yield x ((I# i) + 1) + +{-# INLINE length #-} +length :: Array a -> Int +length arr = sizeofArray arr + +{-# INLINE_NORMAL toStreamDRev #-} +toStreamDRev :: Monad m => Array a -> D.Stream m a +toStreamDRev arr = D.Stream step (length arr - 1) + where + {-# INLINE_LATE step #-} + step _ i + | i < 0 = return D.Stop + step _ (I# i) = + return $ + case Exts.indexArray# (array# arr) i of + (# x #) -> D.Yield x ((I# i) - 1) + +{-# INLINE_NORMAL foldl' #-} +foldl' :: (b -> a -> b) -> b -> Array a -> b +foldl' f z arr = runIdentity $ D.foldl' f z $ toStreamD arr + +{-# INLINE_NORMAL foldr #-} +foldr :: (a -> b -> b) -> b -> Array a -> b +foldr f z arr = runIdentity $ D.foldr f z $ toStreamD arr + +-- writeN n = S.evertM (fromStreamDN n) +{-# INLINE_NORMAL writeN #-} +writeN :: MonadIO m => Int -> Fold m a (Array a) +writeN limit = Fold step initial extract + where + initial = do + marr <- liftIO $ newArray limit bottomElement + return (marr, 0) + step (marr, i) x + | i == limit = return (marr, i) + | otherwise = do + liftIO $ writeArray marr i x + return (marr, i + 1) + extract (marr, len) = liftIO $ freezeArray marr 0 len + +{-# INLINE_NORMAL write #-} +write :: MonadIO m => Fold m a (Array a) +write = Fold step initial extract + where + initial = do + marr <- liftIO $ newArray 0 bottomElement + return (marr, 0, 0) + step (marr, i, capacity) x + | i == capacity = + let newCapacity = max (capacity * 2) 1 + in do newMarr <- liftIO $ newArray newCapacity bottomElement + liftIO $ copyMutableArray newMarr 0 marr 0 i + liftIO $ writeArray newMarr i x + return (newMarr, i + 1, newCapacity) + | otherwise = do + liftIO $ writeArray marr i x + return (marr, i + 1, capacity) + extract (marr, len, _) = liftIO $ freezeArray marr 0 len + +{-# INLINE_NORMAL fromStreamDN #-} +fromStreamDN :: MonadIO m => Int -> D.Stream m a -> m (Array a) +fromStreamDN limit str = do + marr <- liftIO $ newArray (max limit 0) bottomElement + i <- + D.foldlM' + (\i x -> i `seq` (liftIO $ writeArray marr i x) >> return (i + 1)) + 0 $ + D.take limit str + liftIO $ freezeArray marr 0 i + +{-# INLINE fromStreamD #-} +fromStreamD :: MonadIO m => D.Stream m a -> m (Array a) +fromStreamD str = D.runFold write str + +{-# INLINABLE fromListN #-} +fromListN :: Int -> [a] -> Array a +fromListN n xs = unsafePerformIO $ fromStreamDN n $ D.fromList xs + +{-# INLINABLE fromList #-} +fromList :: [a] -> Array a +fromList xs = unsafePerformIO $ fromStreamD $ D.fromList xs + +instance NFData a => NFData (Array a) where + {-# INLINE rnf #-} + rnf = foldl' (\_ x -> rnf x) () + +{-# INLINE fromStreamN #-} +fromStreamN :: MonadIO m => Int -> SerialT m a -> m (Array a) +fromStreamN n m = do + when (n < 0) $ error "fromStreamN: negative write count specified" + fromStreamDN n $ D.toStreamD m + +{-# INLINE fromStream #-} +fromStream :: MonadIO m => SerialT m a -> m (Array a) +fromStream m = fromStreamD $ D.toStreamD m + +{-# INLINE_EARLY toStream #-} +toStream :: (Monad m, IsStream t) => Array a -> t m a +toStream = D.fromStreamD . toStreamD + +{-# INLINE_EARLY toStreamRev #-} +toStreamRev :: (Monad m, IsStream t) => Array a -> t m a +toStreamRev = D.fromStreamD . toStreamDRev + +{-# INLINE fold #-} +fold :: Monad m => Fold m a b -> Array a -> m b +fold f arr = D.runFold f (toStreamD arr) + +{-# INLINE streamFold #-} +streamFold :: Monad m => (SerialT m a -> m b) -> Array a -> m b +streamFold f arr = f (toStream arr) + +{-# INLINE_NORMAL read #-} +read :: Monad m => Unfold m (Array a) a +read = Unfold step inject + where + inject arr = return (arr, 0) + step (arr, i) + | i == length arr = return D.Stop + step (arr, (I# i)) = + return $ + case Exts.indexArray# (array# arr) i of + (# x #) -> D.Yield x (arr, I# i + 1) diff --git a/src/Streamly/Internal/Data/Atomics.hs b/src/Streamly/Internal/Data/Atomics.hs --- a/src/Streamly/Internal/Data/Atomics.hs +++ b/src/Streamly/Internal/Data/Atomics.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE CPP #-} -- | diff --git a/src/Streamly/Internal/Data/Fold.hs b/src/Streamly/Internal/Data/Fold.hs --- a/src/Streamly/Internal/Data/Fold.hs +++ b/src/Streamly/Internal/Data/Fold.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} @@ -56,7 +55,7 @@ , stdDev , rollingHash , rollingHashWithSalt - -- , rollingHashFirstN + , rollingHashFirstN -- , rollingHashLastN -- ** Full Folds (Monoidal) @@ -70,8 +69,8 @@ , toListRevF -- experimental -- ** Partial Folds - -- , drainN - -- , drainWhile + , drainN + , drainWhile -- , lastN -- , (!!) -- , genericIndex @@ -147,6 +146,7 @@ , tee , distribute + , distribute_ -- * Partitioning @@ -159,7 +159,9 @@ , demux -- , demuxWith , demux_ + , demuxDefault_ -- , demuxWith_ + , demuxWithDefault_ -- * Classifying @@ -180,10 +182,15 @@ -- , concatMap -- , chunksOf , duplicate -- experimental + + -- * Folding to SVar + , toParallelSVar + , toParallelSVarLimited ) where import Control.Monad (void) +import Control.Monad.IO.Class (MonadIO(..)) import Data.Functor.Identity (Identity(..)) import Data.Map.Strict (Map) @@ -201,6 +208,7 @@ import Streamly.Internal.Data.Pipe.Types (Pipe (..), PipeState(..)) import Streamly.Internal.Data.Fold.Types import Streamly.Internal.Data.Strict +import Streamly.Internal.Data.SVar import qualified Streamly.Internal.Data.Pipe.Types as Pipe @@ -340,7 +348,7 @@ -- from the 'Foldable', the result is 'None' for empty containers. {-# INLINABLE _Fold1 #-} _Fold1 :: Monad m => (a -> a -> a) -> Fold m a (Maybe a) -_Fold1 step = Fold step_ (return Nothing') fromStrictMaybe +_Fold1 step = Fold step_ (return Nothing') (return . toMaybe) where step_ mx a = return $ Just' $ case mx of @@ -555,6 +563,14 @@ rollingHash :: (Monad m, Enum a) => Fold m a Int rollingHash = rollingHashWithSalt defaultSalt +-- | Compute an 'Int' sized polynomial rolling hash of the first n elements of +-- a stream. +-- +-- > rollingHashFirstN = ltake n rollingHash +{-# INLINABLE rollingHashFirstN #-} +rollingHashFirstN :: (Monad m, Enum a) => Int -> Fold m a Int +rollingHashFirstN n = ltake n rollingHash + ------------------------------------------------------------------------------ -- Monoidal left folds ------------------------------------------------------------------------------ @@ -608,7 +624,7 @@ -- | Folds the input stream to a list. -- -- /Warning!/ working on large lists accumulated as buffers in memory could be --- very inefficient, consider using "Streamly.Array" instead. +-- very inefficient, consider using "Streamly.Memory.Array" instead. -- -- @since 0.7.0 @@ -623,6 +639,18 @@ -- Partial Folds ------------------------------------------------------------------------------ +-- | A fold that drains the first n elements of its input, running the effects +-- and discarding the results. +{-# INLINABLE drainN #-} +drainN :: Monad m => Int -> Fold m a () +drainN n = ltake n drain + +-- | A fold that drains elements of its input as long as the predicate succeeds, +-- running the effects and discarding the results. +{-# INLINABLE drainWhile #-} +drainWhile :: Monad m => (a -> Bool) -> Fold m a () +drainWhile p = ltakeWhile p drain + ------------------------------------------------------------------------------ -- To Elements ------------------------------------------------------------------------------ @@ -664,7 +692,7 @@ -- @since 0.7.0 {-# INLINABLE find #-} find :: Monad m => (a -> Bool) -> Fold m a (Maybe a) -find predicate = Fold step (return Nothing') fromStrictMaybe +find predicate = Fold step (return Nothing') (return . toMaybe) where step x a = return $ case x of @@ -679,7 +707,7 @@ -- @since 0.7.0 {-# INLINABLE lookup #-} lookup :: (Eq a, Monad m) => a -> Fold m (a,b) (Maybe b) -lookup a0 = Fold step (return Nothing') fromStrictMaybe +lookup a0 = Fold step (return Nothing') (return . toMaybe) where step x (a,b) = return $ case x of @@ -839,6 +867,22 @@ distribute [] = foldNil distribute (x:xs) = foldCons x (distribute xs) +-- | Like 'distribute' but for folds that return (), this can be more efficient +-- than 'distribute' as it does not need to maintain state. +-- +{-# INLINE distribute_ #-} +distribute_ :: Monad m => [Fold m a ()] -> Fold m a () +distribute_ fs = Fold step initial extract + where + initial = Prelude.mapM (\(Fold s i e) -> + i >>= \r -> return (Fold s (return r) e)) fs + step ss a = do + Prelude.mapM_ (\(Fold s i _) -> i >>= \r -> s r a >> return ()) ss + return ss + extract ss = do + Prelude.mapM_ (\(Fold _ i e) -> i >>= \r -> e r) ss + return () + ------------------------------------------------------------------------------ -- Partitioning ------------------------------------------------------------------------------ @@ -978,6 +1022,8 @@ where initial = return kv +-- alterF is available only since containers version 0.5.8.2 +#if MIN_VERSION_containers(0,5,8) step mp a = case f a of (k, a') -> Map.alterF twiddle k mp -- XXX should we raise an exception in Nothing case? @@ -990,6 +1036,15 @@ twiddle (Just (Fold step' acc extract')) = do !r <- acc >>= \x -> step' x a' pure . Just $ Fold step' (return r) extract' +#else + step mp a = + let (k, a') = f a + in case Map.lookup k mp of + Nothing -> return mp + Just (Fold step' acc extract') -> do + !r <- acc >>= \x -> step' x a' + return $ Map.insert k (Fold step' (return r) extract') mp +#endif extract = Prelude.mapM (\(Fold _ acc e) -> acc >>= e) -- | Fold a stream of key value pairs using a map of specific folds for each @@ -1000,8 +1055,7 @@ -- > let table = Data.Map.fromList [(\"SUM", FL.sum), (\"PRODUCT", FL.product)] -- input = S.fromList [(\"SUM",1),(\"PRODUCT",2),(\"SUM",3),(\"PRODUCT",4)] -- in S.fold (FL.demux table) input --- One 1 --- Two 2 +-- fromList [("PRODUCT",8),("SUM",4)] -- @ -- -- @since 0.7.0 @@ -1010,6 +1064,32 @@ => Map k (Fold m a b) -> Fold m (k, a) (Map k b) demux = demuxWith id +{-# INLINE demuxWithDefault_ #-} +demuxWithDefault_ :: (Monad m, Ord k) + => (a -> (k, a')) -> Map k (Fold m a' b) -> Fold m (k, a') b -> Fold m a () +demuxWithDefault_ f kv (Fold dstep dinitial dextract) = + Fold step initial extract + + where + + initFold (Fold s i e) = i >>= \r -> return (Fold s (return r) e) + initial = do + mp <- Prelude.mapM initFold kv + dacc <- dinitial + return (Tuple' mp dacc) + step (Tuple' mp dacc) a + | (k, a') <- f a + = case Map.lookup k mp of + Nothing -> do + acc <- dstep dacc (k, a') + return (Tuple' mp acc) + Just (Fold step' acc _) -> do + _ <- acc >>= \x -> step' x a' + return (Tuple' mp dacc) + extract (Tuple' mp dacc) = do + void $ dextract dacc + Prelude.mapM_ (\(Fold _ acc e) -> acc >>= e) mp + -- | Split the input stream based on a key field and fold each split using a -- specific fold without collecting the results. Useful for cases like protocol -- handlers to handle different type of packets. @@ -1068,6 +1148,11 @@ demux_ :: (Monad m, Ord k) => Map k (Fold m a ()) -> Fold m (k, a) () demux_ = demuxWith_ id +{-# INLINE demuxDefault_ #-} +demuxDefault_ :: (Monad m, Ord k) + => Map k (Fold m a ()) -> Fold m (k, a) () -> Fold m (k, a) () +demuxDefault_ = demuxWithDefault_ id + -- TODO If the data is large we may need a map/hashmap in pinned memory instead -- of a regular Map. That may require a serializable constraint though. We can -- have another API for that. @@ -1207,3 +1292,47 @@ lchunksInRange low high (Fold step1 initial1 extract1) (Fold step2 initial2 extract2) = undefined -} + +------------------------------------------------------------------------------ +-- Fold to a Parallel SVar +------------------------------------------------------------------------------ + +{-# INLINE toParallelSVar #-} +toParallelSVar :: MonadIO m => SVar t m a -> Maybe WorkerInfo -> Fold m a () +toParallelSVar svar winfo = Fold step initial extract + where + + initial = return () + + step () x = liftIO $ do + -- XXX we can have a separate fold for unlimited buffer case to avoid a + -- branch in the step here. + decrementBufferLimit svar + void $ send svar (ChildYield x) + + extract () = liftIO $ do + sendStop svar winfo + +{-# INLINE toParallelSVarLimited #-} +toParallelSVarLimited :: MonadIO m + => SVar t m a -> Maybe WorkerInfo -> Fold m a () +toParallelSVarLimited svar winfo = Fold step initial extract + where + + initial = return True + + step True x = liftIO $ do + yieldLimitOk <- decrementYieldLimit svar + if yieldLimitOk + then do + decrementBufferLimit svar + void $ send svar (ChildYield x) + return True + else do + cleanupSVarFromWorker svar + sendStop svar winfo + return False + step False _ = return False + + extract True = liftIO $ sendStop svar winfo + extract False = return () diff --git a/src/Streamly/Internal/Data/Fold/Types.hs b/src/Streamly/Internal/Data/Fold/Types.hs --- a/src/Streamly/Internal/Data/Fold/Types.hs +++ b/src/Streamly/Internal/Data/Fold/Types.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} diff --git a/src/Streamly/Internal/Data/List.hs b/src/Streamly/Internal/Data/List.hs --- a/src/Streamly/Internal/Data/List.hs +++ b/src/Streamly/Internal/Data/List.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -84,11 +83,11 @@ #endif import GHC.Exts (IsList(..), IsString(..)) -import Streamly.Streams.Serial (SerialT) -import Streamly.Streams.Zip (ZipSerialM) +import Streamly.Internal.Data.Stream.Serial (SerialT) +import Streamly.Internal.Data.Stream.Zip (ZipSerialM) -import qualified Streamly.Streams.Prelude as P -import qualified Streamly.Streams.StreamK as K +import qualified Streamly.Internal.Data.Stream.Prelude as P +import qualified Streamly.Internal.Data.Stream.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 diff --git a/src/Streamly/Internal/Data/Pipe.hs b/src/Streamly/Internal/Data/Pipe.hs --- a/src/Streamly/Internal/Data/Pipe.hs +++ b/src/Streamly/Internal/Data/Pipe.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} @@ -141,7 +140,7 @@ -- ... -- @ -- - -- To compute the average of numbers in a stream without going throught he + -- To compute the average of numbers in a stream without going through the -- stream twice: -- -- >>> let avg = (/) <$> FL.sum <*> fmap fromIntegral FL.length @@ -257,8 +256,8 @@ (Pipe(..), PipeState(..), Step(..), zipWith, tee, map, compose) -- import Streamly.Internal.Memory.Array.Types (Array) -- import Streamly.Memory.Ring (Ring) --- import Streamly.Streams.Serial (SerialT) --- import Streamly.Streams.StreamK (IsStream()) +-- import Streamly.Internal.Data.Stream.Serial (SerialT) +-- import Streamly.Internal.Data.Stream.StreamK (IsStream()) -- import Streamly.Internal.Data.Time.Units -- (AbsTime, MilliSecond64(..), addToAbsTime, diffAbsTime, toRelTime, -- toAbsTime) @@ -267,9 +266,9 @@ -- import qualified Streamly.Internal.Memory.Array.Types as A -- import qualified Streamly.Prelude as S --- import qualified Streamly.Streams.StreamD as D --- import qualified Streamly.Streams.StreamK as K --- import qualified Streamly.Streams.Prelude as P +-- import qualified Streamly.Internal.Data.Stream.StreamD as D +-- import qualified Streamly.Internal.Data.Stream.StreamK as K +-- import qualified Streamly.Internal.Data.Stream.Prelude as P ------------------------------------------------------------------------------ -- Pipes @@ -1805,7 +1804,7 @@ -- All the input elements belonging to a session are collected using the fold -- @f@. The session key and the fold result are emitted in the output stream -- when the session is purged either via the session close event or via the --- session liftime timeout. +-- session lifetime timeout. -- -- @since 0.7.0 {-# INLINABLE classifySessionsBy #-} diff --git a/src/Streamly/Internal/Data/Pipe/Types.hs b/src/Streamly/Internal/Data/Pipe/Types.hs --- a/src/Streamly/Internal/Data/Pipe/Types.hs +++ b/src/Streamly/Internal/Data/Pipe/Types.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} diff --git a/src/Streamly/Internal/Data/Prim/Array.hs b/src/Streamly/Internal/Data/Prim/Array.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Prim/Array.hs @@ -0,0 +1,205 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +#include "inline.hs" + +-- | +-- Module : Streamly.Internal.Data.Prim.Array +-- Copyright : (c) 2019 Composewell Technologies +-- +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +module Streamly.Internal.Data.Prim.Array + ( + + -- XXX should it be just Array instead? We should be able to replace one + -- array type with another easily. + PrimArray(..) + + -- XXX Prim should be exported from Data.Prim module? + , Prim(..) + + , foldl' + , foldr + + , length + + , writeN + , write + + , toStreamD + , toStreamDRev + + , toStream + , toStreamRev + , read + , readSlice + + , fromListN + , fromList + , fromStreamDN + , fromStreamD + + , fromStreamN + , fromStream + + , streamFold + , fold + ) +where + +import Prelude hiding (foldr, length, read) +import Control.DeepSeq (NFData(..)) +import Control.Monad (when) +import Control.Monad.IO.Class (liftIO, MonadIO) +import GHC.IO (unsafePerformIO) +import Data.Primitive.Types (Prim(..)) + +import Streamly.Internal.Data.Prim.Array.Types +import Streamly.Internal.Data.Unfold.Types (Unfold(..)) +import Streamly.Internal.Data.Fold.Types (Fold(..)) +import Streamly.Internal.Data.Stream.StreamK.Type (IsStream) +import Streamly.Internal.Data.Stream.Serial (SerialT) + +import qualified Streamly.Internal.Data.Stream.StreamD as D + +{-# INLINE_NORMAL toStreamD #-} +toStreamD :: (Prim a, Monad m) => PrimArray a -> D.Stream m a +toStreamD arr = D.Stream step 0 + where + {-# INLINE_LATE step #-} + step _ i + | i == sizeofPrimArray arr = return D.Stop + step _ i = return $ D.Yield (indexPrimArray arr i) (i + 1) + +{-# INLINE length #-} +length :: Prim a => PrimArray a -> Int +length arr = sizeofPrimArray arr + +{-# INLINE_NORMAL toStreamDRev #-} +toStreamDRev :: (Prim a, Monad m) => PrimArray a -> D.Stream m a +toStreamDRev arr = D.Stream step (sizeofPrimArray arr - 1) + where + {-# INLINE_LATE step #-} + step _ i + | i < 0 = return D.Stop + step _ i = return $ D.Yield (indexPrimArray arr i) (i - 1) + +{-# INLINE_NORMAL foldl' #-} +foldl' :: Prim a => (b -> a -> b) -> b -> PrimArray a -> b +foldl' = foldlPrimArray' + +{-# INLINE_NORMAL foldr #-} +foldr :: Prim a => (a -> b -> b) -> b -> PrimArray a -> b +foldr = foldrPrimArray + +-- writeN n = S.evertM (fromStreamDN n) +{-# INLINE_NORMAL writeN #-} +writeN :: (MonadIO m, Prim a) => Int -> Fold m a (PrimArray a) +writeN limit = Fold step initial extract + where + initial = do + marr <- liftIO $ newPrimArray limit + return (marr, 0) + step (marr, i) x + | i == limit = return (marr, i) + | otherwise = do + liftIO $ writePrimArray marr i x + return (marr, i + 1) + extract (marr, _) = liftIO $ unsafeFreezePrimArray marr + +{-# INLINE_NORMAL write #-} +write :: (MonadIO m, Prim a) => Fold m a (PrimArray a) +write = Fold step initial extract + where + initial = do + marr <- liftIO $ newPrimArray 0 + return (marr, 0, 0) + step (marr, i, capacity) x + | i == capacity = + let newCapacity = max (capacity * 2) 1 + in do newMarr <- liftIO $ resizeMutablePrimArray marr newCapacity + liftIO $ writePrimArray newMarr i x + return (newMarr, i + 1, newCapacity) + | otherwise = do + liftIO $ writePrimArray marr i x + return (marr, i + 1, capacity) + extract (marr, len, _) = do liftIO $ shrinkMutablePrimArray marr len + liftIO $ unsafeFreezePrimArray marr + +{-# INLINE_NORMAL fromStreamDN #-} +fromStreamDN :: (MonadIO m, Prim a) => Int -> D.Stream m a -> m (PrimArray a) +fromStreamDN limit str = do + marr <- liftIO $ newPrimArray (max limit 0) + _ <- + D.foldlM' + (\i x -> i `seq` (liftIO $ writePrimArray marr i x) >> return (i + 1)) + 0 $ + D.take limit str + liftIO $ unsafeFreezePrimArray marr + +{-# INLINE fromStreamD #-} +fromStreamD :: (MonadIO m, Prim a) => D.Stream m a -> m (PrimArray a) +fromStreamD str = D.runFold write str + +{-# INLINABLE fromListN #-} +fromListN :: Prim a => Int -> [a] -> PrimArray a +fromListN n xs = unsafePerformIO $ fromStreamDN n $ D.fromList xs + +{-# INLINABLE fromList #-} +fromList :: Prim a => [a] -> PrimArray a +fromList xs = unsafePerformIO $ fromStreamD $ D.fromList xs + +instance Prim a => NFData (PrimArray a) where + {-# INLINE rnf #-} + rnf = foldl' (\_ _ -> ()) () + +{-# INLINE fromStreamN #-} +fromStreamN :: (MonadIO m, Prim a) => Int -> SerialT m a -> m (PrimArray a) +fromStreamN n m = do + when (n < 0) $ error "fromStreamN: negative write count specified" + fromStreamDN n $ D.toStreamD m + +{-# INLINE fromStream #-} +fromStream :: (MonadIO m, Prim a) => SerialT m a -> m (PrimArray a) +fromStream m = fromStreamD $ D.toStreamD m + +{-# INLINE_EARLY toStream #-} +toStream :: (Prim a, Monad m, IsStream t) => PrimArray a -> t m a +toStream = D.fromStreamD . toStreamD + +{-# INLINE_EARLY toStreamRev #-} +toStreamRev :: (Prim a, Monad m, IsStream t) => PrimArray a -> t m a +toStreamRev = D.fromStreamD . toStreamDRev + +{-# INLINE fold #-} +fold :: (Prim a, Monad m) => Fold m a b -> PrimArray a -> m b +fold f arr = D.runFold f (toStreamD arr) + +{-# INLINE streamFold #-} +streamFold :: (Prim a, Monad m) => (SerialT m a -> m b) -> PrimArray a -> m b +streamFold f arr = f (toStream arr) + +{-# INLINE_NORMAL read #-} +read :: (Prim a, Monad m) => Unfold m (PrimArray a) a +read = Unfold step inject + where + inject arr = return (arr, 0) + step (arr, i) + | i == length arr = return D.Stop + step (arr, i) = return $ D.Yield (indexPrimArray arr i) (arr, i + 1) + +{-# INLINE_NORMAL readSlice #-} +readSlice :: (Prim a, Monad m) => Int -> Int -> Unfold m (PrimArray a) a +readSlice off len = Unfold step inject + where + inject arr = return (arr, off) + step (arr, i) + | i == min (off + len) (length arr) = return D.Stop + step (arr, i) = return $ D.Yield (indexPrimArray arr i) (arr, i + 1) diff --git a/src/Streamly/Internal/Data/Prim/Array/Types.hs b/src/Streamly/Internal/Data/Prim/Array/Types.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Prim/Array/Types.hs @@ -0,0 +1,943 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnboxedTuples #-} + +-- | +-- Module : Streamly.Internal.Data.Prim.Array.Types +-- Copyright : (c) Roman Leshchinskiy 2009-2012 +-- License : BSD-style +-- +-- Maintainer : streamly@composewell.com +-- Portability : non-portable +-- +-- Arrays of unboxed primitive types. The function provided by this module +-- match the behavior of those provided by @Data.Primitive.ByteArray@, and +-- the underlying types and primops that back them are the same. +-- However, the type constructors 'PrimArray' and 'MutablePrimArray' take one additional +-- argument than their respective counterparts 'ByteArray' and 'MutableByteArray'. +-- This argument is used to designate the type of element in the array. +-- Consequently, all function this modules accepts length and incides in +-- terms of elements, not bytes. +-- +-- @since 0.6.4.0 +module Streamly.Internal.Data.Prim.Array.Types + ( -- * Types + PrimArray(..) + , MutablePrimArray(..) + -- * Allocation + , newPrimArray + , resizeMutablePrimArray + , shrinkMutablePrimArray + -- * Element Access + , readPrimArray + , writePrimArray + , indexPrimArray + -- * Freezing and Thawing + , unsafeFreezePrimArray + , unsafeThawPrimArray + -- * Block Operations + , copyPrimArray + , copyMutablePrimArray + , copyPrimArrayToPtr + , copyMutablePrimArrayToPtr + , setPrimArray + -- * Information + , sameMutablePrimArray + , getSizeofMutablePrimArray + , sizeofMutablePrimArray + , sizeofPrimArray + -- * List Conversion + , primArrayToList + , primArrayFromList + , primArrayFromListN + -- * Folding + , foldrPrimArray + , foldrPrimArray' + , foldlPrimArray + , foldlPrimArray' + , foldlPrimArrayM' + -- * Effectful Folding + , traversePrimArray_ + , itraversePrimArray_ + -- * Map/Create + , mapPrimArray + , imapPrimArray + , generatePrimArray + , replicatePrimArray + , filterPrimArray + , mapMaybePrimArray + -- * Effectful Map/Create + -- $effectfulMapCreate + -- ** Lazy Applicative + , traversePrimArray + , itraversePrimArray + , generatePrimArrayA + , replicatePrimArrayA + , filterPrimArrayA + , mapMaybePrimArrayA + -- ** Strict Primitive Monadic + , traversePrimArrayP + , itraversePrimArrayP + , generatePrimArrayP + , replicatePrimArrayP + , filterPrimArrayP + , mapMaybePrimArrayP + ) where + +import GHC.Exts + +import Data.Primitive.Types +import Data.Primitive.ByteArray (ByteArray(..)) +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid (Monoid(..),(<>)) +#endif +import Control.Applicative +import Control.Monad.Primitive +import Control.Monad.ST +import qualified Data.List as L +import qualified Data.Primitive.ByteArray as PB +import qualified Data.Primitive.Types as PT + +#if MIN_VERSION_base(4,9,0) && !MIN_VERSION_base(4,11,0) +import Data.Semigroup (Semigroup) +#endif +#if MIN_VERSION_base(4,9,0) +import qualified Data.Semigroup as SG +#endif + +-- | Arrays of unboxed elements. This accepts types like 'Double', 'Char', +-- 'Int', and 'Word', as well as their fixed-length variants ('Word8', +-- 'Word16', etc.). Since the elements are unboxed, a 'PrimArray' is strict +-- in its elements. This differs from the behavior of 'Array', which is lazy +-- in its elements. +data PrimArray a = PrimArray ByteArray# + +-- | Mutable primitive arrays associated with a primitive state token. +-- These can be written to and read from in a monadic context that supports +-- sequencing such as 'IO' or 'ST'. Typically, a mutable primitive array will +-- be built and then convert to an immutable primitive array using +-- 'unsafeFreezePrimArray'. However, it is also acceptable to simply discard +-- a mutable primitive array since it lives in managed memory and will be +-- garbage collected when no longer referenced. +data MutablePrimArray s a = MutablePrimArray (MutableByteArray# s) + +sameByteArray :: ByteArray# -> ByteArray# -> Bool +sameByteArray ba1 ba2 = + case reallyUnsafePtrEquality# (unsafeCoerce# ba1 :: ()) (unsafeCoerce# ba2 :: ()) of + r -> isTrue# r + +-- | @since 0.6.4.0 +instance (Eq a, Prim a) => Eq (PrimArray a) where + a1@(PrimArray ba1#) == a2@(PrimArray ba2#) + | sameByteArray ba1# ba2# = True + | sz1 /= sz2 = False + | otherwise = loop (quot sz1 (sizeOf (undefined :: a)) - 1) + where + -- Here, we take the size in bytes, not in elements. We do this + -- since it allows us to defer performing the division to + -- calculate the size in elements. + sz1 = PB.sizeofByteArray (ByteArray ba1#) + sz2 = PB.sizeofByteArray (ByteArray ba2#) + loop !i + | i < 0 = True + | otherwise = indexPrimArray a1 i == indexPrimArray a2 i && loop (i-1) + {-# INLINE (==) #-} + +-- | Lexicographic ordering. Subject to change between major versions. +-- +-- @since 0.6.4.0 +instance (Ord a, Prim a) => Ord (PrimArray a) where + compare a1@(PrimArray ba1#) a2@(PrimArray ba2#) + | sameByteArray ba1# ba2# = EQ + | otherwise = loop 0 + where + sz1 = PB.sizeofByteArray (ByteArray ba1#) + sz2 = PB.sizeofByteArray (ByteArray ba2#) + sz = quot (min sz1 sz2) (sizeOf (undefined :: a)) + loop !i + | i < sz = compare (indexPrimArray a1 i) (indexPrimArray a2 i) <> loop (i+1) + | otherwise = compare sz1 sz2 + {-# INLINE compare #-} + +-- | @since 0.6.4.0 +instance Prim a => IsList (PrimArray a) where + type Item (PrimArray a) = a + fromList = primArrayFromList + fromListN = primArrayFromListN + toList = primArrayToList + +-- | @since 0.6.4.0 +instance (Show a, Prim a) => Show (PrimArray a) where + showsPrec p a = showParen (p > 10) $ + showString "fromListN " . shows (sizeofPrimArray a) . showString " " + . shows (primArrayToList a) + +die :: String -> String -> a +die fun problem = error $ "Data.Primitive.PrimArray." ++ fun ++ ": " ++ problem + +primArrayFromList :: Prim a => [a] -> PrimArray a +primArrayFromList vs = primArrayFromListN (L.length vs) vs + +primArrayFromListN :: forall a. Prim a => Int -> [a] -> PrimArray a +primArrayFromListN len vs = runST run where + run :: forall s. ST s (PrimArray a) + run = do + arr <- newPrimArray len + let go :: [a] -> Int -> ST s () + go [] !ix = if ix == len + then return () + else die "fromListN" "list length less than specified size" + go (a : as) !ix = if ix < len + then do + writePrimArray arr ix a + go as (ix + 1) + else die "fromListN" "list length greater than specified size" + go vs 0 + unsafeFreezePrimArray arr + +-- | Convert the primitive array to a list. +{-# INLINE primArrayToList #-} +primArrayToList :: forall a. Prim a => PrimArray a -> [a] +primArrayToList xs = build (\c n -> foldrPrimArray c n xs) + +primArrayToByteArray :: PrimArray a -> PB.ByteArray +primArrayToByteArray (PrimArray x) = PB.ByteArray x + +byteArrayToPrimArray :: ByteArray -> PrimArray a +byteArrayToPrimArray (PB.ByteArray x) = PrimArray x + +#if MIN_VERSION_base(4,9,0) +-- | @since 0.6.4.0 +instance Semigroup (PrimArray a) where + x <> y = byteArrayToPrimArray (primArrayToByteArray x SG.<> primArrayToByteArray y) + sconcat = byteArrayToPrimArray . SG.sconcat . fmap primArrayToByteArray + stimes i arr = byteArrayToPrimArray (SG.stimes i (primArrayToByteArray arr)) +#endif + +-- | @since 0.6.4.0 +instance Monoid (PrimArray a) where + mempty = emptyPrimArray +#if !(MIN_VERSION_base(4,11,0)) + mappend x y = byteArrayToPrimArray (mappend (primArrayToByteArray x) (primArrayToByteArray y)) +#endif + mconcat = byteArrayToPrimArray . mconcat . map primArrayToByteArray + +-- | The empty primitive array. +emptyPrimArray :: PrimArray a +{-# NOINLINE emptyPrimArray #-} +emptyPrimArray = runST $ primitive $ \s0# -> case newByteArray# 0# s0# of + (# s1#, arr# #) -> case unsafeFreezeByteArray# arr# s1# of + (# s2#, arr'# #) -> (# s2#, PrimArray arr'# #) + +-- | Create a new mutable primitive array of the given length. The +-- underlying memory is left uninitialized. +newPrimArray :: forall m a. (PrimMonad m, Prim a) => Int -> m (MutablePrimArray (PrimState m) a) +{-# INLINE newPrimArray #-} +newPrimArray (I# n#) + = primitive (\s# -> + case newByteArray# (n# *# sizeOf# (undefined :: a)) s# of + (# s'#, arr# #) -> (# s'#, MutablePrimArray arr# #) + ) + +-- | Resize a mutable primitive array. The new size is given in elements. +-- +-- This will either resize the array in-place or, if not possible, allocate the +-- contents into a new, unpinned array and copy the original array\'s contents. +-- +-- To avoid undefined behaviour, the original 'MutablePrimArray' shall not be +-- accessed anymore after a 'resizeMutablePrimArray' has been performed. +-- Moreover, no reference to the old one should be kept in order to allow +-- garbage collection of the original 'MutablePrimArray' in case a new +-- 'MutablePrimArray' had to be allocated. +resizeMutablePrimArray :: forall m a. (PrimMonad m, Prim a) + => MutablePrimArray (PrimState m) a + -> Int -- ^ new size + -> m (MutablePrimArray (PrimState m) a) +{-# INLINE resizeMutablePrimArray #-} +resizeMutablePrimArray (MutablePrimArray arr#) (I# n#) + = primitive (\s# -> case resizeMutableByteArray# arr# (n# *# sizeOf# (undefined :: a)) s# of + (# s'#, arr'# #) -> (# s'#, MutablePrimArray arr'# #)) + +-- Although it is possible to shim resizeMutableByteArray for old GHCs, this +-- is not the case with shrinkMutablePrimArray. + +-- | Shrink a mutable primitive array. The new size is given in elements. +-- It must be smaller than the old size. The array will be resized in place. +-- This function is only available when compiling with GHC 7.10 or newer. +shrinkMutablePrimArray :: forall m a. (PrimMonad m, Prim a) + => MutablePrimArray (PrimState m) a + -> Int -- ^ new size + -> m () +{-# INLINE shrinkMutablePrimArray #-} +shrinkMutablePrimArray (MutablePrimArray arr#) (I# n#) + = primitive_ (shrinkMutableByteArray# arr# (n# *# sizeOf# (undefined :: a))) + +readPrimArray :: (Prim a, PrimMonad m) => MutablePrimArray (PrimState m) a -> Int -> m a +{-# INLINE readPrimArray #-} +readPrimArray (MutablePrimArray arr#) (I# i#) + = primitive (readByteArray# arr# i#) + +-- | Write an element to the given index. +writePrimArray :: + (Prim a, PrimMonad m) + => MutablePrimArray (PrimState m) a -- ^ array + -> Int -- ^ index + -> a -- ^ element + -> m () +{-# INLINE writePrimArray #-} +writePrimArray (MutablePrimArray arr#) (I# i#) x + = primitive_ (writeByteArray# arr# i# x) + +-- | Copy part of a mutable array into another mutable array. +-- In the case that the destination and +-- source arrays are the same, the regions may overlap. +copyMutablePrimArray :: forall m a. + (PrimMonad m, Prim a) + => MutablePrimArray (PrimState m) a -- ^ destination array + -> Int -- ^ offset into destination array + -> MutablePrimArray (PrimState m) a -- ^ source array + -> Int -- ^ offset into source array + -> Int -- ^ number of elements to copy + -> m () +{-# INLINE copyMutablePrimArray #-} +copyMutablePrimArray (MutablePrimArray dst#) (I# doff#) (MutablePrimArray src#) (I# soff#) (I# n#) + = primitive_ (copyMutableByteArray# + src# + (soff# *# (sizeOf# (undefined :: a))) + dst# + (doff# *# (sizeOf# (undefined :: a))) + (n# *# (sizeOf# (undefined :: a))) + ) + +-- | Copy part of an array into another mutable array. +copyPrimArray :: forall m a. + (PrimMonad m, Prim a) + => MutablePrimArray (PrimState m) a -- ^ destination array + -> Int -- ^ offset into destination array + -> PrimArray a -- ^ source array + -> Int -- ^ offset into source array + -> Int -- ^ number of elements to copy + -> m () +{-# INLINE copyPrimArray #-} +copyPrimArray (MutablePrimArray dst#) (I# doff#) (PrimArray src#) (I# soff#) (I# n#) + = primitive_ (copyByteArray# + src# + (soff# *# (sizeOf# (undefined :: a))) + dst# + (doff# *# (sizeOf# (undefined :: a))) + (n# *# (sizeOf# (undefined :: a))) + ) + +-- | Copy a slice of an immutable primitive array to an address. +-- The offset and length are given in elements of type @a@. +-- This function assumes that the 'Prim' instance of @a@ +-- agrees with the 'Storable' instance. This function is only +-- available when building with GHC 7.8 or newer. +copyPrimArrayToPtr :: forall m a. (PrimMonad m, Prim a) + => Ptr a -- ^ destination pointer + -> PrimArray a -- ^ source array + -> Int -- ^ offset into source array + -> Int -- ^ number of prims to copy + -> m () +{-# INLINE copyPrimArrayToPtr #-} +copyPrimArrayToPtr (Ptr addr#) (PrimArray ba#) (I# soff#) (I# n#) = + primitive (\ s# -> + let s'# = copyByteArrayToAddr# ba# (soff# *# siz#) addr# (n# *# siz#) s# + in (# s'#, () #)) + where siz# = sizeOf# (undefined :: a) + +-- | Copy a slice of an immutable primitive array to an address. +-- The offset and length are given in elements of type @a@. +-- This function assumes that the 'Prim' instance of @a@ +-- agrees with the 'Storable' instance. This function is only +-- available when building with GHC 7.8 or newer. +copyMutablePrimArrayToPtr :: forall m a. (PrimMonad m, Prim a) + => Ptr a -- ^ destination pointer + -> MutablePrimArray (PrimState m) a -- ^ source array + -> Int -- ^ offset into source array + -> Int -- ^ number of prims to copy + -> m () +{-# INLINE copyMutablePrimArrayToPtr #-} +copyMutablePrimArrayToPtr (Ptr addr#) (MutablePrimArray mba#) (I# soff#) (I# n#) = + primitive (\ s# -> + let s'# = copyMutableByteArrayToAddr# mba# (soff# *# siz#) addr# (n# *# siz#) s# + in (# s'#, () #)) + where siz# = sizeOf# (undefined :: a) + +-- | Fill a slice of a mutable primitive array with a value. +setPrimArray + :: (Prim a, PrimMonad m) + => MutablePrimArray (PrimState m) a -- ^ array to fill + -> Int -- ^ offset into array + -> Int -- ^ number of values to fill + -> a -- ^ value to fill with + -> m () +{-# INLINE setPrimArray #-} +setPrimArray (MutablePrimArray dst#) (I# doff#) (I# sz#) x + = primitive_ (PT.setByteArray# dst# doff# sz# x) + +-- | Get the size of a mutable primitive array in elements. Unlike 'sizeofMutablePrimArray', +-- this function ensures sequencing in the presence of resizing. +getSizeofMutablePrimArray :: forall m a. (PrimMonad m, Prim a) + => MutablePrimArray (PrimState m) a -- ^ array + -> m Int +{-# INLINE getSizeofMutablePrimArray #-} +#if __GLASGOW_HASKELL__ >= 801 +getSizeofMutablePrimArray (MutablePrimArray arr#) + = primitive (\s# -> + case getSizeofMutableByteArray# arr# s# of + (# s'#, sz# #) -> (# s'#, I# (quotInt# sz# (sizeOf# (undefined :: a))) #) + ) +#else +-- On older GHCs, it is not possible to resize a byte array, so +-- this provides behavior consistent with the implementation for +-- newer GHCs. +getSizeofMutablePrimArray arr + = return (sizeofMutablePrimArray arr) +#endif + +-- | Size of the mutable primitive array in elements. This function shall not +-- be used on primitive arrays that are an argument to or a result of +-- 'resizeMutablePrimArray' or 'shrinkMutablePrimArray'. +sizeofMutablePrimArray :: forall s a. Prim a => MutablePrimArray s a -> Int +{-# INLINE sizeofMutablePrimArray #-} +sizeofMutablePrimArray (MutablePrimArray arr#) = + I# (quotInt# (sizeofMutableByteArray# arr#) (sizeOf# (undefined :: a))) + +-- | Check if the two arrays refer to the same memory block. +sameMutablePrimArray :: MutablePrimArray s a -> MutablePrimArray s a -> Bool +{-# INLINE sameMutablePrimArray #-} +sameMutablePrimArray (MutablePrimArray arr#) (MutablePrimArray brr#) + = isTrue# (sameMutableByteArray# arr# brr#) + +-- | Convert a mutable byte array to an immutable one without copying. The +-- array should not be modified after the conversion. +unsafeFreezePrimArray + :: PrimMonad m => MutablePrimArray (PrimState m) a -> m (PrimArray a) +{-# INLINE unsafeFreezePrimArray #-} +unsafeFreezePrimArray (MutablePrimArray arr#) + = primitive (\s# -> case unsafeFreezeByteArray# arr# s# of + (# s'#, arr'# #) -> (# s'#, PrimArray arr'# #)) + +-- | Convert an immutable array to a mutable one without copying. The +-- original array should not be used after the conversion. +unsafeThawPrimArray + :: PrimMonad m => PrimArray a -> m (MutablePrimArray (PrimState m) a) +{-# INLINE unsafeThawPrimArray #-} +unsafeThawPrimArray (PrimArray arr#) + = primitive (\s# -> (# s#, MutablePrimArray (unsafeCoerce# arr#) #)) + +-- | Read a primitive value from the primitive array. +indexPrimArray :: forall a. Prim a => PrimArray a -> Int -> a +{-# INLINE indexPrimArray #-} +indexPrimArray (PrimArray arr#) (I# i#) = indexByteArray# arr# i# + +-- | Get the size, in elements, of the primitive array. +sizeofPrimArray :: forall a. Prim a => PrimArray a -> Int +{-# INLINE sizeofPrimArray #-} +sizeofPrimArray (PrimArray arr#) = I# (quotInt# (sizeofByteArray# arr#) (sizeOf# (undefined :: a))) + +-- | Lazy right-associated fold over the elements of a 'PrimArray'. +{-# INLINE foldrPrimArray #-} +foldrPrimArray :: forall a b. Prim a => (a -> b -> b) -> b -> PrimArray a -> b +foldrPrimArray f z arr = go 0 + where + !sz = sizeofPrimArray arr + go !i + | sz > i = f (indexPrimArray arr i) (go (i+1)) + | otherwise = z + +-- | Strict right-associated fold over the elements of a 'PrimArray'. +{-# INLINE foldrPrimArray' #-} +foldrPrimArray' :: forall a b. Prim a => (a -> b -> b) -> b -> PrimArray a -> b +foldrPrimArray' f z0 arr = go (sizeofPrimArray arr - 1) z0 + where + go !i !acc + | i < 0 = acc + | otherwise = go (i - 1) (f (indexPrimArray arr i) acc) + +-- | Lazy left-associated fold over the elements of a 'PrimArray'. +{-# INLINE foldlPrimArray #-} +foldlPrimArray :: forall a b. Prim a => (b -> a -> b) -> b -> PrimArray a -> b +foldlPrimArray f z arr = go (sizeofPrimArray arr - 1) + where + go !i + | i < 0 = z + | otherwise = f (go (i - 1)) (indexPrimArray arr i) + +-- | Strict left-associated fold over the elements of a 'PrimArray'. +{-# INLINE foldlPrimArray' #-} +foldlPrimArray' :: forall a b. Prim a => (b -> a -> b) -> b -> PrimArray a -> b +foldlPrimArray' f z0 arr = go 0 z0 + where + !sz = sizeofPrimArray arr + go !i !acc + | i < sz = go (i + 1) (f acc (indexPrimArray arr i)) + | otherwise = acc + +-- | Strict left-associated fold over the elements of a 'PrimArray'. +{-# INLINE foldlPrimArrayM' #-} +foldlPrimArrayM' :: (Prim a, Monad m) => (b -> a -> m b) -> b -> PrimArray a -> m b +foldlPrimArrayM' f z0 arr = go 0 z0 + where + !sz = sizeofPrimArray arr + go !i !acc1 + | i < sz = do + acc2 <- f acc1 (indexPrimArray arr i) + go (i + 1) acc2 + | otherwise = return acc1 + +-- | Traverse a primitive array. The traversal forces the resulting values and +-- writes them to the new primitive array as it performs the monadic effects. +-- Consequently: +-- +-- >>> traversePrimArrayP (\x -> print x $> bool x undefined (x == 2)) (fromList [1, 2, 3 :: Int]) +-- 1 +-- 2 +-- *** Exception: Prelude.undefined +-- +-- In many situations, 'traversePrimArrayP' can replace 'traversePrimArray', +-- changing the strictness characteristics of the traversal but typically improving +-- the performance. Consider the following short-circuiting traversal: +-- +-- > incrPositiveA :: PrimArray Int -> Maybe (PrimArray Int) +-- > incrPositiveA xs = traversePrimArray (\x -> bool Nothing (Just (x + 1)) (x > 0)) xs +-- +-- This can be rewritten using 'traversePrimArrayP'. To do this, we must +-- change the traversal context to @MaybeT (ST s)@, which has a 'PrimMonad' +-- instance: +-- +-- > incrPositiveB :: PrimArray Int -> Maybe (PrimArray Int) +-- > incrPositiveB xs = runST $ runMaybeT $ traversePrimArrayP +-- > (\x -> bool (MaybeT (return Nothing)) (MaybeT (return (Just (x + 1)))) (x > 0)) +-- > xs +-- +-- Benchmarks demonstrate that the second implementation runs 150 times +-- faster than the first. It also results in fewer allocations. +{-# INLINE traversePrimArrayP #-} +traversePrimArrayP :: (PrimMonad m, Prim a, Prim b) + => (a -> m b) + -> PrimArray a + -> m (PrimArray b) +traversePrimArrayP f arr = do + let !sz = sizeofPrimArray arr + marr <- newPrimArray sz + let go !ix = if ix < sz + then do + b <- f (indexPrimArray arr ix) + writePrimArray marr ix b + go (ix + 1) + else return () + go 0 + unsafeFreezePrimArray marr + +-- | Filter the primitive array, keeping the elements for which the monadic +-- predicate evaluates true. +{-# INLINE filterPrimArrayP #-} +filterPrimArrayP :: (PrimMonad m, Prim a) + => (a -> m Bool) + -> PrimArray a + -> m (PrimArray a) +filterPrimArrayP f arr = do + let !sz = sizeofPrimArray arr + marr <- newPrimArray sz + let go !ixSrc !ixDst = if ixSrc < sz + then do + let a = indexPrimArray arr ixSrc + b <- f a + if b + then do + writePrimArray marr ixDst a + go (ixSrc + 1) (ixDst + 1) + else go (ixSrc + 1) ixDst + else return ixDst + lenDst <- go 0 0 + marr' <- resizeMutablePrimArray marr lenDst + unsafeFreezePrimArray marr' + +-- | Map over the primitive array, keeping the elements for which the monadic +-- predicate provides a 'Just'. +{-# INLINE mapMaybePrimArrayP #-} +mapMaybePrimArrayP :: (PrimMonad m, Prim a, Prim b) + => (a -> m (Maybe b)) + -> PrimArray a + -> m (PrimArray b) +mapMaybePrimArrayP f arr = do + let !sz = sizeofPrimArray arr + marr <- newPrimArray sz + let go !ixSrc !ixDst = if ixSrc < sz + then do + let a = indexPrimArray arr ixSrc + mb <- f a + case mb of + Just b -> do + writePrimArray marr ixDst b + go (ixSrc + 1) (ixDst + 1) + Nothing -> go (ixSrc + 1) ixDst + else return ixDst + lenDst <- go 0 0 + marr' <- resizeMutablePrimArray marr lenDst + unsafeFreezePrimArray marr' + +-- | Generate a primitive array by evaluating the monadic generator function +-- at each index. +{-# INLINE generatePrimArrayP #-} +generatePrimArrayP :: (PrimMonad m, Prim a) + => Int -- ^ length + -> (Int -> m a) -- ^ generator + -> m (PrimArray a) +generatePrimArrayP sz f = do + marr <- newPrimArray sz + let go !ix = if ix < sz + then do + b <- f ix + writePrimArray marr ix b + go (ix + 1) + else return () + go 0 + unsafeFreezePrimArray marr + +-- | Execute the monadic action the given number of times and store the +-- results in a primitive array. +{-# INLINE replicatePrimArrayP #-} +replicatePrimArrayP :: (PrimMonad m, Prim a) + => Int + -> m a + -> m (PrimArray a) +replicatePrimArrayP sz f = do + marr <- newPrimArray sz + let go !ix = if ix < sz + then do + b <- f + writePrimArray marr ix b + go (ix + 1) + else return () + go 0 + unsafeFreezePrimArray marr + + +-- | Map over the elements of a primitive array. +{-# INLINE mapPrimArray #-} +mapPrimArray :: (Prim a, Prim b) + => (a -> b) + -> PrimArray a + -> PrimArray b +mapPrimArray f arr = runST $ do + let !sz = sizeofPrimArray arr + marr <- newPrimArray sz + let go !ix = if ix < sz + then do + let b = f (indexPrimArray arr ix) + writePrimArray marr ix b + go (ix + 1) + else return () + go 0 + unsafeFreezePrimArray marr + +-- | Indexed map over the elements of a primitive array. +{-# INLINE imapPrimArray #-} +imapPrimArray :: (Prim a, Prim b) + => (Int -> a -> b) + -> PrimArray a + -> PrimArray b +imapPrimArray f arr = runST $ do + let !sz = sizeofPrimArray arr + marr <- newPrimArray sz + let go !ix = if ix < sz + then do + let b = f ix (indexPrimArray arr ix) + writePrimArray marr ix b + go (ix + 1) + else return () + go 0 + unsafeFreezePrimArray marr + +-- | Filter elements of a primitive array according to a predicate. +{-# INLINE filterPrimArray #-} +filterPrimArray :: Prim a + => (a -> Bool) + -> PrimArray a + -> PrimArray a +filterPrimArray p arr = runST $ do + let !sz = sizeofPrimArray arr + marr <- newPrimArray sz + let go !ixSrc !ixDst = if ixSrc < sz + then do + let !a = indexPrimArray arr ixSrc + if p a + then do + writePrimArray marr ixDst a + go (ixSrc + 1) (ixDst + 1) + else go (ixSrc + 1) ixDst + else return ixDst + dstLen <- go 0 0 + marr' <- resizeMutablePrimArray marr dstLen + unsafeFreezePrimArray marr' + +-- | Filter the primitive array, keeping the elements for which the monadic +-- predicate evaluates true. +filterPrimArrayA :: + (Applicative f, Prim a) + => (a -> f Bool) -- ^ mapping function + -> PrimArray a -- ^ primitive array + -> f (PrimArray a) +filterPrimArrayA f = \ !ary -> + let + !len = sizeofPrimArray ary + go !ixSrc + | ixSrc == len = pure $ IxSTA $ \ixDst _ -> return ixDst + | otherwise = let x = indexPrimArray ary ixSrc in + liftA2 + (\keep (IxSTA m) -> IxSTA $ \ixDst mary -> if keep + then writePrimArray (MutablePrimArray mary) ixDst x >> m (ixDst + 1) mary + else m ixDst mary + ) + (f x) + (go (ixSrc + 1)) + in if len == 0 + then pure emptyPrimArray + else runIxSTA len <$> go 0 + +-- | Map over the primitive array, keeping the elements for which the applicative +-- predicate provides a 'Just'. +mapMaybePrimArrayA :: + (Applicative f, Prim a, Prim b) + => (a -> f (Maybe b)) -- ^ mapping function + -> PrimArray a -- ^ primitive array + -> f (PrimArray b) +mapMaybePrimArrayA f = \ !ary -> + let + !len = sizeofPrimArray ary + go !ixSrc + | ixSrc == len = pure $ IxSTA $ \ixDst _ -> return ixDst + | otherwise = let x = indexPrimArray ary ixSrc in + liftA2 + (\mb (IxSTA m) -> IxSTA $ \ixDst mary -> case mb of + Just b -> writePrimArray (MutablePrimArray mary) ixDst b >> m (ixDst + 1) mary + Nothing -> m ixDst mary + ) + (f x) + (go (ixSrc + 1)) + in if len == 0 + then pure emptyPrimArray + else runIxSTA len <$> go 0 + +-- | Map over a primitive array, optionally discarding some elements. This +-- has the same behavior as @Data.Maybe.mapMaybe@. +{-# INLINE mapMaybePrimArray #-} +mapMaybePrimArray :: (Prim a, Prim b) + => (a -> Maybe b) + -> PrimArray a + -> PrimArray b +mapMaybePrimArray p arr = runST $ do + let !sz = sizeofPrimArray arr + marr <- newPrimArray sz + let go !ixSrc !ixDst = if ixSrc < sz + then do + let !a = indexPrimArray arr ixSrc + case p a of + Just b -> do + writePrimArray marr ixDst b + go (ixSrc + 1) (ixDst + 1) + Nothing -> go (ixSrc + 1) ixDst + else return ixDst + dstLen <- go 0 0 + marr' <- resizeMutablePrimArray marr dstLen + unsafeFreezePrimArray marr' + + +-- | Traverse a primitive array. The traversal performs all of the applicative +-- effects /before/ forcing the resulting values and writing them to the new +-- primitive array. Consequently: +-- +-- >>> traversePrimArray (\x -> print x $> bool x undefined (x == 2)) (fromList [1, 2, 3 :: Int]) +-- 1 +-- 2 +-- 3 +-- *** Exception: Prelude.undefined +-- +-- The function 'traversePrimArrayP' always outperforms this function, but it +-- requires a 'PrimMonad' constraint, and it forces the values as +-- it performs the effects. +traversePrimArray :: + (Applicative f, Prim a, Prim b) + => (a -> f b) -- ^ mapping function + -> PrimArray a -- ^ primitive array + -> f (PrimArray b) +traversePrimArray f = \ !ary -> + let + !len = sizeofPrimArray ary + go !i + | i == len = pure $ STA $ \mary -> unsafeFreezePrimArray (MutablePrimArray mary) + | x <- indexPrimArray ary i + = liftA2 (\b (STA m) -> STA $ \mary -> + writePrimArray (MutablePrimArray mary) i b >> m mary) + (f x) (go (i + 1)) + in if len == 0 + then pure emptyPrimArray + else runSTA len <$> go 0 + +-- | Traverse a primitive array with the index of each element. +itraversePrimArray :: + (Applicative f, Prim a, Prim b) + => (Int -> a -> f b) + -> PrimArray a + -> f (PrimArray b) +itraversePrimArray f = \ !ary -> + let + !len = sizeofPrimArray ary + go !i + | i == len = pure $ STA $ \mary -> unsafeFreezePrimArray (MutablePrimArray mary) + | x <- indexPrimArray ary i + = liftA2 (\b (STA m) -> STA $ \mary -> + writePrimArray (MutablePrimArray mary) i b >> m mary) + (f i x) (go (i + 1)) + in if len == 0 + then pure emptyPrimArray + else runSTA len <$> go 0 + +-- | Traverse a primitive array with the indices. The traversal forces the +-- resulting values and writes them to the new primitive array as it performs +-- the monadic effects. +{-# INLINE itraversePrimArrayP #-} +itraversePrimArrayP :: (Prim a, Prim b, PrimMonad m) + => (Int -> a -> m b) + -> PrimArray a + -> m (PrimArray b) +itraversePrimArrayP f arr = do + let !sz = sizeofPrimArray arr + marr <- newPrimArray sz + let go !ix + | ix < sz = do + writePrimArray marr ix =<< f ix (indexPrimArray arr ix) + go (ix + 1) + | otherwise = return () + go 0 + unsafeFreezePrimArray marr + +-- | Generate a primitive array. +{-# INLINE generatePrimArray #-} +generatePrimArray :: Prim a + => Int -- ^ length + -> (Int -> a) -- ^ element from index + -> PrimArray a +generatePrimArray len f = runST $ do + marr <- newPrimArray len + let go !ix = if ix < len + then do + writePrimArray marr ix (f ix) + go (ix + 1) + else return () + go 0 + unsafeFreezePrimArray marr + +-- | Create a primitive array by copying the element the given +-- number of times. +{-# INLINE replicatePrimArray #-} +replicatePrimArray :: Prim a + => Int -- ^ length + -> a -- ^ element + -> PrimArray a +replicatePrimArray len a = runST $ do + marr <- newPrimArray len + setPrimArray marr 0 len a + unsafeFreezePrimArray marr + +-- | Generate a primitive array by evaluating the applicative generator +-- function at each index. +{-# INLINE generatePrimArrayA #-} +generatePrimArrayA :: + (Applicative f, Prim a) + => Int -- ^ length + -> (Int -> f a) -- ^ element from index + -> f (PrimArray a) +generatePrimArrayA len f = + let + go !i + | i == len = pure $ STA $ \mary -> unsafeFreezePrimArray (MutablePrimArray mary) + | otherwise + = liftA2 (\b (STA m) -> STA $ \mary -> + writePrimArray (MutablePrimArray mary) i b >> m mary) + (f i) (go (i + 1)) + in if len == 0 + then pure emptyPrimArray + else runSTA len <$> go 0 + +-- | Execute the applicative action the given number of times and store the +-- results in a vector. +{-# INLINE replicatePrimArrayA #-} +replicatePrimArrayA :: + (Applicative f, Prim a) + => Int -- ^ length + -> f a -- ^ applicative element producer + -> f (PrimArray a) +replicatePrimArrayA len f = + let + go !i + | i == len = pure $ STA $ \mary -> unsafeFreezePrimArray (MutablePrimArray mary) + | otherwise + = liftA2 (\b (STA m) -> STA $ \mary -> + writePrimArray (MutablePrimArray mary) i b >> m mary) + f (go (i + 1)) + in if len == 0 + then pure emptyPrimArray + else runSTA len <$> go 0 + +-- | Traverse the primitive array, discarding the results. There +-- is no 'PrimMonad' variant of this function since it would not provide +-- any performance benefit. +traversePrimArray_ :: + (Applicative f, Prim a) + => (a -> f b) + -> PrimArray a + -> f () +traversePrimArray_ f a = go 0 where + !sz = sizeofPrimArray a + go !ix = if ix < sz + then f (indexPrimArray a ix) *> go (ix + 1) + else pure () + +-- | Traverse the primitive array with the indices, discarding the results. +-- There is no 'PrimMonad' variant of this function since it would not +-- provide any performance benefit. +itraversePrimArray_ :: + (Applicative f, Prim a) + => (Int -> a -> f b) + -> PrimArray a + -> f () +itraversePrimArray_ f a = go 0 where + !sz = sizeofPrimArray a + go !ix = if ix < sz + then f ix (indexPrimArray a ix) *> go (ix + 1) + else pure () + +newtype IxSTA a = IxSTA {_runIxSTA :: forall s. Int -> MutableByteArray# s -> ST s Int} + +runIxSTA :: forall a. Prim a + => Int -- maximum possible size + -> IxSTA a + -> PrimArray a +runIxSTA !szUpper = \ (IxSTA m) -> runST $ do + ar :: MutablePrimArray s a <- newPrimArray szUpper + sz <- m 0 (unMutablePrimArray ar) + ar' <- resizeMutablePrimArray ar sz + unsafeFreezePrimArray ar' +{-# INLINE runIxSTA #-} + +newtype STA a = STA {_runSTA :: forall s. MutableByteArray# s -> ST s (PrimArray a)} + +runSTA :: forall a. Prim a => Int -> STA a -> PrimArray a +runSTA !sz = \ (STA m) -> runST $ newPrimArray sz >>= \ (ar :: MutablePrimArray s a) -> m (unMutablePrimArray ar) +{-# INLINE runSTA #-} + +unMutablePrimArray :: MutablePrimArray s a -> MutableByteArray# s +unMutablePrimArray (MutablePrimArray m) = m + +{- $effectfulMapCreate +The naming conventions adopted in this section are explained in the +documentation of the @Data.Primitive@ module. +-} diff --git a/src/Streamly/Internal/Data/SVar.hs b/src/Streamly/Internal/Data/SVar.hs --- a/src/Streamly/Internal/Data/SVar.hs +++ b/src/Streamly/Internal/Data/SVar.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE CPP #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ConstraintKinds #-} @@ -45,6 +44,7 @@ , setYieldLimit , getInspectMode , setInspectMode + , recordMaxWorkers , cleanupSVar , cleanupSVarFromWorker @@ -61,13 +61,17 @@ , ChildEvent (..) , AheadHeapEntry (..) , send + , sendToProducer , sendYield , sendStop + , sendStopToProducer , enqueueLIFO , enqueueFIFO , enqueueAhead , reEnqueueAhead , pushWorkerPar + , handleChildException + , handleFoldException , queueEmptyAhead , dequeueAhead @@ -96,22 +100,28 @@ , postProcessPaced , readOutputQBounded , readOutputQPaced + , readOutputQBasic , dispatchWorkerPaced , sendFirstWorker , delThread , modifyThread , doFork + , fork + , forkManaged , toStreamVar , SVarStats (..) , dumpSVar + , printSVar + , withDiagMVar ) where import Control.Concurrent - (ThreadId, myThreadId, threadDelay, throwTo) + (ThreadId, myThreadId, threadDelay, throwTo, forkIO, killThread) import Control.Concurrent.MVar - (MVar, newEmptyMVar, tryPutMVar, takeMVar, tryTakeMVar, newMVar, tryReadMVar) + (MVar, newEmptyMVar, tryPutMVar, takeMVar, tryTakeMVar, newMVar, + tryReadMVar) import Control.Exception (SomeException(..), catch, mask, assert, Exception, catches, throwIO, Handler(..), BlockedIndefinitelyOnMVar(..), @@ -119,7 +129,8 @@ import Control.Monad (when) import Control.Monad.Catch (MonadThrow) import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.Trans.Control (MonadBaseControl, control, StM) +import Control.Monad.Trans.Control + (MonadBaseControl, control, StM, liftBaseDiscard) import Streamly.Internal.Data.Atomics (atomicModifyIORefCAS, atomicModifyIORefCAS_, writeBarrier, storeLoadBarrier) @@ -140,11 +151,13 @@ import GHC.Conc (ThreadId(..)) import GHC.Exts import GHC.IO (IO(..)) +import System.IO (hPutStrLn, stderr) +import System.Mem.Weak (addFinalizer) + import Streamly.Internal.Data.Time.Clock (Clock(..), getTime) import Streamly.Internal.Data.Time.Units (AbsTime, NanoSecond64(..), MicroSecond64(..), diffAbsTime64, fromRelTime64, toRelTime64, showNanoSecond64, showRelTime64) -import System.IO (hPutStrLn, stderr) import qualified Data.Heap as H import qualified Data.Set as S @@ -418,6 +431,13 @@ , readOutputQ :: m [ChildEvent a] , postProcess :: m Bool + -- channel to send events from the consumer to the worker. Used to send + -- exceptions from a fold driver to the fold computation running as a + -- consumer thread in the concurrent fold cases. Currently only one event + -- is sent by the fold so we do not really need a queue for it. + , outputQueueFromConsumer :: IORef ([ChildEvent a], Int) + , outputDoorBellFromConsumer :: MVar () + -- Combined/aggregate parameters -- This is truncated to maxBufferLimit if set to more than that. Otherwise -- potentially each worker may yield one value to the buffer in the worst @@ -857,6 +877,11 @@ <> "---------STATS-----------\n" <> stats +printSVar :: SVar t m a -> String -> IO () +printSVar sv how = do + svInfo <- dumpSVar sv + hPutStrLn stderr $ "\n" <> how <> "\n" <> svInfo + -- MVar diagnostics has some overhead - around 5% on asyncly null benchmark, we -- can keep it on in production to debug problems quickly if and when they -- happen, but it may result in unexpected output when threads are left hanging @@ -931,6 +956,20 @@ exHandler run (return tid) +{-# INLINABLE fork #-} +fork :: MonadBaseControl IO m => m () -> m ThreadId +fork = liftBaseDiscard forkIO + +-- | Fork a thread that is automatically killed as soon as the reference to the +-- returned threadId is garbage collected. +-- +{-# INLINABLE forkManaged #-} +forkManaged :: (MonadIO m, MonadBaseControl IO m) => m () -> m ThreadId +forkManaged action = do + tid <- fork action + liftIO $ addFinalizer tid (killThread tid) + return tid + ------------------------------------------------------------------------------ -- Collecting results from child workers in a streamed fashion ------------------------------------------------------------------------------ @@ -1040,13 +1079,12 @@ Limited n -> atomicModifyIORefCAS_ (pushBufferSpace sv) (const (fromIntegral n)) --- | This function is used by the producer threads to queue output for the --- consumer thread to consume. Returns whether the queue has more space. -send :: SVar t m a -> ChildEvent a -> IO Int -send sv msg = do - -- XXX can the access to outputQueue and maxBufferLimit be made faster - -- somehow? - oldlen <- atomicModifyIORefCAS (outputQueue sv) $ \(es, n) -> +{-# INLINE sendWithDoorBell #-} +sendWithDoorBell :: + IORef ([ChildEvent a], Int) -> MVar () -> ChildEvent a -> IO Int +sendWithDoorBell q bell msg = do + -- XXX can the access to outputQueue be made faster somehow? + oldlen <- atomicModifyIORefCAS q $ \(es, n) -> ((msg : es, n + 1), n) when (oldlen <= 0) $ do -- The wake up must happen only after the store has finished otherwise @@ -1058,9 +1096,31 @@ -- to read the queue again and find it empty. -- The important point is that the consumer is guaranteed to receive a -- doorbell if something was added to the queue after it empties it. - void $ tryPutMVar (outputDoorBell sv) () + void $ tryPutMVar bell () return oldlen +-- | This function is used by the producer threads to queue output for the +-- consumer thread to consume. Returns whether the queue has more space. +send :: SVar t m a -> ChildEvent a -> IO Int +send sv msg = sendWithDoorBell (outputQueue sv) (outputDoorBell sv) msg + +-- There is no bound implemented on the buffer, this is assumed to be low +-- traffic. +sendToProducer :: SVar t m a -> ChildEvent a -> IO Int +sendToProducer sv msg = do + -- In case the producer stream is blocked on pushing to the fold buffer + -- then wake it up so that it can check for the stop event or exception + -- being sent to it otherwise we will be deadlocked. + void $ tryPutMVar (pushBufferMVar sv) () + sendWithDoorBell (outputQueueFromConsumer sv) + (outputDoorBellFromConsumer sv) msg + +-- {-# NOINLINE sendStopToProducer #-} +sendStopToProducer :: MonadIO m => SVar t m a -> m () +sendStopToProducer sv = liftIO $ do + tid <- myThreadId + void $ sendToProducer sv (ChildStop tid Nothing) + workerCollectLatency :: WorkerInfo -> IO (Maybe (Count, NanoSecond64)) workerCollectLatency winfo = do (cnt0, t0) <- readIORef (workerLatencyStart winfo) @@ -1488,6 +1548,12 @@ tid <- myThreadId void $ send sv (ChildStop tid (Just e)) +{-# NOINLINE handleFoldException #-} +handleFoldException :: SVar t m a -> SomeException -> IO () +handleFoldException sv e = do + tid <- myThreadId + void $ sendToProducer sv (ChildStop tid (Just e)) + {-# NOINLINE recordMaxWorkers #-} recordMaxWorkers :: MonadIO m => SVar t m a -> m () recordMaxWorkers sv = liftIO $ do @@ -1666,7 +1732,7 @@ -- maxWorkerLatency. -- let - -- How many workers do we need to acheive the required rate? + -- How many workers do we need to achieve the required rate? -- -- When the workers are IO bound we can increase the throughput by -- increasing the number of workers as long as the IO device has enough @@ -1683,7 +1749,7 @@ -- use that to determine the max rate of workers, and also take the CPU -- bandwidth into account. We can also discover the IO bandwidth if we -- know that we are not CPU bound, then how much steady state rate are - -- we able to acheive. Design tests for CPU bound and IO bound cases. + -- we able to achieve. Design tests for CPU bound and IO bound cases. -- Calculate how many yields are we ahead or behind to match the exact -- required rate. Based on that we increase or decrease the effective @@ -1999,10 +2065,14 @@ -- Reading from the workers' output queue/buffer ------------------------------------------------------------------------------- +{-# INLINE readOutputQBasic #-} +readOutputQBasic :: IORef ([ChildEvent a], Int) -> IO ([ChildEvent a], Int) +readOutputQBasic q = atomicModifyIORefCAS q $ \x -> (([],0), x) + {-# INLINE readOutputQRaw #-} readOutputQRaw :: SVar t m a -> IO ([ChildEvent a], Int) readOutputQRaw sv = do - (list, len) <- atomicModifyIORefCAS (outputQueue sv) $ \x -> (([],0), x) + (list, len) <- readOutputQBasic (outputQueue sv) when (svarInspectMode sv) $ do let ref = maxOutQSize $ svarStats sv oqLen <- readIORef ref @@ -2196,6 +2266,7 @@ let getSVar sv readOutput postProc = SVar { outputQueue = outQ + , outputQueueFromConsumer = undefined , remainingWork = yl , maxBufferLimit = getMaxBuffer st , pushBufferSpace = undefined @@ -2204,6 +2275,7 @@ , maxWorkerLimit = min (getMaxThreads st) (getMaxBuffer st) , yieldRateInfo = rateInfo , outputDoorBell = outQMv + , outputDoorBellFromConsumer = undefined , readOutputQ = readOutput sv , postProcess = postProc sv , workerThreads = running @@ -2265,7 +2337,9 @@ => SVarStopStyle -> State t m a -> RunInIO m -> IO (SVar t m a) getParallelSVar ss st mrun = do outQ <- newIORef ([], 0) + outQRev <- newIORef ([], 0) outQMv <- newEmptyMVar + outQMvRev <- newEmptyMVar active <- newIORef 0 running <- newIORef S.empty yl <- case getYieldLimit st of @@ -2289,6 +2363,7 @@ let sv = SVar { outputQueue = outQ + , outputQueueFromConsumer = outQRev , remainingWork = yl , maxBufferLimit = getMaxBuffer st , pushBufferSpace = remBuf @@ -2298,6 +2373,7 @@ -- Used only for diagnostics , yieldRateInfo = rateInfo , outputDoorBell = outQMv + , outputDoorBellFromConsumer = outQMvRev , readOutputQ = readOutputQPar sv , postProcess = allThreadsDone sv , workerThreads = running diff --git a/src/Streamly/Internal/Data/Sink.hs b/src/Streamly/Internal/Data/Sink.hs --- a/src/Streamly/Internal/Data/Sink.hs +++ b/src/Streamly/Internal/Data/Sink.hs @@ -1,5 +1,3 @@ -{-# OPTIONS_HADDOCK hide #-} - -- | -- Module : Streamly.Internal.Data.Sink -- Copyright : (c) 2019 Composewell Technologies diff --git a/src/Streamly/Internal/Data/Sink/Types.hs b/src/Streamly/Internal/Data/Sink/Types.hs --- a/src/Streamly/Internal/Data/Sink/Types.hs +++ b/src/Streamly/Internal/Data/Sink/Types.hs @@ -1,5 +1,3 @@ -{-# OPTIONS_HADDOCK hide #-} - -- | -- Module : Streamly.Internal.Data.Sink.Types -- Copyright : (c) 2019 Composewell Technologies @@ -18,9 +16,9 @@ -- Sink ------------------------------------------------------------------------------ --- | A 'Sink' is a special type of 'Foldl' that does not accumulate any value, +-- | A 'Sink' is a special type of 'Fold' that does not accumulate any value, -- but runs only effects. A 'Sink' has no state to maintain therefore can be a --- bit more efficient than a 'Foldl' with '()' as the state, especially when +-- bit more efficient than a 'Fold' with '()' as the state, especially when -- 'Sink's are composed with other operations. A Sink can be upgraded to a --- 'Foldl', but a 'Foldl' cannot be converted into a Sink. +-- 'Fold', but a 'Fold' cannot be converted into a Sink. data Sink m a = Sink (a -> m ()) diff --git a/src/Streamly/Internal/Data/SmallArray.hs b/src/Streamly/Internal/Data/SmallArray.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/SmallArray.hs @@ -0,0 +1,184 @@ +-- | +-- Module : Streamly.Internal.Data.SmallArray +-- Copyright : (c) 2019 Composewell Technologies +-- +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +#include "inline.hs" + +module Streamly.Internal.Data.SmallArray + ( + -- XXX should it be just Array instead? We should be able to replace one + -- array type with another easily. + SmallArray(..) + + , foldl' + , foldr + + , length + + , writeN + + , toStreamD + , toStreamDRev + + , toStream + , toStreamRev + , read + + , fromListN + , fromStreamDN + , fromStreamN + + , streamFold + , fold + ) +where + +import Prelude hiding (foldr, length, read) +import Control.DeepSeq (NFData(..)) +import Control.Monad (when) +import Control.Monad.IO.Class (MonadIO, liftIO) +import GHC.IO (unsafePerformIO) +import Data.Functor.Identity (runIdentity) + +import Streamly.Internal.Data.SmallArray.Types +import Streamly.Internal.Data.Unfold.Types (Unfold(..)) +import Streamly.Internal.Data.Fold.Types (Fold(..)) +import Streamly.Internal.Data.Stream.StreamK.Type (IsStream) +import Streamly.Internal.Data.Stream.Serial (SerialT) + +import qualified Streamly.Internal.Data.Stream.StreamD as D + +{-# NOINLINE bottomElement #-} +bottomElement :: a +bottomElement = undefined + +{-# INLINE length #-} +length :: SmallArray a -> Int +length arr = sizeofSmallArray arr + +{-# INLINE_NORMAL toStreamD #-} +toStreamD :: Monad m => SmallArray a -> D.Stream m a +toStreamD arr = D.Stream step 0 + where + {-# INLINE_LATE step #-} + step _ i + | i == length arr = return D.Stop + | otherwise = + return $ + case indexSmallArray## arr i of + (# x #) -> D.Yield x (i + 1) + +{-# INLINE_NORMAL toStreamDRev #-} +toStreamDRev :: Monad m => SmallArray a -> D.Stream m a +toStreamDRev arr = D.Stream step (length arr - 1) + where + {-# INLINE_LATE step #-} + step _ i + | i < 0 = return D.Stop + | otherwise = + return $ + case indexSmallArray## arr i of + (# x #) -> D.Yield x (i - 1) + +{-# INLINE_NORMAL foldl' #-} +foldl' :: (b -> a -> b) -> b -> SmallArray a -> b +foldl' f z arr = runIdentity $ D.foldl' f z $ toStreamD arr + +{-# INLINE_NORMAL foldr #-} +foldr :: (a -> b -> b) -> b -> SmallArray a -> b +foldr f z arr = runIdentity $ D.foldr f z $ toStreamD arr + +-- | @writeN n@ folds a maximum of @n@ elements from the input stream to an +-- 'SmallArray'. +-- +-- Since we are folding to a 'SmallArray' @n@ should be <= 128, for larger number +-- of elements use an 'Array' from either "Streamly.Data.Array" or "Streamly.Memory.Array". +{-# INLINE_NORMAL writeN #-} +writeN :: MonadIO m => Int -> Fold m a (SmallArray a) +writeN limit = Fold step initial extract + where + initial = do + marr <- liftIO $ newSmallArray limit bottomElement + return (marr, 0) + step (marr, i) x + | i == limit = return (marr, i) + | otherwise = do + liftIO $ writeSmallArray marr i x + return (marr, i + 1) + extract (marr, len) = liftIO $ freezeSmallArray marr 0 len + +{-# INLINE_NORMAL fromStreamDN #-} +fromStreamDN :: MonadIO m => Int -> D.Stream m a -> m (SmallArray a) +fromStreamDN limit str = do + marr <- liftIO $ newSmallArray (max limit 0) bottomElement + i <- + D.foldlM' + (\i x -> i `seq` (liftIO $ writeSmallArray marr i x) >> return (i + 1)) + 0 $ + D.take limit str + liftIO $ freezeSmallArray marr 0 i + +-- | Create a 'SmallArray' from the first @n@ elements of a list. The +-- array may hold less than @n@ elements if the length of the list <= +-- @n@. +-- +-- It is recommended to use a value of @n@ <= 128. For larger sized +-- arrays, use an 'Array' from "Streamly.Data.Array" or +-- "Streamly.Memory.Array" +{-# INLINABLE fromListN #-} +fromListN :: Int -> [a] -> SmallArray a +fromListN n xs = unsafePerformIO $ fromStreamDN n $ D.fromList xs + +instance NFData a => NFData (SmallArray a) where + {-# INLINE rnf #-} + rnf = foldl' (\_ x -> rnf x) () + +-- | Create a 'SmallArray' from the first @n@ elements of a stream. The +-- array is allocated to size @n@, if the stream terminates before @n@ +-- elements then the array may hold less than @n@ elements. +-- +-- For optimal performance use this with @n@ <= 128. +{-# INLINE fromStreamN #-} +fromStreamN :: MonadIO m => Int -> SerialT m a -> m (SmallArray a) +fromStreamN n m = do + when (n < 0) $ error "fromStreamN: negative write count specified" + fromStreamDN n $ D.toStreamD m + +{-# INLINE_EARLY toStream #-} +toStream :: (Monad m, IsStream t) => SmallArray a -> t m a +toStream = D.fromStreamD . toStreamD + +{-# INLINE_EARLY toStreamRev #-} +toStreamRev :: (Monad m, IsStream t) => SmallArray a -> t m a +toStreamRev = D.fromStreamD . toStreamDRev + +{-# INLINE fold #-} +fold :: Monad m => Fold m a b -> SmallArray a -> m b +fold f arr = D.runFold f (toStreamD arr) + +{-# INLINE streamFold #-} +streamFold :: Monad m => (SerialT m a -> m b) -> SmallArray a -> m b +streamFold f arr = f (toStream arr) + +{-# INLINE_NORMAL read #-} +read :: Monad m => Unfold m (SmallArray a) a +read = Unfold step inject + where + inject arr = return (arr, 0) + step (arr, i) + | i == length arr = return D.Stop + | otherwise = + return $ + case indexSmallArray## arr i of + (# x #) -> D.Yield x (arr, i + 1) diff --git a/src/Streamly/Internal/Data/SmallArray/Types.hs b/src/Streamly/Internal/Data/SmallArray/Types.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/SmallArray/Types.hs @@ -0,0 +1,834 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE BangPatterns #-} + +-- | +-- Module : Data.Primitive.SmallArray +-- Copyright: (c) 2015 Dan Doel +-- License: BSD3 +-- +-- Maintainer : streamly@composewell.com +-- Portability: non-portable +-- +-- Small arrays are boxed (im)mutable arrays. +-- +-- The underlying structure of the 'Array' type contains a card table, allowing +-- segments of the array to be marked as having been mutated. This allows the +-- garbage collector to only re-traverse segments of the array that have been +-- marked during certain phases, rather than having to traverse the entire +-- array. +-- +-- 'SmallArray' lacks this table. This means that it takes up less memory and +-- has slightly faster writes. It is also more efficient during garbage +-- collection so long as the card table would have a single entry covering the +-- entire array. These advantages make them suitable for use as arrays that are +-- known to be small. +-- +-- The card size is 128, so for uses much larger than that, 'Array' would likely +-- be superior. +-- +-- The underlying type, 'SmallArray#', was introduced in GHC 7.10, so prior to +-- that version, this module simply implements small arrays as 'Array'. + +module Streamly.Internal.Data.SmallArray.Types + ( SmallArray(..) + , SmallMutableArray(..) + , newSmallArray + , readSmallArray + , writeSmallArray + , copySmallArray + , copySmallMutableArray + , indexSmallArray + , indexSmallArrayM + , indexSmallArray## + , cloneSmallArray + , cloneSmallMutableArray + , freezeSmallArray + , unsafeFreezeSmallArray + , thawSmallArray + , runSmallArray + , unsafeThawSmallArray + , sizeofSmallArray + , sizeofSmallMutableArray + , smallArrayFromList + , smallArrayFromListN + , mapSmallArray' + , traverseSmallArrayP + ) where + +import GHC.Exts hiding (toList) +import qualified GHC.Exts + +import Control.Applicative +import Control.Monad +#if MIN_VERSION_base(4,9,0) +import qualified Control.Monad.Fail as Fail +#endif +import Control.Monad.Fix +import Control.Monad.Primitive +import Control.Monad.ST +import Control.Monad.Zip +import Data.Data +import Data.Foldable as Foldable +import Data.Functor.Identity +#if !(MIN_VERSION_base(4,10,0)) +import Data.Monoid +#endif +#if MIN_VERSION_base(4,9,0) +import qualified GHC.ST as GHCST +import qualified Data.Semigroup as Sem +#endif +import Text.ParserCombinators.ReadP + +#if MIN_VERSION_base(4,9,0) && !MIN_VERSION_base(4,10,0) +import GHC.Base (runRW#) +#endif + +#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) +import Data.Functor.Classes (Eq1(..),Ord1(..),Show1(..),Read1(..)) +#endif + +data SmallArray a = SmallArray (SmallArray# a) + deriving Typeable + +data SmallMutableArray s a = SmallMutableArray (SmallMutableArray# s a) + deriving Typeable + +-- | Create a new small mutable array. +newSmallArray + :: PrimMonad m + => Int -- ^ size + -> a -- ^ initial contents + -> m (SmallMutableArray (PrimState m) a) +newSmallArray (I# i#) x = primitive $ \s -> + case newSmallArray# i# x s of + (# s', sma# #) -> (# s', SmallMutableArray sma# #) +{-# INLINE newSmallArray #-} + +-- | Read the element at a given index in a mutable array. +readSmallArray + :: PrimMonad m + => SmallMutableArray (PrimState m) a -- ^ array + -> Int -- ^ index + -> m a +readSmallArray (SmallMutableArray sma#) (I# i#) = + primitive $ readSmallArray# sma# i# +{-# INLINE readSmallArray #-} + +-- | Write an element at the given idex in a mutable array. +writeSmallArray + :: PrimMonad m + => SmallMutableArray (PrimState m) a -- ^ array + -> Int -- ^ index + -> a -- ^ new element + -> m () +writeSmallArray (SmallMutableArray sma#) (I# i#) x = + primitive_ $ writeSmallArray# sma# i# x +{-# INLINE writeSmallArray #-} + +-- | Look up an element in an immutable array. +-- +-- The purpose of returning a result using a monad is to allow the caller to +-- avoid retaining references to the array. Evaluating the return value will +-- cause the array lookup to be performed, even though it may not require the +-- element of the array to be evaluated (which could throw an exception). For +-- instance: +-- +-- > data Box a = Box a +-- > ... +-- > +-- > f sa = case indexSmallArrayM sa 0 of +-- > Box x -> ... +-- +-- 'x' is not a closure that references 'sa' as it would be if we instead +-- wrote: +-- +-- > let x = indexSmallArray sa 0 +-- +-- And does not prevent 'sa' from being garbage collected. +-- +-- Note that 'Identity' is not adequate for this use, as it is a newtype, and +-- cannot be evaluated without evaluating the element. +indexSmallArrayM + :: Monad m + => SmallArray a -- ^ array + -> Int -- ^ index + -> m a +indexSmallArrayM (SmallArray sa#) (I# i#) = + case indexSmallArray# sa# i# of + (# x #) -> pure x +{-# INLINE indexSmallArrayM #-} + +-- | Look up an element in an immutable array. +indexSmallArray + :: SmallArray a -- ^ array + -> Int -- ^ index + -> a +indexSmallArray sa i = runIdentity $ indexSmallArrayM sa i +{-# INLINE indexSmallArray #-} + +-- | Read a value from the immutable array at the given index, returning +-- the result in an unboxed unary tuple. This is currently used to implement +-- folds. +indexSmallArray## :: SmallArray a -> Int -> (# a #) +indexSmallArray## (SmallArray ary) (I# i) = indexSmallArray# ary i +{-# INLINE indexSmallArray## #-} + +-- | Create a copy of a slice of an immutable array. +cloneSmallArray + :: SmallArray a -- ^ source + -> Int -- ^ offset + -> Int -- ^ length + -> SmallArray a +cloneSmallArray (SmallArray sa#) (I# i#) (I# j#) = + SmallArray (cloneSmallArray# sa# i# j#) +{-# INLINE cloneSmallArray #-} + +-- | Create a copy of a slice of a mutable array. +cloneSmallMutableArray + :: PrimMonad m + => SmallMutableArray (PrimState m) a -- ^ source + -> Int -- ^ offset + -> Int -- ^ length + -> m (SmallMutableArray (PrimState m) a) +cloneSmallMutableArray (SmallMutableArray sma#) (I# o#) (I# l#) = + primitive $ \s -> case cloneSmallMutableArray# sma# o# l# s of + (# s', smb# #) -> (# s', SmallMutableArray smb# #) +{-# INLINE cloneSmallMutableArray #-} + +-- | Create an immutable array corresponding to a slice of a mutable array. +-- +-- This operation copies the portion of the array to be frozen. +freezeSmallArray + :: PrimMonad m + => SmallMutableArray (PrimState m) a -- ^ source + -> Int -- ^ offset + -> Int -- ^ length + -> m (SmallArray a) +freezeSmallArray (SmallMutableArray sma#) (I# i#) (I# j#) = + primitive $ \s -> case freezeSmallArray# sma# i# j# s of + (# s', sa# #) -> (# s', SmallArray sa# #) +{-# INLINE freezeSmallArray #-} + +-- | Render a mutable array immutable. +-- +-- This operation performs no copying, so care must be taken not to modify the +-- input array after freezing. +unsafeFreezeSmallArray + :: PrimMonad m => SmallMutableArray (PrimState m) a -> m (SmallArray a) +unsafeFreezeSmallArray (SmallMutableArray sma#) = + primitive $ \s -> case unsafeFreezeSmallArray# sma# s of + (# s', sa# #) -> (# s', SmallArray sa# #) +{-# INLINE unsafeFreezeSmallArray #-} + +-- | Create a mutable array corresponding to a slice of an immutable array. +-- +-- This operation copies the portion of the array to be thawed. +thawSmallArray + :: PrimMonad m + => SmallArray a -- ^ source + -> Int -- ^ offset + -> Int -- ^ length + -> m (SmallMutableArray (PrimState m) a) +thawSmallArray (SmallArray sa#) (I# o#) (I# l#) = + primitive $ \s -> case thawSmallArray# sa# o# l# s of + (# s', sma# #) -> (# s', SmallMutableArray sma# #) +{-# INLINE thawSmallArray #-} + +-- | Render an immutable array mutable. +-- +-- This operation performs no copying, so care must be taken with its use. +unsafeThawSmallArray + :: PrimMonad m => SmallArray a -> m (SmallMutableArray (PrimState m) a) +unsafeThawSmallArray (SmallArray sa#) = + primitive $ \s -> case unsafeThawSmallArray# sa# s of + (# s', sma# #) -> (# s', SmallMutableArray sma# #) +{-# INLINE unsafeThawSmallArray #-} + +-- | Copy a slice of an immutable array into a mutable array. +copySmallArray + :: PrimMonad m + => SmallMutableArray (PrimState m) a -- ^ destination + -> Int -- ^ destination offset + -> SmallArray a -- ^ source + -> Int -- ^ source offset + -> Int -- ^ length + -> m () +copySmallArray + (SmallMutableArray dst#) (I# do#) (SmallArray src#) (I# so#) (I# l#) = + primitive_ $ copySmallArray# src# so# dst# do# l# +{-# INLINE copySmallArray #-} + +-- | Copy a slice of one mutable array into another. +copySmallMutableArray + :: PrimMonad m + => SmallMutableArray (PrimState m) a -- ^ destination + -> Int -- ^ destination offset + -> SmallMutableArray (PrimState m) a -- ^ source + -> Int -- ^ source offset + -> Int -- ^ length + -> m () +copySmallMutableArray + (SmallMutableArray dst#) (I# do#) + (SmallMutableArray src#) (I# so#) + (I# l#) = + primitive_ $ copySmallMutableArray# src# so# dst# do# l# +{-# INLINE copySmallMutableArray #-} + +sizeofSmallArray :: SmallArray a -> Int +sizeofSmallArray (SmallArray sa#) = I# (sizeofSmallArray# sa#) +{-# INLINE sizeofSmallArray #-} + +sizeofSmallMutableArray :: SmallMutableArray s a -> Int +sizeofSmallMutableArray (SmallMutableArray sa#) = + I# (sizeofSmallMutableArray# sa#) +{-# INLINE sizeofSmallMutableArray #-} + +-- | This is the fastest, most straightforward way to traverse +-- an array, but it only works correctly with a sufficiently +-- "affine" 'PrimMonad' instance. In particular, it must only produce +-- *one* result array. 'Control.Monad.Trans.List.ListT'-transformed +-- monads, for example, will not work right at all. +traverseSmallArrayP + :: PrimMonad m + => (a -> m b) + -> SmallArray a + -> m (SmallArray b) +traverseSmallArrayP f = \ !ary -> + let + !sz = sizeofSmallArray ary + go !i !mary + | i == sz + = unsafeFreezeSmallArray mary + | otherwise + = do + a <- indexSmallArrayM ary i + b <- f a + writeSmallArray mary i b + go (i + 1) mary + in do + mary <- newSmallArray sz badTraverseValue + go 0 mary +{-# INLINE traverseSmallArrayP #-} + +-- | Strict map over the elements of the array. +mapSmallArray' :: (a -> b) -> SmallArray a -> SmallArray b +mapSmallArray' f sa = createSmallArray (length sa) (die "mapSmallArray'" "impossible") $ \smb -> + fix ? 0 $ \go i -> + when (i < length sa) $ do + x <- indexSmallArrayM sa i + let !y = f x + writeSmallArray smb i y *> go (i+1) +{-# INLINE mapSmallArray' #-} + +#if !MIN_VERSION_base(4,9,0) +runSmallArray + :: (forall s. ST s (SmallMutableArray s a)) + -> SmallArray a +runSmallArray m = runST $ m >>= unsafeFreezeSmallArray + +#else +-- This low-level business is designed to work with GHC's worker-wrapper +-- transformation. A lot of the time, we don't actually need an Array +-- constructor. By putting it on the outside, and being careful about +-- how we special-case the empty array, we can make GHC smarter about this. +-- The only downside is that separately created 0-length arrays won't share +-- their Array constructors, although they'll share their underlying +-- Array#s. +runSmallArray + :: (forall s. ST s (SmallMutableArray s a)) + -> SmallArray a +runSmallArray m = SmallArray (runSmallArray# m) + +runSmallArray# + :: (forall s. ST s (SmallMutableArray s a)) + -> SmallArray# a +runSmallArray# m = case runRW# $ \s -> + case unST m s of { (# s', SmallMutableArray mary# #) -> + unsafeFreezeSmallArray# mary# s'} of (# _, ary# #) -> ary# + +unST :: ST s a -> State# s -> (# State# s, a #) +unST (GHCST.ST f) = f + +#endif + +-- See the comment on runSmallArray for why we use emptySmallArray#. +createSmallArray + :: Int + -> a + -> (forall s. SmallMutableArray s a -> ST s ()) + -> SmallArray a +createSmallArray 0 _ _ = SmallArray (emptySmallArray# (# #)) +createSmallArray n x f = runSmallArray $ do + mary <- newSmallArray n x + f mary + pure mary + +emptySmallArray# :: (# #) -> SmallArray# a +emptySmallArray# _ = case emptySmallArray of SmallArray ar -> ar +{-# NOINLINE emptySmallArray# #-} + +die :: String -> String -> a +die fun problem = error $ "Data.Primitive.SmallArray." ++ fun ++ ": " ++ problem + +emptySmallArray :: SmallArray a +emptySmallArray = + runST $ newSmallArray 0 (die "emptySmallArray" "impossible") + >>= unsafeFreezeSmallArray +{-# NOINLINE emptySmallArray #-} + + +infixl 1 ? +(?) :: (a -> b -> c) -> (b -> a -> c) +(?) = flip +{-# INLINE (?) #-} + +noOp :: a -> ST s () +noOp = const $ pure () + +smallArrayLiftEq :: (a -> b -> Bool) -> SmallArray a -> SmallArray b -> Bool +smallArrayLiftEq p sa1 sa2 = length sa1 == length sa2 && loop (length sa1 - 1) + where + loop i + | i < 0 + = True + | (# x #) <- indexSmallArray## sa1 i + , (# y #) <- indexSmallArray## sa2 i + = p x y && loop (i-1) + +#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) +-- | @since 0.6.4.0 +instance Eq1 SmallArray where +#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) + liftEq = smallArrayLiftEq +#else + eq1 = smallArrayLiftEq (==) +#endif +#endif + +instance Eq a => Eq (SmallArray a) where + sa1 == sa2 = smallArrayLiftEq (==) sa1 sa2 + +instance Eq (SmallMutableArray s a) where + SmallMutableArray sma1# == SmallMutableArray sma2# = + isTrue# (sameSmallMutableArray# sma1# sma2#) + +smallArrayLiftCompare :: (a -> b -> Ordering) -> SmallArray a -> SmallArray b -> Ordering +smallArrayLiftCompare elemCompare a1 a2 = loop 0 + where + mn = length a1 `min` length a2 + loop i + | i < mn + , (# x1 #) <- indexSmallArray## a1 i + , (# x2 #) <- indexSmallArray## a2 i + = elemCompare x1 x2 `mappend` loop (i+1) + | otherwise = compare (length a1) (length a2) + +#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) +-- | @since 0.6.4.0 +instance Ord1 SmallArray where +#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) + liftCompare = smallArrayLiftCompare +#else + compare1 = smallArrayLiftCompare compare +#endif +#endif + +-- | Lexicographic ordering. Subject to change between major versions. +instance Ord a => Ord (SmallArray a) where + compare sa1 sa2 = smallArrayLiftCompare compare sa1 sa2 + +instance Foldable SmallArray where + -- Note: we perform the array lookups eagerly so we won't + -- create thunks to perform lookups even if GHC can't see + -- that the folding function is strict. + foldr f = \z !ary -> + let + !sz = sizeofSmallArray ary + go i + | i == sz = z + | (# x #) <- indexSmallArray## ary i + = f x (go (i+1)) + in go 0 + {-# INLINE foldr #-} + foldl f = \z !ary -> + let + go i + | i < 0 = z + | (# x #) <- indexSmallArray## ary i + = f (go (i-1)) x + in go (sizeofSmallArray ary - 1) + {-# INLINE foldl #-} + foldr1 f = \ !ary -> + let + !sz = sizeofSmallArray ary - 1 + go i = + case indexSmallArray## ary i of + (# x #) | i == sz -> x + | otherwise -> f x (go (i+1)) + in if sz < 0 + then die "foldr1" "Empty SmallArray" + else go 0 + {-# INLINE foldr1 #-} + foldl1 f = \ !ary -> + let + !sz = sizeofSmallArray ary - 1 + go i = + case indexSmallArray## ary i of + (# x #) | i == 0 -> x + | otherwise -> f (go (i - 1)) x + in if sz < 0 + then die "foldl1" "Empty SmallArray" + else go sz + {-# INLINE foldl1 #-} + foldr' f = \z !ary -> + let + go i !acc + | i == -1 = acc + | (# x #) <- indexSmallArray## ary i + = go (i-1) (f x acc) + in go (sizeofSmallArray ary - 1) z + {-# INLINE foldr' #-} + foldl' f = \z !ary -> + let + !sz = sizeofSmallArray ary + go i !acc + | i == sz = acc + | (# x #) <- indexSmallArray## ary i + = go (i+1) (f acc x) + in go 0 z + {-# INLINE foldl' #-} + null a = sizeofSmallArray a == 0 + {-# INLINE null #-} + length = sizeofSmallArray + {-# INLINE length #-} + maximum ary | sz == 0 = die "maximum" "Empty SmallArray" + | (# frst #) <- indexSmallArray## ary 0 + = go 1 frst + where + sz = sizeofSmallArray ary + go i !e + | i == sz = e + | (# x #) <- indexSmallArray## ary i + = go (i+1) (max e x) + {-# INLINE maximum #-} + minimum ary | sz == 0 = die "minimum" "Empty SmallArray" + | (# frst #) <- indexSmallArray## ary 0 + = go 1 frst + where sz = sizeofSmallArray ary + go i !e + | i == sz = e + | (# x #) <- indexSmallArray## ary i + = go (i+1) (min e x) + {-# INLINE minimum #-} + sum = foldl' (+) 0 + {-# INLINE sum #-} + product = foldl' (*) 1 + {-# INLINE product #-} + +newtype STA a = STA {_runSTA :: forall s. SmallMutableArray# s a -> ST s (SmallArray a)} + +runSTA :: Int -> STA a -> SmallArray a +runSTA !sz = \ (STA m) -> runST $ newSmallArray_ sz >>= + \ (SmallMutableArray ar#) -> m ar# +{-# INLINE runSTA #-} + +newSmallArray_ :: Int -> ST s (SmallMutableArray s a) +newSmallArray_ !n = newSmallArray n badTraverseValue + +badTraverseValue :: a +badTraverseValue = die "traverse" "bad indexing" +{-# NOINLINE badTraverseValue #-} + +instance Traversable SmallArray where + traverse f = traverseSmallArray f + {-# INLINE traverse #-} + +traverseSmallArray + :: Applicative f + => (a -> f b) -> SmallArray a -> f (SmallArray b) +traverseSmallArray f = \ !ary -> + let + !len = sizeofSmallArray ary + go !i + | i == len + = pure $ STA $ \mary -> unsafeFreezeSmallArray (SmallMutableArray mary) + | (# x #) <- indexSmallArray## ary i + = liftA2 (\b (STA m) -> STA $ \mary -> + writeSmallArray (SmallMutableArray mary) i b >> m mary) + (f x) (go (i + 1)) + in if len == 0 + then pure emptySmallArray + else runSTA len <$> go 0 +{-# INLINE [1] traverseSmallArray #-} + +{-# RULES +"traverse/ST" forall (f :: a -> ST s b). traverseSmallArray f = traverseSmallArrayP f +"traverse/IO" forall (f :: a -> IO b). traverseSmallArray f = traverseSmallArrayP f +"traverse/Id" forall (f :: a -> Identity b). traverseSmallArray f = + (coerce :: (SmallArray a -> SmallArray (Identity b)) + -> SmallArray a -> Identity (SmallArray b)) (fmap f) + #-} + + +instance Functor SmallArray where + fmap f sa = createSmallArray (length sa) (die "fmap" "impossible") $ \smb -> + fix ? 0 $ \go i -> + when (i < length sa) $ do + x <- indexSmallArrayM sa i + writeSmallArray smb i (f x) *> go (i+1) + {-# INLINE fmap #-} + + x <$ sa = createSmallArray (length sa) x noOp + +instance Applicative SmallArray where + pure x = createSmallArray 1 x noOp + + sa *> sb = createSmallArray (la*lb) (die "*>" "impossible") $ \smb -> + fix ? 0 $ \go i -> + when (i < la) $ + copySmallArray smb 0 sb 0 lb *> go (i+1) + where + la = length sa ; lb = length sb + + a <* b = createSmallArray (sza*szb) (die "<*" "impossible") $ \ma -> + let fill off i e = when (i < szb) $ + writeSmallArray ma (off+i) e >> fill off (i+1) e + go i = when (i < sza) $ do + x <- indexSmallArrayM a i + fill (i*szb) 0 x + go (i+1) + in go 0 + where sza = sizeofSmallArray a ; szb = sizeofSmallArray b + + ab <*> a = createSmallArray (szab*sza) (die "<*>" "impossible") $ \mb -> + let go1 i = when (i < szab) $ + do + f <- indexSmallArrayM ab i + go2 (i*sza) f 0 + go1 (i+1) + go2 off f j = when (j < sza) $ + do + x <- indexSmallArrayM a j + writeSmallArray mb (off + j) (f x) + go2 off f (j + 1) + in go1 0 + where szab = sizeofSmallArray ab ; sza = sizeofSmallArray a + +instance Alternative SmallArray where + empty = emptySmallArray + + sl <|> sr = + createSmallArray (length sl + length sr) (die "<|>" "impossible") $ \sma -> + copySmallArray sma 0 sl 0 (length sl) + *> copySmallArray sma (length sl) sr 0 (length sr) + + many sa | null sa = pure [] + | otherwise = die "many" "infinite arrays are not well defined" + + some sa | null sa = emptySmallArray + | otherwise = die "some" "infinite arrays are not well defined" + +data ArrayStack a + = PushArray !(SmallArray a) !(ArrayStack a) + | EmptyStack +-- TODO: This isn't terribly efficient. It would be better to wrap +-- ArrayStack with a type like +-- +-- data NES s a = NES !Int !(SmallMutableArray s a) !(ArrayStack a) +-- +-- We'd copy incoming arrays into the mutable array until we would +-- overflow it. Then we'd freeze it, push it on the stack, and continue. +-- Any sufficiently large incoming arrays would go straight on the stack. +-- Such a scheme would make the stack much more compact in the case +-- of many small arrays. + +instance Monad SmallArray where + return = pure + (>>) = (*>) + + sa >>= f = collect 0 EmptyStack (la-1) + where + la = length sa + collect sz stk i + | i < 0 = createSmallArray sz (die ">>=" "impossible") $ fill 0 stk + | (# x #) <- indexSmallArray## sa i + , let sb = f x + lsb = length sb + -- If we don't perform this check, we could end up allocating + -- a stack full of empty arrays if someone is filtering most + -- things out. So we refrain from pushing empty arrays. + = if lsb == 0 + then collect sz stk (i-1) + else collect (sz + lsb) (PushArray sb stk) (i-1) + + fill _ EmptyStack _ = return () + fill off (PushArray sb sbs) smb = + copySmallArray smb off sb 0 (length sb) + *> fill (off + length sb) sbs smb + +#if !(MIN_VERSION_base(4,13,0)) && MIN_VERSION_base(4,9,0) + fail = Fail.fail +#endif + +#if MIN_VERSION_base(4,9,0) +instance Fail.MonadFail SmallArray where + fail _ = emptySmallArray +#endif + +instance MonadPlus SmallArray where + mzero = empty + mplus = (<|>) + +zipW :: String -> (a -> b -> c) -> SmallArray a -> SmallArray b -> SmallArray c +zipW nm = \f sa sb -> let mn = length sa `min` length sb in + createSmallArray mn (die nm "impossible") $ \mc -> + fix ? 0 $ \go i -> when (i < mn) $ do + x <- indexSmallArrayM sa i + y <- indexSmallArrayM sb i + writeSmallArray mc i (f x y) + go (i+1) +{-# INLINE zipW #-} + +instance MonadZip SmallArray where + mzip = zipW "mzip" (,) + mzipWith = zipW "mzipWith" + {-# INLINE mzipWith #-} + munzip sab = runST $ do + let sz = length sab + sma <- newSmallArray sz $ die "munzip" "impossible" + smb <- newSmallArray sz $ die "munzip" "impossible" + fix ? 0 $ \go i -> + when (i < sz) $ case indexSmallArray sab i of + (x, y) -> do writeSmallArray sma i x + writeSmallArray smb i y + go $ i+1 + (,) <$> unsafeFreezeSmallArray sma + <*> unsafeFreezeSmallArray smb + +instance MonadFix SmallArray where + mfix f = createSmallArray (sizeofSmallArray (f err)) + (die "mfix" "impossible") $ flip fix 0 $ + \r !i !mary -> when (i < sz) $ do + writeSmallArray mary i (fix (\xi -> f xi `indexSmallArray` i)) + r (i + 1) mary + where + sz = sizeofSmallArray (f err) + err = error "mfix for Data.Primitive.SmallArray applied to strict function." + +#if MIN_VERSION_base(4,9,0) +-- | @since 0.6.3.0 +instance Sem.Semigroup (SmallArray a) where + (<>) = (<|>) + sconcat = mconcat . toList +#endif + +instance Monoid (SmallArray a) where + mempty = empty +#if !(MIN_VERSION_base(4,11,0)) + mappend = (<|>) +#endif + mconcat l = createSmallArray n (die "mconcat" "impossible") $ \ma -> + let go !_ [ ] = return () + go off (a:as) = + copySmallArray ma off a 0 (sizeofSmallArray a) >> go (off + sizeofSmallArray a) as + in go 0 l + where n = sum . fmap length $ l + +instance IsList (SmallArray a) where + type Item (SmallArray a) = a + fromListN = smallArrayFromListN + fromList = smallArrayFromList + toList = Foldable.toList + +smallArrayLiftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> SmallArray a -> ShowS +smallArrayLiftShowsPrec elemShowsPrec elemListShowsPrec p sa = showParen (p > 10) $ + showString "fromListN " . shows (length sa) . showString " " + . listLiftShowsPrec elemShowsPrec elemListShowsPrec 11 (toList sa) + +-- this need to be included for older ghcs +listLiftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> [a] -> ShowS +listLiftShowsPrec _ sl _ = sl + +instance Show a => Show (SmallArray a) where + showsPrec p sa = smallArrayLiftShowsPrec showsPrec showList p sa + +#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) +-- | @since 0.6.4.0 +instance Show1 SmallArray where +#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) + liftShowsPrec = smallArrayLiftShowsPrec +#else + showsPrec1 = smallArrayLiftShowsPrec showsPrec showList +#endif +#endif + +smallArrayLiftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (SmallArray a) +smallArrayLiftReadsPrec _ listReadsPrec p = readParen (p > 10) . readP_to_S $ do + () <$ string "fromListN" + skipSpaces + n <- readS_to_P reads + skipSpaces + l <- readS_to_P listReadsPrec + return $ smallArrayFromListN n l + +instance Read a => Read (SmallArray a) where + readsPrec = smallArrayLiftReadsPrec readsPrec readList + +#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) +-- | @since 0.6.4.0 +instance Read1 SmallArray where +#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) + liftReadsPrec = smallArrayLiftReadsPrec +#else + readsPrec1 = smallArrayLiftReadsPrec readsPrec readList +#endif +#endif + + + +smallArrayDataType :: DataType +smallArrayDataType = + mkDataType "Data.Primitive.SmallArray.SmallArray" [fromListConstr] + +fromListConstr :: Constr +fromListConstr = mkConstr smallArrayDataType "fromList" [] Prefix + +instance Data a => Data (SmallArray a) where + toConstr _ = fromListConstr + dataTypeOf _ = smallArrayDataType + gunfold k z c = case constrIndex c of + 1 -> k (z fromList) + _ -> die "gunfold" "SmallArray" + gfoldl f z m = z fromList `f` toList m + +instance (Typeable s, Typeable a) => Data (SmallMutableArray s a) where + toConstr _ = die "toConstr" "SmallMutableArray" + gunfold _ _ = die "gunfold" "SmallMutableArray" + dataTypeOf _ = mkNoRepType "Data.Primitive.SmallArray.SmallMutableArray" + +-- | Create a 'SmallArray' from a list of a known length. If the length +-- of the list does not match the given length, this throws an exception. +smallArrayFromListN :: Int -> [a] -> SmallArray a +smallArrayFromListN n l = + createSmallArray n + (die "smallArrayFromListN" "uninitialized element") $ \sma -> + let go !ix [] = if ix == n + then return () + else die "smallArrayFromListN" "list length less than specified size" + go !ix (x : xs) = if ix < n + then do + writeSmallArray sma ix x + go (ix+1) xs + else die "smallArrayFromListN" "list length greater than specified size" + in go 0 l + +-- | Create a 'SmallArray' from a list. +smallArrayFromList :: [a] -> SmallArray a +smallArrayFromList l = smallArrayFromListN (length l) l diff --git a/src/Streamly/Internal/Data/Stream/Ahead.hs b/src/Streamly/Internal/Data/Stream/Ahead.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/Ahead.hs @@ -0,0 +1,733 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving#-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} -- XXX + +-- | +-- Module : Streamly.Internal.Data.Stream.Ahead +-- Copyright : (c) 2017 Harendra Kumar +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- +module Streamly.Internal.Data.Stream.Ahead + ( + AheadT + , Ahead + , aheadly + , ahead + ) +where + +import Control.Concurrent.MVar (putMVar, takeMVar) +import Control.Exception (assert) +import Control.Monad (void, when) +import Control.Monad.Base (MonadBase(..), liftBaseDefault) +import Control.Monad.Catch (MonadThrow, throwM) +-- import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Reader.Class (MonadReader(..)) +import Control.Monad.State.Class (MonadState(..)) +import Control.Monad.Trans.Class (MonadTrans(lift)) +import Control.Monad.Trans.Control (MonadBaseControl (..)) +import Data.Heap (Heap, Entry(..)) +import Data.IORef (IORef, readIORef, atomicModifyIORef, writeIORef) +import Data.Maybe (fromJust) +#if __GLASGOW_HASKELL__ < 808 +import Data.Semigroup (Semigroup(..)) +#endif +import GHC.Exts (inline) + +import qualified Data.Heap as H + +import Streamly.Internal.Data.Stream.SVar (fromSVar) +import Streamly.Internal.Data.SVar +import Streamly.Internal.Data.Stream.StreamK + (IsStream(..), Stream, mkStream, foldStream, foldStreamShared) +import qualified Streamly.Internal.Data.Stream.StreamK as K +import qualified Streamly.Internal.Data.Stream.StreamD as D + +import Prelude hiding (map) + +#include "Instances.hs" + +------------------------------------------------------------------------------- +-- Ahead +------------------------------------------------------------------------------- + +-- Lookahead streams can execute multiple tasks concurrently, ahead of time, +-- but always serve them in the same order as they appear in the stream. To +-- implement lookahead streams efficiently we assign a sequence number to each +-- task when the task is picked up for execution. When the task finishes, the +-- output is tagged with the same sequence number and we rearrange the outputs +-- in sequence based on that number. +-- +-- To explain the mechanism imagine that the current task at the head of the +-- stream has a "token" to yield to the outputQueue. The ownership of the token +-- is determined by the current sequence number is maintained in outputHeap. +-- Sequence number is assigned when a task is queued. When a thread dequeues a +-- task it picks up the sequence number as well and when the output is ready it +-- uses the sequence number to queue the output to the outputQueue. +-- +-- The thread with current sequence number sends the output directly to the +-- outputQueue. Other threads push the output to the outputHeap. When the task +-- being queued on the heap is a stream of many elements we evaluate only the +-- first element and keep the rest of the unevaluated computation in the heap. +-- When such a task gets the "token" for outputQueue it evaluates and directly +-- yields all the elements to the outputQueue without checking for the +-- "token". +-- +-- Note that no two outputs in the heap can have the same sequence numbers and +-- therefore we do not need a stable heap. We have also separated the buffer +-- for the current task (outputQueue) and the pending tasks (outputHeap) so +-- that the pending tasks cannot interfere with the current task. Note that for +-- a single task just the outputQueue is enough and for the case of many +-- threads just a heap is good enough. However we balance between these two +-- cases, so that both are efficient. +-- +-- For bigger streams it may make sense to have separate buffers for each +-- stream. However, for singleton streams this may become inefficient. However, +-- if we do not have separate buffers, then the streams that come later in +-- sequence may hog the buffer, hindering the streams that are ahead. For this +-- reason we have a single element buffer limitation for the streams being +-- executed in advance. +-- +-- This scheme works pretty efficiently with less than 40% extra overhead +-- compared to the Async streams where we do not have any kind of sequencing of +-- the outputs. It is especially devised so that we are most efficient when we +-- have short tasks and need just a single thread. Also when a thread yields +-- many items it can hold lockfree access to the outputQueue and do it +-- efficiently. +-- +-- XXX Maybe we can start the ahead threads at a lower cpu and IO priority so +-- that they do not hog the resources and hinder the progress of the threads in +-- front of them. + +-- Left associated ahead expressions are expensive. We start a new SVar for +-- each left associative expression. The queue is used only for right +-- associated expression, we queue the right expression and execute the left. +-- Thererefore the queue never has more than on item in it. +-- +-- XXX Also note that limiting concurrency for cases like "take 10" would not +-- work well with left associative expressions, because we have no visibility +-- about how much the left side of the expression would yield. +-- +-- XXX It may be a good idea to increment sequence numbers for each yield, +-- currently a stream on the left side of the expression may yield many +-- elements with the same sequene number. We can then use the seq number to +-- enforce yieldMax and yieldLImit as well. + +-- Invariants: +-- +-- * A worker should always ensure that it pushes all the consecutive items in +-- the heap to the outputQueue especially the items on behalf of the workers +-- that have already left when we were holding the token. This avoids deadlock +-- conditions when the later workers completion depends on the consumption of +-- earlier results. For more details see comments in the consumer pull side +-- code. + +{-# INLINE underMaxHeap #-} +underMaxHeap :: + SVar Stream m a + -> Heap (Entry Int (AheadHeapEntry Stream m a)) + -> IO Bool +underMaxHeap sv hp = do + (_, len) <- readIORef (outputQueue sv) + + -- XXX simplify this + let maxHeap = case maxBufferLimit sv of + Limited lim -> Limited $ + max 0 (lim - fromIntegral len) + Unlimited -> Unlimited + + case maxHeap of + Limited lim -> do + active <- readIORef (workerCount sv) + return $ H.size hp + active <= fromIntegral lim + Unlimited -> return True + +-- Return value: +-- True => stop +-- False => continue +preStopCheck :: + SVar Stream m a + -> IORef (Heap (Entry Int (AheadHeapEntry Stream m a)) , Maybe Int) + -> IO Bool +preStopCheck sv heap = + -- check the stop condition under a lock before actually + -- stopping so that the whole herd does not stop at once. + withIORef heap $ \(hp, _) -> do + heapOk <- underMaxHeap sv hp + takeMVar (workerStopMVar sv) + let stop = do + putMVar (workerStopMVar sv) () + return True + continue = do + putMVar (workerStopMVar sv) () + return False + if heapOk + then + case yieldRateInfo sv of + Nothing -> continue + Just yinfo -> do + rateOk <- isBeyondMaxRate sv yinfo + if rateOk then continue else stop + else stop + +abortExecution :: + IORef ([Stream m a], Int) + -> SVar Stream m a + -> Maybe WorkerInfo + -> Stream m a + -> IO () +abortExecution q sv winfo m = do + reEnqueueAhead sv q m + incrementYieldLimit sv + sendStop sv winfo + +-- XXX In absence of a "noyield" primitive (i.e. do not pre-empt inside a +-- critical section) from GHC RTS, we have a difficult problem. Assume we have +-- a 100,000 threads producing output and queuing it to the heap for +-- sequencing. The heap can be drained only by one thread at a time, any thread +-- that finds that heap can be drained now, takes a lock and starts draining +-- it, however the thread may get prempted in the middle of it holding the +-- lock. Since that thread is holding the lock, the other threads cannot pick +-- up the draining task, therefore they proceed to picking up the next task to +-- execute. If the draining thread could yield voluntarily at a point where it +-- has released the lock, then the next threads could pick up the draining +-- instead of executing more tasks. When there are 100,000 threads the drainer +-- gets a cpu share to run only 1:100000 of the time. This makes the heap +-- accumulate a lot of output when we the buffer size is large. +-- +-- The solutions to this problem are: +-- 1) make the other threads wait in a queue until the draining finishes +-- 2) make the other threads queue and go away if draining is in progress +-- +-- In both cases we give the drainer a chance to run more often. +-- +processHeap + :: (MonadIO m, MonadBaseControl IO m) + => IORef ([Stream m a], Int) + -> IORef (Heap (Entry Int (AheadHeapEntry Stream m a)), Maybe Int) + -> State Stream m a + -> SVar Stream m a + -> Maybe WorkerInfo + -> AheadHeapEntry Stream m a + -> Int + -> Bool -- we are draining the heap before we stop + -> m () +processHeap q heap st sv winfo entry sno stopping = loopHeap sno entry + + where + + stopIfNeeded ent seqNo r = do + stopIt <- liftIO $ preStopCheck sv heap + if stopIt + then liftIO $ do + -- put the entry back in the heap and stop + requeueOnHeapTop heap (Entry seqNo ent) seqNo + sendStop sv winfo + else runStreamWithYieldLimit True seqNo r + + loopHeap seqNo ent = + case ent of + AheadEntryNull -> nextHeap seqNo + AheadEntryPure a -> do + -- Use 'send' directly so that we do not account this in worker + -- latency as this will not be the real latency. + -- Don't stop the worker in this case as we are just + -- transferring available results from heap to outputQueue. + void $ liftIO $ send sv (ChildYield a) + nextHeap seqNo + AheadEntryStream r -> + if stopping + then stopIfNeeded ent seqNo r + else runStreamWithYieldLimit True seqNo r + + nextHeap prevSeqNo = do + res <- liftIO $ dequeueFromHeapSeq heap (prevSeqNo + 1) + case res of + Ready (Entry seqNo hent) -> loopHeap seqNo hent + Clearing -> liftIO $ sendStop sv winfo + Waiting _ -> + if stopping + then do + r <- liftIO $ preStopCheck sv heap + if r + then liftIO $ sendStop sv winfo + else processWorkQueue prevSeqNo + else inline processWorkQueue prevSeqNo + + processWorkQueue prevSeqNo = do + work <- dequeueAhead q + case work of + Nothing -> liftIO $ sendStop sv winfo + Just (m, seqNo) -> do + yieldLimitOk <- liftIO $ decrementYieldLimit sv + if yieldLimitOk + then + if seqNo == prevSeqNo + 1 + then processWithToken q heap st sv winfo m seqNo + else processWithoutToken q heap st sv winfo m seqNo + else liftIO $ abortExecution q sv winfo m + + -- We do not stop the worker on buffer full here as we want to proceed to + -- nextHeap anyway so that we can clear any subsequent entries. We stop + -- only in yield continuation where we may have a remaining stream to be + -- pushed on the heap. + singleStreamFromHeap seqNo a = do + void $ liftIO $ sendYield sv winfo (ChildYield a) + nextHeap seqNo + + -- XXX when we have an unfinished stream on the heap we cannot account all + -- the yields of that stream until it finishes, so if we have picked up + -- and executed more actions beyond that in the parent stream and put them + -- on the heap then they would eat up some yield limit which is not + -- correct, we will think that our yield limit is over even though we have + -- to yield items from unfinished stream before them. For this reason, if + -- there are pending items in the heap we drain them unconditionally + -- without considering the yield limit. + runStreamWithYieldLimit continue seqNo r = do + _ <- liftIO $ decrementYieldLimit sv + if continue -- see comment above -- && yieldLimitOk + then do + let stop = do + liftIO (incrementYieldLimit sv) + nextHeap seqNo + foldStreamShared st + (yieldStreamFromHeap seqNo) + (singleStreamFromHeap seqNo) + stop + r + else liftIO $ do + let ent = Entry seqNo (AheadEntryStream r) + liftIO $ requeueOnHeapTop heap ent seqNo + incrementYieldLimit sv + sendStop sv winfo + + yieldStreamFromHeap seqNo a r = do + continue <- liftIO $ sendYield sv winfo (ChildYield a) + runStreamWithYieldLimit continue seqNo r + +{-# NOINLINE drainHeap #-} +drainHeap + :: (MonadIO m, MonadBaseControl IO m) + => IORef ([Stream m a], Int) + -> IORef (Heap (Entry Int (AheadHeapEntry Stream m a)), Maybe Int) + -> State Stream m a + -> SVar Stream m a + -> Maybe WorkerInfo + -> m () +drainHeap q heap st sv winfo = do + r <- liftIO $ dequeueFromHeap heap + case r of + Ready (Entry seqNo hent) -> + processHeap q heap st sv winfo hent seqNo True + _ -> liftIO $ sendStop sv winfo + +data HeapStatus = HContinue | HStop +data WorkerStatus = Continue | Suspend + +processWithoutToken + :: (MonadIO m, MonadBaseControl IO m) + => IORef ([Stream m a], Int) + -> IORef (Heap (Entry Int (AheadHeapEntry Stream m a)), Maybe Int) + -> State Stream m a + -> SVar Stream m a + -> Maybe WorkerInfo + -> Stream m a + -> Int + -> m () +processWithoutToken q heap st sv winfo m seqNo = do + -- we have already decremented the yield limit for m + let stop = do + liftIO (incrementYieldLimit sv) + -- If the stream stops without yielding anything, and we do not put + -- anything on heap, but if heap was waiting for this seq number + -- then it will keep waiting forever, because we are never going to + -- put it on heap. So we have to put a null entry on heap even when + -- we stop. + toHeap AheadEntryNull + mrun = runInIO $ svarMrun sv + + r <- liftIO $ mrun $ + foldStreamShared st + (\a r -> toHeap $ AheadEntryStream $ K.cons a r) + (toHeap . AheadEntryPure) + stop + m + res <- restoreM r + case res of + Continue -> workLoopAhead q heap st sv winfo + Suspend -> drainHeap q heap st sv winfo + + where + + -- XXX to reduce contention each CPU can have its own heap + toHeap ent = do + -- Heap insertion is an expensive affair so we use a non CAS based + -- modification, otherwise contention and retries can make a thread + -- context switch and throw it behind other threads which come later in + -- sequence. + newHp <- liftIO $ atomicModifyIORef heap $ \(hp, snum) -> + let hp' = H.insert (Entry seqNo ent) hp + in assert (heapIsSane snum seqNo) ((hp', snum), hp') + + when (svarInspectMode sv) $ + liftIO $ do + maxHp <- readIORef (maxHeapSize $ svarStats sv) + when (H.size newHp > maxHp) $ + writeIORef (maxHeapSize $ svarStats sv) (H.size newHp) + + heapOk <- liftIO $ underMaxHeap sv newHp + status <- + case yieldRateInfo sv of + Nothing -> return HContinue + Just yinfo -> + case winfo of + Just info -> do + rateOk <- liftIO $ workerRateControl sv yinfo info + if rateOk + then return HContinue + else return HStop + Nothing -> return HContinue + + if heapOk + then + case status of + HContinue -> return Continue + HStop -> return Suspend + else return Suspend + +data TokenWorkerStatus = TokenContinue Int | TokenSuspend + +processWithToken + :: (MonadIO m, MonadBaseControl IO m) + => IORef ([Stream m a], Int) + -> IORef (Heap (Entry Int (AheadHeapEntry Stream m a)), Maybe Int) + -> State Stream m a + -> SVar Stream m a + -> Maybe WorkerInfo + -> Stream m a + -> Int + -> m () +processWithToken q heap st sv winfo action sno = do + -- Note, we enter this function with yield limit already decremented + -- XXX deduplicate stop in all invocations + let stop = do + liftIO (incrementYieldLimit sv) + return $ TokenContinue (sno + 1) + mrun = runInIO $ svarMrun sv + + r <- liftIO $ mrun $ + foldStreamShared st (yieldOutput sno) (singleOutput sno) stop action + + res <- restoreM r + case res of + TokenContinue seqNo -> loopWithToken seqNo + TokenSuspend -> drainHeap q heap st sv winfo + + where + + singleOutput seqNo a = do + continue <- liftIO $ sendYield sv winfo (ChildYield a) + if continue + then return $ TokenContinue (seqNo + 1) + else do + liftIO $ updateHeapSeq heap (seqNo + 1) + return TokenSuspend + + -- XXX use a wrapper function around stop so that we never miss + -- incrementing the yield in a stop continuation. Essentiatlly all + -- "unstream" calls in this function must increment yield limit on stop. + yieldOutput seqNo a r = do + continue <- liftIO $ sendYield sv winfo (ChildYield a) + yieldLimitOk <- liftIO $ decrementYieldLimit sv + if continue && yieldLimitOk + then do + let stop = do + liftIO (incrementYieldLimit sv) + return $ TokenContinue (seqNo + 1) + foldStreamShared st + (yieldOutput seqNo) + (singleOutput seqNo) + stop + r + else do + let ent = Entry seqNo (AheadEntryStream r) + liftIO $ requeueOnHeapTop heap ent seqNo + liftIO $ incrementYieldLimit sv + return TokenSuspend + + loopWithToken nextSeqNo = do + work <- dequeueAhead q + case work of + Nothing -> do + liftIO $ updateHeapSeq heap nextSeqNo + workLoopAhead q heap st sv winfo + + Just (m, seqNo) -> do + yieldLimitOk <- liftIO $ decrementYieldLimit sv + let undo = liftIO $ do + updateHeapSeq heap nextSeqNo + reEnqueueAhead sv q m + incrementYieldLimit sv + if yieldLimitOk + then + if seqNo == nextSeqNo + then do + let stop = do + liftIO (incrementYieldLimit sv) + return $ TokenContinue (seqNo + 1) + mrun = runInIO $ svarMrun sv + r <- liftIO $ mrun $ + foldStreamShared st + (yieldOutput seqNo) + (singleOutput seqNo) + stop + m + res <- restoreM r + case res of + TokenContinue seqNo1 -> loopWithToken seqNo1 + TokenSuspend -> drainHeap q heap st sv winfo + + else + -- To avoid a race when another thread puts something + -- on the heap and goes away, the consumer will not get + -- a doorBell and we will not clear the heap before + -- executing the next action. If the consumer depends + -- on the output that is stuck in the heap then this + -- will result in a deadlock. So we always clear the + -- heap before executing the next action. + undo >> workLoopAhead q heap st sv winfo + else undo >> drainHeap q heap st sv winfo + +-- XXX the yield limit changes increased the performance overhead by 30-40%. +-- Just like AsyncT we can use an implementation without yeidlimit and even +-- without pacing code to keep the performance higher in the unlimited and +-- unpaced case. +-- +-- XXX The yieldLimit stuff is pretty invasive. We can instead do it by using +-- three hooks, a pre-execute hook, a yield hook and a stop hook. In fact these +-- hooks can be used for a more general implementation to even check predicates +-- and not just yield limit. + +-- XXX we can remove the sv parameter as it can be derived from st + +workLoopAhead + :: (MonadIO m, MonadBaseControl IO m) + => IORef ([Stream m a], Int) + -> IORef (Heap (Entry Int (AheadHeapEntry Stream m a)), Maybe Int) + -> State Stream m a + -> SVar Stream m a + -> Maybe WorkerInfo + -> m () +workLoopAhead q heap st sv winfo = do + r <- liftIO $ dequeueFromHeap heap + case r of + Ready (Entry seqNo hent) -> + processHeap q heap st sv winfo hent seqNo False + Clearing -> liftIO $ sendStop sv winfo + Waiting _ -> do + -- Before we execute the next item from the work queue we check + -- if we are beyond the yield limit. It is better to check the + -- yield limit before we pick up the next item. Otherwise we + -- may have already started more tasks even though we may have + -- reached the yield limit. We can avoid this by taking active + -- workers into account, but that is not as reliable, because + -- workers may go away without picking up work and yielding a + -- value. + -- + -- Rate control can be done either based on actual yields in + -- the output queue or based on any yield either to the heap or + -- to the output queue. In both cases we may have one issue or + -- the other. We chose to do this based on actual yields to the + -- output queue because it makes the code common to both async + -- and ahead streams. + -- + work <- dequeueAhead q + case work of + Nothing -> liftIO $ sendStop sv winfo + Just (m, seqNo) -> do + yieldLimitOk <- liftIO $ decrementYieldLimit sv + if yieldLimitOk + then + if seqNo == 0 + then processWithToken q heap st sv winfo m seqNo + else processWithoutToken q heap st sv winfo m seqNo + -- If some worker decremented the yield limit but then + -- did not yield anything and therefore incremented it + -- later, then if we did not requeue m here we may find + -- the work queue empty and therefore miss executing + -- the remaining action. + else liftIO $ abortExecution q sv winfo m + +------------------------------------------------------------------------------- +-- WAhead +------------------------------------------------------------------------------- + +-- XXX To be implemented. Use a linked queue like WAsync and put back the +-- remaining computation at the back of the queue instead of the heap, and +-- increment the sequence number. + +-- The only difference between forkSVarAsync and this is that we run the left +-- computation without a shared SVar. +forkSVarAhead :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a +forkSVarAhead m1 m2 = mkStream $ \st yld sng stp -> do + sv <- newAheadVar st (concurrently (toStream m1) (toStream m2)) + workLoopAhead + foldStream st yld sng stp (fromSVar sv) + where + concurrently ma mb = mkStream $ \st yld sng stp -> do + liftIO $ enqueue (fromJust $ streamVar st) mb + foldStream st yld sng stp ma + +-- | 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 yld sng stp -> + case streamVar st of + Just sv | svarStyle sv == AheadVar -> do + 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. + foldStream st yld sng stp m1 + _ -> foldStreamShared st yld sng stp (forkSVarAhead m1 m2) + +-- | XXX we can implement it more efficienty by directly implementing instead +-- of combining streams using ahead. +{-# INLINE consMAhead #-} +{-# 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 +------------------------------------------------------------------------------ + +-- | The 'Semigroup' operation for 'AheadT' appends two streams. The combined +-- stream behaves like a single stream with the actions from the second stream +-- appended to the first stream. The combined stream is evaluated in the +-- speculative style. This operation can be used to fold an infinite lazy +-- container of streams. +-- +-- @ +-- import "Streamly" +-- import qualified "Streamly.Prelude" as S +-- import Control.Concurrent +-- +-- main = do +-- xs \<- S.'toList' . 'aheadly' $ (p 1 |: p 2 |: nil) <> (p 3 |: p 4 |: nil) +-- print xs +-- where p n = threadDelay 1000000 >> return n +-- @ +-- @ +-- [1,2,3,4] +-- @ +-- +-- Any exceptions generated by a constituent stream are propagated to the +-- output stream. +-- +-- The monad instance of 'AheadT' may run each monadic continuation (bind) +-- concurrently in a speculative manner, performing side effects in a partially +-- ordered manner but producing the outputs in an ordered manner like +-- 'SerialT'. +-- +-- @ +-- main = S.drain . 'aheadly' $ do +-- n <- return 3 \<\> return 2 \<\> return 1 +-- S.yieldM $ do +-- threadDelay (n * 1000000) +-- myThreadId >>= \\tid -> putStrLn (show tid ++ ": Delay " ++ show n) +-- @ +-- @ +-- ThreadId 40: Delay 1 +-- ThreadId 39: Delay 2 +-- ThreadId 38: Delay 3 +-- @ +-- +-- @since 0.3.0 +newtype AheadT m a = AheadT {getAheadT :: Stream m a} + deriving (MonadTrans) + +-- | A serial IO stream of elements of type @a@ with concurrent lookahead. See +-- 'AheadT' documentation for more details. +-- +-- @since 0.3.0 +type Ahead = AheadT IO + +-- | Fix the type of a polymorphic stream as 'AheadT'. +-- +-- @since 0.3.0 +aheadly :: IsStream t => AheadT m a -> t m a +aheadly = K.adapt + +instance IsStream AheadT where + toStream = getAheadT + fromStream = AheadT + consM = consMAhead + (|:) = consMAhead + +------------------------------------------------------------------------------ +-- Semigroup +------------------------------------------------------------------------------ + +{-# 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 + (<>) = mappendAhead + +------------------------------------------------------------------------------ +-- Monoid +------------------------------------------------------------------------------ + +instance MonadAsync m => Monoid (AheadT m a) where + mempty = K.nil + mappend = (<>) + +------------------------------------------------------------------------------ +-- Monad +------------------------------------------------------------------------------ + +{-# INLINE concatMapAhead #-} +{-# SPECIALIZE concatMapAhead :: (a -> AheadT IO b) -> AheadT IO a -> AheadT IO b #-} +concatMapAhead :: MonadAsync m => (a -> AheadT m b) -> AheadT m a -> AheadT m b +concatMapAhead f m = fromStream $ + K.concatMapBy ahead (\a -> K.adapt $ f a) (K.adapt m) + +{-# INLINE apAhead #-} +apAhead :: MonadAsync m => AheadT m (a -> b) -> AheadT m a -> AheadT m b +apAhead (AheadT m1) (AheadT m2) = + let f x1 = K.concatMapBy ahead (pure . x1) m2 + in AheadT $ K.concatMapBy ahead f m1 + +instance (Monad m, MonadAsync m) => Applicative (AheadT m) where + {-# INLINE pure #-} + pure = AheadT . K.yield + {-# INLINE (<*>) #-} + (<*>) = apAhead + +instance MonadAsync m => Monad (AheadT m) where + return = pure + {-# INLINE (>>=) #-} + (>>=) = flip concatMapAhead + +------------------------------------------------------------------------------ +-- Other instances +------------------------------------------------------------------------------ + +MONAD_COMMON_INSTANCES(AheadT, MONADPARALLEL) diff --git a/src/Streamly/Internal/Data/Stream/Async.hs b/src/Streamly/Internal/Data/Stream/Async.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/Async.hs @@ -0,0 +1,998 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving#-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} -- XXX + +#include "inline.hs" + +-- | +-- Module : Streamly.Internal.Data.Stream.Async +-- Copyright : (c) 2017 Harendra Kumar +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- +module Streamly.Internal.Data.Stream.Async + ( + AsyncT + , Async + , asyncly + , async + , (<|) --deprecated + , mkAsync + , mkAsyncK + + , WAsyncT + , WAsync + , wAsyncly + , wAsync + ) +where + +import Control.Concurrent (myThreadId) +import Control.Monad.Base (MonadBase(..), liftBaseDefault) +import Control.Monad.Catch (MonadThrow, throwM) +import Control.Monad.Trans.Control (MonadBaseControl (..)) +import Control.Concurrent.MVar (newEmptyMVar) +-- import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Reader.Class (MonadReader(..)) +import Control.Monad.State.Class (MonadState(..)) +import Control.Monad.Trans.Class (MonadTrans(lift)) +import Data.Concurrent.Queue.MichaelScott (LinkedQueue, newQ, nullQ, tryPopR) +import Data.IORef (IORef, newIORef, readIORef) +import Data.Maybe (fromJust) +#if __GLASGOW_HASKELL__ < 808 +import Data.Semigroup (Semigroup(..)) +#endif + +import Prelude hiding (map) +import qualified Data.Set as S + +import Streamly.Internal.Data.Atomics (atomicModifyIORefCAS) +import Streamly.Internal.Data.Stream.SVar (fromSVar) +import Streamly.Internal.Data.SVar +import Streamly.Internal.Data.Stream.StreamK + (IsStream(..), Stream, mkStream, foldStream, adapt, foldStreamShared) +import qualified Streamly.Internal.Data.Stream.StreamK as K +import qualified Streamly.Internal.Data.Stream.StreamD as D + +#include "Instances.hs" + +------------------------------------------------------------------------------- +-- Async +------------------------------------------------------------------------------- + +data WorkerStatus = Continue | Suspend + +{-# INLINE workLoopLIFO #-} +workLoopLIFO + :: (MonadIO m, MonadBaseControl IO m) + => IORef [Stream m a] + -> State Stream m a + -> SVar Stream m a + -> Maybe WorkerInfo + -> m () +workLoopLIFO q st sv winfo = run + + where + + mrun = runInIO $ svarMrun sv + run = do + work <- dequeue + let stop = liftIO $ sendStop sv winfo + case work of + Nothing -> stop + Just m -> do + -- XXX when we finish we need to send the monadic state back to + -- the parent so that the state can be merged back. We capture + -- and return the state in the stop continuation. + -- + -- Instead of using the run function we can just restore the + -- monad state here. That way it can work easily for + -- distributed case as well. + r <- liftIO $ mrun $ + foldStreamShared st yieldk single (return Continue) m + res <- restoreM r + case res of + Continue -> run + Suspend -> stop + + single a = do + res <- liftIO $ sendYield sv winfo (ChildYield a) + return $ if res then Continue else Suspend + + yieldk a r = do + res <- liftIO $ sendYield sv winfo (ChildYield a) + if res + then foldStreamShared st yieldk single (return Continue) r + else liftIO $ do + -- XXX we also need to save the monadic state here + enqueueLIFO sv q r + return Suspend + + dequeue = liftIO $ atomicModifyIORefCAS q $ \case + [] -> ([], Nothing) + x : xs -> (xs, Just x) + +-- We duplicate workLoop for yield limit and no limit cases because it has +-- around 40% performance overhead in the worst case. +-- +-- XXX we can pass yinfo directly as an argument here so that we do not have to +-- make a check every time. +{-# INLINE workLoopLIFOLimited #-} +workLoopLIFOLimited + :: (MonadIO m, MonadBaseControl IO m) + => IORef [Stream m a] + -> State Stream m a + -> SVar Stream m a + -> Maybe WorkerInfo + -> m () +workLoopLIFOLimited q st sv winfo = run + + where + + mrun = runInIO $ svarMrun sv + incrContinue = liftIO (incrementYieldLimit sv) >> return Continue + run = do + work <- dequeue + let stop = liftIO $ sendStop sv winfo + case work of + Nothing -> stop + Just m -> do + -- XXX This is just a best effort minimization of concurrency + -- to the yield limit. If the stream is made of concurrent + -- streams we do not reserve the yield limit in the constituent + -- streams before executing the action. This can be done + -- though, by sharing the yield limit ref with downstream + -- actions via state passing. Just a todo. + yieldLimitOk <- liftIO $ decrementYieldLimit sv + if yieldLimitOk + then do + r <- liftIO $ mrun $ + foldStreamShared st yieldk single incrContinue m + res <- restoreM r + case res of + Continue -> run + Suspend -> stop + -- Avoid any side effects, undo the yield limit decrement if we + -- never yielded anything. + else liftIO $ do + enqueueLIFO sv q m + incrementYieldLimit sv + sendStop sv winfo + + single a = do + res <- liftIO $ sendYield sv winfo (ChildYield a) + return $ if res then Continue else Suspend + + -- XXX can we pass on the yield limit downstream to limit the concurrency + -- of constituent streams. + yieldk a r = do + res <- liftIO $ sendYield sv winfo (ChildYield a) + yieldLimitOk <- liftIO $ decrementYieldLimit sv + if res && yieldLimitOk + then foldStreamShared st yieldk single incrContinue r + else liftIO $ do + incrementYieldLimit sv + enqueueLIFO sv q r + return Suspend + + dequeue = liftIO $ atomicModifyIORefCAS q $ \case + [] -> ([], Nothing) + x : xs -> (xs, Just x) + +------------------------------------------------------------------------------- +-- WAsync +------------------------------------------------------------------------------- + +-- XXX we can remove sv as it is derivable from st + +{-# INLINE workLoopFIFO #-} +workLoopFIFO + :: (MonadIO m, MonadBaseControl IO m) + => LinkedQueue (Stream m a) + -> State Stream m a + -> SVar Stream m a + -> Maybe WorkerInfo + -> m () +workLoopFIFO q st sv winfo = run + + where + + mrun = runInIO $ svarMrun sv + run = do + work <- liftIO $ tryPopR q + let stop = liftIO $ sendStop sv winfo + case work of + Nothing -> stop + Just m -> do + r <- liftIO $ mrun $ + foldStreamShared st yieldk single (return Continue) m + res <- restoreM r + case res of + Continue -> run + Suspend -> stop + + single a = do + res <- liftIO $ sendYield sv winfo (ChildYield a) + return $ if res then Continue else Suspend + + -- XXX in general we would like to yield "n" elements from a single stream + -- before moving on to the next. Single element granularity could be too + -- expensive in certain cases. Similarly, we can use time limit for + -- yielding. + yieldk a r = do + res <- liftIO $ sendYield sv winfo (ChildYield a) + liftIO $ enqueueFIFO sv q r + return $ if res then Continue else Suspend + +{-# INLINE workLoopFIFOLimited #-} +workLoopFIFOLimited + :: (MonadIO m, MonadBaseControl IO m) + => LinkedQueue (Stream m a) + -> State Stream m a + -> SVar Stream m a + -> Maybe WorkerInfo + -> m () +workLoopFIFOLimited q st sv winfo = run + + where + + mrun = runInIO $ svarMrun sv + incrContinue = liftIO (incrementYieldLimit sv) >> return Continue + run = do + work <- liftIO $ tryPopR q + let stop = liftIO $ sendStop sv winfo + case work of + Nothing -> stop + Just m -> do + yieldLimitOk <- liftIO $ decrementYieldLimit sv + if yieldLimitOk + then do + r <- liftIO $ mrun $ + foldStreamShared st yieldk single incrContinue m + res <- restoreM r + case res of + Continue -> run + Suspend -> stop + else liftIO $ do + enqueueFIFO sv q m + incrementYieldLimit sv + sendStop sv winfo + + single a = do + res <- liftIO $ sendYield sv winfo (ChildYield a) + return $ if res then Continue else Suspend + + yieldk a r = do + res <- liftIO $ sendYield sv winfo (ChildYield a) + liftIO $ enqueueFIFO sv q r + yieldLimitOk <- liftIO $ decrementYieldLimit sv + if res && yieldLimitOk + then return Continue + else liftIO $ do + incrementYieldLimit sv + return Suspend + +------------------------------------------------------------------------------- +-- SVar creation +-- This code belongs in SVar.hs but is kept here for perf reasons +------------------------------------------------------------------------------- + +-- XXX we have this function in this file because passing runStreamLIFO as a +-- function argument to this function results in a perf degradation of more +-- than 10%. Need to investigate what the root cause is. +-- Interestingly, the same thing does not make any difference for Ahead. +getLifoSVar :: forall m a. MonadAsync m + => State Stream m a -> RunInIO m -> IO (SVar Stream m a) +getLifoSVar st mrun = do + outQ <- newIORef ([], 0) + outQMv <- newEmptyMVar + active <- newIORef 0 + wfw <- newIORef False + running <- newIORef S.empty + q <- newIORef [] + yl <- case getYieldLimit st of + Nothing -> return Nothing + Just x -> Just <$> newIORef x + rateInfo <- getYieldRateInfo st + + stats <- newSVarStats + tid <- myThreadId + + let isWorkFinished _ = null <$> readIORef q + + let isWorkFinishedLimited sv = do + yieldsDone <- + case remainingWork sv of + Just ref -> do + n <- readIORef ref + return (n <= 0) + Nothing -> return False + qEmpty <- null <$> readIORef q + return $ qEmpty || yieldsDone + + let getSVar :: SVar Stream m a + -> (SVar Stream m a -> m [ChildEvent a]) + -> (SVar Stream m a -> m Bool) + -> (SVar Stream m a -> IO Bool) + -> (IORef [Stream m a] + -> State Stream m a + -> SVar Stream m a + -> Maybe WorkerInfo + -> m()) + -> SVar Stream m a + getSVar sv readOutput postProc workDone wloop = SVar + { outputQueue = outQ + , outputQueueFromConsumer = undefined + , remainingWork = yl + , maxBufferLimit = getMaxBuffer st + , pushBufferSpace = undefined + , pushBufferPolicy = undefined + , pushBufferMVar = undefined + , maxWorkerLimit = min (getMaxThreads st) (getMaxBuffer st) + , yieldRateInfo = rateInfo + , outputDoorBell = outQMv + , outputDoorBellFromConsumer = undefined + , readOutputQ = readOutput sv + , postProcess = postProc sv + , workerThreads = running + , workLoop = wloop q st{streamVar = Just sv} sv + , enqueue = enqueueLIFO sv q + , isWorkDone = workDone sv + , isQueueDone = workDone sv + , needDoorBell = wfw + , svarStyle = AsyncVar + , svarStopStyle = StopNone + , svarStopBy = undefined + , svarMrun = mrun + , workerCount = active + , accountThread = delThread sv + , workerStopMVar = undefined + , svarRef = Nothing + , svarInspectMode = getInspectMode st + , svarCreator = tid + , aheadWorkQueue = undefined + , outputHeap = undefined + , svarStats = stats + } + + let sv = + case getStreamRate st of + Nothing -> + case getYieldLimit st of + Nothing -> getSVar sv readOutputQBounded + postProcessBounded + isWorkFinished + workLoopLIFO + Just _ -> getSVar sv readOutputQBounded + postProcessBounded + isWorkFinishedLimited + workLoopLIFOLimited + Just _ -> + case getYieldLimit st of + Nothing -> getSVar sv readOutputQPaced + postProcessPaced + isWorkFinished + workLoopLIFO + Just _ -> getSVar sv readOutputQPaced + postProcessPaced + isWorkFinishedLimited + workLoopLIFOLimited + in return sv + +getFifoSVar :: forall m a. MonadAsync m + => State Stream m a -> RunInIO m -> IO (SVar Stream m a) +getFifoSVar st mrun = do + outQ <- newIORef ([], 0) + outQMv <- newEmptyMVar + active <- newIORef 0 + wfw <- newIORef False + running <- newIORef S.empty + q <- newQ + yl <- case getYieldLimit st of + Nothing -> return Nothing + Just x -> Just <$> newIORef x + rateInfo <- getYieldRateInfo st + + stats <- newSVarStats + tid <- myThreadId + + let isWorkFinished _ = nullQ q + let isWorkFinishedLimited sv = do + yieldsDone <- + case remainingWork sv of + Just ref -> do + n <- readIORef ref + return (n <= 0) + Nothing -> return False + qEmpty <- nullQ q + return $ qEmpty || yieldsDone + + let getSVar :: SVar Stream m a + -> (SVar Stream m a -> m [ChildEvent a]) + -> (SVar Stream m a -> m Bool) + -> (SVar Stream m a -> IO Bool) + -> (LinkedQueue (Stream m a) + -> State Stream m a + -> SVar Stream m a + -> Maybe WorkerInfo + -> m()) + -> SVar Stream m a + getSVar sv readOutput postProc workDone wloop = SVar + { outputQueue = outQ + , outputQueueFromConsumer = undefined + , remainingWork = yl + , maxBufferLimit = getMaxBuffer st + , pushBufferSpace = undefined + , pushBufferPolicy = undefined + , pushBufferMVar = undefined + , maxWorkerLimit = min (getMaxThreads st) (getMaxBuffer st) + , yieldRateInfo = rateInfo + , outputDoorBell = outQMv + , outputDoorBellFromConsumer = undefined + , readOutputQ = readOutput sv + , postProcess = postProc sv + , workerThreads = running + , workLoop = wloop q st{streamVar = Just sv} sv + , enqueue = enqueueFIFO sv q + , isWorkDone = workDone sv + , isQueueDone = workDone sv + , needDoorBell = wfw + , svarStyle = WAsyncVar + , svarStopStyle = StopNone + , svarStopBy = undefined + , svarMrun = mrun + , workerCount = active + , accountThread = delThread sv + , workerStopMVar = undefined + , svarRef = Nothing + , svarInspectMode = getInspectMode st + , svarCreator = tid + , aheadWorkQueue = undefined + , outputHeap = undefined + , svarStats = stats + } + + let sv = + case getStreamRate st of + Nothing -> + case getYieldLimit st of + Nothing -> getSVar sv readOutputQBounded + postProcessBounded + isWorkFinished + workLoopFIFO + Just _ -> getSVar sv readOutputQBounded + postProcessBounded + isWorkFinishedLimited + workLoopFIFOLimited + Just _ -> + case getYieldLimit st of + Nothing -> getSVar sv readOutputQPaced + postProcessPaced + isWorkFinished + workLoopFIFO + Just _ -> getSVar sv readOutputQPaced + postProcessPaced + isWorkFinishedLimited + workLoopFIFOLimited + in return sv + +{-# INLINABLE newAsyncVar #-} +newAsyncVar :: MonadAsync m + => State Stream m a -> Stream m a -> m (SVar Stream m a) +newAsyncVar st m = do + mrun <- captureMonadState + sv <- liftIO $ getLifoSVar st mrun + sendFirstWorker sv m + +-- | Generate a stream asynchronously to keep it buffered, lazily consume +-- from the buffer. +-- +-- /Internal/ +-- +{-# INLINABLE mkAsyncK #-} +mkAsyncK :: (IsStream t, MonadAsync m) => t m a -> t m a +mkAsyncK m = mkStream $ \st yld sng stp -> do + sv <- newAsyncVar (adaptState st) (toStream m) + foldStream st yld sng stp $ fromSVar sv + +{-# INLINE_NORMAL mkAsyncD #-} +mkAsyncD :: MonadAsync m => D.Stream m a -> D.Stream m a +mkAsyncD m = D.Stream step Nothing + where + + step gst Nothing = do + sv <- newAsyncVar gst (D.fromStreamD m) + return $ D.Skip $ Just $ D.fromSVar sv + + step gst (Just (D.UnStream step1 st)) = do + r <- step1 gst st + return $ case r of + D.Yield a s -> D.Yield a (Just $ D.Stream step1 s) + D.Skip s -> D.Skip (Just $ D.Stream step1 s) + D.Stop -> D.Stop + +-- This is slightly faster than the CPS version above +-- +-- | Make the stream producer and consumer run concurrently by introducing a +-- buffer between them. The producer thread evaluates the input stream until +-- the buffer fills, it terminates if the buffer is full and a worker thread is +-- kicked off again to evaluate the remaining stream when there is space in the +-- buffer. The consumer consumes the stream lazily from the buffer. +-- +-- /Internal/ +-- +{-# INLINE_NORMAL mkAsync #-} +mkAsync :: (K.IsStream t, MonadAsync m) => t m a -> t m a +mkAsync = D.fromStreamD . mkAsyncD . D.toStreamD + +-- | Create a new SVar and enqueue one stream computation on it. +{-# INLINABLE newWAsyncVar #-} +newWAsyncVar :: MonadAsync m + => State Stream m a -> Stream m a -> m (SVar Stream m a) +newWAsyncVar st m = do + mrun <- captureMonadState + sv <- liftIO $ getFifoSVar st mrun + sendFirstWorker sv m + +------------------------------------------------------------------------------ +-- Running streams concurrently +------------------------------------------------------------------------------ + +-- Concurrency rate control. +-- +-- Our objective is to create more threads on demand if the consumer is running +-- faster than us. As soon as we encounter a concurrent composition we create a +-- push pull pair of threads. We use an SVar for communication between the +-- consumer, pulling from the SVar and the producer who is pushing to the SVar. +-- The producer creates more threads if the SVar drains and becomes empty, that +-- is the consumer is running faster. +-- +-- XXX Note 1: This mechanism can be problematic if the initial production +-- latency is high, we may end up creating too many threads. So we need some +-- way to monitor and use the latency as well. Having a limit on the dispatches +-- (programmer controlled) may also help. +-- +-- TBD Note 2: We may want to run computations at the lower level of the +-- composition tree serially even when they are composed using a parallel +-- combinator. We can use 'serial' in place of 'async' and 'wSerial' in +-- place of 'wAsync'. If we find that an SVar immediately above a computation +-- gets drained empty we can switch to parallelizing the computation. For that +-- we can use a state flag to fork the rest of the computation at any point of +-- time inside the Monad bind operation if the consumer is running at a faster +-- speed. +-- +-- TBD Note 3: the binary operation ('parallel') composition allows us to +-- dispatch a chunkSize of only 1. If we have to dispatch in arbitrary +-- chunksizes we will need to compose the parallel actions using a data +-- constructor (A Free container) instead so that we can divide it in chunks of +-- arbitrary size before dispatching. If the stream is composed of +-- hierarchically composed grains of different sizes then we can always switch +-- to a desired granularity depending on the consumer speed. +-- +-- TBD Note 4: for pure work (when we are not in the IO monad) we can divide it +-- into just the number of CPUs. + +-- | Join two computations on the currently running 'SVar' queue for concurrent +-- execution. When we are using parallel composition, an SVar is passed around +-- as a state variable. We try to schedule a new parallel computation on the +-- SVar passed to us. The first time, when no SVar exists, a new SVar is +-- created. Subsequently, 'joinStreamVarAsync' may get called when a computation +-- already scheduled on the SVar is further evaluated. For example, when (a +-- `parallel` b) is evaluated it calls a 'joinStreamVarAsync' to put 'a' and 'b' on +-- the current scheduler queue. +-- +-- The 'SVarStyle' required by the current composition context is passed as one +-- of the parameters. If the scheduling and composition style of the new +-- computation being scheduled is different than the style of the current SVar, +-- then we create a new SVar and schedule it on that. The newly created SVar +-- joins as one of the computations on the current SVar queue. +-- +-- Cases when we need to switch to a new SVar: +-- +-- * (x `parallel` y) `parallel` (t `parallel` u) -- all of them get scheduled on the same SVar +-- * (x `parallel` y) `parallel` (t `async` u) -- @t@ and @u@ get scheduled on a new child SVar +-- because of the scheduling policy change. +-- * if we 'adapt' a stream of type 'async' to a stream of type +-- 'Parallel', we create a new SVar at the transitioning bind. +-- * When the stream is switching from disjunctive composition to conjunctive +-- composition and vice-versa we create a new SVar to isolate the scheduling +-- of the two. + +forkSVarAsync :: (IsStream t, MonadAsync m) + => SVarStyle -> t m a -> t m a -> t m a +forkSVarAsync style m1 m2 = mkStream $ \st yld sng stp -> do + sv <- case style of + AsyncVar -> newAsyncVar st (concurrently (toStream m1) (toStream m2)) + WAsyncVar -> newWAsyncVar st (concurrently (toStream m1) (toStream m2)) + _ -> error "illegal svar type" + foldStream st yld sng stp $ fromSVar sv + where + concurrently ma mb = mkStream $ \st yld sng stp -> do + liftIO $ enqueue (fromJust $ streamVar st) mb + foldStreamShared st yld sng stp ma + +{-# INLINE joinStreamVarAsync #-} +joinStreamVarAsync :: (IsStream t, MonadAsync m) + => SVarStyle -> t m a -> t m a -> t m a +joinStreamVarAsync style m1 m2 = mkStream $ \st yld sng stp -> + case streamVar st of + Just sv | svarStyle sv == style -> do + liftIO $ enqueue sv (toStream m2) + foldStreamShared st yld sng stp m1 + _ -> foldStreamShared st yld sng stp (forkSVarAsync style m1 m2) + +------------------------------------------------------------------------------ +-- Semigroup and Monoid style compositions for parallel actions +------------------------------------------------------------------------------ + +-- | Polymorphic version of the 'Semigroup' operation '<>' of 'AsyncT'. +-- Merges two streams possibly concurrently, preferring the +-- elements from the left one when available. +-- +-- @since 0.2.0 +{-# INLINE async #-} +async :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a +async = joinStreamVarAsync AsyncVar + +-- | Same as 'async'. +-- +-- @since 0.1.0 +{-# DEPRECATED (<|) "Please use 'async' instead." #-} +{-# INLINE (<|) #-} +(<|) :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a +(<|) = async + +-- 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 #-} +{-# 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 +------------------------------------------------------------------------------ + +-- | The 'Semigroup' operation (@<>@) for 'AsyncT' merges two streams +-- concurrently with priority given to the first stream. In @s1 <> s2 <> s3 +-- ...@ the streams s1, s2 and s3 are scheduled for execution in that order. +-- Multiple scheduled streams may be executed concurrently and the elements +-- generated by them are served to the consumer as and when they become +-- available. This behavior is similar to the scheduling and execution behavior +-- of actions in a single async stream. +-- +-- Since only a finite number of streams are executed concurrently, this +-- operation can be used to fold an infinite lazy container of streams. +-- +-- @ +-- import "Streamly" +-- import qualified "Streamly.Prelude" as S +-- import Control.Concurrent +-- +-- main = (S.toList . 'asyncly' $ (S.fromList [1,2]) \<> (S.fromList [3,4])) >>= print +-- @ +-- @ +-- [1,2,3,4] +-- @ +-- +-- Any exceptions generated by a constituent stream are propagated to the +-- output stream. The output and exceptions from a single stream are guaranteed +-- to arrive in the same order in the resulting stream as they were generated +-- in the input stream. However, the relative ordering of elements from +-- different streams in the resulting stream can vary depending on scheduling +-- and generation delays. +-- +-- Similarly, the monad instance of 'AsyncT' /may/ run each iteration +-- concurrently based on demand. More concurrent iterations are started only +-- if the previous iterations are not able to produce enough output for the +-- consumer. +-- +-- @ +-- main = 'drain' . 'asyncly' $ do +-- n <- return 3 \<\> return 2 \<\> return 1 +-- S.yieldM $ do +-- threadDelay (n * 1000000) +-- myThreadId >>= \\tid -> putStrLn (show tid ++ ": Delay " ++ show n) +-- @ +-- @ +-- ThreadId 40: Delay 1 +-- ThreadId 39: Delay 2 +-- ThreadId 38: Delay 3 +-- @ +-- +-- @since 0.1.0 +newtype AsyncT m a = AsyncT {getAsyncT :: Stream m a} + deriving (MonadTrans) + +-- | A demand driven left biased parallely composing IO stream of elements of +-- type @a@. See 'AsyncT' documentation for more details. +-- +-- @since 0.2.0 +type Async = AsyncT IO + +-- | Fix the type of a polymorphic stream as 'AsyncT'. +-- +-- @since 0.1.0 +asyncly :: IsStream t => AsyncT m a -> t m a +asyncly = adapt + +instance IsStream AsyncT where + toStream = getAsyncT + fromStream = AsyncT + 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 + (<>) = mappendAsync + +------------------------------------------------------------------------------ +-- Monoid +------------------------------------------------------------------------------ + +instance MonadAsync m => Monoid (AsyncT m a) where + mempty = K.nil + mappend = (<>) + +------------------------------------------------------------------------------ +-- Applicative +------------------------------------------------------------------------------ + +{-# 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 (AsyncT m1) (AsyncT m2) = + let f x1 = K.concatMapBy async (pure . x1) m2 + in AsyncT $ K.concatMapBy async f m1 + +instance (Monad m, MonadAsync m) => Applicative (AsyncT m) where + {-# INLINE pure #-} + pure = AsyncT . K.yield + {-# INLINE (<*>) #-} + (<*>) = apAsync + +------------------------------------------------------------------------------ +-- Monad +------------------------------------------------------------------------------ + +-- GHC: if we change the implementation of bindWith with arguments in a +-- different order we see a significant performance degradation (~2x). +{-# 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) + +-- GHC: if we specify arguments in the definition of (>>=) we see a significant +-- performance degradation (~2x). +instance MonadAsync m => Monad (AsyncT m) where + return = pure + (>>=) = bindAsync + +------------------------------------------------------------------------------ +-- Other instances +------------------------------------------------------------------------------ + +MONAD_COMMON_INSTANCES(AsyncT, MONADPARALLEL) + +------------------------------------------------------------------------------ +-- WAsyncT +------------------------------------------------------------------------------ + +-- | XXX we can implement it more efficienty by directly implementing instead +-- of combining streams using wAsync. +{-# INLINE consMWAsync #-} +{-# 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. +-- +-- @since 0.2.0 +{-# INLINE wAsync #-} +wAsync :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a +wAsync = joinStreamVarAsync WAsyncVar + +-- | 'WAsyncT' is similar to 'WSerialT' but with concurrent execution. +-- The 'Semigroup' operation (@<>@) for 'WAsyncT' merges two streams +-- concurrently interleaving the actions from both the streams. In @s1 +-- <> s2 <> s3 ...@, the individual actions from streams @s1@, @s2@ and @s3@ +-- are scheduled for execution in a round-robin fashion. Multiple scheduled +-- actions may be executed concurrently, the results from concurrent executions +-- are consumed in the order in which they become available. +-- +-- +-- The @W@ in the name stands for @wide@ or breadth wise scheduling in +-- contrast to the depth wise scheduling behavior of 'AsyncT'. +-- +-- @ +-- import "Streamly" +-- import qualified "Streamly.Prelude" as S +-- import Control.Concurrent +-- +-- main = (S.toList . 'wAsyncly' . maxThreads 1 $ (S.fromList [1,2]) \<> (S.fromList [3,4])) >>= print +-- @ +-- @ +-- [1,3,2,4] +-- @ +-- +-- For this example, we are using @maxThreads 1@ so that concurrent thread +-- scheduling does not affect the results and make them unpredictable. Let's +-- now take a more general example: +-- +-- @ +-- main = (S.toList . 'wAsyncly' . maxThreads 1 $ (S.fromList [1,2,3]) \<> (S.fromList [4,5,6]) \<> (S.fromList [7,8,9])) >>= print +-- @ +-- @ +-- [1,4,2,7,5,3,8,6,9] +-- @ +-- +-- This is how the execution of the above stream proceeds: +-- +-- 1. The scheduler queue is initialized with @[S.fromList [1,2,3], +-- (S.fromList [4,5,6]) \<> (S.fromList [7,8,9])]@ assuming the head of the +-- queue is represented by the rightmost item. +-- 2. @S.fromList [1,2,3]@ is executed, yielding the element @1@ and putting +-- @[2,3]@ at the back of the scheduler queue. The scheduler queue now looks +-- like @[(S.fromList [4,5,6]) \<> (S.fromList [7,8,9]), S.fromList [2,3]]@. +-- 3. Now @(S.fromList [4,5,6]) \<> (S.fromList [7,8,9])@ is picked up for +-- execution, @S.fromList [7,8,9]@ is added at the back of the queue and +-- @S.fromList [4,5,6]@ is executed, yielding the element @4@ and adding +-- @S.fromList [5,6]@ at the back of the queue. The queue now looks like +-- @[S.fromList [2,3], S.fromList [7,8,9], S.fromList [5,6]]@. +-- 4. Note that the scheduler queue expands by one more stream component in +-- every pass because one more @<>@ is broken down into two components. At this +-- point there are no more @<>@ operations to be broken down further and the +-- queue has reached its maximum size. Now these streams are scheduled in +-- round-robin fashion yielding @[2,7,5,3,8,8,9]@. +-- +-- As we see above, in a right associated expression composed with @<>@, only +-- one @<>@ operation is broken down into two components in one execution, +-- therefore, if we have @n@ streams composed using @<>@ it will take @n@ +-- scheduler passes to expand the whole expression. By the time @n-th@ +-- component is added to the scheduler queue, the first component would have +-- received @n@ scheduler passes. +-- +-- Since all streams get interleaved, this operation is not suitable for +-- folding an infinite lazy container of infinite size streams. However, if +-- the streams are small, the streams on the left may get finished before more +-- streams are added to the scheduler queue from the right side of the +-- expression, so it may be possible to fold an infinite lazy container of +-- streams. For example, if the streams are of size @n@ then at most @n@ +-- streams would be in the scheduler queue at a time. +-- +-- Note that 'WSerialT' and 'WAsyncT' differ in their scheduling behavior, +-- therefore the output of 'WAsyncT' even with a single thread of execution is +-- not the same as that of 'WSerialT' See notes in 'WSerialT' for details about +-- its scheduling behavior. +-- +-- Any exceptions generated by a constituent stream are propagated to the +-- output stream. The output and exceptions from a single stream are guaranteed +-- to arrive in the same order in the resulting stream as they were generated +-- in the input stream. However, the relative ordering of elements from +-- different streams in the resulting stream can vary depending on scheduling +-- and generation delays. +-- +-- Similarly, the 'Monad' instance of 'WAsyncT' runs /all/ iterations fairly +-- concurrently using a round robin scheduling. +-- +-- @ +-- main = 'drain' . 'wAsyncly' $ do +-- n <- return 3 \<\> return 2 \<\> return 1 +-- S.yieldM $ do +-- threadDelay (n * 1000000) +-- myThreadId >>= \\tid -> putStrLn (show tid ++ ": Delay " ++ show n) +-- @ +-- @ +-- ThreadId 40: Delay 1 +-- ThreadId 39: Delay 2 +-- ThreadId 38: Delay 3 +-- @ +-- +-- @since 0.2.0 +newtype WAsyncT m a = WAsyncT {getWAsyncT :: Stream m a} + deriving (MonadTrans) + +-- | A round robin parallely composing IO stream of elements of type @a@. +-- See 'WAsyncT' documentation for more details. +-- +-- @since 0.2.0 +type WAsync = WAsyncT IO + +-- | Fix the type of a polymorphic stream as 'WAsyncT'. +-- +-- @since 0.2.0 +wAsyncly :: IsStream t => WAsyncT m a -> t m a +wAsyncly = adapt + +instance IsStream WAsyncT where + toStream = getWAsyncT + fromStream = WAsyncT + 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 + (<>) = mappendWAsync + +------------------------------------------------------------------------------ +-- Monoid +------------------------------------------------------------------------------ + +instance MonadAsync m => Monoid (WAsyncT m a) where + mempty = K.nil + mappend = (<>) + +------------------------------------------------------------------------------ +-- Applicative +------------------------------------------------------------------------------ + +{-# 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 (WAsyncT m1) (WAsyncT m2) = + let f x1 = K.concatMapBy wAsync (pure . x1) m2 + in WAsyncT $ K.concatMapBy wAsync f m1 + +-- GHC: if we specify arguments in the definition of (<*>) we see a significant +-- performance degradation (~2x). +instance (Monad m, MonadAsync m) => Applicative (WAsyncT m) where + pure = WAsyncT . K.yield + (<*>) = apWAsync + +------------------------------------------------------------------------------ +-- Monad +------------------------------------------------------------------------------ + +-- GHC: if we change the implementation of bindWith with arguments in a +-- different order we see a significant performance degradation (~2x). +{-# 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) + +-- GHC: if we specify arguments in the definition of (>>=) we see a significant +-- performance degradation (~2x). +instance MonadAsync m => Monad (WAsyncT m) where + return = pure + (>>=) = bindWAsync + +------------------------------------------------------------------------------ +-- Other instances +------------------------------------------------------------------------------ + +MONAD_COMMON_INSTANCES(WAsyncT, MONADPARALLEL) diff --git a/src/Streamly/Internal/Data/Stream/Combinators.hs b/src/Streamly/Internal/Data/Stream/Combinators.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/Combinators.hs @@ -0,0 +1,217 @@ +{-# LANGUAGE CPP #-} + +#include "inline.hs" + +-- | +-- Module : Streamly.Internal.Data.Stream.Combinators +-- Copyright : (c) 2017 Harendra Kumar +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- +module Streamly.Internal.Data.Stream.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.Internal.Data.SVar +import Streamly.Internal.Data.Stream.StreamK +import Streamly.Internal.Data.Stream.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. 'maxThreads' does not affect +-- 'ParallelT' streams as they can use unbounded number of threads. +-- +-- 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/Internal/Data/Stream/Enumeration.hs b/src/Streamly/Internal/Data/Stream/Enumeration.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/Enumeration.hs @@ -0,0 +1,550 @@ +{-# LANGUAGE CPP #-} + +-- | +-- Module : Streamly.Internal.Data.Stream.Enumeration +-- Copyright : (c) 2018 Harendra Kumar +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.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.Internal.Data.Stream.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.Internal.Data.Stream.StreamD (fromStreamD) +import Streamly.Internal.Data.Stream.StreamK (IsStream(..)) + +import qualified Streamly.Internal.Data.Stream.StreamD as D +import qualified Streamly.Internal.Data.Stream.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.Internal.Data.Stream.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/Data/Stream/Instances.hs b/src/Streamly/Internal/Data/Stream/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/Instances.hs @@ -0,0 +1,168 @@ +------------------------------------------------------------------------------ +-- CPP macros for common instances +------------------------------------------------------------------------------ + +-- XXX use template haskell instead and include Monoid and IsStream instances +-- as well. + +#define MONADPARALLEL , MonadAsync m + +#define MONAD_COMMON_INSTANCES(STREAM,CONSTRAINT) \ +instance Monad m => Functor (STREAM m) where { \ + {-# INLINE fmap #-}; \ + fmap f (STREAM m) = D.fromStreamD $ D.mapM (return . f) $ D.toStreamD m }; \ + \ +instance (MonadBase b m, Monad m CONSTRAINT) => MonadBase b (STREAM m) where {\ + liftBase = liftBaseDefault }; \ + \ +instance (MonadIO m CONSTRAINT) => MonadIO (STREAM m) where { \ + liftIO = lift . liftIO }; \ + \ +instance (MonadThrow m CONSTRAINT) => MonadThrow (STREAM m) where { \ + throwM = lift . throwM }; \ + \ +{- \ +instance (MonadError e m CONSTRAINT) => MonadError e (STREAM m) where { \ + throwError = lift . throwError; \ + catchError m h = \ + fromStream $ withCatchError (toStream m) (\e -> toStream $ h e) }; \ +-} \ + \ +instance (MonadReader r m CONSTRAINT) => MonadReader r (STREAM m) where { \ + ask = lift ask; \ + local f m = fromStream $ K.withLocal f (toStream m) }; \ + \ +instance (MonadState s m CONSTRAINT) => MonadState s (STREAM m) where { \ + get = lift get; \ + put x = lift (put x); \ + state k = lift (state k) } + +------------------------------------------------------------------------------ +-- 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? + +#if MIN_VERSION_deepseq(1,4,3) +#define NFDATA1_INSTANCE(STREAM) \ +instance NFData1 (STREAM Identity) where { \ + {-# INLINE liftRnf #-}; \ + liftRnf r = runIdentity . P.foldl' (\_ x -> r x) () } +#else +#define NFDATA1_INSTANCE(STREAM) +#endif + +#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 { \ + {-# INLINE rnf #-}; \ + rnf = runIdentity . P.foldl' (\_ x -> rnf x) () }; \ + +------------------------------------------------------------------------------- +-- Foldable +------------------------------------------------------------------------------- + +-- The default Foldable instance has several issues: +-- 1) several definitions do not have INLINE on them, so we provide +-- re-implementations with INLINE pragmas. +-- 2) the definitions of sum/product/maximum/minimum are inefficient as they +-- use right folds, they cannot run in constant memory. We provide +-- implementations using strict left folds here. + +#define FOLDABLE_INSTANCE(STREAM) \ +instance (Foldable m, Monad m) => Foldable (STREAM m) where { \ + \ + {-# INLINE foldMap #-}; \ + foldMap f = fold . P.foldr (mappend . f) mempty; \ + \ + {-# INLINE foldr #-}; \ + foldr f z t = appEndo (foldMap (Endo #. f) t) z; \ + \ + {-# INLINE foldl' #-}; \ + foldl' f z0 xs = foldr f' id xs z0 \ + where { f' x k z = k $! f z x}; \ + \ + {-# INLINE length #-}; \ + length = foldl' (\n _ -> n + 1) 0; \ + \ + {-# INLINE elem #-}; \ + elem = any . (==); \ + \ + {-# INLINE maximum #-}; \ + maximum = \ + fromMaybe (errorWithoutStackTrace $ "maximum: empty stream") \ + . toMaybe \ + . foldl' getMax Nothing' where { \ + getMax Nothing' x = Just' x; \ + getMax (Just' mx) x = Just' $! max mx x }; \ + \ + {-# INLINE minimum #-}; \ + minimum = \ + fromMaybe (errorWithoutStackTrace $ "minimum: empty stream") \ + . toMaybe \ + . foldl' getMin Nothing' where { \ + getMin Nothing' x = Just' x; \ + getMin (Just' mn) x = Just' $! min mn x }; \ + \ + {-# INLINE sum #-}; \ + sum = foldl' (+) 0; \ + \ + {-# INLINE product #-}; \ + product = foldl' (*) 1 } + +------------------------------------------------------------------------------- +-- 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/Internal/Data/Stream/Parallel.hs b/src/Streamly/Internal/Data/Stream/Parallel.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/Parallel.hs @@ -0,0 +1,543 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving#-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} -- XXX + +#include "inline.hs" + +-- | +-- Module : Streamly.Internal.Data.Stream.Parallel +-- Copyright : (c) 2017 Harendra Kumar +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- +module Streamly.Internal.Data.Stream.Parallel + ( + -- * Parallel Stream Type + ParallelT + , Parallel + , parallely + + -- * Merge Concurrently + , parallel + , parallelFst + , parallelMin + + -- * Evaluate Concurrently + , mkParallel + + -- * Tap Concurrently + , tapAsync + , distributeAsync_ + ) +where + +import Control.Concurrent (myThreadId, takeMVar) +import Control.Monad (when) +import Control.Monad.Base (MonadBase(..), liftBaseDefault) +import Control.Monad.Catch (MonadThrow, throwM) +-- import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Reader.Class (MonadReader(..)) +import Control.Monad.State.Class (MonadState(..)) +import Control.Monad.Trans.Class (MonadTrans(lift)) +import Data.Functor (void) +import Data.IORef (readIORef, writeIORef) +import Data.Maybe (fromJust) +#if __GLASGOW_HASKELL__ < 808 +import Data.Semigroup (Semigroup(..)) +#endif +import Prelude hiding (map) + +import qualified Data.Set as Set + +import Streamly.Internal.Data.Stream.SVar + (fromSVar, fromProducer, fromConsumer, pushToFold) +import Streamly.Internal.Data.Stream.StreamK + (IsStream(..), Stream, mkStream, foldStream, foldStreamShared, adapt) + +import Streamly.Internal.Data.SVar + +import qualified Streamly.Internal.Data.Stream.StreamK as K +import qualified Streamly.Internal.Data.Stream.StreamD as D + +#include "Instances.hs" + +------------------------------------------------------------------------------- +-- Parallel +------------------------------------------------------------------------------- + +------------------------------------------------------------------------------- +-- StreamK based worker routines +------------------------------------------------------------------------------- + +{-# NOINLINE runOne #-} +runOne + :: MonadIO m + => State Stream m a -> Stream m a -> Maybe WorkerInfo -> m () +runOne st m0 winfo = + case getYieldLimit st of + Nothing -> go m0 + Just _ -> runOneLimited st m0 winfo + + where + + go m = do + liftIO $ decrementBufferLimit sv + foldStreamShared st yieldk single stop m + + sv = fromJust $ streamVar st + + stop = liftIO $ do + incrementBufferLimit sv + sendStop sv winfo + sendit a = liftIO $ void $ send sv (ChildYield a) + single a = sendit a >> (liftIO $ sendStop sv winfo) + yieldk a r = sendit a >> go r + +runOneLimited + :: MonadIO m + => State Stream m a -> Stream m a -> Maybe WorkerInfo -> m () +runOneLimited st m0 winfo = go m0 + + where + + go m = do + yieldLimitOk <- liftIO $ decrementYieldLimit sv + if yieldLimitOk + then do + liftIO $ decrementBufferLimit sv + foldStreamShared st yieldk single stop m + else do + liftIO $ cleanupSVarFromWorker sv + liftIO $ sendStop sv winfo + + sv = fromJust $ streamVar st + + stop = liftIO $ do + incrementBufferLimit sv + incrementYieldLimit sv + sendStop sv winfo + sendit a = liftIO $ void $ send sv (ChildYield a) + single a = sendit a >> (liftIO $ sendStop sv winfo) + yieldk a r = sendit a >> go r + +------------------------------------------------------------------------------- +-- Consing and appending a stream in parallel style +------------------------------------------------------------------------------- + +-- Note that consing and appending requires StreamK as it would not scale well +-- with StreamD unless we are only consing a very small number of streams or +-- elements in a stream. StreamK allows us to manipulate control flow in a way +-- which StreamD cannot allow. StreamK can make a jump without having to +-- remember the past state. + +{-# NOINLINE forkSVarPar #-} +forkSVarPar :: (IsStream t, MonadAsync m) + => SVarStopStyle -> t m a -> t m a -> t m a +forkSVarPar ss m r = mkStream $ \st yld sng stp -> do + sv <- newParallelVar ss st + pushWorkerPar sv (runOne st{streamVar = Just sv} $ toStream m) + case ss of + StopBy -> liftIO $ do + set <- readIORef (workerThreads sv) + writeIORef (svarStopBy sv) $ Set.elemAt 0 set + _ -> return () + pushWorkerPar sv (runOne st{streamVar = Just sv} $ toStream r) + foldStream st yld sng stp (fromSVar sv) + +{-# INLINE joinStreamVarPar #-} +joinStreamVarPar :: (IsStream t, MonadAsync m) + => SVarStyle -> SVarStopStyle -> t m a -> t m a -> t m a +joinStreamVarPar style ss m1 m2 = mkStream $ \st yld sng stp -> + case streamVar st of + Just sv | svarStyle sv == style && svarStopStyle sv == ss -> do + -- Here, WE ARE IN THE WORKER/PRODUCER THREAD, we know that because + -- the SVar exists. We are running under runOne and the output we + -- produce ultimately will be sent to the SVar by runOne. + -- + -- If we came here the worker/runOne is evaluating a `parallel` + -- combinator. In this case, we always fork a new worker for the + -- first component (m1) in the parallel composition and continue to + -- evaluate the second component (m2) in the current worker thread. + -- + -- When m1 is serially composed, the worker would evaluate it + -- without any further forks and the resulting output is sent to + -- the SVar and the evaluation terminates. If m1 is a `parallel` + -- composition of two streams the worker would again recurses here. + -- + -- Similarly, when m2 is serially composed it gets evaluated here + -- and the resulting output is sent to the SVar by the runOne + -- wrapper. When m2 is composed with `parallel` it will again + -- recurse here and so on until it finally terminates. + -- + -- When we create a right associated expression using `parallel`, + -- then m1 would always terminate without further forks or + -- recursion into this routine, therefore, the worker returns + -- immediately after evaluating it. And m2 would continue to + -- fork/recurse, therefore, the current thread always recurses and + -- forks new workers one after the other. This is a tail recursive + -- style execution, m2, the recursive expression always executed at + -- the tail. + -- + -- When the expression is left associated, the worker spawned would + -- get the forking/recursing responsibility and then again the + -- worker spawned by that worker would fork, thus creating layer + -- over layer of workers and a chain of threads leading to a very + -- inefficient execution. + pushWorkerPar sv (runOne st $ toStream m1) + foldStreamShared st yld sng stp m2 + _ -> + -- Here WE ARE IN THE CONSUMER THREAD, we create a new SVar, fork + -- worker threads to execute m1 and m2 and this thread starts + -- pulling the stream from the SVar. + foldStreamShared st yld sng stp (forkSVarPar ss m1 m2) + +------------------------------------------------------------------------------- +-- User facing APIs +------------------------------------------------------------------------------- + +-- | XXX we can implement it more efficienty by directly implementing instead +-- of combining streams using parallel. +{-# INLINE consMParallel #-} +{-# 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. +-- +-- @since 0.2.0 +{-# INLINE parallel #-} +parallel :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a +parallel = joinStreamVarPar ParallelVar StopNone + +-- This is a co-parallel like combinator for streams, where first stream is the +-- main stream and the rest are just supporting it, when the first ends +-- everything ends. +-- +-- | Like `parallel` but stops the output as soon as the first stream stops. +-- +-- @since 0.7.0 +{-# INLINE parallelFst #-} +parallelFst :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a +parallelFst = joinStreamVarPar ParallelVar StopBy + +-- This is a race like combinator for streams. +-- +-- | Like `parallel` but stops the output as soon as any of the two streams +-- stops. +-- +-- @since 0.7.0 +{-# INLINE parallelMin #-} +parallelMin :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a +parallelMin = joinStreamVarPar ParallelVar StopAny + +------------------------------------------------------------------------------ +-- Convert a stream to parallel +------------------------------------------------------------------------------ + +-- | Generate a stream asynchronously to keep it buffered, lazily consume +-- from the buffer. +-- +-- /Internal/ +-- +mkParallel :: (IsStream t, MonadAsync m) => t m a -> t m a +mkParallel m = mkStream $ \st yld sng stp -> do + sv <- newParallelVar StopNone (adaptState st) + -- pushWorkerPar sv (runOne st{streamVar = Just sv} $ toStream m) + D.toSVarParallel st sv $ D.toStreamD m + foldStream st yld sng stp $ fromSVar sv + +------------------------------------------------------------------------------ +-- Clone and distribute a stream in parallel +------------------------------------------------------------------------------ + +-- Tap a stream and send the elements to the specified SVar in addition to +-- yielding them again. +-- +-- XXX this could be written in StreamD style for better efficiency with fusion. +-- +{-# INLINE teeToSVar #-} +teeToSVar :: (IsStream t, MonadAsync m) => SVar Stream m a -> t m a -> t m a +teeToSVar svr m = mkStream $ \st yld sng stp -> do + foldStreamShared st yld sng stp (go False m) + + where + + go False m0 = mkStream $ \st yld _ stp -> do + let drain = do + -- In general, a Stop event would come equipped with the result + -- of the fold. It is not used here but it would be useful in + -- applicative and distribute. + done <- fromConsumer svr + when (not done) $ do + liftIO $ withDiagMVar svr "teeToSVar: waiting to drain" + $ takeMVar (outputDoorBellFromConsumer svr) + drain + + stopFold = do + liftIO $ sendStop svr Nothing + -- drain/wait until a stop event arrives from the fold. + drain + + stop = stopFold >> stp + single a = do + done <- pushToFold svr a + yld a (go done (K.nilM stopFold)) + yieldk a r = pushToFold svr a >>= \done -> yld a (go done r) + in foldStreamShared st yieldk single stop m0 + + go True m0 = m0 + +-- In case of folds the roles of worker and parent on an SVar are reversed. The +-- parent stream pushes values to an SVar instead of pulling from it and a +-- worker thread running the fold pulls from the SVar and folds the stream. We +-- keep a separate channel for pushing exceptions in the reverse direction i.e. +-- from the fold to the parent stream. +-- +-- Note: If we terminate due to an exception, we do not actively terminate the +-- fold. It gets cleaned up by the GC. + +-- | Create an SVar with a fold consumer that will fold any elements sent to it +-- using the supplied fold function. +{-# INLINE newFoldSVar #-} +newFoldSVar :: (IsStream t, MonadAsync m) + => State Stream m a -> (t m a -> m b) -> m (SVar Stream m a) +newFoldSVar stt f = do + -- Buffer size for the SVar is derived from the current state + sv <- newParallelVar StopAny (adaptState stt) + + -- Add the producer thread-id to the SVar. + liftIO myThreadId >>= modifyThread sv + + void $ doFork (void $ f $ fromStream $ fromProducer sv) + (svarMrun sv) + (handleFoldException sv) + return sv + +-- NOTE: In regular pull style streams, the consumer stream is pulling elements +-- from the SVar and we have several workers producing elements and pushing to +-- SVar. In case of folds, we, the parent stream driving the fold, are the +-- stream producing worker, we start an SVar and start pushing to the SVar, the +-- fold on the other side of the SVar is the consumer stream. +-- +-- In the pull stream case exceptions are propagated from the producing workers +-- to the consumer stream, the exceptions are propagated on the same channel as +-- the produced stream elements. However, in case of push style folds the +-- current stream itself is the worker and the fold is the consumer, in this +-- case we have to propagate the exceptions from the consumer to the producer. +-- This is reverse of the pull case and we need a reverse direction channel +-- to propagate the exception. +-- +-- | Redirect a copy of the stream to a supplied fold and run it concurrently +-- in an independent thread. The fold may buffer some elements. The buffer size +-- is determined by the prevailing 'maxBuffer' setting. +-- +-- @ +-- Stream m a -> m b +-- | +-- -----stream m a ---------------stream m a----- +-- +-- @ +-- +-- @ +-- > S.drain $ S.tapAsync (S.mapM_ print) (S.enumerateFromTo 1 2) +-- 1 +-- 2 +-- @ +-- +-- Exceptions from the concurrently running fold are propagated to the current +-- computation. Note that, because of buffering in the fold, exceptions may be +-- delayed and may not correspond to the current element being processed in the +-- parent stream, but we guarantee that before the parent stream stops the tap +-- finishes and all exceptions from it are drained. +-- +-- +-- Compare with 'tap'. +-- +-- @since 0.7.0 +{-# INLINE tapAsync #-} +tapAsync :: (IsStream t, MonadAsync m) => (t m a -> m b) -> t m a -> t m a +tapAsync f m = mkStream $ \st yld sng stp -> do + sv <- newFoldSVar st f + foldStreamShared st yld sng stp (teeToSVar sv m) + +-- | Concurrently distribute a stream to a collection of fold functions, +-- discarding the outputs of the folds. +-- +-- >>> S.drain $ distributeAsync_ [S.mapM_ print, S.mapM_ print] (S.enumerateFromTo 1 2) +-- +-- @ +-- distributeAsync_ = flip (foldr tapAsync) +-- @ +-- +-- /Internal/ +-- +{-# INLINE distributeAsync_ #-} +distributeAsync_ :: (Foldable f, IsStream t, MonadAsync m) + => f (t m a -> m b) -> t m a -> t m a +distributeAsync_ = flip (foldr tapAsync) + +------------------------------------------------------------------------------ +-- ParallelT +------------------------------------------------------------------------------ + +-- | Async composition with strict concurrent execution of all streams. +-- +-- The 'Semigroup' instance of 'ParallelT' executes both the streams +-- concurrently without any delay or without waiting for the consumer demand +-- and /merges/ the results as they arrive. If the consumer does not consume +-- the results, they are buffered upto a configured maximum, controlled by the +-- 'maxBuffer' primitive. If the buffer becomes full the concurrent tasks will +-- block until there is space in the buffer. +-- +-- Both 'WAsyncT' and 'ParallelT', evaluate the constituent streams fairly in a +-- round robin fashion. The key difference is that 'WAsyncT' might wait for the +-- consumer demand before it executes the tasks whereas 'ParallelT' starts +-- executing all the tasks immediately without waiting for the consumer demand. +-- For 'WAsyncT' the 'maxThreads' limit applies whereas for 'ParallelT' it does +-- not apply. In other words, 'WAsyncT' can be lazy whereas 'ParallelT' is +-- strict. +-- +-- 'ParallelT' is useful for cases when the streams are required to be +-- evaluated simultaneously irrespective of how the consumer consumes them e.g. +-- when we want to race two tasks and want to start both strictly at the same +-- time or if we have timers in the parallel tasks and our results depend on +-- the timers being started at the same time. If we do not have such +-- requirements then 'AsyncT' or 'AheadT' are recommended as they can be more +-- efficient than 'ParallelT'. +-- +-- @ +-- main = ('toList' . 'parallely' $ (fromFoldable [1,2]) \<> (fromFoldable [3,4])) >>= print +-- @ +-- @ +-- [1,3,2,4] +-- @ +-- +-- When streams with more than one element are merged, it yields whichever +-- stream yields first without any bias, unlike the 'Async' style streams. +-- +-- Any exceptions generated by a constituent stream are propagated to the +-- output stream. The output and exceptions from a single stream are guaranteed +-- to arrive in the same order in the resulting stream as they were generated +-- in the input stream. However, the relative ordering of elements from +-- different streams in the resulting stream can vary depending on scheduling +-- and generation delays. +-- +-- Similarly, the 'Monad' instance of 'ParallelT' runs /all/ iterations +-- of the loop concurrently. +-- +-- @ +-- import "Streamly" +-- import qualified "Streamly.Prelude" as S +-- import Control.Concurrent +-- +-- main = 'drain' . 'parallely' $ do +-- n <- return 3 \<\> return 2 \<\> return 1 +-- S.yieldM $ do +-- threadDelay (n * 1000000) +-- myThreadId >>= \\tid -> putStrLn (show tid ++ ": Delay " ++ show n) +-- @ +-- @ +-- ThreadId 40: Delay 1 +-- ThreadId 39: Delay 2 +-- ThreadId 38: Delay 3 +-- @ +-- +-- Note that parallel composition can only combine a finite number of +-- streams as it needs to retain state for each unfinished stream. +-- +-- /Since: 0.7.0 (maxBuffer applies to ParallelT streams)/ +-- +-- /Since: 0.1.0/ +newtype ParallelT m a = ParallelT {getParallelT :: Stream m a} + deriving (MonadTrans) + +-- | A parallely composing IO stream of elements of type @a@. +-- See 'ParallelT' documentation for more details. +-- +-- @since 0.2.0 +type Parallel = ParallelT IO + +-- | Fix the type of a polymorphic stream as 'ParallelT'. +-- +-- @since 0.1.0 +parallely :: IsStream t => ParallelT m a -> t m a +parallely = adapt + +instance IsStream ParallelT where + toStream = getParallelT + fromStream = ParallelT + + {-# INLINE consM #-} + {-# SPECIALIZE consM :: IO a -> ParallelT IO a -> ParallelT IO a #-} + consM = consMParallel + + {-# INLINE (|:) #-} + {-# SPECIALIZE (|:) :: IO a -> ParallelT IO a -> ParallelT IO a #-} + (|:) = consM + +------------------------------------------------------------------------------ +-- 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 + (<>) = mappendParallel + +------------------------------------------------------------------------------ +-- Monoid +------------------------------------------------------------------------------ + +instance MonadAsync m => Monoid (ParallelT m a) where + mempty = K.nil + mappend = (<>) + +------------------------------------------------------------------------------ +-- Applicative +------------------------------------------------------------------------------ + +{-# INLINE apParallel #-} +{-# SPECIALIZE apParallel :: ParallelT IO (a -> b) -> ParallelT IO a -> ParallelT IO b #-} +apParallel :: MonadAsync m => ParallelT m (a -> b) -> ParallelT m a -> ParallelT m b +apParallel (ParallelT m1) (ParallelT m2) = + let f x1 = K.concatMapBy parallel (pure . x1) m2 + in ParallelT $ K.concatMapBy parallel f m1 + +instance (Monad m, MonadAsync m) => Applicative (ParallelT m) where + {-# INLINE pure #-} + pure = ParallelT . K.yield + {-# INLINE (<*>) #-} + (<*>) = apParallel + +------------------------------------------------------------------------------ +-- 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 + (>>=) = bindParallel + +------------------------------------------------------------------------------ +-- Other instances +------------------------------------------------------------------------------ + +MONAD_COMMON_INSTANCES(ParallelT, MONADPARALLEL) diff --git a/src/Streamly/Internal/Data/Stream/Prelude.hs b/src/Streamly/Internal/Data/Stream/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/Prelude.hs @@ -0,0 +1,339 @@ +{-# LANGUAGE CPP #-} + +#if __GLASGOW_HASKELL__ >= 800 +{-# OPTIONS_GHC -Wno-orphans #-} +#endif + +#include "inline.hs" + +-- | +-- Module : Streamly.Internal.Data.Stream.Prelude +-- Copyright : (c) 2017 Harendra Kumar +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- +module Streamly.Internal.Data.Stream.Prelude + ( + -- * Stream Conversion + fromStreamS + , toStreamS + + -- * Running Effects + , drain + + -- * Conversion operations + , fromList + , toList + + -- * Fold operations + , foldrM + , foldrMx + , foldr + + , foldlx' + , foldlMx' + , foldl' + , runFold + + -- Lazy left folds are useful only for reversing the stream + , foldlS + , foldlT + + , scanlx' + , scanlMx' + , postscanlx' + , postscanlMx' + + -- * Zip style operations + , eqBy + , cmpBy + + -- * Foldable instance + , minimum + , maximum + + -- * Nesting + , K.concatMapBy + , K.concatMap + + -- * Fold Utilities + , foldWith + , foldMapWith + , forEachWith + ) +where + +import Control.Monad.Trans (MonadTrans(..)) +import Prelude hiding (foldr, minimum, maximum) +import qualified Prelude + +import Streamly.Internal.Data.Fold.Types (Fold (..)) + +#ifdef USE_STREAMK_ONLY +import qualified Streamly.Internal.Data.Stream.StreamK as S +#else +import qualified Streamly.Internal.Data.Stream.StreamD as S +#endif + +import Streamly.Internal.Data.Stream.StreamK (IsStream(..)) +import qualified Streamly.Internal.Data.Stream.StreamK as K +import qualified Streamly.Internal.Data.Stream.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 drain #-} +drain :: (IsStream t, Monad m) => t m a -> m () +drain m = D.drain $ D.fromStreamK (toStream m) +{-# RULES "drain fallback to CPS" [1] + forall a. D.drain (D.fromStreamK a) = K.drain 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 -> m b -> m b) -> m b -> t m a -> m b +foldrM step acc m = S.foldrM step acc $ toStreamS m + +{-# INLINE foldrMx #-} +foldrMx :: (Monad m, IsStream t) + => (a -> m x -> m x) -> m x -> (m x -> m b) -> t m a -> m b +foldrMx step final project m = D.foldrMx step final project $ D.toStreamD m + +{-# INLINE foldr #-} +foldr :: (Monad m, IsStream t) => (a -> b -> b) -> b -> t m a -> m b +foldr f z = foldrM (\a b -> b >>= return . f a) (return z) + +-- | Like 'foldlx'', but with a monadic step function. +-- +-- @since 0.7.0 +{-# INLINE foldlMx' #-} +foldlMx' :: (IsStream t, Monad m) + => (x -> a -> m x) -> m x -> (x -> m b) -> t m a -> m b +foldlMx' step begin done m = S.foldlMx' step begin done $ toStreamS m + +-- | 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.7.0 +{-# INLINE foldlx' #-} +foldlx' :: (IsStream t, Monad m) + => (x -> a -> x) -> x -> (x -> b) -> t m a -> m b +foldlx' step begin done m = S.foldlx' step begin done $ toStreamS m + +-- | 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 + +{-# INLINE foldlS #-} +foldlS :: IsStream t => (t m b -> a -> t m b) -> t m b -> t m a -> t m b +foldlS = K.foldlS + +-- | Lazy left fold to a transformer monad. +-- +-- For example, to reverse a stream: +-- +-- > S.toList $ S.foldlT (flip S.cons) S.nil $ (S.fromList [1..5] :: SerialT IO Int) +-- +{-# INLINE foldlT #-} +foldlT :: (Monad m, IsStream t, Monad (s m), MonadTrans s) + => (s m b -> a -> s m b) -> s m b -> t m a -> s m b +foldlT f z s = S.foldlT f z (toStreamS s) + +{-# INLINE runFold #-} +runFold :: (Monad m, IsStream t) => Fold m a b -> t m a -> m b +runFold (Fold step begin done) = foldlMx' step begin done + +------------------------------------------------------------------------------ +-- Scans +------------------------------------------------------------------------------ + +-- postscanlM' followed by mapM +{-# INLINE postscanlMx' #-} +postscanlMx' :: (IsStream t, Monad m) + => (x -> a -> m x) -> m x -> (x -> m b) -> t m a -> t m b +postscanlMx' step begin done m = + D.fromStreamD $ D.postscanlMx' step begin done $ D.toStreamD m + +-- postscanl' followed by map +{-# INLINE postscanlx' #-} +postscanlx' :: (IsStream t, Monad m) + => (x -> a -> x) -> x -> (x -> b) -> t m a -> t m b +postscanlx' step begin done m = + D.fromStreamD $ D.postscanlx' step begin done $ D.toStreamD m + +-- scanlM' followed by mapM +-- +{-# INLINE scanlMx' #-} +scanlMx' :: (IsStream t, Monad m) + => (x -> a -> m x) -> m x -> (x -> m b) -> t m a -> t m b +scanlMx' step begin done m = + D.fromStreamD $ D.scanlMx' step begin done $ D.toStreamD m + +-- scanl followed by map +-- +-- | 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.7.0 +{-# INLINE scanlx' #-} +scanlx' :: (IsStream t, Monad m) + => (x -> a -> x) -> x -> (x -> b) -> t m a -> t m b +scanlx' step begin done m = + fromStreamS $ S.scanlx' step begin done $ 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) + +{-# INLINE minimum #-} +minimum :: (IsStream t, Monad m, Ord a) => t m a -> m (Maybe a) +minimum m = S.minimum (toStreamS m) + +{-# INLINE maximum #-} +maximum :: (IsStream t, Monad m, Ord a) => t m a -> m (Maybe a) +maximum m = S.maximum (toStreamS m) + +------------------------------------------------------------------------------ +-- Fold Utilities +------------------------------------------------------------------------------ + +{- +-- XXX do we have facilities in Foldable to fold any Foldable in this manner? +-- +-- | Perform a pair wise bottom up hierarchical fold of elements in the +-- container using the given function as the merge function. +-- +-- This will perform a balanced merge sort if the merge function is +-- 'mergeBy compare'. +-- +-- @since 0.7.0 +{-# INLINABLE foldbWith #-} +foldbWith :: IsStream t + => (t m a -> t m a -> t m a) -> SerialT Identity (t m a) -> t m a +foldbWith f = K.foldb f K.nil +-} + +-- /Since: 0.7.0 ("Streamly.Prelude")/ +-- +-- | A variant of 'Data.Foldable.fold' that allows you to fold a 'Foldable' +-- container of streams using the specified stream sum operation. +-- +-- @foldWith 'async' $ map return [1..3]@ +-- +-- Equivalent to: +-- +-- @ +-- foldWith f = S.foldMapWith f id +-- @ +-- +-- /Since: 0.1.0 ("Streamly")/ +{-# 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 = Prelude.foldr f K.nil + +-- /Since: 0.7.0 ("Streamly.Prelude")/ +-- +-- | 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 merge +-- operation. +-- +-- @foldMapWith 'async' return [1..3]@ +-- +-- Equivalent to: +-- +-- @ +-- foldMapWith f g xs = S.concatMapWith f g (S.fromFoldable xs) +-- @ +-- +-- /Since: 0.1.0 ("Streamly")/ +{-# 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 = Prelude.foldr (f . g) K.nil + +-- /Since: 0.7.0 ("Streamly.Prelude")/ +-- +-- | Like 'foldMapWith' but with the last two arguments reversed i.e. the +-- monadic streaming function is the last argument. +-- +-- Equivalent to: +-- +-- @ +-- forEachWith = flip S.foldMapWith +-- @ +-- +-- /Since: 0.1.0 ("Streamly")/ +{-# 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 = Prelude.foldr (f . g) K.nil xs diff --git a/src/Streamly/Internal/Data/Stream/SVar.hs b/src/Streamly/Internal/Data/Stream/SVar.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/SVar.hs @@ -0,0 +1,240 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} + +#ifdef __HADDOCK_VERSION__ +#undef INSPECTION +#endif + +#ifdef INSPECTION +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-} +#endif + +-- | +-- Module : Streamly.Internal.Data.Stream.SVar +-- Copyright : (c) 2017 Harendra Kumar +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- +module Streamly.Internal.Data.Stream.SVar + ( fromSVar + , fromStreamVar + , fromProducer + , fromConsumer + , toSVar + , pushToFold + ) +where + +import Control.Exception (fromException) +import Control.Monad (when, void) +import Control.Monad.Catch (throwM) +import Control.Monad.IO.Class (MonadIO(liftIO)) +import Data.IORef (newIORef, readIORef, mkWeakIORef, writeIORef) +import Data.Maybe (isNothing) +import Streamly.Internal.Data.Time.Clock (Clock(Monotonic), getTime) +import System.Mem (performMajorGC) + +import Streamly.Internal.Data.SVar +import Streamly.Internal.Data.Stream.StreamK hiding (reverse) + +#ifdef INSPECTION +import Control.Exception (Exception) +import Control.Monad.Catch (MonadThrow) +import Control.Monad.Trans.Control (MonadBaseControl) +import Data.Typeable (Typeable) +import Test.Inspection (inspect, hasNoTypeClassesExcept) +#endif + +-- | Pull a stream from an SVar. +{-# NOINLINE fromStreamVar #-} +fromStreamVar :: MonadAsync m => SVar Stream m a -> Stream m a +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. + foldStream st yld sng stp $ processEvents $ reverse list + + where + + allDone stp = do + when (svarInspectMode sv) $ do + t <- liftIO $ getTime Monotonic + liftIO $ writeIORef (svarStopTime (svarStats sv)) (Just t) + liftIO $ printSVar sv "SVar Done" + stp + + {-# INLINE processEvents #-} + processEvents [] = MkStream $ \st yld sng stp -> do + done <- postProcess sv + if done + then allDone stp + else foldStream st yld sng stp $ fromStreamVar sv + + 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 -> do + stop <- shouldStop tid + if stop + then liftIO (cleanupSVar sv) >> allDone stp + else foldStream st yld sng stp rest + Just ex -> + case fromException ex of + Just ThreadAbort -> + foldStream st yld sng stp rest + Nothing -> liftIO (cleanupSVar sv) >> throwM ex + shouldStop tid = + case svarStopStyle sv of + StopNone -> return False + StopAny -> return True + StopBy -> do + sid <- liftIO $ readIORef (svarStopBy sv) + return $ if tid == sid then True else False + +#ifdef INSPECTION +-- Use of GHC constraint tuple (GHC.Classes.(%,,%)) in fromStreamVar leads to +-- space leak because the tuple gets allocated in every recursive call and each +-- allocation holds on to the previous allocation. This test is to make sure +-- that we do not use the constraint tuple type class. +-- +inspect $ hasNoTypeClassesExcept 'fromStreamVar + [ ''Monad + , ''Applicative + , ''MonadThrow + , ''Exception + , ''MonadIO + , ''MonadBaseControl + , ''Typeable + , ''Functor + ] +#endif + +{-# INLINE fromSVar #-} +fromSVar :: (MonadAsync m, IsStream t) => SVar Stream m a -> t m a +fromSVar sv = + 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. + foldStreamShared st yld sng stp $ + fromStream $ fromStreamVar sv{svarRef = Just ref} + where + + hook = do + when (svarInspectMode sv) $ do + r <- liftIO $ readIORef (svarStopTime (svarStats sv)) + when (isNothing r) $ + printSVar sv "SVar Garbage Collected" + cleanupSVar sv + -- If there are any SVars referenced by this SVar a GC will prompt + -- them to be cleaned up quickly. + when (svarInspectMode sv) performMajorGC + +-- | Write a stream to an 'SVar' in a non-blocking manner. The stream can then +-- 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) + +------------------------------------------------------------------------------- +-- Process events received by a fold consumer from a stream producer +------------------------------------------------------------------------------- + +-- | Pull a stream from an SVar. +{-# NOINLINE fromProducer #-} +fromProducer :: MonadAsync m => SVar Stream m a -> Stream m a +fromProducer 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. + foldStream st yld sng stp $ processEvents $ reverse list + + where + + allDone stp = do + when (svarInspectMode sv) $ do + t <- liftIO $ getTime Monotonic + liftIO $ writeIORef (svarStopTime (svarStats sv)) (Just t) + liftIO $ printSVar sv "SVar Done" + sendStopToProducer sv + stp + + {-# INLINE processEvents #-} + processEvents [] = mkStream $ \st yld sng stp -> do + foldStream st yld sng stp $ fromProducer sv + + processEvents (ev : es) = mkStream $ \_ yld _ 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 -> allDone stp + Just _ -> error "Bug: fromProducer: received exception" + +------------------------------------------------------------------------------- +-- Process events received by the producer thread from the consumer side +------------------------------------------------------------------------------- + +-- XXX currently only one event is sent by a fold consumer to the stream +-- producer. But we can potentially have multiple events e.g. the fold step can +-- generate exception more than once and the producer can ignore those +-- exceptions or handle them and still keep driving the fold. +-- +{-# NOINLINE fromConsumer #-} +fromConsumer :: MonadAsync m => SVar Stream m a -> m Bool +fromConsumer sv = do + (list, _) <- liftIO $ readOutputQBasic (outputQueueFromConsumer 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. + processEvents $ reverse list + + where + + {-# INLINE processEvents #-} + processEvents [] = return False + processEvents (ev : _) = do + case ev of + ChildStop _ e -> do + case e of + Nothing -> return True + Just ex -> throwM ex + ChildYield _ -> error "Bug: fromConsumer: invalid ChildYield event" + +-- push values to a fold worker via an SVar. Returns whether the fold is done. +{-# INLINE pushToFold #-} +pushToFold :: MonadAsync m => SVar Stream m a -> a -> m Bool +pushToFold sv a = do + -- Check for exceptions before decrement so that we do not + -- block forever if the child already exited with an exception. + -- + -- We avoid a race between the consumer fold sending an event and we + -- blocking on decrementBufferLimit by waking up the producer thread in + -- sendToProducer before any event is sent by the fold to the producer + -- stream. + let qref = outputQueueFromConsumer sv + done <- do + (_, n) <- liftIO $ readIORef qref + if (n > 0) + then fromConsumer sv + else return False + if done + then return True + else liftIO $ do + decrementBufferLimit sv + void $ send sv (ChildYield a) + return False diff --git a/src/Streamly/Internal/Data/Stream/Serial.hs b/src/Streamly/Internal/Data/Stream/Serial.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/Serial.hs @@ -0,0 +1,472 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving#-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- XXX + +-- | +-- Module : Streamly.Internal.Data.Stream.Serial +-- Copyright : (c) 2017 Harendra Kumar +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- +module Streamly.Internal.Data.Stream.Serial + ( + -- * Serial appending stream + SerialT + , Serial + , K.serial + , serially + + -- * Serial interleaving stream + , WSerialT + , WSerial + , wSerial + , wSerialFst + , wSerialMin + , wSerially + + -- * Construction + , unfoldrM + + -- * Transformation + , map + , mapM + + -- * Deprecated + , StreamT + , InterleavedT + , (<=>) + , interleaving + ) +where + +import Control.Applicative (liftA2) +import Control.DeepSeq (NFData(..)) +#if MIN_VERSION_deepseq(1,4,3) +import Control.DeepSeq (NFData1(..)) +#endif +import Control.Monad.Base (MonadBase(..), liftBaseDefault) +import Control.Monad.Catch (MonadThrow, throwM) +-- import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Reader.Class (MonadReader(..)) +import Control.Monad.State.Class (MonadState(..)) +import Control.Monad.Trans.Class (MonadTrans(lift)) +import Data.Foldable (Foldable(foldl'), fold) +import Data.Functor.Identity (Identity(..), runIdentity) +import Data.Maybe (fromMaybe) +import Data.Semigroup (Endo(..)) +#if __GLASGOW_HASKELL__ < 808 +import Data.Semigroup (Semigroup(..)) +#endif +import GHC.Exts (IsList(..), IsString(..)) +import Text.Read (Lexeme(Ident), lexP, parens, prec, readPrec, readListPrec, + readListPrecDefault) +import Prelude hiding (map, mapM, errorWithoutStackTrace) + +import Streamly.Internal.BaseCompat ((#.), errorWithoutStackTrace) +import Streamly.Internal.Data.Stream.StreamK (IsStream(..), adapt, Stream, mkStream, + foldStream) +import Streamly.Internal.Data.Strict (Maybe'(..), toMaybe) +import qualified Streamly.Internal.Data.Stream.Prelude as P +import qualified Streamly.Internal.Data.Stream.StreamK as K +import qualified Streamly.Internal.Data.Stream.StreamD as D + +#include "Instances.hs" +#include "inline.hs" + +------------------------------------------------------------------------------ +-- SerialT +------------------------------------------------------------------------------ + +-- | The 'Semigroup' operation for 'SerialT' behaves like a regular append +-- operation. Therefore, when @a <> b@ is evaluated, stream @a@ is evaluated +-- first until it exhausts and then stream @b@ is evaluated. In other words, +-- the elements of stream @b@ are appended to the elements of stream @a@. This +-- operation can be used to fold an infinite lazy container of streams. +-- +-- @ +-- import Streamly +-- import qualified "Streamly.Prelude" as S +-- +-- main = (S.toList . 'serially' $ (S.fromList [1,2]) \<\> (S.fromList [3,4])) >>= print +-- @ +-- @ +-- [1,2,3,4] +-- @ +-- +-- The 'Monad' instance runs the /monadic continuation/ for each +-- element of the stream, serially. +-- +-- @ +-- main = S.drain . 'serially' $ do +-- x <- return 1 \<\> return 2 +-- S.yieldM $ print x +-- @ +-- @ +-- 1 +-- 2 +-- @ +-- +-- 'SerialT' nests streams serially in a depth first manner. +-- +-- @ +-- main = S.drain . 'serially' $ do +-- x <- return 1 \<\> return 2 +-- y <- return 3 \<\> return 4 +-- S.yieldM $ print (x, y) +-- @ +-- @ +-- (1,3) +-- (1,4) +-- (2,3) +-- (2,4) +-- @ +-- +-- We call the monadic code being run for each element of the stream a monadic +-- continuation. In imperative paradigm we can think of this composition as +-- nested @for@ loops and the monadic continuation is the body of the loop. The +-- loop iterates for all elements of the stream. +-- +-- Note that the behavior and semantics of 'SerialT', including 'Semigroup' +-- and 'Monad' instances are exactly like Haskell lists except that 'SerialT' +-- can contain effectful actions while lists are pure. +-- +-- In the code above, the 'serially' combinator can be omitted as the default +-- stream type is 'SerialT'. +-- +-- @since 0.2.0 +newtype SerialT m a = SerialT {getSerialT :: Stream m a} + deriving (Semigroup, Monoid, MonadTrans) + +-- | A serial IO stream of elements of type @a@. See 'SerialT' documentation +-- for more details. +-- +-- @since 0.2.0 +type Serial = SerialT IO + +-- | +-- @since 0.1.0 +{-# DEPRECATED StreamT "Please use 'SerialT' instead." #-} +type StreamT = SerialT + +-- | Fix the type of a polymorphic stream as 'SerialT'. +-- +-- @since 0.1.0 +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 + consM = consMSerial + (|:) = consMSerial + +------------------------------------------------------------------------------ +-- Monad +------------------------------------------------------------------------------ + +instance Monad m => Monad (SerialT m) where + return = pure + {-# INLINE (>>=) #-} + (>>=) = K.bindWith K.serial + {-# INLINE (>>) #-} + (>>) = (*>) + + -- StreamD based implementation + -- return = SerialT . D.fromStreamD . D.yield + -- m >>= f = D.fromStreamD $ D.concatMap (\a -> D.toStreamD (f a)) (D.toStreamD m) + +------------------------------------------------------------------------------ +-- Other instances +------------------------------------------------------------------------------ + +{-# INLINE mapM #-} +mapM :: (IsStream t, Monad m) => (a -> m b) -> t m a -> t m b +mapM f m = D.fromStreamD $ D.mapM f $ D.toStreamD m + +-- | +-- @ +-- 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 +map f = mapM (return . f) + +{-# INLINE apSerial #-} +apSerial :: Monad m => SerialT m (a -> b) -> SerialT m a -> SerialT m b +apSerial (SerialT m1) (SerialT m2) = D.fromStreamD $ D.toStreamD m1 <*> D.toStreamD m2 + +{-# INLINE apSequence #-} +apSequence :: Monad m => SerialT m a -> SerialT m b -> SerialT m b +apSequence (SerialT m1) (SerialT m2) = D.fromStreamD $ D.toStreamD m1 *> D.toStreamD m2 + +instance Monad m => Applicative (SerialT m) where + {-# INLINE pure #-} + pure = SerialT . K.yield + {-# INLINE (<*>) #-} + (<*>) = apSerial + {-# INLINE (*>) #-} + (*>) = apSequence + +MONAD_COMMON_INSTANCES(SerialT,) +LIST_INSTANCES(SerialT) +NFDATA1_INSTANCE(SerialT) +FOLDABLE_INSTANCE(SerialT) +TRAVERSABLE_INSTANCE(SerialT) + +------------------------------------------------------------------------------ +-- WSerialT +------------------------------------------------------------------------------ + +-- | The 'Semigroup' operation for 'WSerialT' interleaves the elements from the +-- two streams. Therefore, when @a <> b@ is evaluated, stream @a@ is evaluated +-- first to produce the first element of the combined stream and then stream +-- @b@ is evaluated to produce the next element of the combined stream, and +-- then we go back to evaluating stream @a@ and so on. In other words, the +-- elements of stream @a@ are interleaved with the elements of stream @b@. +-- +-- Note that evaluation of @a <> b <> c@ does not schedule @a@, @b@ and @c@ +-- with equal priority. This expression is equivalent to @a <> (b <> c)@, +-- therefore, it fairly interleaves @a@ with the result of @b <> c@. For +-- example, @S.fromList [1,2] <> S.fromList [3,4] <> S.fromList [5,6] :: +-- WSerialT Identity Int@ would result in [1,3,2,5,4,6]. In other words, the +-- leftmost stream gets the same scheduling priority as the rest of the +-- streams taken together. The same is true for each subexpression on the right. +-- +-- Note that this operation cannot be used to fold a container of infinite +-- streams as the state that it needs to maintain is proportional to the number +-- of streams. +-- +-- The @W@ in the name stands for @wide@ or breadth wise scheduling in +-- contrast to the depth wise scheduling behavior of 'SerialT'. +-- +-- @ +-- import Streamly +-- import qualified "Streamly.Prelude" as S +-- +-- main = (S.toList . 'wSerially' $ (S.fromList [1,2]) \<\> (S.fromList [3,4])) >>= print +-- @ +-- @ +-- [1,3,2,4] +-- @ +-- +-- Similarly, the 'Monad' instance interleaves the iterations of the +-- inner and the outer loop, nesting loops in a breadth first manner. +-- +-- +-- @ +-- main = S.drain . 'wSerially' $ do +-- x <- return 1 \<\> return 2 +-- y <- return 3 \<\> return 4 +-- S.yieldM $ print (x, y) +-- @ +-- @ +-- (1,3) +-- (2,3) +-- (1,4) +-- (2,4) +-- @ +-- +-- @since 0.2.0 +newtype WSerialT m a = WSerialT {getWSerialT :: Stream m a} + deriving (MonadTrans) + +-- | An interleaving serial IO stream of elements of type @a@. See 'WSerialT' +-- documentation for more details. +-- +-- @since 0.2.0 +type WSerial = WSerialT IO + +-- | +-- @since 0.1.0 +{-# DEPRECATED InterleavedT "Please use 'WSerialT' instead." #-} +type InterleavedT = WSerialT + +-- | Fix the type of a polymorphic stream as 'WSerialT'. +-- +-- @since 0.2.0 +wSerially :: IsStream t => WSerialT m a -> t m a +wSerially = adapt + +-- | Same as 'wSerially'. +-- +-- @since 0.1.0 +{-# DEPRECATED interleaving "Please use wSerially instead." #-} +interleaving :: IsStream t => WSerialT m a -> t m a +interleaving = wSerially + +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 + + {-# INLINE consM #-} + {-# SPECIALIZE consM :: IO a -> WSerialT IO a -> WSerialT IO a #-} + consM :: Monad m => m a -> WSerialT m a -> WSerialT m a + consM = consMWSerial + + {-# INLINE (|:) #-} + {-# SPECIALIZE (|:) :: IO a -> WSerialT IO a -> WSerialT IO a #-} + (|:) :: Monad m => m a -> WSerialT m a -> WSerialT m a + (|:) = consMWSerial + +------------------------------------------------------------------------------ +-- Semigroup +------------------------------------------------------------------------------ + +-- Additionally we can have m elements yield from the first stream and n +-- elements yielding from the second stream. We can also have time slicing +-- variants of positional interleaving, e.g. run first stream for m seconds and +-- run the second stream for n seconds. +-- +-- Similar combinators can be implemented using WAhead style. + +-- | Polymorphic version of the 'Semigroup' operation '<>' of 'WSerialT'. +-- Interleaves two streams, yielding one element from each stream alternately. +-- When one stream stops the rest of the other stream is used in the output +-- stream. +-- +-- @since 0.2.0 +{-# INLINE wSerial #-} +wSerial :: IsStream t => t m a -> t m a -> t m a +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 + +-- | Like `wSerial` but stops interleaving as soon as the first stream stops. +-- +-- @since 0.7.0 +{-# INLINE wSerialFst #-} +wSerialFst :: IsStream t => t m a -> t m a -> t m a +wSerialFst m1 m2 = mkStream $ \st yld sng stp -> do + let yieldFirst a r = yld a (yieldSecond r m2) + in foldStream st yieldFirst sng stp m1 + + where + + yieldSecond s1 s2 = mkStream $ \st yld sng stp -> do + let stop = foldStream st yld sng stp s1 + single a = yld a s1 + yieldk a r = yld a (wSerial s1 r) + in foldStream st yieldk single stop s2 + +-- | Like `wSerial` but stops interleaving as soon as any of the two streams +-- stops. +-- +-- @since 0.7.0 +{-# INLINE wSerialMin #-} +wSerialMin :: IsStream t => t m a -> t m a -> t m a +wSerialMin m1 m2 = mkStream $ \st yld sng stp -> do + let stop = stp + single a = sng a + yieldk a r = yld a (wSerial m2 r) + foldStream st yieldk single stop m1 + +instance Semigroup (WSerialT m a) where + (<>) = wSerial + +infixr 5 <=> + +-- | Same as 'wSerial'. +-- +-- @since 0.1.0 +{-# DEPRECATED (<=>) "Please use 'wSerial' instead." #-} +{-# INLINE (<=>) #-} +(<=>) :: IsStream t => t m a -> t m a -> t m a +(<=>) = wSerial + +------------------------------------------------------------------------------ +-- Monoid +------------------------------------------------------------------------------ + +instance Monoid (WSerialT m a) where + mempty = K.nil + mappend = (<>) + +{-# INLINE apWSerial #-} +apWSerial :: Monad m => WSerialT m (a -> b) -> WSerialT m a -> WSerialT m b +apWSerial (WSerialT m1) (WSerialT m2) = + let f x1 = K.concatMapBy wSerial (pure . x1) m2 + in WSerialT $ K.concatMapBy wSerial f m1 + +instance Monad m => Applicative (WSerialT m) where + {-# INLINE pure #-} + pure = WSerialT . K.yield + {-# INLINE (<*>) #-} + (<*>) = apWSerial + +------------------------------------------------------------------------------ +-- Monad +------------------------------------------------------------------------------ + +instance Monad m => Monad (WSerialT m) where + return = pure + {-# INLINE (>>=) #-} + (>>=) = K.bindWith wSerial + +------------------------------------------------------------------------------ +-- Other instances +------------------------------------------------------------------------------ + +MONAD_COMMON_INSTANCES(WSerialT,) +LIST_INSTANCES(WSerialT) +NFDATA1_INSTANCE(WSerialT) +FOLDABLE_INSTANCE(WSerialT) +TRAVERSABLE_INSTANCE(WSerialT) + +------------------------------------------------------------------------------ +-- Construction +------------------------------------------------------------------------------ + +-- | 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 drain $ unfoldrM f 0 +-- @ +-- @ +-- 0 +-- 1 +-- 2 +-- 3 +-- @ +-- +-- /Internal/ +-- +{-# INLINE unfoldrM #-} +unfoldrM :: (IsStream t, Monad m) => (b -> m (Maybe (a, b))) -> b -> t m a +unfoldrM step seed = D.fromStreamD (D.unfoldrM step seed) diff --git a/src/Streamly/Internal/Data/Stream/StreamD.hs b/src/Streamly/Internal/Data/Stream/StreamD.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/StreamD.hs @@ -0,0 +1,4271 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE MagicHash #-} + +#if __GLASGOW_HASKELL__ >= 801 +{-# LANGUAGE TypeApplications #-} +#endif + +#include "inline.hs" + +-- | +-- Module : Streamly.Internal.Data.Stream.StreamD +-- Copyright : (c) 2018 Harendra Kumar +-- (c) Roman Leshchinskiy 2008-2010 +-- (c) The University of Glasgow, 2009 +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.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.Internal.Data.Stream.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.Internal.Data.Stream.StreamD + ( + -- * The stream type + Step (..) + +#if __GLASGOW_HASKELL__ >= 800 + , Stream (Stream, UnStream) +#else + , Stream (UnStream) + , pattern Stream +#endif + + -- * Construction + , nil + , nilM + , cons + + -- * Deconstruction + , uncons + + -- * Generation + -- ** Unfolds + , unfoldr + , unfoldrM + , unfold + + -- ** Specialized Generation + -- | Generate a monadic stream from a seed. + , repeat + , repeatM + , replicate + , replicateM + , fromIndices + , fromIndicesM + , generate + , generateM + , iterate + , iterateM + + -- ** Enumerations + , enumerateFromStepIntegral + , enumerateFromIntegral + , enumerateFromThenIntegral + , enumerateFromToIntegral + , enumerateFromThenToIntegral + + , enumerateFromStepNum + , numFrom + , numFromThen + , enumerateFromToFractional + , enumerateFromThenToFractional + + -- ** Time + , currentTime + + -- ** Conversions + -- | Transform an input structure into a stream. + -- | Direct style stream does not support @fromFoldable@. + , yield + , yieldM + , fromList + , fromListM + , fromStreamK + , fromStreamD + , fromPrimVar + , fromSVar + + -- * Elimination + -- ** General Folds + , foldrS + , foldrT + , foldrM + , foldrMx + , foldr + , foldr1 + + , foldl' + , foldlM' + , foldlS + , foldlT + , reverse + , reverse' + + , foldlx' + , foldlMx' + , runFold + + -- ** Specialized Folds + , tap + , tapOffsetEvery + , tapAsync + , tapRate + , pollCounts + , drain + , null + , head + , headElse + , tail + , last + , elem + , notElem + , all + , any + , maximum + , maximumBy + , minimum + , minimumBy + , findIndices + , lookup + , findM + , find + , (!!) + , toSVarParallel + + -- ** Flattening nested streams + , concatMapM + , concatMap + , ConcatMapUState (..) + , concatMapU + , ConcatUnfoldInterleaveState (..) + , concatUnfoldInterleave + , concatUnfoldRoundrobin + , AppendState(..) + , append + , InterleaveState(..) + , interleave + , interleaveMin + , interleaveSuffix + , interleaveInfix + , roundRobin -- interleaveFair?/ParallelFair + , gintercalateSuffix + , interposeSuffix + , gintercalate + , interpose + + -- ** Grouping + , groupsOf + , groupsOf2 + , groupsBy + , groupsRollingBy + + -- ** Splitting + , splitBy + , splitSuffixBy + , wordsBy + , splitSuffixBy' + + , splitOn + , splitSuffixOn + + , splitInnerBy + , splitInnerBySuffix + + -- ** Substreams + , isPrefixOf + , isSubsequenceOf + , stripPrefix + + -- ** Map and Fold + , mapM_ + + -- ** Conversions + -- | Transform a stream into another type. + , toList + , toListRev + , toStreamK + , toStreamD + + , hoist + , generally + + , liftInner + , runReaderT + , evalStateT + , runStateT + + -- * Transformation + , transform + + -- ** By folding (scans) + , scanlM' + , scanl' + , scanlM + , scanl + , scanl1M' + , scanl1' + , scanl1M + , scanl1 + + , prescanl' + , prescanlM' + + , postscanl + , postscanlM + , postscanl' + , postscanlM' + + , postscanlx' + , postscanlMx' + , scanlMx' + , scanlx' + + -- * Filtering + , filter + , filterM + , uniq + , take + , takeByTime + , takeWhile + , takeWhileM + , drop + , dropByTime + , dropWhile + , dropWhileM + + -- * Mapping + , map + , mapM + , sequence + , rollingMap + , rollingMapM + + -- * Inserting + , intersperseM + , intersperse + , intersperseSuffix + , intersperseSuffixBySpan + , insertBy + + -- * Deleting + , deleteBy + + -- ** Map and Filter + , mapMaybe + , mapMaybeM + + -- * Zipping + , indexed + , indexedR + , zipWith + , zipWithM + + -- * Comparisons + , eqBy + , cmpBy + + -- * Merging + , mergeBy + , mergeByM + + -- * Transformation comprehensions + , the + + -- * Exceptions + , newFinalizedIORef + , runIORefFinalizer + , clearIORefFinalizer + , gbracket + , before + , after + , afterIO + , bracket + , bracketIO + , onException + , finally + , finallyIO + , handle + + -- * Concurrent Application + , mkParallel + , mkParallelD + + , lastN + ) +where + +import Control.Concurrent (killThread, myThreadId, takeMVar, threadDelay) +import Control.Exception + (Exception, SomeException, AsyncException, fromException) +import Control.Monad (void, when, forever) +import Control.Monad.Catch (MonadCatch, throwM) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Reader (ReaderT) +import Control.Monad.State.Strict (StateT) +import Control.Monad.Trans (MonadTrans(lift)) +import Control.Monad.Trans.Control (MonadBaseControl) +import Data.Bits (shiftR, shiftL, (.|.), (.&.)) +import Data.Functor.Identity (Identity(..)) +import Data.Int (Int64) +import Data.IORef (newIORef, readIORef, mkWeakIORef, writeIORef, IORef) +import Data.Maybe (fromJust, isJust, isNothing) +import Data.Word (Word32) +import Foreign.Ptr (Ptr) +import Foreign.Storable (Storable(..)) +import GHC.Types (SPEC(..)) +import System.Mem (performMajorGC) +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, concat, + reverse, iterate) + +import qualified Control.Monad.Catch as MC +import qualified Control.Monad.Reader as Reader +import qualified Control.Monad.State.Strict as State +import qualified Prelude + +import Streamly.Internal.Mutable.Prim.Var + (Prim, Var, readVar, newVar, modifyVar') +import Streamly.Internal.Data.Time.Units + (TimeUnit64, toRelTime64, diffAbsTime64) + +import Streamly.Internal.Data.Atomics (atomicModifyIORefCAS_) +import Streamly.Internal.Memory.Array.Types (Array(..)) +import Streamly.Internal.Data.Fold.Types (Fold(..)) +import Streamly.Internal.Data.Pipe.Types (Pipe(..), PipeState(..)) +import Streamly.Internal.Data.Time.Clock (Clock(Monotonic), getTime) +import Streamly.Internal.Data.Time.Units + (MicroSecond64(..), fromAbsTime, toAbsTime, AbsTime) +import Streamly.Internal.Data.Unfold.Types (Unfold(..)) +import Streamly.Internal.Data.Strict (Tuple3'(..)) + +import Streamly.Internal.Data.Stream.StreamD.Type +import Streamly.Internal.Data.SVar +import Streamly.Internal.Data.Stream.SVar (fromConsumer, pushToFold) + +import qualified Streamly.Internal.Data.Pipe.Types as Pipe +import qualified Streamly.Internal.Memory.Array.Types as A +import qualified Streamly.Internal.Data.Fold as FL +import qualified Streamly.Memory.Ring as RB +import qualified Streamly.Internal.Data.Stream.StreamK as K + +------------------------------------------------------------------------------ +-- Construction +------------------------------------------------------------------------------ + +-- | An empty 'Stream'. +{-# INLINE_NORMAL nil #-} +nil :: Monad m => Stream m a +nil = Stream (\_ _ -> return Stop) () + +-- | An empty 'Stream' with a side effect. +{-# INLINE_NORMAL nilM #-} +nilM :: Monad m => m b -> Stream m a +nilM m = Stream (\_ _ -> m >> return Stop) () + +{-# INLINE_NORMAL consM #-} +consM :: Monad m => m a -> Stream m a -> Stream m a +consM m (Stream step state) = Stream step1 Nothing + where + {-# INLINE_LATE step1 #-} + step1 _ Nothing = m >>= \x -> 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 + +-- XXX implement in terms of consM? +-- cons x = consM (return x) +-- +-- | 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) + +-- | Convert an 'Unfold' into a 'Stream' by supplying it a seed. +-- +{-# INLINE_NORMAL unfold #-} +unfold :: Monad m => Unfold m a b -> a -> Stream m b +unfold (Unfold ustep inject) seed = Stream step Nothing + where + {-# INLINE_LATE step #-} + step _ Nothing = inject seed >>= return . Skip . Just + step _ (Just st) = do + r <- ustep st + return $ case r of + Yield x s -> Yield x (Just s) + Skip s -> Skip (Just s) + Stop -> Stop + +------------------------------------------------------------------------------ +-- Specialized Generation +------------------------------------------------------------------------------ + +{-# INLINE_NORMAL repeatM #-} +repeatM :: Monad m => m a -> Stream m a +repeatM x = Stream (\_ _ -> x >>= \r -> return $ Yield r ()) () + +{-# INLINE_NORMAL repeat #-} +repeat :: Monad m => a -> Stream m a +repeat x = Stream (\_ _ -> return $ Yield x ()) () + +{-# INLINE_NORMAL iterateM #-} +iterateM :: Monad m => (a -> m a) -> m a -> Stream m a +iterateM step = Stream (\_ st -> st >>= \x -> return $ Yield x (step x)) + +{-# INLINE_NORMAL iterate #-} +iterate :: Monad m => (a -> a) -> a -> Stream m a +iterate step st = iterateM (return . step) (return st) + +{-# INLINE_NORMAL replicateM #-} +replicateM :: forall m a. Monad m => Int -> m a -> Stream m a +replicateM n p = Stream step n + where + {-# INLINE_LATE step #-} + step _ (i :: Int) + | 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 +-- every time 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 +------------------------------------------------------------------------------- + +{-# 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 + +{-# INLINE toStreamD #-} +toStreamD :: (K.IsStream t, Monad m) => t m a -> Stream m a +toStreamD = fromStreamK . K.toStream + +{-# INLINE_NORMAL fromPrimVar #-} +fromPrimVar :: (MonadIO m, Prim a) => Var IO a -> Stream m a +fromPrimVar var = Stream step () + where + {-# INLINE_LATE step #-} + step _ () = liftIO (readVar var) >>= \x -> return $ Yield x () + +------------------------------------------------------------------------------- +-- Generation from SVar +------------------------------------------------------------------------------- + +data FromSVarState t m a = + FromSVarInit + | FromSVarRead (SVar t m a) + | FromSVarLoop (SVar t m a) [ChildEvent a] + | FromSVarDone (SVar t m a) + +{-# INLINE_NORMAL fromSVar #-} +fromSVar :: (MonadAsync m) => SVar t m a -> Stream m a +fromSVar svar = Stream step FromSVarInit + where + + {-# INLINE_LATE step #-} + step _ FromSVarInit = do + ref <- liftIO $ newIORef () + _ <- liftIO $ mkWeakIORef ref hook + -- when this copy of svar gets garbage collected "ref" will get + -- garbage collected and our GC hook will be called. + let sv = svar{svarRef = Just ref} + return $ Skip (FromSVarRead sv) + + where + + {-# NOINLINE hook #-} + hook = do + when (svarInspectMode svar) $ do + r <- liftIO $ readIORef (svarStopTime (svarStats svar)) + when (isNothing r) $ + printSVar svar "SVar Garbage Collected" + cleanupSVar svar + -- If there are any SVars referenced by this SVar a GC will prompt + -- them to be cleaned up quickly. + when (svarInspectMode svar) performMajorGC + + step _ (FromSVarRead sv) = 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. + return $ Skip $ FromSVarLoop sv (Prelude.reverse list) + + step _ (FromSVarLoop sv []) = do + done <- postProcess sv + return $ Skip $ if done + then (FromSVarDone sv) + else (FromSVarRead sv) + + step _ (FromSVarLoop sv (ev : es)) = do + case ev of + ChildYield a -> return $ Yield a (FromSVarLoop sv es) + ChildStop tid e -> do + accountThread sv tid + case e of + Nothing -> do + stop <- shouldStop tid + if stop + then do + liftIO (cleanupSVar sv) + return $ Skip (FromSVarDone sv) + else return $ Skip (FromSVarLoop sv es) + Just ex -> + case fromException ex of + Just ThreadAbort -> + return $ Skip (FromSVarLoop sv es) + Nothing -> liftIO (cleanupSVar sv) >> throwM ex + where + + shouldStop tid = + case svarStopStyle sv of + StopNone -> return False + StopAny -> return True + StopBy -> do + sid <- liftIO $ readIORef (svarStopBy sv) + return $ if tid == sid then True else False + + step _ (FromSVarDone sv) = do + when (svarInspectMode sv) $ do + t <- liftIO $ getTime Monotonic + liftIO $ writeIORef (svarStopTime (svarStats sv)) (Just t) + liftIO $ printSVar sv "SVar Done" + return Stop + +------------------------------------------------------------------------------- +-- Process events received by a fold consumer from a stream producer +------------------------------------------------------------------------------- + +{-# INLINE_NORMAL fromProducer #-} +fromProducer :: (MonadAsync m) => SVar t m a -> Stream m a +fromProducer svar = Stream step (FromSVarRead svar) + where + + {-# INLINE_LATE step #-} + step _ (FromSVarRead sv) = 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. + return $ Skip $ FromSVarLoop sv (Prelude.reverse list) + + step _ (FromSVarLoop sv []) = return $ Skip $ FromSVarRead sv + step _ (FromSVarLoop sv (ev : es)) = do + case ev of + ChildYield a -> return $ Yield a (FromSVarLoop sv es) + ChildStop tid e -> do + accountThread sv tid + case e of + Nothing -> do + sendStopToProducer sv + return $ Skip (FromSVarDone sv) + Just _ -> error "Bug: fromProducer: received exception" + + step _ (FromSVarDone sv) = do + when (svarInspectMode sv) $ do + t <- liftIO $ getTime Monotonic + liftIO $ writeIORef (svarStopTime (svarStats sv)) (Just t) + liftIO $ printSVar sv "SVar Done" + return Stop + + step _ FromSVarInit = undefined + +------------------------------------------------------------------------------- +-- Hoisting the inner monad +------------------------------------------------------------------------------- + +{-# INLINE_NORMAL hoist #-} +hoist :: Monad n => (forall x. m x -> n x) -> Stream m a -> Stream n a +hoist f (Stream step state) = (Stream step' state) + where + {-# INLINE_LATE step' #-} + step' gst st = do + r <- f $ step (adaptState gst) st + return $ case r of + Yield x s -> Yield x s + Skip s -> Skip s + Stop -> Stop + +{-# INLINE generally #-} +generally :: Monad m => Stream Identity a -> Stream m a +generally = hoist (return . runIdentity) + +{-# INLINE_NORMAL liftInner #-} +liftInner :: (Monad m, MonadTrans t, Monad (t m)) + => Stream m a -> Stream (t m) a +liftInner (Stream step state) = Stream step' state + where + {-# INLINE_LATE step' #-} + step' gst st = do + r <- lift $ step (adaptState gst) st + return $ case r of + Yield x s -> Yield x s + Skip s -> Skip s + Stop -> Stop + +{-# INLINE_NORMAL runReaderT #-} +runReaderT :: Monad m => s -> Stream (ReaderT s m) a -> Stream m a +runReaderT sval (Stream step state) = Stream step' state + where + {-# INLINE_LATE step' #-} + step' gst st = do + r <- Reader.runReaderT (step (adaptState gst) st) sval + return $ case r of + Yield x s -> Yield x s + Skip s -> Skip s + Stop -> Stop + +{-# INLINE_NORMAL evalStateT #-} +evalStateT :: Monad m => s -> Stream (StateT s m) a -> Stream m a +evalStateT sval (Stream step state) = Stream step' (state, sval) + where + {-# INLINE_LATE step' #-} + step' gst (st, sv) = do + (r, sv') <- State.runStateT (step (adaptState gst) st) sv + return $ case r of + Yield x s -> Yield x (s, sv') + Skip s -> Skip (s, sv') + Stop -> Stop + +{-# INLINE_NORMAL runStateT #-} +runStateT :: Monad m => s -> Stream (StateT s m) a -> Stream m (s, a) +runStateT sval (Stream step state) = Stream step' (state, sval) + where + {-# INLINE_LATE step' #-} + step' gst (st, sv) = do + (r, sv') <- State.runStateT (step (adaptState gst) st) sv + return $ case r of + Yield x s -> Yield (sv', x) (s, sv') + Skip s -> Skip (s, sv') + Stop -> Stop + +------------------------------------------------------------------------------ +-- Elimination by Folds +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ +-- Right Folds +------------------------------------------------------------------------------ + +{-# 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) + +------------------------------------------------------------------------------ +-- Left Folds +------------------------------------------------------------------------------ + +{-# INLINE_NORMAL foldlT #-} +foldlT :: (Monad m, Monad (s m), MonadTrans s) + => (s m b -> a -> s m b) -> s m b -> Stream m a -> s m b +foldlT fstep begin (Stream step state) = go SPEC begin state + where + go !_ acc st = do + r <- lift $ step defState st + case r of + Yield x s -> go SPEC (fstep acc x) s + Skip s -> go SPEC acc s + Stop -> acc + +-- Note, this is going to have horrible performance, because of the nature of +-- the stream type (i.e. direct stream vs CPS). Its only for reference, it is +-- likely be practically unusable. +{-# INLINE_NORMAL foldlS #-} +foldlS :: Monad m + => (Stream m b -> a -> Stream m b) -> Stream m b -> Stream m a -> Stream m b +foldlS fstep begin (Stream step state) = Stream step' (Left (state, begin)) + where + step' gst (Left (st, acc)) = do + r <- step (adaptState gst) st + return $ case r of + Yield x s -> Skip (Left (s, fstep acc x)) + Skip s -> Skip (Left (s, acc)) + Stop -> Skip (Right acc) + + step' gst (Right (Stream stp stt)) = do + r <- stp (adaptState gst) stt + return $ case r of + Yield x s -> Yield x (Right (Stream stp s)) + Skip s -> Skip (Right (Stream stp s)) + Stop -> Stop + +------------------------------------------------------------------------------ +-- Specialized Folds +------------------------------------------------------------------------------ + +-- | Run a streaming composition, discard the results. +{-# INLINE_LATE drain #-} +drain :: Monad m => Stream m a -> m () +-- drain = foldrM (\_ xs -> xs) (return ()) +drain (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 m = foldrM (\_ _ -> return False) (return True) m + +{-# INLINE_NORMAL head #-} +head :: Monad m => Stream m a -> m (Maybe a) +head m = foldrM (\x _ -> return (Just x)) (return Nothing) m + +{-# INLINE_NORMAL headElse #-} +headElse :: Monad m => a -> Stream m a -> m a +headElse a m = foldrM (\x _ -> return x) (return a) m + +-- 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 m = foldrM (\x xs -> if x == e then return True else xs) (return False) m +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 m = foldrM (\x xs -> if p x then xs else return False) (return True) m +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 m = foldrM (\x xs -> if p x then return True else xs) (return False) m +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 m = foldrM (\(a, b) xs -> if e == a then return (Just b) else xs) + (return Nothing) m + +{-# INLINE_NORMAL findM #-} +findM :: Monad m => (a -> m Bool) -> Stream m a -> m (Maybe a) +findM p m = foldrM (\x xs -> p x >>= \r -> if r then return (Just x) else xs) + (return Nothing) m + +{-# 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) = i `seq` 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) + Stop -> Stop + +{-# INLINE toListRev #-} +toListRev :: Monad m => Stream m a -> m [a] +toListRev = foldl' (flip (:)) [] + +-- We can implement reverse as: +-- +-- > reverse = foldlS (flip cons) nil +-- +-- However, this implementation is unusable because of the horrible performance +-- of cons. So we just convert it to a list first and then stream from the +-- list. +-- +-- XXX Maybe we can use an Array instead of a list here? +{-# INLINE_NORMAL reverse #-} +reverse :: Monad m => Stream m a -> Stream m a +reverse m = Stream step Nothing + where + {-# INLINE_LATE step #-} + step _ Nothing = do + xs <- toListRev m + return $ Skip (Just xs) + step _ (Just (x:xs)) = return $ Yield x (Just xs) + step _ (Just []) = return Stop + +-- Much faster reverse for Storables +{-# INLINE_NORMAL reverse' #-} +reverse' :: forall m a. (MonadIO m, Storable a) => Stream m a -> Stream m a +{- +-- This commented implementation copies the whole stream into one single array +-- and then streams from that array, this is 3-4x faster than the chunked code +-- that follows. Though this could be problematic due to unbounded large +-- allocations. We need to figure out why the chunked code is slower and if we +-- can optimize the chunked code to work as fast as this one. It may be a +-- fusion issue? +import Foreign.ForeignPtr (touchForeignPtr) +import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) +import Foreign.Ptr (Ptr, plusPtr) +reverse' m = Stream step Nothing + where + {-# INLINE_LATE step #-} + step _ Nothing = do + arr <- A.fromStreamD m + let p = aEnd arr `plusPtr` negate (sizeOf (undefined :: a)) + return $ Skip $ Just (aStart arr, p) + + step _ (Just (start, p)) | p < unsafeForeignPtrToPtr start = return Stop + + step _ (Just (start, p)) = do + let !x = A.unsafeInlineIO $ do + r <- peek p + touchForeignPtr start + return r + next = p `plusPtr` negate (sizeOf (undefined :: a)) + return $ Yield x (Just (start, next)) +-} +reverse' m = + A.flattenArraysRev + $ fromStreamK + $ K.reverse + $ toStreamK + $ A.fromStreamDArraysOf A.defaultChunkSize m + + +------------------------------------------------------------------------------ +-- Grouping/Splitting +------------------------------------------------------------------------------ + +{-# INLINE_NORMAL splitSuffixBy' #-} +splitSuffixBy' :: Monad m + => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b +splitSuffixBy' predicate f (Stream step state) = + Stream (stepOuter f) (Just state) + + where + + {-# INLINE_LATE stepOuter #-} + stepOuter (Fold fstep initial done) gst (Just st) = do + res <- step (adaptState gst) st + case res of + Yield x s -> do + acc <- initial + acc' <- fstep acc x + if (predicate x) + then done acc' >>= \val -> return $ Yield val (Just s) + else go SPEC s acc' + + Skip s -> return $ Skip $ Just s + Stop -> return Stop + + where + + go !_ stt !acc = do + res <- step (adaptState gst) stt + case res of + Yield x s -> do + acc' <- fstep acc x + if (predicate x) + then done acc' >>= \val -> return $ Yield val (Just s) + else go SPEC s acc' + Skip s -> go SPEC s acc + Stop -> done acc >>= \val -> return $ Yield val Nothing + + stepOuter _ _ Nothing = return Stop + +{-# INLINE_NORMAL groupsBy #-} +groupsBy :: Monad m + => (a -> a -> Bool) + -> Fold m a b + -> Stream m a + -> Stream m b +groupsBy cmp f (Stream step state) = Stream (stepOuter f) (Just state, Nothing) + + where + + {-# INLINE_LATE stepOuter #-} + stepOuter (Fold fstep initial done) gst (Just st, Nothing) = do + res <- step (adaptState gst) st + case res of + Yield x s -> do + acc <- initial + acc' <- fstep acc x + go SPEC x s acc' + + Skip s -> return $ Skip $ (Just s, Nothing) + Stop -> return Stop + + where + + go !_ prev stt !acc = do + res <- step (adaptState gst) stt + case res of + Yield x s -> do + if cmp x prev + then do + acc' <- fstep acc x + go SPEC prev s acc' + else done acc >>= \r -> return $ Yield r (Just s, Just x) + Skip s -> go SPEC prev s acc + Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing) + + stepOuter (Fold fstep initial done) gst (Just st, Just prev) = do + acc <- initial + acc' <- fstep acc prev + go SPEC st acc' + + where + + -- XXX code duplicated from the previous equation + go !_ stt !acc = do + res <- step (adaptState gst) stt + case res of + Yield x s -> do + if cmp x prev + then do + acc' <- fstep acc x + go SPEC s acc' + else done acc >>= \r -> return $ Yield r (Just s, Just x) + Skip s -> go SPEC s acc + Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing) + + stepOuter _ _ (Nothing,_) = return Stop + +{-# INLINE_NORMAL groupsRollingBy #-} +groupsRollingBy :: Monad m + => (a -> a -> Bool) + -> Fold m a b + -> Stream m a + -> Stream m b +groupsRollingBy cmp f (Stream step state) = + Stream (stepOuter f) (Just state, Nothing) + where + + {-# INLINE_LATE stepOuter #-} + stepOuter (Fold fstep initial done) gst (Just st, Nothing) = do + res <- step (adaptState gst) st + case res of + Yield x s -> do + acc <- initial + acc' <- fstep acc x + go SPEC x s acc' + + Skip s -> return $ Skip $ (Just s, Nothing) + Stop -> return Stop + + where + go !_ prev stt !acc = do + res <- step (adaptState gst) stt + case res of + Yield x s -> do + if cmp prev x + then do + acc' <- fstep acc x + go SPEC x s acc' + else + done acc >>= \r -> return $ Yield r (Just s, Just x) + Skip s -> go SPEC prev s acc + Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing) + + stepOuter (Fold fstep initial done) gst (Just st, Just prev') = do + acc <- initial + acc' <- fstep acc prev' + go SPEC prev' st acc' + + where + go !_ prevv stt !acc = do + res <- step (adaptState gst) stt + case res of + Yield x s -> do + if cmp prevv x + then do + acc' <- fstep acc x + go SPEC x s acc' + else done acc >>= \r -> return $ Yield r (Just s, Just x) + Skip s -> go SPEC prevv s acc + Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing) + + stepOuter _ _ (Nothing, _) = return Stop + +{-# INLINE_NORMAL splitBy #-} +splitBy :: Monad m => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b +splitBy predicate f (Stream step state) = Stream (step' f) (Just state) + + where + + {-# INLINE_LATE step' #-} + step' (Fold fstep initial done) gst (Just st) = initial >>= go SPEC st + + where + + go !_ stt !acc = do + res <- step (adaptState gst) stt + case res of + Yield x s -> do + if predicate x + then done acc >>= \r -> return $ Yield r (Just s) + else do + acc' <- fstep acc x + go SPEC s acc' + Skip s -> go SPEC s acc + Stop -> done acc >>= \r -> return $ Yield r Nothing + + step' _ _ Nothing = return Stop + +-- XXX requires -funfolding-use-threshold=150 in lines-unlines benchmark +{-# INLINE_NORMAL splitSuffixBy #-} +splitSuffixBy :: Monad m + => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b +splitSuffixBy predicate f (Stream step state) = Stream (step' f) (Just state) + + where + + {-# INLINE_LATE step' #-} + step' (Fold fstep initial done) gst (Just st) = do + res <- step (adaptState gst) st + case res of + Yield x s -> do + acc <- initial + if predicate x + then done acc >>= \val -> return $ Yield val (Just s) + else do + acc' <- fstep acc x + go SPEC s acc' + + Skip s -> return $ Skip $ Just s + Stop -> return Stop + + where + + go !_ stt !acc = do + res <- step (adaptState gst) stt + case res of + Yield x s -> do + if predicate x + then done acc >>= \r -> return $ Yield r (Just s) + else do + acc' <- fstep acc x + go SPEC s acc' + Skip s -> go SPEC s acc + Stop -> done acc >>= \r -> return $ Yield r Nothing + + step' _ _ Nothing = return Stop + +{-# INLINE_NORMAL wordsBy #-} +wordsBy :: Monad m => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b +wordsBy predicate f (Stream step state) = Stream (stepOuter f) (Just state) + + where + + {-# INLINE_LATE stepOuter #-} + stepOuter (Fold fstep initial done) gst (Just st) = do + res <- step (adaptState gst) st + case res of + Yield x s -> do + if predicate x + then return $ Skip (Just s) + else do + acc <- initial + acc' <- fstep acc x + go SPEC s acc' + + Skip s -> return $ Skip $ Just s + Stop -> return Stop + + where + + go !_ stt !acc = do + res <- step (adaptState gst) stt + case res of + Yield x s -> do + if predicate x + then done acc >>= \r -> return $ Yield r (Just s) + else do + acc' <- fstep acc x + go SPEC s acc' + Skip s -> go SPEC s acc + Stop -> done acc >>= \r -> return $ Yield r Nothing + + stepOuter _ _ Nothing = return Stop + +-- String search algorithms: +-- http://www-igm.univ-mlv.fr/~lecroq/string/index.html + +{- +-- TODO can we unify the splitting operations using a splitting configuration +-- like in the split package. +-- +data SplitStyle = Infix | Suffix | Prefix deriving (Eq, Show) + +data SplitOptions = SplitOptions + { style :: SplitStyle + , withSep :: Bool -- ^ keep the separators in output + -- , compact :: Bool -- ^ treat multiple consecutive separators as one + -- , trimHead :: Bool -- ^ drop blank at head + -- , trimTail :: Bool -- ^ drop blank at tail + } +-} + +data SplitOnState s a = + GO_START + | GO_EMPTY_PAT s + | GO_SINGLE_PAT s a + | GO_SHORT_PAT s + | GO_KARP_RABIN s !(RB.Ring a) !(Ptr a) + | GO_DONE + +{-# INLINE_NORMAL splitOn #-} +splitOn + :: forall m a b. (MonadIO m, Storable a, Enum a, Eq a) + => Array a + -> Fold m a b + -> Stream m a + -> Stream m b +splitOn patArr@Array{..} (Fold fstep initial done) (Stream step state) = + Stream stepOuter GO_START + + where + + patLen = A.length patArr + maxIndex = patLen - 1 + elemBits = sizeOf (undefined :: a) * 8 + + {-# INLINE_LATE stepOuter #-} + stepOuter _ GO_START = + if patLen == 0 + then return $ Skip $ GO_EMPTY_PAT state + else if patLen == 1 + then do + r <- liftIO $ (A.unsafeIndexIO patArr 0) + return $ Skip $ GO_SINGLE_PAT state r + else if sizeOf (undefined :: a) * patLen + <= sizeOf (undefined :: Word) + then return $ Skip $ GO_SHORT_PAT state + else do + (rb, rhead) <- liftIO $ RB.new patLen + return $ Skip $ GO_KARP_RABIN state rb rhead + + stepOuter gst (GO_SINGLE_PAT stt pat) = initial >>= go SPEC stt + + where + + go !_ st !acc = do + res <- step (adaptState gst) st + case res of + Yield x s -> do + if pat == x + then do + r <- done acc + return $ Yield r (GO_SINGLE_PAT s pat) + else fstep acc x >>= go SPEC s + Skip s -> go SPEC s acc + Stop -> done acc >>= \r -> return $ Yield r GO_DONE + + stepOuter gst (GO_SHORT_PAT stt) = initial >>= go0 SPEC 0 (0 :: Word) stt + + where + + mask :: Word + mask = (1 `shiftL` (elemBits * patLen)) - 1 + + addToWord wrd a = (wrd `shiftL` elemBits) .|. fromIntegral (fromEnum a) + + patWord :: Word + patWord = mask .&. A.foldl' addToWord 0 patArr + + go0 !_ !idx wrd st !acc = do + res <- step (adaptState gst) st + case res of + Yield x s -> do + let wrd' = addToWord wrd x + if idx == maxIndex + then do + if wrd' .&. mask == patWord + then do + r <- done acc + return $ Yield r (GO_SHORT_PAT s) + else go1 SPEC wrd' s acc + else go0 SPEC (idx + 1) wrd' s acc + Skip s -> go0 SPEC idx wrd s acc + Stop -> do + acc' <- if idx /= 0 + then go2 wrd idx acc + else return acc + done acc' >>= \r -> return $ Yield r GO_DONE + + {-# INLINE go1 #-} + go1 !_ wrd st !acc = do + res <- step (adaptState gst) st + case res of + Yield x s -> do + let wrd' = addToWord wrd x + old = (mask .&. wrd) `shiftR` (elemBits * (patLen - 1)) + acc' <- fstep acc (toEnum $ fromIntegral old) + if wrd' .&. mask == patWord + then done acc' >>= \r -> return $ Yield r (GO_SHORT_PAT s) + else go1 SPEC wrd' s acc' + Skip s -> go1 SPEC wrd s acc + Stop -> do + acc' <- go2 wrd patLen acc + done acc' >>= \r -> return $ Yield r GO_DONE + + go2 !wrd !n !acc | n > 0 = do + let old = (mask .&. wrd) `shiftR` (elemBits * (n - 1)) + fstep acc (toEnum $ fromIntegral old) >>= go2 wrd (n - 1) + go2 _ _ acc = return acc + + stepOuter gst (GO_KARP_RABIN stt rb rhead) = do + initial >>= go0 SPEC 0 rhead stt + + where + + k = 2891336453 :: Word32 + coeff = k ^ patLen + addCksum cksum a = cksum * k + fromIntegral (fromEnum a) + deltaCksum cksum old new = + addCksum cksum new - coeff * fromIntegral (fromEnum old) + + -- XXX shall we use a random starting hash or 1 instead of 0? + patHash = A.foldl' addCksum 0 patArr + + -- rh == ringHead + go0 !_ !idx !rh st !acc = do + res <- step (adaptState gst) st + case res of + Yield x s -> do + rh' <- liftIO $ RB.unsafeInsert rb rh x + if idx == maxIndex + then do + let fold = RB.unsafeFoldRing (RB.ringBound rb) + let !ringHash = fold addCksum 0 rb + if ringHash == patHash + then go2 SPEC ringHash rh' s acc + else go1 SPEC ringHash rh' s acc + else go0 SPEC (idx + 1) rh' s acc + Skip s -> go0 SPEC idx rh s acc + Stop -> do + !acc' <- if idx /= 0 + then RB.unsafeFoldRingM rh fstep acc rb + else return acc + done acc' >>= \r -> return $ Yield r GO_DONE + + -- XXX Theoretically this code can do 4 times faster if GHC generates + -- optimal code. If we use just "(cksum' == patHash)" condition it goes + -- 4x faster, as soon as we add the "RB.unsafeEqArray rb v" condition + -- the generated code changes drastically and becomes 4x slower. Need + -- to investigate what is going on with GHC. + {-# INLINE go1 #-} + go1 !_ !cksum !rh st !acc = do + res <- step (adaptState gst) st + case res of + Yield x s -> do + old <- liftIO $ peek rh + let cksum' = deltaCksum cksum old x + acc' <- fstep acc old + + if (cksum' == patHash) + then do + rh' <- liftIO (RB.unsafeInsert rb rh x) + go2 SPEC cksum' rh' s acc' + else do + rh' <- liftIO (RB.unsafeInsert rb rh x) + go1 SPEC cksum' rh' s acc' + Skip s -> go1 SPEC cksum rh s acc + Stop -> do + acc' <- RB.unsafeFoldRingFullM rh fstep acc rb + done acc' >>= \r -> return $ Yield r GO_DONE + + go2 !_ !cksum' !rh' s !acc' = do + if RB.unsafeEqArray rb rh' patArr + then do + r <- done acc' + return $ Yield r (GO_KARP_RABIN s rb rhead) + else go1 SPEC cksum' rh' s acc' + + stepOuter gst (GO_EMPTY_PAT st) = do + res <- step (adaptState gst) st + case res of + Yield x s -> do + acc <- initial + acc' <- fstep acc x + done acc' >>= \r -> return $ Yield r (GO_EMPTY_PAT s) + Skip s -> return $ Skip (GO_EMPTY_PAT s) + Stop -> return Stop + + stepOuter _ GO_DONE = return Stop + +{-# INLINE_NORMAL splitSuffixOn #-} +splitSuffixOn + :: forall m a b. (MonadIO m, Storable a, Enum a, Eq a) + => Bool + -> Array a + -> Fold m a b + -> Stream m a + -> Stream m b +splitSuffixOn withSep patArr@Array{..} (Fold fstep initial done) + (Stream step state) = + Stream stepOuter GO_START + + where + + patLen = A.length patArr + maxIndex = patLen - 1 + elemBits = sizeOf (undefined :: a) * 8 + + {-# INLINE_LATE stepOuter #-} + stepOuter _ GO_START = + if patLen == 0 + then return $ Skip $ GO_EMPTY_PAT state + else if patLen == 1 + then do + r <- liftIO $ (A.unsafeIndexIO patArr 0) + return $ Skip $ GO_SINGLE_PAT state r + else if sizeOf (undefined :: a) * patLen + <= sizeOf (undefined :: Word) + then return $ Skip $ GO_SHORT_PAT state + else do + (rb, rhead) <- liftIO $ RB.new patLen + return $ Skip $ GO_KARP_RABIN state rb rhead + + stepOuter gst (GO_SINGLE_PAT stt pat) = do + -- This first part is the only difference between splitOn and + -- splitSuffixOn. + -- If the last element is a separator do not issue a blank segment. + res <- step (adaptState gst) stt + case res of + Yield x s -> do + acc <- initial + if pat == x + then do + acc' <- if withSep then fstep acc x else return acc + done acc' >>= \r -> return $ Yield r (GO_SINGLE_PAT s pat) + else fstep acc x >>= go SPEC s + Skip s -> return $ Skip $ (GO_SINGLE_PAT s pat) + Stop -> return Stop + + where + + -- This is identical for splitOn and splitSuffixOn + go !_ st !acc = do + res <- step (adaptState gst) st + case res of + Yield x s -> do + if pat == x + then do + acc' <- if withSep then fstep acc x else return acc + r <- done acc' + return $ Yield r (GO_SINGLE_PAT s pat) + else fstep acc x >>= go SPEC s + Skip s -> go SPEC s acc + Stop -> done acc >>= \r -> return $ Yield r GO_DONE + + stepOuter gst (GO_SHORT_PAT stt) = do + + -- Call "initial" only if the stream yields an element, otherwise we + -- may call "initial" but never yield anything. initial may produce a + -- side effect, therefore we will end up doing and discard a side + -- effect. + + let idx = 0 + let wrd = 0 + res <- step (adaptState gst) stt + case res of + Yield x s -> do + acc <- initial + let wrd' = addToWord wrd x + acc' <- if withSep then fstep acc x else return acc + if idx == maxIndex + then do + if wrd' .&. mask == patWord + then done acc' >>= \r -> return $ Yield r (GO_SHORT_PAT s) + else go0 SPEC (idx + 1) wrd' s acc' + else go0 SPEC (idx + 1) wrd' s acc' + Skip s -> return $ Skip (GO_SHORT_PAT s) + Stop -> return Stop + + where + + mask :: Word + mask = (1 `shiftL` (elemBits * patLen)) - 1 + + addToWord wrd a = (wrd `shiftL` elemBits) .|. fromIntegral (fromEnum a) + + patWord :: Word + patWord = mask .&. A.foldl' addToWord 0 patArr + + go0 !_ !idx wrd st !acc = do + res <- step (adaptState gst) st + case res of + Yield x s -> do + let wrd' = addToWord wrd x + acc' <- if withSep then fstep acc x else return acc + if idx == maxIndex + then do + if wrd' .&. mask == patWord + then do + r <- done acc' + return $ Yield r (GO_SHORT_PAT s) + else go1 SPEC wrd' s acc' + else go0 SPEC (idx + 1) wrd' s acc' + Skip s -> go0 SPEC idx wrd s acc + Stop -> do + if (idx == maxIndex) && (wrd .&. mask == patWord) + then return Stop + else do + acc' <- if idx /= 0 && not withSep + then go2 wrd idx acc + else return acc + done acc' >>= \r -> return $ Yield r GO_DONE + + {-# INLINE go1 #-} + go1 !_ wrd st !acc = do + res <- step (adaptState gst) st + case res of + Yield x s -> do + let wrd' = addToWord wrd x + old = (mask .&. wrd) `shiftR` (elemBits * (patLen - 1)) + acc' <- if withSep + then fstep acc x + else fstep acc (toEnum $ fromIntegral old) + if wrd' .&. mask == patWord + then done acc' >>= \r -> return $ Yield r (GO_SHORT_PAT s) + else go1 SPEC wrd' s acc' + Skip s -> go1 SPEC wrd s acc + Stop -> + -- If the last sequence is a separator do not issue a blank + -- segment. + if wrd .&. mask == patWord + then return Stop + else do + acc' <- if withSep + then return acc + else go2 wrd patLen acc + done acc' >>= \r -> return $ Yield r GO_DONE + + go2 !wrd !n !acc | n > 0 = do + let old = (mask .&. wrd) `shiftR` (elemBits * (n - 1)) + fstep acc (toEnum $ fromIntegral old) >>= go2 wrd (n - 1) + go2 _ _ acc = return acc + + stepOuter gst (GO_KARP_RABIN stt rb rhead) = do + let idx = 0 + res <- step (adaptState gst) stt + case res of + Yield x s -> do + acc <- initial + acc' <- if withSep then fstep acc x else return acc + rh' <- liftIO (RB.unsafeInsert rb rhead x) + if idx == maxIndex + then do + let fold = RB.unsafeFoldRing (RB.ringBound rb) + let !ringHash = fold addCksum 0 rb + if ringHash == patHash + then go2 SPEC ringHash rh' s acc' + else go0 SPEC (idx + 1) rh' s acc' + else go0 SPEC (idx + 1) rh' s acc' + Skip s -> return $ Skip (GO_KARP_RABIN s rb rhead) + Stop -> return Stop + + where + + k = 2891336453 :: Word32 + coeff = k ^ patLen + addCksum cksum a = cksum * k + fromIntegral (fromEnum a) + deltaCksum cksum old new = + addCksum cksum new - coeff * fromIntegral (fromEnum old) + + -- XXX shall we use a random starting hash or 1 instead of 0? + patHash = A.foldl' addCksum 0 patArr + + -- rh == ringHead + go0 !_ !idx !rh st !acc = do + res <- step (adaptState gst) st + case res of + Yield x s -> do + acc' <- if withSep then fstep acc x else return acc + rh' <- liftIO (RB.unsafeInsert rb rh x) + if idx == maxIndex + then do + let fold = RB.unsafeFoldRing (RB.ringBound rb) + let !ringHash = fold addCksum 0 rb + if ringHash == patHash + then go2 SPEC ringHash rh' s acc' + else go1 SPEC ringHash rh' s acc' + else go0 SPEC (idx + 1) rh' s acc' + Skip s -> go0 SPEC idx rh s acc + Stop -> do + -- do not issue a blank segment when we end at pattern + if (idx == maxIndex) && RB.unsafeEqArray rb rh patArr + then return Stop + else do + !acc' <- if idx /= 0 && not withSep + then RB.unsafeFoldRingM rh fstep acc rb + else return acc + done acc' >>= \r -> return $ Yield r GO_DONE + + -- XXX Theoretically this code can do 4 times faster if GHC generates + -- optimal code. If we use just "(cksum' == patHash)" condition it goes + -- 4x faster, as soon as we add the "RB.unsafeEqArray rb v" condition + -- the generated code changes drastically and becomes 4x slower. Need + -- to investigate what is going on with GHC. + {-# INLINE go1 #-} + go1 !_ !cksum !rh st !acc = do + res <- step (adaptState gst) st + case res of + Yield x s -> do + old <- liftIO $ peek rh + let cksum' = deltaCksum cksum old x + acc' <- if withSep + then fstep acc x + else fstep acc old + + if (cksum' == patHash) + then do + rh' <- liftIO (RB.unsafeInsert rb rh x) + go2 SPEC cksum' rh' s acc' + else do + rh' <- liftIO (RB.unsafeInsert rb rh x) + go1 SPEC cksum' rh' s acc' + Skip s -> go1 SPEC cksum rh s acc + Stop -> do + if RB.unsafeEqArray rb rh patArr + then return Stop + else do + acc' <- if withSep + then return acc + else RB.unsafeFoldRingFullM rh fstep acc rb + done acc' >>= \r -> return $ Yield r GO_DONE + + go2 !_ !cksum' !rh' s !acc' = do + if RB.unsafeEqArray rb rh' patArr + then do + r <- done acc' + return $ Yield r (GO_KARP_RABIN s rb rhead) + else go1 SPEC cksum' rh' s acc' + + stepOuter gst (GO_EMPTY_PAT st) = do + res <- step (adaptState gst) st + case res of + Yield x s -> do + acc <- initial + acc' <- fstep acc x + done acc' >>= \r -> return $ Yield r (GO_EMPTY_PAT s) + Skip s -> return $ Skip (GO_EMPTY_PAT s) + Stop -> return Stop + + stepOuter _ GO_DONE = return Stop + +data SplitState s arr + = SplitInitial s + | SplitBuffering s arr + | SplitSplitting s arr + | SplitYielding arr (SplitState s arr) + | SplitFinishing + +-- XXX An alternative approach would be to use a partial fold (Fold m a b) to +-- split using a splitBy like combinator. The Fold would consume upto the +-- separator and return any leftover which can then be fed to the next fold. +-- +-- We can revisit this once we have partial folds/parsers. +-- +-- | Performs infix separator style splitting. +{-# INLINE_NORMAL splitInnerBy #-} +splitInnerBy + :: Monad m + => (f a -> m (f a, Maybe (f a))) -- splitter + -> (f a -> f a -> m (f a)) -- joiner + -> Stream m (f a) + -> Stream m (f a) +splitInnerBy splitter joiner (Stream step1 state1) = + (Stream step (SplitInitial state1)) + + where + + {-# INLINE_LATE step #-} + step gst (SplitInitial st) = do + r <- step1 gst st + case r of + Yield x s -> do + (x1, mx2) <- splitter x + return $ case mx2 of + Nothing -> Skip (SplitBuffering s x1) + Just x2 -> Skip (SplitYielding x1 (SplitSplitting s x2)) + Skip s -> return $ Skip (SplitInitial s) + Stop -> return $ Stop + + step gst (SplitBuffering st buf) = do + r <- step1 gst st + case r of + Yield x s -> do + (x1, mx2) <- splitter x + buf' <- joiner buf x1 + return $ case mx2 of + Nothing -> Skip (SplitBuffering s buf') + Just x2 -> Skip (SplitYielding buf' (SplitSplitting s x2)) + Skip s -> return $ Skip (SplitBuffering s buf) + Stop -> return $ Skip (SplitYielding buf SplitFinishing) + + step _ (SplitSplitting st buf) = do + (x1, mx2) <- splitter buf + return $ case mx2 of + Nothing -> Skip $ SplitBuffering st x1 + Just x2 -> Skip $ SplitYielding x1 (SplitSplitting st x2) + + step _ (SplitYielding x next) = return $ Yield x next + step _ SplitFinishing = return $ Stop + +-- | Performs infix separator style splitting. +{-# INLINE_NORMAL splitInnerBySuffix #-} +splitInnerBySuffix + :: (Monad m, Eq (f a), Monoid (f a)) + => (f a -> m (f a, Maybe (f a))) -- splitter + -> (f a -> f a -> m (f a)) -- joiner + -> Stream m (f a) + -> Stream m (f a) +splitInnerBySuffix splitter joiner (Stream step1 state1) = + (Stream step (SplitInitial state1)) + + where + + {-# INLINE_LATE step #-} + step gst (SplitInitial st) = do + r <- step1 gst st + case r of + Yield x s -> do + (x1, mx2) <- splitter x + return $ case mx2 of + Nothing -> Skip (SplitBuffering s x1) + Just x2 -> Skip (SplitYielding x1 (SplitSplitting s x2)) + Skip s -> return $ Skip (SplitInitial s) + Stop -> return $ Stop + + step gst (SplitBuffering st buf) = do + r <- step1 gst st + case r of + Yield x s -> do + (x1, mx2) <- splitter x + buf' <- joiner buf x1 + return $ case mx2 of + Nothing -> Skip (SplitBuffering s buf') + Just x2 -> Skip (SplitYielding buf' (SplitSplitting s x2)) + Skip s -> return $ Skip (SplitBuffering s buf) + Stop -> return $ + if buf == mempty + then Stop + else Skip (SplitYielding buf SplitFinishing) + + step _ (SplitSplitting st buf) = do + (x1, mx2) <- splitter buf + return $ case mx2 of + Nothing -> Skip $ SplitBuffering st x1 + Just x2 -> Skip $ SplitYielding x1 (SplitSplitting st x2) + + step _ (SplitYielding x next) = return $ Yield x next + step _ SplitFinishing = return $ Stop + +------------------------------------------------------------------------------ +-- 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 = drain . mapM m + +------------------------------------------------------------------------------- +-- Stream transformations using Unfolds +------------------------------------------------------------------------------- + +-- Define a unique structure to use in inspection testing +data ConcatMapUState o i = + ConcatMapUOuter o + | ConcatMapUInner o i + +-- | @concatMapU unfold stream@ uses @unfold@ to map the input stream elements +-- to streams and then flattens the generated streams into a single output +-- stream. + +-- This is like 'concatMap' but uses an unfold with an explicit state to +-- generate the stream instead of a 'Stream' type generator. This allows better +-- optimization via fusion. This can be many times more efficient than +-- 'concatMap'. + +{-# INLINE_NORMAL concatMapU #-} +concatMapU :: Monad m => Unfold m a b -> Stream m a -> Stream m b +concatMapU (Unfold istep inject) (Stream ostep ost) = + Stream step (ConcatMapUOuter ost) + where + {-# INLINE_LATE step #-} + step gst (ConcatMapUOuter o) = do + r <- ostep (adaptState gst) o + case r of + Yield a o' -> do + i <- inject a + i `seq` return (Skip (ConcatMapUInner o' i)) + Skip o' -> return $ Skip (ConcatMapUOuter o') + Stop -> return $ Stop + + step _ (ConcatMapUInner o i) = do + r <- istep i + return $ case r of + Yield x i' -> Yield x (ConcatMapUInner o i') + Skip i' -> Skip (ConcatMapUInner o i') + Stop -> Skip (ConcatMapUOuter o) + +data ConcatUnfoldInterleaveState o i = + ConcatUnfoldInterleaveOuter o [i] + | ConcatUnfoldInterleaveInner o [i] + | ConcatUnfoldInterleaveInnerL [i] [i] + | ConcatUnfoldInterleaveInnerR [i] [i] + +-- XXX use arrays to store state instead of lists. +-- XXX In general we can use different scheduling strategies e.g. how to +-- schedule the outer vs inner loop or assigning weights to different streams +-- or outer and inner loops. + +-- After a yield, switch to the next stream. Do not switch streams on Skip. +-- Yield from outer stream switches to the inner stream. +-- +-- There are two choices here, (1) exhaust the outer stream first and then +-- start yielding from the inner streams, this is much simpler to implement, +-- (2) yield at least one element from an inner stream before going back to +-- outer stream and opening the next stream from it. +-- +-- Ideally, we need some scheduling bias to inner streams vs outer stream. +-- Maybe we can configure the behavior. +-- +{-# INLINE_NORMAL concatUnfoldInterleave #-} +concatUnfoldInterleave :: Monad m => Unfold m a b -> Stream m a -> Stream m b +concatUnfoldInterleave (Unfold istep inject) (Stream ostep ost) = + Stream step (ConcatUnfoldInterleaveOuter ost []) + where + {-# INLINE_LATE step #-} + step gst (ConcatUnfoldInterleaveOuter o ls) = do + r <- ostep (adaptState gst) o + case r of + Yield a o' -> do + i <- inject a + i `seq` return (Skip (ConcatUnfoldInterleaveInner o' (i : ls))) + Skip o' -> return $ Skip (ConcatUnfoldInterleaveOuter o' ls) + Stop -> return $ Skip (ConcatUnfoldInterleaveInnerL ls []) + + step _ (ConcatUnfoldInterleaveInner _ []) = undefined + step _ (ConcatUnfoldInterleaveInner o (st:ls)) = do + r <- istep st + return $ case r of + Yield x s -> Yield x (ConcatUnfoldInterleaveOuter o (s:ls)) + Skip s -> Skip (ConcatUnfoldInterleaveInner o (s:ls)) + Stop -> Skip (ConcatUnfoldInterleaveOuter o ls) + + step _ (ConcatUnfoldInterleaveInnerL [] []) = return Stop + step _ (ConcatUnfoldInterleaveInnerL [] rs) = + return $ Skip (ConcatUnfoldInterleaveInnerR [] rs) + + step _ (ConcatUnfoldInterleaveInnerL (st:ls) rs) = do + r <- istep st + return $ case r of + Yield x s -> Yield x (ConcatUnfoldInterleaveInnerL ls (s:rs)) + Skip s -> Skip (ConcatUnfoldInterleaveInnerL (s:ls) rs) + Stop -> Skip (ConcatUnfoldInterleaveInnerL ls rs) + + step _ (ConcatUnfoldInterleaveInnerR [] []) = return Stop + step _ (ConcatUnfoldInterleaveInnerR ls []) = + return $ Skip (ConcatUnfoldInterleaveInnerL ls []) + + step _ (ConcatUnfoldInterleaveInnerR ls (st:rs)) = do + r <- istep st + return $ case r of + Yield x s -> Yield x (ConcatUnfoldInterleaveInnerR (s:ls) rs) + Skip s -> Skip (ConcatUnfoldInterleaveInnerR ls (s:rs)) + Stop -> Skip (ConcatUnfoldInterleaveInnerR ls rs) + +-- XXX In general we can use different scheduling strategies e.g. how to +-- schedule the outer vs inner loop or assigning weights to different streams +-- or outer and inner loops. +-- +-- This could be inefficient if the tasks are too small. +-- +-- Compared to concatUnfoldInterleave this one switches streams on Skips. +-- +{-# INLINE_NORMAL concatUnfoldRoundrobin #-} +concatUnfoldRoundrobin :: Monad m => Unfold m a b -> Stream m a -> Stream m b +concatUnfoldRoundrobin (Unfold istep inject) (Stream ostep ost) = + Stream step (ConcatUnfoldInterleaveOuter ost []) + where + {-# INLINE_LATE step #-} + step gst (ConcatUnfoldInterleaveOuter o ls) = do + r <- ostep (adaptState gst) o + case r of + Yield a o' -> do + i <- inject a + i `seq` return (Skip (ConcatUnfoldInterleaveInner o' (i : ls))) + Skip o' -> return $ Skip (ConcatUnfoldInterleaveInner o' ls) + Stop -> return $ Skip (ConcatUnfoldInterleaveInnerL ls []) + + step _ (ConcatUnfoldInterleaveInner o []) = + return $ Skip (ConcatUnfoldInterleaveOuter o []) + + step _ (ConcatUnfoldInterleaveInner o (st:ls)) = do + r <- istep st + return $ case r of + Yield x s -> Yield x (ConcatUnfoldInterleaveOuter o (s:ls)) + Skip s -> Skip (ConcatUnfoldInterleaveOuter o (s:ls)) + Stop -> Skip (ConcatUnfoldInterleaveOuter o ls) + + step _ (ConcatUnfoldInterleaveInnerL [] []) = return Stop + step _ (ConcatUnfoldInterleaveInnerL [] rs) = + return $ Skip (ConcatUnfoldInterleaveInnerR [] rs) + + step _ (ConcatUnfoldInterleaveInnerL (st:ls) rs) = do + r <- istep st + return $ case r of + Yield x s -> Yield x (ConcatUnfoldInterleaveInnerL ls (s:rs)) + Skip s -> Skip (ConcatUnfoldInterleaveInnerL ls (s:rs)) + Stop -> Skip (ConcatUnfoldInterleaveInnerL ls rs) + + step _ (ConcatUnfoldInterleaveInnerR [] []) = return Stop + step _ (ConcatUnfoldInterleaveInnerR ls []) = + return $ Skip (ConcatUnfoldInterleaveInnerL ls []) + + step _ (ConcatUnfoldInterleaveInnerR ls (st:rs)) = do + r <- istep st + return $ case r of + Yield x s -> Yield x (ConcatUnfoldInterleaveInnerR (s:ls) rs) + Skip s -> Skip (ConcatUnfoldInterleaveInnerR (s:ls) rs) + Stop -> Skip (ConcatUnfoldInterleaveInnerR ls rs) + +data AppendState s1 s2 = AppendFirst s1 | AppendSecond s2 + +-- Note that this could be much faster compared to the CPS stream. However, as +-- the number of streams being composed increases this may become expensive. +-- Need to see where the breaking point is between the two. +-- +{-# INLINE_NORMAL append #-} +append :: Monad m => Stream m a -> Stream m a -> Stream m a +append (Stream step1 state1) (Stream step2 state2) = + Stream step (AppendFirst state1) + + where + + {-# INLINE_LATE step #-} + step gst (AppendFirst st) = do + r <- step1 gst st + return $ case r of + Yield a s -> Yield a (AppendFirst s) + Skip s -> Skip (AppendFirst s) + Stop -> Skip (AppendSecond state2) + + step gst (AppendSecond st) = do + r <- step2 gst st + return $ case r of + Yield a s -> Yield a (AppendSecond s) + Skip s -> Skip (AppendSecond s) + Stop -> Stop + +data InterleaveState s1 s2 = InterleaveFirst s1 s2 | InterleaveSecond s1 s2 + | InterleaveSecondOnly s2 | InterleaveFirstOnly s1 + +{-# INLINE_NORMAL interleave #-} +interleave :: Monad m => Stream m a -> Stream m a -> Stream m a +interleave (Stream step1 state1) (Stream step2 state2) = + Stream step (InterleaveFirst state1 state2) + + where + + {-# INLINE_LATE step #-} + step gst (InterleaveFirst st1 st2) = do + r <- step1 gst st1 + return $ case r of + Yield a s -> Yield a (InterleaveSecond s st2) + Skip s -> Skip (InterleaveFirst s st2) + Stop -> Skip (InterleaveSecondOnly st2) + + step gst (InterleaveSecond st1 st2) = do + r <- step2 gst st2 + return $ case r of + Yield a s -> Yield a (InterleaveFirst st1 s) + Skip s -> Skip (InterleaveSecond st1 s) + Stop -> Skip (InterleaveFirstOnly st1) + + step gst (InterleaveFirstOnly st1) = do + r <- step1 gst st1 + return $ case r of + Yield a s -> Yield a (InterleaveFirstOnly s) + Skip s -> Skip (InterleaveFirstOnly s) + Stop -> Stop + + step gst (InterleaveSecondOnly st2) = do + r <- step2 gst st2 + return $ case r of + Yield a s -> Yield a (InterleaveSecondOnly s) + Skip s -> Skip (InterleaveSecondOnly s) + Stop -> Stop + +{-# INLINE_NORMAL interleaveMin #-} +interleaveMin :: Monad m => Stream m a -> Stream m a -> Stream m a +interleaveMin (Stream step1 state1) (Stream step2 state2) = + Stream step (InterleaveFirst state1 state2) + + where + + {-# INLINE_LATE step #-} + step gst (InterleaveFirst st1 st2) = do + r <- step1 gst st1 + return $ case r of + Yield a s -> Yield a (InterleaveSecond s st2) + Skip s -> Skip (InterleaveFirst s st2) + Stop -> Stop + + step gst (InterleaveSecond st1 st2) = do + r <- step2 gst st2 + return $ case r of + Yield a s -> Yield a (InterleaveFirst st1 s) + Skip s -> Skip (InterleaveSecond st1 s) + Stop -> Stop + + step _ (InterleaveFirstOnly _) = undefined + step _ (InterleaveSecondOnly _) = undefined + +{-# INLINE_NORMAL interleaveSuffix #-} +interleaveSuffix :: Monad m => Stream m a -> Stream m a -> Stream m a +interleaveSuffix (Stream step1 state1) (Stream step2 state2) = + Stream step (InterleaveFirst state1 state2) + + where + + {-# INLINE_LATE step #-} + step gst (InterleaveFirst st1 st2) = do + r <- step1 gst st1 + return $ case r of + Yield a s -> Yield a (InterleaveSecond s st2) + Skip s -> Skip (InterleaveFirst s st2) + Stop -> Stop + + step gst (InterleaveSecond st1 st2) = do + r <- step2 gst st2 + return $ case r of + Yield a s -> Yield a (InterleaveFirst st1 s) + Skip s -> Skip (InterleaveSecond st1 s) + Stop -> Skip (InterleaveFirstOnly st1) + + step gst (InterleaveFirstOnly st1) = do + r <- step1 gst st1 + return $ case r of + Yield a s -> Yield a (InterleaveFirstOnly s) + Skip s -> Skip (InterleaveFirstOnly s) + Stop -> Stop + + step _ (InterleaveSecondOnly _) = undefined + +data InterleaveInfixState s1 s2 a + = InterleaveInfixFirst s1 s2 + | InterleaveInfixSecondBuf s1 s2 + | InterleaveInfixSecondYield s1 s2 a + | InterleaveInfixFirstYield s1 s2 a + | InterleaveInfixFirstOnly s1 + +{-# INLINE_NORMAL interleaveInfix #-} +interleaveInfix :: Monad m => Stream m a -> Stream m a -> Stream m a +interleaveInfix (Stream step1 state1) (Stream step2 state2) = + Stream step (InterleaveInfixFirst state1 state2) + + where + + {-# INLINE_LATE step #-} + step gst (InterleaveInfixFirst st1 st2) = do + r <- step1 gst st1 + return $ case r of + Yield a s -> Yield a (InterleaveInfixSecondBuf s st2) + Skip s -> Skip (InterleaveInfixFirst s st2) + Stop -> Stop + + step gst (InterleaveInfixSecondBuf st1 st2) = do + r <- step2 gst st2 + return $ case r of + Yield a s -> Skip (InterleaveInfixSecondYield st1 s a) + Skip s -> Skip (InterleaveInfixSecondBuf st1 s) + Stop -> Skip (InterleaveInfixFirstOnly st1) + + step gst (InterleaveInfixSecondYield st1 st2 x) = do + r <- step1 gst st1 + return $ case r of + Yield a s -> Yield x (InterleaveInfixFirstYield s st2 a) + Skip s -> Skip (InterleaveInfixSecondYield s st2 x) + Stop -> Stop + + step _ (InterleaveInfixFirstYield st1 st2 x) = do + return $ Yield x (InterleaveInfixSecondBuf st1 st2) + + step gst (InterleaveInfixFirstOnly st1) = do + r <- step1 gst st1 + return $ case r of + Yield a s -> Yield a (InterleaveInfixFirstOnly s) + Skip s -> Skip (InterleaveInfixFirstOnly s) + Stop -> Stop + +{-# INLINE_NORMAL roundRobin #-} +roundRobin :: Monad m => Stream m a -> Stream m a -> Stream m a +roundRobin (Stream step1 state1) (Stream step2 state2) = + Stream step (InterleaveFirst state1 state2) + + where + + {-# INLINE_LATE step #-} + step gst (InterleaveFirst st1 st2) = do + r <- step1 gst st1 + return $ case r of + Yield a s -> Yield a (InterleaveSecond s st2) + Skip s -> Skip (InterleaveSecond s st2) + Stop -> Skip (InterleaveSecondOnly st2) + + step gst (InterleaveSecond st1 st2) = do + r <- step2 gst st2 + return $ case r of + Yield a s -> Yield a (InterleaveFirst st1 s) + Skip s -> Skip (InterleaveFirst st1 s) + Stop -> Skip (InterleaveFirstOnly st1) + + step gst (InterleaveSecondOnly st2) = do + r <- step2 gst st2 + return $ case r of + Yield a s -> Yield a (InterleaveSecondOnly s) + Skip s -> Skip (InterleaveSecondOnly s) + Stop -> Stop + + step gst (InterleaveFirstOnly st1) = do + r <- step1 gst st1 + return $ case r of + Yield a s -> Yield a (InterleaveFirstOnly s) + Skip s -> Skip (InterleaveFirstOnly s) + Stop -> Stop + +data ICUState s1 s2 i1 i2 = + ICUFirst s1 s2 + | ICUSecond s1 s2 + | ICUSecondOnly s2 + | ICUFirstOnly s1 + | ICUFirstInner s1 s2 i1 + | ICUSecondInner s1 s2 i2 + | ICUFirstOnlyInner s1 i1 + | ICUSecondOnlyInner s2 i2 + +-- | Interleave streams (full streams, not the elements) unfolded from two +-- input streams and concat. Stop when the first stream stops. If the second +-- stream ends before the first one then first stream still keeps running alone +-- without any interleaving with the second stream. +-- +-- [a1, a2, ... an] [b1, b2 ...] +-- => [streamA1, streamA2, ... streamAn] [streamB1, streamB2, ...] +-- => [streamA1, streamB1, streamA2...StreamAn, streamBn] +-- => [a11, a12, ...a1j, b11, b12, ...b1k, a21, a22, ...] +-- +{-# INLINE_NORMAL gintercalateSuffix #-} +gintercalateSuffix + :: Monad m + => Unfold m a c -> Stream m a -> Unfold m b c -> Stream m b -> Stream m c +gintercalateSuffix + (Unfold istep1 inject1) (Stream step1 state1) + (Unfold istep2 inject2) (Stream step2 state2) = + Stream step (ICUFirst state1 state2) + + where + + {-# INLINE_LATE step #-} + step gst (ICUFirst s1 s2) = do + r <- step1 (adaptState gst) s1 + case r of + Yield a s -> do + i <- inject1 a + i `seq` return (Skip (ICUFirstInner s s2 i)) + Skip s -> return $ Skip (ICUFirst s s2) + Stop -> return Stop + + step gst (ICUFirstOnly s1) = do + r <- step1 (adaptState gst) s1 + case r of + Yield a s -> do + i <- inject1 a + i `seq` return (Skip (ICUFirstOnlyInner s i)) + Skip s -> return $ Skip (ICUFirstOnly s) + Stop -> return Stop + + step _ (ICUFirstInner s1 s2 i1) = do + r <- istep1 i1 + return $ case r of + Yield x i' -> Yield x (ICUFirstInner s1 s2 i') + Skip i' -> Skip (ICUFirstInner s1 s2 i') + Stop -> Skip (ICUSecond s1 s2) + + step _ (ICUFirstOnlyInner s1 i1) = do + r <- istep1 i1 + return $ case r of + Yield x i' -> Yield x (ICUFirstOnlyInner s1 i') + Skip i' -> Skip (ICUFirstOnlyInner s1 i') + Stop -> Skip (ICUFirstOnly s1) + + step gst (ICUSecond s1 s2) = do + r <- step2 (adaptState gst) s2 + case r of + Yield a s -> do + i <- inject2 a + i `seq` return (Skip (ICUSecondInner s1 s i)) + Skip s -> return $ Skip (ICUSecond s1 s) + Stop -> return $ Skip (ICUFirstOnly s1) + + step _ (ICUSecondInner s1 s2 i2) = do + r <- istep2 i2 + return $ case r of + Yield x i' -> Yield x (ICUSecondInner s1 s2 i') + Skip i' -> Skip (ICUSecondInner s1 s2 i') + Stop -> Skip (ICUFirst s1 s2) + + step _ (ICUSecondOnly _s2) = undefined + step _ (ICUSecondOnlyInner _s2 _i2) = undefined + +data InterposeSuffixState s1 i1 = + InterposeSuffixFirst s1 + -- | InterposeSuffixFirstYield s1 i1 + | InterposeSuffixFirstInner s1 i1 + | InterposeSuffixSecond s1 + +-- Note that if an unfolded layer turns out to be nil we still emit the +-- separator effect. An alternate behavior could be to emit the separator +-- effect only if at least one element has been yielded by the unfolding. +-- However, that becomes a bit complicated, so we have chosen the former +-- behvaior for now. +{-# INLINE_NORMAL interposeSuffix #-} +interposeSuffix + :: Monad m + => m c -> Unfold m b c -> Stream m b -> Stream m c +interposeSuffix + action + (Unfold istep1 inject1) (Stream step1 state1) = + Stream step (InterposeSuffixFirst state1) + + where + + {-# INLINE_LATE step #-} + step gst (InterposeSuffixFirst s1) = do + r <- step1 (adaptState gst) s1 + case r of + Yield a s -> do + i <- inject1 a + i `seq` return (Skip (InterposeSuffixFirstInner s i)) + -- i `seq` return (Skip (InterposeSuffixFirstYield s i)) + Skip s -> return $ Skip (InterposeSuffixFirst s) + Stop -> return Stop + + {- + step _ (InterposeSuffixFirstYield s1 i1) = do + r <- istep1 i1 + return $ case r of + Yield x i' -> Yield x (InterposeSuffixFirstInner s1 i') + Skip i' -> Skip (InterposeSuffixFirstYield s1 i') + Stop -> Skip (InterposeSuffixFirst s1) + -} + + step _ (InterposeSuffixFirstInner s1 i1) = do + r <- istep1 i1 + return $ case r of + Yield x i' -> Yield x (InterposeSuffixFirstInner s1 i') + Skip i' -> Skip (InterposeSuffixFirstInner s1 i') + Stop -> Skip (InterposeSuffixSecond s1) + + step _ (InterposeSuffixSecond s1) = do + r <- action + return $ Yield r (InterposeSuffixFirst s1) + +data ICALState s1 s2 i1 i2 a = + ICALFirst s1 s2 + -- | ICALFirstYield s1 s2 i1 + | ICALFirstInner s1 s2 i1 + | ICALFirstOnly s1 + | ICALFirstOnlyInner s1 i1 + | ICALSecondInject s1 s2 + | ICALFirstInject s1 s2 i2 + -- | ICALFirstBuf s1 s2 i1 i2 + | ICALSecondInner s1 s2 i1 i2 + -- -- | ICALSecondInner s1 s2 i1 i2 a + -- -- | ICALFirstResume s1 s2 i1 i2 a + +-- | Interleave streams (full streams, not the elements) unfolded from two +-- input streams and concat. Stop when the first stream stops. If the second +-- stream ends before the first one then first stream still keeps running alone +-- without any interleaving with the second stream. +-- +-- [a1, a2, ... an] [b1, b2 ...] +-- => [streamA1, streamA2, ... streamAn] [streamB1, streamB2, ...] +-- => [streamA1, streamB1, streamA2...StreamAn, streamBn] +-- => [a11, a12, ...a1j, b11, b12, ...b1k, a21, a22, ...] +-- +{-# INLINE_NORMAL gintercalate #-} +gintercalate + :: Monad m + => Unfold m a c -> Stream m a -> Unfold m b c -> Stream m b -> Stream m c +gintercalate + (Unfold istep1 inject1) (Stream step1 state1) + (Unfold istep2 inject2) (Stream step2 state2) = + Stream step (ICALFirst state1 state2) + + where + + {-# INLINE_LATE step #-} + step gst (ICALFirst s1 s2) = do + r <- step1 (adaptState gst) s1 + case r of + Yield a s -> do + i <- inject1 a + i `seq` return (Skip (ICALFirstInner s s2 i)) + -- i `seq` return (Skip (ICALFirstYield s s2 i)) + Skip s -> return $ Skip (ICALFirst s s2) + Stop -> return Stop + + {- + step _ (ICALFirstYield s1 s2 i1) = do + r <- istep1 i1 + return $ case r of + Yield x i' -> Yield x (ICALFirstInner s1 s2 i') + Skip i' -> Skip (ICALFirstYield s1 s2 i') + Stop -> Skip (ICALFirst s1 s2) + -} + + step _ (ICALFirstInner s1 s2 i1) = do + r <- istep1 i1 + return $ case r of + Yield x i' -> Yield x (ICALFirstInner s1 s2 i') + Skip i' -> Skip (ICALFirstInner s1 s2 i') + Stop -> Skip (ICALSecondInject s1 s2) + + step gst (ICALFirstOnly s1) = do + r <- step1 (adaptState gst) s1 + case r of + Yield a s -> do + i <- inject1 a + i `seq` return (Skip (ICALFirstOnlyInner s i)) + Skip s -> return $ Skip (ICALFirstOnly s) + Stop -> return Stop + + step _ (ICALFirstOnlyInner s1 i1) = do + r <- istep1 i1 + return $ case r of + Yield x i' -> Yield x (ICALFirstOnlyInner s1 i') + Skip i' -> Skip (ICALFirstOnlyInner s1 i') + Stop -> Skip (ICALFirstOnly s1) + + -- We inject the second stream even before checking if the first stream + -- would yield any more elements. There is no clear choice whether we + -- should do this before or after that. Doing it after may make the state + -- machine a bit simpler though. + step gst (ICALSecondInject s1 s2) = do + r <- step2 (adaptState gst) s2 + case r of + Yield a s -> do + i <- inject2 a + i `seq` return (Skip (ICALFirstInject s1 s i)) + Skip s -> return $ Skip (ICALSecondInject s1 s) + Stop -> return $ Skip (ICALFirstOnly s1) + + step gst (ICALFirstInject s1 s2 i2) = do + r <- step1 (adaptState gst) s1 + case r of + Yield a s -> do + i <- inject1 a + i `seq` return (Skip (ICALSecondInner s s2 i i2)) + -- i `seq` return (Skip (ICALFirstBuf s s2 i i2)) + Skip s -> return $ Skip (ICALFirstInject s s2 i2) + Stop -> return Stop + + {- + step _ (ICALFirstBuf s1 s2 i1 i2) = do + r <- istep1 i1 + return $ case r of + Yield x i' -> Skip (ICALSecondInner s1 s2 i' i2 x) + Skip i' -> Skip (ICALFirstBuf s1 s2 i' i2) + Stop -> Stop + + step _ (ICALSecondInner s1 s2 i1 i2 v) = do + r <- istep2 i2 + return $ case r of + Yield x i' -> Yield x (ICALSecondInner s1 s2 i1 i' v) + Skip i' -> Skip (ICALSecondInner s1 s2 i1 i' v) + Stop -> Skip (ICALFirstResume s1 s2 i1 i2 v) + -} + + step _ (ICALSecondInner s1 s2 i1 i2) = do + r <- istep2 i2 + return $ case r of + Yield x i' -> Yield x (ICALSecondInner s1 s2 i1 i') + Skip i' -> Skip (ICALSecondInner s1 s2 i1 i') + Stop -> Skip (ICALFirstInner s1 s2 i1) + -- Stop -> Skip (ICALFirstResume s1 s2 i1 i2) + + {- + step _ (ICALFirstResume s1 s2 i1 i2 x) = do + return $ Yield x (ICALFirstInner s1 s2 i1 i2) + -} + +data InterposeState s1 i1 a = + InterposeFirst s1 + -- | InterposeFirstYield s1 i1 + | InterposeFirstInner s1 i1 + | InterposeFirstInject s1 + -- | InterposeFirstBuf s1 i1 + | InterposeSecondYield s1 i1 + -- -- | InterposeSecondYield s1 i1 a + -- -- | InterposeFirstResume s1 i1 a + +-- Note that this only interposes the pure values, we may run many effects to +-- generate those values as some effects may not generate anything (Skip). +{-# INLINE_NORMAL interpose #-} +interpose :: Monad m => m c -> Unfold m b c -> Stream m b -> Stream m c +interpose + action + (Unfold istep1 inject1) (Stream step1 state1) = + Stream step (InterposeFirst state1) + + where + + {-# INLINE_LATE step #-} + step gst (InterposeFirst s1) = do + r <- step1 (adaptState gst) s1 + case r of + Yield a s -> do + i <- inject1 a + i `seq` return (Skip (InterposeFirstInner s i)) + -- i `seq` return (Skip (InterposeFirstYield s i)) + Skip s -> return $ Skip (InterposeFirst s) + Stop -> return Stop + + {- + step _ (InterposeFirstYield s1 i1) = do + r <- istep1 i1 + return $ case r of + Yield x i' -> Yield x (InterposeFirstInner s1 i') + Skip i' -> Skip (InterposeFirstYield s1 i') + Stop -> Skip (InterposeFirst s1) + -} + + step _ (InterposeFirstInner s1 i1) = do + r <- istep1 i1 + return $ case r of + Yield x i' -> Yield x (InterposeFirstInner s1 i') + Skip i' -> Skip (InterposeFirstInner s1 i') + Stop -> Skip (InterposeFirstInject s1) + + step gst (InterposeFirstInject s1) = do + r <- step1 (adaptState gst) s1 + case r of + Yield a s -> do + i <- inject1 a + -- i `seq` return (Skip (InterposeFirstBuf s i)) + i `seq` return (Skip (InterposeSecondYield s i)) + Skip s -> return $ Skip (InterposeFirstInject s) + Stop -> return Stop + + {- + step _ (InterposeFirstBuf s1 i1) = do + r <- istep1 i1 + return $ case r of + Yield x i' -> Skip (InterposeSecondYield s1 i' x) + Skip i' -> Skip (InterposeFirstBuf s1 i') + Stop -> Stop + -} + + {- + step _ (InterposeSecondYield s1 i1 v) = do + r <- action + return $ Yield r (InterposeFirstResume s1 i1 v) + -} + step _ (InterposeSecondYield s1 i1) = do + r <- action + return $ Yield r (InterposeFirstInner s1 i1) + + {- + step _ (InterposeFirstResume s1 i1 v) = do + return $ Yield v (InterposeFirstInner s1 i1) + -} + +------------------------------------------------------------------------------ +-- Exceptions +------------------------------------------------------------------------------ + +data GbracketState s1 s2 v + = GBracketInit + | GBracketNormal s1 v + | GBracketException s2 + +-- | The most general bracketing and exception combinator. All other +-- combinators can be expressed in terms of this combinator. This can also be +-- used for cases which are not covered by the standard combinators. +-- +-- /Internal/ +-- +{-# INLINE_NORMAL gbracket #-} +gbracket + :: Monad m + => m c -- ^ before + -> (forall s. m s -> m (Either e s)) -- ^ try (exception handling) + -> (c -> m d) -- ^ after, on normal stop + -> (c -> e -> Stream m b) -- ^ on exception + -> (c -> Stream m b) -- ^ stream generator + -> Stream m b +gbracket bef exc aft fexc fnormal = + Stream step GBracketInit + + where + + {-# INLINE_LATE step #-} + step _ GBracketInit = do + r <- bef + return $ Skip $ GBracketNormal (fnormal r) r + + step gst (GBracketNormal (UnStream step1 st) v) = do + res <- exc $ step1 gst st + case res of + Right r -> case r of + Yield x s -> + return $ Yield x (GBracketNormal (Stream step1 s) v) + Skip s -> return $ Skip (GBracketNormal (Stream step1 s) v) + Stop -> aft v >> return Stop + Left e -> return $ Skip (GBracketException (fexc v e)) + step gst (GBracketException (UnStream step1 st)) = do + res <- step1 gst st + case res of + Yield x s -> return $ Yield x (GBracketException (Stream step1 s)) + Skip s -> return $ Skip (GBracketException (Stream step1 s)) + Stop -> return Stop + +-- | Create an IORef holding a finalizer that is called automatically when the +-- IORef is garbage collected. The IORef can be written to with a 'Nothing' +-- value to deactivate the finalizer. +newFinalizedIORef :: (MonadIO m, MonadBaseControl IO m) + => m a -> m (IORef (Maybe (IO ()))) +newFinalizedIORef finalizer = do + mrun <- captureMonadState + ref <- liftIO $ newIORef $ Just $ liftIO $ void $ do + _ <- runInIO mrun finalizer + return () + let finalizer1 = do + res <- readIORef ref + case res of + Nothing -> return () + Just f -> f + _ <- liftIO $ mkWeakIORef ref finalizer1 + return ref + +-- | Run the finalizer stored in an IORef and deactivate it so that it is run +-- only once. +-- +runIORefFinalizer :: MonadIO m => IORef (Maybe (IO ())) -> m () +runIORefFinalizer ref = liftIO $ do + res <- readIORef ref + case res of + Nothing -> return () + Just f -> writeIORef ref Nothing >> f + +-- | Deactivate the finalizer stored in an IORef without running it. +-- +clearIORefFinalizer :: MonadIO m => IORef (Maybe (IO ())) -> m () +clearIORefFinalizer ref = liftIO $ writeIORef ref Nothing + +data GbracketIOState s1 s2 v wref + = GBracketIOInit + | GBracketIONormal s1 v wref + | GBracketIOException s2 + +-- | Like gbracket but also uses a finalizer to make sure when the stream is +-- garbage collected we run the finalizing action. This requires a MonadIO and +-- MonadBaseControl IO constraint. +-- +-- | The most general bracketing and exception combinator. All other +-- combinators can be expressed in terms of this combinator. This can also be +-- used for cases which are not covered by the standard combinators. +-- +-- /Internal/ +-- +{-# INLINE_NORMAL gbracketIO #-} +gbracketIO + :: (MonadIO m, MonadBaseControl IO m) + => m c -- ^ before + -> (forall s. m s -> m (Either e s)) -- ^ try (exception handling) + -> (c -> m d) -- ^ after, on normal stop or GC + -> (c -> e -> Stream m b) -- ^ on exception + -> (c -> Stream m b) -- ^ stream generator + -> Stream m b +gbracketIO bef exc aft fexc fnormal = + Stream step GBracketIOInit + + where + + -- If the stream is never evaluated the "aft" action will never be + -- called. For that to occur we will need the user of this API to pass a + -- weak pointer to us. + {-# INLINE_LATE step #-} + step _ GBracketIOInit = do + r <- bef + ref <- newFinalizedIORef (aft r) + return $ Skip $ GBracketIONormal (fnormal r) r ref + + step gst (GBracketIONormal (UnStream step1 st) v ref) = do + res <- exc $ step1 gst st + case res of + Right r -> case r of + Yield x s -> + return $ Yield x (GBracketIONormal (Stream step1 s) v ref) + Skip s -> + return $ Skip (GBracketIONormal (Stream step1 s) v ref) + Stop -> do + runIORefFinalizer ref + return Stop + Left e -> do + clearIORefFinalizer ref + return $ Skip (GBracketIOException (fexc v e)) + step gst (GBracketIOException (UnStream step1 st)) = do + res <- step1 gst st + case res of + Yield x s -> + return $ Yield x (GBracketIOException (Stream step1 s)) + Skip s -> return $ Skip (GBracketIOException (Stream step1 s)) + Stop -> return Stop + +-- | Run a side effect before the stream yields its first element. +{-# INLINE_NORMAL before #-} +before :: Monad m => m b -> Stream m a -> Stream m a +before action (Stream step state) = Stream step' Nothing + + where + + {-# INLINE_LATE step' #-} + step' _ Nothing = action >> return (Skip (Just state)) + + step' gst (Just st) = do + res <- step gst st + case res of + Yield x s -> return $ Yield x (Just s) + Skip s -> return $ Skip (Just s) + Stop -> return Stop + +-- | Run a side effect whenever the stream stops normally. +{-# INLINE_NORMAL after #-} +after :: Monad m => m b -> Stream m a -> Stream m a +after action (Stream step state) = Stream step' state + + where + + {-# INLINE_LATE step' #-} + step' gst st = do + res <- step gst st + case res of + Yield x s -> return $ Yield x s + Skip s -> return $ Skip s + Stop -> action >> return Stop + +{-# INLINE_NORMAL afterIO #-} +afterIO :: (MonadIO m, MonadBaseControl IO m) + => m b -> Stream m a -> Stream m a +afterIO action (Stream step state) = Stream step' Nothing + + where + + {-# INLINE_LATE step' #-} + step' _ Nothing = do + ref <- newFinalizedIORef action + return $ Skip $ Just (state, ref) + step' gst (Just (st, ref)) = do + res <- step gst st + case res of + Yield x s -> return $ Yield x (Just (s, ref)) + Skip s -> return $ Skip (Just (s, ref)) + Stop -> do + runIORefFinalizer ref + return Stop + +-- XXX These combinators are expensive due to the call to +-- onException/handle/try on each step. Therefore, when possible, they should +-- be called in an outer loop where we perform less iterations. For example, we +-- cannot call them on each iteration in a char stream, instead we can call +-- them when doing an IO on an array. +-- +-- XXX For high performance error checks in busy streams we may need another +-- Error constructor in step. +-- +-- | Run a side effect whenever the stream aborts due to an exception. The +-- exception is not caught, simply rethrown. +{-# INLINE_NORMAL onException #-} +onException :: MonadCatch m => m b -> Stream m a -> Stream m a +onException action str = + gbracket (return ()) MC.try return + (\_ (e :: MC.SomeException) -> nilM (action >> MC.throwM e)) + (\_ -> str) + +{-# INLINE_NORMAL _onException #-} +_onException :: MonadCatch m => m b -> Stream m a -> Stream m a +_onException action (Stream step state) = Stream step' state + + where + + {-# INLINE_LATE step' #-} + step' gst st = do + res <- step gst st `MC.onException` action + case res of + Yield x s -> return $ Yield x s + Skip s -> return $ Skip s + Stop -> return Stop + +-- XXX bracket is like concatMap, it generates a stream and then flattens it. +-- Like concatMap it has 10x worse performance compared to linear fused +-- compositions. +-- +-- | Run the first action before the stream starts and remember its output, +-- generate a stream using the output, run the second action providing the +-- remembered value as an argument whenever the stream ends normally or due to +-- an exception. +{-# INLINE_NORMAL bracket #-} +bracket :: MonadCatch m => m b -> (b -> m c) -> (b -> Stream m a) -> Stream m a +bracket bef aft bet = + gbracket bef MC.try aft + (\a (e :: SomeException) -> nilM (aft a >> MC.throwM e)) bet + +{-# INLINE_NORMAL bracketIO #-} +bracketIO :: (MonadAsync m, MonadCatch m) + => m b -> (b -> m c) -> (b -> Stream m a) -> Stream m a +bracketIO bef aft bet = + gbracketIO bef MC.try aft + (\a (e :: SomeException) -> nilM (aft a >> MC.throwM e)) bet + +data BracketState s v = BracketInit | BracketRun s v + +{-# INLINE_NORMAL _bracket #-} +_bracket :: MonadCatch m => m b -> (b -> m c) -> (b -> Stream m a) -> Stream m a +_bracket bef aft bet = Stream step' BracketInit + + where + + {-# INLINE_LATE step' #-} + step' _ BracketInit = bef >>= \x -> return (Skip (BracketRun (bet x) x)) + + -- NOTE: It is important to use UnStream instead of the Stream pattern + -- here, otherwise we get huge perf degradation, see note in concatMap. + step' gst (BracketRun (UnStream step state) v) = do + -- res <- step gst state `MC.onException` aft v + res <- MC.try $ step gst state + case res of + Left (e :: SomeException) -> aft v >> MC.throwM e >> return Stop + Right r -> case r of + Yield x s -> return $ Yield x (BracketRun (Stream step s) v) + Skip s -> return $ Skip (BracketRun (Stream step s) v) + Stop -> aft v >> return Stop + +-- | Run a side effect whenever the stream stops normally or aborts due to an +-- exception. +{-# INLINE finally #-} +finally :: MonadCatch m => m b -> Stream m a -> Stream m a +-- finally action xs = after action $ onException action xs +finally action xs = bracket (return ()) (\_ -> action) (const xs) + +{-# INLINE finallyIO #-} +finallyIO :: (MonadAsync m, MonadCatch m) => m b -> Stream m a -> Stream m a +finallyIO action xs = bracketIO (return ()) (\_ -> action) (const xs) + +-- | When evaluating a stream if an exception occurs, stream evaluation aborts +-- and the specified exception handler is run with the exception as argument. +{-# INLINE_NORMAL handle #-} +handle :: (MonadCatch m, Exception e) + => (e -> Stream m a) -> Stream m a -> Stream m a +handle f str = + gbracket (return ()) MC.try return (\_ e -> f e) (\_ -> str) + +{-# INLINE_NORMAL _handle #-} +_handle :: (MonadCatch m, Exception e) + => (e -> Stream m a) -> Stream m a -> Stream m a +_handle f (Stream step state) = Stream step' (Left state) + + where + + {-# INLINE_LATE step' #-} + step' gst (Left st) = do + res <- MC.try $ step gst st + case res of + Left e -> return $ Skip $ Right (f e) + Right r -> case r of + Yield x s -> return $ Yield x (Left s) + Skip s -> return $ Skip (Left s) + Stop -> return Stop + + step' gst (Right (UnStream step1 st)) = do + res <- step1 gst st + case res of + Yield x s -> return $ Yield x (Right (Stream step1 s)) + Skip s -> return $ Skip (Right (Stream step1 s)) + Stop -> return Stop + +------------------------------------------------------------------------------- +-- General transformation +------------------------------------------------------------------------------- + +{-# INLINE_NORMAL transform #-} +transform :: Monad m => Pipe m a b -> Stream m a -> Stream m b +transform (Pipe pstep1 pstep2 pstate) (Stream step state) = + Stream step' (Consume pstate, state) + + where + + {-# INLINE_LATE step' #-} + + step' gst (Consume pst, st) = pst `seq` do + r <- step (adaptState gst) st + case r of + Yield x s -> do + res <- pstep1 pst x + case res of + Pipe.Yield b pst' -> return $ Yield b (pst', s) + Pipe.Continue pst' -> return $ Skip (pst', s) + Skip s -> return $ Skip (Consume pst, s) + Stop -> return Stop + + step' _ (Produce pst, st) = pst `seq` do + res <- pstep2 pst + case res of + Pipe.Yield b pst' -> return $ Yield b (pst', st) + Pipe.Continue pst' -> return $ Skip (pst', st) + +------------------------------------------------------------------------------ +-- Transformation by Folding (Scans) +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ +-- Prescans +------------------------------------------------------------------------------ + +-- 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) + +------------------------------------------------------------------------------ +-- Monolithic postscans (postscan followed by a map) +------------------------------------------------------------------------------ + +-- The performance of a modular postscan followed by a map seems to be +-- equivalent to this monolithic scan followed by map therefore we may not need +-- this implementation. We just have it for performance comparison and in case +-- modular version does not perform well in some situation. +-- +{-# INLINE_NORMAL postscanlMx' #-} +postscanlMx' :: Monad m + => (x -> a -> m x) -> m x -> (x -> m b) -> Stream m a -> Stream m b +postscanlMx' fstep begin done (Stream step state) = do + 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 + old <- acc + y <- fstep old x + v <- done y + v `seq` y `seq` return (Yield v (s, return y)) + Skip s -> return $ Skip (s, acc) + Stop -> return Stop + +{-# INLINE_NORMAL postscanlx' #-} +postscanlx' :: Monad m + => (x -> a -> x) -> x -> (x -> b) -> Stream m a -> Stream m b +postscanlx' fstep begin done s = + postscanlMx' (\b a -> return (fstep b a)) (return begin) (return . done) s + +-- XXX do we need consM strict to evaluate the begin value? +{-# INLINE scanlMx' #-} +scanlMx' :: Monad m + => (x -> a -> m x) -> m x -> (x -> m b) -> Stream m a -> Stream m b +scanlMx' fstep begin done s = + (begin >>= \x -> x `seq` done x) `consM` postscanlMx' fstep begin done s + +{-# INLINE scanlx' #-} +scanlx' :: Monad m + => (x -> a -> x) -> x -> (x -> b) -> Stream m a -> Stream m b +scanlx' fstep begin done s = + scanlMx' (\b a -> return (fstep b a)) (return begin) (return . done) s + +------------------------------------------------------------------------------ +-- postscans +------------------------------------------------------------------------------ + +{-# 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)) + +------------------------------------------------------------------------------ +-- Stateful map/scan +------------------------------------------------------------------------------ + +data RollingMapState s a = RollingMapInit s | RollingMapGo s a + +{-# INLINE rollingMapM #-} +rollingMapM :: Monad m => (a -> a -> m b) -> Stream m a -> Stream m b +rollingMapM f (Stream step1 state1) = Stream step (RollingMapInit state1) + where + step gst (RollingMapInit st) = do + r <- step1 (adaptState gst) st + return $ case r of + Yield x s -> Skip $ RollingMapGo s x + Skip s -> Skip $ RollingMapInit s + Stop -> Stop + + step gst (RollingMapGo s1 x1) = do + r <- step1 (adaptState gst) s1 + case r of + Yield x s -> do + !res <- f x x1 + return $ Yield res $ RollingMapGo s x + Skip s -> return $ Skip $ RollingMapGo s x1 + Stop -> return $ Stop + +{-# INLINE rollingMap #-} +rollingMap :: Monad m => (a -> a -> b) -> Stream m a -> Stream m b +rollingMap f = rollingMapM (\x y -> return $ f x y) + +------------------------------------------------------------------------------ +-- Tapping/Distributing +------------------------------------------------------------------------------ + +{-# INLINE tap #-} +tap :: Monad m => Fold m a b -> Stream m a -> Stream m a +tap (Fold fstep initial extract) (Stream step state) = Stream step' Nothing + + where + + step' _ Nothing = do + r <- initial + return $ Skip (Just (r, state)) + + step' gst (Just (acc, st)) = acc `seq` do + r <- step gst st + case r of + Yield x s -> do + acc' <- fstep acc x + return $ Yield x (Just (acc', s)) + Skip s -> return $ Skip (Just (acc, s)) + Stop -> do + void $ extract acc + return $ Stop + +{-# INLINE_NORMAL tapOffsetEvery #-} +tapOffsetEvery :: Monad m + => Int -> Int -> Fold m a b -> Stream m a -> Stream m a +tapOffsetEvery offset n (Fold fstep initial extract) (Stream step state) = + Stream step' Nothing + + where + + {-# INLINE_LATE step' #-} + step' _ Nothing = do + r <- initial + return $ Skip (Just (r, state, offset `mod` n)) + + step' gst (Just (acc, st, count)) | count <= 0 = do + r <- step gst st + case r of + Yield x s -> do + !acc' <- fstep acc x + return $ Yield x (Just (acc', s, n - 1)) + Skip s -> return $ Skip (Just (acc, s, count)) + Stop -> do + void $ extract acc + return $ Stop + + step' gst (Just (acc, st, count)) = do + r <- step gst st + case r of + Yield x s -> return $ Yield x (Just (acc, s, count - 1)) + Skip s -> return $ Skip (Just (acc, s, count)) + Stop -> do + void $ extract acc + return $ Stop + +{-# INLINE_NORMAL pollCounts #-} +pollCounts + :: MonadAsync m + => (a -> Bool) + -> (Stream m Int -> Stream m Int) + -> Fold m Int b + -> Stream m a + -> Stream m a +pollCounts predicate transf fld (Stream step state) = Stream step' Nothing + where + + {-# INLINE_LATE step' #-} + step' _ Nothing = do + -- As long as we are using an "Int" for counts lockfree reads from + -- Var should work correctly on both 32-bit and 64-bit machines. + -- However, an Int on a 32-bit machine may overflow quickly. + countVar <- liftIO $ newVar (0 :: Int) + tid <- forkManaged + $ void $ runFold fld + $ transf $ fromPrimVar countVar + return $ Skip (Just (countVar, tid, state)) + + step' gst (Just (countVar, tid, st)) = do + r <- step gst st + case r of + Yield x s -> do + when (predicate x) $ liftIO $ modifyVar' countVar (+ 1) + return $ Yield x (Just (countVar, tid, s)) + Skip s -> return $ Skip (Just (countVar, tid, s)) + Stop -> do + liftIO $ killThread tid + return Stop + +{-# INLINE_NORMAL tapRate #-} +tapRate :: + (MonadAsync m, MonadCatch m) + => Double + -> (Int -> m b) + -> Stream m a + -> Stream m a +tapRate samplingRate action (Stream step state) = Stream step' Nothing + where + {-# NOINLINE loop #-} + loop countVar prev = do + i <- + MC.catch + (do liftIO $ threadDelay (round $ samplingRate * 1000000) + i <- liftIO $ readVar countVar + let !diff = i - prev + void $ action diff + return i) + (\(e :: AsyncException) -> do + i <- liftIO $ readVar countVar + let !diff = i - prev + void $ action diff + throwM (MC.toException e)) + loop countVar i + + {-# INLINE_LATE step' #-} + step' _ Nothing = do + countVar <- liftIO $ newVar 0 + tid <- fork $ loop countVar 0 + ref <- liftIO $ newIORef () + _ <- liftIO $ mkWeakIORef ref (killThread tid) + return $ Skip (Just (countVar, tid, state, ref)) + + step' gst (Just (countVar, tid, st, ref)) = do + r <- step gst st + case r of + Yield x s -> do + liftIO $ modifyVar' countVar (+ 1) + return $ Yield x (Just (countVar, tid, s, ref)) + Skip s -> return $ Skip (Just (countVar, tid, s, ref)) + Stop -> do + liftIO $ killThread tid + return Stop + + +------------------------------------------------------------------------------- +-- Filtering +------------------------------------------------------------------------------- + +{-# 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 y (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 +------------------------------------------------------------------------------ + +data LoopState x s = FirstYield s + | InterspersingYield s + | YieldAndCarry x s + +{-# INLINE_NORMAL intersperseM #-} +intersperseM :: Monad m => m a -> Stream m a -> Stream m a +intersperseM m (Stream step state) = Stream step' (FirstYield state) + where + {-# INLINE_LATE step' #-} + step' gst (FirstYield st) = do + r <- step gst st + return $ + case r of + Yield x s -> Skip (YieldAndCarry x s) + Skip s -> Skip (FirstYield s) + Stop -> Stop + + step' gst (InterspersingYield st) = do + r <- step gst st + case r of + Yield x s -> do + a <- m + return $ Yield a (YieldAndCarry x s) + Skip s -> return $ Skip $ InterspersingYield s + Stop -> return Stop + + step' _ (YieldAndCarry x st) = return $ Yield x (InterspersingYield st) + +data SuffixState s a + = SuffixElem s + | SuffixSuffix s + | SuffixYield a (SuffixState s a) + +{-# INLINE_NORMAL intersperseSuffix #-} +intersperseSuffix :: forall m a. Monad m => m a -> Stream m a -> Stream m a +intersperseSuffix action (Stream step state) = Stream step' (SuffixElem state) + where + {-# INLINE_LATE step' #-} + step' gst (SuffixElem st) = do + r <- step gst st + return $ case r of + Yield x s -> Skip (SuffixYield x (SuffixSuffix s)) + Skip s -> Skip (SuffixElem s) + Stop -> Stop + + step' _ (SuffixSuffix st) = do + action >>= \r -> return $ Skip (SuffixYield r (SuffixElem st)) + + step' _ (SuffixYield x next) = return $ Yield x next + +data SuffixSpanState s a + = SuffixSpanElem s Int + | SuffixSpanSuffix s + | SuffixSpanYield a (SuffixSpanState s a) + | SuffixSpanLast + | SuffixSpanStop + +-- | intersperse after every n items +{-# INLINE_NORMAL intersperseSuffixBySpan #-} +intersperseSuffixBySpan :: forall m a. Monad m + => Int -> m a -> Stream m a -> Stream m a +intersperseSuffixBySpan n action (Stream step state) = + Stream step' (SuffixSpanElem state n) + where + {-# INLINE_LATE step' #-} + step' gst (SuffixSpanElem st i) | i > 0 = do + r <- step gst st + return $ case r of + Yield x s -> Skip (SuffixSpanYield x (SuffixSpanElem s (i - 1))) + Skip s -> Skip (SuffixSpanElem s i) + Stop -> if i == n then Stop else Skip SuffixSpanLast + step' _ (SuffixSpanElem st _) = return $ Skip (SuffixSpanSuffix st) + + step' _ (SuffixSpanSuffix st) = do + action >>= \r -> return $ Skip (SuffixSpanYield r (SuffixSpanElem st n)) + + step' _ (SuffixSpanLast) = do + action >>= \r -> return $ Skip (SuffixSpanYield r SuffixSpanStop) + + step' _ (SuffixSpanYield x next) = return $ Yield x next + + step' _ (SuffixSpanStop) = return Stop + +{-# INLINE intersperse #-} +intersperse :: Monad m => a -> Stream m a -> Stream m a +intersperse a = intersperseM (return a) + +{-# 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 + +#if __GLASGOW_HASKELL__ >= 801 +{-# RULES "zipWithM xs xs" + forall f xs. zipWithM @Identity f xs xs = mapM (\x -> f x x) xs #-} +#endif + +{-# 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)) + +------------------------------------------------------------------------------ +-- 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) + +{-# INLINE runFold #-} +runFold :: (Monad m) => Fold m a b -> Stream m a -> m b +runFold (Fold step begin done) = foldlMx' step begin done + +------------------------------------------------------------------------------- +-- Concurrent application and fold +------------------------------------------------------------------------------- + +-- XXX These functions should be moved to Stream/Parallel.hs +-- +-- Using StreamD the worker stream producing code can fuse with the code to +-- queue output to the SVar giving some perf boost. +-- +-- Note that StreamD can only be used in limited situations, specifically, we +-- cannot implement joinStreamVarPar using this. +-- +-- XXX make sure that the SVar passed is a Parallel style SVar. + +-- | Fold the supplied stream to the SVar asynchronously using Parallel +-- concurrency style. +-- {-# INLINE_NORMAL toSVarParallel #-} +{-# INLINE toSVarParallel #-} +toSVarParallel :: MonadAsync m + => State t m a -> SVar t m a -> Stream m a -> m () +toSVarParallel st sv xs = + if svarInspectMode sv + then forkWithDiag + else do + tid <- + case getYieldLimit st of + Nothing -> doFork (work Nothing) + (svarMrun sv) + (handleChildException sv) + Just _ -> doFork (workLim Nothing) + (svarMrun sv) + (handleChildException sv) + modifyThread sv tid + + where + + {-# NOINLINE work #-} + work info = (runFold (FL.toParallelSVar sv info) xs) + + {-# NOINLINE workLim #-} + workLim info = runFold (FL.toParallelSVarLimited sv info) xs + + {-# NOINLINE forkWithDiag #-} + forkWithDiag = do + -- We do not use workerCount in case of ParallelVar but still there is + -- no harm in maintaining it correctly. + liftIO $ atomicModifyIORefCAS_ (workerCount sv) $ \n -> n + 1 + recordMaxWorkers sv + -- This allocation matters when significant number of workers are being + -- sent. We allocate it only when needed. The overhead increases by 4x. + winfo <- + case yieldRateInfo sv of + Nothing -> return Nothing + Just _ -> liftIO $ do + cntRef <- newIORef 0 + t <- getTime Monotonic + lat <- newIORef (0, t) + return $ Just WorkerInfo + { workerYieldMax = 0 + , workerYieldCount = cntRef + , workerLatencyStart = lat + } + tid <- + case getYieldLimit st of + Nothing -> doFork (work winfo) + (svarMrun sv) + (handleChildException sv) + Just _ -> doFork (workLim winfo) + (svarMrun sv) + (handleChildException sv) + modifyThread sv tid + +{-# INLINE_NORMAL mkParallelD #-} +mkParallelD :: MonadAsync m => Stream m a -> Stream m a +mkParallelD m = Stream step Nothing + where + + step gst Nothing = do + sv <- newParallelVar StopNone gst + toSVarParallel gst sv m + -- XXX use unfold instead? + return $ Skip $ Just $ fromSVar sv + + step gst (Just (UnStream step1 st)) = do + r <- step1 gst st + return $ case r of + Yield a s -> Yield a (Just $ Stream step1 s) + Skip s -> Skip (Just $ Stream step1 s) + Stop -> Stop + +-- Compare with mkAsync. mkAsync uses an Async style SVar whereas this uses a +-- parallel style SVar for evaluation. Currently, parallel style cannot use +-- rate control whereas Async style can use rate control. In async style SVar +-- the worker thread terminates when the buffer is full whereas in Parallel +-- style it blocks. +-- +-- | Make the stream producer and consumer run concurrently by introducing a +-- buffer between them. The producer thread evaluates the input stream until +-- the buffer fills, it blocks if the buffer is full until there is space in +-- the buffer. The consumer consumes the stream lazily from the buffer. +-- +-- /Internal/ +-- +{-# INLINE_NORMAL mkParallel #-} +mkParallel :: (K.IsStream t, MonadAsync m) => t m a -> t m a +mkParallel = fromStreamD . mkParallelD . toStreamD + +------------------------------------------------------------------------------- +-- Concurrent tap +------------------------------------------------------------------------------- + +-- | Create an SVar with a fold consumer that will fold any elements sent to it +-- using the supplied fold function. +{-# INLINE newFoldSVar #-} +newFoldSVar :: MonadAsync m => State t m a -> Fold m a b -> m (SVar t m a) +newFoldSVar stt f = do + -- Buffer size for the SVar is derived from the current state + sv <- newParallelVar StopAny (adaptState stt) + -- Add the producer thread-id to the SVar. + liftIO myThreadId >>= modifyThread sv + void $ doFork (work sv) (svarMrun sv) (handleFoldException sv) + return sv + + where + + {-# NOINLINE work #-} + work sv = void $ runFold f $ fromProducer sv + +data TapState sv st = TapInit | Tapping sv st | TapDone st + +{-# INLINE_NORMAL tapAsync #-} +tapAsync :: MonadAsync m => Fold m a b -> Stream m a -> Stream m a +tapAsync f (Stream step1 state1) = Stream step TapInit + where + + drainFold svr = do + -- In general, a Stop event would come equipped with the result + -- of the fold. It is not used here but it would be useful in + -- applicative and distribute. + done <- fromConsumer svr + when (not done) $ do + liftIO $ withDiagMVar svr "teeToSVar: waiting to drain" + $ takeMVar (outputDoorBellFromConsumer svr) + drainFold svr + + stopFold svr = do + liftIO $ sendStop svr Nothing + -- drain/wait until a stop event arrives from the fold. + drainFold svr + + {-# INLINE_LATE step #-} + step gst TapInit = do + sv <- newFoldSVar gst f + return $ Skip (Tapping sv state1) + + step gst (Tapping sv st) = do + r <- step1 gst st + case r of + Yield a s -> do + done <- pushToFold sv a + if done + then do + -- XXX we do not need to wait synchronously here + stopFold sv + return $ Yield a (TapDone s) + else return $ Yield a (Tapping sv s) + Skip s -> return $ Skip (Tapping sv s) + Stop -> do + stopFold sv + return $ Stop + + step gst (TapDone st) = do + r <- step1 gst st + return $ case r of + Yield a s -> Yield a (TapDone s) + Skip s -> Skip (TapDone s) + Stop -> Stop + +-- XXX Exported from Array again as this fold is specific to Array +-- | Take last 'n' elements from the stream and discard the rest. +{-# INLINE lastN #-} +lastN :: (Storable a, MonadIO m) => Int -> Fold m a (Array a) +lastN n = Fold step initial done + where + step (Tuple3' rb rh i) a = do + rh1 <- liftIO $ RB.unsafeInsert rb rh a + return $ Tuple3' rb rh1 (i + 1) + initial = fmap (\(a, b) -> Tuple3' a b (0 :: Int)) $ liftIO $ RB.new n + done (Tuple3' rb rh i) = do + arr <- liftIO $ A.newArray n + foldFunc i rh snoc' arr rb + snoc' b a = liftIO $ A.unsafeSnoc b a + foldFunc i + | i < n = RB.unsafeFoldRingM + | otherwise = RB.unsafeFoldRingFullM + +------------------------------------------------------------------------------ +-- Time related +------------------------------------------------------------------------------ + +-- XXX using getTime in the loop can be pretty expensive especially for +-- computations where iterations are lightweight. We have the following +-- options: +-- +-- 1) Run a timeout thread updating a flag asynchronously and check that +-- flag here, that way we can have a cheap termination check. +-- +-- 2) Use COARSE clock to get time with lower resolution but more efficiently. +-- +-- 3) Use rdtscp/rdtsc to get time directly from the processor, compute the +-- termination value of rdtsc in the beginning and then in each iteration just +-- get rdtsc and check if we should terminate. +-- +data TakeByTime st s + = TakeByTimeInit st + | TakeByTimeCheck st s + | TakeByTimeYield st s + +{-# INLINE_NORMAL takeByTime #-} +takeByTime :: (MonadIO m, TimeUnit64 t) => t -> Stream m a -> Stream m a +takeByTime duration (Stream step1 state1) = Stream step (TakeByTimeInit state1) + where + + lim = toRelTime64 duration + + {-# INLINE_LATE step #-} + step _ (TakeByTimeInit _) | lim == 0 = return Stop + step _ (TakeByTimeInit st) = do + t0 <- liftIO $ getTime Monotonic + return $ Skip (TakeByTimeYield st t0) + step _ (TakeByTimeCheck st t0) = do + t <- liftIO $ getTime Monotonic + return $ + if diffAbsTime64 t t0 > lim + then Stop + else Skip (TakeByTimeYield st t0) + step gst (TakeByTimeYield st t0) = do + r <- step1 gst st + return $ case r of + Yield x s -> Yield x (TakeByTimeCheck s t0) + Skip s -> Skip (TakeByTimeCheck s t0) + Stop -> Stop + +data DropByTime st s x + = DropByTimeInit st + | DropByTimeGen st s + | DropByTimeCheck st s x + | DropByTimeYield st + +{-# INLINE_NORMAL dropByTime #-} +dropByTime :: (MonadIO m, TimeUnit64 t) => t -> Stream m a -> Stream m a +dropByTime duration (Stream step1 state1) = Stream step (DropByTimeInit state1) + where + + lim = toRelTime64 duration + + {-# INLINE_LATE step #-} + step _ (DropByTimeInit st) = do + t0 <- liftIO $ getTime Monotonic + return $ Skip (DropByTimeGen st t0) + step gst (DropByTimeGen st t0) = do + r <- step1 gst st + return $ case r of + Yield x s -> Skip (DropByTimeCheck s t0 x) + Skip s -> Skip (DropByTimeGen s t0) + Stop -> Stop + step _ (DropByTimeCheck st t0 x) = do + t <- liftIO $ getTime Monotonic + if diffAbsTime64 t t0 <= lim + then return $ Skip $ DropByTimeGen st t0 + else return $ Yield x $ DropByTimeYield st + step gst (DropByTimeYield st) = do + r <- step1 gst st + return $ case r of + Yield x s -> Yield x (DropByTimeYield s) + Skip s -> Skip (DropByTimeYield s) + Stop -> Stop + +-- XXX we should move this to stream generation section of this file. Also, the +-- take/drop combinators above should be moved to filtering section. +{-# INLINE_NORMAL currentTime #-} +currentTime :: MonadAsync m => Double -> Stream m AbsTime +currentTime g = Stream step Nothing + + where + + g' = g * 10 ^ (6 :: Int) + + -- XXX should have a minimum granularity to avoid high CPU usage? + {-# INLINE delayTime #-} + delayTime = + if g' >= fromIntegral (maxBound :: Int) + then maxBound + else round g' + + updateTimeVar timeVar = do + threadDelay $ delayTime + MicroSecond64 t <- fromAbsTime <$> getTime Monotonic + modifyVar' timeVar (const t) + + {-# INLINE_LATE step #-} + step _ Nothing = do + -- XXX note that this is safe only on a 64-bit machine. On a 32-bit + -- machine a 64-bit 'Var' cannot be read consistently without a lock + -- while another thread is writing to it. + timeVar <- liftIO $ newVar (0 :: Int64) + tid <- forkManaged $ liftIO $ forever (updateTimeVar timeVar) + return $ Skip $ Just (timeVar, tid) + + step _ s@(Just (timeVar, _)) = do + a <- liftIO $ readVar timeVar + -- XXX we can perhaps use an AbsTime64 using a 64 bit Int for + -- efficiency. or maybe we can use a representation using Double for + -- floating precision time + return $ Yield (toAbsTime (MicroSecond64 a)) s diff --git a/src/Streamly/Internal/Data/Stream/StreamD/Type.hs b/src/Streamly/Internal/Data/Stream/StreamD/Type.hs --- a/src/Streamly/Internal/Data/Stream/StreamD/Type.hs +++ b/src/Streamly/Internal/Data/Stream/StreamD/Type.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} @@ -15,7 +14,7 @@ -- | -- Module : Streamly.Internal.Data.Stream.StreamD.Type -- Copyright : (c) 2018 Harendra Kumar --- Copyright : (c) Roman Leshchinskiy 2008-2010 +-- (c) Roman Leshchinskiy 2008-2010 -- -- License : BSD3 -- Maintainer : streamly@composewell.com @@ -68,18 +67,19 @@ where import Control.Applicative (liftA2) -import Control.Monad (ap, when) +import Control.Monad (when) import Control.Monad.Catch (MonadThrow, throwM) import Control.Monad.Trans (lift, MonadTrans) import Data.Functor.Identity (Identity(..)) import GHC.Base (build) import GHC.Types (SPEC(..)) import Prelude hiding (map, mapM, foldr, take, concatMap) +import Fusion.Plugin.Types (Fuse(..)) import Streamly.Internal.Data.SVar (State(..), adaptState, defState) import Streamly.Internal.Data.Fold.Types (Fold(..), Fold2(..)) -import qualified Streamly.Streams.StreamK as K +import qualified Streamly.Internal.Data.Stream.StreamK as K ------------------------------------------------------------------------------ -- The direct style stream type @@ -88,15 +88,14 @@ -- | 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. +{-# ANN type Step Fuse #-} 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 @@ -131,12 +130,14 @@ 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 + go st = K.mkStream $ \gst yld _ stp -> + let go' ss = do + r <- step gst ss + case r of + Yield x s -> yld x (go s) + Skip s -> go' s + Stop -> stp + in go' st #ifndef DISABLE_FUSION {-# RULES "fromStreamK/toStreamK fusion" @@ -174,9 +175,12 @@ map :: Monad m => (a -> b) -> Stream m a -> Stream m b map f = mapM (return . f) -instance Monad m => Functor (Stream m) where +instance Functor m => Functor (Stream m) where {-# INLINE fmap #-} - fmap = map + fmap f (Stream step state) = Stream step' state + where + {-# INLINE_LATE step' #-} + step' gst st = fmap (fmap f) (step (adaptState gst) st) ------------------------------------------------------------------------------ -- concatMap @@ -229,19 +233,62 @@ -- | 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 +yield :: Applicative m => a -> Stream m a +yield x = Stream (\_ s -> pure $ step undefined s) True where {-# INLINE_LATE step #-} step _ True = Yield x False step _ False = Stop -instance Monad m => Applicative (Stream m) where +{-# INLINE_NORMAL concatAp #-} +concatAp :: Functor f => Stream f (a -> b) -> Stream f a -> Stream f b +concatAp (Stream stepa statea) (Stream stepb stateb) = Stream step' (Left statea) + where + {-# INLINE_LATE step' #-} + step' gst (Left st) = fmap + (\r -> case r of + Yield f s -> Skip (Right (f, s, stateb)) + Skip s -> Skip (Left s) + Stop -> Stop) + (stepa (adaptState gst) st) + step' gst (Right (f, os, st)) = fmap + (\r -> case r of + Yield a s -> Yield (f a) (Right (f, os, s)) + Skip s -> Skip (Right (f,os, s)) + Stop -> Skip (Left os)) + (stepb (adaptState gst) st) + +{-# INLINE_NORMAL apSequence #-} +apSequence :: Functor f => Stream f a -> Stream f b -> Stream f b +apSequence (Stream stepa statea) (Stream stepb stateb) = Stream step (Left statea) + where + {-# INLINE_LATE step #-} + step gst (Left st) = + fmap + (\r -> + case r of + Yield _ s -> Skip (Right (s, stateb)) + Skip s -> Skip (Left s) + Stop -> Stop) + (stepa (adaptState gst) st) + step gst (Right (ostate, st)) = + fmap + (\r -> + case r of + Yield b s -> Yield b (Right (ostate, s)) + Skip s -> Skip (Right (ostate, s)) + Stop -> Skip (Left ostate)) + (stepb gst st) + +instance Applicative f => Applicative (Stream f) where {-# INLINE pure #-} pure = yield {-# INLINE (<*>) #-} - (<*>) = ap + (<*>) = concatAp + {-# INLINE (*>) #-} + (*>) = apSequence + -- NOTE: even though concatMap for StreamD is 4x faster compared to StreamK, -- the monad instance does not seem to be significantly faster. instance Monad m => Monad (Stream m) where @@ -249,6 +296,8 @@ return = pure {-# INLINE (>>=) #-} (>>=) = flip concatMap + {-# INLINE (>>) #-} + (>>) = (*>) instance MonadTrans Stream where lift = yieldM @@ -418,12 +467,12 @@ -- | Convert a list of pure values to a 'Stream' {-# INLINE_LATE fromList #-} -fromList :: Monad m => [a] -> Stream m a +fromList :: Applicative m => [a] -> Stream m a fromList = Stream step where {-# INLINE_LATE step #-} - step _ (x:xs) = return $ Yield x xs - step _ [] = return Stop + step _ (x:xs) = pure $ Yield x xs + step _ [] = pure Stop ------------------------------------------------------------------------------ -- Comparisons @@ -538,7 +587,7 @@ r <- step (adaptState gst) st case r of Yield x s -> do - fs' <- fstep fs x + !fs' <- fstep fs x let i' = i + 1 return $ if i' >= n @@ -582,7 +631,7 @@ r <- step (adaptState gst) st case r of Yield x s -> do - fs' <- fstep fs x + !fs' <- fstep fs x let i' = i + 1 return $ if i' >= n diff --git a/src/Streamly/Internal/Data/Stream/StreamDK.hs b/src/Streamly/Internal/Data/Stream/StreamDK.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/StreamDK.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +-- {-# LANGUAGE ScopedTypeVariables #-} + +#include "inline.hs" + +-- | +-- Module : Streamly.Internal.Data.Stream.StreamDK +-- Copyright : (c) 2019 Composewell Technologies +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- + +module Streamly.Internal.Data.Stream.StreamDK + ( + -- * Stream Type + + Stream + , Step (..) + + -- * Construction + , nil + , cons + , consM + , unfoldr + , unfoldrM + , replicateM + + -- * Folding + , uncons + , foldrS + + -- * Specific Folds + , drain + ) +where + +import Streamly.Internal.Data.Stream.StreamDK.Type (Stream(..), Step(..)) + +------------------------------------------------------------------------------- +-- Construction +------------------------------------------------------------------------------- + +nil :: Monad m => Stream m a +nil = Stream $ return Stop + +{-# INLINE_NORMAL cons #-} +cons :: Monad m => a -> Stream m a -> Stream m a +cons x xs = Stream $ return $ Yield x xs + +consM :: Monad m => m a -> Stream m a -> Stream m a +consM eff xs = Stream $ eff >>= \x -> return $ Yield x xs + +unfoldrM :: Monad m => (s -> m (Maybe (a, s))) -> s -> Stream m a +unfoldrM next state = Stream (step' state) + where + step' st = do + r <- next st + return $ case r of + Just (x, s) -> Yield x (Stream (step' s)) + Nothing -> Stop +{- +unfoldrM next s0 = buildM $ \yld stp -> + let go s = do + r <- next s + case r of + Just (a, b) -> yld a (go b) + Nothing -> stp + in go s0 +-} + +{-# INLINE unfoldr #-} +unfoldr :: Monad m => (b -> Maybe (a, b)) -> b -> Stream m a +unfoldr next s0 = build $ \yld stp -> + let go s = + case next s of + Just (a, b) -> yld a (go b) + Nothing -> stp + in go s0 + +replicateM :: Monad m => Int -> a -> Stream m a +replicateM n x = Stream (step n) + where + step i = return $ + if i <= 0 + then Stop + else Yield x (Stream (step (i - 1))) + +------------------------------------------------------------------------------- +-- Folding +------------------------------------------------------------------------------- + +uncons :: Monad m => Stream m a -> m (Maybe (a, Stream m a)) +uncons (Stream step) = do + r <- step + return $ case r of + Yield x xs -> Just (x, xs) + Stop -> Nothing + +-- | Lazy right associative fold to a stream. +{-# INLINE_NORMAL foldrS #-} +foldrS :: Monad m + => (a -> Stream m b -> Stream m b) + -> Stream m b + -> Stream m a + -> Stream m b +foldrS f streamb = go + where + go (Stream stepa) = Stream $ do + r <- stepa + case r of + Yield x xs -> let Stream step = f x (go xs) in step + Stop -> let Stream step = streamb in step + +{-# INLINE_LATE foldrM #-} +foldrM :: Monad m => (a -> m b -> m b) -> m b -> Stream m a -> m b +foldrM fstep acc ys = go ys + where + go (Stream step) = do + r <- step + case r of + Yield x xs -> fstep x (go xs) + Stop -> acc + +{-# INLINE_NORMAL build #-} +build :: Monad m + => forall a. (forall b. (a -> b -> b) -> b -> b) -> Stream m a +build g = g cons nil + +{-# RULES +"foldrM/build" forall k z (g :: forall b. (a -> b -> b) -> b -> b). + foldrM k z (build g) = g k z #-} + +{- +-- To fuse foldrM with unfoldrM we need the type m1 to be polymorphic such that +-- it is either Monad m or Stream m. So that we can use cons/nil as well as +-- monadic construction function as its arguments. +-- +{-# INLINE_NORMAL buildM #-} +buildM :: Monad m + => forall a. (forall b. (a -> m1 b -> m1 b) -> m1 b -> m1 b) -> Stream m a +buildM g = g cons nil +-} + +------------------------------------------------------------------------------- +-- Specific folds +------------------------------------------------------------------------------- + +{-# INLINE drain #-} +drain :: Monad m => Stream m a -> m () +drain = foldrM (\_ xs -> xs) (return ()) +{- +drain (Stream step) = do + r <- step + case r of + Yield _ next -> drain next + Stop -> return () + -} diff --git a/src/Streamly/Internal/Data/Stream/StreamDK/Type.hs b/src/Streamly/Internal/Data/Stream/StreamDK/Type.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/StreamDK/Type.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} + +-- | +-- Module : Streamly.StreamDK.Type +-- Copyright : (c) 2019 Composewell Technologies +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- A CPS style stream using a constructor based representation instead of a +-- function based representation. +-- +-- Streamly internally uses two fundamental stream representations, (1) streams +-- with an open or arbitrary control flow (we call it StreamK), (2) streams +-- with a structured or closed loop control flow (we call it StreamD). The +-- higher level stream types can use any of these representations under the +-- hood and can interconvert between the two. +-- +-- StreamD: +-- +-- StreamD is a non-recursive data type in which the state of the stream and +-- the step function are separate. When the step function is called, a stream +-- element and the new stream state is yielded. The generated element and the +-- state are passed to the next consumer in the loop. The state is threaded +-- around in the loop until control returns back to the original step function +-- to run the next step. This creates a structured closed loop representation +-- (like "for" loops in C) with state of each step being hidden/abstracted or +-- existential within that step. This creates a loop representation identical +-- to the "for" or "while" loop constructs in imperative languages, the states +-- of the steps combined together constitute the state of the loop iteration. +-- +-- Internally most combinators use a closed loop representation because it +-- provides very high efficiency due to stream fusion. The performance of this +-- representation is competitive to the C language implementations. +-- +-- Pros and Cons of StreamD: +-- +-- 1) stream-fusion: This representation can be optimized very efficiently by +-- the compiler because the state is explicitly separated from step functions, +-- represented using pure data constructors and visible to the compiler, the +-- stream steps can be fused using case-of-case transformations and the state +-- can be specialized using spec-constructor optimization, yielding a C like +-- tight loop/state machine with no constructors, the state is used unboxed and +-- therefore no unnecessary allocation. +-- +-- 2) Because of a closed representation consing too many elements in this type +-- of stream does not scale, it will have quadratic performance slowdown. Each +-- cons creates a layer that needs to return the control back to the caller. +-- Another implementation of cons is possible but that will have to box/unbox +-- the state and will not fuse. So effectively cons breaks fusion. +-- +-- 3) unconsing an item from the stream breaks fusion, we have to "pause" the +-- loop, rebox and save the state. +-- +-- 3) Exception handling is easy to implement in this model because control +-- flow is structured in the loop and cannot be arbitrary. Therefore, +-- implementing "bracket" is natural. +-- +-- 4) Round-robin scheduling for co-operative multitasking is easy to implement. +-- +-- 5) It fuses well with the direct style Fold implementation. +-- +-- StreamK/StreamDK: +-- +-- StreamDK i.e. the stream defined in this module, like StreamK, is a +-- recursive data type which has no explicit state defined using constructors, +-- each step yields an element and a computation representing the rest of the +-- stream. Stream state is part of the function representing the rest of the +-- stream. This creates an open computation representation, or essentially a +-- continuation passing style computation. After the stream step is executed, +-- the caller is free to consume the produced element and then send the control +-- wherever it wants, there is no restriction on the control to return back +-- somewhere, the control is free to go anywhere. The caller may decide not to +-- consume the rest of the stream. This representation is more like a "goto" +-- based implementation in imperative languages. +-- +-- Pros and Cons of StreamK: +-- +-- 1) The way StreamD can be optimized using stream-fusion, this type can be +-- optimized using foldr/build fusion. However, foldr/build has not yet been +-- fully implemented for StreamK/StreamDK. +-- +-- 2) Using cons is natural in this representation, unlike in StreamD it does +-- not have a quadratic slowdown. Currently, we in fact wrap StreamD in StreamK +-- to support a better cons operation. +-- +-- 3) Similarly, uncons is natural in this representation. +-- +-- 4) Exception handling is not easy to implement because of the "goto" nature +-- of CPS. +-- +-- 5) Composable folds are not implemented/proven, however, intuition says that +-- a push style CPS representation should be able to be used along with StreamK +-- to efficiently implement composable folds. + +module Streamly.Internal.Data.Stream.StreamDK.Type + ( Step(..) + , Stream (..) + ) +where + +-- XXX Use Cons and Nil instead of Yield and Stop? +data Step m a = Yield a (Stream m a) | Stop + +data Stream m a = Stream (m (Step m a)) diff --git a/src/Streamly/Internal/Data/Stream/StreamK.hs b/src/Streamly/Internal/Data/Stream/StreamK.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/StreamK.hs @@ -0,0 +1,1095 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} -- XXX + +#include "inline.hs" + +-- | +-- Module : Streamly.Internal.Data.Stream.StreamK +-- Copyright : (c) 2017 Harendra Kumar +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- +-- Continuation passing style (CPS) stream implementation. The symbol 'K' below +-- denotes a function as well as a Kontinuation. +-- +-- @ +-- import qualified Streamly.Internal.Data.Stream.StreamK as K +-- @ +-- +module Streamly.Internal.Data.Stream.StreamK + ( + -- * A class for streams + IsStream (..) + , adapt + + -- * The stream type + , Stream(..) + + -- * Construction Primitives + , mkStream + , nil + , nilM + , cons + , (.:) + + -- * Elimination Primitives + , foldStream + , foldStreamShared + + -- * Transformation Primitives + , unShare + + -- * Deconstruction + , uncons + + -- * Generation + -- ** Unfolds + , unfoldr + , unfoldrM + + -- ** Specialized Generation + , repeat + , repeatM + , replicate + , replicateM + , fromIndices + , fromIndicesM + , iterate + , iterateM + + -- ** Conversions + , yield + , yieldM + , fromFoldable + , fromList + , fromStreamK + + -- * foldr/build + , foldrS + , foldrSM + , buildS + , buildM + , augmentS + , augmentSM + + -- * Elimination + -- ** General Folds + , foldr + , foldr1 + , foldrM + , foldrT + + , foldl' + , foldlM' + , foldlS + , foldlT + , foldlx' + , foldlMx' + + -- ** Specialized Folds + , drain + , null + , head + , tail + , init + , elem + , notElem + , all + , any + , last + , minimum + , minimumBy + , maximum + , maximumBy + , findIndices + , lookup + , findM + , find + , (!!) + + -- ** Map and Fold + , mapM_ + + -- ** Conversions + , toList + , toStreamK + , hoist + + -- * Transformation + -- ** By folding (scans) + , scanl' + , scanlx' + + -- ** Filtering + , filter + , take + , takeWhile + , drop + , dropWhile + + -- ** Mapping + , map + , mapM + , mapMSerial + , sequence + + -- ** Inserting + , intersperseM + , intersperse + , insertBy + + -- ** Deleting + , deleteBy + + -- ** Reordering + , reverse + + -- ** Map and Filter + , mapMaybe + + -- ** Zipping + , zipWith + , zipWithM + + -- ** Merging + , mergeBy + , mergeByM + + -- ** Nesting + , concatMapBy + , concatMap + , bindWith + + -- ** Transformation comprehensions + , the + + -- * Semigroup Style Composition + , serial + + -- * Utilities + , consMStream + , withLocal + , mfix + + -- * Deprecated + , Streaming -- deprecated + , once -- deprecated + ) +where + +import Control.Monad.Trans (MonadTrans(lift)) +import Control.Monad (void, join) +import Control.Monad.Reader.Class (MonadReader(..)) +import Data.Function (fix) +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, (!!), replicate, reverse, concatMap, iterate) +import qualified Prelude + +import Streamly.Internal.Data.SVar +import Streamly.Internal.Data.Stream.StreamK.Type + +------------------------------------------------------------------------------- +-- Deconstruction +------------------------------------------------------------------------------- + +{-# INLINE uncons #-} +uncons :: (IsStream t, Monad m) => t m a -> m (Maybe (a, t m a)) +uncons m = + let stop = return Nothing + single a = return (Just (a, nil)) + yieldk a r = return (Just (a, r)) + in foldStream defState yieldk single stop m + +------------------------------------------------------------------------------- +-- Generation +------------------------------------------------------------------------------- + +{-# INLINE unfoldr #-} +unfoldr :: IsStream t => (b -> Maybe (a, b)) -> b -> t m a +unfoldr next s0 = build $ \yld stp -> + let go s = + case next s of + Just (a, b) -> yld a (go b) + Nothing -> stp + in go s0 + +{-# INLINE unfoldrM #-} +unfoldrM :: (IsStream t, MonadAsync m) => (b -> m (Maybe (a, b))) -> b -> t m a +unfoldrM step = go + where + go s = sharedM $ \yld _ stp -> do + r <- step s + case r of + Just (a, b) -> yld a (go b) + Nothing -> stp + +{- +-- Generalization of concurrent streams/SVar via unfoldr. +-- +-- Unfold a value into monadic actions and then run the resulting monadic +-- actions to generate a stream. Since the step of generating the monadic +-- action and running them are decoupled we can run the monadic actions +-- cooncurrently. For example, the seed could be a list of monadic actions or a +-- pure stream of monadic actions. +-- +-- We can have different flavors of this depending on the stream type t. The +-- concurrent version could be async or ahead etc. Depending on how we queue +-- back the feedback portion b, it could be DFS or BFS style. +-- +unfoldrA :: (IsStream t, MonadAsync m) => (b -> Maybe (m a, b)) -> b -> t m a +unfoldrA = undefined +-} + +------------------------------------------------------------------------------- +-- Special generation +------------------------------------------------------------------------------- + +-- | Same as yieldM +-- +-- @since 0.2.0 +{-# DEPRECATED once "Please use yieldM instead." #-} +{-# INLINE once #-} +once :: (Monad m, IsStream t) => m a -> t m a +once = yieldM + +-- | +-- @ +-- repeatM = fix . cons +-- repeatM = cycle1 . yield +-- @ +-- +-- Generate an infinite stream by repeating a monadic value. +-- +-- /Internal/ +repeatM :: (IsStream t, MonadAsync m) => m a -> t m a +repeatM = go + where go m = m |: go m + +-- Generate an infinite stream by repeating a pure value. +-- +-- /Internal/ +{-# 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) + +{-# INLINE fromIndicesM #-} +fromIndicesM :: (IsStream t, MonadAsync m) => (Int -> m a) -> t m a +fromIndicesM gen = go 0 + where + go i = mkStream $ \st stp sng yld -> do + foldStreamShared st stp sng yld (gen i |: go (i + 1)) + +{-# INLINE fromIndices #-} +fromIndices :: IsStream t => (Int -> a) -> t m a +fromIndices gen = go 0 + where + go n = (gen n) `cons` go (n + 1) + +{-# INLINE iterate #-} +iterate :: IsStream t => (a -> a) -> a -> t m a +iterate step = fromStream . go + where + go s = cons s (go (step s)) + +{-# INLINE iterateM #-} +iterateM :: (IsStream t, MonadAsync m) => (a -> m a) -> m a -> t m a +iterateM step = go + where + go s = mkStream $ \st stp sng yld -> do + next <- s + foldStreamShared st stp sng yld (return next |: go (step next)) + +------------------------------------------------------------------------------- +-- Conversions +------------------------------------------------------------------------------- + +-- | +-- @ +-- 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 +fromFoldable = Prelude.foldr cons nil + +{-# INLINE fromList #-} +fromList :: IsStream t => [a] -> t m a +fromList = fromFoldable + +{-# INLINE fromStreamK #-} +fromStreamK :: IsStream t => Stream m a -> t m a +fromStreamK = fromStream + +------------------------------------------------------------------------------- +-- Elimination by Folding +------------------------------------------------------------------------------- + +-- | Lazy right associative fold. +{-# INLINE foldr #-} +foldr :: (IsStream t, Monad m) => (a -> b -> b) -> b -> t m a -> m b +foldr step acc = foldrM (\x xs -> xs >>= \b -> return (step x b)) (return acc) + +-- | Right associative fold to an arbitrary transformer monad. +{-# INLINE foldrT #-} +foldrT :: (IsStream t, Monad m, Monad (s m), MonadTrans s) + => (a -> s m b -> s m b) -> s m b -> t m a -> s m b +foldrT step final m = go m + where + go m1 = do + res <- lift $ uncons m1 + case res of + Just (h, t) -> step h (go t) + Nothing -> final + +{-# INLINE foldr1 #-} +foldr1 :: (IsStream t, Monad m) => (a -> a -> a) -> t m a -> m (Maybe a) +foldr1 step m = do + r <- uncons m + case r of + Nothing -> return Nothing + 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 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 foldlx' #-} +foldlx' :: forall t m a b x. (IsStream t, Monad m) + => (x -> a -> x) -> x -> (x -> b) -> t m a -> m b +foldlx' 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 + -- 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 :: t m a -> x -> t m x + go m1 !acc = mkStream $ \_ yld sng _ -> + let stop = sng acc + single a = sng $ step acc a + -- 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' #-} +foldl' :: (IsStream t, Monad m) => (b -> a -> b) -> b -> t m a -> m b +foldl' step begin = foldlx' step begin id + +-- XXX replace the recursive "go" with explicit continuations. +-- | Like 'foldx', but with a monadic step function. +{-# INLINABLE foldlMx' #-} +foldlMx' :: (IsStream t, Monad m) + => (x -> a -> m x) -> m x -> (x -> m b) -> t m a -> m b +foldlMx' 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 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 = foldlMx' step (return begin) return + +-- | Lazy left fold to a stream. +{-# INLINE foldlS #-} +foldlS :: IsStream t => (t m b -> a -> t m b) -> t m b -> t m a -> t m b +foldlS step begin m = go begin m + where + go acc rest = mkStream $ \st yld sng stp -> + let run x = foldStream st yld sng stp x + stop = run acc + single a = run $ step acc a + yieldk a r = run $ go (step acc a) r + in foldStream (adaptState st) yieldk single stop rest + +-- | Lazy left fold to an arbitrary transformer monad. +{-# INLINE foldlT #-} +foldlT :: (IsStream t, Monad m, Monad (s m), MonadTrans s) + => (s m b -> a -> s m b) -> s m b -> t m a -> s m b +foldlT step begin m = go begin m + where + go acc m1 = do + res <- lift $ uncons m1 + case res of + Just (h, t) -> go (step acc h) t + Nothing -> acc + +------------------------------------------------------------------------------ +-- Specialized folds +------------------------------------------------------------------------------ + +-- XXX use foldrM to implement folds where possible +-- XXX This (commented) definition of drain and mapM_ perform much better on +-- some benchmarks but worse on others. Need to investigate why, may there is +-- an optimization opportunity that we can exploit. +-- drain = foldrM (\_ xs -> return () >> xs) (return ()) + +-- | +-- > drain = foldl' (\_ _ -> ()) () +-- > drain = mapM_ (\_ -> return ()) +{-# INLINE drain #-} +drain :: (Monad m, IsStream t) => t m a -> m () +drain = foldrM (\_ xs -> xs) (return ()) +{- +drain = go + where + go m1 = + let stop = return () + single _ = return () + yieldk _ r = go r + in foldStream defState yieldk single stop m1 +-} + +{-# INLINE null #-} +null :: (IsStream t, Monad m) => t m a -> m Bool +-- null = foldrM (\_ _ -> return True) (return False) +null m = + let stop = return True + single _ = return False + yieldk _ _ = return False + in foldStream defState yieldk single stop m + +{-# INLINE head #-} +head :: (IsStream t, Monad m) => t m a -> m (Maybe a) +-- head = foldrM (\x _ -> return $ Just x) (return Nothing) +head m = + let stop = return Nothing + single a = return (Just a) + yieldk a _ = return (Just a) + 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 r + in foldStream defState yieldk single stop m + +{-# INLINE headPartial #-} +headPartial :: (IsStream t, Monad m) => t m a -> m a +headPartial = foldrM (\x _ -> return x) (error "head of nil") + +{-# INLINE tailPartial #-} +tailPartial :: IsStream t => t m a -> t m a +tailPartial m = mkStream $ \st yld sng stp -> + let stop = error "tail of nil" + single _ = stp + yieldk _ r = foldStream st yld sng stp r + in foldStream st yieldk single stop m + +-- | Iterate a lazy function `f` of the shape `m a -> t m a` until it gets +-- fully defined i.e. becomes independent of its argument action, then return +-- the resulting value of the function (`t m a`). +-- +-- It can be used to construct a stream that uses a cyclic definition. For +-- example: +-- +-- @ +-- import Streamly.Internal.Prelude as S +-- import System.IO.Unsafe (unsafeInterleaveIO) +-- +-- main = do +-- S.mapM_ print $ S.mfix $ \x -> do +-- a <- S.fromList [1,2] +-- b <- S.fromListM [return 3, unsafeInterleaveIO (fmap fst x)] +-- return (a, b) +-- @ +-- +-- Note that the function `f` must be lazy in its argument, that's why we use +-- 'unsafeInterleaveIO' because IO monad is strict. + +mfix :: (IsStream t, Monad m) => (m a -> t m a) -> t m a +mfix f = mkStream $ \st yld sng stp -> + let single a = foldStream st yld sng stp $ a `cons` ys + yieldk a _ = foldStream st yld sng stp $ a `cons` ys + in foldStream st yieldk single stp xs + where xs = fix (f . headPartial) + ys = mfix (tailPartial . f) + +{-# INLINE init #-} +init :: (IsStream t, Monad m) => t m a -> m (Maybe (t m a)) +init m = go1 m + where + go1 m1 = do + r <- uncons m1 + case r of + Nothing -> return Nothing + 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 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 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 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 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 foldStream defState yieldk single stop m1 + +{-# INLINABLE all #-} +all :: (IsStream t, Monad m) => (a -> Bool) -> t m a -> m Bool +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 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 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 foldStream defState yieldk single (return False) m1 + +-- | Extract the last element of the stream, if any. +{-# INLINE last #-} +last :: (IsStream t, Monad m) => t m a -> m (Maybe a) +last = foldlx' (\_ y -> Just y) Nothing id + +{-# INLINE minimum #-} +minimum :: (IsStream t, Monad m, Ord a) => t m a -> m (Maybe a) +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 foldStream defState yieldk single stop m1 + + go (Just res) m1 = + let stop = return (Just res) + single a = + if res <= a + then return (Just res) + else return (Just a) + yieldk a r = + if res <= a + then go (Just res) r + else go (Just a) r + 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 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 = + if res <= a + then return (Just a) + else return (Just res) + yieldk a r = + if res <= a + then go (Just a) r + else go (Just res) r + 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 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 foldStream defState yieldk single (return Nothing) m1 + +{-# 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 = 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 = go 0 + where + 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 = foldStream (adaptState st) yld sng stp $ + go (offset + 1) x + in foldStream (adaptState st) yieldk single stp m1 + +------------------------------------------------------------------------------ +-- Map and Fold +------------------------------------------------------------------------------ + +-- | 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 m + where + go m1 = + let stop = return () + single a = void (f a) + yieldk a r = f a >> go r + in foldStream defState yieldk single stop m1 + +------------------------------------------------------------------------------ +-- Converting folds +------------------------------------------------------------------------------ + +{-# INLINABLE toList #-} +toList :: (IsStream t, Monad m) => t m a -> m [a] +toList = foldr (:) [] + +{-# INLINE toStreamK #-} +toStreamK :: Stream m a -> Stream m a +toStreamK = id + +-- Based on suggestions by David Feuer and Pranay Sashank +{-# INLINE hoist #-} +hoist :: (IsStream t, Monad m, Monad n) + => (forall x. m x -> n x) -> t m a -> t n a +hoist f str = + mkStream $ \st yld sng stp -> + let single = return . sng + yieldk a s = return $ yld a (hoist f s) + stop = return stp + state = adaptState st + in join . f $ foldStreamShared state yieldk single stop str + +------------------------------------------------------------------------------- +-- Transformation by folding (Scans) +------------------------------------------------------------------------------- + +{-# INLINE scanlx' #-} +scanlx' :: IsStream t => (x -> a -> x) -> x -> (x -> b) -> t m a -> t m b +scanlx' step begin done m = + cons (done begin) $ go m begin + where + 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 foldStream (adaptState st) yieldk single stp m1 + +{-# INLINE scanl' #-} +scanl' :: IsStream t => (b -> a -> b) -> b -> t m a -> t m b +scanl' step begin = scanlx' step begin id + +------------------------------------------------------------------------------- +-- Filtering +------------------------------------------------------------------------------- + +{-# INLINE filter #-} +filter :: IsStream t => (a -> Bool) -> t m a -> t m a +filter p m = go m + where + 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 = 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 = go n m + where + 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 foldStream st yieldk sng stp m1 + +{-# INLINE takeWhile #-} +takeWhile :: IsStream t => (a -> Bool) -> t m a -> t m a +takeWhile p m = go m + where + 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 foldStream st yieldk single stp m1 + +{-# INLINE drop #-} +drop :: IsStream t => Int -> t m a -> t m a +drop n m = fromStream $ unShare (go n (toStream m)) + where + go n1 m1 = mkStream $ \st yld sng stp -> + let single _ = stp + yieldk _ r = foldStreamShared st yld sng stp $ go (n1 - 1) r + -- Somehow "<=" check performs better than a ">" + in if n1 <= 0 + 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 = go m + where + go m1 = mkStream $ \st yld sng stp -> + let single a | p a = stp + | otherwise = sng a + yieldk a r | p a = foldStream st yieldk single stp r + | otherwise = yld a r + in foldStream st yieldk single stp m1 + +------------------------------------------------------------------------------- +-- Mapping +------------------------------------------------------------------------------- + +-- 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 m + where + go m1 = mkStream $ \st yld sng stp -> + let single ma = ma >>= sng + yieldk ma r = foldStreamShared st yld sng stp $ ma |: go r + in foldStream (adaptState st) yieldk single stp m1 + +------------------------------------------------------------------------------- +-- Inserting +------------------------------------------------------------------------------- + +{-# INLINE intersperseM #-} +intersperseM :: (IsStream t, MonadAsync m) => m a -> t m a -> t m a +intersperseM a m = prependingStart m + where + prependingStart m1 = mkStream $ \st yld sng stp -> + let yieldk i x = foldStreamShared st yld sng stp $ return i |: go x + in foldStream st yieldk sng stp m1 + go m2 = mkStream $ \st yld sng stp -> + let single i = foldStreamShared st yld sng stp $ a |: yield i + yieldk i x = foldStreamShared st yld sng stp $ a |: return i |: go x + in foldStream st yieldk single stp m2 + +{-# INLINE intersperse #-} +intersperse :: (IsStream t, MonadAsync m) => a -> t m a -> t m a +intersperse a = intersperseM (return a) + +{-# 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 + +------------------------------------------------------------------------------ +-- Reordering +------------------------------------------------------------------------------ + +{-# INLINE reverse #-} +reverse :: IsStream t => t m a -> t m a +reverse = foldlS (flip cons) nil + +------------------------------------------------------------------------------- +-- Map and Filter +------------------------------------------------------------------------------- + +{-# INLINE mapMaybe #-} +mapMaybe :: IsStream t => (a -> Maybe b) -> t m a -> t m b +mapMaybe f m = go m + where + 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 $ go r + Nothing -> foldStream (adaptState st) yieldk single stp r + in foldStream (adaptState st) yieldk single stp m1 + +------------------------------------------------------------------------------ +-- Serial Zipping +------------------------------------------------------------------------------ + +-- | 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 = 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 foldStream (adaptState st) yield2 single2 stp my + let single1 a = merge a nil + yield1 = merge + 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 = go m1 m2 + where + go mx my = mkStream $ \st yld sng stp -> do + let merge a ra = + 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 foldStream (adaptState st) yield2 single2 stp my + let single1 a = merge a nil + yield1 = merge + foldStream (adaptState st) yield1 single1 stp mx + +------------------------------------------------------------------------------ +-- Merging +------------------------------------------------------------------------------ + +{-# INLINE mergeByM #-} +mergeByM + :: (IsStream t, Monad m) + => (a -> a -> m Ordering) -> t m a -> t m a -> t m a +mergeByM cmp = go + where + go mx my = mkStream $ \st yld sng stp -> do + let mergeWithY a ra = + let stop2 = foldStream st yld sng stp mx + single2 b = do + r <- cmp a b + case r of + GT -> yld b (go (a `cons` ra) nil) + _ -> yld a (go ra (b `cons` nil)) + yield2 b rb = do + r <- cmp a b + case r of + GT -> yld b (go (a `cons` ra) rb) + _ -> yld a (go ra (b `cons` rb)) + in foldStream st yield2 single2 stop2 my + let stopX = foldStream st yld sng stp my + singleX a = mergeWithY a nil + yieldX = mergeWithY + foldStream st yieldX singleX stopX mx + +{-# INLINABLE mergeBy #-} +mergeBy + :: (IsStream t, Monad m) + => (a -> a -> Ordering) -> t m a -> t m a -> t m a +mergeBy cmp = mergeByM (\a b -> return $ cmp a b) + +------------------------------------------------------------------------------ +-- Transformation comprehensions +------------------------------------------------------------------------------ + +{-# 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 + +------------------------------------------------------------------------------ +-- Alternative & MonadPlus +------------------------------------------------------------------------------ + +_alt :: Stream m a -> Stream m a -> Stream m a +_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 = + mkStream $ \st yld sng stp -> + let single = local f . sng + yieldk a r = local f $ yld a (withLocal f r) + in foldStream st yieldk single (local f stp) m + +------------------------------------------------------------------------------ +-- MonadError +------------------------------------------------------------------------------ + +{- +-- XXX handle and test cross thread state transfer +withCatchError + :: MonadError e m + => Stream m a -> (e -> Stream m a) -> Stream m a +withCatchError m h = + 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 +-} diff --git a/src/Streamly/Internal/Data/Stream/StreamK/Type.hs b/src/Streamly/Internal/Data/Stream/StreamK/Type.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/StreamK/Type.hs @@ -0,0 +1,989 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ViewPatterns #-} +#if __GLASGOW_HASKELL__ >= 806 +{-# LANGUAGE QuantifiedConstraints #-} +#endif +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE UndecidableInstances #-} -- XXX + +#include "inline.hs" + +-- | +-- Module : Streamly.Internal.Data.Stream.StreamK.Type +-- Copyright : (c) 2017 Harendra Kumar +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.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.Internal.Data.Stream.StreamK.Type + ( + -- * A class for streams + IsStream (..) + , adapt + + -- * The stream type + , Stream (..) + + -- * Construction + , mkStream + , fromStopK + , fromYieldK + , consK + + -- * Elimination + , foldStream + , foldStreamShared + + -- * foldr/build + , foldrM + , foldrS + , foldrSM + , build + , buildS + , buildM + , buildSM + , sharedM + , augmentS + , augmentSM + + -- instances + , cons + , (.:) + , consMStream + , consMBy + , yieldM + , yield + + , nil + , nilM + , conjoin + , serial + , map + , mapM + , mapMSerial + , unShare + , concatMapBy + , concatMap + , bindWith + + , Streaming -- deprecated + ) +where + +import Control.Monad (ap, (>=>)) +import Control.Monad.Trans.Class (MonadTrans(lift)) +#if __GLASGOW_HASKELL__ >= 800 +import Data.Kind (Type) +#endif +#if __GLASGOW_HASKELL__ < 808 +import Data.Semigroup (Semigroup(..)) +#endif +import Prelude hiding (map, mapM, concatMap, foldr) + +import Streamly.Internal.Data.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 +#if __GLASGOW_HASKELL__ >= 806 + ( forall m a. MonadAsync m => Semigroup (t m a) + , forall m a. MonadAsync m => Monoid (t m a) + , forall m. Monad m => Functor (t m) + , forall m. MonadAsync m => Applicative (t m) + ) => +#endif + 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 + -- drain $ serially $ delay |: delay |: delay |: nil + -- drain $ 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. + +------------------------------------------------------------------------------ +-- Construction +------------------------------------------------------------------------------ + +infixr 5 `cons` + +-- faster than consM because there is no bind. +-- | Construct a stream by adding a pure value at the head of an existing +-- stream. For serial streams this is the same as @(return a) \`consM` r@ but +-- more efficient. For concurrent streams this is not concurrent whereas +-- 'consM' is concurrent. For example: +-- +-- @ +-- > toList $ 1 \`cons` 2 \`cons` 3 \`cons` nil +-- [1,2,3] +-- @ +-- +-- @since 0.1.0 +{-# INLINE_NORMAL cons #-} +cons :: IsStream t => a -> t m a -> t m a +cons a r = mkStream $ \_ yld _ _ -> yld a r + +infixr 5 .: + +-- | Operator equivalent of 'cons'. +-- +-- @ +-- > toList $ 1 .: 2 .: 3 .: nil +-- [1,2,3] +-- @ +-- +-- @since 0.1.1 +{-# INLINE (.:) #-} +(.:) :: IsStream t => a -> t m a -> t m a +(.:) = cons + +-- | An empty stream. +-- +-- @ +-- > toList nil +-- [] +-- @ +-- +-- @since 0.1.0 +{-# INLINE_NORMAL nil #-} +nil :: IsStream t => t m a +nil = mkStream $ \_ _ _ stp -> stp + +-- | An empty stream producing a side effect. +-- +-- @ +-- > toList (nilM (print "nil")) +-- "nil" +-- [] +-- @ +-- +-- /Internal/ +{-# INLINE_NORMAL nilM #-} +nilM :: (IsStream t, Monad m) => m b -> t m a +nilM m = mkStream $ \_ _ _ stp -> m >> stp + +{-# INLINE_NORMAL yield #-} +yield :: IsStream t => a -> t m a +yield a = mkStream $ \_ _ single _ -> single a + +{-# INLINE_NORMAL yieldM #-} +yieldM :: (Monad m, IsStream t) => m a -> t m a +yieldM m = fromStream $ mkStream $ \_ _ single _ -> m >>= single + +-- XXX specialize to IO? +{-# INLINE consMBy #-} +consMBy :: (IsStream t, MonadAsync m) => (t m a -> t m a -> t m a) + -> m a -> t m a -> t m a +consMBy f m r = (fromStream $ yieldM m) `f` r + +------------------------------------------------------------------------------ +-- 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 + +------------------------------------------------------------------------------- +-- 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 + +------------------------------------------------------------------------------- +-- foldr/build fusion +------------------------------------------------------------------------------- + +-- XXX perhaps we can just use foldrSM/buildM everywhere as they are more +-- general and cover foldrS/buildS as well. + +-- | The function 'f' decides how to reconstruct the stream. We could +-- reconstruct using a shared state (SVar) or without sharing the state. +-- +{-# INLINE foldrSWith #-} +foldrSWith :: IsStream t + => (forall r. State Stream m b + -> (b -> t m b -> m r) + -> (b -> m r) + -> m r + -> t m b + -> m r) + -> (a -> t m b -> t m b) -> t m b -> t m a -> t m b +foldrSWith f step final m = go m + where + go m1 = mkStream $ \st yld sng stp -> + let run x = f st yld sng stp x + stop = run final + single a = run $ step a final + yieldk a r = run $ step a (go r) + -- XXX if type a and b are the same we do not need adaptState, can we + -- save some perf with that? + -- XXX since we are using adaptState anyway here we can use + -- foldStreamShared instead, will that save some perf? + in foldStream (adaptState st) yieldk single stop m1 + +-- XXX we can use rewrite rules just for foldrSWith, if the function f is the +-- same we can rewrite it. + +-- | Fold sharing the SVar state within the reconstructed stream +{-# INLINE_NORMAL foldrSShared #-} +foldrSShared :: IsStream t => (a -> t m b -> t m b) -> t m b -> t m a -> t m b +foldrSShared = foldrSWith foldStreamShared + +-- XXX consM is a typeclass method, therefore rewritten already. Instead maybe +-- we can make consM polymorphic using rewrite rules. +-- {-# RULES "foldrSShared/id" foldrSShared consM nil = \x -> x #-} +{-# RULES "foldrSShared/nil" + forall k z. foldrSShared k z nil = z #-} +{-# RULES "foldrSShared/single" + forall k z x. foldrSShared k z (yield x) = k x z #-} +-- {-# RULES "foldrSShared/app" [1] +-- forall ys. foldrSShared consM ys = \xs -> xs `conjoin` ys #-} + +-- | Lazy right associative fold to a stream. +{-# INLINE_NORMAL foldrS #-} +foldrS :: IsStream t => (a -> t m b -> t m b) -> t m b -> t m a -> t m b +foldrS = foldrSWith foldStream + +{-# RULES "foldrS/id" foldrS cons nil = \x -> x #-} +{-# RULES "foldrS/nil" forall k z. foldrS k z nil = z #-} +-- See notes in GHC.Base about this rule +-- {-# RULES "foldr/cons" +-- forall k z x xs. foldrS k z (x `cons` xs) = k x (foldrS k z xs) #-} +{-# RULES "foldrS/single" forall k z x. foldrS k z (yield x) = k x z #-} +-- {-# RULES "foldrS/app" [1] +-- forall ys. foldrS cons ys = \xs -> xs `conjoin` ys #-} + +------------------------------------------------------------------------------- +-- foldrS with monadic cons i.e. consM +------------------------------------------------------------------------------- + +{-# INLINE foldrSMWith #-} +foldrSMWith :: (IsStream t, Monad m) + => (forall r. State Stream m b + -> (b -> t m b -> m r) + -> (b -> m r) + -> m r + -> t m b + -> m r) + -> (m a -> t m b -> t m b) -> t m b -> t m a -> t m b +foldrSMWith f step final m = go m + where + go m1 = mkStream $ \st yld sng stp -> + let run x = f st yld sng stp x + stop = run final + single a = run $ step (return a) final + yieldk a r = run $ step (return a) (go r) + in foldStream (adaptState st) yieldk single stop m1 + +{-# INLINE_NORMAL foldrSM #-} +foldrSM :: (IsStream t, Monad m) + => (m a -> t m b -> t m b) -> t m b -> t m a -> t m b +foldrSM = foldrSMWith foldStream + +-- {-# RULES "foldrSM/id" foldrSM consM nil = \x -> x #-} +{-# RULES "foldrSM/nil" forall k z. foldrSM k z nil = z #-} +{-# RULES "foldrSM/single" forall k z x. foldrSM k z (yieldM x) = k x z #-} +-- {-# RULES "foldrSM/app" [1] +-- forall ys. foldrSM consM ys = \xs -> xs `conjoin` ys #-} + +-- Like foldrSM but sharing the SVar state within the recostructed stream. +{-# INLINE_NORMAL foldrSMShared #-} +foldrSMShared :: (IsStream t, Monad m) + => (m a -> t m b -> t m b) -> t m b -> t m a -> t m b +foldrSMShared = foldrSMWith foldStreamShared + +-- {-# RULES "foldrSM/id" foldrSM consM nil = \x -> x #-} +{-# RULES "foldrSMShared/nil" + forall k z. foldrSMShared k z nil = z #-} +{-# RULES "foldrSMShared/single" + forall k z x. foldrSMShared k z (yieldM x) = k x z #-} +-- {-# RULES "foldrSM/app" [1] +-- forall ys. foldrSM consM ys = \xs -> xs `conjoin` ys #-} + +------------------------------------------------------------------------------- +-- build +------------------------------------------------------------------------------- + +{-# INLINE_NORMAL build #-} +build :: IsStream t => forall a. (forall b. (a -> b -> b) -> b -> b) -> t m a +build g = g cons nil + +{-# RULES "foldrM/build" + forall k z (g :: forall b. (a -> b -> b) -> b -> b). + foldrM k z (build g) = g k z #-} + +{-# RULES "foldrS/build" + forall k z (g :: forall b. (a -> b -> b) -> b -> b). + foldrS k z (build g) = g k z #-} + +{-# RULES "foldrS/cons/build" + forall k z x (g :: forall b. (a -> b -> b) -> b -> b). + foldrS k z (x `cons` build g) = k x (g k z) #-} + +{-# RULES "foldrSShared/build" + forall k z (g :: forall b. (a -> b -> b) -> b -> b). + foldrSShared k z (build g) = g k z #-} + +{-# RULES "foldrSShared/cons/build" + forall k z x (g :: forall b. (a -> b -> b) -> b -> b). + foldrSShared k z (x `cons` build g) = k x (g k z) #-} + +-- build a stream by applying cons and nil to a build function +{-# INLINE_NORMAL buildS #-} +buildS :: IsStream t => ((a -> t m a -> t m a) -> t m a -> t m a) -> t m a +buildS g = g cons nil + +{-# RULES "foldrS/buildS" + forall k z (g :: (a -> t m a -> t m a) -> t m a -> t m a). + foldrS k z (buildS g) = g k z #-} + +{-# RULES "foldrS/cons/buildS" + forall k z x (g :: (a -> t m a -> t m a) -> t m a -> t m a). + foldrS k z (x `cons` buildS g) = k x (g k z) #-} + +{-# RULES "foldrSShared/buildS" + forall k z (g :: (a -> t m a -> t m a) -> t m a -> t m a). + foldrSShared k z (buildS g) = g k z #-} + +{-# RULES "foldrSShared/cons/buildS" + forall k z x (g :: (a -> t m a -> t m a) -> t m a -> t m a). + foldrSShared k z (x `cons` buildS g) = k x (g k z) #-} + +-- build a stream by applying consM and nil to a build function +{-# INLINE_NORMAL buildSM #-} +buildSM :: (IsStream t, MonadAsync m) + => ((m a -> t m a -> t m a) -> t m a -> t m a) -> t m a +buildSM g = g consM nil + +{-# RULES "foldrSM/buildSM" + forall k z (g :: (m a -> t m a -> t m a) -> t m a -> t m a). + foldrSM k z (buildSM g) = g k z #-} + +{-# RULES "foldrSMShared/buildSM" + forall k z (g :: (m a -> t m a -> t m a) -> t m a -> t m a). + foldrSMShared k z (buildSM g) = g k z #-} + +-- Disabled because this may not fire as consM is a class Op +{- +{-# RULES "foldrS/consM/buildSM" + forall k z x (g :: (m a -> t m a -> t m a) -> t m a -> t m a) + . foldrSM k z (x `consM` buildSM g) + = k x (g k z) +#-} +-} + +-- Build using monadic build functions (continuations) instead of +-- reconstructing a stream. +{-# INLINE_NORMAL buildM #-} +buildM :: (IsStream t, MonadAsync m) + => (forall r. (a -> t m a -> m r) + -> (a -> m r) + -> m r + -> m r + ) + -> t m a +buildM g = mkStream $ \st yld sng stp -> + g (\a r -> foldStream st yld sng stp (return a `consM` r)) sng stp + +-- | Like 'buildM' but shares the SVar state across computations. +{-# INLINE_NORMAL sharedM #-} +sharedM :: (IsStream t, MonadAsync m) + => (forall r. (a -> t m a -> m r) + -> (a -> m r) + -> m r + -> m r + ) + -> t m a +sharedM g = mkStream $ \st yld sng stp -> + g (\a r -> foldStreamShared st yld sng stp (return a `consM` r)) sng stp + +------------------------------------------------------------------------------- +-- augment +------------------------------------------------------------------------------- + +{-# INLINE_NORMAL augmentS #-} +augmentS :: IsStream t + => ((a -> t m a -> t m a) -> t m a -> t m a) -> t m a -> t m a +augmentS g xs = g cons xs + +{-# RULES "augmentS/nil" + forall (g :: (a -> t m a -> t m a) -> t m a -> t m a). + augmentS g nil = buildS g + #-} + +{-# RULES "foldrS/augmentS" + forall k z xs (g :: (a -> t m a -> t m a) -> t m a -> t m a). + foldrS k z (augmentS g xs) = g k (foldrS k z xs) + #-} + +{-# RULES "augmentS/buildS" + forall (g :: (a -> t m a -> t m a) -> t m a -> t m a) + (h :: (a -> t m a -> t m a) -> t m a -> t m a). + augmentS g (buildS h) = buildS (\c n -> g c (h c n)) + #-} + +{-# INLINE_NORMAL augmentSM #-} +augmentSM :: (IsStream t, MonadAsync m) + => ((m a -> t m a -> t m a) -> t m a -> t m a) -> t m a -> t m a +augmentSM g xs = g consM xs + +{-# RULES "augmentSM/nil" + forall (g :: (m a -> t m a -> t m a) -> t m a -> t m a). + augmentSM g nil = buildSM g + #-} + +{-# RULES "foldrSM/augmentSM" + forall k z xs (g :: (m a -> t m a -> t m a) -> t m a -> t m a). + foldrSM k z (augmentSM g xs) = g k (foldrSM k z xs) + #-} + +{-# RULES "augmentSM/buildSM" + forall (g :: (m a -> t m a -> t m a) -> t m a -> t m a) + (h :: (m a -> t m a -> t m a) -> t m a -> t m a). + augmentSM g (buildSM h) = buildSM (\c n -> g c (h c n)) + #-} + +------------------------------------------------------------------------------- +-- Experimental foldrM/buildM +------------------------------------------------------------------------------- + +-- | Lazy right fold with a monadic step function. +{-# INLINE_NORMAL foldrM #-} +foldrM :: IsStream t => (a -> m b -> m b) -> m b -> t m a -> m b +foldrM step acc m = go m + where + go m1 = + let stop = acc + single a = step a acc + yieldk a r = step a (go r) + in foldStream defState yieldk single stop m1 + +{-# INLINE_NORMAL foldrMKWith #-} +foldrMKWith + :: (State Stream m a + -> (a -> t m a -> m b) + -> (a -> m b) + -> m b + -> t m a + -> m b) + -> (a -> m b -> m b) + -> m b + -> ((a -> t m a -> m b) -> (a -> m b) -> m b -> m b) + -> m b +foldrMKWith f step acc g = go g + where + go k = + let stop = acc + single a = step a acc + yieldk a r = step a (go (\yld sng stp -> f defState yld sng stp r)) + in k yieldk single stop + +{- +{-# RULES "foldrM/buildS" + forall k z (g :: (a -> t m a -> t m a) -> t m a -> t m a) + . foldrM k z (buildS g) + = g k z +#-} +-} +-- XXX in which case will foldrM/buildM fusion be useful? +{-# RULES "foldrM/buildM" + forall step acc (g :: (forall r. + (a -> t m a -> m r) + -> (a -> m r) + -> m r + -> m r + )). + foldrM step acc (buildM g) = foldrMKWith foldStream step acc g + #-} + +{-# RULES "foldrM/sharedM" + forall step acc (g :: (forall r. + (a -> t m a -> m r) + -> (a -> m r) + -> m r + -> m r + )). + foldrM step acc (sharedM g) = foldrMKWith foldStreamShared step acc g + #-} + +------------------------------------------------------------------------------ +-- 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 +-- XXX This doubles the time of toNullAp benchmark, may not be fusing properly +-- serial xs ys = augmentS (\c n -> foldrS c n xs) ys +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 + +-- join/merge/append streams depending on consM +{-# INLINE conjoin #-} +conjoin :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a +conjoin xs ys = augmentSM (\c n -> foldrSM c n xs) ys + +instance Semigroup (Stream m a) where + (<>) = serial + +------------------------------------------------------------------------------ +-- Monoid +------------------------------------------------------------------------------ + +instance Monoid (Stream m a) where + mempty = nil + mappend = (<>) + +------------------------------------------------------------------------------- +-- Functor +------------------------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ < 800 +#define Type * +#endif +-- Note eta expanded +{-# INLINE_LATE mapFB #-} +mapFB :: forall (t :: (Type -> Type) -> Type -> Type) b m a. + (b -> t m b -> t m b) -> (a -> b) -> a -> t m b -> t m b +mapFB c f = \x ys -> c (f x) ys +#undef Type + +{-# RULES +"mapFB/mapFB" forall c f g. mapFB (mapFB c f) g = mapFB c (f . g) +"mapFB/id" forall c. mapFB c (\x -> x) = c + #-} + +{-# INLINE map #-} +map :: IsStream t => (a -> b) -> t m a -> t m b +map f xs = buildS (\c n -> foldrS (mapFB c f) n xs) + +-- XXX This definition might potentially be more efficient, but the cost in the +-- benchmark is dominated by unfoldrM cost so we cannot correctly determine +-- differences in the mapping cost. We should perhaps deduct the cost of +-- unfoldrM from the benchmarks and then compare. +{- +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 +-} + +{-# INLINE_LATE mapMFB #-} +mapMFB :: Monad m => (m b -> t m b -> t m b) -> (a -> m b) -> m a -> t m b -> t m b +mapMFB c f = \x ys -> c (x >>= f) ys + +{-# RULES + "mapMFB/mapMFB" forall c f g. mapMFB (mapMFB c f) g = mapMFB c (f >=> g) + #-} +-- XXX These rules may never fire because pure/return type class rules will +-- fire first. +{- +"mapMFB/pure" forall c. mapMFB c (\x -> pure x) = c +"mapMFB/return" forall c. mapMFB c (\x -> return x) = c +-} + +-- 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 = foldrSShared (\x xs -> f x `consM` xs) nil +-- See note under map definition above. +{- +mapM f m = go m + where + go m1 = mkStream $ \st yld sng stp -> + let single a = f a >>= sng + yieldk a r = foldStreamShared st yld sng stp $ f a |: go r + in foldStream (adaptState st) yieldk single stp m1 + -} + +-- This is experimental serial version supporting fusion. +-- +-- XXX what if we do not want to fuse two concurrent mapMs? +-- XXX we can combine two concurrent mapM only if the SVar is of the same type +-- So for now we use it only for serial streams. +-- XXX fusion would be easier for monomoprhic stream types. +-- {-# RULES "mapM serial" mapM = mapMSerial #-} +{-# INLINE mapMSerial #-} +mapMSerial :: MonadAsync m => (a -> m b) -> Stream m a -> Stream m b +mapMSerial f xs = buildSM (\c n -> foldrSMShared (mapMFB c f) n xs) + +-- XXX 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 +------------------------------------------------------------------------------- + +instance MonadTrans Stream where + lift = yieldM + +------------------------------------------------------------------------------- +-- Nesting +------------------------------------------------------------------------------- + +-- | 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 + +-- XXX This is just concatMapBy with arguments flipped. We need to keep this +-- instead of using a concatMap style definition because the bind +-- implementation in Async and WAsync streams show significant perf degradation +-- if the argument order is changed. +{-# INLINE bindWith #-} +bindWith + :: 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 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 + +-- XXX express in terms of foldrS? +-- XXX can we use a different stream type for the generated stream being +-- falttened so that we can combine them differently and keep the resulting +-- stream different? +-- XXX do we need specialize to IO? +-- XXX can we optimize when c and a are same, by removing the forall using +-- rewrite rules with type applications? + +-- | Perform a 'concatMap' using a specified concat strategy. The first +-- argument specifies a merge or concat function that is used to merge the +-- streams generated by the map function. For example, the concat function +-- could be 'serial', 'parallel', 'async', 'ahead' or any other zip or merge +-- function. +-- +-- @since 0.7.0 +{-# INLINE concatMapBy #-} +concatMapBy + :: IsStream t + => (forall c. t m c -> t m c -> t m c) + -> (a -> t m b) + -> t m a + -> t m b +concatMapBy par f xs = bindWith par xs f + +{-# INLINE concatMap #-} +concatMap :: IsStream t => (a -> t m b) -> t m a -> t m b +concatMap f m = fromStream $ + concatMapBy serial + (\a -> adapt $ toStream $ f a) + (adapt $ toStream m) + +{- +-- Fused version. +-- XXX This fuses but when the stream is nil this performs poorly. +-- The filterAllOut benchmark degrades. Need to investigate and fix that. +{-# INLINE concatMap #-} +concatMap :: IsStream t => (a -> t m b) -> t m a -> t m b +concatMap f xs = buildS + (\c n -> foldrS (\x b -> foldrS c b (f x)) n xs) + +-- Stream polymorphic concatMap implementation +-- XXX need to use buildSM/foldrSMShared for parallel behavior +-- XXX unShare seems to degrade the fused performance +{-# INLINE_EARLY concatMap_ #-} +concatMap_ :: IsStream t => (a -> t m b) -> t m a -> t m b +concatMap_ f xs = buildS + (\c n -> foldrSShared (\x b -> foldrSShared c b (unShare $ f x)) n xs) +-} + +instance Monad m => Applicative (Stream m) where + {-# INLINE pure #-} + pure = yield + {-# INLINE (<*>) #-} + (<*>) = ap + +-- NOTE: even though concatMap for StreamD is 3x faster compared to StreamK, +-- the monad instance of StreamD is slower than StreamK after foldr/build +-- fusion. +instance Monad m => Monad (Stream m) where + {-# INLINE return #-} + return = pure + {-# INLINE (>>=) #-} + (>>=) = flip concatMap + +{- +-- Like concatMap but generates stream using an unfold function. Similar to +-- concatUnfold but for StreamK. +concatUnfoldr :: IsStream t + => (b -> t m (Maybe (a, b))) -> t m b -> t m a +concatUnfoldr = undefined +-} diff --git a/src/Streamly/Internal/Data/Stream/Zip.hs b/src/Streamly/Internal/Data/Stream/Zip.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/Zip.hs @@ -0,0 +1,266 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving#-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- XXX + +-- | +-- Module : Streamly.Internal.Data.Stream.Zip +-- Copyright : (c) 2017 Harendra Kumar +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- +module Streamly.Internal.Data.Stream.Zip + ( + ZipSerialM + , ZipSerial + , zipSerially + + , ZipAsyncM + , ZipAsync + , zipAsyncly + + , zipWith + , zipWithM + , zipAsyncWith + , zipAsyncWithM + + -- * Deprecated + , ZipStream + , zipping + , zippingAsync + ) +where + +import Control.Applicative (liftA2) +import Control.DeepSeq (NFData(..)) +#if MIN_VERSION_deepseq(1,4,3) +import Control.DeepSeq (NFData1(..)) +#endif +import Data.Foldable (Foldable(foldl'), fold) +import Data.Functor.Identity (Identity(..), runIdentity) +import Data.Maybe (fromMaybe) +import Data.Semigroup (Endo(..)) +#if __GLASGOW_HASKELL__ < 808 +import Data.Semigroup (Semigroup(..)) +#endif +import GHC.Exts (IsList(..), IsString(..)) +import Text.Read (Lexeme(Ident), lexP, parens, prec, readPrec, readListPrec, + readListPrecDefault) +import Prelude hiding (map, repeat, zipWith, errorWithoutStackTrace) + +import Streamly.Internal.BaseCompat ((#.), errorWithoutStackTrace) +import Streamly.Internal.Data.Stream.StreamK (IsStream(..), Stream) +import Streamly.Internal.Data.Strict (Maybe'(..), toMaybe) +import Streamly.Internal.Data.SVar (MonadAsync) + +import qualified Streamly.Internal.Data.Stream.Prelude as P +import qualified Streamly.Internal.Data.Stream.StreamK as K +import qualified Streamly.Internal.Data.Stream.StreamD as D + +#ifdef USE_STREAMK_ONLY +import qualified Streamly.Internal.Data.Stream.StreamK as S +#else +import qualified Streamly.Internal.Data.Stream.StreamD as S +#endif + +#include "Instances.hs" + +-- | 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 = P.fromStreamS $ S.zipWithM f (P.toStreamS m1) (P.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 = P.fromStreamS $ S.zipWith f (P.toStreamS m1) (P.toStreamS m2) + +------------------------------------------------------------------------------ +-- Parallel Zipping +------------------------------------------------------------------------------ + +-- | Like 'zipWithM' but zips concurrently i.e. both the streams being zipped +-- are generated concurrently. +-- +-- @since 0.4.0 +{-# INLINE zipAsyncWithM #-} +zipAsyncWithM :: (IsStream t, MonadAsync m) + => (a -> b -> m c) -> t m a -> t m b -> t m c +zipAsyncWithM f m1 m2 = D.fromStreamD $ + D.zipWithM f (D.mkParallelD $ D.toStreamD m1) + (D.mkParallelD $ D.toStreamD m2) + +-- | Like 'zipWith' but zips concurrently i.e. both the streams being zipped +-- are generated concurrently. +-- +-- @since 0.1.0 +{-# INLINE zipAsyncWith #-} +zipAsyncWith :: (IsStream t, MonadAsync m) + => (a -> b -> c) -> t m a -> t m b -> t m c +zipAsyncWith f = zipAsyncWithM (\a b -> return (f a b)) + +------------------------------------------------------------------------------ +-- Serially Zipping Streams +------------------------------------------------------------------------------ + +-- | The applicative instance of 'ZipSerialM' zips a number of streams serially +-- i.e. it produces one element from each stream serially and then zips all +-- those elements. +-- +-- @ +-- main = (toList . 'zipSerially' $ (,,) \<$\> s1 \<*\> s2 \<*\> s3) >>= print +-- where s1 = fromFoldable [1, 2] +-- s2 = fromFoldable [3, 4] +-- s3 = fromFoldable [5, 6] +-- @ +-- @ +-- [(1,3,5),(2,4,6)] +-- @ +-- +-- The 'Semigroup' instance of this type works the same way as that of +-- 'SerialT'. +-- +-- @since 0.2.0 +newtype ZipSerialM m a = ZipSerialM {getZipSerialM :: Stream m a} + deriving (Semigroup, Monoid) + +-- | +-- @since 0.1.0 +{-# DEPRECATED ZipStream "Please use 'ZipSerialM' instead." #-} +type ZipStream = ZipSerialM + +-- | An IO stream whose applicative instance zips streams serially. +-- +-- @since 0.2.0 +type ZipSerial = ZipSerialM IO + +-- | Fix the type of a polymorphic stream as 'ZipSerialM'. +-- +-- @since 0.2.0 +zipSerially :: IsStream t => ZipSerialM m a -> t m a +zipSerially = K.adapt + +-- | Same as 'zipSerially'. +-- +-- @since 0.1.0 +{-# DEPRECATED zipping "Please use zipSerially instead." #-} +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 + + {-# INLINE consM #-} + {-# SPECIALIZE consM :: IO a -> ZipSerialM IO a -> ZipSerialM IO a #-} + consM :: Monad m => m a -> ZipSerialM m a -> ZipSerialM m a + consM = consMZip + + {-# INLINE (|:) #-} + {-# SPECIALIZE (|:) :: IO a -> ZipSerialM IO a -> ZipSerialM IO a #-} + (|:) :: Monad m => m a -> ZipSerialM m a -> ZipSerialM m a + (|:) = consMZip + +LIST_INSTANCES(ZipSerialM) +NFDATA1_INSTANCE(ZipSerialM) + +instance Monad m => Functor (ZipSerialM m) where + {-# INLINE fmap #-} + fmap f (ZipSerialM m) = D.fromStreamD $ D.mapM (return . f) $ D.toStreamD m + +instance Monad m => Applicative (ZipSerialM m) where + pure = ZipSerialM . K.repeat + {-# INLINE (<*>) #-} + (<*>) = zipWith id + +FOLDABLE_INSTANCE(ZipSerialM) +TRAVERSABLE_INSTANCE(ZipSerialM) + +------------------------------------------------------------------------------ +-- Parallely Zipping Streams +------------------------------------------------------------------------------ +-- +-- | Like 'ZipSerialM' but zips in parallel, it generates all the elements to +-- be zipped concurrently. +-- +-- @ +-- main = (toList . 'zipAsyncly' $ (,,) \<$\> s1 \<*\> s2 \<*\> s3) >>= print +-- where s1 = fromFoldable [1, 2] +-- s2 = fromFoldable [3, 4] +-- s3 = fromFoldable [5, 6] +-- @ +-- @ +-- [(1,3,5),(2,4,6)] +-- @ +-- +-- The 'Semigroup' instance of this type works the same way as that of +-- 'SerialT'. +-- +-- @since 0.2.0 +newtype ZipAsyncM m a = ZipAsyncM {getZipAsyncM :: Stream m a} + deriving (Semigroup, Monoid) + +-- | An IO stream whose applicative instance zips streams wAsyncly. +-- +-- @since 0.2.0 +type ZipAsync = ZipAsyncM IO + +-- | Fix the type of a polymorphic stream as 'ZipAsyncM'. +-- +-- @since 0.2.0 +zipAsyncly :: IsStream t => ZipAsyncM m a -> t m a +zipAsyncly = K.adapt + +-- | Same as 'zipAsyncly'. +-- +-- @since 0.1.0 +{-# 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 + + {-# INLINE consM #-} + {-# SPECIALIZE consM :: IO a -> ZipAsyncM IO a -> ZipAsyncM IO a #-} + consM :: Monad m => m a -> ZipAsyncM m a -> ZipAsyncM m a + consM = consMZipAsync + + {-# INLINE (|:) #-} + {-# SPECIALIZE (|:) :: IO a -> ZipAsyncM IO a -> ZipAsyncM IO a #-} + (|:) :: Monad m => m a -> ZipAsyncM m a -> ZipAsyncM m a + (|:) = consMZipAsync + +instance Monad m => Functor (ZipAsyncM m) where + {-# INLINE fmap #-} + fmap f (ZipAsyncM m) = D.fromStreamD $ D.mapM (return . f) $ D.toStreamD m + +instance MonadAsync m => Applicative (ZipAsyncM m) where + pure = ZipAsyncM . K.repeat + {-# INLINE (<*>) #-} + m1 <*> m2 = zipAsyncWith id m1 m2 diff --git a/src/Streamly/Internal/Data/Strict.hs b/src/Streamly/Internal/Data/Strict.hs --- a/src/Streamly/Internal/Data/Strict.hs +++ b/src/Streamly/Internal/Data/Strict.hs @@ -1,5 +1,3 @@ -{-# OPTIONS_HADDOCK hide #-} - -- | -- Module : Streamly.Internal.Data.Strict -- Copyright : (c) 2019 Composewell Technologies @@ -25,7 +23,7 @@ , Tuple3' (..) , Tuple4' (..) , Maybe' (..) - , fromStrictMaybe + , toMaybe , Either' (..) ) where @@ -48,10 +46,10 @@ -- XXX perhaps we can use a type class having fromStrict/toStrict operations. -- -- | Convert strict Maybe' to lazy Maybe -{-# INLINABLE fromStrictMaybe #-} -fromStrictMaybe :: Monad m => Maybe' a -> m (Maybe a) -fromStrictMaybe Nothing' = return $ Nothing -fromStrictMaybe (Just' a) = return $ Just a +{-# INLINABLE toMaybe #-} +toMaybe :: Maybe' a -> Maybe a +toMaybe Nothing' = Nothing +toMaybe (Just' a) = Just a ------------------------------------------------------------------------------- -- Either diff --git a/src/Streamly/Internal/Data/Time.hs b/src/Streamly/Internal/Data/Time.hs --- a/src/Streamly/Internal/Data/Time.hs +++ b/src/Streamly/Internal/Data/Time.hs @@ -1,5 +1,3 @@ -{-# OPTIONS_HADDOCK hide #-} - -- | -- Module : Streamly.Internal.Data.Time -- Copyright : (c) 2017 Harendra Kumar diff --git a/src/Streamly/Internal/Data/Time/Clock.hsc b/src/Streamly/Internal/Data/Time/Clock.hsc --- a/src/Streamly/Internal/Data/Time/Clock.hsc +++ b/src/Streamly/Internal/Data/Time/Clock.hsc @@ -1,4 +1,3 @@ -{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} diff --git a/src/Streamly/Internal/Data/Time/Units.hs b/src/Streamly/Internal/Data/Time/Units.hs --- a/src/Streamly/Internal/Data/Time/Units.hs +++ b/src/Streamly/Internal/Data/Time/Units.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} diff --git a/src/Streamly/Internal/Data/Unfold.hs b/src/Streamly/Internal/Data/Unfold.hs --- a/src/Streamly/Internal/Data/Unfold.hs +++ b/src/Streamly/Internal/Data/Unfold.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} @@ -87,6 +86,7 @@ , identity , const , replicateM + , repeatM , fromList , fromListM , enumerateFromStepIntegral @@ -112,16 +112,22 @@ -- * Exceptions , gbracket + , gbracketIO , before , after + , afterIO , onException , finally + , finallyIO , bracket + , bracketIO , handle ) where import Control.Exception (Exception) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Trans.Control (MonadBaseControl) import Data.Void (Void) import GHC.Types (SPEC(..)) import Prelude hiding (concat, map, mapM, takeWhile, take, filter, const) @@ -132,14 +138,14 @@ #endif import Streamly.Internal.Data.Unfold.Types (Unfold(..)) import Streamly.Internal.Data.Fold.Types (Fold(..)) -import Streamly.Internal.Data.SVar (defState) +import Streamly.Internal.Data.SVar (defState, MonadAsync) import Control.Monad.Catch (MonadCatch) import qualified Prelude import qualified Control.Monad.Catch as MC import qualified Data.Tuple as Tuple -import qualified Streamly.Streams.StreamK as K -import qualified Streamly.Streams.StreamD as D +import qualified Streamly.Internal.Data.Stream.StreamK as K +import qualified Streamly.Internal.Data.Stream.StreamD as D ------------------------------------------------------------------------------- -- Input operations @@ -404,6 +410,15 @@ then Stop else Yield x (x, (i - 1)) +-- | Generates an infinite stream repeating the seed. +-- +{-# INLINE repeatM #-} +repeatM :: Monad m => Unfold m a a +repeatM = Unfold step return + where + {-# INLINE_LATE step #-} + step x = return $ Yield x x + -- | Convert a list of pure values to a 'Stream' {-# INLINE_LATE fromList #-} fromList :: Monad m => Unfold m [a] a @@ -644,6 +659,53 @@ Skip s -> return $ Skip (Left s) Stop -> return Stop +-- | The most general bracketing and exception combinator. All other +-- combinators can be expressed in terms of this combinator. This can also be +-- used for cases which are not covered by the standard combinators. +-- +-- /Internal/ +-- +{-# INLINE_NORMAL gbracketIO #-} +gbracketIO + :: (MonadIO m, MonadBaseControl IO m) + => (a -> m c) -- ^ before + -> (forall s. m s -> m (Either e s)) -- ^ try (exception handling) + -> (c -> m d) -- ^ after, on normal stop, or GC + -> Unfold m (c, e) b -- ^ on exception + -> Unfold m c b -- ^ unfold to run + -> Unfold m a b +gbracketIO bef exc aft (Unfold estep einject) (Unfold step1 inject1) = + Unfold step inject + + where + + inject x = do + r <- bef x + ref <- D.newFinalizedIORef (aft r) + s <- inject1 r + return $ Right (s, r, ref) + + {-# INLINE_LATE step #-} + step (Right (st, v, ref)) = do + res <- exc $ step1 st + case res of + Right r -> case r of + Yield x s -> return $ Yield x (Right (s, v, ref)) + Skip s -> return $ Skip (Right (s, v, ref)) + Stop -> do + D.runIORefFinalizer ref + return Stop + Left e -> do + D.clearIORefFinalizer ref + r <- einject (v, e) + return $ Skip (Left r) + step (Left st) = do + res <- estep st + case res of + Yield x s -> return $ Yield x (Left s) + Skip s -> return $ Skip (Left s) + Stop -> return Stop + -- The custom implementation of "before" is slightly faster (5-7%) than -- "_before". This is just to document and make sure that we can always use -- gbracket to implement before. The same applies to other combinators as well. @@ -681,6 +743,10 @@ -- | Run a side effect whenever the unfold stops normally. -- +-- Prefer afterIO over this as the @after@ action in this combinator is not +-- executed if the unfold is partially evaluated lazily and then garbage +-- collected. +-- -- /Internal/ {-# INLINE_NORMAL after #-} after :: Monad m => (a -> m c) -> Unfold m a b -> Unfold m a b @@ -700,6 +766,32 @@ Skip s -> return $ Skip (s, v) Stop -> action v >> return Stop +-- | Run a side effect whenever the unfold stops normally +-- or is garbage collected after a partial lazy evaluation. +-- +-- /Internal/ +{-# INLINE_NORMAL afterIO #-} +afterIO :: (MonadIO m, MonadBaseControl IO m) + => (a -> m c) -> Unfold m a b -> Unfold m a b +afterIO action (Unfold step1 inject1) = Unfold step inject + + where + + inject x = do + s <- inject1 x + ref <- D.newFinalizedIORef (action x) + return (s, ref) + + {-# INLINE_LATE step #-} + step (st, ref) = do + res <- step1 st + case res of + Yield x s -> return $ Yield x (s, ref) + Skip s -> return $ Skip (s, ref) + Stop -> do + D.runIORefFinalizer ref + return Stop + {-# INLINE_NORMAL _onException #-} _onException :: MonadCatch m => (a -> m c) -> Unfold m a b -> Unfold m a b _onException action unf = @@ -737,6 +829,10 @@ -- | Run a side effect whenever the unfold stops normally or aborts due to an -- exception. -- +-- Prefer finallyIO over this as the @after@ action in this combinator is not +-- executed if the unfold is partially evaluated lazily and then garbage +-- collected. +-- -- /Internal/ {-# INLINE_NORMAL finally #-} finally :: MonadCatch m => (a -> m c) -> Unfold m a b -> Unfold m a b @@ -756,6 +852,32 @@ Skip s -> return $ Skip (s, v) Stop -> action v >> return Stop +-- | Run a side effect whenever the unfold stops normally, aborts due to an +-- exception or if it is garbage collected after a partial lazy evaluation. +-- +-- /Internal/ +{-# INLINE_NORMAL finallyIO #-} +finallyIO :: (MonadAsync m, MonadCatch m) + => (a -> m c) -> Unfold m a b -> Unfold m a b +finallyIO action (Unfold step1 inject1) = Unfold step inject + + where + + inject x = do + s <- inject1 x + ref <- D.newFinalizedIORef (action x) + return (s, ref) + + {-# INLINE_LATE step #-} + step (st, ref) = do + res <- step1 st `MC.onException` D.runIORefFinalizer ref + case res of + Yield x s -> return $ Yield x (s, ref) + Skip s -> return $ Skip (s, ref) + Stop -> do + D.runIORefFinalizer ref + return Stop + {-# INLINE_NORMAL _bracket #-} _bracket :: MonadCatch m => (a -> m c) -> (c -> m d) -> Unfold m c b -> Unfold m a b @@ -768,6 +890,10 @@ -- if an exception occurs then the @after@ action is run with the output of -- @before@ as argument. -- +-- Prefer bracketIO over this as the @after@ action in this combinator is not +-- executed if the unfold is partially evaluated lazily and then garbage +-- collected. +-- -- /Internal/ {-# INLINE_NORMAL bracket #-} bracket :: MonadCatch m @@ -788,6 +914,36 @@ Yield x s -> return $ Yield x (s, v) Skip s -> return $ Skip (s, v) Stop -> aft v >> return Stop + +-- | @bracket before after between@ runs the @before@ action and then unfolds +-- its output using the @between@ unfold. When the @between@ unfold is done or +-- if an exception occurs then the @after@ action is run with the output of +-- @before@ as argument. The after action is also executed if the unfold is +-- paritally evaluated and then garbage collected. +-- +-- /Internal/ +{-# INLINE_NORMAL bracketIO #-} +bracketIO :: (MonadAsync m, MonadCatch m) + => (a -> m c) -> (c -> m d) -> Unfold m c b -> Unfold m a b +bracketIO bef aft (Unfold step1 inject1) = Unfold step inject + + where + + inject x = do + r <- bef x + s <- inject1 r + ref <- D.newFinalizedIORef (aft r) + return (s, ref) + + {-# INLINE_LATE step #-} + step (st, ref) = do + res <- step1 st `MC.onException` D.runIORefFinalizer ref + case res of + Yield x s -> return $ Yield x (s, ref) + Skip s -> return $ Skip (s, ref) + Stop -> do + D.runIORefFinalizer ref + return Stop -- | When unfolding if an exception occurs, unfold the exception using the -- exception unfold supplied as the first argument to 'handle'. diff --git a/src/Streamly/Internal/Data/Unfold/Types.hs b/src/Streamly/Internal/Data/Unfold/Types.hs --- a/src/Streamly/Internal/Data/Unfold/Types.hs +++ b/src/Streamly/Internal/Data/Unfold/Types.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} diff --git a/src/Streamly/Internal/Data/Unicode/Char.hs b/src/Streamly/Internal/Data/Unicode/Char.hs --- a/src/Streamly/Internal/Data/Unicode/Char.hs +++ b/src/Streamly/Internal/Data/Unicode/Char.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE FlexibleContexts #-} -- | diff --git a/src/Streamly/Internal/Data/Unicode/Stream.hs b/src/Streamly/Internal/Data/Unicode/Stream.hs --- a/src/Streamly/Internal/Data/Unicode/Stream.hs +++ b/src/Streamly/Internal/Data/Unicode/Stream.hs @@ -1,24 +1,32 @@ -{-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} -- | -- Module : Streamly.Data.Internal.Unicode.Stream -- Copyright : (c) 2018 Composewell Technologies +-- (c) Bjoern Hoehrmann 2008-2009 -- -- License : BSD3 -- Maintainer : streamly@composewell.com -- Stability : experimental -- Portability : GHC -- + +#include "inline.hs" + module Streamly.Internal.Data.Unicode.Stream ( -- * Construction (Decoding) decodeLatin1 , decodeUtf8 , decodeUtf8Lax - , D.DecodeError(..) - , D.DecodeState - , D.CodePoint + , DecodeError(..) + , DecodeState + , CodePoint , decodeUtf8Either , resumeDecodeUtf8Either , decodeUtf8Arrays @@ -33,6 +41,16 @@ , strip -- (dropAround isSpace) , stripEnd -} + + -- * StreamD UTF8 Encoding / Decoding transformations. + , decodeUtf8D + , encodeUtf8D + , decodeUtf8LenientD + , decodeUtf8EitherD + , resumeDecodeUtf8EitherD + , decodeUtf8ArraysD + , decodeUtf8ArraysLenientD + -- * Transformation , stripStart , lines @@ -42,23 +60,519 @@ ) where -import Control.Monad.IO.Class (MonadIO) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Bits (shiftR, shiftL, (.|.), (.&.)) import Data.Char (ord) import Data.Word (Word8) -import GHC.Base (unsafeChr) -import Streamly (IsStream) +import Foreign.ForeignPtr (touchForeignPtr) +import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) +import Foreign.Storable (Storable(..)) +import GHC.Base (assert, unsafeChr) +import GHC.ForeignPtr (ForeignPtr (..)) +import GHC.IO.Encoding.Failure (isSurrogate) +import GHC.Ptr (Ptr (..), plusPtr) import Prelude hiding (String, lines, words, unlines, unwords) +import System.IO.Unsafe (unsafePerformIO) + +import Streamly (IsStream) import Streamly.Data.Fold (Fold) import Streamly.Memory.Array (Array) import Streamly.Internal.Data.Unfold (Unfold) +import Streamly.Internal.Data.SVar (adaptState) +import Streamly.Internal.Data.Stream.StreamD (Stream(..), Step (..)) +import Streamly.Internal.Data.Strict (Tuple'(..)) +#if __GLASGOW_HASKELL__ < 800 +import Streamly.Internal.Data.Stream.StreamD (pattern Stream) +#endif + +import qualified Streamly.Internal.Memory.Array.Types as A import qualified Streamly.Internal.Prelude as S -import qualified Streamly.Streams.StreamD as D +import qualified Streamly.Internal.Data.Stream.StreamD as D ------------------------------------------------------------------------------- --- Encoding/Decoding Unicode Characters +-- Encoding/Decoding Unicode (UTF-8) Characters ------------------------------------------------------------------------------- +-- UTF-8 primitives, Lifted from GHC.IO.Encoding.UTF8. + +data WList = WCons !Word8 !WList | WNil + +{-# INLINE ord2 #-} +ord2 :: Char -> WList +ord2 c = assert (n >= 0x80 && n <= 0x07ff) (WCons x1 (WCons x2 WNil)) + where + n = ord c + x1 = fromIntegral $ (n `shiftR` 6) + 0xC0 + x2 = fromIntegral $ (n .&. 0x3F) + 0x80 + +{-# INLINE ord3 #-} +ord3 :: Char -> WList +ord3 c = assert (n >= 0x0800 && n <= 0xffff) (WCons x1 (WCons x2 (WCons x3 WNil))) + where + n = ord c + x1 = fromIntegral $ (n `shiftR` 12) + 0xE0 + x2 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80 + x3 = fromIntegral $ (n .&. 0x3F) + 0x80 + +{-# INLINE ord4 #-} +ord4 :: Char -> WList +ord4 c = assert (n >= 0x10000) (WCons x1 (WCons x2 (WCons x3 (WCons x4 WNil)))) + where + n = ord c + x1 = fromIntegral $ (n `shiftR` 18) + 0xF0 + x2 = fromIntegral $ ((n `shiftR` 12) .&. 0x3F) + 0x80 + x3 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80 + x4 = fromIntegral $ (n .&. 0x3F) + 0x80 + +data CodingFailureMode + = TransliterateCodingFailure + | ErrorOnCodingFailure + deriving (Show) + +{-# INLINE replacementChar #-} +replacementChar :: Char +replacementChar = '\xFFFD' + +-- Int helps in cheaper conversion from Int to Char +type CodePoint = Int +type DecodeState = Word8 + +-- See http://bjoern.hoehrmann.de/utf-8/decoder/dfa/ for details. + +-- XXX Use names decodeSuccess = 0, decodeFailure = 12 + +decodeTable :: [Word8] +decodeTable = [ + -- The first part of the table maps bytes to character classes that + -- to reduce the size of the transition table and create bitmasks. + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9, + 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, + 8,8,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, + 10,3,3,3,3,3,3,3,3,3,3,3,3,4,3,3, 11,6,6,6,5,8,8,8,8,8,8,8,8,8,8,8, + + -- The second part is a transition table that maps a combination + -- of a state of the automaton and a character class to a state. + 0,12,24,36,60,96,84,12,12,12,48,72, 12,12,12,12,12,12,12,12,12,12,12,12, + 12, 0,12,12,12,12,12, 0,12, 0,12,12, 12,24,12,12,12,12,12,24,12,24,12,12, + 12,12,12,12,12,12,12,24,12,12,12,12, 12,24,12,12,12,12,12,12,12,24,12,12, + 12,12,12,12,12,12,12,36,12,36,12,12, 12,36,12,12,12,12,12,36,12,36,12,12, + 12,36,12,12,12,12,12,12,12,12,12,12 + ] + +utf8d :: A.Array Word8 +utf8d = + unsafePerformIO + -- Aligning to cacheline makes a barely noticeable difference + -- XXX currently alignment is not implemented for unmanaged allocation + $ D.runFold (A.writeNAlignedUnmanaged 64 (length decodeTable)) + (D.fromList decodeTable) + +-- | Return element at the specified index without checking the bounds. +-- and without touching the foreign ptr. +{-# INLINE_NORMAL unsafePeekElemOff #-} +unsafePeekElemOff :: forall a. Storable a => Ptr a -> Int -> a +unsafePeekElemOff p i = let !x = A.unsafeInlineIO $ peekElemOff p i in x + +-- decode is split into two separate cases to avoid branching instructions. +-- From the higher level flow we already know which case we are in so we can +-- call the appropriate decode function. +-- +-- When the state is 0 +{-# INLINE decode0 #-} +decode0 :: Ptr Word8 -> Word8 -> Tuple' DecodeState CodePoint +decode0 table byte = + let !t = table `unsafePeekElemOff` fromIntegral byte + !codep' = (0xff `shiftR` (fromIntegral t)) .&. fromIntegral byte + !state' = table `unsafePeekElemOff` (256 + fromIntegral t) + in assert ((byte > 0x7f || error showByte) + && (state' /= 0 || error (showByte ++ showTable))) + (Tuple' state' codep') + + where + + utf8table = + let !(Ptr addr) = table + end = table `plusPtr` 364 + in A.Array (ForeignPtr addr undefined) end end :: A.Array Word8 + showByte = "Streamly: decode0: byte: " ++ show byte + showTable = " table: " ++ show utf8table + +-- When the state is not 0 +{-# INLINE decode1 #-} +decode1 + :: Ptr Word8 + -> DecodeState + -> CodePoint + -> Word8 + -> Tuple' DecodeState CodePoint +decode1 table state codep byte = + -- Remember codep is Int type! + -- Can it be unsafe to convert the resulting Int to Char? + let !t = table `unsafePeekElemOff` fromIntegral byte + !codep' = (fromIntegral byte .&. 0x3f) .|. (codep `shiftL` 6) + !state' = table `unsafePeekElemOff` + (256 + fromIntegral state + fromIntegral t) + in assert (codep' <= 0x10FFFF + || error (showByte ++ showState state codep)) + (Tuple' state' codep') + where + + utf8table = + let !(Ptr addr) = table + end = table `plusPtr` 364 + in A.Array (ForeignPtr addr undefined) end end :: A.Array Word8 + showByte = "Streamly: decode1: byte: " ++ show byte + showState st cp = + " state: " ++ show st ++ + " codepoint: " ++ show cp ++ + " table: " ++ show utf8table + +-- We can divide the errors in three general categories: +-- * A non-starter was encountered in a begin state +-- * A starter was encountered without completing a codepoint +-- * The last codepoint was not complete (input underflow) +-- +data DecodeError = DecodeError !DecodeState !CodePoint deriving Show + +data FreshPoint s a + = FreshPointDecodeInit s + | FreshPointDecodeInit1 s Word8 + | FreshPointDecodeFirst s Word8 + | FreshPointDecoding s !DecodeState !CodePoint + | YieldAndContinue a (FreshPoint s a) + | Done + +-- XXX Add proper error messages +-- XXX Implement this in terms of decodeUtf8Either +{-# INLINE_NORMAL decodeUtf8WithD #-} +decodeUtf8WithD :: Monad m => CodingFailureMode -> Stream m Word8 -> Stream m Char +decodeUtf8WithD cfm (Stream step state) = + let A.Array p _ _ = utf8d + !ptr = (unsafeForeignPtrToPtr p) + in Stream (step' ptr) (FreshPointDecodeInit state) + where + {-# INLINE transliterateOrError #-} + transliterateOrError e s = + case cfm of + ErrorOnCodingFailure -> error e + TransliterateCodingFailure -> YieldAndContinue replacementChar s + {-# INLINE inputUnderflow #-} + inputUnderflow = + case cfm of + ErrorOnCodingFailure -> + error "Streamly.Internal.Data.Stream.StreamD.decodeUtf8With: Input Underflow" + TransliterateCodingFailure -> YieldAndContinue replacementChar Done + {-# INLINE_LATE step' #-} + step' _ gst (FreshPointDecodeInit st) = do + r <- step (adaptState gst) st + return $ case r of + Yield x s -> Skip (FreshPointDecodeInit1 s x) + Skip s -> Skip (FreshPointDecodeInit s) + Stop -> Skip Done + + step' _ _ (FreshPointDecodeInit1 st x) = do + -- Note: It is important to use a ">" instead of a "<=" test + -- here for GHC to generate code layout for default branch + -- prediction for the common case. This is fragile and might + -- change with the compiler versions, we need a more reliable + -- "likely" primitive to control branch predication. + case x > 0x7f of + False -> + return $ Skip $ YieldAndContinue + (unsafeChr (fromIntegral x)) + (FreshPointDecodeInit st) + -- Using a separate state here generates a jump to a + -- separate code block in the core which seems to perform + -- slightly better for the non-ascii case. + True -> return $ Skip $ FreshPointDecodeFirst st x + + -- XXX should we merge it with FreshPointDecodeInit1? + step' table _ (FreshPointDecodeFirst st x) = do + let (Tuple' sv cp) = decode0 table x + return $ + case sv of + 12 -> + Skip $ + transliterateOrError + "Streamly.Internal.Data.Stream.StreamD.decodeUtf8With: Invalid UTF8 codepoint encountered" + (FreshPointDecodeInit st) + 0 -> error "unreachable state" + _ -> Skip (FreshPointDecoding st sv cp) + + -- We recover by trying the new byte x a starter of a new codepoint. + -- XXX need to use the same recovery in array decoding routine as well + step' table gst (FreshPointDecoding st statePtr codepointPtr) = do + r <- step (adaptState gst) st + case r of + Yield x s -> do + let (Tuple' sv cp) = decode1 table statePtr codepointPtr x + return $ + case sv of + 0 -> Skip $ YieldAndContinue (unsafeChr cp) + (FreshPointDecodeInit s) + 12 -> + Skip $ + transliterateOrError + "Streamly.Internal.Data.Stream.StreamD.decodeUtf8With: Invalid UTF8 codepoint encountered" + (FreshPointDecodeInit1 s x) + _ -> Skip (FreshPointDecoding s sv cp) + Skip s -> return $ Skip (FreshPointDecoding s statePtr codepointPtr) + Stop -> return $ Skip inputUnderflow + + step' _ _ (YieldAndContinue c s) = return $ Yield c s + step' _ _ Done = return Stop + +{-# INLINE decodeUtf8D #-} +decodeUtf8D :: Monad m => Stream m Word8 -> Stream m Char +decodeUtf8D = decodeUtf8WithD ErrorOnCodingFailure + +{-# INLINE decodeUtf8LenientD #-} +decodeUtf8LenientD :: Monad m => Stream m Word8 -> Stream m Char +decodeUtf8LenientD = decodeUtf8WithD TransliterateCodingFailure + +{-# INLINE_NORMAL resumeDecodeUtf8EitherD #-} +resumeDecodeUtf8EitherD + :: Monad m + => DecodeState + -> CodePoint + -> Stream m Word8 + -> Stream m (Either DecodeError Char) +resumeDecodeUtf8EitherD dst codep (Stream step state) = + let A.Array p _ _ = utf8d + !ptr = (unsafeForeignPtrToPtr p) + stt = + if dst == 0 + then FreshPointDecodeInit state + else FreshPointDecoding state dst codep + in Stream (step' ptr) stt + where + {-# INLINE_LATE step' #-} + step' _ gst (FreshPointDecodeInit st) = do + r <- step (adaptState gst) st + return $ case r of + Yield x s -> Skip (FreshPointDecodeInit1 s x) + Skip s -> Skip (FreshPointDecodeInit s) + Stop -> Skip Done + + step' _ _ (FreshPointDecodeInit1 st x) = do + -- Note: It is important to use a ">" instead of a "<=" test + -- here for GHC to generate code layout for default branch + -- prediction for the common case. This is fragile and might + -- change with the compiler versions, we need a more reliable + -- "likely" primitive to control branch predication. + case x > 0x7f of + False -> + return $ Skip $ YieldAndContinue + (Right $ unsafeChr (fromIntegral x)) + (FreshPointDecodeInit st) + -- Using a separate state here generates a jump to a + -- separate code block in the core which seems to perform + -- slightly better for the non-ascii case. + True -> return $ Skip $ FreshPointDecodeFirst st x + + -- XXX should we merge it with FreshPointDecodeInit1? + step' table _ (FreshPointDecodeFirst st x) = do + let (Tuple' sv cp) = decode0 table x + return $ + case sv of + 12 -> + Skip $ YieldAndContinue (Left $ DecodeError 0 (fromIntegral x)) + (FreshPointDecodeInit st) + 0 -> error "unreachable state" + _ -> Skip (FreshPointDecoding st sv cp) + + -- We recover by trying the new byte x a starter of a new codepoint. + -- XXX need to use the same recovery in array decoding routine as well + step' table gst (FreshPointDecoding st statePtr codepointPtr) = do + r <- step (adaptState gst) st + case r of + Yield x s -> do + let (Tuple' sv cp) = decode1 table statePtr codepointPtr x + return $ + case sv of + 0 -> Skip $ YieldAndContinue (Right $ unsafeChr cp) + (FreshPointDecodeInit s) + 12 -> + Skip $ YieldAndContinue (Left $ DecodeError statePtr codepointPtr) + (FreshPointDecodeInit1 s x) + _ -> Skip (FreshPointDecoding s sv cp) + Skip s -> return $ Skip (FreshPointDecoding s statePtr codepointPtr) + Stop -> return $ Skip $ YieldAndContinue (Left $ DecodeError statePtr codepointPtr) Done + + step' _ _ (YieldAndContinue c s) = return $ Yield c s + step' _ _ Done = return Stop + +{-# INLINE_NORMAL decodeUtf8EitherD #-} +decodeUtf8EitherD :: Monad m + => Stream m Word8 -> Stream m (Either DecodeError Char) +decodeUtf8EitherD = resumeDecodeUtf8EitherD 0 0 + +data FlattenState s a + = OuterLoop s !(Maybe (DecodeState, CodePoint)) + | InnerLoopDecodeInit s (ForeignPtr a) !(Ptr a) !(Ptr a) + | InnerLoopDecodeFirst s (ForeignPtr a) !(Ptr a) !(Ptr a) Word8 + | InnerLoopDecoding s (ForeignPtr a) !(Ptr a) !(Ptr a) + !DecodeState !CodePoint + | YAndC !Char (FlattenState s a) -- These constructors can be + -- encoded in the FreshPoint + -- type, I prefer to keep these + -- flat even though that means + -- coming up with new names + | D + +-- The normal decodeUtf8 above should fuse with flattenArrays +-- to create this exact code but it doesn't for some reason, as of now this +-- remains the fastest way I could figure out to decodeUtf8. +-- +-- XXX Add Proper error messages +{-# INLINE_NORMAL decodeUtf8ArraysWithD #-} +decodeUtf8ArraysWithD :: + MonadIO m + => CodingFailureMode + -> Stream m (A.Array Word8) + -> Stream m Char +decodeUtf8ArraysWithD cfm (Stream step state) = + let A.Array p _ _ = utf8d + !ptr = (unsafeForeignPtrToPtr p) + in Stream (step' ptr) (OuterLoop state Nothing) + where + {-# INLINE transliterateOrError #-} + transliterateOrError e s = + case cfm of + ErrorOnCodingFailure -> error e + TransliterateCodingFailure -> YAndC replacementChar s + {-# INLINE inputUnderflow #-} + inputUnderflow = + case cfm of + ErrorOnCodingFailure -> + error + "Streamly.Internal.Data.Stream.StreamD.decodeUtf8ArraysWith: Input Underflow" + TransliterateCodingFailure -> YAndC replacementChar D + {-# INLINE_LATE step' #-} + step' _ gst (OuterLoop st Nothing) = do + r <- step (adaptState gst) st + return $ + case r of + Yield A.Array {..} s -> + let p = unsafeForeignPtrToPtr aStart + in Skip (InnerLoopDecodeInit s aStart p aEnd) + Skip s -> Skip (OuterLoop s Nothing) + Stop -> Skip D + step' _ gst (OuterLoop st dst@(Just (ds, cp))) = do + r <- step (adaptState gst) st + return $ + case r of + Yield A.Array {..} s -> + let p = unsafeForeignPtrToPtr aStart + in Skip (InnerLoopDecoding s aStart p aEnd ds cp) + Skip s -> Skip (OuterLoop s dst) + Stop -> Skip inputUnderflow + step' _ _ (InnerLoopDecodeInit st startf p end) + | p == end = do + liftIO $ touchForeignPtr startf + return $ Skip $ OuterLoop st Nothing + step' _ _ (InnerLoopDecodeInit st startf p end) = do + x <- liftIO $ peek p + -- Note: It is important to use a ">" instead of a "<=" test here for + -- GHC to generate code layout for default branch prediction for the + -- common case. This is fragile and might change with the compiler + -- versions, we need a more reliable "likely" primitive to control + -- branch predication. + case x > 0x7f of + False -> + return $ Skip $ YAndC + (unsafeChr (fromIntegral x)) + (InnerLoopDecodeInit st startf (p `plusPtr` 1) end) + -- Using a separate state here generates a jump to a separate code + -- block in the core which seems to perform slightly better for the + -- non-ascii case. + True -> return $ Skip $ InnerLoopDecodeFirst st startf p end x + + step' table _ (InnerLoopDecodeFirst st startf p end x) = do + let (Tuple' sv cp) = decode0 table x + return $ + case sv of + 12 -> + Skip $ + transliterateOrError + "Streamly.Internal.Data.Stream.StreamD.decodeUtf8ArraysWith: Invalid UTF8 codepoint encountered" + (InnerLoopDecodeInit st startf (p `plusPtr` 1) end) + 0 -> error "unreachable state" + _ -> Skip (InnerLoopDecoding st startf (p `plusPtr` 1) end sv cp) + step' _ _ (InnerLoopDecoding st startf p end sv cp) + | p == end = do + liftIO $ touchForeignPtr startf + return $ Skip $ OuterLoop st (Just (sv, cp)) + step' table _ (InnerLoopDecoding st startf p end statePtr codepointPtr) = do + x <- liftIO $ peek p + let (Tuple' sv cp) = decode1 table statePtr codepointPtr x + return $ + case sv of + 0 -> + Skip $ + YAndC + (unsafeChr cp) + (InnerLoopDecodeInit st startf (p `plusPtr` 1) end) + 12 -> + Skip $ + transliterateOrError + "Streamly.Internal.Data.Stream.StreamD.decodeUtf8ArraysWith: Invalid UTF8 codepoint encountered" + (InnerLoopDecodeInit st startf (p `plusPtr` 1) end) + _ -> Skip (InnerLoopDecoding st startf (p `plusPtr` 1) end sv cp) + step' _ _ (YAndC c s) = return $ Yield c s + step' _ _ D = return Stop + +{-# INLINE decodeUtf8ArraysD #-} +decodeUtf8ArraysD :: + MonadIO m + => Stream m (A.Array Word8) + -> Stream m Char +decodeUtf8ArraysD = decodeUtf8ArraysWithD ErrorOnCodingFailure + +{-# INLINE decodeUtf8ArraysLenientD #-} +decodeUtf8ArraysLenientD :: + MonadIO m + => Stream m (A.Array Word8) + -> Stream m Char +decodeUtf8ArraysLenientD = decodeUtf8ArraysWithD TransliterateCodingFailure + +data EncodeState s = EncodeState s !WList + +-- More yield points improve performance, but I am not sure if they can cause +-- too much code bloat or some trouble with fusion. So keeping only two yield +-- points for now, one for the ascii chars (fast path) and one for all other +-- paths (slow path). +{-# INLINE_NORMAL encodeUtf8D #-} +encodeUtf8D :: Monad m => Stream m Char -> Stream m Word8 +encodeUtf8D (Stream step state) = Stream step' (EncodeState state WNil) + where + {-# INLINE_LATE step' #-} + step' gst (EncodeState st WNil) = do + r <- step (adaptState gst) st + return $ + case r of + Yield c s -> + case ord c of + x + | x <= 0x7F -> + Yield (fromIntegral x) (EncodeState s WNil) + | x <= 0x7FF -> Skip (EncodeState s (ord2 c)) + | x <= 0xFFFF -> + if isSurrogate c + then error + "Streamly.Internal.Data.Stream.StreamD.encodeUtf8: Encountered a surrogate" + else Skip (EncodeState s (ord3 c)) + | otherwise -> Skip (EncodeState s (ord4 c)) + Skip s -> Skip (EncodeState s WNil) + Stop -> Stop + step' _ (EncodeState s (WCons x xs)) = return $ Yield x (EncodeState s xs) + + -- | Decode a stream of bytes to Unicode characters by mapping each byte to a -- corresponding Unicode 'Char' in 0-255 range. -- @@ -79,8 +593,8 @@ convert c = let codepoint = ord c in if codepoint > 255 - then error $ "Streamly.String.encodeLatin1 invalid \ - \input char codepoint " ++ show codepoint + then error $ "Streamly.String.encodeLatin1 invalid " ++ + "input char codepoint " ++ show codepoint else fromIntegral codepoint -- | Like 'encodeLatin1' but silently truncates and maps input characters beyond @@ -98,14 +612,14 @@ -- /Since: 0.7.0/ {-# INLINE decodeUtf8 #-} decodeUtf8 :: (Monad m, IsStream t) => t m Word8 -> t m Char -decodeUtf8 = D.fromStreamD . D.decodeUtf8 . D.toStreamD +decodeUtf8 = D.fromStreamD . decodeUtf8D . D.toStreamD -- | -- -- /Internal/ {-# INLINE decodeUtf8Arrays #-} decodeUtf8Arrays :: (MonadIO m, IsStream t) => t m (Array Word8) -> t m Char -decodeUtf8Arrays = D.fromStreamD . D.decodeUtf8Arrays . D.toStreamD +decodeUtf8Arrays = D.fromStreamD . decodeUtf8ArraysD . D.toStreamD -- | Decode a UTF-8 encoded bytestream to a stream of Unicode characters. -- Any invalid codepoint encountered is replaced with the unicode replacement @@ -114,15 +628,15 @@ -- /Since: 0.7.0/ {-# INLINE decodeUtf8Lax #-} decodeUtf8Lax :: (Monad m, IsStream t) => t m Word8 -> t m Char -decodeUtf8Lax = D.fromStreamD . D.decodeUtf8Lenient . D.toStreamD +decodeUtf8Lax = D.fromStreamD . decodeUtf8LenientD . D.toStreamD -- | -- -- /Internal/ {-# INLINE decodeUtf8Either #-} decodeUtf8Either :: (Monad m, IsStream t) - => t m Word8 -> t m (Either D.DecodeError Char) -decodeUtf8Either = D.fromStreamD . D.decodeUtf8Either . D.toStreamD + => t m Word8 -> t m (Either DecodeError Char) +decodeUtf8Either = D.fromStreamD . decodeUtf8EitherD . D.toStreamD -- | -- @@ -130,12 +644,12 @@ {-# INLINE resumeDecodeUtf8Either #-} resumeDecodeUtf8Either :: (Monad m, IsStream t) - => D.DecodeState - -> D.CodePoint + => DecodeState + -> CodePoint -> t m Word8 - -> t m (Either D.DecodeError Char) + -> t m (Either DecodeError Char) resumeDecodeUtf8Either st cp = - D.fromStreamD . D.resumeDecodeUtf8Either st cp . D.toStreamD + D.fromStreamD . resumeDecodeUtf8EitherD st cp . D.toStreamD -- | -- @@ -144,14 +658,14 @@ decodeUtf8ArraysLenient :: (MonadIO m, IsStream t) => t m (Array Word8) -> t m Char decodeUtf8ArraysLenient = - D.fromStreamD . D.decodeUtf8ArraysLenient . D.toStreamD + D.fromStreamD . decodeUtf8ArraysLenientD . D.toStreamD -- | Encode a stream of Unicode characters to a UTF-8 encoded bytestream. -- -- /Since: 0.7.0/ {-# INLINE encodeUtf8 #-} encodeUtf8 :: (Monad m, IsStream t) => t m Char -> t m Word8 -encodeUtf8 = D.fromStreamD . D.encodeUtf8 . D.toStreamD +encodeUtf8 = D.fromStreamD . encodeUtf8D . D.toStreamD {- ------------------------------------------------------------------------------- diff --git a/src/Streamly/Internal/FileSystem/Dir.hs b/src/Streamly/Internal/FileSystem/Dir.hs --- a/src/Streamly/Internal/FileSystem/Dir.hs +++ b/src/Streamly/Internal/FileSystem/Dir.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-} @@ -73,8 +72,8 @@ -- import Streamly.Internal.Memory.Array.Types -- (Array(..), writeNUnsafe, defaultChunkSize, shrinkToFit, -- lpackArraysChunksOf) --- import Streamly.Streams.Serial (SerialT) -import Streamly.Streams.StreamK.Type (IsStream) +-- import Streamly.Internal.Data.Stream.Serial (SerialT) +import Streamly.Internal.Data.Stream.StreamK.Type (IsStream) -- import Streamly.String (encodeUtf8, decodeUtf8, foldLines) -- import qualified Streamly.Data.Fold as FL diff --git a/src/Streamly/Internal/FileSystem/File.hs b/src/Streamly/Internal/FileSystem/File.hs --- a/src/Streamly/Internal/FileSystem/File.hs +++ b/src/Streamly/Internal/FileSystem/File.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} @@ -22,7 +21,7 @@ -- session consisting of multiple reads and writes to the handle, these APIs -- are one shot read or write APIs. These APIs open the file handle, perform -- the requested operation and close the handle. Thease are safer compared to --- the handle based APIs as there is no possiblity of a file descriptor +-- the handle based APIs as there is no possibility of a file descriptor -- leakage. -- -- > import qualified Streamly.Internal.FileSystem.File as File @@ -107,8 +106,8 @@ import Streamly.Internal.Data.Unfold.Types (Unfold(..)) import Streamly.Internal.Memory.Array.Types (Array(..), defaultChunkSize, writeNUnsafe) -import Streamly.Streams.Serial (SerialT) -import Streamly.Streams.StreamK.Type (IsStream) +import Streamly.Internal.Data.Stream.Serial (SerialT) +import Streamly.Internal.Data.Stream.StreamK.Type (IsStream) import Streamly.Internal.Data.SVar (MonadAsync) -- import Streamly.Data.Fold (Fold) -- import Streamly.String (encodeUtf8, decodeUtf8, foldLines) diff --git a/src/Streamly/Internal/FileSystem/Handle.hs b/src/Streamly/Internal/FileSystem/Handle.hs --- a/src/Streamly/Internal/FileSystem/Handle.hs +++ b/src/Streamly/Internal/FileSystem/Handle.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} @@ -64,7 +63,8 @@ , fromChunks , putChunks , putStrings - -- , putLines + , putBytes + , putLines -- -- * Random Access (Seek) -- -- | Unlike the streaming APIs listed above, these APIs apply to devices or @@ -123,13 +123,12 @@ import Streamly.Internal.Memory.Array.Types (Array(..), writeNUnsafe, defaultChunkSize, shrinkToFit, lpackArraysChunksOf) -import Streamly.Streams.Serial (SerialT) -import Streamly.Streams.StreamK.Type (IsStream, mkStream) +import Streamly.Internal.Data.Stream.Serial (SerialT) +import Streamly.Internal.Data.Stream.StreamK.Type (IsStream, mkStream) -- import Streamly.String (encodeUtf8, decodeUtf8, foldLines) import qualified Streamly.Data.Fold as FL import qualified Streamly.Internal.Data.Fold.Types as FL -import qualified Streamly.Internal.Data.Unicode.Stream as U import qualified Streamly.Internal.Data.Unfold as UF import qualified Streamly.Internal.Memory.Array as IA import qualified Streamly.Internal.Memory.ArrayStream as AS @@ -346,6 +345,7 @@ -- Writing ------------------------------------------------------------------------------- +-- XXX use an unfold to fromObjects or fromUnfold so that we can put any object -- | Write a stream of arrays to a handle. -- -- @since 0.7.0 @@ -362,13 +362,39 @@ putChunks :: (MonadIO m, Storable a) => SerialT m (Array a) -> m () putChunks = fromChunks stdout --- | Write a stream of strings to standard output using Latin1 encoding. +-- XXX use an unfold so that we can put any type of strings. +-- | Write a stream of strings to standard output using the supplied encoding. +-- Output is flushed to the device for each string. -- -- /Internal/ -- {-# INLINE putStrings #-} -putStrings :: MonadAsync m => SerialT m String -> m () -putStrings = putChunks . S.mapM (IA.fromStream . U.encodeLatin1 . S.fromList) +putStrings :: MonadAsync m + => (SerialT m Char -> SerialT m Word8) -> SerialT m String -> m () +putStrings encode = putChunks . S.mapM (IA.fromStream . encode . S.fromList) + +-- XXX use an unfold so that we can put lines from any object +-- | Write a stream of strings as separate lines to standard output using the +-- supplied encoding. Output is line buffered i.e. the output is written to the +-- device as soon as a newline is encountered. +-- +-- /Internal/ +-- +{-# INLINE putLines #-} +putLines :: MonadAsync m + => (SerialT m Char -> SerialT m Word8) -> SerialT m String -> m () +putLines encode = putChunks . S.mapM + (\xs -> IA.fromStream $ encode (S.fromList (xs ++ "\n"))) + +-- | Write a stream of bytes from standard output. +-- +-- > putBytes = fromBytes stdout +-- +-- /Internal/ +-- +{-# INLINE putBytes #-} +putBytes :: MonadIO m => SerialT m Word8 -> m () +putBytes = fromBytes stdout -- | @fromChunksWithBufferOf bufsize handle stream@ writes a stream of arrays -- to @handle@ after coalescing the adjacent arrays in chunks of @bufsize@. diff --git a/src/Streamly/Internal/Memory/Array.hs b/src/Streamly/Internal/Memory/Array.hs --- a/src/Streamly/Internal/Memory/Array.hs +++ b/src/Streamly/Internal/Memory/Array.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} @@ -57,6 +56,7 @@ -- Monadic APIs -- , newArray , A.writeN -- drop new + , A.writeNAligned , A.write -- full buffer -- , writeLastN -- drop old (ring buffer) @@ -66,6 +66,7 @@ , toStream , toStreamRev , read + , unsafeRead -- , readChunksOf -- * Random Access @@ -74,6 +75,7 @@ , last -- , (!!) , readIndex + , A.unsafeIndex -- , readIndices -- , readRanges @@ -121,6 +123,9 @@ -- * Folding Arrays , streamFold , fold + + -- * Folds with Array as the container + , D.lastN ) where @@ -133,18 +138,20 @@ import GHC.ForeignPtr (ForeignPtr(..)) import GHC.Ptr (Ptr(..)) +import GHC.Prim (touch#) +import GHC.IO (IO(..)) import Streamly.Internal.Data.Fold.Types (Fold(..)) import Streamly.Internal.Data.Unfold.Types (Unfold(..)) import Streamly.Internal.Memory.Array.Types (Array(..), length) -import Streamly.Streams.Serial (SerialT) -import Streamly.Streams.StreamK.Type (IsStream) +import Streamly.Internal.Data.Stream.Serial (SerialT) +import Streamly.Internal.Data.Stream.StreamK.Type (IsStream) import qualified Streamly.Internal.Memory.Array.Types as A -import qualified Streamly.Streams.Prelude as P -import qualified Streamly.Streams.Serial as Serial -import qualified Streamly.Streams.StreamD as D -import qualified Streamly.Streams.StreamK as K +import qualified Streamly.Internal.Data.Stream.Prelude as P +import qualified Streamly.Internal.Data.Stream.Serial as Serial +import qualified Streamly.Internal.Data.Stream.StreamD as D +import qualified Streamly.Internal.Data.Stream.StreamK as K ------------------------------------------------------------------------------- -- Construction @@ -236,6 +243,41 @@ let !x = A.unsafeInlineIO $ peek p return $ D.Yield x (ReadUState fp (p `plusPtr` (sizeOf (undefined :: a)))) + +-- | Unfold an array into a stream, does not check the end of the array, the +-- user is responsible for terminating the stream within the array bounds. For +-- high performance application where the end condition can be determined by +-- a terminating fold. +-- +-- Written in the hope that it may be faster than "read", however, in the case +-- for which this was written, "read" proves to be faster even though the core +-- generated with unsafeRead looks simpler. +-- +-- /Internal/ +-- +{-# INLINE_NORMAL unsafeRead #-} +unsafeRead :: forall m a. (Monad m, Storable a) => Unfold m (Array a) a +unsafeRead = Unfold step inject + where + + inject (Array fp _ _) = return fp + + {-# INLINE_LATE step #-} + step (ForeignPtr p contents) = do + -- unsafeInlineIO allows us to run this in Identity monad for pure + -- toList/foldr case which makes them much faster due to not + -- accumulating the list and fusing better with the pure consumers. + -- + -- This should be safe as the array contents are guaranteed to be + -- evaluated/written to before we peek at them. + let !x = A.unsafeInlineIO $ do + r <- peek (Ptr p) + touch contents + return r + let !(Ptr p1) = Ptr p `plusPtr` (sizeOf (undefined :: a)) + return $ D.Yield x (ForeignPtr p1 contents) + + touch r = IO $ \s -> case touch# r s of s' -> (# s', () #) -- | > null arr = length arr == 0 -- diff --git a/src/Streamly/Internal/Memory/Array/Types.hs b/src/Streamly/Internal/Memory/Array/Types.hs --- a/src/Streamly/Internal/Memory/Array/Types.hs +++ b/src/Streamly/Internal/Memory/Array/Types.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ExistentialQuantification #-} @@ -121,7 +120,7 @@ import qualified Streamly.Memory.Malloc as Malloc import qualified Streamly.Internal.Data.Stream.StreamD.Type as D -import qualified Streamly.Streams.StreamK as K +import qualified Streamly.Internal.Data.Stream.StreamK as K import qualified GHC.Exts as Exts #ifdef DEVBUILD @@ -286,7 +285,7 @@ -- -- Internal routine for when the array is being created. Appends one item at -- the end of the array. Useful when sequentially writing a stream to the --- array. DOES NOT CHECK THE ARRAY BOUNDS. +-- array. {-# INLINE unsafeSnoc #-} unsafeSnoc :: forall a. Storable a => Array a -> a -> IO (Array a) unsafeSnoc arr@Array{..} x = do @@ -539,7 +538,7 @@ writeN :: forall m a. (MonadIO m, Storable a) => Int -> Fold m a (Array a) writeN = writeNAllocWith newArray --- | @writeNAligned n@ folds a maximum of @n@ elements from the input +-- | @writeNAligned alignment n@ folds a maximum of @n@ elements from the input -- stream to an 'Array' aligned to the given size. -- -- /Internal/ diff --git a/src/Streamly/Internal/Memory/ArrayStream.hs b/src/Streamly/Internal/Memory/ArrayStream.hs --- a/src/Streamly/Internal/Memory/ArrayStream.hs +++ b/src/Streamly/Internal/Memory/ArrayStream.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} @@ -50,14 +49,14 @@ import Prelude hiding (length, null, last, map, (!!), read, concat) import Streamly.Internal.Memory.Array.Types (Array(..), length) -import Streamly.Streams.Serial (SerialT) -import Streamly.Streams.StreamK.Type (IsStream) +import Streamly.Internal.Data.Stream.Serial (SerialT) +import Streamly.Internal.Data.Stream.StreamK.Type (IsStream) import qualified Streamly.Internal.Memory.Array as A import qualified Streamly.Internal.Memory.Array.Types as A import qualified Streamly.Internal.Prelude as S -import qualified Streamly.Streams.StreamD as D -import qualified Streamly.Streams.Prelude as P +import qualified Streamly.Internal.Data.Stream.StreamD as D +import qualified Streamly.Internal.Data.Stream.Prelude as P -- XXX efficiently compare two streams of arrays. Two streams can have chunks -- of different sizes, we can handle that in the stream comparison abstraction. diff --git a/src/Streamly/Internal/Memory/Unicode/Array.hs b/src/Streamly/Internal/Memory/Unicode/Array.hs --- a/src/Streamly/Internal/Memory/Unicode/Array.hs +++ b/src/Streamly/Internal/Memory/Unicode/Array.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE FlexibleContexts #-} -- | diff --git a/src/Streamly/Internal/Mutable/Prim/Var.hs b/src/Streamly/Internal/Mutable/Prim/Var.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Mutable/Prim/Var.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE ScopedTypeVariables #-} + +#include "inline.hs" + +-- | +-- Module : Streamly.Internal.Mutable.Prim.Var +-- Copyright : (c) 2019 Composewell Technologies +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- A mutable variable in a mutation capable monad (IO/ST) holding a 'Prim' +-- value. This allows fast modification because of unboxed storage. +-- +-- = Multithread Consistency Notes +-- +-- In general, any value that straddles a machine word cannot be guaranteed to +-- be consistently read from another thread without a lock. GHC heap objects +-- are always machine word aligned, therefore, a 'Var' is also word aligned. On +-- a 64-bit platform, writing a 64-bit aligned type from one thread and reading +-- it from another thread should give consistent old or new value. The same +-- holds true for 32-bit values on a 32-bit platform. + +module Streamly.Internal.Mutable.Prim.Var + ( + Var + , MonadMut + , Prim + + -- * Construction + , newVar + + -- * Write + , writeVar + , modifyVar' + + -- * Read + , readVar + ) +where + +import Control.Monad.Primitive (PrimMonad(..), primitive_) +import Data.Primitive.Types (Prim, sizeOf#, readByteArray#, writeByteArray#) +import GHC.Exts (MutableByteArray#, newByteArray#) + +-- | A 'Var' holds a single 'Prim' value. +data Var m a = Var (MutableByteArray# (PrimState m)) + +-- The name PrimMonad does not give a clue what it means, an explicit "Mut" +-- suffix provides a better hint. MonadMut is just a generalization of MonadIO. +-- +-- | A monad that allows mutable operations using a state token. +type MonadMut = PrimMonad + +-- | Create a new mutable variable. +{-# INLINE newVar #-} +newVar :: forall m a. (MonadMut m, Prim a) => a -> m (Var m a) +newVar x = primitive (\s# -> + case newByteArray# (sizeOf# (undefined :: a)) s# of + (# s1#, arr# #) -> + case writeByteArray# arr# 0# x s1# of + s2# -> (# s2#, Var arr# #) + ) + +-- | Write a value to a mutable variable. +{-# INLINE writeVar #-} +writeVar :: (MonadMut m, Prim a) => Var m a -> a -> m () +writeVar (Var arr#) x = primitive_ (writeByteArray# arr# 0# x) + +-- | Read a value from a variable. +{-# INLINE readVar #-} +readVar :: (MonadMut m, Prim a) => Var m a -> m a +readVar (Var arr#) = primitive (readByteArray# arr# 0#) + +-- | Modify the value of a mutable variable using a function with strict +-- application. +{-# INLINE modifyVar' #-} +modifyVar' :: (MonadMut m, Prim a) => Var m a -> (a -> a) -> m () +modifyVar' (Var arr#) g = primitive_ $ \s# -> + case readByteArray# arr# 0# s# of + (# s'#, a #) -> let a' = g a in a' `seq` writeByteArray# arr# 0# a' s'# diff --git a/src/Streamly/Internal/Network/Inet/TCP.hs b/src/Streamly/Internal/Network/Inet/TCP.hs --- a/src/Streamly/Internal/Network/Inet/TCP.hs +++ b/src/Streamly/Internal/Network/Inet/TCP.hs @@ -1,10 +1,5 @@ -{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE UnboxedTuples #-} #include "inline.hs" @@ -24,11 +19,14 @@ -- * TCP Servers -- ** Unfolds acceptOnAddr + , acceptOnAddrWith , acceptOnPort + , acceptOnPortWith , acceptOnPortLocal -- ** Streams , connectionsOnAddr + , connectionsOnAddrWith , connectionsOnPort , connectionsOnLocalHost @@ -71,6 +69,9 @@ -- , writeArray , writeChunks , fromChunks + + -- ** Transformation + , transformBytesWith {- -- ** Sink Servers @@ -106,11 +107,12 @@ import Streamly (MonadAsync) import Streamly.Internal.Data.Fold.Types (Fold(..)) +import Streamly.Internal.Data.SVar (fork) import Streamly.Internal.Data.Unfold.Types (Unfold(..)) import Streamly.Internal.Network.Socket (SockSpec(..), accept, connections) -import Streamly.Streams.Serial (SerialT) +import Streamly.Internal.Data.Stream.Serial (SerialT) import Streamly.Internal.Memory.Array.Types (Array(..), defaultChunkSize, writeNUnsafe) -import Streamly.Streams.StreamK.Type (IsStream) +import Streamly.Internal.Data.Stream.StreamK.Type (IsStream) import qualified Control.Monad.Catch as MC import qualified Network.Socket as Net @@ -127,16 +129,12 @@ -- Accept (unfolds) ------------------------------------------------------------------------------- --- | Unfold a tuple @(ipAddr, port)@ into a stream of connected TCP sockets. --- @ipAddr@ is the local IP address and @port@ is the local port on which --- connections are accepted. --- --- @since 0.7.0 -{-# INLINE acceptOnAddr #-} -acceptOnAddr +{-# INLINE acceptOnAddrWith #-} +acceptOnAddrWith :: MonadIO m - => Unfold m ((Word8, Word8, Word8, Word8), PortNumber) Socket -acceptOnAddr = UF.lmap f accept + => [(SocketOption, Int)] + -> Unfold m ((Word8, Word8, Word8, Word8), PortNumber) Socket +acceptOnAddrWith opts = UF.lmap f accept where f (addr, port) = (maxListenQueue @@ -144,11 +142,28 @@ { sockFamily = AF_INET , sockType = Stream , sockProto = defaultProtocol -- TCP - , sockOpts = [(NoDelay,1), (ReuseAddr,1)] + , sockOpts = opts } , SockAddrInet port (tupleToHostAddress addr) ) +-- | Unfold a tuple @(ipAddr, port)@ into a stream of connected TCP sockets. +-- @ipAddr@ is the local IP address and @port@ is the local port on which +-- connections are accepted. +-- +-- @since 0.7.0 +{-# INLINE acceptOnAddr #-} +acceptOnAddr + :: MonadIO m + => Unfold m ((Word8, Word8, Word8, Word8), PortNumber) Socket +acceptOnAddr = acceptOnAddrWith [] + +{-# INLINE acceptOnPortWith #-} +acceptOnPortWith :: MonadIO m + => [(SocketOption, Int)] + -> Unfold m PortNumber Socket +acceptOnPortWith opts = UF.supplyFirst (acceptOnAddrWith opts) (0,0,0,0) + -- | Like 'acceptOnAddr' but binds on the IPv4 address @0.0.0.0@ i.e. on all -- IPv4 addresses/interfaces of the machine and listens for TCP connections on -- the specified port. @@ -175,6 +190,22 @@ -- Accept (streams) ------------------------------------------------------------------------------- +{-# INLINE connectionsOnAddrWith #-} +connectionsOnAddrWith + :: MonadAsync m + => [(SocketOption, Int)] + -> (Word8, Word8, Word8, Word8) + -> PortNumber + -> SerialT m Socket +connectionsOnAddrWith opts addr port = + connections maxListenQueue SockSpec + { sockFamily = AF_INET + , sockType = Stream + , sockProto = defaultProtocol + , sockOpts = opts + } + (SockAddrInet port (tupleToHostAddress addr)) + -- | Like 'connections' but binds on the specified IPv4 address of the machine -- and listens for TCP connections on the specified port. -- @@ -185,14 +216,7 @@ => (Word8, Word8, Word8, Word8) -> PortNumber -> SerialT m Socket -connectionsOnAddr addr port = - connections maxListenQueue SockSpec - { sockFamily = AF_INET - , sockType = Stream - , sockProto = defaultProtocol - , sockOpts = [(NoDelay,1), (ReuseAddr,1)] - } - (SockAddrInet port (tupleToHostAddress addr)) +connectionsOnAddr = connectionsOnAddrWith [] -- | Like 'connections' but binds on the IPv4 address @0.0.0.0@ i.e. on all -- IPv4 addresses/interfaces of the machine and listens for TCP connections on @@ -331,13 +355,12 @@ where initial = do skt <- liftIO (connect addr port) - fld <- FL.initialize (SK.writeChunks skt) - `MC.onException` (liftIO $ Net.close skt) + fld <- FL.initialize (SK.writeChunks skt) `MC.onException` liftIO (Net.close skt) return (fld, skt) step (fld, skt) x = do - r <- FL.runStep fld x `MC.onException` (liftIO $ Net.close skt) + r <- FL.runStep fld x `MC.onException` liftIO (Net.close skt) return (r, skt) - extract ((Fold _ initial1 extract1), skt) = do + extract (Fold _ initial1 extract1, skt) = do liftIO $ Net.close skt initial1 >>= extract1 @@ -386,3 +409,45 @@ write :: (MonadAsync m, MonadCatch m) => (Word8, Word8, Word8, Word8) -> PortNumber -> Fold m Word8 () write = writeWithBufferOf defaultChunkSize + +------------------------------------------------------------------------------- +-- Transformations +------------------------------------------------------------------------------- + +{-# INLINABLE withInputConnect #-} +withInputConnect + :: (IsStream t, MonadCatch m, MonadAsync m) + => (Word8, Word8, Word8, Word8) + -> PortNumber + -> SerialT m Word8 + -> (Socket -> t m a) + -> t m a +withInputConnect addr port input f = S.bracket pre post handler + + where + + pre = do + sk <- liftIO $ connect addr port + tid <- fork (ISK.fromBytes sk input) + return (sk, tid) + + handler (sk, _) = f sk + + -- XXX kill the thread immediately? + post (sk, _) = liftIO $ Net.close sk + +-- | Send an input stream to a remote host and produce the output stream from +-- the host. The server host just acts as a transformation function on the +-- input stream. Both sending and receiving happen asynchronously. +-- +-- /Internal/ +-- +{-# INLINABLE transformBytesWith #-} +transformBytesWith + :: (IsStream t, MonadAsync m, MonadCatch m) + => (Word8, Word8, Word8, Word8) + -> PortNumber + -> SerialT m Word8 + -> t m Word8 +transformBytesWith addr port input = + withInputConnect addr port input ISK.toBytes diff --git a/src/Streamly/Internal/Network/Socket.hs b/src/Streamly/Internal/Network/Socket.hs --- a/src/Streamly/Internal/Network/Socket.hs +++ b/src/Streamly/Internal/Network/Socket.hs @@ -1,10 +1,6 @@ -{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MagicHash #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE UnboxedTuples #-} #include "inline.hs" @@ -21,8 +17,8 @@ ( SockSpec (..) -- * Use a socket - , useSocketM - , useSocket + , handleWithM + , handleWith -- * Accept connections , accept @@ -60,8 +56,9 @@ , fromBytes -- -- * Array Write - , writeArray + , writeChunk , writeChunks + , writeChunksWithBufferOf , writeStrings -- reading/writing datagrams @@ -78,11 +75,10 @@ import Foreign.Ptr (minusPtr, plusPtr, Ptr, castPtr) import Foreign.Storable (Storable(..)) import GHC.ForeignPtr (mallocPlainForeignPtrBytes) -import Network.Socket (sendBuf, recvBuf) import Network.Socket (Socket, SocketOption(..), Family(..), SockAddr(..), ProtocolNumber, withSocketsDo, SocketType(..), socket, bind, - setSocketOption) + setSocketOption, sendBuf, recvBuf) #if MIN_VERSION_network(3,1,0) import Network.Socket (withFdSocket) #else @@ -94,14 +90,13 @@ import Streamly (MonadAsync) import Streamly.Internal.Data.Unfold.Types (Unfold(..)) -import Streamly.Internal.Memory.Array.Types (Array(..)) -import Streamly.Streams.Serial (SerialT) -import Streamly.Streams.StreamK.Type (IsStream, mkStream) +import Streamly.Internal.Memory.Array.Types (Array(..), lpackArraysChunksOf) +import Streamly.Internal.Data.Stream.Serial (SerialT) +import Streamly.Internal.Data.Stream.StreamK.Type (IsStream, mkStream) import Streamly.Data.Fold (Fold) -- import Streamly.String (encodeUtf8, decodeUtf8, foldLines) import qualified Streamly.Data.Fold as FL -import qualified Streamly.Data.Unicode.Stream as U import qualified Streamly.Internal.Data.Fold.Types as FL import qualified Streamly.Internal.Data.Unfold as UF import qualified Streamly.Internal.Memory.Array as IA @@ -111,25 +106,25 @@ import qualified Streamly.Prelude as S import qualified Streamly.Internal.Data.Stream.StreamD.Type as D --- | @'useSocketM' socket act@ runs the monadic computation @act@ passing the --- socket handle to it. The handle will be closed on exit from 'useSocketM', +-- | @'handleWithM' socket act@ runs the monadic computation @act@ passing the +-- socket handle to it. The handle will be closed on exit from 'handleWithM', -- whether by normal termination or by raising an exception. If closing the -- handle raises an exception, then this exception will be raised by --- 'useSocketM' rather than any exception raised by 'act'. +-- 'handleWithM' rather than any exception raised by 'act'. -- -- @since 0.7.0 -{-# INLINE useSocketM #-} -useSocketM :: (MonadMask m, MonadIO m) => Socket -> (Socket -> m ()) -> m () -useSocketM sk f = finally (f sk) (liftIO (Net.close sk)) +{-# INLINE handleWithM #-} +handleWithM :: (MonadMask m, MonadIO m) => (Socket -> m ()) -> Socket -> m () +handleWithM f sk = finally (f sk) (liftIO (Net.close sk)) --- | Like 'useSocketM' but runs a streaming computation instead of a monadic +-- | Like 'handleWithM' but runs a streaming computation instead of a monadic -- computation. -- -- @since 0.7.0 -{-# INLINE useSocket #-} -useSocket :: (IsStream t, MonadCatch m, MonadIO m) +{-# INLINE handleWith #-} +handleWith :: (IsStream t, MonadCatch m, MonadIO m) => Socket -> (Socket -> t m a) -> t m a -useSocket sk f = S.finally (liftIO $ Net.close sk) (f sk) +handleWith sk f = S.finally (liftIO $ Net.close sk) (f sk) ------------------------------------------------------------------------------- -- Accept (Unfolds) @@ -161,9 +156,7 @@ => Unfold m (Int, SockSpec, SockAddr) (Socket, SockAddr) listenTuples = Unfold step inject where - inject (listenQLen, spec, addr) = do - listener <- liftIO $ initListener listenQLen spec addr - return listener + inject (listenQLen, spec, addr) = liftIO $ initListener listenQLen spec addr step listener = do r <- liftIO $ Net.accept listener @@ -209,8 +202,7 @@ -- /Internal/ {-# INLINE connections #-} connections :: MonadAsync m => Int -> SockSpec -> SockAddr -> SerialT m Socket -connections tcpListenQ spec addr = fmap fst $ - recvConnectionTuplesWith tcpListenQ spec addr +connections tcpListenQ spec addr = fst <$> recvConnectionTuplesWith tcpListenQ spec addr ------------------------------------------------------------------------------- -- Array IO (Input) @@ -252,6 +244,8 @@ waitWhen0 0 s = when rtsSupportsBoundThreads $ #if MIN_VERSION_network(3,1,0) withFdSocket s $ \fd -> threadWaitWrite $ fromIntegral fd +#elif MIN_VERSION_network(3,0,0) + fdSocket s >>= threadWaitWrite . fromIntegral #else let fd = fdSocket s in threadWaitWrite $ fromIntegral fd #endif @@ -282,19 +276,19 @@ -- | Write an Array to a file handle. -- -- @since 0.7.0 -{-# INLINABLE writeArray #-} -writeArray :: Storable a => Socket -> Array a -> IO () -writeArray = writeArrayWith sendAll +{-# INLINABLE writeChunk #-} +writeChunk :: Storable a => Socket -> Array a -> IO () +writeChunk = writeArrayWith sendAll ------------------------------------------------------------------------------- -- Stream of Arrays IO ------------------------------------------------------------------------------- -{-# INLINABLE readChunksUptoWith #-} -readChunksUptoWith :: (IsStream t, MonadIO m) +{-# INLINABLE _readChunksUptoWith #-} +_readChunksUptoWith :: (IsStream t, MonadIO m) => (Int -> h -> IO (Array Word8)) -> Int -> h -> t m (Array Word8) -readChunksUptoWith f size h = go +_readChunksUptoWith f size h = go where -- XXX use cons/nil instead go = mkStream $ \_ yld _ stp -> do @@ -307,10 +301,19 @@ -- The maximum size of a single array is limited to @size@. -- 'fromHandleArraysUpto' ignores the prevailing 'TextEncoding' and 'NewlineMode' -- on the 'Handle'. -{-# INLINABLE toChunksWithBufferOf #-} +{-# INLINE_NORMAL toChunksWithBufferOf #-} toChunksWithBufferOf :: (IsStream t, MonadIO m) => Int -> Socket -> t m (Array Word8) -toChunksWithBufferOf = readChunksUptoWith readArrayOf +-- toChunksWithBufferOf = _readChunksUptoWith readArrayOf +toChunksWithBufferOf size h = D.fromStreamD (D.Stream step ()) + where + {-# INLINE_LATE step #-} + step _ _ = do + arr <- liftIO $ readArrayOf size h + return $ + case A.length arr of + 0 -> D.Stop + _ -> D.Yield arr () -- XXX read 'Array a' instead of Word8 -- @@ -408,7 +411,7 @@ {-# INLINE fromChunks #-} fromChunks :: (MonadIO m, Storable a) => Socket -> SerialT m (Array a) -> m () -fromChunks h m = S.mapM_ (liftIO . writeArray h) m +fromChunks h = S.mapM_ (liftIO . writeChunk h) -- | Write a stream of arrays to a socket. Each array in the stream is written -- to the socket as a separate IO request. @@ -416,16 +419,30 @@ -- @since 0.7.0 {-# INLINE writeChunks #-} writeChunks :: (MonadIO m, Storable a) => Socket -> Fold m (Array a) () -writeChunks h = FL.drainBy (liftIO . writeArray h) +writeChunks h = FL.drainBy (liftIO . writeChunk h) --- | Write a stream of strings to a socket in Latin1 encoding. +-- | @writeChunksWithBufferOf bufsize socket@ writes a stream of arrays +-- to @socket@ after coalescing the adjacent arrays in chunks of @bufsize@. +-- We never split an array, if a single array is bigger than the specified size +-- it emitted as it is. Multiple arrays are coalesed as long as the total size +-- remains below the specified size. -- +-- @since 0.7.0 +{-# INLINE writeChunksWithBufferOf #-} +writeChunksWithBufferOf :: (MonadIO m, Storable a) + => Int -> Socket -> Fold m (Array a) () +writeChunksWithBufferOf n h = lpackArraysChunksOf n (writeChunks h) + +-- | Write a stream of strings to a socket in Latin1 encoding. Output is +-- flushed to the socket for each string. +-- -- /Internal/ -- {-# INLINE writeStrings #-} -writeStrings :: MonadIO m => Socket -> Fold m String () -writeStrings h = - FL.lmapM (IA.fromStream . U.encodeLatin1 . S.fromList) (writeChunks h) +writeStrings :: MonadIO m + => (SerialT m Char -> SerialT m Word8) -> Socket -> Fold m String () +writeStrings encode h = + FL.lmapM (IA.fromStream . encode . S.fromList) (writeChunks h) -- GHC buffer size dEFAULT_FD_BUFFER_SIZE=8192 bytes. -- diff --git a/src/Streamly/Internal/Prelude.hs b/src/Streamly/Internal/Prelude.hs --- a/src/Streamly/Internal/Prelude.hs +++ b/src/Streamly/Internal/Prelude.hs @@ -1,3700 +1,4401 @@ -{-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FlexibleContexts #-} - -#if __GLASGOW_HASKELL__ >= 800 -{-# OPTIONS_GHC -Wno-orphans #-} -#endif - -#include "../Streams/inline.hs" - --- | --- Module : Streamly.Internal.Prelude --- Copyright : (c) 2017 Harendra Kumar --- --- License : BSD3 --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- - -module Streamly.Internal.Prelude - ( - -- * Construction - -- ** Primitives - K.nil - , K.nilM - , K.cons - , (K..:) - - , consM - , (|:) - - -- ** From Values - , yield - , yieldM - , repeat - , repeatM - , replicate - , replicateM - - -- ** Enumeration - , Enumerable (..) - , enumerate - , enumerateTo - - -- ** From Generators - , unfoldr - , unfoldrM - , unfold - , iterate - , iterateM - , fromIndices - , fromIndicesM - - -- ** From Containers - , P.fromList - , fromListM - , K.fromFoldable - , fromFoldableM - - -- * Elimination - - -- ** Deconstruction - , uncons - , tail - , init - - -- ** Folding - -- ** Right Folds - , foldrM - , foldrS - , foldrT - , foldr - - -- ** Left Folds - , foldl' - , foldl1' - , foldlM' - - -- ** Full Folds - - -- -- ** To Summary (Full Folds) - , drain - , last - , length - , sum - , product - --, mconcat - - -- -- ** To Summary (Maybe) (Full Folds) - , maximumBy - , maximum - , minimumBy - , minimum - , the - - -- ** Partial Folds - - -- -- ** To Elements (Partial Folds) - , drainN - , drainWhile - - -- -- | Folds that extract selected elements of a stream or their properties. - , (!!) - , head - , findM - , find - , lookup - , findIndex - , elemIndex - - -- -- ** To Boolean (Partial Folds) - , null - , elem - , notElem - , all - , any - , and - , or - - -- ** To Containers - , toList - , toListRev - , toPure - , toPureRev - - -- ** Composable Left Folds - , fold - - , toStream -- XXX rename to write? - , toStreamRev -- XXX rename to writeRev? - - -- * Transformation - , transform - - -- ** Mapping - , Serial.map - , sequence - , mapM - , mapM_ - - -- ** Scanning - -- ** Left scans - , scanl' - , scanlM' - , postscanl' - , postscanlM' - , prescanl' - , prescanlM' - , scanl1' - , scanl1M' - - -- ** Scan Using Fold - , scan - , postscan - - -- , lscanl' - -- , lscanlM' - -- , lscanl1' - -- , lscanl1M' - -- - -- , lpostscanl' - -- , lpostscanlM' - -- , lprescanl' - -- , lprescanlM' - - -- ** Indexing - , indexed - , indexedR - -- , timestamped - -- , timestampedR -- timer - - -- ** Filtering - - , filter - , filterM - - -- ** Stateful Filters - , take - -- , takeEnd - , takeWhile - , takeWhileM - -- , takeWhileEnd - , drop - -- , dropEnd - , dropWhile - , dropWhileM - -- , dropWhileEnd - -- , dropAround - , deleteBy - , uniq - -- , uniqBy -- by predicate e.g. to remove duplicate "/" in a path - -- , uniqOn -- to remove duplicate sequences - -- , pruneBy -- dropAround + uniqBy - like words - - -- ** Mapping Filters - , mapMaybe - , mapMaybeM - - -- ** Scanning Filters - , findIndices - , elemIndices - -- , seqIndices -- search a sequence in the stream - - -- ** Insertion - , insertBy - , intersperseM - , intersperse - , intersperseSuffix - -- , intersperseBySpan - , interjectSuffix - - -- ** Reordering - , reverse - , reverse' - - -- * Multi-Stream Operations - - -- ** Appending - , append - - -- ** Interleaving - , interleave - , interleaveMin - , interleaveSuffix - , interleaveInfix - - , Serial.wSerialFst - , Serial.wSerialMin - - -- ** Scheduling - , roundrobin - - -- ** Parallel - , Par.parallelFst - , Par.parallelMin - - -- ** Merging - - -- , merge - , mergeBy - , mergeByM - , mergeAsyncBy - , mergeAsyncByM - - -- ** Zipping - , zipWith - , zipWithM - , Z.zipAsyncWith - , Z.zipAsyncWithM - - -- ** Nested Streams - , concatMapM - , concatUnfold - , concatUnfoldInterleave - , concatUnfoldRoundrobin - , concatMap - , concatMapWith - , gintercalate - , gintercalateSuffix - , intercalate - , intercalateSuffix - , interpose - , interposeSuffix - - -- -- ** Breaking - - -- By chunks - , splitAt -- spanN - -- , splitIn -- sessionN - - -- By elements - , span -- spanWhile - , break -- breakBefore - -- , breakAfter - -- , breakOn - -- , breakAround - , spanBy - , spanByRolling - - -- By sequences - -- , breakOnSeq - - -- ** Splitting - -- , groupScan - - -- -- *** Chunks - , chunksOf - , chunksOf2 - , arraysOf - , intervalsOf - - -- -- *** Using Element Separators - , splitOn - , splitOnSuffix - -- , splitOnPrefix - - -- , splitBy - , splitWithSuffix - -- , splitByPrefix - , wordsBy -- stripAndCompactBy - - -- -- *** Using Sequence Separators - , splitOnSeq - , splitOnSuffixSeq - -- , splitOnPrefixSeq - - -- Keeping the delimiters - , splitBySeq - , splitWithSuffixSeq - -- , splitByPrefixSeq - -- , wordsBySeq - - -- Splitting using multiple sequence separators - -- , splitOnAnySeq - -- , splitOnAnySuffixSeq - -- , splitOnAnyPrefixSeq - - -- Nested splitting - , splitInnerBy - , splitInnerBySuffix - - -- ** Grouping - , groups - , groupsBy - , groupsByRolling - - -- ** Distributing - , trace - , tap - , Par.tapAsync - - -- * Windowed Classification - - -- ** Tumbling Windows - -- , classifyChunksOf - , classifySessionsBy - , classifySessionsOf - - -- ** Keep Alive Windows - -- , classifyKeepAliveChunks - , classifyKeepAliveSessions - - {- - -- ** Sliding Windows - , classifySlidingChunks - , classifySlidingSessions - -} - -- ** Sliding Window Buffers - -- , slidingChunkBuffer - -- , slidingSessionBuffer - - -- ** Containers of Streams - , foldWith - , foldMapWith - , forEachWith - - -- ** Folding - , eqBy - , cmpBy - , isPrefixOf - -- , isSuffixOf - -- , isInfixOf - , isSubsequenceOf - , stripPrefix - -- , stripSuffix - -- , stripInfix - - -- * Exceptions - , before - , after - , bracket - , onException - , finally - , handle - - -- * Generalize Inner Monad - , hoist - , generally - - -- * Transform Inner Monad - , liftInner - , runReaderT - , evalStateT - , usingStateT - , runStateT - - -- * Diagnostics - , inspectMode - - -- * Deprecated - , K.once - , each - , scanx - , foldx - , foldxM - , foldr1 - , runStream - , runN - , runWhile - , fromHandle - , toHandle - ) -where - -import Control.Concurrent (threadDelay) -import Control.Exception (Exception) -import Control.Monad (void) -import Control.Monad.Catch (MonadCatch) -import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.Reader (ReaderT) -import Control.Monad.State.Strict (StateT) -import Control.Monad.Trans (MonadTrans(..)) -import Data.Functor.Identity (Identity (..)) -import Data.Heap (Entry(..)) -import Data.Maybe (isJust, fromJust, isNothing) -import Foreign.Storable (Storable) -import Prelude - hiding (filter, drop, dropWhile, take, takeWhile, zipWith, foldr, - foldl, map, 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, span, splitAt, break, - repeat) - -import qualified Data.Heap as H -import qualified Data.Map.Strict as Map -import qualified Prelude -import qualified System.IO as IO - -import Streamly.Streams.Enumeration (Enumerable(..), enumerate, enumerateTo) -import Streamly.Internal.Data.Fold.Types (Fold (..), Fold2 (..)) -import Streamly.Internal.Data.Unfold.Types (Unfold) -import Streamly.Internal.Memory.Array.Types (Array, writeNUnsafe) --- import Streamly.Memory.Ring (Ring) -import Streamly.Internal.Data.SVar (MonadAsync, defState) -import Streamly.Streams.Async (mkAsync') -import Streamly.Streams.Combinators (inspectMode, maxYields) -import Streamly.Streams.Prelude - (fromStreamS, toStreamS, foldWith, foldMapWith, forEachWith) -import Streamly.Streams.StreamD (fromStreamD, toStreamD) -import Streamly.Streams.StreamK (IsStream((|:), consM)) -import Streamly.Streams.Serial (SerialT) -import Streamly.Internal.Data.Pipe.Types (Pipe (..)) -import Streamly.Internal.Data.Time.Units - (AbsTime, MilliSecond64(..), addToAbsTime, diffAbsTime, toRelTime, - toAbsTime) - -import Streamly.Internal.Data.Strict - -import qualified Streamly.Internal.Memory.Array as A -import qualified Streamly.Data.Fold as FL -import qualified Streamly.Internal.Data.Fold.Types as FL -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 -import qualified Streamly.Streams.Parallel as Par - ------------------------------------------------------------------------------- --- 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. --- --- This is a brute force primitive. Avoid using it as long as possible, use it --- when no other combinator can do the job. This can be used to do pretty much --- anything in an imperative manner, as it just breaks down the stream into --- individual elements and we can loop over them as we deem fit. For example, --- this can be used to convert a streamly stream into other stream types. --- --- @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 drain $ 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) - --- | Convert an 'Unfold' into a stream by supplying it an input seed. --- --- >>> unfold UF.replicateM 10 (putStrLn "hello") --- --- /Since: 0.7.0/ -{-# INLINE unfold #-} -unfold :: (IsStream t, Monad m) => Unfold m a b -> a -> t m b -unfold unf x = fromStreamD $ D.unfold unf x - ------------------------------------------------------------------------------- --- 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 = fromStreamS . S.fromIndices - --- --- | --- @ --- 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. --- --- /Concurrent/ --- --- @since 0.6.0 -{-# INLINE_EARLY fromIndicesM #-} -fromIndicesM :: (IsStream t, MonadAsync m) => (Int -> m a) -> t m a -fromIndicesM = K.fromIndicesM - -{-# RULES "fromIndicesM serial" fromIndicesM = fromIndicesMSerial #-} -{-# INLINE fromIndicesMSerial #-} -fromIndicesMSerial :: MonadAsync m => (Int -> m a) -> SerialT m a -fromIndicesMSerial = fromStreamS . S.fromIndicesM - --- | --- @ --- replicateM = take n . repeatM --- @ --- --- Generate a stream by performing a monadic action @n@ times. Same as: --- --- @ --- drain $ serially $ S.replicateM 10 $ (threadDelay 1000000 >> print 1) --- drain $ 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 -{-# INLINE_NORMAL replicate #-} -replicate :: (IsStream t, Monad m) => Int -> a -> t m a -replicate n = fromStreamS . S.replicate n - --- | --- Generate an infinite stream by repeating a pure value. --- --- @since 0.4.0 -{-# INLINE_NORMAL repeat #-} -repeat :: (IsStream t, Monad m) => a -> t m a -repeat = fromStreamS . S.repeat - --- | --- @ --- repeatM = fix . consM --- repeatM = cycle1 . yieldM --- @ --- --- Generate a stream by repeatedly executing a monadic action forever. --- --- @ --- drain $ serially $ S.take 10 $ S.repeatM $ (threadDelay 1000000 >> print 1) --- drain $ asyncly $ S.take 10 $ S.repeatM $ (threadDelay 1000000 >> print 1) --- @ --- --- /Concurrent, infinite (do not use with 'parallely')/ --- --- @since 0.2.0 -{-# INLINE_EARLY repeatM #-} -repeatM :: (IsStream t, MonadAsync m) => m a -> t m a -repeatM = K.repeatM - -{-# RULES "repeatM serial" repeatM = repeatMSerial #-} -{-# INLINE repeatMSerial #-} -repeatMSerial :: MonadAsync m => m a -> SerialT m a -repeatMSerial = fromStreamS . S.repeatM - --- | --- @ --- 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 = K.fromStream . go - where - go s = K.cons s (go (step s)) - --- | --- @ --- iterateM f m = m >>= \a -> return a \`consM` iterateM f (f a) --- @ --- --- 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. --- --- @ --- drain $ serially $ S.take 10 $ S.iterateM --- (\\x -> threadDelay 1000000 >> print x >> return (x + 1)) (return 0) --- --- drain $ asyncly $ S.take 10 $ S.iterateM --- (\\x -> threadDelay 1000000 >> print x >> return (x + 1)) (return 0) --- @ --- --- /Concurrent/ --- --- /Since: 0.7.0 (signature change)/ --- --- /Since: 0.1.2/ -iterateM :: (IsStream t, MonadAsync m) => (a -> m a) -> m a -> t m a -iterateM step = go - where - go s = K.mkStream $ \st stp sng yld -> do - next <- s - K.foldStreamShared st stp sng yld (return next |: go (step 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. --- --- @ --- drain $ serially $ S.fromFoldableM $ replicateM 10 (threadDelay 1000000 >> print 1) --- drain $ 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 -{-# DEPRECATED fromHandle - "Please use Streamly.FileSystem.Handle module (see the changelog)" #-} -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 ------------------------------------------------------------------------------- - --- | Right associative/lazy pull fold. @foldrM build final stream@ constructs --- an output structure using the step function @build@. @build@ is invoked with --- the next input element and the remaining (lazy) tail of the output --- structure. It builds a lazy output expression using the two. When the "tail --- structure" in the output expression is evaluated it calls @build@ again thus --- lazily consuming the input @stream@ until either the output expression built --- by @build@ is free of the "tail" or the input is exhausted in which case --- @final@ is used as the terminating case for the output structure. For more --- details see the description in the previous section. --- --- Example, determine if any element is 'odd' in a stream: --- --- >>> S.foldrM (\x xs -> if odd x then return True else xs) (return False) $ S.fromList (2:4:5:undefined) --- > True --- --- /Since: 0.7.0 (signature changed)/ --- --- /Since: 0.2.0 (signature changed)/ --- --- /Since: 0.1.0/ -{-# INLINE foldrM #-} -foldrM :: Monad m => (a -> m b -> m b) -> m b -> SerialT m a -> m b -foldrM = P.foldrM - --- | Right fold to a streaming monad. --- --- > foldrS S.cons S.nil === id --- --- 'foldrS' can be used to perform stateless stream to stream transformations --- like map and filter in general. It can be coupled with a scan to perform --- stateful transformations. However, note that the custom map and filter --- routines can be much more efficient than this due to better stream fusion. --- --- >>> S.toList $ S.foldrS S.cons S.nil $ S.fromList [1..5] --- > [1,2,3,4,5] --- --- Find if any element in the stream is 'True': --- --- >>> S.toList $ S.foldrS (\x xs -> if odd x then return True else xs) (return False) $ (S.fromList (2:4:5:undefined) :: SerialT IO Int) --- > [True] --- --- Map (+2) on odd elements and filter out the even elements: --- --- >>> S.toList $ S.foldrS (\x xs -> if odd x then (x + 2) `S.cons` xs else xs) S.nil $ (S.fromList [1..5] :: SerialT IO Int) --- > [3,5,7] --- --- 'foldrM' can also be represented in terms of 'foldrS', however, the former --- is much more efficient: --- --- > foldrM f z s = runIdentityT $ foldrS (\x xs -> lift $ f x (runIdentityT xs)) (lift z) s --- --- @since 0.7.0 -{-# INLINE foldrS #-} -foldrS :: IsStream t => (a -> t m b -> t m b) -> t m b -> t m a -> t m b -foldrS = K.foldrS - --- | Right fold to a transformer monad. This is the most general right fold --- function. 'foldrS' is a special case of 'foldrT', however 'foldrS' --- implementation can be more efficient: --- --- > foldrS = foldrT --- > foldrM f z s = runIdentityT $ foldrT (\x xs -> lift $ f x (runIdentityT xs)) (lift z) s --- --- 'foldrT' can be used to translate streamly streams to other transformer --- monads e.g. to a different streaming type. --- --- @since 0.7.0 -{-# INLINE foldrT #-} -foldrT :: (IsStream t, Monad m, Monad (s m), MonadTrans s) - => (a -> s m b -> s m b) -> s m b -> t m a -> s m b -foldrT f z s = S.foldrT f z (toStreamS s) - --- | Right fold, lazy for lazy monads and pure streams, and strict for strict --- monads. --- --- Please avoid using this routine in strict monads like IO unless you need a --- strict right fold. This is provided only for use in lazy monads (e.g. --- Identity) or pure streams. Note that with this signature it is not possible --- to implement a lazy foldr when the monad @m@ is strict. In that case it --- would be strict in its accumulator and therefore would necessarily consume --- all its input. --- --- @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 #-} -{-# DEPRECATED foldr1 "Use foldrM instead." #-} -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 -{-# DEPRECATED foldx "Please use foldl' followed by fmap instead." #-} -{-# INLINE foldx #-} -foldx :: Monad m => (x -> a -> x) -> x -> (x -> b) -> SerialT m a -> m b -foldx = P.foldlx' - --- | Left associative/strict push fold. @foldl' reduce initial stream@ invokes --- @reduce@ with the accumulator and the next input in the input stream, using --- @initial@ as the initial value of the current value of the accumulator. When --- the input is exhausted the current value of the accumulator is returned. --- Make sure to use a strict data structure for accumulator to not build --- unnecessary lazy expressions unless that's what you want. See the previous --- section for more details. --- --- @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 -{-# DEPRECATED foldxM "Please use foldlM' followed by fmap instead." #-} -{-# INLINE foldxM #-} -foldxM :: Monad m => (x -> a -> m x) -> m x -> (x -> m b) -> SerialT m a -> m b -foldxM = P.foldlMx' - --- | 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 - ------------------------------------------------------------------------------- --- Running a Fold ------------------------------------------------------------------------------- - --- | Fold a stream using the supplied left fold. --- --- >>> S.fold FL.sum (S.enumerateFromTo 1 100) --- 5050 --- --- @since 0.7.0 -{-# INLINE fold #-} -fold :: Monad m => Fold m a b -> SerialT m a -> m b -fold = P.runFold - ------------------------------------------------------------------------------- --- Running a sink ------------------------------------------------------------------------------- - -{- --- | Drain a stream to a 'Sink'. -{-# INLINE runSink #-} -runSink :: Monad m => Sink m a -> SerialT m a -> m () -runSink = fold . toFold --} - ------------------------------------------------------------------------------- --- Specialized folds ------------------------------------------------------------------------------- - --- | --- > drain = mapM_ (\_ -> return ()) --- --- 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 @drain . 'asyncly'@. --- --- @since 0.7.0 -{-# INLINE drain #-} -drain :: Monad m => SerialT m a -> m () -drain = P.drain - --- | 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 -{-# DEPRECATED runStream "Please use \"drain\" instead" #-} -{-# INLINE runStream #-} -runStream :: Monad m => SerialT m a -> m () -runStream = drain - --- | --- > drainN n = drain . take n --- --- Run maximum up to @n@ iterations of a stream. --- --- @since 0.7.0 -{-# INLINE drainN #-} -drainN :: Monad m => Int -> SerialT m a -> m () -drainN n = drain . take n - --- | --- > runN n = runStream . take n --- --- Run maximum up to @n@ iterations of a stream. --- --- @since 0.6.0 -{-# DEPRECATED runN "Please use \"drainN\" instead" #-} -{-# INLINE runN #-} -runN :: Monad m => Int -> SerialT m a -> m () -runN = drainN - --- | --- > drainWhile p = drain . takeWhile p --- --- Run a stream as long as the predicate holds true. --- --- @since 0.7.0 -{-# INLINE drainWhile #-} -drainWhile :: Monad m => (a -> Bool) -> SerialT m a -> m () -drainWhile p = drain . takeWhile p - --- | --- > runWhile p = runStream . takeWhile p --- --- Run a stream as long as the predicate holds true. --- --- @since 0.6.0 -{-# DEPRECATED runWhile "Please use \"drainWhile\" instead" #-} -{-# INLINE runWhile #-} -runWhile :: Monad m => (a -> Bool) -> SerialT m a -> m () -runWhile = drainWhile - --- | Determine whether the stream is empty. --- --- @since 0.1.1 -{-# INLINE null #-} -null :: Monad m => SerialT m a -> m Bool -null = S.null . toStreamS - --- | 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 = S.head . toStreamS - --- | --- > tail = fmap (fmap snd) . uncons --- --- 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) - ------------------------------------------------------------------------------- --- Substreams ------------------------------------------------------------------------------- - --- | Returns 'True' if the first stream is the same as or a prefix of the --- second. A stream is a prefix of itself. --- --- @ --- > 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 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 drain . mapM --- | --- > mapM_ = drain . mapM --- --- Apply a monadic action to each element of the stream and discard the output --- of the action. This is not really a pure transformation operation but a --- transformation followed by fold. --- --- @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. The list can be --- consumed lazily in a lazy monad (e.g. 'Identity'). In a strict monad (e.g. --- IO) the whole list is generated and buffered before it can be consumed. --- --- /Warning!/ working on large lists accumulated as buffers in memory could be --- very inefficient, consider using "Streamly.Array" instead. --- --- @since 0.1.0 -{-# INLINE toList #-} -toList :: Monad m => SerialT m a -> m [a] -toList = P.toList - --- | --- @ --- toListRev = S.foldl' (flip (:)) [] --- @ --- --- Convert a stream into a list in reverse order in the underlying monad. --- --- /Warning!/ working on large lists accumulated as buffers in memory could be --- very inefficient, consider using "Streamly.Array" instead. --- --- /Internal/ -{-# INLINE toListRev #-} -toListRev :: Monad m => SerialT m a -> m [a] -toListRev = D.toListRev . toStreamD - --- | --- @ --- toHandle h = S.mapM_ $ hPutStrLn h --- @ --- --- Write a stream of Strings to an IO Handle. --- --- @since 0.1.0 -{-# DEPRECATED toHandle - "Please use Streamly.FileSystem.Handle module (see the changelog)" #-} -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 - --- XXX rename these to write/writeRev to make the naming consistent with folds --- in other modules. --- --- | A fold that buffers its input to a pure stream. --- --- /Warning!/ working on large streams accumulated as buffers in memory could --- be very inefficient, consider using "Streamly.Array" instead. --- --- /Internal/ -{-# INLINE toStream #-} -toStream :: Monad m => Fold m a (SerialT Identity a) -toStream = Fold (\f x -> return $ f . (x `K.cons`)) - (return id) - (return . ($ K.nil)) - --- This is more efficient than 'toStream'. toStream is exactly the same as --- reversing the stream after toStreamRev. --- --- | Buffers the input stream to a pure stream in the reverse order of the --- input. --- --- /Warning!/ working on large streams accumulated as buffers in memory could --- be very inefficient, consider using "Streamly.Array" instead. --- --- /Internal/ - --- xn : ... : x2 : x1 : [] -{-# INLINABLE toStreamRev #-} -toStreamRev :: Monad m => Fold m a (SerialT Identity a) -toStreamRev = Fold (\xs x -> return $ x `K.cons` xs) (return K.nil) return - --- | Convert a stream to a pure stream. --- --- @ --- toPure = foldr cons nil --- @ --- --- /Internal/ --- -{-# INLINE toPure #-} -toPure :: Monad m => SerialT m a -> m (SerialT Identity a) -toPure = foldr K.cons K.nil - --- | Convert a stream to a pure stream in reverse order. --- --- @ --- toPureRev = foldl' (flip cons) nil --- @ --- --- /Internal/ --- -{-# INLINE toPureRev #-} -toPureRev :: Monad m => SerialT m a -> m (SerialT Identity a) -toPureRev = foldl' (flip K.cons) K.nil - ------------------------------------------------------------------------------- --- General Transformation ------------------------------------------------------------------------------- - --- | Use a 'Pipe' to transform a stream. -{-# INLINE transform #-} -transform :: (IsStream t, Monad m) => Pipe m a b -> t m a -> t m b -transform pipe xs = fromStreamD $ D.transform pipe (toStreamD xs) - ------------------------------------------------------------------------------- --- Transformation by Folding (Scans) ------------------------------------------------------------------------------- - --- XXX It may be useful to have a version of scan where we can keep the --- accumulator independent of the value emitted. So that we do not necessarily --- have to keep a value in the accumulator which we are not using. We can pass --- an extraction function that will take the accumulator and the current value --- of the element and emit the next value in the stream. That will also make it --- possible to modify the accumulator after using it. In fact, the step function --- can return new accumulator and the value to be emitted. The signature would --- be more like mapAccumL. Or we can change the signature of scanx to --- accommodate this. --- --- | 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.7.0 (Monad m constraint)/ --- --- /Since 0.2.0/ -{-# DEPRECATED scanx "Please use scanl followed by map instead." #-} -{-# INLINE scanx #-} -scanx :: (IsStream t, Monad m) => (x -> a -> x) -> x -> (x -> b) -> t m a -> t m b -scanx = P.scanlx' - --- XXX this needs to be concurrent --- | Like 'scanl'' but with a monadic fold function. --- --- @since 0.4.0 -{-# INLINE scanlM' #-} -scanlM' :: (IsStream t, Monad m) => (b -> a -> m b) -> b -> t m a -> t m b -scanlM' step begin m = fromStreamD $ D.scanlM' step begin $ toStreamD m - --- | Strict left scan. Like 'map', 'scanl'' too is a one to one transformation, --- however it adds an extra element. --- --- @ --- > 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 monolithic 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 make it modular by computing the sum in the first --- stage and passing 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 - --- | Like 'scanl'' but does not stream the initial value of the accumulator. --- --- > postscanl' f z xs = S.drop 1 $ S.scanl' f z xs --- --- @since 0.7.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.7.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 - ------------------------------------------------------------------------------- --- Scanning with a Fold ------------------------------------------------------------------------------- - --- | Scan a stream using the given monadic fold. --- --- @since 0.7.0 -{-# INLINE scan #-} -scan :: (IsStream t, Monad m) => Fold m a b -> t m a -> t m b -scan (Fold step begin done) = P.scanlMx' step begin done - --- | Postscan a stream using the given monadic fold. --- --- @since 0.7.0 -{-# INLINE postscan #-} -postscan :: (IsStream t, Monad m) => Fold m a b -> t m a -> t m b -postscan (Fold step begin done) = P.postscanlMx' step begin done - ------------------------------------------------------------------------------- --- 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. --- --- @ --- > drain $ S.mapM putStr $ S.fromList ["a", "b", "c"] --- abc --- --- drain $ S.replicateM 10 (return 1) --- & (serially . S.mapM (\\x -> threadDelay 1000000 >> print x)) --- --- drain $ 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. --- --- @ --- > drain $ S.sequence $ S.fromList [putStr "a", putStr "b", putStrLn "c"] --- abc --- --- drain $ S.replicateM 10 (return $ threadDelay 1000000 >> print 1) --- & (serially . S.sequence) --- --- drain $ 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'. --- --- Equivalent to: --- --- @ --- mapMaybe f = S.map 'fromJust' . S.filter 'isJust' . S.map f --- @ --- --- @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. --- --- Equivalent to: --- --- @ --- mapMaybeM f = S.map 'fromJust' . S.filter 'isJust' . S.mapM f --- @ --- --- /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 Use a compact region list to temporarily store the list, in both reverse --- as well as in reverse'. --- --- /Note:/ 'reverse'' is much faster than this, use that when performance --- matters. --- --- > reverse = S.foldlT (flip S.cons) S.nil --- --- | Returns the elements of the stream in reverse order. The stream must be --- finite. Note that this necessarily buffers the entire stream in memory. --- --- /Since 0.7.0 (Monad m constraint)/ --- --- /Since: 0.1.1/ -{-# INLINE reverse #-} -reverse :: (IsStream t, Monad m) => t m a -> t m a -reverse s = fromStreamS $ S.reverse $ toStreamS s - --- | Like 'reverse' but several times faster, requires a 'Storable' instance. --- --- @since 0.7.0 -{-# INLINE reverse' #-} -reverse' :: (IsStream t, MonadIO m, Storable a) => t m a -> t m a -reverse' s = fromStreamD $ D.reverse' $ toStreamD s - ------------------------------------------------------------------------------- --- Transformation by Inserting ------------------------------------------------------------------------------- - --- intersperseM = intersperseBySpan 1 - --- | 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 (return ',') $ S.fromList "hello" --- "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 m = fromStreamS . S.intersperseM m . toStreamS - --- | Generate a stream by inserting a given element between consecutive --- elements of the given stream. --- --- @ --- > S.toList $ S.intersperse ',' $ S.fromList "hello" --- "h,e,l,l,o" --- @ --- --- @since 0.7.0 -{-# INLINE intersperse #-} -intersperse :: (IsStream t, MonadAsync m) => a -> t m a -> t m a -intersperse a = fromStreamS . S.intersperse a . toStreamS - --- | Insert a monadic action after each element in the stream. --- --- @since 0.7.0 -{-# INLINE intersperseSuffix #-} -intersperseSuffix :: (IsStream t, MonadAsync m) => m a -> t m a -> t m a -intersperseSuffix m = fromStreamD . D.intersperseSuffix m . toStreamD - -{- --- | Intersperse a monadic action into the input stream after every @n@ --- elements. --- --- @ --- > S.toList $ S.intersperseBySpan 2 (return ',') $ S.fromList "hello" --- "he,ll,o" --- @ --- --- @since 0.7.0 -{-# INLINE intersperseBySpan #-} -intersperseBySpan :: IsStream t => Int -> m a -> t m a -> t m a -intersperseBySpan _n _f _xs = undefined --} - --- | Intersperse a monadic action into the input stream after every @n@ --- seconds. --- --- @ --- > S.drain $ S.interjectSuffix 1 (putChar ',') $ S.mapM (\\x -> threadDelay 1000000 >> putChar x) $ S.fromList "hello" --- "h,e,l,l,o" --- @ --- --- @since 0.7.0 -{-# INLINE interjectSuffix #-} -interjectSuffix - :: (IsStream t, MonadAsync m) - => Double -> m a -> t m a -> t m a -interjectSuffix n f xs = xs `Par.parallelFst` repeatM timed - where timed = liftIO (threadDelay (round $ n * 1000000)) >> f - --- | @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.postscanl' (\(i, _) x -> (i + 1, x)) (-1,undefined) --- > indexed = S.zipWith (,) (S.enumerateFrom 0) --- --- Pair each element in a stream with its index, starting from index 0. --- --- @ --- > 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.postscanl' (\(i, _) x -> (i - 1, x)) (n + 1,undefined) --- > indexedR n = S.zipWith (,) (S.enumerateFromThen 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" --- [(10,'h'),(9,'e'),(8,'l'),(7,'l'),(6,'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) - -{- --- | Like 'mergeByM' but stops merging as soon as any of the two streams stops. -{-# INLINABLE mergeEndByAny #-} -mergeEndByAny - :: (IsStream t, Monad m) - => (a -> a -> m Ordering) -> t m a -> t m a -> t m a -mergeEndByAny f m1 m2 = fromStreamD $ - D.mergeEndByAny f (toStreamD m1) (toStreamD m2) - --- Like 'mergeByM' but stops merging as soon as the first stream stops. -{-# INLINABLE mergeEndByFirst #-} -mergeEndByFirst - :: (IsStream t, Monad m) - => (a -> a -> m Ordering) -> t m a -> t m a -> t m a -mergeEndByFirst f m1 m2 = fromStreamS $ - D.mergeEndByFirst f (toStreamD m1) (toStreamD 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) - ------------------------------------------------------------------------------- --- Nesting ------------------------------------------------------------------------------- - --- | @concatMapWith merge map stream@ is a two dimensional looping combinator. --- The first argument specifies a merge or concat function that is used to --- merge the streams generated by applying the second argument i.e. the @map@ --- function to each element of the input stream. The concat function could be --- 'serial', 'parallel', 'async', 'ahead' or any other zip or merge function --- and the second argument could be any stream generation function using a --- seed. --- --- /Compare 'foldMapWith'/ --- --- @since 0.7.0 -{-# INLINE concatMapWith #-} -concatMapWith - :: IsStream t - => (forall c. t m c -> t m c -> t m c) - -> (a -> t m b) - -> t m a - -> t m b -concatMapWith = K.concatMapBy - --- | Map a stream producing function on each element of the stream and then --- flatten the results into a single stream. --- --- @ --- concatMap = 'concatMapWith' 'Serial.serial' --- 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) - --- | Append the outputs of two streams, yielding all the elements from the --- first stream and then yielding all the elements from the second stream. --- --- IMPORTANT NOTE: This could be 100x faster than @serial/<>@ for appending a --- few (say 100) streams because it can fuse via stream fusion. However, it --- does not scale for a large number of streams (say 1000s) and becomes --- qudartically slow. Therefore use this for custom appending of a few streams --- but use 'concatMap' or 'concatMapWith serial' for appending @n@ streams or --- infinite containers of streams. --- --- @since 0.7.0 -{-# INLINE append #-} -append ::(IsStream t, Monad m) => t m b -> t m b -> t m b -append m1 m2 = fromStreamD $ D.append (toStreamD m1) (toStreamD m2) - --- XXX Same as 'wSerial'. We should perhaps rename wSerial to interleave. --- XXX Document the interleaving behavior of side effects in all the --- interleaving combinators. --- XXX Write time-domain equivalents of these. In the time domain we can --- interleave two streams such that the value of second stream is always taken --- from its last value even if no new value is being yielded, like --- zipWithLatest. It would be something like interleaveWithLatest. --- --- | Interleaves the outputs of two streams, yielding elements from each stream --- alternately, starting from the first stream. If any of the streams finishes --- early the other stream continues alone until it too finishes. --- --- >>> :set -XOverloadedStrings --- >>> interleave "ab" ",,,," :: SerialT Identity Char --- fromList "a,b,,," --- >>> interleave "abcd" ",," :: SerialT Identity Char --- fromList "a,b,cd" --- --- 'interleave' is dual to 'interleaveMin', it can be called @interleaveMax@. --- --- Do not use at scale in concatMapWith. --- --- @since 0.7.0 -{-# INLINE interleave #-} -interleave ::(IsStream t, Monad m) => t m b -> t m b -> t m b -interleave m1 m2 = fromStreamD $ D.interleave (toStreamD m1) (toStreamD m2) - --- | Interleaves the outputs of two streams, yielding elements from each stream --- alternately, starting from the first stream. As soon as the first stream --- finishes, the output stops, discarding the remaining part of the second --- stream. In this case, the last element in the resulting stream would be from --- the second stream. If the second stream finishes early then the first stream --- still continues to yield elements until it finishes. --- --- >>> :set -XOverloadedStrings --- >>> interleaveSuffix "abc" ",,,," :: SerialT Identity Char --- fromList "a,b,c," --- >>> interleaveSuffix "abc" "," :: SerialT Identity Char --- fromList "a,bc" --- --- 'interleaveSuffix' is a dual of 'interleaveInfix'. --- --- Do not use at scale in concatMapWith. --- --- @since 0.7.0 -{-# INLINE interleaveSuffix #-} -interleaveSuffix ::(IsStream t, Monad m) => t m b -> t m b -> t m b -interleaveSuffix m1 m2 = - fromStreamD $ D.interleaveSuffix (toStreamD m1) (toStreamD m2) - --- | Interleaves the outputs of two streams, yielding elements from each stream --- alternately, starting from the first stream and ending at the first stream. --- If the second stream is longer than the first, elements from the second --- stream are infixed with elements from the first stream. If the first stream --- is longer then it continues yielding elements even after the second stream --- has finished. --- --- >>> :set -XOverloadedStrings --- >>> interleaveInfix "abc" ",,,," :: SerialT Identity Char --- fromList "a,b,c" --- >>> interleaveInfix "abc" "," :: SerialT Identity Char --- fromList "a,bc" --- --- 'interleaveInfix' is a dual of 'interleaveSuffix'. --- --- Do not use at scale in concatMapWith. --- --- @since 0.7.0 -{-# INLINE interleaveInfix #-} -interleaveInfix ::(IsStream t, Monad m) => t m b -> t m b -> t m b -interleaveInfix m1 m2 = - fromStreamD $ D.interleaveInfix (toStreamD m1) (toStreamD m2) - --- | Interleaves the outputs of two streams, yielding elements from each stream --- alternately, starting from the first stream. The output stops as soon as any --- of the two streams finishes, discarding the remaining part of the other --- stream. The last element of the resulting stream would be from the longer --- stream. --- --- >>> :set -XOverloadedStrings --- >>> interleaveMin "ab" ",,,," :: SerialT Identity Char --- fromList "a,b," --- >>> interleaveMin "abcd" ",," :: SerialT Identity Char --- fromList "a,b,c" --- --- 'interleaveMin' is dual to 'interleave'. --- --- Do not use at scale in concatMapWith. --- --- @since 0.7.0 -{-# INLINE interleaveMin #-} -interleaveMin ::(IsStream t, Monad m) => t m b -> t m b -> t m b -interleaveMin m1 m2 = fromStreamD $ D.interleaveMin (toStreamD m1) (toStreamD m2) - --- | Schedule the execution of two streams in a fair round-robin manner, --- executing each stream once, alternately. Execution of a stream may not --- necessarily result in an output, a stream may chose to @Skip@ producing an --- element until later giving the other stream a chance to run. Therefore, this --- combinator fairly interleaves the execution of two streams rather than --- fairly interleaving the output of the two streams. This can be useful in --- co-operative multitasking without using explicit threads. This can be used --- as an alternative to `async`. --- --- Do not use at scale in concatMapWith. --- --- @since 0.7.0 -{-# INLINE roundrobin #-} -roundrobin ::(IsStream t, Monad m) => t m b -> t m b -> t m b -roundrobin m1 m2 = fromStreamD $ D.roundRobin (toStreamD m1) (toStreamD m2) - --- | Map a stream producing monadic function on each element of the stream --- and then flatten the results into a single stream. Since the stream --- generation function is monadic, unlike 'concatMap', it can produce an --- effect at the beginning of each iteration of the inner loop. --- --- @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) - --- | Like 'concatMap' but uses an 'Unfold' for stream generation. Unlike --- 'concatMap' this can fuse the 'Unfold' code with the inner loop and --- therefore provide many times better performance. --- --- @since 0.7.0 -{-# INLINE concatUnfold #-} -concatUnfold ::(IsStream t, Monad m) => Unfold m a b -> t m a -> t m b -concatUnfold u m = fromStreamD $ D.concatMapU u (toStreamD m) - --- | Like 'concatUnfold' but interleaves the streams in the same way as --- 'interleave' behaves instead of appending them. --- --- @since 0.7.0 -{-# INLINE concatUnfoldInterleave #-} -concatUnfoldInterleave ::(IsStream t, Monad m) - => Unfold m a b -> t m a -> t m b -concatUnfoldInterleave u m = - fromStreamD $ D.concatUnfoldInterleave u (toStreamD m) - --- | Like 'concatUnfold' but executes the streams in the same way as --- 'roundrobin'. --- --- @since 0.7.0 -{-# INLINE concatUnfoldRoundrobin #-} -concatUnfoldRoundrobin ::(IsStream t, Monad m) - => Unfold m a b -> t m a -> t m b -concatUnfoldRoundrobin u m = - fromStreamD $ D.concatUnfoldRoundrobin u (toStreamD m) - --- XXX we can swap the order of arguments to gintercalate so that the --- definition of concatUnfold becomes simpler? The first stream should be --- infixed inside the second one. However, if we change the order in --- "interleave" as well similarly, then that will make it a bit unintuitive. --- --- > concatUnfold unf str = --- > gintercalate unf str (UF.nilM (\_ -> return ())) (repeat ()) --- --- | 'interleaveInfix' followed by unfold and concat. --- --- /Internal/ -{-# INLINE gintercalate #-} -gintercalate - :: (IsStream t, Monad m) - => Unfold m a c -> t m a -> Unfold m b c -> t m b -> t m c -gintercalate unf1 str1 unf2 str2 = - D.fromStreamD $ D.gintercalate - unf1 (D.toStreamD str1) - unf2 (D.toStreamD str2) - --- XXX The order of arguments in "intercalate" is consistent with the list --- intercalate but inconsistent with gintercalate and other stream interleaving --- combinators. We can change the order of the arguments in other combinators --- but then 'interleave' combinator may become a bit unintuitive because we --- will be starting with the second stream. - --- > intercalate seed unf str = gintercalate unf str unf (repeatM seed) --- > intercalate a unf str = concatUnfold unf $ intersperse a str --- --- | 'intersperse' followed by unfold and concat. --- --- > unwords = intercalate " " UF.fromList --- --- >>> intercalate " " UF.fromList ["abc", "def", "ghi"] --- > "abc def ghi" --- -{-# INLINE intercalate #-} -intercalate :: (IsStream t, Monad m) - => b -> Unfold m b c -> t m b -> t m c -intercalate seed unf str = D.fromStreamD $ - D.concatMapU unf $ D.intersperse seed (toStreamD str) - --- > interpose x unf str = gintercalate unf str UF.identity (repeat x) --- --- | Unfold the elements of a stream, intersperse the given element between the --- unfolded streams and then concat them into a single stream. --- --- > unwords = S.interpose ' ' --- --- /Internal/ -{-# INLINE interpose #-} -interpose :: (IsStream t, Monad m) - => c -> Unfold m b c -> t m b -> t m c -interpose x unf str = - D.fromStreamD $ D.interpose (return x) unf (D.toStreamD str) - --- | 'interleaveSuffix' followed by unfold and concat. --- --- /Internal/ -{-# INLINE gintercalateSuffix #-} -gintercalateSuffix - :: (IsStream t, Monad m) - => Unfold m a c -> t m a -> Unfold m b c -> t m b -> t m c -gintercalateSuffix unf1 str1 unf2 str2 = - D.fromStreamD $ D.gintercalateSuffix - unf1 (D.toStreamD str1) - unf2 (D.toStreamD str2) - --- > intercalateSuffix seed unf str = gintercalateSuffix unf str unf (repeatM seed) --- > intercalateSuffix a unf str = concatUnfold unf $ intersperseSuffix a str --- --- | 'intersperseSuffix' followed by unfold and concat. --- --- > unlines = intercalateSuffix "\n" UF.fromList --- --- >>> intercalate "\n" UF.fromList ["abc", "def", "ghi"] --- > "abc\ndef\nghi\n" --- -{-# INLINE intercalateSuffix #-} -intercalateSuffix :: (IsStream t, Monad m) - => b -> Unfold m b c -> t m b -> t m c -intercalateSuffix seed unf str = fromStreamD $ D.concatMapU unf - $ D.intersperseSuffix (return seed) (D.toStreamD str) - --- interposeSuffix x unf str = gintercalateSuffix unf str UF.identity (repeat x) --- --- | Unfold the elements of a stream, append the given element after each --- unfolded stream and then concat them into a single stream. --- --- > unlines = S.interposeSuffix '\n' --- --- /Internal/ -{-# INLINE interposeSuffix #-} -interposeSuffix :: (IsStream t, Monad m) - => c -> Unfold m b c -> t m b -> t m c -interposeSuffix x unf str = - D.fromStreamD $ D.interposeSuffix (return x) unf (D.toStreamD str) - ------------------------------------------------------------------------------- --- Grouping/Splitting ------------------------------------------------------------------------------- - ------------------------------------------------------------------------------- --- Grouping without looking at elements ------------------------------------------------------------------------------- --- ------------------------------------------------------------------------------- --- Binary APIs ------------------------------------------------------------------------------- --- - --- | @splitAt n f1 f2@ composes folds @f1@ and @f2@ such that first @n@ --- elements of its input are consumed by fold @f1@ and the rest of the stream --- is consumed by fold @f2@. --- --- > let splitAt_ n xs = S.fold (FL.splitAt n FL.toList FL.toList) $ S.fromList xs --- --- >>> splitAt_ 6 "Hello World!" --- > ("Hello ","World!") --- --- >>> splitAt_ (-1) [1,2,3] --- > ([],[1,2,3]) --- --- >>> splitAt_ 0 [1,2,3] --- > ([],[1,2,3]) --- --- >>> splitAt_ 1 [1,2,3] --- > ([1],[2,3]) --- --- >>> splitAt_ 3 [1,2,3] --- > ([1,2,3],[]) --- --- >>> splitAt_ 4 [1,2,3] --- > ([1,2,3],[]) --- --- @since 0.7.0 - --- This can be considered as a two-fold version of 'ltake' where we take both --- the segments instead of discarding the leftover. --- -{-# INLINE splitAt #-} -splitAt - :: Monad m - => Int - -> Fold m a b - -> Fold m a c - -> Fold m a (b, c) -splitAt n (Fold stepL initialL extractL) (Fold stepR initialR extractR) = - Fold step initial extract - where - initial = Tuple3' <$> return n <*> initialL <*> initialR - - step (Tuple3' i xL xR) input = - if i > 0 - then stepL xL input >>= (\a -> return (Tuple3' (i - 1) a xR)) - else stepR xR input >>= (\b -> return (Tuple3' i xL b)) - - extract (Tuple3' _ a b) = (,) <$> extractL a <*> extractR b - ------------------------------------------------------------------------------- --- N-ary APIs ------------------------------------------------------------------------------- - ------------------------------------------------------------------------------- --- Generalized grouping ------------------------------------------------------------------------------- - --- This combinator is the most general grouping combinator and can be used to --- implement all other grouping combinators. --- --- XXX check if this can implement the splitOn combinator i.e. we can slide in --- new elements, slide out old elements and incrementally compute the hash. --- Also, can we implement the windowed classification combinators using this? --- --- In fact this is a parse. Instead of using a special return value in the fold --- we are using a mapping function. --- --- Note that 'scanl'' (usually followed by a map to extract the desired value --- from the accumulator) can be used to realize many implementations e.g. a --- sliding window implementation. A scan followed by a mapMaybe is also a good --- pattern to express many problems where we want to emit a filtered output and --- not emit an output on every input. --- --- Passing on of the initial accumulator value to the next fold is equivalent --- to returning the leftover concept. - -{- --- | @groupScan splitter fold stream@ folds the input stream using @fold@. --- @splitter@ is applied on the accumulator of the fold every time an item is --- consumed by the fold. The fold continues until @splitter@ returns a 'Just' --- value. A 'Just' result from the @splitter@ specifies a result to be emitted --- in the output stream and the initial value of the accumulator for the next --- group's fold. This allows us to control whether to start fresh for the next --- fold or to continue from the previous fold's output. --- -{-# INLINE groupScan #-} -groupScan - :: (IsStream t, Monad m) - => (x -> m (Maybe (b, x))) -> Fold m a x -> t m a -> t m b -groupScan split fold m = undefined --} - --- | Group the input stream into groups of @n@ elements each and then fold each --- group using the provided fold function. --- --- >> S.toList $ S.chunksOf 2 FL.sum (S.enumerateFromTo 1 10) --- > [3,7,11,15,19] --- --- This can be considered as an n-fold version of 'ltake' where we apply --- 'ltake' repeatedly on the leftover stream until the stream exhausts. --- --- @since 0.7.0 -{-# INLINE chunksOf #-} -chunksOf - :: (IsStream t, Monad m) - => Int -> Fold m a b -> t m a -> t m b -chunksOf n f m = D.fromStreamD $ D.groupsOf n f (D.toStreamD m) - -{-# INLINE chunksOf2 #-} -chunksOf2 - :: (IsStream t, Monad m) - => Int -> m c -> Fold2 m c a b -> t m a -> t m b -chunksOf2 n action f m = D.fromStreamD $ D.groupsOf2 n action f (D.toStreamD m) - --- | @arraysOf n stream@ groups the elements in the input stream into arrays of --- @n@ elements each. --- --- Same as the following but may be more efficient: --- --- > arraysOf n = S.chunksOf n (A.writeN n) --- --- @since 0.7.0 -{-# INLINE arraysOf #-} -arraysOf :: (IsStream t, MonadIO m, Storable a) - => Int -> t m a -> t m (Array a) -arraysOf n = chunksOf n (writeNUnsafe n) - --- XXX we can implement this by repeatedly applying the 'lrunFor' fold. --- XXX add this example after fixing the serial stream rate control --- >>> S.toList $ S.take 5 $ intervalsOf 1 FL.sum $ constRate 2 $ S.enumerateFrom 1 --- > [3,7,11,15,19] --- --- | Group the input stream into windows of @n@ second each and then fold each --- group using the provided fold function. --- --- @since 0.7.0 -{-# INLINE intervalsOf #-} -intervalsOf - :: (IsStream t, MonadAsync m) - => Double -> Fold m a b -> t m a -> t m b -intervalsOf n f xs = - splitWithSuffix isNothing (FL.lcatMaybes f) - (interjectSuffix n (return Nothing) (Serial.map Just xs)) - ------------------------------------------------------------------------------- --- Element Aware APIs ------------------------------------------------------------------------------- --- ------------------------------------------------------------------------------- --- Binary APIs ------------------------------------------------------------------------------- - --- | Break the input stream into two groups, the first group takes the input as --- long as the predicate applied to the first element of the stream and next --- input element holds 'True', the second group takes the rest of the input. --- -spanBy - :: Monad m - => (a -> a -> Bool) - -> Fold m a b - -> Fold m a c - -> Fold m a (b, c) -spanBy cmp (Fold stepL initialL extractL) (Fold stepR initialR extractR) = - Fold step initial extract - - where - initial = Tuple3' <$> initialL <*> initialR <*> return (Tuple' Nothing True) - - step (Tuple3' a b (Tuple' (Just frst) isFirstG)) input = - if cmp frst input && isFirstG - then stepL a input - >>= (\a' -> return (Tuple3' a' b (Tuple' (Just frst) isFirstG))) - else stepR b input - >>= (\a' -> return (Tuple3' a a' (Tuple' Nothing False))) - - step (Tuple3' a b (Tuple' Nothing isFirstG)) input = - if isFirstG - then stepL a input - >>= (\a' -> return (Tuple3' a' b (Tuple' (Just input) isFirstG))) - else stepR b input - >>= (\a' -> return (Tuple3' a a' (Tuple' Nothing False))) - - extract (Tuple3' a b _) = (,) <$> extractL a <*> extractR b - --- | @span p f1 f2@ composes folds @f1@ and @f2@ such that @f1@ consumes the --- input as long as the predicate @p@ is 'True'. @f2@ consumes the rest of the --- input. --- --- > let span_ p xs = S.fold (S.span p FL.toList FL.toList) $ S.fromList xs --- --- >>> span_ (< 1) [1,2,3] --- > ([],[1,2,3]) --- --- >>> span_ (< 2) [1,2,3] --- > ([1],[2,3]) --- --- >>> span_ (< 4) [1,2,3] --- > ([1,2,3],[]) --- --- @since 0.7.0 - --- This can be considered as a two-fold version of 'ltakeWhile' where we take --- both the segments instead of discarding the leftover. -{-# INLINE span #-} -span - :: Monad m - => (a -> Bool) - -> Fold m a b - -> Fold m a c - -> Fold m a (b, c) -span p (Fold stepL initialL extractL) (Fold stepR initialR extractR) = - Fold step initial extract - - where - - initial = Tuple3' <$> initialL <*> initialR <*> return True - - step (Tuple3' a b isFirstG) input = - if isFirstG && p input - then stepL a input >>= (\a' -> return (Tuple3' a' b True)) - else stepR b input >>= (\a' -> return (Tuple3' a a' False)) - - extract (Tuple3' a b _) = (,) <$> extractL a <*> extractR b - --- | --- > break p = span (not . p) --- --- Break as soon as the predicate becomes 'True'. @break p f1 f2@ composes --- folds @f1@ and @f2@ such that @f1@ stops consuming input as soon as the --- predicate @p@ becomes 'True'. The rest of the input is consumed @f2@. --- --- This is the binary version of 'splitBy'. --- --- > let break_ p xs = S.fold (S.break p FL.toList FL.toList) $ S.fromList xs --- --- >>> break_ (< 1) [3,2,1] --- > ([3,2,1],[]) --- --- >>> break_ (< 2) [3,2,1] --- > ([3,2],[1]) --- --- >>> break_ (< 4) [3,2,1] --- > ([],[3,2,1]) --- --- @since 0.7.0 -{-# INLINE break #-} -break - :: Monad m - => (a -> Bool) - -> Fold m a b - -> Fold m a c - -> Fold m a (b, c) -break p = span (not . p) - --- | Like 'spanBy' but applies the predicate in a rolling fashion i.e. --- predicate is applied to the previous and the next input elements. -{-# INLINE spanByRolling #-} -spanByRolling - :: Monad m - => (a -> a -> Bool) - -> Fold m a b - -> Fold m a c - -> Fold m a (b, c) -spanByRolling cmp (Fold stepL initialL extractL) (Fold stepR initialR extractR) = - Fold step initial extract - - where - initial = Tuple3' <$> initialL <*> initialR <*> return Nothing - - step (Tuple3' a b (Just frst)) input = - if cmp input frst - then stepL a input >>= (\a' -> return (Tuple3' a' b (Just input))) - else stepR b input >>= (\b' -> return (Tuple3' a b' (Just input))) - - step (Tuple3' a b Nothing) input = - stepL a input >>= (\a' -> return (Tuple3' a' b (Just input))) - - extract (Tuple3' a b _) = (,) <$> extractL a <*> extractR b - ------------------------------------------------------------------------------- --- N-ary APIs ------------------------------------------------------------------------------- --- --- | @groupsBy cmp f $ S.fromList [a,b,c,...]@ assigns the element @a@ to the --- first group, if @a \`cmp` b@ is 'True' then @b@ is also assigned to the same --- group. If @a \`cmp` c@ is 'True' then @c@ is also assigned to the same --- group and so on. When the comparison fails a new group is started. Each --- group is folded using the fold @f@ and the result of the fold is emitted in --- the output stream. --- --- >>> S.toList $ S.groupsBy (>) FL.toList $ S.fromList [1,3,7,0,2,5] --- > [[1,3,7],[0,2,5]] --- --- @since 0.7.0 -{-# INLINE groupsBy #-} -groupsBy - :: (IsStream t, Monad m) - => (a -> a -> Bool) - -> Fold m a b - -> t m a - -> t m b -groupsBy cmp f m = D.fromStreamD $ D.groupsBy cmp f (D.toStreamD m) - --- | Unlike @groupsBy@ this function performs a rolling comparison of two --- successive elements in the input stream. @groupsByRolling cmp f $ S.fromList --- [a,b,c,...]@ assigns the element @a@ to the first group, if @a \`cmp` b@ is --- 'True' then @b@ is also assigned to the same group. If @b \`cmp` c@ is --- 'True' then @c@ is also assigned to the same group and so on. When the --- comparison fails a new group is started. Each group is folded using the fold --- @f@. --- --- >>> S.toList $ S.groupsByRolling (\a b -> a + 1 == b) FL.toList $ S.fromList [1,2,3,7,8,9] --- > [[1,2,3],[7,8,9]] --- --- @since 0.7.0 -{-# INLINE groupsByRolling #-} -groupsByRolling - :: (IsStream t, Monad m) - => (a -> a -> Bool) - -> Fold m a b - -> t m a - -> t m b -groupsByRolling cmp f m = D.fromStreamD $ D.groupsRollingBy cmp f (D.toStreamD m) - --- | --- > groups = groupsBy (==) --- > groups = groupsByRolling (==) --- --- Groups contiguous spans of equal elements together in individual groups. --- --- >>> S.toList $ S.groups FL.toList $ S.fromList [1,1,2,2] --- > [[1,1],[2,2]] --- --- @since 0.7.0 -groups :: (IsStream t, Monad m, Eq a) => Fold m a b -> t m a -> t m b -groups = groupsBy (==) - ------------------------------------------------------------------------------- --- Binary splitting on a separator ------------------------------------------------------------------------------- - -{- --- | Find the first occurrence of the specified sequence in the input stream --- and break the input stream into two parts, the first part consisting of the --- stream before the sequence and the second part consisting of the sequence --- and the rest of the stream. --- --- > let breakOn_ pat xs = S.fold (S.breakOn pat FL.toList FL.toList) $ S.fromList xs --- --- >>> breakOn_ "dear" "Hello dear world!" --- > ("Hello ","dear world!") --- -{-# INLINE breakOn #-} -breakOn :: Monad m => Array a -> Fold m a b -> Fold m a c -> Fold m a (b,c) -breakOn pat f m = undefined --} - ------------------------------------------------------------------------------- --- N-ary split on a predicate ------------------------------------------------------------------------------- - --- TODO: Use a Splitter configuration similar to the "split" package to make it --- possible to express all splitting combinations. In general, we can have --- infix/suffix/prefix/condensing of separators, dropping both leading/trailing --- separators. We can have a single split operation taking the splitter config --- as argument. - --- | Split on an infixed separator element, dropping the separator. Splits the --- stream on separator elements determined by the supplied predicate, separator --- is considered as infixed between two segments, if one side of the separator --- is missing then it is parsed as an empty stream. The supplied 'Fold' is --- applied on the split segments. With '-' representing non-separator elements --- and '.' as separator, 'splitOn' splits as follows: --- --- @ --- "--.--" => "--" "--" --- "--." => "--" "" --- ".--" => "" "--" --- @ --- --- @splitOn (== x)@ is an inverse of @intercalate (S.yield x)@ --- --- Let's use the following definition for illustration: --- --- > splitOn' p xs = S.toList $ S.splitOn p (FL.toList) (S.fromList xs) --- --- >>> splitOn' (== '.') "" --- [""] --- --- >>> splitOn' (== '.') "." --- ["",""] --- --- >>> splitOn' (== '.') ".a" --- > ["","a"] --- --- >>> splitOn' (== '.') "a." --- > ["a",""] --- --- >>> splitOn' (== '.') "a.b" --- > ["a","b"] --- --- >>> splitOn' (== '.') "a..b" --- > ["a","","b"] --- --- @since 0.7.0 - --- This can be considered as an n-fold version of 'breakOn' where we apply --- 'breakOn' successively on the input stream, dropping the first element --- of the second segment after each break. --- -{-# INLINE splitOn #-} -splitOn - :: (IsStream t, Monad m) - => (a -> Bool) -> Fold m a b -> t m a -> t m b -splitOn predicate f m = - D.fromStreamD $ D.splitBy predicate f (D.toStreamD m) - --- | Like 'splitOn' but the separator is considered as suffixed to the segments --- in the stream. A missing suffix at the end is allowed. A separator at the --- beginning is parsed as empty segment. With '-' representing elements and --- '.' as separator, 'splitOnSuffix' splits as follows: --- --- @ --- "--.--." => "--" "--" --- "--.--" => "--" "--" --- ".--." => "" "--" --- @ --- --- > splitOnSuffix' p xs = S.toList $ S.splitSuffixBy p (FL.toList) (S.fromList xs) --- --- >>> splitOnSuffix' (== '.') "" --- [] --- --- >>> splitOnSuffix' (== '.') "." --- [""] --- --- >>> splitOnSuffix' (== '.') "a" --- ["a"] --- --- >>> splitOnSuffix' (== '.') ".a" --- > ["","a"] --- --- >>> splitOnSuffix' (== '.') "a." --- > ["a"] --- --- >>> splitOnSuffix' (== '.') "a.b" --- > ["a","b"] --- --- >>> splitOnSuffix' (== '.') "a.b." --- > ["a","b"] --- --- >>> splitOnSuffix' (== '.') "a..b.." --- > ["a","","b",""] --- --- > lines = splitOnSuffix (== '\n') --- --- @since 0.7.0 - --- This can be considered as an n-fold version of 'breakPost' where we apply --- 'breakPost' successively on the input stream, dropping the first element --- of the second segment after each break. --- -{-# INLINE splitOnSuffix #-} -splitOnSuffix - :: (IsStream t, Monad m) - => (a -> Bool) -> Fold m a b -> t m a -> t m b -splitOnSuffix predicate f m = - D.fromStreamD $ D.splitSuffixBy predicate f (D.toStreamD m) - --- | Like 'splitOn' after stripping leading, trailing, and repeated separators. --- Therefore, @".a..b."@ with '.' as the separator would be parsed as --- @["a","b"]@. In other words, its like parsing words from whitespace --- separated text. --- --- > wordsBy' p xs = S.toList $ S.wordsBy p (FL.toList) (S.fromList xs) --- --- >>> wordsBy' (== ',') "" --- > [] --- --- >>> wordsBy' (== ',') "," --- > [] --- --- >>> wordsBy' (== ',') ",a,,b," --- > ["a","b"] --- --- > words = wordsBy isSpace --- --- @since 0.7.0 - --- It is equivalent to splitting in any of the infix/prefix/suffix styles --- followed by removal of empty segments. -{-# INLINE wordsBy #-} -wordsBy - :: (IsStream t, Monad m) - => (a -> Bool) -> Fold m a b -> t m a -> t m b -wordsBy predicate f m = - D.fromStreamD $ D.wordsBy predicate f (D.toStreamD m) - --- | Like 'splitOnSuffix' but keeps the suffix attached to the resulting --- splits. --- --- > splitWithSuffix' p xs = S.toList $ S.splitWithSuffix p (FL.toList) (S.fromList xs) --- --- >>> splitWithSuffix' (== '.') "" --- [] --- --- >>> splitWithSuffix' (== '.') "." --- ["."] --- --- >>> splitWithSuffix' (== '.') "a" --- ["a"] --- --- >>> splitWithSuffix' (== '.') ".a" --- > [".","a"] --- --- >>> splitWithSuffix' (== '.') "a." --- > ["a."] --- --- >>> splitWithSuffix' (== '.') "a.b" --- > ["a.","b"] --- --- >>> splitWithSuffix' (== '.') "a.b." --- > ["a.","b."] --- --- >>> splitWithSuffix' (== '.') "a..b.." --- > ["a.",".","b.","."] --- --- @since 0.7.0 - --- This can be considered as an n-fold version of 'breakPost' where we apply --- 'breakPost' successively on the input stream. --- -{-# INLINE splitWithSuffix #-} -splitWithSuffix - :: (IsStream t, Monad m) - => (a -> Bool) -> Fold m a b -> t m a -> t m b -splitWithSuffix predicate f m = - D.fromStreamD $ D.splitSuffixBy' predicate f (D.toStreamD m) - ------------------------------------------------------------------------------- --- Split on a delimiter sequence ------------------------------------------------------------------------------- - --- Int list examples for splitOn: --- --- >>> splitList [] [1,2,3,3,4] --- > [[1],[2],[3],[3],[4]] --- --- >>> splitList [5] [1,2,3,3,4] --- > [[1,2,3,3,4]] --- --- >>> splitList [1] [1,2,3,3,4] --- > [[],[2,3,3,4]] --- --- >>> splitList [4] [1,2,3,3,4] --- > [[1,2,3,3],[]] --- --- >>> splitList [2] [1,2,3,3,4] --- > [[1],[3,3,4]] --- --- >>> splitList [3] [1,2,3,3,4] --- > [[1,2],[],[4]] --- --- >>> splitList [3,3] [1,2,3,3,4] --- > [[1,2],[4]] --- --- >>> splitList [1,2,3,3,4] [1,2,3,3,4] --- > [[],[]] - --- | Like 'splitOn' but the separator is a sequence of elements instead of a --- single element. --- --- For illustration, let's define a function that operates on pure lists: --- --- @ --- splitOnSeq' pat xs = S.toList $ S.splitOnSeq (A.fromList pat) (FL.toList) (S.fromList xs) --- @ --- --- >>> splitOnSeq' "" "hello" --- > ["h","e","l","l","o"] --- --- >>> splitOnSeq' "hello" "" --- > [""] --- --- >>> splitOnSeq' "hello" "hello" --- > ["",""] --- --- >>> splitOnSeq' "x" "hello" --- > ["hello"] --- --- >>> splitOnSeq' "h" "hello" --- > ["","ello"] --- --- >>> splitOnSeq' "o" "hello" --- > ["hell",""] --- --- >>> splitOnSeq' "e" "hello" --- > ["h","llo"] --- --- >>> splitOnSeq' "l" "hello" --- > ["he","","o"] --- --- >>> splitOnSeq' "ll" "hello" --- > ["he","o"] --- --- 'splitOnSeq' is an inverse of 'intercalate'. The following law always holds: --- --- > intercalate . splitOn == id --- --- The following law holds when the separator is non-empty and contains none of --- the elements present in the input lists: --- --- > splitOn . intercalate == id --- --- @since 0.7.0 - --- XXX We can use a polymorphic vector implemented by Array# to represent the --- sequence, that way we can avoid the Storable constraint. If we still need --- Storable Array for performance, we can use a separate splitOnArray API for --- that. We can also have an API where the sequence itself is a lazy stream, so --- that we can search files in files for example. -{-# INLINE splitOnSeq #-} -splitOnSeq - :: (IsStream t, MonadIO m, Storable a, Enum a, Eq a) - => Array a -> Fold m a b -> t m a -> t m b -splitOnSeq patt f m = D.fromStreamD $ D.splitOn patt f (D.toStreamD m) - -{- --- This can be implemented easily using Rabin Karp --- | Split on any one of the given patterns. -{-# INLINE splitOnAny #-} -splitOnAny - :: (IsStream t, Monad m, Storable a, Integral a) - => [Array a] -> Fold m a b -> t m a -> t m b -splitOnAny subseq f m = undefined -- D.fromStreamD $ D.splitOnAny f subseq (D.toStreamD m) --} - --- | Like 'splitSuffixBy' but the separator is a sequence of elements, instead --- of a predicate for a single element. --- --- > splitSuffixOn_ pat xs = S.toList $ S.splitSuffixOn (A.fromList pat) (FL.toList) (S.fromList xs) --- --- >>> splitSuffixOn_ "." "" --- [""] --- --- >>> splitSuffixOn_ "." "." --- [""] --- --- >>> splitSuffixOn_ "." "a" --- ["a"] --- --- >>> splitSuffixOn_ "." ".a" --- > ["","a"] --- --- >>> splitSuffixOn_ "." "a." --- > ["a"] --- --- >>> splitSuffixOn_ "." "a.b" --- > ["a","b"] --- --- >>> splitSuffixOn_ "." "a.b." --- > ["a","b"] --- --- >>> splitSuffixOn_ "." "a..b.." --- > ["a","","b",""] --- --- > lines = splitSuffixOn "\n" --- --- @since 0.7.0 -{-# INLINE splitOnSuffixSeq #-} -splitOnSuffixSeq - :: (IsStream t, MonadIO m, Storable a, Enum a, Eq a) - => Array a -> Fold m a b -> t m a -> t m b -splitOnSuffixSeq patt f m = - D.fromStreamD $ D.splitSuffixOn False patt f (D.toStreamD m) - -{- --- | Like 'splitOn' but drops any empty splits. --- -{-# INLINE wordsOn #-} -wordsOn - :: (IsStream t, Monad m, Storable a, Eq a) - => Array a -> Fold m a b -> t m a -> t m b -wordsOn subseq f m = undefined -- D.fromStreamD $ D.wordsOn f subseq (D.toStreamD m) --} - --- XXX use a non-monadic intersperse to remove the MonadAsync constraint. --- --- | Like 'splitOnSeq' but splits the separator as well, as an infix token. --- --- > splitOn'_ pat xs = S.toList $ S.splitOn' (A.fromList pat) (FL.toList) (S.fromList xs) --- --- >>> splitOn'_ "" "hello" --- > ["h","","e","","l","","l","","o"] --- --- >>> splitOn'_ "hello" "" --- > [""] --- --- >>> splitOn'_ "hello" "hello" --- > ["","hello",""] --- --- >>> splitOn'_ "x" "hello" --- > ["hello"] --- --- >>> splitOn'_ "h" "hello" --- > ["","h","ello"] --- --- >>> splitOn'_ "o" "hello" --- > ["hell","o",""] --- --- >>> splitOn'_ "e" "hello" --- > ["h","e","llo"] --- --- >>> splitOn'_ "l" "hello" --- > ["he","l","","l","o"] --- --- >>> splitOn'_ "ll" "hello" --- > ["he","ll","o"] --- --- @since 0.7.0 -{-# INLINE splitBySeq #-} -splitBySeq - :: (IsStream t, MonadAsync m, Storable a, Enum a, Eq a) - => Array a -> Fold m a b -> t m a -> t m b -splitBySeq patt f m = - intersperseM (fold f (A.toStream patt)) $ splitOnSeq patt f m - --- | Like 'splitSuffixOn' but keeps the suffix intact in the splits. --- --- > splitSuffixOn'_ pat xs = S.toList $ FL.splitSuffixOn' (A.fromList pat) (FL.toList) (S.fromList xs) --- --- >>> splitSuffixOn'_ "." "" --- [""] --- --- >>> splitSuffixOn'_ "." "." --- ["."] --- --- >>> splitSuffixOn'_ "." "a" --- ["a"] --- --- >>> splitSuffixOn'_ "." ".a" --- > [".","a"] --- --- >>> splitSuffixOn'_ "." "a." --- > ["a."] --- --- >>> splitSuffixOn'_ "." "a.b" --- > ["a.","b"] --- --- >>> splitSuffixOn'_ "." "a.b." --- > ["a.","b."] --- --- >>> splitSuffixOn'_ "." "a..b.." --- > ["a.",".","b.","."] --- --- @since 0.7.0 -{-# INLINE splitWithSuffixSeq #-} -splitWithSuffixSeq - :: (IsStream t, MonadIO m, Storable a, Enum a, Eq a) - => Array a -> Fold m a b -> t m a -> t m b -splitWithSuffixSeq patt f m = - D.fromStreamD $ D.splitSuffixOn True patt f (D.toStreamD m) - -{- --- This can be implemented easily using Rabin Karp --- | Split post any one of the given patterns. -{-# INLINE splitSuffixOnAny #-} -splitSuffixOnAny - :: (IsStream t, Monad m, Storable a, Integral a) - => [Array a] -> Fold m a b -> t m a -> t m b -splitSuffixOnAny subseq f m = undefined - -- D.fromStreamD $ D.splitPostAny f subseq (D.toStreamD m) --} - ------------------------------------------------------------------------------- --- Nested Split ------------------------------------------------------------------------------- - --- | Consider a chunked stream of container elements e.g. a stream of @Word8@ --- chunked as a stream of arrays of @Word8@. @splitInnerBy splitter joiner --- stream@ splits the inner containers @f a@ using the @splitter@ function and --- joins back the resulting fragments from splitting across multiple containers --- using the @joiner@ function such that the transformed output stream is --- consolidated as one container per segment of the split. --- --- CAUTION! This is not a true streaming function as the container size after --- the split and merge may not be bounded. --- --- @since 0.7.0 -{-# INLINE splitInnerBy #-} -splitInnerBy - :: (IsStream t, Monad m) - => (f a -> m (f a, Maybe (f a))) -- splitter - -> (f a -> f a -> m (f a)) -- joiner - -> t m (f a) - -> t m (f a) -splitInnerBy splitter joiner xs = - D.fromStreamD $ D.splitInnerBy splitter joiner $ D.toStreamD xs - --- | Like 'splitInnerBy' but splits assuming the separator joins the segment in --- a suffix style. --- --- @since 0.7.0 -{-# INLINE splitInnerBySuffix #-} -splitInnerBySuffix - :: (IsStream t, Monad m, Eq (f a), Monoid (f a)) - => (f a -> m (f a, Maybe (f a))) -- splitter - -> (f a -> f a -> m (f a)) -- joiner - -> t m (f a) - -> t m (f a) -splitInnerBySuffix splitter joiner xs = - D.fromStreamD $ D.splitInnerBySuffix splitter joiner $ D.toStreamD xs - ------------------------------------------------------------------------------- --- Reorder in sequence ------------------------------------------------------------------------------- - -{- --- Buffer until the next element in sequence arrives. The function argument --- determines the difference in sequence numbers. This could be useful in --- implementing sequenced streams, for example, TCP reassembly. -{-# INLINE reassembleBy #-} -reassembleBy - :: (IsStream t, Monad m) - => Fold m a b - -> (a -> a -> Int) - -> t m a - -> t m b -reassembleBy = undefined --} - ------------------------------------------------------------------------------- --- Distributing ------------------------------------------------------------------------------- - --- | Tap the data flowing through a stream into a 'Fold'. For example, you may --- add a tap to log the contents flowing through the stream. The fold is used --- only for effects, its result is discarded. --- --- @ --- Fold m a b --- | --- -----stream m a ---------------stream m a----- --- --- @ --- --- @ --- > S.drain $ S.tap (FL.drainBy print) (S.enumerateFromTo 1 2) --- 1 --- 2 --- @ --- --- Compare with 'trace'. --- --- @since 0.7.0 -tap :: (IsStream t, Monad m) => FL.Fold m a b -> t m a -> t m a -tap f xs = D.fromStreamD $ D.tap f (D.toStreamD xs) - --- | Apply a monadic function to each element flowing through the stream and --- discard the results. --- --- @ --- > S.drain $ S.trace print (S.enumerateFromTo 1 2) --- 1 --- 2 --- @ --- --- Compare with 'tap'. --- --- @since 0.7.0 -trace :: (IsStream t, MonadAsync m) => (a -> m b) -> t m a -> t m a -trace f = mapM (\x -> void (f x) >> return x) - ------------------------------------------------------------------------------- --- Windowed classification ------------------------------------------------------------------------------- - --- We divide the stream into windows or chunks in space or time and each window --- can be associated with a key, all events associated with a particular key in --- the window can be folded to a single result. The stream can be split into --- windows by size or by using a split predicate on the elements in the stream. --- For example, when we receive a closing flag, we can close the window. --- --- A "chunk" is a space window and a "session" is a time window. Are there any --- other better short words to describe them. An alternative is to use --- "swindow" and "twindow". Another word for "session" could be "spell". --- --- TODO: To mark the position in space or time we can have Indexed or --- TimeStamped types. That can make it easy to deal with the position indices --- or timestamps. - ------------------------------------------------------------------------------- --- Keyed Sliding Windows ------------------------------------------------------------------------------- - -{- -{-# INLINABLE classifySlidingChunks #-} -classifySlidingChunks - :: (IsStream t, MonadAsync m, Ord k) - => Int -- ^ window size - -> Int -- ^ window slide - -> Fold m a b -- ^ Fold to be applied to window events - -> t m (k, a, Bool) -- ^ window key, data, close event - -> t m (k, b) -classifySlidingChunks wsize wslide (Fold step initial extract) str - = undefined - --- XXX Another variant could be to slide the window on an event, e.g. in TCP we --- slide the send window when an ack is received and we slide the receive --- window when a sequence is complete. Sliding is stateful in case of TCP, --- sliding releases the send buffer or makes data available to the user from --- the receive buffer. -{-# INLINABLE classifySlidingSessions #-} -classifySlidingSessions - :: (IsStream t, MonadAsync m, Ord k) - => Double -- ^ timer tick in seconds - -> Double -- ^ time window size - -> Double -- ^ window slide - -> Fold m a b -- ^ Fold to be applied to window events - -> t m (k, a, Bool, AbsTime) -- ^ window key, data, close flag, timestamp - -> t m (k, b) -classifySlidingSessions tick interval slide (Fold step initial extract) str - = undefined --} - ------------------------------------------------------------------------------- --- Sliding Window Buffers ------------------------------------------------------------------------------- - --- These buffered versions could be faster than concurrent incremental folds of --- all overlapping windows as in many cases we may not need all the values to --- compute the fold, we can just compute the result using the old value and new --- value. However, we may need the buffer once in a while, for example for --- string search we usually compute the hash incrementally but when the hash --- matches the hash of the pattern we need to compare the whole string. --- --- XXX we should be able to implement sequence based splitting combinators --- using this combinator. - -{- --- | Buffer n elements of the input in a ring buffer. When t new elements are --- collected, slide the window to remove the same number of oldest elements, --- insert the new elements, and apply an incremental fold on the sliding --- window, supplying the outgoing elements, the new ring buffer as arguments. -slidingChunkBuffer - :: (IsStream t, Monad m, Ord a, Storable a) - => Int -- window size - -> Int -- window slide - -> Fold m (Ring a, Array a) b - -> t m a - -> t m b -slidingChunkBuffer = undefined - --- Buffer n seconds worth of stream elements of the input in a radix tree. --- Every t seconds, remove the items that are older than n seconds, and apply --- an incremental fold on the sliding window, supplying the outgoing elements, --- and the new radix tree buffer as arguments. -slidingSessionBuffer - :: (IsStream t, Monad m, Ord a, Storable a) - => Int -- window size - -> Int -- tick size - -> Fold m (RTree a, Array a) b - -> t m a - -> t m b -slidingSessionBuffer = undefined --} - ------------------------------------------------------------------------------- --- Keyed Session Windows ------------------------------------------------------------------------------- - -{- --- | Keyed variable size space windows. Close the window if we do not receive a --- window event in the next "spaceout" elements. -{-# INLINABLE classifyChunksBy #-} -classifyChunksBy - :: (IsStream t, MonadAsync m, Ord k) - => Int -- ^ window spaceout (spread) - -> Bool -- ^ reset the spaceout when a chunk window element is received - -> Fold m a b -- ^ Fold to be applied to chunk window elements - -> t m (k, a, Bool) -- ^ chunk key, data, last element - -> t m (k, b) -classifyChunksBy spanout reset (Fold step initial extract) str = undefined - --- | Like 'classifyChunksOf' but the chunk size is reset if an element is --- received within the chunk size window. The chunk gets closed only if no --- element is received within the chunk window. --- -{-# INLINABLE classifyKeepAliveChunks #-} -classifyKeepAliveChunks - :: (IsStream t, MonadAsync m, Ord k) - => Int -- ^ window spaceout (spread) - -> Fold m a b -- ^ Fold to be applied to chunk window elements - -> t m (k, a, Bool) -- ^ chunk key, data, last element - -> t m (k, b) -classifyKeepAliveChunks spanout = classifyChunksBy spanout True --} - --- | @classifySessionsBy tick timeout reset f stream@ groups together all input --- stream elements that belong to the same session. @timeout@ is the maximum --- lifetime of a session in seconds. All elements belonging to a session are --- purged after this duration. If "reset" is 'Ture' then the timeout is reset --- after every event received in the session. Session duration is measured --- using the timestamp of the first element seen for that session. To detect --- session timeouts, a monotonic event time clock is maintained using the --- timestamps seen in the inputs and a timer with a tick duration specified by --- @tick@. --- --- @session key@ is a key that uniquely identifies the session for the given --- element, @timestamp@ characterizes the time when the input element was --- generated, this is an absolute time measured from some @Epoch@. @session --- close@ is a boolean indicating whether this element marks the closing of the --- session. When an input element with @session close@ set to @True@ is seen --- the session is purged immediately. --- --- All the input elements belonging to a session are collected using the fold --- @f@. The session key and the fold result are emitted in the output stream --- when the session is purged either via the session close event or via the --- session liftime timeout. --- --- @since 0.7.0 -{-# INLINABLE classifySessionsBy #-} -classifySessionsBy - :: (IsStream t, MonadAsync m, Ord k) - => Double -- ^ timer tick in seconds - -> Double -- ^ session timeout - -> Bool -- ^ reset the timeout when an event is received - -> Fold m a b -- ^ Fold to be applied to session events - -> t m (k, a, Bool, AbsTime) -- ^ session key, timestamp, close event, data - -> t m (k, b) -classifySessionsBy tick timeout reset (Fold step initial extract) str = - concatMap (\(Tuple4' _ _ _ s) -> s) $ scanlM' sstep szero stream - - where - - timeoutMs = toRelTime (round (timeout * 1000) :: MilliSecond64) - tickMs = toRelTime (round (tick * 1000) :: MilliSecond64) - szero = Tuple4' (toAbsTime (0 :: MilliSecond64)) H.empty Map.empty K.nil - - -- Got a new stream input element - sstep (Tuple4' evTime hp mp _) (Just (key, a, closing, ts)) = - -- XXX we should use a heap in pinned memory to scale it to a large - -- size - -- - -- deleting a key from the heap is expensive, so we never delete a - -- key, we just purge it from the Map and it gets purged from the - -- heap on timeout. We just need an extra lookup in the Map when - -- the key is purged from the heap, that should not be expensive. - -- - -- To detect session inactivity we keep a timestamp of the latest event - -- in the Map along with the fold result. When we purge the session - -- from the heap we match the timestamp in the heap with the timestamp - -- in the Map, if the latest timestamp is newer and has not expired we - -- reinsert the key in the heap. - -- - -- XXX if the key is an Int, we can also use an IntMap for slightly - -- better performance. - -- - let accumulate v = do - Tuple' _ old <- maybe (initial >>= return . Tuple' ts) return v - new <- step old a - return $ Tuple' ts new - in if closing - then do - let (r, mp') = Map.updateLookupWithKey (\_ _ -> Nothing) key mp - Tuple' _ acc <- accumulate r - res <- extract acc - return $ Tuple4' evTime hp mp' (yield (key, res)) - else do - let r = Map.lookup key mp - acc <- accumulate r - let mp' = Map.insert key acc mp - let hp' = - case r of - Nothing -> - let expiry = addToAbsTime ts timeoutMs - in H.insert (Entry expiry key) hp - Just _ -> hp - -- Event time is maintained as monotonically increasing - -- time. If we have lagged behind any of the timestamps - -- seen then we increase it to match the latest time seen - -- in the timestamps. We also increase it on timer ticks. - return $ Tuple4' (max evTime ts) hp' mp' K.nil - - -- Got a timer tick event - -- XXX can we yield the entries without accumulating them? - sstep (Tuple4' evTime heap sessions _) Nothing = do - (hp', mp', out) <- go heap sessions K.nil - return $ Tuple4' curTime hp' mp' out - - where - - curTime = addToAbsTime evTime tickMs - go hp mp out = do - let hres = H.uncons hp - case hres of - Just (Entry ts key, hp') -> do - let duration = diffAbsTime curTime ts - if duration >= timeoutMs - then do - let (r, mp') = Map.updateLookupWithKey - (\_ _ -> Nothing) key mp - case r of - Nothing -> go hp' mp' out - Just (Tuple' latestTS acc) -> do - let dur = diffAbsTime curTime latestTS - if dur >= timeoutMs || not reset - then do - sess <- extract acc - go hp' mp' ((key, sess) `K.cons` out) - else - -- reset the session timeout - let expiry = addToAbsTime latestTS timeoutMs - hp'' = H.insert (Entry expiry key) hp' - mp'' = Map.insert key (Tuple' latestTS acc) mp' - in go hp'' mp'' out - else return (hp, mp, out) - Nothing -> return (hp, mp, out) - - -- merge timer events in the stream - stream = Serial.map Just str `Par.parallel` repeatM timer - timer = do - liftIO $ threadDelay (round $ tick * 1000000) - return Nothing - --- | Like 'classifySessionsOf' but the session is kept alive if an event is --- received within the session window. The session times out and gets closed --- only if no event is received within the specified session window size. --- --- @since 0.7.0 -{-# INLINABLE classifyKeepAliveSessions #-} -classifyKeepAliveSessions - :: (IsStream t, MonadAsync m, Ord k) - => Double -- ^ session inactive timeout - -> Fold m a b -- ^ Fold to be applied to session payload data - -> t m (k, a, Bool, AbsTime) -- ^ session key, data, close flag, timestamp - -> t m (k, b) -classifyKeepAliveSessions timeout = classifySessionsBy 1 timeout True - ------------------------------------------------------------------------------- --- Keyed tumbling windows ------------------------------------------------------------------------------- - --- Tumbling windows is a special case of sliding windows where the window slide --- is the same as the window size. Or it can be a special case of session --- windows where the reset flag is set to False. - --- XXX instead of using the early termination flag in the stream, we can use an --- early terminating fold instead. - -{- --- | Split the stream into fixed size chunks of specified size. Within each --- such chunk fold the elements in buckets identified by the keys. A particular --- bucket fold can be terminated early if a closing flag is encountered in an --- element for that key. --- --- @since 0.7.0 -{-# INLINABLE classifyChunksOf #-} -classifyChunksOf - :: (IsStream t, MonadAsync m, Ord k) - => Int -- ^ window size - -> Fold m a b -- ^ Fold to be applied to window events - -> t m (k, a, Bool) -- ^ window key, data, close event - -> t m (k, b) -classifyChunksOf wsize = classifyChunksBy wsize False --} - --- | Split the stream into fixed size time windows of specified interval in --- seconds. Within each such window, fold the elements in buckets identified by --- the keys. A particular bucket fold can be terminated early if a closing flag --- is encountered in an element for that key. Once a fold is terminated the key --- and value for that bucket are emitted in the output stream. --- --- Session @timestamp@ in the input stream is an absolute time from some epoch, --- characterizing the time when the input element was generated. To detect --- session window end, a monotonic event time clock is maintained synced with --- the timestamps with a clock resolution of 1 second. --- --- @since 0.7.0 -{-# INLINABLE classifySessionsOf #-} -classifySessionsOf - :: (IsStream t, MonadAsync m, Ord k) - => Double -- ^ time window size - -> Fold m a b -- ^ Fold to be applied to window events - -> t m (k, a, Bool, AbsTime) -- ^ window key, data, close flag, timestamp - -> t m (k, b) -classifySessionsOf interval = classifySessionsBy 1 interval False - ------------------------------------------------------------------------------- --- Exceptions ------------------------------------------------------------------------------- - --- | Run a side effect before the stream yields its first element. --- --- @since 0.7.0 -{-# INLINE before #-} -before :: (IsStream t, Monad m) => m b -> t m a -> t m a -before action xs = D.fromStreamD $ D.before action $ D.toStreamD xs - --- | Run a side effect whenever the stream stops normally. --- --- @since 0.7.0 -{-# INLINE after #-} -after :: (IsStream t, Monad m) => m b -> t m a -> t m a -after action xs = D.fromStreamD $ D.after action $ D.toStreamD xs - --- | Run a side effect whenever the stream aborts due to an exception. --- --- @since 0.7.0 -{-# INLINE onException #-} -onException :: (IsStream t, MonadCatch m) => m b -> t m a -> t m a -onException action xs = D.fromStreamD $ D.onException action $ D.toStreamD xs - --- | Run a side effect whenever the stream stops normally or aborts due to an --- exception. --- --- @since 0.7.0 -{-# INLINE finally #-} -finally :: (IsStream t, MonadCatch m) => m b -> t m a -> t m a -finally action xs = D.fromStreamD $ D.finally action $ D.toStreamD xs - --- | Run the first action before the stream starts and remember its output, --- generate a stream using the output, run the second action using the --- remembered value as an argument whenever the stream ends normally or due to --- an exception. --- --- @since 0.7.0 -{-# INLINE bracket #-} -bracket :: (IsStream t, MonadCatch m) - => m b -> (b -> m c) -> (b -> t m a) -> t m a -bracket bef aft bet = D.fromStreamD $ - D.bracket bef aft (\x -> toStreamD $ bet x) +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE FlexibleContexts #-} + +#if __GLASGOW_HASKELL__ >= 800 +{-# OPTIONS_GHC -Wno-orphans #-} +#endif + +#include "inline.hs" + +-- | +-- Module : Streamly.Internal.Prelude +-- Copyright : (c) 2017 Harendra Kumar +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- + +module Streamly.Internal.Prelude + ( + -- * Construction + -- ** Primitives + K.nil + , K.nilM + , K.cons + , (K..:) + + , consM + , (|:) + + -- ** From Values + , yield + , yieldM + , repeat + , repeatM + , replicate + , replicateM + + -- ** Enumeration + , Enumerable (..) + , enumerate + , enumerateTo + + -- ** From Generators + , unfoldr + , unfoldrM + , unfold + , iterate + , iterateM + , fromIndices + , fromIndicesM + + -- ** From Containers + , P.fromList + , fromListM + , K.fromFoldable + , fromFoldableM + , fromPrimVar + + -- ** Time related + , currentTime + + -- * Elimination + + -- ** Deconstruction + , uncons + , tail + , init + + -- ** Folding + -- ** Right Folds + , foldrM + , foldrS + , foldrT + , foldr + + -- ** Left Folds + , foldl' + , foldl1' + , foldlM' + + -- ** Concurrent Folds + , foldAsync + , (|$.) + , (|&.) + + -- ** Full Folds + + -- -- ** To Summary (Full Folds) + , drain + , last + , length + , sum + , product + --, mconcat + + -- -- ** To Summary (Maybe) (Full Folds) + , maximumBy + , maximum + , minimumBy + , minimum + , the + + -- ** Partial Folds + + -- -- ** To Elements (Partial Folds) + , drainN + , drainWhile + + -- -- | Folds that extract selected elements of a stream or their properties. + , (!!) + , head + , headElse + , findM + , find + , lookup + , findIndex + , elemIndex + + -- -- ** To Boolean (Partial Folds) + , null + , elem + , notElem + , all + , any + , and + , or + + -- ** To Containers + , toList + , toListRev + , toPure + , toPureRev + + -- ** Composable Left Folds + , fold + + , toStream -- XXX rename to write? + , toStreamRev -- XXX rename to writeRev? + + -- * Transformation + , transform + + -- ** Mapping + , Serial.map + , sequence + , mapM + , mapM_ + + -- ** Scanning + -- ** Left scans + , scanl' + , scanlM' + , postscanl' + , postscanlM' + , prescanl' + , prescanlM' + , scanl1' + , scanl1M' + + -- ** Scan Using Fold + , scan + , postscan + + -- , lscanl' + -- , lscanlM' + -- , lscanl1' + -- , lscanl1M' + -- + -- , lpostscanl' + -- , lpostscanlM' + -- , lprescanl' + -- , lprescanlM' + + -- ** Concurrent Transformation + , D.mkParallel + -- Par.mkParallel + , applyAsync + , (|$) + , (|&) + + -- ** Indexing + , indexed + , indexedR + -- , timestamped + -- , timestampedR -- timer + + -- ** Filtering + + , filter + , filterM + + -- ** Stateful Filters + , take + , takeByTime + -- , takeEnd + , takeWhile + , takeWhileM + -- , takeWhileEnd + , drop + , dropByTime + -- , dropEnd + , dropWhile + , dropWhileM + -- , dropWhileEnd + -- , dropAround + , deleteBy + , uniq + -- , uniqBy -- by predicate e.g. to remove duplicate "/" in a path + -- , uniqOn -- to remove duplicate sequences + -- , pruneBy -- dropAround + uniqBy - like words + + -- ** Mapping Filters + , mapMaybe + , mapMaybeM + , rollingMapM + , rollingMap + + -- ** Scanning Filters + , findIndices + , elemIndices + -- , seqIndices -- search a sequence in the stream + + -- ** Insertion + , insertBy + , intersperseM + , intersperse + , intersperseSuffix + , intersperseSuffixBySpan + -- , intersperseBySpan + , interjectSuffix + , delayPost + + -- ** Reordering + , reverse + , reverse' + + -- * Multi-Stream Operations + + -- ** Appending + , append + + -- ** Interleaving + , interleave + , interleaveMin + , interleaveSuffix + , interleaveInfix + + , Serial.wSerialFst + , Serial.wSerialMin + + -- ** Scheduling + , roundrobin + + -- ** Parallel + , Par.parallelFst + , Par.parallelMin + + -- ** Merging + + -- , merge + , mergeBy + , mergeByM + , mergeAsyncBy + , mergeAsyncByM + + -- ** Zipping + , Z.zipWith + , Z.zipWithM + , Z.zipAsyncWith + , Z.zipAsyncWithM + + -- ** Nested Streams + , concatMapM + , concatUnfold + , concatUnfoldInterleave + , concatUnfoldRoundrobin + , concatMap + , concatMapWith + , gintercalate + , gintercalateSuffix + , intercalate + , intercalateSuffix + , interpose + , interposeSuffix + , concatMapIterateWith + , concatMapTreeWith + , concatMapLoopWith + , concatMapTreeYieldLeavesWith + + -- -- ** Breaking + + -- By chunks + , splitAt -- spanN + -- , splitIn -- sessionN + + -- By elements + , span -- spanWhile + , break -- breakBefore + -- , breakAfter + -- , breakOn + -- , breakAround + , spanBy + , spanByRolling + + -- By sequences + -- , breakOnSeq + + -- ** Splitting + -- , groupScan + + -- -- *** Chunks + , chunksOf + , chunksOf2 + , arraysOf + , intervalsOf + + -- -- *** Using Element Separators + , splitOn + , splitOnSuffix + -- , splitOnPrefix + + -- , splitBy + , splitWithSuffix + -- , splitByPrefix + , wordsBy -- stripAndCompactBy + + -- -- *** Using Sequence Separators + , splitOnSeq + , splitOnSuffixSeq + -- , splitOnPrefixSeq + + -- Keeping the delimiters + , splitBySeq + , splitWithSuffixSeq + -- , splitByPrefixSeq + -- , wordsBySeq + + -- Splitting using multiple sequence separators + -- , splitOnAnySeq + -- , splitOnAnySuffixSeq + -- , splitOnAnyPrefixSeq + + -- Nested splitting + , splitInnerBy + , splitInnerBySuffix + + -- ** Grouping + , groups + , groupsBy + , groupsByRolling + + -- ** Distributing + , trace + , tap + , tapOffsetEvery + , tapAsync + , tapRate + , pollCounts + + -- * Windowed Classification + + -- ** Tumbling Windows + -- , classifyChunksOf + , classifySessionsBy + , classifySessionsOf + + -- ** Keep Alive Windows + -- , classifyKeepAliveChunks + , classifyKeepAliveSessions + + {- + -- ** Sliding Windows + , classifySlidingChunks + , classifySlidingSessions + -} + -- ** Sliding Window Buffers + -- , slidingChunkBuffer + -- , slidingSessionBuffer + + -- ** Containers of Streams + , foldWith + , foldMapWith + , forEachWith + + -- ** Folding + , eqBy + , cmpBy + , isPrefixOf + -- , isSuffixOf + -- , isInfixOf + , isSubsequenceOf + , stripPrefix + -- , stripSuffix + -- , stripInfix + + -- * Exceptions + , before + , after + , afterIO + , bracket + , bracketIO + , onException + , finally + , finallyIO + , handle + + -- * Generalize Inner Monad + , hoist + , generally + + -- * Transform Inner Monad + , liftInner + , runReaderT + , evalStateT + , usingStateT + , runStateT + + -- * MonadFix + , K.mfix + + -- * Diagnostics + , inspectMode + + -- * Deprecated + , K.once + , each + , scanx + , foldx + , foldxM + , foldr1 + , runStream + , runN + , runWhile + , fromHandle + , toHandle + ) +where + +import Control.Concurrent (threadDelay) +import Control.Exception (Exception, assert) +import Control.Monad (void) +import Control.Monad.Catch (MonadCatch) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Reader (ReaderT) +import Control.Monad.State.Strict (StateT) +import Control.Monad.Trans (MonadTrans(..)) +import Control.Monad.Trans.Control (MonadBaseControl) +import Data.Functor.Identity (Identity (..)) +#if __GLASGOW_HASKELL__ >= 800 +import Data.Kind (Type) +#endif +import Data.Heap (Entry(..)) +import Data.Maybe (isJust, fromJust, isNothing) +import Foreign.Storable (Storable) +import Prelude + hiding (filter, drop, dropWhile, take, takeWhile, zipWith, foldr, + foldl, map, 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, span, splitAt, break, + repeat) + +import qualified Data.Heap as H +import qualified Data.Map.Strict as Map +import qualified Prelude +import qualified System.IO as IO + +import Streamly.Internal.Data.Stream.Enumeration (Enumerable(..), enumerate, enumerateTo) +import Streamly.Internal.Data.Fold.Types (Fold (..), Fold2 (..)) +import Streamly.Internal.Data.Unfold.Types (Unfold) +import Streamly.Internal.Memory.Array.Types (Array, writeNUnsafe) +-- import Streamly.Memory.Ring (Ring) +import Streamly.Internal.Data.SVar (MonadAsync, defState) +import Streamly.Internal.Data.Stream.Combinators (inspectMode, maxYields) +import Streamly.Internal.Data.Stream.Prelude + (fromStreamS, toStreamS, foldWith, foldMapWith, forEachWith) +import Streamly.Internal.Data.Stream.StreamD (fromStreamD, toStreamD) +import Streamly.Internal.Data.Stream.StreamK (IsStream((|:), consM)) +import Streamly.Internal.Data.Stream.Serial (SerialT, WSerialT) +import Streamly.Internal.Data.Stream.Zip (ZipSerialM) +import Streamly.Internal.Data.Pipe.Types (Pipe (..)) +import Streamly.Internal.Data.Time.Units + (AbsTime, MilliSecond64(..), addToAbsTime, toRelTime, + toAbsTime, TimeUnit64) +import Streamly.Internal.Mutable.Prim.Var (Prim, Var) + +import Streamly.Internal.Data.Strict + +import qualified Streamly.Internal.Memory.Array as A +import qualified Streamly.Data.Fold as FL +import qualified Streamly.Internal.Data.Fold.Types as FL +import qualified Streamly.Internal.Data.Stream.Prelude as P +import qualified Streamly.Internal.Data.Stream.StreamK as K +import qualified Streamly.Internal.Data.Stream.StreamD as D + +#ifdef USE_STREAMK_ONLY +import qualified Streamly.Internal.Data.Stream.StreamK as S +#else +import qualified Streamly.Internal.Data.Stream.StreamD as S +#endif + +-- import qualified Streamly.Internal.Data.Stream.Async as Async +import qualified Streamly.Internal.Data.Stream.Serial as Serial +import qualified Streamly.Internal.Data.Stream.Parallel as Par +import qualified Streamly.Internal.Data.Stream.Zip as Z + +------------------------------------------------------------------------------ +-- 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. +-- +-- This is a brute force primitive. Avoid using it as long as possible, use it +-- when no other combinator can do the job. This can be used to do pretty much +-- anything in an imperative manner, as it just breaks down the stream into +-- individual elements and we can loop over them as we deem fit. For example, +-- this can be used to convert a streamly stream into other stream types. +-- +-- @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 drain $ 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 = Serial.unfoldrM + +{-# RULES "unfoldrM wSerial" unfoldrM = unfoldrMWSerial #-} +{-# INLINE_EARLY unfoldrMWSerial #-} +unfoldrMWSerial :: MonadAsync m => (b -> m (Maybe (a, b))) -> b -> WSerialT m a +unfoldrMWSerial = Serial.unfoldrM + +{-# RULES "unfoldrM zipSerial" unfoldrM = unfoldrMZipSerial #-} +{-# INLINE_EARLY unfoldrMZipSerial #-} +unfoldrMZipSerial :: MonadAsync m => (b -> m (Maybe (a, b))) -> b -> ZipSerialM m a +unfoldrMZipSerial = Serial.unfoldrM + +-- | Convert an 'Unfold' into a stream by supplying it an input seed. +-- +-- >>> unfold (UF.replicateM 10) (putStrLn "hello") +-- +-- /Since: 0.7.0/ +{-# INLINE unfold #-} +unfold :: (IsStream t, Monad m) => Unfold m a b -> a -> t m b +unfold unf x = fromStreamD $ D.unfold unf x + +------------------------------------------------------------------------------ +-- 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 = fromStreamS . S.fromIndices + +-- +-- | +-- @ +-- 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. +-- +-- /Concurrent/ +-- +-- @since 0.6.0 +{-# INLINE_EARLY fromIndicesM #-} +fromIndicesM :: (IsStream t, MonadAsync m) => (Int -> m a) -> t m a +fromIndicesM = K.fromIndicesM + +{-# RULES "fromIndicesM serial" fromIndicesM = fromIndicesMSerial #-} +{-# INLINE fromIndicesMSerial #-} +fromIndicesMSerial :: MonadAsync m => (Int -> m a) -> SerialT m a +fromIndicesMSerial = fromStreamS . S.fromIndicesM + +-- | +-- @ +-- replicateM = take n . repeatM +-- @ +-- +-- Generate a stream by performing a monadic action @n@ times. Same as: +-- +-- @ +-- drain $ serially $ S.replicateM 10 $ (threadDelay 1000000 >> print 1) +-- drain $ 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 +{-# INLINE_NORMAL replicate #-} +replicate :: (IsStream t, Monad m) => Int -> a -> t m a +replicate n = fromStreamS . S.replicate n + +-- | +-- Generate an infinite stream by repeating a pure value. +-- +-- @since 0.4.0 +{-# INLINE_NORMAL repeat #-} +repeat :: (IsStream t, Monad m) => a -> t m a +repeat = fromStreamS . S.repeat + +-- | +-- @ +-- repeatM = fix . consM +-- repeatM = cycle1 . yieldM +-- @ +-- +-- Generate a stream by repeatedly executing a monadic action forever. +-- +-- @ +-- drain $ serially $ S.take 10 $ S.repeatM $ (threadDelay 1000000 >> print 1) +-- drain $ asyncly $ S.take 10 $ S.repeatM $ (threadDelay 1000000 >> print 1) +-- @ +-- +-- /Concurrent, infinite (do not use with 'parallely')/ +-- +-- @since 0.2.0 +{-# INLINE_EARLY repeatM #-} +repeatM :: (IsStream t, MonadAsync m) => m a -> t m a +repeatM = K.repeatM + +{-# RULES "repeatM serial" repeatM = repeatMSerial #-} +{-# INLINE repeatMSerial #-} +repeatMSerial :: MonadAsync m => m a -> SerialT m a +repeatMSerial = fromStreamS . S.repeatM + +-- | +-- @ +-- 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 +{-# INLINE_NORMAL iterate #-} +iterate :: (IsStream t, Monad m) => (a -> a) -> a -> t m a +iterate step = fromStreamS . S.iterate step + +-- | +-- @ +-- iterateM f m = m >>= \a -> return a \`consM` iterateM f (f a) +-- @ +-- +-- 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. +-- +-- @ +-- drain $ serially $ S.take 10 $ S.iterateM +-- (\\x -> threadDelay 1000000 >> print x >> return (x + 1)) (return 0) +-- +-- drain $ asyncly $ S.take 10 $ S.iterateM +-- (\\x -> threadDelay 1000000 >> print x >> return (x + 1)) (return 0) +-- @ +-- +-- /Concurrent/ +-- +-- /Since: 0.7.0 (signature change)/ +-- +-- /Since: 0.1.2/ +{-# INLINE_EARLY iterateM #-} +iterateM :: (IsStream t, MonadAsync m) => (a -> m a) -> m a -> t m a +iterateM = K.iterateM + +{-# RULES "iterateM serial" iterateM = iterateMSerial #-} +{-# INLINE iterateMSerial #-} +iterateMSerial :: MonadAsync m => (a -> m a) -> m a -> SerialT m a +iterateMSerial step = fromStreamS . S.iterateM step + +------------------------------------------------------------------------------ +-- 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. +-- +-- @ +-- drain $ serially $ S.fromFoldableM $ replicateM 10 (threadDelay 1000000 >> print 1) +-- drain $ 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 +{-# DEPRECATED fromHandle + "Please use Streamly.FileSystem.Handle module (see the changelog)" #-} +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 + +-- | Construct a stream by reading a 'Prim' 'Var' repeatedly. +-- +-- /Internal/ +-- +{-# INLINE fromPrimVar #-} +fromPrimVar :: (IsStream t, MonadIO m, Prim a) => Var IO a -> t m a +fromPrimVar = fromStreamD . D.fromPrimVar + +------------------------------------------------------------------------------ +-- Time related +------------------------------------------------------------------------------ + +-- XXX Some related/interesting combinators: +-- +-- 1) emit the relative time elapsed since last evaluation. That would just be +-- a rollingMap on the currentTime stream. +-- +-- 2) Generate ticks at specified interval. Drop ticks when blocked. +-- ticks :: Double -> t m () +-- +-- 3) Emit relative time at specified tick interval. If a tick is dropped +-- combine the interval with the next tick. +-- ticks :: Double -> t m RelTime +-- +-- | @currentTime g@ returns a stream of absolute timestamps using a clock of +-- granularity @g@ specified in seconds. A low granularity clock is more +-- expensive in terms of CPU usage. +-- +-- Note: This API is not safe on 32-bit machines. +-- +-- /Internal/ +-- +{-# INLINE currentTime #-} +currentTime :: (IsStream t, MonadAsync m) => Double -> t m AbsTime +currentTime g = fromStreamD $ D.currentTime g + +------------------------------------------------------------------------------ +-- Elimination by Folding +------------------------------------------------------------------------------ + +-- | Right associative/lazy pull fold. @foldrM build final stream@ constructs +-- an output structure using the step function @build@. @build@ is invoked with +-- the next input element and the remaining (lazy) tail of the output +-- structure. It builds a lazy output expression using the two. When the "tail +-- structure" in the output expression is evaluated it calls @build@ again thus +-- lazily consuming the input @stream@ until either the output expression built +-- by @build@ is free of the "tail" or the input is exhausted in which case +-- @final@ is used as the terminating case for the output structure. For more +-- details see the description in the previous section. +-- +-- Example, determine if any element is 'odd' in a stream: +-- +-- >>> S.foldrM (\x xs -> if odd x then return True else xs) (return False) $ S.fromList (2:4:5:undefined) +-- > True +-- +-- /Since: 0.7.0 (signature changed)/ +-- +-- /Since: 0.2.0 (signature changed)/ +-- +-- /Since: 0.1.0/ +{-# INLINE foldrM #-} +foldrM :: Monad m => (a -> m b -> m b) -> m b -> SerialT m a -> m b +foldrM = P.foldrM + +-- | Right fold to a streaming monad. +-- +-- > foldrS S.cons S.nil === id +-- +-- 'foldrS' can be used to perform stateless stream to stream transformations +-- like map and filter in general. It can be coupled with a scan to perform +-- stateful transformations. However, note that the custom map and filter +-- routines can be much more efficient than this due to better stream fusion. +-- +-- >>> S.toList $ S.foldrS S.cons S.nil $ S.fromList [1..5] +-- > [1,2,3,4,5] +-- +-- Find if any element in the stream is 'True': +-- +-- >>> S.toList $ S.foldrS (\x xs -> if odd x then return True else xs) (return False) $ (S.fromList (2:4:5:undefined) :: SerialT IO Int) +-- > [True] +-- +-- Map (+2) on odd elements and filter out the even elements: +-- +-- >>> S.toList $ S.foldrS (\x xs -> if odd x then (x + 2) `S.cons` xs else xs) S.nil $ (S.fromList [1..5] :: SerialT IO Int) +-- > [3,5,7] +-- +-- 'foldrM' can also be represented in terms of 'foldrS', however, the former +-- is much more efficient: +-- +-- > foldrM f z s = runIdentityT $ foldrS (\x xs -> lift $ f x (runIdentityT xs)) (lift z) s +-- +-- @since 0.7.0 +{-# INLINE foldrS #-} +foldrS :: IsStream t => (a -> t m b -> t m b) -> t m b -> t m a -> t m b +foldrS = K.foldrS + +-- | Right fold to a transformer monad. This is the most general right fold +-- function. 'foldrS' is a special case of 'foldrT', however 'foldrS' +-- implementation can be more efficient: +-- +-- > foldrS = foldrT +-- > foldrM f z s = runIdentityT $ foldrT (\x xs -> lift $ f x (runIdentityT xs)) (lift z) s +-- +-- 'foldrT' can be used to translate streamly streams to other transformer +-- monads e.g. to a different streaming type. +-- +-- @since 0.7.0 +{-# INLINE foldrT #-} +foldrT :: (IsStream t, Monad m, Monad (s m), MonadTrans s) + => (a -> s m b -> s m b) -> s m b -> t m a -> s m b +foldrT f z s = S.foldrT f z (toStreamS s) + +-- | Right fold, lazy for lazy monads and pure streams, and strict for strict +-- monads. +-- +-- Please avoid using this routine in strict monads like IO unless you need a +-- strict right fold. This is provided only for use in lazy monads (e.g. +-- Identity) or pure streams. Note that with this signature it is not possible +-- to implement a lazy foldr when the monad @m@ is strict. In that case it +-- would be strict in its accumulator and therefore would necessarily consume +-- all its input. +-- +-- @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 #-} +{-# DEPRECATED foldr1 "Use foldrM instead." #-} +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 +{-# DEPRECATED foldx "Please use foldl' followed by fmap instead." #-} +{-# INLINE foldx #-} +foldx :: Monad m => (x -> a -> x) -> x -> (x -> b) -> SerialT m a -> m b +foldx = P.foldlx' + +-- | Left associative/strict push fold. @foldl' reduce initial stream@ invokes +-- @reduce@ with the accumulator and the next input in the input stream, using +-- @initial@ as the initial value of the current value of the accumulator. When +-- the input is exhausted the current value of the accumulator is returned. +-- Make sure to use a strict data structure for accumulator to not build +-- unnecessary lazy expressions unless that's what you want. See the previous +-- section for more details. +-- +-- @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 +{-# DEPRECATED foldxM "Please use foldlM' followed by fmap instead." #-} +{-# INLINE foldxM #-} +foldxM :: Monad m => (x -> a -> m x) -> m x -> (x -> m b) -> SerialT m a -> m b +foldxM = P.foldlMx' + +-- | 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 + +------------------------------------------------------------------------------ +-- Running a Fold +------------------------------------------------------------------------------ + +-- | Fold a stream using the supplied left fold. +-- +-- >>> S.fold FL.sum (S.enumerateFromTo 1 100) +-- 5050 +-- +-- @since 0.7.0 +{-# INLINE fold #-} +fold :: Monad m => Fold m a b -> SerialT m a -> m b +fold = P.runFold + +------------------------------------------------------------------------------ +-- Running a sink +------------------------------------------------------------------------------ + +{- +-- | Drain a stream to a 'Sink'. +{-# INLINE runSink #-} +runSink :: Monad m => Sink m a -> SerialT m a -> m () +runSink = fold . toFold +-} + +------------------------------------------------------------------------------ +-- Specialized folds +------------------------------------------------------------------------------ + +-- | +-- > drain = mapM_ (\_ -> return ()) +-- +-- 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 @drain . 'asyncly'@. +-- +-- @since 0.7.0 +{-# INLINE drain #-} +drain :: Monad m => SerialT m a -> m () +drain = P.drain + +-- | 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 +{-# DEPRECATED runStream "Please use \"drain\" instead" #-} +{-# INLINE runStream #-} +runStream :: Monad m => SerialT m a -> m () +runStream = drain + +-- | +-- > drainN n = drain . take n +-- +-- Run maximum up to @n@ iterations of a stream. +-- +-- @since 0.7.0 +{-# INLINE drainN #-} +drainN :: Monad m => Int -> SerialT m a -> m () +drainN n = drain . take n + +-- | +-- > runN n = runStream . take n +-- +-- Run maximum up to @n@ iterations of a stream. +-- +-- @since 0.6.0 +{-# DEPRECATED runN "Please use \"drainN\" instead" #-} +{-# INLINE runN #-} +runN :: Monad m => Int -> SerialT m a -> m () +runN = drainN + +-- | +-- > drainWhile p = drain . takeWhile p +-- +-- Run a stream as long as the predicate holds true. +-- +-- @since 0.7.0 +{-# INLINE drainWhile #-} +drainWhile :: Monad m => (a -> Bool) -> SerialT m a -> m () +drainWhile p = drain . takeWhile p + +-- | +-- > runWhile p = runStream . takeWhile p +-- +-- Run a stream as long as the predicate holds true. +-- +-- @since 0.6.0 +{-# DEPRECATED runWhile "Please use \"drainWhile\" instead" #-} +{-# INLINE runWhile #-} +runWhile :: Monad m => (a -> Bool) -> SerialT m a -> m () +runWhile = drainWhile + +-- | Determine whether the stream is empty. +-- +-- @since 0.1.1 +{-# INLINE null #-} +null :: Monad m => SerialT m a -> m Bool +null = S.null . toStreamS + +-- | 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 = S.head . toStreamS + +-- | Extract the first element of the stream, if any, otherwise use the +-- supplied default value. It can help avoid one branch in high performance +-- code. +-- +-- /Internal/ +{-# INLINE headElse #-} +headElse :: Monad m => a -> SerialT m a -> m a +headElse x = D.headElse x . toStreamD + +-- | +-- > tail = fmap (fmap snd) . uncons +-- +-- 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 = P.maximum + +-- | 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) + +------------------------------------------------------------------------------ +-- Substreams +------------------------------------------------------------------------------ + +-- | Returns 'True' if the first stream is the same as or a prefix of the +-- second. A stream is a prefix of itself. +-- +-- @ +-- > 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 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 drain . mapM +-- | +-- > mapM_ = drain . mapM +-- +-- Apply a monadic action to each element of the stream and discard the output +-- of the action. This is not really a pure transformation operation but a +-- transformation followed by fold. +-- +-- @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. The list can be +-- consumed lazily in a lazy monad (e.g. 'Identity'). In a strict monad (e.g. +-- IO) the whole list is generated and buffered before it can be consumed. +-- +-- /Warning!/ working on large lists accumulated as buffers in memory could be +-- very inefficient, consider using "Streamly.Array" instead. +-- +-- @since 0.1.0 +{-# INLINE toList #-} +toList :: Monad m => SerialT m a -> m [a] +toList = P.toList + +-- | +-- @ +-- toListRev = S.foldl' (flip (:)) [] +-- @ +-- +-- Convert a stream into a list in reverse order in the underlying monad. +-- +-- /Warning!/ working on large lists accumulated as buffers in memory could be +-- very inefficient, consider using "Streamly.Array" instead. +-- +-- /Internal/ +{-# INLINE toListRev #-} +toListRev :: Monad m => SerialT m a -> m [a] +toListRev = D.toListRev . toStreamD + +-- | +-- @ +-- toHandle h = S.mapM_ $ hPutStrLn h +-- @ +-- +-- Write a stream of Strings to an IO Handle. +-- +-- @since 0.1.0 +{-# DEPRECATED toHandle + "Please use Streamly.FileSystem.Handle module (see the changelog)" #-} +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 + +-- XXX rename these to write/writeRev to make the naming consistent with folds +-- in other modules. +-- +-- | A fold that buffers its input to a pure stream. +-- +-- /Warning!/ working on large streams accumulated as buffers in memory could +-- be very inefficient, consider using "Streamly.Array" instead. +-- +-- /Internal/ +{-# INLINE toStream #-} +toStream :: Monad m => Fold m a (SerialT Identity a) +toStream = Fold (\f x -> return $ f . (x `K.cons`)) + (return id) + (return . ($ K.nil)) + +-- This is more efficient than 'toStream'. toStream is exactly the same as +-- reversing the stream after toStreamRev. +-- +-- | Buffers the input stream to a pure stream in the reverse order of the +-- input. +-- +-- /Warning!/ working on large streams accumulated as buffers in memory could +-- be very inefficient, consider using "Streamly.Array" instead. +-- +-- /Internal/ + +-- xn : ... : x2 : x1 : [] +{-# INLINABLE toStreamRev #-} +toStreamRev :: Monad m => Fold m a (SerialT Identity a) +toStreamRev = Fold (\xs x -> return $ x `K.cons` xs) (return K.nil) return + +-- | Convert a stream to a pure stream. +-- +-- @ +-- toPure = foldr cons nil +-- @ +-- +-- /Internal/ +-- +{-# INLINE toPure #-} +toPure :: Monad m => SerialT m a -> m (SerialT Identity a) +toPure = foldr K.cons K.nil + +-- | Convert a stream to a pure stream in reverse order. +-- +-- @ +-- toPureRev = foldl' (flip cons) nil +-- @ +-- +-- /Internal/ +-- +{-# INLINE toPureRev #-} +toPureRev :: Monad m => SerialT m a -> m (SerialT Identity a) +toPureRev = foldl' (flip K.cons) K.nil + +------------------------------------------------------------------------------ +-- Concurrent Application +------------------------------------------------------------------------------ + +infixr 0 |$ +infixr 0 |$. + +infixl 1 |& +infixl 1 |&. + +-- | Parallel transform application operator; applies a stream transformation +-- function @t m a -> t m b@ to a stream @t m a@ concurrently; the input stream +-- is evaluated asynchronously in an independent thread yielding elements to a +-- buffer and the transformation function runs in another thread consuming the +-- input from the buffer. '|$' is just like regular function application +-- operator '$' except that it is concurrent. +-- +-- If you read the signature as @(t m a -> t m b) -> (t m a -> t m b)@ you can +-- look at it as a transformation that converts a transform function to a +-- buffered concurrent transform function. +-- +-- The following code prints a value every second even though each stage adds a +-- 1 second delay. +-- +-- +-- @ +-- drain $ +-- S.mapM (\\x -> threadDelay 1000000 >> print x) +-- |$ S.repeatM (threadDelay 1000000 >> return 1) +-- @ +-- +-- /Concurrent/ +-- +-- @since 0.3.0 +{-# INLINE (|$) #-} +(|$) :: (IsStream t, MonadAsync m) => (t m a -> t m b) -> (t m a -> t m b) +-- (|$) f = f . Async.mkAsync +(|$) f = f . D.mkParallel + +-- | Same as '|$'. +-- +-- /Internal/ +-- +{-# INLINE applyAsync #-} +applyAsync :: (IsStream t, MonadAsync m) + => (t m a -> t m b) -> (t m a -> t m b) +applyAsync = (|$) + +-- | Parallel reverse function application operator for streams; just like the +-- regular reverse function application operator '&' except that it is +-- concurrent. +-- +-- @ +-- drain $ +-- S.repeatM (threadDelay 1000000 >> return 1) +-- |& S.mapM (\\x -> threadDelay 1000000 >> print x) +-- @ +-- +-- /Concurrent/ +-- +-- @since 0.3.0 +{-# INLINE (|&) #-} +(|&) :: (IsStream t, MonadAsync m) => t m a -> (t m a -> t m b) -> t m b +x |& f = f |$ x + +-- | Parallel fold application operator; applies a fold function @t m a -> m b@ +-- to a stream @t m a@ concurrently; The the input stream is evaluated +-- asynchronously in an independent thread yielding elements to a buffer and +-- the folding action runs in another thread consuming the input from the +-- buffer. +-- +-- If you read the signature as @(t m a -> m b) -> (t m a -> m b)@ you can look +-- at it as a transformation that converts a fold function to a buffered +-- concurrent fold function. +-- +-- The @.@ at the end of the operator is a mnemonic for termination of the +-- stream. +-- +-- @ +-- S.foldlM' (\\_ a -> threadDelay 1000000 >> print a) () +-- |$. S.repeatM (threadDelay 1000000 >> return 1) +-- @ +-- +-- /Concurrent/ +-- +-- @since 0.3.0 +{-# INLINE (|$.) #-} +(|$.) :: (IsStream t, MonadAsync m) => (t m a -> m b) -> (t m a -> m b) +-- (|$.) f = f . Async.mkAsync +(|$.) f = f . D.mkParallel + +-- | Same as '|$.'. +-- +-- /Internal/ +-- +{-# INLINE foldAsync #-} +foldAsync :: (IsStream t, MonadAsync m) => (t m a -> m b) -> (t m a -> m b) +foldAsync = (|$.) + +-- | Parallel reverse function application operator for applying a run or fold +-- functions to a stream. Just like '|$.' except that the operands are reversed. +-- +-- @ +-- S.repeatM (threadDelay 1000000 >> return 1) +-- |&. S.foldlM' (\\_ a -> threadDelay 1000000 >> print a) () +-- @ +-- +-- /Concurrent/ +-- +-- @since 0.3.0 +{-# INLINE (|&.) #-} +(|&.) :: (IsStream t, MonadAsync m) => t m a -> (t m a -> m b) -> m b +x |&. f = f |$. x + +------------------------------------------------------------------------------ +-- General Transformation +------------------------------------------------------------------------------ + +-- | Use a 'Pipe' to transform a stream. +{-# INLINE transform #-} +transform :: (IsStream t, Monad m) => Pipe m a b -> t m a -> t m b +transform pipe xs = fromStreamD $ D.transform pipe (toStreamD xs) + +------------------------------------------------------------------------------ +-- Transformation by Folding (Scans) +------------------------------------------------------------------------------ + +-- XXX It may be useful to have a version of scan where we can keep the +-- accumulator independent of the value emitted. So that we do not necessarily +-- have to keep a value in the accumulator which we are not using. We can pass +-- an extraction function that will take the accumulator and the current value +-- of the element and emit the next value in the stream. That will also make it +-- possible to modify the accumulator after using it. In fact, the step function +-- can return new accumulator and the value to be emitted. The signature would +-- be more like mapAccumL. Or we can change the signature of scanx to +-- accommodate this. +-- +-- | 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.7.0 (Monad m constraint)/ +-- +-- /Since 0.2.0/ +{-# DEPRECATED scanx "Please use scanl followed by map instead." #-} +{-# INLINE scanx #-} +scanx :: (IsStream t, Monad m) => (x -> a -> x) -> x -> (x -> b) -> t m a -> t m b +scanx = P.scanlx' + +-- XXX this needs to be concurrent +-- | Like 'scanl'' but with a monadic fold function. +-- +-- @since 0.4.0 +{-# INLINE scanlM' #-} +scanlM' :: (IsStream t, Monad m) => (b -> a -> m b) -> b -> t m a -> t m b +scanlM' step begin m = fromStreamD $ D.scanlM' step begin $ toStreamD m + +-- | Strict left scan. Like 'map', 'scanl'' too is a one to one transformation, +-- however it adds an extra element. +-- +-- @ +-- > 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 monolithic 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 make it modular by computing the sum in the first +-- stage and passing 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 + +-- | Like 'scanl'' but does not stream the initial value of the accumulator. +-- +-- > postscanl' f z xs = S.drop 1 $ S.scanl' f z xs +-- +-- @since 0.7.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.7.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 + +------------------------------------------------------------------------------ +-- Scanning with a Fold +------------------------------------------------------------------------------ + +-- | Scan a stream using the given monadic fold. +-- +-- @since 0.7.0 +{-# INLINE scan #-} +scan :: (IsStream t, Monad m) => Fold m a b -> t m a -> t m b +scan (Fold step begin done) = P.scanlMx' step begin done + +-- | Postscan a stream using the given monadic fold. +-- +-- @since 0.7.0 +{-# INLINE postscan #-} +postscan :: (IsStream t, Monad m) => Fold m a b -> t m a -> t m b +postscan (Fold step begin done) = P.postscanlMx' step begin done + +------------------------------------------------------------------------------ +-- Stateful Transformations +------------------------------------------------------------------------------ + +-- | Apply a function on every two successive elements of a stream. If the +-- stream consists of a single element the output is an empty stream. +-- +-- /Internal/ +-- +{-# INLINE rollingMap #-} +rollingMap :: (IsStream t, Monad m) => (a -> a -> b) -> t m a -> t m b +rollingMap f m = fromStreamD $ D.rollingMap f $ toStreamD m + +-- | Like 'rollingMap' but with an effectful map function. +-- +-- /Internal/ +-- +{-# INLINE rollingMapM #-} +rollingMapM :: (IsStream t, Monad m) => (a -> a -> m b) -> t m a -> t m b +rollingMapM f m = fromStreamD $ D.rollingMapM f $ 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 + +-- | @takeByTime duration@ yields stream elements upto specified time +-- @duration@. The duration starts when the stream is evaluated for the first +-- time, before the first element is yielded. The time duration is checked +-- before generating each element, if the duration has expired the stream +-- stops. +-- +-- The total time taken in executing the stream is guaranteed to be /at least/ +-- @duration@, however, because the duration is checked before generating an +-- element, the upper bound is indeterminate and depends on the time taken in +-- generating and processing the last element. +-- +-- No element is yielded if the duration is zero. At least one element is +-- yielded if the duration is non-zero. +-- +-- /Internal/ +-- +{-# INLINE takeByTime #-} +takeByTime ::(MonadIO m, IsStream t, TimeUnit64 d) => d -> t m a -> t m a +takeByTime d = fromStreamD . D.takeByTime d . toStreamD + +-- | 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 + +-- | @dropByTime duration@ drops stream elements until specified @duration@ has +-- passed. The duration begins when the stream is evaluated for the first +-- time. The time duration is checked /after/ generating a stream element, the +-- element is yielded if the duration has expired otherwise it is dropped. +-- +-- The time elapsed before starting to generate the first element is /at most/ +-- @duration@, however, because the duration expiry is checked after the +-- element is generated, the lower bound is indeterminate and depends on the +-- time taken in generating an element. +-- +-- All elements are yielded if the duration is zero. +-- +-- /Internal/ +-- +{-# INLINE dropByTime #-} +dropByTime ::(MonadIO m, IsStream t, TimeUnit64 d) => d -> t m a -> t m a +dropByTime d = fromStreamD . D.dropByTime d . toStreamD + +------------------------------------------------------------------------------ +-- 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. +-- +-- @ +-- > drain $ S.mapM putStr $ S.fromList ["a", "b", "c"] +-- abc +-- +-- drain $ S.replicateM 10 (return 1) +-- & (serially . S.mapM (\\x -> threadDelay 1000000 >> print x)) +-- +-- drain $ 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. +-- +-- @ +-- > drain $ S.sequence $ S.fromList [putStr "a", putStr "b", putStrLn "c"] +-- abc +-- +-- drain $ S.replicateM 10 (return $ threadDelay 1000000 >> print 1) +-- & (serially . S.sequence) +-- +-- drain $ 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'. +-- +-- Equivalent to: +-- +-- @ +-- mapMaybe f = S.map 'fromJust' . S.filter 'isJust' . S.map f +-- @ +-- +-- @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. +-- +-- Equivalent to: +-- +-- @ +-- mapMaybeM f = S.map 'fromJust' . S.filter 'isJust' . S.mapM f +-- @ +-- +-- /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 Use a compact region list to temporarily store the list, in both reverse +-- as well as in reverse'. +-- +-- /Note:/ 'reverse'' is much faster than this, use that when performance +-- matters. +-- +-- > reverse = S.foldlT (flip S.cons) S.nil +-- +-- | Returns the elements of the stream in reverse order. The stream must be +-- finite. Note that this necessarily buffers the entire stream in memory. +-- +-- /Since 0.7.0 (Monad m constraint)/ +-- +-- /Since: 0.1.1/ +{-# INLINE reverse #-} +reverse :: (IsStream t, Monad m) => t m a -> t m a +reverse s = fromStreamS $ S.reverse $ toStreamS s + +-- | Like 'reverse' but several times faster, requires a 'Storable' instance. +-- +-- @since 0.7.0 +{-# INLINE reverse' #-} +reverse' :: (IsStream t, MonadIO m, Storable a) => t m a -> t m a +reverse' s = fromStreamD $ D.reverse' $ toStreamD s + +------------------------------------------------------------------------------ +-- Transformation by Inserting +------------------------------------------------------------------------------ + +-- intersperseM = intersperseBySpan 1 + +-- | Generate a stream by inserting the result of a monadic action between +-- consecutive elements of the given stream. Note that the monadic action is +-- performed after the stream action before which its result is inserted. +-- +-- @ +-- > S.toList $ S.intersperseM (return ',') $ S.fromList "hello" +-- "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 m = fromStreamS . S.intersperseM m . toStreamS + +-- | Generate a stream by inserting a given element between consecutive +-- elements of the given stream. +-- +-- @ +-- > S.toList $ S.intersperse ',' $ S.fromList "hello" +-- "h,e,l,l,o" +-- @ +-- +-- @since 0.7.0 +{-# INLINE intersperse #-} +intersperse :: (IsStream t, MonadAsync m) => a -> t m a -> t m a +intersperse a = fromStreamS . S.intersperse a . toStreamS + +-- | Insert a monadic action after each element in the stream. +-- +-- @since 0.7.0 +{-# INLINE intersperseSuffix #-} +intersperseSuffix :: (IsStream t, MonadAsync m) => m a -> t m a -> t m a +intersperseSuffix m = fromStreamD . D.intersperseSuffix m . toStreamD + +-- | Perform a side effect after each element of a stream. The output of the +-- effectful action is discarded, therefore, the input stream remains +-- unchanged. +-- +-- @ +-- > S.mapM_ putChar $ S.intersperseSuffix_ (threadDelay 1000000) $ S.fromList "hello" +-- @ +-- +-- /Internal/ +-- +{-# INLINE intersperseSuffix_ #-} +intersperseSuffix_ :: (IsStream t, Monad m) => m b -> t m a -> t m a +intersperseSuffix_ m = Serial.mapM (\x -> void m >> return x) + +-- | Introduces a delay of specified seconds after each element of a stream. +-- +-- /Internal/ +-- +{-# INLINE delayPost #-} +delayPost :: (IsStream t, MonadIO m) => Double -> t m a -> t m a +delayPost n = intersperseSuffix_ $ liftIO $ threadDelay $ round $ n * 1000000 + +-- | Like 'intersperseSuffix' but intersperses a monadic action into the input +-- stream after every @n@ elements and after the last element. +-- +-- @ +-- > S.toList $ S.intersperseSuffixBySpan 2 (return ',') $ S.fromList "hello" +-- "he,ll,o," +-- @ +-- +-- /Internal/ +-- +{-# INLINE intersperseSuffixBySpan #-} +intersperseSuffixBySpan :: (IsStream t, MonadAsync m) + => Int -> m a -> t m a -> t m a +intersperseSuffixBySpan n eff = + fromStreamD . D.intersperseSuffixBySpan n eff . toStreamD + +{- +-- | Intersperse a monadic action into the input stream after every @n@ +-- elements. +-- +-- @ +-- > S.toList $ S.intersperseBySpan 2 (return ',') $ S.fromList "hello" +-- "he,ll,o" +-- @ +-- +-- @since 0.7.0 +{-# INLINE intersperseBySpan #-} +intersperseBySpan :: IsStream t => Int -> m a -> t m a -> t m a +intersperseBySpan _n _f _xs = undefined +-} + +-- | Intersperse a monadic action into the input stream after every @n@ +-- seconds. +-- +-- @ +-- > S.drain $ S.interjectSuffix 1 (putChar ',') $ S.mapM (\\x -> threadDelay 1000000 >> putChar x) $ S.fromList "hello" +-- "h,e,l,l,o" +-- @ +-- +-- @since 0.7.0 +{-# INLINE interjectSuffix #-} +interjectSuffix + :: (IsStream t, MonadAsync m) + => Double -> m a -> t m a -> t m a +interjectSuffix n f xs = xs `Par.parallelFst` repeatM timed + where timed = liftIO (threadDelay (round $ n * 1000000)) >> f + +-- | @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 occurrence 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.postscanl' (\(i, _) x -> (i + 1, x)) (-1,undefined) +-- > indexed = S.zipWith (,) (S.enumerateFrom 0) +-- +-- Pair each element in a stream with its index, starting from index 0. +-- +-- @ +-- > 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.postscanl' (\(i, _) x -> (i - 1, x)) (n + 1,undefined) +-- > indexedR n = S.zipWith (,) (S.enumerateFromThen 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" +-- [(10,'h'),(9,'e'),(8,'l'),(7,'l'),(6,'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 + +------------------------------------------------------------------------------ +-- 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) + +{- +-- | Like 'mergeByM' but stops merging as soon as any of the two streams stops. +{-# INLINABLE mergeEndByAny #-} +mergeEndByAny + :: (IsStream t, Monad m) + => (a -> a -> m Ordering) -> t m a -> t m a -> t m a +mergeEndByAny f m1 m2 = fromStreamD $ + D.mergeEndByAny f (toStreamD m1) (toStreamD m2) + +-- Like 'mergeByM' but stops merging as soon as the first stream stops. +{-# INLINABLE mergeEndByFirst #-} +mergeEndByFirst + :: (IsStream t, Monad m) + => (a -> a -> m Ordering) -> t m a -> t m a -> t m a +mergeEndByFirst f m1 m2 = fromStreamS $ + D.mergeEndByFirst f (toStreamD m1) (toStreamD 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 +{-# INLINE mergeAsyncBy #-} +mergeAsyncBy :: (IsStream t, MonadAsync m) + => (a -> a -> Ordering) -> t m a -> t m a -> t m a +mergeAsyncBy f = mergeAsyncByM (\a b -> return $ f a b) + +-- | Like 'mergeByM' but merges concurrently (i.e. both the elements being +-- merged are generated concurrently). +-- +-- @since 0.6.0 +{-# INLINE mergeAsyncByM #-} +mergeAsyncByM :: (IsStream t, MonadAsync m) + => (a -> a -> m Ordering) -> t m a -> t m a -> t m a +mergeAsyncByM f m1 m2 = fromStreamD $ + D.mergeByM f (D.mkParallelD $ toStreamD m1) (D.mkParallelD $ toStreamD m2) + +------------------------------------------------------------------------------ +-- Nesting +------------------------------------------------------------------------------ + +-- | @concatMapWith merge map stream@ is a two dimensional looping combinator. +-- The first argument specifies a merge or concat function that is used to +-- merge the streams generated by applying the second argument i.e. the @map@ +-- function to each element of the input stream. The concat function could be +-- 'serial', 'parallel', 'async', 'ahead' or any other zip or merge function +-- and the second argument could be any stream generation function using a +-- seed. +-- +-- /Compare 'foldMapWith'/ +-- +-- @since 0.7.0 +{-# INLINE concatMapWith #-} +concatMapWith + :: IsStream t + => (forall c. t m c -> t m c -> t m c) + -> (a -> t m b) + -> t m a + -> t m b +concatMapWith = K.concatMapBy + +-- | Map a stream producing function on each element of the stream and then +-- flatten the results into a single stream. +-- +-- @ +-- concatMap = 'concatMapWith' 'Serial.serial' +-- 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) + +-- | Append the outputs of two streams, yielding all the elements from the +-- first stream and then yielding all the elements from the second stream. +-- +-- IMPORTANT NOTE: This could be 100x faster than @serial/<>@ for appending a +-- few (say 100) streams because it can fuse via stream fusion. However, it +-- does not scale for a large number of streams (say 1000s) and becomes +-- qudartically slow. Therefore use this for custom appending of a few streams +-- but use 'concatMap' or 'concatMapWith serial' for appending @n@ streams or +-- infinite containers of streams. +-- +-- @since 0.7.0 +{-# INLINE append #-} +append ::(IsStream t, Monad m) => t m b -> t m b -> t m b +append m1 m2 = fromStreamD $ D.append (toStreamD m1) (toStreamD m2) + +-- XXX Same as 'wSerial'. We should perhaps rename wSerial to interleave. +-- XXX Document the interleaving behavior of side effects in all the +-- interleaving combinators. +-- XXX Write time-domain equivalents of these. In the time domain we can +-- interleave two streams such that the value of second stream is always taken +-- from its last value even if no new value is being yielded, like +-- zipWithLatest. It would be something like interleaveWithLatest. +-- +-- | Interleaves the outputs of two streams, yielding elements from each stream +-- alternately, starting from the first stream. If any of the streams finishes +-- early the other stream continues alone until it too finishes. +-- +-- >>> :set -XOverloadedStrings +-- >>> interleave "ab" ",,,," :: SerialT Identity Char +-- fromList "a,b,,," +-- >>> interleave "abcd" ",," :: SerialT Identity Char +-- fromList "a,b,cd" +-- +-- 'interleave' is dual to 'interleaveMin', it can be called @interleaveMax@. +-- +-- Do not use at scale in concatMapWith. +-- +-- @since 0.7.0 +{-# INLINE interleave #-} +interleave ::(IsStream t, Monad m) => t m b -> t m b -> t m b +interleave m1 m2 = fromStreamD $ D.interleave (toStreamD m1) (toStreamD m2) + +-- | Interleaves the outputs of two streams, yielding elements from each stream +-- alternately, starting from the first stream. As soon as the first stream +-- finishes, the output stops, discarding the remaining part of the second +-- stream. In this case, the last element in the resulting stream would be from +-- the second stream. If the second stream finishes early then the first stream +-- still continues to yield elements until it finishes. +-- +-- >>> :set -XOverloadedStrings +-- >>> interleaveSuffix "abc" ",,,," :: SerialT Identity Char +-- fromList "a,b,c," +-- >>> interleaveSuffix "abc" "," :: SerialT Identity Char +-- fromList "a,bc" +-- +-- 'interleaveSuffix' is a dual of 'interleaveInfix'. +-- +-- Do not use at scale in concatMapWith. +-- +-- @since 0.7.0 +{-# INLINE interleaveSuffix #-} +interleaveSuffix ::(IsStream t, Monad m) => t m b -> t m b -> t m b +interleaveSuffix m1 m2 = + fromStreamD $ D.interleaveSuffix (toStreamD m1) (toStreamD m2) + +-- | Interleaves the outputs of two streams, yielding elements from each stream +-- alternately, starting from the first stream and ending at the first stream. +-- If the second stream is longer than the first, elements from the second +-- stream are infixed with elements from the first stream. If the first stream +-- is longer then it continues yielding elements even after the second stream +-- has finished. +-- +-- >>> :set -XOverloadedStrings +-- >>> interleaveInfix "abc" ",,,," :: SerialT Identity Char +-- fromList "a,b,c" +-- >>> interleaveInfix "abc" "," :: SerialT Identity Char +-- fromList "a,bc" +-- +-- 'interleaveInfix' is a dual of 'interleaveSuffix'. +-- +-- Do not use at scale in concatMapWith. +-- +-- @since 0.7.0 +{-# INLINE interleaveInfix #-} +interleaveInfix ::(IsStream t, Monad m) => t m b -> t m b -> t m b +interleaveInfix m1 m2 = + fromStreamD $ D.interleaveInfix (toStreamD m1) (toStreamD m2) + +-- | Interleaves the outputs of two streams, yielding elements from each stream +-- alternately, starting from the first stream. The output stops as soon as any +-- of the two streams finishes, discarding the remaining part of the other +-- stream. The last element of the resulting stream would be from the longer +-- stream. +-- +-- >>> :set -XOverloadedStrings +-- >>> interleaveMin "ab" ",,,," :: SerialT Identity Char +-- fromList "a,b," +-- >>> interleaveMin "abcd" ",," :: SerialT Identity Char +-- fromList "a,b,c" +-- +-- 'interleaveMin' is dual to 'interleave'. +-- +-- Do not use at scale in concatMapWith. +-- +-- @since 0.7.0 +{-# INLINE interleaveMin #-} +interleaveMin ::(IsStream t, Monad m) => t m b -> t m b -> t m b +interleaveMin m1 m2 = fromStreamD $ D.interleaveMin (toStreamD m1) (toStreamD m2) + +-- | Schedule the execution of two streams in a fair round-robin manner, +-- executing each stream once, alternately. Execution of a stream may not +-- necessarily result in an output, a stream may chose to @Skip@ producing an +-- element until later giving the other stream a chance to run. Therefore, this +-- combinator fairly interleaves the execution of two streams rather than +-- fairly interleaving the output of the two streams. This can be useful in +-- co-operative multitasking without using explicit threads. This can be used +-- as an alternative to `async`. +-- +-- Do not use at scale in concatMapWith. +-- +-- @since 0.7.0 +{-# INLINE roundrobin #-} +roundrobin ::(IsStream t, Monad m) => t m b -> t m b -> t m b +roundrobin m1 m2 = fromStreamD $ D.roundRobin (toStreamD m1) (toStreamD m2) + +-- | Map a stream producing monadic function on each element of the stream +-- and then flatten the results into a single stream. Since the stream +-- generation function is monadic, unlike 'concatMap', it can produce an +-- effect at the beginning of each iteration of the inner loop. +-- +-- @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) + +-- | Like 'concatMap' but uses an 'Unfold' for stream generation. Unlike +-- 'concatMap' this can fuse the 'Unfold' code with the inner loop and +-- therefore provide many times better performance. +-- +-- @since 0.7.0 +{-# INLINE concatUnfold #-} +concatUnfold ::(IsStream t, Monad m) => Unfold m a b -> t m a -> t m b +concatUnfold u m = fromStreamD $ D.concatMapU u (toStreamD m) + +-- | Like 'concatUnfold' but interleaves the streams in the same way as +-- 'interleave' behaves instead of appending them. +-- +-- @since 0.7.0 +{-# INLINE concatUnfoldInterleave #-} +concatUnfoldInterleave ::(IsStream t, Monad m) + => Unfold m a b -> t m a -> t m b +concatUnfoldInterleave u m = + fromStreamD $ D.concatUnfoldInterleave u (toStreamD m) + +-- | Like 'concatUnfold' but executes the streams in the same way as +-- 'roundrobin'. +-- +-- @since 0.7.0 +{-# INLINE concatUnfoldRoundrobin #-} +concatUnfoldRoundrobin ::(IsStream t, Monad m) + => Unfold m a b -> t m a -> t m b +concatUnfoldRoundrobin u m = + fromStreamD $ D.concatUnfoldRoundrobin u (toStreamD m) + +-- XXX we can swap the order of arguments to gintercalate so that the +-- definition of concatUnfold becomes simpler? The first stream should be +-- infixed inside the second one. However, if we change the order in +-- "interleave" as well similarly, then that will make it a bit unintuitive. +-- +-- > concatUnfold unf str = +-- > gintercalate unf str (UF.nilM (\_ -> return ())) (repeat ()) +-- +-- | 'interleaveInfix' followed by unfold and concat. +-- +-- /Internal/ +{-# INLINE gintercalate #-} +gintercalate + :: (IsStream t, Monad m) + => Unfold m a c -> t m a -> Unfold m b c -> t m b -> t m c +gintercalate unf1 str1 unf2 str2 = + D.fromStreamD $ D.gintercalate + unf1 (D.toStreamD str1) + unf2 (D.toStreamD str2) + +-- XXX The order of arguments in "intercalate" is consistent with the list +-- intercalate but inconsistent with gintercalate and other stream interleaving +-- combinators. We can change the order of the arguments in other combinators +-- but then 'interleave' combinator may become a bit unintuitive because we +-- will be starting with the second stream. + +-- > intercalate seed unf str = gintercalate unf str unf (repeatM seed) +-- > intercalate a unf str = concatUnfold unf $ intersperse a str +-- +-- | 'intersperse' followed by unfold and concat. +-- +-- > unwords = intercalate " " UF.fromList +-- +-- >>> intercalate " " UF.fromList ["abc", "def", "ghi"] +-- > "abc def ghi" +-- +{-# INLINE intercalate #-} +intercalate :: (IsStream t, Monad m) + => b -> Unfold m b c -> t m b -> t m c +intercalate seed unf str = D.fromStreamD $ + D.concatMapU unf $ D.intersperse seed (toStreamD str) + +-- > interpose x unf str = gintercalate unf str UF.identity (repeat x) +-- +-- | Unfold the elements of a stream, intersperse the given element between the +-- unfolded streams and then concat them into a single stream. +-- +-- > unwords = S.interpose ' ' +-- +-- /Internal/ +{-# INLINE interpose #-} +interpose :: (IsStream t, Monad m) + => c -> Unfold m b c -> t m b -> t m c +interpose x unf str = + D.fromStreamD $ D.interpose (return x) unf (D.toStreamD str) + +-- | 'interleaveSuffix' followed by unfold and concat. +-- +-- /Internal/ +{-# INLINE gintercalateSuffix #-} +gintercalateSuffix + :: (IsStream t, Monad m) + => Unfold m a c -> t m a -> Unfold m b c -> t m b -> t m c +gintercalateSuffix unf1 str1 unf2 str2 = + D.fromStreamD $ D.gintercalateSuffix + unf1 (D.toStreamD str1) + unf2 (D.toStreamD str2) + +-- > intercalateSuffix seed unf str = gintercalateSuffix unf str unf (repeatM seed) +-- > intercalateSuffix a unf str = concatUnfold unf $ intersperseSuffix a str +-- +-- | 'intersperseSuffix' followed by unfold and concat. +-- +-- > unlines = intercalateSuffix "\n" UF.fromList +-- +-- >>> intercalate "\n" UF.fromList ["abc", "def", "ghi"] +-- > "abc\ndef\nghi\n" +-- +{-# INLINE intercalateSuffix #-} +intercalateSuffix :: (IsStream t, Monad m) + => b -> Unfold m b c -> t m b -> t m c +intercalateSuffix seed unf str = fromStreamD $ D.concatMapU unf + $ D.intersperseSuffix (return seed) (D.toStreamD str) + +-- interposeSuffix x unf str = gintercalateSuffix unf str UF.identity (repeat x) +-- +-- | Unfold the elements of a stream, append the given element after each +-- unfolded stream and then concat them into a single stream. +-- +-- > unlines = S.interposeSuffix '\n' +-- +-- /Internal/ +{-# INLINE interposeSuffix #-} +interposeSuffix :: (IsStream t, Monad m) + => c -> Unfold m b c -> t m b -> t m c +interposeSuffix x unf str = + D.fromStreamD $ D.interposeSuffix (return x) unf (D.toStreamD str) + +------------------------------------------------------------------------------ +-- Flattening Trees +------------------------------------------------------------------------------ + +-- | Like 'iterateM' but using a stream generator function. +-- +-- /Internal/ +-- +{-# INLINE concatMapIterateWith #-} +concatMapIterateWith + :: IsStream t + => (forall c. t m c -> t m c -> t m c) + -> (a -> t m a) + -> t m a + -> t m a +concatMapIterateWith combine f xs = concatMapWith combine go xs + where + go x = yield x `combine` concatMapWith combine go (f x) + +-- concatMapIterateLeftsWith +-- +-- | Traverse a forest with recursive tree structures whose non-leaf nodes are +-- of type @a@ and leaf nodes are of type @b@, flattening all the trees into +-- streams and combining the streams into a single stream consisting of both +-- leaf and non-leaf nodes. +-- +-- 'concatMapTreeWith' is a generalization of 'concatMap', using a recursive +-- feedback loop to append the non-leaf nodes back to the input stream enabling +-- recursive traversal. 'concatMap' flattens a single level nesting whereas +-- 'concatMapTreeWith' flattens a recursively nested structure. +-- +-- Traversing a directory tree recursively is a canonical use case of +-- 'concatMapTreeWith'. +-- +-- @ +-- concatMapTreeWith combine f xs = concatMapIterateWith combine g xs +-- where +-- g (Left tree) = f tree +-- g (Right leaf) = nil +-- @ +-- +-- /Internal/ +-- +{-# INLINE concatMapTreeWith #-} +concatMapTreeWith + :: IsStream t + => (forall c. t m c -> t m c -> t m c) + -> (a -> t m (Either a b)) + -> t m (Either a b) -- Should be t m a? + -> t m (Either a b) +concatMapTreeWith combine f xs = concatMapWith combine go xs + where + go (Left tree) = yield (Left tree) `combine` concatMapWith combine go (f tree) + go (Right leaf) = yield $ Right leaf + +{- +-- | Like concatMapTreeWith but produces only stream of leaf elements. +-- On an either stream, iterate lefts but yield only rights. +-- +-- concatMapEitherYieldRightsWith combine f xs = +-- catRights $ concatMapTreeWith combine f xs +-- +{-# INLINE concatMapEitherYieldRightsWith #-} +concatMapEitherYieldRightsWith :: (IsStream t, MonadAsync m) + => _ -> (a -> t m (Either a b)) -> t m (Either a b) -> t m b +concatMapEitherYieldRightsWith combine f xs = undefined +-} + +{- +{-# INLINE concatUnfoldTree #-} +concatUnfoldTree :: (IsStream t, MonadAsync m) + => Unfold m a (Either a b) -> t m (Either a b) -> t m (Either a b) +concatUnfoldTree unf xs = undefined +-} + +------------------------------------------------------------------------------ +-- Feedback loop +------------------------------------------------------------------------------ + +-- We can perhaps even implement the SVar using this. The stream we are mapping +-- on is the work queue. When evaluated it results in either a leaf element to +-- yield or a tail stream to queue back to the work queue. +-- +-- | Flatten a stream with a feedback loop back into the input. +-- +-- For example, exceptions generated by the output stream can be fed back to +-- the input to take any corrective action. The corrective action may be to +-- retry the action or do nothing or log the errors. For the retry case we need +-- a feedback loop. +-- +-- /Internal/ +-- +{-# INLINE concatMapLoopWith #-} +concatMapLoopWith + :: (IsStream t, MonadAsync m) + => (forall x. t m x -> t m x -> t m x) + -> (a -> t m (Either b c)) + -> (b -> t m a) -- ^ feedback function to feed @b@ back into input + -> t m a + -> t m c +concatMapLoopWith combine f fb xs = + concatMapWith combine go $ concatMapWith combine f xs + where + go (Left b) = concatMapLoopWith combine f fb $ fb b + go (Right c) = yield c + +-- | Concat a stream of trees, generating only leaves. +-- +-- Compare with 'concatMapTreeWith'. While the latter returns all nodes in the +-- tree, this one returns only the leaves. +-- +-- Traversing a directory tree recursively and yielding on the files is a +-- canonical use case of 'concatMapTreeYieldLeavesWith'. +-- +-- @ +-- concatMapTreeYieldLeavesWith combine f = concatMapLoopWith combine f yield +-- @ +-- +-- /Internal/ +-- +{-# INLINE concatMapTreeYieldLeavesWith #-} +concatMapTreeYieldLeavesWith + :: (IsStream t, MonadAsync m) + => (forall x. t m x -> t m x -> t m x) + -> (a -> t m (Either a b)) + -> t m a + -> t m b +concatMapTreeYieldLeavesWith combine f = concatMapLoopWith combine f yield + +------------------------------------------------------------------------------ +-- Grouping/Splitting +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ +-- Grouping without looking at elements +------------------------------------------------------------------------------ +-- +------------------------------------------------------------------------------ +-- Binary APIs +------------------------------------------------------------------------------ +-- + +-- | @splitAt n f1 f2@ composes folds @f1@ and @f2@ such that first @n@ +-- elements of its input are consumed by fold @f1@ and the rest of the stream +-- is consumed by fold @f2@. +-- +-- > let splitAt_ n xs = S.fold (FL.splitAt n FL.toList FL.toList) $ S.fromList xs +-- +-- >>> splitAt_ 6 "Hello World!" +-- > ("Hello ","World!") +-- +-- >>> splitAt_ (-1) [1,2,3] +-- > ([],[1,2,3]) +-- +-- >>> splitAt_ 0 [1,2,3] +-- > ([],[1,2,3]) +-- +-- >>> splitAt_ 1 [1,2,3] +-- > ([1],[2,3]) +-- +-- >>> splitAt_ 3 [1,2,3] +-- > ([1,2,3],[]) +-- +-- >>> splitAt_ 4 [1,2,3] +-- > ([1,2,3],[]) +-- +-- @since 0.7.0 + +-- This can be considered as a two-fold version of 'ltake' where we take both +-- the segments instead of discarding the leftover. +-- +{-# INLINE splitAt #-} +splitAt + :: Monad m + => Int + -> Fold m a b + -> Fold m a c + -> Fold m a (b, c) +splitAt n (Fold stepL initialL extractL) (Fold stepR initialR extractR) = + Fold step initial extract + where + initial = Tuple3' <$> return n <*> initialL <*> initialR + + step (Tuple3' i xL xR) input = + if i > 0 + then stepL xL input >>= (\a -> return (Tuple3' (i - 1) a xR)) + else stepR xR input >>= (\b -> return (Tuple3' i xL b)) + + extract (Tuple3' _ a b) = (,) <$> extractL a <*> extractR b + +------------------------------------------------------------------------------ +-- N-ary APIs +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ +-- Generalized grouping +------------------------------------------------------------------------------ + +-- This combinator is the most general grouping combinator and can be used to +-- implement all other grouping combinators. +-- +-- XXX check if this can implement the splitOn combinator i.e. we can slide in +-- new elements, slide out old elements and incrementally compute the hash. +-- Also, can we implement the windowed classification combinators using this? +-- +-- In fact this is a parse. Instead of using a special return value in the fold +-- we are using a mapping function. +-- +-- Note that 'scanl'' (usually followed by a map to extract the desired value +-- from the accumulator) can be used to realize many implementations e.g. a +-- sliding window implementation. A scan followed by a mapMaybe is also a good +-- pattern to express many problems where we want to emit a filtered output and +-- not emit an output on every input. +-- +-- Passing on of the initial accumulator value to the next fold is equivalent +-- to returning the leftover concept. + +{- +-- | @groupScan splitter fold stream@ folds the input stream using @fold@. +-- @splitter@ is applied on the accumulator of the fold every time an item is +-- consumed by the fold. The fold continues until @splitter@ returns a 'Just' +-- value. A 'Just' result from the @splitter@ specifies a result to be emitted +-- in the output stream and the initial value of the accumulator for the next +-- group's fold. This allows us to control whether to start fresh for the next +-- fold or to continue from the previous fold's output. +-- +{-# INLINE groupScan #-} +groupScan + :: (IsStream t, Monad m) + => (x -> m (Maybe (b, x))) -> Fold m a x -> t m a -> t m b +groupScan split fold m = undefined +-} + +-- | Group the input stream into groups of @n@ elements each and then fold each +-- group using the provided fold function. +-- +-- >> S.toList $ S.chunksOf 2 FL.sum (S.enumerateFromTo 1 10) +-- > [3,7,11,15,19] +-- +-- This can be considered as an n-fold version of 'ltake' where we apply +-- 'ltake' repeatedly on the leftover stream until the stream exhausts. +-- +-- @since 0.7.0 +{-# INLINE chunksOf #-} +chunksOf + :: (IsStream t, Monad m) + => Int -> Fold m a b -> t m a -> t m b +chunksOf n f m = D.fromStreamD $ D.groupsOf n f (D.toStreamD m) + +{-# INLINE chunksOf2 #-} +chunksOf2 + :: (IsStream t, Monad m) + => Int -> m c -> Fold2 m c a b -> t m a -> t m b +chunksOf2 n action f m = D.fromStreamD $ D.groupsOf2 n action f (D.toStreamD m) + +-- | @arraysOf n stream@ groups the elements in the input stream into arrays of +-- @n@ elements each. +-- +-- Same as the following but may be more efficient: +-- +-- > arraysOf n = S.chunksOf n (A.writeN n) +-- +-- @since 0.7.0 +{-# INLINE arraysOf #-} +arraysOf :: (IsStream t, MonadIO m, Storable a) + => Int -> t m a -> t m (Array a) +arraysOf n = chunksOf n (writeNUnsafe n) + +-- XXX we can implement this by repeatedly applying the 'lrunFor' fold. +-- XXX add this example after fixing the serial stream rate control +-- >>> S.toList $ S.take 5 $ intervalsOf 1 FL.sum $ constRate 2 $ S.enumerateFrom 1 +-- > [3,7,11,15,19] +-- +-- | Group the input stream into windows of @n@ second each and then fold each +-- group using the provided fold function. +-- +-- @since 0.7.0 +{-# INLINE intervalsOf #-} +intervalsOf + :: (IsStream t, MonadAsync m) + => Double -> Fold m a b -> t m a -> t m b +intervalsOf n f xs = + splitWithSuffix isNothing (FL.lcatMaybes f) + (interjectSuffix n (return Nothing) (Serial.map Just xs)) + +------------------------------------------------------------------------------ +-- Element Aware APIs +------------------------------------------------------------------------------ +-- +------------------------------------------------------------------------------ +-- Binary APIs +------------------------------------------------------------------------------ + +-- | Break the input stream into two groups, the first group takes the input as +-- long as the predicate applied to the first element of the stream and next +-- input element holds 'True', the second group takes the rest of the input. +-- +spanBy + :: Monad m + => (a -> a -> Bool) + -> Fold m a b + -> Fold m a c + -> Fold m a (b, c) +spanBy cmp (Fold stepL initialL extractL) (Fold stepR initialR extractR) = + Fold step initial extract + + where + initial = Tuple3' <$> initialL <*> initialR <*> return (Tuple' Nothing True) + + step (Tuple3' a b (Tuple' (Just frst) isFirstG)) input = + if cmp frst input && isFirstG + then stepL a input + >>= (\a' -> return (Tuple3' a' b (Tuple' (Just frst) isFirstG))) + else stepR b input + >>= (\a' -> return (Tuple3' a a' (Tuple' Nothing False))) + + step (Tuple3' a b (Tuple' Nothing isFirstG)) input = + if isFirstG + then stepL a input + >>= (\a' -> return (Tuple3' a' b (Tuple' (Just input) isFirstG))) + else stepR b input + >>= (\a' -> return (Tuple3' a a' (Tuple' Nothing False))) + + extract (Tuple3' a b _) = (,) <$> extractL a <*> extractR b + +-- | @span p f1 f2@ composes folds @f1@ and @f2@ such that @f1@ consumes the +-- input as long as the predicate @p@ is 'True'. @f2@ consumes the rest of the +-- input. +-- +-- > let span_ p xs = S.fold (S.span p FL.toList FL.toList) $ S.fromList xs +-- +-- >>> span_ (< 1) [1,2,3] +-- > ([],[1,2,3]) +-- +-- >>> span_ (< 2) [1,2,3] +-- > ([1],[2,3]) +-- +-- >>> span_ (< 4) [1,2,3] +-- > ([1,2,3],[]) +-- +-- @since 0.7.0 + +-- This can be considered as a two-fold version of 'ltakeWhile' where we take +-- both the segments instead of discarding the leftover. +{-# INLINE span #-} +span + :: Monad m + => (a -> Bool) + -> Fold m a b + -> Fold m a c + -> Fold m a (b, c) +span p (Fold stepL initialL extractL) (Fold stepR initialR extractR) = + Fold step initial extract + + where + + initial = Tuple3' <$> initialL <*> initialR <*> return True + + step (Tuple3' a b isFirstG) input = + if isFirstG && p input + then stepL a input >>= (\a' -> return (Tuple3' a' b True)) + else stepR b input >>= (\a' -> return (Tuple3' a a' False)) + + extract (Tuple3' a b _) = (,) <$> extractL a <*> extractR b + +-- | +-- > break p = span (not . p) +-- +-- Break as soon as the predicate becomes 'True'. @break p f1 f2@ composes +-- folds @f1@ and @f2@ such that @f1@ stops consuming input as soon as the +-- predicate @p@ becomes 'True'. The rest of the input is consumed @f2@. +-- +-- This is the binary version of 'splitBy'. +-- +-- > let break_ p xs = S.fold (S.break p FL.toList FL.toList) $ S.fromList xs +-- +-- >>> break_ (< 1) [3,2,1] +-- > ([3,2,1],[]) +-- +-- >>> break_ (< 2) [3,2,1] +-- > ([3,2],[1]) +-- +-- >>> break_ (< 4) [3,2,1] +-- > ([],[3,2,1]) +-- +-- @since 0.7.0 +{-# INLINE break #-} +break + :: Monad m + => (a -> Bool) + -> Fold m a b + -> Fold m a c + -> Fold m a (b, c) +break p = span (not . p) + +-- | Like 'spanBy' but applies the predicate in a rolling fashion i.e. +-- predicate is applied to the previous and the next input elements. +{-# INLINE spanByRolling #-} +spanByRolling + :: Monad m + => (a -> a -> Bool) + -> Fold m a b + -> Fold m a c + -> Fold m a (b, c) +spanByRolling cmp (Fold stepL initialL extractL) (Fold stepR initialR extractR) = + Fold step initial extract + + where + initial = Tuple3' <$> initialL <*> initialR <*> return Nothing + + step (Tuple3' a b (Just frst)) input = + if cmp input frst + then stepL a input >>= (\a' -> return (Tuple3' a' b (Just input))) + else stepR b input >>= (\b' -> return (Tuple3' a b' (Just input))) + + step (Tuple3' a b Nothing) input = + stepL a input >>= (\a' -> return (Tuple3' a' b (Just input))) + + extract (Tuple3' a b _) = (,) <$> extractL a <*> extractR b + +------------------------------------------------------------------------------ +-- N-ary APIs +------------------------------------------------------------------------------ +-- +-- | @groupsBy cmp f $ S.fromList [a,b,c,...]@ assigns the element @a@ to the +-- first group, if @a \`cmp` b@ is 'True' then @b@ is also assigned to the same +-- group. If @a \`cmp` c@ is 'True' then @c@ is also assigned to the same +-- group and so on. When the comparison fails a new group is started. Each +-- group is folded using the fold @f@ and the result of the fold is emitted in +-- the output stream. +-- +-- >>> S.toList $ S.groupsBy (>) FL.toList $ S.fromList [1,3,7,0,2,5] +-- > [[1,3,7],[0,2,5]] +-- +-- @since 0.7.0 +{-# INLINE groupsBy #-} +groupsBy + :: (IsStream t, Monad m) + => (a -> a -> Bool) + -> Fold m a b + -> t m a + -> t m b +groupsBy cmp f m = D.fromStreamD $ D.groupsBy cmp f (D.toStreamD m) + +-- | Unlike @groupsBy@ this function performs a rolling comparison of two +-- successive elements in the input stream. @groupsByRolling cmp f $ S.fromList +-- [a,b,c,...]@ assigns the element @a@ to the first group, if @a \`cmp` b@ is +-- 'True' then @b@ is also assigned to the same group. If @b \`cmp` c@ is +-- 'True' then @c@ is also assigned to the same group and so on. When the +-- comparison fails a new group is started. Each group is folded using the fold +-- @f@. +-- +-- >>> S.toList $ S.groupsByRolling (\a b -> a + 1 == b) FL.toList $ S.fromList [1,2,3,7,8,9] +-- > [[1,2,3],[7,8,9]] +-- +-- @since 0.7.0 +{-# INLINE groupsByRolling #-} +groupsByRolling + :: (IsStream t, Monad m) + => (a -> a -> Bool) + -> Fold m a b + -> t m a + -> t m b +groupsByRolling cmp f m = D.fromStreamD $ D.groupsRollingBy cmp f (D.toStreamD m) + +-- | +-- > groups = groupsBy (==) +-- > groups = groupsByRolling (==) +-- +-- Groups contiguous spans of equal elements together in individual groups. +-- +-- >>> S.toList $ S.groups FL.toList $ S.fromList [1,1,2,2] +-- > [[1,1],[2,2]] +-- +-- @since 0.7.0 +groups :: (IsStream t, Monad m, Eq a) => Fold m a b -> t m a -> t m b +groups = groupsBy (==) + +------------------------------------------------------------------------------ +-- Binary splitting on a separator +------------------------------------------------------------------------------ + +{- +-- | Find the first occurrence of the specified sequence in the input stream +-- and break the input stream into two parts, the first part consisting of the +-- stream before the sequence and the second part consisting of the sequence +-- and the rest of the stream. +-- +-- > let breakOn_ pat xs = S.fold (S.breakOn pat FL.toList FL.toList) $ S.fromList xs +-- +-- >>> breakOn_ "dear" "Hello dear world!" +-- > ("Hello ","dear world!") +-- +{-# INLINE breakOn #-} +breakOn :: Monad m => Array a -> Fold m a b -> Fold m a c -> Fold m a (b,c) +breakOn pat f m = undefined +-} + +------------------------------------------------------------------------------ +-- N-ary split on a predicate +------------------------------------------------------------------------------ + +-- TODO: Use a Splitter configuration similar to the "split" package to make it +-- possible to express all splitting combinations. In general, we can have +-- infix/suffix/prefix/condensing of separators, dropping both leading/trailing +-- separators. We can have a single split operation taking the splitter config +-- as argument. + +-- | Split on an infixed separator element, dropping the separator. Splits the +-- stream on separator elements determined by the supplied predicate, separator +-- is considered as infixed between two segments, if one side of the separator +-- is missing then it is parsed as an empty stream. The supplied 'Fold' is +-- applied on the split segments. With '-' representing non-separator elements +-- and '.' as separator, 'splitOn' splits as follows: +-- +-- @ +-- "--.--" => "--" "--" +-- "--." => "--" "" +-- ".--" => "" "--" +-- @ +-- +-- @splitOn (== x)@ is an inverse of @intercalate (S.yield x)@ +-- +-- Let's use the following definition for illustration: +-- +-- > splitOn' p xs = S.toList $ S.splitOn p (FL.toList) (S.fromList xs) +-- +-- >>> splitOn' (== '.') "" +-- [""] +-- +-- >>> splitOn' (== '.') "." +-- ["",""] +-- +-- >>> splitOn' (== '.') ".a" +-- > ["","a"] +-- +-- >>> splitOn' (== '.') "a." +-- > ["a",""] +-- +-- >>> splitOn' (== '.') "a.b" +-- > ["a","b"] +-- +-- >>> splitOn' (== '.') "a..b" +-- > ["a","","b"] +-- +-- @since 0.7.0 + +-- This can be considered as an n-fold version of 'breakOn' where we apply +-- 'breakOn' successively on the input stream, dropping the first element +-- of the second segment after each break. +-- +{-# INLINE splitOn #-} +splitOn + :: (IsStream t, Monad m) + => (a -> Bool) -> Fold m a b -> t m a -> t m b +splitOn predicate f m = + D.fromStreamD $ D.splitBy predicate f (D.toStreamD m) + +-- | Like 'splitOn' but the separator is considered as suffixed to the segments +-- in the stream. A missing suffix at the end is allowed. A separator at the +-- beginning is parsed as empty segment. With '-' representing elements and +-- '.' as separator, 'splitOnSuffix' splits as follows: +-- +-- @ +-- "--.--." => "--" "--" +-- "--.--" => "--" "--" +-- ".--." => "" "--" +-- @ +-- +-- > splitOnSuffix' p xs = S.toList $ S.splitSuffixBy p (FL.toList) (S.fromList xs) +-- +-- >>> splitOnSuffix' (== '.') "" +-- [] +-- +-- >>> splitOnSuffix' (== '.') "." +-- [""] +-- +-- >>> splitOnSuffix' (== '.') "a" +-- ["a"] +-- +-- >>> splitOnSuffix' (== '.') ".a" +-- > ["","a"] +-- +-- >>> splitOnSuffix' (== '.') "a." +-- > ["a"] +-- +-- >>> splitOnSuffix' (== '.') "a.b" +-- > ["a","b"] +-- +-- >>> splitOnSuffix' (== '.') "a.b." +-- > ["a","b"] +-- +-- >>> splitOnSuffix' (== '.') "a..b.." +-- > ["a","","b",""] +-- +-- > lines = splitOnSuffix (== '\n') +-- +-- @since 0.7.0 + +-- This can be considered as an n-fold version of 'breakPost' where we apply +-- 'breakPost' successively on the input stream, dropping the first element +-- of the second segment after each break. +-- +{-# INLINE splitOnSuffix #-} +splitOnSuffix + :: (IsStream t, Monad m) + => (a -> Bool) -> Fold m a b -> t m a -> t m b +splitOnSuffix predicate f m = + D.fromStreamD $ D.splitSuffixBy predicate f (D.toStreamD m) + +-- | Like 'splitOn' after stripping leading, trailing, and repeated separators. +-- Therefore, @".a..b."@ with '.' as the separator would be parsed as +-- @["a","b"]@. In other words, its like parsing words from whitespace +-- separated text. +-- +-- > wordsBy' p xs = S.toList $ S.wordsBy p (FL.toList) (S.fromList xs) +-- +-- >>> wordsBy' (== ',') "" +-- > [] +-- +-- >>> wordsBy' (== ',') "," +-- > [] +-- +-- >>> wordsBy' (== ',') ",a,,b," +-- > ["a","b"] +-- +-- > words = wordsBy isSpace +-- +-- @since 0.7.0 + +-- It is equivalent to splitting in any of the infix/prefix/suffix styles +-- followed by removal of empty segments. +{-# INLINE wordsBy #-} +wordsBy + :: (IsStream t, Monad m) + => (a -> Bool) -> Fold m a b -> t m a -> t m b +wordsBy predicate f m = + D.fromStreamD $ D.wordsBy predicate f (D.toStreamD m) + +-- | Like 'splitOnSuffix' but keeps the suffix attached to the resulting +-- splits. +-- +-- > splitWithSuffix' p xs = S.toList $ S.splitWithSuffix p (FL.toList) (S.fromList xs) +-- +-- >>> splitWithSuffix' (== '.') "" +-- [] +-- +-- >>> splitWithSuffix' (== '.') "." +-- ["."] +-- +-- >>> splitWithSuffix' (== '.') "a" +-- ["a"] +-- +-- >>> splitWithSuffix' (== '.') ".a" +-- > [".","a"] +-- +-- >>> splitWithSuffix' (== '.') "a." +-- > ["a."] +-- +-- >>> splitWithSuffix' (== '.') "a.b" +-- > ["a.","b"] +-- +-- >>> splitWithSuffix' (== '.') "a.b." +-- > ["a.","b."] +-- +-- >>> splitWithSuffix' (== '.') "a..b.." +-- > ["a.",".","b.","."] +-- +-- @since 0.7.0 + +-- This can be considered as an n-fold version of 'breakPost' where we apply +-- 'breakPost' successively on the input stream. +-- +{-# INLINE splitWithSuffix #-} +splitWithSuffix + :: (IsStream t, Monad m) + => (a -> Bool) -> Fold m a b -> t m a -> t m b +splitWithSuffix predicate f m = + D.fromStreamD $ D.splitSuffixBy' predicate f (D.toStreamD m) + +------------------------------------------------------------------------------ +-- Split on a delimiter sequence +------------------------------------------------------------------------------ + +-- Int list examples for splitOn: +-- +-- >>> splitList [] [1,2,3,3,4] +-- > [[1],[2],[3],[3],[4]] +-- +-- >>> splitList [5] [1,2,3,3,4] +-- > [[1,2,3,3,4]] +-- +-- >>> splitList [1] [1,2,3,3,4] +-- > [[],[2,3,3,4]] +-- +-- >>> splitList [4] [1,2,3,3,4] +-- > [[1,2,3,3],[]] +-- +-- >>> splitList [2] [1,2,3,3,4] +-- > [[1],[3,3,4]] +-- +-- >>> splitList [3] [1,2,3,3,4] +-- > [[1,2],[],[4]] +-- +-- >>> splitList [3,3] [1,2,3,3,4] +-- > [[1,2],[4]] +-- +-- >>> splitList [1,2,3,3,4] [1,2,3,3,4] +-- > [[],[]] + +-- | Like 'splitOn' but the separator is a sequence of elements instead of a +-- single element. +-- +-- For illustration, let's define a function that operates on pure lists: +-- +-- @ +-- splitOnSeq' pat xs = S.toList $ S.splitOnSeq (A.fromList pat) (FL.toList) (S.fromList xs) +-- @ +-- +-- >>> splitOnSeq' "" "hello" +-- > ["h","e","l","l","o"] +-- +-- >>> splitOnSeq' "hello" "" +-- > [""] +-- +-- >>> splitOnSeq' "hello" "hello" +-- > ["",""] +-- +-- >>> splitOnSeq' "x" "hello" +-- > ["hello"] +-- +-- >>> splitOnSeq' "h" "hello" +-- > ["","ello"] +-- +-- >>> splitOnSeq' "o" "hello" +-- > ["hell",""] +-- +-- >>> splitOnSeq' "e" "hello" +-- > ["h","llo"] +-- +-- >>> splitOnSeq' "l" "hello" +-- > ["he","","o"] +-- +-- >>> splitOnSeq' "ll" "hello" +-- > ["he","o"] +-- +-- 'splitOnSeq' is an inverse of 'intercalate'. The following law always holds: +-- +-- > intercalate . splitOn == id +-- +-- The following law holds when the separator is non-empty and contains none of +-- the elements present in the input lists: +-- +-- > splitOn . intercalate == id +-- +-- @since 0.7.0 + +-- XXX We can use a polymorphic vector implemented by Array# to represent the +-- sequence, that way we can avoid the Storable constraint. If we still need +-- Storable Array for performance, we can use a separate splitOnArray API for +-- that. We can also have an API where the sequence itself is a lazy stream, so +-- that we can search files in files for example. +{-# INLINE splitOnSeq #-} +splitOnSeq + :: (IsStream t, MonadIO m, Storable a, Enum a, Eq a) + => Array a -> Fold m a b -> t m a -> t m b +splitOnSeq patt f m = D.fromStreamD $ D.splitOn patt f (D.toStreamD m) + +{- +-- This can be implemented easily using Rabin Karp +-- | Split on any one of the given patterns. +{-# INLINE splitOnAny #-} +splitOnAny + :: (IsStream t, Monad m, Storable a, Integral a) + => [Array a] -> Fold m a b -> t m a -> t m b +splitOnAny subseq f m = undefined -- D.fromStreamD $ D.splitOnAny f subseq (D.toStreamD m) +-} + +-- | Like 'splitSuffixBy' but the separator is a sequence of elements, instead +-- of a predicate for a single element. +-- +-- > splitSuffixOn_ pat xs = S.toList $ S.splitSuffixOn (A.fromList pat) (FL.toList) (S.fromList xs) +-- +-- >>> splitSuffixOn_ "." "" +-- [""] +-- +-- >>> splitSuffixOn_ "." "." +-- [""] +-- +-- >>> splitSuffixOn_ "." "a" +-- ["a"] +-- +-- >>> splitSuffixOn_ "." ".a" +-- > ["","a"] +-- +-- >>> splitSuffixOn_ "." "a." +-- > ["a"] +-- +-- >>> splitSuffixOn_ "." "a.b" +-- > ["a","b"] +-- +-- >>> splitSuffixOn_ "." "a.b." +-- > ["a","b"] +-- +-- >>> splitSuffixOn_ "." "a..b.." +-- > ["a","","b",""] +-- +-- > lines = splitSuffixOn "\n" +-- +-- @since 0.7.0 +{-# INLINE splitOnSuffixSeq #-} +splitOnSuffixSeq + :: (IsStream t, MonadIO m, Storable a, Enum a, Eq a) + => Array a -> Fold m a b -> t m a -> t m b +splitOnSuffixSeq patt f m = + D.fromStreamD $ D.splitSuffixOn False patt f (D.toStreamD m) + +{- +-- | Like 'splitOn' but drops any empty splits. +-- +{-# INLINE wordsOn #-} +wordsOn + :: (IsStream t, Monad m, Storable a, Eq a) + => Array a -> Fold m a b -> t m a -> t m b +wordsOn subseq f m = undefined -- D.fromStreamD $ D.wordsOn f subseq (D.toStreamD m) +-} + +-- XXX use a non-monadic intersperse to remove the MonadAsync constraint. +-- +-- | Like 'splitOnSeq' but splits the separator as well, as an infix token. +-- +-- > splitOn'_ pat xs = S.toList $ S.splitOn' (A.fromList pat) (FL.toList) (S.fromList xs) +-- +-- >>> splitOn'_ "" "hello" +-- > ["h","","e","","l","","l","","o"] +-- +-- >>> splitOn'_ "hello" "" +-- > [""] +-- +-- >>> splitOn'_ "hello" "hello" +-- > ["","hello",""] +-- +-- >>> splitOn'_ "x" "hello" +-- > ["hello"] +-- +-- >>> splitOn'_ "h" "hello" +-- > ["","h","ello"] +-- +-- >>> splitOn'_ "o" "hello" +-- > ["hell","o",""] +-- +-- >>> splitOn'_ "e" "hello" +-- > ["h","e","llo"] +-- +-- >>> splitOn'_ "l" "hello" +-- > ["he","l","","l","o"] +-- +-- >>> splitOn'_ "ll" "hello" +-- > ["he","ll","o"] +-- +-- @since 0.7.0 +{-# INLINE splitBySeq #-} +splitBySeq + :: (IsStream t, MonadAsync m, Storable a, Enum a, Eq a) + => Array a -> Fold m a b -> t m a -> t m b +splitBySeq patt f m = + intersperseM (fold f (A.toStream patt)) $ splitOnSeq patt f m + +-- | Like 'splitSuffixOn' but keeps the suffix intact in the splits. +-- +-- > splitSuffixOn'_ pat xs = S.toList $ FL.splitSuffixOn' (A.fromList pat) (FL.toList) (S.fromList xs) +-- +-- >>> splitSuffixOn'_ "." "" +-- [""] +-- +-- >>> splitSuffixOn'_ "." "." +-- ["."] +-- +-- >>> splitSuffixOn'_ "." "a" +-- ["a"] +-- +-- >>> splitSuffixOn'_ "." ".a" +-- > [".","a"] +-- +-- >>> splitSuffixOn'_ "." "a." +-- > ["a."] +-- +-- >>> splitSuffixOn'_ "." "a.b" +-- > ["a.","b"] +-- +-- >>> splitSuffixOn'_ "." "a.b." +-- > ["a.","b."] +-- +-- >>> splitSuffixOn'_ "." "a..b.." +-- > ["a.",".","b.","."] +-- +-- @since 0.7.0 +{-# INLINE splitWithSuffixSeq #-} +splitWithSuffixSeq + :: (IsStream t, MonadIO m, Storable a, Enum a, Eq a) + => Array a -> Fold m a b -> t m a -> t m b +splitWithSuffixSeq patt f m = + D.fromStreamD $ D.splitSuffixOn True patt f (D.toStreamD m) + +{- +-- This can be implemented easily using Rabin Karp +-- | Split post any one of the given patterns. +{-# INLINE splitSuffixOnAny #-} +splitSuffixOnAny + :: (IsStream t, Monad m, Storable a, Integral a) + => [Array a] -> Fold m a b -> t m a -> t m b +splitSuffixOnAny subseq f m = undefined + -- D.fromStreamD $ D.splitPostAny f subseq (D.toStreamD m) +-} + +------------------------------------------------------------------------------ +-- Nested Split +------------------------------------------------------------------------------ + +-- | Consider a chunked stream of container elements e.g. a stream of @Word8@ +-- chunked as a stream of arrays of @Word8@. @splitInnerBy splitter joiner +-- stream@ splits the inner containers @f a@ using the @splitter@ function and +-- joins back the resulting fragments from splitting across multiple containers +-- using the @joiner@ function such that the transformed output stream is +-- consolidated as one container per segment of the split. +-- +-- CAUTION! This is not a true streaming function as the container size after +-- the split and merge may not be bounded. +-- +-- @since 0.7.0 +{-# INLINE splitInnerBy #-} +splitInnerBy + :: (IsStream t, Monad m) + => (f a -> m (f a, Maybe (f a))) -- splitter + -> (f a -> f a -> m (f a)) -- joiner + -> t m (f a) + -> t m (f a) +splitInnerBy splitter joiner xs = + D.fromStreamD $ D.splitInnerBy splitter joiner $ D.toStreamD xs + +-- | Like 'splitInnerBy' but splits assuming the separator joins the segment in +-- a suffix style. +-- +-- @since 0.7.0 +{-# INLINE splitInnerBySuffix #-} +splitInnerBySuffix + :: (IsStream t, Monad m, Eq (f a), Monoid (f a)) + => (f a -> m (f a, Maybe (f a))) -- splitter + -> (f a -> f a -> m (f a)) -- joiner + -> t m (f a) + -> t m (f a) +splitInnerBySuffix splitter joiner xs = + D.fromStreamD $ D.splitInnerBySuffix splitter joiner $ D.toStreamD xs + +------------------------------------------------------------------------------ +-- Reorder in sequence +------------------------------------------------------------------------------ + +{- +-- Buffer until the next element in sequence arrives. The function argument +-- determines the difference in sequence numbers. This could be useful in +-- implementing sequenced streams, for example, TCP reassembly. +{-# INLINE reassembleBy #-} +reassembleBy + :: (IsStream t, Monad m) + => Fold m a b + -> (a -> a -> Int) + -> t m a + -> t m b +reassembleBy = undefined +-} + +------------------------------------------------------------------------------ +-- Distributing +------------------------------------------------------------------------------ + +-- | Tap the data flowing through a stream into a 'Fold'. For example, you may +-- add a tap to log the contents flowing through the stream. The fold is used +-- only for effects, its result is discarded. +-- +-- @ +-- Fold m a b +-- | +-- -----stream m a ---------------stream m a----- +-- +-- @ +-- +-- @ +-- > S.drain $ S.tap (FL.drainBy print) (S.enumerateFromTo 1 2) +-- 1 +-- 2 +-- @ +-- +-- Compare with 'trace'. +-- +-- @since 0.7.0 +{-# INLINE tap #-} +tap :: (IsStream t, Monad m) => FL.Fold m a b -> t m a -> t m a +tap f xs = D.fromStreamD $ D.tap f (D.toStreamD xs) + +-- | @tapOffsetEvery offset n@ taps every @n@th element in the stream +-- starting at @offset@. @offset@ can be between @0@ and @n - 1@. Offset 0 +-- means start at the first element in the stream. If the offset is outside +-- this range then @offset `mod` n@ is used as offset. +-- +-- @ +-- >>> S.drain $ S.tapOffsetEvery 0 2 (FL.mapM print FL.toList) $ S.enumerateFromTo 0 10 +-- > [0,2,4,6,8,10] +-- @ +-- +-- /Internal/ +-- +{-# INLINE tapOffsetEvery #-} +tapOffsetEvery :: (IsStream t, Monad m) + => Int -> Int -> FL.Fold m a b -> t m a -> t m a +tapOffsetEvery offset n f xs = + D.fromStreamD $ D.tapOffsetEvery offset n f (D.toStreamD xs) + +-- | Redirect a copy of the stream to a supplied fold and run it concurrently +-- in an independent thread. The fold may buffer some elements. The buffer size +-- is determined by the prevailing 'maxBuffer' setting. +-- +-- @ +-- Stream m a -> m b +-- | +-- -----stream m a ---------------stream m a----- +-- +-- @ +-- +-- @ +-- > S.drain $ S.tapAsync (S.mapM_ print) (S.enumerateFromTo 1 2) +-- 1 +-- 2 +-- @ +-- +-- Exceptions from the concurrently running fold are propagated to the current +-- computation. Note that, because of buffering in the fold, exceptions may be +-- delayed and may not correspond to the current element being processed in the +-- parent stream, but we guarantee that before the parent stream stops the tap +-- finishes and all exceptions from it are drained. +-- +-- +-- Compare with 'tap'. +-- +-- /Internal/ +{-# INLINE tapAsync #-} +tapAsync :: (IsStream t, MonadAsync m) => FL.Fold m a b -> t m a -> t m a +tapAsync f xs = D.fromStreamD $ D.tapAsync f (D.toStreamD xs) + +-- | @pollCounts predicate transform fold stream@ counts those elements in the +-- stream that pass the @predicate@. The resulting count stream is sent to +-- another thread which transforms it using @transform@ and then folds it using +-- @fold@. The thread is automatically cleaned up if the stream stops or +-- aborts due to exception. +-- +-- For example, to print the count of elements processed every second: +-- +-- @ +-- > S.drain $ S.pollCounts (const True) (S.rollingMap (-) . S.delayPost 1) (FL.drainBy print) +-- $ S.enumerateFrom 0 +-- @ +-- +-- Note: This may not work correctly on 32-bit machines. +-- +-- /Internal +-- +{-# INLINE pollCounts #-} +pollCounts :: + (IsStream t, MonadAsync m) + => (a -> Bool) + -> (t m Int -> t m Int) + -> Fold m Int b + -> t m a + -> t m a +pollCounts predicate transf f xs = + D.fromStreamD + $ D.pollCounts predicate (D.toStreamD . transf . D.fromStreamD) f + $ (D.toStreamD xs) + +-- | Calls the supplied function with the number of elements consumed +-- every @n@ seconds. The given function is run in a separate thread +-- until the end of the stream. In case there is an exception in the +-- stream the thread is killed during the next major GC. +-- +-- Note: The action is not guaranteed to run if the main thread exits. +-- +-- @ +-- > delay n = threadDelay (round $ n * 1000000) >> return n +-- > S.drain $ S.tapRate 2 (\\n -> print $ show n ++ " elements processed") (delay 1 S.|: delay 0.5 S.|: delay 0.5 S.|: S.nil) +-- 2 elements processed +-- 1 elements processed +-- @ +-- +-- Note: This may not work correctly on 32-bit machines. +-- +-- /Internal +{-# INLINE tapRate #-} +tapRate :: + (IsStream t, MonadAsync m, MonadCatch m) + => Double + -> (Int -> m b) + -> t m a + -> t m a +tapRate n f xs = D.fromStreamD $ D.tapRate n f $ (D.toStreamD xs) + +-- | Apply a monadic function to each element flowing through the stream and +-- discard the results. +-- +-- @ +-- > S.drain $ S.trace print (S.enumerateFromTo 1 2) +-- 1 +-- 2 +-- @ +-- +-- Compare with 'tap'. +-- +-- @since 0.7.0 +{-# INLINE trace #-} +trace :: (IsStream t, MonadAsync m) => (a -> m b) -> t m a -> t m a +trace f = mapM (\x -> void (f x) >> return x) + +------------------------------------------------------------------------------ +-- Windowed classification +------------------------------------------------------------------------------ + +-- We divide the stream into windows or chunks in space or time and each window +-- can be associated with a key, all events associated with a particular key in +-- the window can be folded to a single result. The stream can be split into +-- windows by size or by using a split predicate on the elements in the stream. +-- For example, when we receive a closing flag, we can close the window. +-- +-- A "chunk" is a space window and a "session" is a time window. Are there any +-- other better short words to describe them. An alternative is to use +-- "swindow" and "twindow". Another word for "session" could be "spell". +-- +-- TODO: To mark the position in space or time we can have Indexed or +-- TimeStamped types. That can make it easy to deal with the position indices +-- or timestamps. + +------------------------------------------------------------------------------ +-- Keyed Sliding Windows +------------------------------------------------------------------------------ + +{- +{-# INLINABLE classifySlidingChunks #-} +classifySlidingChunks + :: (IsStream t, MonadAsync m, Ord k) + => Int -- ^ window size + -> Int -- ^ window slide + -> Fold m a b -- ^ Fold to be applied to window events + -> t m (k, a, Bool) -- ^ window key, data, close event + -> t m (k, b) +classifySlidingChunks wsize wslide (Fold step initial extract) str + = undefined + +-- XXX Another variant could be to slide the window on an event, e.g. in TCP we +-- slide the send window when an ack is received and we slide the receive +-- window when a sequence is complete. Sliding is stateful in case of TCP, +-- sliding releases the send buffer or makes data available to the user from +-- the receive buffer. +{-# INLINABLE classifySlidingSessions #-} +classifySlidingSessions + :: (IsStream t, MonadAsync m, Ord k) + => Double -- ^ timer tick in seconds + -> Double -- ^ time window size + -> Double -- ^ window slide + -> Fold m a b -- ^ Fold to be applied to window events + -> t m (k, a, Bool, AbsTime) -- ^ window key, data, close flag, timestamp + -> t m (k, b) +classifySlidingSessions tick interval slide (Fold step initial extract) str + = undefined +-} + +------------------------------------------------------------------------------ +-- Sliding Window Buffers +------------------------------------------------------------------------------ + +-- These buffered versions could be faster than concurrent incremental folds of +-- all overlapping windows as in many cases we may not need all the values to +-- compute the fold, we can just compute the result using the old value and new +-- value. However, we may need the buffer once in a while, for example for +-- string search we usually compute the hash incrementally but when the hash +-- matches the hash of the pattern we need to compare the whole string. +-- +-- XXX we should be able to implement sequence based splitting combinators +-- using this combinator. + +{- +-- | Buffer n elements of the input in a ring buffer. When t new elements are +-- collected, slide the window to remove the same number of oldest elements, +-- insert the new elements, and apply an incremental fold on the sliding +-- window, supplying the outgoing elements, the new ring buffer as arguments. +slidingChunkBuffer + :: (IsStream t, Monad m, Ord a, Storable a) + => Int -- window size + -> Int -- window slide + -> Fold m (Ring a, Array a) b + -> t m a + -> t m b +slidingChunkBuffer = undefined + +-- Buffer n seconds worth of stream elements of the input in a radix tree. +-- Every t seconds, remove the items that are older than n seconds, and apply +-- an incremental fold on the sliding window, supplying the outgoing elements, +-- and the new radix tree buffer as arguments. +slidingSessionBuffer + :: (IsStream t, Monad m, Ord a, Storable a) + => Int -- window size + -> Int -- tick size + -> Fold m (RTree a, Array a) b + -> t m a + -> t m b +slidingSessionBuffer = undefined +-} + +------------------------------------------------------------------------------ +-- Keyed Session Windows +------------------------------------------------------------------------------ + +{- +-- | Keyed variable size space windows. Close the window if we do not receive a +-- window event in the next "spaceout" elements. +{-# INLINABLE classifyChunksBy #-} +classifyChunksBy + :: (IsStream t, MonadAsync m, Ord k) + => Int -- ^ window spaceout (spread) + -> Bool -- ^ reset the spaceout when a chunk window element is received + -> Fold m a b -- ^ Fold to be applied to chunk window elements + -> t m (k, a, Bool) -- ^ chunk key, data, last element + -> t m (k, b) +classifyChunksBy spanout reset (Fold step initial extract) str = undefined + +-- | Like 'classifyChunksOf' but the chunk size is reset if an element is +-- received within the chunk size window. The chunk gets closed only if no +-- element is received within the chunk window. +-- +{-# INLINABLE classifyKeepAliveChunks #-} +classifyKeepAliveChunks + :: (IsStream t, MonadAsync m, Ord k) + => Int -- ^ window spaceout (spread) + -> Fold m a b -- ^ Fold to be applied to chunk window elements + -> t m (k, a, Bool) -- ^ chunk key, data, last element + -> t m (k, b) +classifyKeepAliveChunks spanout = classifyChunksBy spanout True +-} + +#if __GLASGOW_HASKELL__ < 800 +#define Type * +#endif + +data SessionState t m k a b = SessionState + { sessionCurTime :: !AbsTime -- ^ time since last event + , sessionEventTime :: !AbsTime -- ^ time as per last event + , sessionCount :: !Int -- ^ total number sessions in progress + , sessionTimerHeap :: H.Heap (H.Entry AbsTime k) -- ^ heap for timeouts + , sessionKeyValueMap :: Map.Map k a -- ^ Stored sessions for keys + , sessionOutputStream :: t (m :: Type -> Type) (k, b) -- ^ Completed sessions + } + +#undef Type + +-- | @classifySessionsBy tick timeout idle pred f stream@ groups timestamped +-- events in an input event stream into sessions based on a session key. Each +-- element in the stream is an event consisting of a triple @(session key, +-- sesssion data, timestamp)@. @session key@ is a key that uniquely identifies +-- the session. All the events belonging to a session are folded using the +-- fold @f@ until the fold returns a 'Left' result or a timeout has occurred. +-- The session key and the result of the fold are emitted in the output stream +-- when the session is purged. +-- +-- When @idle@ is 'False', @timeout@ is the maximum lifetime of a session in +-- seconds, measured from the @timestamp@ of the first event in that session. +-- When @idle@ is 'True' then the timeout is an idle timeout, it is reset after +-- every event received in the session. +-- +-- @timestamp@ in an event characterizes the time when the input event was +-- generated, this is an absolute time measured from some @Epoch@. The notion +-- of current time is maintained by a monotonic event time clock using the +-- timestamps seen in the input stream. The latest timestamp seen till now is +-- used as the base for the current time. When no new events are seen, a timer +-- is started with a tick duration specified by @tick@. This timer is used to +-- detect session timeouts in the absence of new events. +-- +-- The predicate @pred@ is invoked with the current session count, if it +-- returns 'True' a session is ejected from the session cache before inserting +-- a new session. This could be useful to alert or eject sessions when the +-- number of sessions becomes too high. +-- +-- /Internal/ +-- + +-- XXX Perhaps we should use an "Event a" type to represent timestamped data. +{-# INLINABLE classifySessionsBy #-} +classifySessionsBy + :: (IsStream t, MonadAsync m, Ord k) + => Double -- ^ timer tick in seconds + -> Double -- ^ session timeout in seconds + -> Bool -- ^ reset the timeout when an event is received + -> (Int -> m Bool) -- ^ predicate to eject sessions based on session count + -> Fold m a (Either b b) -- ^ Fold to be applied to session events + -> t m (k, a, AbsTime) -- ^ session key, data, timestamp + -> t m (k, b) -- ^ session key, fold result +classifySessionsBy tick timeout reset ejectPred + (Fold step initial extract) str = + concatMap (\session -> sessionOutputStream session) + $ scanlM' sstep szero stream + + where + + timeoutMs = toRelTime (round (timeout * 1000) :: MilliSecond64) + tickMs = toRelTime (round (tick * 1000) :: MilliSecond64) + szero = SessionState + { sessionCurTime = toAbsTime (0 :: MilliSecond64) + , sessionEventTime = toAbsTime (0 :: MilliSecond64) + , sessionCount = 0 + , sessionTimerHeap = H.empty + , sessionKeyValueMap = Map.empty + , sessionOutputStream = K.nil + } + + -- We can eject sessions based on the current session count to limit + -- memory consumption. There are two possible strategies: + -- + -- 1) Eject old sessions or sessions beyond a certain/lower timeout + -- threshold even before timeout, effectively reduce the timeout. + -- 2) Drop creation of new sessions but keep accepting new events for the + -- old ones. + -- + -- We use the first strategy as of now. + + -- Got a new stream input element + sstep (session@SessionState{..}) (Just (key, value, timestamp)) = do + -- XXX we should use a heap in pinned memory to scale it to a large + -- size + -- + -- To detect session inactivity we keep a timestamp of the latest event + -- in the Map along with the fold result. When we purge the session + -- from the heap we match the timestamp in the heap with the timestamp + -- in the Map, if the latest timestamp is newer and has not expired we + -- reinsert the key in the heap. + -- + -- XXX if the key is an Int, we can also use an IntMap for slightly + -- better performance. + -- + let curTime = max sessionEventTime timestamp + accumulate v = do + old <- case v of + Nothing -> initial + Just (Tuple' _ acc) -> return acc + new <- step old value + return $ Tuple' timestamp new + mOld = Map.lookup key sessionKeyValueMap + + acc@(Tuple' _ fres) <- accumulate mOld + res <- extract fres + case res of + Left x -> do + -- deleting a key from the heap is expensive, so we never + -- delete a key from heap, we just purge it from the Map and it + -- gets purged from the heap on timeout. We just need an extra + -- lookup in the Map when the key is purged from the heap, that + -- should not be expensive. + -- + let (mp, cnt) = case mOld of + Nothing -> (sessionKeyValueMap, sessionCount) + Just _ -> (Map.delete key sessionKeyValueMap + , sessionCount - 1) + return $ session + { sessionCurTime = curTime + , sessionEventTime = curTime + , sessionCount = cnt + , sessionKeyValueMap = mp + , sessionOutputStream = yield (key, x) + } + Right _ -> do + (hp1, mp1, out1, cnt1) <- do + let vars = (sessionTimerHeap, sessionKeyValueMap, + K.nil, sessionCount) + case mOld of + -- inserting new entry + Nothing -> do + -- Eject a session from heap and map is needed + eject <- ejectPred sessionCount + (hp, mp, out, cnt) <- + if eject + then ejectOne vars + else return vars + + -- Insert the new session in heap + let expiry = addToAbsTime timestamp timeoutMs + hp' = H.insert (Entry expiry key) hp + in return $ (hp', mp, out, (cnt + 1)) + -- updating old entry + Just _ -> return vars + + let mp2 = Map.insert key acc mp1 + return $ SessionState + { sessionCurTime = curTime + , sessionEventTime = curTime + , sessionCount = cnt1 + , sessionTimerHeap = hp1 + , sessionKeyValueMap = mp2 + , sessionOutputStream = out1 + } + + -- Got a timer tick event + sstep (sessionState@SessionState{..}) Nothing = + let curTime = addToAbsTime sessionCurTime tickMs + in ejectExpired sessionState curTime + + fromEither e = + case e of + Left x -> x + Right x -> x + + -- delete from map and output the fold accumulator + ejectEntry hp mp out cnt acc key = do + sess <- extract acc + let out1 = (key, fromEither sess) `K.cons` out + let mp1 = Map.delete key mp + return (hp, mp1, out1, (cnt - 1)) + + ejectOne (hp, mp, out, !cnt) = do + let hres = H.uncons hp + case hres of + Just (Entry expiry key, hp1) -> do + case Map.lookup key mp of + Nothing -> ejectOne (hp1, mp, out, cnt) + Just (Tuple' latestTS acc) -> do + let expiry1 = addToAbsTime latestTS timeoutMs + if not reset || expiry1 <= expiry + then ejectEntry hp1 mp out cnt acc key + else + -- reset the session timeout and continue + let hp2 = H.insert (Entry expiry1 key) hp1 + in ejectOne (hp2, mp, out, cnt) + Nothing -> do + assert (Map.null mp) (return ()) + return (hp, mp, out, cnt) + + ejectExpired (session@SessionState{..}) curTime = do + (hp', mp', out, count) <- + ejectLoop sessionTimerHeap sessionKeyValueMap K.nil sessionCount + return $ session + { sessionCurTime = curTime + , sessionCount = count + , sessionTimerHeap = hp' + , sessionKeyValueMap = mp' + , sessionOutputStream = out + } + + where + + ejectLoop hp mp out !cnt = do + let hres = H.uncons hp + case hres of + Just (Entry expiry key, hp1) -> do + (eject, force) <- do + if curTime >= expiry + then return (True, False) + else do + r <- ejectPred cnt + return (r, r) + if eject + then do + case Map.lookup key mp of + Nothing -> ejectLoop hp1 mp out cnt + Just (Tuple' latestTS acc) -> do + let expiry1 = addToAbsTime latestTS timeoutMs + if expiry1 <= curTime || not reset || force + then do + (hp2,mp1,out1,cnt1) <- + ejectEntry hp1 mp out cnt acc key + ejectLoop hp2 mp1 out1 cnt1 + else + -- reset the session timeout and continue + let hp2 = H.insert (Entry expiry1 key) hp1 + in ejectLoop hp2 mp out cnt + else return (hp, mp, out, cnt) + Nothing -> do + assert (Map.null mp) (return ()) + return (hp, mp, out, cnt) + + -- merge timer events in the stream + stream = Serial.map Just str `Par.parallel` repeatM timer + timer = do + liftIO $ threadDelay (round $ tick * 1000000) + return Nothing + +-- | Like 'classifySessionsOf' but the session is kept alive if an event is +-- received within the session window. The session times out and gets closed +-- only if no event is received within the specified session window size. +-- +-- If the ejection predicate returns 'True', the session that was idle for +-- the longest time is ejected before inserting a new session. +-- +-- @ +-- classifyKeepAliveSessions timeout pred = classifySessionsBy 1 timeout True pred +-- @ +-- +-- /Internal/ +-- +{-# INLINABLE classifyKeepAliveSessions #-} +classifyKeepAliveSessions + :: (IsStream t, MonadAsync m, Ord k) + => Double -- ^ session inactive timeout + -> (Int -> m Bool) -- ^ predicate to eject sessions on session count + -> Fold m a (Either b b) -- ^ Fold to be applied to session payload data + -> t m (k, a, AbsTime) -- ^ session key, data, timestamp + -> t m (k, b) +classifyKeepAliveSessions timeout ejectPred = + classifySessionsBy 1 timeout True ejectPred + +------------------------------------------------------------------------------ +-- Keyed tumbling windows +------------------------------------------------------------------------------ + +-- Tumbling windows is a special case of sliding windows where the window slide +-- is the same as the window size. Or it can be a special case of session +-- windows where the reset flag is set to False. + +-- XXX instead of using the early termination flag in the stream, we can use an +-- early terminating fold instead. + +{- +-- | Split the stream into fixed size chunks of specified size. Within each +-- such chunk fold the elements in buckets identified by the keys. A particular +-- bucket fold can be terminated early if a closing flag is encountered in an +-- element for that key. +-- +-- @since 0.7.0 +{-# INLINABLE classifyChunksOf #-} +classifyChunksOf + :: (IsStream t, MonadAsync m, Ord k) + => Int -- ^ window size + -> Fold m a b -- ^ Fold to be applied to window events + -> t m (k, a, Bool) -- ^ window key, data, close event + -> t m (k, b) +classifyChunksOf wsize = classifyChunksBy wsize False +-} + +-- | Split the stream into fixed size time windows of specified interval in +-- seconds. Within each such window, fold the elements in sessions identified +-- by the session keys. The fold result is emitted in the output stream if the +-- fold returns a 'Left' result or if the time window ends. +-- +-- Session @timestamp@ in the input stream is an absolute time from some epoch, +-- characterizing the time when the input element was generated. To detect +-- session window end, a monotonic event time clock is maintained synced with +-- the timestamps with a clock resolution of 1 second. +-- +-- If the ejection predicate returns 'True', the session with the longest +-- lifetime is ejected before inserting a new session. +-- +-- @ +-- classifySessionsOf interval pred = classifySessionsBy 1 interval False pred +-- @ +-- +-- /Internal/ +-- +{-# INLINABLE classifySessionsOf #-} +classifySessionsOf + :: (IsStream t, MonadAsync m, Ord k) + => Double -- ^ time window size + -> (Int -> m Bool) -- ^ predicate to eject sessions on session count + -> Fold m a (Either b b) -- ^ Fold to be applied to session events + -> t m (k, a, AbsTime) -- ^ session key, data, timestamp + -> t m (k, b) +classifySessionsOf interval ejectPred = + classifySessionsBy 1 interval False ejectPred + +------------------------------------------------------------------------------ +-- Exceptions +------------------------------------------------------------------------------ + +-- | Run a side effect before the stream yields its first element. +-- +-- @since 0.7.0 +{-# INLINE before #-} +before :: (IsStream t, Monad m) => m b -> t m a -> t m a +before action xs = D.fromStreamD $ D.before action $ D.toStreamD xs + +-- | Run a side effect whenever the stream stops normally. +-- +-- Prefer 'afterIO' over this as the @after@ action in this combinator is not +-- executed if the unfold is partially evaluated lazily and then garbage +-- collected. +-- +-- @since 0.7.0 +{-# INLINE after #-} +after :: (IsStream t, Monad m) => m b -> t m a -> t m a +after action xs = D.fromStreamD $ D.after action $ D.toStreamD xs + +-- | Run a side effect whenever the stream stops normally +-- or is garbage collected after a partial lazy evaluation. +-- +-- /Internal/ +-- +{-# INLINE afterIO #-} +afterIO :: (IsStream t, MonadIO m, MonadBaseControl IO m) => m b -> t m a -> t m a +afterIO action xs = D.fromStreamD $ D.afterIO action $ D.toStreamD xs + +-- | Run a side effect whenever the stream aborts due to an exception. +-- +-- @since 0.7.0 +{-# INLINE onException #-} +onException :: (IsStream t, MonadCatch m) => m b -> t m a -> t m a +onException action xs = D.fromStreamD $ D.onException action $ D.toStreamD xs + +-- | Run a side effect whenever the stream stops normally or aborts due to an +-- exception. +-- +-- Prefer 'finallyIO' over this as the @after@ action in this combinator is not +-- executed if the unfold is partially evaluated lazily and then garbage +-- collected. +-- +-- @since 0.7.0 +{-# INLINE finally #-} +finally :: (IsStream t, MonadCatch m) => m b -> t m a -> t m a +finally action xs = D.fromStreamD $ D.finally action $ D.toStreamD xs + +-- | Run a side effect whenever the stream stops normally, aborts due to an +-- exception or if it is garbage collected after a partial lazy evaluation. +-- +-- /Internal/ +-- +{-# INLINE finallyIO #-} +finallyIO :: (IsStream t, MonadAsync m, MonadCatch m) => m b -> t m a -> t m a +finallyIO action xs = D.fromStreamD $ D.finallyIO action $ D.toStreamD xs + +-- | Run the first action before the stream starts and remember its output, +-- generate a stream using the output, run the second action using the +-- remembered value as an argument whenever the stream ends normally or due to +-- an exception. +-- +-- Prefer 'bracketIO' over this as the @after@ action in this combinator is not +-- executed if the unfold is partially evaluated lazily and then garbage +-- collected. +-- +-- @since 0.7.0 +{-# INLINE bracket #-} +bracket :: (IsStream t, MonadCatch m) + => m b -> (b -> m c) -> (b -> t m a) -> t m a +bracket bef aft bet = D.fromStreamD $ + D.bracket bef aft (\x -> toStreamD $ bet x) + +-- | Run the first action before the stream starts and remember its output, +-- generate a stream using the output, run the second action using the +-- remembered value as an argument whenever the stream ends normally, due to +-- an exception or if it is garbage collected after a partial lazy evaluation. +-- +-- /Internal/ +-- +{-# INLINE bracketIO #-} +bracketIO :: (IsStream t, MonadAsync m, MonadCatch m) + => m b -> (b -> m c) -> (b -> t m a) -> t m a +bracketIO bef aft bet = D.fromStreamD $ + D.bracketIO bef aft (\x -> toStreamD $ bet x) -- | When evaluating a stream if an exception occurs, stream evaluation aborts -- and the specified exception handler is run with the exception as argument. diff --git a/src/Streamly/Memory/Array.hs b/src/Streamly/Memory/Array.hs --- a/src/Streamly/Memory/Array.hs +++ b/src/Streamly/Memory/Array.hs @@ -1,8 +1,4 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE ScopedTypeVariables #-} #include "inline.hs" @@ -24,7 +20,7 @@ -- 'Storable' values of a given type, they cannot store non-serializable data -- like functions. Once created an array cannot be modified. Pinned memory -- allows efficient buffering of long lived data without adding any impact to --- GC. One array is just one pointer visible to GC and it does not have to +-- GC. One array is just one pointer visible to GC and it does not have to be -- copied across generations. Moreover, pinned memory allows communication -- with foreign consumers and producers (e.g. file or network IO) without -- copying the data. diff --git a/src/Streamly/Memory/Malloc.hs b/src/Streamly/Memory/Malloc.hs --- a/src/Streamly/Memory/Malloc.hs +++ b/src/Streamly/Memory/Malloc.hs @@ -1,11 +1,7 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE FlexibleContexts #-} #include "inline.hs" @@ -40,8 +36,8 @@ {-# INLINE mallocForeignPtrAlignedBytes #-} mallocForeignPtrAlignedBytes :: Int -> Int -> IO (GHC.ForeignPtr a) #ifdef USE_GHC_MALLOC -mallocForeignPtrAlignedBytes size alignment = do - GHC.mallocPlainForeignPtrAlignedBytes size alignment +mallocForeignPtrAlignedBytes = + GHC.mallocPlainForeignPtrAlignedBytes #else mallocForeignPtrAlignedBytes size _alignment = do p <- mallocBytes size diff --git a/src/Streamly/Memory/Ring.hs b/src/Streamly/Memory/Ring.hs --- a/src/Streamly/Memory/Ring.hs +++ b/src/Streamly/Memory/Ring.hs @@ -32,7 +32,7 @@ ) where import Control.Exception (assert) -import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) +import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, touchForeignPtr) import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) import Foreign.Ptr (plusPtr, minusPtr, castPtr) import Foreign.Storable (Storable(..)) @@ -40,6 +40,8 @@ import GHC.Ptr (Ptr(..)) import Prelude hiding (length, concat) +import Control.Monad.IO.Class (MonadIO(..)) + import qualified Streamly.Internal.Memory.Array.Types as A -- | A ring buffer is a mutable array of fixed size. Initially the array is @@ -67,7 +69,7 @@ let size = count * sizeOf (undefined :: a) fptr <- mallocPlainForeignPtrAlignedBytes size (alignment (undefined :: a)) let p = unsafeForeignPtrToPtr fptr - return $ (Ring + return (Ring { ringStart = fptr , ringBound = p `plusPtr` size }, p) @@ -103,7 +105,7 @@ unsafeEqArrayN Ring{..} rh A.Array{..} n = let !res = A.unsafeInlineIO $ do let rs = unsafeForeignPtrToPtr ringStart - let as = unsafeForeignPtrToPtr aStart + as = unsafeForeignPtrToPtr aStart assert (aBound `minusPtr` as >= ringBound `minusPtr` rs) (return ()) let len = ringBound `minusPtr` rh r1 <- A.memcmp (castPtr rh) (castPtr as) (min len n) @@ -163,13 +165,21 @@ x <- peek p go (f acc x) (p `plusPtr` sizeOf (undefined :: a)) q +-- XXX Can we remove MonadIO here? +withForeignPtrM :: MonadIO m => ForeignPtr a -> (Ptr a -> m b) -> m b +withForeignPtrM fp fn = do + r <- fn $ unsafeForeignPtrToPtr fp + liftIO $ touchForeignPtr fp + return r + -- | Like unsafeFoldRing but with a monadic step function. {-# INLINE unsafeFoldRingM #-} -unsafeFoldRingM :: forall m a b. (Monad m, Storable a) +unsafeFoldRingM :: forall m a b. (MonadIO m, Storable a) => Ptr a -> (b -> a -> m b) -> b -> Ring a -> m b -unsafeFoldRingM ptr f z Ring{..} = go z (unsafeForeignPtrToPtr ringStart) ptr - where - go !acc !start !end +unsafeFoldRingM ptr f z Ring {..} = + withForeignPtrM ringStart $ \x -> go z x ptr + where + go !acc !start !end | start == end = return acc | otherwise = do let !x = A.unsafeInlineIO $ peek start @@ -181,14 +191,15 @@ -- this would fold the ring starting from the oldest item to the newest item in -- the ring. {-# INLINE unsafeFoldRingFullM #-} -unsafeFoldRingFullM :: forall m a b. (Monad m, Storable a) +unsafeFoldRingFullM :: forall m a b. (MonadIO m, Storable a) => Ptr a -> (b -> a -> m b) -> b -> Ring a -> m b -unsafeFoldRingFullM rh f z rb@Ring{..} = go z rh - where - go !acc !start = do - let !x = A.unsafeInlineIO $ peek start - acc' <- f acc x - let ptr = advance rb start - if ptr == rh +unsafeFoldRingFullM rh f z rb@Ring {..} = + withForeignPtrM ringStart $ \_ -> go z rh + where + go !acc !start = do + let !x = A.unsafeInlineIO $ peek start + acc' <- f acc x + let ptr = advance rb start + if ptr == rh then return acc' else go acc' ptr diff --git a/src/Streamly/Network/Socket.hs b/src/Streamly/Network/Socket.hs --- a/src/Streamly/Network/Socket.hs +++ b/src/Streamly/Network/Socket.hs @@ -9,7 +9,7 @@ -- -- A socket is a handle to a protocol endpoint. -- --- This module provides APIs to read and write streams and arrays to and from +-- This module provides APIs to read and write streams and arrays from and to -- network sockets. Sockets may be connected or unconnected. Connected sockets -- can only send or recv data to/from the connected endpoint, therefore, APIs -- for connected sockets do not need to explicitly specify the remote endpoint. diff --git a/src/Streamly/Prelude.hs b/src/Streamly/Prelude.hs --- a/src/Streamly/Prelude.hs +++ b/src/Streamly/Prelude.hs @@ -6,7 +6,7 @@ {-# OPTIONS_GHC -Wno-orphans #-} #endif -#include "Streams/inline.hs" +#include "inline.hs" -- | -- Module : Streamly.Prelude @@ -781,7 +781,7 @@ -- left fold reconstructs in a LIFO style, thereby reversing the order of -- elements.. -- 3. A right fold has termination control and therefore can terminate early --- without going throught the entire input, a left fold cannot terminate +-- without going through the entire input, a left fold cannot terminate -- without consuming all of its input. For example, a right fold -- implementation of 'or' can terminate as soon as it finds the first 'True' -- element, whereas a left fold would necessarily go through the entire input diff --git a/src/Streamly/Streams/Ahead.hs b/src/Streamly/Streams/Ahead.hs deleted file mode 100644 --- a/src/Streamly/Streams/Ahead.hs +++ /dev/null @@ -1,700 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving#-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -- XXX - --- | --- Module : Streamly.Streams.Ahead --- Copyright : (c) 2017 Harendra Kumar --- --- License : BSD3 --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- --- -module Streamly.Streams.Ahead - ( - AheadT - , Ahead - , aheadly - , ahead - ) -where - -import Control.Concurrent.MVar (putMVar, takeMVar) -import Control.Exception (assert) -import Control.Monad (ap, void, when) -import Control.Monad.Base (MonadBase(..), liftBaseDefault) -import Control.Monad.Catch (MonadThrow, throwM) --- import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.Reader.Class (MonadReader(..)) -import Control.Monad.State.Class (MonadState(..)) -import Control.Monad.Trans.Class (MonadTrans(lift)) -import Data.Heap (Heap, Entry(..)) -import Data.IORef (IORef, readIORef, atomicModifyIORef, writeIORef) -import Data.Maybe (fromJust) -#if __GLASGOW_HASKELL__ < 808 -import Data.Semigroup (Semigroup(..)) -#endif -import GHC.Exts (inline) - -import qualified Data.Heap as H - -import Streamly.Streams.SVar (fromSVar) -import Streamly.Streams.Serial (map) -import Streamly.Internal.Data.SVar -import Streamly.Streams.StreamK - (IsStream(..), Stream, mkStream, foldStream, foldStreamShared, - foldStreamSVar) -import qualified Streamly.Streams.StreamK as K - -import Prelude hiding (map) - -#include "Instances.hs" - -------------------------------------------------------------------------------- --- Ahead -------------------------------------------------------------------------------- - --- Lookahead streams can execute multiple tasks concurrently, ahead of time, --- but always serve them in the same order as they appear in the stream. To --- implement lookahead streams efficiently we assign a sequence number to each --- task when the task is picked up for execution. When the task finishes, the --- output is tagged with the same sequence number and we rearrange the outputs --- in sequence based on that number. --- --- To explain the mechanism imagine that the current task at the head of the --- stream has a "token" to yield to the outputQueue. The ownership of the token --- is determined by the current sequence number is maintained in outputHeap. --- Sequence number is assigned when a task is queued. When a thread dequeues a --- task it picks up the sequence number as well and when the output is ready it --- uses the sequence number to queue the output to the outputQueue. --- --- The thread with current sequence number sends the output directly to the --- outputQueue. Other threads push the output to the outputHeap. When the task --- being queued on the heap is a stream of many elements we evaluate only the --- first element and keep the rest of the unevaluated computation in the heap. --- When such a task gets the "token" for outputQueue it evaluates and directly --- yields all the elements to the outputQueue without checking for the --- "token". --- --- Note that no two outputs in the heap can have the same sequence numbers and --- therefore we do not need a stable heap. We have also separated the buffer --- for the current task (outputQueue) and the pending tasks (outputHeap) so --- that the pending tasks cannot interfere with the current task. Note that for --- a single task just the outputQueue is enough and for the case of many --- threads just a heap is good enough. However we balance between these two --- cases, so that both are efficient. --- --- For bigger streams it may make sense to have separate buffers for each --- stream. However, for singleton streams this may become inefficient. However, --- if we do not have separate buffers, then the streams that come later in --- sequence may hog the buffer, hindering the streams that are ahead. For this --- reason we have a single element buffer limitation for the streams being --- executed in advance. --- --- This scheme works pretty efficiently with less than 40% extra overhead --- compared to the Async streams where we do not have any kind of sequencing of --- the outputs. It is especially devised so that we are most efficient when we --- have short tasks and need just a single thread. Also when a thread yields --- many items it can hold lockfree access to the outputQueue and do it --- efficiently. --- --- XXX Maybe we can start the ahead threads at a lower cpu and IO priority so --- that they do not hog the resources and hinder the progress of the threads in --- front of them. - --- Left associated ahead expressions are expensive. We start a new SVar for --- each left associative expression. The queue is used only for right --- associated expression, we queue the right expression and execute the left. --- Thererefore the queue never has more than on item in it. --- --- XXX Also note that limiting concurrency for cases like "take 10" would not --- work well with left associative expressions, because we have no visibility --- about how much the left side of the expression would yield. --- --- XXX It may be a good idea to increment sequence numbers for each yield, --- currently a stream on the left side of the expression may yield many --- elements with the same sequene number. We can then use the seq number to --- enforce yieldMax and yieldLImit as well. - --- Invariants: --- --- * A worker should always ensure that it pushes all the consecutive items in --- the heap to the outputQueue especially the items on behalf of the workers --- that have already left when we were holding the token. This avoids deadlock --- conditions when the later workers completion depends on the consumption of --- earlier results. For more details see comments in the consumer pull side --- code. - -{-# INLINE underMaxHeap #-} -underMaxHeap :: - SVar Stream m a - -> Heap (Entry Int (AheadHeapEntry Stream m a)) - -> IO Bool -underMaxHeap sv hp = do - (_, len) <- readIORef (outputQueue sv) - - -- XXX simplify this - let maxHeap = case maxBufferLimit sv of - Limited lim -> Limited $ - max 0 (lim - fromIntegral len) - Unlimited -> Unlimited - - case maxHeap of - Limited lim -> do - active <- readIORef (workerCount sv) - return $ H.size hp + active <= fromIntegral lim - Unlimited -> return True - --- Return value: --- True => stop --- False => continue -preStopCheck :: - SVar Stream m a - -> IORef (Heap (Entry Int (AheadHeapEntry Stream m a)) , Maybe Int) - -> IO Bool -preStopCheck sv heap = - -- check the stop condition under a lock before actually - -- stopping so that the whole herd does not stop at once. - withIORef heap $ \(hp, _) -> do - heapOk <- underMaxHeap sv hp - takeMVar (workerStopMVar sv) - let stop = do - putMVar (workerStopMVar sv) () - return True - continue = do - putMVar (workerStopMVar sv) () - return False - if heapOk - then - case yieldRateInfo sv of - Nothing -> continue - Just yinfo -> do - rateOk <- isBeyondMaxRate sv yinfo - if rateOk then continue else stop - else stop - -abortExecution :: - IORef ([Stream m a], Int) - -> SVar Stream m a - -> Maybe WorkerInfo - -> Stream m a - -> IO () -abortExecution q sv winfo m = do - reEnqueueAhead sv q m - incrementYieldLimit sv - sendStop sv winfo - --- XXX In absence of a "noyield" primitive (i.e. do not pre-empt inside a --- critical section) from GHC RTS, we have a difficult problem. Assume we have --- a 100,000 threads producing output and queuing it to the heap for --- sequencing. The heap can be drained only by one thread at a time, any thread --- that finds that heap can be drained now, takes a lock and starts draining --- it, however the thread may get prempted in the middle of it holding the --- lock. Since that thread is holding the lock, the other threads cannot pick --- up the draining task, therefore they proceed to picking up the next task to --- execute. If the draining thread could yield voluntarily at a point where it --- has released the lock, then the next threads could pick up the draining --- instead of executing more tasks. When there are 100,000 threads the drainer --- gets a cpu share to run only 1:100000 of the time. This makes the heap --- accumulate a lot of output when we the buffer size is large. --- --- The solutions to this problem are: --- 1) make the other threads wait in a queue until the draining finishes --- 2) make the other threads queue and go away if draining is in progress --- --- In both cases we give the drainer a chance to run more often. --- -processHeap :: MonadIO m - => IORef ([Stream m a], Int) - -> IORef (Heap (Entry Int (AheadHeapEntry Stream m a)), Maybe Int) - -> State Stream m a - -> SVar Stream m a - -> Maybe WorkerInfo - -> AheadHeapEntry Stream m a - -> Int - -> Bool -- we are draining the heap before we stop - -> m () -processHeap q heap st sv winfo entry sno stopping = loopHeap sno entry - - where - - stopIfNeeded ent seqNo r = do - stopIt <- liftIO $ preStopCheck sv heap - if stopIt - then liftIO $ do - -- put the entry back in the heap and stop - requeueOnHeapTop heap (Entry seqNo ent) seqNo - sendStop sv winfo - else runStreamWithYieldLimit True seqNo r - - loopHeap seqNo ent = - case ent of - AheadEntryNull -> nextHeap seqNo - AheadEntryPure a -> do - -- Use 'send' directly so that we do not account this in worker - -- latency as this will not be the real latency. - -- Don't stop the worker in this case as we are just - -- transferring available results from heap to outputQueue. - void $ liftIO $ send sv (ChildYield a) - nextHeap seqNo - AheadEntryStream r -> - if stopping - then stopIfNeeded ent seqNo r - else runStreamWithYieldLimit True seqNo r - - nextHeap prevSeqNo = do - res <- liftIO $ dequeueFromHeapSeq heap (prevSeqNo + 1) - case res of - Ready (Entry seqNo hent) -> loopHeap seqNo hent - Clearing -> liftIO $ sendStop sv winfo - Waiting _ -> - if stopping - then do - r <- liftIO $ preStopCheck sv heap - if r - then liftIO $ sendStop sv winfo - else processWorkQueue prevSeqNo - else inline processWorkQueue prevSeqNo - - processWorkQueue prevSeqNo = do - work <- dequeueAhead q - case work of - Nothing -> liftIO $ sendStop sv winfo - Just (m, seqNo) -> do - yieldLimitOk <- liftIO $ decrementYieldLimit sv - if yieldLimitOk - then - if seqNo == prevSeqNo + 1 - then processWithToken q heap st sv winfo m seqNo - else processWithoutToken q heap st sv winfo m seqNo - else liftIO $ abortExecution q sv winfo m - - -- We do not stop the worker on buffer full here as we want to proceed to - -- nextHeap anyway so that we can clear any subsequent entries. We stop - -- only in yield continuation where we may have a remaining stream to be - -- pushed on the heap. - singleStreamFromHeap seqNo a = do - void $ liftIO $ sendYield sv winfo (ChildYield a) - nextHeap seqNo - - -- XXX when we have an unfinished stream on the heap we cannot account all - -- the yields of that stream until it finishes, so if we have picked up - -- and executed more actions beyond that in the parent stream and put them - -- on the heap then they would eat up some yield limit which is not - -- correct, we will think that our yield limit is over even though we have - -- to yield items from unfinished stream before them. For this reason, if - -- there are pending items in the heap we drain them unconditionally - -- without considering the yield limit. - runStreamWithYieldLimit continue seqNo r = do - _ <- liftIO $ decrementYieldLimit sv - if continue -- see comment above -- && yieldLimitOk - then do - let stop = do - liftIO (incrementYieldLimit sv) - nextHeap seqNo - foldStreamSVar sv st - (yieldStreamFromHeap seqNo) - (singleStreamFromHeap seqNo) - stop - r - else liftIO $ do - let ent = Entry seqNo (AheadEntryStream r) - liftIO $ requeueOnHeapTop heap ent seqNo - incrementYieldLimit sv - sendStop sv winfo - - yieldStreamFromHeap seqNo a r = do - continue <- liftIO $ sendYield sv winfo (ChildYield a) - runStreamWithYieldLimit continue seqNo r - -{-# NOINLINE drainHeap #-} -drainHeap :: MonadIO m - => IORef ([Stream m a], Int) - -> IORef (Heap (Entry Int (AheadHeapEntry Stream m a)), Maybe Int) - -> State Stream m a - -> SVar Stream m a - -> Maybe WorkerInfo - -> m () -drainHeap q heap st sv winfo = do - r <- liftIO $ dequeueFromHeap heap - case r of - Ready (Entry seqNo hent) -> - processHeap q heap st sv winfo hent seqNo True - _ -> liftIO $ sendStop sv winfo - -data HeapStatus = HContinue | HStop - -processWithoutToken :: MonadIO m - => IORef ([Stream m a], Int) - -> IORef (Heap (Entry Int (AheadHeapEntry Stream m a)), Maybe Int) - -> State Stream m a - -> SVar Stream m a - -> Maybe WorkerInfo - -> Stream m a - -> Int - -> m () -processWithoutToken q heap st sv winfo m seqNo = do - -- we have already decremented the yield limit for m - let stop = do - liftIO (incrementYieldLimit sv) - -- If the stream stops without yielding anything, and we do not put - -- anything on heap, but if heap was waiting for this seq number - -- then it will keep waiting forever, because we are never going to - -- put it on heap. So we have to put a null entry on heap even when - -- we stop. - toHeap AheadEntryNull - - foldStreamSVar sv st - (\a r -> toHeap $ AheadEntryStream $ K.cons a r) - (toHeap . AheadEntryPure) - stop - m - - where - - -- XXX to reduce contention each CPU can have its own heap - toHeap ent = do - -- Heap insertion is an expensive affair so we use a non CAS based - -- modification, otherwise contention and retries can make a thread - -- context switch and throw it behind other threads which come later in - -- sequence. - newHp <- liftIO $ atomicModifyIORef heap $ \(hp, snum) -> - let hp' = H.insert (Entry seqNo ent) hp - in assert (heapIsSane snum seqNo) ((hp', snum), hp') - - when (svarInspectMode sv) $ - liftIO $ do - maxHp <- readIORef (maxHeapSize $ svarStats sv) - when (H.size newHp > maxHp) $ - writeIORef (maxHeapSize $ svarStats sv) (H.size newHp) - - heapOk <- liftIO $ underMaxHeap sv newHp - let drainAndStop = drainHeap q heap st sv winfo - mainLoop = workLoopAhead q heap st sv winfo - status <- - case yieldRateInfo sv of - Nothing -> return HContinue - Just yinfo -> - case winfo of - Just info -> do - rateOk <- liftIO $ workerRateControl sv yinfo info - if rateOk - then return HContinue - else return HStop - Nothing -> return HContinue - - if heapOk - then - case status of - HContinue -> mainLoop - HStop -> drainAndStop - else drainAndStop - -processWithToken :: MonadIO m - => IORef ([Stream m a], Int) - -> IORef (Heap (Entry Int (AheadHeapEntry Stream m a)), Maybe Int) - -> State Stream m a - -> SVar Stream m a - -> Maybe WorkerInfo - -> Stream m a - -> Int - -> m () -processWithToken q heap st sv winfo action sno = do - -- Note, we enter this function with yield limit already decremented - -- XXX deduplicate stop in all invocations - let stop = do - liftIO (incrementYieldLimit sv) - loopWithToken (sno + 1) - - foldStreamSVar sv st (yieldOutput sno) (singleOutput sno) stop action - - where - - singleOutput seqNo a = do - continue <- liftIO $ sendYield sv winfo (ChildYield a) - if continue - then loopWithToken (seqNo + 1) - else do - liftIO $ updateHeapSeq heap (seqNo + 1) - drainHeap q heap st sv winfo - - -- XXX use a wrapper function around stop so that we never miss - -- incrementing the yield in a stop continuation. Essentiatlly all - -- "unstream" calls in this function must increment yield limit on stop. - yieldOutput seqNo a r = do - continue <- liftIO $ sendYield sv winfo (ChildYield a) - yieldLimitOk <- liftIO $ decrementYieldLimit sv - if continue && yieldLimitOk - then do - let stop = do - liftIO (incrementYieldLimit sv) - loopWithToken (seqNo + 1) - foldStreamSVar sv st - (yieldOutput seqNo) - (singleOutput seqNo) - stop - r - else do - let ent = Entry seqNo (AheadEntryStream r) - liftIO $ requeueOnHeapTop heap ent seqNo - liftIO $ incrementYieldLimit sv - drainHeap q heap st sv winfo - - loopWithToken nextSeqNo = do - work <- dequeueAhead q - case work of - Nothing -> do - liftIO $ updateHeapSeq heap nextSeqNo - workLoopAhead q heap st sv winfo - - Just (m, seqNo) -> do - yieldLimitOk <- liftIO $ decrementYieldLimit sv - let undo = liftIO $ do - updateHeapSeq heap nextSeqNo - reEnqueueAhead sv q m - incrementYieldLimit sv - if yieldLimitOk - then - if seqNo == nextSeqNo - then do - let stop = do - liftIO (incrementYieldLimit sv) - loopWithToken (seqNo + 1) - 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 - -- a doorBell and we will not clear the heap before - -- executing the next action. If the consumer depends - -- on the output that is stuck in the heap then this - -- will result in a deadlock. So we always clear the - -- heap before executing the next action. - undo >> workLoopAhead q heap st sv winfo - else undo >> drainHeap q heap st sv winfo - --- XXX the yield limit changes increased the performance overhead by 30-40%. --- Just like AsyncT we can use an implementation without yeidlimit and even --- without pacing code to keep the performance higher in the unlimited and --- unpaced case. --- --- XXX The yieldLimit stuff is pretty invasive. We can instead do it by using --- three hooks, a pre-execute hook, a yield hook and a stop hook. In fact these --- hooks can be used for a more general implementation to even check predicates --- and not just yield limit. - --- XXX we can remove the sv parameter as it can be derived from st - -workLoopAhead :: MonadIO m - => IORef ([Stream m a], Int) - -> IORef (Heap (Entry Int (AheadHeapEntry Stream m a)), Maybe Int) - -> State Stream m a - -> SVar Stream m a - -> Maybe WorkerInfo - -> m () -workLoopAhead q heap st sv winfo = do - r <- liftIO $ dequeueFromHeap heap - case r of - Ready (Entry seqNo hent) -> - processHeap q heap st sv winfo hent seqNo False - Clearing -> liftIO $ sendStop sv winfo - Waiting _ -> do - -- Before we execute the next item from the work queue we check - -- if we are beyond the yield limit. It is better to check the - -- yield limit before we pick up the next item. Otherwise we - -- may have already started more tasks even though we may have - -- reached the yield limit. We can avoid this by taking active - -- workers into account, but that is not as reliable, because - -- workers may go away without picking up work and yielding a - -- value. - -- - -- Rate control can be done either based on actual yields in - -- the output queue or based on any yield either to the heap or - -- to the output queue. In both cases we may have one issue or - -- the other. We chose to do this based on actual yields to the - -- output queue because it makes the code common to both async - -- and ahead streams. - -- - work <- dequeueAhead q - case work of - Nothing -> liftIO $ sendStop sv winfo - Just (m, seqNo) -> do - yieldLimitOk <- liftIO $ decrementYieldLimit sv - if yieldLimitOk - then - if seqNo == 0 - then processWithToken q heap st sv winfo m seqNo - else processWithoutToken q heap st sv winfo m seqNo - -- If some worker decremented the yield limit but then - -- did not yield anything and therefore incremented it - -- later, then if we did not requeue m here we may find - -- the work queue empty and therefore miss executing - -- the remaining action. - else liftIO $ abortExecution q sv winfo m - -------------------------------------------------------------------------------- --- WAhead -------------------------------------------------------------------------------- - --- XXX To be implemented. Use a linked queue like WAsync and put back the --- remaining computation at the back of the queue instead of the heap, and --- increment the sequence number. - --- The only difference between forkSVarAsync and this is that we run the left --- computation without a shared SVar. -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 = mkStream $ \st stp sng yld -> do - liftIO $ enqueue (fromJust $ streamVar st) mb - foldStream st stp sng yld ma - --- | 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 (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. - 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 #-} -{-# 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 ------------------------------------------------------------------------------- - --- | The 'Semigroup' operation for 'AheadT' appends two streams. The combined --- stream behaves like a single stream with the actions from the second stream --- appended to the first stream. The combined stream is evaluated in the --- speculative style. This operation can be used to fold an infinite lazy --- container of streams. --- --- @ --- import "Streamly" --- import qualified "Streamly.Prelude" as S --- import Control.Concurrent --- --- main = do --- xs \<- S.'toList' . 'aheadly' $ (p 1 |: p 2 |: nil) <> (p 3 |: p 4 |: nil) --- print xs --- where p n = threadDelay 1000000 >> return n --- @ --- @ --- [1,2,3,4] --- @ --- --- Any exceptions generated by a constituent stream are propagated to the --- output stream. --- --- The monad instance of 'AheadT' may run each monadic continuation (bind) --- concurrently in a speculative manner, performing side effects in a partially --- ordered manner but producing the outputs in an ordered manner like --- 'SerialT'. --- --- @ --- main = S.drain . 'aheadly' $ do --- n <- return 3 \<\> return 2 \<\> return 1 --- S.yieldM $ do --- threadDelay (n * 1000000) --- myThreadId >>= \\tid -> putStrLn (show tid ++ ": Delay " ++ show n) --- @ --- @ --- ThreadId 40: Delay 1 --- ThreadId 39: Delay 2 --- ThreadId 38: Delay 3 --- @ --- --- @since 0.3.0 -newtype AheadT m a = AheadT {getAheadT :: Stream m a} - deriving (MonadTrans) - --- | A serial IO stream of elements of type @a@ with concurrent lookahead. See --- 'AheadT' documentation for more details. --- --- @since 0.3.0 -type Ahead = AheadT IO - --- | Fix the type of a polymorphic stream as 'AheadT'. --- --- @since 0.3.0 -aheadly :: IsStream t => AheadT m a -> t m a -aheadly = K.adapt - -instance IsStream AheadT where - toStream = getAheadT - fromStream = AheadT - consM = consMAhead - (|:) = consMAhead - ------------------------------------------------------------------------------- --- Semigroup ------------------------------------------------------------------------------- - -{-# 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 - (<>) = mappendAhead - ------------------------------------------------------------------------------- --- Monoid ------------------------------------------------------------------------------- - -instance MonadAsync m => Monoid (AheadT m a) where - mempty = K.nil - mappend = (<>) - ------------------------------------------------------------------------------- --- Monad ------------------------------------------------------------------------------- - -{-# INLINE concatMapAhead #-} -{-# SPECIALIZE concatMapAhead :: (a -> AheadT IO b) -> AheadT IO a -> AheadT IO b #-} -concatMapAhead :: MonadAsync m => (a -> AheadT m b) -> AheadT m a -> AheadT m b -concatMapAhead f m = fromStream $ - K.concatMapBy ahead (\a -> K.adapt $ f a) (K.adapt m) - -instance MonadAsync m => Monad (AheadT m) where - return = pure - {-# INLINE (>>=) #-} - (>>=) = flip concatMapAhead - -instance (Monad m, MonadAsync m) => Applicative (AheadT m) where - pure = AheadT . K.yield - {-# INLINE (<*>) #-} - (<*>) = ap - ------------------------------------------------------------------------------- --- Other instances ------------------------------------------------------------------------------- - -MONAD_COMMON_INSTANCES(AheadT, MONADPARALLEL) diff --git a/src/Streamly/Streams/Async.hs b/src/Streamly/Streams/Async.hs deleted file mode 100644 --- a/src/Streamly/Streams/Async.hs +++ /dev/null @@ -1,860 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving#-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UndecidableInstances #-} -- XXX - --- | --- Module : Streamly.Streams.Async --- Copyright : (c) 2017 Harendra Kumar --- --- License : BSD3 --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- --- -module Streamly.Streams.Async - ( - AsyncT - , Async - , asyncly - , async - , (<|) --deprecated - , mkAsync - , mkAsync' - - , WAsyncT - , WAsync - , wAsyncly - , wAsync - ) -where - -import Control.Concurrent (myThreadId) -import Control.Monad (ap) -import Control.Monad.Base (MonadBase(..), liftBaseDefault) -import Control.Monad.Catch (MonadThrow, throwM) -import Control.Concurrent.MVar (newEmptyMVar) --- import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.Reader.Class (MonadReader(..)) -import Control.Monad.State.Class (MonadState(..)) -import Control.Monad.Trans.Class (MonadTrans(lift)) -import Data.Concurrent.Queue.MichaelScott (LinkedQueue, newQ, nullQ, tryPopR) -import Data.IORef (IORef, newIORef, readIORef) -import Data.Maybe (fromJust) -#if __GLASGOW_HASKELL__ < 808 -import Data.Semigroup (Semigroup(..)) -#endif - -import Prelude hiding (map) -import qualified Data.Set as S - -import Streamly.Internal.Data.Atomics (atomicModifyIORefCAS) -import Streamly.Streams.SVar (fromSVar) -import Streamly.Streams.Serial (map) -import Streamly.Internal.Data.SVar -import Streamly.Streams.StreamK - (IsStream(..), Stream, mkStream, foldStream, adapt, foldStreamShared, - foldStreamSVar) -import qualified Streamly.Streams.StreamK as K - -#include "Instances.hs" - -------------------------------------------------------------------------------- --- Async -------------------------------------------------------------------------------- - -{-# INLINE workLoopLIFO #-} -workLoopLIFO - :: MonadIO m - => IORef [Stream m a] - -> State Stream m a - -> SVar Stream m a - -> Maybe WorkerInfo - -> m () -workLoopLIFO q st sv winfo = run - - where - - run = do - work <- dequeue - case work of - Nothing -> liftIO $ sendStop sv winfo - Just m -> foldStreamSVar sv st yieldk single run m - - single a = do - res <- liftIO $ sendYield sv winfo (ChildYield a) - if res then run else liftIO $ sendStop sv winfo - - yieldk a r = do - res <- liftIO $ sendYield sv winfo (ChildYield a) - if res - then foldStreamSVar sv st yieldk single run r - else liftIO $ do - enqueueLIFO sv q r - sendStop sv winfo - - dequeue = liftIO $ atomicModifyIORefCAS q $ \case - [] -> ([], Nothing) - x : xs -> (xs, Just x) - --- We duplicate workLoop for yield limit and no limit cases because it has --- around 40% performance overhead in the worst case. --- --- XXX we can pass yinfo directly as an argument here so that we do not have to --- make a check every time. -{-# INLINE workLoopLIFOLimited #-} -workLoopLIFOLimited - :: MonadIO m - => IORef [Stream m a] - -> State Stream m a - -> SVar Stream m a - -> Maybe WorkerInfo - -> m () -workLoopLIFOLimited q st sv winfo = run - - where - - run = do - work <- dequeue - case work of - Nothing -> liftIO $ sendStop sv winfo - Just m -> do - -- XXX This is just a best effort minimization of concurrency - -- to the yield limit. If the stream is made of concurrent - -- streams we do not reserve the yield limit in the constituent - -- streams before executing the action. This can be done - -- though, by sharing the yield limit ref with downstream - -- actions via state passing. Just a todo. - yieldLimitOk <- liftIO $ decrementYieldLimit sv - if yieldLimitOk - then do - let stop = liftIO (incrementYieldLimit sv) >> run - foldStreamSVar sv st yieldk single stop m - -- Avoid any side effects, undo the yield limit decrement if we - -- never yielded anything. - else liftIO $ do - enqueueLIFO sv q m - incrementYieldLimit sv - sendStop sv winfo - - single a = do - res <- liftIO $ sendYield sv winfo (ChildYield a) - if res then run else liftIO $ sendStop sv winfo - - -- XXX can we pass on the yield limit downstream to limit the concurrency - -- of constituent streams. - yieldk a r = do - res <- liftIO $ sendYield sv winfo (ChildYield a) - yieldLimitOk <- liftIO $ decrementYieldLimit sv - let stop = liftIO (incrementYieldLimit sv) >> run - if res && yieldLimitOk - then foldStreamSVar sv st yieldk single stop r - else liftIO $ do - incrementYieldLimit sv - enqueueLIFO sv q r - sendStop sv winfo - - dequeue = liftIO $ atomicModifyIORefCAS q $ \case - [] -> ([], Nothing) - x : xs -> (xs, Just x) - -------------------------------------------------------------------------------- --- WAsync -------------------------------------------------------------------------------- - --- XXX we can remove sv as it is derivable from st - -{-# INLINE workLoopFIFO #-} -workLoopFIFO - :: MonadIO m - => LinkedQueue (Stream m a) - -> State Stream m a - -> SVar Stream m a - -> Maybe WorkerInfo - -> m () -workLoopFIFO q st sv winfo = run - - where - - run = do - work <- liftIO $ tryPopR q - case work of - Nothing -> liftIO $ sendStop sv winfo - Just m -> foldStreamSVar sv st yieldk single run m - - single a = do - res <- liftIO $ sendYield sv winfo (ChildYield a) - if res then run else liftIO $ sendStop sv winfo - - yieldk a r = do - res <- liftIO $ sendYield sv winfo (ChildYield a) - if res - then foldStreamSVar sv st yieldk single run r - else liftIO $ do - enqueueFIFO sv q r - sendStop sv winfo - -{-# INLINE workLoopFIFOLimited #-} -workLoopFIFOLimited - :: MonadIO m - => LinkedQueue (Stream m a) - -> State Stream m a - -> SVar Stream m a - -> Maybe WorkerInfo - -> m () -workLoopFIFOLimited q st sv winfo = run - - where - - run = do - work <- liftIO $ tryPopR q - case work of - Nothing -> liftIO $ sendStop sv winfo - Just m -> do - yieldLimitOk <- liftIO $ decrementYieldLimit sv - if yieldLimitOk - then do - let stop = liftIO (incrementYieldLimit sv) >> run - foldStreamSVar sv st yieldk single stop m - else liftIO $ do - enqueueFIFO sv q m - incrementYieldLimit sv - sendStop sv winfo - - single a = do - res <- liftIO $ sendYield sv winfo (ChildYield a) - if res then run else liftIO $ sendStop sv winfo - - yieldk a r = do - res <- liftIO $ sendYield sv winfo (ChildYield a) - yieldLimitOk <- liftIO $ decrementYieldLimit sv - let stop = liftIO (incrementYieldLimit sv) >> run - if res && yieldLimitOk - then foldStreamSVar sv st yieldk single stop r - else liftIO $ do - incrementYieldLimit sv - enqueueFIFO sv q r - sendStop sv winfo - -------------------------------------------------------------------------------- --- SVar creation --- This code belongs in SVar.hs but is kept here for perf reasons -------------------------------------------------------------------------------- - --- XXX we have this function in this file because passing runStreamLIFO as a --- function argument to this function results in a perf degradation of more --- than 10%. Need to investigate what the root cause is. --- Interestingly, the same thing does not make any difference for Ahead. -getLifoSVar :: forall m a. MonadAsync m - => State Stream m a -> RunInIO m -> IO (SVar Stream m a) -getLifoSVar st mrun = do - outQ <- newIORef ([], 0) - outQMv <- newEmptyMVar - active <- newIORef 0 - wfw <- newIORef False - running <- newIORef S.empty - q <- newIORef [] - yl <- case getYieldLimit st of - Nothing -> return Nothing - Just x -> Just <$> newIORef x - rateInfo <- getYieldRateInfo st - - stats <- newSVarStats - tid <- myThreadId - - let isWorkFinished _ = null <$> readIORef q - - let isWorkFinishedLimited sv = do - yieldsDone <- - case remainingWork sv of - Just ref -> do - n <- readIORef ref - return (n <= 0) - Nothing -> return False - qEmpty <- null <$> readIORef q - return $ qEmpty || yieldsDone - - let getSVar :: SVar Stream m a - -> (SVar Stream m a -> m [ChildEvent a]) - -> (SVar Stream m a -> m Bool) - -> (SVar Stream m a -> IO Bool) - -> (IORef [Stream m a] - -> State Stream m a - -> SVar Stream m a - -> Maybe WorkerInfo - -> m()) - -> SVar Stream m a - getSVar sv readOutput postProc workDone wloop = SVar - { outputQueue = outQ - , remainingWork = yl - , maxBufferLimit = getMaxBuffer st - , pushBufferSpace = undefined - , pushBufferPolicy = undefined - , pushBufferMVar = undefined - , maxWorkerLimit = min (getMaxThreads st) (getMaxBuffer st) - , yieldRateInfo = rateInfo - , outputDoorBell = outQMv - , readOutputQ = readOutput sv - , postProcess = postProc sv - , workerThreads = running - , workLoop = wloop q st{streamVar = Just sv} sv - , enqueue = enqueueLIFO sv q - , isWorkDone = workDone sv - , isQueueDone = workDone sv - , needDoorBell = wfw - , svarStyle = AsyncVar - , svarStopStyle = StopNone - , svarStopBy = undefined - , svarMrun = mrun - , workerCount = active - , accountThread = delThread sv - , workerStopMVar = undefined - , svarRef = Nothing - , svarInspectMode = getInspectMode st - , svarCreator = tid - , aheadWorkQueue = undefined - , outputHeap = undefined - , svarStats = stats - } - - let sv = - case getStreamRate st of - Nothing -> - case getYieldLimit st of - Nothing -> getSVar sv readOutputQBounded - postProcessBounded - isWorkFinished - workLoopLIFO - Just _ -> getSVar sv readOutputQBounded - postProcessBounded - isWorkFinishedLimited - workLoopLIFOLimited - Just _ -> - case getYieldLimit st of - Nothing -> getSVar sv readOutputQPaced - postProcessPaced - isWorkFinished - workLoopLIFO - Just _ -> getSVar sv readOutputQPaced - postProcessPaced - isWorkFinishedLimited - workLoopLIFOLimited - in return sv - -getFifoSVar :: forall m a. MonadAsync m - => State Stream m a -> RunInIO m -> IO (SVar Stream m a) -getFifoSVar st mrun = do - outQ <- newIORef ([], 0) - outQMv <- newEmptyMVar - active <- newIORef 0 - wfw <- newIORef False - running <- newIORef S.empty - q <- newQ - yl <- case getYieldLimit st of - Nothing -> return Nothing - Just x -> Just <$> newIORef x - rateInfo <- getYieldRateInfo st - - stats <- newSVarStats - tid <- myThreadId - - let isWorkFinished _ = nullQ q - let isWorkFinishedLimited sv = do - yieldsDone <- - case remainingWork sv of - Just ref -> do - n <- readIORef ref - return (n <= 0) - Nothing -> return False - qEmpty <- nullQ q - return $ qEmpty || yieldsDone - - let getSVar :: SVar Stream m a - -> (SVar Stream m a -> m [ChildEvent a]) - -> (SVar Stream m a -> m Bool) - -> (SVar Stream m a -> IO Bool) - -> (LinkedQueue (Stream m a) - -> State Stream m a - -> SVar Stream m a - -> Maybe WorkerInfo - -> m()) - -> SVar Stream m a - getSVar sv readOutput postProc workDone wloop = SVar - { outputQueue = outQ - , remainingWork = yl - , maxBufferLimit = getMaxBuffer st - , pushBufferSpace = undefined - , pushBufferPolicy = undefined - , pushBufferMVar = undefined - , maxWorkerLimit = min (getMaxThreads st) (getMaxBuffer st) - , yieldRateInfo = rateInfo - , outputDoorBell = outQMv - , readOutputQ = readOutput sv - , postProcess = postProc sv - , workerThreads = running - , workLoop = wloop q st{streamVar = Just sv} sv - , enqueue = enqueueFIFO sv q - , isWorkDone = workDone sv - , isQueueDone = workDone sv - , needDoorBell = wfw - , svarStyle = WAsyncVar - , svarStopStyle = StopNone - , svarStopBy = undefined - , svarMrun = mrun - , workerCount = active - , accountThread = delThread sv - , workerStopMVar = undefined - , svarRef = Nothing - , svarInspectMode = getInspectMode st - , svarCreator = tid - , aheadWorkQueue = undefined - , outputHeap = undefined - , svarStats = stats - } - - let sv = - case getStreamRate st of - Nothing -> - case getYieldLimit st of - Nothing -> getSVar sv readOutputQBounded - postProcessBounded - isWorkFinished - workLoopFIFO - Just _ -> getSVar sv readOutputQBounded - postProcessBounded - isWorkFinishedLimited - workLoopFIFOLimited - Just _ -> - case getYieldLimit st of - Nothing -> getSVar sv readOutputQPaced - postProcessPaced - isWorkFinished - workLoopFIFO - Just _ -> getSVar sv readOutputQPaced - postProcessPaced - isWorkFinishedLimited - workLoopFIFOLimited - in return sv - -{-# INLINABLE newAsyncVar #-} -newAsyncVar :: MonadAsync m - => State Stream m a -> Stream m a -> m (SVar Stream m a) -newAsyncVar st m = do - mrun <- captureMonadState - sv <- liftIO $ getLifoSVar st mrun - sendFirstWorker sv m - --- XXX Get rid of this? --- | Make a stream asynchronous, triggers the computation and returns a stream --- in the underlying monad representing the output generated by the original --- computation. The returned action is exhaustible and must be drained once. If --- not drained fully we may have a thread blocked forever and once exhausted it --- will always return 'empty'. --- --- @since 0.2.0 -{-# INLINABLE mkAsync #-} -mkAsync :: (IsStream t, MonadAsync m) => t m a -> m (t m a) -mkAsync = mkAsync' defState - -{-# INLINABLE mkAsync' #-} -mkAsync' :: (IsStream t, MonadAsync m) => State Stream m a -> t m a -> m (t m a) -mkAsync' st m = fmap fromSVar (newAsyncVar st (toStream m)) - --- | Create a new SVar and enqueue one stream computation on it. -{-# INLINABLE newWAsyncVar #-} -newWAsyncVar :: MonadAsync m - => State Stream m a -> Stream m a -> m (SVar Stream m a) -newWAsyncVar st m = do - mrun <- captureMonadState - sv <- liftIO $ getFifoSVar st mrun - sendFirstWorker sv m - ------------------------------------------------------------------------------- --- Running streams concurrently ------------------------------------------------------------------------------- - --- Concurrency rate control. --- --- Our objective is to create more threads on demand if the consumer is running --- faster than us. As soon as we encounter a concurrent composition we create a --- push pull pair of threads. We use an SVar for communication between the --- consumer, pulling from the SVar and the producer who is pushing to the SVar. --- The producer creates more threads if the SVar drains and becomes empty, that --- is the consumer is running faster. --- --- XXX Note 1: This mechanism can be problematic if the initial production --- latency is high, we may end up creating too many threads. So we need some --- way to monitor and use the latency as well. Having a limit on the dispatches --- (programmer controlled) may also help. --- --- TBD Note 2: We may want to run computations at the lower level of the --- composition tree serially even when they are composed using a parallel --- combinator. We can use 'serial' in place of 'async' and 'wSerial' in --- place of 'wAsync'. If we find that an SVar immediately above a computation --- gets drained empty we can switch to parallelizing the computation. For that --- we can use a state flag to fork the rest of the computation at any point of --- time inside the Monad bind operation if the consumer is running at a faster --- speed. --- --- TBD Note 3: the binary operation ('parallel') composition allows us to --- dispatch a chunkSize of only 1. If we have to dispatch in arbitrary --- chunksizes we will need to compose the parallel actions using a data --- constructor (A Free container) instead so that we can divide it in chunks of --- arbitrary size before dispatching. If the stream is composed of --- hierarchically composed grains of different sizes then we can always switch --- to a desired granularity depending on the consumer speed. --- --- TBD Note 4: for pure work (when we are not in the IO monad) we can divide it --- into just the number of CPUs. - --- | Join two computations on the currently running 'SVar' queue for concurrent --- execution. When we are using parallel composition, an SVar is passed around --- as a state variable. We try to schedule a new parallel computation on the --- SVar passed to us. The first time, when no SVar exists, a new SVar is --- created. Subsequently, 'joinStreamVarAsync' may get called when a computation --- already scheduled on the SVar is further evaluated. For example, when (a --- `parallel` b) is evaluated it calls a 'joinStreamVarAsync' to put 'a' and 'b' on --- the current scheduler queue. --- --- The 'SVarStyle' required by the current composition context is passed as one --- of the parameters. If the scheduling and composition style of the new --- computation being scheduled is different than the style of the current SVar, --- then we create a new SVar and schedule it on that. The newly created SVar --- joins as one of the computations on the current SVar queue. --- --- Cases when we need to switch to a new SVar: --- --- * (x `parallel` y) `parallel` (t `parallel` u) -- all of them get scheduled on the same SVar --- * (x `parallel` y) `parallel` (t `async` u) -- @t@ and @u@ get scheduled on a new child SVar --- because of the scheduling policy change. --- * if we 'adapt' a stream of type 'async' to a stream of type --- 'Parallel', we create a new SVar at the transitioning bind. --- * When the stream is switching from disjunctive composition to conjunctive --- composition and vice-versa we create a new SVar to isolate the scheduling --- of the two. - -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 (toStream m1) (toStream m2)) - WAsyncVar -> newWAsyncVar st (concurrently (toStream m1) (toStream m2)) - _ -> error "illegal svar type" - foldStream st stp sng yld $ fromSVar sv - where - concurrently ma mb = mkStream $ \st stp sng yld -> do - liftIO $ enqueue (fromJust $ streamVar st) mb - foldStreamShared st stp sng yld ma - -{-# INLINE joinStreamVarAsync #-} -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 -> 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 ------------------------------------------------------------------------------- - --- | Polymorphic version of the 'Semigroup' operation '<>' of 'AsyncT'. --- Merges two streams possibly concurrently, preferring the --- elements from the left one when available. --- --- @since 0.2.0 -{-# INLINE async #-} -async :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a -async = joinStreamVarAsync AsyncVar - --- | Same as 'async'. --- --- @since 0.1.0 -{-# DEPRECATED (<|) "Please use 'async' instead." #-} -{-# INLINE (<|) #-} -(<|) :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a -(<|) = async - --- 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 #-} -{-# 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 ------------------------------------------------------------------------------- - --- | The 'Semigroup' operation for 'AsyncT' appends two streams. The combined --- stream behaves like a single stream with the actions from the second stream --- appended to the first stream. The combined stream is evaluated in the --- asynchronous style. This operation can be used to fold an infinite lazy --- container of streams. --- --- @ --- import "Streamly" --- import qualified "Streamly.Prelude" as S --- import Control.Concurrent --- --- main = (S.toList . 'asyncly' $ (S.fromList [1,2]) \<> (S.fromList [3,4])) >>= print --- @ --- @ --- [1,2,3,4] --- @ --- --- Any exceptions generated by a constituent stream are propagated to the --- output stream. The output and exceptions from a single stream are guaranteed --- to arrive in the same order in the resulting stream as they were generated --- in the input stream. However, the relative ordering of elements from --- different streams in the resulting stream can vary depending on scheduling --- and generation delays. --- --- Similarly, the monad instance of 'AsyncT' /may/ run each iteration --- concurrently based on demand. More concurrent iterations are started only --- if the previous iterations are not able to produce enough output for the --- consumer. --- --- @ --- main = 'drain' . 'asyncly' $ do --- n <- return 3 \<\> return 2 \<\> return 1 --- S.yieldM $ do --- threadDelay (n * 1000000) --- myThreadId >>= \\tid -> putStrLn (show tid ++ ": Delay " ++ show n) --- @ --- @ --- ThreadId 40: Delay 1 --- ThreadId 39: Delay 2 --- ThreadId 38: Delay 3 --- @ --- --- @since 0.1.0 -newtype AsyncT m a = AsyncT {getAsyncT :: Stream m a} - deriving (MonadTrans) - --- | A demand driven left biased parallely composing IO stream of elements of --- type @a@. See 'AsyncT' documentation for more details. --- --- @since 0.2.0 -type Async = AsyncT IO - --- | Fix the type of a polymorphic stream as 'AsyncT'. --- --- @since 0.1.0 -asyncly :: IsStream t => AsyncT m a -> t m a -asyncly = adapt - -instance IsStream AsyncT where - toStream = getAsyncT - fromStream = AsyncT - 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 - (<>) = mappendAsync - ------------------------------------------------------------------------------- --- Monoid ------------------------------------------------------------------------------- - -instance MonadAsync m => Monoid (AsyncT m a) where - mempty = K.nil - mappend = (<>) - ------------------------------------------------------------------------------- --- Monad ------------------------------------------------------------------------------- - --- GHC: if we change the implementation of bindWith with arguments in a --- different order we see a significant performance degradation (~2x). -{-# 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) - --- GHC: if we specify arguments in the definition of (>>=) we see a significant --- performance degradation (~2x). -instance MonadAsync m => Monad (AsyncT m) where - return = pure - (>>=) = 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_COMMON_INSTANCES(AsyncT, MONADPARALLEL) - ------------------------------------------------------------------------------- --- WAsyncT ------------------------------------------------------------------------------- - --- | XXX we can implement it more efficienty by directly implementing instead --- of combining streams using wAsync. -{-# INLINE consMWAsync #-} -{-# 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. --- --- @since 0.2.0 -{-# INLINE wAsync #-} -wAsync :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a -wAsync = joinStreamVarAsync WAsyncVar - --- | The 'Semigroup' operation for 'WAsyncT' interleaves the elements from the --- two streams. Therefore, when @a <> b@ is evaluated, one action is picked --- from stream @a@ for evaluation and then the next action is picked from --- stream @b@ and then the next action is again picked from stream @a@, going --- around in a round-robin fashion. Many such actions are executed concurrently --- depending on 'maxThreads' and 'maxBuffer' limits. Results are served to the --- consumer in the order completion of the actions. --- --- Note that when multiple actions are combined like @a <> b <> c ... <> z@ we --- go in a round-robin fasion across all of them picking one action from each --- up to @z@ and then come back to @a@. Note that this operation cannot be --- used to fold a container of infinite streams as the state that it needs to --- maintain is proportional to the number of streams. --- --- @ --- import "Streamly" --- import qualified "Streamly.Prelude" as S --- import Control.Concurrent --- --- main = (S.toList . 'wAsyncly' $ (S.fromList [1,2]) \<> (S.fromList [3,4])) >>= print --- @ --- @ --- [1,3,2,4] --- @ --- --- Any exceptions generated by a constituent stream are propagated to the --- output stream. The output and exceptions from a single stream are guaranteed --- to arrive in the same order in the resulting stream as they were generated --- in the input stream. However, the relative ordering of elements from --- different streams in the resulting stream can vary depending on scheduling --- and generation delays. --- --- Similarly, the 'Monad' instance of 'WAsyncT' runs /all/ iterations fairly --- concurrently using a round robin scheduling. --- --- @ --- main = 'drain' . 'wAsyncly' $ do --- n <- return 3 \<\> return 2 \<\> return 1 --- S.yieldM $ do --- threadDelay (n * 1000000) --- myThreadId >>= \\tid -> putStrLn (show tid ++ ": Delay " ++ show n) --- @ --- @ --- ThreadId 40: Delay 1 --- ThreadId 39: Delay 2 --- ThreadId 38: Delay 3 --- @ --- --- @since 0.2.0 -newtype WAsyncT m a = WAsyncT {getWAsyncT :: Stream m a} - deriving (MonadTrans) - --- | A round robin parallely composing IO stream of elements of type @a@. --- See 'WAsyncT' documentation for more details. --- --- @since 0.2.0 -type WAsync = WAsyncT IO - --- | Fix the type of a polymorphic stream as 'WAsyncT'. --- --- @since 0.2.0 -wAsyncly :: IsStream t => WAsyncT m a -> t m a -wAsyncly = adapt - -instance IsStream WAsyncT where - toStream = getWAsyncT - fromStream = WAsyncT - 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 - (<>) = mappendWAsync - ------------------------------------------------------------------------------- --- Monoid ------------------------------------------------------------------------------- - -instance MonadAsync m => Monoid (WAsyncT m a) where - mempty = K.nil - mappend = (<>) - ------------------------------------------------------------------------------- --- Monad ------------------------------------------------------------------------------- - --- GHC: if we change the implementation of bindWith with arguments in a --- different order we see a significant performance degradation (~2x). -{-# 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) - --- GHC: if we specify arguments in the definition of (>>=) we see a significant --- performance degradation (~2x). -instance MonadAsync m => Monad (WAsyncT m) where - return = pure - (>>=) = 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_COMMON_INSTANCES(WAsyncT, MONADPARALLEL) diff --git a/src/Streamly/Streams/Combinators.hs b/src/Streamly/Streams/Combinators.hs deleted file mode 100644 --- a/src/Streamly/Streams/Combinators.hs +++ /dev/null @@ -1,217 +0,0 @@ -{-# LANGUAGE CPP #-} - -#include "inline.hs" - --- | --- Module : Streamly.Streams.Combinators --- Copyright : (c) 2017 Harendra Kumar --- --- License : BSD3 --- Maintainer : streamly@composewell.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.Internal.Data.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. 'maxThreads' does not affect --- 'ParallelT' streams as they can use unbounded number of threads. --- --- 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/Enumeration.hs b/src/Streamly/Streams/Enumeration.hs deleted file mode 100644 --- a/src/Streamly/Streams/Enumeration.hs +++ /dev/null @@ -1,550 +0,0 @@ -{-# LANGUAGE CPP #-} - --- | --- Module : Streamly.Streams.Enumeration --- Copyright : (c) 2018 Harendra Kumar --- --- License : BSD3 --- Maintainer : streamly@composewell.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.Streams.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.Streams.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/Streams/Instances.hs b/src/Streamly/Streams/Instances.hs deleted file mode 100644 --- a/src/Streamly/Streams/Instances.hs +++ /dev/null @@ -1,134 +0,0 @@ ------------------------------------------------------------------------------- --- CPP macros for common instances ------------------------------------------------------------------------------- - --- XXX use template haskell instead and include Monoid and IsStream instances --- as well. - -#define MONADPARALLEL , MonadAsync m - -#define MONAD_APPLICATIVE_INSTANCE(STREAM,CONSTRAINT) \ -instance (Monad m CONSTRAINT) => Applicative (STREAM m) where { \ - {-# INLINE pure #-}; \ - pure = STREAM . K.yield; \ - {-# INLINE (<*>) #-}; \ - (<*>) = ap } - -#define MONAD_COMMON_INSTANCES(STREAM,CONSTRAINT) \ -instance Monad m => Functor (STREAM m) where { \ - fmap = map }; \ - \ -instance (MonadBase b m, Monad m CONSTRAINT) => MonadBase b (STREAM m) where {\ - liftBase = liftBaseDefault }; \ - \ -instance (MonadIO m CONSTRAINT) => MonadIO (STREAM m) where { \ - liftIO = lift . liftIO }; \ - \ -instance (MonadThrow m CONSTRAINT) => MonadThrow (STREAM m) where { \ - throwM = lift . throwM }; \ - \ -{- \ -instance (MonadError e m CONSTRAINT) => MonadError e (STREAM m) where { \ - throwError = lift . throwError; \ - catchError m h = \ - fromStream $ withCatchError (toStream m) (\e -> toStream $ h e) }; \ --} \ - \ -instance (MonadReader r m CONSTRAINT) => MonadReader r (STREAM m) where { \ - ask = lift ask; \ - local f m = fromStream $ K.withLocal f (toStream m) }; \ - \ -instance (MonadState s m CONSTRAINT) => MonadState s (STREAM m) where { \ - get = lift get; \ - put x = lift (put x); \ - state k = lift (state k) } - ------------------------------------------------------------------------------- --- 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? - -#if MIN_VERSION_deepseq(1,4,3) -#define NFDATA1_INSTANCE(STREAM) \ -instance NFData1 (STREAM Identity) where { \ - {-# INLINE liftRnf #-}; \ - liftRnf r = runIdentity . P.foldl' (\_ x -> r x) () } -#else -#define NFDATA1_INSTANCE(STREAM) -#endif - -#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 { \ - {-# INLINE rnf #-}; \ - rnf = runIdentity . P.foldl' (\_ x -> rnf x) () }; \ - -------------------------------------------------------------------------------- --- Foldable -------------------------------------------------------------------------------- - --- XXX the foldable instance seems to be quit slow. We can try writing --- custom implementations of foldr and foldl'. If nothing works we can also try --- writing a Foldable for Identity monad rather than for "Foldable m". -#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 deleted file mode 100644 --- a/src/Streamly/Streams/Parallel.hs +++ /dev/null @@ -1,511 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving#-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -- XXX - --- | --- Module : Streamly.Streams.Parallel --- Copyright : (c) 2017 Harendra Kumar --- --- License : BSD3 --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- --- -module Streamly.Streams.Parallel - ( - ParallelT - , Parallel - , parallely - , parallel - , parallelFst - , parallelMin - , tapAsync - - -- * Function application - , mkParallel - , (|$) - , (|&) - , (|$.) - , (|&.) - ) -where - -import Control.Concurrent (myThreadId) -import Control.Exception (SomeException(..), throwIO) -import Control.Monad (ap) -import Control.Monad.Base (MonadBase(..), liftBaseDefault) -import Control.Monad.Catch (MonadThrow, throwM) --- import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.Reader.Class (MonadReader(..)) -import Control.Monad.State.Class (MonadState(..)) -import Control.Monad.Trans.Class (MonadTrans(lift)) -import Data.Functor (void) -import Data.IORef (readIORef, writeIORef) -import Data.Maybe (fromJust) -#if __GLASGOW_HASKELL__ < 808 -import Data.Semigroup (Semigroup(..)) -#endif -import Prelude hiding (map) - -import qualified Data.Set as Set - -import Streamly.Streams.SVar (fromSVar, fromStreamVar) -import Streamly.Streams.Serial (map) -import Streamly.Internal.Data.SVar -import Streamly.Streams.StreamK (IsStream(..), Stream, mkStream, foldStream, - foldStreamShared, adapt) -import qualified Streamly.Streams.StreamK as K - -#include "Instances.hs" - -------------------------------------------------------------------------------- --- Parallel -------------------------------------------------------------------------------- - -{-# NOINLINE runOne #-} -runOne - :: MonadIO m - => State Stream m a -> Stream m a -> Maybe WorkerInfo -> m () -runOne st m0 winfo = - case getYieldLimit st of - Nothing -> go m0 - Just _ -> runOneLimited st m0 winfo - - where - - go m = do - liftIO $ decrementBufferLimit sv - foldStreamShared st yieldk single stop m - - sv = fromJust $ streamVar st - - stop = liftIO $ do - incrementBufferLimit sv - sendStop sv winfo - sendit a = liftIO $ void $ send sv (ChildYield a) - single a = sendit a >> (liftIO $ sendStop sv winfo) - yieldk a r = sendit a >> go r - -runOneLimited - :: MonadIO m - => State Stream m a -> Stream m a -> Maybe WorkerInfo -> m () -runOneLimited st m0 winfo = go m0 - - where - - go m = do - yieldLimitOk <- liftIO $ decrementYieldLimit sv - if yieldLimitOk - then do - liftIO $ decrementBufferLimit sv - foldStreamShared st yieldk single stop m - else do - liftIO $ cleanupSVarFromWorker sv - liftIO $ sendStop sv winfo - - sv = fromJust $ streamVar st - - stop = liftIO $ do - incrementBufferLimit sv - incrementYieldLimit sv - sendStop sv winfo - sendit a = liftIO $ void $ send sv (ChildYield a) - single a = sendit a >> (liftIO $ sendStop sv winfo) - yieldk a r = sendit a >> go r - -{-# NOINLINE forkSVarPar #-} -forkSVarPar :: (IsStream t, MonadAsync m) - => SVarStopStyle -> t m a -> t m a -> t m a -forkSVarPar ss m r = mkStream $ \st yld sng stp -> do - sv <- newParallelVar ss st - pushWorkerPar sv (runOne st{streamVar = Just sv} $ toStream m) - case ss of - StopBy -> liftIO $ do - set <- readIORef (workerThreads sv) - writeIORef (svarStopBy sv) $ Set.elemAt 0 set - _ -> return () - pushWorkerPar sv (runOne st{streamVar = Just sv} $ toStream r) - foldStream st yld sng stp (fromSVar sv) - -{-# INLINE joinStreamVarPar #-} -joinStreamVarPar :: (IsStream t, MonadAsync m) - => SVarStyle -> SVarStopStyle -> t m a -> t m a -> t m a -joinStreamVarPar style ss m1 m2 = mkStream $ \st yld sng stp -> - case streamVar st of - Just sv | svarStyle sv == style && svarStopStyle sv == ss -> do - pushWorkerPar sv (runOne st $ toStream m1) - foldStreamShared st yld sng stp m2 - _ -> foldStreamShared st yld sng stp (forkSVarPar ss m1 m2) - --- | XXX we can implement it more efficienty by directly implementing instead --- of combining streams using parallel. -{-# INLINE consMParallel #-} -{-# 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. --- --- @since 0.2.0 -{-# INLINE parallel #-} -parallel :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a -parallel = joinStreamVarPar ParallelVar StopNone - --- This is a co-parallel like combinator for streams, where first stream is the --- main stream and the rest are just supporting it, when the first ends --- everything ends. --- --- | Like `parallel` but stops the output as soon as the first stream stops. --- --- @since 0.7.0 -{-# INLINE parallelFst #-} -parallelFst :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a -parallelFst = joinStreamVarPar ParallelVar StopBy - --- This is a race like combinator for streams. --- --- | Like `parallel` but stops the output as soon as any of the two streams --- stops. --- --- @since 0.7.0 -{-# INLINE parallelMin #-} -parallelMin :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a -parallelMin = joinStreamVarPar ParallelVar StopAny - ------------------------------------------------------------------------------- --- Convert a stream to parallel ------------------------------------------------------------------------------- - -mkParallel :: (IsStream t, MonadAsync m) => t m a -> m (t m a) -mkParallel m = do - sv <- newParallelVar StopNone defState - pushWorkerPar sv (runOne defState{streamVar = Just sv} $ toStream m) - return $ fromSVar sv - ------------------------------------------------------------------------------- --- Stream to stream concurrent function application ------------------------------------------------------------------------------- - -{-# INLINE applyParallel #-} -applyParallel :: (IsStream t, MonadAsync m) => (t m a -> t m b) -> t m a -> t m b -applyParallel f m = mkStream $ \st yld sng stp -> do - sv <- newParallelVar StopNone (adaptState st) - pushWorkerPar sv (runOne st{streamVar = Just sv} (toStream m)) - foldStream st yld sng stp $ f $ fromSVar sv - ------------------------------------------------------------------------------- --- Stream runner concurrent function application ------------------------------------------------------------------------------- - -{-# INLINE foldParallel #-} -foldParallel :: (IsStream t, MonadAsync m) => (t m a -> m b) -> t m a -> m b -foldParallel f m = do - sv <- newParallelVar StopNone defState - pushWorkerPar sv (runOne defState{streamVar = Just sv} $ toStream m) - f $ fromSVar sv - -{-# INLINE teeToSVar #-} -teeToSVar :: (IsStream t, MonadAsync m) => SVar Stream m a -> t m a -> t m a -teeToSVar svr m = mkStream $ \st yld sng stp -> do - foldStreamShared st yld sng stp (go svr m) - - where - - go sv m0 = mkStream $ \st yld sng stp -> do - let stop = do - liftIO $ do - incrementBufferLimit sv - sendStop sv Nothing - -- XXX wait for Stop response event on exception channel, - -- drain the exception channel. - stp - sendit a = liftIO $ do - -- XXX check for exceptions before decrement so that we do not - -- block forever if the child already exited with an exception. - decrementBufferLimit sv - void $ send sv (ChildYield a) - single a = sendit a >> (liftIO $ sendStop sv Nothing) >> sng a - yieldk a r = sendit a >> yld a (go sv r) - in foldStreamShared st yieldk single stop m0 - --- In case of folds the roles of worker and parent on an SVar are reversed. The --- parent stream pushes values to an SVar instead of pulling from it and a --- worker thread running the fold pulls from the SVar and folds the stream. We --- keep a separate channel for pushing exceptions in the reverse direction i.e. --- from the fold to the parent stream. --- --- NOTE: If we use fromSVar here it will kill the main computation (the parent) --- when the SVar goes away so we use fromStreamVar instead. - -{-# NOINLINE handleChildException #-} -handleChildException :: SVar t m a -> SomeException -> IO () -handleChildException _sv e = do - -- tid <- myThreadId - -- void $ sendReverse sv (ChildStop tid (Just e)) - throwIO e - --- | Redirect a copy of the stream to a supplied fold and run it concurrently --- in an independent thread. The fold may buffer some elements. The buffer size --- is determined by the prevailing 'maxBuffer' setting. --- --- @ --- Stream m a -> m b --- | --- -----stream m a ---------------stream m a----- --- --- @ --- --- @ --- > S.drain $ S.tapAsync (S.mapM_ print) (S.enumerateFromTo 1 2) --- 1 --- 2 --- @ --- --- Exceptions from the concurrently running fold are propagated to the current --- computation. Note that, because of buffering in the fold, exceptions may be --- delayed and may not correspond to the current element being processed in the --- parent stream, but we guarantee that the tap finishes and all exceptions --- from it are drained before the parent stream stops. --- --- --- Compare with 'tap'. --- --- @since 0.7.0 -{-# INLINE tapAsync #-} -tapAsync :: (IsStream t, MonadAsync m) => (t m a -> m b) -> t m a -> t m a -tapAsync f m = mkStream $ \st yld sng stp -> do - -- Buffer size for the SVar is derived from the current state - sv <- newParallelVar StopNone (adaptState st) - -- XXX exception handling - -- XXX if we terminate due to an exception, do we need to actively - -- terminate the fold? - liftIO myThreadId >>= modifyThread sv - void $ doFork (void $ f $ fromStream $ fromStreamVar sv) - (svarMrun sv) (handleChildException sv) - foldStreamShared st yld sng stp (teeToSVar sv m) - ------------------------------------------------------------------------------- --- Concurrent Application ------------------------------------------------------------------------------- - -infixr 0 |$ -infixr 0 |$. - -infixl 1 |& -infixl 1 |&. - --- | Parallel function application operator for streams; just like the regular --- function application operator '$' except that it is concurrent. The --- following code prints a value every second even though each stage adds a 1 --- second delay. --- --- --- @ --- drain $ --- S.mapM (\\x -> threadDelay 1000000 >> print x) --- |$ S.repeatM (threadDelay 1000000 >> return 1) --- @ --- --- /Concurrent/ --- --- @since 0.3.0 -{-# INLINE (|$) #-} -(|$) :: (IsStream t, MonadAsync m) => (t m a -> t m b) -> t m a -> t m b -f |$ x = applyParallel f x - --- | Parallel reverse function application operator for streams; just like the --- regular reverse function application operator '&' except that it is --- concurrent. --- --- @ --- drain $ --- S.repeatM (threadDelay 1000000 >> return 1) --- |& S.mapM (\\x -> threadDelay 1000000 >> print x) --- @ --- --- /Concurrent/ --- --- @since 0.3.0 -{-# INLINE (|&) #-} -(|&) :: (IsStream t, MonadAsync m) => t m a -> (t m a -> t m b) -> t m b -x |& f = f |$ x - --- | Parallel function application operator; applies a @run@ or @fold@ function --- to a stream such that the fold consumer and the stream producer run in --- parallel. A @run@ or @fold@ function reduces the stream to a value in the --- underlying monad. The @.@ at the end of the operator is a mnemonic for --- termination of the stream. --- --- @ --- S.foldlM' (\\_ a -> threadDelay 1000000 >> print a) () --- |$. S.repeatM (threadDelay 1000000 >> return 1) --- @ --- --- /Concurrent/ --- --- @since 0.3.0 -{-# INLINE (|$.) #-} -(|$.) :: (IsStream t, MonadAsync m) => (t m a -> m b) -> t m a -> m b -f |$. x = foldParallel f x - --- | Parallel reverse function application operator for applying a run or fold --- functions to a stream. Just like '|$.' except that the operands are reversed. --- --- @ --- S.repeatM (threadDelay 1000000 >> return 1) --- |&. S.foldlM' (\\_ a -> threadDelay 1000000 >> print a) () --- @ --- --- /Concurrent/ --- --- @since 0.3.0 -{-# INLINE (|&.) #-} -(|&.) :: (IsStream t, MonadAsync m) => t m a -> (t m a -> m b) -> m b -x |&. f = f |$. x - ------------------------------------------------------------------------------- --- ParallelT ------------------------------------------------------------------------------- - --- | Async composition with strict concurrent execution of all streams. --- --- The 'Semigroup' instance of 'ParallelT' executes both the streams --- concurrently without any delay or without waiting for the consumer demand --- and /merges/ the results as they arrive. If the consumer does not consume --- the results, they are buffered upto a configured maximum, controlled by the --- 'maxBuffer' primitive. If the buffer becomes full the concurrent tasks will --- block until there is space in the buffer. --- --- Both 'WAsyncT' and 'ParallelT', evaluate the constituent streams fairly in a --- round robin fashion. The key difference is that 'WAsyncT' might wait for the --- consumer demand before it executes the tasks whereas 'ParallelT' starts --- executing all the tasks immediately without waiting for the consumer demand. --- For 'WAsyncT' the 'maxThreads' limit applies whereas for 'ParallelT' it does --- not apply. In other words, 'WAsyncT' can be lazy whereas 'ParallelT' is --- strict. --- --- 'ParallelT' is useful for cases when the streams are required to be --- evaluated simultaneously irrespective of how the consumer consumes them e.g. --- when we want to race two tasks and want to start both strictly at the same --- time or if we have timers in the parallel tasks and our results depend on --- the timers being started at the same time. If we do not have such --- requirements then 'AsyncT' or 'AheadT' are recommended as they can be more --- efficient than 'ParallelT'. --- --- @ --- main = ('toList' . 'parallely' $ (fromFoldable [1,2]) \<> (fromFoldable [3,4])) >>= print --- @ --- @ --- [1,3,2,4] --- @ --- --- When streams with more than one element are merged, it yields whichever --- stream yields first without any bias, unlike the 'Async' style streams. --- --- Any exceptions generated by a constituent stream are propagated to the --- output stream. The output and exceptions from a single stream are guaranteed --- to arrive in the same order in the resulting stream as they were generated --- in the input stream. However, the relative ordering of elements from --- different streams in the resulting stream can vary depending on scheduling --- and generation delays. --- --- Similarly, the 'Monad' instance of 'ParallelT' runs /all/ iterations --- of the loop concurrently. --- --- @ --- import "Streamly" --- import qualified "Streamly.Prelude" as S --- import Control.Concurrent --- --- main = 'drain' . 'parallely' $ do --- n <- return 3 \<\> return 2 \<\> return 1 --- S.yieldM $ do --- threadDelay (n * 1000000) --- myThreadId >>= \\tid -> putStrLn (show tid ++ ": Delay " ++ show n) --- @ --- @ --- ThreadId 40: Delay 1 --- ThreadId 39: Delay 2 --- ThreadId 38: Delay 3 --- @ --- --- Note that parallel composition can only combine a finite number of --- streams as it needs to retain state for each unfinished stream. --- --- /Since: 0.7.0 (maxBuffer applies to ParallelT streams)/ --- --- /Since: 0.1.0/ -newtype ParallelT m a = ParallelT {getParallelT :: Stream m a} - deriving (MonadTrans) - --- | A parallely composing IO stream of elements of type @a@. --- See 'ParallelT' documentation for more details. --- --- @since 0.2.0 -type Parallel = ParallelT IO - --- | Fix the type of a polymorphic stream as 'ParallelT'. --- --- @since 0.1.0 -parallely :: IsStream t => ParallelT m a -> t m a -parallely = adapt - -instance IsStream ParallelT where - toStream = getParallelT - fromStream = ParallelT - - {-# INLINE consM #-} - {-# SPECIALIZE consM :: IO a -> ParallelT IO a -> ParallelT IO a #-} - consM = consMParallel - - {-# INLINE (|:) #-} - {-# SPECIALIZE (|:) :: IO a -> ParallelT IO a -> ParallelT IO a #-} - (|:) = consM - ------------------------------------------------------------------------------- --- 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 - (<>) = mappendParallel - ------------------------------------------------------------------------------- --- Monoid ------------------------------------------------------------------------------- - -instance MonadAsync m => Monoid (ParallelT m a) where - mempty = K.nil - mappend = (<>) - ------------------------------------------------------------------------------- --- 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 - (>>=) = bindParallel - ------------------------------------------------------------------------------- --- Other instances ------------------------------------------------------------------------------- - -MONAD_APPLICATIVE_INSTANCE(ParallelT,MONADPARALLEL) -MONAD_COMMON_INSTANCES(ParallelT, MONADPARALLEL) diff --git a/src/Streamly/Streams/Prelude.hs b/src/Streamly/Streams/Prelude.hs deleted file mode 100644 --- a/src/Streamly/Streams/Prelude.hs +++ /dev/null @@ -1,327 +0,0 @@ -{-# LANGUAGE CPP #-} - -#if __GLASGOW_HASKELL__ >= 800 -{-# OPTIONS_GHC -Wno-orphans #-} -#endif - -#include "inline.hs" - --- | --- Module : Streamly.Streams.Prelude --- Copyright : (c) 2017 Harendra Kumar --- --- License : BSD3 --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- --- -module Streamly.Streams.Prelude - ( - -- * Stream Conversion - fromStreamS - , toStreamS - - -- * Running Effects - , drain - - -- * Conversion operations - , fromList - , toList - - -- * Fold operations - , foldrM - , foldrMx - , foldr - - , foldlx' - , foldlMx' - , foldl' - , runFold - - -- Lazy left folds are useful only for reversing the stream - , foldlS - , foldlT - - , scanlx' - , scanlMx' - , postscanlx' - , postscanlMx' - - -- * Zip style operations - , eqBy - , cmpBy - - -- * Nesting - , K.concatMapBy - , K.concatMap - - -- * Fold Utilities - , foldWith - , foldMapWith - , forEachWith - ) -where - -import Control.Monad.Trans (MonadTrans(..)) -import Prelude hiding (foldr) -import qualified Prelude - -import Streamly.Internal.Data.Fold.Types (Fold (..)) - -#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 drain #-} -drain :: (IsStream t, Monad m) => t m a -> m () -drain m = D.drain $ D.fromStreamK (toStream m) -{-# RULES "drain fallback to CPS" [1] - forall a. D.drain (D.fromStreamK a) = K.drain 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 -> m b -> m b) -> m b -> t m a -> m b -foldrM step acc m = S.foldrM step acc $ toStreamS m - -{-# INLINE foldrMx #-} -foldrMx :: (Monad m, IsStream t) - => (a -> m x -> m x) -> m x -> (m x -> m b) -> t m a -> m b -foldrMx step final project m = D.foldrMx step final project $ D.toStreamD m - -{-# INLINE foldr #-} -foldr :: (Monad m, IsStream t) => (a -> b -> b) -> b -> t m a -> m b -foldr f z = foldrM (\a b -> b >>= return . f a) (return z) - --- | Like 'foldlx'', but with a monadic step function. --- --- @since 0.7.0 -{-# INLINE foldlMx' #-} -foldlMx' :: (IsStream t, Monad m) - => (x -> a -> m x) -> m x -> (x -> m b) -> t m a -> m b -foldlMx' step begin done m = S.foldlMx' step begin done $ toStreamS m - --- | 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.7.0 -{-# INLINE foldlx' #-} -foldlx' :: (IsStream t, Monad m) - => (x -> a -> x) -> x -> (x -> b) -> t m a -> m b -foldlx' step begin done m = S.foldlx' step begin done $ toStreamS m - --- | 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 - -{-# INLINE foldlS #-} -foldlS :: IsStream t => (t m b -> a -> t m b) -> t m b -> t m a -> t m b -foldlS = K.foldlS - --- | Lazy left fold to a transformer monad. --- --- For example, to reverse a stream: --- --- > S.toList $ S.foldlT (flip S.cons) S.nil $ (S.fromList [1..5] :: SerialT IO Int) --- -{-# INLINE foldlT #-} -foldlT :: (Monad m, IsStream t, Monad (s m), MonadTrans s) - => (s m b -> a -> s m b) -> s m b -> t m a -> s m b -foldlT f z s = S.foldlT f z (toStreamS s) - -{-# INLINE runFold #-} -runFold :: (Monad m, IsStream t) => Fold m a b -> t m a -> m b -runFold (Fold step begin done) = foldlMx' step begin done - ------------------------------------------------------------------------------- --- Scans ------------------------------------------------------------------------------- - --- postscanlM' followed by mapM -{-# INLINE postscanlMx' #-} -postscanlMx' :: (IsStream t, Monad m) - => (x -> a -> m x) -> m x -> (x -> m b) -> t m a -> t m b -postscanlMx' step begin done m = - D.fromStreamD $ D.postscanlMx' step begin done $ D.toStreamD m - --- postscanl' followed by map -{-# INLINE postscanlx' #-} -postscanlx' :: (IsStream t, Monad m) - => (x -> a -> x) -> x -> (x -> b) -> t m a -> t m b -postscanlx' step begin done m = - D.fromStreamD $ D.postscanlx' step begin done $ D.toStreamD m - --- scanlM' followed by mapM --- -{-# INLINE scanlMx' #-} -scanlMx' :: (IsStream t, Monad m) - => (x -> a -> m x) -> m x -> (x -> m b) -> t m a -> t m b -scanlMx' step begin done m = - D.fromStreamD $ D.scanlMx' step begin done $ D.toStreamD m - --- scanl followed by map --- --- | 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.7.0 -{-# INLINE scanlx' #-} -scanlx' :: (IsStream t, Monad m) - => (x -> a -> x) -> x -> (x -> b) -> t m a -> t m b -scanlx' step begin done m = - fromStreamS $ S.scanlx' step begin done $ 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 ------------------------------------------------------------------------------- - -{- --- XXX do we have facilities in Foldable to fold any Foldable in this manner? --- --- | Perform a pair wise bottom up hierarchical fold of elements in the --- container using the given function as the merge function. --- --- This will perform a balanced merge sort if the merge function is --- 'mergeBy compare'. --- --- @since 0.7.0 -{-# INLINABLE foldbWith #-} -foldbWith :: IsStream t - => (t m a -> t m a -> t m a) -> SerialT Identity (t m a) -> t m a -foldbWith f = K.foldb f K.nil --} - --- /Since: 0.7.0 ("Streamly.Prelude")/ --- --- | A variant of 'Data.Foldable.fold' that allows you to fold a 'Foldable' --- container of streams using the specified stream sum operation. --- --- @foldWith 'async' $ map return [1..3]@ --- --- Equivalent to: --- --- @ --- foldWith f = S.foldMapWith f id --- @ --- --- /Since: 0.1.0 ("Streamly")/ -{-# 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 = Prelude.foldr f K.nil - --- /Since: 0.7.0 ("Streamly.Prelude")/ --- --- | 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 merge --- operation. --- --- @foldMapWith 'async' return [1..3]@ --- --- Equivalent to: --- --- @ --- foldMapWith f g xs = S.concatMapWith f g (S.fromFoldable xs) --- @ --- --- /Since: 0.1.0 ("Streamly")/ -{-# 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 = Prelude.foldr (f . g) K.nil - --- /Since: 0.7.0 ("Streamly.Prelude")/ --- --- | Like 'foldMapWith' but with the last two arguments reversed i.e. the --- monadic streaming function is the last argument. --- --- Equivalent to: --- --- @ --- forEachWith = flip S.foldMapWith --- @ --- --- /Since: 0.1.0 ("Streamly")/ -{-# 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 = Prelude.foldr (f . g) K.nil xs diff --git a/src/Streamly/Streams/SVar.hs b/src/Streamly/Streams/SVar.hs deleted file mode 100644 --- a/src/Streamly/Streams/SVar.hs +++ /dev/null @@ -1,119 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} - --- | --- Module : Streamly.Streams.SVar --- Copyright : (c) 2017 Harendra Kumar --- --- License : BSD3 --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- --- -module Streamly.Streams.SVar - ( fromSVar - , fromStreamVar - , toSVar - ) -where - -import Control.Exception (fromException) -import Control.Monad (when) -import Control.Monad.Catch (throwM) -import Control.Monad.IO.Class (MonadIO(liftIO)) -import Data.IORef (newIORef, readIORef, mkWeakIORef, writeIORef) -import Data.Maybe (isNothing) -#if __GLASGOW_HASKELL__ < 808 -import Data.Semigroup ((<>)) -#endif -import System.IO (hPutStrLn, stderr) -import Streamly.Internal.Data.Time.Clock (Clock(Monotonic), getTime) -import System.Mem (performMajorGC) - -import Streamly.Internal.Data.SVar -import Streamly.Streams.StreamK hiding (reverse) - -printSVar :: SVar t m a -> String -> IO () -printSVar sv how = do - svInfo <- dumpSVar sv - hPutStrLn stderr $ "\n" <> how <> "\n" <> svInfo - --- | Pull a stream from an SVar. -{-# NOINLINE fromStreamVar #-} -fromStreamVar :: MonadAsync m => SVar Stream m a -> Stream m a -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. - foldStream st yld sng stp $ processEvents $ reverse list - - where - - allDone stp = do - when (svarInspectMode sv) $ do - t <- liftIO $ getTime Monotonic - liftIO $ writeIORef (svarStopTime (svarStats sv)) (Just t) - liftIO $ printSVar sv "SVar Done" - stp - - {-# INLINE processEvents #-} - processEvents [] = mkStream $ \st yld sng stp -> do - done <- postProcess sv - if done - then allDone stp - else foldStream st yld sng stp $ fromStreamVar sv - - 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 -> do - stop <- shouldStop tid - if stop - then liftIO (cleanupSVar sv) >> allDone stp - else foldStream st yld sng stp rest - Just ex -> - case fromException ex of - Just ThreadAbort -> - foldStream st yld sng stp rest - Nothing -> liftIO (cleanupSVar sv) >> throwM ex - shouldStop tid = - case svarStopStyle sv of - StopNone -> return False - StopAny -> return True - StopBy -> do - sid <- liftIO $ readIORef (svarStopBy sv) - return $ if tid == sid then True else False - -{-# INLINE fromSVar #-} -fromSVar :: (MonadAsync m, IsStream t) => SVar Stream m a -> t m a -fromSVar sv = - 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. - foldStreamShared st yld sng stp $ - fromStream $ fromStreamVar sv{svarRef = Just ref} - where - - hook = do - when (svarInspectMode sv) $ do - r <- liftIO $ readIORef (svarStopTime (svarStats sv)) - when (isNothing r) $ - printSVar sv "SVar Garbage Collected" - cleanupSVar sv - -- If there are any SVars referenced by this SVar a GC will prompt - -- them to be cleaned up quickly. - when (svarInspectMode sv) performMajorGC - --- | Write a stream to an 'SVar' in a non-blocking manner. The stream can then --- 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) diff --git a/src/Streamly/Streams/Serial.hs b/src/Streamly/Streams/Serial.hs deleted file mode 100644 --- a/src/Streamly/Streams/Serial.hs +++ /dev/null @@ -1,399 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving#-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -- XXX - --- | --- Module : Streamly.Streams.Serial --- Copyright : (c) 2017 Harendra Kumar --- --- License : BSD3 --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- --- -module Streamly.Streams.Serial - ( - -- * Serial appending stream - SerialT - , StreamT -- deprecated - , Serial - , K.serial - , serially - - -- * Serial interleaving stream - , WSerialT - , InterleavedT -- deprecated - , WSerial - , wSerial - , wSerialFst - , wSerialMin - , (<=>) -- deprecated - , wSerially - , interleaving -- deprecated - - -- * Transformation - , map - , mapM - ) -where - -import Control.Applicative (liftA2) -import Control.DeepSeq (NFData(..)) -#if MIN_VERSION_deepseq(1,4,3) -import Control.DeepSeq (NFData1(..)) -#endif -import Control.Monad (ap) -import Control.Monad.Base (MonadBase(..), liftBaseDefault) -import Control.Monad.Catch (MonadThrow, throwM) --- import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.Reader.Class (MonadReader(..)) -import Control.Monad.State.Class (MonadState(..)) -import Control.Monad.Trans.Class (MonadTrans(lift)) -import Data.Functor.Identity (Identity(..), runIdentity) -import Data.Foldable (fold) -#if __GLASGOW_HASKELL__ < 808 -import Data.Semigroup (Semigroup(..)) -#endif -import GHC.Exts (IsList(..), IsString(..)) -import Text.Read (Lexeme(Ident), lexP, parens, prec, readPrec, readListPrec, - readListPrecDefault) -import Prelude hiding (map, mapM) - -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.hs" - ------------------------------------------------------------------------------- --- SerialT ------------------------------------------------------------------------------- - --- | The 'Semigroup' operation for 'SerialT' behaves like a regular append --- operation. Therefore, when @a <> b@ is evaluated, stream @a@ is evaluated --- first until it exhausts and then stream @b@ is evaluated. In other words, --- the elements of stream @b@ are appended to the elements of stream @a@. This --- operation can be used to fold an infinite lazy container of streams. --- --- @ --- import Streamly --- import qualified "Streamly.Prelude" as S --- --- main = (S.toList . 'serially' $ (S.fromList [1,2]) \<\> (S.fromList [3,4])) >>= print --- @ --- @ --- [1,2,3,4] --- @ --- --- The 'Monad' instance runs the /monadic continuation/ for each --- element of the stream, serially. --- --- @ --- main = S.drain . 'serially' $ do --- x <- return 1 \<\> return 2 --- S.yieldM $ print x --- @ --- @ --- 1 --- 2 --- @ --- --- 'SerialT' nests streams serially in a depth first manner. --- --- @ --- main = S.drain . 'serially' $ do --- x <- return 1 \<\> return 2 --- y <- return 3 \<\> return 4 --- S.yieldM $ print (x, y) --- @ --- @ --- (1,3) --- (1,4) --- (2,3) --- (2,4) --- @ --- --- We call the monadic code being run for each element of the stream a monadic --- continuation. In imperative paradigm we can think of this composition as --- nested @for@ loops and the monadic continuation is the body of the loop. The --- loop iterates for all elements of the stream. --- --- Note that the behavior and semantics of 'SerialT', including 'Semigroup' --- and 'Monad' instances are exactly like Haskell lists except that 'SerialT' --- can contain effectful actions while lists are pure. --- --- In the code above, the 'serially' combinator can be omitted as the default --- stream type is 'SerialT'. --- --- @since 0.2.0 -newtype SerialT m a = SerialT {getSerialT :: Stream m a} - deriving (Semigroup, Monoid, MonadTrans) - --- | A serial IO stream of elements of type @a@. See 'SerialT' documentation --- for more details. --- --- @since 0.2.0 -type Serial = SerialT IO - --- | --- @since 0.1.0 -{-# DEPRECATED StreamT "Please use 'SerialT' instead." #-} -type StreamT = SerialT - --- | Fix the type of a polymorphic stream as 'SerialT'. --- --- @since 0.1.0 -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 - consM = consMSerial - (|:) = consMSerial - ------------------------------------------------------------------------------- --- Monad ------------------------------------------------------------------------------- - -instance Monad m => Monad (SerialT m) where - return = pure - {-# INLINE (>>=) #-} - (>>=) = K.bindWith K.serial - - -- StreamD based implementation - -- return = SerialT . D.fromStreamD . D.yield - -- m >>= f = D.fromStreamD $ D.concatMap (\a -> D.toStreamD (f a)) (D.toStreamD m) - ------------------------------------------------------------------------------- --- Other instances ------------------------------------------------------------------------------- - -{-# INLINE_EARLY mapM #-} -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) - --- | --- @ --- 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 -map f = mapM (return . f) - -MONAD_APPLICATIVE_INSTANCE(SerialT,) -MONAD_COMMON_INSTANCES(SerialT,) -LIST_INSTANCES(SerialT) -NFDATA1_INSTANCE(SerialT) -FOLDABLE_INSTANCE(SerialT) -TRAVERSABLE_INSTANCE(SerialT) - ------------------------------------------------------------------------------- --- WSerialT ------------------------------------------------------------------------------- - --- | The 'Semigroup' operation for 'WSerialT' interleaves the elements from the --- two streams. Therefore, when @a <> b@ is evaluated, stream @a@ is evaluated --- first to produce the first element of the combined stream and then stream --- @b@ is evaluated to produce the next element of the combined stream, and --- then we go back to evaluating stream @a@ and so on. In other words, the --- elements of stream @a@ are interleaved with the elements of stream @b@. --- --- Note that when multiple actions are combined like @a <> b <> c ... <> z@ we --- interleave them in a binary fashion i.e. @a@ and @b@ are interleaved with --- each other and the result is interleaved with @c@ and so on. This will not --- act as a true round-robin scheduling across all the streams. Note that this --- operation cannot be used to fold a container of infinite streams as the --- state that it needs to maintain is proportional to the number of streams. --- --- @ --- import Streamly --- import qualified "Streamly.Prelude" as S --- --- main = (S.toList . 'wSerially' $ (S.fromList [1,2]) \<\> (S.fromList [3,4])) >>= print --- @ --- @ --- [1,3,2,4] --- @ --- --- Similarly, the 'Monad' instance interleaves the iterations of the --- inner and the outer loop, nesting loops in a breadth first manner. --- --- --- @ --- main = S.drain . 'wSerially' $ do --- x <- return 1 \<\> return 2 --- y <- return 3 \<\> return 4 --- S.yieldM $ print (x, y) --- @ --- @ --- (1,3) --- (2,3) --- (1,4) --- (2,4) --- @ --- --- @since 0.2.0 -newtype WSerialT m a = WSerialT {getWSerialT :: Stream m a} - deriving (MonadTrans) - --- | An interleaving serial IO stream of elements of type @a@. See 'WSerialT' --- documentation for more details. --- --- @since 0.2.0 -type WSerial = WSerialT IO - --- | --- @since 0.1.0 -{-# DEPRECATED InterleavedT "Please use 'WSerialT' instead." #-} -type InterleavedT = WSerialT - --- | Fix the type of a polymorphic stream as 'WSerialT'. --- --- @since 0.2.0 -wSerially :: IsStream t => WSerialT m a -> t m a -wSerially = adapt - --- | Same as 'wSerially'. --- --- @since 0.1.0 -{-# DEPRECATED interleaving "Please use wSerially instead." #-} -interleaving :: IsStream t => WSerialT m a -> t m a -interleaving = wSerially - -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 - - {-# INLINE consM #-} - {-# SPECIALIZE consM :: IO a -> WSerialT IO a -> WSerialT IO a #-} - consM :: Monad m => m a -> WSerialT m a -> WSerialT m a - consM = consMWSerial - - {-# INLINE (|:) #-} - {-# SPECIALIZE (|:) :: IO a -> WSerialT IO a -> WSerialT IO a #-} - (|:) :: Monad m => m a -> WSerialT m a -> WSerialT m a - (|:) = consMWSerial - ------------------------------------------------------------------------------- --- Semigroup ------------------------------------------------------------------------------- - --- Additionally we can have m elements yield from the first stream and n --- elements yeilding from the second stream. We can also have time slicing --- variants of positional interleaving, e.g. run first stream for m seconds and --- run the second stream for n seconds. --- --- Similar combinators can be implemented using WAhead style. - --- | Polymorphic version of the 'Semigroup' operation '<>' of 'WSerialT'. --- Interleaves two streams, yielding one element from each stream alternately. --- When one stream stops the rest of the other stream is used in the output --- stream. --- --- @since 0.2.0 -{-# INLINE wSerial #-} -wSerial :: IsStream t => t m a -> t m a -> t m a -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 - --- | Like `wSerial` but stops interleaving as soon as the first stream stops. --- --- @since 0.7.0 -{-# INLINE wSerialFst #-} -wSerialFst :: IsStream t => t m a -> t m a -> t m a -wSerialFst m1 m2 = mkStream $ \st yld sng stp -> do - let yieldFirst a r = yld a (yieldSecond r m2) - in foldStream st yieldFirst sng stp m1 - - where - - yieldSecond s1 s2 = mkStream $ \st yld sng stp -> do - let stop = foldStream st yld sng stp s1 - single a = yld a s1 - yieldk a r = yld a (wSerial s1 r) - in foldStream st yieldk single stop s2 - --- | Like `wSerial` but stops interleaving as soon as any of the two streams --- stops. --- --- @since 0.7.0 -{-# INLINE wSerialMin #-} -wSerialMin :: IsStream t => t m a -> t m a -> t m a -wSerialMin m1 m2 = mkStream $ \st yld sng stp -> do - let stop = stp - single a = sng a - yieldk a r = yld a (wSerial m2 r) - foldStream st yieldk single stop m1 - -instance Semigroup (WSerialT m a) where - (<>) = wSerial - -infixr 5 <=> - --- | Same as 'wSerial'. --- --- @since 0.1.0 -{-# DEPRECATED (<=>) "Please use 'wSerial' instead." #-} -{-# INLINE (<=>) #-} -(<=>) :: IsStream t => t m a -> t m a -> t m a -(<=>) = wSerial - ------------------------------------------------------------------------------- --- Monoid ------------------------------------------------------------------------------- - -instance Monoid (WSerialT m a) where - mempty = K.nil - mappend = (<>) - ------------------------------------------------------------------------------- --- Monad ------------------------------------------------------------------------------- - -instance Monad m => Monad (WSerialT m) where - return = pure - {-# INLINE (>>=) #-} - (>>=) = K.bindWith wSerial - ------------------------------------------------------------------------------- --- Other instances ------------------------------------------------------------------------------- - -MONAD_APPLICATIVE_INSTANCE(WSerialT,) -MONAD_COMMON_INSTANCES(WSerialT,) -LIST_INSTANCES(WSerialT) -NFDATA1_INSTANCE(WSerialT) -FOLDABLE_INSTANCE(WSerialT) -TRAVERSABLE_INSTANCE(WSerialT) diff --git a/src/Streamly/Streams/StreamD.hs b/src/Streamly/Streams/StreamD.hs deleted file mode 100644 --- a/src/Streamly/Streams/StreamD.hs +++ /dev/null @@ -1,3950 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE MagicHash #-} - -#if __GLASGOW_HASKELL__ >= 801 -{-# LANGUAGE TypeApplications #-} -#endif - -#include "inline.hs" - --- | --- Module : Streamly.Streams.StreamD --- Copyright : (c) 2018 Harendra Kumar --- Copyright : (c) Roman Leshchinskiy 2008-2010 --- Copyright : (c) The University of Glasgow, 2009 --- Copyright : (c) Bjoern Hoehrmann 2008-2009 --- --- License : BSD3 --- Maintainer : streamly@composewell.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 - , nilM - , cons - - -- * Deconstruction - , uncons - - -- * Generation - -- ** Unfolds - , unfoldr - , unfoldrM - , unfold - - -- ** Specialized Generation - -- | Generate a monadic stream from a seed. - , repeat - , repeatM - , 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 - , foldrS - , foldrT - , foldrM - , foldrMx - , foldr - , foldr1 - - , foldl' - , foldlM' - , foldlS - , foldlT - , reverse - , reverse' - - , foldlx' - , foldlMx' - - -- ** Specialized Folds - , tap - , drain - , null - , head - , tail - , last - , elem - , notElem - , all - , any - , maximum - , maximumBy - , minimum - , minimumBy - , findIndices - , lookup - , findM - , find - , (!!) - - -- ** Flattening nested streams - , concatMapM - , concatMap - , ConcatMapUState (..) - , concatMapU - , ConcatUnfoldInterleaveState (..) - , concatUnfoldInterleave - , concatUnfoldRoundrobin - , AppendState(..) - , append - , InterleaveState(..) - , interleave - , interleaveMin - , interleaveSuffix - , interleaveInfix - , roundRobin -- interleaveFair?/ParallelFair - , gintercalateSuffix - , interposeSuffix - , gintercalate - , interpose - - -- ** Grouping - , groupsOf - , groupsOf2 - , groupsBy - , groupsRollingBy - - -- ** Splitting - , splitBy - , splitSuffixBy - , wordsBy - , splitSuffixBy' - - , splitOn - , splitSuffixOn - - , splitInnerBy - , splitInnerBySuffix - - -- ** Substreams - , isPrefixOf - , isSubsequenceOf - , stripPrefix - - -- ** Map and Fold - , mapM_ - - -- ** Conversions - -- | Transform a stream into another type. - , toList - , toListRev - , toStreamK - , toStreamD - - , hoist - , generally - - , liftInner - , runReaderT - , evalStateT - , runStateT - - -- * Transformation - , transform - - -- ** By folding (scans) - , scanlM' - , scanl' - , scanlM - , scanl - , scanl1M' - , scanl1' - , scanl1M - , scanl1 - - , prescanl' - , prescanlM' - - , postscanl - , postscanlM - , postscanl' - , postscanlM' - - , postscanlx' - , postscanlMx' - , scanlMx' - , scanlx' - - -- * Filtering - , filter - , filterM - , uniq - , take - , takeWhile - , takeWhileM - , drop - , dropWhile - , dropWhileM - - -- * Mapping - , map - , mapM - , sequence - - -- * Inserting - , intersperseM - , intersperse - , intersperseSuffix - , insertBy - - -- * Deleting - , deleteBy - - -- ** Map and Filter - , mapMaybe - , mapMaybeM - - -- * Zipping - , indexed - , indexedR - , zipWith - , zipWithM - - -- * Comparisons - , eqBy - , cmpBy - - -- * Merging - , mergeBy - , mergeByM - - -- * Transformation comprehensions - , the - - -- * Exceptions - , gbracket - , before - , after - , bracket - , onException - , finally - , handle - - -- * UTF8 Encoding / Decoding transformations. - , DecodeError(..) - , DecodeState - , CodePoint - , decodeUtf8 - , encodeUtf8 - , decodeUtf8Lenient - , decodeUtf8Either - , resumeDecodeUtf8Either - , decodeUtf8Arrays - , decodeUtf8ArraysLenient - ) -where - -import Control.Exception (Exception, SomeException) -import Control.Monad (void) -import Control.Monad.Catch (MonadCatch) -import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.Reader (ReaderT) -import Control.Monad.State.Strict (StateT) -import Control.Monad.Trans (MonadTrans(lift)) -import Data.Bits (shiftR, shiftL, (.|.), (.&.)) -import Data.Functor.Identity (Identity(..)) -import Data.Maybe (fromJust, isJust) -import Data.Word (Word32) -import Foreign.Ptr (Ptr) -import Foreign.Storable (Storable(..)) -import GHC.Base (assert, unsafeChr, ord) -import GHC.IO.Encoding.Failure (isSurrogate) -import GHC.ForeignPtr (ForeignPtr (..)) -import GHC.Ptr (Ptr (..)) -import GHC.Types (SPEC(..)) -import GHC.Word (Word8(..)) -import System.IO.Unsafe (unsafePerformIO) -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, concat, - reverse) - -import qualified Control.Monad.Catch as MC -import qualified Control.Monad.Reader as Reader -import qualified Control.Monad.State.Strict as State - -import Streamly.Internal.Memory.Array.Types (Array(..)) -import Streamly.Internal.Data.Fold.Types (Fold(..)) -import Streamly.Internal.Data.Pipe.Types (Pipe(..), PipeState(..)) -import Streamly.Internal.Data.SVar (MonadAsync, defState, adaptState) -import Streamly.Internal.Data.Unfold.Types (Unfold(..)) -import Streamly.Internal.Data.Strict (Tuple'(..)) - -import Streamly.Internal.Data.Stream.StreamD.Type - -import qualified Streamly.Internal.Data.Pipe.Types as Pipe -import qualified Streamly.Internal.Memory.Array.Types as A -import qualified Streamly.Memory.Ring as RB -import qualified Streamly.Streams.StreamK as K - -import Foreign.Ptr (plusPtr) -import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) -import Foreign.ForeignPtr (touchForeignPtr) - ------------------------------------------------------------------------------- --- Construction ------------------------------------------------------------------------------- - --- | An empty 'Stream'. -{-# INLINE_NORMAL nil #-} -nil :: Monad m => Stream m a -nil = Stream (\_ _ -> return Stop) () - --- | An empty 'Stream' with a side effect. -{-# INLINE_NORMAL nilM #-} -nilM :: Monad m => m b -> Stream m a -nilM m = Stream (\_ _ -> m >> return Stop) () - -{-# INLINE_NORMAL consM #-} -consM :: Monad m => m a -> Stream m a -> Stream m a -consM m (Stream step state) = Stream step1 Nothing - where - {-# INLINE_LATE step1 #-} - step1 _ Nothing = m >>= \x -> 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 - --- XXX implement in terms of consM? --- cons x = consM (return x) --- --- | 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) - --- | Convert an 'Unfold' into a 'Stream' by supplying it a seed. --- -{-# INLINE_NORMAL unfold #-} -unfold :: Monad m => Unfold m a b -> a -> Stream m b -unfold (Unfold ustep inject) seed = Stream step Nothing - where - {-# INLINE_LATE step #-} - step _ Nothing = inject seed >>= return . Skip . Just - step _ (Just st) = do - r <- ustep st - return $ case r of - Yield x s -> Yield x (Just s) - Skip s -> Skip (Just s) - Stop -> Stop - ------------------------------------------------------------------------------- --- Specialized Generation ------------------------------------------------------------------------------- - -repeatM :: Monad m => m a -> Stream m a -repeatM x = Stream (\_ _ -> x >>= \r -> return $ Yield r ()) () - -repeat :: Monad m => a -> Stream m a -repeat x = Stream (\_ _ -> return $ Yield x ()) () - -{-# INLINE_NORMAL replicateM #-} -replicateM :: forall m a. Monad m => Int -> m a -> Stream m a -replicateM n p = Stream step n - where - {-# INLINE_LATE step #-} - step _ (i :: Int) - | 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 -------------------------------------------------------------------------------- - -{-# 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 - -{-# INLINE toStreamD #-} -toStreamD :: (K.IsStream t, Monad m) => t m a -> Stream m a -toStreamD = fromStreamK . K.toStream - -{-# INLINE_NORMAL hoist #-} -hoist :: Monad n => (forall x. m x -> n x) -> Stream m a -> Stream n a -hoist f (Stream step state) = (Stream step' state) - where - step' gst st = do - r <- f $ step (adaptState gst) st - return $ case r of - Yield x s -> Yield x s - Skip s -> Skip s - Stop -> Stop - -{-# INLINE_NORMAL generally #-} -generally :: Monad m => Stream Identity a -> Stream m a -generally = hoist (return . runIdentity) - -{-# INLINE_NORMAL liftInner #-} -liftInner :: (Monad m, MonadTrans t, Monad (t m)) - => Stream m a -> Stream (t m) a -liftInner (Stream step state) = Stream step' state - where - step' gst st = do - r <- lift $ step (adaptState gst) st - return $ case r of - Yield x s -> Yield x s - Skip s -> Skip s - Stop -> Stop - -{-# INLINE_NORMAL runReaderT #-} -runReaderT :: Monad m => s -> Stream (ReaderT s m) a -> Stream m a -runReaderT sval (Stream step state) = Stream step' state - where - step' gst st = do - r <- Reader.runReaderT (step (adaptState gst) st) sval - return $ case r of - Yield x s -> Yield x s - Skip s -> Skip s - Stop -> Stop - -{-# INLINE_NORMAL evalStateT #-} -evalStateT :: Monad m => s -> Stream (StateT s m) a -> Stream m a -evalStateT sval (Stream step state) = Stream step' (state, sval) - where - step' gst (st, sv) = do - (r, sv') <- State.runStateT (step (adaptState gst) st) sv - return $ case r of - Yield x s -> Yield x (s, sv') - Skip s -> Skip (s, sv') - Stop -> Stop - -{-# INLINE_NORMAL runStateT #-} -runStateT :: Monad m => s -> Stream (StateT s m) a -> Stream m (s, a) -runStateT sval (Stream step state) = Stream step' (state, sval) - where - step' gst (st, sv) = do - (r, sv') <- State.runStateT (step (adaptState gst) st) sv - return $ case r of - Yield x s -> Yield (sv', x) (s, sv') - Skip s -> Skip (s, sv') - Stop -> Stop - ------------------------------------------------------------------------------- --- Elimination by Folds ------------------------------------------------------------------------------- - ------------------------------------------------------------------------------- --- Right Folds ------------------------------------------------------------------------------- - -{-# 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) - ------------------------------------------------------------------------------- --- Left Folds ------------------------------------------------------------------------------- - -{-# INLINE_NORMAL foldlT #-} -foldlT :: (Monad m, Monad (s m), MonadTrans s) - => (s m b -> a -> s m b) -> s m b -> Stream m a -> s m b -foldlT fstep begin (Stream step state) = go SPEC begin state - where - go !_ acc st = do - r <- lift $ step defState st - case r of - Yield x s -> go SPEC (fstep acc x) s - Skip s -> go SPEC acc s - Stop -> acc - --- Note, this is going to have horrible performance, because of the nature of --- the stream type (i.e. direct stream vs CPS). Its only for reference, it is --- likely be practically unusable. -{-# INLINE_NORMAL foldlS #-} -foldlS :: Monad m - => (Stream m b -> a -> Stream m b) -> Stream m b -> Stream m a -> Stream m b -foldlS fstep begin (Stream step state) = Stream step' (Left (state, begin)) - where - step' gst (Left (st, acc)) = do - r <- step (adaptState gst) st - return $ case r of - Yield x s -> Skip (Left (s, fstep acc x)) - Skip s -> Skip (Left (s, acc)) - Stop -> Skip (Right acc) - - step' gst (Right (Stream stp stt)) = do - r <- stp (adaptState gst) stt - return $ case r of - Yield x s -> Yield x (Right (Stream stp s)) - Skip s -> Skip (Right (Stream stp s)) - Stop -> Stop - ------------------------------------------------------------------------------- --- Specialized Folds ------------------------------------------------------------------------------- - --- | Run a streaming composition, discard the results. -{-# INLINE_LATE drain #-} -drain :: Monad m => Stream m a -> m () --- drain = foldrM (\_ xs -> xs) (return ()) -drain (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 m = foldrM (\_ _ -> return False) (return True) m - -{-# INLINE_NORMAL head #-} -head :: Monad m => Stream m a -> m (Maybe a) -head m = foldrM (\x _ -> return (Just x)) (return Nothing) m - --- 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 m = foldrM (\x xs -> if x == e then return True else xs) (return False) m -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 m = foldrM (\x xs -> if p x then xs else return False) (return True) m -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 m = foldrM (\x xs -> if p x then return True else xs) (return False) m -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 m = foldrM (\(a, b) xs -> if e == a then return (Just b) else xs) - (return Nothing) m - -{-# INLINE_NORMAL findM #-} -findM :: Monad m => (a -> m Bool) -> Stream m a -> m (Maybe a) -findM p m = foldrM (\x xs -> p x >>= \r -> if r then return (Just x) else xs) - (return Nothing) m - -{-# 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 toListRev #-} -toListRev :: Monad m => Stream m a -> m [a] -toListRev = foldl' (flip (:)) [] - --- We can implement reverse as: --- --- > reverse = foldlS (flip cons) nil --- --- However, this implementation is unusable because of the horrible performance --- of cons. So we just convert it to a list first and then stream from the --- list. --- --- XXX Maybe we can use an Array instead of a list here? -{-# INLINE_NORMAL reverse #-} -reverse :: Monad m => Stream m a -> Stream m a -reverse m = Stream step Nothing - where - {-# INLINE_LATE step #-} - step _ Nothing = do - xs <- toListRev m - return $ Skip (Just xs) - step _ (Just (x:xs)) = return $ Yield x (Just xs) - step _ (Just []) = return Stop - --- Much faster reverse for Storables -{-# INLINE_NORMAL reverse' #-} -reverse' :: forall m a. (MonadIO m, Storable a) => Stream m a -> Stream m a -{- --- This commented implementation copies the whole stream into one single array --- and then streams from that array, this is 3-4x faster than the chunked code --- that follows. Though this could be problematic due to unbounded large --- allocations. We need to figure out why the chunked code is slower and if we --- can optimize the chunked code to work as fast as this one. It may be a --- fusion issue? -import Foreign.ForeignPtr (touchForeignPtr) -import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) -import Foreign.Ptr (Ptr, plusPtr) -reverse' m = Stream step Nothing - where - {-# INLINE_LATE step #-} - step _ Nothing = do - arr <- A.fromStreamD m - let p = aEnd arr `plusPtr` negate (sizeOf (undefined :: a)) - return $ Skip $ Just (aStart arr, p) - - step _ (Just (start, p)) | p < unsafeForeignPtrToPtr start = return Stop - - step _ (Just (start, p)) = do - let !x = A.unsafeInlineIO $ do - r <- peek p - touchForeignPtr start - return r - next = p `plusPtr` negate (sizeOf (undefined :: a)) - return $ Yield x (Just (start, next)) --} -reverse' m = - A.flattenArraysRev - $ fromStreamK - $ K.reverse - $ toStreamK - $ A.fromStreamDArraysOf A.defaultChunkSize m - - ------------------------------------------------------------------------------- --- Grouping/Splitting ------------------------------------------------------------------------------- - -{-# INLINE_NORMAL splitSuffixBy' #-} -splitSuffixBy' :: Monad m - => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b -splitSuffixBy' predicate f (Stream step state) = - Stream (stepOuter f) (Just state) - - where - - {-# INLINE_LATE stepOuter #-} - stepOuter (Fold fstep initial done) gst (Just st) = do - res <- step (adaptState gst) st - case res of - Yield x s -> do - acc <- initial - acc' <- fstep acc x - if (predicate x) - then done acc' >>= \val -> return $ Yield val (Just s) - else go SPEC s acc' - - Skip s -> return $ Skip $ Just s - Stop -> return Stop - - where - - go !_ stt !acc = do - res <- step (adaptState gst) stt - case res of - Yield x s -> do - acc' <- fstep acc x - if (predicate x) - then done acc' >>= \val -> return $ Yield val (Just s) - else go SPEC s acc' - Skip s -> go SPEC s acc - Stop -> done acc >>= \val -> return $ Yield val Nothing - - stepOuter _ _ Nothing = return Stop - -{-# INLINE_NORMAL groupsBy #-} -groupsBy :: Monad m - => (a -> a -> Bool) - -> Fold m a b - -> Stream m a - -> Stream m b -groupsBy cmp f (Stream step state) = Stream (stepOuter f) (Just state, Nothing) - - where - - {-# INLINE_LATE stepOuter #-} - stepOuter (Fold fstep initial done) gst (Just st, Nothing) = do - res <- step (adaptState gst) st - case res of - Yield x s -> do - acc <- initial - acc' <- fstep acc x - go SPEC x s acc' - - Skip s -> return $ Skip $ (Just s, Nothing) - Stop -> return Stop - - where - - go !_ prev stt !acc = do - res <- step (adaptState gst) stt - case res of - Yield x s -> do - if cmp x prev - then do - acc' <- fstep acc x - go SPEC prev s acc' - else done acc >>= \r -> return $ Yield r (Just s, Just x) - Skip s -> go SPEC prev s acc - Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing) - - stepOuter (Fold fstep initial done) gst (Just st, Just prev) = do - acc <- initial - acc' <- fstep acc prev - go SPEC st acc' - - where - - -- XXX code duplicated from the previous equation - go !_ stt !acc = do - res <- step (adaptState gst) stt - case res of - Yield x s -> do - if cmp x prev - then do - acc' <- fstep acc x - go SPEC s acc' - else done acc >>= \r -> return $ Yield r (Just s, Just x) - Skip s -> go SPEC s acc - Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing) - - stepOuter _ _ (Nothing,_) = return Stop - -{-# INLINE_NORMAL groupsRollingBy #-} -groupsRollingBy :: Monad m - => (a -> a -> Bool) - -> Fold m a b - -> Stream m a - -> Stream m b -groupsRollingBy cmp f (Stream step state) = - Stream (stepOuter f) (Just state, Nothing) - where - - {-# INLINE_LATE stepOuter #-} - stepOuter (Fold fstep initial done) gst (Just st, Nothing) = do - res <- step (adaptState gst) st - case res of - Yield x s -> do - acc <- initial - acc' <- fstep acc x - go SPEC x s acc' - - Skip s -> return $ Skip $ (Just s, Nothing) - Stop -> return Stop - - where - go !_ prev stt !acc = do - res <- step (adaptState gst) stt - case res of - Yield x s -> do - if cmp prev x - then do - acc' <- fstep acc x - go SPEC x s acc' - else - done acc >>= \r -> return $ Yield r (Just s, Just x) - Skip s -> go SPEC prev s acc - Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing) - - stepOuter (Fold fstep initial done) gst (Just st, Just prev') = do - acc <- initial - acc' <- fstep acc prev' - go SPEC prev' st acc' - - where - go !_ prevv stt !acc = do - res <- step (adaptState gst) stt - case res of - Yield x s -> do - if cmp prevv x - then do - acc' <- fstep acc x - go SPEC x s acc' - else done acc >>= \r -> return $ Yield r (Just s, Just x) - Skip s -> go SPEC prevv s acc - Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing) - - stepOuter _ _ (Nothing, _) = return Stop - -{-# INLINE_NORMAL splitBy #-} -splitBy :: Monad m => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b -splitBy predicate f (Stream step state) = Stream (step' f) (Just state) - - where - - {-# INLINE_LATE step' #-} - step' (Fold fstep initial done) gst (Just st) = initial >>= go SPEC st - - where - - go !_ stt !acc = do - res <- step (adaptState gst) stt - case res of - Yield x s -> do - if predicate x - then done acc >>= \r -> return $ Yield r (Just s) - else do - acc' <- fstep acc x - go SPEC s acc' - Skip s -> go SPEC s acc - Stop -> done acc >>= \r -> return $ Yield r Nothing - - step' _ _ Nothing = return Stop - --- XXX requires -funfolding-use-threshold=150 in lines-unlines benchmark -{-# INLINE_NORMAL splitSuffixBy #-} -splitSuffixBy :: Monad m - => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b -splitSuffixBy predicate f (Stream step state) = Stream (step' f) (Just state) - - where - - {-# INLINE_LATE step' #-} - step' (Fold fstep initial done) gst (Just st) = do - res <- step (adaptState gst) st - case res of - Yield x s -> do - acc <- initial - if predicate x - then done acc >>= \val -> return $ Yield val (Just s) - else do - acc' <- fstep acc x - go SPEC s acc' - - Skip s -> return $ Skip $ Just s - Stop -> return Stop - - where - - go !_ stt !acc = do - res <- step (adaptState gst) stt - case res of - Yield x s -> do - if predicate x - then done acc >>= \r -> return $ Yield r (Just s) - else do - acc' <- fstep acc x - go SPEC s acc' - Skip s -> go SPEC s acc - Stop -> done acc >>= \r -> return $ Yield r Nothing - - step' _ _ Nothing = return Stop - -{-# INLINE_NORMAL wordsBy #-} -wordsBy :: Monad m => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b -wordsBy predicate f (Stream step state) = Stream (stepOuter f) (Just state) - - where - - {-# INLINE_LATE stepOuter #-} - stepOuter (Fold fstep initial done) gst (Just st) = do - res <- step (adaptState gst) st - case res of - Yield x s -> do - if predicate x - then return $ Skip (Just s) - else do - acc <- initial - acc' <- fstep acc x - go SPEC s acc' - - Skip s -> return $ Skip $ Just s - Stop -> return Stop - - where - - go !_ stt !acc = do - res <- step (adaptState gst) stt - case res of - Yield x s -> do - if predicate x - then done acc >>= \r -> return $ Yield r (Just s) - else do - acc' <- fstep acc x - go SPEC s acc' - Skip s -> go SPEC s acc - Stop -> done acc >>= \r -> return $ Yield r Nothing - - stepOuter _ _ Nothing = return Stop - --- String search algorithms: --- http://www-igm.univ-mlv.fr/~lecroq/string/index.html - -{- --- TODO can we unify the splitting operations using a splitting configuration --- like in the split package. --- -data SplitStyle = Infix | Suffix | Prefix deriving (Eq, Show) - -data SplitOptions = SplitOptions - { style :: SplitStyle - , withSep :: Bool -- ^ keep the separators in output - -- , compact :: Bool -- ^ treat multiple consecutive separators as one - -- , trimHead :: Bool -- ^ drop blank at head - -- , trimTail :: Bool -- ^ drop blank at tail - } --} - -data SplitOnState s a = - GO_START - | GO_EMPTY_PAT s - | GO_SINGLE_PAT s a - | GO_SHORT_PAT s - | GO_KARP_RABIN s !(RB.Ring a) !(Ptr a) - | GO_DONE - -{-# INLINE_NORMAL splitOn #-} -splitOn - :: forall m a b. (MonadIO m, Storable a, Enum a, Eq a) - => Array a - -> Fold m a b - -> Stream m a - -> Stream m b -splitOn patArr@Array{..} (Fold fstep initial done) (Stream step state) = - Stream stepOuter GO_START - - where - - patLen = A.length patArr - maxIndex = patLen - 1 - elemBits = sizeOf (undefined :: a) * 8 - - {-# INLINE_LATE stepOuter #-} - stepOuter _ GO_START = - if patLen == 0 - then return $ Skip $ GO_EMPTY_PAT state - else if patLen == 1 - then do - r <- liftIO $ (A.unsafeIndexIO patArr 0) - return $ Skip $ GO_SINGLE_PAT state r - else if sizeOf (undefined :: a) * patLen - <= sizeOf (undefined :: Word) - then return $ Skip $ GO_SHORT_PAT state - else do - (rb, rhead) <- liftIO $ RB.new patLen - return $ Skip $ GO_KARP_RABIN state rb rhead - - stepOuter gst (GO_SINGLE_PAT stt pat) = initial >>= go SPEC stt - - where - - go !_ st !acc = do - res <- step (adaptState gst) st - case res of - Yield x s -> do - if pat == x - then do - r <- done acc - return $ Yield r (GO_SINGLE_PAT s pat) - else fstep acc x >>= go SPEC s - Skip s -> go SPEC s acc - Stop -> done acc >>= \r -> return $ Yield r GO_DONE - - stepOuter gst (GO_SHORT_PAT stt) = initial >>= go0 SPEC 0 (0 :: Word) stt - - where - - mask :: Word - mask = (1 `shiftL` (elemBits * patLen)) - 1 - - addToWord wrd a = (wrd `shiftL` elemBits) .|. fromIntegral (fromEnum a) - - patWord :: Word - patWord = mask .&. A.foldl' addToWord 0 patArr - - go0 !_ !idx wrd st !acc = do - res <- step (adaptState gst) st - case res of - Yield x s -> do - let wrd' = addToWord wrd x - if idx == maxIndex - then do - if wrd' .&. mask == patWord - then do - r <- done acc - return $ Yield r (GO_SHORT_PAT s) - else go1 SPEC wrd' s acc - else go0 SPEC (idx + 1) wrd' s acc - Skip s -> go0 SPEC idx wrd s acc - Stop -> do - acc' <- if idx /= 0 - then go2 wrd idx acc - else return acc - done acc' >>= \r -> return $ Yield r GO_DONE - - {-# INLINE go1 #-} - go1 !_ wrd st !acc = do - res <- step (adaptState gst) st - case res of - Yield x s -> do - let wrd' = addToWord wrd x - old = (mask .&. wrd) `shiftR` (elemBits * (patLen - 1)) - acc' <- fstep acc (toEnum $ fromIntegral old) - if wrd' .&. mask == patWord - then done acc' >>= \r -> return $ Yield r (GO_SHORT_PAT s) - else go1 SPEC wrd' s acc' - Skip s -> go1 SPEC wrd s acc - Stop -> do - acc' <- go2 wrd patLen acc - done acc' >>= \r -> return $ Yield r GO_DONE - - go2 !wrd !n !acc | n > 0 = do - let old = (mask .&. wrd) `shiftR` (elemBits * (n - 1)) - fstep acc (toEnum $ fromIntegral old) >>= go2 wrd (n - 1) - go2 _ _ acc = return acc - - stepOuter gst (GO_KARP_RABIN stt rb rhead) = do - initial >>= go0 SPEC 0 rhead stt - - where - - k = 2891336453 :: Word32 - coeff = k ^ patLen - addCksum cksum a = cksum * k + fromIntegral (fromEnum a) - deltaCksum cksum old new = - addCksum cksum new - coeff * fromIntegral (fromEnum old) - - -- XXX shall we use a random starting hash or 1 instead of 0? - patHash = A.foldl' addCksum 0 patArr - - -- rh == ringHead - go0 !_ !idx !rh st !acc = do - res <- step (adaptState gst) st - case res of - Yield x s -> do - rh' <- liftIO $ RB.unsafeInsert rb rh x - if idx == maxIndex - then do - let fold = RB.unsafeFoldRing (RB.ringBound rb) - let !ringHash = fold addCksum 0 rb - if ringHash == patHash - then go2 SPEC ringHash rh' s acc - else go1 SPEC ringHash rh' s acc - else go0 SPEC (idx + 1) rh' s acc - Skip s -> go0 SPEC idx rh s acc - Stop -> do - !acc' <- if idx /= 0 - then RB.unsafeFoldRingM rh fstep acc rb - else return acc - done acc' >>= \r -> return $ Yield r GO_DONE - - -- XXX Theoretically this code can do 4 times faster if GHC generates - -- optimal code. If we use just "(cksum' == patHash)" condition it goes - -- 4x faster, as soon as we add the "RB.unsafeEqArray rb v" condition - -- the generated code changes drastically and becomes 4x slower. Need - -- to investigate what is going on with GHC. - {-# INLINE go1 #-} - go1 !_ !cksum !rh st !acc = do - res <- step (adaptState gst) st - case res of - Yield x s -> do - old <- liftIO $ peek rh - let cksum' = deltaCksum cksum old x - acc' <- fstep acc old - - if (cksum' == patHash) - then do - rh' <- liftIO (RB.unsafeInsert rb rh x) - go2 SPEC cksum' rh' s acc' - else do - rh' <- liftIO (RB.unsafeInsert rb rh x) - go1 SPEC cksum' rh' s acc' - Skip s -> go1 SPEC cksum rh s acc - Stop -> do - acc' <- RB.unsafeFoldRingFullM rh fstep acc rb - done acc' >>= \r -> return $ Yield r GO_DONE - - go2 !_ !cksum' !rh' s !acc' = do - if RB.unsafeEqArray rb rh' patArr - then do - r <- done acc' - return $ Yield r (GO_KARP_RABIN s rb rhead) - else go1 SPEC cksum' rh' s acc' - - stepOuter gst (GO_EMPTY_PAT st) = do - res <- step (adaptState gst) st - case res of - Yield x s -> do - acc <- initial - acc' <- fstep acc x - done acc' >>= \r -> return $ Yield r (GO_EMPTY_PAT s) - Skip s -> return $ Skip (GO_EMPTY_PAT s) - Stop -> return Stop - - stepOuter _ GO_DONE = return Stop - -{-# INLINE_NORMAL splitSuffixOn #-} -splitSuffixOn - :: forall m a b. (MonadIO m, Storable a, Enum a, Eq a) - => Bool - -> Array a - -> Fold m a b - -> Stream m a - -> Stream m b -splitSuffixOn withSep patArr@Array{..} (Fold fstep initial done) - (Stream step state) = - Stream stepOuter GO_START - - where - - patLen = A.length patArr - maxIndex = patLen - 1 - elemBits = sizeOf (undefined :: a) * 8 - - {-# INLINE_LATE stepOuter #-} - stepOuter _ GO_START = - if patLen == 0 - then return $ Skip $ GO_EMPTY_PAT state - else if patLen == 1 - then do - r <- liftIO $ (A.unsafeIndexIO patArr 0) - return $ Skip $ GO_SINGLE_PAT state r - else if sizeOf (undefined :: a) * patLen - <= sizeOf (undefined :: Word) - then return $ Skip $ GO_SHORT_PAT state - else do - (rb, rhead) <- liftIO $ RB.new patLen - return $ Skip $ GO_KARP_RABIN state rb rhead - - stepOuter gst (GO_SINGLE_PAT stt pat) = do - -- This first part is the only difference between splitOn and - -- splitSuffixOn. - -- If the last element is a separator do not issue a blank segment. - res <- step (adaptState gst) stt - case res of - Yield x s -> do - acc <- initial - if pat == x - then do - acc' <- if withSep then fstep acc x else return acc - done acc' >>= \r -> return $ Yield r (GO_SINGLE_PAT s pat) - else fstep acc x >>= go SPEC s - Skip s -> return $ Skip $ (GO_SINGLE_PAT s pat) - Stop -> return Stop - - where - - -- This is identical for splitOn and splitSuffixOn - go !_ st !acc = do - res <- step (adaptState gst) st - case res of - Yield x s -> do - if pat == x - then do - acc' <- if withSep then fstep acc x else return acc - r <- done acc' - return $ Yield r (GO_SINGLE_PAT s pat) - else fstep acc x >>= go SPEC s - Skip s -> go SPEC s acc - Stop -> done acc >>= \r -> return $ Yield r GO_DONE - - stepOuter gst (GO_SHORT_PAT stt) = do - - -- Call "initial" only if the stream yields an element, otherwise we - -- may call "initial" but never yield anything. initial may produce a - -- side effect, therefore we will end up doing and discard a side - -- effect. - - let idx = 0 - let wrd = 0 - res <- step (adaptState gst) stt - case res of - Yield x s -> do - acc <- initial - let wrd' = addToWord wrd x - acc' <- if withSep then fstep acc x else return acc - if idx == maxIndex - then do - if wrd' .&. mask == patWord - then done acc' >>= \r -> return $ Yield r (GO_SHORT_PAT s) - else go0 SPEC (idx + 1) wrd' s acc' - else go0 SPEC (idx + 1) wrd' s acc' - Skip s -> return $ Skip (GO_SHORT_PAT s) - Stop -> return Stop - - where - - mask :: Word - mask = (1 `shiftL` (elemBits * patLen)) - 1 - - addToWord wrd a = (wrd `shiftL` elemBits) .|. fromIntegral (fromEnum a) - - patWord :: Word - patWord = mask .&. A.foldl' addToWord 0 patArr - - go0 !_ !idx wrd st !acc = do - res <- step (adaptState gst) st - case res of - Yield x s -> do - let wrd' = addToWord wrd x - acc' <- if withSep then fstep acc x else return acc - if idx == maxIndex - then do - if wrd' .&. mask == patWord - then do - r <- done acc' - return $ Yield r (GO_SHORT_PAT s) - else go1 SPEC wrd' s acc' - else go0 SPEC (idx + 1) wrd' s acc' - Skip s -> go0 SPEC idx wrd s acc - Stop -> do - if (idx == maxIndex) && (wrd .&. mask == patWord) - then return Stop - else do - acc' <- if idx /= 0 && not withSep - then go2 wrd idx acc - else return acc - done acc' >>= \r -> return $ Yield r GO_DONE - - {-# INLINE go1 #-} - go1 !_ wrd st !acc = do - res <- step (adaptState gst) st - case res of - Yield x s -> do - let wrd' = addToWord wrd x - old = (mask .&. wrd) `shiftR` (elemBits * (patLen - 1)) - acc' <- if withSep - then fstep acc x - else fstep acc (toEnum $ fromIntegral old) - if wrd' .&. mask == patWord - then done acc' >>= \r -> return $ Yield r (GO_SHORT_PAT s) - else go1 SPEC wrd' s acc' - Skip s -> go1 SPEC wrd s acc - Stop -> - -- If the last sequence is a separator do not issue a blank - -- segment. - if wrd .&. mask == patWord - then return Stop - else do - acc' <- if withSep - then return acc - else go2 wrd patLen acc - done acc' >>= \r -> return $ Yield r GO_DONE - - go2 !wrd !n !acc | n > 0 = do - let old = (mask .&. wrd) `shiftR` (elemBits * (n - 1)) - fstep acc (toEnum $ fromIntegral old) >>= go2 wrd (n - 1) - go2 _ _ acc = return acc - - stepOuter gst (GO_KARP_RABIN stt rb rhead) = do - let idx = 0 - res <- step (adaptState gst) stt - case res of - Yield x s -> do - acc <- initial - acc' <- if withSep then fstep acc x else return acc - rh' <- liftIO (RB.unsafeInsert rb rhead x) - if idx == maxIndex - then do - let fold = RB.unsafeFoldRing (RB.ringBound rb) - let !ringHash = fold addCksum 0 rb - if ringHash == patHash - then go2 SPEC ringHash rh' s acc' - else go0 SPEC (idx + 1) rh' s acc' - else go0 SPEC (idx + 1) rh' s acc' - Skip s -> return $ Skip (GO_KARP_RABIN s rb rhead) - Stop -> return Stop - - where - - k = 2891336453 :: Word32 - coeff = k ^ patLen - addCksum cksum a = cksum * k + fromIntegral (fromEnum a) - deltaCksum cksum old new = - addCksum cksum new - coeff * fromIntegral (fromEnum old) - - -- XXX shall we use a random starting hash or 1 instead of 0? - patHash = A.foldl' addCksum 0 patArr - - -- rh == ringHead - go0 !_ !idx !rh st !acc = do - res <- step (adaptState gst) st - case res of - Yield x s -> do - acc' <- if withSep then fstep acc x else return acc - rh' <- liftIO (RB.unsafeInsert rb rh x) - if idx == maxIndex - then do - let fold = RB.unsafeFoldRing (RB.ringBound rb) - let !ringHash = fold addCksum 0 rb - if ringHash == patHash - then go2 SPEC ringHash rh' s acc' - else go1 SPEC ringHash rh' s acc' - else go0 SPEC (idx + 1) rh' s acc' - Skip s -> go0 SPEC idx rh s acc - Stop -> do - -- do not issue a blank segment when we end at pattern - if (idx == maxIndex) && RB.unsafeEqArray rb rh patArr - then return Stop - else do - !acc' <- if idx /= 0 && not withSep - then RB.unsafeFoldRingM rh fstep acc rb - else return acc - done acc' >>= \r -> return $ Yield r GO_DONE - - -- XXX Theoretically this code can do 4 times faster if GHC generates - -- optimal code. If we use just "(cksum' == patHash)" condition it goes - -- 4x faster, as soon as we add the "RB.unsafeEqArray rb v" condition - -- the generated code changes drastically and becomes 4x slower. Need - -- to investigate what is going on with GHC. - {-# INLINE go1 #-} - go1 !_ !cksum !rh st !acc = do - res <- step (adaptState gst) st - case res of - Yield x s -> do - old <- liftIO $ peek rh - let cksum' = deltaCksum cksum old x - acc' <- if withSep - then fstep acc x - else fstep acc old - - if (cksum' == patHash) - then do - rh' <- liftIO (RB.unsafeInsert rb rh x) - go2 SPEC cksum' rh' s acc' - else do - rh' <- liftIO (RB.unsafeInsert rb rh x) - go1 SPEC cksum' rh' s acc' - Skip s -> go1 SPEC cksum rh s acc - Stop -> do - if RB.unsafeEqArray rb rh patArr - then return Stop - else do - acc' <- if withSep - then return acc - else RB.unsafeFoldRingFullM rh fstep acc rb - done acc' >>= \r -> return $ Yield r GO_DONE - - go2 !_ !cksum' !rh' s !acc' = do - if RB.unsafeEqArray rb rh' patArr - then do - r <- done acc' - return $ Yield r (GO_KARP_RABIN s rb rhead) - else go1 SPEC cksum' rh' s acc' - - stepOuter gst (GO_EMPTY_PAT st) = do - res <- step (adaptState gst) st - case res of - Yield x s -> do - acc <- initial - acc' <- fstep acc x - done acc' >>= \r -> return $ Yield r (GO_EMPTY_PAT s) - Skip s -> return $ Skip (GO_EMPTY_PAT s) - Stop -> return Stop - - stepOuter _ GO_DONE = return Stop - -data SplitState s arr - = SplitInitial s - | SplitBuffering s arr - | SplitSplitting s arr - | SplitYielding arr (SplitState s arr) - | SplitFinishing - --- XXX An alternative approach would be to use a partial fold (Fold m a b) to --- split using a splitBy like combinator. The Fold would consume upto the --- separator and return any leftover which can then be fed to the next fold. --- --- We can revisit this once we have partial folds/parsers. --- --- | Performs infix separator style splitting. -{-# INLINE_NORMAL splitInnerBy #-} -splitInnerBy - :: Monad m - => (f a -> m (f a, Maybe (f a))) -- splitter - -> (f a -> f a -> m (f a)) -- joiner - -> Stream m (f a) - -> Stream m (f a) -splitInnerBy splitter joiner (Stream step1 state1) = - (Stream step (SplitInitial state1)) - - where - - {-# INLINE_LATE step #-} - step gst (SplitInitial st) = do - r <- step1 gst st - case r of - Yield x s -> do - (x1, mx2) <- splitter x - return $ case mx2 of - Nothing -> Skip (SplitBuffering s x1) - Just x2 -> Skip (SplitYielding x1 (SplitSplitting s x2)) - Skip s -> return $ Skip (SplitInitial s) - Stop -> return $ Stop - - step gst (SplitBuffering st buf) = do - r <- step1 gst st - case r of - Yield x s -> do - (x1, mx2) <- splitter x - buf' <- joiner buf x1 - return $ case mx2 of - Nothing -> Skip (SplitBuffering s buf') - Just x2 -> Skip (SplitYielding buf' (SplitSplitting s x2)) - Skip s -> return $ Skip (SplitBuffering s buf) - Stop -> return $ Skip (SplitYielding buf SplitFinishing) - - step _ (SplitSplitting st buf) = do - (x1, mx2) <- splitter buf - return $ case mx2 of - Nothing -> Skip $ SplitBuffering st x1 - Just x2 -> Skip $ SplitYielding x1 (SplitSplitting st x2) - - step _ (SplitYielding x next) = return $ Yield x next - step _ SplitFinishing = return $ Stop - --- | Performs infix separator style splitting. -{-# INLINE_NORMAL splitInnerBySuffix #-} -splitInnerBySuffix - :: (Monad m, Eq (f a), Monoid (f a)) - => (f a -> m (f a, Maybe (f a))) -- splitter - -> (f a -> f a -> m (f a)) -- joiner - -> Stream m (f a) - -> Stream m (f a) -splitInnerBySuffix splitter joiner (Stream step1 state1) = - (Stream step (SplitInitial state1)) - - where - - {-# INLINE_LATE step #-} - step gst (SplitInitial st) = do - r <- step1 gst st - case r of - Yield x s -> do - (x1, mx2) <- splitter x - return $ case mx2 of - Nothing -> Skip (SplitBuffering s x1) - Just x2 -> Skip (SplitYielding x1 (SplitSplitting s x2)) - Skip s -> return $ Skip (SplitInitial s) - Stop -> return $ Stop - - step gst (SplitBuffering st buf) = do - r <- step1 gst st - case r of - Yield x s -> do - (x1, mx2) <- splitter x - buf' <- joiner buf x1 - return $ case mx2 of - Nothing -> Skip (SplitBuffering s buf') - Just x2 -> Skip (SplitYielding buf' (SplitSplitting s x2)) - Skip s -> return $ Skip (SplitBuffering s buf) - Stop -> return $ - if buf == mempty - then Stop - else Skip (SplitYielding buf SplitFinishing) - - step _ (SplitSplitting st buf) = do - (x1, mx2) <- splitter buf - return $ case mx2 of - Nothing -> Skip $ SplitBuffering st x1 - Just x2 -> Skip $ SplitYielding x1 (SplitSplitting st x2) - - step _ (SplitYielding x next) = return $ Yield x next - step _ SplitFinishing = return $ Stop - ------------------------------------------------------------------------------- --- 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 = drain . mapM m - -------------------------------------------------------------------------------- --- Stream transformations using Unfolds -------------------------------------------------------------------------------- - --- Define a unique structure to use in inspection testing -data ConcatMapUState o i = - ConcatMapUOuter o - | ConcatMapUInner o i - --- | @concatMapU unfold stream@ uses @unfold@ to map the input stream elements --- to streams and then flattens the generated streams into a single output --- stream. - --- This is like 'concatMap' but uses an unfold with an explicit state to --- generate the stream instead of a 'Stream' type generator. This allows better --- optimization via fusion. This can be many times more efficient than --- 'concatMap'. - -{-# INLINE_NORMAL concatMapU #-} -concatMapU :: Monad m => Unfold m a b -> Stream m a -> Stream m b -concatMapU (Unfold istep inject) (Stream ostep ost) = - Stream step (ConcatMapUOuter ost) - where - {-# INLINE_LATE step #-} - step gst (ConcatMapUOuter o) = do - r <- ostep (adaptState gst) o - case r of - Yield a o' -> do - i <- inject a - i `seq` return (Skip (ConcatMapUInner o' i)) - Skip o' -> return $ Skip (ConcatMapUOuter o') - Stop -> return $ Stop - - step _ (ConcatMapUInner o i) = do - r <- istep i - return $ case r of - Yield x i' -> Yield x (ConcatMapUInner o i') - Skip i' -> Skip (ConcatMapUInner o i') - Stop -> Skip (ConcatMapUOuter o) - -data ConcatUnfoldInterleaveState o i = - ConcatUnfoldInterleaveOuter o [i] - | ConcatUnfoldInterleaveInner o [i] - | ConcatUnfoldInterleaveInnerL [i] [i] - | ConcatUnfoldInterleaveInnerR [i] [i] - --- XXX use arrays to store state instead of lists. --- XXX In general we can use different scheduling strategies e.g. how to --- schedule the outer vs inner loop or assigning weights to different streams --- or outer and inner loops. - --- After a yield, switch to the next stream. Do not switch streams on Skip. --- Yield from outer stream switches to the inner stream. --- --- There are two choices here, (1) exhaust the outer stream first and then --- start yielding from the inner streams, this is much simpler to implement, --- (2) yield at least one element from an inner stream before going back to --- outer stream and opening the next stream from it. --- --- Ideally, we need some scheduling bias to inner streams vs outer stream. --- Maybe we can configure the behavior. --- -{-# INLINE_NORMAL concatUnfoldInterleave #-} -concatUnfoldInterleave :: Monad m => Unfold m a b -> Stream m a -> Stream m b -concatUnfoldInterleave (Unfold istep inject) (Stream ostep ost) = - Stream step (ConcatUnfoldInterleaveOuter ost []) - where - {-# INLINE_LATE step #-} - step gst (ConcatUnfoldInterleaveOuter o ls) = do - r <- ostep (adaptState gst) o - case r of - Yield a o' -> do - i <- inject a - i `seq` return (Skip (ConcatUnfoldInterleaveInner o' (i : ls))) - Skip o' -> return $ Skip (ConcatUnfoldInterleaveOuter o' ls) - Stop -> return $ Skip (ConcatUnfoldInterleaveInnerL ls []) - - step _ (ConcatUnfoldInterleaveInner _ []) = undefined - step _ (ConcatUnfoldInterleaveInner o (st:ls)) = do - r <- istep st - return $ case r of - Yield x s -> Yield x (ConcatUnfoldInterleaveOuter o (s:ls)) - Skip s -> Skip (ConcatUnfoldInterleaveInner o (s:ls)) - Stop -> Skip (ConcatUnfoldInterleaveOuter o ls) - - step _ (ConcatUnfoldInterleaveInnerL [] []) = return Stop - step _ (ConcatUnfoldInterleaveInnerL [] rs) = - return $ Skip (ConcatUnfoldInterleaveInnerR [] rs) - - step _ (ConcatUnfoldInterleaveInnerL (st:ls) rs) = do - r <- istep st - return $ case r of - Yield x s -> Yield x (ConcatUnfoldInterleaveInnerL ls (s:rs)) - Skip s -> Skip (ConcatUnfoldInterleaveInnerL (s:ls) rs) - Stop -> Skip (ConcatUnfoldInterleaveInnerL ls rs) - - step _ (ConcatUnfoldInterleaveInnerR [] []) = return Stop - step _ (ConcatUnfoldInterleaveInnerR ls []) = - return $ Skip (ConcatUnfoldInterleaveInnerL ls []) - - step _ (ConcatUnfoldInterleaveInnerR ls (st:rs)) = do - r <- istep st - return $ case r of - Yield x s -> Yield x (ConcatUnfoldInterleaveInnerR (s:ls) rs) - Skip s -> Skip (ConcatUnfoldInterleaveInnerR ls (s:rs)) - Stop -> Skip (ConcatUnfoldInterleaveInnerR ls rs) - --- XXX In general we can use different scheduling strategies e.g. how to --- schedule the outer vs inner loop or assigning weights to different streams --- or outer and inner loops. --- --- This could be inefficient if the tasks are too small. --- --- Compared to concatUnfoldInterleave this one switches streams on Skips. --- -{-# INLINE_NORMAL concatUnfoldRoundrobin #-} -concatUnfoldRoundrobin :: Monad m => Unfold m a b -> Stream m a -> Stream m b -concatUnfoldRoundrobin (Unfold istep inject) (Stream ostep ost) = - Stream step (ConcatUnfoldInterleaveOuter ost []) - where - {-# INLINE_LATE step #-} - step gst (ConcatUnfoldInterleaveOuter o ls) = do - r <- ostep (adaptState gst) o - case r of - Yield a o' -> do - i <- inject a - i `seq` return (Skip (ConcatUnfoldInterleaveInner o' (i : ls))) - Skip o' -> return $ Skip (ConcatUnfoldInterleaveInner o' ls) - Stop -> return $ Skip (ConcatUnfoldInterleaveInnerL ls []) - - step _ (ConcatUnfoldInterleaveInner o []) = - return $ Skip (ConcatUnfoldInterleaveOuter o []) - - step _ (ConcatUnfoldInterleaveInner o (st:ls)) = do - r <- istep st - return $ case r of - Yield x s -> Yield x (ConcatUnfoldInterleaveOuter o (s:ls)) - Skip s -> Skip (ConcatUnfoldInterleaveOuter o (s:ls)) - Stop -> Skip (ConcatUnfoldInterleaveOuter o ls) - - step _ (ConcatUnfoldInterleaveInnerL [] []) = return Stop - step _ (ConcatUnfoldInterleaveInnerL [] rs) = - return $ Skip (ConcatUnfoldInterleaveInnerR [] rs) - - step _ (ConcatUnfoldInterleaveInnerL (st:ls) rs) = do - r <- istep st - return $ case r of - Yield x s -> Yield x (ConcatUnfoldInterleaveInnerL ls (s:rs)) - Skip s -> Skip (ConcatUnfoldInterleaveInnerL ls (s:rs)) - Stop -> Skip (ConcatUnfoldInterleaveInnerL ls rs) - - step _ (ConcatUnfoldInterleaveInnerR [] []) = return Stop - step _ (ConcatUnfoldInterleaveInnerR ls []) = - return $ Skip (ConcatUnfoldInterleaveInnerL ls []) - - step _ (ConcatUnfoldInterleaveInnerR ls (st:rs)) = do - r <- istep st - return $ case r of - Yield x s -> Yield x (ConcatUnfoldInterleaveInnerR (s:ls) rs) - Skip s -> Skip (ConcatUnfoldInterleaveInnerR (s:ls) rs) - Stop -> Skip (ConcatUnfoldInterleaveInnerR ls rs) - -data AppendState s1 s2 = AppendFirst s1 | AppendSecond s2 - --- Note that this could be much faster compared to the CPS stream. However, as --- the number of streams being composed increases this may become expensive. --- Need to see where the breaking point is between the two. --- -{-# INLINE_NORMAL append #-} -append :: Monad m => Stream m a -> Stream m a -> Stream m a -append (Stream step1 state1) (Stream step2 state2) = - Stream step (AppendFirst state1) - - where - - {-# INLINE_LATE step #-} - step gst (AppendFirst st) = do - r <- step1 gst st - return $ case r of - Yield a s -> Yield a (AppendFirst s) - Skip s -> Skip (AppendFirst s) - Stop -> Skip (AppendSecond state2) - - step gst (AppendSecond st) = do - r <- step2 gst st - return $ case r of - Yield a s -> Yield a (AppendSecond s) - Skip s -> Skip (AppendSecond s) - Stop -> Stop - -data InterleaveState s1 s2 = InterleaveFirst s1 s2 | InterleaveSecond s1 s2 - | InterleaveSecondOnly s2 | InterleaveFirstOnly s1 - -{-# INLINE_NORMAL interleave #-} -interleave :: Monad m => Stream m a -> Stream m a -> Stream m a -interleave (Stream step1 state1) (Stream step2 state2) = - Stream step (InterleaveFirst state1 state2) - - where - - {-# INLINE_LATE step #-} - step gst (InterleaveFirst st1 st2) = do - r <- step1 gst st1 - return $ case r of - Yield a s -> Yield a (InterleaveSecond s st2) - Skip s -> Skip (InterleaveFirst s st2) - Stop -> Skip (InterleaveSecondOnly st2) - - step gst (InterleaveSecond st1 st2) = do - r <- step2 gst st2 - return $ case r of - Yield a s -> Yield a (InterleaveFirst st1 s) - Skip s -> Skip (InterleaveSecond st1 s) - Stop -> Skip (InterleaveFirstOnly st1) - - step gst (InterleaveFirstOnly st1) = do - r <- step1 gst st1 - return $ case r of - Yield a s -> Yield a (InterleaveFirstOnly s) - Skip s -> Skip (InterleaveFirstOnly s) - Stop -> Stop - - step gst (InterleaveSecondOnly st2) = do - r <- step2 gst st2 - return $ case r of - Yield a s -> Yield a (InterleaveSecondOnly s) - Skip s -> Skip (InterleaveSecondOnly s) - Stop -> Stop - -{-# INLINE_NORMAL interleaveMin #-} -interleaveMin :: Monad m => Stream m a -> Stream m a -> Stream m a -interleaveMin (Stream step1 state1) (Stream step2 state2) = - Stream step (InterleaveFirst state1 state2) - - where - - {-# INLINE_LATE step #-} - step gst (InterleaveFirst st1 st2) = do - r <- step1 gst st1 - return $ case r of - Yield a s -> Yield a (InterleaveSecond s st2) - Skip s -> Skip (InterleaveFirst s st2) - Stop -> Stop - - step gst (InterleaveSecond st1 st2) = do - r <- step2 gst st2 - return $ case r of - Yield a s -> Yield a (InterleaveFirst st1 s) - Skip s -> Skip (InterleaveSecond st1 s) - Stop -> Stop - - step _ (InterleaveFirstOnly _) = undefined - step _ (InterleaveSecondOnly _) = undefined - -{-# INLINE_NORMAL interleaveSuffix #-} -interleaveSuffix :: Monad m => Stream m a -> Stream m a -> Stream m a -interleaveSuffix (Stream step1 state1) (Stream step2 state2) = - Stream step (InterleaveFirst state1 state2) - - where - - {-# INLINE_LATE step #-} - step gst (InterleaveFirst st1 st2) = do - r <- step1 gst st1 - return $ case r of - Yield a s -> Yield a (InterleaveSecond s st2) - Skip s -> Skip (InterleaveFirst s st2) - Stop -> Stop - - step gst (InterleaveSecond st1 st2) = do - r <- step2 gst st2 - return $ case r of - Yield a s -> Yield a (InterleaveFirst st1 s) - Skip s -> Skip (InterleaveSecond st1 s) - Stop -> Skip (InterleaveFirstOnly st1) - - step gst (InterleaveFirstOnly st1) = do - r <- step1 gst st1 - return $ case r of - Yield a s -> Yield a (InterleaveFirstOnly s) - Skip s -> Skip (InterleaveFirstOnly s) - Stop -> Stop - - step _ (InterleaveSecondOnly _) = undefined - -data InterleaveInfixState s1 s2 a - = InterleaveInfixFirst s1 s2 - | InterleaveInfixSecondBuf s1 s2 - | InterleaveInfixSecondYield s1 s2 a - | InterleaveInfixFirstYield s1 s2 a - | InterleaveInfixFirstOnly s1 - -{-# INLINE_NORMAL interleaveInfix #-} -interleaveInfix :: Monad m => Stream m a -> Stream m a -> Stream m a -interleaveInfix (Stream step1 state1) (Stream step2 state2) = - Stream step (InterleaveInfixFirst state1 state2) - - where - - {-# INLINE_LATE step #-} - step gst (InterleaveInfixFirst st1 st2) = do - r <- step1 gst st1 - return $ case r of - Yield a s -> Yield a (InterleaveInfixSecondBuf s st2) - Skip s -> Skip (InterleaveInfixFirst s st2) - Stop -> Stop - - step gst (InterleaveInfixSecondBuf st1 st2) = do - r <- step2 gst st2 - return $ case r of - Yield a s -> Skip (InterleaveInfixSecondYield st1 s a) - Skip s -> Skip (InterleaveInfixSecondBuf st1 s) - Stop -> Skip (InterleaveInfixFirstOnly st1) - - step gst (InterleaveInfixSecondYield st1 st2 x) = do - r <- step1 gst st1 - return $ case r of - Yield a s -> Yield x (InterleaveInfixFirstYield s st2 a) - Skip s -> Skip (InterleaveInfixSecondYield s st2 x) - Stop -> Stop - - step _ (InterleaveInfixFirstYield st1 st2 x) = do - return $ Yield x (InterleaveInfixSecondBuf st1 st2) - - step gst (InterleaveInfixFirstOnly st1) = do - r <- step1 gst st1 - return $ case r of - Yield a s -> Yield a (InterleaveInfixFirstOnly s) - Skip s -> Skip (InterleaveInfixFirstOnly s) - Stop -> Stop - -{-# INLINE_NORMAL roundRobin #-} -roundRobin :: Monad m => Stream m a -> Stream m a -> Stream m a -roundRobin (Stream step1 state1) (Stream step2 state2) = - Stream step (InterleaveFirst state1 state2) - - where - - {-# INLINE_LATE step #-} - step gst (InterleaveFirst st1 st2) = do - r <- step1 gst st1 - return $ case r of - Yield a s -> Yield a (InterleaveSecond s st2) - Skip s -> Skip (InterleaveSecond s st2) - Stop -> Skip (InterleaveSecondOnly st2) - - step gst (InterleaveSecond st1 st2) = do - r <- step2 gst st2 - return $ case r of - Yield a s -> Yield a (InterleaveFirst st1 s) - Skip s -> Skip (InterleaveFirst st1 s) - Stop -> Skip (InterleaveFirstOnly st1) - - step gst (InterleaveSecondOnly st2) = do - r <- step2 gst st2 - return $ case r of - Yield a s -> Yield a (InterleaveSecondOnly s) - Skip s -> Skip (InterleaveSecondOnly s) - Stop -> Stop - - step gst (InterleaveFirstOnly st1) = do - r <- step1 gst st1 - return $ case r of - Yield a s -> Yield a (InterleaveFirstOnly s) - Skip s -> Skip (InterleaveFirstOnly s) - Stop -> Stop - -data ICUState s1 s2 i1 i2 = - ICUFirst s1 s2 - | ICUSecond s1 s2 - | ICUSecondOnly s2 - | ICUFirstOnly s1 - | ICUFirstInner s1 s2 i1 - | ICUSecondInner s1 s2 i2 - | ICUFirstOnlyInner s1 i1 - | ICUSecondOnlyInner s2 i2 - --- | Interleave streams (full streams, not the elements) unfolded from two --- input streams and concat. Stop when the first stream stops. If the second --- stream ends before the first one then first stream still keeps running alone --- without any interleaving with the second stream. --- --- [a1, a2, ... an] [b1, b2 ...] --- => [streamA1, streamA2, ... streamAn] [streamB1, streamB2, ...] --- => [streamA1, streamB1, streamA2...StreamAn, streamBn] --- => [a11, a12, ...a1j, b11, b12, ...b1k, a21, a22, ...] --- -{-# INLINE_NORMAL gintercalateSuffix #-} -gintercalateSuffix - :: Monad m - => Unfold m a c -> Stream m a -> Unfold m b c -> Stream m b -> Stream m c -gintercalateSuffix - (Unfold istep1 inject1) (Stream step1 state1) - (Unfold istep2 inject2) (Stream step2 state2) = - Stream step (ICUFirst state1 state2) - - where - - {-# INLINE_LATE step #-} - step gst (ICUFirst s1 s2) = do - r <- step1 (adaptState gst) s1 - case r of - Yield a s -> do - i <- inject1 a - i `seq` return (Skip (ICUFirstInner s s2 i)) - Skip s -> return $ Skip (ICUFirst s s2) - Stop -> return Stop - - step gst (ICUFirstOnly s1) = do - r <- step1 (adaptState gst) s1 - case r of - Yield a s -> do - i <- inject1 a - i `seq` return (Skip (ICUFirstOnlyInner s i)) - Skip s -> return $ Skip (ICUFirstOnly s) - Stop -> return Stop - - step _ (ICUFirstInner s1 s2 i1) = do - r <- istep1 i1 - return $ case r of - Yield x i' -> Yield x (ICUFirstInner s1 s2 i') - Skip i' -> Skip (ICUFirstInner s1 s2 i') - Stop -> Skip (ICUSecond s1 s2) - - step _ (ICUFirstOnlyInner s1 i1) = do - r <- istep1 i1 - return $ case r of - Yield x i' -> Yield x (ICUFirstOnlyInner s1 i') - Skip i' -> Skip (ICUFirstOnlyInner s1 i') - Stop -> Skip (ICUFirstOnly s1) - - step gst (ICUSecond s1 s2) = do - r <- step2 (adaptState gst) s2 - case r of - Yield a s -> do - i <- inject2 a - i `seq` return (Skip (ICUSecondInner s1 s i)) - Skip s -> return $ Skip (ICUSecond s1 s) - Stop -> return $ Skip (ICUFirstOnly s1) - - step _ (ICUSecondInner s1 s2 i2) = do - r <- istep2 i2 - return $ case r of - Yield x i' -> Yield x (ICUSecondInner s1 s2 i') - Skip i' -> Skip (ICUSecondInner s1 s2 i') - Stop -> Skip (ICUFirst s1 s2) - - step _ (ICUSecondOnly _s2) = undefined - step _ (ICUSecondOnlyInner _s2 _i2) = undefined - -data InterposeSuffixState s1 i1 = - InterposeSuffixFirst s1 - -- | InterposeSuffixFirstYield s1 i1 - | InterposeSuffixFirstInner s1 i1 - | InterposeSuffixSecond s1 - --- Note that if an unfolded layer turns out to be nil we still emit the --- separator effect. An alternate behavior could be to emit the separator --- effect only if at least one element has been yielded by the unfolding. --- However, that becomes a bit complicated, so we have chosen the former --- behvaior for now. -{-# INLINE_NORMAL interposeSuffix #-} -interposeSuffix - :: Monad m - => m c -> Unfold m b c -> Stream m b -> Stream m c -interposeSuffix - action - (Unfold istep1 inject1) (Stream step1 state1) = - Stream step (InterposeSuffixFirst state1) - - where - - {-# INLINE_LATE step #-} - step gst (InterposeSuffixFirst s1) = do - r <- step1 (adaptState gst) s1 - case r of - Yield a s -> do - i <- inject1 a - i `seq` return (Skip (InterposeSuffixFirstInner s i)) - -- i `seq` return (Skip (InterposeSuffixFirstYield s i)) - Skip s -> return $ Skip (InterposeSuffixFirst s) - Stop -> return Stop - - {- - step _ (InterposeSuffixFirstYield s1 i1) = do - r <- istep1 i1 - return $ case r of - Yield x i' -> Yield x (InterposeSuffixFirstInner s1 i') - Skip i' -> Skip (InterposeSuffixFirstYield s1 i') - Stop -> Skip (InterposeSuffixFirst s1) - -} - - step _ (InterposeSuffixFirstInner s1 i1) = do - r <- istep1 i1 - return $ case r of - Yield x i' -> Yield x (InterposeSuffixFirstInner s1 i') - Skip i' -> Skip (InterposeSuffixFirstInner s1 i') - Stop -> Skip (InterposeSuffixSecond s1) - - step _ (InterposeSuffixSecond s1) = do - r <- action - return $ Yield r (InterposeSuffixFirst s1) - -data ICALState s1 s2 i1 i2 a = - ICALFirst s1 s2 - -- | ICALFirstYield s1 s2 i1 - | ICALFirstInner s1 s2 i1 - | ICALFirstOnly s1 - | ICALFirstOnlyInner s1 i1 - | ICALSecondInject s1 s2 - | ICALFirstInject s1 s2 i2 - -- | ICALFirstBuf s1 s2 i1 i2 - | ICALSecondInner s1 s2 i1 i2 - -- -- | ICALSecondInner s1 s2 i1 i2 a - -- -- | ICALFirstResume s1 s2 i1 i2 a - --- | Interleave streams (full streams, not the elements) unfolded from two --- input streams and concat. Stop when the first stream stops. If the second --- stream ends before the first one then first stream still keeps running alone --- without any interleaving with the second stream. --- --- [a1, a2, ... an] [b1, b2 ...] --- => [streamA1, streamA2, ... streamAn] [streamB1, streamB2, ...] --- => [streamA1, streamB1, streamA2...StreamAn, streamBn] --- => [a11, a12, ...a1j, b11, b12, ...b1k, a21, a22, ...] --- -{-# INLINE_NORMAL gintercalate #-} -gintercalate - :: Monad m - => Unfold m a c -> Stream m a -> Unfold m b c -> Stream m b -> Stream m c -gintercalate - (Unfold istep1 inject1) (Stream step1 state1) - (Unfold istep2 inject2) (Stream step2 state2) = - Stream step (ICALFirst state1 state2) - - where - - {-# INLINE_LATE step #-} - step gst (ICALFirst s1 s2) = do - r <- step1 (adaptState gst) s1 - case r of - Yield a s -> do - i <- inject1 a - i `seq` return (Skip (ICALFirstInner s s2 i)) - -- i `seq` return (Skip (ICALFirstYield s s2 i)) - Skip s -> return $ Skip (ICALFirst s s2) - Stop -> return Stop - - {- - step _ (ICALFirstYield s1 s2 i1) = do - r <- istep1 i1 - return $ case r of - Yield x i' -> Yield x (ICALFirstInner s1 s2 i') - Skip i' -> Skip (ICALFirstYield s1 s2 i') - Stop -> Skip (ICALFirst s1 s2) - -} - - step _ (ICALFirstInner s1 s2 i1) = do - r <- istep1 i1 - return $ case r of - Yield x i' -> Yield x (ICALFirstInner s1 s2 i') - Skip i' -> Skip (ICALFirstInner s1 s2 i') - Stop -> Skip (ICALSecondInject s1 s2) - - step gst (ICALFirstOnly s1) = do - r <- step1 (adaptState gst) s1 - case r of - Yield a s -> do - i <- inject1 a - i `seq` return (Skip (ICALFirstOnlyInner s i)) - Skip s -> return $ Skip (ICALFirstOnly s) - Stop -> return Stop - - step _ (ICALFirstOnlyInner s1 i1) = do - r <- istep1 i1 - return $ case r of - Yield x i' -> Yield x (ICALFirstOnlyInner s1 i') - Skip i' -> Skip (ICALFirstOnlyInner s1 i') - Stop -> Skip (ICALFirstOnly s1) - - -- We inject the second stream even before checking if the first stream - -- would yield any more elements. There is no clear choice whether we - -- should do this before or after that. Doing it after may make the state - -- machine a bit simpler though. - step gst (ICALSecondInject s1 s2) = do - r <- step2 (adaptState gst) s2 - case r of - Yield a s -> do - i <- inject2 a - i `seq` return (Skip (ICALFirstInject s1 s i)) - Skip s -> return $ Skip (ICALSecondInject s1 s) - Stop -> return $ Skip (ICALFirstOnly s1) - - step gst (ICALFirstInject s1 s2 i2) = do - r <- step1 (adaptState gst) s1 - case r of - Yield a s -> do - i <- inject1 a - i `seq` return (Skip (ICALSecondInner s s2 i i2)) - -- i `seq` return (Skip (ICALFirstBuf s s2 i i2)) - Skip s -> return $ Skip (ICALFirstInject s s2 i2) - Stop -> return Stop - - {- - step _ (ICALFirstBuf s1 s2 i1 i2) = do - r <- istep1 i1 - return $ case r of - Yield x i' -> Skip (ICALSecondInner s1 s2 i' i2 x) - Skip i' -> Skip (ICALFirstBuf s1 s2 i' i2) - Stop -> Stop - - step _ (ICALSecondInner s1 s2 i1 i2 v) = do - r <- istep2 i2 - return $ case r of - Yield x i' -> Yield x (ICALSecondInner s1 s2 i1 i' v) - Skip i' -> Skip (ICALSecondInner s1 s2 i1 i' v) - Stop -> Skip (ICALFirstResume s1 s2 i1 i2 v) - -} - - step _ (ICALSecondInner s1 s2 i1 i2) = do - r <- istep2 i2 - return $ case r of - Yield x i' -> Yield x (ICALSecondInner s1 s2 i1 i') - Skip i' -> Skip (ICALSecondInner s1 s2 i1 i') - Stop -> Skip (ICALFirstInner s1 s2 i1) - -- Stop -> Skip (ICALFirstResume s1 s2 i1 i2) - - {- - step _ (ICALFirstResume s1 s2 i1 i2 x) = do - return $ Yield x (ICALFirstInner s1 s2 i1 i2) - -} - -data InterposeState s1 i1 a = - InterposeFirst s1 - -- | InterposeFirstYield s1 i1 - | InterposeFirstInner s1 i1 - | InterposeFirstInject s1 - -- | InterposeFirstBuf s1 i1 - | InterposeSecondYield s1 i1 - -- -- | InterposeSecondYield s1 i1 a - -- -- | InterposeFirstResume s1 i1 a - --- Note that this only interposes the pure values, we may run many effects to --- generate those values as some effects may not generate anything (Skip). -{-# INLINE_NORMAL interpose #-} -interpose :: Monad m => m c -> Unfold m b c -> Stream m b -> Stream m c -interpose - action - (Unfold istep1 inject1) (Stream step1 state1) = - Stream step (InterposeFirst state1) - - where - - {-# INLINE_LATE step #-} - step gst (InterposeFirst s1) = do - r <- step1 (adaptState gst) s1 - case r of - Yield a s -> do - i <- inject1 a - i `seq` return (Skip (InterposeFirstInner s i)) - -- i `seq` return (Skip (InterposeFirstYield s i)) - Skip s -> return $ Skip (InterposeFirst s) - Stop -> return Stop - - {- - step _ (InterposeFirstYield s1 i1) = do - r <- istep1 i1 - return $ case r of - Yield x i' -> Yield x (InterposeFirstInner s1 i') - Skip i' -> Skip (InterposeFirstYield s1 i') - Stop -> Skip (InterposeFirst s1) - -} - - step _ (InterposeFirstInner s1 i1) = do - r <- istep1 i1 - return $ case r of - Yield x i' -> Yield x (InterposeFirstInner s1 i') - Skip i' -> Skip (InterposeFirstInner s1 i') - Stop -> Skip (InterposeFirstInject s1) - - step gst (InterposeFirstInject s1) = do - r <- step1 (adaptState gst) s1 - case r of - Yield a s -> do - i <- inject1 a - -- i `seq` return (Skip (InterposeFirstBuf s i)) - i `seq` return (Skip (InterposeSecondYield s i)) - Skip s -> return $ Skip (InterposeFirstInject s) - Stop -> return Stop - - {- - step _ (InterposeFirstBuf s1 i1) = do - r <- istep1 i1 - return $ case r of - Yield x i' -> Skip (InterposeSecondYield s1 i' x) - Skip i' -> Skip (InterposeFirstBuf s1 i') - Stop -> Stop - -} - - {- - step _ (InterposeSecondYield s1 i1 v) = do - r <- action - return $ Yield r (InterposeFirstResume s1 i1 v) - -} - step _ (InterposeSecondYield s1 i1) = do - r <- action - return $ Yield r (InterposeFirstInner s1 i1) - - {- - step _ (InterposeFirstResume s1 i1 v) = do - return $ Yield v (InterposeFirstInner s1 i1) - -} - ------------------------------------------------------------------------------- --- Exceptions ------------------------------------------------------------------------------- - -data GbracketState s1 s2 v - = GBracketInit - | GBracketNormal s1 v - | GBracketException s2 - --- | The most general bracketing and exception combinator. All other --- combinators can be expressed in terms of this combinator. This can also be --- used for cases which are not covered by the standard combinators. --- --- /Internal/ --- -{-# INLINE_NORMAL gbracket #-} -gbracket - :: Monad m - => m c -- ^ before - -> (forall s. m s -> m (Either e s)) -- ^ try (exception handling) - -> (c -> m d) -- ^ after, on normal stop - -> (c -> e -> Stream m b) -- ^ on exception - -> (c -> Stream m b) -- ^ stream generator - -> Stream m b -gbracket bef exc aft fexc fnormal = - Stream step GBracketInit - - where - - {-# INLINE_LATE step #-} - step _ GBracketInit = do - r <- bef - return $ Skip $ GBracketNormal (fnormal r) r - - step gst (GBracketNormal (UnStream step1 st) v) = do - res <- exc $ step1 gst st - case res of - Right r -> case r of - Yield x s -> - return $ Yield x (GBracketNormal (Stream step1 s) v) - Skip s -> return $ Skip (GBracketNormal (Stream step1 s) v) - Stop -> aft v >> return Stop - Left e -> return $ Skip (GBracketException (fexc v e)) - step gst (GBracketException (UnStream step1 st)) = do - res <- step1 gst st - case res of - Yield x s -> return $ Yield x (GBracketException (Stream step1 s)) - Skip s -> return $ Skip (GBracketException (Stream step1 s)) - Stop -> return Stop - --- | Run a side effect before the stream yields its first element. -{-# INLINE_NORMAL before #-} -before :: Monad m => m b -> Stream m a -> Stream m a -before action (Stream step state) = Stream step' Nothing - - where - - {-# INLINE_LATE step' #-} - step' _ Nothing = action >> return (Skip (Just state)) - - step' gst (Just st) = do - res <- step gst st - case res of - Yield x s -> return $ Yield x (Just s) - Skip s -> return $ Skip (Just s) - Stop -> return Stop - --- | Run a side effect whenever the stream stops normally. -{-# INLINE_NORMAL after #-} -after :: Monad m => m b -> Stream m a -> Stream m a -after action (Stream step state) = Stream step' state - - where - - {-# INLINE_LATE step' #-} - step' gst st = do - res <- step gst st - case res of - Yield x s -> return $ Yield x s - Skip s -> return $ Skip s - Stop -> action >> return Stop - --- XXX These combinators are expensive due to the call to --- onException/handle/try on each step. Therefore, when possible, they should --- be called in an outer loop where we perform less iterations. For example, we --- cannot call them on each iteration in a char stream, instead we can call --- them when doing an IO on an array. --- --- XXX For high performance error checks in busy streams we may need another --- Error constructor in step. --- --- | Run a side effect whenever the stream aborts due to an exception. The --- exception is not caught, simply rethrown. -{-# INLINE_NORMAL onException #-} -onException :: MonadCatch m => m b -> Stream m a -> Stream m a -onException action str = - gbracket (return ()) MC.try return - (\_ (e :: MC.SomeException) -> nilM (action >> MC.throwM e)) - (\_ -> str) - -{-# INLINE_NORMAL _onException #-} -_onException :: MonadCatch m => m b -> Stream m a -> Stream m a -_onException action (Stream step state) = Stream step' state - - where - - {-# INLINE_LATE step' #-} - step' gst st = do - res <- step gst st `MC.onException` action - case res of - Yield x s -> return $ Yield x s - Skip s -> return $ Skip s - Stop -> return Stop - --- XXX bracket is like concatMap, it generates a stream and then flattens it. --- Like concatMap it has 10x worse performance compared to linear fused --- compositions. --- --- | Run the first action before the stream starts and remember its output, --- generate a stream using the output, run the second action providing the --- remembered value as an argument whenever the stream ends normally or due to --- an exception. -{-# INLINE_NORMAL bracket #-} -bracket :: MonadCatch m => m b -> (b -> m c) -> (b -> Stream m a) -> Stream m a -bracket bef aft bet = - gbracket bef MC.try aft - (\a (e :: SomeException) -> nilM (aft a >> MC.throwM e)) bet - -data BracketState s v = BracketInit | BracketRun s v - -{-# INLINE_NORMAL _bracket #-} -_bracket :: MonadCatch m => m b -> (b -> m c) -> (b -> Stream m a) -> Stream m a -_bracket bef aft bet = Stream step' BracketInit - - where - - {-# INLINE_LATE step' #-} - step' _ BracketInit = bef >>= \x -> return (Skip (BracketRun (bet x) x)) - - -- NOTE: It is important to use UnStream instead of the Stream pattern - -- here, otherwise we get huge perf degradation, see note in concatMap. - step' gst (BracketRun (UnStream step state) v) = do - -- res <- step gst state `MC.onException` aft v - res <- MC.try $ step gst state - case res of - Left (e :: SomeException) -> aft v >> MC.throwM e >> return Stop - Right r -> case r of - Yield x s -> return $ Yield x (BracketRun (Stream step s) v) - Skip s -> return $ Skip (BracketRun (Stream step s) v) - Stop -> aft v >> return Stop - --- | Run a side effect whenever the stream stops normally or aborts due to an --- exception. -{-# INLINE finally #-} -finally :: MonadCatch m => m b -> Stream m a -> Stream m a --- finally action xs = after action $ onException action xs -finally action xs = bracket (return ()) (\_ -> action) (const xs) - --- | When evaluating a stream if an exception occurs, stream evaluation aborts --- and the specified exception handler is run with the exception as argument. -{-# INLINE_NORMAL handle #-} -handle :: (MonadCatch m, Exception e) - => (e -> Stream m a) -> Stream m a -> Stream m a -handle f str = - gbracket (return ()) MC.try return (\_ e -> f e) (\_ -> str) - -{-# INLINE_NORMAL _handle #-} -_handle :: (MonadCatch m, Exception e) - => (e -> Stream m a) -> Stream m a -> Stream m a -_handle f (Stream step state) = Stream step' (Left state) - - where - - {-# INLINE_LATE step' #-} - step' gst (Left st) = do - res <- MC.try $ step gst st - case res of - Left e -> return $ Skip $ Right (f e) - Right r -> case r of - Yield x s -> return $ Yield x (Left s) - Skip s -> return $ Skip (Left s) - Stop -> return Stop - - step' gst (Right (UnStream step1 st)) = do - res <- step1 gst st - case res of - Yield x s -> return $ Yield x (Right (Stream step1 s)) - Skip s -> return $ Skip (Right (Stream step1 s)) - Stop -> return Stop - -------------------------------------------------------------------------------- --- General transformation -------------------------------------------------------------------------------- - -{-# INLINE_NORMAL transform #-} -transform :: Monad m => Pipe m a b -> Stream m a -> Stream m b -transform (Pipe pstep1 pstep2 pstate) (Stream step state) = - Stream step' (Consume pstate, state) - - where - - {-# INLINE_LATE step' #-} - - step' gst (Consume pst, st) = pst `seq` do - r <- step (adaptState gst) st - case r of - Yield x s -> do - res <- pstep1 pst x - case res of - Pipe.Yield b pst' -> return $ Yield b (pst', s) - Pipe.Continue pst' -> return $ Skip (pst', s) - Skip s -> return $ Skip (Consume pst, s) - Stop -> return Stop - - step' _ (Produce pst, st) = pst `seq` do - res <- pstep2 pst - case res of - Pipe.Yield b pst' -> return $ Yield b (pst', st) - Pipe.Continue pst' -> return $ Skip (pst', st) - ------------------------------------------------------------------------------- --- Transformation by Folding (Scans) ------------------------------------------------------------------------------- - ------------------------------------------------------------------------------- --- Prescans ------------------------------------------------------------------------------- - --- 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) - ------------------------------------------------------------------------------- --- Monolithic postscans (postscan followed by a map) ------------------------------------------------------------------------------- - --- The performance of a modular postscan followed by a map seems to be --- equivalent to this monolithic scan followed by map therefore we may not need --- this implementation. We just have it for performance comparison and in case --- modular version does not perform well in some situation. --- -{-# INLINE_NORMAL postscanlMx' #-} -postscanlMx' :: Monad m - => (x -> a -> m x) -> m x -> (x -> m b) -> Stream m a -> Stream m b -postscanlMx' fstep begin done (Stream step state) = do - 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 - old <- acc - y <- fstep old x - v <- done y - v `seq` y `seq` return (Yield v (s, return y)) - Skip s -> return $ Skip (s, acc) - Stop -> return Stop - -{-# INLINE_NORMAL postscanlx' #-} -postscanlx' :: Monad m - => (x -> a -> x) -> x -> (x -> b) -> Stream m a -> Stream m b -postscanlx' fstep begin done s = - postscanlMx' (\b a -> return (fstep b a)) (return begin) (return . done) s - --- XXX do we need consM strict to evaluate the begin value? -{-# INLINE scanlMx' #-} -scanlMx' :: Monad m - => (x -> a -> m x) -> m x -> (x -> m b) -> Stream m a -> Stream m b -scanlMx' fstep begin done s = - (begin >>= \x -> x `seq` done x) `consM` postscanlMx' fstep begin done s - -{-# INLINE scanlx' #-} -scanlx' :: Monad m - => (x -> a -> x) -> x -> (x -> b) -> Stream m a -> Stream m b -scanlx' fstep begin done s = - scanlMx' (\b a -> return (fstep b a)) (return begin) (return . done) s - ------------------------------------------------------------------------------- --- postscans ------------------------------------------------------------------------------- - -{-# 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)) - -{-# INLINE tap #-} -tap :: Monad m => Fold m a b -> Stream m a -> Stream m a -tap (Fold fstep initial extract) (Stream step state) = Stream step' Nothing - - where - - step' _ Nothing = do - r <- initial - return $ Skip (Just (r, state)) - - step' gst (Just (acc, st)) = do - r <- step gst st - case r of - Yield x s -> do - acc' <- fstep acc x - return $ Yield x (Just (acc', s)) - Skip s -> return $ Skip (Just (acc, s)) - Stop -> do - void $ extract acc - return $ Stop - -------------------------------------------------------------------------------- --- Filtering -------------------------------------------------------------------------------- - -{-# 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 y (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 ------------------------------------------------------------------------------- - -data LoopState x s = FirstYield s - | InterspersingYield s - | YieldAndCarry x s - -{-# INLINE_NORMAL intersperseM #-} -intersperseM :: Monad m => m a -> Stream m a -> Stream m a -intersperseM m (Stream step state) = Stream step' (FirstYield state) - where - {-# INLINE_LATE step' #-} - step' gst (FirstYield st) = do - r <- step gst st - return $ - case r of - Yield x s -> Skip (YieldAndCarry x s) - Skip s -> Skip (FirstYield s) - Stop -> Stop - - step' gst (InterspersingYield st) = do - r <- step gst st - case r of - Yield x s -> do - a <- m - return $ Yield a (YieldAndCarry x s) - Skip s -> return $ Skip $ InterspersingYield s - Stop -> return Stop - - step' _ (YieldAndCarry x st) = return $ Yield x (InterspersingYield st) - -data SuffixState s a - = SuffixElem s - | SuffixSuffix s - | SuffixYield a (SuffixState s a) - -{-# INLINE_NORMAL intersperseSuffix #-} -intersperseSuffix :: forall m a. Monad m => m a -> Stream m a -> Stream m a -intersperseSuffix action (Stream step state) = Stream step' (SuffixElem state) - where - {-# INLINE_LATE step' #-} - step' gst (SuffixElem st) = do - r <- step gst st - return $ case r of - Yield x s -> Skip (SuffixYield x (SuffixSuffix s)) - Skip s -> Skip (SuffixElem s) - Stop -> Stop - - step' _ (SuffixSuffix st) = do - action >>= \r -> return $ Skip (SuffixYield r (SuffixElem st)) - - step' _ (SuffixYield x next) = return $ Yield x next - -{-# INLINE intersperse #-} -intersperse :: Monad m => a -> Stream m a -> Stream m a -intersperse a = intersperseM (return a) - -{-# 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 - -#if __GLASGOW_HASKELL__ >= 801 -{-# RULES "zipWithM xs xs" - forall f xs. zipWithM @Identity f xs xs = mapM (\x -> f x x) xs #-} -#endif - -{-# 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)) - ------------------------------------------------------------------------------- --- 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) - --------------------------------------------------------------------------------- --- UTF8 Encoding / Decoding --------------------------------------------------------------------------------- - --- UTF-8 primitives, Lifted from GHC.IO.Encoding.UTF8. - -{-# INLINE ord2 #-} -ord2 :: Char -> WList -ord2 c = assert (n >= 0x80 && n <= 0x07ff) (WCons x1 (WCons x2 WNil)) - where - n = ord c - x1 = fromIntegral $ (n `shiftR` 6) + 0xC0 - x2 = fromIntegral $ (n .&. 0x3F) + 0x80 - -{-# INLINE ord3 #-} -ord3 :: Char -> WList -ord3 c = assert (n >= 0x0800 && n <= 0xffff) (WCons x1 (WCons x2 (WCons x3 WNil))) - where - n = ord c - x1 = fromIntegral $ (n `shiftR` 12) + 0xE0 - x2 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80 - x3 = fromIntegral $ (n .&. 0x3F) + 0x80 - -{-# INLINE ord4 #-} -ord4 :: Char -> WList -ord4 c = assert (n >= 0x10000) (WCons x1 (WCons x2 (WCons x3 (WCons x4 WNil)))) - where - n = ord c - x1 = fromIntegral $ (n `shiftR` 18) + 0xF0 - x2 = fromIntegral $ ((n `shiftR` 12) .&. 0x3F) + 0x80 - x3 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80 - x4 = fromIntegral $ (n .&. 0x3F) + 0x80 - -data CodingFailureMode - = TransliterateCodingFailure - | ErrorOnCodingFailure - deriving (Show) - -{-# INLINE replacementChar #-} -replacementChar :: Char -replacementChar = '\xFFFD' - --- Int helps in cheaper conversion from Int to Char -type CodePoint = Int -type DecodeState = Word8 - --- See http://bjoern.hoehrmann.de/utf-8/decoder/dfa/ for details. - -{-# INLINE runFold #-} -runFold :: (Monad m) => Fold m a b -> Stream m a -> m b -runFold (Fold step begin done) = foldlMx' step begin done - --- XXX Use names decodeSuccess = 0, decodeFailure = 12 - -decodeTable :: [Word8] -decodeTable = [ - -- The first part of the table maps bytes to character classes that - -- to reduce the size of the transition table and create bitmasks. - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, - 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9, - 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, - 8,8,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, - 10,3,3,3,3,3,3,3,3,3,3,3,3,4,3,3, 11,6,6,6,5,8,8,8,8,8,8,8,8,8,8,8, - - -- The second part is a transition table that maps a combination - -- of a state of the automaton and a character class to a state. - 0,12,24,36,60,96,84,12,12,12,48,72, 12,12,12,12,12,12,12,12,12,12,12,12, - 12, 0,12,12,12,12,12, 0,12, 0,12,12, 12,24,12,12,12,12,12,24,12,24,12,12, - 12,12,12,12,12,12,12,24,12,12,12,12, 12,24,12,12,12,12,12,12,12,24,12,12, - 12,12,12,12,12,12,12,36,12,36,12,12, 12,36,12,12,12,12,12,36,12,36,12,12, - 12,36,12,12,12,12,12,12,12,12,12,12 - ] - -utf8d :: A.Array Word8 -utf8d = - unsafePerformIO - -- Aligning to cacheline makes a barely noticeable difference - -- XXX currently alignment is not implemented for unmanaged allocation - $ runFold (A.writeNAlignedUnmanaged 64 (length decodeTable)) - (fromList decodeTable) - --- | Return element at the specified index without checking the bounds. --- and without touching the foreign ptr. -{-# INLINE_NORMAL unsafePeekElemOff #-} -unsafePeekElemOff :: forall a. Storable a => Ptr a -> Int -> a -unsafePeekElemOff p i = let !x = A.unsafeInlineIO $ peekElemOff p i in x - --- decode is split into two separate cases to avoid branching instructions. --- From the higher level flow we already know which case we are in so we can --- call the appropriate decode function. --- --- When the state is 0 -{-# INLINE decode0 #-} -decode0 :: Ptr Word8 -> Word8 -> Tuple' DecodeState CodePoint -decode0 table byte = - let !t = table `unsafePeekElemOff` fromIntegral byte - !codep' = (0xff `shiftR` (fromIntegral t)) .&. fromIntegral byte - !state' = table `unsafePeekElemOff` (256 + fromIntegral t) - in assert ((byte > 0x7f || error showByte) - && (state' /= 0 || error (showByte ++ showTable))) - (Tuple' state' codep') - - where - - utf8table = - let !(Ptr addr) = table - end = table `plusPtr` 364 - in A.Array (ForeignPtr addr undefined) end end :: A.Array Word8 - showByte = "Streamly: decode0: byte: " ++ show byte - showTable = " table: " ++ show utf8table - --- When the state is not 0 -{-# INLINE decode1 #-} -decode1 - :: Ptr Word8 - -> DecodeState - -> CodePoint - -> Word8 - -> Tuple' DecodeState CodePoint -decode1 table state codep byte = - -- Remember codep is Int type! - -- Can it be unsafe to convert the resulting Int to Char? - let !t = table `unsafePeekElemOff` fromIntegral byte - !codep' = (fromIntegral byte .&. 0x3f) .|. (codep `shiftL` 6) - !state' = table `unsafePeekElemOff` - (256 + fromIntegral state + fromIntegral t) - in assert (codep' <= 0x10FFFF - || error (showByte ++ showState state codep)) - (Tuple' state' codep') - where - - utf8table = - let !(Ptr addr) = table - end = table `plusPtr` 364 - in A.Array (ForeignPtr addr undefined) end end :: A.Array Word8 - showByte = "Streamly: decode1: byte: " ++ show byte - showState st cp = - " state: " ++ show st ++ - " codepoint: " ++ show cp ++ - " table: " ++ show utf8table - --- We can divide the errors in three general categories: --- * A non-starter was encountered in a begin state --- * A starter was encountered without completing a codepoint --- * The last codepoint was not complete (input underflow) --- -data DecodeError = DecodeError !DecodeState !CodePoint deriving Show - -data FreshPoint s a - = FreshPointDecodeInit s - | FreshPointDecodeInit1 s Word8 - | FreshPointDecodeFirst s Word8 - | FreshPointDecoding s !DecodeState !CodePoint - | YieldAndContinue a (FreshPoint s a) - | Done - --- XXX Add proper error messages --- XXX Implement this in terms of decodeUtf8Either -{-# INLINE_NORMAL decodeUtf8With #-} -decodeUtf8With :: Monad m => CodingFailureMode -> Stream m Word8 -> Stream m Char -decodeUtf8With cfm (Stream step state) = - let Array p _ _ = utf8d - !ptr = (unsafeForeignPtrToPtr p) - in Stream (step' ptr) (FreshPointDecodeInit state) - where - {-# INLINE transliterateOrError #-} - transliterateOrError e s = - case cfm of - ErrorOnCodingFailure -> error e - TransliterateCodingFailure -> YieldAndContinue replacementChar s - {-# INLINE inputUnderflow #-} - inputUnderflow = - case cfm of - ErrorOnCodingFailure -> - error "Streamly.Streams.StreamD.decodeUtf8With: Input Underflow" - TransliterateCodingFailure -> YieldAndContinue replacementChar Done - {-# INLINE_LATE step' #-} - step' _ gst (FreshPointDecodeInit st) = do - r <- step (adaptState gst) st - return $ case r of - Yield x s -> Skip (FreshPointDecodeInit1 s x) - Skip s -> Skip (FreshPointDecodeInit s) - Stop -> Skip Done - - step' _ _ (FreshPointDecodeInit1 st x) = do - -- Note: It is important to use a ">" instead of a "<=" test - -- here for GHC to generate code layout for default branch - -- prediction for the common case. This is fragile and might - -- change with the compiler versions, we need a more reliable - -- "likely" primitive to control branch predication. - case x > 0x7f of - False -> - return $ Skip $ YieldAndContinue - (unsafeChr (fromIntegral x)) - (FreshPointDecodeInit st) - -- Using a separate state here generates a jump to a - -- separate code block in the core which seems to perform - -- slightly better for the non-ascii case. - True -> return $ Skip $ FreshPointDecodeFirst st x - - -- XXX should we merge it with FreshPointDecodeInit1? - step' table _ (FreshPointDecodeFirst st x) = do - let (Tuple' sv cp) = decode0 table x - return $ - case sv of - 12 -> - Skip $ - transliterateOrError - "Streamly.Streams.StreamD.decodeUtf8With: Invalid UTF8 codepoint encountered" - (FreshPointDecodeInit st) - 0 -> error "unreachable state" - _ -> Skip (FreshPointDecoding st sv cp) - - -- We recover by trying the new byte x a starter of a new codepoint. - -- XXX need to use the same recovery in array decoding routine as well - step' table gst (FreshPointDecoding st statePtr codepointPtr) = do - r <- step (adaptState gst) st - case r of - Yield x s -> do - let (Tuple' sv cp) = decode1 table statePtr codepointPtr x - return $ - case sv of - 0 -> Skip $ YieldAndContinue (unsafeChr cp) - (FreshPointDecodeInit s) - 12 -> - Skip $ - transliterateOrError - "Streamly.Streams.StreamD.decodeUtf8With: Invalid UTF8 codepoint encountered" - (FreshPointDecodeInit1 s x) - _ -> Skip (FreshPointDecoding s sv cp) - Skip s -> return $ Skip (FreshPointDecoding s statePtr codepointPtr) - Stop -> return $ Skip inputUnderflow - - step' _ _ (YieldAndContinue c s) = return $ Yield c s - step' _ _ Done = return Stop - -{-# INLINE decodeUtf8 #-} -decodeUtf8 :: Monad m => Stream m Word8 -> Stream m Char -decodeUtf8 = decodeUtf8With ErrorOnCodingFailure - -{-# INLINE decodeUtf8Lenient #-} -decodeUtf8Lenient :: Monad m => Stream m Word8 -> Stream m Char -decodeUtf8Lenient = decodeUtf8With TransliterateCodingFailure - -{-# INLINE_NORMAL resumeDecodeUtf8Either #-} -resumeDecodeUtf8Either - :: Monad m - => DecodeState - -> CodePoint - -> Stream m Word8 - -> Stream m (Either DecodeError Char) -resumeDecodeUtf8Either dst codep (Stream step state) = - let Array p _ _ = utf8d - !ptr = (unsafeForeignPtrToPtr p) - stt = - if dst == 0 - then FreshPointDecodeInit state - else FreshPointDecoding state dst codep - in Stream (step' ptr) stt - where - {-# INLINE_LATE step' #-} - step' _ gst (FreshPointDecodeInit st) = do - r <- step (adaptState gst) st - return $ case r of - Yield x s -> Skip (FreshPointDecodeInit1 s x) - Skip s -> Skip (FreshPointDecodeInit s) - Stop -> Skip Done - - step' _ _ (FreshPointDecodeInit1 st x) = do - -- Note: It is important to use a ">" instead of a "<=" test - -- here for GHC to generate code layout for default branch - -- prediction for the common case. This is fragile and might - -- change with the compiler versions, we need a more reliable - -- "likely" primitive to control branch predication. - case x > 0x7f of - False -> - return $ Skip $ YieldAndContinue - (Right $ unsafeChr (fromIntegral x)) - (FreshPointDecodeInit st) - -- Using a separate state here generates a jump to a - -- separate code block in the core which seems to perform - -- slightly better for the non-ascii case. - True -> return $ Skip $ FreshPointDecodeFirst st x - - -- XXX should we merge it with FreshPointDecodeInit1? - step' table _ (FreshPointDecodeFirst st x) = do - let (Tuple' sv cp) = decode0 table x - return $ - case sv of - 12 -> - Skip $ YieldAndContinue (Left $ DecodeError 0 (fromIntegral x)) - (FreshPointDecodeInit st) - 0 -> error "unreachable state" - _ -> Skip (FreshPointDecoding st sv cp) - - -- We recover by trying the new byte x a starter of a new codepoint. - -- XXX need to use the same recovery in array decoding routine as well - step' table gst (FreshPointDecoding st statePtr codepointPtr) = do - r <- step (adaptState gst) st - case r of - Yield x s -> do - let (Tuple' sv cp) = decode1 table statePtr codepointPtr x - return $ - case sv of - 0 -> Skip $ YieldAndContinue (Right $ unsafeChr cp) - (FreshPointDecodeInit s) - 12 -> - Skip $ YieldAndContinue (Left $ DecodeError statePtr codepointPtr) - (FreshPointDecodeInit1 s x) - _ -> Skip (FreshPointDecoding s sv cp) - Skip s -> return $ Skip (FreshPointDecoding s statePtr codepointPtr) - Stop -> return $ Skip $ YieldAndContinue (Left $ DecodeError statePtr codepointPtr) Done - - step' _ _ (YieldAndContinue c s) = return $ Yield c s - step' _ _ Done = return Stop - -{-# INLINE_NORMAL decodeUtf8Either #-} -decodeUtf8Either :: Monad m - => Stream m Word8 -> Stream m (Either DecodeError Char) -decodeUtf8Either = resumeDecodeUtf8Either 0 0 - -data FlattenState s a - = OuterLoop s !(Maybe (DecodeState, CodePoint)) - | InnerLoopDecodeInit s (ForeignPtr a) !(Ptr a) !(Ptr a) - | InnerLoopDecodeFirst s (ForeignPtr a) !(Ptr a) !(Ptr a) Word8 - | InnerLoopDecoding s (ForeignPtr a) !(Ptr a) !(Ptr a) - !DecodeState !CodePoint - | YAndC !Char (FlattenState s a) -- These constructors can be - -- encoded in the FreshPoint - -- type, I prefer to keep these - -- flat even though that means - -- coming up with new names - | D - --- The normal decodeUtf8 above should fuse with flattenArrays --- to create this exact code but it doesn't for some reason, as of now this --- remains the fastest way I could figure out to decodeUtf8. --- --- XXX Add Proper error messages -{-# INLINE_NORMAL decodeUtf8ArraysWith #-} -decodeUtf8ArraysWith :: - MonadIO m - => CodingFailureMode - -> Stream m (A.Array Word8) - -> Stream m Char -decodeUtf8ArraysWith cfm (Stream step state) = - let Array p _ _ = utf8d - !ptr = (unsafeForeignPtrToPtr p) - in Stream (step' ptr) (OuterLoop state Nothing) - where - {-# INLINE transliterateOrError #-} - transliterateOrError e s = - case cfm of - ErrorOnCodingFailure -> error e - TransliterateCodingFailure -> YAndC replacementChar s - {-# INLINE inputUnderflow #-} - inputUnderflow = - case cfm of - ErrorOnCodingFailure -> - error - "Streamly.Streams.StreamD.decodeUtf8ArraysWith: Input Underflow" - TransliterateCodingFailure -> YAndC replacementChar D - {-# INLINE_LATE step' #-} - step' _ gst (OuterLoop st Nothing) = do - r <- step (adaptState gst) st - return $ - case r of - Yield A.Array {..} s -> - let p = unsafeForeignPtrToPtr aStart - in Skip (InnerLoopDecodeInit s aStart p aEnd) - Skip s -> Skip (OuterLoop s Nothing) - Stop -> Skip D - step' _ gst (OuterLoop st dst@(Just (ds, cp))) = do - r <- step (adaptState gst) st - return $ - case r of - Yield A.Array {..} s -> - let p = unsafeForeignPtrToPtr aStart - in Skip (InnerLoopDecoding s aStart p aEnd ds cp) - Skip s -> Skip (OuterLoop s dst) - Stop -> Skip inputUnderflow - step' _ _ (InnerLoopDecodeInit st startf p end) - | p == end = do - liftIO $ touchForeignPtr startf - return $ Skip $ OuterLoop st Nothing - step' _ _ (InnerLoopDecodeInit st startf p end) = do - x <- liftIO $ peek p - -- Note: It is important to use a ">" instead of a "<=" test here for - -- GHC to generate code layout for default branch prediction for the - -- common case. This is fragile and might change with the compiler - -- versions, we need a more reliable "likely" primitive to control - -- branch predication. - case x > 0x7f of - False -> - return $ Skip $ YAndC - (unsafeChr (fromIntegral x)) - (InnerLoopDecodeInit st startf (p `plusPtr` 1) end) - -- Using a separate state here generates a jump to a separate code - -- block in the core which seems to perform slightly better for the - -- non-ascii case. - True -> return $ Skip $ InnerLoopDecodeFirst st startf p end x - - step' table _ (InnerLoopDecodeFirst st startf p end x) = do - let (Tuple' sv cp) = decode0 table x - return $ - case sv of - 12 -> - Skip $ - transliterateOrError - "Streamly.Streams.StreamD.decodeUtf8ArraysWith: Invalid UTF8 codepoint encountered" - (InnerLoopDecodeInit st startf (p `plusPtr` 1) end) - 0 -> error "unreachable state" - _ -> Skip (InnerLoopDecoding st startf (p `plusPtr` 1) end sv cp) - step' _ _ (InnerLoopDecoding st startf p end sv cp) - | p == end = do - liftIO $ touchForeignPtr startf - return $ Skip $ OuterLoop st (Just (sv, cp)) - step' table _ (InnerLoopDecoding st startf p end statePtr codepointPtr) = do - x <- liftIO $ peek p - let (Tuple' sv cp) = decode1 table statePtr codepointPtr x - return $ - case sv of - 0 -> - Skip $ - YAndC - (unsafeChr cp) - (InnerLoopDecodeInit st startf (p `plusPtr` 1) end) - 12 -> - Skip $ - transliterateOrError - "Streamly.Streams.StreamD.decodeUtf8ArraysWith: Invalid UTF8 codepoint encountered" - (InnerLoopDecodeInit st startf (p `plusPtr` 1) end) - _ -> Skip (InnerLoopDecoding st startf (p `plusPtr` 1) end sv cp) - step' _ _ (YAndC c s) = return $ Yield c s - step' _ _ D = return Stop - -{-# INLINE decodeUtf8Arrays #-} -decodeUtf8Arrays :: - MonadIO m - => Stream m (A.Array Word8) - -> Stream m Char -decodeUtf8Arrays = decodeUtf8ArraysWith ErrorOnCodingFailure - -{-# INLINE decodeUtf8ArraysLenient #-} -decodeUtf8ArraysLenient :: - MonadIO m - => Stream m (A.Array Word8) - -> Stream m Char -decodeUtf8ArraysLenient = decodeUtf8ArraysWith TransliterateCodingFailure - -data WList = WCons !Word8 !WList | WNil - -data EncodeState s = EncodeState s !WList - --- More yield points improve performance, but I am not sure if they can cause --- too much code bloat or some trouble with fusion. So keeping only two yield --- points for now, one for the ascii chars (fast path) and one for all other --- paths (slow path). -{-# INLINE_NORMAL encodeUtf8 #-} -encodeUtf8 :: Monad m => Stream m Char -> Stream m Word8 -encodeUtf8 (Stream step state) = Stream step' (EncodeState state WNil) - where - {-# INLINE_LATE step' #-} - step' gst (EncodeState st WNil) = do - r <- step (adaptState gst) st - return $ - case r of - Yield c s -> - case ord c of - x - | x <= 0x7F -> - Yield (fromIntegral x) (EncodeState s WNil) - | x <= 0x7FF -> Skip (EncodeState s (ord2 c)) - | x <= 0xFFFF -> - if isSurrogate c - then error - "Streamly.Streams.StreamD.encodeUtf8: Encountered a surrogate" - else Skip (EncodeState s (ord3 c)) - | otherwise -> Skip (EncodeState s (ord4 c)) - Skip s -> Skip (EncodeState s WNil) - Stop -> Stop - step' _ (EncodeState s (WCons x xs)) = return $ Yield x (EncodeState s xs) diff --git a/src/Streamly/Streams/StreamDK.hs b/src/Streamly/Streams/StreamDK.hs deleted file mode 100644 --- a/src/Streamly/Streams/StreamDK.hs +++ /dev/null @@ -1,165 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} --- {-# LANGUAGE ScopedTypeVariables #-} - -#include "inline.hs" - --- | --- Module : Streamly.Streams.StreamDK --- Copyright : (c) 2019 Composewell Technologies --- License : BSD3 --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- - -module Streamly.Streams.StreamDK - ( - -- * Stream Type - - Stream - , Step (..) - - -- * Construction - , nil - , cons - , consM - , unfoldr - , unfoldrM - , replicateM - - -- * Folding - , uncons - , foldrS - - -- * Specific Folds - , drain - ) -where - -import Streamly.Streams.StreamDK.Type (Stream(..), Step(..)) - -------------------------------------------------------------------------------- --- Construction -------------------------------------------------------------------------------- - -nil :: Monad m => Stream m a -nil = Stream $ return Stop - -{-# INLINE_NORMAL cons #-} -cons :: Monad m => a -> Stream m a -> Stream m a -cons x xs = Stream $ return $ Yield x xs - -consM :: Monad m => m a -> Stream m a -> Stream m a -consM eff xs = Stream $ eff >>= \x -> return $ Yield x xs - -unfoldrM :: Monad m => (s -> m (Maybe (a, s))) -> s -> Stream m a -unfoldrM next state = Stream (step' state) - where - step' st = do - r <- next st - return $ case r of - Just (x, s) -> Yield x (Stream (step' s)) - Nothing -> Stop -{- -unfoldrM next s0 = buildM $ \yld stp -> - let go s = do - r <- next s - case r of - Just (a, b) -> yld a (go b) - Nothing -> stp - in go s0 --} - -{-# INLINE unfoldr #-} -unfoldr :: Monad m => (b -> Maybe (a, b)) -> b -> Stream m a -unfoldr next s0 = build $ \yld stp -> - let go s = - case next s of - Just (a, b) -> yld a (go b) - Nothing -> stp - in go s0 - -replicateM :: Monad m => Int -> a -> Stream m a -replicateM n x = Stream (step n) - where - step i = return $ - if i <= 0 - then Stop - else Yield x (Stream (step (i - 1))) - -------------------------------------------------------------------------------- --- Folding -------------------------------------------------------------------------------- - -uncons :: Monad m => Stream m a -> m (Maybe (a, Stream m a)) -uncons (Stream step) = do - r <- step - return $ case r of - Yield x xs -> Just (x, xs) - Stop -> Nothing - --- | Lazy right associative fold to a stream. -{-# INLINE_NORMAL foldrS #-} -foldrS :: Monad m - => (a -> Stream m b -> Stream m b) - -> Stream m b - -> Stream m a - -> Stream m b -foldrS f streamb = go - where - go (Stream stepa) = Stream $ do - r <- stepa - case r of - Yield x xs -> let Stream step = f x (go xs) in step - Stop -> let Stream step = streamb in step - -{-# INLINE_LATE foldrM #-} -foldrM :: Monad m => (a -> m b -> m b) -> m b -> Stream m a -> m b -foldrM fstep acc ys = go ys - where - go (Stream step) = do - r <- step - case r of - Yield x xs -> fstep x (go xs) - Stop -> acc - -{-# INLINE_NORMAL build #-} -build :: Monad m - => forall a. (forall b. (a -> b -> b) -> b -> b) -> Stream m a -build g = g cons nil - -{-# RULES -"foldrM/build" forall k z (g :: forall b. (a -> b -> b) -> b -> b). - foldrM k z (build g) = g k z #-} - -{- --- To fuse foldrM with unfoldrM we need the type m1 to be polymorphic such that --- it is either Monad m or Stream m. So that we can use cons/nil as well as --- monadic construction function as its arguments. --- -{-# INLINE_NORMAL buildM #-} -buildM :: Monad m - => forall a. (forall b. (a -> m1 b -> m1 b) -> m1 b -> m1 b) -> Stream m a -buildM g = g cons nil --} - -------------------------------------------------------------------------------- --- Specific folds -------------------------------------------------------------------------------- - -{-# INLINE drain #-} -drain :: Monad m => Stream m a -> m () -drain = foldrM (\_ xs -> xs) (return ()) -{- -drain (Stream step) = do - r <- step - case r of - Yield _ next -> drain next - Stop -> return () - -} diff --git a/src/Streamly/Streams/StreamDK/Type.hs b/src/Streamly/Streams/StreamDK/Type.hs deleted file mode 100644 --- a/src/Streamly/Streams/StreamDK/Type.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} - --- | --- Module : Streamly.StreamDK.Type --- Copyright : (c) 2019 Composewell Technologies --- License : BSD3 --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- --- A CPS style stream using a constructor based representation instead of a --- function based representation. --- --- Streamly internally uses two fundamental stream representations, (1) streams --- with an open or arbitrary control flow (we call it StreamK), (2) streams --- with a structured or closed loop control flow (we call it StreamD). The --- higher level stream types can use any of these representations under the --- hood and can interconvert between the two. --- --- StreamD: --- --- StreamD is a non-recursive data type in which the state of the stream and --- the step function are separate. When the step function is called, a stream --- element and the new stream state is yielded. The generated element and the --- state are passed to the next consumer in the loop. The state is threaded --- around in the loop until control returns back to the original step function --- to run the next step. This creates a structured closed loop representation --- (like "for" loops in C) with state of each step being hidden/abstracted or --- existential within that step. This creates a loop representation identical --- to the "for" or "while" loop constructs in imperative languages, the states --- of the steps combined together constitute the state of the loop iteration. --- --- Internally most combinators use a closed loop representation because it --- provides very high efficiency due to stream fusion. The performance of this --- representation is competitive to the C language implementations. --- --- Pros and Cons of StreamD: --- --- 1) stream-fusion: This representation can be optimized very efficiently by --- the compiler because the state is explicitly separated from step functions, --- represented using pure data constructors and visible to the compiler, the --- stream steps can be fused using case-of-case transformations and the state --- can be specialized using spec-constructor optimization, yielding a C like --- tight loop/state machine with no constructors, the state is used unboxed and --- therefore no unnecessary allocation. --- --- 2) Because of a closed representation consing too many elements in this type --- of stream does not scale, it will have quadratic performance slowdown. Each --- cons creates a layer that needs to return the control back to the caller. --- Another implementation of cons is possible but that will have to box/unbox --- the state and will not fuse. So effectively cons breaks fusion. --- --- 3) unconsing an item from the stream breaks fusion, we have to "pause" the --- loop, rebox and save the state. --- --- 3) Exception handling is easy to implement in this model because control --- flow is structured in the loop and cannot be arbitrary. Therefore, --- implementing "bracket" is natural. --- --- 4) Round-robin scheduling for co-operative multitasking is easy to implement. --- --- 5) It fuses well with the direct style Fold implementation. --- --- StreamK/StreamDK: --- --- StreamDK i.e. the stream defined in this module, like StreamK, is a --- recursive data type which has no explicit state defined using constructors, --- each step yields an element and a computation representing the rest of the --- stream. Stream state is part of the function representing the rest of the --- stream. This creates an open computation representation, or essentially a --- continuation passing style computation. After the stream step is executed, --- the caller is free to consume the produced element and then send the control --- wherever it wants, there is no restriction on the control to return back --- somewhere, the control is free to go anywhere. The caller may decide not to --- consume the rest of the stream. This representation is more like a "goto" --- based implementation in imperative languages. --- --- Pros and Cons of StreamK: --- --- 1) The way StreamD can be optimized using stream-fusion, this type can be --- optimized using foldr/build fusion. However, foldr/build has not yet been --- fully implemented for StreamK/StreamDK. --- --- 2) Using cons is natural in this representation, unlike in StreamD it does --- not have a quadratic slowdown. Currently, we in fact wrap StreamD in StreamK --- to support a better cons operation. --- --- 3) Similarly, uncons is natural in this representation. --- --- 4) Exception handling is not easy to implement because of the "goto" nature --- of CPS. --- --- 5) Composable folds are not implemented/proven, however, intuition says that --- a push style CPS representation should be able to be used along with StreamK --- to efficiently implement composable folds. - -module Streamly.Streams.StreamDK.Type - ( Step(..) - , Stream (..) - ) -where - --- XXX Use Cons and Nil instead of Yield and Stop? -data Step m a = Yield a (Stream m a) | Stop - -data Stream m a = Stream (m (Step m a)) diff --git a/src/Streamly/Streams/StreamK.hs b/src/Streamly/Streams/StreamK.hs deleted file mode 100644 --- a/src/Streamly/Streams/StreamK.hs +++ /dev/null @@ -1,1037 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UndecidableInstances #-} -- XXX - -#include "inline.hs" - --- | --- Module : Streamly.Streams.StreamK --- Copyright : (c) 2017 Harendra Kumar --- --- License : BSD3 --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- --- --- Continuation passing style (CPS) stream implementation. The symbol 'K' below --- denotes a function as well as a Kontinuation. --- --- @ --- import qualified Streamly.Streams.StreamK as K --- @ --- -module Streamly.Streams.StreamK - ( - -- * A class for streams - IsStream (..) - , adapt - - -- * The stream type - , Stream - - -- * Construction Primitives - , mkStream - , nil - , nilM - , cons - , (.:) - - -- * Elimination Primitives - , foldStream - , foldStreamShared - , foldStreamSVar - - -- * Transformation Primitives - , unShare - - -- * Deconstruction - , uncons - - -- * Generation - -- ** Unfolds - , unfoldr - , unfoldrM - - -- ** Specialized Generation - , repeat - , repeatM - , replicate - , replicateM - , fromIndices - , fromIndicesM - - -- ** Conversions - , yield - , yieldM - , fromFoldable - , fromList - , fromStreamK - - -- * foldr/build - , foldrS - , foldrSM - , buildS - , buildM - , augmentS - , augmentSM - - -- * Elimination - -- ** General Folds - , foldr - , foldr1 - , foldrM - , foldrT - - , foldl' - , foldlM' - , foldlS - , foldlT - , foldlx' - , foldlMx' - - -- ** Specialized Folds - , drain - , null - , head - , tail - , init - , elem - , notElem - , all - , any - , last - , minimum - , minimumBy - , maximum - , maximumBy - , findIndices - , lookup - , findM - , find - , (!!) - - -- ** Map and Fold - , mapM_ - - -- ** Conversions - , toList - , toStreamK - , hoist - - -- * Transformation - -- ** By folding (scans) - , scanl' - , scanlx' - - -- ** Filtering - , filter - , take - , takeWhile - , drop - , dropWhile - - -- ** Mapping - , map - , mapM - , mapMSerial - , sequence - - -- ** Inserting - , intersperseM - , intersperse - , insertBy - - -- ** Deleting - , deleteBy - - -- ** Reordering - , reverse - - -- ** Map and Filter - , mapMaybe - - -- ** Zipping - , zipWith - , zipWithM - - -- ** Merging - , mergeBy - , mergeByM - - -- ** Nesting - , concatMapBy - , concatMap - , bindWith - - -- ** Transformation comprehensions - , the - - -- * Semigroup Style Composition - , serial - - -- * Utilities - , consMStream - , withLocal - - -- * Deprecated - , Streaming -- deprecated - , once -- deprecated - ) -where - -import Control.Monad.Trans (MonadTrans(lift)) -import Control.Monad (void, join) -import Control.Monad.Reader.Class (MonadReader(..)) -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, (!!), replicate, reverse, concatMap) -import qualified Prelude - -import Streamly.Internal.Data.SVar -import Streamly.Streams.StreamK.Type - -------------------------------------------------------------------------------- --- Deconstruction -------------------------------------------------------------------------------- - -{-# INLINE uncons #-} -uncons :: (IsStream t, Monad m) => t m a -> m (Maybe (a, t m a)) -uncons m = - let stop = return Nothing - single a = return (Just (a, nil)) - yieldk a r = return (Just (a, r)) - in foldStream defState yieldk single stop m - -------------------------------------------------------------------------------- --- Generation -------------------------------------------------------------------------------- - -{-# INLINE unfoldr #-} -unfoldr :: IsStream t => (b -> Maybe (a, b)) -> b -> t m a -unfoldr next s0 = build $ \yld stp -> - let go s = - case next s of - Just (a, b) -> yld a (go b) - Nothing -> stp - in go s0 - -{-# INLINE unfoldrM #-} -unfoldrM :: (IsStream t, MonadAsync m) => (b -> m (Maybe (a, b))) -> b -> t m a -unfoldrM step = go - where - go s = sharedM $ \yld _ stp -> do - r <- step s - case r of - Just (a, b) -> yld a (go b) - Nothing -> stp - -{- --- Generalization of concurrent streams/SVar via unfoldr. --- --- Unfold a value into monadic actions and then run the resulting monadic --- actions to generate a stream. Since the step of generating the monadic --- action and running them are decoupled we can run the monadic actions --- cooncurrently. For example, the seed could be a list of monadic actions or a --- pure stream of monadic actions. --- --- We can have different flavors of this depending on the stream type t. The --- concurrent version could be async or ahead etc. Depending on how we queue --- back the feedback portion b, it could be DFS or BFS style. --- -unfoldrA :: (IsStream t, MonadAsync m) => (b -> Maybe (m a, b)) -> b -> t m a -unfoldrA = undefined --} - -------------------------------------------------------------------------------- --- Special generation -------------------------------------------------------------------------------- - --- | Same as yieldM --- --- @since 0.2.0 -{-# DEPRECATED once "Please use yieldM instead." #-} -{-# INLINE once #-} -once :: (Monad m, IsStream t) => m a -> t m a -once = yieldM - --- | --- @ --- repeatM = fix . cons --- repeatM = cycle1 . yield --- @ --- --- Generate an infinite stream by repeating a monadic value. --- --- /Internal/ -repeatM :: (IsStream t, MonadAsync m) => m a -> t m a -repeatM = go - where go m = m |: go m - --- Generate an infinite stream by repeating a pure value. --- --- /Internal/ -{-# 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) - -{-# INLINE fromIndicesM #-} -fromIndicesM :: (IsStream t, MonadAsync m) => (Int -> m a) -> t m a -fromIndicesM gen = go 0 - where - go i = mkStream $ \st stp sng yld -> do - foldStreamShared st stp sng yld (gen i |: go (i + 1)) - -{-# INLINE fromIndices #-} -fromIndices :: IsStream t => (Int -> a) -> t m a -fromIndices gen = go 0 - where - go n = (gen n) `cons` go (n + 1) - -------------------------------------------------------------------------------- --- Conversions -------------------------------------------------------------------------------- - --- | --- @ --- 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 -fromFoldable = Prelude.foldr cons nil - -{-# INLINE fromList #-} -fromList :: IsStream t => [a] -> t m a -fromList = fromFoldable - -{-# INLINE fromStreamK #-} -fromStreamK :: IsStream t => Stream m a -> t m a -fromStreamK = fromStream - -------------------------------------------------------------------------------- --- Elimination by Folding -------------------------------------------------------------------------------- - --- | Lazy right associative fold. -{-# INLINE foldr #-} -foldr :: (IsStream t, Monad m) => (a -> b -> b) -> b -> t m a -> m b -foldr step acc = foldrM (\x xs -> xs >>= \b -> return (step x b)) (return acc) - --- | Right associative fold to an arbitrary transformer monad. -{-# INLINE foldrT #-} -foldrT :: (IsStream t, Monad m, Monad (s m), MonadTrans s) - => (a -> s m b -> s m b) -> s m b -> t m a -> s m b -foldrT step final m = go m - where - go m1 = do - res <- lift $ uncons m1 - case res of - Just (h, t) -> step h (go t) - Nothing -> final - -{-# INLINE foldr1 #-} -foldr1 :: (IsStream t, Monad m) => (a -> a -> a) -> t m a -> m (Maybe a) -foldr1 step m = do - r <- uncons m - case r of - Nothing -> return Nothing - 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 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 foldlx' #-} -foldlx' :: forall t m a b x. (IsStream t, Monad m) - => (x -> a -> x) -> x -> (x -> b) -> t m a -> m b -foldlx' 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 - -- 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 :: t m a -> x -> t m x - go m1 !acc = mkStream $ \_ yld sng _ -> - let stop = sng acc - single a = sng $ step acc a - -- 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' #-} -foldl' :: (IsStream t, Monad m) => (b -> a -> b) -> b -> t m a -> m b -foldl' step begin = foldlx' step begin id - --- XXX replace the recursive "go" with explicit continuations. --- | Like 'foldx', but with a monadic step function. -{-# INLINABLE foldlMx' #-} -foldlMx' :: (IsStream t, Monad m) - => (x -> a -> m x) -> m x -> (x -> m b) -> t m a -> m b -foldlMx' 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 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 = foldlMx' step (return begin) return - --- | Lazy left fold to a stream. -{-# INLINE foldlS #-} -foldlS :: IsStream t => (t m b -> a -> t m b) -> t m b -> t m a -> t m b -foldlS step begin m = go begin m - where - go acc rest = mkStream $ \st yld sng stp -> - let run x = foldStream st yld sng stp x - stop = run acc - single a = run $ step acc a - yieldk a r = run $ go (step acc a) r - in foldStream (adaptState st) yieldk single stop rest - --- | Lazy left fold to an arbitrary transformer monad. -{-# INLINE foldlT #-} -foldlT :: (IsStream t, Monad m, Monad (s m), MonadTrans s) - => (s m b -> a -> s m b) -> s m b -> t m a -> s m b -foldlT step begin m = go begin m - where - go acc m1 = do - res <- lift $ uncons m1 - case res of - Just (h, t) -> go (step acc h) t - Nothing -> acc - ------------------------------------------------------------------------------- --- Specialized folds ------------------------------------------------------------------------------- - --- XXX use foldrM to implement folds where possible --- XXX This (commented) definition of drain and mapM_ perform much better on --- some benchmarks but worse on others. Need to investigate why, may there is --- an optimization opportunity that we can exploit. --- drain = foldrM (\_ xs -> return () >> xs) (return ()) - --- | --- > drain = foldl' (\_ _ -> ()) () --- > drain = mapM_ (\_ -> return ()) -{-# INLINE drain #-} -drain :: (Monad m, IsStream t) => t m a -> m () -drain = foldrM (\_ xs -> xs) (return ()) -{- -drain = go - where - go m1 = - let stop = return () - single _ = return () - yieldk _ r = go r - in foldStream defState yieldk single stop m1 --} - -{-# INLINE null #-} -null :: (IsStream t, Monad m) => t m a -> m Bool --- null = foldrM (\_ _ -> return True) (return False) -null m = - let stop = return True - single _ = return False - yieldk _ _ = return False - in foldStream defState yieldk single stop m - -{-# INLINE head #-} -head :: (IsStream t, Monad m) => t m a -> m (Maybe a) --- head = foldrM (\x _ -> return $ Just x) (return Nothing) -head m = - let stop = return Nothing - single a = return (Just a) - yieldk a _ = return (Just a) - 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 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 m - where - go1 m1 = do - r <- uncons m1 - case r of - Nothing -> return Nothing - 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 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 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 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 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 foldStream defState yieldk single stop m1 - -{-# INLINABLE all #-} -all :: (IsStream t, Monad m) => (a -> Bool) -> t m a -> m Bool -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 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 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 foldStream defState yieldk single (return False) m1 - --- | Extract the last element of the stream, if any. -{-# INLINE last #-} -last :: (IsStream t, Monad m) => t m a -> m (Maybe a) -last = foldlx' (\_ y -> Just y) Nothing id - -{-# INLINE minimum #-} -minimum :: (IsStream t, Monad m, Ord a) => t m a -> m (Maybe a) -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 foldStream defState yieldk single stop m1 - - go (Just res) m1 = - let stop = return (Just res) - single a = - if res <= a - then return (Just res) - else return (Just a) - yieldk a r = - if res <= a - then go (Just res) r - else go (Just a) r - 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 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 = - if res <= a - then return (Just a) - else return (Just res) - yieldk a r = - if res <= a - then go (Just a) r - else go (Just res) r - 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 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 foldStream defState yieldk single (return Nothing) m1 - -{-# 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 = 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 = go 0 - where - 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 = foldStream (adaptState st) yld sng stp $ - go (offset + 1) x - in foldStream (adaptState st) yieldk single stp m1 - ------------------------------------------------------------------------------- --- Map and Fold ------------------------------------------------------------------------------- - --- | 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 m - where - go m1 = - let stop = return () - single a = void (f a) - yieldk a r = f a >> go r - in foldStream defState yieldk single stop m1 - ------------------------------------------------------------------------------- --- Converting folds ------------------------------------------------------------------------------- - -{-# INLINABLE toList #-} -toList :: (IsStream t, Monad m) => t m a -> m [a] -toList = foldr (:) [] - -{-# INLINE toStreamK #-} -toStreamK :: Stream m a -> Stream m a -toStreamK = id - --- Based on suggestions by David Feuer and Pranay Sashank -{-# INLINE hoist #-} -hoist :: (IsStream t, Monad m, Monad n) - => (forall x. m x -> n x) -> t m a -> t n a -hoist f str = - mkStream $ \st yld sng stp -> - let single = return . sng - yieldk a s = return $ yld a (hoist f s) - stop = return stp - state = adaptState st - in join . f $ foldStreamShared state yieldk single stop str - -------------------------------------------------------------------------------- --- Transformation by folding (Scans) -------------------------------------------------------------------------------- - -{-# INLINE scanlx' #-} -scanlx' :: IsStream t => (x -> a -> x) -> x -> (x -> b) -> t m a -> t m b -scanlx' step begin done m = - cons (done begin) $ go m begin - where - 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 foldStream (adaptState st) yieldk single stp m1 - -{-# INLINE scanl' #-} -scanl' :: IsStream t => (b -> a -> b) -> b -> t m a -> t m b -scanl' step begin = scanlx' step begin id - -------------------------------------------------------------------------------- --- Filtering -------------------------------------------------------------------------------- - -{-# INLINE filter #-} -filter :: IsStream t => (a -> Bool) -> t m a -> t m a -filter p m = go m - where - 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 = 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 = go n m - where - 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 foldStream st yieldk sng stp m1 - -{-# INLINE takeWhile #-} -takeWhile :: IsStream t => (a -> Bool) -> t m a -> t m a -takeWhile p m = go m - where - 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 foldStream st yieldk single stp m1 - -{-# INLINE drop #-} -drop :: IsStream t => Int -> t m a -> t m a -drop n m = fromStream $ unShare (go n (toStream m)) - where - go n1 m1 = mkStream $ \st yld sng stp -> - let single _ = stp - yieldk _ r = foldStreamShared st yld sng stp $ go (n1 - 1) r - -- Somehow "<=" check performs better than a ">" - in if n1 <= 0 - 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 = go m - where - go m1 = mkStream $ \st yld sng stp -> - let single a | p a = stp - | otherwise = sng a - yieldk a r | p a = foldStream st yieldk single stp r - | otherwise = yld a r - in foldStream st yieldk single stp m1 - -------------------------------------------------------------------------------- --- Mapping -------------------------------------------------------------------------------- - --- 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 m - where - go m1 = mkStream $ \st yld sng stp -> - let single ma = ma >>= sng - yieldk ma r = foldStreamShared st yld sng stp $ ma |: go r - in foldStream (adaptState st) yieldk single stp m1 - -------------------------------------------------------------------------------- --- Inserting -------------------------------------------------------------------------------- - -{-# INLINE intersperseM #-} -intersperseM :: (IsStream t, MonadAsync m) => m a -> t m a -> t m a -intersperseM a m = prependingStart m - where - prependingStart m1 = mkStream $ \st yld sng stp -> - let yieldk i x = foldStreamShared st yld sng stp $ return i |: go x - in foldStream st yieldk sng stp m1 - go m2 = mkStream $ \st yld sng stp -> - let single i = foldStreamShared st yld sng stp $ a |: yield i - yieldk i x = foldStreamShared st yld sng stp $ a |: return i |: go x - in foldStream st yieldk single stp m2 - -{-# INLINE intersperse #-} -intersperse :: (IsStream t, MonadAsync m) => a -> t m a -> t m a -intersperse a = intersperseM (return a) - -{-# 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 - ------------------------------------------------------------------------------- --- Reordering ------------------------------------------------------------------------------- - -{-# INLINE reverse #-} -reverse :: IsStream t => t m a -> t m a -reverse = foldlS (flip cons) nil - -------------------------------------------------------------------------------- --- Map and Filter -------------------------------------------------------------------------------- - -{-# INLINE mapMaybe #-} -mapMaybe :: IsStream t => (a -> Maybe b) -> t m a -> t m b -mapMaybe f m = go m - where - 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 $ go r - Nothing -> foldStream (adaptState st) yieldk single stp r - in foldStream (adaptState st) yieldk single stp m1 - ------------------------------------------------------------------------------- --- Serial Zipping ------------------------------------------------------------------------------- - --- | 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 = 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 foldStream (adaptState st) yield2 single2 stp my - let single1 a = merge a nil - yield1 = merge - 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 = go m1 m2 - where - go mx my = mkStream $ \st yld sng stp -> do - let merge a ra = - 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 foldStream (adaptState st) yield2 single2 stp my - let single1 a = merge a nil - yield1 = merge - foldStream (adaptState st) yield1 single1 stp mx - ------------------------------------------------------------------------------- --- Merging ------------------------------------------------------------------------------- - -{-# INLINE mergeByM #-} -mergeByM - :: (IsStream t, Monad m) - => (a -> a -> m Ordering) -> t m a -> t m a -> t m a -mergeByM cmp = go - where - go mx my = mkStream $ \st yld sng stp -> do - let mergeWithY a ra = - let stop2 = foldStream st yld sng stp mx - single2 b = do - r <- cmp a b - case r of - GT -> yld b (go (a `cons` ra) nil) - _ -> yld a (go ra (b `cons` nil)) - yield2 b rb = do - r <- cmp a b - case r of - GT -> yld b (go (a `cons` ra) rb) - _ -> yld a (go ra (b `cons` rb)) - in foldStream st yield2 single2 stop2 my - let stopX = foldStream st yld sng stp my - singleX a = mergeWithY a nil - yieldX = mergeWithY - foldStream st yieldX singleX stopX mx - -{-# INLINABLE mergeBy #-} -mergeBy - :: (IsStream t, Monad m) - => (a -> a -> Ordering) -> t m a -> t m a -> t m a -mergeBy cmp = mergeByM (\a b -> return $ cmp a b) - ------------------------------------------------------------------------------- --- Transformation comprehensions ------------------------------------------------------------------------------- - -{-# 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 - ------------------------------------------------------------------------------- --- Alternative & MonadPlus ------------------------------------------------------------------------------- - -_alt :: Stream m a -> Stream m a -> Stream m a -_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 = - mkStream $ \st yld sng stp -> - let single = local f . sng - yieldk a r = local f $ yld a (withLocal f r) - in foldStream st yieldk single (local f stp) m - ------------------------------------------------------------------------------- --- MonadError ------------------------------------------------------------------------------- - -{- --- XXX handle and test cross thread state transfer -withCatchError - :: MonadError e m - => Stream m a -> (e -> Stream m a) -> Stream m a -withCatchError m h = - 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 --} diff --git a/src/Streamly/Streams/StreamK/Type.hs b/src/Streamly/Streams/StreamK/Type.hs deleted file mode 100644 --- a/src/Streamly/Streams/StreamK/Type.hs +++ /dev/null @@ -1,1043 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE ViewPatterns #-} -#if __GLASGOW_HASKELL__ >= 806 -{-# LANGUAGE QuantifiedConstraints #-} -#endif -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE UndecidableInstances #-} -- XXX - -#include "../inline.hs" - --- | --- Module : Streamly.Streams.StreamK.Type --- Copyright : (c) 2017 Harendra Kumar --- --- License : BSD3 --- Maintainer : streamly@composewell.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 - - -- * foldr/build - , foldrM - , foldrS - , foldrSM - , build - , buildS - , buildM - , buildSM - , sharedM - , augmentS - , augmentSM - - -- instances - , cons - , (.:) - , consMStream - , consMBy - , yieldM - , yield - - , nil - , nilM - , conjoin - , serial - , map - , mapM - , mapMSerial - , unShare - , concatMapBy - , concatMap - , bindWith - - , Streaming -- deprecated - ) -where - -import Control.Monad (void, ap, (>=>)) -import Control.Monad.IO.Class (MonadIO(liftIO)) -import Control.Monad.Trans.Class (MonadTrans(lift)) -#if __GLASGOW_HASKELL__ >= 800 -import Data.Kind (Type) -#endif -#if __GLASGOW_HASKELL__ < 808 -import Data.Semigroup (Semigroup(..)) -#endif -import Prelude hiding (map, mapM, concatMap, foldr) - -import Streamly.Internal.Data.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 -#if __GLASGOW_HASKELL__ >= 806 - ( forall m a. MonadAsync m => Semigroup (t m a) - , forall m a. MonadAsync m => Monoid (t m a) - , forall m. Monad m => Functor (t m) - , forall m. MonadAsync m => Applicative (t m) - ) => -#endif - 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 - -- drain $ serially $ delay |: delay |: delay |: nil - -- drain $ 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. - ------------------------------------------------------------------------------- --- Construction ------------------------------------------------------------------------------- - -infixr 5 `cons` - --- faster than consM because there is no bind. --- | Construct a stream by adding a pure value at the head of an existing --- stream. For serial streams this is the same as @(return a) \`consM` r@ but --- more efficient. For concurrent streams this is not concurrent whereas --- 'consM' is concurrent. For example: --- --- @ --- > toList $ 1 \`cons` 2 \`cons` 3 \`cons` nil --- [1,2,3] --- @ --- --- @since 0.1.0 -{-# INLINE_NORMAL cons #-} -cons :: IsStream t => a -> t m a -> t m a -cons a r = mkStream $ \_ yld _ _ -> yld a r - -infixr 5 .: - --- | Operator equivalent of 'cons'. --- --- @ --- > toList $ 1 .: 2 .: 3 .: nil --- [1,2,3] --- @ --- --- @since 0.1.1 -{-# INLINE (.:) #-} -(.:) :: IsStream t => a -> t m a -> t m a -(.:) = cons - --- | An empty stream. --- --- @ --- > toList nil --- [] --- @ --- --- @since 0.1.0 -{-# INLINE_NORMAL nil #-} -nil :: IsStream t => t m a -nil = mkStream $ \_ _ _ stp -> stp - --- | An empty stream producing a side effect. --- --- @ --- > toList (nilM (print "nil")) --- "nil" --- [] --- @ --- --- /Internal/ -{-# INLINE_NORMAL nilM #-} -nilM :: (IsStream t, Monad m) => m b -> t m a -nilM m = mkStream $ \_ _ _ stp -> m >> stp - -{-# INLINE_NORMAL yield #-} -yield :: IsStream t => a -> t m a -yield a = mkStream $ \_ _ single _ -> single a - -{-# INLINE_NORMAL yieldM #-} -yieldM :: (Monad m, IsStream t) => m a -> t m a -yieldM m = fromStream $ mkStream $ \_ _ single _ -> m >>= single - --- XXX specialize to IO? -{-# INLINE consMBy #-} -consMBy :: (IsStream t, MonadAsync m) => (t m a -> t m a -> t m a) - -> m a -> t m a -> t m a -consMBy f m r = (fromStream $ yieldM m) `f` r - ------------------------------------------------------------------------------- --- 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 - -------------------------------------------------------------------------------- --- foldr/build fusion -------------------------------------------------------------------------------- - --- XXX perhaps we can just use foldrSM/buildM everywhere as they are more --- general and cover foldrS/buildS as well. - --- | The function 'f' decides how to reconstruct the stream. We could --- reconstruct using a shared state (SVar) or without sharing the state. --- -{-# INLINE foldrSWith #-} -foldrSWith :: IsStream t - => (forall r. State Stream m b - -> (b -> t m b -> m r) - -> (b -> m r) - -> m r - -> t m b - -> m r) - -> (a -> t m b -> t m b) -> t m b -> t m a -> t m b -foldrSWith f step final m = go m - where - go m1 = mkStream $ \st yld sng stp -> - let run x = f st yld sng stp x - stop = run final - single a = run $ step a final - yieldk a r = run $ step a (go r) - -- XXX if type a and b are the same we do not need adaptState, can we - -- save some perf with that? - -- XXX since we are using adaptState anyway here we can use - -- foldStreamShared instead, will that save some perf? - in foldStream (adaptState st) yieldk single stop m1 - --- XXX we can use rewrite rules just for foldrSWith, if the function f is the --- same we can rewrite it. - --- | Fold sharing the SVar state within the reconstructed stream -{-# INLINE_NORMAL foldrSShared #-} -foldrSShared :: IsStream t => (a -> t m b -> t m b) -> t m b -> t m a -> t m b -foldrSShared = foldrSWith foldStreamShared - --- XXX consM is a typeclass method, therefore rewritten already. Instead maybe --- we can make consM polymorphic using rewrite rules. --- {-# RULES "foldrSShared/id" foldrSShared consM nil = \x -> x #-} -{-# RULES "foldrSShared/nil" - forall k z. foldrSShared k z nil = z #-} -{-# RULES "foldrSShared/single" - forall k z x. foldrSShared k z (yield x) = k x z #-} --- {-# RULES "foldrSShared/app" [1] --- forall ys. foldrSShared consM ys = \xs -> xs `conjoin` ys #-} - --- | Lazy right associative fold to a stream. -{-# INLINE_NORMAL foldrS #-} -foldrS :: IsStream t => (a -> t m b -> t m b) -> t m b -> t m a -> t m b -foldrS = foldrSWith foldStream - -{-# RULES "foldrS/id" foldrS cons nil = \x -> x #-} -{-# RULES "foldrS/nil" forall k z. foldrS k z nil = z #-} --- See notes in GHC.Base about this rule --- {-# RULES "foldr/cons" --- forall k z x xs. foldrS k z (x `cons` xs) = k x (foldrS k z xs) #-} -{-# RULES "foldrS/single" forall k z x. foldrS k z (yield x) = k x z #-} --- {-# RULES "foldrS/app" [1] --- forall ys. foldrS cons ys = \xs -> xs `conjoin` ys #-} - -------------------------------------------------------------------------------- --- foldrS with monadic cons i.e. consM -------------------------------------------------------------------------------- - -{-# INLINE foldrSMWith #-} -foldrSMWith :: (IsStream t, Monad m) - => (forall r. State Stream m b - -> (b -> t m b -> m r) - -> (b -> m r) - -> m r - -> t m b - -> m r) - -> (m a -> t m b -> t m b) -> t m b -> t m a -> t m b -foldrSMWith f step final m = go m - where - go m1 = mkStream $ \st yld sng stp -> - let run x = f st yld sng stp x - stop = run final - single a = run $ step (return a) final - yieldk a r = run $ step (return a) (go r) - in foldStream (adaptState st) yieldk single stop m1 - -{-# INLINE_NORMAL foldrSM #-} -foldrSM :: (IsStream t, Monad m) - => (m a -> t m b -> t m b) -> t m b -> t m a -> t m b -foldrSM = foldrSMWith foldStream - --- {-# RULES "foldrSM/id" foldrSM consM nil = \x -> x #-} -{-# RULES "foldrSM/nil" forall k z. foldrSM k z nil = z #-} -{-# RULES "foldrSM/single" forall k z x. foldrSM k z (yieldM x) = k x z #-} --- {-# RULES "foldrSM/app" [1] --- forall ys. foldrSM consM ys = \xs -> xs `conjoin` ys #-} - --- Like foldrSM but sharing the SVar state within the recostructed stream. -{-# INLINE_NORMAL foldrSMShared #-} -foldrSMShared :: (IsStream t, Monad m) - => (m a -> t m b -> t m b) -> t m b -> t m a -> t m b -foldrSMShared = foldrSMWith foldStreamShared - --- {-# RULES "foldrSM/id" foldrSM consM nil = \x -> x #-} -{-# RULES "foldrSMShared/nil" - forall k z. foldrSMShared k z nil = z #-} -{-# RULES "foldrSMShared/single" - forall k z x. foldrSMShared k z (yieldM x) = k x z #-} --- {-# RULES "foldrSM/app" [1] --- forall ys. foldrSM consM ys = \xs -> xs `conjoin` ys #-} - -------------------------------------------------------------------------------- --- build -------------------------------------------------------------------------------- - -{-# INLINE_NORMAL build #-} -build :: IsStream t => forall a. (forall b. (a -> b -> b) -> b -> b) -> t m a -build g = g cons nil - -{-# RULES "foldrM/build" - forall k z (g :: forall b. (a -> b -> b) -> b -> b). - foldrM k z (build g) = g k z #-} - -{-# RULES "foldrS/build" - forall k z (g :: forall b. (a -> b -> b) -> b -> b). - foldrS k z (build g) = g k z #-} - -{-# RULES "foldrS/cons/build" - forall k z x (g :: forall b. (a -> b -> b) -> b -> b). - foldrS k z (x `cons` build g) = k x (g k z) #-} - -{-# RULES "foldrSShared/build" - forall k z (g :: forall b. (a -> b -> b) -> b -> b). - foldrSShared k z (build g) = g k z #-} - -{-# RULES "foldrSShared/cons/build" - forall k z x (g :: forall b. (a -> b -> b) -> b -> b). - foldrSShared k z (x `cons` build g) = k x (g k z) #-} - --- build a stream by applying cons and nil to a build function -{-# INLINE_NORMAL buildS #-} -buildS :: IsStream t => ((a -> t m a -> t m a) -> t m a -> t m a) -> t m a -buildS g = g cons nil - -{-# RULES "foldrS/buildS" - forall k z (g :: (a -> t m a -> t m a) -> t m a -> t m a). - foldrS k z (buildS g) = g k z #-} - -{-# RULES "foldrS/cons/buildS" - forall k z x (g :: (a -> t m a -> t m a) -> t m a -> t m a). - foldrS k z (x `cons` buildS g) = k x (g k z) #-} - -{-# RULES "foldrSShared/buildS" - forall k z (g :: (a -> t m a -> t m a) -> t m a -> t m a). - foldrSShared k z (buildS g) = g k z #-} - -{-# RULES "foldrSShared/cons/buildS" - forall k z x (g :: (a -> t m a -> t m a) -> t m a -> t m a). - foldrSShared k z (x `cons` buildS g) = k x (g k z) #-} - --- build a stream by applying consM and nil to a build function -{-# INLINE_NORMAL buildSM #-} -buildSM :: (IsStream t, MonadAsync m) - => ((m a -> t m a -> t m a) -> t m a -> t m a) -> t m a -buildSM g = g consM nil - -{-# RULES "foldrSM/buildSM" - forall k z (g :: (m a -> t m a -> t m a) -> t m a -> t m a). - foldrSM k z (buildSM g) = g k z #-} - -{-# RULES "foldrSMShared/buildSM" - forall k z (g :: (m a -> t m a -> t m a) -> t m a -> t m a). - foldrSMShared k z (buildSM g) = g k z #-} - --- Disabled because this may not fire as consM is a class Op -{- -{-# RULES "foldrS/consM/buildSM" - forall k z x (g :: (m a -> t m a -> t m a) -> t m a -> t m a) - . foldrSM k z (x `consM` buildSM g) - = k x (g k z) -#-} --} - --- Build using monadic build functions (continuations) instead of --- reconstructing a stream. -{-# INLINE_NORMAL buildM #-} -buildM :: (IsStream t, MonadAsync m) - => (forall r. (a -> t m a -> m r) - -> (a -> m r) - -> m r - -> m r - ) - -> t m a -buildM g = mkStream $ \st yld sng stp -> - g (\a r -> foldStream st yld sng stp (return a `consM` r)) sng stp - --- | Like 'buildM' but shares the SVar state across computations. -{-# INLINE_NORMAL sharedM #-} -sharedM :: (IsStream t, MonadAsync m) - => (forall r. (a -> t m a -> m r) - -> (a -> m r) - -> m r - -> m r - ) - -> t m a -sharedM g = mkStream $ \st yld sng stp -> - g (\a r -> foldStreamShared st yld sng stp (return a `consM` r)) sng stp - -------------------------------------------------------------------------------- --- augment -------------------------------------------------------------------------------- - -{-# INLINE_NORMAL augmentS #-} -augmentS :: IsStream t - => ((a -> t m a -> t m a) -> t m a -> t m a) -> t m a -> t m a -augmentS g xs = g cons xs - -{-# RULES "augmentS/nil" - forall (g :: (a -> t m a -> t m a) -> t m a -> t m a). - augmentS g nil = buildS g - #-} - -{-# RULES "foldrS/augmentS" - forall k z xs (g :: (a -> t m a -> t m a) -> t m a -> t m a). - foldrS k z (augmentS g xs) = g k (foldrS k z xs) - #-} - -{-# RULES "augmentS/buildS" - forall (g :: (a -> t m a -> t m a) -> t m a -> t m a) - (h :: (a -> t m a -> t m a) -> t m a -> t m a). - augmentS g (buildS h) = buildS (\c n -> g c (h c n)) - #-} - -{-# INLINE_NORMAL augmentSM #-} -augmentSM :: (IsStream t, MonadAsync m) - => ((m a -> t m a -> t m a) -> t m a -> t m a) -> t m a -> t m a -augmentSM g xs = g consM xs - -{-# RULES "augmentSM/nil" - forall (g :: (m a -> t m a -> t m a) -> t m a -> t m a). - augmentSM g nil = buildSM g - #-} - -{-# RULES "foldrSM/augmentSM" - forall k z xs (g :: (m a -> t m a -> t m a) -> t m a -> t m a). - foldrSM k z (augmentSM g xs) = g k (foldrSM k z xs) - #-} - -{-# RULES "augmentSM/buildSM" - forall (g :: (m a -> t m a -> t m a) -> t m a -> t m a) - (h :: (m a -> t m a -> t m a) -> t m a -> t m a). - augmentSM g (buildSM h) = buildSM (\c n -> g c (h c n)) - #-} - -------------------------------------------------------------------------------- --- Experimental foldrM/buildM -------------------------------------------------------------------------------- - --- | Lazy right fold with a monadic step function. -{-# INLINE_NORMAL foldrM #-} -foldrM :: IsStream t => (a -> m b -> m b) -> m b -> t m a -> m b -foldrM step acc m = go m - where - go m1 = - let stop = acc - single a = step a acc - yieldk a r = step a (go r) - in foldStream defState yieldk single stop m1 - -{-# INLINE_NORMAL foldrMKWith #-} -foldrMKWith - :: (State Stream m a - -> (a -> t m a -> m b) - -> (a -> m b) - -> m b - -> t m a - -> m b) - -> (a -> m b -> m b) - -> m b - -> ((a -> t m a -> m b) -> (a -> m b) -> m b -> m b) - -> m b -foldrMKWith f step acc g = go g - where - go k = - let stop = acc - single a = step a acc - yieldk a r = step a (go (\yld sng stp -> f defState yld sng stp r)) - in k yieldk single stop - -{- -{-# RULES "foldrM/buildS" - forall k z (g :: (a -> t m a -> t m a) -> t m a -> t m a) - . foldrM k z (buildS g) - = g k z -#-} --} --- XXX in which case will foldrM/buildM fusion be useful? -{-# RULES "foldrM/buildM" - forall step acc (g :: (forall r. - (a -> t m a -> m r) - -> (a -> m r) - -> m r - -> m r - )). - foldrM step acc (buildM g) = foldrMKWith foldStream step acc g - #-} - -{-# RULES "foldrM/sharedM" - forall step acc (g :: (forall r. - (a -> t m a -> m r) - -> (a -> m r) - -> m r - -> m r - )). - foldrM step acc (sharedM g) = foldrMKWith foldStreamShared step acc g - #-} - ------------------------------------------------------------------------------- --- 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 xs ys = augmentS (\c n -> foldrS c n xs) ys -{- -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 --} - --- join/merge/append streams depending on consM -{-# INLINE conjoin #-} -conjoin :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a -conjoin xs ys = augmentSM (\c n -> foldrSM c n xs) ys - -instance Semigroup (Stream m a) where - (<>) = serial - ------------------------------------------------------------------------------- --- Monoid ------------------------------------------------------------------------------- - -instance Monoid (Stream m a) where - mempty = nil - mappend = (<>) - -------------------------------------------------------------------------------- --- Functor -------------------------------------------------------------------------------- - -#if __GLASGOW_HASKELL__ < 800 -#define Type * -#endif --- Note eta expanded -{-# INLINE_LATE mapFB #-} -mapFB :: forall (t :: (Type -> Type) -> Type -> Type) b m a. - (b -> t m b -> t m b) -> (a -> b) -> a -> t m b -> t m b -mapFB c f = \x ys -> c (f x) ys -#undef Type - -{-# RULES -"mapFB/mapFB" forall c f g. mapFB (mapFB c f) g = mapFB c (f . g) -"mapFB/id" forall c. mapFB c (\x -> x) = c - #-} - -{-# INLINE map #-} -map :: IsStream t => (a -> b) -> t m a -> t m b -map f xs = buildS (\c n -> foldrS (mapFB c f) n xs) - --- XXX This definition might potentially be more efficient, but the cost in the --- benchmark is dominated by unfoldrM cost so we cannot correctly determine --- differences in the mapping cost. We should perhaps deduct the cost of --- unfoldrM from the benchmarks and then compare. -{- -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 --} - -{-# INLINE_LATE mapMFB #-} -mapMFB :: Monad m => (m b -> t m b -> t m b) -> (a -> m b) -> m a -> t m b -> t m b -mapMFB c f = \x ys -> c (x >>= f) ys - -{-# RULES - "mapMFB/mapMFB" forall c f g. mapMFB (mapMFB c f) g = mapMFB c (f >=> g) - #-} --- XXX These rules may never fire because pure/return type class rules will --- fire first. -{- -"mapMFB/pure" forall c. mapMFB c (\x -> pure x) = c -"mapMFB/return" forall c. mapMFB c (\x -> return x) = c --} - --- 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 = foldrSShared (\x xs -> f x `consM` xs) nil --- See note under map definition above. -{- -mapM f m = go m - where - go m1 = mkStream $ \st yld sng stp -> - let single a = f a >>= sng - yieldk a r = foldStreamShared st yld sng stp $ f a |: go r - in foldStream (adaptState st) yieldk single stp m1 - -} - --- This is experimental serial version supporting fusion. --- --- XXX what if we do not want to fuse two concurrent mapMs? --- XXX we can combine two concurrent mapM only if the SVar is of the same type --- So for now we use it only for serial streams. --- XXX fusion would be easier for monomoprhic stream types. --- {-# RULES "mapM serial" mapM = mapMSerial #-} -{-# INLINE mapMSerial #-} -mapMSerial :: MonadAsync m => (a -> m b) -> Stream m a -> Stream m b -mapMSerial f xs = buildSM (\c n -> foldrSMShared (mapMFB c f) n xs) - --- XXX 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 -------------------------------------------------------------------------------- - -instance MonadTrans Stream where - lift = yieldM - -------------------------------------------------------------------------------- --- Nesting -------------------------------------------------------------------------------- - --- | 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 - --- XXX This is just concatMapBy with arguments flipped. We need to keep this --- instead of using a concatMap style definition because the bind --- implementation in Async and WAsync streams show significant perf degradation --- if the argument order is changed. -{-# INLINE bindWith #-} -bindWith - :: 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 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 - --- XXX express in terms of foldrS? --- XXX can we use a different stream type for the generated stream being --- falttened so that we can combine them differently and keep the resulting --- stream different? --- XXX do we need specialize to IO? --- XXX can we optimize when c and a are same, by removing the forall using --- rewrite rules with type applications? - --- | Perform a 'concatMap' using a specified concat strategy. The first --- argument specifies a merge or concat function that is used to merge the --- streams generated by the map function. For example, the concat function --- could be 'serial', 'parallel', 'async', 'ahead' or any other zip or merge --- function. --- --- @since 0.7.0 -{-# INLINE concatMapBy #-} -concatMapBy - :: IsStream t - => (forall c. t m c -> t m c -> t m c) - -> (a -> t m b) - -> t m a - -> t m b -concatMapBy par f xs = bindWith par xs f - -{-# INLINE concatMap #-} -concatMap :: IsStream t => (a -> t m b) -> t m a -> t m b -concatMap f m = fromStream $ - concatMapBy serial - (\a -> adapt $ toStream $ f a) - (adapt $ toStream m) - -{- --- Fused version. --- XXX This fuses but when the stream is nil this performs poorly. --- The filterAllOut benchmark degrades. Need to investigate and fix that. -{-# INLINE concatMap #-} -concatMap :: IsStream t => (a -> t m b) -> t m a -> t m b -concatMap f xs = buildS - (\c n -> foldrS (\x b -> foldrS c b (f x)) n xs) - --- Stream polymorphic concatMap implementation --- XXX need to use buildSM/foldrSMShared for parallel behavior --- XXX unShare seems to degrade the fused performance -{-# INLINE_EARLY concatMap_ #-} -concatMap_ :: IsStream t => (a -> t m b) -> t m a -> t m b -concatMap_ f xs = buildS - (\c n -> foldrSShared (\x b -> foldrSShared c b (unShare $ f x)) n xs) --} - -instance Monad m => Applicative (Stream m) where - {-# INLINE pure #-} - pure = yield - {-# INLINE (<*>) #-} - (<*>) = ap - --- NOTE: even though concatMap for StreamD is 3x faster compared to StreamK, --- the monad instance of StreamD is slower than StreamK after foldr/build --- fusion. -instance Monad m => Monad (Stream m) where - {-# INLINE return #-} - return = pure - {-# INLINE (>>=) #-} - (>>=) = flip concatMap - -{- --- ConcatMap recursively on itself using a merge strategy. -concatLoopBy :: IsStream t - => (forall c. t m c -> t m c -> t m c) - -> (a -> t m a) -> t m a -concatLoopBy = undefined - --- This is mfix. Put another way, concatMap recursively on the output of a --- stream. Compare with iterate. -concatLoop :: IsStream t => (a -> t m a) -> t m a -concatLoop = concatLoopBy serial - -instance MonadFix (Stream m) where - mfix = concatLoop - --- The SVar implementation is something similar to concatFeedBack, so maybe --- there is an opportunity to share the implementation here. In an SVar we run --- a part of an action (a stream), it yields an output and the rest of the --- stream, we yield the output and queue back the rest of the stream for --- further evaluation. Also see unfoldrA. --- --- There could be multiple variants of this combinator, for example use a --- specific way of concating i.e. concatLoopBy. Which also includes combinators --- with different stop behaviors. For example if the Left values are errors we --- can stop the whole composition on errors or on specific errors. --- --- We can also flip the serial/ahead append behavior e.g. instead of processing --- the Left output after the original stream we can reverse the order. --- --- | Concat map on the 'Left' output of a stream and merge it back into the --- stream. The right output is yielded in the output stream. -concatFeedBack :: IsStream t - => (b -> t m (Either a b)) -> t m (Either a b) -> t m a -concatFeedBack = undefined - --- Compare this with unfoldr. Start with a seed stream and generate a stream --- with a value and new seeds. The new seeds are fed back to generate a seed --- stream and so on. This is a stream level unfoldr. -concatUnfoldr :: IsStream t - => (b -> t m (Maybe (a, b))) -> t m (Maybe (a, b)) -> t m a -concatUnfoldr = undefined --} diff --git a/src/Streamly/Streams/Zip.hs b/src/Streamly/Streams/Zip.hs deleted file mode 100644 --- a/src/Streamly/Streams/Zip.hs +++ /dev/null @@ -1,236 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving#-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -- XXX - --- | --- Module : Streamly.Streams.Zip --- Copyright : (c) 2017 Harendra Kumar --- --- License : BSD3 --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- --- -module Streamly.Streams.Zip - ( - K.zipWith - , K.zipWithM - , zipAsyncWith - , zipAsyncWithM - - , ZipSerialM - , ZipSerial - , ZipStream -- deprecated - , zipSerially - , zipping -- deprecated - - , ZipAsyncM - , ZipAsync - , zipAsyncly - , zippingAsync -- deprecated - ) -where - -import Control.Applicative (liftA2) -import Control.DeepSeq (NFData(..)) -#if MIN_VERSION_deepseq(1,4,3) -import Control.DeepSeq (NFData1(..)) -#endif -import Data.Functor.Identity (Identity, runIdentity) -import Data.Foldable (fold) -#if __GLASGOW_HASKELL__ < 808 -import Data.Semigroup (Semigroup(..)) -#endif -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, mkStream, foldStream) -import Streamly.Streams.Async (mkAsync') -import Streamly.Streams.Serial (map) -import Streamly.Internal.Data.SVar (MonadAsync, adaptState) - -import qualified Streamly.Streams.Prelude as P -import qualified Streamly.Streams.StreamK as K - -#include "Instances.hs" - ------------------------------------------------------------------------------- --- Serially Zipping Streams ------------------------------------------------------------------------------- - --- | The applicative instance of 'ZipSerialM' zips a number of streams serially --- i.e. it produces one element from each stream serially and then zips all --- those elements. --- --- @ --- main = (toList . 'zipSerially' $ (,,) \<$\> s1 \<*\> s2 \<*\> s3) >>= print --- where s1 = fromFoldable [1, 2] --- s2 = fromFoldable [3, 4] --- s3 = fromFoldable [5, 6] --- @ --- @ --- [(1,3,5),(2,4,6)] --- @ --- --- The 'Semigroup' instance of this type works the same way as that of --- 'SerialT'. --- --- @since 0.2.0 -newtype ZipSerialM m a = ZipSerialM {getZipSerialM :: Stream m a} - deriving (Semigroup, Monoid) - --- | --- @since 0.1.0 -{-# DEPRECATED ZipStream "Please use 'ZipSerialM' instead." #-} -type ZipStream = ZipSerialM - --- | An IO stream whose applicative instance zips streams serially. --- --- @since 0.2.0 -type ZipSerial = ZipSerialM IO - --- | Fix the type of a polymorphic stream as 'ZipSerialM'. --- --- @since 0.2.0 -zipSerially :: IsStream t => ZipSerialM m a -> t m a -zipSerially = K.adapt - --- | Same as 'zipSerially'. --- --- @since 0.1.0 -{-# DEPRECATED zipping "Please use zipSerially instead." #-} -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 - - {-# INLINE consM #-} - {-# SPECIALIZE consM :: IO a -> ZipSerialM IO a -> ZipSerialM IO a #-} - consM :: Monad m => m a -> ZipSerialM m a -> ZipSerialM m a - consM = consMZip - - {-# INLINE (|:) #-} - {-# SPECIALIZE (|:) :: IO a -> ZipSerialM IO a -> ZipSerialM IO a #-} - (|:) :: Monad m => m a -> ZipSerialM m a -> ZipSerialM m a - (|:) = consMZip - -LIST_INSTANCES(ZipSerialM) -NFDATA1_INSTANCE(ZipSerialM) - -instance Monad m => Functor (ZipSerialM m) where - fmap = map - -instance Monad m => Applicative (ZipSerialM m) where - pure = ZipSerialM . K.repeat - (<*>) = K.zipWith id - -FOLDABLE_INSTANCE(ZipSerialM) -TRAVERSABLE_INSTANCE(ZipSerialM) - ------------------------------------------------------------------------------- --- Parallel Zipping ------------------------------------------------------------------------------- - --- | 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 = 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) - --- | 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 = 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 ------------------------------------------------------------------------------- --- --- | Like 'ZipSerialM' but zips in parallel, it generates all the elements to --- be zipped concurrently. --- --- @ --- main = (toList . 'zipAsyncly' $ (,,) \<$\> s1 \<*\> s2 \<*\> s3) >>= print --- where s1 = fromFoldable [1, 2] --- s2 = fromFoldable [3, 4] --- s3 = fromFoldable [5, 6] --- @ --- @ --- [(1,3,5),(2,4,6)] --- @ --- --- The 'Semigroup' instance of this type works the same way as that of --- 'SerialT'. --- --- @since 0.2.0 -newtype ZipAsyncM m a = ZipAsyncM {getZipAsyncM :: Stream m a} - deriving (Semigroup, Monoid) - --- | An IO stream whose applicative instance zips streams wAsyncly. --- --- @since 0.2.0 -type ZipAsync = ZipAsyncM IO - --- | Fix the type of a polymorphic stream as 'ZipAsyncM'. --- --- @since 0.2.0 -zipAsyncly :: IsStream t => ZipAsyncM m a -> t m a -zipAsyncly = K.adapt - --- | Same as 'zipAsyncly'. --- --- @since 0.1.0 -{-# 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 - - {-# INLINE consM #-} - {-# SPECIALIZE consM :: IO a -> ZipAsyncM IO a -> ZipAsyncM IO a #-} - consM :: Monad m => m a -> ZipAsyncM m a -> ZipAsyncM m a - consM = consMZipAsync - - {-# INLINE (|:) #-} - {-# SPECIALIZE (|:) :: IO a -> ZipAsyncM IO a -> ZipAsyncM IO a #-} - (|:) :: Monad m => m a -> ZipAsyncM m a -> ZipAsyncM m a - (|:) = consMZipAsync - -instance Monad m => Functor (ZipAsyncM m) where - fmap = map - -instance MonadAsync m => Applicative (ZipAsyncM m) where - pure = ZipAsyncM . K.repeat - m1 <*> m2 = zipAsyncWith id m1 m2 diff --git a/src/Streamly/Streams/inline.hs b/src/Streamly/Streams/inline.hs deleted file mode 100644 --- a/src/Streamly/Streams/inline.hs +++ /dev/null @@ -1,27 +0,0 @@ --- 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/inline.hs b/src/inline.hs new file mode 100644 --- /dev/null +++ b/src/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/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-13.25 +resolver: lts-14.25 packages: - '.' extra-deps: @@ -7,6 +7,8 @@ - Chart-diagrams-1.9.2 - bench-show-0.2.2 - inspection-testing-0.4.2.1 + - fusion-plugin-types-0.1.0 + - fusion-plugin-0.2.0 #allow-newer: true flags: {} diff --git a/streamly.cabal b/streamly.cabal --- a/streamly.cabal +++ b/streamly.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: streamly -version: 0.7.0 +version: 0.7.1 synopsis: Beautiful Streaming, Concurrent and Reactive Composition description: Streamly is a framework for writing programs in a high level, declarative @@ -20,7 +20,7 @@ it may not be for you. It expresses a small "hello world" program with the same efficiency, simplicity and elegance as a large scale concurrent application. It unifies many different aspects of special purpose libraries - into a single yet simple framework. + into a single yet simple framework. . Streamly covers the functionality provided by Haskell lists as well as the functionality provided by streaming libraries like @@ -62,7 +62,7 @@ . Where to find more information: . - * /Quick Overview/: in the package + * /Quick Overview/: <#readme README file> in the package * /Building/: for optimal performance * /Detailed Tutorial/: "Streamly.Tutorial" module in the haddock documentation * /Interoperation/: "Streamly.Tutorial" module for interop with other @@ -75,10 +75,6 @@ * * . - For additional unreleased/experimental APIs, build the haddock docs using: - . - > $ cabal haddock --haddock-option="--show-all" - > $ stack haddock --haddock-arguments "--show-all" --no-haddock-deps homepage: https://github.com/composewell/streamly @@ -101,11 +97,11 @@ Changelog.md credits/*.md credits/base-4.12.0.0.txt + credits/primitive-0.7.0.0.txt credits/bjoern-2008-2009.txt credits/clock-0.7.2.txt credits/foldl-1.4.5.txt credits/pipes-concurrency-2.0.8.txt - credits/pipes-concurrency.txt credits/transient-0.5.5.txt credits/vector-0.12.0.2.txt credits/Yampa-0.10.6.2.txt @@ -113,10 +109,13 @@ docs/streamly-vs-async.md docs/streamly-vs-lists.md docs/transformers.md + docs/Build.md + design/*.md + design/*.png bench.sh stack.yaml - src/Streamly/Streams/Instances.hs - src/Streamly/Streams/inline.hs + src/Streamly/Internal/Data/Stream/Instances.hs + src/inline.hs configure.ac configure src/Streamly/Internal/Data/Time/config.h.in @@ -131,8 +130,8 @@ type: git location: https://github.com/composewell/streamly -flag benchmark - description: Benchmark build +flag fusion-plugin + description: Use fusion plugin for benchmarks and executables manual: True default: False @@ -152,17 +151,17 @@ default: False flag has-llvm - description: Use llvm backend for better performance + description: Use llvm backend for code generation manual: True default: False flag no-charts - description: Disable chart generation + description: Disable benchmark charts in development build manual: True default: False flag no-fusion - description: Disable rewrite rules + description: Disable rewrite rules for stream fusion manual: True default: False @@ -222,6 +221,7 @@ common optimization-options ghc-options: -O2 + -fdicts-strict -fspec-constr-recursive=16 -fmax-worker-args=16 @@ -243,18 +243,44 @@ -- in general. common test-options import: compile-options, threading-options + ghc-options: -O0 -fno-ignore-asserts + if flag(fusion-plugin) && !impl(ghcjs) && !impl(ghc < 8.6) + ghc-options: -fplugin Fusion.Plugin + build-depends: + fusion-plugin >= 0.2 && < 0.3 -- Used by maxrate test, benchmarks and executables common exe-options import: compile-options, optimization-options, threading-options + if flag(fusion-plugin) && !impl(ghcjs) && !impl(ghc < 8.6) + ghc-options: -fplugin Fusion.Plugin + build-depends: + fusion-plugin >= 0.2 && < 0.3 -- Some benchmarks are threaded some are not +-- XXX dependencies should be separated under bench-depends common bench-options import: compile-options, optimization-options - ghc-options: -with-rtsopts "-T" + ghc-options: -with-rtsopts "-T -K32K -M16M" + if flag(fusion-plugin) && !impl(ghcjs) && !impl(ghc < 8.6) + ghc-options: -fplugin Fusion.Plugin + build-depends: + fusion-plugin >= 0.2 && < 0.3 + build-depends: mtl >= 2.2 && < 3 +common bench-options-threaded + import: compile-options, optimization-options + -- -threaded and -N2 is important because some GC and space leak issues + -- trigger only with these options. + ghc-options: -threaded -with-rtsopts "-T -N2 -K32K -M16M" + if flag(fusion-plugin) && !impl(ghcjs) && !impl(ghc < 8.6) + ghc-options: -fplugin Fusion.Plugin + build-depends: + fusion-plugin >= 0.2 && < 0.3 + build-depends: mtl >= 2.2 && < 3 + ------------------------------------------------------------------------------- -- Library ------------------------------------------------------------------------------- @@ -263,40 +289,27 @@ import: lib-options js-sources: jsbits/clock.js include-dirs: src/Streamly/Internal/Data/Time - , src/Streamly/Streams + , src if os(windows) c-sources: src/Streamly/Internal/Data/Time/Windows.c if os(darwin) c-sources: src/Streamly/Internal/Data/Time/Darwin.c hs-source-dirs: src other-modules: + Streamly.Data.Array + , Streamly.Data.SmallArray + , Streamly.Data.Prim.Array + -- Memory storage Streamly.Memory.Malloc , Streamly.Memory.Ring - -- Base streams - , Streamly.Streams.StreamK.Type - , Streamly.Streams.StreamK - , Streamly.Streams.StreamDK.Type - , Streamly.Streams.StreamDK - , Streamly.Streams.StreamD - , Streamly.Streams.Enumeration - , 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.Combinators - , Streamly.FileSystem.IOVec , Streamly.FileSystem.FDIO , Streamly.FileSystem.FD - exposed-modules: Streamly.Prelude + exposed-modules: + Streamly.Prelude , Streamly , Streamly.Data.Fold , Streamly.Data.Unfold @@ -309,13 +322,19 @@ , Streamly.Tutorial -- Internal modules + , Streamly.Internal.BaseCompat + , Streamly.Internal.Control.Monad , Streamly.Internal.Data.Strict , Streamly.Internal.Data.Atomics , Streamly.Internal.Data.Time , Streamly.Internal.Data.Time.Units , Streamly.Internal.Data.Time.Clock - , Streamly.Internal.Data.Stream.StreamD.Type , Streamly.Internal.Data.SVar + , Streamly.Internal.Data.Array + , Streamly.Internal.Data.Prim.Array.Types + , Streamly.Internal.Data.Prim.Array + , Streamly.Internal.Data.SmallArray.Types + , Streamly.Internal.Data.SmallArray , Streamly.Internal.Memory.Array.Types , Streamly.Internal.Memory.Array , Streamly.Internal.Memory.ArrayStream @@ -323,6 +342,25 @@ , Streamly.Internal.Data.Fold , Streamly.Internal.Data.Sink.Types , Streamly.Internal.Data.Sink + + -- Base streams + , Streamly.Internal.Data.Stream.StreamK.Type + , Streamly.Internal.Data.Stream.StreamK + , Streamly.Internal.Data.Stream.StreamD.Type + , Streamly.Internal.Data.Stream.StreamD + , Streamly.Internal.Data.Stream.StreamDK.Type + , Streamly.Internal.Data.Stream.StreamDK + , Streamly.Internal.Data.Stream.Enumeration + , Streamly.Internal.Data.Stream.Prelude + + -- Higher level streams + , Streamly.Internal.Data.Stream.SVar + , Streamly.Internal.Data.Stream.Serial + , Streamly.Internal.Data.Stream.Async + , Streamly.Internal.Data.Stream.Parallel + , Streamly.Internal.Data.Stream.Ahead + , Streamly.Internal.Data.Stream.Zip + , Streamly.Internal.Data.Stream.Combinators , Streamly.Internal.Data.Unfold.Types , Streamly.Internal.Data.Unfold , Streamly.Internal.Data.Pipe.Types @@ -335,6 +373,10 @@ , Streamly.Internal.Data.Unicode.Char , Streamly.Internal.Memory.Unicode.Array , Streamly.Internal.Prelude + + -- Mutable data + , Streamly.Internal.Mutable.Prim.Var + if !impl(ghcjs) exposed-modules: Streamly.Network.Socket @@ -343,41 +385,48 @@ , Streamly.Internal.Network.Socket , Streamly.Internal.Network.Inet.TCP - if flag(benchmark) - exposed-modules: - Streamly.Benchmark.FileIO.Array - , Streamly.Benchmark.FileIO.Stream - , Streamly.Benchmark.Prelude - - build-depends: base >= 4.8 && < 5 - , ghc-prim >= 0.2 && < 0.6 + build-depends: + -- Core libraries shipped with ghc, the min and max + -- constraints of these libraries should match with + -- the GHC versions we support + base >= 4.8 && < 5 + , containers >= 0.5 && < 0.7 , deepseq >= 1.4.1 && < 1.5 - , containers >= 0.5.8.2 && < 0.7 - , heaps >= 0.3 && < 0.4 - , directory >= 1.3 && < 1.4 + , directory >= 1.2.2 && < 1.4 + , exceptions >= 0.8 && < 0.11 + , ghc-prim >= 0.2 && < 0.6 + , mtl >= 2.2 && < 3 + , primitive >= 0.5.4 && < 0.8 + , transformers >= 0.4 && < 0.6 + , heaps >= 0.3 && < 0.4 + -- concurrency , atomic-primops >= 0.8 && < 0.9 , lockfree-queue >= 0.2.3 && < 0.3 -- transfomers - , 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 flag(inspection) - build-depends: template-haskell >= 2.14 && < 2.16 - , inspection-testing >= 0.4 && < 0.5 + , fusion-plugin-types >= 0.1 && < 0.2 if !impl(ghcjs) build-depends: - network >= 2.6 && < 4 + network >= 2.6 && < 4 if impl(ghc < 8.0) build-depends: - semigroups >= 0.18 && < 0.19 + semigroups >= 0.18 && < 0.19 + if flag(inspection) + build-depends: template-haskell >= 2.14 && < 2.16 + , inspection-testing >= 0.4 && < 0.5 + + -- Array uses a Storable constraint in dev build making several inspection + -- tests fail + if flag(dev) && flag(inspection) + build-depends: inspection-and-dev-flags-cannot-be-used-together + ------------------------------------------------------------------------------- -- Test suites ------------------------------------------------------------------------------- @@ -392,12 +441,25 @@ streamly , base >= 4.8 && < 5 , hspec >= 2.0 && < 3 - , containers >= 0.5.8.2 && < 0.7 + , containers >= 0.5 && < 0.7 , transformers >= 0.4 && < 0.6 , mtl >= 2.2 && < 3 , exceptions >= 0.8 && < 0.11 default-language: Haskell2010 +test-suite internal-prelude-test + import: test-options + type: exitcode-stdio-1.0 + main-is: Streamly/Test/Internal/Prelude.hs + js-sources: jsbits/clock.js + hs-source-dirs: test + build-depends: + streamly + , base >= 4.8 && < 5 + , QuickCheck >= 2.10 && < 2.14 + , hspec >= 2.0 && < 3 + default-language: Haskell2010 + test-suite pure-streams-base import: test-options type: exitcode-stdio-1.0 @@ -440,9 +502,10 @@ test-suite array-test import: test-options type: exitcode-stdio-1.0 - main-is: Arrays.hs + main-is: Streamly/Test/Array.hs js-sources: jsbits/clock.js hs-source-dirs: test + cpp-options: -DTEST_ARRAY build-depends: streamly , base >= 4.8 && < 5 @@ -453,6 +516,69 @@ transformers >= 0.4 && < 0.6 default-language: Haskell2010 +test-suite internal-data-fold-test + import: test-options + type: exitcode-stdio-1.0 + main-is: Streamly/Test/Internal/Data/Fold.hs + js-sources: jsbits/clock.js + hs-source-dirs: test + build-depends: + streamly + , base >= 4.8 && < 5 + , hspec >= 2.0 && < 3 + , QuickCheck >= 2.10 && < 2.14 + default-language: Haskell2010 + +test-suite data-array-test + import: test-options + type: exitcode-stdio-1.0 + main-is: Streamly/Test/Array.hs + js-sources: jsbits/clock.js + hs-source-dirs: test + build-depends: + streamly + , base >= 4.8 && < 5 + , QuickCheck >= 2.10 && < 2.14 + , hspec >= 2.0 && < 3 + if impl(ghc < 8.0) + build-depends: + transformers >= 0.4 && < 0.6 + default-language: Haskell2010 + +test-suite smallarray-test + import: test-options + type: exitcode-stdio-1.0 + main-is: Streamly/Test/Array.hs + js-sources: jsbits/clock.js + hs-source-dirs: test + cpp-options: -DTEST_SMALL_ARRAY + build-depends: + streamly + , base >= 4.8 && < 5 + , QuickCheck >= 2.10 && < 2.14 + , hspec >= 2.0 && < 3 + if impl(ghc < 8.0) + build-depends: + transformers >= 0.4 && < 0.6 + default-language: Haskell2010 + +test-suite primarray-test + import: test-options + type: exitcode-stdio-1.0 + main-is: Streamly/Test/Array.hs + js-sources: jsbits/clock.js + hs-source-dirs: test + cpp-options: -DTEST_PRIM_ARRAY + build-depends: + streamly + , base >= 4.8 && < 5 + , QuickCheck >= 2.10 && < 2.14 + , hspec >= 2.0 && < 3 + if impl(ghc < 8.0) + build-depends: + transformers >= 0.4 && < 0.6 + default-language: Haskell2010 + test-suite string-test import: test-options type: exitcode-stdio-1.0 @@ -519,74 +645,89 @@ , base >= 4.8 && < 5 , random >= 1.0.0 && < 2 +test-suite version-bounds + import: test-options + type: exitcode-stdio-1.0 + default-language: Haskell2010 + main-is: version-bounds.hs + hs-source-dirs: test + build-Depends: + streamly + , ghc + , base >= 4.8 && < 5 + ------------------------------------------------------------------------------- -- Benchmarks ------------------------------------------------------------------------------- +-- For linear, linear-async, linear-rate, nested and nested-concurrent +-- you can pass the number of elements in the stream using the +-- --stream-size option: +-- $ cabal run linear -- --stream-size 1000000 + benchmark linear import: bench-options type: exitcode-stdio-1.0 hs-source-dirs: benchmark + -- XXX heap/stack limits can be reduced once we split out the buffered + -- benchmarks into a separate suite + ghc-options: -with-rtsopts "-T -K4M -M128M" main-is: Linear.hs - if flag(benchmark) - buildable: True + other-modules: Streamly.Benchmark.Prelude, Common + build-depends: + streamly + , base >= 4.8 && < 5 + , deepseq >= 1.4.1 && < 1.5 + , random >= 1.0 && < 2.0 + , gauge >= 0.2.4 && < 0.3 + if impl(ghc < 8.0) build-depends: - streamly - , base >= 4.8 && < 5 - , deepseq >= 1.4.1 && < 1.5 - , random >= 1.0 && < 2.0 - , gauge >= 0.2.4 && < 0.3 - if impl(ghc < 8.0) - build-depends: - transformers >= 0.4 && < 0.6 - else - buildable: False + transformers >= 0.4 && < 0.6 + if flag(inspection) + build-depends: template-haskell >= 2.14 && < 2.16 + , inspection-testing >= 0.4 && < 0.5 -benchmark linear-async +benchmark nested import: bench-options - cpp-options: -DLINEAR_ASYNC type: exitcode-stdio-1.0 hs-source-dirs: benchmark - main-is: LinearAsync.hs - if flag(benchmark) - buildable: True + ghc-options: -with-rtsopts "-T -K256K -M16M" + main-is: Nested.hs + other-modules: NestedOps, Common + build-depends: + streamly + , base >= 4.8 && < 5 + , deepseq >= 1.4.1 && < 1.5 + , random >= 1.0 && < 2.0 + , gauge >= 0.2.4 && < 0.3 + if impl(ghc < 8.0) build-depends: - streamly - , base >= 4.8 && < 5 - , deepseq >= 1.4.1 && < 1.5 - , random >= 1.0 && < 2.0 - , gauge >= 0.2.4 && < 0.3 - if impl(ghc < 8.0) - build-depends: - transformers >= 0.4 && < 0.6 - else - buildable: False + transformers >= 0.4 && < 0.6 -benchmark linear-rate +benchmark nested-unfold import: bench-options type: exitcode-stdio-1.0 hs-source-dirs: benchmark - main-is: LinearRate.hs - if flag(benchmark) - buildable: True + ghc-options: -with-rtsopts "-T -K64K -M16M" + main-is: NestedUnfold.hs + other-modules: NestedUnfoldOps, Common + build-depends: + streamly + , base >= 4.8 && < 5 + , deepseq >= 1.4.1 && < 1.5 + , random >= 1.0 && < 2.0 + , gauge >= 0.2.4 && < 0.3 + if impl(ghc < 8.0) build-depends: - streamly - , base >= 4.8 && < 5 - , deepseq >= 1.4.1 && < 1.5 - , random >= 1.0 && < 2.0 - , gauge >= 0.2.4 && < 0.3 - if impl(ghc < 8.0) - build-depends: - transformers >= 0.4 && < 0.6 - else - buildable: False + transformers >= 0.4 && < 0.6 -benchmark nested +benchmark unpinned-array import: bench-options type: exitcode-stdio-1.0 hs-source-dirs: benchmark - main-is: Nested.hs - other-modules: NestedOps + ghc-options: -with-rtsopts "-T -K1K -M128M" + main-is: Streamly/Benchmark/Data/Array.hs + other-modules: Streamly.Benchmark.Data.ArrayOps build-depends: streamly , base >= 4.8 && < 5 @@ -597,12 +738,13 @@ build-depends: transformers >= 0.4 && < 0.6 -benchmark nestedUnfold +benchmark prim-array import: bench-options type: exitcode-stdio-1.0 hs-source-dirs: benchmark - main-is: NestedUnfold.hs - other-modules: NestedUnfoldOps + ghc-options: -with-rtsopts "-T -K64K -M32M" + main-is: Streamly/Benchmark/Data/Prim/Array.hs + other-modules: Streamly.Benchmark.Data.Prim.ArrayOps build-depends: streamly , base >= 4.8 && < 5 @@ -613,10 +755,28 @@ build-depends: transformers >= 0.4 && < 0.6 +benchmark small-array + import: bench-options + type: exitcode-stdio-1.0 + hs-source-dirs: benchmark + ghc-options: -with-rtsopts "-T -K128K -M16M" + main-is: Streamly/Benchmark/Data/SmallArray.hs + other-modules: Streamly.Benchmark.Data.SmallArrayOps + build-depends: + streamly + , base >= 4.8 && < 5 + , deepseq >= 1.4.1 && < 1.5 + , random >= 1.0 && < 2.0 + , gauge >= 0.2.4 && < 0.3 + if impl(ghc < 8.0) + build-depends: + transformers >= 0.4 && < 0.6 + benchmark array import: bench-options type: exitcode-stdio-1.0 hs-source-dirs: benchmark + ghc-options: -with-rtsopts "-T -K64K -M128M" main-is: Array.hs other-modules: ArrayOps build-depends: @@ -637,150 +797,163 @@ -- ghc-options: -funfolding-use-threshold=150 hs-source-dirs: benchmark main-is: FileIO.hs - if flag(benchmark) - buildable: True + other-modules: Streamly.Benchmark.FileIO.Array + , Streamly.Benchmark.FileIO.Stream + build-depends: + streamly + , base >= 4.8 && < 5 + , gauge >= 0.2.4 && < 0.3 + , typed-process >= 0.2.3 && < 0.3 + , deepseq >= 1.4.1 && < 1.5 + if flag(inspection) + build-depends: template-haskell >= 2.14 && < 2.16 + , inspection-testing >= 0.4 && < 0.5 + +------------------------------------------------------------------------------- +-- Threaded Benchmarks +------------------------------------------------------------------------------- + +benchmark linear-async + import: bench-options-threaded + type: exitcode-stdio-1.0 + hs-source-dirs: benchmark + ghc-options: -with-rtsopts "-T -N2 -K64K -M16M" + main-is: LinearAsync.hs + other-modules: Streamly.Benchmark.Prelude, Common + build-depends: + streamly + , base >= 4.8 && < 5 + , deepseq >= 1.4.1 && < 1.5 + , random >= 1.0 && < 2.0 + , gauge >= 0.2.4 && < 0.3 + if impl(ghc < 8.0) build-depends: - streamly - , base >= 4.8 && < 5 - , gauge >= 0.2.4 && < 0.3 - , typed-process >= 0.2.3 && < 0.3 - , deepseq >= 1.4.1 && < 1.5 - else - buildable: False + transformers >= 0.4 && < 0.6 + if flag(inspection) + build-depends: template-haskell >= 2.14 && < 2.16 + , inspection-testing >= 0.4 && < 0.5 +benchmark nested-concurrent + import: bench-options-threaded + type: exitcode-stdio-1.0 + hs-source-dirs: benchmark + -- XXX this can be lowered once we split out the finite benchmarks + ghc-options: -with-rtsopts "-T -N2 -K256K -M128M" + main-is: NestedConcurrent.hs + other-modules: NestedOps, Common + build-depends: + streamly + , base >= 4.8 && < 5 + , deepseq >= 1.4.1 && < 1.5 + , random >= 1.0 && < 2.0 + , gauge >= 0.2.4 && < 0.3 + if impl(ghc < 8.0) + build-depends: + transformers >= 0.4 && < 0.6 + +benchmark parallel + import: bench-options-threaded + type: exitcode-stdio-1.0 + hs-source-dirs: benchmark + ghc-options: -with-rtsopts "-T -N2 -K128K -M256M" + main-is: Parallel.hs + other-modules: Streamly.Benchmark.Prelude, NestedOps, Common + build-depends: + streamly + , base >= 4.8 && < 5 + , deepseq >= 1.4.1 && < 1.5 + , random >= 1.0 && < 2.0 + , gauge >= 0.2.4 && < 0.3 + if impl(ghc < 8.0) + build-depends: + transformers >= 0.4 && < 0.6 + if flag(inspection) + build-depends: template-haskell >= 2.14 && < 2.16 + , inspection-testing >= 0.4 && < 0.5 + +benchmark linear-rate + import: bench-options-threaded + type: exitcode-stdio-1.0 + hs-source-dirs: benchmark + main-is: LinearRate.hs + other-modules: Streamly.Benchmark.Prelude, Common + build-depends: + streamly + , base >= 4.8 && < 5 + , deepseq >= 1.4.1 && < 1.5 + , random >= 1.0 && < 2.0 + , gauge >= 0.2.4 && < 0.3 + if impl(ghc < 8.0) + build-depends: + transformers >= 0.4 && < 0.6 + if flag(inspection) + build-depends: template-haskell >= 2.14 && < 2.16 + , inspection-testing >= 0.4 && < 0.5 + benchmark concurrent - import: bench-options + import: bench-options-threaded type: exitcode-stdio-1.0 hs-source-dirs: benchmark main-is: Concurrent.hs - if flag(dev) - buildable: True - build-depends: - streamly - , base >= 4.8 && < 5 - , gauge >= 0.2.4 && < 0.3 - else - buildable: False + ghc-options: -with-rtsopts "-T -N2 -K256K -M384M" + build-depends: + streamly + , base >= 4.8 && < 5 + , gauge >= 0.2.4 && < 0.3 ------------------------------------------------------------------------------- --- Internal benchmarks for unexposed modules +-- Internal benchmarks ------------------------------------------------------------------------------- --- We have to copy the streamly library modules here because there is no --- way to use unexposed modules from the library. - benchmark base import: bench-options type: exitcode-stdio-1.0 - include-dirs: src/Streamly/Internal/Data/Time - , src/Streamly/Streams - if os(windows) - c-sources: src/Streamly/Internal/Data/Time/Windows.c - if os(darwin) - c-sources: src/Streamly/Internal/Data/Time/Darwin.c - hs-source-dirs: benchmark, src + hs-source-dirs: benchmark + if flag(dev) + cpp-options: -DDEVBUILD + ghc-options: -with-rtsopts "-T -K2M -M16M" + else + ghc-options: -with-rtsopts "-T -K128K -M16M" main-is: BaseStreams.hs - other-modules: Streamly.Internal.Data.Atomics - , Streamly.Internal.Data.Stream.StreamD.Type - , Streamly.Internal.Data.SVar - , Streamly.Internal.Data.Time.Units - , Streamly.Internal.Data.Time.Clock - , Streamly.Streams.StreamDK.Type - , Streamly.Streams.StreamDK - , Streamly.Streams.StreamK.Type - , Streamly.Streams.StreamK - , Streamly.Streams.StreamD - , Streamly.Streams.Prelude - , Streamly.FileSystem.IOVec - - , StreamDOps + other-modules: StreamDOps , StreamKOps , StreamDKOps - if flag(dev) - buildable: True - build-depends: - base >= 4.8 && < 5 + build-depends: + streamly + , base >= 4.8 && < 5 , deepseq >= 1.4.1 && < 1.5 , random >= 1.0 && < 2.0 , gauge >= 0.2.4 && < 0.3 - , ghc-prim >= 0.2 && < 0.6 - , containers >= 0.5.8.2 && < 0.7 - , heaps >= 0.3 && < 0.4 - - -- concurrency - , atomic-primops >= 0.8 && < 0.9 - , lockfree-queue >= 0.2.3 && < 0.3 - - , 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 - else - buildable: False - executable nano-bench import: bench-options - hs-source-dirs: benchmark, src - include-dirs: src/Streamly/Internal/Data/Time - , src/Streamly/Streams - if os(windows) - c-sources: src/Streamly/Internal/Data/Time/Windows.c - if os(darwin) - c-sources: src/Streamly/Internal/Data/Time/Darwin.c + hs-source-dirs: benchmark main-is: NanoBenchmarks.hs - other-modules: Streamly.Internal.Data.Atomics - , Streamly.Internal.Data.Stream.StreamD.Type - , Streamly.Internal.Data.SVar - , Streamly.Internal.Data.Time.Units - , Streamly.Internal.Data.Time.Clock - , Streamly.Streams.StreamK.Type - , Streamly.Streams.StreamK - , Streamly.FileSystem.IOVec - , Streamly.Streams.StreamD 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.8.2 && < 0.7 - , deepseq >= 1.4.1 && < 1.5 - , heaps >= 0.3 && < 0.4 - , random >= 1.0 && < 2.0 - - -- concurrency - , atomic-primops >= 0.8 && < 0.9 - , lockfree-queue >= 0.2.3 && < 0.3 - - , 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 + streamly + , base >= 4.8 && < 5 + , gauge >= 0.2.4 && < 0.3 + , random >= 1.0 && < 2.0 else buildable: False -executable adaptive - import: bench-options +benchmark adaptive + import: bench-options-threaded + type: exitcode-stdio-1.0 hs-source-dirs: benchmark main-is: Adaptive.hs default-language: Haskell2010 - if flag(dev) - buildable: True + build-depends: + streamly + , base >= 4.8 && < 5 + , gauge >= 0.2.4 && < 0.3 + , random >= 1.0 && < 2.0 + if impl(ghc < 8.0) build-depends: - streamly - , base >= 4.8 && < 5 - , gauge >= 0.2.4 && < 0.3 - , random >= 1.0 && < 2.0 - else - buildable: False + transformers >= 0.4 && < 0.6 executable chart default-language: Haskell2010 @@ -823,7 +996,6 @@ build-Depends: streamly , base >= 4.8 && < 5 - , directory >= 1.3 && < 1.4 if impl(ghc < 8.0) build-depends: transformers >= 0.4 && < 0.6 diff --git a/test/Arrays.hs b/test/Arrays.hs deleted file mode 100644 --- a/test/Arrays.hs +++ /dev/null @@ -1,115 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} - -module Main (main) where - -import Foreign.Storable (Storable(..)) - -import Test.Hspec.QuickCheck -import Test.QuickCheck (Property, forAll, Gen, vectorOf, arbitrary, choose) -import Test.QuickCheck.Monadic (monadicIO, assert) - -import Test.Hspec as H - -import qualified Streamly.Internal.Memory.Array as IA -import qualified Streamly.Memory.Array as A -import qualified Streamly.Prelude as S -import qualified Streamly.Internal.Prelude as IP - --- Coverage build takes too long with default number of tests -maxTestCount :: Int -#ifdef DEVBUILD -maxTestCount = 100 -#else -maxTestCount = 10 -#endif - -allocOverhead :: Int -allocOverhead = 2 * sizeOf (undefined :: Int) - --- XXX this should be in sync with the defaultChunkSize in Array code, or we --- should expose that and use that. For fast testing we could reduce the --- defaultChunkSize under CPP conditionals. --- -defaultChunkSize :: Int -defaultChunkSize = 32 * k - allocOverhead - where k = 1024 - -maxArrLen :: Int -maxArrLen = defaultChunkSize * 8 - -testLength :: Property -testLength = - forAll (choose (0, maxArrLen)) $ \len -> - forAll (vectorOf len (arbitrary :: Gen Int)) $ \list -> - monadicIO $ do - arr <- S.fold (A.writeN len) - $ S.fromList list - assert (A.length arr == len) - -testFromToStreamN :: Property -testFromToStreamN = - forAll (choose (0, maxArrLen)) $ \len -> - forAll (vectorOf len (arbitrary :: Gen Int)) $ \list -> - monadicIO $ do - arr <- S.fold (A.writeN len) - $ S.fromList list - xs <- S.toList - $ S.unfold A.read arr - assert (xs == list) - -testToStreamRev :: Property -testToStreamRev = - forAll (choose (0, maxArrLen)) $ \len -> - forAll (vectorOf len (arbitrary :: Gen Int)) $ \list -> - monadicIO $ do - arr <- S.fold (A.writeN len) - $ S.fromList list - xs <- S.toList - $ IA.toStreamRev arr - assert (xs == reverse list) - -testArraysOf :: Property -testArraysOf = - forAll (choose (0, maxArrLen)) $ \len -> - forAll (vectorOf len (arbitrary :: Gen Int)) $ \list -> - monadicIO $ do - xs <- S.toList - $ S.concatUnfold A.read - $ IP.arraysOf 240 - $ S.fromList list - assert (xs == list) - -testFlattenArrays :: Property -testFlattenArrays = - forAll (choose (0, maxArrLen)) $ \len -> - forAll (vectorOf len (arbitrary :: Gen Int)) $ \list -> - monadicIO $ do - xs <- S.toList - $ S.concatUnfold A.read - $ IP.arraysOf 240 - $ S.fromList list - assert (xs == list) - -testFromToStream :: Property -testFromToStream = - forAll (choose (0, maxArrLen)) $ \len -> - forAll (vectorOf len (arbitrary :: Gen Int)) $ \list -> - monadicIO $ do - arr <- S.fold A.write $ S.fromList list - xs <- S.toList - $ S.unfold A.read arr - assert (xs == list) - -main :: IO () -main = hspec - $ H.parallel - $ modifyMaxSuccess (const maxTestCount) - $ do - describe "Construction" $ do - prop "length . writeN n === n" $ testLength - prop "read . writeN n === id" $ testFromToStreamN - prop "toStreamRev . write === reverse" $ testToStreamRev - prop "arraysOf concats to original" $ testArraysOf - prop "concats to original" $ testFlattenArrays - prop "read . write === id" $ testFromToStream diff --git a/test/Prop.hs b/test/Prop.hs --- a/test/Prop.hs +++ b/test/Prop.hs @@ -34,6 +34,7 @@ import Streamly as S import qualified Streamly.Prelude as S import qualified Streamly.Data.Fold as FL +import qualified Streamly.Internal.Data.Fold as FL -- Coverage build takes too long with default number of tests maxTestCount :: Int @@ -492,6 +493,22 @@ let f x = if odd x then Just (x + 100) else Nothing prop (desc <> " mapMaybe") $ transform (mapMaybe f) t (S.mapMaybe f) + -- tap + prop (desc <> " tap FL.sum . map (+1)") $ \a b -> + withMaxSuccess maxTestCount $ + monadicIO $ do + cref <- run $ newIORef 0 + let sumfoldinref = FL.Fold (\_ e -> modifyIORef' cref (e+)) + (return ()) + (const $ return ()) + op = S.tap sumfoldinref . S.mapM (\x -> return (x+1)) + listOp = fmap (+1) + stream <- run ((S.toList . t) $ op (constr a <> constr b)) + let list = listOp (a <> b) + ssum <- run $ readIORef cref + assert (sum list == ssum) + listEquals eq stream list + -- reordering prop (desc <> " reverse") $ transform reverse t S.reverse -- prop (desc <> " reverse'") $ transform reverse t S.reverse' @@ -620,6 +637,10 @@ prop (desc <> " findIndices") $ transform (findIndices odd) t (S.findIndices odd) + prop (desc <> " findIndices . filter") $ + transform (findIndices odd . filter odd) + t + (S.findIndices odd . S.filter odd) prop (desc <> " elemIndices") $ transform (elemIndices 0) t (S.elemIndices 0) diff --git a/test/Streamly/Test/Array.hs b/test/Streamly/Test/Array.hs new file mode 100644 --- /dev/null +++ b/test/Streamly/Test/Array.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE CPP #-} + +-- | +-- Module : Main +-- Copyright : (c) 2019 Composewell Technologies +-- +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +module Main (main) where + +import Foreign.Storable (Storable(..)) + +import Test.Hspec.QuickCheck +import Test.QuickCheck (Property, forAll, Gen, vectorOf, arbitrary, choose) +import Test.QuickCheck.Monadic (monadicIO, assert, run) + +import Test.Hspec as H + +import Streamly (SerialT) + +import qualified Streamly.Prelude as S + +#ifdef TEST_SMALL_ARRAY +import qualified Streamly.Internal.Data.SmallArray as A +type Array = A.SmallArray +#elif defined(TEST_ARRAY) +import qualified Streamly.Memory.Array as A +import qualified Streamly.Internal.Memory.Array as A +import qualified Streamly.Internal.Prelude as IP +type Array = A.Array +#elif defined(TEST_PRIM_ARRAY) +import qualified Streamly.Internal.Data.Prim.Array as A +type Array = A.PrimArray +#else +import qualified Streamly.Internal.Data.Array as A +type Array = A.Array +#endif + +-- Coverage build takes too long with default number of tests +maxTestCount :: Int +#ifdef DEVBUILD +maxTestCount = 100 +#else +maxTestCount = 10 +#endif + +allocOverhead :: Int +allocOverhead = 2 * sizeOf (undefined :: Int) + +-- XXX this should be in sync with the defaultChunkSize in Array code, or we +-- should expose that and use that. For fast testing we could reduce the +-- defaultChunkSize under CPP conditionals. +-- +defaultChunkSize :: Int +defaultChunkSize = 32 * k - allocOverhead + where k = 1024 + +maxArrLen :: Int +maxArrLen = defaultChunkSize * 8 + +genericTestFrom :: + (Int -> SerialT IO Int -> IO (Array Int)) + -> Property +genericTestFrom arrFold = + forAll (choose (0, maxArrLen)) $ \len -> + forAll (vectorOf len (arbitrary :: Gen Int)) $ \list -> + monadicIO $ do + arr <- run $ arrFold len $ S.fromList list + assert (A.length arr == len) + +testLength :: Property +testLength = genericTestFrom (\n -> S.fold (A.writeN n)) + +testLengthFromStreamN :: Property +testLengthFromStreamN = genericTestFrom A.fromStreamN + +#ifndef TEST_SMALL_ARRAY +testLengthFromStream :: Property +testLengthFromStream = genericTestFrom (const A.fromStream) +#endif + +genericTestFromTo :: + (Int -> SerialT IO Int -> IO (Array Int)) + -> (Array Int -> SerialT IO Int) + -> ([Int] -> [Int] -> Bool) + -> Property +genericTestFromTo arrFold arrUnfold listEq = + forAll (choose (0, maxArrLen)) $ \len -> + forAll (vectorOf len (arbitrary :: Gen Int)) $ \list -> + monadicIO $ do + arr <- run $ arrFold len $ S.fromList list + xs <- run $ S.toList $ arrUnfold arr + assert (listEq xs list) + +testFoldNUnfold :: Property +testFoldNUnfold = + genericTestFromTo (\n -> S.fold (A.writeN n)) (S.unfold A.read) (==) + +testFoldNToStream :: Property +testFoldNToStream = + genericTestFromTo (\n -> S.fold (A.writeN n)) A.toStream (==) + +testFoldNToStreamRev :: Property +testFoldNToStreamRev = + genericTestFromTo + (\n -> S.fold (A.writeN n)) + A.toStreamRev + (\xs list -> xs == reverse list) + +testFromStreamNUnfold :: Property +testFromStreamNUnfold = genericTestFromTo A.fromStreamN (S.unfold A.read) (==) + +testFromStreamNToStream :: Property +testFromStreamNToStream = genericTestFromTo A.fromStreamN A.toStream (==) + +#ifndef TEST_SMALL_ARRAY +testFromStreamToStream :: Property +testFromStreamToStream = genericTestFromTo (const A.fromStream) A.toStream (==) + +testFoldUnfold :: Property +testFoldUnfold = genericTestFromTo (const (S.fold A.write)) (S.unfold A.read) (==) +#endif + +#ifdef TEST_ARRAY +testArraysOf :: Property +testArraysOf = + forAll (choose (0, maxArrLen)) $ \len -> + forAll (vectorOf len (arbitrary :: Gen Int)) $ \list -> + monadicIO $ do + xs <- S.toList + $ S.concatUnfold A.read + $ IP.arraysOf 240 + $ S.fromList list + assert (xs == list) + +lastN :: Int -> [a] -> [a] +lastN n l = drop (length l - n) l + +testLastN :: Property +testLastN = + forAll (choose (0, maxArrLen)) $ \len -> + forAll (choose (0, len)) $ \n -> + forAll (vectorOf len (arbitrary :: Gen Int)) $ \list -> + monadicIO $ do + xs <- fmap A.toList + $ S.fold (A.lastN n) + $ S.fromList list + assert (xs == lastN n list) +#endif + +main :: IO () +main = + hspec $ + H.parallel $ + modifyMaxSuccess (const maxTestCount) $ do + describe "Construction" $ do + prop "length . writeN n === n" testLength + prop "length . fromStreamN n === n" testLengthFromStreamN + prop "read . writeN === id " testFoldNUnfold + prop "toStream . writeN === id" testFoldNToStream + prop "toStreamRev . writeN === reverse" testFoldNToStreamRev + prop "read . fromStreamN === id" testFromStreamNUnfold + prop "toStream . fromStreamN === id" testFromStreamNToStream +#ifndef TEST_SMALL_ARRAY + prop "length . fromStream === n" testLengthFromStream + prop "toStream . fromStream === id" testFromStreamToStream + prop "read . write === id" testFoldUnfold +#endif +#ifdef TEST_ARRAY + prop "arraysOf concats to original" testArraysOf +#endif +#ifdef TEST_ARRAY + describe "Fold" $ do + prop "lastN" $ testLastN +#endif diff --git a/test/Streamly/Test/Internal/Data/Fold.hs b/test/Streamly/Test/Internal/Data/Fold.hs new file mode 100644 --- /dev/null +++ b/test/Streamly/Test/Internal/Data/Fold.hs @@ -0,0 +1,27 @@ +module Main (main) where + +import qualified Streamly.Prelude as S +import Streamly.Internal.Data.Fold + +import Test.Hspec.QuickCheck +import Test.QuickCheck (Property, forAll, Gen, vectorOf, arbitrary, choose) +import Test.QuickCheck.Monadic (monadicIO, assert, run) + +import Test.Hspec as H + +maxStreamLen :: Int +maxStreamLen = 1000 + +testRollingHashFirstN :: Property +testRollingHashFirstN = + forAll (choose (0, maxStreamLen)) $ \len -> + forAll (choose (0, len)) $ \n -> + forAll (vectorOf len (arbitrary :: Gen Int)) $ \vec -> monadicIO $ do + a <- run $ S.fold rollingHash $ S.take n $ S.fromList vec + b <- run $ S.fold (rollingHashFirstN n) $ S.fromList vec + assert $ a == b + +main :: IO () +main = hspec $ + describe "Rolling Hash Folds" $ + prop "testRollingHashFirstN" testRollingHashFirstN diff --git a/test/Streamly/Test/Internal/Prelude.hs b/test/Streamly/Test/Internal/Prelude.hs new file mode 100644 --- /dev/null +++ b/test/Streamly/Test/Internal/Prelude.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : Main +-- Copyright : (c) 2019 Composewell Technologies +-- +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +module Main (main) where + +import Control.Concurrent (threadDelay) +import Control.Monad (when) + +import Test.Hspec as H + +import qualified Streamly.Prelude as S +import qualified Streamly.Internal.Data.Fold as FL +import qualified Streamly.Internal.Prelude as SI + +import Streamly.Internal.Data.Time.Clock (Clock(Monotonic), getTime) +import Streamly.Internal.Data.Time.Units + (AbsTime, NanoSecond64(..), toRelTime64, diffAbsTime64) +import Data.Int (Int64) + +tenPow8 :: Int64 +tenPow8 = 10^(8 :: Int) + +tenPow7 :: Int64 +tenPow7 = 10^(7 :: Int) + +takeDropTime :: NanoSecond64 +takeDropTime = NanoSecond64 $ 5 * tenPow8 + +checkTakeDropTime :: (Maybe AbsTime, Maybe AbsTime) -> IO Bool +checkTakeDropTime (mt0, mt1) = do + let graceTime = NanoSecond64 $ 8 * tenPow7 + case mt0 of + Nothing -> return True + Just t0 -> + case mt1 of + Nothing -> return True + Just t1 -> do + let tMax = toRelTime64 (takeDropTime + graceTime) + let tMin = toRelTime64 (takeDropTime - graceTime) + let t = diffAbsTime64 t1 t0 + let r = t >= tMin && t <= tMax + when (not r) $ putStrLn $ + "t = " ++ show t ++ + " tMin = " ++ show tMin ++ + " tMax = " ++ show tMax + return r + +testTakeByTime :: IO Bool +testTakeByTime = do + r <- + S.fold ((,) <$> FL.head <*> FL.last) + $ SI.takeByTime takeDropTime + $ S.repeatM (threadDelay 1000 >> getTime Monotonic) + checkTakeDropTime r + +testDropByTime :: IO Bool +testDropByTime = do + t0 <- getTime Monotonic + mt1 <- + S.head + $ SI.dropByTime takeDropTime + $ S.repeatM (threadDelay 1000 >> getTime Monotonic) + checkTakeDropTime (Just t0, mt1) + +main :: IO () +main = + hspec $ + describe "Filtering" $ do + it "takeByTime" (testTakeByTime `shouldReturn` True) + it "dropByTime" (testDropByTime `shouldReturn` True) diff --git a/test/version-bounds.hs b/test/version-bounds.hs new file mode 100644 --- /dev/null +++ b/test/version-bounds.hs @@ -0,0 +1,4 @@ +main :: IO () +main = + print + "Version bounds do not conflict when both streamly and ghc are dependencies."