packages feed

streamly 0.7.0 → 0.7.1

raw patch · 139 files changed

+25550/−17163 lines, 139 filesdep +fusion-plugindep +fusion-plugin-typesdep +ghcdep ~containersdep ~directorydep ~randomnew-uploaderbinary-added

Dependencies added: fusion-plugin, fusion-plugin-types, ghc, inspection-and-dev-flags-cannot-be-used-together, primitive

Dependency ranges changed: containers, directory, random

Files

Changelog.md view
@@ -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
README.md view
@@ -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
bench.sh view
@@ -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 <all|linear|linear-async|linear-rate|nested|concurrent|fileio|array|base>]"+  echo "       [--benchmarks <ALL|SERIAL|CONCURRENT|ARRAY|INFINITE|FINITE|DEV$(list_benches)>]"   echo "       [--group-diff]"   echo "       [--graphs]"   echo "       [--no-measure]"-  echo "       [--append] "-  echo "       [--compare] [--base commit] [--candidate commit]"+  echo "       [--append]"+  echo "       [--long]"   echo "       [--slow]"-  echo "       -- <gauge options>"+  echo "       [--quick]"+  echo "       [--compare] [--base commit] [--candidate commit]"+  echo "       [--cabal-build-flags]"+  echo "       -- <gauge options or benchmarks>"   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
benchmark/BaseStreams.hs view
@@ -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"
benchmark/Chart.hs view
@@ -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"
+ benchmark/Common.hs view
@@ -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)
benchmark/Concurrent.hs view
@@ -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)    ]
benchmark/FileIO.hs view
@@ -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
benchmark/Linear.hs view
@@ -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       ]     ]
benchmark/LinearAsync.hs view
@@ -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         ]       ]
benchmark/LinearRate.hs view
@@ -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)         ]       ]     ]
benchmark/NanoBenchmarks.hs view
@@ -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
benchmark/Nested.hs view
@@ -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       ]     ]
+ benchmark/NestedConcurrent.hs view
@@ -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+        ]+      ]+    ]
benchmark/NestedOps.hs view
@@ -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))
benchmark/NestedUnfold.hs view
@@ -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       ]     ]
benchmark/NestedUnfoldOps.hs view
@@ -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)
+ benchmark/Parallel.hs view
@@ -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+              ]+            ]
benchmark/StreamDKOps.hs view
@@ -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
benchmark/StreamDOps.hs view
@@ -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
benchmark/StreamKOps.hs view
@@ -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
+ benchmark/Streamly/Benchmark/Data/Array.hs view
@@ -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)+        ]+    ]+    ]
+ benchmark/Streamly/Benchmark/Data/ArrayOps.hs view
@@ -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
+ benchmark/Streamly/Benchmark/Data/Prim/Array.hs view
@@ -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)+        ]+    ]+    ]
+ benchmark/Streamly/Benchmark/Data/Prim/ArrayOps.hs view
@@ -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
+ benchmark/Streamly/Benchmark/Data/SmallArray.hs view
@@ -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)+        ]+    ]+    ]
+ benchmark/Streamly/Benchmark/Data/SmallArrayOps.hs view
@@ -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
+ benchmark/Streamly/Benchmark/FileIO/Array.hs view
@@ -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
+ benchmark/Streamly/Benchmark/FileIO/Stream.hs view
@@ -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
+ benchmark/Streamly/Benchmark/Prelude.hs view
@@ -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
credits/CONTRIBUTORS.md view
@@ -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
credits/COPYRIGHTS.md view
@@ -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.
− credits/pipes-concurrency.txt 
@@ -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.
+ credits/primitive-0.7.0.0.txt view
@@ -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.+
+ design/dfa-bytes.png view

binary file changed (absent → 18288 bytes)

+ design/dfa-classes.png view

binary file changed (absent → 15413 bytes)

+ design/dfa-rearr.png view

binary file changed (absent → 16619 bytes)

+ design/inlining.md view
@@ -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 .
+ design/linked-lists.md view
@@ -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.
+ design/module-organization.md view
@@ -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.
+ design/utf8-decoder.md view
@@ -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 <bjoern@hoehrmann.de>+    // 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(&current, &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 <bjoern@hoehrmann.de>+    // 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/)+\<<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) <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))
+ docs/Build.md view
@@ -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
examples/ControlFlow.hs view
@@ -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
examples/HandleIO.hs view
@@ -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
examples/ListDir.hs view
@@ -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
src/Streamly.hs view
@@ -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 --
− src/Streamly/Benchmark/FileIO/Array.hs 
@@ -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
− src/Streamly/Benchmark/FileIO/Stream.hs 
@@ -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
− src/Streamly/Benchmark/Prelude.hs 
@@ -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
+ src/Streamly/Data/Array.hs view
@@ -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
src/Streamly/Data/Fold.hs view
@@ -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
+ src/Streamly/Data/Prim/Array.hs view
@@ -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
+ src/Streamly/Data/SmallArray.hs view
@@ -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
src/Streamly/Data/Unfold.hs view
@@ -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     (
src/Streamly/Data/Unicode/Stream.hs view
@@ -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.
src/Streamly/FileSystem/FD.hs view
@@ -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
src/Streamly/FileSystem/FDIO.hs view
@@ -1,8 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE UnboxedTuples #-}  #include "inline.hs"
src/Streamly/FileSystem/Handle.hs view
@@ -1,8 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE UnboxedTuples #-}  #include "inline.hs"
+ src/Streamly/Internal/BaseCompat.hs view
@@ -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
+ src/Streamly/Internal/Control/Monad.hs view
@@ -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 ())
+ src/Streamly/Internal/Data/Array.hs view
@@ -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)
src/Streamly/Internal/Data/Atomics.hs view
@@ -1,4 +1,3 @@-{-# OPTIONS_HADDOCK hide #-} {-# LANGUAGE CPP         #-}  -- |
src/Streamly/Internal/Data/Fold.hs view
@@ -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 ()
src/Streamly/Internal/Data/Fold/Types.hs view
@@ -1,4 +1,3 @@-{-# OPTIONS_HADDOCK hide               #-} {-# LANGUAGE CPP                       #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts          #-}
src/Streamly/Internal/Data/List.hs view
@@ -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
src/Streamly/Internal/Data/Pipe.hs view
@@ -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 #-}
src/Streamly/Internal/Data/Pipe/Types.hs view
@@ -1,4 +1,3 @@-{-# OPTIONS_HADDOCK hide               #-} {-# LANGUAGE CPP                       #-} {-# LANGUAGE ExistentialQuantification #-}
+ src/Streamly/Internal/Data/Prim/Array.hs view
@@ -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)
+ src/Streamly/Internal/Data/Prim/Array/Types.hs view
@@ -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.+-}
src/Streamly/Internal/Data/SVar.hs view
@@ -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
src/Streamly/Internal/Data/Sink.hs view
@@ -1,5 +1,3 @@-{-# OPTIONS_HADDOCK hide #-}- -- | -- Module      : Streamly.Internal.Data.Sink -- Copyright   : (c) 2019 Composewell Technologies
src/Streamly/Internal/Data/Sink/Types.hs view
@@ -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 ())
+ src/Streamly/Internal/Data/SmallArray.hs view
@@ -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)
+ src/Streamly/Internal/Data/SmallArray/Types.hs view
@@ -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
+ src/Streamly/Internal/Data/Stream/Ahead.hs view
@@ -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)
+ src/Streamly/Internal/Data/Stream/Async.hs view
@@ -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)
+ src/Streamly/Internal/Data/Stream/Combinators.hs view
@@ -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
+ src/Streamly/Internal/Data/Stream/Enumeration.hs view
@@ -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)+-}
+ src/Streamly/Internal/Data/Stream/Instances.hs view
@@ -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 }}
+ src/Streamly/Internal/Data/Stream/Parallel.hs view
@@ -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)
+ src/Streamly/Internal/Data/Stream/Prelude.hs view
@@ -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
+ src/Streamly/Internal/Data/Stream/SVar.hs view
@@ -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
+ src/Streamly/Internal/Data/Stream/Serial.hs view
@@ -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)
+ src/Streamly/Internal/Data/Stream/StreamD.hs view
@@ -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
src/Streamly/Internal/Data/Stream/StreamD/Type.hs view
@@ -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
+ src/Streamly/Internal/Data/Stream/StreamDK.hs view
@@ -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 ()+        -}
+ src/Streamly/Internal/Data/Stream/StreamDK/Type.hs view
@@ -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))
+ src/Streamly/Internal/Data/Stream/StreamK.hs view
@@ -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+-}
+ src/Streamly/Internal/Data/Stream/StreamK/Type.hs view
@@ -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+-}
+ src/Streamly/Internal/Data/Stream/Zip.hs view
@@ -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
src/Streamly/Internal/Data/Strict.hs view
@@ -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
src/Streamly/Internal/Data/Time.hs view
@@ -1,5 +1,3 @@-{-# OPTIONS_HADDOCK hide #-}- -- | -- Module      : Streamly.Internal.Data.Time -- Copyright   : (c) 2017 Harendra Kumar
src/Streamly/Internal/Data/Time/Clock.hsc view
@@ -1,4 +1,3 @@-{-# OPTIONS_HADDOCK hide                 #-} {-# LANGUAGE CPP                         #-} {-# LANGUAGE DeriveGeneric               #-} {-# LANGUAGE GeneralizedNewtypeDeriving  #-}
src/Streamly/Internal/Data/Time/Units.hs view
@@ -1,4 +1,3 @@-{-# OPTIONS_HADDOCK hide                #-} {-# LANGUAGE CPP                        #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables        #-}
src/Streamly/Internal/Data/Unfold.hs view
@@ -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'.
src/Streamly/Internal/Data/Unfold/Types.hs view
@@ -1,4 +1,3 @@-{-# OPTIONS_HADDOCK hide               #-} {-# LANGUAGE CPP                       #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts          #-}
src/Streamly/Internal/Data/Unicode/Char.hs view
@@ -1,4 +1,3 @@-{-# OPTIONS_HADDOCK hide      #-} {-# LANGUAGE FlexibleContexts #-}  -- |
src/Streamly/Internal/Data/Unicode/Stream.hs view
@@ -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  {- -------------------------------------------------------------------------------
src/Streamly/Internal/FileSystem/Dir.hs view
@@ -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
src/Streamly/Internal/FileSystem/File.hs view
@@ -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)
src/Streamly/Internal/FileSystem/Handle.hs view
@@ -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@.
src/Streamly/Internal/Memory/Array.hs view
@@ -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 --
src/Streamly/Internal/Memory/Array/Types.hs view
@@ -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/
src/Streamly/Internal/Memory/ArrayStream.hs view
@@ -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.
src/Streamly/Internal/Memory/Unicode/Array.hs view
@@ -1,4 +1,3 @@-{-# OPTIONS_HADDOCK hide      #-} {-# LANGUAGE FlexibleContexts #-}  -- |
+ src/Streamly/Internal/Mutable/Prim/Var.hs view
@@ -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'#
src/Streamly/Internal/Network/Inet/TCP.hs view
@@ -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
src/Streamly/Internal/Network/Socket.hs view
@@ -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. --
src/Streamly/Internal/Prelude.hs view
@@ -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.
src/Streamly/Memory/Array.hs view
@@ -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.
src/Streamly/Memory/Malloc.hs view
@@ -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
src/Streamly/Memory/Ring.hs view
@@ -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
src/Streamly/Network/Socket.hs view
@@ -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.
src/Streamly/Prelude.hs view
@@ -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
− src/Streamly/Streams/Ahead.hs 
@@ -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)
− src/Streamly/Streams/Async.hs 
@@ -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)
− src/Streamly/Streams/Combinators.hs 
@@ -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
− src/Streamly/Streams/Enumeration.hs 
@@ -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)--}
− src/Streamly/Streams/Instances.hs 
@@ -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 }}
− src/Streamly/Streams/Parallel.hs 
@@ -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)
− src/Streamly/Streams/Prelude.hs 
@@ -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
− src/Streamly/Streams/SVar.hs 
@@ -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)
− src/Streamly/Streams/Serial.hs 
@@ -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)
− src/Streamly/Streams/StreamD.hs 
@@ -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)
− src/Streamly/Streams/StreamDK.hs 
@@ -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 ()-        -}
− src/Streamly/Streams/StreamDK/Type.hs 
@@ -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))
− src/Streamly/Streams/StreamK.hs 
@@ -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--}
− src/Streamly/Streams/StreamK/Type.hs 
@@ -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--}
− src/Streamly/Streams/Zip.hs 
@@ -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
− src/Streamly/Streams/inline.hs 
@@ -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]
+ src/inline.hs view
@@ -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]
stack.yaml view
@@ -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: {}
streamly.cabal view
@@ -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/: <src/README.md README file> in the package+  * /Quick Overview/: <#readme README file> in the package   * /Building/: <src/docs/Build.md Build guide> for optimal performance   * /Detailed Tutorial/: "Streamly.Tutorial" module in the haddock documentation   * /Interoperation/: "Streamly.Tutorial" module for interop with other@@ -75,10 +75,6 @@   * <https://github.com/composewell/streaming-benchmarks Streaming Benchmarks>   * <https://github.com/composewell/concurrency-benchmarks 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   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
− test/Arrays.hs 
@@ -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
test/Prop.hs view
@@ -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)
+ test/Streamly/Test/Array.hs view
@@ -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
+ test/Streamly/Test/Internal/Data/Fold.hs view
@@ -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
+ test/Streamly/Test/Internal/Prelude.hs view
@@ -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)
+ test/version-bounds.hs view
@@ -0,0 +1,4 @@+main :: IO ()+main =+    print+        "Version bounds do not conflict when both streamly and ghc are dependencies."