packages feed

streamly 0.6.1 → 0.7.0

raw patch · 141 files changed

+35645/−9450 lines, 141 filesdep +directorydep +hashabledep +inspection-testingdep −path-iodep ~bench-showdep ~clockdep ~containersnew-component:exe:CamelCasenew-component:exe:EchoServernew-component:exe:FileIOExamplesnew-component:exe:FileSinkServernew-component:exe:FromFileClientnew-component:exe:HandleIOnew-component:exe:WordClassifiernew-component:exe:WordCount

Dependencies added: directory, hashable, inspection-testing, network, template-haskell, typed-process, unordered-containers, vector

Dependencies removed: path-io

Dependency ranges changed: bench-show, clock, containers, deepseq, random

Files

Changelog.md view
@@ -1,3 +1,115 @@+## 0.7.0++### Breaking changes++* Change the signature of `foldrM` to ensure that it is lazy+* Change the signature of `iterateM` to ensure that it is lazy.+* `scanx` would now require an additional `Monad m` constraint.++### Behavior change++* Earlier `ParallelT` was unaffected by `maxBuffer` directive, now `maxBuffer`+  can limit the buffer of a `ParallelT` stream as well. When the buffer becomes+  full, the producer threads block.+* `ParallelT` streams no longer have an unlimited buffer by default. Now the+  buffer for parallel streams is limited to 1500 by default, the same as other+  concurrent stream types.++### Deprecations++* In `Streamly.Prelude`:+    * `runStream` has been replaced by `drain`+    * `runN` has been replaced by `drainN`+    * `runWhile` has been replaced by `drainWhile`+    * `fromHandle` has been deprecated. Please use+      `Streamly.FileSystem.Handle.read`, `Streamly.Data.Unicode.Stream.decodeUtf8` and+      `splitOnSuffix` with `Streamly.Data.Fold.toList` to split the+       stream to a stream of `String` separated by a newline.+    * `toHandle` has been deprecated. Please use `intersperse` and `concatUnfold` to+      add newlines to a stream, `Streamly.Data.Unicode.Stream.encodeUtf8` for encoding and+      `Streamly.FileSystem.Handle.write` for writing to a file handle.+    * Deprecate `scanx`, `foldx`, `foldxM`, `foldr1`+    * Remove deprecated APIs `foldl`, `foldlM`+    * Replace deprecated API `scan` with a new signature, to scan using Fold.++* In `Streamly` module:+    * `runStream` has been deprecated, please use `Streamly.Prelude.drain`++* Remove deprecated module `Streamly.Time` (moved to Streamly.Internal.Data.Time)+* Remove module `Streamly.Internal` (functionality moved to the Internal hierarchy)++### Bug Fixes++* 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.++### Major Enhancements++This release contains a lot of new features and major enhancements.  For more+details on the new features described below please see the haddock docs of the+modules on hackage.++#### Exception Handling++See `Streamly.Prelude` for new exception handling combinators like `before`,+`after`, `bracket`, `onException`, `finally`, `handle` etc.++#### Composable Folds++`Streamly.Data.Fold` module provides composable folds (stream consumers). Folds+allow splitting, grouping, partitioning, unzipping and nesting a stream onto+multiple folds without breaking the stream. Combinators are provided for+temporal and spatial window based fold operations, for example, to support+folding and aggregating data for timeout or inactivity based sessions.++#### Composable Unfolds++`Streamly.Data.Unfold` module provides composable stream generators. Unfolds allow+high performance merging/flattening/combining of stream generators.++#### Streaming File IO++`Streamly.FileSystem.Handle` provides handle based streaming file IO+operations.++#### Streaming Network IO++* `Streamly.Network.Socket` provides socket based streaming network IO+operations.++* `Streamly.Network.Inet.TCP` provides combinators to build Inet/TCP+clients and servers.++#### Concurrent concatMap++The new `concatMapWith` in `Streamly.Prelude` combinator performs a+`concatMap` using a supplied merge/concat strategy. This is a very+powerful combinator as you can, for example, concat streams+concurrently using this.++### Other Enhancements++* Add the following new features/modules:+  * _Unicode Strings_: `Streamly.Data.Unicode.Stream` module provides+    encoding/decoding of character streams and other character stream+    operations.+  * _Arrays_: `Streamly.Memory.Array` module provides arrays for efficient+    in-memory buffering and efficient interfacing with IO.++* Add the following to `Streamly.Prelude`:+    * `unfold`, `fold`, `scan` and `postscan`+    * `concatUnfold` to concat a stream after unfolding each element+    * `intervalsOf` and `chunksOf`+    * `splitOn`, `splitOnSuffix`, `splitWithSuffix`, and `wordsBy`+    * `groups`, `groupsBy` and `groupsByRolling`+    * `postscanl'` and `postscanlM'`+    * `intersperse` intersperse an element in between consecutive elements in+      stream+    * `trace` combinator maps a monadic function on a stream just for side+      effects+    * `tap` redirects a copy of the stream to a `Fold`+ ## 0.6.1  ### Bug Fixes@@ -30,7 +142,7 @@     * Multi-stream: `eqBy`, `cmpBy`, `mergeBy`, `mergeByM`, `mergeAsyncBy`,       `mergeAsyncByM`, `isPrefixOf`, `isSubsequenceOf`, `stripPrefix`,       `concatMap`, `concatMapM`, `indexed`, `indexedR`-* Following instances were added for `SerialT m`, `WSerialT m` and +* Following instances were added for `SerialT m`, `WSerialT m` and   `ZipSerialM m`:   * When `m` ~ `Identity`: IsList, Eq, Ord, Show, Read, IsString, NFData,     NFData1, Traversable
README.md view
@@ -22,27 +22,28 @@  ## Where to use streamly? -Streamly is a general purpose programming framwework.  It can be used equally+Streamly is a general purpose programming framework.  It can be used equally efficiently from a simple `Hello World!` program to a massively concurrent application. The answer to the question, "where to use streamly?" - would be similar to the answer to - "Where to use Haskell lists or the IO monad?".-Streamly generalizes lists to monadic streams, and the `IO` monad to-non-deterministic and concurrent stream composition. The `IO` monad is a-special case of streamly; if we use single element streams the behavior of-streamly becomes identical to the IO monad.  The IO monad code can be replaced-with streamly by just prefixing the IO actions with `liftIO`, without any other-changes, and without any loss of performance.  Pure lists too are a special-case of streamly; if we use `Identity` as the underlying monad, streamly-streams turn into pure lists.  Non-concurrent programs are just a special case-of concurrent ones, simply adding a combinator turns a non-concurrent program-into a concurrent one. -In other words, streamly combines the functionality of lists and IO, with-builtin concurrency.  If you want to write a program that involves IO,-concurrent or not, then you can just use streamly as the base monad, in fact,-you could even use streamly for pure computations, as streamly performs at par-with pure lists or `vector`.+Streamly simplifies streaming and makes it as intuitive as plain lists. Unlike+other streaming libraries, no fancy types are required.  Streamly is simply a+generalization of Haskell lists to monadic streaming optionally with concurrent+composition. The basic stream type in streamly `SerialT m a` can be considered+as a list type `[a]` parameterized by the monad `m`. For example, `SerialT IO+a` is a moral equivalent of `[a]` in the IO monad. `SerialT Identity a`, is+equivalent to pure lists.  Streams are constructed very much like lists, except+that they use `nil` and `cons` instead of `[]` and `:`.  Unlike lists, streams+can be constructed from monadic effects, not just pure elements.  Streams are+processed just like lists, with list like combinators, except that they are+monadic and work in a streaming fashion. In other words streamly just completes+what lists lack, you do not need to learn anything new. Please see [streamly vs+lists](docs/streamly-vs-lists.md) for a detailed comparison. +Not surprisingly, the monad instance of streamly is a list transformer, with+concurrency capability.+ ## Why data flow programming?  If you need some convincing for using streaming or data flow programming@@ -55,66 +56,45 @@ model, we just love to fall into the imperative trap, and start asking the same fundamental question again - why do we have to use the streaming data model? -## Show me an example--Here is an IO monad code to list a directory recursively:--```haskell-import Control.Monad.IO.Class (liftIO)-import Path.IO (listDir, getCurrentDir) -- from path-io package--listDirRecursive = getCurrentDir >>= readdir-  where-    readdir dir = do-      (dirs, files) <- listDir dir-      liftIO $ mapM_ putStrLn-             $ map show dirs ++ map show files-      foldMap readdir dirs-```--This is your usual IO monad code, with no streamly specific code whatsoever.-This is how you can run this:--``` haskell-main :: IO ()-main = listDirRecursive-```--And, this is how you can run exactly the same code using streamly with-lookahead style concurrency, the only difference is that this time multiple-directories are read concurrently:--``` haskell-import Streamly (runStream, aheadly)+## Comparative Performance -main :: IO ()-main = runStream $ aheadly $ listDirRecursive-```+High performance and simplicity are the two primary goals of streamly.+`Streamly` employs two different stream representations (CPS and direct style)+and interconverts between the two to get the best of both worlds on different+operations. It uses both foldr/build (for CPS style) and stream fusion (for+direct style) techniques to fuse operations. In terms of performance,+Streamly's goal is to compete with equivalent C programs. Streamly redefines+"blazing fast" for streaming libraries, it competes with lists and `vector`.+Other streaming libraries like "streaming", "pipes" and "conduit" are orders of+magnitude slower on most microbenchmarks.  See [streaming+benchmarks](https://github.com/composewell/streaming-benchmarks) for detailed+comparison. -Isn't that magical? What's going on here? Streamly does not introduce any new-abstractions, it just uses standard abstractions like `Semigroup` or-`Monoid` to combine monadic streams concurrently, the way lists combine a-sequence of pure values non-concurrently. The `foldMap` in the code-above turns into a concurrent monoidal composition of a stream of `readdir`-computations.+The following chart shows a comparison of those streamly and list operations+where performance of the two differs by more than 10%. Positive y-axis displays+how many times worse is a list operation compared to the same streamly+operation, negative y-axis shows where streamly is worse compared to lists. -## How does it perform?+![Streamly vs Lists (time) comparison](charts-0/streamly-vs-list-time.svg) -Providing monadic streaming and high level declarative concurrency does not-mean that `streamly` compromises with performance in any way. The-non-concurrent performance of `streamly` competes with lists and the `vector`-library. The concurrent performance is as good as it gets, see [concurrency+Streamly uses lock-free synchronization for concurrent operations. It employs+auto-scaling of the degree of concurrency based on demand. For CPU bound tasks+it tries to keep the threads close to the number of CPUs available whereas for+IO bound tasks more threads can be utilized. Parallelism can be utilized with+little overhead even if the task size is very small.  See [concurrency benchmarks](https://github.com/composewell/concurrency-benchmarks) for detailed performance results and a comparison with the `async` package. -The following chart shows a summary of the cost of key streaming operations-processing a million elements. The timings for `streamly` and `vector` are in-the 600-700 microseconds range and therefore can barely be seen in the graph.-For more details, see [streaming-benchmarks](https://github.com/composewell/streaming-benchmarks).+## Installing and using -![Streaming Operations at a Glance](charts-0/KeyOperations-time.svg)+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. +The module `Streamly` provides just the core stream types, type casting and+concurrency control combinators.  Stream construction, transformation, folding,+merging, zipping combinators are found in `Streamly.Prelude`.+ ## Streaming Pipelines  The following snippet provides a simple stream composition example that reads@@ -126,7 +106,7 @@ import qualified Streamly.Prelude as S import Data.Function ((&)) -main = runStream $+main = S.drain $        S.repeatM getLine      & fmap read      & S.filter even@@ -140,33 +120,50 @@ just like a list and is explicitly passed around to functions that process the stream.  Therefore, no special operator is needed to join stages in a streaming pipeline, just the standard function application (`$`) or reverse function-application (`&`) operator is enough.  Combinators are provided in-`Streamly.Prelude` to transform or fold streams.+application (`&`) operator is enough.  ## Concurrent Stream Generation -Monadic construction and generation functions e.g. `consM`, `unfoldrM`,-`replicateM`, `repeatM`, `iterateM` and `fromFoldableM` etc. work concurrently-when used with appropriate stream type combinator (e.g. `asyncly`, `aheadly` or-`parallely`).+`consM` or its operator form `|:` can be used to construct a stream from+monadic actions. A stream constructed with `consM` can run the monadic actions+in the stream concurrently when used with appropriate stream type combinator+(e.g. `asyncly`, `aheadly` or `parallely`). -The following code finishes in 3 seconds (6 seconds when serial):+The following code finishes in 3 seconds (6 seconds when serial), note the+order of elements in the resulting output, the outputs are consumed as soon as+each action is finished (asyncly):  ``` haskell > let p n = threadDelay (n * 1000000) >> return n+> S.toList $ asyncly $ p 3 |: p 2 |: p 1 |: S.nil+[1,2,3]+```++Use `aheadly` if you want speculative concurrency i.e. execute the actions in+the stream concurrently but consume the results in the specified order:++``` haskell > S.toList $ aheadly $ p 3 |: p 2 |: p 1 |: S.nil [3,2,1]--> S.toList $ parallely $ p 3 |: p 2 |: p 1 |: S.nil-[1,2,3] ``` +Monadic stream generation functions e.g. `unfoldrM`, `replicateM`, `repeatM`,+`iterateM` and `fromFoldableM` etc. can work concurrently.+ The following finishes in 10 seconds (100 seconds when serial):  ``` haskell-runStream $ asyncly $ S.replicateM 10 $ p 10+S.drain $ asyncly $ S.replicateM 10 $ p 10 ``` +## Concurrency Auto Scaling++Concurrency is auto-scaled i.e. more actions are executed concurrently if the+consumer is consuming the stream at a higher speed. How many tasks are executed+concurrently can be controlled by `maxThreads` and how many results are+buffered ahead of consumption can be controlled by `maxBuffer`. See the+documentation in the `Streamly` module.+ ## Concurrent Streaming Pipelines  Use `|&` or `|$` to apply stream processing functions concurrently. The@@ -175,7 +172,7 @@ application.  ``` haskell-main = runStream $+main = S.drain $       S.repeatM (threadDelay 1000000 >> return "hello")    |& S.mapM (\x -> threadDelay 1000000 >> putStrLn x) ```@@ -186,7 +183,7 @@  ``` haskell > let p n = threadDelay (n * 1000000) >> return n-> runStream $ aheadly $ S.mapM (\x -> p 1 >> print x) (serially $ repeatM (p 1))+> S.drain $ aheadly $ S.mapM (\x -> p 1 >> print x) (serially $ repeatM (p 1)) ```  ## Serial and Concurrent Merging@@ -222,7 +219,7 @@ ### Serial  ``` haskell-main = runStream $ delay 3 <> delay 2 <> delay 1+main = S.drain $ delay 3 <> delay 2 <> delay 1 ``` ``` ThreadId 36: Delay 3@@ -233,7 +230,7 @@ ### Parallel  ``` haskell-main = runStream . parallely $ delay 3 <> delay 2 <> delay 1+main = S.drain . parallely $ delay 3 <> delay 2 <> delay 1 ``` ``` ThreadId 42: Delay 1@@ -254,7 +251,7 @@     y <- S.fromFoldable [3,4]     S.yieldM $ putStrLn $ show (x, y) -main = runStream loops+main = S.drain loops ``` ``` (1,3)@@ -265,43 +262,18 @@  ## Concurrent Nested Loops -To run the above code with, lookahead style concurrency i.e. each iteration in-the loop can run run concurrently by but the results are presented in the same-order as serial execution:--``` haskell-main = runStream $ aheadly $ loops-```--To run it with depth first concurrency yielding results asynchronously in the-same order as they become available (deep async composition):--``` haskell-main = runStream $ asyncly $ loops-```--To run it with breadth first concurrency and yeilding results asynchronously-(wide async composition):--``` haskell-main = runStream $ wAsyncly $ loops-```--The above streams provide lazy/demand-driven concurrency which is automatically-scaled as per demand and is controlled/bounded so that it can be used on-infinite streams. The following combinator provides strict, unbounded-concurrency irrespective of demand:+To run the above code with speculative concurrency i.e. each iteration in the+loop can run concurrently but the results are presented to the consumer of the+output in the same order as serial execution:  ``` haskell-main = runStream $ parallely $ loops+main = S.drain $ aheadly $ loops ``` -To run it serially but interleaving the outer and inner loop iterations-(breadth first serial):--``` haskell-main = runStream $ wSerially $ loops-```+Different stream types execute the loop iterations in different ways. For+example, `wSerially` interleaves the loop iterations. There are several+concurrent stream styles to execute the loop iterations concurrently in+different ways, see the `Streamly.Tutorial` module for a detailed treatment.  ## Magical Concurrency @@ -329,6 +301,34 @@ [Cilk](https://en.wikipedia.org/wiki/Cilk) but with a more declarative expression. +## Example: Listing Directories Recursively/Concurrently++The following code snippet lists a directory tree recursively, reading multiple+directories concurrently:++```haskell+import Control.Monad.IO.Class (liftIO)+import Path.IO (listDir, getCurrentDir) -- from path-io package+import Streamly (AsyncT, adapt)+import qualified Streamly.Prelude as S++listDirRecursive :: AsyncT IO ()+listDirRecursive = getCurrentDir >>= readdir >>= liftIO . mapM_ putStrLn+  where+    readdir dir = do+      (dirs, files) <- listDir dir+      S.yield (map show dirs ++ map show files) <> foldMap readdir dirs++main :: IO ()+main = S.drain $ adapt $ listDirRecursive+```++`AsyncT` is a stream monad transformer. If you are familiar with a list+transformer, it is nothing but `ListT` with concurrency semantics. For example,+the semigroup operation `<>` is concurrent. This makes `foldMap` concurrent+too. You can replace `AsyncT` with `SerialT` and the above code will become+serial, exactly equivalent to a `ListT`.+ ## Rate Limiting  For bounded concurrent streams, stream yield rate can be specified. For@@ -338,7 +338,7 @@ import Streamly import Streamly.Prelude as S -main = runStream $ asyncly $ avgRate 1 $ S.repeatM $ putStrLn "hello"+main = S.drain $ asyncly $ avgRate 1 $ S.repeatM $ putStrLn "hello" ```  For some practical uses of rate control, see@@ -351,22 +351,162 @@ yields per second. For more sophisticated rate control see the haddock documentation. +## Arrays++The `Streamly.Memory.Array` module provides immutable arrays.  Arrays are the+computing duals of streams. Streams are good at sequential access and immutable+transformations of in-transit data whereas arrays are good at random access and+in-place transformations of buffered data. Unlike streams which are potentially+infinite, arrays are necessarily finite. Arrays can be used as an efficient+interface between streams and external storage systems like memory, files and+network. Streams and arrays complete each other to provide a general purpose+computing system. The design of streamly as a general purpose computing+framework is centered around these two fundamental aspects of computing and+storage.++`Streamly.Memory.Array` uses pinned memory outside GC and therefore avoid any+GC overhead for the storage in arrays. Streamly allows efficient+transformations over arrays using streams. It uses arrays to transfer data to+and from the operating system and to store data in memory.++## Folds++Folds are consumers of streams.  `Streamly.Data.Fold` module provides a `Fold`+type that represents a `foldl'`.  Such folds can be efficiently composed+allowing the compiler to perform stream fusion and therefore implement high+performance combinators for consuming streams. A stream can be distributed to+multiple folds, or it can be partitioned across multiple folds, or+demultiplexed over multiple folds, or unzipped to two folds. We can also use+folds to fold segments of stream generating a stream of the folded results.++If you are familiar with the `foldl` library, these are the same composable+left folds but simpler and better integrated with streamly, and with many more+powerful ways of composing and applying them.++## Unfolds++Unfolds are duals of folds. Folds help us compose consumers of streams+efficiently and unfolds help us compose producers of streams efficiently.+`Streamly.Data.Unfold` provides an `Unfold` type that represents an `unfoldr`+or a stream generator. Such generators can be combined together efficiently+allowing the compiler to perform stream fusion and implement high performance+stream merging combinators.++## File IO++The following code snippets implement some common Unix command line utilities+using streamly.  You can compile these with `ghc -O2 -fspec-constr-recursive=16+-fmax-worker-args=16` and compare the performance with regular GNU coreutils+available on your system.  Though many of these are not most optimal solutions+to keep them short and elegant. Source file+[HandleIO.hs](https://github.com/composewell/streamly/tree/master/examples/HandleIO.hs)+in the examples directory includes these examples.++``` haskell+module Main where++import qualified Streamly.Prelude as S+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 Data.Char (ord)+import System.Environment (getArgs)+import System.IO (openFile, IOMode(..), stdout)++withArg f = do+    (name : _) <- getArgs+    src <- openFile name ReadMode+    f src++withArg2 f = do+    (sname : dname : _) <- getArgs+    src <- openFile sname ReadMode+    dst <- openFile dname WriteMode+    f src dst+```++### cat++``` haskell+cat = S.fold (FH.writeChunks stdout) . S.unfold FH.readChunks+main = withArg cat+```++### cp++``` haskell+cp src dst = S.fold (FH.writeChunks dst) $ S.unfold FH.readChunks src+main = withArg2 cp+```++### wc -l++``` haskell+wcl = S.length . S.splitOn (== 10) FL.drain . S.unfold FH.read+main = withArg wcl >>= print+```++### Average Line Length++``` haskell+avgll =+      S.fold avg+    . S.splitOn (== 10) FL.length+    . S.unfold FH.read++    where avg      = (/) <$> toDouble FL.sum <*> toDouble FL.length+          toDouble = fmap (fromIntegral :: Int -> Double)++main = withArg avgll >>= print+```++### Line Length Histogram++`classify` is not released yet, and is available in+`Streamly.Internal.Data.Fold`++``` haskell+llhisto =+      S.fold (FL.classify FL.length)+    . S.map bucket+    . S.splitOn (== 10) FL.length+    . S.unfold FH.read++    where+    bucket n = let i = n `mod` 10 in if i > 9 then (9,n) else (i,n)++main = withArg llhisto >>= print+```++## Socket IO++Its easy to build concurrent client and server programs using streamly.+`Streamly.Network.*` modules provide easy combinators to build network servers+and client programs using streamly. See+[FromFileClient.hs](https://github.com/composewell/streamly/tree/master/examples/FromFileClient.hs),+[EchoServer.hs](https://github.com/composewell/streamly/tree/master/examples/EchoServer.hs),+[FileSinkServer.hs](https://github.com/composewell/streamly/tree/master/examples/FileSinkServer.hs)+in the examples directory.+ ## Exceptions -From a library user point of view, there is nothing much to learn or talk about-exceptions.  Synchronous exceptions work just the way they are supposed to work-in any standard 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. Exceptions can be thrown-using the `MonadThrow` instance.+Exceptions can be thrown at any point using the `MonadThrow` instance. Standard+exception handling combinators like `bracket`, `finally`, `handle`,+`onException` are provided in `Streamly.Prelude` module. +In presence of concurrency, synchronous exceptions work just the way they are+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. + There is no notion of explicit threads in streamly, therefore, no asynchronous exceptions to deal with. You can just ignore the zillions of blogs, talks, caveats about async exceptions. Async exceptions just don't exist.  Please don't use things like `myThreadId` and `throwTo` just for fun! - ## Reactive Programming (FRP)  Streamly is a foundation for first class reactive programming as well by virtue@@ -435,26 +575,41 @@    * [Detailed tutorial](https://hackage.haskell.org/package/streamly/docs/Streamly-Tutorial.html)   * [Reference documentation](https://hackage.haskell.org/package/streamly)-  * [Examples](https://github.com/composewell/streamly/tree/master/examples)-  * [Guides](https://github.com/composewell/streamly/blob/master/docs)+  * [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 +Please feel free to ask questions on the+[streamly gitter channel](https://gitter.im/composewell/streamly). If you require professional support, consulting, training or timely enhancements to the library please contact [support@composewell.com](mailto:support@composewell.com). +## Credits++The following authors/libraries have influenced or inspired this library in a+significant way:++  * Roman Leshchinskiy (vector)+  * Gabriel Gonzalez (foldl)+  * Alberto G. Corona (transient)++See the `credits` directory for full list of contributors, credits and licenses.+ ## Contributing  The code is available under BSD-3 license-[on github](https://github.com/composewell/streamly). Join the-[gitter chat](https://gitter.im/composewell/streamly) channel for discussions.-You can find some of the-[todo items on the github wiki](https://github.com/composewell/streamly/wiki/Things-To-Do).-Please ask on the gitter channel or [contact the maintainer directly](mailto:harendra.kumar@gmail.com)-for more details on each item. All contributions are welcome!--This library was originally inspired by the `transient` package authored by-Alberto G. Corona.+[on github](https://github.com/composewell/streamly). Join the [gitter+chat](https://gitter.im/composewell/streamly) channel for discussions.  Please+ask any questions on the gitter channel or [contact the maintainer+directly](mailto:streamly@composewell.com). All contributions are welcome!
bench.sh view
@@ -2,7 +2,7 @@  print_help () {   echo "Usage: $0 "-  echo "       [--benchmarks <all|linear|linear-async|linear-rate|nested|base>]"+  echo "       [--benchmarks <all|linear|linear-async|linear-rate|nested|concurrent|fileio|array|base>]"   echo "       [--group-diff]"   echo "       [--graphs]"   echo "       [--no-measure]"@@ -46,7 +46,7 @@ find_report_prog() {     local prog_name="chart"     hash -r-    local prog_path=$($STACK exec which $prog_name)+    local prog_path=$($WHICH_COMMAND $prog_name)     if test -x "$prog_path"     then       echo $prog_path@@ -58,14 +58,14 @@ # $1: benchmark name (linear, nested, base) build_report_prog() {     local prog_name="chart"-    local prog_path=$($STACK exec which $prog_name)+    local prog_path=$($WHICH_COMMAND $prog_name)      hash -r     if test ! -x "$prog_path" -a "$BUILD_ONCE" = "0"     then       echo "Building bench-graph executables"       BUILD_ONCE=1-      $STACK build --flag "streamly:dev" || die "build failed"+      $BUILD_CHART_EXE || die "build failed"     elif test ! -x "$prog_path"     then       return 1@@ -93,9 +93,9 @@ # Use this command to find the exe if this script fails with an error: # find .stack-work/ -type f -name "benchmarks" -find_bench_prog () {+stack_bench_prog () {   local bench_name=$1-  local bench_prog=`$STACK path --dist-dir`/build/$bench_name/$bench_name+  local bench_prog=`stack path --dist-dir`/build/$bench_name/$bench_name   if test -x "$bench_prog"   then     echo $bench_prog@@ -104,6 +104,17 @@   fi } +cabal_bench_prog () {+  local bench_name=$1+  local bench_prog=`$WHICH_COMMAND $1`+  if test -x "$bench_prog"+  then+    echo $bench_prog+  else+    return 1+  fi+}+ bench_output_file() {     local bench_name=$1     echo "charts/$bench_name/results.csv"@@ -126,7 +137,7 @@   local bench_name=$1   local output_file=$(bench_output_file $bench_name)   local bench_prog-  bench_prog=$(find_bench_prog $bench_name) || \+  bench_prog=$($GET_BENCH_PROG $bench_name) || \     die "Cannot find benchmark executable for benchmark $bench_name"    mkdir -p `dirname $output_file`@@ -162,14 +173,14 @@     echo "Checking out base commit [$BASE] for benchmarking"     git checkout "$BASE" || die "Checkout of base commit [$BASE] failed" -    $STACK build $STACK_BUILD_FLAGS --bench --no-run-benchmarks || die "build failed"+    $BUILD_BENCH || die "build failed"     run_benches "$bench_list"      echo "Checking out candidate commit [$CANDIDATE] for benchmarking"     git checkout "$CANDIDATE" || \         die "Checkout of candidate [$CANDIDATE] commit failed" -    $STACK build $STACK_BUILD_FLAGS --bench --no-run-benchmarks || die "build failed"+    $BUILD_BENCH || die "build failed"     run_benches "$bench_list"     # XXX reset back to the original commit }@@ -220,7 +231,7 @@ #-----------------------------------------------------------------------------  DEFAULT_BENCHMARKS="linear"-ALL_BENCHMARKS="linear linear-async linear-rate nested base"+ALL_BENCHMARKS="linear linear-async linear-rate nested concurrrent fileio array base" GROUP_DIFF=0  COMPARE=0@@ -233,11 +244,16 @@ MEASURE=1 SPEED_OPTIONS="--quick --min-samples 10 --time-limit 1 --min-duration 0" -STACK=stack GAUGE_ARGS=- BUILD_ONCE=0+USE_STACK=0 +GHC_VERSION=$(ghc --numeric-version)++cabal_which() {+  find dist-newstyle -type f -path "*${GHC_VERSION}*/$1"+}+ #----------------------------------------------------------------------------- # Read command line #-----------------------------------------------------------------------------@@ -271,8 +287,30 @@ if echo "$BENCHMARKS" | grep -q base then   STACK_BUILD_FLAGS="--flag streamly:dev"+  CABAL_BUILD_FLAGS="--flags dev" fi +if echo "$BENCHMARKS" | grep -q concurrent+then+  STACK_BUILD_FLAGS="--flag streamly:dev"+  CABAL_BUILD_FLAGS="--flags dev"+fi++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"+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"+fi+ #----------------------------------------------------------------------------- # Build stuff #-----------------------------------------------------------------------------@@ -287,7 +325,8 @@  if test "$MEASURE" = "1" then-  $STACK build $STACK_BUILD_FLAGS --bench --no-run-benchmarks || die "build failed"+  echo $BUILD_BENCH+  $BUILD_BENCH || die "build failed"   run_measurements "$BENCHMARKS" fi
benchmark/Adaptive.hs view
@@ -3,7 +3,7 @@ -- Copyright   : (c) 2018 Harendra Kumar -- -- License     : BSD3--- Maintainer  : harendra.kumar@gmail.com+-- Maintainer  : streamly@composewell.com  import Control.Concurrent (threadDelay) import Control.Monad (when)@@ -32,7 +32,7 @@  {-# INLINE run #-} run :: IsStream t => (Int, Int) -> (Int, Int) -> (t IO Int -> SerialT IO Int) -> IO ()-run srange crange t = runStream $ do+run srange crange t = S.drain $ do     n <- t $ source srange     d <- liftIO (randomRIO crange)     when (d /= 0) $ liftIO $ threadDelay d
+ benchmark/Array.hs view
@@ -0,0 +1,251 @@+{-# LANGUAGE CPP #-}+-- |+-- Module      : Main+-- Copyright   : (c) 2018 Harendra Kumar+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com++import Control.DeepSeq (NFData(..), deepseq)+import Foreign.Storable (Storable(..))+import System.Random (randomRIO)++import qualified GHC.Exts as GHC++import qualified ArrayOps as Ops+import qualified Streamly.Internal.Memory.Array as IA+import qualified Streamly.Memory.Array as A+import qualified Streamly.Prelude as S++import Gauge++-------------------------------------------------------------------------------+--+-------------------------------------------------------------------------------++{-# INLINE benchPure #-}+benchPure :: NFData b => String -> (Int -> a) -> (a -> b) -> Benchmark+benchPure name src f = bench name $ nfIO $+    randomRIO (1,1) >>= return . f . src++-- Drain a source that generates a pure array+{-# INLINE benchPureSrc #-}+benchPureSrc :: (NFData a, Storable a)+    => String -> (Int -> Ops.Stream a) -> Benchmark+benchPureSrc name src = benchPure name src id++{-# 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, Storable 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 "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 "eqBy" Ops.eqBy+        , benchPureSink "==" Ops.eqInstance+        , benchPureSink "/=" Ops.eqInstanceNotEq+        {-+        , benchPureSink "cmpBy" Ops.cmpBy+        -}+        , 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 . IA.toStreamRev)+#ifdef DEVBUILD+        , benchPureSink "foldable/foldl'" Ops.foldableFoldl'+        , benchPureSink "foldable/sum" Ops.foldableSum+        -- , benchPureSinkIO "traversable/mapM" Ops.traversableMapM+#endif+        ]++        {-+        [ benchPureSink "uncons" Ops.uncons+        , benchPureSink "toNull" $ Ops.toNull serially+        , benchPureSink "mapM_" Ops.mapM_++        , benchPureSink "init" Ops.init+        , benchPureSink "tail" Ops.tail+        , benchPureSink "nullHeadTail" Ops.nullHeadTail++        -- this is too low and causes all benchmarks reported in ns+        -- , benchPureSink "head" Ops.head+        , benchPureSink "last" Ops.last+        -- , benchPureSink "lookup" Ops.lookup+        , benchPureSink "find" Ops.find+        , benchPureSink "findIndex" Ops.findIndex+        , benchPureSink "elemIndex" Ops.elemIndex++        -- this is too low and causes all benchmarks reported in ns+        -- , benchPureSink "null" Ops.null+        , benchPureSink "elem" Ops.elem+        , benchPureSink "notElem" Ops.notElem+        , benchPureSink "all" Ops.all+        , benchPureSink "any" Ops.any+        , benchPureSink "and" Ops.and+        , benchPureSink "or" Ops.or++        , benchPureSink "length" Ops.length+        , benchPureSink "sum" Ops.sum+        , benchPureSink "product" Ops.product++        , benchPureSink "maximumBy" Ops.maximumBy+        , benchPureSink "maximum" Ops.maximum+        , benchPureSink "minimumBy" Ops.minimumBy+        , benchPureSink "minimum" Ops.minimum++        , benchPureSink "toList" Ops.toList+        , benchPureSink "toRevList" Ops.toRevList+        ]+        -}+      , bgroup "transformation"+        [ benchIOSink "scanl'" (Ops.scanl' 1)+        , benchIOSink "scanl1'" (Ops.scanl1' 1)+        , benchIOSink "map" (Ops.map 1)+        {-+        , benchPureSink "fmap" (Ops.fmap 1)+        , benchPureSink "mapM" (Ops.mapM serially 1)+        , benchPureSink "mapMaybe" (Ops.mapMaybe 1)+        , benchPureSink "mapMaybeM" (Ops.mapMaybeM 1)+        , bench "sequence" $ nfIO $ randomRIO (1,1000) >>= \n ->+            Ops.sequence serially (Ops.sourceUnfoldrMAction n)+        , benchPureSink "findIndices" (Ops.findIndices 1)+        , benchPureSink "elemIndices" (Ops.elemIndices 1)+        , benchPureSink "reverse" (Ops.reverse 1)+        , benchPureSink "foldrS" (Ops.foldrS 1)+        , benchPureSink "foldrSMap" (Ops.foldrSMap 1)+        , benchPureSink "foldrT" (Ops.foldrT 1)+        , benchPureSink "foldrTMap" (Ops.foldrTMap 1)+        -}+        ]+      , bgroup "transformationX4"+        [ benchIOSink "scanl'" (Ops.scanl' 4)+        , benchIOSink "scanl1'" (Ops.scanl1' 4)+        , benchIOSink "map" (Ops.map 4)+        {-+        , benchPureSink "fmap" (Ops.fmap 4)+        , benchPureSink "mapM" (Ops.mapM serially 4)+        , benchPureSink "mapMaybe" (Ops.mapMaybe 4)+        , benchPureSink "mapMaybeM" (Ops.mapMaybeM 4)+        -- , bench "sequence" $ nfIO $ randomRIO (1,1000) >>= \n ->+            -- Ops.sequence serially (Ops.sourceUnfoldrMAction n)+        , benchPureSink "findIndices" (Ops.findIndices 4)+        , benchPureSink "elemIndices" (Ops.elemIndices 4)+        -}+        ]+        {-+      , bgroup "filtering"+        [ benchPureSink "filter-even"     (Ops.filterEven 1)+        , benchPureSink "filter-all-out"  (Ops.filterAllOut 1)+        , benchPureSink "filter-all-in"   (Ops.filterAllIn 1)+        , benchPureSink "take-all"        (Ops.takeAll 1)+        , benchPureSink "takeWhile-true"  (Ops.takeWhileTrue 1)+        --, benchPureSink "takeWhileM-true" (Ops.takeWhileMTrue 1)+        , benchPureSink "drop-one"        (Ops.dropOne 1)+        , benchPureSink "drop-all"        (Ops.dropAll 1)+        , benchPureSink "dropWhile-true"  (Ops.dropWhileTrue 1)+        --, benchPureSink "dropWhileM-true" (Ops.dropWhileMTrue 1)+        , benchPureSink "dropWhile-false" (Ops.dropWhileFalse 1)+        , benchPureSink "deleteBy" (Ops.deleteBy 1)+        , benchPureSink "insertBy" (Ops.insertBy 1)+        ]+      , bgroup "filteringX4"+        [ benchPureSink "filter-even"     (Ops.filterEven 4)+        , benchPureSink "filter-all-out"  (Ops.filterAllOut 4)+        , benchPureSink "filter-all-in"   (Ops.filterAllIn 4)+        , benchPureSink "take-all"        (Ops.takeAll 4)+        , benchPureSink "takeWhile-true"  (Ops.takeWhileTrue 4)+        --, benchPureSink "takeWhileM-true" (Ops.takeWhileMTrue 4)+        , benchPureSink "drop-one"        (Ops.dropOne 4)+        , benchPureSink "drop-all"        (Ops.dropAll 4)+        , benchPureSink "dropWhile-true"  (Ops.dropWhileTrue 4)+        --, benchPureSink "dropWhileM-true" (Ops.dropWhileMTrue 4)+        , benchPureSink "dropWhile-false" (Ops.dropWhileFalse 4)+        , benchPureSink "deleteBy" (Ops.deleteBy 4)+        , benchPureSink "insertBy" (Ops.insertBy 4)+        ]+      , bgroup "multi-stream"+        [ benchPureSink "eqBy" Ops.eqBy+        , benchPureSink "cmpBy" Ops.cmpBy+        , benchPureSink "zip" Ops.zip+        , benchPureSink "zipM" Ops.zipM+        , benchPureSink "mergeBy" Ops.mergeBy+        , benchPureSink "isPrefixOf" Ops.isPrefixOf+        , benchPureSink "isSubsequenceOf" Ops.isSubsequenceOf+        , benchPureSink "stripPrefix" Ops.stripPrefix+        , benchPureSrc  serially "concatMap" Ops.concatMap+        ]+    -- 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"+      [ benchPureSink "scanl-map" (Ops.scanMap 1)+      , benchPureSink "foldl-map" Ops.foldl'ReduceMap+      , benchPureSink "sum-product-fold"  Ops.sumProductFold+      , benchPureSink "sum-product-scan"  Ops.sumProductScan+      ]+    , bgroup "mixedX4"+      [ benchPureSink "scan-map"    (Ops.scanMap 4)+      , benchPureSink "drop-map"    (Ops.dropMap 4)+      , benchPureSink "drop-scan"   (Ops.dropScan 4)+      , benchPureSink "take-drop"   (Ops.takeDrop 4)+      , benchPureSink "take-scan"   (Ops.takeScan 4)+      , benchPureSink "take-map"    (Ops.takeMap 4)+      , benchPureSink "filter-drop" (Ops.filterDrop 4)+      , benchPureSink "filter-take" (Ops.filterTake 4)+      , benchPureSink "filter-scan" (Ops.filterScan 4)+      , benchPureSink "filter-scanl1" (Ops.filterScanl1 4)+      , benchPureSink "filter-map"  (Ops.filterMap 4)+      ]+    , bgroup "iterated"+      [ benchPureSrc serially "mapM"           Ops.iterateMapM+      , benchPureSrc serially "scan(1/100)"    Ops.iterateScan+      , benchPureSrc serially "scanl1(1/100)"  Ops.iterateScanl1+      , benchPureSrc serially "filterEven"     Ops.iterateFilterEven+      , benchPureSrc serially "takeAll"        Ops.iterateTakeAll+      , benchPureSrc serially "dropOne"        Ops.iterateDropOne+      , benchPureSrc serially "dropWhileFalse" Ops.iterateDropWhileFalse+      , benchPureSrc serially "dropWhileTrue"  Ops.iterateDropWhileTrue+      ]+      -}+    ]+    ]
+ benchmark/ArrayOps.hs view
@@ -0,0 +1,531 @@+-- |+-- Module      : ArrayOps+-- Copyright   : (c) 2018 Harendra Kumar+--+-- License     : MIT+-- Maintainer  : streamly@composewell.com++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}++module ArrayOps where++-- import Control.Monad (when)+import Control.Monad.IO.Class (MonadIO)+-- import Data.Maybe (fromJust)+import Prelude (Int, Bool, (+), ($), (==), (>), (.), Maybe(..), undefined)+import qualified Prelude as P+#ifdef DEVBUILD+import qualified Data.Foldable as F+#endif+import qualified GHC.Exts as GHC+-- import Control.DeepSeq (NFData)+-- import GHC.Generics (Generic)++import qualified Streamly           as S hiding (foldMapWith, runStream)+import qualified Streamly.Memory.Array as A+import qualified Streamly.Prelude   as S++value, maxValue :: Int+#ifdef LINEAR_ASYNC+value = 10000+#else+value = 100000+#endif+maxValue = value + 1++-------------------------------------------------------------------------------+-- 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)++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')++{-+-------------------------------------------------------------------------------+-- Elimination+-------------------------------------------------------------------------------++{-# INLINE runStream #-}+runStream :: Monad m => Stream m a -> m ()+runStream = S.runStream++{-# 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, 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.runStream++{-# 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 toRevList #-}+toRevList :: Monad m => Stream m Int -> m [Int]+toRevList = S.toRevList++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 :: Stream a -> Stream a+transform = P.id+-}++{-# 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 #-}+{-+{-# 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 foldrS #-}+{-# INLINE foldrSMap #-}+{-# INLINE foldrT #-}+{-# INLINE foldrTMap #-}+    -}+scanl' , scanl1', map{-, fmap, mapMaybe, filterEven, filterAllOut,+    filterAllIn, takeOne, takeAll, takeWhileTrue, takeWhileMTrue, dropOne,+    dropAll, dropWhileTrue, dropWhileMTrue, dropWhileFalse,+    findIndices, elemIndices, insertBy, deleteBy, reverse,+    foldrS, foldrSMap, foldrT, foldrTMap -}+    :: MonadIO m => Int -> Stream Int -> m (Stream Int)++{-+{-# INLINE mapMaybeM #-}+mapMaybeM :: 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 ()+    -}++{-# 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)+-- map           n = composeN n $ A.map (+1)+{-+fmap          n = composeN n $ Prelude.fmap (+1)+fmap' t       n = composeN' n $ t . Prelude.fmap (+1)+map' t        n = composeN' n $ t . S.map (+1)+mapM t        n = composeN' n $ t . S.mapM return+mapMaybe      n = composeN n $ S.mapMaybe+    (\x -> if Prelude.odd x then Nothing else Just x)+mapMaybeM     n = composeN n $ S.mapMaybeM+    (\x -> if Prelude.odd x then return Nothing else return $ Just x)+sequence t    = transform . t . S.sequence+filterEven    n = composeN n $ S.filter even+filterAllOut  n = composeN n $ S.filter (> maxValue)+filterAllIn   n = composeN n $ S.filter (<= maxValue)+takeOne       n = composeN n $ S.take 1+takeAll       n = composeN n $ S.take maxValue+takeWhileTrue n = composeN n $ S.takeWhile (<= maxValue)+takeWhileMTrue n = composeN n $ S.takeWhileM (return . (<= maxValue))+dropOne        n = composeN n $ S.drop 1+dropAll        n = composeN n $ S.drop maxValue+dropWhileTrue  n = composeN n $ S.dropWhile (<= maxValue)+dropWhileMTrue n = composeN n $ S.dropWhileM (return . (<= maxValue))+dropWhileFalse n = composeN n $ S.dropWhile (> maxValue)+findIndices    n = composeN n $ S.findIndices (== maxValue)+elemIndices    n = composeN n $ S.elemIndices maxValue+insertBy       n = composeN n $ S.insertBy compare maxValue+deleteBy       n = composeN n $ S.deleteBy (>=) maxValue+reverse        n = composeN n $ S.reverse+foldrS         n = composeN n $ S.foldrS S.cons S.nil+foldrSMap      n = composeN n $ S.foldrS (\x xs -> x + 1 `S.cons` xs) S.nil+foldrT         n = composeN n $ S.foldrT S.cons S.nil+foldrTMap      n = composeN n $ S.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 #-}+{-# INLINE zipM #-}+{-# INLINE mergeBy #-}+zip, zipM, mergeBy :: Monad m => Stream m Int -> m ()++zip src       = do+    r <- S.tail src+    let src1 = fromJust r+    transform (S.zipWith (,) src src1)+zipM src      =  do+    r <- S.tail src+    let src1 = fromJust r+    transform (S.zipWithM (curry return) src src1)++mergeBy src     =  do+    r <- S.tail src+    let src1 = fromJust r+    transform (S.mergeBy P.compare src src1)++{-# INLINE isPrefixOf #-}+{-# INLINE isSubsequenceOf #-}+isPrefixOf, isSubsequenceOf :: Monad m => Stream m Int -> m Bool++isPrefixOf src = S.isPrefixOf src src+isSubsequenceOf src = S.isSubsequenceOf src src++{-# INLINE stripPrefix #-}+stripPrefix :: Monad m => Stream m Int -> m ()+stripPrefix src = do+    _ <- S.stripPrefix src src+    return ()++{-# INLINE zipAsync #-}+{-# INLINE zipAsyncM #-}+{-# INLINE zipAsyncAp #-}+zipAsync, zipAsyncAp, zipAsyncM :: S.MonadAsync m => Stream m Int -> m ()++zipAsync src  = do+    r <- S.tail src+    let src1 = fromJust r+    transform (S.zipAsyncWith (,) src src1)++zipAsyncM src = do+    r <- S.tail src+    let src1 = fromJust r+    transform (S.zipAsyncWithM (curry return) src src1)++zipAsyncAp src  = do+    r <- S.tail src+    let src1 = fromJust r+    transform (S.zipAsyncly $ (,) <$> S.serially src+                                  <*> S.serially src1)++{-# INLINE eqBy #-}+eqBy :: (Monad m, P.Eq a) => Stream m a -> m P.Bool+eqBy src = S.eqBy (==) src src++{-# INLINE cmpBy #-}+cmpBy :: (Monad m, P.Ord a) => Stream m a -> m P.Ordering+cmpBy src = S.cmpBy P.compare src src++concatStreamLen, maxNested :: Int+concatStreamLen = 1+maxNested = 100000++{-# INLINE concatMap #-}+concatMap :: S.MonadAsync m => Int -> Stream m Int+concatMap n = S.concatMap (\_ -> sourceUnfoldrMN maxNested n)+                          (sourceUnfoldrMN concatStreamLen n)++-------------------------------------------------------------------------------+-- 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+    :: Monad m => Int -> Stream m Int -> m ()++scanMap    n = composeN n $ S.map (subtract 1) . S.scanl' (+) 0+dropMap    n = composeN n $ S.map (subtract 1) . S.drop 1+dropScan   n = composeN n $ S.scanl' (+) 0 . S.drop 1+takeDrop   n = composeN n $ S.drop 1 . S.take maxValue+takeScan   n = composeN n $ S.scanl' (+) 0 . S.take maxValue+takeMap    n = composeN n $ S.map (subtract 1) . S.take maxValue+filterDrop n = composeN n $ S.drop 1 . S.filter (<= maxValue)+filterTake n = composeN n $ S.take maxValue . S.filter (<= maxValue)+filterScan n = composeN n $ S.scanl' (+) 0 . S.filter (<= maxBound)+filterScanl1 n = composeN n $ S.scanl1' (+) . S.filter (<= maxBound)+filterMap  n = composeN n $ S.map (subtract 1) . S.filter (<= maxValue)++data Pair a b = Pair !a !b deriving (Generic, NFData)++{-# INLINE sumProductFold #-}+sumProductFold :: Monad m => Stream m Int -> m (Int, Int)+sumProductFold = S.foldl' (\(s,p) x -> (s + x, p P.* x)) (0,1)++{-# INLINE sumProductScan #-}+sumProductScan :: Monad m => Stream m Int -> m (Pair Int Int)+sumProductScan = S.foldl' (\(Pair _  p) (s0,x) -> Pair s0 (p P.* x)) (Pair 0 1)+    . S.scanl' (\(s,_) x -> (s + x,x)) (0,0)++-------------------------------------------------------------------------------+-- Pure stream operations+-------------------------------------------------------------------------------++-}+{-# 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++{-+{-# INLINE traversableMapM #-}+traversableMapM :: Stream Identity Int -> IO (Stream Identity Int)+traversableMapM = P.mapM return+-}
benchmark/BaseStreams.hs view
@@ -3,7 +3,7 @@ -- Copyright   : (c) 2018 Harendra Kumar -- -- License     : BSD3--- Maintainer  : harendra.kumar@gmail.com+-- Maintainer  : streamly@composewell.com  {-# LANGUAGE CPP                       #-} @@ -14,6 +14,8 @@ import Gauge import qualified StreamDOps as D import qualified StreamKOps as K+import qualified StreamDKOps as DK+import qualified Data.List as List  -- 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.@@ -21,6 +23,20 @@ benchIO :: String -> (a IO Int -> IO ()) -> (Int -> a IO Int) -> Benchmark benchIO name run f = bench name $ nfIO $ randomRIO (1,1) >>= run . f +{-# INLINE _benchIOSrcK #-}+_benchIOSrcK+    :: String+    -> (Int -> K.Stream IO Int)+    -> Benchmark+_benchIOSrcK name f = bench name $ nfIO $ randomRIO (1,1) >>= K.toNull . f++{-# INLINE _benchIOSrcD #-}+_benchIOSrcD+    :: String+    -> (Int -> D.Stream IO Int)+    -> Benchmark+_benchIOSrcD name f = bench name $ nfIO $ randomRIO (1,1) >>= D.toNull . f+ benchFold :: NFData b     => String -> (t IO Int -> IO b) -> (Int -> t IO Int) -> Benchmark benchFold name f src = bench name $ nfIO $ randomRIO (1,1) >>= f . src@@ -39,6 +55,10 @@ _benchId name f = bench name $ nf (runIdentity . f) (Ops.source 10) -} +{-# INLINE benchPure #-}+benchPure :: String -> ([Int] -> [Int]) -> (Int -> [Int]) -> Benchmark+benchPure name run f = bench name $ nfIO $ randomRIO (1,1) >>= return . run . f+ main :: IO () main =   defaultMain@@ -52,15 +72,28 @@         -- , benchIO "fromFoldableM" D.sourceFromFoldableM         ]       , bgroup "elimination"-        [ benchIO "toNull"   D.toNull D.sourceUnfoldrM-        , benchIO "uncons"   D.uncons D.sourceUnfoldrM-        , benchFold "tail"   D.tail   D.sourceUnfoldrM+        [ benchIO "toNull"   D.toNull   D.sourceUnfoldrM+        , benchIO "mapM_"    D.mapM_    D.sourceUnfoldrM+        , benchIO "uncons"   D.uncons   D.sourceUnfoldrM+        , benchFold "tail"   D.tail     D.sourceUnfoldrM         , benchIO "nullTail" D.nullTail D.sourceUnfoldrM         , benchIO "headTail" D.headTail D.sourceUnfoldrM-        , benchFold "toList" K.toList K.sourceUnfoldrM-        , benchFold "fold"   K.foldl  K.sourceUnfoldrM-        , benchFold "last"   K.last   K.sourceUnfoldrM+        , benchFold "toList" D.toList   D.sourceUnfoldrM+        , benchFold "foldl'" D.foldl    D.sourceUnfoldrM+        , benchFold "last"   D.last     D.sourceUnfoldrM         ]+      , bgroup "nested"+        [ benchIO "toNullAp" D.toNullApNested (D.sourceUnfoldrMN D.value2)+        , benchIO "toNull"   D.toNullNested   (D.sourceUnfoldrMN D.value2)+        , benchIO "toNull3"  D.toNullNested3  (D.sourceUnfoldrMN D.value3)+        , benchIO "filterAllIn"  D.filterAllInNested  (D.sourceUnfoldrMN K.value2)+        , benchIO "filterAllOut"  D.filterAllOutNested  (D.sourceUnfoldrMN K.value2)+        , benchIO "toNullApPure" D.toNullApNested (D.sourceUnfoldrN K.value2)+        , benchIO "toNullPure"   D.toNullNested   (D.sourceUnfoldrN K.value2)+        , benchIO "toNull3Pure"  D.toNullNested3  (D.sourceUnfoldrN K.value3)+        , benchIO "filterAllInPure"  D.filterAllInNested  (D.sourceUnfoldrN K.value2)+        , benchIO "filterAllOutPure"  D.filterAllOutNested  (D.sourceUnfoldrN K.value2)+        ]       , bgroup "transformation"         [ benchIO "scan"      (D.scan      1) D.sourceUnfoldrM         , benchIO "map"       (D.map       1) D.sourceUnfoldrM@@ -68,6 +101,17 @@         , benchIO "mapM"      (D.mapM      1) D.sourceUnfoldrM         , benchIO "mapMaybe"  (D.mapMaybe  1) D.sourceUnfoldrM         , benchIO "mapMaybeM" (D.mapMaybeM 1) D.sourceUnfoldrM+        , benchIO "concatMapNxN" (D.concatMap 1) (D.sourceUnfoldrMN D.value2)+        , benchIO "concatMapRepl4xN" D.concatMapRepl4xN+            (D.sourceUnfoldrMN (D.value `div` 4))+        , benchIO "concatMapPureNxN" (D.concatMap 1) (D.sourceUnfoldrN D.value2)+        , benchIO "concatMapURepl4xN" D.concatMapURepl4xN+            (D.sourceUnfoldrMN (D.value `div` 4))+        , benchIO "intersperse" (D.intersperse 1) (D.sourceUnfoldrMN D.value2)+        , benchIO "interspersePure" (D.intersperse 1) (D.sourceUnfoldrN D.value2)+        -- , benchIO "foldrS"    (D.foldrS    1) D.sourceUnfoldrM+        -- This has horrible performance, never finishes+        -- , benchIO "foldlS"    (D.foldlS    1) D.sourceUnfoldrM         ]       , bgroup "transformationX4"         [ benchIO "scan"      (D.scan      4) D.sourceUnfoldrM@@ -76,6 +120,8 @@         , benchIO "mapM"      (D.mapM      4) D.sourceUnfoldrM         , benchIO "mapMaybe"  (D.mapMaybe  4) D.sourceUnfoldrM         , benchIO "mapMaybeM" (D.mapMaybeM 4) D.sourceUnfoldrM+        -- , benchIO "concatMap" (D.concatMap 4) (D.sourceUnfoldrMN D.value16)+        , benchIO "intersperse" (D.intersperse 4) (D.sourceUnfoldrMN D.value16)         ]       , bgroup "filtering"         [ benchIO "filter-even"     (D.filterEven     1) D.sourceUnfoldrM@@ -150,6 +196,18 @@         , benchD "dropWhileTrue"        D.iterateDropWhileTrue         ]       ]+    , bgroup "list"+      [ bgroup "elimination"+        [ benchPure "last" (\xs -> [List.last xs]) (K.sourceUnfoldrList K.value)+        ]+      , bgroup "nested"+        [ benchPure "toNullAp" K.toNullApNestedList (K.sourceUnfoldrList K.value2)+        , benchPure "toNull"   K.toNullNestedList (K.sourceUnfoldrList K.value2)+        , benchPure "toNull3"  K.toNullNestedList3 (K.sourceUnfoldrList K.value3)+        , benchPure "filterAllIn"  K.filterAllInNestedList (K.sourceUnfoldrList K.value2)+        , benchPure "filterAllOut"  K.filterAllOutNestedList (K.sourceUnfoldrList K.value2)+        ]+      ]     , bgroup "streamK"       [ bgroup "generation"         [ benchIO "unfoldr"       K.toNull K.sourceUnfoldr@@ -164,30 +222,52 @@         , benchIO "foldMapWithM" K.toNull K.sourceFoldMapWithM         ]       , bgroup "elimination"-        [ benchIO "toNull" K.toNull K.sourceUnfoldrM-        , benchIO "mapM_" K.mapM_ K.sourceUnfoldrM-        , benchIO "uncons" K.uncons K.sourceUnfoldrM-        , benchFold "init" K.init   K.sourceUnfoldrM-        , benchFold "tail" K.tail   K.sourceUnfoldrM+        [ benchIO "toNull"   K.toNull   K.sourceUnfoldrM+        , benchIO "mapM_"    K.mapM_    K.sourceUnfoldrM+        , benchIO "uncons"   K.uncons   K.sourceUnfoldrM+        , benchFold "init"   K.init     K.sourceUnfoldrM+        , benchFold "tail"   K.tail     K.sourceUnfoldrM         , benchIO "nullTail" K.nullTail K.sourceUnfoldrM         , benchIO "headTail" K.headTail K.sourceUnfoldrM-        , benchFold "toList" K.toList K.sourceUnfoldrM-        , benchFold "fold"   K.foldl  K.sourceUnfoldrM-        , benchFold "last"   K.last   K.sourceUnfoldrM+        , benchFold "toList" K.toList   K.sourceUnfoldrM+        , benchFold "foldl'" K.foldl    K.sourceUnfoldrM+        , benchFold "last"   K.last     K.sourceUnfoldrM         ]+      , bgroup "nested"+        [ benchIO "toNullAp" K.toNullApNested (K.sourceUnfoldrMN K.value2)+        , benchIO "toNull"   K.toNullNested   (K.sourceUnfoldrMN K.value2)+        , benchIO "toNull3"  K.toNullNested3  (K.sourceUnfoldrMN K.value3)+        , benchIO "filterAllIn"  K.filterAllInNested  (K.sourceUnfoldrMN K.value2)+        , benchIO "filterAllOut" K.filterAllOutNested (K.sourceUnfoldrMN K.value2)+        , benchIO "toNullApPure" K.toNullApNested (K.sourceUnfoldrN K.value2)+        , benchIO "toNullPure"   K.toNullNested   (K.sourceUnfoldrN K.value2)+        , benchIO "toNull3Pure"  K.toNullNested3  (K.sourceUnfoldrN K.value3)+        , benchIO "filterAllInPure"  K.filterAllInNested  (K.sourceUnfoldrN K.value2)+        , benchIO "filterAllOutPure" K.filterAllOutNested (K.sourceUnfoldrN K.value2)+        ]       , bgroup "transformation"         [ benchIO "scan"   (K.scan 1) K.sourceUnfoldrM         , benchIO "map"    (K.map  1) K.sourceUnfoldrM         , benchIO "fmap"   (K.fmap 1) K.sourceUnfoldrM         , benchIO "mapM"   (K.mapM 1) K.sourceUnfoldrM-        -- , benchIO "concat" K.concat K.sourceUnfoldrM+        , benchIO "mapMSerial"  (K.mapMSerial 1) K.sourceUnfoldrM+        -- , benchIOSrcK "concatMap" K.concatMap+        , benchIO "concatMapNxN" (K.concatMap 1) (K.sourceUnfoldrMN K.value2)+        , benchIO "concatMapPureNxN" (K.concatMap 1) (K.sourceUnfoldrN K.value2)+        , benchIO "concatMapRepl4xN" K.concatMapRepl4xN+            (K.sourceUnfoldrMN (K.value `div` 4))+        , benchIO "intersperse" (K.intersperse 1) (K.sourceUnfoldrMN K.value2)+        , benchIO "interspersePure" (K.intersperse 1) (K.sourceUnfoldrN K.value2)+        , benchIO "foldlS" (K.foldlS 1) K.sourceUnfoldrM         ]       , bgroup "transformationX4"         [ benchIO "scan"   (K.scan 4) K.sourceUnfoldrM         , benchIO "map"    (K.map  4) K.sourceUnfoldrM         , benchIO "fmap"   (K.fmap 4) K.sourceUnfoldrM         , benchIO "mapM"   (K.mapM 4) K.sourceUnfoldrM-        -- , benchIO "concat" K.concat K.sourceUnfoldrM+        , benchIO "mapMSerial" (K.mapMSerial 4) K.sourceUnfoldrM+        -- , benchIO "concatMap" (K.concatMap 4) (K.sourceUnfoldrMN K.value16)+        , benchIO "intersperse" (K.intersperse 4) (K.sourceUnfoldrMN K.value16)         ]       , bgroup "filtering"         [ benchIO "filter-even"     (K.filterEven     1) K.sourceUnfoldrM@@ -258,6 +338,16 @@         , benchK "dropOne"              K.iterateDropOne         , benchK "dropWhileFalse(1/10)" K.iterateDropWhileFalse         , benchK "dropWhileTrue"        K.iterateDropWhileTrue+        ]+      ]+    , bgroup "streamDK"+      [ bgroup "generation"+        [ benchIO "unfoldr"       DK.toNull DK.sourceUnfoldr+        , benchIO "unfoldrM"      DK.toNull DK.sourceUnfoldrM+        ]+      , bgroup "elimination"+        [ benchIO "toNull"   DK.toNull   DK.sourceUnfoldrM+        , benchIO "uncons"   DK.uncons   DK.sourceUnfoldrM         ]       ]     ]
benchmark/Chart.hs view
@@ -22,7 +22,15 @@ -- Command line parsing ------------------------------------------------------------------------------ -data BenchType = Linear | LinearAsync | LinearRate | Nested | Base+data BenchType+    = Linear+    | LinearAsync+    | LinearRate+    | Nested+    | Base+    | FileIO+    | Array+    | Concurrent     deriving Show  data Options = Options@@ -62,6 +70,9 @@         Just "linear-rate" -> setBenchType LinearRate         Just "nested" -> setBenchType Nested         Just "base" -> setBenchType Base+        Just "fileio" -> setBenchType FileIO+        Just "array" -> setBenchType Array+        Just "concurrent" -> setBenchType Concurrent         Just str -> do                 liftIO $ putStrLn $ "unrecognized benchmark type " <> str                 mzero@@ -225,6 +236,22 @@     return ()  ------------------------------------------------------------------------------+-- FileIO+------------------------------------------------------------------------------++makeFileIOGraphs :: Config -> String -> IO ()+makeFileIOGraphs cfg@Config{..} inputFile =+    ignoringErr $ graph inputFile "fileIO" cfg++makeArrayGraphs :: Config -> String -> IO ()+makeArrayGraphs cfg@Config{..} inputFile =+    ignoringErr $ graph inputFile "array" cfg++makeConcurrentGraphs :: Config -> String -> IO ()+makeConcurrentGraphs cfg@Config{..} inputFile =+    ignoringErr $ graph inputFile "concurrent" cfg++------------------------------------------------------------------------------ -- Reports/Charts for base streams ------------------------------------------------------------------------------ @@ -274,14 +301,16 @@ -- text reports ------------------------------------------------------------------------------ -selectBench :: (SortColumn -> Either String [(String, Double)]) -> [String]+selectBench+    :: (SortColumn -> Maybe GroupStyle -> Either String [(String, Double)])+    -> [String] selectBench f =     reverse     $ fmap fst     $ either-      (const $ either error (sortOn snd) $ f $ ColumnIndex 0)+      (const $ either error (sortOn snd) $ f (ColumnIndex 0) (Just PercentDiff))       (sortOn snd)-      $ f $ ColumnIndex 1+      $ f (ColumnIndex 1) (Just PercentDiff)  benchShow Options{..} cfg func inp out =     if genGraphs@@ -320,6 +349,21 @@                             makeNestedGraphs                             "charts/nested/results.csv"                             "charts/nested"+                FileIO -> benchShow opts cfg+                            { title = Just "File IO" }+                            makeFileIOGraphs+                            "charts/fileio/results.csv"+                            "charts/fileio"+                Array -> benchShow opts cfg+                            { title = Just "Array" }+                            makeArrayGraphs+                            "charts/array/results.csv"+                            "charts/array"+                Concurrent -> benchShow opts cfg+                            { title = Just "Concurrent Ops" }+                            makeConcurrentGraphs+                            "charts/concurrent/results.csv"+                            "charts/concurrent"                 Base -> do                     let cfg' = cfg { title = Just "100,000 elems" }                     if groupDiff
+ benchmark/Concurrent.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE RankNTypes #-}+-- |+-- Module      : Main+-- Copyright   : (c) 2018 Harendra Kumar+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com++import Control.Concurrent+import Control.Monad (when)+-- import Data.IORef++import Gauge+import Streamly+import qualified Streamly.Prelude as S++-------------------------------------------------------------------------------+-- Append+-------------------------------------------------------------------------------++-- Single work item yielded per thread+{-# INLINE append #-}+append :: IsStream t+    => Int -> Int -> Int -> (t IO Int -> SerialT IO Int) -> IO ()+append buflen tcount d t =+    let work = (\i -> when (d /= 0) (threadDelay d) >> return i)+    in S.drain+        $ t+        $ maxBuffer buflen+        $ maxThreads (-1)+        $ S.fromFoldableM $ map work [1..tcount]++-- Big stream of items yielded per thread+{-# INLINE concated #-}+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)))+    in S.drain+        $ adapt+        $ maxThreads (-1)+        $ maxBuffer buflen+        $ S.concatMapWith t work+        $ S.replicate threads elems++appendGroup :: Int -> Int -> Int -> [Benchmark]+appendGroup buflen threads delay =+    [ -- bench "serial"   $ nfIO $ append buflen threads delay serially+      bench "ahead"    $ nfIO $ append buflen threads delay aheadly+    , bench "async"    $ nfIO $ append buflen threads delay asyncly+    , bench "wAsync"   $ nfIO $ append buflen threads delay wAsyncly+    , bench "parallel" $ nfIO $ append buflen threads delay parallely+    ]++concatGroup :: Int -> Int -> Int -> Int -> [Benchmark]+concatGroup buflen threads delay n =+    [ bench "serial"   $ nfIO $ concated buflen threads delay n serial+    , bench "ahead"    $ nfIO $ concated buflen threads delay n ahead+    , bench "async"    $ nfIO $ concated buflen threads delay n async+    , bench "wAsync"   $ nfIO $ concated buflen threads delay n wAsync+    , bench "parallel" $ nfIO $ concated buflen threads delay n parallel+    ]++main :: IO ()+main = do+  defaultMainWith (defaultConfig+    { timeLimit = Just 0+    , minSamples = Just 1+    , minDuration = 0+    , includeFirstIter = True+    , quickMode = True+    })++    [ -- 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 "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+    ]+    -}+   ]
+ benchmark/FileIO.hs view
@@ -0,0 +1,317 @@+-- |+-- Module      : Main+-- Copyright   : (c) 2019 Harendra Kumar+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com++{-# LANGUAGE CPP #-}++import Control.DeepSeq (NFData)+import System.IO (openFile, IOMode(..), Handle, hClose)+import System.Process.Typed (shell, runProcess_)++import Data.IORef+import Gauge++import qualified Streamly.Benchmark.FileIO.Stream as BFS+import qualified Streamly.Benchmark.FileIO.Array as BFA++-- Input and output file handles+data Handles = Handles Handle Handle++scratchDir :: String+scratchDir = "benchmark/scratch/"++outfile :: String+outfile = scratchDir ++ "out.txt"++blockSize, blockCount :: Int+blockSize = 32768+blockCount = 3200++#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+-- conditional (enabled by "dev" cabal flag). Some tests that depend on+-- this file are available only in DEVBUILD mode.+infile :: String+infile = "benchmark/text-processing/gutenberg-500.txt"++fileSize :: Int+fileSize = blockSize * blockCount++#else+infile :: String+infile = scratchDir ++ "in-100MB.txt"+#endif++main :: IO ()+main = do+#ifndef DEVBUILD+    -- XXX will this work on windows/msys?+    let cmd = "mkdir -p " ++ scratchDir+                ++ "; test -e " ++ infile+                ++ " || { echo \"creating input file " ++ infile+                ++ "\" && dd if=/dev/random of=" ++ infile+                ++ " bs=" ++ show blockSize+                ++ " count=" ++ show blockCount+                ++ ";}"++    runProcess_ (shell cmd)+#endif+    inHandle <- openFile infile ReadMode+    outHandle <- openFile outfile WriteMode+    href <- newIORef $ Handles inHandle outHandle+    devNull <- openFile "/dev/null" WriteMode++    defaultMain+        [ bgroup "readArray"+            [ mkBench "last" href $ do+                Handles inh _ <- readIORef href+                BFA.last inh+            -- Note: this cannot be fairly compared with GNU wc -c or wc -m as+            -- wc uses lseek to just determine the file size rather than reading+            -- and counting characters.+            , mkBench "length (bytecount)" href $ do+                Handles inh _ <- readIORef href+                BFA.countBytes inh+            , mkBench "linecount" href $ do+                Handles inh _ <- readIORef href+                BFA.countLines inh+            , mkBench "wordcount" href $ do+                Handles inh _ <- readIORef href+                BFA.countWords inh+            , mkBench "sum" href $ do+                Handles inh _ <- readIORef href+                BFA.sumBytes inh+            , mkBench "cat" href $ do+                Handles inh _ <- readIORef href+                BFA.cat devNull inh+           , mkBench "catBracket" href $ do+               Handles inh _ <- readIORef href+               BFA.catBracket devNull inh+           , mkBench "catBracketStream" href $ do+               Handles inh _ <- readIORef href+               BFA.catBracketStream devNull inh+           , mkBench "catOnException" href $ do+               Handles inh _ <- readIORef href+               BFA.catOnException devNull inh+           , mkBench "read-utf8" href $ do+               Handles inh _ <- readIORef href+               BFA.decodeUtf8Lenient inh+            ]+        , bgroup "readStream"+            [ mkBench "last" href $ do+                Handles inh _ <- readIORef href+                BFS.last inh+            , mkBench "length (bytecount)" href $ do+                Handles inh _ <- readIORef href+                BFS.countBytes inh+            , mkBench "linecount" href $ do+                Handles inh _ <- readIORef href+                BFS.countLines inh+            , mkBench "linecountU" href $ do+                Handles inh _ <- readIORef href+                BFS.countLinesU inh+            , mkBench "wordcount" href $ do+                Handles inh _ <- readIORef href+                BFS.countWords inh+            , mkBench "sum" href $ do+                Handles inh _ <- readIORef href+                BFS.sumBytes inh+            , mkBench "cat" href $ do+                Handles inh _ <- readIORef href+                BFS.cat devNull inh+            , mkBench "catStream" href $ do+                Handles inh _ <- readIORef href+                BFS.catStreamWrite devNull inh+#ifdef DEVBUILD+           , mkBench "catOnException" href $ do+               Handles inh _ <- readIORef href+               BFS.catOnException devNull inh+           , mkBench "catOnExceptionStream" href $ do+               Handles inh _ <- readIORef href+               BFS.catOnExceptionStream devNull inh+           , mkBench "catHandle" href $ do+               Handles inh _ <- readIORef href+               BFS.catHandle devNull inh+           , mkBench "catHandleStream" href $ do+               Handles inh _ <- readIORef href+               BFS.catHandleStream devNull inh+           , mkBench "catFinally" href $ do+               Handles inh _ <- readIORef href+               BFS.catFinally devNull inh+           , mkBench "catFinallyStream" href $ do+               Handles inh _ <- readIORef href+               BFS.catFinallyStream devNull inh+           , mkBench "catBracketStream" href $ do+               Handles inh _ <- readIORef href+               BFS.catBracketStream devNull inh+           , mkBench "catBracket" href $ do+               Handles inh _ <- readIORef href+               BFS.catBracket devNull inh+#endif+           , mkBench "read-word8" href $ do+               Handles inh _ <- readIORef href+               BFS.readWord8 inh+           , mkBench "read-latin1" href $ do+               Handles inh _ <- readIORef href+               BFS.decodeLatin1 inh+           , mkBench "read-utf8" href $ do+               Handles inh _ <- readIORef href+               BFS.decodeUtf8Lax inh+            ]+        , bgroup "copyArray"+            [ mkBench "copy" href $ do+                Handles inh outh <- readIORef href+                BFA.copy inh outh+            ]+#ifdef DEVBUILD+        -- This takes a little longer therefore put under the dev conditional+        , bgroup "copyStream"+            [ mkBench "fromToHandle" href $ do+                Handles inh outh <- readIORef href+                BFS.copy inh outh+            ]+        -- This needs an ascii file, as decode just errors out.+        , bgroup "decode-encode"+           [ mkBench "latin1" href $ do+               Handles inh outh <- readIORef href+               BFS.copyCodecChar8 inh outh+           , mkBench "utf8-arrays" href $ do+               Handles inh outh <- readIORef href+               BFA.copyCodecUtf8Lenient inh outh+           , mkBench "utf8" href $ do+               Handles inh outh <- readIORef href+               BFS.copyCodecUtf8Lenient inh outh+           ]+        , bgroup "grouping"+            [ mkBench "chunksOf (single chunk)" href $ do+                Handles inh _ <- readIORef href+                BFS.chunksOf fileSize inh++            , mkBench "chunksOf 1" href $ do+                Handles inh _ <- readIORef href+                BFS.chunksOf 1 inh+            , mkBench "chunksOf 10" href $ do+                Handles inh _ <- readIORef href+                BFS.chunksOf 10 inh+            , mkBench "chunksOf 1000" href $ do+                Handles inh _ <- readIORef href+                BFS.chunksOf 1000 inh+            ]+        , bgroup "group-ungroup-stream"+            [ mkBench "lines-unlines-[Char]" href $ do+                Handles inh outh <- readIORef href+                BFS.linesUnlinesCopy inh outh+            , mkBench "lines-unlines-Word8Array" href $ do+                Handles inh outh <- readIORef href+                BFS.linesUnlinesArrayWord8Copy inh outh+            , mkBench "lines-unlines-CharArray" href $ do+                Handles inh outh <- readIORef href+                BFS.linesUnlinesArrayCharCopy inh outh+            , mkBench "words-unwords-[Word8]" href $ do+                Handles inh outh <- readIORef href+                BFS.wordsUnwordsCopyWord8 inh outh+            , mkBench "words-unwords-[Char]" href $ do+                Handles inh outh <- readIORef href+                BFS.wordsUnwordsCopy inh outh+            , mkBench "words-unwords-CharArray" href $ do+                Handles inh outh <- readIORef href+                BFS.wordsUnwordsCharArrayCopy inh outh+            ]++        , bgroup "group-ungroup-array-stream"+            [ mkBench "lines-unlines-Word8Array" href $ do+                Handles inh outh <- readIORef href+                BFA.linesUnlinesCopy inh outh+            , mkBench "words-unwords-Word8Array" href $ do+                Handles inh outh <- readIORef href+                BFA.wordsUnwordsCopy inh outh+            ]++        , bgroup "splitting"+            [ bgroup "predicate"+                [ mkBench "splitOn \\n (line count)" href $ do+                    Handles inh _ <- readIORef href+                    BFS.splitOn inh+                , mkBench "splitOnSuffix \\n (line count)" href $ do+                    Handles inh _ <- readIORef href+                    BFS.splitOnSuffix inh+                , mkBench "wordsBy isSpace (word count)" href $ do+                    Handles inh _ <- readIORef href+                    BFS.wordsBy inh+                ]++            , bgroup "empty-pattern"+                [ mkBench "splitOnSeq \"\"" href $ do+                    Handles inh _ <- readIORef href+                    BFS.splitOnSeq "" inh+                , mkBench "splitOnSuffixSeq \"\"" href $ do+                    Handles inh _ <- readIORef href+                    BFS.splitOnSuffixSeq "" inh+                ]+            , bgroup "short-pattern"+                [ mkBench "splitOnSeq \\n (line count)" href $ do+                    Handles inh _ <- readIORef href+                    BFS.splitOnSeq "\n" inh+                , mkBench "splitOnSuffixSeq \\n (line count)" href $ do+                    Handles inh _ <- readIORef href+                    BFS.splitOnSuffixSeq "\n" inh+                , mkBench "splitOnSeq a" href $ do+                    Handles inh _ <- readIORef href+                    BFS.splitOnSeq "a" inh+                , mkBench "splitOnSeq \\r\\n" href $ do+                    Handles inh _ <- readIORef href+                    BFS.splitOnSeq "\r\n" inh+                , mkBench "splitOnSuffixSeq \\r\\n)" href $ do+                    Handles inh _ <- readIORef href+                    BFS.splitOnSuffixSeq "\r\n" inh+                , mkBench "splitOnSeq aa" href $ do+                    Handles inh _ <- readIORef href+                    BFS.splitOnSeq "aa" inh+                , mkBench "splitOnSeq aaaa" href $ do+                    Handles inh _ <- readIORef href+                    BFS.splitOnSeq "aaaa" inh+                , mkBench "splitOnSeq abcdefgh" href $ do+                    Handles inh _ <- readIORef href+                    BFS.splitOnSeq "abcdefgh" inh+                , mkBench "splitOnSeqUtf8 abcdefgh" href $ do+                    Handles inh _ <- readIORef href+                    BFS.splitOnSeqUtf8 "abcdefgh" inh+                ]+            , bgroup "long-pattern"+                [ mkBench "splitOnSeq abcdefghi" href $ do+                    Handles inh _ <- readIORef href+                    BFS.splitOnSeq "abcdefghi" inh+                , mkBench "splitOnSeq catcatcatcatcat" href $ do+                    Handles inh _ <- readIORef href+                    BFS.splitOnSeq "catcatcatcatcat" inh+                , mkBench "splitOnSeq abc...xyz" href $ do+                    Handles inh _ <- readIORef href+                    BFS.splitOnSeq "abcdefghijklmnopqrstuvwxyz" inh+                , mkBench "splitOnSuffixSeq abc...xyz" href $ do+                    Handles inh _ <- readIORef href+                    BFS.splitOnSuffixSeq "abcdefghijklmnopqrstuvwxyz" inh+                , mkBench "splitOnSeqUtf8 abc...xyz" href $ do+                    Handles inh _ <- readIORef href+                    BFS.splitOnSeqUtf8 "abcdefghijklmnopqrstuvwxyz" inh+                ]+            ]+#endif+        ]++    where++    mkBench :: NFData b => String -> IORef Handles -> IO b -> Benchmark+    mkBench name ref action =+        bench name $ perRunEnv (do+                (Handles inh outh) <- readIORef ref+                hClose inh+                hClose outh+                inHandle <- openFile infile ReadMode+                outHandle <- openFile outfile WriteMode+                writeIORef ref (Handles inHandle outHandle)+            )+            (\_ -> action)
benchmark/Linear.hs view
@@ -1,21 +1,43 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 800+{-# OPTIONS_GHC -Wno-orphans #-}+#endif+ -- | -- Module      : Main -- Copyright   : (c) 2018 Harendra Kumar -- -- License     : BSD3--- Maintainer  : harendra.kumar@gmail.com+-- Maintainer  : streamly@composewell.com -import Control.DeepSeq (NFData)+import Control.DeepSeq (NFData(..), deepseq) import Data.Functor.Identity (Identity, runIdentity) import System.Random (randomRIO)+import Data.Monoid (Last(..))  import qualified GHC.Exts as GHC-import qualified LinearOps as Ops+import qualified Streamly.Benchmark.Prelude as Ops  import Streamly+import qualified Streamly.Data.Fold as FL+import qualified Streamly.Memory.Array as A import qualified Streamly.Prelude as S+import qualified Streamly.Internal.Data.Sink as Sink++import qualified Streamly.Internal.Data.Fold as IFL+import qualified Streamly.Internal.Prelude as IP+import qualified Streamly.Internal.Data.Pipe as Pipe+ import Gauge +-------------------------------------------------------------------------------+--+-------------------------------------------------------------------------------++#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. @@ -26,6 +48,19 @@     => String -> (t IO Int -> IO b) -> Benchmark benchIOSink name f = bench name $ nfIO $ randomRIO (1,1) >>= f . Ops.source +{-# 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++-- XXX once we convert all the functions to use this we can rename this to+-- benchIOSink+{-# INLINE benchIOSink1 #-}+benchIOSink1 :: NFData b => String -> (Int -> IO b) -> Benchmark+benchIOSink1 name f = bench name $ nfIO $ randomRIO (1,1) >>= f+ -- XXX We should be using sourceUnfoldrM for fair comparison with IO monad, but -- we can't use it as it requires MonadAsync constraint. {-# INLINE benchIdentitySink #-}@@ -44,6 +79,10 @@ benchIOSrc t name f =     bench name $ nfIO $ randomRIO (1,1) >>= Ops.toNull t . f +{-# INLINE benchIOSrc1 #-}+benchIOSrc1 :: String -> (Int -> IO ()) -> Benchmark+benchIOSrc1 name f = bench name $ nfIO $ randomRIO (1,1) >>= f+ {-# INLINE benchPure #-} benchPure :: NFData b => String -> (Int -> a) -> (a -> b) -> Benchmark benchPure name src f = bench name $ nfIO $ randomRIO (1,1) >>= return . f . src@@ -52,6 +91,13 @@ benchPureSink :: NFData b => String -> (SerialT Identity Int -> b) -> Benchmark benchPureSink name f = benchPure name Ops.sourceUnfoldr f +-- XXX once we convert all the functions to use this we can rename this to+-- benchPureSink+{-# INLINE benchPureSink1 #-}+benchPureSink1 :: NFData b => String -> (Int -> Identity b) -> Benchmark+benchPureSink1 name f =+    bench name $ nfIO $ randomRIO (1,1) >>= return . runIdentity . f+ {-# INLINE benchPureSinkIO #-} benchPureSinkIO     :: NFData b@@ -61,28 +107,40 @@  {-# INLINE benchPureSrc #-} benchPureSrc :: String -> (Int -> SerialT Identity a) -> Benchmark-benchPureSrc name src = benchPure name src (runIdentity . runStream)+benchPureSrc name src = benchPure name src (runIdentity . S.drain) +mkString :: String+mkString = "fromList [1" ++ concat (replicate Ops.value ",1") ++ "]"++mkListString :: String+mkListString = "[1" ++ concat (replicate Ops.value ",1") ++ "]"++mkList :: [Int]+mkList = [1..Ops.value]+ main :: IO () main =   defaultMain     [ bgroup "serially"       [ bgroup "pure"         [ benchPureSink "id" id-        , benchPureSink "eqBy" Ops.eqBy+        , benchPureSink1 "eqBy" Ops.eqByPure         , benchPureSink "==" Ops.eqInstance         , benchPureSink "/=" Ops.eqInstanceNotEq-        , benchPureSink "cmpBy" Ops.cmpBy+        , benchPureSink1 "cmpBy" Ops.cmpByPure         , benchPureSink "<" Ops.ordInstance         , benchPureSink "min" Ops.ordInstanceMin         , benchPureSrc "IsList.fromList" Ops.sourceIsList-        , benchPureSink "IsList.toList" GHC.toList+        -- length is used to check for foldr/build fusion+        , benchPureSink "length . IsList.toList" (length . GHC.toList)         , benchPureSrc "IsString.fromString" Ops.sourceIsString-        , benchPure "readsPrec" (\n -> S.fromList [1..n :: Int])-                    Ops.readInstance-        , benchPureSink "showsPrec" Ops.showInstance-        , benchPure "showsPrecList" (\n -> S.fromList [1..n :: Int])-                    Ops.showInstanceList+        , 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@@ -102,31 +160,17 @@         -- These are essentially cons and consM         , benchIOSrc serially "fromFoldable" Ops.sourceFromFoldable         , benchIOSrc serially "fromFoldableM" Ops.sourceFromFoldableM-        -- These are essentially appends-        , benchIOSrc serially "foldMapWith" Ops.sourceFoldMapWith-        , benchIOSrc serially "foldMapWithM" Ops.sourceFoldMapWithM-        , benchIOSrc serially "foldMapM" Ops.sourceFoldMapM         ]       , bgroup "elimination"-        [ benchIOSink "toNull" $ Ops.toNull serially-        , benchIOSink "uncons" Ops.uncons-        , benchIOSink "init" Ops.init-        , benchIOSink "tail" Ops.tail-        , benchIOSink "nullHeadTail" Ops.nullHeadTail-        , benchIOSink "mapM_" Ops.mapM_-        , benchIOSink "toList" Ops.toList--        , bgroup "reduce"+        [ bgroup "reduce"           [ bgroup "IO"-            [ benchIOSink "foldr" Ops.foldrReduce-            , benchIOSink "foldr1" Ops.foldr1Reduce+            [ benchIOSink "foldrM" Ops.foldrMReduce             , benchIOSink "foldl'" Ops.foldl'Reduce             , benchIOSink "foldl1'" Ops.foldl1'Reduce             , benchIOSink "foldlM'" Ops.foldlM'Reduce             ]           , bgroup "Identity"-            [ benchIdentitySink "foldr" Ops.foldrReduce-            , benchIdentitySink "foldr1" Ops.foldr1Reduce+            [ benchIdentitySink "foldrM" Ops.foldrMReduce             , benchIdentitySink "foldl'" Ops.foldl'Reduce             , benchIdentitySink "foldl1'" Ops.foldl1'Reduce             , benchIdentitySink "foldlM'" Ops.foldlM'Reduce@@ -135,39 +179,129 @@          , bgroup "build"           [ bgroup "IO"-            [ benchIOSink "foldr" Ops.foldrBuild-            , benchIOSink "foldrM" Ops.foldrMBuild+            [ benchIOSink "foldrM" Ops.foldrMBuild             , benchIOSink "foldl'" Ops.foldl'Build             , benchIOSink "foldlM'" Ops.foldlM'Build             ]           , bgroup "Identity"-            [ benchIdentitySink "foldr" Ops.foldrBuild-            , benchIdentitySink "foldrM" Ops.foldrMBuild+            [ benchIdentitySink "foldrM" Ops.foldrMBuild             , benchIdentitySink "foldl'" Ops.foldl'Build             , benchIdentitySink "foldlM'" Ops.foldlM'Build             ]           ]+        , benchIOSink "uncons" Ops.uncons+        , benchIOSink "toNull" $ Ops.toNull serially+        , benchIOSink "mapM_" Ops.mapM_ +        , benchIOSink "init" Ops.init+        , benchIOSink "tail" Ops.tail+        , benchIOSink "nullHeadTail" Ops.nullHeadTail++        -- this is too low and causes all benchmarks reported in ns+        -- , benchIOSink "head" Ops.head         , benchIOSink "last" Ops.last-        , benchIOSink "length" Ops.length+        -- , benchIOSink "lookup" Ops.lookup+        , benchIOSink "find" Ops.find+        , benchIOSink "findIndex" Ops.findIndex+        , benchIOSink "elemIndex" Ops.elemIndex++        -- 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 "find" Ops.find-        , benchIOSink "findIndex" Ops.findIndex-        , benchIOSink "elemIndex" Ops.elemIndex-        , benchIOSink "maximum" Ops.maximum-        , benchIOSink "maximumBy" Ops.maximumBy-        , benchIOSink "minimum" Ops.minimum-        , benchIOSink "minimumBy" Ops.minimumBy++        , benchIOSink "length" Ops.length+        , benchHoistSink "length . generally" (Ops.length . IP.generally)         , benchIOSink "sum" Ops.sum         , benchIOSink "product" Ops.product++        , benchIOSink "maximumBy" Ops.maximumBy+        , benchIOSink "maximum" Ops.maximum+        , benchIOSink "minimumBy" Ops.minimumBy+        , benchIOSink "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 "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 "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 "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))+        ]+      , bgroup "fold-multi-stream"+        [ benchIOSink1 "eqBy" Ops.eqBy+        , benchIOSink1 "cmpBy" Ops.cmpBy+        , benchIOSink "isPrefixOf" Ops.isPrefixOf+        , benchIOSink "isSubsequenceOf" Ops.isSubsequenceOf+        , benchIOSink "stripPrefix" Ops.stripPrefix+        ]+      , bgroup "folds-transforms"+        [ benchIOSink "drain" (S.fold FL.drain)+        , benchIOSink "lmap" (S.fold (IFL.lmap (+1) FL.drain))+        , benchIOSink "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))+        ]+      , 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)+        ]+      , 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)+        ]+      , bgroup "transformer"+        [ benchIOSrc serially "evalState" Ops.evalStateT+        , benchIOSrc serially "withState" Ops.withState+        ]       , bgroup "transformation"-        [ benchIOSink "scan" (Ops.scan 1)+        [ benchIOSink "scanl" (Ops.scan 1)         , benchIOSink "scanl1'" (Ops.scanl1' 1)         , benchIOSink "map" (Ops.map 1)         , benchIOSink "fmap" (Ops.fmap 1)@@ -178,6 +312,12 @@             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)         ]       , bgroup "transformationX4"         [ benchIOSink "scan" (Ops.scan 4)@@ -205,6 +345,7 @@         --, 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)         ]       , bgroup "filteringX4"@@ -220,21 +361,59 @@         --, 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)         ]-      , bgroup "multi-stream"-        [ benchIOSink "eqBy" Ops.eqBy-        , benchIOSink "cmpBy" Ops.cmpBy-        , benchIOSink "zip" Ops.zip-        , benchIOSink "zipM" Ops.zipM-        , benchIOSink "mergeBy" Ops.mergeBy-        , benchIOSink "isPrefixOf" Ops.isPrefixOf-        , benchIOSink "isSubsequenceOf" Ops.isSubsequenceOf-        , benchIOSink "stripPrefix" Ops.stripPrefix-        , benchIOSrc  serially "concatMap" Ops.concatMap+      , bgroup "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         ]+      , 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+        ]+      , 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 "concatMapWithSerial (2x50K)"+            (Ops.concatMapWithSerial 2 50000)+        , benchIOSrc1 "concatMapWithSerial (50Kx2)"+            (Ops.concatMapWithSerial 50000 2)++        , benchIOSrc1 "concatMapWithAppend (2x50K)"+            (Ops.concatMapWithAppend 2 50000)+        ]+      , 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+        ]+    -- 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 "sum-product-fold"  Ops.sumProductFold+      [ benchIOSink "scanl-map" (Ops.scanMap 1)+      , benchIOSink "foldl-map" Ops.foldl'ReduceMap+      , benchIOSink "sum-product-fold"  Ops.sumProductFold       , benchIOSink "sum-product-scan"  Ops.sumProductScan       ]     , bgroup "mixedX4"
benchmark/LinearAsync.hs view
@@ -3,12 +3,12 @@ -- Copyright   : (c) 2018 Harendra Kumar -- -- License     : BSD3--- Maintainer  : harendra.kumar@gmail.com+-- Maintainer  : streamly@composewell.com  import Control.DeepSeq (NFData) -- import Data.Functor.Identity (Identity, runIdentity) import System.Random (randomRIO)-import qualified LinearOps as Ops+import qualified Streamly.Benchmark.Prelude as Ops  import Streamly import Gauge
− benchmark/LinearOps.hs 
@@ -1,587 +0,0 @@--- |--- Module      : BenchmarkOps--- Copyright   : (c) 2018 Harendra Kumar------ License     : MIT--- Maintainer  : harendra.kumar@gmail.com--{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}--module LinearOps where--import Control.Monad (when)-import Data.Functor.Identity (Identity, runIdentity)-import Data.Maybe (fromJust)-import Prelude-       (Monad, Int, (+), ($), (.), return, fmap, even, (>), (<=), (==), (>=),-        subtract, undefined, Maybe(..), odd, Bool, not, (>>=), mapM_, curry,-        maxBound, div, IO, compare, Double, fromIntegral, Integer, (<$>),-        (<*>), flip)-import qualified Prelude as P-import qualified Data.Foldable as F-import qualified GHC.Exts as GHC-import Control.DeepSeq (NFData)-import GHC.Generics (Generic)--import qualified Streamly          as S-import qualified Streamly.Prelude  as S--value, maxValue :: Int-#ifdef LINEAR_ASYNC-value = 10000-#else-value = 100000-#endif-maxValue = value + 1------------------------------------------------------------------------------------ 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 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 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 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 sourceUnfoldrMN #-}-sourceUnfoldrMN :: (S.IsStream t, S.MonadAsync m) => Int -> Int -> t m Int-sourceUnfoldrMN m n = S.unfoldrM step n-    where-    step cnt =-        if cnt > n + m-        then return Nothing-        else return (Just (cnt, cnt + 1))--{-# INLINE 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.runStream--{-# INLINE toList #-}-toList :: Monad m => Stream m Int -> m [Int]--{-# INLINE last #-}-{-# INLINE maximum #-}-{-# INLINE minimum #-}-{-# INLINE find #-}-{-# INLINE findIndex #-}-{-# INLINE elemIndex #-}-{-# INLINE foldl1'Reduce #-}-{-# INLINE foldr1Reduce #-}-last, minimum, maximum, find, findIndex, elemIndex, foldl1'Reduce, foldr1Reduce-    :: Monad m => Stream m Int -> m (Maybe Int)--{-# INLINE minimumBy #-}-{-# INLINE maximumBy #-}-minimumBy, maximumBy :: Monad m => Stream m Int -> m (Maybe Int)--{-# INLINE foldl'Reduce #-}-{-# INLINE foldlM'Reduce #-}-{-# INLINE foldrReduce #-}-{-# INLINE length #-}-{-# INLINE sum #-}-{-# INLINE product #-}-foldl'Reduce, foldlM'Reduce, foldrReduce, length, sum, product-    :: Monad m-    => Stream m Int -> m Int--{-# INLINE foldl'Build #-}-{-# INLINE foldlM'Build #-}-{-# INLINE foldrBuild #-}-{-# INLINE foldrMBuild #-}-foldrBuild, foldrMBuild, foldl'Build, foldlM'Build-    :: Monad m-    => Stream m Int -> m [Int]--{-# INLINE all #-}-{-# INLINE any #-}-{-# INLINE and #-}-{-# INLINE or #-}-{-# INLINE elem #-}-{-# INLINE notElem #-}-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.runStream--{-# 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--foldl'Build = S.foldl' (flip (:)) []-foldrBuild  = S.foldr (:) []-foldlM'Build = S.foldlM' (\xs x -> return $ x : xs) []-foldrMBuild  = S.foldrM  (\x xs -> return $ x : xs) []--foldrReduce = S.foldr (+) 0-foldr1Reduce = S.foldr1 (+)-foldl'Reduce = S.foldl' (+) 0-foldl1'Reduce = S.foldl1' (+)-foldlM'Reduce = S.foldlM' (\xs a -> return $ a + xs) 0--last   = S.last-elem   = S.elem maxValue-notElem = S.notElem maxValue-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-    :: Monad m-    => Int -> (Stream m Int -> Stream m Int) -> Stream m Int -> m ()-composeN n f =-    case n of-        1 -> transform . f-        2 -> transform . f . f-        3 -> transform . f . f . f-        4 -> transform . f . f . f . f-        _ -> undefined---- polymorphic stream version of composeN-{-# INLINE composeN' #-}-composeN'-    :: (S.IsStream t, Monad m)-    => Int -> (t m Int -> Stream m Int) -> t m Int -> m ()-composeN' n f =-    case n of-        1 -> transform . f-        2 -> transform . f . S.adapt . f-        3 -> transform . f . S.adapt . f . S.adapt . f-        4 -> transform . f . S.adapt . f . S.adapt . f . S.adapt . f-        _ -> undefined--{-# INLINE scan #-}-{-# INLINE 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 #-}-scan, scanl1', map, fmap, mapMaybe, filterEven, filterAllOut,-    filterAllIn, takeOne, takeAll, takeWhileTrue, takeWhileMTrue, dropOne,-    dropAll, dropWhileTrue, dropWhileMTrue, dropWhileFalse,-    findIndices, elemIndices, insertBy, deleteBy-    :: Monad m-    => Int -> Stream m Int -> m ()--{-# INLINE mapMaybeM #-}-mapMaybeM :: 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-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-insertBy       n = composeN n $ S.insertBy compare maxValue-deleteBy       n = composeN n $ S.deleteBy (>=) maxValue------------------------------------------------------------------------------------ Iteration----------------------------------------------------------------------------------iterStreamLen, maxIters :: Int-iterStreamLen = 10-maxIters = 10000--{-# INLINE iterateSource #-}-iterateSource-    :: S.MonadAsync m-    => (Stream m Int -> Stream m Int) -> Int -> Int -> Stream m Int-iterateSource g i n = f i (sourceUnfoldrMN iterStreamLen n)-    where-        f (0 :: Int) m = g m-        f x m = g (f (x P.- 1) m)--{-# INLINE iterateMapM #-}-{-# INLINE iterateScan #-}-{-# INLINE iterateScanl1 #-}-{-# INLINE iterateFilterEven #-}-{-# INLINE iterateTakeAll #-}-{-# INLINE iterateDropOne #-}-{-# INLINE iterateDropWhileFalse #-}-{-# INLINE iterateDropWhileTrue #-}-iterateMapM, iterateScan, iterateScanl1, iterateFilterEven, iterateTakeAll,-    iterateDropOne, iterateDropWhileFalse, iterateDropWhileTrue-    :: S.MonadAsync m-    => Int -> Stream m Int---- this is quadratic-iterateScan            = iterateSource (S.scanl' (+) 0) (maxIters `div` 10)--- so is this-iterateScanl1          = iterateSource (S.scanl1' (+)) (maxIters `div` 10)--iterateMapM            = iterateSource (S.mapM return) maxIters-iterateFilterEven      = iterateSource (S.filter even) maxIters-iterateTakeAll         = iterateSource (S.take maxValue) maxIters-iterateDropOne         = iterateSource (S.drop 1) maxIters-iterateDropWhileFalse  = iterateSource (S.dropWhile (> maxValue)) maxIters-iterateDropWhileTrue   = iterateSource (S.dropWhile (<= maxValue)) maxIters------------------------------------------------------------------------------------ Zipping and concat----------------------------------------------------------------------------------{-# INLINE zip #-}-{-# INLINE zipM #-}-{-# INLINE mergeBy #-}-zip, zipM, mergeBy :: Monad m => Stream m Int -> m ()--zip src       = do-    r <- S.tail src-    let src1 = fromJust r-    transform (S.zipWith (,) src src1)-zipM src      =  do-    r <- S.tail src-    let src1 = fromJust r-    transform (S.zipWithM (curry return) src src1)--mergeBy src     =  do-    r <- S.tail src-    let src1 = fromJust r-    transform (S.mergeBy P.compare src src1)--{-# INLINE isPrefixOf #-}-{-# INLINE isSubsequenceOf #-}-isPrefixOf, isSubsequenceOf :: Monad m => Stream m Int -> m Bool--isPrefixOf src = S.isPrefixOf src src-isSubsequenceOf src = S.isSubsequenceOf src src--{-# INLINE stripPrefix #-}-stripPrefix :: Monad m => Stream m Int -> m ()-stripPrefix src = do-    _ <- S.stripPrefix src src-    return ()--{-# INLINE zipAsync #-}-{-# INLINE zipAsyncM #-}-{-# INLINE zipAsyncAp #-}-zipAsync, zipAsyncAp, zipAsyncM :: S.MonadAsync m => Stream m Int -> m ()--zipAsync src  = do-    r <- S.tail src-    let src1 = fromJust r-    transform (S.zipAsyncWith (,) src src1)--zipAsyncM src = do-    r <- S.tail src-    let src1 = fromJust r-    transform (S.zipAsyncWithM (curry return) src src1)--zipAsyncAp src  = do-    r <- S.tail src-    let src1 = fromJust r-    transform (S.zipAsyncly $ (,) <$> S.serially src-                                  <*> S.serially src1)--{-# INLINE eqBy #-}-eqBy :: (Monad m, P.Eq a) => Stream m a -> m P.Bool-eqBy src = S.eqBy (==) src src--{-# INLINE cmpBy #-}-cmpBy :: (Monad m, P.Ord a) => Stream m a -> m P.Ordering-cmpBy src = S.cmpBy P.compare src src--concatStreamLen, maxNested :: Int-concatStreamLen = 1-maxNested = 100000--{-# INLINE concatMap #-}-concatMap :: S.MonadAsync m => Int -> Stream m Int-concatMap n = S.concatMap (\_ -> sourceUnfoldrMN maxNested n)-                          (sourceUnfoldrMN concatStreamLen n)------------------------------------------------------------------------------------ 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-    :: Monad m => Int -> Stream m Int -> m ()--scanMap    n = composeN n $ S.map (subtract 1) . S.scanl' (+) 0-dropMap    n = composeN n $ S.map (subtract 1) . S.drop 1-dropScan   n = composeN n $ S.scanl' (+) 0 . S.drop 1-takeDrop   n = composeN n $ S.drop 1 . S.take maxValue-takeScan   n = composeN n $ S.scanl' (+) 0 . S.take maxValue-takeMap    n = composeN n $ S.map (subtract 1) . S.take maxValue-filterDrop n = composeN n $ S.drop 1 . S.filter (<= maxValue)-filterTake n = composeN n $ S.take maxValue . S.filter (<= maxValue)-filterScan n = composeN n $ S.scanl' (+) 0 . S.filter (<= maxBound)-filterScanl1 n = composeN n $ S.scanl1' (+) . S.filter (<= maxBound)-filterMap  n = composeN n $ S.map (subtract 1) . S.filter (<= maxValue)--data Pair a b = Pair !a !b deriving (Generic, NFData)--{-# INLINE sumProductFold #-}-sumProductFold :: Monad m => Stream m Int -> m (Int, Int)-sumProductFold = S.foldl' (\(s,p) x -> (s + x, p P.* x)) (0,1)--{-# INLINE sumProductScan #-}-sumProductScan :: Monad m => Stream m Int -> m (Pair Int Int)-sumProductScan = S.foldl' (\(Pair _  p) (s0,x) -> Pair s0 (p P.* x)) (Pair 0 1)-    . S.scanl' (\(s,_) x -> (s + x,x)) (0,0)------------------------------------------------------------------------------------ Pure stream operations----------------------------------------------------------------------------------{-# INLINE eqInstance #-}-eqInstance :: Stream Identity Int -> Bool-eqInstance src = src == src--{-# INLINE eqInstanceNotEq #-}-eqInstanceNotEq :: Stream Identity Int -> Bool-eqInstanceNotEq src = src P./= src--{-# INLINE ordInstance #-}-ordInstance :: Stream Identity Int -> Bool-ordInstance src = src P.< src--{-# INLINE ordInstanceMin #-}-ordInstanceMin :: Stream Identity Int -> Stream Identity Int-ordInstanceMin src = P.min src src--{-# INLINE showInstance #-}-showInstance :: Stream Identity Int -> P.String-showInstance src = P.show src--{-# INLINE showInstanceList #-}-showInstanceList :: Stream Identity Int -> P.String-showInstanceList src = P.show (GHC.toList src P.++ [2..value])--{-# INLINE readInstance #-}-readInstance :: Stream Identity Int -> Stream Identity Int-readInstance src =-    let r = P.reads ("fromList [1"-                P.++ P.concat (P.replicate value ",1") P.++ "]")-    in case r of-        [(x,"")] -> src S.<> x-        _ -> P.error "readInstance: no parse"--{-# INLINE pureFoldl' #-}-pureFoldl' :: Stream Identity Int -> Int-pureFoldl' = runIdentity . S.foldl' (+) 0--{-# INLINE foldableFoldl' #-}-foldableFoldl' :: Stream Identity Int -> Int-foldableFoldl' = F.foldl' (+) 0--{-# INLINE foldableSum #-}-foldableSum :: Stream Identity Int -> Int-foldableSum = P.sum--{-# INLINE traversableMapM #-}-traversableMapM :: Stream Identity Int -> IO (Stream Identity Int)-traversableMapM = P.mapM return
benchmark/LinearRate.hs view
@@ -3,14 +3,14 @@ -- Copyright   : (c) 2018 Harendra Kumar -- -- License     : BSD3--- Maintainer  : harendra.kumar@gmail.com+-- Maintainer  : streamly@composewell.com  -- Rate benchmarks are kept separate because they need more running time to -- provide stable results.  -- import Data.Functor.Identity (Identity, runIdentity) import System.Random (randomRIO)-import qualified LinearOps as Ops+import qualified Streamly.Benchmark.Prelude as Ops  import Streamly import Gauge
benchmark/NanoBenchmarks.hs view
@@ -5,16 +5,31 @@  {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-}-import Streamly.SVar (MonadAsync)-import qualified Streamly.Streams.StreamK as S++import Streamly (SerialT)+import Streamly.Internal.Data.SVar (MonadAsync)++import qualified Streamly.Memory.Array as A+import qualified Streamly.FileSystem.Handle as FH+import qualified Streamly.Internal.FileSystem.Handle as IFH+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 Data.Char (ord) import Gauge+import System.IO (hSeek, SeekMode(..), openFile, IOMode(..)) import System.Random  maxValue :: Int maxValue = 100000 +-- type Stream = K.Stream+type Stream = SerialT+ {-# INLINE sourceUnfoldrM #-}-sourceUnfoldrM :: MonadAsync m => S.Stream m Int+sourceUnfoldrM :: MonadAsync m => Stream m Int sourceUnfoldrM = S.unfoldrM step 0     where     step cnt =@@ -23,7 +38,7 @@         else return (Just (cnt, cnt + 1))  {-# INLINE sourceUnfoldrMN #-}-sourceUnfoldrMN :: MonadAsync m => Int -> S.Stream m Int+sourceUnfoldrMN :: MonadAsync m => Int -> Stream m Int sourceUnfoldrMN n = S.unfoldrM step n     where     step cnt =@@ -32,7 +47,7 @@         else return (Just (cnt, cnt + 1))  {-# INLINE sourceUnfoldr #-}-sourceUnfoldr :: Monad m => Int -> S.Stream m Int+sourceUnfoldr :: Monad m => Int -> Stream m Int sourceUnfoldr n = S.unfoldr step n     where     step cnt =@@ -44,30 +59,30 @@ -- take-drop composition ------------------------------------------------------------------------------- -takeAllDropOne :: Monad m => S.Stream m Int -> S.Stream m Int+takeAllDropOne :: Monad m => Stream m Int -> Stream m Int takeAllDropOne = S.drop 1 . S.take maxValue  -- Requires -fspec-constr-recursive=5 for better fused code -- The number depends on how many times we compose it  {-# INLINE takeDrop #-}-takeDrop :: Monad m => S.Stream m Int -> m ()-takeDrop = S.runStream .+takeDrop :: Monad m => Stream m Int -> m ()+takeDrop = S.drain .     takeAllDropOne . takeAllDropOne . takeAllDropOne . takeAllDropOne  ------------------------------------------------------------------------------- -- dropWhileFalse composition ------------------------------------------------------------------------------- -dropWhileFalse :: Monad m => S.Stream m Int -> S.Stream m Int+dropWhileFalse :: Monad m => Stream m Int -> Stream m Int dropWhileFalse = S.dropWhile (> maxValue)  -- Requires -fspec-constr-recursive=5 for better fused code -- The number depends on how many times we compose it  {-# INLINE dropWhileFalseX4 #-}-dropWhileFalseX4 :: Monad m => S.Stream m Int -> m ()-dropWhileFalseX4 = S.runStream+dropWhileFalseX4 :: Monad m => Stream m Int -> m ()+dropWhileFalseX4 = S.drain     . dropWhileFalse . dropWhileFalse . dropWhileFalse .  dropWhileFalse  -------------------------------------------------------------------------------@@ -77,7 +92,7 @@ {-# INLINE iterateSource #-} iterateSource     :: MonadAsync m-    => (S.Stream m Int -> S.Stream m Int) -> Int -> Int -> S.Stream m Int+    => (Stream m Int -> Stream m Int) -> Int -> Int -> Stream m Int iterateSource g i n = f i (sourceUnfoldrMN n)     where         f (0 :: Int) m = g m@@ -88,9 +103,20 @@ main :: IO () main = do     defaultMain [bench "unfoldr" $ nfIO $-        randomRIO (1,1) >>= \n -> S.runStream (sourceUnfoldr n)]+        randomRIO (1,1) >>= \n -> S.drain (sourceUnfoldr n)]     defaultMain [bench "take-drop" $ nfIO $ takeDrop sourceUnfoldrM]     defaultMain [bench "dropWhileFalseX4" $         nfIO $ dropWhileFalseX4 sourceUnfoldrM]     defaultMain [bench "iterate-mapM" $-        nfIO $ S.runStream $ iterateSource (S.mapM return) 100000 10]+        nfIO $ S.drain $ iterateSource (S.mapM return) 100000 10]++    inText <- openFile "benchmark/text-processing/gutenberg-500.txt" ReadMode+    defaultMain [mkBenchText "splitOn abc...xyz" inText $ do+                (S.length $ Internal.splitOnSeq (A.fromList $ map (fromIntegral . ord)+                    "abcdefghijklmnopqrstuvwxyz") FL.drain+                        $ IFH.toStream inText) >>= print+                ]+    where++    mkBenchText name h action =+        bench name $ perRunEnv (hSeek h AbsoluteSeek 0) (\_ -> action)
benchmark/Nested.hs view
@@ -3,7 +3,7 @@ -- Copyright   : (c) 2018 Harendra Kumar -- -- License     : BSD3--- Maintainer  : harendra.kumar@gmail.com+-- Maintainer  : streamly@composewell.com  import Control.DeepSeq (NFData) import Data.Functor.Identity (Identity, runIdentity)@@ -25,6 +25,7 @@     [ 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@@ -36,6 +37,7 @@     , 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@@ -47,6 +49,7 @@     , 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@@ -58,6 +61,7 @@     , 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@@ -69,6 +73,7 @@     , 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@@ -80,6 +85,7 @@     , 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
benchmark/NestedOps.hs view
@@ -3,7 +3,7 @@ -- Copyright   : (c) 2018 Harendra Kumar -- -- License     : MIT--- Maintainer  : harendra.kumar@gmail.com+-- Maintainer  : streamly@composewell.com  {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -13,15 +13,21 @@ import Control.Exception (try) import GHC.Exception (ErrorCall) -import qualified Streamly          as S+import qualified Streamly          as S hiding (runStream) import qualified Streamly.Prelude  as S -sumCount :: Int-sumCount = 1000000+linearCount :: Int+linearCount = 100000 -prodCount :: Int-prodCount = 100+-- 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 -------------------------------------------------------------------------------@@ -52,7 +58,7 @@  {-# INLINE runStream #-} runStream :: Monad m => Stream m a -> m ()-runStream = S.runStream+runStream = S.drain  {-# INLINE runToList #-} runToList :: Monad m => Stream m a -> m [a]@@ -67,24 +73,34 @@     :: (S.IsStream t, S.MonadAsync m, Monad (t m))     => (t m Int -> S.SerialT m Int) -> Int -> m () toNullAp t start = runStream . t $-    (+) <$> source start prodCount <*> source start prodCount+    (+) <$> source start nestedCount2 <*> source start nestedCount2  {-# 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-    x <- source start prodCount-    y <- source start prodCount+    x <- source start nestedCount2+    y <- source start nestedCount2     return $ x + y +{-# 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+    x <- source start nestedCount3+    y <- source start nestedCount3+    z <- source start nestedCount3+    return $ x + y + z+ {-# 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-    x <- source start prodCount-    y <- source start prodCount+    x <- source start nestedCount2+    y <- source start nestedCount2     return $ x + y  {-# INLINE toListSome #-}@@ -93,8 +109,8 @@     => (t m Int -> S.SerialT m Int) -> Int -> m [Int] toListSome t start =     runToList . t $ S.take 1000 $ do-        x <- source start prodCount-        y <- source start prodCount+        x <- source start nestedCount2+        y <- source start nestedCount2         return $ x + y  {-# INLINE filterAllOut #-}@@ -102,8 +118,8 @@     :: (S.IsStream t, S.MonadAsync m, Monad (t m))     => (t m Int -> S.SerialT m Int) -> Int -> m () filterAllOut t start = runStream . t $ do-    x <- source start prodCount-    y <- source start prodCount+    x <- source start nestedCount2+    y <- source start nestedCount2     let s = x + y     if s < 0     then return s@@ -114,8 +130,8 @@     :: (S.IsStream t, S.MonadAsync m, Monad (t m))     => (t m Int -> S.SerialT m Int) -> Int -> m () filterAllIn t start = runStream . t $ do-    x <- source start prodCount-    y <- source start prodCount+    x <- source start nestedCount2+    y <- source start nestedCount2     let s = x + y     if s > 0     then return s@@ -126,8 +142,8 @@     :: (S.IsStream t, S.MonadAsync m, Monad (t m))     => (t m Int -> S.SerialT m Int) -> Int -> m () filterSome t start = runStream . t $ do-    x <- source start prodCount-    y <- source start prodCount+    x <- source start nestedCount2+    y <- source start nestedCount2     let s = x + y     if s > 1100000     then return s@@ -139,8 +155,8 @@     => (t IO Int -> S.SerialT IO Int) -> Int -> IO () breakAfterSome t start = do     (_ :: Either ErrorCall ()) <- try $ runStream . t $ do-        x <- source start prodCount-        y <- source start prodCount+        x <- source start nestedCount2+        y <- source start nestedCount2         let s = x + y         if s > 1100000         then error "break"
+ benchmark/NestedUnfold.hs view
@@ -0,0 +1,32 @@+-- |+-- Module      : NestedUnfold+-- Copyright   : (c) 2019 Composewell Technologies+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com++import Control.DeepSeq (NFData)+import System.Random (randomRIO)++import qualified NestedUnfoldOps as Ops++import Gauge++benchIO :: (NFData b) => String -> (Int -> IO b) -> Benchmark+benchIO name f = bench name $ nfIO $ randomRIO (1,1) >>= f++main :: IO ()+main =+  defaultMain+    [ 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+      ]+    ]
+ benchmark/NestedUnfoldOps.hs view
@@ -0,0 +1,128 @@+-- |+-- Module      : NestedUnfoldOps+-- Copyright   : (c) 2019 Composewell Technologies+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com++module NestedUnfoldOps where++import Control.Monad.IO.Class (MonadIO (..))+import Streamly.Internal.Data.Unfold (Unfold)++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++-- double nested loop+nestedCount2 :: Int+nestedCount2 = round (fromIntegral linearCount**(1/2::Double))++-- triple nested loop+nestedCount3 :: Int+nestedCount3 = round (fromIntegral linearCount**(1/3::Double))++-------------------------------------------------------------------------------+-- Stream generation and elimination+-------------------------------------------------------------------------------++-- generate numbers up to the argument value+{-# INLINE source #-}+source :: Monad m => Int -> Unfold m Int Int+source n = UF.enumerateFromToIntegral n++-------------------------------------------------------------------------------+-- Benchmark ops+-------------------------------------------------------------------------------++{-# INLINE toNull #-}+toNull :: MonadIO m => Int -> m ()+toNull start = do+    let end = start + nestedCount2+    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+    UF.fold+            (UF.map (\(x, y) -> x + y)+            $ UF.outerProduct (source end)+                ((UF.map (\(x, y) -> x + y)+                $ UF.outerProduct (source end) (source end))))+            FL.drain (start, (start, start))++{-# INLINE concat #-}+concat :: MonadIO m => Int -> m ()+concat start = do+    let end = start + concatCount+    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+    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+    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+    UF.fold+        (UF.filter (< 0)+        $ UF.map (\(x, y) -> x + y)+        $ UF.outerProduct (source end) (source end))+        FL.drain (start, start)++{-# INLINE filterAllIn #-}+filterAllIn :: MonadIO m => Int -> m ()+filterAllIn start = do+    let end = start + nestedCount2+    UF.fold+        (UF.filter (> 0)+        $ UF.map (\(x, y) -> x + y)+        $ UF.outerProduct (source end) (source end))+        FL.drain (start, start)++{-# INLINE filterSome #-}+filterSome :: MonadIO m => Int -> m ()+filterSome start = do+    let end = start + nestedCount2+    UF.fold+        (UF.filter (> 1100000)+        $ UF.map (\(x, y) -> x + y)+        $ UF.outerProduct (source end) (source end))+        FL.drain (start, start)++{-# INLINE breakAfterSome #-}+breakAfterSome :: MonadIO m => Int -> m ()+breakAfterSome start = do+    let end = start + nestedCount2+    UF.fold+        (UF.takeWhile (<= 1100000)+        $ UF.map (\(x, y) -> x + y)+        $ UF.outerProduct (source end) (source end))+        FL.drain (start, start)
+ benchmark/StreamDKOps.hs view
@@ -0,0 +1,424 @@+-- |+-- Module      : StreamDKOps+-- Copyright   : (c) 2018 Harendra Kumar+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++module StreamDKOps where++-- import Control.Monad (when)+-- import Data.Maybe (isJust)+import Prelude+       (Monad, Int, (+), ($), (.), return, even, (>), (<=), div,+        subtract, undefined, Maybe(..), not, (>>=),+        maxBound, flip, (<$>), (<*>), 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.SVar as S++value, value2, value3, value16, maxValue :: Int+value = 100000+value2 = round (P.fromIntegral value**(1/2::P.Double)) -- double nested loop+value3 = round (P.fromIntegral value**(1/3::P.Double)) -- triple nested loop+value16 = round (P.fromIntegral value**(1/16::P.Double)) -- triple nested loop+maxValue = value++-------------------------------------------------------------------------------+-- Benchmark ops+-------------------------------------------------------------------------------++-------------------------------------------------------------------------------+-- Stream generation and elimination+-------------------------------------------------------------------------------++type Stream m a = S.Stream m a++{-# INLINE sourceUnfoldr #-}+sourceUnfoldr :: Monad m => Int -> Stream 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 => Int -> Int -> Stream m Int+sourceUnfoldrN m n = S.unfoldr step n+    where+    step cnt =+        if cnt > n + m+        then Nothing+        else Just (cnt, cnt + 1)++{-# INLINE sourceUnfoldrM #-}+sourceUnfoldrM :: Monad m => Int -> Stream 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 sourceUnfoldrMN #-}+sourceUnfoldrMN :: Monad m => Int -> Int -> Stream m Int+sourceUnfoldrMN m n = S.unfoldrM step n+    where+    step cnt =+        if cnt > n + m+        then return Nothing+        else return (Just (cnt, cnt + 1))++{-+{-# INLINE sourceFromEnum #-}+sourceFromEnum :: Monad m => Int -> Stream m Int+sourceFromEnum n = S.enumFromStepN n 1 value+-}++{-+{-# INLINE sourceFromFoldable #-}+sourceFromFoldable :: Int -> Stream m Int+sourceFromFoldable n = S.fromFoldable [n..n+value]+-}++{-+{-# INLINE sourceFromFoldableM #-}+sourceFromFoldableM :: S.MonadAsync m => Int -> Stream m Int+sourceFromFoldableM n = S.fromFoldableM (Prelude.fmap return [n..n+value])+-}++{-+{-# INLINE sourceFoldMapWith #-}+sourceFoldMapWith :: Int -> Stream m Int+sourceFoldMapWith n = SP.foldMapWith S.serial S.yield [n..n+value]++{-# INLINE sourceFoldMapWithM #-}+sourceFoldMapWithM :: Monad m => Int -> Stream m Int+sourceFoldMapWithM n = SP.foldMapWith S.serial (S.yieldM . return) [n..n+value]+-}++{-# INLINE source #-}+source :: Monad m => Int -> Stream m Int+source = sourceUnfoldrM++-------------------------------------------------------------------------------+-- Elimination+-------------------------------------------------------------------------------++{-# INLINE runStream #-}+runStream :: Monad m => Stream m a -> m ()+runStream = S.drain+-- runStream = S.mapM_ (\_ -> return ())++{-+{-# INLINE mapM_ #-}+mapM_ :: Monad m => Stream m a -> m ()+mapM_ = S.mapM_ (\_ -> return ())+-}++{-# INLINE toNull #-}+toNull :: Monad m => Stream m Int -> m ()+toNull = runStream++{-# 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, S.IsStream t) => t m a -> m ()+init s = do+    t <- S.init s+    P.mapM_ S.drain t++{-# INLINE tail #-}+tail :: (Monad m, S.IsStream t) => t m a -> m ()+tail s = S.tail s >>= P.mapM_ tail++{-# INLINE nullTail #-}+{-# INLINE headTail #-}+{-# INLINE zip #-}+nullTail, headTail, zip+    :: Monad m+    => Stream m Int -> m ()++nullTail s = do+    r <- S.null s+    when (not r) $ S.tail s >>= P.mapM_ nullTail++headTail s = do+    h <- S.head s+    when (isJust h) $ S.tail s >>= P.mapM_ headTail++{-# INLINE toList #-}+toList :: Monad m => Stream m Int -> m [Int]+toList = S.toList++{-# INLINE foldl #-}+foldl :: Monad m => Stream m Int -> m Int+foldl  = S.foldl' (+) 0++{-# INLINE last #-}+last :: Monad m => Stream m Int -> m (Maybe Int)+last   = S.last+-}++-------------------------------------------------------------------------------+-- Transformation+-------------------------------------------------------------------------------++{-# INLINE transform #-}+transform :: Monad m => Stream m a -> m ()+transform = runStream++{-# INLINE composeN #-}+composeN+    :: Monad m+    => Int -> (Stream m Int -> Stream m Int) -> Stream m Int -> m ()+composeN n f =+    case n of+        1 -> transform . f+        2 -> transform . f . f+        3 -> transform . f . f . f+        4 -> transform . f . f . f . f+        _ -> undefined++{-+{-# INLINE scan #-}+{-# INLINE map #-}+{-# INLINE fmap #-}+{-# INLINE filterEven #-}+{-# INLINE filterAllOut #-}+{-# INLINE filterAllIn #-}+{-# INLINE takeOne #-}+{-# INLINE takeAll #-}+{-# INLINE takeWhileTrue #-}+{-# INLINE dropOne #-}+{-# INLINE dropAll #-}+{-# INLINE dropWhileTrue #-}+{-# INLINE dropWhileFalse #-}+{-# INLINE foldlS #-}+{-# INLINE concatMap #-}+scan, map, fmap, filterEven, filterAllOut,+    filterAllIn, takeOne, takeAll, takeWhileTrue, dropAll, dropOne,+    dropWhileTrue, dropWhileFalse, foldlS, concatMap+    :: Monad m+    => Int -> Stream m Int -> m ()++{-# INLINE mapM #-}+{-# INLINE mapMSerial #-}+{-# INLINE intersperse #-}+mapM, mapMSerial, intersperse+    :: S.MonadAsync m => Int -> Stream m Int -> m ()++scan           n = composeN n $ S.scanl' (+) 0+map            n = composeN n $ P.fmap (+1)+fmap           n = composeN n $ P.fmap (+1)+mapM           n = composeN n $ S.mapM return+mapMSerial     n = composeN n $ S.mapMSerial return+filterEven     n = composeN n $ S.filter even+filterAllOut   n = composeN n $ S.filter (> maxValue)+filterAllIn    n = composeN n $ S.filter (<= maxValue)+takeOne        n = composeN n $ S.take 1+takeAll        n = composeN n $ S.take maxValue+takeWhileTrue  n = composeN n $ S.takeWhile (<= maxValue)+dropOne        n = composeN n $ S.drop 1+dropAll        n = composeN n $ S.drop maxValue+dropWhileTrue  n = composeN n $ S.dropWhile (<= maxValue)+dropWhileFalse n = composeN n $ S.dropWhile (<= 1)+foldlS         n = composeN n $ S.foldlS (flip S.cons) S.nil+-- We use a (sqrt n) element stream as source and then concat the same stream+-- for each element to produce an n element stream.+concatMap      n = composeN n $ (\s -> S.concatMap (\_ -> s) s)+intersperse    n = composeN n $ S.intersperse maxValue++-------------------------------------------------------------------------------+-- Iteration+-------------------------------------------------------------------------------++iterStreamLen, maxIters :: Int+iterStreamLen = 10+maxIters = 10000++{-# INLINE iterateSource #-}+iterateSource+    :: S.MonadAsync m+    => (Stream m Int -> Stream m Int) -> Int -> Int -> Stream m Int+iterateSource g i n = f i (sourceUnfoldrMN iterStreamLen n)+    where+        f (0 :: Int) m = g m+        f x m = g (f (x P.- 1) m)++{-# INLINE iterateMapM #-}+{-# INLINE iterateScan #-}+{-# INLINE iterateFilterEven #-}+{-# INLINE iterateTakeAll #-}+{-# INLINE iterateDropOne #-}+{-# INLINE iterateDropWhileFalse #-}+{-# INLINE iterateDropWhileTrue #-}+iterateMapM, iterateScan, iterateFilterEven, iterateTakeAll, iterateDropOne,+    iterateDropWhileFalse, iterateDropWhileTrue+    :: S.MonadAsync m+    => Int -> Stream m Int++-- this is quadratic+iterateScan            = iterateSource (S.scanl' (+) 0) (maxIters `div` 10)+iterateDropWhileFalse  = iterateSource (S.dropWhile (> maxValue))+                                       (maxIters `div` 10)++iterateMapM            = iterateSource (S.mapM return) maxIters+iterateFilterEven      = iterateSource (S.filter even) maxIters+iterateTakeAll         = iterateSource (S.take maxValue) maxIters+iterateDropOne         = iterateSource (S.drop 1) maxIters+iterateDropWhileTrue   = iterateSource (S.dropWhile (<= maxValue)) maxIters++-------------------------------------------------------------------------------+-- Zipping and concat+-------------------------------------------------------------------------------++zip src       = transform $ S.zipWith (,) src src++{-# INLINE concatMapRepl4xN #-}+concatMapRepl4xN :: Monad m => Stream m Int -> m ()+concatMapRepl4xN src = transform $ (S.concatMap (S.replicate 4) src)++-------------------------------------------------------------------------------+-- Mixed Composition+-------------------------------------------------------------------------------++{-# INLINE scanMap #-}+{-# INLINE dropMap #-}+{-# INLINE dropScan #-}+{-# INLINE takeDrop #-}+{-# INLINE takeScan #-}+{-# INLINE takeMap #-}+{-# INLINE filterDrop #-}+{-# INLINE filterTake #-}+{-# INLINE filterScan #-}+{-# INLINE filterMap #-}+scanMap, dropMap, dropScan, takeDrop, takeScan, takeMap, filterDrop,+    filterTake, filterScan, filterMap+    :: Monad m => Int -> Stream m Int -> m ()++scanMap    n = composeN n $ S.map (subtract 1) . S.scanl' (+) 0+dropMap    n = composeN n $ S.map (subtract 1) . S.drop 1+dropScan   n = composeN n $ S.scanl' (+) 0 . S.drop 1+takeDrop   n = composeN n $ S.drop 1 . S.take maxValue+takeScan   n = composeN n $ S.scanl' (+) 0 . S.take maxValue+takeMap    n = composeN n $ S.map (subtract 1) . S.take maxValue+filterDrop n = composeN n $ S.drop 1 . S.filter (<= maxValue)+filterTake n = composeN n $ S.take maxValue . S.filter (<= maxValue)+filterScan n = composeN n $ S.scanl' (+) 0 . S.filter (<= maxBound)+filterMap  n = composeN n $ S.map (subtract 1) . S.filter (<= maxValue)++-------------------------------------------------------------------------------+-- Nested Composition+-------------------------------------------------------------------------------++{-# INLINE toNullApNested #-}+toNullApNested :: Monad m => Stream m Int -> m ()+toNullApNested s = runStream $ do+    (+) <$> s <*> s++{-# INLINE toNullNested #-}+toNullNested :: Monad m => Stream m Int -> m ()+toNullNested s = runStream $ do+    x <- s+    y <- s+    return $ x + y++{-# INLINE toNullNested3 #-}+toNullNested3 :: Monad m => Stream m Int -> m ()+toNullNested3 s = runStream $ do+    x <- s+    y <- s+    z <- s+    return $ x + y + z++{-# INLINE filterAllOutNested #-}+filterAllOutNested+    :: Monad m+    => Stream m Int -> m ()+filterAllOutNested str = runStream $ do+    x <- str+    y <- str+    let s = x + y+    if s < 0+    then return s+    else S.nil++{-# INLINE filterAllInNested #-}+filterAllInNested+    :: Monad m+    => Stream m Int -> m ()+filterAllInNested str = runStream $ do+    x <- str+    y <- str+    let s = x + y+    if s > 0+    then return s+    else S.nil++-------------------------------------------------------------------------------+-- Nested Composition Pure lists+-------------------------------------------------------------------------------++{-# INLINE sourceUnfoldrList #-}+sourceUnfoldrList :: Int -> Int -> [Int]+sourceUnfoldrList maxval n = List.unfoldr step n+    where+    step cnt =+        if cnt > n + maxval+        then Nothing+        else Just (cnt, cnt + 1)++{-# INLINE toNullApNestedList #-}+toNullApNestedList :: [Int] -> [Int]+toNullApNestedList s = (+) <$> s <*> s++{-# INLINE toNullNestedList #-}+toNullNestedList :: [Int] -> [Int]+toNullNestedList s = do+    x <- s+    y <- s+    return $ x + y++{-# INLINE toNullNestedList3 #-}+toNullNestedList3 :: [Int] -> [Int]+toNullNestedList3 s = do+    x <- s+    y <- s+    z <- s+    return $ x + y + z++{-# INLINE filterAllOutNestedList #-}+filterAllOutNestedList :: [Int] -> [Int]+filterAllOutNestedList str = do+    x <- str+    y <- str+    let s = x + y+    if s < 0+    then return s+    else []++{-# INLINE filterAllInNestedList #-}+filterAllInNestedList :: [Int] -> [Int]+filterAllInNestedList str = do+    x <- str+    y <- str+    let s = x + y+    if s > 0+    then return s+    else []+-}
benchmark/StreamDOps.hs view
@@ -3,7 +3,7 @@ -- Copyright   : (c) 2018 Harendra Kumar -- -- License     : BSD3--- Maintainer  : harendra.kumar@gmail.com+-- Maintainer  : streamly@composewell.com  {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -14,15 +14,21 @@ import Data.Maybe (isJust) import Prelude         (Monad, Int, (+), ($), (.), return, (>), even, (<=), div,-         subtract, undefined, Maybe(..), not, mapM_, (>>=),-         maxBound, fmap, odd, (==))+         subtract, undefined, Maybe(..), not, (>>=),+         maxBound, fmap, odd, (==), flip, (<$>), (<*>), round, (/), (**), (<)) import qualified Prelude as P  import qualified Streamly.Streams.StreamD as S+import qualified Streamly.Internal.Data.Unfold as UF -value, maxValue :: Int+-- We try to keep the total number of iterations same irrespective of nesting+-- of the loops so that the overhead is easy to compare.+value, value2, value3, value16, maxValue :: Int value = 100000-maxValue = value + 1000+value2 = round (P.fromIntegral value**(1/2::P.Double)) -- double nested loop+value3 = round (P.fromIntegral value**(1/3::P.Double)) -- triple nested loop+value16 = round (P.fromIntegral value**(1/16::P.Double)) -- triple nested loop+maxValue = value  ------------------------------------------------------------------------------- -- Stream generation and elimination@@ -39,6 +45,15 @@         then Nothing         else Just (cnt, cnt + 1) +{-# INLINE sourceUnfoldrN #-}+sourceUnfoldrN :: Monad m => Int -> Int -> Stream m Int+sourceUnfoldrN m n = S.unfoldr step n+    where+    step cnt =+        if cnt > n + m+        then Nothing+        else Just (cnt, cnt + 1)+ {-# INLINE sourceUnfoldrMN #-} sourceUnfoldrMN :: Monad m => Int -> Int -> Stream m Int sourceUnfoldrMN m n = S.unfoldrM step n@@ -75,8 +90,12 @@  {-# INLINE runStream #-} runStream :: Monad m => Stream m a -> m ()-runStream = S.runStream+runStream = S.drain +{-# INLINE mapM_ #-}+mapM_ :: Monad m => Stream m a -> m ()+mapM_ = S.mapM_ (\_ -> return ())+ {-# INLINE toNull #-} toNull :: Monad m => Stream m Int -> m () toNull = runStream@@ -96,15 +115,15 @@  {-# INLINE tail #-} tail :: Monad m => Stream m a -> m ()-tail s = S.tail s >>= mapM_ tail+tail s = S.tail s >>= P.mapM_ tail  nullTail s = do     r <- S.null s-    when (not r) $ S.tail s >>= mapM_ nullTail+    when (not r) $ S.tail s >>= P.mapM_ nullTail  headTail s = do     h <- S.head s-    when (isJust h) $ S.tail s >>= mapM_ headTail+    when (isJust h) $ S.tail s >>= P.mapM_ headTail  {-# INLINE toList #-} toList :: Monad m => Stream m Int -> m [Int]@@ -156,9 +175,14 @@ {-# INLINE dropWhileTrue #-} {-# INLINE dropWhileMTrue #-} {-# INLINE dropWhileFalse #-}+{-# INLINE foldrS #-}+{-# INLINE foldlS #-}+{-# INLINE concatMap #-}+{-# INLINE intersperse #-} scan, map, fmap, mapM, mapMaybe, mapMaybeM, filterEven, filterAllOut,     filterAllIn, takeOne, takeAll, takeWhileTrue, takeWhileMTrue, dropOne,-    dropAll, dropWhileTrue, dropWhileMTrue, dropWhileFalse+    dropAll, dropWhileTrue, dropWhileMTrue, dropWhileFalse, foldrS, foldlS,+    concatMap, intersperse     :: Monad m     => Int -> Stream m Int -> m () @@ -182,6 +206,10 @@ dropWhileTrue  n = composeN n $ S.dropWhile (<= maxValue) dropWhileMTrue n = composeN n $ S.dropWhileM (return . (<= maxValue)) dropWhileFalse n = composeN n $ S.dropWhile (> maxValue)+foldrS         n = composeN n $ S.foldrS S.cons S.nil+foldlS         n = composeN n $ S.foldlS (flip S.cons) S.nil+concatMap      n = composeN n $ (\s -> S.concatMap (\_ -> s) s)+intersperse    n = composeN n $ S.intersperse maxValue  ------------------------------------------------------------------------------- -- Iteration@@ -239,11 +267,14 @@ zip :: Monad m => Stream m Int -> m () zip src = transform $ S.zipWith (,) src src -{--{-# INLINE concat #-}-concat _n     = return ()--}+{-# INLINE concatMapRepl4xN #-}+concatMapRepl4xN :: Monad m => Stream m Int -> m ()+concatMapRepl4xN src = transform $ (S.concatMap (S.replicate 4) src) +{-# INLINE concatMapURepl4xN #-}+concatMapURepl4xN :: Monad m => Stream m Int -> m ()+concatMapURepl4xN src = transform $ S.concatMapU (UF.replicateM 4) src+ ------------------------------------------------------------------------------- -- Mixed Composition -------------------------------------------------------------------------------@@ -272,3 +303,51 @@ filterTake n = composeN n $ S.take maxValue . S.filter (<= maxValue) filterScan n = composeN n $ S.scanl' (+) 0 . S.filter (<= maxBound) filterMap  n = composeN n $ S.map (subtract 1) . S.filter (<= maxValue)++-------------------------------------------------------------------------------+-- Nested Composition+-------------------------------------------------------------------------------++{-# INLINE toNullApNested #-}+toNullApNested :: Monad m => Stream m Int -> m ()+toNullApNested s = runStream $ do+    (+) <$> s <*> s++{-# INLINE toNullNested #-}+toNullNested :: Monad m => Stream m Int -> m ()+toNullNested s = runStream $ do+    x <- s+    y <- s+    return $ x + y++{-# INLINE toNullNested3 #-}+toNullNested3 :: Monad m => Stream m Int -> m ()+toNullNested3 s = runStream $ do+    x <- s+    y <- s+    z <- s+    return $ x + y + z++{-# INLINE filterAllOutNested #-}+filterAllOutNested+    :: Monad m+    => Stream m Int -> m ()+filterAllOutNested str = runStream $ do+    x <- str+    y <- str+    let s = x + y+    if s < 0+    then return s+    else S.nil++{-# INLINE filterAllInNested #-}+filterAllInNested+    :: Monad m+    => Stream m Int -> m ()+filterAllInNested str = runStream $ do+    x <- str+    y <- str+    let s = x + y+    if s > 0+    then return s+    else S.nil
benchmark/StreamKOps.hs view
@@ -3,7 +3,7 @@ -- Copyright   : (c) 2018 Harendra Kumar -- -- License     : BSD3--- Maintainer  : harendra.kumar@gmail.com+-- Maintainer  : streamly@composewell.com  {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -15,16 +15,20 @@ import Prelude        (Monad, Int, (+), ($), (.), return, even, (>), (<=), div,         subtract, undefined, Maybe(..), not, (>>=),-        maxBound)+        maxBound, flip, (<$>), (<*>), round, (/), (**), (<)) 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.SVar as S+import qualified Streamly.Internal.Data.SVar as S -value, maxValue :: Int+value, value2, value3, value16, maxValue :: Int value = 100000-maxValue = value + 1000+value2 = round (P.fromIntegral value**(1/2::P.Double)) -- double nested loop+value3 = round (P.fromIntegral value**(1/3::P.Double)) -- triple nested loop+value16 = round (P.fromIntegral value**(1/16::P.Double)) -- triple nested loop+maxValue = value  ------------------------------------------------------------------------------- -- Benchmark ops@@ -35,8 +39,7 @@ {-# INLINE nullTail #-} {-# INLINE headTail #-} {-# INLINE zip #-}-{-# INLINE concat #-}-toNull, uncons, nullTail, headTail, zip, concat+toNull, uncons, nullTail, headTail, zip     :: Monad m     => Stream m Int -> m () @@ -62,6 +65,15 @@         then Nothing         else Just (cnt, cnt + 1) +{-# INLINE sourceUnfoldrN #-}+sourceUnfoldrN :: Int -> Int -> Stream m Int+sourceUnfoldrN m n = S.unfoldr step n+    where+    step cnt =+        if cnt > n + m+        then Nothing+        else Just (cnt, cnt + 1)+ {-# INLINE sourceUnfoldrM #-} sourceUnfoldrM :: S.MonadAsync m => Int -> Stream m Int sourceUnfoldrM n = S.unfoldrM step n@@ -114,7 +126,8 @@  {-# INLINE runStream #-} runStream :: Monad m => Stream m a -> m ()-runStream = S.runStream+runStream = S.drain+-- runStream = S.mapM_ (\_ -> return ())  {-# INLINE mapM_ #-} mapM_ :: Monad m => Stream m a -> m ()@@ -131,7 +144,7 @@ init :: (Monad m, S.IsStream t) => t m a -> m () init s = do     t <- S.init s-    P.mapM_ S.runStream t+    P.mapM_ S.drain t  {-# INLINE tail #-} tail :: (Monad m, S.IsStream t) => t m a -> m ()@@ -182,19 +195,25 @@ {-# INLINE dropAll #-} {-# INLINE dropWhileTrue #-} {-# INLINE dropWhileFalse #-}+{-# INLINE foldlS #-}+{-# INLINE concatMap #-} scan, map, fmap, filterEven, filterAllOut,     filterAllIn, takeOne, takeAll, takeWhileTrue, dropAll, dropOne,-    dropWhileTrue, dropWhileFalse+    dropWhileTrue, dropWhileFalse, foldlS, concatMap     :: Monad m     => Int -> Stream m Int -> m ()  {-# INLINE mapM #-}-mapM :: S.MonadAsync m => Int -> Stream m Int -> m ()+{-# INLINE mapMSerial #-}+{-# INLINE intersperse #-}+mapM, mapMSerial, intersperse+    :: S.MonadAsync m => Int -> Stream m Int -> m ()  scan           n = composeN n $ S.scanl' (+) 0 map            n = composeN n $ P.fmap (+1) fmap           n = composeN n $ P.fmap (+1) mapM           n = composeN n $ S.mapM return+mapMSerial     n = composeN n $ S.mapMSerial return filterEven     n = composeN n $ S.filter even filterAllOut   n = composeN n $ S.filter (> maxValue) filterAllIn    n = composeN n $ S.filter (<= maxValue)@@ -205,6 +224,11 @@ dropAll        n = composeN n $ S.drop maxValue dropWhileTrue  n = composeN n $ S.dropWhile (<= maxValue) dropWhileFalse n = composeN n $ S.dropWhile (<= 1)+foldlS         n = composeN n $ S.foldlS (flip S.cons) S.nil+-- We use a (sqrt n) element stream as source and then concat the same stream+-- for each element to produce an n element stream.+concatMap      n = composeN n $ (\s -> S.concatMap (\_ -> s) s)+intersperse    n = composeN n $ S.intersperse maxValue  ------------------------------------------------------------------------------- -- Iteration@@ -251,8 +275,11 @@ -------------------------------------------------------------------------------  zip src       = transform $ S.zipWith (,) src src-concat _n     = return () +{-# INLINE concatMapRepl4xN #-}+concatMapRepl4xN :: Monad m => Stream m Int -> m ()+concatMapRepl4xN src = transform $ (S.concatMap (S.replicate 4) src)+ ------------------------------------------------------------------------------- -- Mixed Composition -------------------------------------------------------------------------------@@ -281,3 +308,103 @@ filterTake n = composeN n $ S.take maxValue . S.filter (<= maxValue) filterScan n = composeN n $ S.scanl' (+) 0 . S.filter (<= maxBound) filterMap  n = composeN n $ S.map (subtract 1) . S.filter (<= maxValue)++-------------------------------------------------------------------------------+-- Nested Composition+-------------------------------------------------------------------------------++{-# INLINE toNullApNested #-}+toNullApNested :: Monad m => Stream m Int -> m ()+toNullApNested s = runStream $ do+    (+) <$> s <*> s++{-# INLINE toNullNested #-}+toNullNested :: Monad m => Stream m Int -> m ()+toNullNested s = runStream $ do+    x <- s+    y <- s+    return $ x + y++{-# INLINE toNullNested3 #-}+toNullNested3 :: Monad m => Stream m Int -> m ()+toNullNested3 s = runStream $ do+    x <- s+    y <- s+    z <- s+    return $ x + y + z++{-# INLINE filterAllOutNested #-}+filterAllOutNested+    :: Monad m+    => Stream m Int -> m ()+filterAllOutNested str = runStream $ do+    x <- str+    y <- str+    let s = x + y+    if s < 0+    then return s+    else S.nil++{-# INLINE filterAllInNested #-}+filterAllInNested+    :: Monad m+    => Stream m Int -> m ()+filterAllInNested str = runStream $ do+    x <- str+    y <- str+    let s = x + y+    if s > 0+    then return s+    else S.nil++-------------------------------------------------------------------------------+-- Nested Composition Pure lists+-------------------------------------------------------------------------------++{-# INLINE sourceUnfoldrList #-}+sourceUnfoldrList :: Int -> Int -> [Int]+sourceUnfoldrList maxval n = List.unfoldr step n+    where+    step cnt =+        if cnt > n + maxval+        then Nothing+        else Just (cnt, cnt + 1)++{-# INLINE toNullApNestedList #-}+toNullApNestedList :: [Int] -> [Int]+toNullApNestedList s = (+) <$> s <*> s++{-# INLINE toNullNestedList #-}+toNullNestedList :: [Int] -> [Int]+toNullNestedList s = do+    x <- s+    y <- s+    return $ x + y++{-# INLINE toNullNestedList3 #-}+toNullNestedList3 :: [Int] -> [Int]+toNullNestedList3 s = do+    x <- s+    y <- s+    z <- s+    return $ x + y + z++{-# INLINE filterAllOutNestedList #-}+filterAllOutNestedList :: [Int] -> [Int]+filterAllOutNestedList str = do+    x <- str+    y <- str+    let s = x + y+    if s < 0+    then return s+    else []++{-# INLINE filterAllInNestedList #-}+filterAllInNestedList :: [Int] -> [Int]+filterAllInNestedList str = do+    x <- str+    y <- str+    let s = x + y+    if s > 0+    then return s+    else []
configure view
@@ -2,7 +2,7 @@ # Guess values for system-dependent variables and create Makefiles. # Generated by GNU Autoconf 2.69 for streamly 0.6.0. #-# Report bugs to <harendra.kumar@gmail.com>.+# Report bugs to <streamly@composewell.com>. # # # Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc.@@ -267,7 +267,7 @@     $as_echo "$0: be upgraded to zsh 4.3.4 or later."   else     $as_echo "$0: Please tell bug-autoconf@gnu.org and-$0: harendra.kumar@gmail.com about your system, including+$0: streamly@composewell.com about your system, including $0: any error possibly output before this message. Then $0: install a modern shell, or manually run the script $0: under such a shell if you do have one."@@ -582,7 +582,7 @@ PACKAGE_TARNAME='streamly' PACKAGE_VERSION='0.6.0' PACKAGE_STRING='streamly 0.6.0'-PACKAGE_BUGREPORT='harendra.kumar@gmail.com'+PACKAGE_BUGREPORT='streamly@composewell.com' PACKAGE_URL=''  # Factoring default headers for most tests.@@ -1308,7 +1308,7 @@ Use these variables to override the choices made by `configure' or to help it to find libraries and programs with nonstandard names/locations. -Report bugs to <harendra.kumar@gmail.com>.+Report bugs to <streamly@composewell.com>. _ACEOF ac_status=$? fi@@ -1531,7 +1531,7 @@     { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: proceeding with the compiler's result" >&5 $as_echo "$as_me: WARNING: $2: proceeding with the compiler's result" >&2;} ( $as_echo "## --------------------------------------- ##-## Report this to harendra.kumar@gmail.com ##+## Report this to streamly@composewell.com ## ## --------------------------------------- ##"      ) | sed "s/^/$as_me: WARNING:     /" >&2     ;;@@ -3310,7 +3310,7 @@   # Output-ac_config_headers="$ac_config_headers src/Streamly/Time/config.h"+ac_config_headers="$ac_config_headers src/Streamly/Internal/Data/Time/config.h"  cat >confcache <<\_ACEOF # This file is a shell script that caches the results of configure@@ -3865,7 +3865,7 @@ Configuration headers: $config_headers -Report bugs to <harendra.kumar@gmail.com>."+Report bugs to <streamly@composewell.com>."  _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1@@ -3984,7 +3984,7 @@ for ac_config_target in $ac_config_targets do   case $ac_config_target in-    "src/Streamly/Time/config.h") CONFIG_HEADERS="$CONFIG_HEADERS src/Streamly/Time/config.h" ;;+    "src/Streamly/Internal/Data/Time/config.h") CONFIG_HEADERS="$CONFIG_HEADERS src/Streamly/Internal/Data/Time/config.h" ;;    *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;;   esac@@ -4328,4 +4328,3 @@   { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} fi-
configure.ac view
@@ -3,7 +3,7 @@ # See https://www.gnu.org/software/autoconf/manual/autoconf.html for help on # the macros used in this file. -AC_INIT([streamly], [0.6.0], [harendra.kumar@gmail.com], [streamly])+AC_INIT([streamly], [0.6.0], [streamly@composewell.com], [streamly])  # To suppress "WARNING: unrecognized options: --with-compiler" AC_ARG_WITH([compiler], [GHC])@@ -13,5 +13,5 @@ AC_CHECK_FUNCS([clock_gettime])  # Output-AC_CONFIG_HEADERS([src/Streamly/Time/config.h])+AC_CONFIG_HEADERS([src/Streamly/Internal/Data/Time/config.h]) AC_OUTPUT
+ credits/CONTRIBUTORS.md view
@@ -0,0 +1,85 @@+This is a list of code contributors to this library. For issue contributors+please see https://github.com/composewell/streamly/issues.++Use `git shortlog -sn tag1...tag2` on the git repository to get a list of+contributors between two repository tags.++## 0.7.0++Harendra Kumar+Pranay Sashank+Artyom Kazak+David Feuer+Adithya Kumar+Aravind Gopal++## 0.6.1++Harendra Kumar+Mariusz Ryndzionek+Luke Clifton+Nicolas Henin++## 0.6.0++* Harendra Kumar+* Pranay Sashank+* Abhiroop Sarkar+* Michael Sloan++## 0.5.2++* Harendra Kumar+* Keith++## 0.5.1++* Harendra Kumar++## 0.5.0++* Harendra Kumar+* Veladus+* Tim Buckley++## 0.4.1++* Harendra Kumar++## 0.4.0++* Harendra Kumar++## 0.3.0++* Harendra Kumar+* Xiaokui Shu+* k0ral++## 0.2.1++* Harendra Kumar++## 0.2.0++* Harendra Kumar+* Abhiroop Sarkar+* Hussein Ait Lahcen++## 0.1.2++* Harendra Kumar+* Abhiroop Sarkar+* Hussein Ait Lahcen++## 0.1.1++* Harendra Kumar+* Veladus+* Abhiroop Sarkar+* Sibi Prabakaran++## 0.1.0++* Harendra Kumar+* Sibi Prabakaran
+ credits/COPYRIGHTS.md view
@@ -0,0 +1,55 @@+This file contains a summary of the credits and copyrights for the code+currently shipped with the package.  To find parts of the code where the+original or modified code has been included please search for the copyright+notices in the individual files.++## 0.7.0++* Composable folds include code from the "foldl" package.+   * Copyright (c) 2013 Gabriel Gonzalez+   * http://hackage.haskell.org/package/foldl-1.4.5+   * See foldl-1.4.5.txt for the original license.++* Portions of UTF8 encoding/decoding code taken from the "base" package+  * Copyright (c) The University of Glasgow, 2009+  * http://hackage.haskell.org/package/base-4.12.0.0+  * See base-4.12.0.0.txt for the original license.++* UTF8 decoding state machine+  * Copyright (c) 2008-2009 Bjoern Hoehrmann <bjoern@hoehrmann.de>+  * http://bjoern.hoehrmann.de/utf-8/decoder/dfa/+  * See bjoern-2008-2009.txt for original license++## 0.6.1++* The time related code includes portions from the "clock" package.+   * Copyright (c) 2009-2012, Cetin Sert+   * Copyright (c) 2010, Eugene Kirpichov+   * http://hackage.haskell.org/package/clock-0.7.2+   * See clock-0.7.2.txt for the original license.++## 0.4.0++* Implementation of direct style monadic streams includes code from the+   "vector" package.+   * Copyright (c) 2008-2012, Roman Leshchinskiy+   * http://hackage.haskell.org/package/vector-0.12.0.2+   * See vector-0.12.0.2.txt for the original license.++## 0.1.0++* The initial version of this release included code from the transient+   package, however it was completely rewritten later on.+  * Copyright © 2014-2016 Alberto G. Corona+  * http://hackage.haskell.org/package/transient-0.5.5+  * See transient-0.5.5.txt for the original license.++* The AcidRain example was adapted from the "pipes-concurrency" package.+  * Copyright (c) 2014 Gabriel Gonzalez+  * http://hackage.haskell.org/package/pipes-concurrency-2.0.8+  * See pipes-concurrency-2.0.8.txt for the original license.++* The circling square example was adapted from the "Yampa" package.+  * Copyright (c) 2003, Henrik Nilsson, Antony Courtney and Yale University.+  * http://hackage.haskell.org/package/Yampa-0.10.6.2+  * See Yampa-0.10.6.2.txt for the original license.
+ credits/README.md view
@@ -0,0 +1,41 @@+This library builds upon many good ideas from the existing body of Haskell+work.  We would like to thank all the Haskellers whose work might have+influenced this library. It is not possible to quantify that contribution and+give proper credits for it. Below, we have listed the copyright attributions+and contributions to this library.  We do due diligence in giving credit where+its due, if something got missed please do point out by [raising an issue on+github](https://github.com/composewell/streamly/issues) or [sending an email to+the maintainers](mailto:streamly@composewell.com).++## Attributions++See COPYRIGHTS.md for parts of other works included in this package.++## Contributions++See CONTRIBUTORS.md for a release wise list of contributors to this library.++## References++Some (among many others) of the Haskell packages that we looked at and might+have taken some ideas or inspiration from include:++* http://hackage.haskell.org/package/base++* https://hackage.haskell.org/package/logict+* https://hackage.haskell.org/package/list-transformer+* http://hackage.haskell.org/package/transient++* http://hackage.haskell.org/package/streaming+* http://hackage.haskell.org/package/machines+* https://hackage.haskell.org/package/simple-conduit+* http://hackage.haskell.org/package/pipes+* http://hackage.haskell.org/package/conduit++* http://hackage.haskell.org/package/vector+* http://hackage.haskell.org/package/bytestring+* http://hackage.haskell.org/package/text++* http://hackage.haskell.org/package/split+* https://hackage.haskell.org/package/foldl+* https://github.com/effectfully/prefolds
+ credits/Yampa-0.10.6.2.txt view
@@ -0,0 +1,29 @@+Copyright (c) 2003, Henrik Nilsson, Antony Courtney and Yale University.+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 copyright holders 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 COPYRIGHT HOLDERS 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 COPYRIGHT+HOLDERS 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.
+ credits/base-4.12.0.0.txt view
@@ -0,0 +1,83 @@+This library (libraries/base) is derived from code from several+sources: ++  * Code from the GHC project which is largely (c) The University of+    Glasgow, and distributable under a BSD-style license (see below),++  * Code from the Haskell 98 Report which is (c) Simon Peyton Jones+    and freely redistributable (but see the full license for+    restrictions).++  * Code from the Haskell Foreign Function Interface specification,+    which is (c) Manuel M. T. Chakravarty and freely redistributable+    (but see the full license for restrictions).++The full text of these licenses is reproduced below.  All of the+licenses are BSD-style or compatible.++-----------------------------------------------------------------------------++The Glasgow Haskell Compiler License++Copyright 2004, The University Court of the University of Glasgow. +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.++-----------------------------------------------------------------------------++Code derived from the document "Report on the Programming Language+Haskell 98", is distributed under the following license:++  Copyright (c) 2002 Simon Peyton Jones++  The authors intend this Report to belong to the entire Haskell+  community, and so we grant permission to copy and distribute it for+  any purpose, provided that it is reproduced in its entirety,+  including this Notice.  Modified versions of this Report may also be+  copied and distributed for any purpose, provided that the modified+  version is clearly presented as such, and that it does not claim to+  be a definition of the Haskell 98 Language.++-----------------------------------------------------------------------------++Code derived from the document "The Haskell 98 Foreign Function+Interface, An Addendum to the Haskell 98 Report" is distributed under+the following license:++  Copyright (c) 2002 Manuel M. T. Chakravarty++  The authors intend this Report to belong to the entire Haskell+  community, and so we grant permission to copy and distribute it for+  any purpose, provided that it is reproduced in its entirety,+  including this Notice.  Modified versions of this Report may also be+  copied and distributed for any purpose, provided that the modified+  version is clearly presented as such, and that it does not claim to+  be a definition of the Haskell 98 Foreign Function Interface.++-----------------------------------------------------------------------------
+ credits/bjoern-2008-2009.txt view
@@ -0,0 +1,19 @@+Copyright (c) 2008-2009 Bjoern Hoehrmann <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.
+ credits/clock-0.7.2.txt view
@@ -0,0 +1,32 @@+Copyright (c) 2009-2012, Cetin Sert+Copyright (c) 2010, Eugene Kirpichov++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.++    * The names of contributors may not 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/foldl-1.4.5.txt view
@@ -0,0 +1,24 @@+Copyright (c) 2013 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/pipes-concurrency-2.0.8.txt view
@@ -0,0 +1,24 @@+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/pipes-concurrency.txt view
@@ -0,0 +1,24 @@+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/transient-0.5.5.txt view
@@ -0,0 +1,18 @@+Copyright © 2014-2016 Alberto G. Corona       <https://github.com/agocorona>
+
+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.
+ credits/vector-0.12.0.2.txt view
@@ -0,0 +1,30 @@+Copyright (c) 2008-2012, 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.+
docs/streamly-vs-async.md view
@@ -36,7 +36,7 @@ added on top.  However, if you would like to just run only some concurrent portions of your-program using streamly, you can do that too. Just use `runStream` if you want+program using streamly, you can do that too. Just use `drain` if you want to run the stream without collecting the outputs of the concurrent actions or use `toList` if you want to convert the output stream into a list.  Other stream folding operations can also be used, see the docs for more details.@@ -84,10 +84,10 @@  ### concurrently_ -Use `runStream` instead of `toList` to run the actions but ignore the results:+Use `drain` instead of `toList` to run the actions but ignore the results:  ```haskell-  runStream $ parallely $ getURL 1 |: getURL 2 |: S.nil+  S.drain $ parallely $ getURL 1 |: getURL 2 |: S.nil ```  ### Concurrent Applicative@@ -135,7 +135,7 @@   instance Exception Result    main = do-      url <- try $ runStream $ parallely $+      url <- try $ S.drain $ parallely $                    (getURL 2 >>= throwM . Result)                 |: (getURL 1 >>= throwM . Result)                 |: S.nil
+ docs/streamly-vs-lists.md view
@@ -0,0 +1,265 @@+# Streams are concurrent monadic lists++Streamly streams are a generalization of Haskell lists with a similar API with+two crucial additions:++* A list is a _pure sequence_ of values whereas a stream is a _monadic+  sequence_ of values i.e. a sequence of values generated by monadic actions.+* The monadic actions producing the sequence can be executed concurrently.+  Concurrency is declarative and can be switched on or off using an appropriate+  combinator.++## Pure Streams vs Monadic Streams++A list is a sequence of pure values or pure steps that produce a value on+evaluation.  Ideally, we want to process each element in the sequence through a+pipeline of processing stages without first accumulating all the elements in+the sequence. This style of processing is known as "streaming" and it runs in+constant memory because we do not accumulate elements in memory, data gets+consumed as soon as it is produced.  If all the processing stages are pure,+lists can be used in a streaming style processing. For example, this is+streaming style processing:++```+  replicate 10 1+    & zipWith (+) [1..10]+    & map (+1)+    & filter odd+    & sum+```++However, if a list is generated in a strict monad (e.g. IO) it cannot be+consumed in a streaming fashion as described above. In that case the full list+first gets accumulated and then processed. This means we will consume memory+proportional to the size of the list and therefore it becomes unusable for+large lists. For example, the following code accumulates `xs` before it+processes it:++```+  xs <- replicateM 10 (return 1)+  zipWith (+) [1..10] xs+    & map (+1)+    & filter odd+    & sum+```++Monadic streams solve this problem. To be able to consume elements from+`replicateM` as it produces them we need a monadic representation of the stream+and stream processing operations that can consume the stream elements lazily+one at a time. Streamly provides a monadic representation for lists with the+same API.  So we can represent the previous example in a streaming fashion by+replacing the list combinators with corresponding streamly combinators:++```+  S.replicateM 10 (return 1)+    & S.zipWith (+) (S.fromList [1..10])+    & S.map (+1)+    & S.filter odd+    & S.sum+```++Streamly's monadic streams are a generalization of pure streams (aka lists) and+therefore can represent pure streams just as easily, making lists a special+case.++## Streamly as lists++`SerialT Identity a` can be used in place of `[a]` with equivalent or better+performance and almost identical interface except a few differences. Use of+`OverloadedLists` extension can make the difference even less significant. +++### Construction++Lists are constructed using `[]` and `:`.++```+> "hello" : "world" : []+["hello","world"]+```++Pure streams are constructed using `S.nil` (corresponds to `[]`) and `S.cons`+or `.:` (corresponds to `:`):++```+import Streamly+import Streamly.Prelude ((.:))+import qualified Streamly.Prelude as S++> "hello" .: "world" .: S.nil :: SerialT Identity String+fromList ["hello","world"]+```++### Pattern Matching++The crucial difference is that lists are built using constructors whereas+streams are built using functions. `S.nil` and `S.cons` are functions.+Therefore, you cannot directly pattern match on streams.  However, the yet+unexposed `Streamly.List` module also provides `Nil` and `Cons` pattern+synonyms corresponding to the list `[]` and `:` constructors for pattern+matches.++### Pure Operations++`SerialT Identity a` is an instance of `Show`, `Read`, `Eq`, `Ord`, `IsList`,+`Foldable` and `Traversable` type classes. Furthermore, `SerialT Identity Char`+is an instance of `IsString`. Use of `OverloadedLists` and `OverloadedStrings`+can make the use of streams in place of lists quite convenient.++Along with these we can use combinators from `Streamly.Prelude` to perform all+list operations on pure streams.++Lists:++```+> replicate 10 1+> map (+1) $ replicate 10 1+> length $ replicate 10 1+```++Pure streams are almost identical:++```+> S.replicate 10 1 :: SerialT Identity Int+> S.map (+1) $ S.replicate 10 1 :: SerialT Identity Int+> length (S.replicate 10 1 :: SerialT Identity Int)+```++## Monadic Operations++Lists have great performance as long as we perform only pure operations on+them. When monadic operations are performed on lists, they may accumulate+potentially unbounded or large lists in memory degrading performance massively.++Such "unsafe" list operations exist in `Control.Monad`, `Data.Traversable`, and+`Data.Foldable` in `base`. They are typically found with an `M` suffix.++Streamly provides monadic streams and the equivalents of the above mentioned+monadic list operations work on streams without any issues.++Unsafe monadic operations involving lists, run these example with `+RTS -s`+options:++```+import Control.Monad+main = do+  xs <- replicateM 10000000 (pure 1)+  ys <- mapM (\x -> return $ x + 1) xs+  print $ length ys+```++Streams:++```+import Streamly+import qualified Streamly.Prelude as S+main = do+  n <- S.length+      $ S.mapM (\x -> return $ x + 1)+      $ S.replicateM 10000000 (pure 1)+  print n+```++## Splitting Operations++Another unsafe category of operations for lists is stream splitting operations+e.g. `lines`, `splitAt` and `group`. Such operations may also accumulate+unbounded data in memory.++Stream splitting operations in streamly are streaming in nature and can work+without accumulating any data in memory.++### Monadic Lists++Monadic streams are nothing but lists made monadic. We can construct streams+using monadic actions, just the way pure lists are constructed:++```+> import Streamly.Prelude ((|:))+> import qualified Streamly.Prelude as S+> S.toList $ getLine |: getLine |: S.nil+hello+world+["hello","world"]+```++`|:` is the monadic construction equivalent of `:`.+The monadic action `getLine` is executed twice in a sequence, the first one+gets "hello" and second one gets "world" from the terminal and a stream+consisting of those strings is produced.++## Concurrent Monadic Lists++Streamly streams are not just monadic lists but they are concurrent monadic+lists. All the monadic streaming operations provided by streamly are inherently+concurrent.  Concurrent behavior can be enabled by just using an appropriate+modifying combinator, without any other change to the code.++The following code prints one element every second:++```haskell+import Control.Concurrent+import Streamly+import qualified Streamly.Prelude as S++func = S.mapM (\x -> threadDelay 1000000 >> print x) $ S.replicate 10 1+main = runStream func+```++To run it concurrently, just run the same code with `asyncly` combinator:++```haskell+main = runStream $ asyncly func+```++The `mapM` combinator now maps the monadic delay action concurrently on all the+stream elements.  It prints all the 10 elements after one second because all+the delay actions run concurrently. Alternatively we can write:++```+func = S.mapM $ asyncly $ S.replicateM (threadDelay 1000000 >> print 1)+main = runStream func+```++Here, the `replicateM` operation replicates the action concurrently.  In real+applications this could be a request to a web server that you may want to+perform multiple times concurrently.++## Performance: Streamly vs Lists++The following figures show the ratio of time and memory consumed by `[Int]`+(`base-4.12`) vs `SerialT Identity Int`+([streamly@00c7613](https://github.com/composewell/streamly)) for exactly the+same operation. `5x` on the y axis means lists take 5 times more resources+compared to streamly. Whereas a `1/5x` means that lists take 5 times less+resources compared to streamly. We only show those operations that are at least+10% better or worse in one library compared to the other. The operations are+shown in a sorted order, from list's worst performing ones on the left to its+best ones on the right.++![Streamly vs Lists (time) comparison](../charts-0/streamly-vs-list-time.svg)++## Why use streams instead of lists?++By using monadic streams instead of lists you get the following benefits:++* Use just one library for pure or monadic lists. There is no difference in+  pure or monadic code, its all the same.+* You can use a monadic action anywhere in the code e.g. printing a warning or+  error message or any other effectful operations. This is not possible in pure+  list code.+* You can make the code concurrent whenever you want without having to modify+  it.+* You do not have the risk of using unsafe/accumulating list operations+  degrading performance massively and resulting in space leaks.+* Streamly provides safe versions of partial list functions like `head`, `tail`+  etc.+* You get better fusion and therefore better performance for many operations,+  the only operation which is significantly faster for lists is `concatMap`.++## References++* [Data.List](https://hackage.haskell.org/package/base/docs/Data-List.html)+* [Control.Monad](http://hackage.haskell.org/package/base/docs/Control-Monad.html)+* [Data.Foldable](http://hackage.haskell.org/package/base/docs/Data-Foldable.html)+* [Data.Traversable](http://hackage.haskell.org/package/base/docs/Data-Traversable.html)
docs/transformers.md view
@@ -6,7 +6,7 @@  The semantics of monads other than `ReaderT` with concurrent streams are not yet finalized and will change in future, therefore as of now they are not-recommended to be used.+recommended to be used with concurrent streams.  ## Ordering of Monad Transformers
examples/AcidRain.hs view
@@ -1,5 +1,8 @@ {-# LANGUAGE FlexibleContexts #-} +-- Copyright   : (c) 2017 Harendra Kumar+--               (c) 2013, 2014 Gabriel Gonzalez+-- -- This example is adapted from Gabriel Gonzalez's pipes-concurrency package. -- https://hackage.haskell.org/package/pipes-concurrency-2.0.8/docs/Pipes-Concurrent-Tutorial.html @@ -51,5 +54,5 @@ main = do     putStrLn "Your health is deteriorating due to acid rain,\              \ type \"potion\" or \"quit\""-    let runGame = S.runWhile (== Alive) $ S.mapM getStatus runEvents+    let runGame = S.drainWhile (== Alive) $ S.mapM getStatus runEvents     void $ runStateT runGame 60
+ examples/CamelCase.hs view
@@ -0,0 +1,33 @@+-- ghc -O2  -fspec-constr-recursive=10 -fmax-worker-args=16+-- Convert the input file to camel case and write to stdout++import Data.Maybe (fromJust, isJust)+import System.Environment (getArgs)+import System.IO (Handle, IOMode(..), openFile, stdout)++import qualified Streamly.Prelude as S+import qualified Streamly.Internal.FileSystem.Handle as FH++camelCase :: Handle -> Handle -> IO ()+camelCase src dst =+      FH.fromBytes dst+    $ S.map fromJust+    $ S.filter isJust+    $ S.map snd+    $ S.scanl' step (True, Nothing)+    $ FH.toBytes src++    where++    step (wasSpace, _) x =+        if x == 0x0a || x >= 0x41 && x <= 0x5a+        then (False, Just x)+        else if x >= 0x61 && x <= 0x7a+             then (False, Just $ if wasSpace then x - 32 else x)+             else (True, Nothing)++main :: IO ()+main = do+    name <- fmap head getArgs+    src <- openFile name ReadMode+    camelCase src stdout
examples/CirclingSquare.hs view
@@ -78,6 +78,6 @@ main = do     sdlInit     cref <- newIORef (0,0)-    runStream $ asyncly $ constRate 40+    S.drain $ asyncly $ constRate 40         $ S.repeatM (updateController cref)               `parallel` S.repeatM (updateDisplay cref)
examples/ControlFlow.hs view
@@ -26,7 +26,6 @@ import Control.Monad.Trans.Except import Control.Monad.Trans.Cont import Streamly-import Streamly.Prelude ((|:)) import qualified Streamly.Prelude as S  -------------------------------------------------------------------------------@@ -40,7 +39,6 @@     :: ( IsStream t        , Monad m        , MonadTrans t-       , Applicative (t (MaybeT m))        , MonadIO (t (MaybeT m))        )     => t (MaybeT m) ()@@ -58,7 +56,7 @@  mainMaybeBelow :: IO () mainMaybeBelow = do-    r <- runMaybeT (runStream getSequenceMaybeBelow)+    r <- runMaybeT (S.drain getSequenceMaybeBelow)     case r of         Just _ -> putStrLn "Bingo"         Nothing -> putStrLn "Wrong"@@ -103,7 +101,6 @@     :: ( IsStream t        , MonadTrans t        , Monad m-       , MonadIO (t m)        , MonadIO (t (ExceptT String m))        )     => t (ExceptT String m) ()@@ -122,7 +119,7 @@ mainEitherBelow :: IO () mainEitherBelow = do     -- XXX Cannot lift catchE-    r <- runExceptT (runStream getSequenceEitherBelow)+    r <- runExceptT (S.drain getSequenceEitherBelow)     case r of         Right _ -> liftIO $ putStrLn "Bingo"         Left s  -> liftIO $ putStrLn s@@ -137,8 +134,6 @@     :: ( IsStream t        , MonadTrans t        , MonadIO m-       , MonadAsync m-       , MonadIO (t m)        , MonadIO (t (ExceptT String m))        , Semigroup (t (ExceptT String m) Integer)        )@@ -155,7 +150,7 @@  mainEitherAsyncBelow :: IO () mainEitherAsyncBelow = do-    r <- runExceptT (runStream $ asyncly getSequenceEitherAsyncBelow)+    r <- runExceptT (S.drain $ asyncly getSequenceEitherAsyncBelow)     case r of         Right _ -> liftIO $ putStrLn "Bingo"         Left s  -> liftIO $ putStrLn s@@ -172,7 +167,7 @@ -- -- Here we can use catchE directly but will have to use monad-control to lift -- stream operations with stream arguments.-getSequenceEitherAbove :: (IsStream t, Monad m, MonadIO (t m))+getSequenceEitherAbove :: (IsStream t, MonadIO (t m))     => ExceptT String (t m) () getSequenceEitherAbove = do     liftIO $ putStrLn "ExceptT above streamly: Enter one char per line: "@@ -186,8 +181,7 @@     r2 <- liftIO getLine     when (r2 /= "y") $ throwE $ "Expecting y got: " <> r2 -mainEitherAbove :: (IsStream t, Monad m, MonadIO (t m))-    => ExceptT String (t m) ()+mainEitherAbove :: (IsStream t, MonadIO (t m)) => ExceptT String (t m) () mainEitherAbove =     catchE (getSequenceEitherAbove >> liftIO (putStrLn "Bingo"))            (liftIO . putStrLn)@@ -203,7 +197,7 @@ -- Note that unlike when ExceptT is used on top, MonadThrow terminates all -- iterations of non-determinism rather then just the current iteration. ---getSequenceMonadThrow :: (IsStream t, Monad m, MonadIO (t m), MonadThrow (t m))+getSequenceMonadThrow :: (IsStream t, MonadIO (t m), MonadThrow (t m))     => t m () getSequenceMonadThrow = do     liftIO $ putStrLn "MonadThrow in streamly: Enter one char per line: "@@ -219,7 +213,7 @@  mainMonadThrow :: IO () mainMonadThrow =-    catch (runStream getSequenceMonadThrow >> liftIO (putStrLn "Bingo"))+    catch (S.drain getSequenceMonadThrow >> liftIO (putStrLn "Bingo"))           (\(e :: SomeException) -> liftIO $ print e)  -------------------------------------------------------------------------------@@ -266,7 +260,7 @@ -- Using ContT above streamly ------------------------------------------------------------------------------- ---getSequenceContAbove :: (IsStream t, Monad m, MonadIO (t m))+getSequenceContAbove :: (IsStream t, MonadIO (t m))     => ContT r (t m) (Either String ()) getSequenceContAbove = do     liftIO $ putStrLn "ContT above streamly: Enter one char per line: "@@ -285,7 +279,7 @@         then exit $ Left $ "Expecting y got: " <> r2         else return $ Right () -mainContAbove :: (IsStream t, Monad m, MonadIO (t m)) => ContT r (t m) ()+mainContAbove :: (IsStream t, MonadIO (t m)) => ContT r (t m) () mainContAbove = do     r <- getSequenceContAbove     case r of@@ -300,10 +294,10 @@ main :: IO () main = do     mainMaybeBelow-    runStream $ runMaybeT mainMaybeAbove-    runContT (runStream mainContBelow) return-    runStream (runContT mainContAbove return)+    S.drain $ runMaybeT mainMaybeAbove+    runContT (S.drain mainContBelow) return+    S.drain (runContT mainContAbove return)     mainEitherBelow-    runStream (runExceptT mainEitherAbove)+    S.drain (runExceptT mainEitherAbove)     mainMonadThrow     mainEitherAsyncBelow
+ examples/EchoServer.hs view
@@ -0,0 +1,19 @@+-- A concurrent TCP server that echoes everything that it receives.++import Control.Exception (finally)+import Control.Monad.IO.Class (liftIO)+import Streamly+import Streamly.Network.Socket+import qualified Network.Socket as Net+import qualified Streamly.Network.Inet.TCP as TCP+import qualified Streamly.Prelude as S++main :: IO ()+main = S.drain+    $ parallely $ S.mapM (useWith echo)+    $ serially $ S.unfold TCP.acceptOnPort 8091+    where+    echo sk =+          S.fold (writeChunks sk)+        $ S.unfold readChunksWithBufferOf (32768, sk)+    useWith f sk = finally (f sk) (liftIO (Net.close sk))
+ examples/FileIOExamples.hs view
@@ -0,0 +1,65 @@+import qualified Streamly.Prelude as S+import qualified Streamly.Data.Fold as FL+import qualified Streamly.Memory.Array as A++import qualified Streamly.Internal.Data.Fold as FL+import qualified Streamly.Internal.Prelude as IP+import qualified Streamly.Internal.FileSystem.File as File++import Data.Char (ord)+import System.Environment (getArgs)++cat :: FilePath -> IO ()+cat src =+      File.fromChunks "/dev/stdout"+    $ File.toChunksWithBufferOf (256*1024) src++cp :: FilePath -> FilePath -> IO ()+cp src dst =+      File.fromChunks dst+    $ File.toChunksWithBufferOf (256*1024) src++append :: FilePath -> FilePath -> IO ()+append src dst =+      File.appendChunks dst+    $ File.toChunksWithBufferOf (256*1024) src++ord' :: Num a => Char -> a+ord' = (fromIntegral . ord)++wcl :: FilePath -> IO ()+wcl src = print =<< (S.length+    $ S.splitOnSuffix (== ord' '\n') FL.drain+    $ File.toBytes src)++grepc :: String -> FilePath -> IO ()+grepc pat src = print . (subtract 1) =<< (S.length+    $ IP.splitOnSeq (A.fromList (map ord' pat)) FL.drain+    $ File.toBytes src)++avgll :: FilePath -> IO ()+avgll src = print =<< (S.fold avg+    $ S.splitOnSuffix (== ord' '\n') FL.length+    $ File.toBytes src)+    where avg = (/) <$> toDouble FL.sum <*> toDouble FL.length+          toDouble = fmap (fromIntegral :: Int -> Double)++llhisto :: FilePath -> IO ()+llhisto src = print =<< (S.fold (FL.classify FL.length)+    $ S.map bucket+    $ S.splitOnSuffix (== ord' '\n') FL.length+    $ File.toBytes src)+    where+    bucket n = let i = n `mod` 10 in if i > 9 then (9,n) else (i,n)++main :: IO ()+main = do+    src <- fmap head getArgs++    putStrLn "cat"    >> cat src              -- Unix cat program+    putStr "wcl "     >> wcl src              -- Unix wc -l program+    putStr "grepc "   >> grepc "aaaa" src     -- Unix grep -c program+    putStr "avgll "   >> avgll src            -- get average line length+    putStr "llhisto " >> llhisto src          -- get line length histogram+    putStr "cp "      >> cp src "dst-xyz.txt" -- Unix cp program+    putStr "append "  >> append src "dst-xyz.txt" -- Appending to file
+ examples/FileSinkServer.hs view
@@ -0,0 +1,38 @@+-- A concurrent TCP server that:+--+-- * receives connections from clients+-- * splits the incoming data into lines+-- * lines from concurrent connections are merged into a single srteam+-- * writes the line stream to an output file++import Control.Monad.IO.Class (liftIO)+import Network.Socket (close)+import System.Environment (getArgs)++import Streamly+import Streamly.Data.Unicode.Stream+import qualified Streamly.FileSystem.Handle as FH+import qualified Streamly.Memory.Array as A+import qualified Streamly.Network.Socket as NS+import qualified Streamly.Network.Inet.TCP as TCP+import qualified Streamly.Prelude as S++import System.IO (withFile, IOMode(..))++main :: IO ()+main = do+    file <- fmap head getArgs+    withFile file AppendMode+        (\src -> S.fold (FH.write src)+        $ encodeLatin1Lax+        $ S.concatUnfold A.read+        $ S.concatMapWith parallel use+        $ S.unfold TCP.acceptOnPort 8090)++    where++    use sk = S.finally (liftIO $ close sk) (recv sk)+    recv =+          S.splitWithSuffix (== '\n') A.write+        . decodeLatin1+        . S.unfold NS.read
+ examples/FromFileClient.hs view
@@ -0,0 +1,21 @@+-- A TCP client that does the following:+-- * Reads multiple filenames passed on the command line+-- * Opens as many concurrent connections to the server+-- * Sends all the files concurrently to the server++import System.Environment (getArgs)++import Streamly+import qualified Streamly.Prelude as S+import qualified Streamly.Internal.FileSystem.Handle as IFH+import qualified Streamly.Internal.Network.Inet.TCP as TCP++import System.IO (withFile, IOMode(..))++main :: IO ()+main =+    let sendFile file =+            withFile file ReadMode $ \src ->+                  S.fold (TCP.writeChunks (127, 0, 0, 1) 8090)+                $ IFH.toChunks src+     in getArgs >>= S.drain . parallely . S.mapM sendFile . S.fromList
+ examples/HandleIO.hs view
@@ -0,0 +1,81 @@+import qualified Streamly.Prelude as S+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.FileSystem.FD as FH+-- import qualified Streamly.Data.Unicode.Stream as US++import qualified Streamly.Internal.Data.Fold as FL+import qualified Streamly.Internal.Memory.ArrayStream as AS+import qualified Streamly.Internal.FileSystem.Handle as IFH++import Data.Char (ord)+import System.Environment (getArgs)+import System.IO (IOMode(..), hSeek, SeekMode(..))++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++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++ord' :: Num a => Char -> a+ord' = (fromIntegral . ord)++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)+-}++{-+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)+-}++avgll :: FH.Handle -> IO ()+avgll src = print =<< (S.fold avg+    $ S.splitWithSuffix (== ord' '\n') FL.length+    $ S.unfold FH.read src)+    where avg = (/) <$> toDouble FL.sum <*> toDouble FL.length+          toDouble = fmap (fromIntegral :: Int -> Double)++llhisto :: FH.Handle -> IO ()+llhisto src = print =<< (S.fold (FL.classify FL.length)+    $ S.map bucket+    $ S.splitWithSuffix (== ord' '\n') FL.length+    $ S.unfold FH.read src)+    where+    bucket n = let i = n `mod` 10 in if i > 9 then (9,n) else (i,n)++main :: IO ()+main = do+    name <- fmap head getArgs+    src <- FH.openFile name ReadMode+    let rewind = hSeek src AbsoluteSeek 0++    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 "avgll "   >> avgll src        -- get average line length+    rewind >> putStr "llhisto " >> llhisto src      -- get line length histogram++    dst <- FH.openFile "dst-xyz.txt" WriteMode+    rewind >> putStr "cp " >> cp src dst       -- Unix cp program
examples/ListDir.hs view
@@ -1,18 +1,31 @@-import Control.Monad.IO.Class (liftIO)-import Path.IO (listDir, getCurrentDir) import System.IO (stdout, hSetBuffering, BufferMode(LineBuffering))-import Streamly (runStream, aheadly, (<>))+import Streamly (aheadly, ahead, AheadT)+import Data.Function ((&)) +import qualified Streamly.Prelude as S+import qualified Streamly.Internal.FileSystem.Dir as Dir+ -- | List the current directory recursively using concurrent processing ----- This example demonstrates that there is little difference between regular--- IO code and concurrent streamly code. You can just remove--- 'runStream . aheadly' and this becomes your regular IO code. main :: IO () main = do     hSetBuffering stdout LineBuffering-    runStream . aheadly $ getCurrentDir >>= readdir-    where readdir d = do-            (ds, fs) <- listDir d-            liftIO $ mapM_ putStrLn $ fmap show fs <> fmap show ds-            foldMap readdir ds+    S.mapM_ print $ aheadly $ recursePath (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
examples/SearchQuery.hs view
@@ -1,5 +1,5 @@ import Streamly-import Streamly.Prelude (nil, yieldM, (|:))+import Streamly.Prelude (drain, nil, yieldM, (|:)) import Network.HTTP.Simple  -- | Runs three search engine queries in parallel and prints the search engine@@ -10,13 +10,13 @@ main :: IO () main = do     putStrLn "Using parallel stream construction"-    runStream . parallely $ google |: bing |: duckduckgo |: nil+    drain . parallely $ google |: bing |: duckduckgo |: nil      putStrLn "\nUsing parallel semigroup composition"-    runStream . parallely $ yieldM google <> yieldM bing <> yieldM duckduckgo+    drain . parallely $ yieldM google <> yieldM bing <> yieldM duckduckgo      putStrLn "\nUsing parallel applicative zip"-    runStream . zipAsyncly $+    drain . zipAsyncly $         (,,) <$> yieldM google <*> yieldM bing <*> yieldM duckduckgo      where
+ examples/WordClassifier.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+#if __GLASGOW_HASKELL__ >= 800+{-# OPTIONS_GHC -Wno-orphans #-}+#endif+-- compile with:+-- ghc -O2 -fspec-constr-recursive=10 -fmax-worker-args=16 word-classifier.hs+--+import qualified Data.Char as Char+import           Data.Foldable+import           Data.Function ((&))+import           Data.Functor.Identity (Identity(..))+import qualified Data.HashMap.Strict as Map+import           Data.Hashable+import           Data.IORef+import qualified Data.List as List+import qualified Data.Ord as Ord+import           Foreign.Storable (Storable(..))+import qualified Streamly.Data.Unicode.Stream as S+import qualified Streamly.Internal.Data.Unicode.Stream as S+import qualified Streamly.Data.Fold as FL+import qualified Streamly.Internal.Data.Fold as IFL+import qualified Streamly.Internal.Data.Unfold as IUF+import qualified Streamly.Internal.FileSystem.File as File+import qualified Streamly.Memory.Array as A+import qualified Streamly.Prelude as S+import           System.Environment (getArgs)++instance (Enum a, Storable a) => Hashable (A.Array a) where+    hash arr = runIdentity $ IUF.fold A.read IFL.rollingHash arr+    hashWithSalt salt arr = runIdentity $+        IUF.fold A.read (IFL.rollingHashWithSalt salt) arr++{-# INLINE toLower #-}+toLower :: Char -> Char+toLower c+  | uc >= 0x61 && uc <= 0x7a = c+  | otherwise = Char.toLower c+  where+    uc = fromIntegral (Char.ord c) :: Word++{-# INLINE isAlpha #-}+isAlpha :: Char -> Bool+isAlpha c+  | uc >= 0x61 && uc <= 0x7a = True+  | otherwise = Char.isAlpha c+  where+    uc = fromIntegral (Char.ord c) :: Word++main :: IO ()+main = do+    inFile <- fmap head getArgs++    -- Write the stream to a hashmap consisting of word counts+    mp <-+        let+            alter Nothing    = fmap Just $ newIORef (1 :: Int)+            alter (Just ref) = modifyIORef' ref (+ 1) >> return (Just ref)+        in File.toBytes inFile    -- SerialT IO Word8+         & S.decodeLatin1         -- SerialT IO Char+         & S.map toLower          -- SerialT IO Char+         & S.words FL.toList      -- SerialT IO String+         & S.filter (all isAlpha) -- SerialT IO String+         & S.foldlM' (flip (Map.alterF alter)) Map.empty -- IO (Map String (IORef Int))++    -- Print the top hashmap entries+    counts <-+        let readRef (w, ref) = do+                cnt <- readIORef ref+                return (w, cnt)+         in Map.toList mp+          & mapM readRef++    traverse_ print $ List.sortOn (Ord.Down . snd) counts+                    & List.take 25
+ examples/WordCount.hs view
@@ -0,0 +1,630 @@+-------------------------------------------------------------------------------+-- Fast, streaming and parallel word counting (wc) program.+-------------------------------------------------------------------------------+-- 1) On utf8 inputs the serial version is around 3x faster than MacOS wc+-- 2) It can run parallely on multiple cores providing further speedup+-- 3) Parallel version works efficiently on stdin/streaming input as well+-- 4) Parallel version handles utf8 input correctly (including multi-byte space+--    chars) and gives the same output as the serial version on all inputs.+-- 5) There may be differences in word/char counts when there are invalid utf8+--    byte sequences present in the input because of different styles of error+--    handling.++-------------------------------------------------------------------------------+-- Build with the following options:+-------------------------------------------------------------------------------+-- streamly optimization plugin is required for best performance+-- ghc -O2 -fplugin Plugin -fspec-constr-recursive=10 -fmax-worker-args=16+-- For concurrent version add: -threaded -with-rtsopts "-N"++-------------------------------------------------------------------------------+-- Comparing with "wc -mwl" command:+-------------------------------------------------------------------------------+--+-- 1) To enable UTF8 with wc: export LANG=en_US.UTF-8; export LC_ALL=$LANG+-- 2) To test whether it is acutally using utf8, copy and paste this string+-- "U+1680 U+2000 U+2001 U+2002" and run "wc -mwl" on this. Without proper UTF8+-- handling word count would be 1, with proper UTF8 handling word count would+-- be 4. Note that the spaces in this string are not regular space chars they+-- are different unicode space chars.++{-# LANGUAGE CPP #-}++import Control.Monad (when)+import Data.Char (isSpace)+import Data.Word (Word8)+import GHC.Conc (numCapabilities)+import System.Environment (getArgs)+import System.IO (Handle, openFile, IOMode(..))+import Streamly.Internal.Data.Unicode.Stream+       (DecodeState, DecodeError(..), CodePoint, decodeUtf8Either,+       resumeDecodeUtf8Either)++import qualified Streamly as S+import qualified Streamly.Data.Unicode.Stream as S+import qualified Streamly.FileSystem.Handle as FH+import qualified Streamly.Memory.Array as A+import qualified Streamly.Prelude as S+import qualified Data.Vector.Storable.Mutable as V++-------------------------------------------------------------------------------+-- Parallel char, line and word counting+-------------------------------------------------------------------------------++-- We process individual chunks in the stream independently and parallely and+-- the combine the chunks to combine what they have counted.+--+-------------------------------------------------------------------------------+-- Char counting+-------------------------------------------------------------------------------++-- To count chars each block needs the following:+--+-- -- | header | char counts | trailer |+--+-- header and trailer are incomplete utf8 byte sequences that may be combined+-- with the previous or the next block to complete them later.+--+-- The trailer may have one or more bytes in a valid utf8 sequence and is+-- expecting more bytes to complete the sequence. The header stores any+-- possible continuation from the previous block. It contains a maximum of 3+-- bytes which all must be non-starter bytes.+--+-- When two blocks are combined, the trailer of the first block is combined+-- with the header of the next block and then utf8 decoded. The combined+-- header+trailer may yield:+--+-- * Nothing - when there is no trailer and header+-- * All errors - when there is no trailer in the previous block, and there is+-- a header in the next block. In this case there is no starting char which+-- means all header bytes are errors.+-- * It can yield at most one valid character followed by 0, 1 or 2 errors.+--+-- We count an incomplete utf8 sequence of 2 or more bytes starting with a+-- valid starter byte as a single codepoint. Bytes not following a valid+-- starter byte are treated as individual codepoints for counting.+--+-------------------------------------------------------------------------------+-- Word counting+-------------------------------------------------------------------------------++-- For word counting we need the following in each block:+--+-- -- | header | startsWithSpace | word counts | endsWithSpace | trailer |+--+-- The word counts in individual blocks are performed assuming that the+-- previous char before the block is a space.+-- When combining two blocks, after combining the trailer of previous blocks+-- with the header of the next we determine if the resulting char is a space or+-- not.+--+-- 1) If there is no new char joining the two blocks then we use endsWithSpace+-- of the previous block and startsWithSpace of the next block to determine if+-- the word counts are to be adjusted. If the previous block ends with+-- non-space and the next block starts with non-space we need to decrement the+-- word count by one if it is non-zero in the next block.+--+-- 2) If the new joining char is a space then we combine it with+-- startsWithSpace and endsWithSpace to determine the+-- startsWithSpace/endsWithSpace of the combined block and adjust the word+-- counts appropriately.+--+-------------------------------------------------------------------------------+-- Line counting+-------------------------------------------------------------------------------++-- Line counting is performed by counting "\n" in the stream. No new "\n" can+-- result from patching the trailer and header as it is always a single byte.++-------------------------------------------------------------------------------+-- Counting state+-------------------------------------------------------------------------------++-- We use a mutable vector for the counting state. A fold using an immutable+-- structure for such a large state does not perform well.  However, mutability+-- is confined to just the accumulator.+--+-- XXX we need convenient mutable records (like C structs) to handle things+-- like this. It may be possible to achieve the same performance with an+-- immutable accumulator, but that will require more research. Since we are+-- always discarding the previous state, we can perhaps make use of that memory+-- using safe in-place modifications, without having to allocate new memory.++-- XXX we can also count the number of decoding errors separately+data Field =+    -- The number of "\n" characters found in the block.+      LineCount+    -- Number of full words found in the block, words are counted on a+    -- transition from space char to a non-space char. We always assume the+    -- char before the first starter char in a block is a space. If this is+    -- found to be incorrect when joining two blocks then we fix the counts+    -- accordingly.+    | WordCount+    -- The number of successfully decoded characters plus the number of+    -- decoding failures in the block. Each byte or sequence of bytes on which+    -- decoding fails is also counted as one char. The header and trailer bytes+    -- are not accounted in this, they are accounted only when we join two+    -- blocks.+    | CharCount+    -- whether the last counted char in this block was a space char+    | WasSpace+    -- whether the first successfully decoded char in this block is a space. A+    -- decoding failure, after the trailing bytes from the previous block are+    -- accounted, is also considered as space.+    | FirstIsSpace+    -- If no starter byte is found in the first three bytes in the block then+    -- store those bytes to possibly combine them with the trailing incomplete+    -- byte sequence in the previous block. We mark it done when either we have+    -- stored three bytes or we have found a starter byte.+    --+    -- XXX This is ugly to manipulate, we can implement a statically max sized+    -- mutable ring structure within this record.+    | HeaderDone+    | HeaderWordCount+    | HeaderWord1+    | HeaderWord2+    | HeaderWord3+    -- If a byte sequence at the end of the block is not complete then store+    -- the current state of the utf8 decoder to continue it later using the+    -- incomplete leading byte sequence in the next block.+    | TrailerPresent+    | TrailerState+    | TrailerCodePoint+    deriving (Show, Enum, Bounded)++-------------------------------------------------------------------------------+-- Default/initial state of the block+-------------------------------------------------------------------------------++readField :: V.IOVector Int -> Field -> IO Int+readField v fld = V.read v (fromEnum fld)++writeField :: V.IOVector Int -> Field -> Int -> IO ()+writeField v fld val = V.write v (fromEnum fld) val++modifyField :: V.IOVector Int -> Field -> (Int -> Int) -> IO ()+modifyField v fld f = V.modify v f (fromEnum fld)++newCounts :: IO (V.IOVector Int)+newCounts = do+    counts <- V.new (fromEnum (maxBound :: Field) + 1)+    writeField counts LineCount 0+    writeField counts WordCount 0+    writeField counts CharCount 0+    writeField counts WasSpace 1+    writeField counts FirstIsSpace 0+    writeField counts HeaderDone 0+    writeField counts HeaderWordCount 0+    writeField counts TrailerPresent 0+    return counts++-------------------------------------------------------------------------------+-- Counting chars+-------------------------------------------------------------------------------++accountChar :: V.IOVector Int -> Bool -> IO ()+accountChar counts isSp = do+    c <- readField counts CharCount+    let space = if isSp then 1 else 0+    when (c == 0) $ writeField counts FirstIsSpace space+    writeField counts CharCount (c + 1)+    writeField counts WasSpace space++-------------------------------------------------------------------------------+-- Manipulating the header bytes+-------------------------------------------------------------------------------++addToHeader :: V.IOVector Int -> Int -> IO Bool+addToHeader counts cp = do+    cnt <- readField counts HeaderWordCount+    case cnt of+        0 -> do+            writeField counts HeaderWord1 cp+            writeField counts HeaderWordCount 1+            return True+        1 -> do+            writeField counts HeaderWord2 cp+            writeField counts HeaderWordCount 2+            return True+        2 -> do+            writeField counts HeaderWord3 cp+            writeField counts HeaderWordCount 3+            writeField counts HeaderDone 1+            return True+        _ -> return False++resetHeaderOnNewChar :: V.IOVector Int -> IO ()+resetHeaderOnNewChar counts = do+    hdone <- readField counts HeaderDone+    when (hdone == 0) $ writeField counts HeaderDone 1++-------------------------------------------------------------------------------+-- Manipulating the trailer+-------------------------------------------------------------------------------++setTrailer :: V.IOVector Int -> DecodeState -> CodePoint -> IO ()+setTrailer counts st cp = do+    writeField counts TrailerState (fromIntegral st)+    writeField counts TrailerCodePoint cp+    writeField counts TrailerPresent 1++resetTrailerOnNewChar :: V.IOVector Int -> IO ()+resetTrailerOnNewChar counts = do+    trailer <- readField counts TrailerPresent+    when (trailer /= 0) $ do+        writeField counts TrailerPresent 0+        accountChar counts True++-------------------------------------------------------------------------------+-- Counting the stream+-------------------------------------------------------------------------------++{-# INLINE countChar #-}+countChar :: V.IOVector Int -> Either DecodeError Char -> IO ()+countChar counts inp =+    case inp of+        Right ch -> do+            resetHeaderOnNewChar counts+            -- account the last stored error as whitespace and clear it+            resetTrailerOnNewChar counts++            when (ch == '\n') $ modifyField counts LineCount (+ 1)+            if isSpace ch+            then accountChar counts True+            else do+                wasSpace <- readField counts WasSpace+                when (wasSpace /= 0) $ modifyField counts WordCount (+ 1)+                accountChar counts False+        Left (DecodeError st cp) -> do+            hdone <- readField counts HeaderDone+            if hdone == 0+            then do+                if st == 0+                then do+                    -- We got a non-starter in initial decoder state, there may+                    -- be something that comes before this to complete it.+                    r <- addToHeader counts cp+                    when (not r) $ error "countChar: Bug addToHeader failed"+                else do+                    -- We got an error in a non-initial decoder state, it may+                    -- be an input underflow error, keep it as incomplete in+                    -- the trailer.+                    writeField counts HeaderDone 1+                    setTrailer counts st cp+            else do+                    resetTrailerOnNewChar counts+                    if st == 0+                    then accountChar counts True+                    else setTrailer counts st cp++printCounts :: V.IOVector Int -> IO ()+printCounts v = do+    l <- readField v LineCount+    w <- readField v WordCount+    c <- readField v CharCount+    putStrLn $ show l ++ " " ++ show w ++  " " ++ show c++-------------------------------------------------------------------------------+-- Serial counting using parallel version of countChar+-------------------------------------------------------------------------------++_wc_mwl_parserial :: Handle -> IO (V.IOVector Int)+_wc_mwl_parserial src = do+    counts <- newCounts+    S.mapM_ (countChar counts)+        $ decodeUtf8Either+        $ S.unfold FH.read src+    return counts++-------------------------------------------------------------------------------+-- Serial word counting with UTF-8 handling+-------------------------------------------------------------------------------++data Counts = Counts !Int !Int !Int !Bool deriving Show++{-# INLINE countCharSerial #-}+countCharSerial :: Counts -> Char -> Counts+countCharSerial (Counts l w c wasSpace) ch =+    let l1 = if (ch == '\n') then l + 1 else l+        (w1, wasSpace1) =+            if (isSpace ch)+            then (w, True)+            else (if wasSpace then w + 1 else w, False)+    in (Counts l1 w1 (c + 1) wasSpace1)++-- Note: This counts invalid byte sequences are non-space chars+_wc_mwl_serial :: Handle -> IO ()+_wc_mwl_serial src = print =<< (+      S.foldl' countCharSerial (Counts 0 0 0 True)+    $ S.decodeUtf8Lax+    $ S.unfold FH.read src)++-------------------------------------------------------------------------------+-- Parallel counting+-------------------------------------------------------------------------------++-- XXX we need a better data structure to store the header bytes to make these+-- routines simpler.+--+-- combine trailing bytes in preceding block with leading bytes in the next+-- block and decode them into a codepoint+reconstructChar :: Int+                -> V.IOVector Int+                -> V.IOVector Int+                -> IO (S.SerialT IO (Either DecodeError Char))+reconstructChar hdrCnt v1 v2 = do+    when (hdrCnt > 3 || hdrCnt < 0) $ error "reconstructChar: hdrCnt > 3"+    stream1 <-+        if (hdrCnt > 2)+        then do+            x <- readField v2 HeaderWord3+            return $ (fromIntegral x :: Word8) `S.cons` S.nil+        else return S.nil+    stream2 <-+        if (hdrCnt > 1)+        then do+            x <- readField v2 HeaderWord2+            return $ fromIntegral x `S.cons` stream1+        else return stream1+    stream3 <-+        if (hdrCnt > 0)+        then do+            x <- readField v2 HeaderWord1+            return $ fromIntegral x `S.cons` stream2+        else return stream2++    state <- readField v1 TrailerState+    cp <- readField v1 TrailerCodePoint+    return $ resumeDecodeUtf8Either (fromIntegral state) cp stream3++getHdrChar :: V.IOVector Int -> IO (Maybe Int)+getHdrChar v = do+    hdrCnt <- readField v HeaderWordCount+    case hdrCnt of+        0 -> return Nothing+        1 -> do+            writeField v HeaderWordCount 0+            fmap Just $ readField v HeaderWord1+        2 -> do+            x1 <- readField v HeaderWord1+            x2 <- readField v HeaderWord2+            writeField v HeaderWord1 x2+            writeField v HeaderWordCount 1+            return $ Just x1+        3 -> do+            x1 <- readField v HeaderWord1+            x2 <- readField v HeaderWord2+            x3 <- readField v HeaderWord3+            writeField v HeaderWord1 x2+            writeField v HeaderWord2 x3+            writeField v HeaderWordCount 2+            return $ Just x1+        _ -> error "getHdrChar: Bug, hdrCnt not in range 0-3"++-- If the header of the first block is not done then combine the header+-- with the header of the next block.+combineHeaders :: V.IOVector Int -> V.IOVector Int -> IO ()+combineHeaders v1 v2 = do+    hdone1 <- readField v1 HeaderDone+    if hdone1 == 0+    then do+        res <- getHdrChar v2+        case res of+            Nothing -> return ()+            Just x -> do+                r <- addToHeader v1 x+                when (not r) $ error "combineHeaders: Bug, addToHeader failed"+    else return ()++-- We combine the contents of the second vector into the first vector, mutating+-- the first vector and returning it.+-- XXX This is a quick hack and can be refactored to reduce the size+-- and understandability considerably.+addCounts :: V.IOVector Int -> V.IOVector Int -> IO (V.IOVector Int)+addCounts v1 v2 = do+    hdone1 <- readField v1 HeaderDone+    hdone2 <- readField v2 HeaderDone+    hdrCnt2_0 <- readField v2 HeaderWordCount+    if hdone1 == 0 && (hdrCnt2_0 /= 0 || hdone2 /= 0)+    then do+        combineHeaders v1 v2+        if hdone2 == 0+        then return v1+        else do+            writeField v1 HeaderDone 1+            addCounts v1 v2+    else do+        trailerPresent2 <- readField v2 TrailerPresent+        trailerState2 <- readField v2 TrailerState+        trailerCodePoint2 <- readField v2 TrailerCodePoint+        if hdone1 == 0+        then error "addCounts: Bug, trying to add completely empty second block"+        else do+            l1 <- readField v1 LineCount+            w1 <- readField v1 WordCount+            c1 <- readField v1 CharCount+            wasSpace1 <- readField v1 WasSpace++            l2 <- readField v2 LineCount+            w2 <- readField v2 WordCount+            c2 <- readField v2 CharCount+            wasSpace2 <- readField v2 WasSpace+            firstIsSpace2 <- readField v2 FirstIsSpace+            hdrCnt2 <- readField v2 HeaderWordCount++            trailer1 <- readField v1 TrailerPresent+            if trailer1 == 0 -- no trailer in the first block+            then do+                -- header2, if any, complete or incomplete, is just invalid+                -- bytes, count them as whitespace+                let firstIsSpace2' = firstIsSpace2 /= 0 || hdrCnt2 /= 0+                w <-+                        if w2 /= 0 && wasSpace1 == 0 && not firstIsSpace2'+                        then return $ w1 + w2 - 1+                        else return $ w1 + w2+                writeField v1 LineCount (l1 + l2)+                writeField v1 WordCount w+                writeField v1 CharCount (c1 + c2 + hdrCnt2)++                when (c1 == 0) $ do+                    if c2 == 0 && hdrCnt2 /= 0+                    then writeField v1 FirstIsSpace 1+                    else writeField v1 FirstIsSpace firstIsSpace2++                if c2 == 0 && hdrCnt2 /= 0+                then writeField v1 WasSpace 1+                else writeField v1 WasSpace wasSpace2++                writeField v1 TrailerPresent trailerPresent2+                writeField v1 TrailerState trailerState2+                writeField v1 TrailerCodePoint trailerCodePoint2+                return v1+            else do+                if hdrCnt2 == 0+                then do+                    when (hdone2 /= 0) $ do -- empty and Done header+                        -- count trailer as whitespace, its counted as one char+                        -- Note: hdrCnt2 == 0 means either header is not done+                        -- or c2 /= 0+                        writeField v1 LineCount (l1 + l2)+                        writeField v1 WordCount (w1 + w2)+                        writeField v1 CharCount (c1 + c2 + 1)++                        when (c1 == 0) $ writeField v1 FirstIsSpace 1+                        if (c2 == 0)+                        then writeField v1 WasSpace 1+                        else writeField v1 WasSpace wasSpace2++                        writeField v1 TrailerPresent trailerPresent2+                        writeField v1 TrailerState trailerState2+                        writeField v1 TrailerCodePoint trailerCodePoint2+                    -- If header of the next block is not done we continue the+                    -- trailer from the previous block instead of treating it+                    -- as whitespace+                    return v1+                else do+                    -- join the trailing part of the first block with the+                    -- header of the next+                    decoded <- reconstructChar hdrCnt2 v1 v2+                    res <- S.uncons decoded+                    case res of+                        Nothing -> error "addCounts: Bug. empty reconstructed char"+                        Just (h, t) -> do+                            tlength <- S.length t+                            case h of+                                Right ch -> do+                                    -- If we have an error case after this+                                    -- char then that would be treated+                                    -- as whitespace+                                    let lcount = l1 + l2+                                        lcount1 = if (ch == '\n') then lcount + 1 else lcount+                                        wcount = w1 + w2+                                        firstSpace = isSpace ch+                                        wasSpace = firstSpace || tlength /= 0+                                        wcount1 =+                                            if wasSpace+                                            then wcount+                                            else if w2 == 0 || firstIsSpace2 /= 0+                                                 then wcount+                                                 else wcount - 1+                                    writeField v1 LineCount lcount1+                                    writeField v1 WordCount wcount1+                                    writeField v1 CharCount (c1 + c2 + 1 + tlength)++                                    when (c1 == 0) $+                                        writeField v1 FirstIsSpace+                                                   (if firstSpace then 1 else 0)++                                    if c2 == 0+                                    then do+                                        if wasSpace+                                        then writeField v1 WasSpace 1+                                        else writeField v1 WasSpace 0+                                    else writeField v1 WasSpace wasSpace2++                                    writeField v1 TrailerPresent trailerPresent2+                                    writeField v1 TrailerState trailerState2+                                    writeField v1 TrailerCodePoint trailerCodePoint2+                                    return v1+                                Left (DecodeError st cp) -> do+                                    -- if header was incomplete it may result+                                    -- in partially decoded char to be written+                                    -- as trailer. Check if the last error is+                                    -- an incomplete decode.+                                    r <- S.last t+                                    let (st', cp') =+                                            case r of+                                                Nothing -> (st, cp)+                                                Just lst -> case lst of+                                                    Right _ -> error "addCounts: Bug"+                                                    Left (DecodeError st1 cp1) -> (st1, cp1)+                                    if hdone2 == 0 && st' /= 12+                                    then do+                                        -- all elements before the last one must be errors+                                        writeField v1 CharCount (c1 + tlength)++                                        when (c1 == 0) $+                                            writeField v1 FirstIsSpace 1++                                        writeField v1 WasSpace 1++                                        writeField v1 TrailerState (fromIntegral st')+                                        writeField v1 TrailerCodePoint cp'+                                    else do+                                        -- all elements must be errors+                                        -- treat them as whitespace+                                        writeField v1 LineCount (l1 + l2)+                                        writeField v1 WordCount (w1 + w2)+                                        writeField v1 CharCount (c1 + c2 + tlength + 1)++                                        when (c1 == 0) $+                                            writeField v1 FirstIsSpace 1++                                        if c2 == 0+                                        then writeField v1 WasSpace 1+                                        else writeField v1 WasSpace wasSpace2++                                        writeField v1 TrailerPresent trailerPresent2+                                        writeField v1 TrailerState trailerState2+                                        writeField v1 TrailerCodePoint trailerCodePoint2+                                    return v1++-- Individual array processing is an isolated loop, fusing it with the bigger+-- loop may be counter productive.+{-# NOINLINE countArray #-}+countArray :: A.Array Word8 -> IO (V.IOVector Int)+countArray src = do+    counts <- newCounts+    S.mapM_ (countChar counts)+        $ decodeUtf8Either+        $ S.unfold A.read src+    return counts++{-# INLINE wc_mwl_parallel #-}+wc_mwl_parallel :: Handle -> Int -> IO (V.IOVector Int)+wc_mwl_parallel src n = do+    counts <- newCounts+    S.foldlM' addCounts counts+        $ S.aheadly+        $ S.maxThreads numCapabilities+        $ S.mapM (countArray)+        $ S.unfold FH.readChunksWithBufferOf (n, src)++-------------------------------------------------------------------------------+-- Main+-------------------------------------------------------------------------------++main :: IO ()+main = do+    name <- fmap head getArgs+    src <- openFile name ReadMode+    -- _wc_mwl_serial src -- Unix wc -l program+    -- printCounts =<< _wc_mwl_parserial src -- Unix wc -l program+    -- Using different sizes of chunks (1,2,3,4,5,10,128,256) is a good testing+    -- mechanism for parallel counting code.+    {-+    args <- getArgs+    let chunkSize = read $ args !! 1+    -}+    let chunkSize = 32 * 1024+    printCounts =<< wc_mwl_parallel src chunkSize  -- Unix wc -l program
src/Streamly.hs view
@@ -3,59 +3,56 @@ -- Copyright   : (c) 2017 Harendra Kumar -- -- License     : BSD3--- Maintainer  : harendra.kumar@gmail.com+-- Maintainer  : streamly@composewell.com -- Stability   : experimental -- Portability : GHC ----- The way a list represents a sequence of pure values, a stream represents a--- sequence of monadic actions. The monadic stream API offered by Streamly is--- very close to the Haskell "Prelude" pure lists' API, it can be considered as--- a natural extension of lists to monadic actions. Streamly streams provide--- concurrent composition and merging of streams. It can be considered as a--- concurrent list transformer. In contrast to the "Prelude" lists, merging or--- appending streams of arbitrary length is scalable and inexpensive.------ The basic stream type is 'Serial', it represents a sequence of IO actions,--- and is a 'Monad'.  The type 'SerialT' is a monad transformer that can--- represent a sequence of actions in an arbitrary monad. The type 'Serial' is--- in fact a synonym for @SerialT IO@.  There are a few more types similar to--- 'SerialT', all of them represent a stream and differ only in the--- 'Semigroup', 'Applicative' and 'Monad' compositions of the stream. 'Serial'--- and 'WSerial' types compose serially whereas 'Async' and 'WAsync'--- types compose concurrently. All these types can be freely inter-converted--- using type combinators without any cost. You can freely switch to any type--- of composition at any point in the program.  When no type annotation or--- explicit stream type combinators are used, the default stream type is--- inferred as 'Serial'.------ Here is a simple console echo program example:+-- Streamly is a general purpose programming framework using cocnurrent data+-- flow programming paradigm.  It can be considered as a generalization of+-- Haskell lists to monadic streaming with concurrent composition capability.+-- The serial stream type in streamly @SerialT m a@ is like the list type @[a]@+-- parameterized by the monad @m@. For example, @SerialT IO a@ is a moral+-- equivalent of @[a]@ in the IO monad.  Streams are constructed very much like+-- lists, except that they use 'nil' and 'cons' instead of '[]' and ':'. -- -- @--- > runStream $ S.repeatM getLine & S.mapM putStrLn+-- > import "Streamly"+-- > import "Streamly.Prelude" (cons, consM)+-- > import qualified "Streamly.Prelude" as S+-- >+-- > S.toList $ 1 \`cons` 2 \`cons` 3 \`cons` nil+-- [1,2,3] -- @ ----- For more details please see the "Streamly.Tutorial" module and the examples--- directory in this package.------ This module exports stream types, instances and some basic operations.--- Functionality exported by this module include:------ * Semigroup append ('<>') instances as well as explicit  operations for merging streams--- * Monad and Applicative instances for looping over streams--- * Zip Applicatives for zipping streams--- * Stream type combinators to convert between different composition styles--- * Some basic utilities to run and fold streams+-- Unlike lists, streams can be constructed from monadic effects: ----- See the "Streamly.Prelude" module for comprehensive APIs for construction,--- generation, elimination and transformation of streams.+-- @+-- > S.'toList' $ 'getLine' \`consM` 'getLine' \`consM` S.'nil'+-- hello+-- world+-- ["hello","world"]+-- @ ----- This module is designed to be imported unqualified:+-- Streams are processed just like lists, with list like combinators, except+-- that they are monadic and work in a streaming fashion.  Here is a simple+-- console echo program example: -- -- @--- import Streamly+-- > S.drain $ S.repeatM getLine & S.mapM putStrLn -- @+--+-- @SerialT Identity a@ is a moral equivalent of pure lists. Streamly utilizes+-- fusion for high performance, therefore, we can represent and process strings+-- as streams of 'Char', encode and decode the streams to/from UTF8 and+-- serialize them to @Array Word8@ obviating the need for special purpose+-- libraries like @bytestring@ and @text@.+--+-- For more details+-- please see the "Streamly.Tutorial" module and the examples directory in this+-- package.  {-# LANGUAGE CPP                       #-}+{-# LANGUAGE MultiParamTypeClasses     #-}  #if __GLASGOW_HASKELL__ >= 800 {-# OPTIONS_GHC -Wno-orphans #-}@@ -65,19 +62,60 @@  module Streamly     (+    -- -- * Concepts Overview+    -- -- ** Streams+    -- -- $streams++    -- -- ** Folds+    -- -- $folds++    -- -- ** Arrays+    -- -- $arrays++    -- * Module Overview+    -- $streamtypes++    -- * Type Synonyms       MonadAsync      -- * Stream transformers+    -- | A stream represents a sequence of pure or effectful actions. The+    -- `cons` and `consM` operations and the corresponding operators '.:' and+    -- '|:' can be used to join pure values or effectful actions in a sequence.+    -- The effects in the stream can be executed in many different ways+    -- depending on the type of stream. In other words, the behavior of 'consM'+    -- depends on the type of the stream.+    --+    -- There are three high level categories of streams, /spatially ordered/+    -- streams, /speculative/ streams and /time ordered/ streams. Spatially+    -- ordered streams, 'SerialT' and 'WSerialT', execute the effects in serial+    -- order i.e. one at a time and present the outputs of those effects to the+    -- consumer in the same order.  Speculative streams, 'AheadT', may execute+    -- many effects concurrently but present the outputs to the consumer in the+    -- specified spatial order.  Time ordered streams, 'AsyncT', 'WAsyncT' and+    -- 'ParallelT', may execute many effects concurrently and present the+    -- outputs of those effects to the consumer in time order i.e. as soon as+    -- the output is generated.+    --+    -- We described above how the effects in a sequence are executed for+    -- different types of streams. The behvavior of the 'Semigroup' and 'Monad'+    -- instances follow the behavior of 'consM'. Stream generation operations+    -- like 'repeatM' also execute the effects differently for different+    -- streams, providing a concurrent generation capability when used with+    -- stream types that execute effects concurrently. Similarly, effectful+    -- transformation operations like 'mapM' also execute the transforming+    -- effects differently for different types of streams.+     -- ** Serial Streams     -- $serial     , SerialT     , WSerialT -    -- ** Concurrent Lookahead Streams-    -- $lookahead+    -- ** Speculative Streams+    -- $ahead     , AheadT -    -- ** Concurrent Asynchronous Streams+    -- ** Asynchronous Streams     -- $async     , AsyncT     , WAsyncT@@ -88,8 +126,6 @@     , ZipSerialM     , ZipAsyncM -    -- * Running Streams-    , P.runStream     -- * Parallel Function Application     -- $application     , (|$)@@ -120,12 +156,6 @@     , maxRate     , constRate -    -- * Folding Containers of Streams-    -- $foldutils-    , foldWith-    , foldMapWith-    , forEachWith-     -- * Stream Type Adapters     -- $adapters     , IsStream ()@@ -150,11 +180,22 @@     , ZipSerial     , ZipAsync +    -- ** Folding Containers of Streams+    -- | These are variants of standard 'Foldable' fold functions that use a+    -- polymorphic stream sum operation (e.g. 'async' or 'wSerial') to fold a+    -- finite container of streams. Note that these are just special cases of+    -- the more general 'concatMapWith' operation.+    --+    , IP.foldWith+    , IP.foldMapWith+    , IP.forEachWith+     -- * Re-exports     , Semigroup (..)      -- * Deprecated     , Streaming+    , runStream     , runStreaming     , runStreamT     , runInterleavedT@@ -170,25 +211,161 @@     , zippingAsync     , (<=>)     , (<|)++    {-+    -- * Deprecated/Moved+    -- | These APIs have been moved to other modules+    , foldWith+    , foldMapWith+    , forEachWith+    -}     ) where  import Data.Semigroup (Semigroup(..))-import Streamly.SVar (MonadAsync, Rate(..))+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.Prelude import Streamly.Streams.Serial-import Streamly.Streams.StreamK hiding (runStream, serial)+import Streamly.Streams.StreamK hiding (serial) import Streamly.Streams.Zip  import qualified Streamly.Prelude as P+import qualified Streamly.Internal.Prelude as IP import qualified Streamly.Streams.StreamK as K --- XXX This should perhaps be moved to Prelude.+-- XXX provide good succinct examples of pipelining, merging, splitting ect.+-- below.+--+-- $streams+--+-- A program is expressed as a network of streams and folds. A stream is a+-- source or generator of data elements and a fold is a consumer of data elements that+-- reduces multiple input elements to a single value.+--+-- In the following example, a 'Word8' stream is generated by using+-- 'Streamly.FileSystem.Handle.read' on a file handle, then the+-- 'Streamly.Prelude.splitBySuffix' transformation splits the stream on+-- newlines (ascii value 10); it uses the 'Streamly.Data.Fold.drain' fold to reduce+-- the resulting lines to unit values (@()@), 'Streamly.Prelude.length' fold+-- then counts the unit elements in the resulting stream which gives us the+-- number of lines in the file:+--+-- > S.length $ S.splitOnSuffix FL.drain 10 $ FH.read fh+--+-- The following example folds the lines to arrays of 'Word8' using the+-- 'Streamly.Memory.Array.writeF' fold and then wraps the lines in square+-- brackets before writing them to standard output using+-- 'Streamly.FileSystem.Handle.write':+--+-- > wrapLine ln = S.fromList "[" <> A.read ln <> S.fromList "]\n"+-- > readLines = S.splitOnSuffix A.writeF 10+-- > FH.write stdout $ S.concatMap wrapLine $ readLines fh1+--+-- One stream can be appended after another:+--+-- > FH.write stdout $ S.concatMap wrapLine $ readLines fh1 <> readLines fh2+--+-- The following example reads two files concurrently, merges the lines from+-- the two streams and writes the resulting stream to another file:+--+-- > FH.write stdout $ S.concatMap wrapLine $ readLines fh1 `parallel` readLines fh2+--+-- There are many ways to generate, merge, zip, transform and fold data+-- streams.  Many transformations can be chained in a stream pipeline. See+-- "Streamly.Prelude" module for combinators to manipulate streams. +-- $folds+--+-- The way stream types in this module like 'SerialT' represent data sources,+-- the same way the 'Fold' type from "Streamly.Data.Fold" represents data sinks or+-- reducers of streams. Reducers can be combined to consume a stream source in+-- many ways. The simplest is to reduce a stream source using a fold e.g.:+--+-- > S.runFold FL.length $ S.enumerateTo 100+--+-- Folds are consumers of streams and can be used to split a stream into+-- multiple independent flows. Grouping transforms a stream by applying a fold+-- on segments of a stream, distributing applies multiple folds in parallel on+-- the same stream and combines them, partitioning sends different elements of+-- a stream to different folds, unzipping divides the elements of a stream into+-- parts and sends them through different folds. Parsers are nothing but a+-- particular type of folds. Transformations can be applied contravariantly on+-- the input of a fold.+--+-- @+--+--                             |---transform----Fold m a b--------|+-- ---stream m a-->transform-->|                                  |---f b c ...+--                             |---transform----Fold m a c--------|+--                             |                                  |+--                                        ...+-- @+--++-- $arrays+--+-- Streamly arrays (See "Streamly.Memory.Array") complement streams to provide an+-- efficient computing paradigm.  Streams are suitable for immutable+-- transformations of /potentially infinite/ data using /sequential access/ and+-- pipelined transformations whereas arrays are suitable for in-place+-- transformations of /necessarily finite/ data using /random access/. Streams+-- are synonymous with /sequential pipelined processing/ whereas arrays are+-- synonymous with /efficient buffering and random access/.+--+-- In general, a data processing pipeline reads data from some IO device, does+-- some processing on it and finally writes the output to another IO device.+-- Streams provide the overall framework of sequential processing pipeline in+-- which arrays are used as buffering elements in the middle.  In addition to+-- buffering in the middle, arrays can also be used at the boundaries of the+-- pipeline to efficiently interface with external storage systems like memory,+-- files and network.  If streams are the pipes in a water pipeline network+-- then arrays are like the storage tanks in the middle.  On the input side,+-- think of arrays as buckets to fetch water to feed the pipeline and on the+-- output side buckets to remove the processed water.+--+-- 'ByteString' data type from the 'bytestring' package and the 'Text' data+-- type from the 'text' package are special cases of arrays.  'ByteString' is+-- like @Array Word8@ and 'Text' is like @utf16@ encoded @Array Word8@.+-- Streamly arrays can be transformed as efficiently as @bytestring@ or @text@+-- by using stream operations on them.++-- Streams and arrays are equally important in computing. They are computing+-- duals of each other.++-- $streamtypes+-- The basic stream type is 'Serial', it represents a sequence of IO actions,+-- and is a 'Monad'.  The type 'SerialT' is a monad transformer that can+-- represent a sequence of actions in an arbitrary monad. The type 'Serial' is+-- in fact a synonym for @SerialT IO@.  There are a few more types similar to+-- 'SerialT', all of them represent a stream and differ only in the+-- 'Semigroup', 'Applicative' and 'Monad' compositions of the stream. 'Serial'+-- and 'WSerial' types compose serially whereas 'Async' and 'WAsync'+-- types compose concurrently. All these types can be freely inter-converted+-- using type combinators without any cost. You can freely switch to any type+-- of composition at any point in the program.  When no type annotation or+-- explicit stream type combinators are used, the default stream type is+-- inferred as 'Serial'.+--+-- This module exports stream types, instances and combinators for:+--+-- * converting between different stream types+-- * appending and concurrently merging streams+-- * Concurrency control+-- * Concurrent function application+-- * Stream rate control+--+-- This module is designed to be imported unqualified:+--+-- @+-- import Streamly+-- @+--+-- See the "Streamly.Prelude" module for APIs for construction,+-- generation, elimination and transformation of streams.+ ------------------------------------------------------------------------------ -- Eliminating a stream ------------------------------------------------------------------------------@@ -198,71 +375,175 @@ -- @since 0.1.0 {-# DEPRECATED runStreaming "Please use runStream instead." #-} runStreaming :: (Monad m, IsStream t) => t m a -> m ()-runStreaming = P.runStream . K.adapt+runStreaming = P.drain . K.adapt  -- | Same as @runStream@. -- -- @since 0.1.0 {-# DEPRECATED runStreamT "Please use runStream instead." #-} runStreamT :: Monad m => SerialT m a -> m ()-runStreamT = P.runStream+runStreamT = P.drain +-- | Same as "Streamly.Prelude.runStream".+--+{-# DEPRECATED runStream "Please use Streamly.Prelude.drain instead." #-}+runStream :: Monad m => SerialT m a -> m ()+runStream = P.drain+ -- | Same as @runStream . wSerially@. -- -- @since 0.1.0 {-# DEPRECATED runInterleavedT "Please use 'runStream . interleaving' instead." #-} runInterleavedT :: Monad m => WSerialT m a -> m ()-runInterleavedT = P.runStream . K.adapt+runInterleavedT = P.drain . K.adapt  -- | Same as @runStream . parallely@. -- -- @since 0.1.0 {-# DEPRECATED runParallelT "Please use 'runStream . parallely' instead." #-} runParallelT :: Monad m => ParallelT m a -> m ()-runParallelT = P.runStream . K.adapt+runParallelT = P.drain . K.adapt  -- | Same as @runStream . asyncly@. -- -- @since 0.1.0 {-# DEPRECATED runAsyncT "Please use 'runStream . asyncly' instead." #-} runAsyncT :: Monad m => AsyncT m a -> m ()-runAsyncT = P.runStream . K.adapt+runAsyncT = P.drain . K.adapt  -- | Same as @runStream . zipping@. -- -- @since 0.1.0 {-# DEPRECATED runZipStream "Please use 'runStream . zipSerially instead." #-} runZipStream :: Monad m => ZipSerialM m a -> m ()-runZipStream = P.runStream . K.adapt+runZipStream = P.drain . K.adapt  -- | Same as @runStream . zippingAsync@. -- -- @since 0.1.0 {-# DEPRECATED runZipAsync "Please use 'runStream . zipAsyncly instead." #-} runZipAsync :: Monad m => ZipAsyncM m a -> m ()-runZipAsync = P.runStream . K.adapt+runZipAsync = P.drain . K.adapt +{-+-- | Same as "Streamly.Prelude.foldWith".+--+{-# DEPRECATED foldWith "Please use Streamly.Prelude.foldWith instead." #-}+{-# INLINABLE foldWith #-}+foldWith :: (IsStream t, Foldable f)+    => (t m a -> t m a -> t m a) -> f (t m a) -> t m a+foldWith = P.foldWith++-- | Same as "Streamly.Prelude.foldMapWith".+--+{-# DEPRECATED foldMapWith "Please use Streamly.Prelude.foldMapWith instead." #-}+{-# 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 = P.foldMapWith++-- | Same as "Streamly.Prelude.forEachWith".+--+{-# DEPRECATED forEachWith "Please use Streamly.Prelude.forEachWith instead." #-}+{-# 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 = P.forEachWith+-}+ ------------------------------------------------------------------------------ -- Documentation ------------------------------------------------------------------------------  -- $serial ----- Serial streams compose serially or non-concurrently. In a composed stream,--- each action is executed only after the previous action has finished.  The two--- serial stream types 'SerialT' and 'WSerialT' differ in how they traverse the--- streams in a 'Semigroup' or 'Monad' composition.+-- When a stream consumer demands an element from a serial stream constructed+-- as @a \`consM` b \`consM` ... nil@, the action @a@ at the head of the stream+-- sequence is executed and the result is supplied to the consumer. When the+-- next element is demanded, the action @b@ is executed and its result is+-- supplied.  Thus, the effects are performed and results are consumed strictly+-- in a serial order.  Serial streams can be considered as /spatially ordered/+-- streams as the order of execution and consumption is the same as the spatial+-- order in which the actions are composed by the programmer.+--+-- Serial streams enforce the side effects as well as the results of the+-- actions to be in the same order in which the actions are added to the+-- stream.  Therefore, the semigroup operation for serial streams is not+-- commutative:+--+-- @+-- a <> b is not the same as b <> a+-- @+--+-- There are two serial stream types 'SerialT' and 'WSerialT'. The stream+-- evaluation of both the variants works in the same way as described above,+-- they differ only in the 'Semigroup' and 'Monad' implementaitons. +-- $ahead+--+-- When a stream consumer demands an element from a speculative stream+-- constructed as @a \`consM` b \`consM` ... nil@, the action @a@ at the head+-- of the stream is executed and the output of the action is supplied to the+-- consumer. However, in addition to the action at the head multiple actions+-- following it may also be executed concurrently and the results buffered.+-- When the next element is demanded it may be served from the buffer and we+-- may execute the next action in the sequence to keep the buffer adequately+-- filled.  Thus, the actions are executed concurrently but results consumed in+-- serial order just like serial streams.  `consM` can be used to fold an+-- infinite lazy container of effects, as the number of concurrent executions+-- is limited.+--+-- Similar to 'consM', the monadic stream generation (e.g. replicateM) and+-- transformation operations (e.g. mapM) on speculative streams can execute+-- multiple effects concurrently in a speculative manner.+--+-- 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.+--+-- Speculative streams enforce ordering of the results of actions in the stream+-- but the side effects are only partially ordered.  Therefore, the semigroup+-- operation for speculative streams is not commutative from the pure outputs+-- perspective but commutative from side effects perspective.+ -- $async ----- The async style streams execute actions asynchronously and consume the--- outputs as well asynchronously. In a composed stream, at any point of time--- more than one stream can run concurrently and yield elements.  The elements--- are yielded by the composed stream as they are generated by the constituent--- streams on a first come first serve basis.  Therefore, on each run the--- stream may yield elements in a different sequence depending on the delays--- introduced by scheduling.  The two async types 'AsyncT' and 'WAsyncT' differ--- in how they traverse streams in 'Semigroup' or 'Monad' compositions.+-- 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.+--+-- 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.+--+-- 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.+--+-- 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.+--+-- 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.  -- $zipping --@@ -302,12 +583,33 @@ -- $concurrency -- -- These combinators can be used at any point in a stream composition to set--- parameters to control the concurrency of the enclosed stream.  A parameter--- set at any point remains effective for any concurrent combinators used--- downstream until it is reset.  These control parameters have no effect on--- non-concurrent combinators in the stream, or on non-concurrent streams. They--- also do not affect 'Parallel' streams, as concurrency for 'Parallel' streams--- is always unbounded.+-- parameters to control the concurrency of the /argument stream/.  A control+-- parameter set at any point remains effective for any concurrent combinators+-- used in the argument stream until it is reset by using the combinator again.+-- These control parameters have no effect on non-concurrent combinators in the+-- stream, or on non-concurrent streams.+--+-- /Pitfall:/ Remember that 'maxBuffer' in the following example applies to+-- 'mapM' and any other combinators that may follow it, and it does not apply+-- to the combinators before it:+--+-- @+--  ...+--  $ maxBuffer 10+--  $ S.mapM ...+--  ...+-- @+--+-- If we use '&' instead of '$' the situation will reverse, in the following+-- example, 'maxBuffer' does not apply to 'mapM', it applies to combinators+-- that come before it, because those are the arguments to 'maxBuffer':+--+-- @+--  ...+--  & maxBuffer 10+--  & S.mapM ...+--  ...+-- @  -- $adapters --@@ -325,10 +627,3 @@ -- which specific type you are converting from or to. If you see a an -- @ambiguous type variable@ error then most likely you are using 'adapt' -- unnecessarily on polymorphic code.------- $foldutils------ These are variants of standard 'Foldable' fold functions that use a--- polymorphic stream sum operation (e.g. 'async' or 'wSerial') to fold a--- container of streams.
− src/Streamly/Atomics.hs 
@@ -1,82 +0,0 @@-{-# LANGUAGE CPP    #-}---- |--- Module      : Streamly.Atomics--- Copyright   : (c) 2018-2019 Composewell Technologies------ License     : BSD3--- Maintainer  : harendra.kumar@gmail.com--- Stability   : experimental--- Portability : GHC--module Streamly.Atomics-    (-      atomicModifyIORefCAS-    , atomicModifyIORefCAS_-    , writeBarrier-    , storeLoadBarrier-    )-where--import Data.IORef (IORef, atomicModifyIORef)-#ifdef ghcjs_HOST_OS-import Data.IORef (modifyIORef)-#else-import qualified Data.Atomics as A-#endif--#ifndef ghcjs_HOST_OS---- XXX Does it make sense to have replacements for atomicModifyIORef etc. on a--- single threaded system.------ Slightly faster version of CAS. Gained some improvement by avoiding the use--- of "evaluate" because we know we do not have exceptions in fn.-{-# INLINE atomicModifyIORefCAS #-}-atomicModifyIORefCAS :: IORef a -> (a -> (a,b)) -> IO b-atomicModifyIORefCAS ref fn = do-    tkt <- A.readForCAS ref-    loop tkt retries--    where--    retries = 25 :: Int-    loop _   0     = atomicModifyIORef ref fn-    loop old tries = do-        let (new, result) = fn $ A.peekTicket old-        (success, tkt) <- A.casIORef ref old new-        if success-        then return result-        else loop tkt (tries - 1)--{-# INLINE atomicModifyIORefCAS_ #-}-atomicModifyIORefCAS_ :: IORef t -> (t -> t) -> IO ()-atomicModifyIORefCAS_ = A.atomicModifyIORefCAS_--{-# INLINE writeBarrier #-}-writeBarrier :: IO ()-writeBarrier = A.writeBarrier--{-# INLINE storeLoadBarrier #-}-storeLoadBarrier :: IO ()-storeLoadBarrier = A.storeLoadBarrier--#else--{-# INLINE atomicModifyIORefCAS #-}-atomicModifyIORefCAS :: IORef a -> (a -> (a,b)) -> IO b-atomicModifyIORefCAS = atomicModifyIORef--{-# INLINE atomicModifyIORefCAS_ #-}-atomicModifyIORefCAS_ :: IORef a -> (a -> a) -> IO ()-atomicModifyIORefCAS_ = modifyIORef--{-# INLINE writeBarrier #-}-writeBarrier :: IO ()-writeBarrier = return ()--{-# INLINE storeLoadBarrier #-}-storeLoadBarrier :: IO ()-storeLoadBarrier = return ()--#endif
+ src/Streamly/Benchmark/FileIO/Array.hs view
@@ -0,0 +1,242 @@+-- |+-- 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 view
@@ -0,0 +1,617 @@+-- |+-- 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 view
@@ -0,0 +1,912 @@+-- |+-- 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/Fold.hs view
@@ -0,0 +1,261 @@+-- |+-- Module      : Streamly.Data.Fold+-- Copyright   : (c) 2019 Composewell Technologies+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+-- 'Fold' type represents an effectful action that consumes a value from an+-- input stream and combines it with a single final value often called an+-- accumulator, returning the resulting output accumulator.  Values from a+-- stream can be /pushed/ to the fold and consumed one at a time. It can also+-- be called a consumer of stream or a sink.  It is a data representation of+-- the standard 'Streamly.Prelude.foldl'' function.  A 'Fold' can be turned+-- into an effect (@m b@) using 'Streamly.Prelude.fold' by supplying it the+-- input stream.+--+-- Using this representation multiple folds can be combined efficiently using+-- combinators; a stream can then be supplied to the combined fold and it would+-- distribute the input to constituent folds according to the composition.  For+-- example, an applicative composition distributes the same input to the+-- constituent folds and then combines the resulting fold outputs.  Similarly,+-- a partitioning combinator divides the input among constituent folds.+--+-- = Performance Notes+--+-- 'Fold' representation is more efficient than using streams when splitting+-- streams.  @Fold m a b@ can be considered roughly equivalent to a fold action+-- @m b -> t m a -> m b@ (where @t@ is a stream type and @m@ is a 'Monad').+-- Instead of using a 'Fold' type one could just use a fold action of the shape+-- @m b -> t m a -> m b@ for folding streams. However, multiple such actions+-- cannot be composed into a single fold function in an efficient manner.+-- Using the 'Fold' type we can efficiently split the stream across mutliple+-- folds because it allows the compiler to perform stream fusion optimizations.+--+-- On the other hand, transformation operations (e.g. 'Streamly.Prelude.map')+-- on stream types can be as efficient as transformations on 'Fold' (e.g.+-- 'Streamly.Internal.Data.Fold.lmap').+--+-- = Programmer Notes+--+-- > import qualified Streamly.Data.Fold as FL+--+-- More, not yet exposed, fold combinators can be found in+-- "Streamly.Internal.Data.Fold".++-- IMPORTANT: keep the signatures consistent with the folds in Streamly.Prelude++module Streamly.Data.Fold+    (+    -- * Fold Type+    -- |+    -- A 'Fold' can be run over a stream using the 'Streamly.Prelude.fold'+    -- combinator:+    --+    -- >>> S.fold FL.sum (S.enumerateFromTo 1 100)+    -- 5050++      Fold -- (..)++    -- , tail+    -- , init++    -- ** Full Folds+    , drain+    , drainBy+    , last+    , length+    , sum+    , product+    , maximumBy+    , maximum+    , minimumBy+    , minimum+    -- , the+    , mean+    , variance+    , stdDev++    -- ** Full Folds (Monoidal)+    , mconcat+    , foldMap+    , foldMapM++    -- ** Full Folds (To Containers)+    -- | Avoid using these folds in scalable or performance critical+    -- applications, they buffer all the input in GC memory which can be+    -- detrimental to performance if the input is large.++    , toList++    -- ** Partial Folds+    -- , drainN+    -- , drainWhile+    -- , lastN+    -- , (!!)+    -- , genericIndex+    , index+    , head+    -- , findM+    , find+    , lookup+    , findIndex+    , elemIndex+    , null+    , elem+    , notElem+    -- XXX these are slower than right folds even when full input is used+    , all+    , any+    , and+    , or++    -- * Transformations+    -- | Unlike stream producer types (e.g. @SerialT m a@) which have only+    -- output side, folds have an input side as well as an output side.  In the+    -- type @Fold m a b@, the input type is @a@ and the output type is @b@.+    -- Transformations can be applied either on the input side or on the output+    -- side. The 'Functor' instance of a fold maps on the output of the fold:+    --+    -- >>> S.fold (fmap show FL.sum) (S.enumerateFromTo 1 100)+    -- "5050"+    --+    -- However, the input side or contravariant transformations are more+    -- interesting for folds.  The following sections describe the input+    -- transformation operations on a fold.  The names of the operations are+    -- consistent with their covariant counterparts in "Streamly.Prelude", the+    -- only difference is that they are prefixed with 'l' which stands for+    -- 'left' assuming left side is the input side, notice that in @Fold m a b@+    -- the type variable @a@ is on the left side.++    -- ** Covariant Operations+    , sequence+    , mapM++    {-+    -- ** Mapping+    --, transform+    -- , lmap+    --, lsequence+    -- , lmapM++    -- -- ** Filtering+    -- , lfilter+    -- , lfilterM+    -- , ldeleteBy+    -- , luniq++    -- ** Mapping Filters+    , lmapMaybe+    , lmapMaybeM++    -- ** Scanning Filters+    , lfindIndices+    , lelemIndices++    -- ** Insertion+    -- | Insertion adds more elements to the stream.++    , linsertBy+    , lintersperseM++    -- ** Reordering+    , lreverse+    -}++    {-+    -- * Parsing+    -- ** Trimming+    , ltake+    -- , lrunFor -- time+    , ltakeWhile+    , ltakeWhileM+    , ldrop+    , ldropWhile+    , ldropWhileM+    -}++    -- * Distributing+    -- |+    -- The 'Applicative' instance of a distributing 'Fold' distributes one copy+    -- of the stream to each fold and combines the results using a function.+    --+    -- @+    --+    --                 |-------Fold m a b--------|+    -- ---stream m a---|                         |---m (b,c,...)+    --                 |-------Fold m a c--------|+    --                 |                         |+    --                            ...+    -- @+    --+    -- To compute the average of numbers in a stream without going throught he+    -- stream twice:+    --+    -- >>> let avg = (/) <$> FL.sum <*> fmap fromIntegral FL.length+    -- >>> S.fold avg (S.enumerateFromTo 1.0 100.0)+    -- 50.5+    --+    -- The 'Semigroup' and 'Monoid' instances of a distributing fold distribute+    -- the input to both the folds and combines the outputs using Monoid or+    -- Semigroup instances of the output types:+    --+    -- >>> import Data.Monoid (Sum)+    -- >>> S.fold (FL.head <> FL.last) (fmap Sum $ S.enumerateFromTo 1.0 100.0)+    -- Just (Sum {getSum = 101.0})+    --+    -- The 'Num', 'Floating', and 'Fractional' instances work in the same way.++    , tee+    , distribute++    -- * Partitioning+    -- |+    -- Direct items in the input stream to different folds using a binary+    -- fold selector.++    -- , partitionByM+    -- , partitionBy+    , partition++    {-+    -- * Demultiplexing+    -- | Direct values in the input stream to different folds using an n-ary+    -- fold selector.++    , demux+    -- , demuxWith+    , demux_+    -- , demuxWith_++    -- * Classifying+    -- | In an input stream of key value pairs fold values for different keys+    -- in individual output buckets using the given fold.++    , classify+    -- , classifyWith+    -}++    -- * Unzipping+    , unzip+    -- These can be expressed using lmap/lmapM and unzip+    -- , unzipWith+    -- , unzipWithM++    -- -- * Nested Folds+    -- , concatMap+    -- , chunksOf+    -- , duplicate  -- experimental+    )+where++import Prelude+       hiding (filter, drop, dropWhile, take, takeWhile, zipWith, foldr,+               foldl, map, 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, mconcat, foldMap, unzip,+               span, splitAt, break, mapM)++import Streamly.Internal.Data.Fold
+ src/Streamly/Data/Unfold.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE BangPatterns              #-}+{-# LANGUAGE CPP                       #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE PatternSynonyms           #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}++#include "inline.hs"++-- |+-- Module      : Streamly.Data.Unfold+-- Copyright   : (c) 2019 Composewell Technologies+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+-- 'Unfold' type represents an effectful action that generates a stream of+-- 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.+--+-- = Performance Notes+--+-- 'Unfold' representation is more efficient than using streams when combining+-- streams.  'Unfold' type allows multiple unfold actions to be composed into a+-- single unfold function in an efficient manner by enabling the compiler to+-- perform stream fusion optimization.+-- @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+-- 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'.+--+-- On the other hand, transformation operations on stream types are as+-- efficient as transformations on 'Unfold'.+--+-- We should note that in some cases working with stream types may be more+-- convenient compared to working with the 'Unfold' type.  However, if extra+-- performance boost is important then 'Unfold' based composition should be+-- preferred compared to stream based composition when merging or concatenating+-- streams.+--+-- = Programmer Notes+--+-- > import qualified Streamly.Data.Unfold as UF+--+-- 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.+--+module Streamly.Data.Unfold+    (+    -- * Unfold Type+      Unfold+    )+where++import Prelude hiding (concat, map, takeWhile, take, filter, const)+import Streamly.Internal.Data.Unfold
+ src/Streamly/Data/Unicode/Stream.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE FlexibleContexts #-}+-- |+-- Module      : Streamly.Data.Unicode.Stream+-- Copyright   : (c) 2018 Composewell Technologies+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+-- = Processing Unicode Strings+--+-- A 'Char' stream is the canonical representation to process Unicode strings.+-- It can be processed efficiently using regular stream processing operations.+-- A byte stream of Unicode text read from an IO device or from an+-- 'Streamly.Memory.Array.Array' in memory can be decoded into a 'Char' stream+-- using the decoding routines in this module.  A 'String' (@[Char]@) can be+-- converted into a 'Char' stream using 'Streamly.Prelude.fromList'.  An @Array+-- Char@ can be 'Streamly.Prelude.unfold'ed into a stream using the array+-- 'Streamly.Memory.Array.read' unfold.+--+-- = Storing Unicode Strings+--+-- A stream of 'Char' can be encoded into a byte stream using the encoding+-- routines in this module and then written to IO devices or to arrays in+-- memory.+--+-- If you have to store a 'Char' stream in memory you can convert it into a+-- 'String' using 'Streamly.Prelude.toList' or using the+-- 'Streamly.Data.Fold.toList' fold. The 'String' type can be more efficient+-- than pinned arrays for short and short lived strings.+--+-- For longer or long lived streams you can 'Streamly.Prelude.fold' the 'Char'+-- stream as @Array Char@ using the array 'Streamly.Memory.Array.write' fold.+-- The 'Array' type provides a more compact representation and pinned memory+-- reducing GC overhead. If space efficiency is a concern you can use+-- 'encodeUtf8' on the 'Char' stream before writing it to an 'Array' providing+-- an even more compact representation.+--+-- = String Literals+--+-- @SerialT Identity Char@ and @Array Char@ are instances of 'IsString' and+-- 'IsList', therefore, 'OverloadedStrings' and 'OverloadedLists' extensions+-- can be used for convenience when specifying unicode strings literals using+-- these types.+--+-- = Pitfalls+--+-- * Case conversion: Some unicode characters translate to more than one code+-- point on case conversion. The 'toUpper' and 'toLower' functions in @base@+-- package do not handle such characters. Therefore, operations like @map+-- toUpper@ on a character stream or character array may not always perform+-- correct conversion.+-- * String comparison: In some cases, visually identical strings may have+-- different unicode representations, therefore, a character stream or+-- character array cannot be directly compared. A normalized comparison may be+-- needed to check string equivalence correctly.+--+-- = Experimental APIs+--+-- Some experimental APIs to conveniently process text using the @Array Char@+-- represenation directly can be found in "Streamly.Internal.Unicode.Array".++-- XXX an unpinned array representation can be useful to store short and short+-- lived strings in memory.+--+module Streamly.Data.Unicode.Stream+    (+    -- * Construction (Decoding)+      decodeLatin1+    , decodeUtf8+    , decodeUtf8Lax++    -- * Elimination (Encoding)+    , encodeLatin1+    , encodeLatin1Lax+    , encodeUtf8+    {-+    -- * Operations on character strings+    , strip -- (dropAround isSpace)+    , stripEnd+    , stripStart+    -}+    -- Not exposing these yet as we have consider these with respect to Unicode+    -- segmentation routines which are yet to be implemented.+    -- -- * Transformation+    -- , lines+    -- , words+    -- , unlines+    -- , unwords+    )+where++import Streamly.Internal.Data.Unicode.Stream+import Prelude hiding (lines, words, unlines, unwords)
− src/Streamly/Enumeration.hs 
@@ -1,550 +0,0 @@-{-# LANGUAGE CPP                       #-}---- |--- Module      : Streamly.Enumeration--- Copyright   : (c) 2018 Harendra Kumar------ License     : BSD3--- Maintainer  : harendra.kumar@gmail.com--- Stability   : experimental--- Portability : GHC------ The functions defined in this module should be rarely needed for direct use,--- try to use the operations from the 'Enumerable' type class--- instances instead.------ This module provides an 'Enumerable' type class to enumerate 'Enum' types--- into a stream. The operations in this type class correspond to similar--- perations in the 'Enum' type class, the only difference is that they produce--- a stream instead of a list. These operations cannot be defined generically--- based on the 'Enum' type class. We provide instances for commonly used--- types. If instances for other types are needed convenience functions defined--- in this module can be used to define them. Alternatively, these functions--- can be used directly.--module Streamly.Enumeration-    (-      Enumerable (..)--    -- ** Enumerating 'Bounded' 'Enum' Types-    , enumerate-    , enumerateTo-    , enumerateFromBounded--    -- ** Enumerating 'Enum' Types not larger than 'Int'-    , enumerateFromToSmall-    , enumerateFromThenToSmall-    , enumerateFromThenSmallBounded--    -- ** Enumerating 'Bounded' 'Integral' Types-    , enumerateFromIntegral-    , enumerateFromThenIntegral--    -- ** Enumerating 'Integral' Types-    , enumerateFromToIntegral-    , enumerateFromThenToIntegral--    -- ** Enumerating unbounded 'Integral' Types-    , enumerateFromStepIntegral--    -- ** Enumerating 'Fractional' Types-    , enumerateFromFractional-    , enumerateFromToFractional-    , enumerateFromThenFractional-    , enumerateFromThenToFractional-    )-where--import Data.Fixed-import Data.Int-import Data.Ratio-import Data.Word-import Numeric.Natural-import Data.Functor.Identity (Identity(..))--import Streamly.Streams.StreamD (fromStreamD)-import Streamly.Streams.StreamK (IsStream(..))--import qualified Streamly.Streams.StreamD as D-import qualified Streamly.Streams.Serial as Serial------------------------------------------------------------------------------------ Enumeration of Integral types-------------------------------------------------------------------------------------- | @enumerateFromStepIntegral from step@ generates an infinite stream whose--- first element is @from@ and the successive elements are in increments of--- @step@.------ CAUTION: This function is not safe for finite integral types. It does not--- check for overflow, underflow or bounds.------ @--- > S.toList $ S.take 4 $ S.enumerateFromStepIntegral 0 2--- [0,2,4,6]--- > S.toList $ S.take 3 $ S.enumerateFromStepIntegral 0 (-2)--- [0,-2,-4]--- @------ @since 0.6.0-{-# INLINE enumerateFromStepIntegral #-}-enumerateFromStepIntegral-    :: (IsStream t, Monad m, Integral a)-    => a -> a -> t m a-enumerateFromStepIntegral from stride =-    fromStreamD $ D.enumerateFromStepIntegral from stride---- | Enumerate an 'Integral' type. @enumerateFromIntegral from@ generates a--- stream whose first element is @from@ and the successive elements are in--- increments of @1@. The stream is bounded by the size of the 'Integral' type.------ @--- > S.toList $ S.take 4 $ S.enumerateFromIntegral (0 :: Int)--- [0,1,2,3]--- @------ @since 0.6.0-{-# INLINE enumerateFromIntegral #-}-enumerateFromIntegral-    :: (IsStream t, Monad m, Integral a, Bounded a)-    => a -> t m a-enumerateFromIntegral from = fromStreamD $ D.enumerateFromIntegral from---- | Enumerate an 'Integral' type in steps. @enumerateFromThenIntegral from--- then@ generates a stream whose first element is @from@, the second element--- is @then@ and the successive elements are in increments of @then - from@.--- The stream is bounded by the size of the 'Integral' type.------ @--- > S.toList $ S.take 4 $ S.enumerateFromThenIntegral (0 :: Int) 2--- [0,2,4,6]--- > S.toList $ S.take 4 $ S.enumerateFromThenIntegral (0 :: Int) (-2)--- [0,-2,-4,-6]--- @------ @since 0.6.0-{-# INLINE enumerateFromThenIntegral #-}-enumerateFromThenIntegral-    :: (IsStream t, Monad m, Integral a, Bounded a)-    => a -> a -> t m a-enumerateFromThenIntegral from next =-    fromStreamD $ D.enumerateFromThenIntegral from next---- | Enumerate an 'Integral' type up to a given limit.--- @enumerateFromToIntegral from to@ generates a finite stream whose first--- element is @from@ and successive elements are in increments of @1@ up to--- @to@.------ @--- > S.toList $ S.enumerateFromToIntegral 0 4--- [0,1,2,3,4]--- @------ @since 0.6.0-{-# INLINE enumerateFromToIntegral #-}-enumerateFromToIntegral :: (IsStream t, Monad m, Integral a) => a -> a -> t m a-enumerateFromToIntegral from to =-    fromStreamD $ D.enumerateFromToIntegral from to---- | Enumerate an 'Integral' type in steps up to a given limit.--- @enumerateFromThenToIntegral from then to@ generates a finite stream whose--- first element is @from@, the second element is @then@ and the successive--- elements are in increments of @then - from@ up to @to@.------ @--- > S.toList $ S.enumerateFromThenToIntegral 0 2 6--- [0,2,4,6]--- > S.toList $ S.enumerateFromThenToIntegral 0 (-2) (-6)--- [0,-2,-4,-6]--- @------ @since 0.6.0-{-# INLINE enumerateFromThenToIntegral #-}-enumerateFromThenToIntegral-    :: (IsStream t, Monad m, Integral a)-    => a -> a -> a -> t m a-enumerateFromThenToIntegral from next to =-    fromStreamD $ D.enumerateFromThenToIntegral from next to------------------------------------------------------------------------------------ Enumeration of Fractional types-------------------------------------------------------------------------------------- Even though the underlying implementation of enumerateFromFractional and--- enumerateFromThenFractional works for any 'Num' we have restricted these to--- 'Fractional' because these do not perform any bounds check, in contrast to--- integral versions and are therefore not equivalent substitutes for those.------ | Numerically stable enumeration from a 'Fractional' number in steps of size--- @1@. @enumerateFromFractional from@ generates a stream whose first element--- is @from@ and the successive elements are in increments of @1@.  No overflow--- or underflow checks are performed.------ This is the equivalent to 'enumFrom' for 'Fractional' types. For example:------ @--- > S.toList $ S.take 4 $ S.enumerateFromFractional 1.1--- [1.1,2.1,3.1,4.1]--- @--------- @since 0.6.0-{-# INLINE enumerateFromFractional #-}-enumerateFromFractional :: (IsStream t, Monad m, Fractional a) => a -> t m a-enumerateFromFractional from = fromStreamD $ D.numFrom from---- | Numerically stable enumeration from a 'Fractional' number in steps.--- @enumerateFromThenFractional from then@ generates a stream whose first--- element is @from@, the second element is @then@ and the successive elements--- are in increments of @then - from@.  No overflow or underflow checks are--- performed.------ This is the equivalent of 'enumFromThen' for 'Fractional' types. For--- example:------ @--- > S.toList $ S.take 4 $ S.enumerateFromThenFractional 1.1 2.1--- [1.1,2.1,3.1,4.1]--- > S.toList $ S.take 4 $ S.enumerateFromThenFractional 1.1 (-2.1)--- [1.1,-2.1,-5.300000000000001,-8.500000000000002]--- @------ @since 0.6.0-{-# INLINE enumerateFromThenFractional #-}-enumerateFromThenFractional-    :: (IsStream t, Monad m, Fractional a)-    => a -> a -> t m a-enumerateFromThenFractional from next = fromStreamD $ D.numFromThen from next---- | Numerically stable enumeration from a 'Fractional' number to a given--- limit.  @enumerateFromToFractional from to@ generates a finite stream whose--- first element is @from@ and successive elements are in increments of @1@ up--- to @to@.------ This is the equivalent of 'enumFromTo' for 'Fractional' types. For--- example:------ @--- > S.toList $ S.enumerateFromToFractional 1.1 4--- [1.1,2.1,3.1,4.1]--- > S.toList $ S.enumerateFromToFractional 1.1 4.6--- [1.1,2.1,3.1,4.1,5.1]--- @------ Notice that the last element is equal to the specified @to@ value after--- rounding to the nearest integer.------ @since 0.6.0-{-# INLINE enumerateFromToFractional #-}-enumerateFromToFractional-    :: (IsStream t, Monad m, Fractional a, Ord a)-    => a -> a -> t m a-enumerateFromToFractional from to =-    fromStreamD $ D.enumerateFromToFractional from to---- | Numerically stable enumeration from a 'Fractional' number in steps up to a--- given limit.  @enumerateFromThenToFractional from then to@ generates a--- finite stream whose first element is @from@, the second element is @then@--- and the successive elements are in increments of @then - from@ up to @to@.------ This is the equivalent of 'enumFromThenTo' for 'Fractional' types. For--- example:------ @--- > S.toList $ S.enumerateFromThenToFractional 0.1 2 6--- [0.1,2.0,3.9,5.799999999999999]--- > S.toList $ S.enumerateFromThenToFractional 0.1 (-2) (-6)--- [0.1,-2.0,-4.1000000000000005,-6.200000000000001]--- @--------- @since 0.6.0-{-# INLINE enumerateFromThenToFractional #-}-enumerateFromThenToFractional-    :: (IsStream t, Monad m, Fractional a, Ord a)-    => a -> a -> a -> t m a-enumerateFromThenToFractional from next to =-    fromStreamD $ D.enumerateFromThenToFractional from next to------------------------------------------------------------------------------------ Enumeration of Enum types not larger than Int-------------------------------------------------------------------------------------- | 'enumerateFromTo' for 'Enum' types not larger than 'Int'.------ @since 0.6.0-{-# INLINE enumerateFromToSmall #-}-enumerateFromToSmall :: (IsStream t, Monad m, Enum a) => a -> a -> t m a-enumerateFromToSmall from to = Serial.map toEnum $-    enumerateFromToIntegral (fromEnum from) (fromEnum to)---- | 'enumerateFromThenTo' for 'Enum' types not larger than 'Int'.------ @since 0.6.0-{-# INLINE enumerateFromThenToSmall #-}-enumerateFromThenToSmall :: (IsStream t, Monad m, Enum a)-    => a -> a -> a -> t m a-enumerateFromThenToSmall from next to = Serial.map toEnum $-    enumerateFromThenToIntegral (fromEnum from) (fromEnum next) (fromEnum to)---- | 'enumerateFromThen' for 'Enum' types not larger than 'Int'.------ Note: We convert the 'Enum' to 'Int' and enumerate the 'Int'. If a--- type is bounded but does not have a 'Bounded' instance then we can go on--- enumerating it beyond the legal values of the type, resulting in the failure--- of 'toEnum' when converting back to 'Enum'. Therefore we require a 'Bounded'--- instance for this function to be safely used.------ @since 0.6.0-{-# INLINE enumerateFromThenSmallBounded #-}-enumerateFromThenSmallBounded :: (IsStream t, Monad m, Enumerable a, Bounded a)-    => a -> a -> t m a-enumerateFromThenSmallBounded from next =-    case fromEnum next >= fromEnum from of-        True -> enumerateFromThenTo from next maxBound-        False -> enumerateFromThenTo from next minBound------------------------------------------------------------------------------------ Enumerable type class-------------------------------------------------------------------------------------- NOTE: We would like to rewrite calls to fromList [1..] etc. to stream--- enumerations like this:------ {-# RULES "fromList enumFrom" [1]---     forall (a :: Int). D.fromList (enumFrom a) = D.enumerateFromIntegral a #-}------ But this does not work because enumFrom is a class method and GHC rewrites--- it quickly, so we do not get a chance to have our rule fired.---- | Types that can be enumerated as a stream. The operations in this type--- class are equivalent to those in the 'Enum' type class, except that these--- generate a stream instead of a list. Use the functions in--- "Streamly.Enumeration" module to define new instances.------ @since 0.6.0-class Enum a => Enumerable a where-    -- | @enumerateFrom from@ generates a stream starting with the element-    -- @from@, enumerating up to 'maxBound' when the type is 'Bounded' or-    -- generating an infinite stream when the type is not 'Bounded'.-    ---    -- @-    -- > S.toList $ S.take 4 $ S.enumerateFrom (0 :: Int)-    -- [0,1,2,3]-    -- @-    ---    -- For 'Fractional' types, enumeration is numerically stable. However, no-    -- overflow or underflow checks are performed.-    ---    -- @-    -- > S.toList $ S.take 4 $ S.enumerateFrom 1.1-    -- [1.1,2.1,3.1,4.1]-    -- @-    ---    -- @since 0.6.0-    enumerateFrom :: (IsStream t, Monad m) => a -> t m a--    -- | Generate a finite stream starting with the element @from@, enumerating-    -- the type up to the value @to@. If @to@ is smaller than @from@ then an-    -- empty stream is returned.-    ---    -- @-    -- > S.toList $ S.enumerateFromTo 0 4-    -- [0,1,2,3,4]-    -- @-    ---    -- For 'Fractional' types, the last element is equal to the specified @to@-    -- value after rounding to the nearest integral value.-    ---    -- @-    -- > S.toList $ S.enumerateFromTo 1.1 4-    -- [1.1,2.1,3.1,4.1]-    -- > S.toList $ S.enumerateFromTo 1.1 4.6-    -- [1.1,2.1,3.1,4.1,5.1]-    -- @-    ---    -- @since 0.6.0-    enumerateFromTo :: (IsStream t, Monad m) => a -> a -> t m a--    -- | @enumerateFromThen from then@ generates a stream whose first element-    -- is @from@, the second element is @then@ and the successive elements are-    -- in increments of @then - from@.  Enumeration can occur downwards or-    -- upwards depending on whether @then@ comes before or after @from@. For-    -- 'Bounded' types the stream ends when 'maxBound' is reached, for-    -- unbounded types it keeps enumerating infinitely.-    ---    -- @-    -- > S.toList $ S.take 4 $ S.enumerateFromThen 0 2-    -- [0,2,4,6]-    -- > S.toList $ S.take 4 $ S.enumerateFromThen 0 (-2)-    -- [0,-2,-4,-6]-    -- @-    ---    -- @since 0.6.0-    enumerateFromThen :: (IsStream t, Monad m) => a -> a -> t m a--    -- | @enumerateFromThenTo from then to@ generates a finite stream whose-    -- first element is @from@, the second element is @then@ and the successive-    -- elements are in increments of @then - from@ up to @to@. Enumeration can-    -- occur downwards or upwards depending on whether @then@ comes before or-    -- after @from@.-    ---    -- @-    -- > S.toList $ S.enumerateFromThenTo 0 2 6-    -- [0,2,4,6]-    -- > S.toList $ S.enumerateFromThenTo 0 (-2) (-6)-    -- [0,-2,-4,-6]-    -- @-    ---    -- @since 0.6.0-    enumerateFromThenTo :: (IsStream t, Monad m) => a -> a -> a -> t m a---- MAYBE: Sometimes it is more convenient to know the count rather then the--- ending or starting element. For those cases we can define the folllowing--- APIs. All of these will work only for bounded types if we represent the--- count by Int.------ enumerateN--- enumerateFromN--- enumerateToN--- enumerateFromStep--- enumerateFromStepN------------------------------------------------------------------------------------ Convenient functions for bounded types-------------------------------------------------------------------------------------- |--- > enumerate = enumerateFrom minBound------ Enumerate a 'Bounded' type from its 'minBound' to 'maxBound'------ @since 0.6.0-{-# INLINE enumerate #-}-enumerate :: (IsStream t, Monad m, Bounded a, Enumerable a) => t m a-enumerate = enumerateFrom minBound---- |--- > enumerateTo = enumerateFromTo minBound------ Enumerate a 'Bounded' type from its 'minBound' to specified value.------ @since 0.6.0-{-# INLINE enumerateTo #-}-enumerateTo :: (IsStream t, Monad m, Bounded a, Enumerable a) => a -> t m a-enumerateTo = enumerateFromTo minBound---- |--- > enumerateFromBounded = enumerateFromTo from maxBound------ 'enumerateFrom' for 'Bounded' 'Enum' types.------ @since 0.6.0-{-# INLINE enumerateFromBounded #-}-enumerateFromBounded :: (IsStream t, Monad m, Enumerable a, Bounded a)-    => a -> t m a-enumerateFromBounded from = enumerateFromTo from maxBound------------------------------------------------------------------------------------ Enumerable Instances-------------------------------------------------------------------------------------- For Enum types smaller than or equal to Int size.-#define ENUMERABLE_BOUNDED_SMALL(SMALL_TYPE)           \-instance Enumerable SMALL_TYPE where {                 \-    {-# INLINE enumerateFrom #-};                      \-    enumerateFrom = enumerateFromBounded;              \-    {-# INLINE enumerateFromThen #-};                  \-    enumerateFromThen = enumerateFromThenSmallBounded; \-    {-# INLINE enumerateFromTo #-};                    \-    enumerateFromTo = enumerateFromToSmall;            \-    {-# INLINE enumerateFromThenTo #-};                \-    enumerateFromThenTo = enumerateFromThenToSmall }---ENUMERABLE_BOUNDED_SMALL(())-ENUMERABLE_BOUNDED_SMALL(Bool)-ENUMERABLE_BOUNDED_SMALL(Ordering)-ENUMERABLE_BOUNDED_SMALL(Char)---- For bounded Integral Enum types, may be larger than Int.-#define ENUMERABLE_BOUNDED_INTEGRAL(INTEGRAL_TYPE)  \-instance Enumerable INTEGRAL_TYPE where {           \-    {-# INLINE enumerateFrom #-};                   \-    enumerateFrom = enumerateFromIntegral;          \-    {-# INLINE enumerateFromThen #-};               \-    enumerateFromThen = enumerateFromThenIntegral;  \-    {-# INLINE enumerateFromTo #-};                 \-    enumerateFromTo = enumerateFromToIntegral;      \-    {-# INLINE enumerateFromThenTo #-};             \-    enumerateFromThenTo = enumerateFromThenToIntegral }--ENUMERABLE_BOUNDED_INTEGRAL(Int)-ENUMERABLE_BOUNDED_INTEGRAL(Int8)-ENUMERABLE_BOUNDED_INTEGRAL(Int16)-ENUMERABLE_BOUNDED_INTEGRAL(Int32)-ENUMERABLE_BOUNDED_INTEGRAL(Int64)-ENUMERABLE_BOUNDED_INTEGRAL(Word)-ENUMERABLE_BOUNDED_INTEGRAL(Word8)-ENUMERABLE_BOUNDED_INTEGRAL(Word16)-ENUMERABLE_BOUNDED_INTEGRAL(Word32)-ENUMERABLE_BOUNDED_INTEGRAL(Word64)---- For unbounded Integral Enum types.-#define ENUMERABLE_UNBOUNDED_INTEGRAL(INTEGRAL_TYPE)              \-instance Enumerable INTEGRAL_TYPE where {                         \-    {-# INLINE enumerateFrom #-};                                 \-    enumerateFrom from = enumerateFromStepIntegral from 1;        \-    {-# INLINE enumerateFromThen #-};                             \-    enumerateFromThen from next =                                 \-        enumerateFromStepIntegral from (next - from);             \-    {-# INLINE enumerateFromTo #-};                               \-    enumerateFromTo = enumerateFromToIntegral;                    \-    {-# INLINE enumerateFromThenTo #-};                           \-    enumerateFromThenTo = enumerateFromThenToIntegral }--ENUMERABLE_UNBOUNDED_INTEGRAL(Integer)-ENUMERABLE_UNBOUNDED_INTEGRAL(Natural)--#define ENUMERABLE_FRACTIONAL(FRACTIONAL_TYPE,CONSTRAINT)         \-instance (CONSTRAINT) => Enumerable (FRACTIONAL_TYPE) where {     \-    {-# INLINE enumerateFrom #-};                                 \-    enumerateFrom = enumerateFromFractional;                      \-    {-# INLINE enumerateFromThen #-};                             \-    enumerateFromThen = enumerateFromThenFractional;              \-    {-# INLINE enumerateFromTo #-};                               \-    enumerateFromTo = enumerateFromToFractional;                  \-    {-# INLINE enumerateFromThenTo #-};                           \-    enumerateFromThenTo = enumerateFromThenToFractional }--ENUMERABLE_FRACTIONAL(Float,)-ENUMERABLE_FRACTIONAL(Double,)-ENUMERABLE_FRACTIONAL(Fixed a,HasResolution a)-ENUMERABLE_FRACTIONAL(Ratio a,Integral a)--#if __GLASGOW_HASKELL__ >= 800-instance Enumerable a => Enumerable (Identity a) where-    {-# INLINE enumerateFrom #-}-    enumerateFrom (Identity from) = Serial.map Identity $-        enumerateFrom from-    {-# INLINE enumerateFromThen #-}-    enumerateFromThen (Identity from) (Identity next) = Serial.map Identity $-        enumerateFromThen from next-    {-# INLINE enumerateFromTo #-}-    enumerateFromTo (Identity from) (Identity to) = Serial.map Identity $-        enumerateFromTo from to-    {-# INLINE enumerateFromThenTo #-}-    enumerateFromThenTo (Identity from) (Identity next) (Identity to) =-        Serial.map Identity $ enumerateFromThenTo from next to-#endif---- TODO-{--instance Enumerable a => Enumerable (Last a)-instance Enumerable a => Enumerable (First a)-instance Enumerable a => Enumerable (Max a)-instance Enumerable a => Enumerable (Min a)-instance Enumerable a => Enumerable (Const a b)-instance Enumerable (f a) => Enumerable (Alt f a)-instance Enumerable (f a) => Enumerable (Ap f a)--}
+ src/Streamly/FileSystem/FD.hs view
@@ -0,0 +1,574 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE UnboxedTuples #-}++#include "inline.hs"++-- |+-- Module      : Streamly.FileSystem.FD+-- Copyright   : (c) 2019 Composewell Technologies+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+-- This module is a an experimental replacement for+-- "Streamly.FileSystem.Handle". The former module provides IO facilities based+-- on the GHC Handle type. The APIs in this module avoid the GHC handle layer+-- and provide more explicit control over buffering.+--+-- Read and write data as streams and arrays to and from files.+--+-- This module provides read and write APIs based on handles. Before reading or+-- writing, a file must be opened first using 'openFile'. The 'Handle' returned+-- by 'openFile' is then used to access the file. A 'Handle' is backed by an+-- operating system file descriptor. When the 'Handle' is garbage collected the+-- underlying file descriptor is automatically closed. A handle can be+-- explicitly closed using 'closeFile'.+--+-- Reading and writing APIs are divided into two categories, sequential+-- streaming APIs and random or seekable access APIs.  File IO APIs are quite+-- similar to "Streamly.Memory.Array" read write APIs. In that regard, arrays can+-- be considered as in-memory files or files can be considered as on-disk+-- arrays.+--+-- > import qualified Streamly.FileSystem.FD as FD+--++module Streamly.FileSystem.FD+    (+    -- * File Handles+      Handle+    , stdin+    , stdout+    , stderr+    , openFile++    -- TODO file path based APIs+    -- , readFile+    -- , writeFile++    -- * Streaming IO+    -- | Streaming APIs read or write data to or from a file or device+    -- sequentially, they never perform a seek to a random location.  When+    -- reading, the stream is lazy and generated on-demand as the consumer+    -- consumes it.  Read IO requests to the IO device are performed in chunks+    -- of 32KiB, this is referred to as @defaultChunkSize@ in the+    -- documentation. One IO request may or may not read the full chunk. If the+    -- whole stream is not consumed, it is possible that we may read slightly+    -- more from the IO device than what the consumer needed.  Unless specified+    -- otherwise in the API, writes are collected into chunks of+    -- @defaultChunkSize@ before they are written to the IO device.++    -- Streaming APIs work for all kind of devices, seekable or non-seekable;+    -- including disks, files, memory devices, terminals, pipes, sockets and+    -- fifos. While random access APIs work only for files or devices that have+    -- random access or seek capability for example disks, memory devices.+    -- Devices like terminals, pipes, sockets and fifos do not have random+    -- access capability.++    -- ** Read File to Stream+    , read+    -- , readUtf8+    -- , readLines+    -- , readFrames+    , readInChunksOf++    -- -- * Array Read+    -- , readArrayUpto+    -- , readArrayOf++    , readArrays+    , readArraysOfUpto+    -- , readArraysOf++    -- ** Write File from Stream+    , write+    -- , writeUtf8+    -- , writeUtf8Lines+    -- , writeFrames+    , writeInChunksOf++    -- -- * Array Write+    -- , writeArray+    , writeArrays+    , writeArraysPackedUpto++    -- XXX these are incomplete+    -- , writev+    -- , writevArraysPackedUpto++    -- -- * Random Access (Seek)+    -- -- | Unlike the streaming APIs listed above, these APIs apply to devices or+    -- files that have random access or seek capability.  This type of devices+    -- include disks, files, memory devices and exclude terminals, pipes,+    -- sockets and fifos.+    --+    -- , readIndex+    -- , readSlice+    -- , readSliceRev+    -- , readAt -- read from a given position to th end of file+    -- , readSliceArrayUpto+    -- , readSliceArrayOf++    -- , writeIndex+    -- , writeSlice+    -- , writeSliceRev+    -- , writeAt -- start writing at the given position+    -- , writeSliceArray+    )+where++import Control.Monad.IO.Class (MonadIO(..))+import Data.Word (Word8)+import Foreign.ForeignPtr (withForeignPtr)+-- import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)+import Foreign.Ptr (plusPtr, castPtr)+import Foreign.Storable (Storable(..))+import GHC.ForeignPtr (mallocPlainForeignPtrBytes)+-- import System.IO (Handle, hGetBufSome, hPutBuf)+import System.IO (IOMode)+import Prelude hiding (read)++import qualified GHC.IO.FD as FD+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)++#if !defined(mingw32_HOST_OS)+import Streamly.Internal.Memory.Array.Types (groupIOVecsOf)+import Streamly.Streams.StreamD (toStreamD)+import Streamly.Internal.Data.Stream.StreamD.Type (fromStreamD)+import qualified Streamly.FileSystem.FDIO as RawIO hiding (write)+#endif+-- import Streamly.Data.Fold (Fold)+-- import Streamly.String (encodeUtf8, decodeUtf8, foldLines)++import qualified Streamly.Memory.Array as A+import qualified Streamly.Internal.Memory.ArrayStream as AS+import qualified Streamly.Prelude as S+import qualified Streamly.Internal.Data.Stream.StreamD.Type as D++-------------------------------------------------------------------------------+-- References+-------------------------------------------------------------------------------+--+-- The following references may be useful to build an understanding about the+-- file API design:+--+-- http://www.linux-mag.com/id/308/ for blocking/non-blocking IO on linux.+-- https://lwn.net/Articles/612483/ Non-blocking buffered file read operations+-- https://en.wikipedia.org/wiki/C_file_input/output for C APIs.+-- https://docs.oracle.com/javase/tutorial/essential/io/file.html for Java API.+-- https://www.w3.org/TR/FileAPI/ for http file API.++-------------------------------------------------------------------------------+-- Handles+-------------------------------------------------------------------------------++-- XXX attach a finalizer+-- | A 'Handle' is returned by 'openFile' and is subsequently used to perform+-- read and write operations on a file.+--+newtype Handle = Handle FD.FD++-- | File handle for standard input+stdin :: Handle+stdin = Handle FD.stdin++-- | File handle for standard output+stdout :: Handle+stdout = Handle FD.stdout++-- | File handle for standard error+stderr :: Handle+stderr = Handle FD.stderr++-- XXX we can support all the flags that the "open" system call supports.+-- Instead of using RTS locking mechanism can we use system provided locking+-- instead?+--+-- | Open a file that is not a directory and return a file handle.+-- 'openFile' enforces a multiple-reader single-writer locking on files. That+-- is, there may either be many handles on the same file which manage input, or+-- just one handle on the file which manages output. If any open handle is+-- managing a file for output, no new handle can be allocated for that file. If+-- any open handle is managing a file for input, new handles can only be+-- allocated if they do not manage output. Whether two files are the same is+-- implementation-dependent, but they should normally be the same if they have+-- 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++-------------------------------------------------------------------------------+-- Array IO (Input)+-------------------------------------------------------------------------------++-- | Read a 'ByteArray' from a file handle. If no data is available on the+-- handle it blocks until some data becomes available. If data is available+-- then it immediately returns that data without blocking. It reads a maximum+-- of up to the size requested.+{-# INLINABLE readArrayUpto #-}+readArrayUpto :: Int -> Handle -> IO (Array Word8)+readArrayUpto size (Handle fd) = do+    ptr <- mallocPlainForeignPtrBytes size+    -- ptr <- mallocPlainForeignPtrAlignedBytes size (alignment (undefined :: Word8))+    withForeignPtr ptr $ \p -> do+        -- n <- hGetBufSome h p size+        n <- RawIO.read fd p size+        let v = Array+                { aStart = ptr+                , aEnd   = p `plusPtr` n+                , aBound = p `plusPtr` size+                }+        -- XXX shrink only if the diff is significant+        -- A.shrinkToFit v+        return v++-------------------------------------------------------------------------------+-- Array IO (output)+-------------------------------------------------------------------------------++-- | Write an 'Array' to a file handle.+--+-- @since 0.7.0+{-# 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+    -- RawIO.writeAll fd (castPtr p) aLen+    RawIO.write fd (castPtr p) aLen+    {-+    -- Experiment to compare "writev" based IO with "write" based IO.+    iov <- A.newArray 1+    let iov' = iov {aEnd = aBound iov}+    A.writeIndex iov' 0 (RawIO.IOVec (castPtr p) (fromIntegral aLen))+    RawIO.writevAll fd (unsafeForeignPtrToPtr (aStart iov')) 1+    -}+    where+    aLen = byteLength arr++#if !defined(mingw32_HOST_OS)+-- | Write an array of 'IOVec' to a file handle.+--+-- @since 0.7.0+{-# INLINABLE writeIOVec #-}+writeIOVec :: Handle -> Array RawIO.IOVec -> IO ()+writeIOVec _ iov | A.length iov == 0 = return ()+writeIOVec (Handle fd) iov =+    withForeignPtr (aStart iov) $ \p ->+        RawIO.writevAll fd p (A.length iov)+#endif++-------------------------------------------------------------------------------+-- Stream of Arrays IO+-------------------------------------------------------------------------------++-- | @readArraysOfUpto size h@ reads a stream of arrays from file handle @h@.+-- The maximum size of a single array is specified by @size@. The actual size+-- read may be less than or equal to @size@.+{-# INLINABLE _readArraysOfUpto #-}+_readArraysOfUpto :: (IsStream t, MonadIO m)+    => Int -> Handle -> t m (Array Word8)+_readArraysOfUpto size h = go+  where+    -- XXX use cons/nil instead+    go = mkStream $ \_ yld _ stp -> do+        arr <- liftIO $ readArrayUpto size h+        if A.length arr == 0+        then stp+        else yld arr go++{-# INLINE_NORMAL readArraysOfUpto #-}+readArraysOfUpto :: (IsStream t, MonadIO m)+    => Int -> Handle -> t m (Array Word8)+readArraysOfUpto size h = D.fromStreamD (D.Stream step ())+  where+    {-# INLINE_LATE step #-}+    step _ _ = do+        arr <- liftIO $ readArrayUpto size h+        return $+            case A.length arr of+                0 -> D.Stop+                _ -> D.Yield arr ()++-- XXX read 'Array a' instead of Word8+--+-- | @readArrays h@ reads a stream of arrays from file handle @h@.+-- The maximum size of a single array is limited to @defaultChunkSize@.+-- 'readArrays' ignores the prevailing 'TextEncoding' and 'NewlineMode'+-- on the 'Handle'.+--+-- > readArrays = readArraysOfUpto defaultChunkSize+--+-- @since 0.7.0+{-# INLINE readArrays #-}+readArrays :: (IsStream t, MonadIO m) => Handle -> t m (Array Word8)+readArrays = readArraysOfUpto defaultChunkSize++-------------------------------------------------------------------------------+-- Read File to Stream+-------------------------------------------------------------------------------++-- TODO for concurrent streams implement readahead IO. We can send multiple+-- read requests at the same time. For serial case we can use async IO. We can+-- also control the read throughput in mbps or IOPS.++-- | @readInChunksOf chunkSize handle@ reads a byte stream from a file handle,+-- reads are performed in chunks of up to @chunkSize@.  The stream ends as soon+-- as EOF is encountered.+--+{-# INLINE readInChunksOf #-}+readInChunksOf :: (IsStream t, MonadIO m) => Int -> Handle -> t m Word8+readInChunksOf chunkSize h = AS.concat $ readArraysOfUpto chunkSize h++-- TODO+-- read :: (IsStream t, MonadIO m, Storable a) => Handle -> t m a+--+-- > read = 'readByChunks' A.defaultChunkSize+-- | Generate a stream of elements of the given type from a file 'Handle'. The+-- stream ends when EOF is encountered.+--+-- @since 0.7.0+{-# INLINE read #-}+read :: (IsStream t, MonadIO m) => Handle -> t m Word8+read = AS.concat . readArrays++-------------------------------------------------------------------------------+-- Writing+-------------------------------------------------------------------------------++-- | Write a stream of arrays to a handle.+--+-- @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++-- | 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+-- be smaller than that as we do not split the arrays to fit them to the+-- specified size.+--+-- @since 0.7.0+{-# INLINE writeArraysPackedUpto #-}+writeArraysPackedUpto :: (MonadIO m, Storable a)+    => Int -> Handle -> SerialT m (Array a) -> m ()+writeArraysPackedUpto n h xs = writeArrays h $ AS.compact n xs++#if !defined(mingw32_HOST_OS)+-- XXX this is incomplete+-- | Write a stream of 'IOVec' arrays to a handle.+--+-- @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++-- XXX this is incomplete+-- | Write a stream of arrays to a handle after grouping them in 'IOVec' arrays+-- of up to a maximum total size. Writes are performed using gather IO via+-- @writev@ system call. The maximum number of entries in each 'IOVec' group+-- limited to 512.+--+-- @since 0.7.0+{-# INLINE _writevArraysPackedUpto #-}+_writevArraysPackedUpto :: MonadIO m+    => Int -> Handle -> SerialT m (Array a) -> m ()+_writevArraysPackedUpto n h xs =+    writev h $ fromStreamD $ groupIOVecsOf n 512 (toStreamD xs)+#endif++-- GHC buffer size dEFAULT_FD_BUFFER_SIZE=8192 bytes.+--+-- XXX test this+-- Note that if you use a chunk size less than 8K (GHC's default buffer+-- size) then you are advised to use 'NOBuffering' mode on the 'Handle' in case you+-- do not want buffering to occur at GHC level as well. Same thing applies to+-- writes as well.++-- | Like 'write' but provides control over the write buffer. Output will+-- be written to the IO device as soon as we collect the specified number of+-- input elements.+--+-- @since 0.7.0+{-# INLINE writeInChunksOf #-}+writeInChunksOf :: MonadIO m => Int -> Handle -> SerialT m Word8 -> m ()+writeInChunksOf n h m = writeArrays h $ AS.arraysOf n m++-- > write = 'writeInChunksOf' A.defaultChunkSize+--+-- | Write a byte stream to a file handle. Combines the bytes in chunks of size+-- up to 'A.defaultChunkSize' before writing.  Note that the write behavior+-- depends on the 'IOMode' and the current seek position of the handle.+--+-- @since 0.7.0+{-# INLINE write #-}+write :: MonadIO m => Handle -> SerialT m Word8 -> m ()+write = writeInChunksOf defaultChunkSize++{-+{-# INLINE write #-}+write :: (MonadIO m, Storable a) => Handle -> SerialT m a -> m ()+write = toHandleWith A.defaultChunkSize+-}++-------------------------------------------------------------------------------+-- IO with encoding/decoding Unicode characters+-------------------------------------------------------------------------------++{-+-- |+-- > readUtf8 = decodeUtf8 . read+--+-- Read a UTF8 encoded stream of unicode characters from a file handle.+--+-- @since 0.7.0+{-# INLINE readUtf8 #-}+readUtf8 :: (IsStream t, MonadIO m) => Handle -> t m Char+readUtf8 = decodeUtf8 . read++-- |+-- > writeUtf8 h s = write h $ encodeUtf8 s+--+-- Encode a stream of unicode characters to UTF8 and write it to the given file+-- handle. Default block buffering applies to the writes.+--+-- @since 0.7.0+{-# INLINE writeUtf8 #-}+writeUtf8 :: MonadIO m => Handle -> SerialT m Char -> m ()+writeUtf8 h s = write h $ encodeUtf8 s++-- | Write a stream of unicode characters after encoding to UTF-8 in chunks+-- separated by a linefeed character @'\n'@. If the size of the buffer exceeds+-- @defaultChunkSize@ and a linefeed is not yet found, the buffer is written+-- anyway.  This is similar to writing to a 'Handle' with the 'LineBuffering'+-- option.+--+-- @since 0.7.0+{-# INLINE writeUtf8ByLines #-}+writeUtf8ByLines :: (IsStream t, MonadIO m) => Handle -> t m Char -> m ()+writeUtf8ByLines = undefined++-- | Read UTF-8 lines from a file handle and apply the specified fold to each+-- line. This is similar to reading a 'Handle' with the 'LineBuffering' option.+--+-- @since 0.7.0+{-# INLINE readLines #-}+readLines :: (IsStream t, MonadIO m) => Handle -> Fold m Char b -> t m b+readLines h f = foldLines (readUtf8 h) f++-------------------------------------------------------------------------------+-- Framing on a sequence+-------------------------------------------------------------------------------++-- | Read a stream from a file handle and split it into frames delimited by+-- the specified sequence of elements. The supplied fold is applied on each+-- frame.+--+-- @since 0.7.0+{-# INLINE readFrames #-}+readFrames :: (IsStream t, MonadIO m, Storable a)+    => Array a -> Handle -> Fold m a b -> t m b+readFrames = undefined -- foldFrames . read++-- | Write a stream to the given file handle buffering up to frames separated+-- by the given sequence or up to a maximum of @defaultChunkSize@.+--+-- @since 0.7.0+{-# INLINE writeByFrames #-}+writeByFrames :: (IsStream t, MonadIO m, Storable a)+    => Array a -> Handle -> t m a -> m ()+writeByFrames = undefined++-------------------------------------------------------------------------------+-- Random Access IO (Seek)+-------------------------------------------------------------------------------++-- XXX handles could be shared, so we may not want to use the handle state at+-- all for these APIs. we can use pread and pwrite instead. On windows we will+-- need to use readFile/writeFile with an offset argument.++-------------------------------------------------------------------------------++-- | Read the element at the given index treating the file as an array.+--+-- @since 0.7.0+{-# INLINE readIndex #-}+readIndex :: Storable a => Handle -> Int -> Maybe a+readIndex arr i = undefined++-- NOTE: To represent a range to read we have chosen (start, size) instead of+-- (start, end). This helps in removing the ambiguity of whether "end" is+-- included in the range or not.+--+-- We could avoid specifying the range to be read and instead use "take size"+-- on the stream, but it may end up reading more and then consume it partially.++-- | @readSliceWith chunkSize handle pos len@ reads up to @len@ bytes+-- from @handle@ starting at the offset @pos@ from the beginning of the file.+--+-- Reads are performed in chunks of size @chunkSize@.  For block devices, to+-- avoid reading partial blocks @chunkSize@ must align with the block size of+-- the underlying device. If the underlying block size is unknown, it is a good+-- idea to keep it a multiple 4KiB. This API ensures that the start of each+-- chunk is aligned with @chunkSize@ from second chunk onwards.+--+{-# INLINE readSliceWith #-}+readSliceWith :: (IsStream t, MonadIO m, Storable a)+    => Int -> Handle -> Int -> Int -> t m a+readSliceWith chunkSize h pos len = undefined++-- | @readSlice h i count@ streams a slice from the file handle @h@ starting+-- at index @i@ and reading up to @count@ elements in the forward direction+-- ending at the index @i + count - 1@.+--+-- @since 0.7.0+{-# INLINE readSlice #-}+readSlice :: (IsStream t, MonadIO m, Storable a)+    => Handle -> Int -> Int -> t m a+readSlice = readSliceWith defaultChunkSize++-- | @readSliceRev h i count@ streams a slice from the file handle @h@ starting+-- at index @i@ and reading up to @count@ elements in the reverse direction+-- ending at the index @i - count + 1@.+--+-- @since 0.7.0+{-# INLINE readSliceRev #-}+readSliceRev :: (IsStream t, MonadIO m, Storable a)+    => Handle -> Int -> Int -> t m a+readSliceRev h i count = undefined++-- | Write the given element at the given index in the file.+--+-- @since 0.7.0+{-# INLINE writeIndex #-}+writeIndex :: (MonadIO m, Storable a) => Handle -> Int -> a -> m ()+writeIndex h i a = undefined++-- | @writeSlice h i count stream@ writes a stream to the file handle @h@+-- starting at index @i@ and writing up to @count@ elements in the forward+-- direction ending at the index @i + count - 1@.+--+-- @since 0.7.0+{-# INLINE writeSlice #-}+writeSlice :: (IsStream t, Monad m, Storable a)+    => Handle -> Int -> Int -> t m a -> m ()+writeSlice h i len s = undefined++-- | @writeSliceRev h i count stream@ writes a stream to the file handle @h@+-- starting at index @i@ and writing up to @count@ elements in the reverse+-- direction ending at the index @i - count + 1@.+--+-- @since 0.7.0+{-# INLINE writeSliceRev #-}+writeSliceRev :: (IsStream t, Monad m, Storable a)+    => Handle -> Int -> Int -> t m a -> m ()+writeSliceRev arr i len s = undefined+-}
+ src/Streamly/FileSystem/FDIO.hs view
@@ -0,0 +1,232 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE UnboxedTuples #-}++#include "inline.hs"++-- |+-- Module      : Streamly.FileSystem.FDIO+-- Copyright   : (c) 2019 Composewell Technologies+-- Copyright   : (c) 1994-2008 The University of Glasgow+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+-- Low level IO routines interfacing the operating system.+--++module Streamly.FileSystem.FDIO+    ( write+    , writeAll+    , IOVec (..)+    , writev+    , writevAll+    )+where++#if !defined(mingw32_HOST_OS)+import Control.Concurrent (threadWaitWrite)+import Control.Monad (when)+import Data.Int (Int64)+import Foreign.C.Error (throwErrnoIfMinus1RetryMayBlock)+#if __GLASGOW_HASKELL__ >= 802+import Foreign.C.Types (CBool(..))+#endif+import System.Posix.Internals (c_write, c_safe_write)+import Streamly.FileSystem.IOVec (c_writev, c_safe_writev)+#endif++import Foreign.C.Types (CSize(..), CInt(..))+import Data.Word (Word8)+import Foreign.Ptr (plusPtr, Ptr)++import GHC.IO.FD (FD(..))++import Streamly.FileSystem.IOVec (IOVec(..))++-------------------------------------------------------------------------------+-- IO Routines+-------------------------------------------------------------------------------++-- See System.POSIX.Internals in GHC base package++-------------------------------------------------------------------------------+-- Write without blocking the underlying OS thread+-------------------------------------------------------------------------------++#if !defined(mingw32_HOST_OS)++foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool++isNonBlocking :: FD -> Bool+isNonBlocking fd = fdIsNonBlocking fd /= 0++-- "poll"s the fd for data to become available or timeout+-- See cbits/inputReady.c in base package+#if __GLASGOW_HASKELL__ >= 804+foreign import ccall unsafe "fdReady"+    unsafe_fdReady :: CInt -> CBool -> Int64 -> CBool -> IO CInt+#else+foreign import ccall safe "fdReady"+    unsafe_fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt+#endif++writeNonBlocking :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt+writeNonBlocking loc !fd !buf !off !len+    | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block+    | otherwise   = do+        let isWrite = 1+            isSocket = 0+            msecs = 0+        r <- unsafe_fdReady (fdFD fd) isWrite msecs isSocket+        when (r == 0) $ threadWaitWrite (fromIntegral (fdFD fd))+        if threaded then safe_write else unsafe_write++    where++    do_write call = fromIntegral `fmap`+                      throwErrnoIfMinus1RetryMayBlock loc call+                        (threadWaitWrite (fromIntegral (fdFD fd)))+    unsafe_write  = do_write (c_write (fdFD fd) (buf `plusPtr` off) len)+    safe_write    = do_write (c_safe_write (fdFD fd) (buf `plusPtr` off) len)++writevNonBlocking :: String -> FD -> Ptr IOVec -> Int -> IO CInt+writevNonBlocking loc !fd !iov !cnt+    | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block+    | otherwise   = do+        let isWrite = 1+            isSocket = 0+            msecs = 0+        r <- unsafe_fdReady (fdFD fd) isWrite msecs isSocket+        when (r == 0) $ threadWaitWrite (fromIntegral (fdFD fd))+        if threaded then safe_write else unsafe_write++    where++    do_write call = fromIntegral `fmap`+                      throwErrnoIfMinus1RetryMayBlock loc call+                        (threadWaitWrite (fromIntegral (fdFD fd)))+    unsafe_write  = do_write (c_writev (fdFD fd) iov (fromIntegral cnt))+    safe_write    = do_write (c_safe_writev (fdFD fd) iov (fromIntegral cnt))++#else+writeNonBlocking :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt+writeNonBlocking = undefined++writevNonBlocking :: String -> FD -> Ptr IOVec -> Int -> IO CInt+writevNonBlocking = undefined+#endif++-- Windows code is disabled for now+#if 0++#if defined(mingw32_HOST_OS)+# if defined(i386_HOST_ARCH)+#  define WINDOWS_CCONV stdcall+# elif defined(x86_64_HOST_ARCH)+#  define WINDOWS_CCONV ccall+# else+#  error Unknown mingw32 arch+# endif+#endif++foreign import WINDOWS_CCONV safe "recv"+   c_safe_recv :: CInt -> Ptr Word8 -> CInt -> CInt{-flags-} -> IO CInt++foreign import WINDOWS_CCONV safe "send"+   c_safe_send :: CInt -> Ptr Word8 -> CInt -> CInt{-flags-} -> IO CInt++blockingWriteRawBufferPtr :: String -> FD -> Ptr Word8-> Int -> CSize -> IO CInt+blockingWriteRawBufferPtr loc !fd !buf !off !len+  = throwErrnoIfMinus1Retry loc $ do+        let start_ptr = buf `plusPtr` off+            send_ret = c_safe_send  (fdFD fd) start_ptr (fromIntegral len) 0+            write_ret = c_safe_write (fdFD fd) start_ptr (fromIntegral len)+        r <- bool write_ret send_ret (fdIsSocket fd)+        when (r == -1) c_maperrno+        return r+      -- We don't trust write() to give us the correct errno, and+      -- instead do the errno conversion from GetLastError()+      -- ourselves. The main reason is that we treat ERROR_NO_DATA+      -- (pipe is closing) as EPIPE, whereas write() returns EINVAL+      -- for this case. We need to detect EPIPE correctly, because it+      -- shouldn't be reported as an error when it happens on stdout.+      -- As for send()'s case, Winsock functions don't do errno+      -- conversion in any case so we have to do it ourselves.+      -- That means we're doing the errno conversion no matter if the+      -- fd is from a socket or not.++-- NOTE: "safe" versions of the read/write calls for use by the threaded RTS.+-- These calls may block, but that's ok.++asyncWriteRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt+asyncWriteRawBufferPtr loc !fd !buf !off !len = do+    (l, rc) <- asyncWrite (fromIntegral (fdFD fd)) (fdIsSocket_ fd)+                  (fromIntegral len) (buf `plusPtr` off)+    if l == (-1)+      then let sock_errno = c_maperrno_func (fromIntegral rc)+               non_sock_errno = Errno (fromIntegral rc)+               errno = bool non_sock_errno sock_errno (fdIsSocket fd)+           in  ioError (errnoToIOError loc errno Nothing Nothing)+      else return (fromIntegral l)++writeNonBlocking :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt+writeNonBlocking loc !fd !buf !off !len+    | threaded  = blockingWriteRawBufferPtr loc fd buf off len+    | otherwise = asyncWriteRawBufferPtr    loc fd buf off len++#endif++-- | @write FD buffer offset length@ tries to write data on the given+-- filesystem fd (cannot be a socket) up to sepcified length starting from the+-- given offset in the buffer. The write will not block the OS thread, it may+-- suspend the Haskell thread until write can proceed.  Returns the actual+-- amount of data written.+write :: FD -> Ptr Word8 -> Int -> CSize -> IO CInt+write = writeNonBlocking "Streamly.FileSystem.FDIO"++-- XXX sendAll for sockets has a similar code, we can deduplicate the two.+-- XXX we need to check the errno to determine if the loop should continue. For+-- example, write may return without writing all data if the process file-size+-- limit has reached, in that case keep writing in a loop is fruitless.+--+-- | Keep writing in a loop until all data in the buffer has been written.+writeAll :: FD -> Ptr Word8 -> Int -> IO ()+writeAll fd ptr bytes = do+    res <- write fd ptr 0 (fromIntegral bytes)+    let res' = fromIntegral res+    if res' < bytes+    then writeAll fd (ptr `plusPtr` res') (bytes - res')+    else return ()++-------------------------------------------------------------------------------+-- Vector IO+-------------------------------------------------------------------------------++-- | @write FD iovec count@ tries to write data on the given filesystem fd+-- (cannot be a socket) from an iovec with specified number of entries.  The+-- write will not block the OS thread, it may suspend the Haskell thread until+-- write can proceed.  Returns the actual amount of data written.+writev :: FD -> Ptr IOVec -> Int -> IO CInt+writev = writevNonBlocking "Streamly.FileSystem.FDIO"++-- XXX incomplete+-- | Keep writing an iovec in a loop until all the iovec entries are written.+writevAll :: FD -> Ptr IOVec -> Int -> IO ()+writevAll fd iovec count = do+    _res <- writev fd iovec count+    {-+    let res' = fromIntegral res+    totalBytes = countIOVecBytes+    if res' < totalBytes+     then do+        let iovec' = createModifiedIOVec+            count' = ...+        writeAll fd iovec' count'+     else return ()+    -}+    return ()
+ src/Streamly/FileSystem/Handle.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE UnboxedTuples #-}++#include "inline.hs"++-- |+-- Module      : Streamly.FileSystem.Handle+-- Copyright   : (c) 2018 Composewell Technologies+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+-- Read and write streams and arrays to and from file handles. File handle IO+-- APIs are quite similar to "Streamly.Memory.Array" read write APIs. In that+-- regard, arrays can be considered as in-memory files or files can be+-- considered as on-disk arrays.+--+-- Control over file reading and writing behavior in terms of buffering,+-- encoding, decoding is in the hands of the programmer, the 'TextEncoding',+-- 'NewLineMode', and 'Buffering' options of the underlying handle provided by+-- GHC are not needed and ignored.+--+-- = Programmer Notes+--+-- > import qualified Streamly.FileSystem.Handle as FH+--+-- For additional, experimental APIs take a look at+-- "Streamly.Internal.FileSystem.Handle" module.+--+-- = Performance Notes+--+-- In some cases the stream type based APIs in the+-- "Streamly.Internal.FileSystem.Handle" module may be more efficient compared+-- to the unfold/fold based APIs exposed from this module because of better+-- fusion by GHC. However, with the streamly fusion GHC plugin (upcoming) these+-- APIs would perform as well as the stream based APIs in all cases.++-- IO APIs are divided into two categories, sequential streaming IO APIs and+-- random access IO APIs.++module Streamly.FileSystem.Handle+    (+    -- * Sequential/Streaming IO+    -- | Stream data to or from a file or device sequentially.  When reading,+    -- the stream is lazy and generated on-demand as the consumer consumes it.+    -- Read IO requests to the IO device are performed in chunks limited to a+    -- maximum size of 32KiB, this is referred to as+    -- 'Streamly.Internal.Memory.Array.Types.defaultChunkSize' in the+    -- documentation. One IO request may or may not read the full+    -- chunk. If the whole stream is not consumed, it is possible that we may+    -- read slightly more from the IO device than what the consumer needed.+    -- Unless specified otherwise in the API, writes are collected into chunks+    -- of 'Streamly.Internal.Memory.Array.Types.defaultChunkSize' before they+    -- are written to the IO device.++    -- Streaming APIs work for all kind of devices, seekable or non-seekable;+    -- including disks, files, memory devices, terminals, pipes, sockets and+    -- fifos. While random access APIs work only for files or devices that have+    -- random access or seek capability for example disks, memory devices.+    -- Devices like terminals, pipes, sockets and fifos do not have random+    -- access capability.++    -- ** Read From Handle+    -- | 'TextEncoding', 'NewLineMode', and 'Buffering' options of the+    -- underlying handle are ignored. The read occurs from the current seek+    -- position of the file handle. The stream ends as soon as EOF is+    -- encountered.++      read+    , readWithBufferOf+    , readChunks+    , readChunksWithBufferOf++    -- ** Write to Handle+    -- | 'TextEncoding', 'NewLineMode', and 'Buffering' options of the+    -- underlying handle are ignored. The write occurs from the current seek+    -- position of the file handle.  The write behavior depends on the 'IOMode'+    -- of the handle.++    , write+    , writeWithBufferOf+    , writeChunks+    )+where++import Streamly.Internal.FileSystem.Handle+import Prelude hiding (read)
+ src/Streamly/FileSystem/IOVec.hsc view
@@ -0,0 +1,80 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CApiFFI #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Module      : Streamly.FileSystem.IOVec+-- Copyright   : (c) 2019 Composewell Technologies+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+-- Low level IO routines interfacing the operating system.+--++module Streamly.FileSystem.IOVec+    ( IOVec(..)+    , c_writev+    , c_safe_writev+    )+where++import Data.Word (Word8, Word64)+import Foreign.C.Types (CInt(..))+import Foreign.Ptr (Ptr)+import System.Posix.Types (CSsize(..))+#if !defined(mingw32_HOST_OS)+import Foreign.Storable (Storable(..))+#endif++-------------------------------------------------------------------------------+-- IOVec+-------------------------------------------------------------------------------++data IOVec = IOVec+  { iovBase :: {-# UNPACK #-} !(Ptr Word8)+  , iovLen  :: {-# UNPACK #-} !Word64+  } deriving (Eq, Show)++#if !defined(mingw32_HOST_OS)++#include <sys/uio.h>++#if __GLASGOW_HASKELL__ < 800+#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)+#endif++instance Storable IOVec where+  sizeOf _ = #{size struct iovec}+  alignment _ = #{alignment struct iovec}+  peek ptr = do+      base <- #{peek struct iovec, iov_base} ptr+      len  :: #{type size_t} <- #{peek struct iovec, iov_len}  ptr+      return $ IOVec base len+  poke ptr vec = do+      let base = iovBase vec+          len  :: #{type size_t} = iovLen  vec+      #{poke struct iovec, iov_base} ptr base+      #{poke struct iovec, iov_len}  ptr len+#endif++-- capi calling convention does not work without -fobject-code option with GHCi+-- so using this in DEVBUILD only for now.+--+#if !defined(mingw32_HOST_OS) && defined DEVBUILD+foreign import capi unsafe "sys/uio.h writev"+   c_writev :: CInt -> Ptr IOVec -> CInt -> IO CSsize++foreign import capi safe "sys/uio.h writev"+   c_safe_writev :: CInt -> Ptr IOVec -> CInt -> IO CSsize++#else+c_writev :: CInt -> Ptr IOVec -> CInt -> IO CSsize+c_writev = error "writev not implemented"++c_safe_writev :: CInt -> Ptr IOVec -> CInt -> IO CSsize+c_safe_writev = error "writev not implemented"+#endif
− src/Streamly/Internal.hs 
@@ -1,19 +0,0 @@--- |--- Module      : Streamly.Internal--- Copyright   : (c) 2018 Harendra Kumar------ License     : BSD3--- Maintainer  : harendra.kumar@gmail.com--- Stability   : experimental--- Portability : GHC------ This module is only for internal use. There is no warranty for the routines--- in this module to work correctly, please use at your own risk. These--- routines are subject to change or be removed without notice.----module Streamly.Internal-    ( inspectMode-    )-where--import Streamly.Streams.Combinators (inspectMode)
+ src/Streamly/Internal/Data/Atomics.hs view
@@ -0,0 +1,83 @@+{-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE CPP         #-}++-- |+-- Module      : Streamly.Internal.Data.Atomics+-- Copyright   : (c) 2018-2019 Composewell Technologies+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++module Streamly.Internal.Data.Atomics+    (+      atomicModifyIORefCAS+    , atomicModifyIORefCAS_+    , writeBarrier+    , storeLoadBarrier+    )+where++import Data.IORef (IORef, atomicModifyIORef)+#ifdef ghcjs_HOST_OS+import Data.IORef (modifyIORef)+#else+import qualified Data.Atomics as A+#endif++#ifndef ghcjs_HOST_OS++-- XXX Does it make sense to have replacements for atomicModifyIORef etc. on a+-- single threaded system.+--+-- Slightly faster version of CAS. Gained some improvement by avoiding the use+-- of "evaluate" because we know we do not have exceptions in fn.+{-# INLINE atomicModifyIORefCAS #-}+atomicModifyIORefCAS :: IORef a -> (a -> (a,b)) -> IO b+atomicModifyIORefCAS ref fn = do+    tkt <- A.readForCAS ref+    loop tkt retries++    where++    retries = 25 :: Int+    loop _   0     = atomicModifyIORef ref fn+    loop old tries = do+        let (new, result) = fn $ A.peekTicket old+        (success, tkt) <- A.casIORef ref old new+        if success+        then return result+        else loop tkt (tries - 1)++{-# INLINE atomicModifyIORefCAS_ #-}+atomicModifyIORefCAS_ :: IORef t -> (t -> t) -> IO ()+atomicModifyIORefCAS_ = A.atomicModifyIORefCAS_++{-# INLINE writeBarrier #-}+writeBarrier :: IO ()+writeBarrier = A.writeBarrier++{-# INLINE storeLoadBarrier #-}+storeLoadBarrier :: IO ()+storeLoadBarrier = A.storeLoadBarrier++#else++{-# INLINE atomicModifyIORefCAS #-}+atomicModifyIORefCAS :: IORef a -> (a -> (a,b)) -> IO b+atomicModifyIORefCAS = atomicModifyIORef++{-# INLINE atomicModifyIORefCAS_ #-}+atomicModifyIORefCAS_ :: IORef a -> (a -> a) -> IO ()+atomicModifyIORefCAS_ = modifyIORef++{-# INLINE writeBarrier #-}+writeBarrier :: IO ()+writeBarrier = return ()++{-# INLINE storeLoadBarrier #-}+storeLoadBarrier :: IO ()+storeLoadBarrier = return ()++#endif
+ src/Streamly/Internal/Data/Fold.hs view
@@ -0,0 +1,1209 @@+{-# OPTIONS_HADDOCK hide               #-}+{-# LANGUAGE BangPatterns              #-}+{-# LANGUAGE CPP                       #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE RankNTypes                #-}+{-# LANGUAGE RecordWildCards           #-}+{-# LANGUAGE ScopedTypeVariables       #-}++-- |+-- Module      : Streamly.Internal.Data.Fold+-- Copyright   : (c) 2019 Composewell Technologies+--               (c) 2013 Gabriel Gonzalez+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++-- Also see the "Streamly.Internal.Data.Sink" module that provides specialized left folds+-- that discard the outputs.+--+-- IMPORTANT: keep the signatures consistent with the folds in Streamly.Prelude++module Streamly.Internal.Data.Fold+    (+    -- * Fold Type+      Fold (..)++    , hoist+    , generally++    -- , tail+    -- , init++    -- * Fold Creation Utilities+    , mkPure+    , mkPureId+    , mkFold+    , mkFoldId++    -- ** Full Folds+    , drain+    , drainBy+    , drainBy2+    , last+    , length+    , sum+    , product+    , maximumBy+    , maximum+    , minimumBy+    , minimum+    -- , the+    , mean+    , variance+    , stdDev+    , rollingHash+    , rollingHashWithSalt+    -- , rollingHashFirstN+    -- , rollingHashLastN++    -- ** Full Folds (Monoidal)+    , mconcat+    , foldMap+    , foldMapM++    -- ** Full Folds (To Containers)++    , toList+    , toListRevF  -- experimental++    -- ** Partial Folds+    -- , drainN+    -- , drainWhile+    -- , lastN+    -- , (!!)+    -- , genericIndex+    , index+    , head+    -- , findM+    , find+    , lookup+    , findIndex+    , elemIndex+    , null+    , elem+    , notElem+    -- XXX these are slower than right folds even when full input is used+    , all+    , any+    , and+    , or++    -- * Transformations++    -- ** Covariant Operations+    , sequence+    , mapM++    -- ** Mapping+    , transform+    , lmap+    --, lsequence+    , lmapM+    -- ** Filtering+    , lfilter+    , lfilterM+    -- , ldeleteBy+    -- , luniq+    , lcatMaybes++    {-+    -- ** Mapping Filters+    , lmapMaybe+    , lmapMaybeM++    -- ** Scanning Filters+    , lfindIndices+    , lelemIndices++    -- ** Insertion+    -- | Insertion adds more elements to the stream.++    , linsertBy+    , lintersperseM++    -- ** Reordering+    , lreverse+    -}++    -- * Parsing+    -- ** Trimming+    , ltake+    -- , lrunFor -- time+    , ltakeWhile+    {-+    , ltakeWhileM+    , ldrop+    , ldropWhile+    , ldropWhileM+    -}++    , lsessionsOf+    , lchunksOf++    -- * Distributing++    , tee+    , distribute++    -- * Partitioning++    -- , partitionByM+    -- , partitionBy+    , partition++    -- * Demultiplexing++    , demux+    -- , demuxWith+    , demux_+    -- , demuxWith_++    -- * Classifying++    , classify+    -- , classifyWith++    -- * Unzipping+    , unzip+    -- These can be expressed using lmap/lmapM and unzip+    -- , unzipWith+    -- , unzipWithM++    -- * Running Folds+    , initialize+    , runStep++    -- * Nested Folds+    -- , concatMap+    -- , chunksOf+    , duplicate  -- experimental+    )+where++import Control.Monad (void)+import Data.Functor.Identity (Identity(..))+import Data.Map.Strict (Map)++import Prelude+       hiding (filter, drop, dropWhile, take, takeWhile, zipWith, foldr,+               foldl, map, 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, mconcat, foldMap, unzip,+               span, splitAt, break, mapM)++import qualified Data.Map.Strict as Map+import qualified Prelude++import Streamly.Internal.Data.Pipe.Types (Pipe (..), PipeState(..))+import Streamly.Internal.Data.Fold.Types+import Streamly.Internal.Data.Strict++import qualified Streamly.Internal.Data.Pipe.Types as Pipe++------------------------------------------------------------------------------+-- Smart constructors+------------------------------------------------------------------------------++-- | Make a fold using a pure step function, a pure initial state and+-- a pure state extraction function.+--+-- /Internal/+--+{-# INLINE mkPure #-}+mkPure :: Monad m => (s -> a -> s) -> s -> (s -> b) -> Fold m a b+mkPure step initial extract =+    Fold (\s a -> return $ step s a) (return initial) (return . extract)++-- | Make a fold using a pure step function and a pure initial state. The+-- final state extracted is identical to the intermediate state.+--+-- /Internal/+--+{-# INLINE mkPureId #-}+mkPureId :: Monad m => (b -> a -> b) -> b -> Fold m a b+mkPureId step initial = mkPure step initial id++-- | Make a fold with an effectful step function and initial state, and a state+-- extraction function.+--+-- > mkFold = Fold+--+--  We can just use 'Fold' but it is provided for completeness.+--+-- /Internal/+--+{-# INLINE mkFold #-}+mkFold :: (s -> a -> m s) -> m s -> (s -> m b) -> Fold m a b+mkFold = Fold++-- | Make a fold with an effectful step function and initial state.  The final+-- state extracted is identical to the intermediate state.+--+-- /Internal/+--+{-# INLINE mkFoldId #-}+mkFoldId :: Monad m => (b -> a -> m b) -> m b -> Fold m a b+mkFoldId step initial = Fold step initial return++------------------------------------------------------------------------------+-- hoist+------------------------------------------------------------------------------++-- | Change the underlying monad of a fold+--+-- /Internal/+hoist :: (forall x. m x -> n x) -> Fold m a b -> Fold n a b+hoist f (Fold step initial extract) =+    Fold (\x a -> f $ step x a) (f initial) (f . extract)++-- | Adapt a pure fold to any monad+--+-- > generally = hoist (return . runIdentity)+--+-- /Internal/+generally :: Monad m => Fold Identity a b -> Fold m a b+generally = hoist (return . runIdentity)++------------------------------------------------------------------------------+-- Transformations on fold inputs+------------------------------------------------------------------------------++-- | Flatten the monadic output of a fold to pure output.+--+-- @since 0.7.0+{-# INLINE sequence #-}+sequence :: Monad m => Fold m a (m b) -> Fold m a b+sequence (Fold step initial extract) = Fold step initial extract'+  where+    extract' x = do+        act <- extract x+        act >>= return++-- | Map a monadic function on the output of a fold.+--+-- @since 0.7.0+{-# INLINE mapM #-}+mapM :: Monad m => (b -> m c) -> Fold m a b -> Fold m a c+mapM f = sequence . fmap f++------------------------------------------------------------------------------+-- Transformations on fold inputs+------------------------------------------------------------------------------++-- rename to lpipe?+--+-- | Apply a transformation on a 'Fold' using a 'Pipe'.+--+-- @since 0.7.0+{-# INLINE transform #-}+transform :: Monad m => Pipe m a b -> Fold m b c -> Fold m a c+transform (Pipe pstep1 pstep2 pinitial) (Fold fstep finitial fextract) =+    Fold step initial extract++    where++    initial = Tuple' <$> return pinitial <*> finitial+    step (Tuple' ps fs) x = do+        r <- pstep1 ps x+        go fs r++        where+        -- XXX use SPEC?+        go acc (Pipe.Yield b (Consume ps')) = do+            acc' <- fstep acc b+            return (Tuple' ps' acc')++        go acc (Pipe.Yield b (Produce ps')) = do+            acc' <- fstep acc b+            r <- pstep2 ps'+            go acc' r++        go acc (Pipe.Continue (Consume ps')) = return (Tuple' ps' acc)++        go acc (Pipe.Continue (Produce ps')) = do+            r <- pstep2 ps'+            go acc r++    extract (Tuple' _ fs) = fextract fs++------------------------------------------------------------------------------+-- Utilities+------------------------------------------------------------------------------++-- | @_Fold1 step@ returns a new 'Fold' using just a step function that has the+-- same type for the accumulator and the element. The result type is the+-- accumulator type wrapped in 'Maybe'. The initial accumulator is retrieved+-- 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+  where+    step_ mx a = return $ Just' $+        case mx of+            Nothing' -> a+            Just' x -> step x a++------------------------------------------------------------------------------+-- Left folds+------------------------------------------------------------------------------++------------------------------------------------------------------------------+-- Run Effects+------------------------------------------------------------------------------++-- | A fold that drains all its input, running the effects and discarding the+-- results.+--+-- @since 0.7.0+{-# INLINABLE drain #-}+drain :: Monad m => Fold m a ()+drain = Fold step begin done+    where+    begin = return ()+    step _ _ = return ()+    done = return++-- |+-- > drainBy f = lmapM f drain+--+-- Drain all input after passing it through a monadic function. This is the+-- dual of mapM_ on stream producers.+--+-- @since 0.7.0+{-# INLINABLE drainBy #-}+drainBy ::  Monad m => (a -> m b) -> Fold m a ()+drainBy f = Fold (const (void . f)) (return ()) return++{-# INLINABLE drainBy2 #-}+drainBy2 ::  Monad m => (a -> m b) -> Fold2 m c a ()+drainBy2 f = Fold2 (const (void . f)) (\_ -> return ()) return++-- | Extract the last element of the input stream, if any.+--+-- @since 0.7.0+{-# INLINABLE last #-}+last :: Monad m => Fold m a (Maybe a)+last = _Fold1 (flip const)++------------------------------------------------------------------------------+-- To Summary+------------------------------------------------------------------------------++-- | Like 'length', except with a more general 'Num' return value+--+-- @since 0.7.0+{-# INLINABLE genericLength #-}+genericLength :: (Monad m, Num b) => Fold m a b+genericLength = Fold (\n _ -> return $ n + 1) (return 0) return++-- | Determine the length of the input stream.+--+-- @since 0.7.0+{-# INLINABLE length #-}+length :: Monad m => Fold m a Int+length = genericLength++-- | Determine the sum of all elements of a stream of numbers. Returns additive+-- identity (@0@) when the stream is empty. Note that this is not numerically+-- stable for floating point numbers.+--+-- @since 0.7.0+{-# INLINABLE sum #-}+sum :: (Monad m, Num a) => Fold m a a+sum = Fold (\x a -> return $ x + a) (return 0) return++-- | Determine the product of all elements of a stream of numbers. Returns+-- multiplicative identity (@1@) when the stream is empty.+--+-- @since 0.7.0+{-# INLINABLE product #-}+product :: (Monad m, Num a) => Fold m a a+product = Fold (\x a -> return $ x * a) (return 1) return++------------------------------------------------------------------------------+-- To Summary (Maybe)+------------------------------------------------------------------------------++-- | Determine the maximum element in a stream using the supplied comparison+-- function.+--+-- @since 0.7.0+{-# INLINABLE maximumBy #-}+maximumBy :: Monad m => (a -> a -> Ordering) -> Fold m a (Maybe a)+maximumBy cmp = _Fold1 max'+  where+    max' x y = case cmp x y of+        GT -> x+        _  -> y++-- |+-- @+-- maximum = 'maximumBy' compare+-- @+--+-- Determine the maximum element in a stream.+--+-- @since 0.7.0+{-# INLINABLE maximum #-}+maximum :: (Monad m, Ord a) => Fold m a (Maybe a)+maximum = _Fold1 max++-- | Computes the minimum element with respect to the given comparison function+--+-- @since 0.7.0+{-# INLINABLE minimumBy #-}+minimumBy :: Monad m => (a -> a -> Ordering) -> Fold m a (Maybe a)+minimumBy cmp = _Fold1 min'+  where+    min' x y = case cmp x y of+        GT -> y+        _  -> x++-- | Determine the minimum element in a stream using the supplied comparison+-- function.+--+-- @since 0.7.0+{-# INLINABLE minimum #-}+minimum :: (Monad m, Ord a) => Fold m a (Maybe a)+minimum = _Fold1 min++------------------------------------------------------------------------------+-- To Summary (Statistical)+------------------------------------------------------------------------------++-- | Compute a numerically stable arithmetic mean of all elements in the input+-- stream.+--+-- @since 0.7.0+{-# INLINABLE mean #-}+mean :: (Monad m, Fractional a) => Fold m a a+mean = Fold step (return begin) (return . done)+  where+    begin = Tuple' 0 0+    step (Tuple' x n) y = return $+        let n' = n + 1+        in Tuple' (x + (y - x) / n') n'+    done (Tuple' x _) = x++-- | Compute a numerically stable (population) variance over all elements in+-- the input stream.+--+-- @since 0.7.0+{-# INLINABLE variance #-}+variance :: (Monad m, Fractional a) => Fold m a a+variance = Fold step (return begin) (return . done)+  where+    begin = Tuple3' 0 0 0++    step (Tuple3' n mean_ m2) x = return $ Tuple3' n' mean' m2'+      where+        n'     = n + 1+        mean'  = (n * mean_ + x) / (n + 1)+        delta  = x - mean_+        m2'    = m2 + delta * delta * n / (n + 1)++    done (Tuple3' n _ m2) = m2 / n++-- | Compute a numerically stable (population) standard deviation over all+-- elements in the input stream.+--+-- @since 0.7.0+{-# INLINABLE stdDev #-}+stdDev :: (Monad m, Floating a) => Fold m a a+stdDev = sqrt variance++-- | Compute an 'Int' sized polynomial rolling hash+--+-- > H = salt * k ^ n + c1 * k ^ (n - 1) + c2 * k ^ (n - 2) + ... + cn * k ^ 0+--+-- Where @c1@, @c2@, @cn@ are the elements in the input stream and @k@ is a+-- constant.+--+-- This hash is often used in Rabin-Karp string search algorithm.+--+-- See https://en.wikipedia.org/wiki/Rolling_hash+--+-- @since 0.7.0+{-# INLINABLE rollingHashWithSalt #-}+rollingHashWithSalt :: (Monad m, Enum a) => Int -> Fold m a Int+rollingHashWithSalt salt = Fold step initial extract+    where+    k = 2891336453+    initial = return salt+    step cksum a = return $ cksum * k + fromEnum a+    extract = return++-- | A default salt used in the implementation of 'rollingHash'.+{-# INLINE defaultSalt #-}+defaultSalt :: Int+#if WORD_SIZE_IN_BITS == 64+defaultSalt = 0xdc36d1615b7400a4+#else+defaultSalt = 0x087fc72c+#endif++-- | Compute an 'Int' sized polynomial rolling hash of a stream.+--+-- > rollingHash = rollingHashWithSalt defaultSalt+--+-- @since 0.7.0+{-# INLINABLE rollingHash #-}+rollingHash :: (Monad m, Enum a) => Fold m a Int+rollingHash = rollingHashWithSalt defaultSalt++------------------------------------------------------------------------------+-- Monoidal left folds+------------------------------------------------------------------------------++-- | Fold an input stream consisting of monoidal elements using 'mappend'+-- and 'mempty'.+--+-- > S.fold FL.mconcat (S.map Sum $ S.enumerateFromTo 1 10)+--+-- @since 0.7.0+{-# INLINABLE mconcat #-}+mconcat :: (Monad m, Monoid a) => Fold m a a+mconcat = Fold (\x a -> return $ mappend x a) (return mempty) return++-- |+-- > foldMap f = map f mconcat+--+-- Make a fold from a pure function that folds the output of the function+-- using 'mappend' and 'mempty'.+--+-- > S.fold (FL.foldMap Sum) $ S.enumerateFromTo 1 10+--+-- @since 0.7.0+{-# INLINABLE foldMap #-}+foldMap :: (Monad m, Monoid b) => (a -> b) -> Fold m a b+foldMap f = lmap f mconcat++-- |+-- > foldMapM f = mapM f mconcat+--+-- Make a fold from a monadic function that folds the output of the function+-- using 'mappend' and 'mempty'.+--+-- > S.fold (FL.foldMapM (return . Sum)) $ S.enumerateFromTo 1 10+--+-- @since 0.7.0+{-# INLINABLE foldMapM #-}+foldMapM ::  (Monad m, Monoid b) => (a -> m b) -> Fold m a b+foldMapM act = Fold step begin done+    where+    done = return+    begin = return mempty+    step m a = do+        m' <- act a+        return $! mappend m m'++------------------------------------------------------------------------------+-- To Containers+------------------------------------------------------------------------------++-- | 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.+--+-- @since 0.7.0++-- id . (x1 :) . (x2 :) . (x3 :) . ... . (xn :) $ []+{-# INLINABLE toList #-}+toList :: Monad m => Fold m a [a]+toList = Fold (\f x -> return $ f . (x :))+              (return id)+              (return . ($ []))++------------------------------------------------------------------------------+-- Partial Folds+------------------------------------------------------------------------------++------------------------------------------------------------------------------+-- To Elements+------------------------------------------------------------------------------++-- | Like 'index', except with a more general 'Integral' argument+--+-- @since 0.7.0+{-# INLINABLE genericIndex #-}+genericIndex :: (Integral i, Monad m) => i -> Fold m a (Maybe a)+genericIndex i = Fold step (return $ Left' 0) done+  where+    step x a = return $+        case x of+            Left'  j -> if i == j+                        then Right' a+                        else Left' (j + 1)+            _        -> x+    done x = return $+        case x of+            Left'  _ -> Nothing+            Right' a -> Just a++-- | Lookup the element at the given index.+--+-- @since 0.7.0+{-# INLINABLE index #-}+index :: Monad m => Int -> Fold m a (Maybe a)+index = genericIndex++-- | Extract the first element of the stream, if any.+--+-- @since 0.7.0+{-# INLINABLE head #-}+head :: Monad m => Fold m a (Maybe a)+head = _Fold1 const++-- | Returns the first element that satisfies the given predicate.+--+-- @since 0.7.0+{-# INLINABLE find #-}+find :: Monad m => (a -> Bool) -> Fold m a (Maybe a)+find predicate = Fold step (return Nothing') fromStrictMaybe+  where+    step x a = return $+        case x of+            Nothing' -> if predicate a+                        then Just' a+                        else Nothing'+            _        -> x++-- | 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@.+--+-- @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+  where+    step x (a,b) = return $+        case x of+            Nothing' -> if a == a0+                        then Just' b+                        else Nothing'+            _ -> x++-- | Convert strict 'Either'' to lazy 'Maybe'+{-# INLINABLE hush #-}+hush :: Either' a b -> Maybe b+hush (Left'  _) = Nothing+hush (Right' b) = Just b++-- | Returns the first index that satisfies the given predicate.+--+-- @since 0.7.0+{-# INLINABLE findIndex #-}+findIndex :: Monad m => (a -> Bool) -> Fold m a (Maybe Int)+findIndex predicate = Fold step (return $ Left' 0) (return . hush)+  where+    step x a = return $+        case x of+            Left' i ->+                if predicate a+                then Right' i+                else Left' (i + 1)+            _       -> x++-- | Returns the first index where a given value is found in the stream.+--+-- @since 0.7.0+{-# INLINABLE elemIndex #-}+elemIndex :: (Eq a, Monad m) => a -> Fold m a (Maybe Int)+elemIndex a = findIndex (a ==)++------------------------------------------------------------------------------+-- To Boolean+------------------------------------------------------------------------------++-- | Return 'True' if the input stream is empty.+--+-- @since 0.7.0+{-# INLINABLE null #-}+null :: Monad m => Fold m a Bool+null = Fold (\_ _ -> return False) (return True) return++-- |+-- > any p = lmap p or+--+-- | Returns 'True' if any of the elements of a stream satisfies a predicate.+--+-- @since 0.7.0+{-# INLINABLE any #-}+any :: Monad m => (a -> Bool) -> Fold m a Bool+any predicate = Fold (\x a -> return $ x || predicate a) (return False) return++-- | Return 'True' if the given element is present in the stream.+--+-- @since 0.7.0+{-# INLINABLE elem #-}+elem :: (Eq a, Monad m) => a -> Fold m a Bool+elem a = any (a ==)++-- |+-- > all p = lmap p and+--+-- | Returns 'True' if all elements of a stream satisfy a predicate.+--+-- @since 0.7.0+{-# INLINABLE all #-}+all :: Monad m => (a -> Bool) -> Fold m a Bool+all predicate = Fold (\x a -> return $ x && predicate a) (return True) return++-- | Returns 'True' if the given element is not present in the stream.+--+-- @since 0.7.0+{-# INLINABLE notElem #-}+notElem :: (Eq a, Monad m) => a -> Fold m a Bool+notElem a = all (a /=)++-- | Returns 'True' if all elements are 'True', 'False' otherwise+--+-- @since 0.7.0+{-# INLINABLE and #-}+and :: Monad m => Fold m Bool Bool+and = Fold (\x a -> return $ x && a) (return True) return++-- | Returns 'True' if any element is 'True', 'False' otherwise+--+-- @since 0.7.0+{-# INLINABLE or #-}+or :: Monad m => Fold m Bool Bool+or = Fold (\x a -> return $ x || a) (return False) return++------------------------------------------------------------------------------+-- Distributing+------------------------------------------------------------------------------+--+-- | Distribute one copy of the stream to each fold and zip the results.+--+-- @+--                 |-------Fold m a b--------|+-- ---stream m a---|                         |---m (b,c)+--                 |-------Fold m a c--------|+-- @+-- >>> S.fold (FL.tee FL.sum FL.length) (S.enumerateFromTo 1.0 100.0)+-- (5050.0,100)+--+-- @since 0.7.0+{-# INLINE tee #-}+tee :: Monad m => Fold m a b -> Fold m a c -> Fold m a (b,c)+tee f1 f2 = (,) <$> f1 <*> f2++{-# INLINE foldNil #-}+foldNil :: Monad m => Fold m a [b]+foldNil = Fold step begin done  where+  begin = return []+  step _ _ = return []+  done = return++{-# INLINE foldCons #-}+foldCons :: Monad m => Fold m a b -> Fold m a [b] -> Fold m a [b]+foldCons (Fold stepL beginL doneL) (Fold stepR beginR doneR) =+    Fold step begin done++    where++    begin = Tuple' <$> beginL <*> beginR+    step (Tuple' xL xR) a = Tuple' <$> stepL xL a <*> stepR xR a+    done (Tuple' xL xR) = (:) <$> (doneL xL) <*> (doneR xR)++-- XXX use "List" instead of "[]"?, use Array for output to scale it to a large+-- number of consumers? For polymorphic case a vector could be helpful. For+-- Storables we can use arrays. Will need separate APIs for those.+--+-- | Distribute one copy of the stream to each fold and collect the results in+-- a container.+--+-- @+--+--                 |-------Fold m a b--------|+-- ---stream m a---|                         |---m [b]+--                 |-------Fold m a b--------|+--                 |                         |+--                            ...+-- @+--+-- >>> S.fold (FL.distribute [FL.sum, FL.length]) (S.enumerateFromTo 1 5)+-- [15,5]+--+-- This is the consumer side dual of the producer side 'sequence' operation.+--+-- @since 0.7.0+{-# INLINE distribute #-}+distribute :: Monad m => [Fold m a b] -> Fold m a [b]+distribute [] = foldNil+distribute (x:xs) = foldCons x (distribute xs)++------------------------------------------------------------------------------+-- Partitioning+------------------------------------------------------------------------------+--+-- | Partition the input over two folds using an 'Either' partitioning+-- predicate.+--+-- @+--+--                                     |-------Fold b x--------|+-- -----stream m a --> (Either b c)----|                       |----(x,y)+--                                     |-------Fold c y--------|+-- @+--+-- Send input to either fold randomly:+--+-- >>> import System.Random (randomIO)+-- >>> randomly a = randomIO >>= \x -> return $ if x then Left a else Right a+-- >>> S.fold (FL.partitionByM randomly FL.length FL.length) (S.enumerateFromTo 1 100)+-- (59,41)+--+-- Send input to the two folds in a proportion of 2:1:+--+-- @+-- import Data.IORef (newIORef, readIORef, writeIORef)+-- proportionately m n = do+--  ref <- newIORef $ cycle $ concat [replicate m Left, replicate n Right]+--  return $ \\a -> do+--      r <- readIORef ref+--      writeIORef ref $ tail r+--      return $ head r a+--+-- main = do+--  f <- proportionately 2 1+--  r <- S.fold (FL.partitionByM f FL.length FL.length) (S.enumerateFromTo (1 :: Int) 100)+--  print r+-- @+-- @+-- (67,33)+-- @+--+-- This is the consumer side dual of the producer side 'mergeBy' operation.+--+-- @since 0.7.0+{-# INLINE partitionByM #-}+partitionByM :: Monad m+    => (a -> m (Either b c)) -> Fold m b x -> Fold m c y -> Fold m a (x, y)+partitionByM f (Fold stepL beginL doneL) (Fold stepR beginR doneR) =++    Fold step begin done++    where++    begin = Tuple' <$> beginL <*> beginR+    step (Tuple' xL xR) a = do+        r <- f a+        case r of+            Left b -> Tuple' <$> stepL xL b <*> return xR+            Right c -> Tuple' <$> return xL <*> stepR xR c+    done (Tuple' xL xR) = (,) <$> doneL xL <*> doneR xR++-- Note: we could use (a -> Bool) instead of (a -> Either b c), but the latter+-- makes the signature clearer as to which case belongs to which fold.+-- XXX need to check the performance in both cases.++-- | Same as 'partitionByM' but with a pure partition function.+--+-- Count even and odd numbers in a stream:+--+-- @+-- >>> let f = FL.partitionBy (\\n -> if even n then Left n else Right n)+--                       (fmap (("Even " ++) . show) FL.length)+--                       (fmap (("Odd "  ++) . show) FL.length)+--   in S.fold f (S.enumerateFromTo 1 100)+-- ("Even 50","Odd 50")+-- @+--+-- @since 0.7.0+{-# INLINE partitionBy #-}+partitionBy :: Monad m+    => (a -> Either b c) -> Fold m b x -> Fold m c y -> Fold m a (x, y)+partitionBy f = partitionByM (return . f)++-- | Compose two folds such that the combined fold accepts a stream of 'Either'+-- and routes the 'Left' values to the first fold and 'Right' values to the+-- second fold.+--+-- > partition = partitionBy id+--+-- @since 0.7.0+{-# INLINE partition #-}+partition :: Monad m+    => Fold m b x -> Fold m c y -> Fold m (Either b c) (x, y)+partition = partitionBy id++{-+-- | Send one item to each fold in a round-robin fashion. This is the consumer+-- side dual of producer side 'mergeN' operation.+--+-- partitionN :: Monad m => [Fold m a b] -> Fold m a [b]+-- partitionN fs = Fold step begin done+-}++-- TODO Demultiplex an input element into a number of typed variants. We want+-- to statically restrict the target values within a set of predefined types,+-- an enumeration of a GADT. We also want to make sure that the Map contains+-- only those types and the full set of those types.+--+-- TODO Instead of the input Map it should probably be a lookup-table using an+-- array and not in GC memory. The same applies to the output Map as well.+-- However, that would only be helpful if we have a very large data structure,+-- need to measure and see how it scales.+--+-- This is the consumer side dual of the producer side 'mux' operation (XXX to+-- be implemented).++-- | Split the input stream based on a key field and fold each split using a+-- specific fold collecting the results in a map from the keys to the results.+-- Useful for cases like protocol handlers to handle different type of packets+-- using different handlers.+--+-- @+--+--                             |-------Fold m a b+-- -----stream m a-----Map-----|+--                             |-------Fold m a b+--                             |+--                                       ...+-- @+--+-- @since 0.7.0+{-# INLINE demuxWith #-}+demuxWith :: (Monad m, Ord k)+    => (a -> (k, a')) -> Map k (Fold m a' b) -> Fold m a (Map k b)+demuxWith f kv = Fold step initial extract++    where++    initial = return kv+    step mp a = case f a of+      (k, a') -> Map.alterF twiddle k mp+        -- XXX should we raise an exception in Nothing case?+        -- Ideally we should enforce that it is a total map over k so that look+        -- up never fails+        -- XXX we could use a monadic update function for a single lookup and+        -- update in the map.+        where+          twiddle Nothing = pure Nothing+          twiddle (Just (Fold step' acc extract')) = do+            !r <- acc >>= \x -> step' x a'+            pure . Just $ Fold step' (return r) extract'+    extract = Prelude.mapM (\(Fold _ acc e) -> acc >>= e)++-- | Fold a stream of key value pairs using a map of specific folds for each+-- key into a map from keys to the results of fold outputs of the corresponding+-- values.+--+-- @+-- > 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+-- @+--+-- @since 0.7.0+{-# INLINE demux #-}+demux :: (Monad m, Ord k)+    => Map k (Fold m a b) -> Fold m (k, a) (Map k b)+demux = demuxWith id++-- | 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.+--+-- @+--+--                             |-------Fold m a ()+-- -----stream m a-----Map-----|+--                             |-------Fold m a ()+--                             |+--                                       ...+-- @+--+--+-- @since 0.7.0++-- demuxWith_ can be slightly faster than demuxWith because we do not need to+-- update the Map in this case. This may be significant only if the map is+-- large.+{-# INLINE demuxWith_ #-}+demuxWith_ :: (Monad m, Ord k)+    => (a -> (k, a')) -> Map k (Fold m a' b) -> Fold m a ()+demuxWith_ f kv = Fold step initial extract++    where++    initial = do+        Prelude.mapM (\(Fold s i e) ->+            i >>= \r -> return (Fold s (return r) e)) kv+    step mp a+        -- XXX should we raise an exception in Nothing case?+        -- Ideally we should enforce that it is a total map over k so that look+        -- up never fails+      | (k, a') <- f a+      = case Map.lookup k mp of+            Nothing -> return mp+            Just (Fold step' acc _) -> do+                _ <- acc >>= \x -> step' x a'+                return mp+    extract mp = Prelude.mapM_ (\(Fold _ acc e) -> acc >>= e) mp++-- | Given a stream of key value pairs and a map from keys to folds, fold the+-- values for each key using the corresponding folds, discarding the outputs.+--+-- @+-- > let prn = FL.drainBy print+-- > let table = Data.Map.fromList [(\"ONE", prn), (\"TWO", prn)]+--       input = S.fromList [(\"ONE",1),(\"TWO",2)]+--   in S.fold (FL.demux_ table) input+-- One 1+-- Two 2+-- @+--+-- @since 0.7.0+{-# INLINE demux_ #-}+demux_ :: (Monad m, Ord k) => Map k (Fold m a ()) -> Fold m (k, a) ()+demux_ = demuxWith_ 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.+--+-- | Split the input stream based on a key field and fold each split using the+-- given fold. Useful for map/reduce, bucketizing the input in different bins+-- or for generating histograms.+--+-- @+-- > let input = S.fromList [(\"ONE",1),(\"ONE",1.1),(\"TWO",2), (\"TWO",2.2)]+--   in S.fold (FL.classify FL.toList) input+-- fromList [(\"ONE",[1.1,1.0]),(\"TWO",[2.2,2.0])]+-- @+--+-- @since 0.7.0+{-# INLINE classifyWith #-}+classifyWith :: (Monad m, Ord k) => (a -> k) -> Fold m a b -> Fold m a (Map k b)+classifyWith f (Fold step initial extract) = Fold step' initial' extract'++    where++    initial' = return Map.empty+    step' kv a =+        let k = f a+        in case Map.lookup k kv of+            Nothing -> do+                x <- initial+                r <- step x a+                return $ Map.insert k r kv+            Just x -> do+                r <- step x a+                return $ Map.insert k r kv+    extract' = Prelude.mapM extract++-- | Given an input stream of key value pairs and a fold for values, fold all+-- the values belonging to each key.  Useful for map/reduce, bucketizing the+-- input in different bins or for generating histograms.+--+-- @+-- > let input = S.fromList [(\"ONE",1),(\"ONE",1.1),(\"TWO",2), (\"TWO",2.2)]+--   in S.fold (FL.classify FL.toList) input+-- fromList [(\"ONE",[1.1,1.0]),(\"TWO",[2.2,2.0])]+-- @+--+-- @since 0.7.0++-- Same as:+--+-- > classify fld = classifyWith fst (lmap snd fld)+--+{-# INLINE classify #-}+classify :: (Monad m, Ord k) => Fold m a b -> Fold m (k, a) (Map k b)+classify fld = classifyWith fst (lmap snd fld)++------------------------------------------------------------------------------+-- Unzipping+------------------------------------------------------------------------------+--+-- | Like 'unzipWith' but with a monadic splitter function.+--+-- @since 0.7.0+{-# INLINE unzipWithM #-}+unzipWithM :: Monad m+    => (a -> m (b,c)) -> Fold m b x -> Fold m c y -> Fold m a (x,y)+unzipWithM f (Fold stepL beginL doneL) (Fold stepR beginR doneR) =+    Fold step begin done++    where++    step (Tuple' xL xR) a = do+        (b,c) <- f a+        Tuple' <$> stepL xL b <*> stepR xR c+    begin = Tuple' <$> beginL <*> beginR+    done (Tuple' xL xR) = (,) <$> doneL xL <*> doneR xR++-- | Split elements in the input stream into two parts using a pure splitter+-- function, direct each part to a different fold and zip the results.+--+-- @since 0.7.0+{-# INLINE unzipWith #-}+unzipWith :: Monad m+    => (a -> (b,c)) -> Fold m b x -> Fold m c y -> Fold m a (x,y)+unzipWith f = unzipWithM (return . f)++-- | Send the elements of tuples in a stream of tuples through two different+-- folds.+--+-- @+--+--                           |-------Fold m a x--------|+-- ---------stream of (a,b)--|                         |----m (x,y)+--                           |-------Fold m b y--------|+--+-- @+--+-- This is the consumer side dual of the producer side 'zip' operation.+--+-- @since 0.7.0+{-# INLINE unzip #-}+unzip :: Monad m => Fold m a x -> Fold m b y -> Fold m (a,b) (x,y)+unzip = unzipWith id++------------------------------------------------------------------------------+-- Nesting+------------------------------------------------------------------------------+--+{-+-- All the stream flattening transformations can also be applied to a fold+-- input stream.++-- | This can be used to apply all the stream generation operations on folds.+lconcatMap ::(IsStream t, Monad m) => (a -> t m b)+    -> Fold m b c+    -> Fold m a c+lconcatMap s f1 f2 = undefined+-}++-- All the grouping transformation that we apply to a stream can also be+-- applied to a fold input stream.++{-+-- | Group the input stream into groups of elements between @low@ and @high@.+-- Collection starts in chunks of @low@ and then keeps doubling until we reach+-- @high@. Each chunk is folded using the provided fold function.+--+-- This could be useful, for example, when we are folding a stream of unknown+-- size to a stream of arrays and we want to minimize the number of+-- allocations.+--+-- @+--+-- XXX we should be able to implement it with parsers/terminating folds.+--+{-# INLINE lchunksInRange #-}+lchunksInRange :: Monad m+    => Int -> Int -> Fold m a b -> Fold m b c -> Fold m a c+lchunksInRange low high (Fold step1 initial1 extract1)+                        (Fold step2 initial2 extract2) = undefined+-}
+ src/Streamly/Internal/Data/Fold/Types.hs view
@@ -0,0 +1,479 @@+{-# OPTIONS_HADDOCK hide               #-}+{-# LANGUAGE CPP                       #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts          #-}++-- |+-- Module      : Streamly.Internal.Data.Fold.Types+-- Copyright   : (c) 2019 Composewell Technologies+--               (c) 2013 Gabriel Gonzalez+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++module Streamly.Internal.Data.Fold.Types+    ( Fold (..)+    , Fold2 (..)+    , simplify+    , toListRevF  -- experimental+    , lmap+    , lmapM+    , lfilter+    , lfilterM+    , lcatMaybes+    , ltake+    , ltakeWhile+    , lsessionsOf+    , lchunksOf+    , lchunksOf2++    , duplicate+    , initialize+    , runStep+    )+where++import Control.Applicative (liftA2)+import Control.Concurrent (threadDelay, forkIO, killThread)+import Control.Concurrent.MVar (MVar, newMVar, takeMVar, putMVar)+import Control.Exception (SomeException(..), catch, mask)+import Control.Monad (void)+import Control.Monad.Catch (throwM)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Trans.Control (control)+import Data.Maybe (isJust, fromJust)+#if __GLASGOW_HASKELL__ < 808+import Data.Semigroup (Semigroup(..))+#endif+import Streamly.Internal.Data.Strict (Tuple'(..), Tuple3'(..), Either'(..))+import Streamly.Internal.Data.SVar (MonadAsync)++------------------------------------------------------------------------------+-- Monadic left folds+------------------------------------------------------------------------------++-- | Represents a left fold over an input stream of values of type @a@ to a+-- single value of type @b@ in 'Monad' @m@.+--+-- The fold uses an intermediate state @s@ as accumulator. The @step@ function+-- updates the state and returns the new updated state. When the fold is done+-- the final result of the fold is extracted from the intermediate state+-- representation using the @extract@ function.+--+-- @since 0.7.0++data Fold m a b =+  -- | @Fold @ @ step @ @ initial @ @ extract@+  forall s. Fold (s -> a -> m s) (m s) (s -> m b)++-- Experimental type to provide a side input to the fold for generating the+-- initial state. For example, if we have to fold chunks of a stream and write+-- each chunk to a different file, then we can generate the file name using a+-- monadic action. This is a generalized version of 'Fold'.+--+data Fold2 m c a b =+  -- | @Fold @ @ step @ @ inject @ @ extract@+  forall s. Fold2 (s -> a -> m s) (c -> m s) (s -> m b)++-- | Convert more general type 'Fold2' into a simpler type 'Fold'+simplify :: Fold2 m c a b -> c -> Fold m a b+simplify (Fold2 step inject extract) c = Fold step (inject c) extract++-- | Maps a function on the output of the fold (the type @b@).+instance Applicative m => Functor (Fold m a) where+    {-# INLINE fmap #-}+    fmap f (Fold step start done) = Fold step start done'+        where+        done' x = fmap f $! done x++    {-# INLINE (<$) #-}+    (<$) b = \_ -> pure b++-- | The fold resulting from '<*>' distributes its input to both the argument+-- folds and combines their output using the supplied function.+instance Applicative m => Applicative (Fold m a) where+    {-# INLINE pure #-}+    pure b = Fold (\() _ -> pure ()) (pure ()) (\() -> pure b)++    {-# INLINE (<*>) #-}+    (Fold stepL beginL doneL) <*> (Fold stepR beginR doneR) =+        let step (Tuple' xL xR) a = Tuple' <$> stepL xL a <*> stepR xR a+            begin = Tuple' <$> beginL <*> beginR+            done (Tuple' xL xR) = doneL xL <*> doneR xR+        in  Fold step begin done++    {-# INLINE (<*) #-}+    (<*) m = \_ -> m++    {-# INLINE (*>) #-}+    _ *> m = m++-- | Combines the outputs of the folds (the type @b@) using their 'Semigroup'+-- instances.+instance (Semigroup b, Monad m) => Semigroup (Fold m a b) where+    {-# INLINE (<>) #-}+    (<>) = liftA2 (<>)++-- | Combines the outputs of the folds (the type @b@) using their 'Monoid'+-- instances.+instance (Semigroup b, Monoid b, Monad m) => Monoid (Fold m a b) where+    {-# INLINE mempty #-}+    mempty = pure mempty++    {-# INLINE mappend #-}+    mappend = (<>)++-- | Combines the fold outputs (type @b@) using their 'Num' instances.+instance (Monad m, Num b) => Num (Fold m a b) where+    {-# INLINE fromInteger #-}+    fromInteger = pure . fromInteger++    {-# INLINE negate #-}+    negate = fmap negate++    {-# INLINE abs #-}+    abs = fmap abs++    {-# INLINE signum #-}+    signum = fmap signum++    {-# INLINE (+) #-}+    (+) = liftA2 (+)++    {-# INLINE (*) #-}+    (*) = liftA2 (*)++    {-# INLINE (-) #-}+    (-) = liftA2 (-)++-- | Combines the fold outputs (type @b@) using their 'Fractional' instances.+instance (Monad m, Fractional b) => Fractional (Fold m a b) where+    {-# INLINE fromRational #-}+    fromRational = pure . fromRational++    {-# INLINE recip #-}+    recip = fmap recip++    {-# INLINE (/) #-}+    (/) = liftA2 (/)++-- | Combines the fold outputs using their 'Floating' instances.+instance (Monad m, Floating b) => Floating (Fold m a b) where+    {-# INLINE pi #-}+    pi = pure pi++    {-# INLINE exp #-}+    exp = fmap exp++    {-# INLINE sqrt #-}+    sqrt = fmap sqrt++    {-# INLINE log #-}+    log = fmap log++    {-# INLINE sin #-}+    sin = fmap sin++    {-# INLINE tan #-}+    tan = fmap tan++    {-# INLINE cos #-}+    cos = fmap cos++    {-# INLINE asin #-}+    asin = fmap asin++    {-# INLINE atan #-}+    atan = fmap atan++    {-# INLINE acos #-}+    acos = fmap acos++    {-# INLINE sinh #-}+    sinh = fmap sinh++    {-# INLINE tanh #-}+    tanh = fmap tanh++    {-# INLINE cosh #-}+    cosh = fmap cosh++    {-# INLINE asinh #-}+    asinh = fmap asinh++    {-# INLINE atanh #-}+    atanh = fmap atanh++    {-# INLINE acosh #-}+    acosh = fmap acosh++    {-# INLINE (**) #-}+    (**) = liftA2 (**)++    {-# INLINE logBase #-}+    logBase = liftA2 logBase++------------------------------------------------------------------------------+-- Internal APIs+------------------------------------------------------------------------------++-- This is more efficient than 'toList'. toList is exactly the same as+-- reversing the list after toListRev.+--+-- | Buffers the input stream to a list in the reverse order of the input.+--+-- /Warning!/ working on large lists accumulated as buffers in memory could be+-- very inefficient, consider using "Streamly.Array" instead.+--+-- @since 0.7.0++--  xn : ... : x2 : x1 : []+{-# INLINABLE toListRevF #-}+toListRevF :: Monad m => Fold m a [a]+toListRevF = Fold (\xs x -> return $ x:xs) (return []) return++-- | @(lmap f fold)@ maps the function @f@ on the input of the fold.+--+-- >>> S.fold (FL.lmap (\x -> x * x) FL.sum) (S.enumerateFromTo 1 100)+-- 338350+--+-- @since 0.7.0+{-# INLINABLE lmap #-}+lmap :: (a -> b) -> Fold m b r -> Fold m a r+lmap f (Fold step begin done) = Fold step' begin done+  where+    step' x a = step x (f a)++-- | @(lmapM f fold)@ maps the monadic function @f@ on the input of the fold.+--+-- @since 0.7.0+{-# INLINABLE lmapM #-}+lmapM :: Monad m => (a -> m b) -> Fold m b r -> Fold m a r+lmapM f (Fold step begin done) = Fold step' begin done+  where+    step' x a = f a >>= step x++------------------------------------------------------------------------------+-- Filtering+------------------------------------------------------------------------------++-- | Include only those elements that pass a predicate.+--+-- >>> S.fold (lfilter (> 5) FL.sum) [1..10]+-- 40+--+-- @since 0.7.0+{-# INLINABLE lfilter #-}+lfilter :: Monad m => (a -> Bool) -> Fold m a r -> Fold m a r+lfilter f (Fold step begin done) = Fold step' begin done+  where+    step' x a = if f a then step x a else return x++-- | Like 'lfilter' but with a monadic predicate.+--+-- @since 0.7.0+{-# INLINABLE lfilterM #-}+lfilterM :: Monad m => (a -> m Bool) -> Fold m a r -> Fold m a r+lfilterM f (Fold step begin done) = Fold step' begin done+  where+    step' x a = do+      use <- f a+      if use then step x a else return x++-- | Transform a fold from a pure input to a 'Maybe' input, consuming only+-- 'Just' values.+{-# INLINE lcatMaybes #-}+lcatMaybes :: Monad m => Fold m a b -> Fold m (Maybe a) b+lcatMaybes = lfilter isJust . lmap fromJust++-- | Take first 'n' elements from the stream and discard the rest.+--+-- @since 0.7.0+{-# INLINABLE ltake #-}+ltake :: Monad m => Int -> Fold m a b -> Fold m a b+ltake n (Fold step initial done) = Fold step' initial' done'+    where+    initial' = fmap (Tuple' 0) initial+    step' (Tuple' i r) a = do+        if i < n+        then do+            res <- step r a+            return $ Tuple' (i + 1) res+        else return $ Tuple' i r+    done' (Tuple' _ r) = done r++-- | Takes elements from the input as long as the predicate succeeds.+--+-- @since 0.7.0+{-# INLINABLE ltakeWhile #-}+ltakeWhile :: Monad m => (a -> Bool) -> Fold m a b -> Fold m a b+ltakeWhile predicate (Fold step initial done) = Fold step' initial' done'+    where+    initial' = fmap Left' initial+    step' (Left' r) a = do+        if predicate a+        then fmap Left' $ step r a+        else return (Right' r)+    step' r _ = return r+    done' (Left' r) = done r+    done' (Right' r) = done r++------------------------------------------------------------------------------+-- Nesting+------------------------------------------------------------------------------+--+-- | Modify the fold such that when the fold is done, instead of returning the+-- accumulator, it returns a fold. The returned fold starts from where we left+-- i.e. it uses the last accumulator value as the initial value of the+-- accumulator. Thus we can resume the fold later and feed it more input.+--+-- >> do+-- >    more <- S.fold (FL.duplicate FL.sum) (S.enumerateFromTo 1 10)+-- >    evenMore <- S.fold (FL.duplicate more) (S.enumerateFromTo 11 20)+-- >    S.fold evenMore (S.enumerateFromTo 21 30)+-- > 465+--+-- @since 0.7.0+{-# INLINABLE duplicate #-}+duplicate :: Applicative m => Fold m a b -> Fold m a (Fold m a b)+duplicate (Fold step begin done) =+    Fold step begin (\x -> pure (Fold step (pure x) done))++-- | Run the initialization effect of a fold. The returned fold would use the+-- value returned by this effect as its initial value.+--+{-# INLINABLE initialize #-}+initialize :: Monad m => Fold m a b -> m (Fold m a b)+initialize (Fold step initial extract) = do+    i <- initial+    return $ Fold step (return i) extract++-- | Run one step of a fold and store the accumulator as an initial value in+-- the returned fold.+{-# INLINABLE runStep #-}+runStep :: Monad m => Fold m a b -> a -> m (Fold m a b)+runStep (Fold step initial extract) a = do+    i <- initial+    r <- step i a+    return $ (Fold step (return r) extract)++-- | For every n input items, apply the first fold and supply the result to the+-- next fold.+--+{-# INLINE lchunksOf #-}+lchunksOf :: Monad m => Int -> Fold m a b -> Fold m b c -> Fold m a c+lchunksOf n (Fold step1 initial1 extract1) (Fold step2 initial2 extract2) =+    Fold step' initial' extract'++    where++    initial' = (Tuple3' 0) <$> initial1 <*> initial2+    step' (Tuple3' i r1 r2) a = do+        if i < n+        then do+            res <- step1 r1 a+            return $ Tuple3' (i + 1) res r2+        else do+            res <- extract1 r1+            acc2 <- step2 r2 res++            i1 <- initial1+            acc1 <- step1 i1 a+            return $ Tuple3' 1 acc1 acc2+    extract' (Tuple3' _ r1 r2) = do+        res <- extract1 r1+        acc2 <- step2 r2 res+        extract2 acc2++{-# INLINE lchunksOf2 #-}+lchunksOf2 :: Monad m => Int -> Fold m a b -> Fold2 m x b c -> Fold2 m x a c+lchunksOf2 n (Fold step1 initial1 extract1) (Fold2 step2 inject2 extract2) =+    Fold2 step' inject' extract'++    where++    inject' x = (Tuple3' 0) <$> initial1 <*> inject2 x+    step' (Tuple3' i r1 r2) a = do+        if i < n+        then do+            res <- step1 r1 a+            return $ Tuple3' (i + 1) res r2+        else do+            res <- extract1 r1+            acc2 <- step2 r2 res++            i1 <- initial1+            acc1 <- step1 i1 a+            return $ Tuple3' 1 acc1 acc2+    extract' (Tuple3' _ r1 r2) = do+        res <- extract1 r1+        acc2 <- step2 r2 res+        extract2 acc2++-- | Group the input stream into windows of n second each and then fold each+-- group using the provided fold function.+--+-- For example, we can copy and distribute a stream to multiple folds where+-- each fold can group the input differently e.g. by one second, one minute and+-- one hour windows respectively and fold each resulting stream of folds.+--+-- @+--+-- -----Fold m a b----|-Fold n a c-|-Fold n a c-|-...-|----Fold m a c+--+-- @+{-# INLINE lsessionsOf #-}+lsessionsOf :: MonadAsync m => Double -> Fold m a b -> Fold m b c -> Fold m a c+lsessionsOf n (Fold step1 initial1 extract1) (Fold step2 initial2 extract2) =+    Fold step' initial' extract'++    where++    -- XXX MVar may be expensive we need a cheaper synch mechanism here+    initial' = do+        i1 <- initial1+        i2 <- initial2+        mv1 <- liftIO $ newMVar i1+        mv2 <- liftIO $ newMVar (Right i2)+        t <- control $ \run ->+            mask $ \restore -> do+                tid <- forkIO $ catch (restore $ void $ run (timerThread mv1 mv2))+                                      (handleChildException mv2)+                run (return tid)+        return $ Tuple3' t mv1 mv2+    step' acc@(Tuple3' _ mv1 _) a = do+            r1 <- liftIO $ takeMVar mv1+            res <- step1 r1 a+            liftIO $ putMVar mv1 res+            return acc+    extract' (Tuple3' tid _ mv2) = do+        r2 <- liftIO $ takeMVar mv2+        liftIO $ killThread tid+        case r2 of+            Left e -> throwM e+            Right x -> extract2 x++    timerThread mv1 mv2 = do+        liftIO $ threadDelay (round $ n * 1000000)++        r1 <- liftIO $ takeMVar mv1+        i1 <- initial1+        liftIO $ putMVar mv1 i1++        res1 <- extract1 r1+        r2 <- liftIO $ takeMVar mv2+        res <- case r2 of+                    Left _ -> return r2+                    Right x -> fmap Right $ step2 x res1+        liftIO $ putMVar mv2 res+        timerThread mv1 mv2++    handleChildException ::+        MVar (Either SomeException a) -> SomeException -> IO ()+    handleChildException mv2 e = do+        r2 <- takeMVar mv2+        let r = case r2 of+                    Left _ -> r2+                    Right _ -> Left e+        putMVar mv2 r
+ src/Streamly/Internal/Data/List.hs view
@@ -0,0 +1,200 @@+{-# OPTIONS_HADDOCK hide                #-}+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE DeriveTraversable          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE PatternSynonyms            #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UndecidableInstances       #-} -- XXX+{-# LANGUAGE ViewPatterns               #-}++-- |+-- Module      : Streamly.Internal.Data.List+-- Copyright   : (c) 2018 Composewell Technologies+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+-- Lists are just a special case of monadic streams. The stream type @SerialT+-- Identity a@ can be used as a replacement for @[a]@.  The 'List' type in this+-- module is just a newtype wrapper around @SerialT Identity@ for better type+-- inference when using the 'OverloadedLists' GHC extension. @List a@ provides+-- better performance compared to @[a]@. Standard list, string and list+-- comprehension syntax can be used with the 'List' type by enabling+-- 'OverloadedLists', 'OverloadedStrings' and 'MonadComprehensions' GHC+-- extensions.  There would be a slight difference in the 'Show' and 'Read'+-- strings of streamly list as compared to regular lists.+--+-- Conversion to stream types is free, any stream combinator can be used on+-- lists by converting them to streams.  However, for convenience, this module+-- provides combinators that work directly on the 'List' type.+--+--+-- @+-- List $ S.map (+ 1) $ toSerial (1 \`Cons\` Nil)+-- @+--+-- To convert a 'List' to regular lists, you can use any of the following:+--+-- * @toList . toSerial@ and @toSerial . fromList@+-- * 'Data.Foldable.toList' from "Data.Foldable"+-- * 'GHC.Exts.toList' and 'GHC.Exts.fromList' from 'IsList' in "GHC.Exts"+--+-- If you have made use of 'Nil' and 'Cons' constructors in the code and you+-- want to replace streamly lists with standard lists, all you need to do is+-- import these definitions:+--+-- @+-- type List = []+-- pattern Nil <- [] where Nil = []+-- pattern Cons x xs = x : xs+-- infixr 5 `Cons`+-- {-\# COMPLETE Cons, Nil #-}+-- @+--+-- See <src/docs/streamly-vs-lists.md> for more details and+-- <src/test/PureStreams.hs> for comprehensive usage examples.+--+module Streamly.Internal.Data.List+    (+#if __GLASGOW_HASKELL__ >= 800+    List (.., Nil, Cons)+#else+    List (..)+    , pattern Nil+    , pattern Cons+#endif+    -- XXX we may want to use rebindable syntax for variants instead of using+    -- different types (applicative do and apWith).+    , ZipList (..)+    , fromZipList+    , toZipList+    )+where++import Control.Arrow (second)+import Control.DeepSeq (NFData(..))+#if MIN_VERSION_deepseq(1,4,3)+import Control.DeepSeq (NFData1(..))+#endif+import Data.Functor.Identity (Identity, runIdentity)+#if __GLASGOW_HASKELL__ < 808+import Data.Semigroup (Semigroup(..))+#endif+import GHC.Exts (IsList(..), IsString(..))++import Streamly.Streams.Serial (SerialT)+import Streamly.Streams.Zip (ZipSerialM)++import qualified Streamly.Streams.Prelude as P+import qualified Streamly.Streams.StreamK as K++-- We implement list as a newtype instead of a type synonym to make type+-- inference easier when using -XOverloadedLists and -XOverloadedStrings. When+-- using a stream type the programmer needs to specify the Monad otherwise the+-- type remains ambiguous.+--+-- XXX once we separate consM from IsStream or remove the MonadIO and+-- MonadBaseControlIO dependency from it, then we can make this an instance of+-- IsStream and use the regular polymorphic functions on Lists as well. Once+-- that happens we can change the Show and Read instances as well to use "1 >:+-- 2 >: nil" etc. or should we use a separate constructor indicating the "List"+-- type ":>" for better inference?+--+-- | @List a@ is a replacement for @[a]@.+--+-- @since 0.6.0+newtype List a = List { toSerial :: SerialT Identity a }+    deriving (Show, Read, Eq, Ord, NFData+#if MIN_VERSION_deepseq(1,4,3)+    , NFData1+#endif+             , Semigroup, Monoid, Functor, Foldable+             , Applicative, Traversable, Monad)++instance (a ~ Char) => IsString (List a) where+    {-# INLINE fromString #-}+    fromString = List . P.fromList++-- GHC versions 8.0 and below cannot derive IsList+instance IsList (List a) where+    type (Item (List a)) = a+    {-# INLINE fromList #-}+    fromList = List . P.fromList+    {-# INLINE toList #-}+    toList = runIdentity . P.toList . toSerial++------------------------------------------------------------------------------+-- Patterns+------------------------------------------------------------------------------++-- Note: When using the OverloadedLists extension we should be able to pattern+-- match using the regular list contructors. OverloadedLists uses 'toList' to+-- perform the pattern match, it should not be too bad as it works lazily in+-- the Identity monad. We need these patterns only when not using that+-- extension.+--+-- | An empty list constructor and pattern that matches an empty 'List'.+-- Corresponds to '[]' for Haskell lists.+--+-- @since 0.6.0+pattern Nil :: List a+pattern Nil <- (runIdentity . K.null . toSerial -> True) where+    Nil = List K.nil++infixr 5 `Cons`++-- | A list constructor and pattern that deconstructs a 'List' into its head+-- and tail. Corresponds to ':' for Haskell lists.+--+-- @since 0.6.0+pattern Cons :: a -> List a -> List a+pattern Cons x xs <-+    (fmap (second List) . runIdentity . K.uncons . toSerial+        -> Just (x, xs)) where+            Cons x xs = List $ K.cons x (toSerial xs)++#if __GLASGOW_HASKELL__ >= 802+{-# COMPLETE Nil, Cons #-}+#endif++------------------------------------------------------------------------------+-- ZipList+------------------------------------------------------------------------------++-- | Just like 'List' except that it has a zipping 'Applicative' instance+-- and no 'Monad' instance.+--+-- @since 0.6.0+newtype ZipList a = ZipList { toZipSerial :: ZipSerialM Identity a }+    deriving (Show, Read, Eq, Ord, NFData+#if MIN_VERSION_deepseq(1,4,3)+    , NFData1+#endif+             , Semigroup, Monoid, Functor, Foldable+             , Applicative, Traversable)++instance (a ~ Char) => IsString (ZipList a) where+    {-# INLINE fromString #-}+    fromString = ZipList . P.fromList++-- GHC versions 8.0 and below cannot derive IsList+instance IsList (ZipList a) where+    type (Item (ZipList a)) = a+    {-# INLINE fromList #-}+    fromList = ZipList . P.fromList+    {-# INLINE toList #-}+    toList = runIdentity . P.toList . toZipSerial++-- | Convert a 'ZipList' to a regular 'List'+--+-- @since 0.6.0+fromZipList :: ZipList a -> List a+fromZipList = List . K.adapt . toZipSerial++-- | Convert a regular 'List' to a 'ZipList'+--+-- @since 0.6.0+toZipList :: List a -> ZipList a+toZipList = ZipList . K.adapt . toSerial
+ src/Streamly/Internal/Data/Pipe.hs view
@@ -0,0 +1,1977 @@+{-# OPTIONS_HADDOCK hide               #-}+{-# LANGUAGE BangPatterns              #-}+{-# LANGUAGE CPP                       #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE RankNTypes                #-}+{-# LANGUAGE RecordWildCards           #-}+{-# LANGUAGE ScopedTypeVariables       #-}++-- |+-- Module      : Streamly.Internal.Data.Pipe+-- Copyright   : (c) 2019 Composewell Technologies+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+-- There are three fundamental types in streamly. They are streams+-- ("Streamly.Prelude"), pipes ("Streamly.Internal.Data.Pipe") and folds ("Streamly.Data.Fold").+-- Streams are sources or producers of values, multiple sources can be merged+-- into a single source but a source cannot be split into multiple stream+-- sources.  Folds are sinks or consumers, a stream can be split and+-- distributed to multiple folds but the results cannot be merged back into a+-- stream source again. Pipes are transformations, a stream source can be split+-- and distributed to multiple pipes each pipe can apply its own transform on+-- the stream and the results can be merged back into a single pipe. Pipes can+-- be attached to a source to produce a source or they can be attached to a+-- fold to produce a fold, or multiple pipes can be merged or zipped into a+-- single pipe.+--+-- > import qualified Streamly.Internal.Data.Pipe as P++module Streamly.Internal.Data.Pipe+    (+    -- * Pipe Type+      Pipe++    -- * Pipes+    -- ** Mapping+    , map+    , mapM++    {-+    -- ** Filtering+    , lfilter+    , lfilterM+    -- , ldeleteBy+    -- , luniq++    {-+    -- ** Mapping Filters+    , lmapMaybe+    , lmapMaybeM++    -- ** Scanning Filters+    , lfindIndices+    , lelemIndices++    -- ** Insertion+    -- | Insertion adds more elements to the stream.++    , linsertBy+    , lintersperseM++    -- ** Reordering+    , lreverse+    -}++    -- * Parsing+    -- ** Trimming+    , ltake+    -- , lrunFor -- time+    , ltakeWhile+    {-+    , ltakeWhileM+    , ldrop+    , ldropWhile+    , ldropWhileM+    -}++    -- ** Splitting+    -- | Streams can be split into segments in space or in time. We use the+    -- term @chunk@ to refer to a spatial length of the stream (spatial window)+    -- and the term @session@ to refer to a length in time (time window).++    -- In imperative terms, grouped folding can be considered as a nested loop+    -- where we loop over the stream to group elements and then loop over+    -- individual groups to fold them to a single value that is yielded in the+    -- output stream.++    -- *** By Chunks+    , chunksOf+    , sessionsOf++    -- *** By Elements+    , splitBy+    , splitSuffixBy+    , splitSuffixBy'+    -- , splitPrefixBy+    , wordsBy++    -- *** By Sequences+    , splitOn+    , splitSuffixOn+    -- , splitPrefixOn+    -- , wordsOn++    -- Keeping the delimiters+    , splitOn'+    , splitSuffixOn'+    -- , splitPrefixOn'++    -- Splitting by multiple sequences+    -- , splitOnAny+    -- , splitSuffixOnAny+    -- , splitPrefixOnAny++    -- ** Grouping+    , groups+    , groupsBy+    , groupsRollingBy+    -}++    -- * Composing Pipes+    , tee+    , zipWith+    , compose++    {-+    -- * Distributing+    -- |+    -- The 'Applicative' instance of a distributing 'Fold' distributes one copy+    -- of the stream to each fold and combines the results using a function.+    --+    -- @+    --+    --                 |-------Fold m a b--------|+    -- ---stream m a---|                         |---m (b,c,...)+    --                 |-------Fold m a c--------|+    --                 |                         |+    --                            ...+    -- @+    --+    -- To compute the average of numbers in a stream without going throught he+    -- stream twice:+    --+    -- >>> let avg = (/) <$> FL.sum <*> fmap fromIntegral FL.length+    -- >>> FL.foldl' avg (S.enumerateFromTo 1.0 100.0)+    -- 50.5+    --+    -- The 'Semigroup' and 'Monoid' instances of a distributing fold distribute+    -- the input to both the folds and combines the outputs using Monoid or+    -- Semigroup instances of the output types:+    --+    -- >>> import Data.Monoid (Sum)+    -- >>> FL.foldl' (FL.head <> FL.last) (fmap Sum $ S.enumerateFromTo 1.0 100.0)+    -- Just (Sum {getSum = 101.0})+    --+    -- The 'Num', 'Floating', and 'Fractional' instances work in the same way.++    , tee+    , distribute++    -- * Partitioning+    -- |+    -- Direct items in the input stream to different folds using a function to+    -- select the fold. This is useful to demultiplex the input stream.+    -- , partitionByM+    -- , partitionBy+    , partition++    -- * Demultiplexing+    , demux+    -- , demuxWith+    , demux_+    -- , demuxWith_++    -- * Classifying+    , classify+    -- , classifyWith++    -- * Unzipping+    , unzip+    -- These can be expressed using lmap/lmapM and unzip+    -- , unzipWith+    -- , unzipWithM++    -- * Nested Folds+    -- , concatMap+    -- , chunksOf+    , duplicate  -- experimental++    -- * Windowed Classification+    -- | Split the stream into windows or chunks in space or time. 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 is split+    -- into windows of specified size, the window can be terminated early if+    -- the closing flag is specified in the input stream.+    --+    -- The term "chunk" is used for a space window and the term "session" is+    -- used for a time window.++    -- ** Tumbling Windows+    -- | A new window starts after the previous window is finished.+    -- , classifyChunksOf+    , classifySessionsOf++    -- ** Keep Alive Windows+    -- | The window size is extended if an event arrives within the specified+    -- window size. This can represent sessions with idle or inactive timeout.+    -- , classifyKeepAliveChunks+    , classifyKeepAliveSessions++    {-+    -- ** Sliding Windows+    -- | A new window starts after the specified slide from the previous+    -- window. Therefore windows can overlap.+    , classifySlidingChunks+    , classifySlidingSessions+    -}+    -- ** Sliding Window Buffers+    -- , slidingChunkBuffer+    -- , slidingSessionBuffer+-}+    )+where++-- import Control.Concurrent (threadDelay, forkIO, killThread)+-- import Control.Concurrent.MVar (MVar, newMVar, takeMVar, putMVar)+-- import Control.Exception (SomeException(..), catch, mask)+-- import Control.Monad (void)+-- import Control.Monad.Catch (throwM)+-- import Control.Monad.IO.Class (MonadIO(..))+-- import Control.Monad.Trans (lift)+-- import Control.Monad.Trans.Control (control)+-- import Data.Functor.Identity (Identity)+-- import Data.Heap (Entry(..))+-- import Data.Map.Strict (Map)+-- import Data.Maybe (fromJust, isJust, isNothing)++-- import Foreign.Storable (Storable(..))+import Prelude+       hiding (id, filter, drop, dropWhile, take, takeWhile, zipWith, foldr,+               foldl, map, 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, mconcat, foldMap, unzip,+               span, splitAt, break, mapM)++-- import qualified Data.Heap as H+-- import qualified Data.Map.Strict as Map+-- import qualified Prelude++-- import Streamly (MonadAsync, parallel)+-- import Streamly.Data.Fold.Types (Fold(..))+import Streamly.Internal.Data.Pipe.Types+       (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.Time.Units+-- (AbsTime, MilliSecond64(..), addToAbsTime, diffAbsTime, toRelTime,+-- toAbsTime)++-- import Streamly.Internal.Data.Strict++-- 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++------------------------------------------------------------------------------+-- Pipes+------------------------------------------------------------------------------++-- | Lift a monadic function to a 'Pipe'.+--+-- @since 0.7.0+{-# INLINE mapM #-}+mapM :: Monad m => (a -> m b) -> Pipe m a b+mapM f = Pipe consume undefined ()+    where+    consume _ a = do+        r <- f a+        return $ Yield r (Consume ())+{-+------------------------------------------------------------------------------+-- Filtering+------------------------------------------------------------------------------++-- | Include only those elements that pass a predicate.+--+-- >>> FL.foldl (lfilter (> 5) FL.sum) [1..10]+-- 40+--+-- @since 0.7.0+{-# INLINABLE lfilter #-}+lfilter :: Monad m => (a -> Bool) -> Fold m a r -> Fold m a r+lfilter f (Fold step begin done) = Fold step' begin done+  where+    step' x a = if f a then step x a else return x++-- | Like 'lfilter' but with a monadic predicate.+--+-- @since 0.7.0+{-# INLINABLE lfilterM #-}+lfilterM :: Monad m => (a -> m Bool) -> Fold m a r -> Fold m a r+lfilterM f (Fold step begin done) = Fold step' begin done+  where+    step' x a = do+      use <- f a+      if use then step x a else return x++-- | Take first 'n' elements from the stream and discard the rest.+--+-- @since 0.7.0+{-# INLINABLE ltake #-}+ltake :: Monad m => Int -> Fold m a b -> Fold m a b+ltake n (Fold step initial done) = Fold step' initial' done'+    where+    initial' = fmap (Tuple' 0) initial+    step' (Tuple' i r) a = do+        if i < n+        then do+            res <- step r a+            return $ Tuple' (i + 1) res+        else return $ Tuple' i r+    done' (Tuple' _ r) = done r++-- | Takes elements from the input as long as the predicate succeeds.+--+-- @since 0.7.0+{-# INLINABLE ltakeWhile #-}+ltakeWhile :: Monad m => (a -> Bool) -> Fold m a b -> Fold m a b+ltakeWhile predicate (Fold step initial done) = Fold step' initial' done'+    where+    initial' = fmap Left' initial+    step' (Left' r) a = do+        if predicate a+        then fmap Left' $ step r a+        else return (Right' r)+    step' r _ = return r+    done' (Left' r) = done r+    done' (Right' r) = done r++------------------------------------------------------------------------------+-- 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 sent to fold @f1@ and the rest of the stream is+-- sent to fold @f2@.+--+-- > let splitAt_ n xs = FL.foldl' (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],[])+--+-- This can be considered as a two-fold version of 'ltake' where we take both+-- the segments instead of discarding the leftover.+--+-- @since 0.7.0+{-# 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 init extract+    where+      init  = 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 $ FL.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)++-- | Transform a fold from a pure input to a 'Maybe' input, consuming only+-- 'Just' values.+{-# INLINE lcatMaybes #-}+lcatMaybes :: Monad m => Fold m a b -> Fold m (Maybe a) b+lcatMaybes = lfilter isJust . lmap fromJust++-- 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 $ sessionsOf 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 sessionsOf #-}+sessionsOf+    :: (IsStream t, MonadAsync m)+    => Double -> Fold m a b -> t m a -> t m b+sessionsOf n f xs =+    splitSuffixBy' isNothing (lcatMaybes f)+        (S.intersperseByTime n (return Nothing) (S.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 init extract++    where+      init = 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 as long as the predicate is 'True'. @span p f1 f2@ composes folds+-- @f1@ and @f2@ such that the composed fold continues sending the input to+-- @f1@ as long as the predicate @p@ is 'True'.  The rest of the input is sent+-- to @f2@.+--+-- > let span_ p xs = FL.foldl' (FL.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],[])+--+-- This can be considered as a two-fold version of 'ltakeWhile' where we take+-- both the segments instead of discarding the leftover.+--+-- @since 0.7.0+{-# 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 init extract++    where+      init = 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 receiving input as soon as the+-- predicate @p@ becomes 'True'. The rest of the input is sent to @f2@.+--+-- This is the binary version of 'splitBy'.+--+-- > let break_ p xs = FL.foldl' (FL.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 _spanRollingBy #-}+_spanRollingBy+    :: Monad m+    => (a -> a -> Bool)+    -> Fold m a b+    -> Fold m a c+    -> Fold m a (b, c)+_spanRollingBy cmp (Fold stepL initialL extractL) (Fold stepR initialR extractR) =+    Fold step init extract++  where+    init = 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@.+--+-- >>> S.toList $ FL.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. @groupsRollingBy 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 $ FL.groupsRollingBy (\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 groupsRollingBy #-}+groupsRollingBy+    :: (IsStream t, Monad m)+    => (a -> a -> Bool)+    -> Fold m a b+    -> t m a+    -> t m b+groupsRollingBy cmp f m =  D.fromStreamD $ D.groupsRollingBy cmp f (D.toStreamD m)++-- |+-- > groups = groupsBy (==)+-- > groups = groupsRollingBy (==)+--+-- Groups a contiguous span of equal elements together in one group.+--+-- >>> S.toList $ FL.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 = FL.foldl' (FL.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 a stream on separator elements determined by a predicate, dropping+-- the separator.  Separators are not considered part of stream segments on+-- either side of it instead they are treated as infixed between two stream+-- segments. For example, with @.@ as separator, @"a.b.c"@ would be parsed as+-- @["a","b","c"]@. When @.@ is in leading or trailing position it is still+-- considered as infixed, treating the first or the last segment as empty.  For+-- example, @".a."@ would be parsed as @["","a",""]@.  This operation is+-- opposite of 'intercalate'.+--+-- Let's use the following definition for illustration:+--+-- > splitBy_ p xs = S.toList $ FL.splitBy p (FL.toList) (S.fromList xs)+--+-- >>> splitBy_ (== '.') ""+-- [""]+--+-- >>> splitBy_ (== '.') "."+-- ["",""]+--+-- >>> splitBy_ (== '.') ".a"+-- > ["","a"]+--+-- >>> splitBy_ (== '.') "a."+-- > ["a",""]+--+-- >>> splitBy_ (== '.') "a.b"+-- > ["a","b"]+--+-- >>> splitBy_ (== '.') "a..b"+-- > ["a","","b"]+--+-- This can be considered as an n-fold version of 'break' where we apply+-- 'break' successively on the input stream, dropping the first element+-- of the second segment after each break.+--+-- @since 0.7.0+{-# INLINE splitBy #-}+splitBy+    :: (IsStream t, Monad m)+    => (a -> Bool) -> Fold m a b -> t m a -> t m b+splitBy predicate f m =+    D.fromStreamD $ D.splitBy predicate f (D.toStreamD m)++-- | Like 'splitBy' but the separator is treated as part of the previous+-- stream segment (suffix).  Therefore, when the separator is in trailing+-- position, no empty segment is considered to follow it. For example, @"a.b."@+-- would be parsed as @["a","b"]@ instead of @["a","b",""]@ as in the case of+-- 'splitBy'.+--+-- > splitSuffixBy_ p xs = S.toList $ FL.splitSuffixBy p (FL.toList) (S.fromList xs)+--+-- >>> splitSuffixBy_ (== '.') ""+-- []+--+-- >>> splitSuffixBy_ (== '.') "."+-- [""]+--+-- >>> splitSuffixBy_ (== '.') "a"+-- ["a"]+--+-- >>> splitSuffixBy_ (== '.') ".a"+-- > ["","a"]+--+-- >>> splitSuffixBy_ (== '.') "a."+-- > ["a"]+--+-- >>> splitSuffixBy_ (== '.') "a.b"+-- > ["a","b"]+--+-- >>> splitSuffixBy_ (== '.') "a.b."+-- > ["a","b"]+--+-- >>> splitSuffixBy_ (== '.') "a..b.."+-- > ["a","","b",""]+--+-- > lines = splitSuffixBy (== '\n')+--+-- 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.+--+-- @since 0.7.0+{-# INLINE splitSuffixBy #-}+splitSuffixBy+    :: (IsStream t, Monad m)+    => (a -> Bool) -> Fold m a b -> t m a -> t m b+splitSuffixBy predicate f m =+    D.fromStreamD $ D.splitSuffixBy predicate f (D.toStreamD m)++-- | Like 'splitBy' but ignores repeated separators or separators in leading+-- or trailing position. Therefore, @"..a..b.."@ would be parsed as+-- @["a","b"]@.  In other words, it treats the input like words separated by+-- whitespace elements determined by the predicate.+--+-- > wordsBy' p xs = S.toList $ FL.wordsBy p (FL.toList) (S.fromList xs)+--+-- >>> wordsBy' (== ',') ""+-- > []+--+-- >>> wordsBy' (== ',') ","+-- > []+--+-- >>> wordsBy' (== ',') ",a,,b,"+-- > ["a","b"]+--+-- > words = wordsBy isSpace+--+-- @since 0.7.0+{-# 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)++-- XXX we should express this using the Splitter config.+--+-- We can get splitSuffixBy' by appending the suffix to the output segments+-- produced by splitSuffixBy. However, it may add an additional suffix if the last+-- fragment did not have a suffix in the first place.++-- | Like 'splitSuffixBy' but keeps the suffix in the splits.+--+-- > splitSuffixBy'_ p xs = S.toList $ FL.splitSuffixBy' p (FL.toList) (S.fromList xs)+--+-- >>> splitSuffixBy'_ (== '.') ""+-- []+--+-- >>> splitSuffixBy'_ (== '.') "."+-- ["."]+--+-- >>> splitSuffixBy'_ (== '.') "a"+-- ["a"]+--+-- >>> splitSuffixBy'_ (== '.') ".a"+-- > [".","a"]+--+-- >>> splitSuffixBy'_ (== '.') "a."+-- > ["a."]+--+-- >>> splitSuffixBy'_ (== '.') "a.b"+-- > ["a.","b"]+--+-- >>> splitSuffixBy'_ (== '.') "a.b."+-- > ["a.","b."]+--+-- >>> splitSuffixBy'_ (== '.') "a..b.."+-- > ["a.",".","b.","."]+--+-- This can be considered as an n-fold version of 'breakPost' where we apply+-- 'breakPost' successively on the input stream.+--+-- @since 0.7.0+{-# INLINE splitSuffixBy' #-}+splitSuffixBy'+    :: (IsStream t, Monad m)+    => (a -> Bool) -> Fold m a b -> t m a -> t m b+splitSuffixBy' 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]+-- > [[],[]]++-- | Split the stream on both sides of a separator sequence, dropping the+-- separator.+--+-- For illustration, let's define a function that operates on pure lists:+--+-- @+-- splitOn_ pat xs = S.toList $ FL.splitOn (A.fromList pat) (FL.toList) (S.fromList xs)+-- @+--+-- >>> splitOn_ "" "hello"+-- > ["h","e","l","l","o"]+--+-- >>> splitOn_ "hello" ""+-- > [""]+--+-- >>> splitOn_ "hello" "hello"+-- > ["",""]+--+-- >>> splitOn_ "x" "hello"+-- > ["hello"]+--+-- >>> splitOn_ "h" "hello"+-- > ["","ello"]+--+-- >>> splitOn_ "o" "hello"+-- > ["hell",""]+--+-- >>> splitOn_ "e" "hello"+-- > ["h","llo"]+--+-- >>> splitOn_ "l" "hello"+-- > ["he","","o"]+--+-- >>> splitOn_ "ll" "hello"+-- > ["he","o"]+--+-- 'splitOn' 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+--+-- The following law always holds:+--+-- > concat . splitOn . intercalate == concat+--+-- @since 0.7.0+{-# INLINE splitOn #-}+splitOn+    :: (IsStream t, MonadIO m, Storable a, Enum a, Eq a)+    => Array a -> Fold m a b -> t m a -> t m b+splitOn 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 $ 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",""]+--+-- > lines = splitSuffixOn "\n"+--+-- @since 0.7.0+{-# INLINE splitSuffixOn #-}+splitSuffixOn+    :: (IsStream t, MonadIO m, Storable a, Enum a, Eq a)+    => Array a -> Fold m a b -> t m a -> t m b+splitSuffixOn 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 'splitOn' but splits the separator as well, as an infix token.+--+-- > splitOn'_ pat xs = S.toList $ FL.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 splitOn' #-}+splitOn'+    :: (IsStream t, MonadAsync m, Storable a, Enum a, Eq a)+    => Array a -> Fold m a b -> t m a -> t m b+splitOn' patt f m = S.intersperseM (foldl' f (A.read patt)) $ splitOn 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 splitSuffixOn' #-}+splitSuffixOn'+    :: (IsStream t, MonadIO m, Storable a, Enum a, Eq a)+    => Array a -> Fold m a b -> t m a -> t m b+splitSuffixOn' 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)+-}++------------------------------------------------------------------------------+-- 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+------------------------------------------------------------------------------+--+-- | Distribute one copy of the stream to each fold and zip the results.+--+-- @+--                 |-------Fold m a b--------|+-- ---stream m a---|                         |---m (b,c)+--                 |-------Fold m a c--------|+-- @+-- >>> FL.foldl' (FL.tee FL.sum FL.length) (S.enumerateFromTo 1.0 100.0)+-- (5050.0,100)+--+-- @since 0.7.0+{-# INLINE tee #-}+tee :: Monad m => Fold m a b -> Fold m a c -> Fold m a (b,c)+tee f1 f2 = (,) <$> f1 <*> f2++{-# INLINE foldNil #-}+foldNil :: Monad m => Fold m a [b]+foldNil = Fold step begin done  where+  begin = return []+  step _ _ = return []+  done = return++{-# INLINE foldCons #-}+foldCons :: Monad m => Fold m a b -> Fold m a [b] -> Fold m a [b]+foldCons (Fold stepL beginL doneL) (Fold stepR beginR doneR) =+    Fold step begin done++    where++    begin = Tuple' <$> beginL <*> beginR+    step (Tuple' xL xR) a = Tuple' <$> stepL xL a <*> stepR xR a+    done (Tuple' xL xR) = (:) <$> (doneL xL) <*> (doneR xR)++-- XXX use "List" instead of "[]"?, use Array for output to scale it to a large+-- number of consumers?+--+-- | Distribute one copy of the stream to each fold and collect the results in+-- a container.+--+-- @+--+--                 |-------Fold m a b--------|+-- ---stream m a---|                         |---m [b]+--                 |-------Fold m a b--------|+--                 |                         |+--                            ...+-- @+--+-- >>> FL.foldl' (FL.distribute [FL.sum, FL.length]) (S.enumerateFromTo 1 5)+-- [15,5]+--+-- This is the consumer side dual of the producer side 'sequence' operation.+--+-- @since 0.7.0+{-# INLINE distribute #-}+distribute :: Monad m => [Fold m a b] -> Fold m a [b]+distribute [] = foldNil+distribute (x:xs) = foldCons x (distribute xs)++------------------------------------------------------------------------------+-- Partitioning+------------------------------------------------------------------------------+--+-- | Partition the input over two folds using an 'Either' partitioning+-- predicate.+--+-- @+--+--                                     |-------Fold b x--------|+-- -----stream m a --> (Either b c)----|                       |----(x,y)+--                                     |-------Fold c y--------|+-- @+--+-- Send input to either fold randomly:+--+-- >>> import System.Random (randomIO)+-- >>> randomly a = randomIO >>= \x -> return $ if x then Left a else Right a+-- >>> FL.foldl' (FL.partitionByM randomly FL.length FL.length) (S.enumerateFromTo 1 100)+-- (59,41)+--+-- Send input to the two folds in a proportion of 2:1:+--+-- @+-- import Data.IORef (newIORef, readIORef, writeIORef)+-- proportionately m n = do+--  ref <- newIORef $ cycle $ concat [replicate m Left, replicate n Right]+--  return $ \\a -> do+--      r <- readIORef ref+--      writeIORef ref $ tail r+--      return $ head r a+--+-- main = do+--  f <- proportionately 2 1+--  r <- FL.foldl' (FL.partitionByM f FL.length FL.length) (S.enumerateFromTo (1 :: Int) 100)+--  print r+-- @+-- @+-- (67,33)+-- @+--+-- This is the consumer side dual of the producer side 'mergeBy' operation.+--+-- @since 0.7.0+{-# INLINE partitionByM #-}+partitionByM :: Monad m+    => (a -> m (Either b c)) -> Fold m b x -> Fold m c y -> Fold m a (x, y)+partitionByM f (Fold stepL beginL doneL) (Fold stepR beginR doneR) =++    Fold step begin done++    where++    begin = Tuple' <$> beginL <*> beginR+    step (Tuple' xL xR) a = do+        r <- f a+        case r of+            Left b -> Tuple' <$> stepL xL b <*> return xR+            Right c -> Tuple' <$> return xL <*> stepR xR c+    done (Tuple' xL xR) = (,) <$> doneL xL <*> doneR xR++-- Note: we could use (a -> Bool) instead of (a -> Either b c), but the latter+-- makes the signature clearer as to which case belongs to which fold.+-- XXX need to check the performance in both cases.++-- | Same as 'partitionByM' but with a pure partition function.+--+-- Count even and odd numbers in a stream:+--+-- @+-- >>> let f = FL.partitionBy (\\n -> if even n then Left n else Right n)+--                       (fmap (("Even " ++) . show) FL.length)+--                       (fmap (("Odd "  ++) . show) FL.length)+--   in FL.foldl' f (S.enumerateFromTo 1 100)+-- ("Even 50","Odd 50")+-- @+--+-- @since 0.7.0+{-# INLINE partitionBy #-}+partitionBy :: Monad m+    => (a -> Either b c) -> Fold m b x -> Fold m c y -> Fold m a (x, y)+partitionBy f = partitionByM (return . f)++-- | Compose two folds such that the combined fold accepts a stream of 'Either'+-- and routes the 'Left' values to the first fold and 'Right' values to the+-- second fold.+--+-- > partition = partitionBy id+--+-- @since 0.7.0+{-# INLINE partition #-}+partition :: Monad m+    => Fold m b x -> Fold m c y -> Fold m (Either b c) (x, y)+partition = partitionBy id++{-+-- | Send one item to each fold in a round-robin fashion. This is the consumer+-- side dual of producer side 'mergeN' operation.+--+-- partitionN :: Monad m => [Fold m a b] -> Fold m a [b]+-- partitionN fs = Fold step begin done+-}++-- Demultiplex an input element into a number of typed variants. We want to+-- statically restrict the target values within a set of predefined types, an+-- enumeration of a GADT. We also want to make sure that the Map contains only+-- those types and the full set of those types.  Instead of Map it should+-- probably be a lookup-table using an array and not in GC memory.+--+-- This is the consumer side dual of the producer side 'mux' operation (XXX to+-- be implemented).++-- | Split the input stream based on a key field and fold each split using a+-- specific fold collecting the results in a map from the keys to the results.+-- Useful for cases like protocol handlers to handle different type of packets+-- using different handlers.+--+-- @+--+--                             |-------Fold m a b+-- -----stream m a-----Map-----|+--                             |-------Fold m a b+--                             |+--                                       ...+-- @+--+-- @since 0.7.0+{-# INLINE demuxWith #-}+demuxWith :: (Monad m, Ord k)+    => (a -> k) -> Map k (Fold m a b) -> Fold m a (Map k b)+demuxWith f kv = Fold step initial extract++    where++    initial = return kv+    step mp a =+        -- XXX should we raise an exception in Nothing case?+        -- Ideally we should enforce that it is a total map over k so that look+        -- up never fails+        -- XXX we could use a monadic update function for a single lookup and+        -- update in the map.+        let k = 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+    extract = Prelude.mapM (\(Fold _ acc e) -> acc >>= e)++-- | Fold a stream of key value pairs using a map of specific folds for each+-- key into a map from keys to the results of fold outputs of the corresponding+-- values.+--+-- @+-- > let table = Data.Map.fromList [(\"SUM", FL.sum), (\"PRODUCT", FL.product)]+--       input = S.fromList [(\"SUM",1),(\"PRODUCT",2),(\"SUM",3),(\"PRODUCT",4)]+--   in FL.foldl' (FL.demux table) input+-- One 1+-- Two 2+-- @+--+-- @since 0.7.0+{-# INLINE demux #-}+demux :: (Monad m, Ord k)+    => Map k (Fold m a b) -> Fold m (k, a) (Map k b)+demux fs = demuxWith fst (Map.map (lmap snd) fs)++-- | 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.+--+-- @+--+--                             |-------Fold m a ()+-- -----stream m a-----Map-----|+--                             |-------Fold m a ()+--                             |+--                                       ...+-- @+--+--+-- @since 0.7.0++-- demuxWith_ can be slightly faster than demuxWith because we do not need to+-- update the Map in this case. This may be significant only if the map is+-- large.+{-# INLINE demuxWith_ #-}+demuxWith_ :: (Monad m, Ord k)+    => (a -> k) -> Map k (Fold m a b) -> Fold m a ()+demuxWith_ f kv = Fold step initial extract++    where++    initial = do+        Prelude.mapM (\(Fold s i e) ->+            i >>= \r -> return (Fold s (return r) e)) kv+    step mp a =+        -- XXX should we raise an exception in Nothing case?+        -- Ideally we should enforce that it is a total map over k so that look+        -- up never fails+        case Map.lookup (f a) mp of+            Nothing -> return mp+            Just (Fold step' acc _) -> do+                _ <- acc >>= \x -> step' x a+                return mp+    extract mp = Prelude.mapM (\(Fold _ acc e) -> acc >>= e) mp >> return ()++-- | Given a stream of key value pairs and a map from keys to folds, fold the+-- values for each key using the corresponding folds, discarding the outputs.+--+-- @+-- > let prn = FL.drainBy print+-- > let table = Data.Map.fromList [(\"ONE", prn), (\"TWO", prn)]+--       input = S.fromList [(\"ONE",1),(\"TWO",2)]+--   in FL.foldl' (FL.demux_ table) input+-- One 1+-- Two 2+-- @+--+-- @since 0.7.0+{-# INLINE demux_ #-}+demux_ :: (Monad m, Ord k) => Map k (Fold m a ()) -> Fold m (k, a) ()+demux_ fs = demuxWith_ fst (Map.map (lmap snd) fs)++-- XXX instead of a Map we could yield the results as a pure stream as they+-- complete. We could then concatMap the fold results to implement the+-- windowing combinators.+--+-- | Split the input stream based on a key field and fold each split using the+-- given fold. Useful for map/reduce, bucketizing the input in different bins+-- or for generating histograms.+--+-- @+-- > let input = S.fromList [(\"ONE",1),(\"ONE",1.1),(\"TWO",2), (\"TWO",2.2)]+--   in FL.foldl' (FL.classify FL.toListRev) input+-- fromList [(\"ONE",[1.1,1.0]),(\"TWO",[2.2,2.0])]+-- @+--+-- @since 0.7.0+{-# INLINE classifyWith #-}+classifyWith :: (Monad m, Ord k) => (a -> k) -> Fold m a b -> Fold m a (Map k b)+classifyWith f (Fold step initial extract) = Fold step' initial' extract'++    where++    initial' = return Map.empty+    step' kv a =+        let k = f a+        in case Map.lookup k kv of+            Nothing -> do+                x <- initial+                r <- step x a+                return $ Map.insert k r kv+            Just x -> do+                r <- step x a+                return $ Map.insert k r kv+    extract' = Prelude.mapM extract++-- | Given an input stream of key value pairs and a fold for values, fold all+-- the values belonging to each key.  Useful for map/reduce, bucketizing the+-- input in different bins or for generating histograms.+--+-- @+-- > let input = S.fromList [(\"ONE",1),(\"ONE",1.1),(\"TWO",2), (\"TWO",2.2)]+--   in FL.foldl' (FL.classify FL.toListRev) input+-- fromList [(\"ONE",[1.1,1.0]),(\"TWO",[2.2,2.0])]+-- @+--+-- Same as:+--+-- > classify fld = classifyWith fst (lmap snd fld)+--+-- @since 0.7.0+{-# INLINE classify #-}+classify :: (Monad m, Ord k) => Fold m a b -> Fold m (k, a) (Map k b)+classify fld = classifyWith fst (lmap snd fld)++------------------------------------------------------------------------------+-- Unzipping+------------------------------------------------------------------------------+--+-- | Like 'unzipWith' but with a monadic splitter function.+--+-- @since 0.7.0+{-# INLINE unzipWithM #-}+unzipWithM :: Monad m+    => (a -> m (b,c)) -> Fold m b x -> Fold m c y -> Fold m a (x,y)+unzipWithM f (Fold stepL beginL doneL) (Fold stepR beginR doneR) =+    Fold step begin done++    where++    step (Tuple' xL xR) a = do+        (b,c) <- f a+        Tuple' <$> stepL xL b <*> stepR xR c+    begin = Tuple' <$> beginL <*> beginR+    done (Tuple' xL xR) = (,) <$> doneL xL <*> doneR xR++-- | Split elements in the input stream into two parts using a pure splitter+-- function, direct each part to a different fold and zip the results.+--+-- @since 0.7.0+{-# INLINE unzipWith #-}+unzipWith :: Monad m+    => (a -> (b,c)) -> Fold m b x -> Fold m c y -> Fold m a (x,y)+unzipWith f = unzipWithM (return . f)++-- | Send the elements of tuples in a stream of tuples through two different+-- folds.+--+-- @+--+--                           |-------Fold a x--------|+-- -----Stream m x----(a,b)--|                       |----m (x,y)+--                           |-------Fold b y--------|+--+-- @+--+-- This is the consumer side dual of the producer side 'zip' operation.+--+-- @since 0.7.0+{-# INLINE unzip #-}+unzip :: Monad m => Fold m a x -> Fold m b y -> Fold m (a,b) (x,y)+unzip = unzipWith id++------------------------------------------------------------------------------+-- Nesting+------------------------------------------------------------------------------+--+-- | Modify the fold such that when the fold is done, instead of returning the+-- accumulator, it returns a fold. The returned fold starts from where we left+-- i.e. it uses the last accumulator value as the initial value of the+-- accumulator. Thus we can resume the fold later and feed it more input.+--+-- >> do+-- >    more <- FL.foldl (FL.duplicate FL.sum) (S.enumerateFromTo 1 10)+-- >    evenMore <- FL.foldl (FL.duplicate more) (S.enumerateFromTo 11 20)+-- >    FL.foldl evenMore (S.enumerateFromTo 21 30)+-- > 465+--+-- @since 0.7.0+{-# INLINABLE duplicate #-}+duplicate :: Applicative m => Fold m a b -> Fold m a (Fold m a b)+duplicate (Fold step begin done) =+    Fold step begin (\x -> pure (Fold step (pure x) done))++{-+-- All the stream flattening transformations can also be applied to a fold+-- input stream.++-- | This can be used to apply all the stream generation operations on folds.+lconcatMap ::(IsStream t, Monad m) => (a -> t m b)+    -> Fold m b c+    -> Fold m a c+lconcatMap s f1 f2 = undefined+-}++-- All the grouping transformation that we apply to a stream can also be+-- applied to a fold input stream.++{-+-- | Group the input stream into groups of elements between @low@ and @high@.+-- Collection starts in chunks of @low@ and then keeps doubling until we reach+-- @high@. Each chunk is folded using the provided fold function.+--+-- This could be useful, for example, when we are folding a stream of unknown+-- size to a stream of arrays and we want to minimize the number of+-- allocations.+--+-- @+--+-- XXX we should be able to implement it with parsers/terminating folds.+--+{-# INLINE lchunksInRange #-}+lchunksInRange :: Monad m+    => Int -> Int -> Fold m a b -> Fold m b c -> Fold m a c+lchunksInRange low high (Fold step1 initial1 extract1)+                        (Fold step2 initial2 extract2) = undefined+-}++-- | Group the input stream into groups of @n@ elements each and then fold each+-- group using the provided fold function.+--+-- @+--+-- -----Fold m a b----|-Fold n a c-|-Fold n a c-|-...-|----Fold m a c+--+-- @+--+{-# INLINE lchunksOf #-}+lchunksOf :: Monad m => Int -> Fold m a b -> Fold m b c -> Fold m a c+lchunksOf n (Fold step1 initial1 extract1) (Fold step2 initial2 extract2) =+    Fold step' initial' extract'++    where++    initial' = (Tuple3' 0) <$> initial1 <*> initial2+    step' (Tuple3' i r1 r2) a = do+        if i < n+        then do+            res <- step1 r1 a+            return $ Tuple3' (i + 1) res r2+        else do+            res <- extract1 r1+            acc2 <- step2 r2 res++            i1 <- initial1+            acc1 <- step1 i1 a+            return $ Tuple3' 1 acc1 acc2+    extract' (Tuple3' _ _ r) = extract2 r++-- | Group the input stream into windows of n second each and then fold each+-- group using the provided fold function.+--+-- For example, we can copy and distribute a stream to multiple folds where+-- each fold can group the input differently e.g. by one second, one minute and+-- one hour windows respectively and fold each resulting stream of folds.+--+-- @+--+-- -----Fold m a b----|-Fold n a c-|-Fold n a c-|-...-|----Fold m a c+--+-- @+{-# INLINE lsessionsOf #-}+lsessionsOf :: MonadAsync m => Double -> Fold m a b -> Fold m b c -> Fold m a c+lsessionsOf n (Fold step1 initial1 extract1) (Fold step2 initial2 extract2) =+    Fold step' initial' extract'++    where++    -- XXX MVar may be expensive we need a cheaper synch mechanism here+    initial' = do+        i1 <- initial1+        i2 <- initial2+        mv1 <- liftIO $ newMVar i1+        mv2 <- liftIO $ newMVar (Right i2)+        t <- control $ \run ->+            mask $ \restore -> do+                tid <- forkIO $ catch (restore $ void $ run (timerThread mv1 mv2))+                                      (handleChildException mv2)+                run (return tid)+        return $ Tuple3' t mv1 mv2+    step' acc@(Tuple3' _ mv1 _) a = do+            r1 <- liftIO $ takeMVar mv1+            res <- step1 r1 a+            liftIO $ putMVar mv1 res+            return acc+    extract' (Tuple3' tid _ mv2) = do+        r2 <- liftIO $ takeMVar mv2+        liftIO $ killThread tid+        case r2 of+            Left e -> throwM e+            Right x -> extract2 x++    timerThread mv1 mv2 = do+        liftIO $ threadDelay (round $ n * 1000000)++        r1 <- liftIO $ takeMVar mv1+        i1 <- initial1+        liftIO $ putMVar mv1 i1++        res1 <- extract1 r1+        r2 <- liftIO $ takeMVar mv2+        res <- case r2 of+                    Left _ -> return r2+                    Right x -> fmap Right $ step2 x res1+        liftIO $ putMVar mv2 res+        timerThread mv1 mv2++    handleChildException ::+        MVar (Either SomeException a) -> SomeException -> IO ()+    handleChildException mv2 e = do+        r2 <- takeMVar mv2+        let r = case r2 of+                    Left _ -> r2+                    Right _ -> Left e+        putMVar mv2 r++------------------------------------------------------------------------------+-- 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 =+    S.concatMap (\(Tuple4' _ _ _ s) -> 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 S.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' (S.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' S.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 S.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) `S.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 = S.map Just str `parallel` S.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+-}
+ src/Streamly/Internal/Data/Pipe/Types.hs view
@@ -0,0 +1,450 @@+{-# OPTIONS_HADDOCK hide               #-}+{-# LANGUAGE CPP                       #-}+{-# LANGUAGE ExistentialQuantification #-}++#include "inline.hs"++-- |+-- Module      : Streamly.Internal.Data.Pipe.Types+-- Copyright   : (c) 2019 Composewell Technologies+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++module Streamly.Internal.Data.Pipe.Types+    ( Step (..)+    , Pipe (..)+    , PipeState (..)+    , zipWith+    , tee+    , map+    , compose+    )+where++import Control.Arrow (Arrow(..))+import Control.Category (Category(..))+import Data.Maybe (isJust)+#if __GLASGOW_HASKELL__ < 808+import Data.Semigroup (Semigroup(..))+#endif+import Prelude hiding (zipWith, map, id, unzip, null)+import Streamly.Internal.Data.Strict (Tuple'(..), Tuple3'(..))++import qualified Prelude++------------------------------------------------------------------------------+-- Pipes+------------------------------------------------------------------------------++-- A scan is a much simpler version of pipes. A scan always produces an output+-- on an input whereas a pipe does not necessarily produce an output on an+-- input, it might consume multiple inputs before producing an output. That way+-- it can implement filtering. Similarly, it can produce more than one output+-- on an single input.+--+-- Therefore when two pipes are composed in parallel formation, one may run+-- slower or faster than the other. If all of them are being fed from the same+-- source, we may have to buffer the input to match the speeds. In case of+-- scans we do not have that problem.+--+-- We may also need a "Stop" constructor to indicate that we are not generating+-- any more values and we can have a "Done" constructor to indicate that we are+-- not consuming any more values. Similarly we can have a stop with error or+-- exception and a done with error or leftover values.+--+-- In generator mode, Continue means no output/continue. In fold mode Continue means+-- need more input to produce result. we can perhaps call it Continue instead.+--+data Step s a =+      Yield a s+    | Continue s++-- | Represents a stateful transformation over an input stream of values of+-- type @a@ to outputs of type @b@ in 'Monad' @m@.++-- A pipe uses a consume function and a produce function. It can switch from+-- consume/fold mode to a produce/source mode. The first step function is a+-- fold function while the seocnd one is a stream generator function.+--+-- We can upgrade a stream or a fold into a pipe. However, streams are more+-- efficient in generation and folds are more efficient in consumption.+--+-- For pure transformation we can have a 'Scan' type. A Scan would be more+-- efficient in zipping whereas pipes are useful for merging and zipping where+-- we know buffering can occur. A Scan type can be upgraded to a pipe.+--+-- XXX In general the starting state could either be for generation or for+-- consumption. Currently we are only starting with a consumption state.+--+-- An explicit either type for better readability of the code+data PipeState s1 s2 = Consume s1 | Produce s2++isProduce :: PipeState s1 s2 -> Bool+isProduce s =+    case s of+        Produce _ -> True+        Consume _ -> False++data Pipe m a b =+  forall s1 s2. Pipe (s1 -> a -> m (Step (PipeState s1 s2) b))+                     (s2 -> m (Step (PipeState s1 s2) b)) s1++instance Monad m => Functor (Pipe m a) where+    {-# INLINE_NORMAL fmap #-}+    fmap f (Pipe consume produce initial) = Pipe consume' produce' initial+        where+        {-# INLINE_LATE consume' #-}+        consume' st a = do+            r <- consume st a+            return $ case r of+                Yield x s -> Yield (f x) s+                Continue s -> Continue s++        {-# INLINE_LATE produce' #-}+        produce' st = do+            r <- produce st+            return $ case r of+                Yield x s -> Yield (f x) s+                Continue s -> Continue s++-- XXX move this to a separate module+data Deque a = Deque [a] [a]++{-# INLINE null #-}+null :: Deque a -> Bool+null (Deque [] []) = True+null _ = False++{-# INLINE snoc #-}+snoc :: a -> Deque a -> Deque a+snoc a (Deque snocList consList) = Deque (a : snocList) consList++{-# INLINE uncons #-}+uncons :: Deque a -> Maybe (a, Deque a)+uncons (Deque snocList consList) =+  case consList of+    h : t -> Just (h, Deque snocList t)+    _ ->+      case Prelude.reverse snocList of+        h : t -> Just (h, Deque [] t)+        _ -> Nothing++-- | The composed pipe distributes the input to both the constituent pipes and+-- zips the output of the two using a supplied zipping function.+--+-- @since 0.7.0+{-# INLINE_NORMAL zipWith #-}+zipWith :: Monad m => (a -> b -> c) -> Pipe m i a -> Pipe m i b -> Pipe m i c+zipWith f (Pipe consumeL produceL stateL) (Pipe consumeR produceR stateR) =+                    Pipe consume produce state+        where++        -- Left state means we need to consume input from the source. A Right+        -- state means we either have buffered input or we are in generation+        -- mode so we do not need input from source in either case.+        --+        state = Tuple' (Consume stateL, Nothing, Nothing)+                       (Consume stateR, Nothing, Nothing)++        -- XXX for heavy buffering we need to have the (ring) buffer in pinned+        -- memory using the Storable instance.+        {-# INLINE_LATE consume #-}+        consume (Tuple' (sL, resL, lq) (sR, resR, rq)) a = do+            s1 <- drive sL resL lq consumeL produceL a+            s2 <- drive sR resR rq consumeR produceR a+            yieldOutput s1 s2++            where++            {-# INLINE drive #-}+            drive st res queue fConsume fProduce val = do+                case res of+                    Nothing -> goConsume st queue val fConsume fProduce+                    Just x -> return $+                        case queue of+                            Nothing -> (st, Just x, Just $ (Deque [val] []))+                            Just q  -> (st, Just x, Just $ snoc val q)++            {-# INLINE goConsume #-}+            goConsume stt queue val fConsume stp2 = do+                case stt of+                    Consume st -> do+                        case queue of+                            Nothing -> do+                                r <- fConsume st val+                                return $ case r of+                                    Yield x s  -> (s, Just x, Nothing)+                                    Continue s -> (s, Nothing, Nothing)+                            Just queue' ->+                                case uncons queue' of+                                    Just (v, q) -> do+                                        r <- fConsume st v+                                        let q' = snoc val q+                                        return $ case r of+                                            Yield x s  -> (s, Just x, Just q')+                                            Continue s -> (s, Nothing, Just q')+                                    Nothing -> undefined -- never occurs+                    Produce st -> do+                        r <- stp2 st+                        return $ case r of+                            Yield x s  -> (s, Just x, queue)+                            Continue s -> (s, Nothing, queue)++        {-# INLINE_LATE produce #-}+        produce (Tuple' (sL, resL, lq) (sR, resR, rq)) = do+            s1 <- drive sL resL lq consumeL produceL+            s2 <- drive sR resR rq consumeR produceR+            yieldOutput s1 s2++            where++            {-# INLINE drive #-}+            drive stt res q fConsume fProduce = do+                case res of+                    Nothing -> goProduce stt q fConsume fProduce+                    Just x -> return (stt, Just x, q)++            {-# INLINE goProduce #-}+            goProduce stt queue fConsume fProduce = do+                case stt of+                    Consume st -> do+                        case queue of+                            -- See yieldOutput. We enter produce mode only when+                            -- each pipe is either in Produce state or the+                            -- queue is non-empty. So this case cannot occur.+                            Nothing -> undefined+                            Just queue' ->+                                case uncons queue' of+                                    Just (v, q) -> do+                                        r <- fConsume st v+                                        -- We provide a guarantee that if the+                                        -- queue is "Just" it is always+                                        -- non-empty. yieldOutput and goConsume+                                        -- depend on it.+                                        let q' = if null q+                                                 then Nothing+                                                 else Just q+                                        return $ case r of+                                            Yield x s  -> (s, Just x, q')+                                            Continue s -> (s, Nothing, q')+                                    Nothing -> return (stt, Nothing, Nothing)+                    Produce st -> do+                        r <- fProduce st+                        return $ case r of+                            Yield x s  -> (s, Just x, queue)+                            Continue s -> (s, Nothing, queue)++        {-# INLINE yieldOutput #-}+        yieldOutput s1@(sL', resL', lq') s2@(sR', resR', rq') = return $+            -- switch to produce mode if we do not need input+            if (isProduce sL' || isJust lq') && (isProduce sR' || isJust rq')+            then+                case (resL', resR') of+                    (Just xL, Just xR) ->+                        Yield (f xL xR) (Produce (Tuple' (clear s1) (clear s2)))+                    _ -> Continue (Produce (Tuple' s1 s2))+            else+                case (resL', resR') of+                    (Just xL, Just xR) ->+                        Yield (f xL xR) (Consume (Tuple' (clear s1) (clear s2)))+                    _ -> Continue (Consume (Tuple' s1 s2))+            where clear (s, _, q) = (s, Nothing, q)++instance Monad m => Applicative (Pipe m a) where+    {-# INLINE pure #-}+    pure b = Pipe (\_ _ -> pure $ Yield b (Consume ())) undefined ()++    (<*>) = zipWith id++-- | The composed pipe distributes the input to both the constituent pipes and+-- merges the outputs of the two.+--+-- @since 0.7.0+{-# INLINE_NORMAL tee #-}+tee :: Monad m => Pipe m a b -> Pipe m a b -> Pipe m a b+tee (Pipe consumeL produceL stateL) (Pipe consumeR produceR stateR) =+        Pipe consume produce state+    where++    state = Tuple' (Consume stateL) (Consume stateR)++    consume (Tuple' sL sR) a = do+        case sL of+            Consume st -> do+                r <- consumeL st a+                return $ case r of+                    Yield x s -> Yield x (Produce (Tuple3' (Just a) s sR))+                    Continue s -> Continue (Produce (Tuple3' (Just a) s sR))+            -- XXX we should never come here unless the initial state of the+            -- first pipe is set to "Right".+            Produce _st -> undefined -- do+            {-+                r <- produceL st+                return $ case r of+                    Yield x s -> Yield x (Right (Tuple3' (Just a) s sR))+                    Continue s -> Continue (Right (Tuple3' (Just a) s sR))+                -}++    produce (Tuple3' (Just a) sL sR) = do+        case sL of+            Consume _ -> do+                case sR of+                    Consume st -> do+                        r <- consumeR st a+                        let nextL s = Consume (Tuple' sL s)+                        let nextR s = Produce (Tuple3' Nothing sL s)+                        return $ case r of+                            Yield x s@(Consume _) -> Yield x (nextL s)+                            Yield x s@(Produce _) -> Yield x (nextR s)+                            Continue s@(Consume _) -> Continue (nextL s)+                            Continue s@(Produce _) -> Continue (nextR s)+                    -- We will never come here unless the initial state of+                    -- second pipe is set to "Right".+                    Produce _ -> undefined+            Produce st -> do+                r <- produceL st+                let next s = Produce (Tuple3' (Just a) s sR)+                return $ case r of+                    Yield x s -> Yield x (next s)+                    Continue s -> Continue (next s)++    produce (Tuple3' Nothing sL sR) = do+        case sR of+            Consume _ -> undefined -- should never occur+            Produce st -> do+                r <- produceR st+                return $ case r of+                    Yield x s@(Consume _) ->+                        Yield x (Consume (Tuple' sL s))+                    Yield x s@(Produce _) ->+                        Yield x (Produce (Tuple3' Nothing sL s))+                    Continue s@(Consume _) ->+                        Continue (Consume (Tuple' sL s))+                    Continue s@(Produce _) ->+                        Continue (Produce (Tuple3' Nothing sL s))++instance Monad m => Semigroup (Pipe m a b) where+    {-# INLINE (<>) #-}+    (<>) = tee++-- | Lift a pure function to a 'Pipe'.+--+-- @since 0.7.0+{-# INLINE map #-}+map :: Monad m => (a -> b) -> Pipe m a b+map f = Pipe consume undefined ()+    where+    consume _ a = return $ Yield (f a) (Consume ())++{-+-- | A hollow or identity 'Pipe' passes through everything that comes in.+--+-- @since 0.7.0+{-# INLINE id #-}+id :: Monad m => Pipe m a a+id = map Prelude.id+-}++-- | Compose two pipes such that the output of the second pipe is attached to+-- the input of the first pipe.+--+-- @since 0.7.0+{-# INLINE_NORMAL compose #-}+compose :: Monad m => Pipe m b c -> Pipe m a b -> Pipe m a c+compose (Pipe consumeL produceL stateL) (Pipe consumeR produceR stateR) =+    Pipe consume produce state++    where++    state = Tuple' (Consume stateL) (Consume stateR)++    consume (Tuple' sL sR) a = do+        case sL of+            Consume stt ->+                case sR of+                    Consume st -> do+                        rres <- consumeR st a+                        case rres of+                            Yield x sR' -> do+                                let next s =+                                        if isProduce sR'+                                        then Produce s+                                        else Consume s+                                lres <- consumeL stt x+                                return $ case lres of+                                    Yield y s1@(Consume _) ->+                                        Yield y (next $ Tuple' s1 sR')+                                    Yield y s1@(Produce _) ->+                                        Yield y (Produce $ Tuple' s1 sR')+                                    Continue s1@(Consume _) ->+                                        Continue (next $ Tuple' s1 sR')+                                    Continue s1@(Produce _) ->+                                        Continue (Produce $ Tuple' s1 sR')+                            Continue s1@(Consume _) ->+                                return $ Continue (Consume $ Tuple' sL s1)+                            Continue s1@(Produce _) ->+                                return $ Continue (Produce $ Tuple' sL s1)+                    Produce _ -> undefined+            -- XXX we should never come here unless the initial state of the+            -- first pipe is set to "Right".+            Produce _ -> undefined++    -- XXX we need to write the code in mor optimized fashion. Use Continue+    -- more and less yield points.+    produce (Tuple' sL sR) = do+        case sL of+            Produce st -> do+                r <- produceL st+                let next s = if isProduce sR then Produce s else Consume s+                return $ case r of+                    Yield x s@(Consume _) -> Yield x (next $ Tuple' s sR)+                    Yield x s@(Produce _) -> Yield x (Produce $ Tuple' s sR)+                    Continue s@(Consume _) -> Continue (next $ Tuple' s sR)+                    Continue s@(Produce _) -> Continue (Produce $ Tuple' s sR)+            Consume stt ->+                case sR of+                    Produce st -> do+                        rR <- produceR st+                        case rR of+                            Yield x sR' -> do+                                let next s =+                                        if isProduce sR'+                                        then Produce s+                                        else Consume s+                                rL <- consumeL stt x+                                return $ case rL of+                                    Yield y s1@(Consume _) ->+                                        Yield y (next $ Tuple' s1 sR')+                                    Yield y s1@(Produce _) ->+                                        Yield y (Produce $ Tuple' s1 sR')+                                    Continue s1@(Consume _) ->+                                        Continue (next $ Tuple' s1 sR')+                                    Continue s1@(Produce _) ->+                                        Continue (Produce $ Tuple' s1 sR')+                            Continue s1@(Consume _) ->+                                return $ Continue (Consume $ Tuple' sL s1)+                            Continue s1@(Produce _) ->+                                return $ Continue (Produce $ Tuple' sL s1)+                    Consume _ -> return $ Continue (Consume $ Tuple' sL sR)++instance Monad m => Category (Pipe m) where+    {-# INLINE id #-}+    id = map Prelude.id++    {-# INLINE (.) #-}+    (.) = compose++unzip :: Pipe m a x -> Pipe m b y -> Pipe m (a, b) (x, y)+unzip = undefined++instance Monad m => Arrow (Pipe m) where+    {-# INLINE arr #-}+    arr = map++    {-# INLINE (***) #-}+    (***) = unzip++    {-# INLINE (&&&) #-}+    (&&&) = zipWith (,)
+ src/Streamly/Internal/Data/SVar.hs view
@@ -0,0 +1,2397 @@+{-# OPTIONS_HADDOCK hide                #-}+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE KindSignatures             #-}+{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE ExistentialQuantification  #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE MagicHash                  #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE UnboxedTuples              #-}++-- |+-- Module      : Streamly.Internal.Data.SVar+-- Copyright   : (c) 2017 Harendra Kumar+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++module Streamly.Internal.Data.SVar+    (+      MonadAsync+    , SVarStyle (..)+    , SVarStopStyle (..)+    , SVar (..)++    -- State threaded around the stream+    , Limit (..)+    , State (streamVar)+    , defState+    , adaptState+    , getMaxThreads+    , setMaxThreads+    , getMaxBuffer+    , setMaxBuffer+    , getStreamRate+    , setStreamRate+    , setStreamLatency+    , getYieldLimit+    , setYieldLimit+    , getInspectMode+    , setInspectMode++    , cleanupSVar+    , cleanupSVarFromWorker++    -- SVar related+    , newAheadVar+    , newParallelVar+    , captureMonadState+    , RunInIO (..)++    , WorkerInfo (..)+    , YieldRateInfo (..)+    , ThreadAbort (..)+    , ChildEvent (..)+    , AheadHeapEntry (..)+    , send+    , sendYield+    , sendStop+    , enqueueLIFO+    , enqueueFIFO+    , enqueueAhead+    , reEnqueueAhead+    , pushWorkerPar++    , queueEmptyAhead+    , dequeueAhead++    , HeapDequeueResult(..)+    , dequeueFromHeap+    , dequeueFromHeapSeq+    , requeueOnHeapTop+    , updateHeapSeq+    , withIORef+    , heapIsSane++    , Rate (..)+    , getYieldRateInfo+    , newSVarStats+    , collectLatency+    , workerUpdateLatency+    , isBeyondMaxRate+    , workerRateControl+    , updateYieldCount+    , decrementYieldLimit+    , incrementYieldLimit+    , decrementBufferLimit+    , incrementBufferLimit+    , postProcessBounded+    , postProcessPaced+    , readOutputQBounded+    , readOutputQPaced+    , dispatchWorkerPaced+    , sendFirstWorker+    , delThread+    , modifyThread+    , doFork++    , toStreamVar+    , SVarStats (..)+    , dumpSVar+    )+where++import Control.Concurrent+       (ThreadId, myThreadId, threadDelay, throwTo)+import Control.Concurrent.MVar+       (MVar, newEmptyMVar, tryPutMVar, takeMVar, tryTakeMVar, newMVar, tryReadMVar)+import Control.Exception+       (SomeException(..), catch, mask, assert, Exception, catches,+        throwIO, Handler(..), BlockedIndefinitelyOnMVar(..),+        BlockedIndefinitelyOnSTM(..))+import Control.Monad (when)+import Control.Monad.Catch (MonadThrow)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Trans.Control (MonadBaseControl, control, StM)+import Streamly.Internal.Data.Atomics+       (atomicModifyIORefCAS, atomicModifyIORefCAS_, writeBarrier,+        storeLoadBarrier)+import Data.Concurrent.Queue.MichaelScott (LinkedQueue, pushL)+import Data.Functor (void)+import Data.Heap (Heap, Entry(..))+import Data.Int (Int64)+#if __GLASGOW_HASKELL__ >= 800+import Data.Kind (Type)+#endif+import Data.IORef+       (IORef, modifyIORef, newIORef, readIORef, writeIORef, atomicModifyIORef)+import Data.Maybe (fromJust)+#if __GLASGOW_HASKELL__ < 808+import Data.Semigroup ((<>))+#endif+import Data.Set (Set)+import GHC.Conc (ThreadId(..))+import GHC.Exts+import GHC.IO (IO(..))+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++newtype Count = Count Int64+    deriving ( Eq+             , Read+             , Show+             , Enum+             , Bounded+             , Num+             , Real+             , Integral+             , Ord+             )++------------------------------------------------------------------------------+-- Parent child thread communication type+------------------------------------------------------------------------------++data ThreadAbort = ThreadAbort deriving Show++instance Exception ThreadAbort++-- | Events that a child thread may send to a parent thread.+data ChildEvent a =+      ChildYield a+    | ChildStop ThreadId (Maybe SomeException)++#if __GLASGOW_HASKELL__ < 800+#define Type *+#endif+-- | Sorting out-of-turn outputs in a heap for Ahead style streams+data AheadHeapEntry (t :: (Type -> Type) -> Type -> Type) m a =+      AheadEntryNull+    | AheadEntryPure a+    | AheadEntryStream (t m a)+#undef Type++------------------------------------------------------------------------------+-- State threaded around the monad for thread management+------------------------------------------------------------------------------++-- | Identify the type of the SVar. Two computations using the same style can+-- be scheduled on the same SVar.+data SVarStyle =+      AsyncVar             -- depth first concurrent+    | WAsyncVar            -- breadth first concurrent+    | ParallelVar          -- all parallel+    | AheadVar             -- Concurrent look ahead+    deriving (Eq, Show)++-- | An SVar or a Stream Var is a conduit to the output from multiple streams+-- running concurrently and asynchronously. An SVar can be thought of as an+-- asynchronous IO handle. We can write any number of streams to an SVar in a+-- non-blocking manner and then read them back at any time at any pace.  The+-- SVar would run the streams asynchronously and accumulate results. An SVar+-- may not really execute the stream completely and accumulate all the results.+-- However, it ensures that the reader can read the results at whatever paces+-- it wants to read. The SVar monitors and adapts to the consumer's pace.+--+-- An SVar is a mini scheduler, it has an associated workLoop that holds the+-- stream tasks to be picked and run by a pool of worker threads. It has an+-- associated output queue where the output stream elements are placed by the+-- worker threads. A outputDoorBell is used by the worker threads to intimate the+-- consumer thread about availability of new results in the output queue. More+-- workers are added to the SVar by 'fromStreamVar' on demand if the output+-- produced is not keeping pace with the consumer. On bounded SVars, workers+-- block on the output queue to provide throttling of the producer  when the+-- consumer is not pulling fast enough.  The number of workers may even get+-- reduced depending on the consuming pace.+--+-- New work is enqueued either at the time of creation of the SVar or as a+-- result of executing the parallel combinators i.e. '<|' and '<|>' when the+-- already enqueued computations get evaluated. See 'joinStreamVarAsync'.++-- We measure the individual worker latencies to estimate the number of workers+-- needed or the amount of time we have to sleep between dispatches to achieve+-- a particular rate when controlled pace mode it used.+data WorkerInfo = WorkerInfo+    { workerYieldMax   :: Count -- 0 means unlimited+    -- total number of yields by the worker till now+    , workerYieldCount    :: IORef Count+    -- yieldCount at start, timestamp+    , workerLatencyStart  :: IORef (Count, AbsTime)+    }+++-- | Specifies the stream yield rate in yields per second (@Hertz@).+-- We keep accumulating yield credits at 'rateGoal'. At any point of time we+-- allow only as many yields as we have accumulated as per 'rateGoal' since the+-- start of time. If the consumer or the producer is slower or faster, the+-- actual rate may fall behind or exceed 'rateGoal'.  We try to recover the gap+-- between the two by increasing or decreasing the pull rate from the producer.+-- However, if the gap becomes more than 'rateBuffer' we try to recover only as+-- much as 'rateBuffer'.+--+-- 'rateLow' puts a bound on how low the instantaneous rate can go when+-- recovering the rate gap.  In other words, it determines the maximum yield+-- latency.  Similarly, 'rateHigh' puts a bound on how high the instantaneous+-- rate can go when recovering the rate gap.  In other words, it determines the+-- minimum yield latency. We reduce the latency by increasing concurrency,+-- therefore we can say that it puts an upper bound on concurrency.+--+-- If the 'rateGoal' is 0 or negative the stream never yields a value.+-- If the 'rateBuffer' is 0 or negative we do not attempt to recover.+--+-- @since 0.5.0+data Rate = Rate+    { rateLow    :: Double -- ^ The lower rate limit+    , rateGoal   :: Double -- ^ The target rate we want to achieve+    , rateHigh   :: Double -- ^ The upper rate limit+    , rateBuffer :: Int    -- ^ Maximum slack from the goal+    }++data LatencyRange = LatencyRange+    { minLatency :: NanoSecond64+    , maxLatency :: NanoSecond64+    } deriving Show++-- Rate control.+data YieldRateInfo = YieldRateInfo+    { svarLatencyTarget    :: NanoSecond64+    , svarLatencyRange     :: LatencyRange+    , svarRateBuffer       :: Int++    -- [LOCKING] Unlocked access. Modified by the consumer thread and unsafely+    -- read by the worker threads+    , svarGainedLostYields :: IORef Count++    -- Actual latency/througput as seen from the consumer side, we count the+    -- yields and the time it took to generates those yields. This is used to+    -- increase or decrease the number of workers needed to achieve the desired+    -- rate. The idle time of workers is adjusted in this, so that we only+    -- account for the rate when the consumer actually demands data.+    -- XXX interval latency is enough, we can move this under diagnostics build+    -- [LOCKING] Unlocked access. Modified by the consumer thread and unsafely+    -- read by the worker threads+    , svarAllTimeLatency :: IORef (Count, AbsTime)++    -- XXX Worker latency specified by the user to be used before the first+    -- actual measurement arrives. Not yet implemented+    , workerBootstrapLatency :: Maybe NanoSecond64++    -- After how many yields the worker should update the latency information.+    -- If the latency is high, this count is kept lower and vice-versa.  XXX If+    -- the latency suddenly becomes too high this count may remain too high for+    -- long time, in such cases the consumer can change it.+    -- 0 means no latency computation+    -- XXX this is derivable from workerMeasuredLatency, can be removed.+    -- [LOCKING] Unlocked access. Modified by the consumer thread and unsafely+    -- read by the worker threads+    , workerPollingInterval :: IORef Count++    -- This is in progress latency stats maintained by the workers which we+    -- empty into workerCollectedLatency stats at certain intervals - whenever+    -- we process the stream elements yielded in this period. The first count+    -- is all yields, the second count is only those yields for which the+    -- latency was measured to be non-zero (note that if the timer resolution+    -- is low the measured latency may be zero e.g. on JS platform).+    -- [LOCKING] Locked access. Modified by the consumer thread as well as+    -- worker threads. Workers modify it periodically based on+    -- workerPollingInterval and not on every yield to reduce the locking+    -- overhead.+    -- (allYieldCount, yieldCount, timeTaken)+    , workerPendingLatency   :: IORef (Count, Count, NanoSecond64)++    -- This is the second level stat which is an accmulation from+    -- workerPendingLatency stats. We keep accumulating latencies in this+    -- bucket until we have stats for a sufficient period and then we reset it+    -- to start collecting for the next period and retain the computed average+    -- latency for the last period in workerMeasuredLatency.+    -- [LOCKING] Unlocked access. Modified by the consumer thread and unsafely+    -- read by the worker threads+    -- (allYieldCount, yieldCount, timeTaken)+    , workerCollectedLatency :: IORef (Count, Count, NanoSecond64)++    -- Latency as measured by workers, aggregated for the last period.+    -- [LOCKING] Unlocked access. Modified by the consumer thread and unsafely+    -- read by the worker threads+    , workerMeasuredLatency :: IORef NanoSecond64+    }++data SVarStats = SVarStats {+      totalDispatches  :: IORef Int+    , maxWorkers       :: IORef Int+    , maxOutQSize      :: IORef Int+    , maxHeapSize      :: IORef Int+    , maxWorkQSize     :: IORef Int+    , avgWorkerLatency :: IORef (Count, NanoSecond64)+    , minWorkerLatency :: IORef NanoSecond64+    , maxWorkerLatency :: IORef NanoSecond64+    , svarStopTime     :: IORef (Maybe AbsTime)+}++-- This is essentially a 'Maybe Word' type+data Limit = Unlimited | Limited Word deriving Show++instance Eq Limit where+    Unlimited == Unlimited = True+    Unlimited == Limited _ = False+    Limited _ == Unlimited = False+    Limited x == Limited y = x == y++instance Ord Limit where+    Unlimited <= Unlimited = True+    Unlimited <= Limited _ = False+    Limited _ <= Unlimited = True+    Limited x <= Limited y = x <= y++-- When to stop the composed stream.+data SVarStopStyle =+      StopNone -- stops only when all streams are finished+    | StopAny  -- stop when any stream finishes+    | StopBy   -- stop when a specific stream finishes+    deriving (Eq, Show)++-- | Buffering policy for persistent push workers (in ParallelT).  In a pull+-- style SVar (in AsyncT, AheadT etc.), the consumer side dispatches workers on+-- demand, workers terminate if the buffer is full or if the consumer is not+-- cosuming fast enough.  In a push style SVar, a worker is dispatched only+-- once, workers are persistent and keep pushing work to the consumer via a+-- bounded buffer. If the buffer becomes full the worker either blocks, or it+-- can drop an item from the buffer to make space.+--+-- Pull style SVars are useful in lazy stream evaluation whereas push style+-- SVars are useful in strict left Folds.+--+-- XXX Maybe we can separate the implementation in two different types instead+-- of using a common SVar type.+--+data PushBufferPolicy =+      PushBufferDropNew  -- drop the latest element and continue+    | PushBufferDropOld  -- drop the oldest element and continue+    | PushBufferBlock    -- block the thread until space+                         -- becomes available++-- IMPORTANT NOTE: we cannot update the SVar after generating it as we have+-- references to the original SVar stored in several functions which will keep+-- pointing to the original data and the new updates won't reflect there.+-- Any updateable parts must be kept in mutable references (IORef).+--+data SVar t m a = SVar+    {+    -- Read only state+      svarStyle       :: SVarStyle+    , svarMrun        :: RunInIO m+    , svarStopStyle   :: SVarStopStyle+    , svarStopBy      :: IORef ThreadId++    -- Shared output queue (events, length)+    -- XXX For better efficiency we can try a preallocated array type (perhaps+    -- something like a vector) that allows an O(1) append. That way we will+    -- avoid constructing and reversing the list. Possibly we can also avoid+    -- the GC copying overhead. When the size increases we should be able to+    -- allocate the array in chunks.+    --+    -- [LOCKING] Frequent locked access. This is updated by workers on each+    -- yield and once in a while read by the consumer thread. This could have+    -- big locking overhead if the number of workers is high.+    --+    -- XXX We can use a per-CPU data structure to reduce the locking overhead.+    -- However, a per-cpu structure cannot guarantee the exact sequence in+    -- which the elements were added, though that may not be important.+    , outputQueue    :: IORef ([ChildEvent a], Int)++    -- [LOCKING] Infrequent MVar. Used when the outputQ transitions from empty+    -- to non-empty, or a work item is queued by a worker to the work queue and+    -- needDoorBell is set by the consumer.+    , outputDoorBell :: MVar ()  -- signal the consumer about output+    , readOutputQ    :: m [ChildEvent a]+    , postProcess    :: m Bool++    -- 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+    -- case exceeding the requested buffer size.+    , maxWorkerLimit :: Limit+    , maxBufferLimit :: Limit+    -- These two are valid and used only when maxBufferLimit is Limited.+    , pushBufferSpace  :: IORef Count+    , pushBufferPolicy :: PushBufferPolicy+    -- [LOCKING] The consumer puts this MVar after emptying the buffer, workers+    -- block on it when the buffer becomes full. No overhead unless the buffer+    -- becomes full.+    , pushBufferMVar :: MVar ()++    -- [LOCKING] Read only access by consumer when dispatching a worker.+    -- Decremented by workers when picking work and undo decrement if the+    -- worker does not yield a value.+    , remainingWork  :: Maybe (IORef Count)+    , yieldRateInfo  :: Maybe YieldRateInfo++    -- Used only by bounded SVar types+    , enqueue        :: t m a -> IO ()+    , isWorkDone     :: IO Bool+    , isQueueDone    :: IO Bool+    , needDoorBell   :: IORef Bool+    , workLoop       :: Maybe WorkerInfo -> m ()++    -- Shared, thread tracking+    -- [LOCKING] Updated unlocked only by consumer thread in case of+    -- Async/Ahead style SVars. Updated locked by worker threads in case of+    -- Parallel style.+    , workerThreads  :: IORef (Set ThreadId)+    -- [LOCKING] Updated locked by consumer thread when dispatching a worker+    -- and by the worker threads when the thread stops. This is read unsafely+    -- at several places where we want to rely on an approximate value.+    , workerCount    :: IORef Int+    , accountThread  :: ThreadId -> m ()+    , workerStopMVar :: MVar ()++    , svarStats      :: SVarStats+    -- to track garbage collection of SVar+    , svarRef        :: Maybe (IORef ())++    -- Only for diagnostics+    , svarInspectMode :: Bool+    , svarCreator    :: ThreadId+    , outputHeap     :: IORef ( Heap (Entry Int (AheadHeapEntry t m a))+                              , Maybe Int)+    -- Shared work queue (stream, seqNo)+    , aheadWorkQueue :: IORef ([t m a], Int)+    }++-------------------------------------------------------------------------------+-- State for concurrency control+-------------------------------------------------------------------------------++-- XXX we can put the resettable fields in a oneShotConfig field and others in+-- a persistentConfig field. That way reset would be fast and scalable+-- irrespective of the number of fields.+--+-- XXX make all these Limited types and use phantom types to distinguish them+data State t m a = State+    { -- one shot configuration, automatically reset for each API call+      streamVar   :: Maybe (SVar t m a)+    , _yieldLimit  :: Maybe Count++    -- persistent configuration, state that remains valid until changed by+    -- an explicit setting via a combinator.+    , _threadsHigh    :: Limit+    , _bufferHigh     :: Limit+    -- XXX these two can be collapsed into a single type+    , _streamLatency  :: Maybe NanoSecond64 -- bootstrap latency+    , _maxStreamRate  :: Maybe Rate+    , _inspectMode    :: Bool+    }++-------------------------------------------------------------------------------+-- State defaults and reset+-------------------------------------------------------------------------------++-- A magical value for the buffer size arrived at by running the smallest+-- possible task and measuring the optimal value of the buffer for that.  This+-- is obviously dependent on hardware, this figure is based on a 2.2GHz intel+-- core-i7 processor.+magicMaxBuffer :: Word+magicMaxBuffer = 1500++defaultMaxThreads, defaultMaxBuffer :: Limit+defaultMaxThreads = Limited magicMaxBuffer+defaultMaxBuffer = Limited magicMaxBuffer++-- The fields prefixed by an _ are not to be accessed or updated directly but+-- via smart accessor APIs.+defState :: State t m a+defState = State+    { streamVar = Nothing+    , _yieldLimit = Nothing+    , _threadsHigh = defaultMaxThreads+    , _bufferHigh = defaultMaxBuffer+    , _maxStreamRate = Nothing+    , _streamLatency = Nothing+    , _inspectMode = False+    }++-- XXX if perf gets affected we can have all the Nothing params in a single+-- structure so that we reset is fast. We can also use rewrite rules such that+-- reset occurs only in concurrent streams to reduce the impact on serial+-- streams.+-- We can optimize this so that we clear it only if it is a Just value, it+-- results in slightly better perf for zip/zipM but the performance of scan+-- worsens a lot, it does not fuse.+--+-- XXX This has a side effect of clearing the SVar and yieldLimit, therefore it+-- should not be used to convert from the same type to the same type, unless+-- you want to clear the SVar. For clearing the SVar you should be using the+-- appropriate unStream functions instead.+--+-- | Adapt the stream state from one type to another.+adaptState :: State t m a -> State t n b+adaptState st = st+    { streamVar = Nothing+    , _yieldLimit = Nothing+    }++-------------------------------------------------------------------------------+-- Smart get/set routines for State+-------------------------------------------------------------------------------++-- Use get/set routines instead of directly accessing the State fields+setYieldLimit :: Maybe Int64 -> State t m a -> State t m a+setYieldLimit lim st =+    st { _yieldLimit =+            case lim of+                Nothing -> Nothing+                Just n  ->+                    if n <= 0+                    then Just 0+                    else Just (fromIntegral n)+       }++getYieldLimit :: State t m a -> Maybe Count+getYieldLimit = _yieldLimit++setMaxThreads :: Int -> State t m a -> State t m a+setMaxThreads n st =+    st { _threadsHigh =+            if n < 0+            then Unlimited+            else if n == 0+                 then defaultMaxThreads+                 else Limited (fromIntegral n)+       }++getMaxThreads :: State t m a -> Limit+getMaxThreads = _threadsHigh++setMaxBuffer :: Int -> State t m a -> State t m a+setMaxBuffer n st =+    st { _bufferHigh =+            if n < 0+            then Unlimited+            else if n == 0+                 then defaultMaxBuffer+                 else Limited (fromIntegral n)+       }++getMaxBuffer :: State t m a -> Limit+getMaxBuffer = _bufferHigh++setStreamRate :: Maybe Rate -> State t m a -> State t m a+setStreamRate r st = st { _maxStreamRate = r }++getStreamRate :: State t m a -> Maybe Rate+getStreamRate = _maxStreamRate++setStreamLatency :: Int -> State t m a -> State t m a+setStreamLatency n st =+    st { _streamLatency =+            if n <= 0+            then Nothing+            else Just (fromIntegral n)+       }++getStreamLatency :: State t m a -> Maybe NanoSecond64+getStreamLatency = _streamLatency++setInspectMode :: State t m a -> State t m a+setInspectMode st = st { _inspectMode = True }++getInspectMode :: State t m a -> Bool+getInspectMode = _inspectMode++-------------------------------------------------------------------------------+-- Cleanup+-------------------------------------------------------------------------------++cleanupSVar :: SVar t m a -> IO ()+cleanupSVar sv = do+    workers <- readIORef (workerThreads sv)+    Prelude.mapM_ (`throwTo` ThreadAbort)+          workers++cleanupSVarFromWorker :: SVar t m a -> IO ()+cleanupSVarFromWorker sv = do+    workers <- readIORef (workerThreads sv)+    self <- myThreadId+    Prelude.mapM_ (`throwTo` ThreadAbort)+          (Prelude.filter (/= self) $ S.toList workers)++-------------------------------------------------------------------------------+-- Worker latency data collection+-------------------------------------------------------------------------------++-- Every once in a while workers update the latencies and check the yield rate.+-- They return if we are above the expected yield rate. If we check too often+-- it may impact performance, if we check less often we may have a stale+-- picture. We update every minThreadDelay but we translate that into a yield+-- count based on latency so that the checking overhead is little.+--+-- XXX use a generation count to indicate that the value is updated. If the+-- value is updated an existing worker must check it again on the next yield.+-- Otherwise it is possible that we may keep updating it and because of the mod+-- worker keeps skipping it.+updateWorkerPollingInterval :: YieldRateInfo -> NanoSecond64 -> IO ()+updateWorkerPollingInterval yinfo latency = do+    let periodRef = workerPollingInterval yinfo+        cnt = max 1 $ minThreadDelay `div` latency+        period = min cnt (fromIntegral magicMaxBuffer)++    writeIORef periodRef (fromIntegral period)++{-# INLINE recordMinMaxLatency #-}+recordMinMaxLatency :: SVar t m a -> NanoSecond64 -> IO ()+recordMinMaxLatency sv new = do+    let ss = svarStats sv+    minLat <- readIORef (minWorkerLatency ss)+    when (new < minLat || minLat == 0) $+        writeIORef (minWorkerLatency ss) new++    maxLat <- readIORef (maxWorkerLatency ss)+    when (new > maxLat) $ writeIORef (maxWorkerLatency ss) new++recordAvgLatency :: SVar t m a -> (Count, NanoSecond64) -> IO ()+recordAvgLatency sv (count, time) = do+    let ss = svarStats sv+    modifyIORef (avgWorkerLatency ss) $+        \(cnt, t) -> (cnt + count, t + time)++-- Pour the pending latency stats into a collection bucket+{-# INLINE collectWorkerPendingLatency #-}+collectWorkerPendingLatency+    :: IORef (Count, Count, NanoSecond64)+    -> IORef (Count, Count, NanoSecond64)+    -> IO (Count, Maybe (Count, NanoSecond64))+collectWorkerPendingLatency cur col = do+    (fcount, count, time) <- atomicModifyIORefCAS cur $ \v -> ((0,0,0), v)++    (fcnt, cnt, t) <- readIORef col+    let totalCount = fcnt + fcount+        latCount   = cnt + count+        latTime    = t + time+    writeIORef col (totalCount, latCount, latTime)++    assert (latCount == 0 || latTime /= 0) (return ())+    let latPair =+            if latCount > 0 && latTime > 0+            then Just $ (latCount, latTime)+            else Nothing+    return (totalCount, latPair)++{-# INLINE shouldUseCollectedBatch #-}+shouldUseCollectedBatch+    :: Count+    -> NanoSecond64+    -> NanoSecond64+    -> NanoSecond64+    -> Bool+shouldUseCollectedBatch collectedYields collectedTime newLat prevLat =+    let r = fromIntegral newLat / fromIntegral prevLat :: Double+    in     (collectedYields > fromIntegral magicMaxBuffer)+        || (collectedTime > minThreadDelay)+        || (prevLat > 0 && (r > 2 || r < 0.5))+        || (prevLat == 0)++-- Returns a triple, (1) yield count since last collection, (2) the base time+-- when we started counting, (3) average latency in the last measurement+-- period. The former two are used for accurate measurement of the going rate+-- whereas the average is used for future estimates e.g. how many workers+-- should be maintained to maintain the rate.+-- CAUTION! keep it in sync with getWorkerLatency+collectLatency :: SVar t m a+               -> YieldRateInfo+               -> Bool+               -> IO (Count, AbsTime, NanoSecond64)+collectLatency sv yinfo drain = do+    let cur      = workerPendingLatency yinfo+        col      = workerCollectedLatency yinfo+        longTerm = svarAllTimeLatency yinfo+        measured = workerMeasuredLatency yinfo++    (newCount, newLatPair) <- collectWorkerPendingLatency cur col+    (lcount, ltime) <- readIORef longTerm+    prevLat <- readIORef measured++    let newLcount = lcount + newCount+        retWith lat = return (newLcount, ltime, lat)++    case newLatPair of+        Nothing -> retWith prevLat+        Just (count, time) -> do+            let newLat = time `div` (fromIntegral count)+            when (svarInspectMode sv) $ recordMinMaxLatency sv newLat+            -- When we have collected a significant sized batch we compute the+            -- new latency using that batch and return the new latency,+            -- otherwise we return the previous latency derived from the+            -- previous batch.+            if shouldUseCollectedBatch newCount time newLat prevLat || drain+            then do+                -- XXX make this NOINLINE?+                updateWorkerPollingInterval yinfo (max newLat prevLat)+                when (svarInspectMode sv) $ recordAvgLatency sv (count, time)+                writeIORef col (0, 0, 0)+                writeIORef measured ((prevLat + newLat) `div` 2)+                modifyIORef longTerm $ \(_, t) -> (newLcount, t)+                retWith newLat+            else retWith prevLat++-------------------------------------------------------------------------------+-- Dumping the SVar for debug/diag+-------------------------------------------------------------------------------++dumpSVarStats :: SVar t m a -> SVarStats -> SVarStyle -> IO String+dumpSVarStats sv ss style = do+    case yieldRateInfo sv of+        Nothing -> return ()+        Just yinfo -> do+            _ <- liftIO $ collectLatency sv yinfo True+            return ()++    dispatches <- readIORef $ totalDispatches ss+    maxWrk <- readIORef $ maxWorkers ss+    maxOq <- readIORef $ maxOutQSize ss+    maxHp <- readIORef $ maxHeapSize ss+    minLat <- readIORef $ minWorkerLatency ss+    maxLat <- readIORef $ maxWorkerLatency ss+    (avgCnt, avgTime) <- readIORef $ avgWorkerLatency ss+    (svarCnt, svarGainLossCnt, svarLat) <- case yieldRateInfo sv of+        Nothing -> return (0, 0, 0)+        Just yinfo -> do+            (cnt, startTime) <- readIORef $ svarAllTimeLatency yinfo+            if cnt > 0+            then do+                t <- readIORef (svarStopTime ss)+                gl <- readIORef (svarGainedLostYields yinfo)+                case t of+                    Nothing -> do+                        now <- getTime Monotonic+                        let interval = diffAbsTime64 now startTime+                        return (cnt, gl, interval `div` fromIntegral cnt)+                    Just stopTime -> do+                        let interval = diffAbsTime64 stopTime startTime+                        return (cnt, gl, interval `div` fromIntegral cnt)+            else return (0, 0, 0)++    return $ unlines+        [ "total dispatches = " <> show dispatches+        , "max workers = " <> show maxWrk+        , "max outQSize = " <> show maxOq+            <> (if style == AheadVar+               then "\nheap max size = " <> show maxHp+               else "")+            <> (if minLat > 0+               then "\nmin worker latency = " <> showNanoSecond64 minLat+               else "")+            <> (if maxLat > 0+               then "\nmax worker latency = " <> showNanoSecond64 maxLat+               else "")+            <> (if avgCnt > 0+                then let lat = avgTime `div` fromIntegral avgCnt+                     in "\navg worker latency = " <> showNanoSecond64 lat+                else "")+            <> (if svarLat > 0+               then "\nSVar latency = " <> showRelTime64 svarLat+               else "")+            <> (if svarCnt > 0+               then "\nSVar yield count = " <> show svarCnt+               else "")+            <> (if svarGainLossCnt > 0+               then "\nSVar gain/loss yield count = " <> show svarGainLossCnt+               else "")+        ]++{-# NOINLINE dumpSVar #-}+dumpSVar :: SVar t m a -> IO String+dumpSVar sv = do+    (oqList, oqLen) <- readIORef $ outputQueue sv+    db <- tryReadMVar $ outputDoorBell sv+    aheadDump <-+        if svarStyle sv == AheadVar+        then do+            (oheap, oheapSeq) <- readIORef $ outputHeap sv+            (wq, wqSeq) <- readIORef $ aheadWorkQueue sv+            return $ unlines+                [ "heap length = " <> show (H.size oheap)+                , "heap seqeunce = " <> show oheapSeq+                , "work queue length = " <> show (length wq)+                , "work queue sequence = " <> show wqSeq+                ]+        else return []++    let style = svarStyle sv+    waiting <-+        if style /= ParallelVar+        then readIORef $ needDoorBell sv+        else return False+    rthread <- readIORef $ workerThreads sv+    workers <- readIORef $ workerCount sv+    stats <- dumpSVarStats sv (svarStats sv) (svarStyle sv)++    return $ unlines+        [+          "Creator tid = " <> show (svarCreator sv),+          "style = " <> show (svarStyle sv)+        , "---------CURRENT STATE-----------"+        , "outputQueue length computed  = " <> show (length oqList)+        , "outputQueue length maintained = " <> show oqLen+        -- XXX print the types of events in the outputQueue, first 5+        , "outputDoorBell = " <> show db+        ]+        <> aheadDump+        <> unlines+        [ "needDoorBell = " <> show waiting+        , "running threads = " <> show rthread+        -- XXX print the status of first 5 threads+        , "running thread count = " <> show workers+        ]+        <> "---------STATS-----------\n"+        <> stats++-- 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+-- until they are GCed because the consumer went away.++{-# NOINLINE mvarExcHandler #-}+mvarExcHandler :: SVar t m a -> String -> BlockedIndefinitelyOnMVar -> IO ()+mvarExcHandler sv label e@BlockedIndefinitelyOnMVar = do+    svInfo <- dumpSVar sv+    hPutStrLn stderr $ label <> " " <> "BlockedIndefinitelyOnMVar\n" <> svInfo+    throwIO e++{-# NOINLINE stmExcHandler #-}+stmExcHandler :: SVar t m a -> String -> BlockedIndefinitelyOnSTM -> IO ()+stmExcHandler sv label e@BlockedIndefinitelyOnSTM = do+    svInfo <- dumpSVar sv+    hPutStrLn stderr $ label <> " " <> "BlockedIndefinitelyOnSTM\n" <> svInfo+    throwIO e++withDiagMVar :: SVar t m a -> String -> IO () -> IO ()+withDiagMVar sv label action =+    if svarInspectMode sv+    then+        action `catches` [ Handler (mvarExcHandler sv label)+                         , Handler (stmExcHandler sv label)+                         ]+    else action++------------------------------------------------------------------------------+-- Spawning threads+------------------------------------------------------------------------------++-- | A monad that can perform concurrent or parallel IO operations. Streams+-- that can be composed concurrently require the underlying monad to be+-- 'MonadAsync'.+--+-- @since 0.1.0+type MonadAsync m = (MonadIO m, MonadBaseControl IO m, MonadThrow m)++-- When we run computations concurrently, we completely isolate the state of+-- the concurrent computations from the parent computation.  The invariant is+-- that we should never be running two concurrent computations in the same+-- thread without using the runInIO function.  Also, we should never be running+-- a concurrent computation in the parent thread, otherwise it may affect the+-- state of the parent which is against the defined semantics of concurrent+-- execution.+newtype RunInIO m = RunInIO { runInIO :: forall b. m b -> IO (StM m b) }++captureMonadState :: MonadBaseControl IO m => m (RunInIO m)+captureMonadState = control $ \run -> run (return $ RunInIO run)++-- Stolen from the async package. The perf improvement is modest, 2% on a+-- thread heavy benchmark (parallel composition using noop computations).+-- A version of forkIO that does not include the outer exception+-- handler: saves a bit of time when we will be installing our own+-- exception handler.+{-# INLINE rawForkIO #-}+rawForkIO :: IO () -> IO ThreadId+rawForkIO action = IO $ \ s ->+   case fork# action s of (# s1, tid #) -> (# s1, ThreadId tid #)++{-# INLINE doFork #-}+doFork :: MonadBaseControl IO m+    => m ()+    -> RunInIO m+    -> (SomeException -> IO ())+    -> m ThreadId+doFork action (RunInIO mrun) exHandler =+    control $ \run ->+        mask $ \restore -> do+                tid <- rawForkIO $ catch (restore $ void $ mrun action)+                                         exHandler+                run (return tid)++------------------------------------------------------------------------------+-- Collecting results from child workers in a streamed fashion+------------------------------------------------------------------------------++-- XXX Can we make access to remainingWork and yieldRateInfo fields in sv+-- faster, along with the fields in sv required by send?+-- XXX make it noinline+--+-- XXX we may want to employ an increment and decrement in batches when the+-- througput is high or when the cost of synchronization is high. For example+-- if the application is distributed then inc/dec of a shared variable may be+-- very costly.+--+-- A worker decrements the yield limit before it executes an action. However,+-- the action may not result in an element being yielded, in that case we have+-- to increment the yield limit.+--+-- Note that we need it to be an Int type so that we have the ability to undo a+-- decrement that takes it below zero.+{-# INLINE decrementYieldLimit #-}+decrementYieldLimit :: SVar t m a -> IO Bool+decrementYieldLimit sv =+    case remainingWork sv of+        Nothing -> return True+        Just ref -> do+            r <- atomicModifyIORefCAS ref $ \x -> (x - 1, x)+            return $ r >= 1++{-# INLINE incrementYieldLimit #-}+incrementYieldLimit :: SVar t m a -> IO ()+incrementYieldLimit sv =+    case remainingWork sv of+        Nothing -> return ()+        Just ref -> atomicModifyIORefCAS_ ref (+ 1)++-- XXX exception safety of all atomic/MVar operations++-- TBD Each worker can have their own queue and the consumer can empty one+-- queue at a time, that way contention can be reduced.++-- XXX Only yields should be counted in the buffer limit and not the Stop+-- events.++{-# INLINE decrementBufferLimit #-}+decrementBufferLimit :: SVar t m a -> IO ()+decrementBufferLimit sv =+    case maxBufferLimit sv of+        Unlimited -> return ()+        Limited _ -> do+            let ref = pushBufferSpace sv+            old <- atomicModifyIORefCAS ref $ \x ->+                        (if x >= 1 then x - 1 else x, x)+            when (old <= 0) $+                case pushBufferPolicy sv of+                    PushBufferBlock -> blockAndRetry+                    PushBufferDropNew -> do+                        -- We just drop one item and proceed. It is possible+                        -- that by the time we drop the item the consumer+                        -- thread might have run and created space in the+                        -- buffer, but we do not care about that condition.+                        -- This is not pedantically correct but it should be+                        -- fine in practice.+                        -- XXX we may want to drop only if n == maxBuf+                        -- otherwise we must have space in the buffer and a+                        -- decrement should be possible.+                        block <- atomicModifyIORefCAS (outputQueue sv) $+                            \(es, n) ->+                                case es of+                                    [] -> (([],n), True)+                                    _ : xs -> ((xs, n - 1), False)+                        when block blockAndRetry+                    -- XXX need a dequeue or ring buffer for this+                    PushBufferDropOld -> undefined++    where++    blockAndRetry = do+        let ref = pushBufferSpace sv+        liftIO $ takeMVar (pushBufferMVar sv)+        old <- atomicModifyIORefCAS ref $ \x ->+                        (if x >= 1 then x - 1 else x, x)+        -- When multiple threads sleep on takeMVar, the first thread would+        -- wakeup due to a putMVar by the consumer, but the rest of the threads+        -- would have to put back the MVar after taking it and decrementing the+        -- buffer count, otherwise all other threads will remain asleep.+        if old >= 1+        then void $ liftIO $ tryPutMVar (pushBufferMVar sv) ()+        -- We do not put the MVar back in this case, instead we+        -- wait for the consumer to put it.+        else blockAndRetry++{-# INLINE incrementBufferLimit #-}+incrementBufferLimit :: SVar t m a -> IO ()+incrementBufferLimit sv =+    case maxBufferLimit sv of+        Unlimited -> return ()+        Limited _ -> do+            atomicModifyIORefCAS_ (pushBufferSpace sv) (+ 1)+            writeBarrier+            void $ liftIO $ tryPutMVar (pushBufferMVar sv) ()++{-# INLINE resetBufferLimit #-}+resetBufferLimit :: SVar t m a -> IO ()+resetBufferLimit sv =+    case maxBufferLimit sv of+        Unlimited -> return ()+        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) ->+        ((msg : es, n + 1), n)+    when (oldlen <= 0) $ do+        -- The wake up must happen only after the store has finished otherwise+        -- we can have lost wakeup problems.+        writeBarrier+        -- Since multiple workers can try this at the same time, it is possible+        -- that we may put a spurious MVar after the consumer has already seen+        -- the output. But that's harmless, at worst it may cause the consumer+        -- to read the queue again and find it empty.+        -- The important point is that the consumer is guaranteed to receive a+        -- doorbell if something was added to the queue after it empties it.+        void $ tryPutMVar (outputDoorBell sv) ()+    return oldlen++workerCollectLatency :: WorkerInfo -> IO (Maybe (Count, NanoSecond64))+workerCollectLatency winfo = do+    (cnt0, t0) <- readIORef (workerLatencyStart winfo)+    cnt1 <- readIORef (workerYieldCount winfo)+    let cnt = cnt1 - cnt0++    if cnt > 0+    then do+        t1 <- getTime Monotonic+        let period = fromRelTime64 $ diffAbsTime64 t1 t0+        writeIORef (workerLatencyStart winfo) (cnt1, t1)+        return $ Just (cnt, period)+    else return Nothing++-- XXX There are a number of gotchas in measuring latencies.+-- 1) We measure latencies only when a worker yields a value+-- 2) It is possible that a stream calls the stop continuation, in which case+-- the worker would not yield a value and we would not account that worker in+-- latencies. Even though this case should ideally be accounted we do not+-- account it because we cannot or do not distinguish it from the case+-- described next.+-- 3) It is possible that a worker returns without yielding anything because it+-- never got a chance to pick up work.+-- 4) If the system timer resolution is lower than the latency, the latency+-- computation turns out to be zero.+--+-- We can fix this if we measure the latencies by counting the work items+-- picked rather than based on the outputs yielded.+workerUpdateLatency :: YieldRateInfo -> WorkerInfo -> IO ()+workerUpdateLatency yinfo winfo = do+    r <- workerCollectLatency winfo+    case r of+        Just (cnt, period) -> do+        -- NOTE: On JS platform the timer resolution could be pretty low. When+        -- the timer resolution is low, measurement of latencies could be+        -- tricky. All the worker latencies will turn out to be zero if they+        -- are lower than the resolution. We only take into account those+        -- measurements which are more than the timer resolution.++            let ref = workerPendingLatency yinfo+                (cnt1, t1) = if period > 0 then (cnt, period) else (0, 0)+            atomicModifyIORefCAS_ ref $+                    \(fc, n, t) -> (fc + cnt, n + cnt1, t + t1)+        Nothing -> return ()++updateYieldCount :: WorkerInfo -> IO Count+updateYieldCount winfo = do+    cnt <- readIORef (workerYieldCount winfo)+    let cnt1 = cnt + 1+    writeIORef (workerYieldCount winfo) cnt1+    return cnt1++isBeyondMaxYield :: Count -> WorkerInfo -> Bool+isBeyondMaxYield cnt winfo =+    let ymax = workerYieldMax winfo+    in ymax /= 0 && cnt >= ymax++-- XXX we should do rate control periodically based on the total yields rather+-- than based on the worker local yields as other workers may have yielded more+-- and we should stop based on the aggregate yields. However, latency update+-- period can be based on individual worker yields.+{-# NOINLINE checkRatePeriodic #-}+checkRatePeriodic :: SVar t m a+                  -> YieldRateInfo+                  -> WorkerInfo+                  -> Count+                  -> IO Bool+checkRatePeriodic sv yinfo winfo ycnt = do+    i <- readIORef (workerPollingInterval yinfo)+    -- XXX use generation count to check if the interval has been updated+    if i /= 0 && (ycnt `mod` i) == 0+    then do+        workerUpdateLatency yinfo winfo+        -- XXX not required for parallel streams+        isBeyondMaxRate sv yinfo+    else return False++-- CAUTION! this also updates the yield count and therefore should be called+-- only when we are actually yielding an element.+{-# NOINLINE workerRateControl #-}+workerRateControl :: SVar t m a -> YieldRateInfo -> WorkerInfo -> IO Bool+workerRateControl sv yinfo winfo = do+    cnt <- updateYieldCount winfo+    beyondMaxRate <- checkRatePeriodic sv yinfo winfo cnt+    return $ not (isBeyondMaxYield cnt winfo || beyondMaxRate)++-- XXX we should do rate control here but not latency update in case of ahead+-- streams. latency update must be done when we yield directly to outputQueue+-- or when we yield to heap.+--+-- returns whether the worker should continue (True) or stop (False).+{-# INLINE sendYield #-}+sendYield :: SVar t m a -> Maybe WorkerInfo -> ChildEvent a -> IO Bool+sendYield sv mwinfo msg = do+    oldlen <- send sv msg+    let limit = maxBufferLimit sv+    bufferSpaceOk <- case limit of+            Unlimited -> return True+            Limited lim -> do+                active <- readIORef (workerCount sv)+                return $ (oldlen + 1) < (fromIntegral lim - active)+    rateLimitOk <-+        case mwinfo of+            Just winfo ->+                case yieldRateInfo sv of+                    Nothing -> return True+                    Just yinfo -> workerRateControl sv yinfo winfo+            Nothing -> return True+    return $ bufferSpaceOk && rateLimitOk++{-# INLINE workerStopUpdate #-}+workerStopUpdate :: WorkerInfo -> YieldRateInfo -> IO ()+workerStopUpdate winfo info = do+    i <- readIORef (workerPollingInterval info)+    when (i /= 0) $ workerUpdateLatency info winfo++{-# INLINABLE sendStop #-}+sendStop :: SVar t m a -> Maybe WorkerInfo -> IO ()+sendStop sv mwinfo = do+    atomicModifyIORefCAS_ (workerCount sv) $ \n -> n - 1+    case (mwinfo, yieldRateInfo sv) of+      (Just winfo, Just info) ->+          workerStopUpdate winfo info+      _ ->+          return ()+    myThreadId >>= \tid -> void $ send sv (ChildStop tid Nothing)++-------------------------------------------------------------------------------+-- Doorbell+-------------------------------------------------------------------------------++{-# INLINE ringDoorBell #-}+ringDoorBell :: SVar t m a -> IO ()+ringDoorBell sv = do+    storeLoadBarrier+    w <- readIORef $ needDoorBell sv+    when w $ do+        -- Note: the sequence of operations is important for correctness here.+        -- We need to set the flag to false strictly before sending the+        -- outputDoorBell, otherwise the outputDoorBell may get processed too+        -- early and then we may set the flag to False to later making the+        -- consumer lose the flag, even without receiving a outputDoorBell.+        atomicModifyIORefCAS_ (needDoorBell sv) (const False)+        void $ tryPutMVar (outputDoorBell sv) ()++-------------------------------------------------------------------------------+-- Async+-------------------------------------------------------------------------------++-- Note: For purely right associated expressions this queue should have at most+-- one element. It grows to more than one when we have left associcated+-- expressions. Large left associated compositions can grow this to a+-- large size+{-# INLINE enqueueLIFO #-}+enqueueLIFO :: SVar t m a -> IORef [t m a] -> t m a -> IO ()+enqueueLIFO sv q m = do+    atomicModifyIORefCAS_ q $ \ms -> m : ms+    ringDoorBell sv++-------------------------------------------------------------------------------+-- WAsync+-------------------------------------------------------------------------------++-- XXX we can use the Ahead style sequence/heap mechanism to make the best+-- effort to always try to finish the streams on the left side of an expression+-- first as long as possible.++{-# INLINE enqueueFIFO #-}+enqueueFIFO :: SVar t m a -> LinkedQueue (t m a) -> t m a -> IO ()+enqueueFIFO sv q m = do+    pushL q m+    ringDoorBell sv++-------------------------------------------------------------------------------+-- 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.++-- XXX 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 one item in it.+--+-- XXX we can fix this. When we queue more than one item on the queue we can+-- mark the previously queued item as not-runnable. The not-runnable item is+-- not dequeued until the already running one has finished and at that time we+-- would also know the exact sequence number of the already queued item.+--+-- we can even run the already queued items but they will have to be sorted in+-- layers in the heap. We can use a list of heaps for that.+{-# INLINE enqueueAhead #-}+enqueueAhead :: SVar t m a -> IORef ([t m a], Int) -> t m a -> IO ()+enqueueAhead sv q m = do+    atomicModifyIORefCAS_ q $ \ case+        ([], n) -> ([m], n + 1)  -- increment sequence+        _ -> error "enqueueAhead: queue is not empty"+    ringDoorBell sv++-- enqueue without incrementing the sequence number+{-# INLINE reEnqueueAhead #-}+reEnqueueAhead :: SVar t m a -> IORef ([t m a], Int) -> t m a -> IO ()+reEnqueueAhead sv q m = do+    atomicModifyIORefCAS_ q $ \ case+        ([], n) -> ([m], n)  -- DO NOT increment sequence+        _ -> error "reEnqueueAhead: queue is not empty"+    ringDoorBell sv++-- Normally the thread that has the token should never go away. The token gets+-- handed over to another thread, but someone or the other has the token at any+-- point of time. But if the task that has the token finds that the outputQueue+-- is full, in that case it can go away without even handing over the token to+-- another thread. In that case it sets the nextSequence number in the heap its+-- own sequence number before going away. To handle this case, any task that+-- does not have the token tries to dequeue from the heap first before+-- dequeuing from the work queue. If it finds that the task at the top of the+-- heap is the one that owns the current sequence number then it grabs the+-- token and starts with that.+--+-- XXX instead of queueing just the head element and the remaining computation+-- on the heap, evaluate as many as we can and place them on the heap. But we+-- need to give higher priority to the lower sequence numbers so that lower+-- priority tasks do not fill up the heap making higher priority tasks block+-- due to full heap. Maybe we can have a weighted space for them in the heap.+-- The weight is inversely proportional to the sequence number.+--+-- XXX review for livelock+--+{-# INLINE queueEmptyAhead #-}+queueEmptyAhead :: MonadIO m => IORef ([t m a], Int) -> m Bool+queueEmptyAhead q = liftIO $ do+    (xs, _) <- readIORef q+    return $ null xs++{-# INLINE dequeueAhead #-}+dequeueAhead :: MonadIO m+    => IORef ([t m a], Int) -> m (Maybe (t m a, Int))+dequeueAhead q = liftIO $+    atomicModifyIORefCAS q $ \case+            ([], n) -> (([], n), Nothing)+            (x : [], n) -> (([], n), Just (x, n))+            _ -> error "more than one item on queue"++-------------------------------------------------------------------------------+-- Heap manipulation+-------------------------------------------------------------------------------++withIORef :: IORef a -> (a -> IO b) -> IO b+withIORef ref f = readIORef ref >>= f++atomicModifyIORef_ :: IORef a -> (a -> a) -> IO ()+atomicModifyIORef_ ref f =+    atomicModifyIORef ref $ \x -> (f x, ())++data HeapDequeueResult t m a =+      Clearing+    | Waiting Int+    | Ready (Entry Int (AheadHeapEntry t m a))++{-# INLINE dequeueFromHeap #-}+dequeueFromHeap+    :: IORef (Heap (Entry Int (AheadHeapEntry t m a)), Maybe Int)+    -> IO (HeapDequeueResult t m a)+dequeueFromHeap hpVar =+    atomicModifyIORef hpVar $ \pair@(hp, snum) ->+        case snum of+            Nothing -> (pair, Clearing)+            Just n -> do+                let r = H.uncons hp+                case r of+                    Just (ent@(Entry seqNo _ev), hp') ->+                            if seqNo == n+                            then ((hp', Nothing), Ready ent)+                            else assert (seqNo >= n) (pair, Waiting n)+                    Nothing -> (pair, Waiting n)++{-# INLINE dequeueFromHeapSeq #-}+dequeueFromHeapSeq+    :: IORef (Heap (Entry Int (AheadHeapEntry t m a)), Maybe Int)+    -> Int+    -> IO (HeapDequeueResult t m a)+dequeueFromHeapSeq hpVar i =+    atomicModifyIORef hpVar $ \(hp, snum) ->+        case snum of+            Nothing -> do+                let r = H.uncons hp+                case r of+                    Just (ent@(Entry seqNo _ev), hp') ->+                        if seqNo == i+                        then ((hp', Nothing), Ready ent)+                        else assert (seqNo >= i) ((hp, Just i), Waiting i)+                    Nothing -> ((hp, Just i), Waiting i)+            Just _ -> error "dequeueFromHeapSeq: unreachable"++heapIsSane :: Maybe Int -> Int -> Bool+heapIsSane snum seqNo =+    case snum of+        Nothing -> True+        Just n -> seqNo >= n++{-# INLINE requeueOnHeapTop #-}+requeueOnHeapTop+    :: IORef (Heap (Entry Int (AheadHeapEntry t m a)), Maybe Int)+    -> Entry Int (AheadHeapEntry t m a)+    -> Int+    -> IO ()+requeueOnHeapTop hpVar ent seqNo =+    atomicModifyIORef_ hpVar $ \(hp, snum) ->+        assert (heapIsSane snum seqNo) (H.insert ent hp, Just seqNo)++{-# INLINE updateHeapSeq #-}+updateHeapSeq+    :: IORef (Heap (Entry Int (AheadHeapEntry t m a)), Maybe Int)+    -> Int+    -> IO ()+updateHeapSeq hpVar seqNo =+    atomicModifyIORef_ hpVar $ \(hp, snum) ->+        assert (heapIsSane snum seqNo) (hp, Just seqNo)++-------------------------------------------------------------------------------+-- 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.++-------------------------------------------------------------------------------+-- Dispatching workers and tracking them+-------------------------------------------------------------------------------++-- Thread tracking is needed for two reasons:+--+-- 1) Killing threads on exceptions. Threads may not be left to go away by+-- themselves because they may run for significant times before going away or+-- worse they may be stuck in IO and never go away.+--+-- 2) To know when all threads are done and the stream has ended.++{-# NOINLINE addThread #-}+addThread :: MonadIO m => SVar t m a -> ThreadId -> m ()+addThread sv tid =+    liftIO $ modifyIORef (workerThreads sv) (S.insert tid)++-- This is cheaper than modifyThread because we do not have to send a+-- outputDoorBell This can make a difference when more workers are being+-- dispatched.+{-# INLINE delThread #-}+delThread :: MonadIO m => SVar t m a -> ThreadId -> m ()+delThread sv tid =+    liftIO $ modifyIORef (workerThreads sv) (S.delete tid)++-- If present then delete else add. This takes care of out of order add and+-- delete i.e. a delete arriving before we even added a thread.+-- This occurs when the forked thread is done even before the 'addThread' right+-- after the fork gets a chance to run.+{-# INLINE modifyThread #-}+modifyThread :: MonadIO m => SVar t m a -> ThreadId -> m ()+modifyThread sv tid = do+    changed <- liftIO $ atomicModifyIORefCAS (workerThreads sv) $ \old ->+        if S.member tid old+        then let new = S.delete tid old in (new, new)+        else let new = S.insert tid old in (new, old)+    when (null changed) $+         liftIO $ do+            writeBarrier+            void $ tryPutMVar (outputDoorBell sv) ()++-- | This is safe even if we are adding more threads concurrently because if+-- a child thread is adding another thread then anyway 'workerThreads' will+-- not be empty.+{-# INLINE allThreadsDone #-}+allThreadsDone :: MonadIO m => SVar t m a -> m Bool+allThreadsDone sv = liftIO $ S.null <$> readIORef (workerThreads sv)++{-# NOINLINE handleChildException #-}+handleChildException :: SVar t m a -> SomeException -> IO ()+handleChildException sv e = do+    tid <- myThreadId+    void $ send sv (ChildStop tid (Just e))++{-# NOINLINE recordMaxWorkers #-}+recordMaxWorkers :: MonadIO m => SVar t m a -> m ()+recordMaxWorkers sv = liftIO $ do+    active <- readIORef (workerCount sv)+    maxWrk <- readIORef (maxWorkers $ svarStats sv)+    when (active > maxWrk) $ writeIORef (maxWorkers $ svarStats sv) active+    modifyIORef (totalDispatches $ svarStats sv) (+1)++{-# NOINLINE pushWorker #-}+pushWorker :: MonadAsync m => Count -> SVar t m a -> m ()+pushWorker yieldMax sv = do+    liftIO $ atomicModifyIORefCAS_ (workerCount sv) $ \n -> n + 1+    when (svarInspectMode sv) $ recordMaxWorkers sv+    -- This allocation matters when significant number of workers are being+    -- sent. We allocate it only when needed.+    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 = yieldMax+                    , workerYieldCount = cntRef+                    , workerLatencyStart = lat+                    }+    doFork (workLoop sv winfo) (svarMrun sv) (handleChildException sv)+        >>= addThread sv++-- XXX we can push the workerCount modification in accountThread and use the+-- same pushWorker for Parallel case as well.+--+-- | In contrast to pushWorker which always happens only from the consumer+-- thread, a pushWorkerPar can happen concurrently from multiple threads on the+-- producer side. So we need to use a thread safe modification of+-- workerThreads. Alternatively, we can use a CreateThread event to avoid+-- using a CAS based modification.+{-# INLINE pushWorkerPar #-}+pushWorkerPar+    :: MonadAsync m+    => SVar t m a -> (Maybe WorkerInfo -> m ()) -> m ()+pushWorkerPar sv wloop =+    if svarInspectMode sv+    then forkWithDiag+    else doFork (wloop Nothing) (svarMrun sv) (handleChildException sv)+            >>= modifyThread sv++    where++    {-# 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+                        }++        doFork (wloop winfo) (svarMrun sv) (handleChildException sv)+            >>= modifyThread sv++-- Returns:+-- True: can dispatch more+-- False: cannot dispatch any more+dispatchWorker :: MonadAsync m => Count -> SVar t m a -> m Bool+dispatchWorker yieldCount sv = do+    let workerLimit = maxWorkerLimit sv+    -- XXX in case of Ahead streams we should not send more than one worker+    -- when the work queue is done but heap is not done.+    done <- liftIO $ isWorkDone sv+    -- Note, "done" may not mean that the work is actually finished if there+    -- are workers active, because there may be a worker which has not yet+    -- queued the leftover work.+    if not done+    then do+        qDone <- liftIO $ isQueueDone sv+        -- This count may not be accurate as it is decremented by the workers+        -- and we have no synchronization with that decrement.+        active <- liftIO $ readIORef $ workerCount sv+        if not qDone+        then do+            -- Note that we may deadlock if the previous workers (tasks in the+            -- stream) wait/depend on the future workers (tasks in the stream)+            -- executing. In that case we should either configure the maxWorker+            -- count to higher or use parallel style instead of ahead or async+            -- style.+            limit <- case remainingWork sv of+                Nothing -> return workerLimit+                Just ref -> do+                    n <- liftIO $ readIORef ref+                    case yieldRateInfo sv of+                        Just _ -> return workerLimit+                        Nothing ->+                            return $+                                case workerLimit of+                                    Unlimited -> Limited (fromIntegral n)+                                    Limited lim -> Limited $ min lim (fromIntegral n)++            -- XXX for ahead streams shall we take the heap yields into account+            -- for controlling the dispatch? We should not dispatch if the heap+            -- has already got the limit covered.+            let dispatch = pushWorker yieldCount sv >> return True+             in case limit of+                Unlimited -> dispatch+                -- Note that the use of remainingWork and workerCount is not+                -- atomic and the counts may even have changed between reading+                -- and using them here, so this is just approximate logic and+                -- we cannot rely on it for correctness. We may actually+                -- dispatch more workers than required.+                Limited lim | lim > fromIntegral active -> dispatch+                _ -> return False+        else do+            when (active <= 0) $ pushWorker 0 sv+            return False+    else return False++-------------------------------------------------------------------------------+-- Dispatch workers with rate control+-------------------------------------------------------------------------------++-- | This is a magic number and it is overloaded, and used at several places to+-- achieve batching:+--+-- 1. If we have to sleep to slowdown this is the minimum period that we+--    accumulate before we sleep. Also, workers do not stop until this much+--    sleep time is accumulated.+-- 3. Collected latencies are computed and transferred to measured latency+--    after a minimum of this period.+minThreadDelay :: NanoSecond64+minThreadDelay = 1000000++-- | Another magic number! When we have to start more workers to cover up a+-- number of yields that we are lagging by then we cannot start one worker for+-- each yield because that may be a very big number and if the latency of the+-- workers is low these number of yields could be very high. We assume that we+-- run each extra worker for at least this much time.+rateRecoveryTime :: NanoSecond64+rateRecoveryTime = 1000000++-- We either block, or send one worker with limited yield count or one or more+-- workers with unlimited yield count.+data Work+    = BlockWait NanoSecond64+    | PartialWorker Count+    | ManyWorkers Int Count+    deriving Show++-- XXX we can use phantom types to distinguish the duration/latency/expectedLat+estimateWorkers+    :: Limit+    -> Count+    -> Count+    -> NanoSecond64+    -> NanoSecond64+    -> NanoSecond64+    -> LatencyRange+    -> Work+estimateWorkers workerLimit svarYields gainLossYields+                svarElapsed wLatency targetLat range =+    -- XXX we can have a maxEfficiency combinator as well which runs the+    -- producer at the maximal efficiency i.e. the number of workers are chosen+    -- such that the latency is minimum or within a range. Or we can call it+    -- maxWorkerLatency.+    --+    let+        -- How many workers do we need to acheive 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+        -- capacity to process all the requests concurrently. If the IO+        -- bandwidth is saturated increasing the workers won't help. Also, if+        -- the CPU utilization in processing all these requests exceeds the CPU+        -- bandwidth, then increasing the number of workers won't help.+        --+        -- When the workers are purely CPU bound, increasing the workers beyond+        -- the number of CPUs won't help.+        --+        -- TODO - measure the CPU and IO requirements of the workers. Have a+        -- way to specify the max bandwidth of the underlying IO mechanism and+        -- 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.++        -- Calculate how many yields are we ahead or behind to match the exact+        -- required rate. Based on that we increase or decrease the effective+        -- workers.+        --+        -- When the worker latency is lower than required latency we begin with+        -- a yield and then wait rather than first waiting and then yielding.+        targetYields = (svarElapsed + wLatency + targetLat - 1) `div` targetLat+        effectiveYields = svarYields + gainLossYields+        deltaYields = fromIntegral targetYields - effectiveYields++        -- We recover the deficit by running at a higher/lower rate for a+        -- certain amount of time. To keep the effective rate in reasonable+        -- limits we use rateRecoveryTime, minLatency and maxLatency.+        in  if deltaYields > 0+            then+                let deltaYieldsFreq :: Double+                    deltaYieldsFreq =+                        fromIntegral deltaYields /+                            fromIntegral rateRecoveryTime+                    yieldsFreq = 1.0 / fromIntegral targetLat+                    totalYieldsFreq = yieldsFreq + deltaYieldsFreq+                    requiredLat = NanoSecond64 $ round $ 1.0 / totalYieldsFreq+                    adjustedLat = min (max requiredLat (minLatency range))+                                      (maxLatency range)+                in  assert (adjustedLat > 0) $+                    if wLatency <= adjustedLat+                    then PartialWorker deltaYields+                    else let workers = withLimit $ wLatency `div` adjustedLat+                             limited = min workers (fromIntegral deltaYields)+                         in ManyWorkers (fromIntegral limited) deltaYields+            else+                let expectedDuration = fromIntegral effectiveYields * targetLat+                    sleepTime = expectedDuration - svarElapsed+                    maxSleepTime = maxLatency range - wLatency+                    s = min sleepTime maxSleepTime+                in assert (sleepTime >= 0) $+                    -- if s is less than 0 it means our maxSleepTime is less+                    -- than the worker latency.+                    if s > 0 then BlockWait s else ManyWorkers 1 (Count 0)+    where+        withLimit n =+            case workerLimit of+                Unlimited -> n+                Limited x -> min n (fromIntegral x)++-- | Get the worker latency without resetting workerPendingLatency+-- Returns (total yield count, base time, measured latency)+-- CAUTION! keep it in sync with collectLatency+getWorkerLatency :: YieldRateInfo -> IO (Count, AbsTime, NanoSecond64)+getWorkerLatency yinfo  = do+    let cur      = workerPendingLatency yinfo+        col      = workerCollectedLatency yinfo+        longTerm = svarAllTimeLatency yinfo+        measured = workerMeasuredLatency yinfo++    (curTotalCount, curCount, curTime) <- readIORef cur+    (colTotalCount, colCount, colTime) <- readIORef col+    (lcount, ltime)     <- readIORef longTerm+    prevLat             <- readIORef measured++    let latCount = colCount + curCount+        latTime  = colTime + curTime+        totalCount = colTotalCount + curTotalCount+        newLat =+            if latCount > 0 && latTime > 0+            then let lat = latTime `div` fromIntegral latCount+                 -- XXX Give more weight to new?+                 in (lat + prevLat) `div` 2+            else prevLat+    return (lcount + totalCount, ltime, newLat)++isBeyondMaxRate :: SVar t m a -> YieldRateInfo -> IO Bool+isBeyondMaxRate sv yinfo = do+    (count, tstamp, wLatency) <- getWorkerLatency yinfo+    now <- getTime Monotonic+    let duration = fromRelTime64 $ diffAbsTime64 now tstamp+    let targetLat = svarLatencyTarget yinfo+    gainLoss <- readIORef (svarGainedLostYields yinfo)+    let work = estimateWorkers (maxWorkerLimit sv) count gainLoss duration+                               wLatency targetLat (svarLatencyRange yinfo)+    cnt <- readIORef $ workerCount sv+    return $ case work of+        -- XXX set the worker's maxYields or polling interval based on yields+        PartialWorker _yields -> cnt > 1+        ManyWorkers n _ -> cnt > n+        BlockWait _ -> True++-- XXX in case of ahead style stream we need to take the heap size into account+-- because we return the workers on the basis of that which causes a condition+-- where we keep dispatching and they keep returning. So we must have exactly+-- the same logic for not dispatching and for returning.+--+-- Returns:+-- True: can dispatch more+-- False: full, no more dispatches+dispatchWorkerPaced :: MonadAsync m => SVar t m a -> m Bool+dispatchWorkerPaced sv = do+    let yinfo = fromJust $ yieldRateInfo sv+    (svarYields, svarElapsed, wLatency) <- do+        now <- liftIO $ getTime Monotonic+        (yieldCount, baseTime, lat) <-+            liftIO $ collectLatency sv yinfo False+        let elapsed = fromRelTime64 $ diffAbsTime64 now baseTime+        let latency =+                if lat == 0+                then+                    case workerBootstrapLatency yinfo of+                        Nothing -> lat+                        Just t -> t+                else lat++        return (yieldCount, elapsed, latency)++    if wLatency == 0+    -- Need to measure the latency with a single worker before we can perform+    -- any computation.+    then return False+    else do+        let workerLimit = maxWorkerLimit sv+        let targetLat = svarLatencyTarget yinfo+        let range = svarLatencyRange yinfo+        gainLoss <- liftIO $ readIORef (svarGainedLostYields yinfo)+        let work = estimateWorkers workerLimit svarYields gainLoss svarElapsed+                                   wLatency targetLat range++        -- XXX we need to take yieldLimit into account here. If we are at the+        -- end of the limit as well as the time, we should not be sleeping.+        -- If we are not actually planning to dispatch any more workers we need+        -- to take that in account.+        case work of+            BlockWait s -> do+                assert (s >= 0) (return ())+                -- XXX note that when we return from here we will block waiting+                -- for the result from the existing worker. If that takes too+                -- long we won't be able to send another worker until the+                -- result arrives.+                --+                -- Sleep only if there are no active workers, otherwise we will+                -- defer the output of those. Note we cannot use workerCount+                -- here as it is not a reliable way to ensure there are+                -- definitely no active workers. When workerCount is 0 we may+                -- still have a Stop event waiting in the outputQueue.+                done <- allThreadsDone sv+                when done $ void $ do+                    let us = fromRelTime64 (toRelTime64 s) :: MicroSecond64+                    liftIO $ threadDelay (fromIntegral us)+                    dispatchWorker 1 sv+                return False+            PartialWorker yields -> do+                assert (yields > 0) (return ())+                updateGainedLostYields yinfo yields++                done <- allThreadsDone sv+                when done $ void $ dispatchWorker yields sv+                return False+            ManyWorkers netWorkers yields -> do+                assert (netWorkers >= 1) (return ())+                assert (yields >= 0) (return ())+                updateGainedLostYields yinfo yields++                let periodRef = workerPollingInterval yinfo+                    ycnt = max 1 $ yields `div` fromIntegral netWorkers+                    period = min ycnt (fromIntegral magicMaxBuffer)++                old <- liftIO $ readIORef periodRef+                when (period < old) $+                    liftIO $ writeIORef periodRef period++                cnt <- liftIO $ readIORef $ workerCount sv+                if cnt < netWorkers+                then do+                    let total = netWorkers - cnt+                        batch = max 1 $ fromIntegral $+                                    minThreadDelay `div` targetLat+                    -- XXX stagger the workers over a period?+                    -- XXX cannot sleep, as that would mean we cannot process+                    -- the outputs. need to try a different mechanism to+                    -- stagger.+                    -- when (total > batch) $+                       -- liftIO $ threadDelay $ nanoToMicroSecs minThreadDelay+                    dispatchN (min total batch)+                else return False++    where++    updateGainedLostYields yinfo yields = do+        let buf = fromIntegral $ svarRateBuffer yinfo+        when (yields /= 0 && abs yields > buf) $ do+            let delta =+                   if yields > 0+                   then yields - buf+                   else yields + buf+            liftIO $ modifyIORef (svarGainedLostYields yinfo) (+ delta)++    dispatchN n =+        if n == 0+        then return True+        else do+            r <- dispatchWorker 0 sv+            if r+            then dispatchN (n - 1)+            else return False++-------------------------------------------------------------------------------+-- Worker dispatch and wait loop+-------------------------------------------------------------------------------++sendWorkerDelayPaced :: SVar t m a -> IO ()+sendWorkerDelayPaced _ = return ()++sendWorkerDelay :: SVar t m a -> IO ()+sendWorkerDelay _sv =+    -- XXX we need a better way to handle this than hardcoded delays. The+    -- delays may be different for different systems.+    -- If there is a usecase where this is required we can create a combinator+    -- to set it as a config in the state.+    {-+  do+    ncpu <- getNumCapabilities+    if ncpu <= 1+    then+        if (svarStyle sv == AheadVar)+        then threadDelay 100+        else threadDelay 25+    else+        if (svarStyle sv == AheadVar)+        then threadDelay 100+        else threadDelay 10+    -}+    return ()++{-# NOINLINE sendWorkerWait #-}+sendWorkerWait+    :: MonadAsync m+    => (SVar t m a -> IO ())+    -> (SVar t m a -> m Bool)+    -> SVar t m a+    -> m ()+sendWorkerWait delay dispatch sv = do+    -- Note that we are guaranteed to have at least one outstanding worker when+    -- we enter this function. So if we sleep we are guaranteed to be woken up+    -- by an outputDoorBell, when the worker exits.++    liftIO $ delay sv+    (_, n) <- liftIO $ readIORef (outputQueue sv)+    when (n <= 0) $ do+        -- The queue may be empty temporarily if the worker has dequeued the+        -- work item but has not enqueued the remaining part yet. For the same+        -- reason, a worker may come back if it tries to dequeue and finds the+        -- queue empty, even though the whole work has not finished yet.++        -- If we find that the queue is empty, but it may be empty+        -- temporarily, when we checked it. If that's the case we might+        -- sleep indefinitely unless the active workers produce some+        -- output. We may deadlock specially if the otuput from the active+        -- workers depends on the future workers that we may never send.+        -- So in case the queue was temporarily empty set a flag to inform+        -- the enqueue to send us a doorbell.++        -- Note that this is just a best effort mechanism to avoid a+        -- deadlock. Deadlocks may still happen if for some weird reason+        -- the consuming computation shares an MVar or some other resource+        -- with the producing computation and gets blocked on that resource+        -- and therefore cannot do any pushworker to add more threads to+        -- the producer. In such cases the programmer should use a parallel+        -- style so that all the producers are scheduled immediately and+        -- unconditionally. We can also use a separate monitor thread to+        -- push workers instead of pushing them from the consumer, but then+        -- we are no longer using pull based concurrency rate adaptation.+        --+        -- XXX update this in the tutorial.+        --+        -- Having pending active workers does not mean that we are guaranteed+        -- to be woken up if we sleep. In case of Ahead streams, there may be+        -- queued items in the heap even though the outputQueue is empty, and+        -- we may have active workers which are deadlocked on those items to be+        -- processed by the consumer. We should either guarantee that any+        -- worker, before returning, clears the heap or we send a worker to+        -- clear it. Normally we always send a worker if no output is seen, but+        -- if the thread limit is reached or we are using pacing then we may+        -- not send a worker. See the concurrentApplication test in the tests,+        -- that test case requires at least one yield from the producer to not+        -- deadlock, if the last workers output is stuck in the heap then this+        -- test fails.  This problem can be extended to n threads when the+        -- consumer may depend on the evaluation of next n items in the+        -- producer stream.++        -- register for the outputDoorBell before we check the queue so that if+        -- we sleep because the queue was empty we are guaranteed to get a+        -- doorbell on the next enqueue.++        liftIO $ atomicModifyIORefCAS_ (needDoorBell sv) $ const True+        liftIO storeLoadBarrier+        canDoMore <- dispatch sv++        -- XXX test for the case when we miss sending a worker when the worker+        -- count is more than 1500.+        --+        -- XXX Assert here that if the heap is not empty then there is at+        -- least one outstanding worker. Otherwise we could be sleeping+        -- forever.++        if canDoMore+        then sendWorkerWait delay dispatch sv+        else do+            liftIO $ withDiagMVar sv "sendWorkerWait: nothing to do"+                             $ takeMVar (outputDoorBell sv)+            (_, len) <- liftIO $ readIORef (outputQueue sv)+            when (len <= 0) $ sendWorkerWait delay dispatch sv++-------------------------------------------------------------------------------+-- Reading from the workers' output queue/buffer+-------------------------------------------------------------------------------++{-# INLINE readOutputQRaw #-}+readOutputQRaw :: SVar t m a -> IO ([ChildEvent a], Int)+readOutputQRaw sv = do+    (list, len) <- atomicModifyIORefCAS (outputQueue sv) $ \x -> (([],0), x)+    when (svarInspectMode sv) $ do+        let ref = maxOutQSize $ svarStats sv+        oqLen <- readIORef ref+        when (len > oqLen) $ writeIORef ref len+    return (list, len)++readOutputQBounded :: MonadAsync m => SVar t m a -> m [ChildEvent a]+readOutputQBounded sv = do+    (list, len) <- liftIO $ readOutputQRaw sv+    -- When there is no output seen we dispatch more workers to help+    -- out if there is work pending in the work queue.+    if len <= 0+    then blockingRead+    else do+        -- send a worker proactively, if needed, even before we start+        -- processing the output.  This may degrade single processor+        -- perf but improves multi-processor, because of more+        -- parallelism+        sendOneWorker+        return list++    where++    sendOneWorker = do+        cnt <- liftIO $ readIORef $ workerCount sv+        when (cnt <= 0) $ do+            done <- liftIO $ isWorkDone sv+            when (not done) (pushWorker 0 sv)++    {-# INLINE blockingRead #-}+    blockingRead = do+        sendWorkerWait sendWorkerDelay (dispatchWorker 0) sv+        liftIO (fst `fmap` readOutputQRaw sv)++readOutputQPaced :: MonadAsync m => SVar t m a -> m [ChildEvent a]+readOutputQPaced sv = do+    (list, len) <- liftIO $ readOutputQRaw sv+    if len <= 0+    then blockingRead+    else do+        -- XXX send a worker proactively, if needed, even before we start+        -- processing the output.+        void $ dispatchWorkerPaced sv+        return list++    where++    {-# INLINE blockingRead #-}+    blockingRead = do+        sendWorkerWait sendWorkerDelayPaced dispatchWorkerPaced sv+        liftIO (fst `fmap` readOutputQRaw sv)++postProcessBounded :: MonadAsync m => SVar t m a -> m Bool+postProcessBounded sv = do+    workersDone <- allThreadsDone sv+    -- There may still be work pending even if there are no workers pending+    -- because all the workers may return if the outputQueue becomes full. In+    -- that case send off a worker to kickstart the work again.+    --+    -- Note that isWorkDone can only be safely checked if all workers are done.+    -- When some workers are in progress they may have decremented the yield+    -- Limit and later ending up incrementing it again. If we look at the yield+    -- limit in that window we may falsely say that it is 0 and therefore we+    -- are done.+    if workersDone+    then do+        r <- liftIO $ isWorkDone sv+        -- Note that we need to guarantee a worker, therefore we cannot just+        -- use dispatchWorker which may or may not send a worker.+        when (not r) (pushWorker 0 sv)+        -- XXX do we need to dispatch many here?+        -- void $ dispatchWorker sv+        return r+    else return False++postProcessPaced :: MonadAsync m => SVar t m a -> m Bool+postProcessPaced sv = do+    workersDone <- allThreadsDone sv+    -- XXX If during consumption we figure out we are getting delayed then we+    -- should trigger dispatch there as well.  We should try to check on the+    -- workers after consuming every n item from the buffer?+    if workersDone+    then do+        r <- liftIO $ isWorkDone sv+        when (not r) $ do+            void $ dispatchWorkerPaced sv+            -- Note that we need to guarantee a worker since the work is not+            -- finished, therefore we cannot just rely on dispatchWorkerPaced+            -- which may or may not send a worker.+            noWorker <- allThreadsDone sv+            when noWorker $ pushWorker 0 sv+        return r+    else return False++-------------------------------------------------------------------------------+-- Creating an SVar+-------------------------------------------------------------------------------++getYieldRateInfo :: State t m a -> IO (Maybe YieldRateInfo)+getYieldRateInfo st = do+    -- convert rate in Hertz to latency in Nanoseconds+    let rateToLatency r = if r <= 0 then maxBound else round $ 1.0e9 / r+    case getStreamRate st of+        Just (Rate low goal high buf) ->+            let l    = rateToLatency goal+                minl = rateToLatency high+                maxl = rateToLatency low+            in mkYieldRateInfo l (LatencyRange minl maxl) buf+        Nothing -> return Nothing++    where++    mkYieldRateInfo latency latRange buf = do+        measured <- newIORef 0+        wcur     <- newIORef (0,0,0)+        wcol     <- newIORef (0,0,0)+        now      <- getTime Monotonic+        wlong    <- newIORef (0,now)+        period   <- newIORef 1+        gainLoss <- newIORef (Count 0)++        return $ Just YieldRateInfo+            { svarLatencyTarget      = latency+            , svarLatencyRange       = latRange+            , svarRateBuffer         = buf+            , svarGainedLostYields   = gainLoss+            , workerBootstrapLatency = getStreamLatency st+            , workerPollingInterval  = period+            , workerMeasuredLatency  = measured+            , workerPendingLatency   = wcur+            , workerCollectedLatency = wcol+            , svarAllTimeLatency     = wlong+            }++newSVarStats :: IO SVarStats+newSVarStats = do+    disp   <- newIORef 0+    maxWrk <- newIORef 0+    maxOq  <- newIORef 0+    maxHs  <- newIORef 0+    maxWq  <- newIORef 0+    avgLat <- newIORef (0, NanoSecond64 0)+    maxLat <- newIORef (NanoSecond64 0)+    minLat <- newIORef (NanoSecond64 0)+    stpTime <- newIORef Nothing++    return SVarStats+        { totalDispatches  = disp+        , maxWorkers       = maxWrk+        , maxOutQSize      = maxOq+        , maxHeapSize      = maxHs+        , maxWorkQSize     = maxWq+        , avgWorkerLatency = avgLat+        , minWorkerLatency = minLat+        , maxWorkerLatency = maxLat+        , svarStopTime     = stpTime+        }++-- XXX remove polymorphism in t, inline f+getAheadSVar :: MonadAsync m+    => State t m a+    -> (   IORef ([t m a], Int)+        -> IORef (Heap (Entry Int (AheadHeapEntry t m a)), Maybe Int)+        -> State t m a+        -> SVar t m a+        -> Maybe WorkerInfo+        -> m ())+    -> RunInIO m+    -> IO (SVar t m a)+getAheadSVar st f mrun = do+    outQ    <- newIORef ([], 0)+    -- the second component of the tuple is "Nothing" when heap is being+    -- cleared, "Just n" when we are expecting sequence number n to arrive+    -- before we can start clearing the heap.+    outH    <- newIORef (H.empty, Just 0)+    outQMv  <- newEmptyMVar+    active  <- newIORef 0+    wfw     <- newIORef False+    running <- newIORef S.empty+    -- Sequence number is incremented whenever something is queued, therefore,+    -- first sequence number would be 0+    q <- newIORef ([], -1)+    stopMVar <- newMVar ()+    yl <- case getYieldLimit st of+            Nothing -> return Nothing+            Just x -> Just <$> newIORef x+    rateInfo <- getYieldRateInfo st++    stats <- newSVarStats+    tid <- myThreadId++    let getSVar sv readOutput postProc = 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         = f q outH st{streamVar = Just sv} sv+            , enqueue          = enqueueAhead sv q+            , isWorkDone       = isWorkDoneAhead sv q outH+            , isQueueDone      = isQueueDoneAhead sv q+            , needDoorBell     = wfw+            , svarStyle        = AheadVar+            , svarStopStyle    = StopNone+            , svarStopBy       = undefined+            , svarMrun         = mrun+            , workerCount      = active+            , accountThread    = delThread sv+            , workerStopMVar   = stopMVar+            , svarRef          = Nothing+            , svarInspectMode  = getInspectMode st+            , svarCreator      = tid+            , aheadWorkQueue   = q+            , outputHeap       = outH+            , svarStats        = stats+            }++    let sv =+            case getStreamRate st of+                Nothing -> getSVar sv readOutputQBounded postProcessBounded+                Just _  -> getSVar sv readOutputQPaced postProcessPaced+     in return sv++    where++    {-# INLINE isQueueDoneAhead #-}+    isQueueDoneAhead sv q = do+        queueDone <- checkEmpty q+        yieldsDone <-+                case remainingWork sv of+                    Just yref -> do+                        n <- readIORef yref+                        return (n <= 0)+                    Nothing -> return False+        -- XXX note that yieldsDone can only be authoritative only when there+        -- are no workers running. If there are active workers they can+        -- later increment the yield count and therefore change the result.+        return $ yieldsDone || queueDone++    {-# INLINE isWorkDoneAhead #-}+    isWorkDoneAhead sv q ref = do+        heapDone <- do+                (hp, _) <- readIORef ref+                return (H.size hp <= 0)+        queueDone <- isQueueDoneAhead sv q+        return $ heapDone && queueDone++    checkEmpty q = do+        (xs, _) <- readIORef q+        return $ null xs++getParallelSVar :: MonadIO m+    => SVarStopStyle -> State t m a -> RunInIO m -> IO (SVar t m a)+getParallelSVar ss st mrun = do+    outQ    <- newIORef ([], 0)+    outQMv  <- newEmptyMVar+    active  <- newIORef 0+    running <- newIORef S.empty+    yl <- case getYieldLimit st of+            Nothing -> return Nothing+            Just x -> Just <$> newIORef x+    rateInfo <- getYieldRateInfo st+    let bufLim =+            case getMaxBuffer st of+                Unlimited -> undefined+                Limited x -> (fromIntegral x)+    remBuf <- newIORef bufLim+    pbMVar <- newMVar ()++    stats <- newSVarStats+    tid <- myThreadId++    stopBy <-+        case ss of+            StopBy -> liftIO $ newIORef undefined+            _ -> return undefined++    let sv =+            SVar { outputQueue      = outQ+                 , remainingWork    = yl+                 , maxBufferLimit   = getMaxBuffer st+                 , pushBufferSpace  = remBuf+                 , pushBufferPolicy = PushBufferBlock+                 , pushBufferMVar   = pbMVar+                 , maxWorkerLimit   = Unlimited+                 -- Used only for diagnostics+                 , yieldRateInfo    = rateInfo+                 , outputDoorBell   = outQMv+                 , readOutputQ      = readOutputQPar sv+                 , postProcess      = allThreadsDone sv+                 , workerThreads    = running+                 , workLoop         = undefined+                 , enqueue          = undefined+                 , isWorkDone       = undefined+                 , isQueueDone      = undefined+                 , needDoorBell     = undefined+                 , svarStyle        = ParallelVar+                 , svarStopStyle    = ss+                 , svarStopBy       = stopBy+                 , svarMrun         = mrun+                 , workerCount      = active+                 , accountThread    = modifyThread sv+                 , workerStopMVar   = undefined+                 , svarRef          = Nothing+                 , svarInspectMode  = getInspectMode st+                 , svarCreator      = tid+                 , aheadWorkQueue   = undefined+                 , outputHeap       = undefined+                 , svarStats        = stats+                 }+     in return sv++    where++    readOutputQPar sv = liftIO $ do+        withDiagMVar sv "readOutputQPar: doorbell"+            $ takeMVar (outputDoorBell sv)+        case yieldRateInfo sv of+            Nothing -> return ()+            Just yinfo -> void $ collectLatency sv yinfo False+        r <- fst `fmap` readOutputQRaw sv+        liftIO $ do+            void $ tryTakeMVar (pushBufferMVar sv)+            resetBufferLimit sv+            writeBarrier+            void $ tryPutMVar (pushBufferMVar sv) ()+        return r++sendFirstWorker :: MonadAsync m => SVar t m a -> t m a -> m (SVar t m a)+sendFirstWorker sv m = do+    -- Note: We must have all the work on the queue before sending the+    -- pushworker, otherwise the pushworker may exit before we even get a+    -- chance to push.+    liftIO $ enqueue sv m+    case yieldRateInfo sv of+        Nothing -> pushWorker 0 sv+        Just yinfo  ->+            if svarLatencyTarget yinfo == maxBound+            then liftIO $ threadDelay maxBound+            else pushWorker 1 sv+    return sv++{-# INLINABLE newAheadVar #-}+newAheadVar :: MonadAsync m+    => State t m a+    -> t m a+    -> (   IORef ([t m a], Int)+        -> IORef (Heap (Entry Int (AheadHeapEntry t m a)), Maybe Int)+        -> State t m a+        -> SVar t m a+        -> Maybe WorkerInfo+        -> m ())+    -> m (SVar t m a)+newAheadVar st m wloop = do+    mrun <- captureMonadState+    sv <- liftIO $ getAheadSVar st wloop mrun+    sendFirstWorker sv m++{-# INLINABLE newParallelVar #-}+newParallelVar :: MonadAsync m+    => SVarStopStyle -> State t m a -> m (SVar t m a)+newParallelVar ss st = do+    mrun <- captureMonadState+    liftIO $ getParallelSVar ss st mrun++-------------------------------------------------------------------------------+-- Write a stream to an SVar+-------------------------------------------------------------------------------++-- XXX this errors out for Parallel/Ahead SVars+-- | Write a stream to an 'SVar' in a non-blocking manner. The stream can then+-- be read back from the SVar using 'fromSVar'.+toStreamVar :: MonadAsync m => SVar t m a -> t m a -> m ()+toStreamVar sv m = do+    liftIO $ enqueue sv m+    done <- allThreadsDone sv+    -- XXX This is safe only when called from the consumer thread or when no+    -- consumer is present.  There may be a race if we are not running in the+    -- consumer thread.+    -- XXX do this only if the work queue is not empty. The work may have been+    -- carried out by existing workers.+    when done $+        case yieldRateInfo sv of+            Nothing -> pushWorker 0 sv+            Just _  -> pushWorker 1 sv
+ src/Streamly/Internal/Data/Sink.hs view
@@ -0,0 +1,247 @@+{-# OPTIONS_HADDOCK hide #-}++-- |+-- Module      : Streamly.Internal.Data.Sink+-- Copyright   : (c) 2019 Composewell Technologies+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+--+-- The 'Sink' type is a just a special case of 'Fold' and we can do without+-- it. However, in some cases 'Sink' is a simpler type and may provide better+-- performance than 'Fold' because it does not maintain any state. Folds can+-- be used for both pure and monadic computations. Sinks are not applicable to+-- pure computations.++module Streamly.Internal.Data.Sink+    (+      Sink (..)++    -- * Upgrading+    , toFold++    -- * Composing Sinks+    -- ** Distribute+    , tee+    , distribute++    -- ** Demultiplex+    , demux++    -- ** Unzip+    , unzipM+    , unzip++    -- -- ** Group+    -- , grouped++    -- -- ** Nest+    -- , concatFold++    -- -- * Comonad+    -- , duplicate++    -- * Input Transformation+    -- | These are contravariant operations i.e. they apply on the input of the+    -- 'Sink', for this reason they are prefixed with 'l' for 'left'.+    , lmap+    , lmapM+    , lfilter+    , lfilterM++    -- * Sinks+    , drain+    , drainM+    -- , drainN+    -- , drainWhile+    )+where++import Control.Monad (when, void)+import Data.Map.Strict (Map)+import Prelude+       hiding (filter, drop, dropWhile, take, takeWhile, zipWith, foldr,+               foldl, map, 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, mconcat, foldMap, unzip)++import Streamly.Internal.Data.Fold.Types (Fold(..))+import Streamly.Internal.Data.Sink.Types (Sink(..))++import qualified Data.Map.Strict as Map++------------------------------------------------------------------------------+-- Conversion+------------------------------------------------------------------------------++-- | Convert a 'Sink' to a 'Fold'. When you want to compose sinks and folds+-- together, upgrade a sink to a fold before composing.+toFold :: Monad m => Sink m a -> Fold m a ()+toFold (Sink f) = Fold step begin done+    where+    begin = return ()+    step _ = f+    done _ = return ()++------------------------------------------------------------------------------+-- Composing with sinks+------------------------------------------------------------------------------++-- | Distribute one copy each of the input to both the sinks.+--+-- @+--                 |-------Sink m a+-- ---stream m a---|+--                 |-------Sink m a+-- @+-- @+-- > let pr x = Sink.drainM (putStrLn . ((x ++ " ") ++) . show)+-- > sink (Sink.tee (pr \"L") (pr \"R")) (S.enumerateFromTo 1 2)+-- L 1+-- R 1+-- L 2+-- R 2+-- @+--+tee :: Monad m => Sink m a -> Sink m a -> Sink m a+tee (Sink fL) (Sink fR) = Sink (\a -> fL a >> fR a)++-- | Distribute copies of the input to all the sinks in a container.+--+-- @+--                 |-------Sink m a+-- ---stream m a---|+--                 |-------Sink m a+--                 |+--                       ...+-- @+-- @+-- > let pr x = Sink.drainM (putStrLn . ((x ++ " ") ++) . show)+-- > sink (Sink.distribute [(pr \"L"), (pr \"R")]) (S.enumerateFromTo 1 2)+-- L 1+-- R 1+-- L 2+-- R 2+-- @+--+-- This is the consumer side dual of the producer side 'sequence_' operation.+{-# INLINE distribute #-}+distribute :: Monad m => [Sink m a] -> Sink m a+distribute ss = Sink (\a -> Prelude.mapM_ (\(Sink f) -> f a) ss)++-- | Demultiplex to multiple consumers without collecting the results. Useful+-- to run different effectful computations depending on the value of the stream+-- elements, for example handling network packets of different types using+-- different handlers.+--+-- @+--+--                             |-------Sink m a+-- -----stream m a-----Map-----|+--                             |-------Sink m a+--                             |+--                                       ...+-- @+--+-- @+-- > let pr x = Sink.drainM (putStrLn . ((x ++ " ") ++) . show)+-- > let table = Data.Map.fromList [(1, pr \"One"), (2, pr \"Two")]+--   in Sink.sink (Sink.demux id table) (S.enumerateFromTo 1 100)+-- One 1+-- Two 2+-- @+{-+demux :: (Monad m, Ord k) => (a -> k) -> Map k (Sink m a) -> Sink m a+demux f kv = Sink step++    where++    step a =+        -- XXX should we raise an exception in Nothing case?+        -- Ideally we should enforce that it is a total map over k so that look+        -- up never fails+        case Map.lookup (f a) kv of+            Nothing -> return ()+            Just (Sink g) -> g a+-}++demux :: (Monad m, Ord k) => Map k (Sink m a) -> Sink m (a, k)+demux kv = Sink step++    where++    step (a, k) =+        -- XXX should we raise an exception in Nothing case?+        -- Ideally we should enforce that it is a total map over k so that look+        -- up never fails+        case Map.lookup k kv of+            Nothing -> return ()+            Just (Sink g) -> g a++-- | Split elements in the input stream into two parts using a monadic unzip+-- function, direct each part to a different sink.+--+-- @+--+--                           |-------Sink m b+-- -----Stream m a----(b,c)--|+--                           |-------Sink m c+-- @+-- @+-- > let pr x = Sink.drainM (putStrLn . ((x ++ " ") ++) . show)+--   in Sink.sink (Sink.unzip return (pr \"L") (pr \"R")) (S.yield (1,2))+-- L 1+-- R 2+-- @+{-# INLINE unzipM #-}+unzipM :: Monad m => (a -> m (b,c)) -> Sink m b -> Sink m c -> Sink m a+unzipM f (Sink stepB) (Sink stepC) =+    Sink (\a -> f a >>= \(b,c) -> stepB b >> stepC c)++-- | Same as 'unzipM' but with a pure unzip function.+{-# INLINE unzip #-}+unzip :: Monad m => (a -> (b,c)) -> Sink m b -> Sink m c -> Sink m a+unzip f = unzipM (return . f)++------------------------------------------------------------------------------+-- Input transformation+------------------------------------------------------------------------------++-- | Map a pure function on the input of a 'Sink'.+{-# INLINABLE lmap #-}+lmap :: (a -> b) -> Sink m b -> Sink m a+lmap f (Sink step) = Sink (step . f)++-- | Map a monadic function on the input of a 'Sink'.+{-# INLINABLE lmapM #-}+lmapM :: Monad m => (a -> m b) -> Sink m b -> Sink m a+lmapM f (Sink step) = Sink (\x -> f x >>= step)++-- | Filter the input of a 'Sink' using a pure predicate function.+{-# INLINABLE lfilter #-}+lfilter :: Monad m => (a -> Bool) -> Sink m a -> Sink m a+lfilter f (Sink step) = Sink (\a -> when (f a) $ step a)++-- | Filter the input of a 'Sink' using a monadic predicate function.+{-# INLINABLE lfilterM #-}+lfilterM :: Monad m => (a -> m Bool) -> Sink m a -> Sink m a+lfilterM f (Sink step) = Sink (\a -> f a >>= \use -> when use $ step a)++------------------------------------------------------------------------------+-- Sinks+------------------------------------------------------------------------------++-- | Drain all input, running the effects and discarding the results.+drain :: Monad m => Sink m a+drain = Sink (\_ -> return ())++-- |+-- > drainM f = lmapM f drain+--+-- Drain all input after passing it through a monadic function.+{-# INLINABLE drainM #-}+drainM ::  Monad m => (a -> m b) -> Sink m a+drainM f = Sink (void . f)
+ src/Streamly/Internal/Data/Sink/Types.hs view
@@ -0,0 +1,26 @@+{-# OPTIONS_HADDOCK hide #-}++-- |+-- Module      : Streamly.Internal.Data.Sink.Types+-- Copyright   : (c) 2019 Composewell Technologies+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++module Streamly.Internal.Data.Sink.Types+    (+      Sink (..)+    )+where++------------------------------------------------------------------------------+-- Sink+------------------------------------------------------------------------------++-- | A 'Sink' is a special type of 'Foldl' 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+-- 'Sink's are composed with other operations. A Sink can be upgraded to a+-- 'Foldl', but a 'Foldl' cannot be converted into a Sink.+data Sink m a = Sink (a -> m ())
+ src/Streamly/Internal/Data/Stream/StreamD/Type.hs view
@@ -0,0 +1,598 @@+{-# OPTIONS_HADDOCK hide     #-}+{-# LANGUAGE BangPatterns              #-}+{-# LANGUAGE CPP                       #-}+{-# LANGUAGE ConstraintKinds           #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE MultiParamTypeClasses     #-}+{-# LANGUAGE PatternSynonyms           #-}+{-# LANGUAGE ViewPatterns              #-}+{-# LANGUAGE RankNTypes                #-}++#include "inline.hs"++-- |+-- Module      : Streamly.Internal.Data.Stream.StreamD.Type+-- Copyright   : (c) 2018 Harendra Kumar+-- Copyright   : (c) Roman Leshchinskiy 2008-2010+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++module Streamly.Internal.Data.Stream.StreamD.Type+    (+    -- * The stream type+      Step (..)+    -- XXX UnStream is exported to avoid a performance issue in concatMap if we+    -- use the pattern synonym "Stream".+#if __GLASGOW_HASKELL__ >= 800+    , Stream (Stream, UnStream)+#else+    , Stream (UnStream)+    , pattern Stream+#endif+    , fromStreamK+    , toStreamK+    , fromStreamD+    , map+    , mapM+    , yield+    , yieldM+    , concatMap+    , concatMapM++    , foldrT+    , foldrM+    , foldrMx+    , foldr+    , foldrS++    , foldl'+    , foldlM'+    , foldlx'+    , foldlMx'++    , toList+    , fromList++    , eqBy+    , cmpBy+    , take+    , GroupState (..) -- for inspection testing+    , groupsOf+    , groupsOf2+    )+where++import Control.Applicative (liftA2)+import Control.Monad (ap, 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 Streamly.Internal.Data.SVar (State(..), adaptState, defState)+import Streamly.Internal.Data.Fold.Types (Fold(..), Fold2(..))++import qualified Streamly.Streams.StreamK as K++------------------------------------------------------------------------------+-- The direct style stream type+------------------------------------------------------------------------------++-- | A stream is a succession of 'Step's. A 'Yield' produces a single value and+-- the next state of the stream. 'Stop' indicates there are no more values in+-- the stream.+data Step s a = Yield a s | Skip s | Stop++{-+instance Functor (Step s) where+    {-# INLINE fmap #-}+    fmap f (Yield x s) = Yield (f x) s+    fmap _ (Skip s) = Skip s+    fmap _ Stop = Stop+-}++-- gst = global state+-- | A stream consists of a step function that generates the next step given a+-- current state, and the current state.+data Stream m a =+    forall s. UnStream (State K.Stream m a -> s -> m (Step s a)) s++unShare :: Stream m a -> Stream m a+unShare (UnStream step state) = UnStream step' state+    where step' gst = step (adaptState gst)++pattern Stream :: (State K.Stream m a -> s -> m (Step s a)) -> s -> Stream m a+pattern Stream step state <- (unShare -> UnStream step state)+    where Stream = UnStream++#if __GLASGOW_HASKELL__ >= 802+{-# COMPLETE Stream #-}+#endif++{-# INLINE_LATE fromStreamK #-}+fromStreamK :: Monad m => K.Stream m a -> Stream m a+fromStreamK = Stream step+    where+    step gst m1 =+        let stop       = return Stop+            single a   = return $ Yield a K.nil+            yieldk a r = return $ Yield a r+         in K.foldStreamShared gst yieldk single stop m1++-- Convert a direct stream to and from CPS encoded stream+{-# INLINE_LATE toStreamK #-}+toStreamK :: Monad m => Stream m a -> K.Stream m a+toStreamK (Stream step state) = go state+    where+    go st = K.mkStream $ \gst yld sng stp -> do+        r <- step gst st+        case r of+            Yield x s -> yld x (go s)+            Skip  s   -> K.foldStreamShared gst yld sng stp $ go s+            Stop      -> stp++#ifndef DISABLE_FUSION+{-# RULES "fromStreamK/toStreamK fusion"+    forall s. toStreamK (fromStreamK s) = s #-}+{-# RULES "toStreamK/fromStreamK fusion"+    forall s. fromStreamK (toStreamK s) = s #-}+#endif++------------------------------------------------------------------------------+-- Converting folds+------------------------------------------------------------------------------++{-# INLINE fromStreamD #-}+fromStreamD :: (K.IsStream t, Monad m) => Stream m a -> t m a+fromStreamD = K.fromStream . toStreamK++------------------------------------------------------------------------------+-- Instances+------------------------------------------------------------------------------++-- | Map a monadic function over a 'Stream'+{-# INLINE_NORMAL mapM #-}+mapM :: Monad m => (a -> m b) -> Stream m a -> Stream m b+mapM f (Stream step state) = Stream step' state+  where+    {-# INLINE_LATE step' #-}+    step' gst st = do+        r <- step (adaptState gst) st+        case r of+            Yield x s -> f x >>= \a -> return $ Yield a s+            Skip s    -> return $ Skip s+            Stop      -> return Stop++{-# INLINE map #-}+map :: Monad m => (a -> b) -> Stream m a -> Stream m b+map f = mapM (return . f)++instance Monad m => Functor (Stream m) where+    {-# INLINE fmap #-}+    fmap = map++------------------------------------------------------------------------------+-- concatMap+------------------------------------------------------------------------------++{-# INLINE_NORMAL concatMapM #-}+concatMapM :: Monad m => (a -> m (Stream m b)) -> Stream m a -> Stream m b+concatMapM f (Stream step state) = Stream step' (Left state)+  where+    {-# INLINE_LATE step' #-}+    step' gst (Left st) = do+        r <- step (adaptState gst) st+        case r of+            Yield a s -> do+                b_stream <- f a+                return $ Skip (Right (b_stream, s))+            Skip s -> return $ Skip (Left s)+            Stop -> return Stop++    -- XXX flattenArrays is 5x faster than "concatMap fromArray". if somehow we+    -- can get inner_step to inline and fuse here we can perhaps get the same+    -- performance using "concatMap fromArray".+    --+    -- XXX using the pattern synonym "Stream" causes a major performance issue+    -- here even if the synonym does not include an adaptState call. Need to+    -- find out why. Is that something to be fixed in GHC?+    step' gst (Right (UnStream inner_step inner_st, st)) = do+        r <- inner_step (adaptState gst) inner_st+        case r of+            Yield b inner_s ->+                return $ Yield b (Right (Stream inner_step inner_s, st))+            Skip inner_s ->+                return $ Skip (Right (Stream inner_step inner_s, st))+            Stop -> return $ Skip (Left st)++{-# INLINE concatMap #-}+concatMap :: Monad m => (a -> Stream m b) -> Stream m a -> Stream m b+concatMap f = concatMapM (return . f)++-- XXX The idea behind this rule is to rewrite any calls to "concatMap+-- fromArray" automatically to flattenArrays which is much faster.  However, we+-- need an INLINE_EARLY on concatMap for this rule to fire. But if we use+-- INLINE_EARLY on concatMap or fromArray then direct uses of+-- "concatMap fromArray" (without the RULE) become much slower, this means+-- "concatMap f" in general would become slower. Need to find a solution to+-- this.+--+-- {-# RULES "concatMap Array.toStreamD"+--      concatMap Array.toStreamD = Array.flattenArray #-}++-- | Create a singleton 'Stream' from a pure value.+{-# INLINE_NORMAL yield #-}+yield :: Monad m => a -> Stream m a+yield x = Stream (\_ s -> return $ step undefined s) True+  where+    {-# INLINE_LATE step #-}+    step _ True  = Yield x False+    step _ False = Stop++instance Monad m => Applicative (Stream m) where+    {-# INLINE pure #-}+    pure = yield+    {-# INLINE (<*>) #-}+    (<*>) = ap++-- 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+    {-# INLINE return #-}+    return = pure+    {-# INLINE (>>=) #-}+    (>>=) = flip concatMap++instance MonadTrans Stream where+    lift = yieldM++instance (MonadThrow m) => MonadThrow (Stream m) where+    throwM = lift . throwM++-- XXX Use of SPEC constructor in folds causes 2x performance degradation in+-- one shot operations, but helps immensely in operations composed of multiple+-- combinators or the same combinator many times. There seems to be an+-- opportunity to optimize here, can we get both, better perf for single ops+-- as well as composed ops? Without SPEC, all single operation benchmarks+-- become 2x faster.++-- The way we want a left fold to be strict, dually we want the right fold to+-- be lazy.  The correct signature of the fold function to keep it lazy must be+-- (a -> m b -> m b) instead of (a -> b -> m b). We were using the latter+-- earlier, which is incorrect. In the latter signature we have to feed the+-- value to the fold function after evaluating the monadic action, depending on+-- the bind behavior of the monad, the action may get evaluated immediately+-- introducing unnecessary strictness to the fold. If the implementation is+-- lazy the following example, must work:+--+-- S.foldrM (\x t -> if x then return t else return False) (return True)+--  (S.fromList [False,undefined] :: SerialT IO Bool)+--+{-# INLINE_NORMAL foldrM #-}+foldrM :: Monad m => (a -> m b -> m b) -> m b -> Stream m a -> m b+foldrM f z (Stream step state) = go SPEC state+  where+    {-# INLINE_LATE go #-}+    go !_ st = do+          r <- step defState st+          case r of+            Yield x s -> f x (go SPEC s)+            Skip s    -> go SPEC s+            Stop      -> z++{-# INLINE_NORMAL foldrMx #-}+foldrMx :: Monad m+    => (a -> m x -> m x) -> m x -> (m x -> m b) -> Stream m a -> m b+foldrMx fstep final convert (Stream step state) = convert $ go SPEC state+  where+    {-# INLINE_LATE go #-}+    go !_ st = do+          r <- step defState st+          case r of+            Yield x s -> fstep x (go SPEC s)+            Skip s    -> go SPEC s+            Stop      -> final++-- Note that foldr works on pure values, therefore it becomes necessarily+-- strict when the monad m is strict. In that case it cannot terminate early,+-- it would evaluate all of its input.  Though, this should work fine with lazy+-- monads. For example, if "any" is implemented using "foldr" instead of+-- "foldrM" it performs the same with Identity monad but performs 1000x slower+-- with IO monad.+--+{-# INLINE_NORMAL foldr #-}+foldr :: Monad m => (a -> b -> b) -> b -> Stream m a -> m b+foldr f z = foldrM (\a b -> liftA2 f (return a) b) (return z)++-- | Create a singleton 'Stream' from a monadic action.+{-# INLINE_NORMAL yieldM #-}+yieldM :: Monad m => m a -> Stream m a+yieldM m = Stream step True+  where+    {-# INLINE_LATE step #-}+    step _ True  = m >>= \x -> return $ Yield x False+    step _ False = return Stop++-- this performs horribly, should not be used+{-# INLINE_NORMAL foldrS #-}+foldrS+    :: Monad m+    => (a -> Stream m b -> Stream m b)+    -> Stream m b+    -> Stream m a+    -> Stream m b+foldrS f final (Stream step state) = go SPEC state+  where+    {-# INLINE_LATE go #-}+    go !_ st = do+        -- defState??+        r <- yieldM $ step defState st+        case r of+          Yield x s -> f x (go SPEC s)+          Skip s    -> go SPEC s+          Stop      -> final++-- Right fold to some transformer (T) monad.  This can be useful to implement+-- stateless combinators like map, filtering, insertions, takeWhile, dropWhile.+--+{-# INLINE_NORMAL foldrT #-}+foldrT :: (Monad m, Monad (t m), MonadTrans t)+    => (a -> t m b -> t m b) -> t m b -> Stream m a -> t m b+foldrT f final (Stream step state) = go SPEC state+  where+    {-# INLINE_LATE go #-}+    go !_ st = do+          r <- lift $ step defState st+          case r of+            Yield x s -> f x (go SPEC s)+            Skip s    -> go SPEC s+            Stop      -> final++{-# INLINE_NORMAL toList #-}+toList :: Monad m => Stream m a -> m [a]+toList = foldr (:) []++-- Use foldr/build fusion to fuse with list consumers+-- This can be useful when using the IsList instance+{-# INLINE_LATE toListFB #-}+toListFB :: (a -> b -> b) -> b -> Stream Identity a -> b+toListFB c n (Stream step state) = go state+  where+    go st = case runIdentity (step defState st) of+             Yield x s -> x `c` go s+             Skip s    -> go s+             Stop      -> n++{-# RULES "toList Identity" toList = toListId #-}+{-# INLINE_EARLY toListId #-}+toListId :: Stream Identity a -> Identity [a]+toListId s = Identity $ build (\c n -> toListFB c n s)++-- XXX run begin action only if the stream is not empty.+{-# INLINE_NORMAL foldlMx' #-}+foldlMx' :: Monad m => (x -> a -> m x) -> m x -> (x -> m b) -> Stream m a -> m b+foldlMx' fstep begin done (Stream step state) =+    begin >>= \x -> go SPEC x state+  where+    -- XXX !acc?+    {-# INLINE_LATE go #-}+    go !_ acc st = acc `seq` do+        r <- step defState st+        case r of+            Yield x s -> do+                acc' <- fstep acc x+                go SPEC acc' s+            Skip s -> go SPEC acc s+            Stop   -> done acc++{-# INLINE foldlx' #-}+foldlx' :: Monad m => (x -> a -> x) -> x -> (x -> b) -> Stream m a -> m b+foldlx' fstep begin done m =+    foldlMx' (\b a -> return (fstep b a)) (return begin) (return . done) m++-- XXX implement in terms of foldlMx'?+{-# INLINE_NORMAL foldlM' #-}+foldlM' :: Monad m => (b -> a -> m b) -> b -> Stream m a -> m b+foldlM' fstep begin (Stream step state) = go SPEC begin state+  where+    {-# INLINE_LATE go #-}+    go !_ acc st = acc `seq` do+        r <- step defState st+        case r of+            Yield x s -> do+                acc' <- fstep acc x+                go SPEC acc' s+            Skip s -> go SPEC acc s+            Stop   -> return acc++{-# INLINE foldl' #-}+foldl' :: Monad m => (b -> a -> b) -> b -> Stream m a -> m b+foldl' fstep = foldlM' (\b a -> return (fstep b a))++-- | Convert a list of pure values to a 'Stream'+{-# INLINE_LATE fromList #-}+fromList :: Monad m => [a] -> Stream m a+fromList = Stream step+  where+    {-# INLINE_LATE step #-}+    step _ (x:xs) = return $ Yield x xs+    step _ []     = return Stop++------------------------------------------------------------------------------+-- Comparisons+------------------------------------------------------------------------------++{-# INLINE_NORMAL eqBy #-}+eqBy :: Monad m => (a -> b -> Bool) -> Stream m a -> Stream m b -> m Bool+eqBy eq (Stream step1 t1) (Stream step2 t2) = eq_loop0 SPEC t1 t2+  where+    eq_loop0 !_ s1 s2 = do+      r <- step1 defState s1+      case r of+        Yield x s1' -> eq_loop1 SPEC x s1' s2+        Skip    s1' -> eq_loop0 SPEC   s1' s2+        Stop        -> eq_null s2++    eq_loop1 !_ x s1 s2 = do+      r <- step2 defState s2+      case r of+        Yield y s2'+          | eq x y    -> eq_loop0 SPEC   s1 s2'+          | otherwise -> return False+        Skip    s2'   -> eq_loop1 SPEC x s1 s2'+        Stop          -> return False++    eq_null s2 = do+      r <- step2 defState s2+      case r of+        Yield _ _ -> return False+        Skip s2'  -> eq_null s2'+        Stop      -> return True++-- | Compare two streams lexicographically+{-# INLINE_NORMAL cmpBy #-}+cmpBy+    :: Monad m+    => (a -> b -> Ordering) -> Stream m a -> Stream m b -> m Ordering+cmpBy cmp (Stream step1 t1) (Stream step2 t2) = cmp_loop0 SPEC t1 t2+  where+    cmp_loop0 !_ s1 s2 = do+      r <- step1 defState s1+      case r of+        Yield x s1' -> cmp_loop1 SPEC x s1' s2+        Skip    s1' -> cmp_loop0 SPEC   s1' s2+        Stop        -> cmp_null s2++    cmp_loop1 !_ x s1 s2 = do+      r <- step2 defState s2+      case r of+        Yield y s2' -> case x `cmp` y of+                         EQ -> cmp_loop0 SPEC s1 s2'+                         c  -> return c+        Skip    s2' -> cmp_loop1 SPEC x s1 s2'+        Stop        -> return GT++    cmp_null s2 = do+      r <- step2 defState s2+      case r of+        Yield _ _ -> return LT+        Skip s2'  -> cmp_null s2'+        Stop      -> return EQ++{-# INLINE_NORMAL take #-}+take :: Monad m => Int -> Stream m a -> Stream m a+take n (Stream step state) = n `seq` Stream step' (state, 0)+  where+    {-# INLINE_LATE step' #-}+    step' gst (st, i) | i < n = do+        r <- step gst st+        return $ case r of+            Yield x s -> Yield x (s, i + 1)+            Skip s    -> Skip (s, i)+            Stop      -> Stop+    step' _ (_, _) = return Stop++------------------------------------------------------------------------------+-- Grouping/Splitting+------------------------------------------------------------------------------++-- s = stream state, fs = fold state+data GroupState s fs+    = GroupStart s+    | GroupBuffer s fs Int+    | GroupYield fs (GroupState s fs)+    | GroupFinish++{-# INLINE_NORMAL groupsOf #-}+groupsOf+    :: Monad m+    => Int+    -> Fold m a b+    -> Stream m a+    -> Stream m b+groupsOf n (Fold fstep initial extract) (Stream step state) =+    n `seq` Stream step' (GroupStart state)++    where++    {-# INLINE_LATE step' #-}+    step' _ (GroupStart st) = do+        -- XXX shall we use the Natural type instead? Need to check performance+        -- implications.+        when (n <= 0) $+            -- XXX we can pass the module string from the higher level API+            error $ "Streamly.Internal.Data.Stream.StreamD.Type.groupsOf: the size of "+                 ++ "groups [" ++ show n ++ "] must be a natural number"+        -- fs = fold state+        fs <- initial+        return $ Skip (GroupBuffer st fs 0)++    step' gst (GroupBuffer st fs i) = do+        r <- step (adaptState gst) st+        case r of+            Yield x s -> do+                fs' <- fstep fs x+                let i' = i + 1+                return $+                    if i' >= n+                    then Skip (GroupYield fs' (GroupStart s))+                    else Skip (GroupBuffer s fs' i')+            Skip s -> return $ Skip (GroupBuffer s fs i)+            Stop -> return $ Skip (GroupYield fs GroupFinish)++    step' _ (GroupYield fs next) = do+        r <- extract fs+        return $ Yield r next++    step' _ GroupFinish = return Stop++{-# INLINE_NORMAL groupsOf2 #-}+groupsOf2+    :: Monad m+    => Int+    -> m c+    -> Fold2 m c a b+    -> Stream m a+    -> Stream m b+groupsOf2 n input (Fold2 fstep inject extract) (Stream step state) =+    n `seq` Stream step' (GroupStart state)++    where++    {-# INLINE_LATE step' #-}+    step' _ (GroupStart st) = do+        -- XXX shall we use the Natural type instead? Need to check performance+        -- implications.+        when (n <= 0) $+            -- XXX we can pass the module string from the higher level API+            error $ "Streamly.Internal.Data.Stream.StreamD.Type.groupsOf: the size of "+                 ++ "groups [" ++ show n ++ "] must be a natural number"+        -- fs = fold state+        fs <- input >>= inject+        return $ Skip (GroupBuffer st fs 0)++    step' gst (GroupBuffer st fs i) = do+        r <- step (adaptState gst) st+        case r of+            Yield x s -> do+                fs' <- fstep fs x+                let i' = i + 1+                return $+                    if i' >= n+                    then Skip (GroupYield fs' (GroupStart s))+                    else Skip (GroupBuffer s fs' i')+            Skip s -> return $ Skip (GroupBuffer s fs i)+            Stop -> return $ Skip (GroupYield fs GroupFinish)++    step' _ (GroupYield fs next) = do+        r <- extract fs+        return $ Yield r next++    step' _ GroupFinish = return Stop
+ src/Streamly/Internal/Data/Strict.hs view
@@ -0,0 +1,61 @@+{-# OPTIONS_HADDOCK hide #-}++-- |+-- Module      : Streamly.Internal.Data.Strict+-- Copyright   : (c) 2019 Composewell Technologies+--               (c) 2013 Gabriel Gonzalez+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+-- | Strict data types to be used as accumulator for strict left folds and+-- scans. For more comprehensive strict data types see+-- https://hackage.haskell.org/package/strict-base-types . The names have been+-- suffixed by a prime so that programmers can easily distinguish the strict+-- versions from the lazy ones.+--+-- One major advantage of strict data structures as accumulators in folds and+-- scans is that it helps the compiler optimize the code much better by+-- unboxing. In a big tight loop the difference could be huge.+--+module Streamly.Internal.Data.Strict+    (+      Tuple' (..)+    , Tuple3' (..)+    , Tuple4' (..)+    , Maybe' (..)+    , fromStrictMaybe+    , Either' (..)+    )+where++-------------------------------------------------------------------------------+-- Tuples+-------------------------------------------------------------------------------+--+data Tuple' a b = Tuple' !a !b deriving Show+data Tuple3' a b c = Tuple3' !a !b !c deriving Show+data Tuple4' a b c d = Tuple4' !a !b !c !d deriving Show++-------------------------------------------------------------------------------+-- Maybe+-------------------------------------------------------------------------------+--+-- | A strict 'Maybe'+data Maybe' a = Just' !a | Nothing' deriving Show++-- 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++-------------------------------------------------------------------------------+-- Either+-------------------------------------------------------------------------------+--+-- | A strict 'Either'+data Either' a b = Left' !a | Right' !b deriving Show
+ src/Streamly/Internal/Data/Time.hs view
@@ -0,0 +1,76 @@+{-# OPTIONS_HADDOCK hide #-}++-- |+-- Module      : Streamly.Internal.Data.Time+-- Copyright   : (c) 2017 Harendra Kumar+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+-- Time utilities for reactive programming.++module Streamly.Internal.Data.Time+{-# DEPRECATED+   "Please use the \"rate\" combinator instead of the functions in this module"+  #-}+    ( periodic+    , withClock+    )+where++import Control.Monad (when)+import Control.Concurrent (threadDelay)++-- | Run an action forever periodically at the given frequency specified in per+-- second (Hz).+--+-- @since 0.1.0+{-# DEPRECATED periodic "Please use the \"rate\" combinator instead" #-}+periodic :: Int -> IO () -> IO ()+periodic freq action = do+    action+    threadDelay (1000000 `div` freq)+    periodic freq action++-- | Run a computation on every clock tick, the clock runs at the specified+-- frequency. It allows running a computation at high frequency efficiently by+-- maintaining a local clock and adjusting it with the provided base clock at+-- longer intervals.  The first argument is a base clock returning some notion+-- of time in microseconds. The second argument is the frequency in per second+-- (Hz). The third argument is the action to run, the action is provided the+-- local time as an argument.+--+-- @since 0.1.0+{-# DEPRECATED withClock "Please use the \"rate\" combinator instead" #-}+withClock :: IO Int -> Int -> (Int -> IO ()) -> IO ()+withClock clock freq action = do+    t <- clock+    go t period period t 0++    where++    period = 1000000 `div` freq++    -- Note that localTime is roughly but not exactly equal to (lastAdj + tick+    -- * n).  That is because we do not abruptly adjust the clock skew instead+    -- we adjust the tick size.+    go lastAdj delay tick localTime n = do+        action localTime+        when (delay > 0) $ threadDelay delay++        if n == freq+        then do+            (t, newTick, newDelay) <- adjustClock lastAdj localTime delay+            go t newDelay newTick (localTime + newTick) 0+        else go lastAdj delay tick (localTime + tick) (n + 1)++    -- Adjust the tick size rather than the clock to avoid abrupt changes+    -- resulting in jittery behavior at the end of every interval.+    adjustClock lastAdj localTime delay = do+        baseTime <- clock+        let newTick    = period + (baseTime - localTime) `div` freq+            lastPeriod = (baseTime - lastAdj) `div` freq+            newDelay   = max 0 (delay + period - lastPeriod)+        return (baseTime, newTick, newDelay)
+ src/Streamly/Internal/Data/Time/Clock.hsc view
@@ -0,0 +1,310 @@+{-# OPTIONS_HADDOCK hide                 #-}+{-# LANGUAGE CPP                         #-}+{-# LANGUAGE DeriveGeneric               #-}+{-# LANGUAGE GeneralizedNewtypeDeriving  #-}+{-# LANGUAGE ScopedTypeVariables         #-}++#if __GLASGOW_HASKELL__ >= 800+{-# OPTIONS_GHC -Wno-identities          #-}+{-# OPTIONS_GHC -Wno-orphans             #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+#endif++#ifndef __GHCJS__+#include "config.h"+#endif++-- |+-- Module      : Streamly.Internal.Data.Time.Clock+-- Copyright   : (c) 2019 Harendra Kumar+--               (c) 2009-2012, Cetin Sert+--               (c) 2010, Eugene Kirpichov+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++-- A majority of the code below has been stolen from the "clock" package.++#if __GHCJS__+#define HS_CLOCK_GHCJS 1+#elif (defined (HAVE_TIME_H) && defined(HAVE_CLOCK_GETTIME))+#define HS_CLOCK_POSIX 1+#elif __APPLE__+#define HS_CLOCK_OSX 1+#elif defined(_WIN32)+#define HS_CLOCK_WINDOWS 1+#else+#error "Time/Clock functionality not implemented for this system"+#endif++module Streamly.Internal.Data.Time.Clock+    (+    -- * get time from the system clock+      Clock(..)+    , getTime+    )+where++import Data.Int (Int32, Int64)+import Data.Typeable (Typeable)+import Data.Word (Word32)+import Foreign.C (CInt(..), throwErrnoIfMinus1_, CTime(..), CLong(..))+import Foreign.Marshal.Alloc (alloca)+import Foreign.Ptr (Ptr)+import Foreign.Storable (Storable(..), peek)+import GHC.Generics (Generic)++import Streamly.Internal.Data.Time.Units (TimeSpec(..), AbsTime(..))++-------------------------------------------------------------------------------+-- Clock Types+-------------------------------------------------------------------------------++#if HS_CLOCK_POSIX+#include <time.h>++#if defined(CLOCK_MONOTONIC_RAW)+#define HAVE_CLOCK_MONOTONIC_RAW+#endif++-- XXX this may be RAW on apple not RAW on linux+#if __linux__ && defined(CLOCK_MONOTONIC_COARSE)+#define HAVE_CLOCK_MONOTONIC_COARSE+#endif++#if __APPLE__ && defined(CLOCK_MONOTONIC_RAW_APPROX)+#define HAVE_CLOCK_MONOTONIC_COARSE+#endif++#if __linux__ && defined(CLOCK_BOOTTIME)+#define HAVE_CLOCK_MONOTONIC_UPTIME+#endif++#if __APPLE__ && defined(CLOCK_UPTIME_RAW)+#define HAVE_CLOCK_MONOTONIC_UPTIME+#endif++#if __linux__ && defined(CLOCK_REALTIME_COARSE)+#define HAVE_CLOCK_REALTIME_COARSE+#endif++#endif++-- | Clock types. A clock may be system-wide (that is, visible to all processes)+--   or per-process (measuring time that is meaningful only within a process).+--   All implementations shall support CLOCK_REALTIME. (The only suspend-aware+--   monotonic is CLOCK_BOOTTIME on Linux.)+data Clock++    -- | The identifier for the system-wide monotonic clock, which is defined as+    --   a clock measuring real time, whose value cannot be set via+    --   @clock_settime@ and which cannot have negative clock jumps. The maximum+    --   possible clock jump shall be implementation defined. For this clock,+    --   the value returned by 'getTime' represents the amount of time (in+    --   seconds and nanoseconds) since an unspecified point in the past (for+    --   example, system start-up time, or the Epoch). This point does not+    --   change after system start-up time. Note that the absolute value of the+    --   monotonic clock is meaningless (because its origin is arbitrary), and+    --   thus there is no need to set it. Furthermore, realtime applications can+    --   rely on the fact that the value of this clock is never set.+  = Monotonic++    -- | The identifier of the system-wide clock measuring real time. For this+    --   clock, the value returned by 'getTime' represents the amount of time (in+    --   seconds and nanoseconds) since the Epoch.+  | Realtime++#ifndef HS_CLOCK_GHCJS+    -- | The identifier of the CPU-time clock associated with the calling+    --   process. For this clock, the value returned by 'getTime' represents the+    --   amount of execution time of the current process.+  | ProcessCPUTime++    -- | The identifier of the CPU-time clock associated with the calling OS+    --   thread. For this clock, the value returned by 'getTime' represents the+    --   amount of execution time of the current OS thread.+  | ThreadCPUTime+#endif++#if defined (HAVE_CLOCK_MONOTONIC_RAW)+    -- | (since Linux 2.6.28; Linux and Mac OSX)+    --   Similar to CLOCK_MONOTONIC, but provides access to a+    --   raw hardware-based time that is not subject to NTP+    --   adjustments or the incremental adjustments performed by+    --   adjtime(3).+  | MonotonicRaw+#endif++#if defined (HAVE_CLOCK_MONOTONIC_COARSE)+    -- | (since Linux 2.6.32; Linux and Mac OSX)+    --   A faster but less precise version of CLOCK_MONOTONIC.+    --   Use when you need very fast, but not fine-grained timestamps.+  | MonotonicCoarse+#endif++#if defined (HAVE_CLOCK_MONOTONIC_UPTIME)+    -- | (since Linux 2.6.39; Linux and Mac OSX)+    --   Identical to CLOCK_MONOTONIC, except it also includes+    --   any time that the system is suspended.  This allows+    --   applications to get a suspend-aware monotonic clock+    --   without having to deal with the complications of+    --   CLOCK_REALTIME, which may have discontinuities if the+    --   time is changed using settimeofday(2).+  | Uptime+#endif++#if defined (HAVE_CLOCK_REALTIME_COARSE)+    -- | (since Linux 2.6.32; Linux-specific)+    --   A faster but less precise version of CLOCK_REALTIME.+    --   Use when you need very fast, but not fine-grained timestamps.+  | RealtimeCoarse+#endif++  deriving (Eq, Enum, Generic, Read, Show, Typeable)++-------------------------------------------------------------------------------+-- Translate the Haskell "Clock" type to C+-------------------------------------------------------------------------------++#if HS_CLOCK_POSIX+-- Posix systems (Linux and Mac OSX 10.12 and later)+clockToPosixClockId :: Clock -> #{type clockid_t}+clockToPosixClockId Monotonic      = #const CLOCK_MONOTONIC+clockToPosixClockId Realtime       = #const CLOCK_REALTIME+clockToPosixClockId ProcessCPUTime = #const CLOCK_PROCESS_CPUTIME_ID+clockToPosixClockId ThreadCPUTime  = #const CLOCK_THREAD_CPUTIME_ID++#if defined(CLOCK_MONOTONIC_RAW)+clockToPosixClockId MonotonicRaw = #const CLOCK_MONOTONIC_RAW+#endif++#if __linux__ && defined (CLOCK_MONOTONIC_COARSE)+clockToPosixClockId MonotonicCoarse = #const CLOCK_MONOTONIC_COARSE+#elif __APPLE__ && defined(CLOCK_MONOTONIC_RAW_APPROX)+clockToPosixClockId MonotonicCoarse = #const CLOCK_MONOTONIC_RAW_APPROX+#endif++#if __linux__ && defined (CLOCK_REALTIME_COARSE)+clockToPosixClockId RealtimeCoarse = #const CLOCK_REALTIME_COARSE+#endif++#if __linux__ && defined(CLOCK_BOOTTIME)+clockToPosixClockId Uptime = #const CLOCK_BOOTTIME+#elif __APPLE__ && defined(CLOCK_UPTIME_RAW)+clockToPosixClockId Uptime = #const CLOCK_UPTIME_RAW+#endif++#elif HS_CLOCK_OSX+-- Mac OSX versions prior to 10.12+#include <time.h>+#include <mach/clock.h>++clockToOSXClockId :: Clock -> #{type clock_id_t}+clockToOSXClockId Monotonic      = #const SYSTEM_CLOCK+clockToOSXClockId Realtime       = #const CALENDAR_CLOCK+clockToOSXClockId ProcessCPUTime = #const SYSTEM_CLOCK+clockToOSXClockId ThreadCPUTime  = #const SYSTEM_CLOCK+#elif HS_CLOCK_GHCJS+-- XXX need to implement a monotonic clock for JS using performance.now()+clockToJSClockId :: Clock -> CInt+clockToJSClockId Monotonic      = 0+clockToJSClockId Realtime       = 0+#endif++-------------------------------------------------------------------------------+-- Clock time+-------------------------------------------------------------------------------++#if __GLASGOW_HASKELL__ < 800+#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)+#endif++#ifdef HS_CLOCK_GHCJS+instance Storable TimeSpec where+  sizeOf _ = 8+  alignment _ = 4+  peek p = do+    CTime  s <- peekByteOff p 0+    CLong ns <- peekByteOff p 4+    return (TimeSpec (fromIntegral s) (fromIntegral ns))+  poke p (TimeSpec s ns) = do+    pokeByteOff p 0 ((fromIntegral s) :: CTime)+    pokeByteOff p 4 ((fromIntegral ns) :: CLong)++#elif HS_CLOCK_WINDOWS+instance Storable TimeSpec where+  sizeOf _ = sizeOf (undefined :: Int64) * 2+  alignment _ = alignment (undefined :: Int64)+  peek ptr = do+    s <- peekByteOff ptr 0+    ns <- peekByteOff ptr (sizeOf (undefined :: Int64))+    return (TimeSpec s ns)+  poke ptr ts = do+      pokeByteOff ptr 0 (sec ts)+      pokeByteOff ptr (sizeOf (undefined :: Int64)) (nsec ts)+#else+instance Storable TimeSpec where+  sizeOf _ = #{size struct timespec}+  alignment _ = #{alignment struct timespec}+  peek ptr = do+      s :: #{type time_t} <- #{peek struct timespec, tv_sec} ptr+      ns :: #{type long} <- #{peek struct timespec, tv_nsec} ptr+      return $ TimeSpec (fromIntegral s) (fromIntegral ns)+  poke ptr ts = do+      let s :: #{type time_t} = fromIntegral $ sec ts+          ns :: #{type long} = fromIntegral $ nsec ts+      #{poke struct timespec, tv_sec} ptr (s)+      #{poke struct timespec, tv_nsec} ptr (ns)+#endif++{-# INLINE getTimeWith #-}+getTimeWith :: (Ptr TimeSpec -> IO ()) -> IO AbsTime+getTimeWith f = do+    t <- alloca (\ptr -> f ptr >> peek ptr)+    return $ AbsTime t++#if HS_CLOCK_GHCJS++foreign import ccall unsafe "time.h clock_gettime_js"+    clock_gettime_js :: CInt -> Ptr TimeSpec -> IO CInt++{-# INLINABLE getTime #-}+getTime :: Clock -> IO AbsTime+getTime clock =+    getTimeWith (throwErrnoIfMinus1_ "clock_gettime" .+        clock_gettime_js (clockToJSClockId clock))++#elif HS_CLOCK_POSIX++foreign import ccall unsafe "time.h clock_gettime"+    clock_gettime :: #{type clockid_t} -> Ptr TimeSpec -> IO CInt++{-# INLINABLE getTime #-}+getTime :: Clock -> IO AbsTime+getTime clock =+    getTimeWith (throwErrnoIfMinus1_ "clock_gettime" .+        clock_gettime (clockToPosixClockId clock))++#elif HS_CLOCK_OSX++-- XXX perform error checks inside c implementation+foreign import ccall+    clock_gettime_darwin :: #{type clock_id_t} -> Ptr TimeSpec -> IO ()++{-# INLINABLE getTime #-}+getTime :: Clock -> IO AbsTime+getTime clock = getTimeWith $ clock_gettime_darwin (clockToOSXClockId clock)++#elif HS_CLOCK_WINDOWS++-- XXX perform error checks inside c implementation+foreign import ccall clock_gettime_win32_monotonic :: Ptr TimeSpec -> IO ()++{-# INLINABLE getTime #-}+getTime :: Clock -> IO AbsTime+getTime Monotonic = getTimeWith $ clock_gettime_win32_monotonic+getTime RealTime = getTimeWith $ clock_gettime_win32_realtime+getTime ProcessCPUTime = getTimeWith $ clock_gettime_win32_processtime+getTime ThreadCPUTime = getTimeWith $ clock_gettime_win32_threadtime+#endif
+ src/Streamly/Internal/Data/Time/Darwin.c view
@@ -0,0 +1,36 @@+/*+ * Code taken from the Haskell "clock" package.+ *+ * Copyright (c) 2009-2012, Cetin Sert+ * Copyright (c) 2010, Eugene Kirpichov+ *+ * OS X code was contributed by Gerolf Seitz on 2013-10-15.+ */++#ifdef __MACH__+#include <time.h>+#include <mach/clock.h>+#include <mach/mach.h>++void clock_gettime_darwin(clock_id_t clock, struct timespec *ts)+{+    clock_serv_t cclock;+    mach_timespec_t mts;+    host_get_clock_service(mach_host_self(), clock, &cclock);+    clock_get_time(cclock, &mts);+    mach_port_deallocate(mach_task_self(), cclock);+    ts->tv_sec = mts.tv_sec;+    ts->tv_nsec = mts.tv_nsec;+}++void clock_getres_darwin(clock_id_t clock, struct timespec *ts)+{+    clock_serv_t cclock;+    int nsecs;+    mach_msg_type_number_t count;+    host_get_clock_service(mach_host_self(), clock, &cclock);+    clock_get_attributes(cclock, CLOCK_GET_TIME_RES, (clock_attr_t)&nsecs, &count);+    mach_port_deallocate(mach_task_self(), cclock);+}++#endif  /* __MACH__ */
+ src/Streamly/Internal/Data/Time/Units.hs view
@@ -0,0 +1,472 @@+{-# OPTIONS_HADDOCK hide                #-}+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables        #-}++#include "inline.hs"++-- |+-- Module      : Streamly.Internal.Data.Time.Units+-- Copyright   : (c) 2019 Harendra Kumar+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++module Streamly.Internal.Data.Time.Units+    (+    -- * Time Unit Conversions+      TimeUnit()+    -- , TimeUnitWide()+    , TimeUnit64()++    -- * Time Units+    , TimeSpec(..)+    , NanoSecond64(..)+    , MicroSecond64(..)+    , MilliSecond64(..)+    , showNanoSecond64++    -- * Absolute times (using TimeSpec)+    , AbsTime(..)+    , toAbsTime+    , fromAbsTime++    -- * Relative times (using TimeSpec)+    , RelTime+    , toRelTime+    , fromRelTime+    , diffAbsTime+    , addToAbsTime++    -- * Relative times (using NanoSecond64)+    , RelTime64+    , toRelTime64+    , fromRelTime64+    , diffAbsTime64+    , addToAbsTime64+    , showRelTime64+    )+where++import Data.Int+import Text.Printf (printf)++-------------------------------------------------------------------------------+-- Some constants+-------------------------------------------------------------------------------++{-# INLINE tenPower3 #-}+tenPower3 :: Int64+tenPower3 = 1000++{-# INLINE tenPower6 #-}+tenPower6 :: Int64+tenPower6 = 1000000++{-# INLINE tenPower9 #-}+tenPower9 :: Int64+tenPower9 = 1000000000++-------------------------------------------------------------------------------+-- Time Unit Representations+-------------------------------------------------------------------------------++-- XXX We should be able to use type families to use different represenations+-- for a unit.+--+-- Second Rational+-- Second Double+-- Second Int64+-- Second Integer+-- NanoSecond Int64+-- ...++-- Double or Fixed would be a much better representation so that we do not lose+-- information between conversions. However, for faster arithmetic operations+-- we use an 'Int64' here. When we need convservation of values we can use a+-- different system of units with a Fixed precision.++-------------------------------------------------------------------------------+-- Integral Units+-------------------------------------------------------------------------------++-- | An 'Int64' time representation with a nanosecond resolution. It can+-- represent time up to ~292 years.+newtype NanoSecond64 = NanoSecond64 Int64+    deriving ( Eq+             , Read+             , Show+             , Enum+             , Bounded+             , Num+             , Real+             , Integral+             , Ord+             )++-- | An 'Int64' time representation with a microsecond resolution.+-- It can represent time up to ~292,000 years.+newtype MicroSecond64 = MicroSecond64 Int64+    deriving ( Eq+             , Read+             , Show+             , Enum+             , Bounded+             , Num+             , Real+             , Integral+             , Ord+             )++-- | An 'Int64' time representation with a millisecond resolution.+-- It can represent time up to ~292 million years.+newtype MilliSecond64 = MilliSecond64 Int64+    deriving ( Eq+             , Read+             , Show+             , Enum+             , Bounded+             , Num+             , Real+             , Integral+             , Ord+             )++-------------------------------------------------------------------------------+-- Fractional Units+-------------------------------------------------------------------------------++-------------------------------------------------------------------------------+-- TimeSpec representation+-------------------------------------------------------------------------------++-- A structure storing seconds and nanoseconds as 'Int64' is the simplest and+-- fastest way to store practically large quantities of time with efficient+-- arithmetic operations. If we store nanoseconds using 'Integer' it can store+-- practically unbounded quantities but it may not be as efficient to+-- manipulate in performance critical applications. XXX need to measure the+-- performance.+--+-- | Data type to represent practically large quantities of time efficiently.+-- It can represent time up to ~292 billion years at nanosecond resolution.+data TimeSpec = TimeSpec+  { sec  :: {-# UNPACK #-} !Int64 -- ^ seconds+  , nsec :: {-# UNPACK #-} !Int64 -- ^ nanoseconds+  } deriving (Eq, Read, Show)++-- We assume that nsec is always less than 10^9. When TimeSpec is negative then+-- both sec and nsec are negative.+instance Ord TimeSpec where+    compare (TimeSpec s1 ns1) (TimeSpec s2 ns2) =+        if s1 == s2+        then compare ns1 ns2+        else compare s1 s2++-- make sure nsec is less than 10^9+{-# INLINE addWithOverflow #-}+addWithOverflow :: TimeSpec -> TimeSpec -> TimeSpec+addWithOverflow (TimeSpec s1 ns1) (TimeSpec s2 ns2) =+    let nsum = ns1 + ns2+        (s', ns) = if (nsum > tenPower9 || nsum < negate tenPower9)+                    then nsum `divMod` tenPower9+                    else (0, nsum)+    in TimeSpec (s1 + s2 + s') ns++-- make sure both sec and nsec have the same sign+{-# INLINE adjustSign #-}+adjustSign :: TimeSpec -> TimeSpec+adjustSign (t@(TimeSpec s ns)) =+    if (s > 0 && ns < 0)+    then TimeSpec (s - 1) (ns + tenPower9)+    else if (s < 0 && ns > 0)+    then TimeSpec (s + 1) (ns - tenPower9)+    else t++{-# INLINE timeSpecToInteger #-}+timeSpecToInteger :: TimeSpec -> Integer+timeSpecToInteger (TimeSpec s ns) = toInteger $ s * tenPower9 + ns++instance Num TimeSpec where+    {-# INLINE (+) #-}+    t1 + t2 = adjustSign (addWithOverflow t1 t2)++    -- XXX will this be more optimal if imlemented without "negate"?+    {-# INLINE (-) #-}+    t1 - t2 = t1 + (negate t2)+    t1 * t2 = fromInteger $ timeSpecToInteger t1 * timeSpecToInteger t2++    {-# INLINE negate #-}+    negate (TimeSpec s ns) = TimeSpec (negate s) (negate ns)+    {-# INLINE abs #-}+    abs    (TimeSpec s ns) = TimeSpec (abs s) (abs ns)+    {-# INLINE signum #-}+    signum (TimeSpec s ns) | s == 0    = TimeSpec (signum ns) 0+                           | otherwise = TimeSpec (signum s) 0+    -- This is fromNanoSecond64 Integer+    {-# INLINE fromInteger #-}+    fromInteger nanosec = TimeSpec (fromInteger s) (fromInteger ns)+        where (s, ns) = nanosec `divMod` toInteger tenPower9++-------------------------------------------------------------------------------+-- Time unit conversions+-------------------------------------------------------------------------------++-- TODO: compare whether using TimeSpec instead of Integer provides significant+-- performance boost. If not then we can just use Integer nanoseconds and get+-- rid of TimeUnitWide.+--+-- | A type class for converting between time units using 'Integer' as the+-- intermediate and the widest representation with a nanosecond resolution.+-- This system of units can represent arbitrarily large times but provides+-- least efficient arithmetic operations due to 'Integer' arithmetic.+--+-- NOTE: Converting to and from units may truncate the value depending on the+-- original value and the size and resolution of the destination unit.+{-+class TimeUnitWide a where+    toTimeInteger   :: a -> Integer+    fromTimeInteger :: Integer -> a+-}++-- | A type class for converting between units of time using 'TimeSpec' as the+-- intermediate representation.  This system of units can represent up to ~292+-- billion years at nanosecond resolution with reasonably efficient arithmetic+-- operations.+--+-- NOTE: Converting to and from units may truncate the value depending on the+-- original value and the size and resolution of the destination unit.+class TimeUnit a where+    toTimeSpec   :: a -> TimeSpec+    fromTimeSpec :: TimeSpec -> a++-- XXX we can use a fromNanoSecond64 for conversion with overflow check and+-- fromNanoSecond64Unsafe for conversion without overflow check.+--+-- | A type class for converting between units of time using 'Int64' as the+-- intermediate representation with a nanosecond resolution.  This system of+-- units can represent up to ~292 years at nanosecond resolution with fast+-- arithmetic operations.+--+-- NOTE: Converting to and from units may truncate the value depending on the+-- original value and the size and resolution of the destination unit.+class TimeUnit64 a where+    toNanoSecond64   :: a -> NanoSecond64+    fromNanoSecond64 :: NanoSecond64 -> a++-------------------------------------------------------------------------------+-- Time units+-------------------------------------------------------------------------------++instance TimeUnit TimeSpec where+    toTimeSpec = id+    fromTimeSpec = id++instance TimeUnit NanoSecond64 where+    {-# INLINE toTimeSpec #-}+    toTimeSpec (NanoSecond64 t) = TimeSpec s ns+        where (s, ns) = t `divMod` tenPower9++    {-# INLINE fromTimeSpec #-}+    fromTimeSpec (TimeSpec s ns) =+        NanoSecond64 $ s * tenPower9 + ns++instance TimeUnit64 NanoSecond64 where+    {-# INLINE toNanoSecond64 #-}+    toNanoSecond64 = id++    {-# INLINE fromNanoSecond64 #-}+    fromNanoSecond64 = id++instance TimeUnit MicroSecond64 where+    {-# INLINE toTimeSpec #-}+    toTimeSpec (MicroSecond64 t) = TimeSpec s us+        where (s, us) = t `divMod` tenPower6++    {-# INLINE fromTimeSpec #-}+    fromTimeSpec (TimeSpec s us) =+        MicroSecond64 $ s * tenPower6 + us++instance TimeUnit64 MicroSecond64 where+    {-# INLINE toNanoSecond64 #-}+    toNanoSecond64 (MicroSecond64 us) = NanoSecond64 $ us * tenPower3++    {-# INLINE fromNanoSecond64 #-}+    fromNanoSecond64 (NanoSecond64 ns) = MicroSecond64 $ ns `div` tenPower3++instance TimeUnit MilliSecond64 where+    {-# INLINE toTimeSpec #-}+    toTimeSpec (MilliSecond64 t) = TimeSpec s us+        where (s, us) = t `divMod` tenPower3++    {-# INLINE fromTimeSpec #-}+    fromTimeSpec (TimeSpec s us) =+        MilliSecond64 $ s * tenPower3 + us++instance TimeUnit64 MilliSecond64 where+    {-# INLINE toNanoSecond64 #-}+    toNanoSecond64 (MilliSecond64 us) = NanoSecond64 $ us * tenPower6++    {-# INLINE fromNanoSecond64 #-}+    fromNanoSecond64 (NanoSecond64 ns) = MilliSecond64 $ ns `div` tenPower6++-------------------------------------------------------------------------------+-- Absolute time+-------------------------------------------------------------------------------++-- | Absolute times are relative to a predefined epoch in time. 'AbsTime'+-- represents times using 'TimeSpec' which can represent times up to ~292+-- billion years at a nanosecond resolution.+newtype AbsTime = AbsTime TimeSpec+    deriving (Eq, Ord, Show)++-- | Convert a 'TimeUnit' to an absolute time.+{-# INLINE_NORMAL toAbsTime #-}+toAbsTime :: TimeUnit a => a -> AbsTime+toAbsTime = AbsTime . toTimeSpec++-- | Convert absolute time to a 'TimeUnit'.+{-# INLINE_NORMAL fromAbsTime #-}+fromAbsTime :: TimeUnit a => AbsTime -> a+fromAbsTime (AbsTime t) = fromTimeSpec t++-- XXX We can also write rewrite rules to simplify divisions multiplications+-- and additions when manipulating units. Though, that might get simplified at+-- the assembly (llvm) level as well. Note to/from conversions may be lossy and+-- therefore this equation may not hold, but that's ok.+{-# RULES "fromAbsTime/toAbsTime" forall a. toAbsTime (fromAbsTime a) = a #-}+{-# RULES "toAbsTime/fromAbsTime" forall a. fromAbsTime (toAbsTime a) = a #-}++-------------------------------------------------------------------------------+-- Relative time using NaonoSecond64 as the underlying representation+-------------------------------------------------------------------------------++-- We use a separate type to represent relative time for safety and speed.+-- RelTime has a Num instance, absolute time doesn't.  Relative times are+-- usually shorter and for our purposes an Int64 nanoseconds can hold close to+-- thousand year duration. It is also faster to manipulate. We do not check for+-- overflows during manipulations so use it only when you know the time cannot+-- be too big. If you need a bigger RelTime representation then use RelTimeBig.++-- | Relative times are relative to some arbitrary point of time. Unlike+-- 'AbsTime' they are not relative to a predefined epoch.+newtype RelTime64 = RelTime64 NanoSecond64+    deriving ( Eq+             , Read+             , Show+             , Enum+             , Bounded+             , Num+             , Real+             , Integral+             , Ord+             )++-- | Convert a 'TimeUnit' to a relative time.+{-# INLINE_NORMAL toRelTime64 #-}+toRelTime64 :: TimeUnit64 a => a -> RelTime64+toRelTime64 = RelTime64 . toNanoSecond64++-- | Convert relative time to a 'TimeUnit'.+{-# INLINE_NORMAL fromRelTime64 #-}+fromRelTime64 :: TimeUnit64 a => RelTime64 -> a+fromRelTime64 (RelTime64 t) = fromNanoSecond64 t++{-# RULES "fromRelTime64/toRelTime64" forall a .+          toRelTime64 (fromRelTime64 a) = a #-}++{-# RULES "toRelTime64/fromRelTime64" forall a .+          fromRelTime64 (toRelTime64 a) = a #-}++-- | Difference between two absolute points of time.+{-# INLINE diffAbsTime64 #-}+diffAbsTime64 :: AbsTime -> AbsTime -> RelTime64+diffAbsTime64 (AbsTime (TimeSpec s1 ns1)) (AbsTime (TimeSpec s2 ns2)) =+    RelTime64 $ NanoSecond64 $ ((s1 - s2) * tenPower9) + (ns1 - ns2)++{-# INLINE addToAbsTime64 #-}+addToAbsTime64 :: AbsTime -> RelTime64 -> AbsTime+addToAbsTime64 (AbsTime (TimeSpec s1 ns1)) (RelTime64 (NanoSecond64 ns2)) =+    AbsTime $ TimeSpec (s1 + s) ns+    where (s, ns) = (ns1 + ns2) `divMod` tenPower9++-------------------------------------------------------------------------------+-- Relative time using TimeSpec as the underlying representation+-------------------------------------------------------------------------------++newtype RelTime = RelTime TimeSpec+    deriving ( Eq+             , Read+             , Show+             -- , Enum+             -- , Bounded+             , Num+             -- , Real+             -- , Integral+             , Ord+             )++{-# INLINE_NORMAL toRelTime #-}+toRelTime :: TimeUnit a => a -> RelTime+toRelTime = RelTime . toTimeSpec++{-# INLINE_NORMAL fromRelTime #-}+fromRelTime :: TimeUnit a => RelTime -> a+fromRelTime (RelTime t) = fromTimeSpec t++{-# RULES "fromRelTime/toRelTime" forall a. toRelTime (fromRelTime a) = a #-}+{-# RULES "toRelTime/fromRelTime" forall a. fromRelTime (toRelTime a) = a #-}++-- XXX rename to diffAbsTimes?+{-# INLINE diffAbsTime #-}+diffAbsTime :: AbsTime -> AbsTime -> RelTime+diffAbsTime (AbsTime t1) (AbsTime t2) = RelTime (t1 - t2)++{-# INLINE addToAbsTime #-}+addToAbsTime :: AbsTime -> RelTime -> AbsTime+addToAbsTime (AbsTime t1) (RelTime t2) = AbsTime $ t1 + t2++-------------------------------------------------------------------------------+-- Formatting and printing+-------------------------------------------------------------------------------++-- | Convert nanoseconds to a string showing time in an appropriate unit.+showNanoSecond64 :: NanoSecond64 -> String+showNanoSecond64 time@(NanoSecond64 ns)+    | time < 0    = '-' : showNanoSecond64 (-time)+    | ns < 1000 = fromIntegral ns `with` "ns"+#ifdef mingw32_HOST_OS+    | ns < 1000000 = (fromIntegral ns / 1000) `with` "us"+#else+    | ns < 1000000 = (fromIntegral ns / 1000) `with` "μs"+#endif+    | ns < 1000000000 = (fromIntegral ns / 1000000) `with` "ms"+    | ns < (60 * 1000000000) = (fromIntegral ns / 1000000000) `with` "s"+    | ns < (60 * 60 * 1000000000) =+        (fromIntegral ns / (60 * 1000000000)) `with` "min"+    | ns < (24 * 60 * 60 * 1000000000) =+        (fromIntegral ns / (60 * 60 * 1000000000)) `with` "hr"+    | ns < (365 * 24 * 60 * 60 * 1000000000) =+        (fromIntegral ns / (24 * 60 * 60 * 1000000000)) `with` "days"+    | otherwise =+        (fromIntegral ns / (365 * 24 * 60 * 60 * 1000000000)) `with` "years"+     where with (t :: Double) (u :: String)+               | t >= 1e9  = printf "%.4g %s" t u+               | t >= 1e3  = printf "%.0f %s" t u+               | t >= 1e2  = printf "%.1f %s" t u+               | t >= 1e1  = printf "%.2f %s" t u+               | otherwise = printf "%.3f %s" t u++-- In general we should be able to show the time in a specified unit, if we+-- omit the unit we can show it in an automatically chosen one.+{-+data UnitName =+      Nano+    | Micro+    | Milli+    | Sec+-}++showRelTime64 :: RelTime64 -> String+showRelTime64 = showNanoSecond64 . fromRelTime64
+ src/Streamly/Internal/Data/Time/Windows.c view
@@ -0,0 +1,115 @@+/*+ * Code taken from the Haskell "clock" package.+ *+ * Copyright (c) 2009-2012, Cetin Sert+ * Copyright (c) 2010, Eugene Kirpichov+ */++#ifdef _WIN32+#include <windows.h>++#if defined(_MSC_VER) || defined(_MSC_EXTENSIONS)+  #define U64(x) x##Ui64+#else+  #define U64(x) x##ULL+#endif++#define DELTA_EPOCH_IN_100NS  U64(116444736000000000)++static long ticks_to_nanos(LONGLONG subsecond_time, LONGLONG frequency)+{+    return (long)((1e9 * subsecond_time) / frequency);+}++static ULONGLONG to_quad_100ns(FILETIME ft)+{+    ULARGE_INTEGER li;+    li.LowPart = ft.dwLowDateTime;+    li.HighPart = ft.dwHighDateTime;+    return li.QuadPart;+}++static void to_timespec_from_100ns(ULONGLONG t_100ns, long long *t)+{+    t[0] = (long)(t_100ns / 10000000UL);+    t[1] = 100*(long)(t_100ns % 10000000UL);+}++void clock_gettime_win32_monotonic(long long* t)+{+   LARGE_INTEGER time;+   LARGE_INTEGER frequency;+   QueryPerformanceCounter(&time);+   QueryPerformanceFrequency(&frequency);+   // seconds+   t[0] = time.QuadPart / frequency.QuadPart;+   // nanos =+   t[1] = ticks_to_nanos(time.QuadPart % frequency.QuadPart, frequency.QuadPart);+}++void clock_gettime_win32_realtime(long long* t)+{+    FILETIME ft;+    ULONGLONG tmp;++    GetSystemTimeAsFileTime(&ft);++    tmp = to_quad_100ns(ft);+    tmp -= DELTA_EPOCH_IN_100NS;++    to_timespec_from_100ns(tmp, t);+}++void clock_gettime_win32_processtime(long long* t)+{+    FILETIME creation_time, exit_time, kernel_time, user_time;+    ULONGLONG time;++    GetProcessTimes(GetCurrentProcess(), &creation_time, &exit_time, &kernel_time, &user_time);+    // Both kernel and user, acc. to http://www.opengroup.org/onlinepubs/009695399/basedefs/xbd_chap03.html#tag_03_117++    time = to_quad_100ns(user_time) + to_quad_100ns(kernel_time);+    to_timespec_from_100ns(time, t);+}++void clock_gettime_win32_threadtime(long long* t)+{+    FILETIME creation_time, exit_time, kernel_time, user_time;+    ULONGLONG time;++    GetThreadTimes(GetCurrentThread(), &creation_time, &exit_time, &kernel_time, &user_time);+    // Both kernel and user, acc. to http://www.opengroup.org/onlinepubs/009695399/basedefs/xbd_chap03.html#tag_03_117++    time = to_quad_100ns(user_time) + to_quad_100ns(kernel_time);+    to_timespec_from_100ns(time, t);+}++void clock_getres_win32_monotonic(long long* t)+{+    LARGE_INTEGER frequency;+    QueryPerformanceFrequency(&frequency);++    ULONGLONG resolution = U64(1000000000)/frequency.QuadPart;+    t[0] = resolution / U64(1000000000);+    t[1] = resolution % U64(1000000000);+}++void clock_getres_win32_realtime(long long* t)+{+    t[0] = 0;+    t[1] = 100;+}++void clock_getres_win32_processtime(long long* t)+{+    t[0] = 0;+    t[1] = 100;+}++void clock_getres_win32_threadtime(long long* t)+{+    t[0] = 0;+    t[1] = 100;+}++#endif  /* _WIN32 */
+ src/Streamly/Internal/Data/Time/config.h.in view
@@ -0,0 +1,55 @@+/* src/Streamly.Internal.Data.Time/config.h.in.  Generated from configure.ac by autoheader.  */++/* Define to 1 if you have the `clock_gettime' function. */+#undef HAVE_CLOCK_GETTIME++/* Define to 1 if you have the <inttypes.h> header file. */+#undef HAVE_INTTYPES_H++/* Define to 1 if you have the <memory.h> header file. */+#undef HAVE_MEMORY_H++/* Define to 1 if you have the <stdint.h> header file. */+#undef HAVE_STDINT_H++/* Define to 1 if you have the <stdlib.h> header file. */+#undef HAVE_STDLIB_H++/* Define to 1 if you have the <strings.h> header file. */+#undef HAVE_STRINGS_H++/* Define to 1 if you have the <string.h> header file. */+#undef HAVE_STRING_H++/* Define to 1 if you have the <sys/stat.h> header file. */+#undef HAVE_SYS_STAT_H++/* Define to 1 if you have the <sys/types.h> header file. */+#undef HAVE_SYS_TYPES_H++/* Define to 1 if you have the <time.h> header file. */+#undef HAVE_TIME_H++/* Define to 1 if you have the <unistd.h> header file. */+#undef HAVE_UNISTD_H++/* Define to the address where bug reports for this package should be sent. */+#undef PACKAGE_BUGREPORT++/* Define to the full name of this package. */+#undef PACKAGE_NAME++/* Define to the full name and version of this package. */+#undef PACKAGE_STRING++/* Define to the one symbol short name of this package. */+#undef PACKAGE_TARNAME++/* Define to the home page for this package. */+#undef PACKAGE_URL++/* Define to the version of this package. */+#undef PACKAGE_VERSION++/* Define to 1 if you have the ANSI C header files. */+#undef STDC_HEADERS
+ src/Streamly/Internal/Data/Unfold.hs view
@@ -0,0 +1,800 @@+{-# OPTIONS_HADDOCK hide               #-}+{-# LANGUAGE BangPatterns              #-}+{-# LANGUAGE CPP                       #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE PatternSynonyms           #-}+{-# LANGUAGE RankNTypes                #-}+{-# LANGUAGE RecordWildCards           #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE TupleSections             #-}++#include "inline.hs"++-- |+-- Module      : Streamly.Internal.Data.Unfold+-- Copyright   : (c) 2019 Composewell Technologies+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+-- Streams forcing a closed control flow loop can be categorized under+-- two types, unfolds and folds, both of these are duals of each other.+--+-- Unfold streams are really generators of a sequence of elements, we can also+-- call them pull style streams. These are lazy producers of streams. On each+-- evaluation the producer generates the next element.  A consumer can+-- therefore pull elements from the stream whenever it wants to.  A stream+-- consumer can multiplex pull streams by pulling elements from the chosen+-- streams, therefore, pull streams allow merging or multiplexing.  On the+-- other hand, with this representation we cannot split or demultiplex a+-- stream.  So really these are stream sources that can be generated from a+-- seed and can be merged or zipped into a single stream.+--+-- The dual of Unfolds are Folds. Folds can also be called as push style+-- streams or reducers. These are strict consumers of streams. We keep pushing+-- elements to a fold and we can extract the result at any point. A driver can+-- choose which fold to push to and can also push the same element to multiple+-- folds. Therefore, folds allow splitting or demultiplexing a stream. On the+-- other hand, we cannot merge streams using this representation. So really+-- these are stream consumers that reduce the stream to a single value, these+-- consumers can be composed such that a stream can be split over multiple+-- consumers.+--+-- Performance:+--+-- Composing a tree or graph of computations with unfolds can be much more+-- efficient compared to composing with the Monad instance.  The reason is that+-- unfolds allow the compiler to statically know the state and optimize it+-- using stream fusion whereas it is not possible with the monad bind because+-- the state is determined dynamically.++-- Open control flow style streams can also have two representations. StreamK+-- is a producer style representation. We can also have a consumer style+-- representation. We can use that for composable folds in StreamK+-- representation.+--+module Streamly.Internal.Data.Unfold+    (+    -- * Unfold Type+      Unfold++    -- * Operations on Input+    , lmap+    , lmapM+    , supply+    , supplyFirst+    , supplySecond+    , discardFirst+    , discardSecond+    , swap+    -- coapply+    -- comonad++    -- * Operations on Output+    , fold+    -- pipe++    -- * Unfolds+    , fromStream+    , fromStream1+    , fromStream2+    , nilM+    , consM+    , effect+    , singleton+    , identity+    , const+    , replicateM+    , fromList+    , fromListM+    , enumerateFromStepIntegral+    , enumerateFromToIntegral+    , enumerateFromIntegral++    -- * Transformations+    , map+    , mapM+    , mapMWithInput++    -- * Filtering+    , takeWhileM+    , takeWhile+    , take+    , filter+    , filterM++    -- * Nesting+    , concat+    , concatMapM+    , outerProduct++    -- * Exceptions+    , gbracket+    , before+    , after+    , onException+    , finally+    , bracket+    , handle+    )+where++import Control.Exception (Exception)+import Data.Void (Void)+import GHC.Types (SPEC(..))+import Prelude hiding (concat, map, mapM, takeWhile, take, filter, const)++import Streamly.Internal.Data.Stream.StreamD.Type (Stream(..), Step(..))+#if __GLASGOW_HASKELL__ < 800+import Streamly.Internal.Data.Stream.StreamD.Type (pattern Stream)+#endif+import Streamly.Internal.Data.Unfold.Types (Unfold(..))+import Streamly.Internal.Data.Fold.Types (Fold(..))+import Streamly.Internal.Data.SVar (defState)+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++-------------------------------------------------------------------------------+-- Input operations+-------------------------------------------------------------------------------++-- | Map a function on the input argument of the 'Unfold'.+--+-- /Internal/+{-# INLINE_NORMAL lmap #-}+lmap :: (a -> c) -> Unfold m c b -> Unfold m a b+lmap f (Unfold ustep uinject) = Unfold ustep (uinject . f)++-- | Map an action on the input argument of the 'Unfold'.+--+-- /Internal/+{-# INLINE_NORMAL lmapM #-}+lmapM :: Monad m => (a -> m c) -> Unfold m c b -> Unfold m a b+lmapM f (Unfold ustep uinject) = Unfold ustep (\x -> f x >>= uinject)++-- | Supply the seed to an unfold closing the input end of the unfold.+--+-- /Internal/+--+{-# INLINE_NORMAL supply #-}+supply :: Unfold m a b -> a -> Unfold m Void b+supply unf a = lmap (Prelude.const a) unf++-- | Supply the first component of the tuple to an unfold that accepts a tuple+-- as a seed resulting in a fold that accepts the second component of the tuple+-- as a seed.+--+-- /Internal/+--+{-# INLINE_NORMAL supplyFirst #-}+supplyFirst :: Unfold m (a, b) c -> a -> Unfold m b c+supplyFirst unf a = lmap (a, ) unf++-- | Supply the second component of the tuple to an unfold that accepts a tuple+-- as a seed resulting in a fold that accepts the first component of the tuple+-- as a seed.+--+-- /Internal/+--+{-# INLINE_NORMAL supplySecond #-}+supplySecond :: Unfold m (a, b) c -> b -> Unfold m a c+supplySecond unf b = lmap (, b) unf++-- | Convert an 'Unfold' into an unfold accepting a tuple as an argument,+-- using the argument of the original fold as the second element of tuple and+-- discarding the first element of the tuple.+--+-- /Internal/+--+{-# INLINE_NORMAL discardFirst #-}+discardFirst :: Unfold m a b -> Unfold m (c, a) b+discardFirst = lmap snd++-- | Convert an 'Unfold' into an unfold accepting a tuple as an argument,+-- using the argument of the original fold as the first element of tuple and+-- discarding the second element of the tuple.+--+-- /Internal/+--+{-# INLINE_NORMAL discardSecond #-}+discardSecond :: Unfold m a b -> Unfold m (a, c) b+discardSecond = lmap fst++-- | Convert an 'Unfold' that accepts a tuple as an argument into an unfold+-- that accepts a tuple with elements swapped.+--+-- /Internal/+--+{-# INLINE_NORMAL swap #-}+swap :: Unfold m (a, c) b -> Unfold m (c, a) b+swap = lmap Tuple.swap++-------------------------------------------------------------------------------+-- Output operations+-------------------------------------------------------------------------------++-- | Compose an 'Unfold' and a 'Fold'. Given an @Unfold m a b@ and a+-- @Fold m b c@, returns a monadic action @a -> m c@ representing the+-- application of the fold on the unfolded stream.+--+-- /Internal/+--+{-# INLINE_NORMAL fold #-}+fold :: Monad m => Unfold m a b -> Fold m b c -> a -> m c+fold (Unfold ustep inject) (Fold fstep initial extract) a =+    initial >>= \x -> inject a >>= go SPEC x+  where+    -- XXX !acc?+    {-# INLINE_LATE go #-}+    go !_ acc st = acc `seq` do+        r <- ustep st+        case r of+            Yield x s -> do+                acc' <- fstep acc x+                go SPEC acc' s+            Skip s -> go SPEC acc s+            Stop   -> extract acc++{-# INLINE_NORMAL map #-}+map :: Monad m => (b -> c) -> Unfold m a b -> Unfold m a c+map f (Unfold ustep uinject) = Unfold step uinject+    where+    {-# INLINE_LATE step #-}+    step st = do+        r <- ustep st+        return $ case r of+            Yield x s -> Yield (f x) s+            Skip s    -> Skip s+            Stop      -> Stop++{-# INLINE_NORMAL mapM #-}+mapM :: Monad m => (b -> m c) -> Unfold m a b -> Unfold m a c+mapM f (Unfold ustep uinject) = Unfold step uinject+    where+    {-# INLINE_LATE step #-}+    step st = do+        r <- ustep st+        case r of+            Yield x s -> f x >>= \a -> return $ Yield a s+            Skip s    -> return $ Skip s+            Stop      -> return $ Stop++{-# INLINE_NORMAL mapMWithInput #-}+mapMWithInput :: Monad m => (a -> b -> m c) -> Unfold m a b -> Unfold m a c+mapMWithInput f (Unfold ustep uinject) = Unfold step inject+    where+    inject a = do+        r <- uinject a+        return (a, r)++    {-# INLINE_LATE step #-}+    step (inp, st) = do+        r <- ustep st+        case r of+            Yield x s -> f inp x >>= \a -> return $ Yield a (inp, s)+            Skip s    -> return $ Skip (inp, s)+            Stop      -> return $ Stop++-------------------------------------------------------------------------------+-- Convert streams into unfolds+-------------------------------------------------------------------------------++{-# INLINE_LATE streamStep #-}+streamStep :: Monad m => Stream m a -> m (Step (Stream m a) a)+streamStep (Stream step1 state) = do+    r <- step1 defState state+    return $ case r of+        Yield x s -> Yield x (Stream step1 s)+        Skip s    -> Skip (Stream step1 s)+        Stop      -> Stop++-- | Convert a stream into an 'Unfold'. Note that a stream converted to an+-- 'Unfold' may not be as efficient as an 'Unfold' in some situations.+--+-- /Internal/+fromStream :: (K.IsStream t, Monad m) => t m b -> Unfold m Void b+fromStream str = Unfold streamStep (\_ -> return $ D.toStreamD str)++-- | Convert a single argument stream generator function into an+-- 'Unfold'. Note that a stream converted to an 'Unfold' may not be as+-- efficient as an 'Unfold' in some situations.+--+-- /Internal/+fromStream1 :: (K.IsStream t, Monad m) => (a -> t m b) -> Unfold m a b+fromStream1 f = Unfold streamStep (return . D.toStreamD . f)++-- | Convert a two argument stream generator function into an 'Unfold'. Note+-- that a stream converted to an 'Unfold' may not be as efficient as an+-- 'Unfold' in some situations.+--+-- /Internal/+fromStream2 :: (K.IsStream t, Monad m)+    => (a -> b -> t m c) -> Unfold m (a, b) c+fromStream2 f = Unfold streamStep (\(a, b) -> return $ D.toStreamD $ f a b)++-------------------------------------------------------------------------------+-- Unfolds+-------------------------------------------------------------------------------++-- | Lift a monadic function into an unfold generating a nil stream with a side+-- effect.+--+{-# INLINE nilM #-}+nilM :: Monad m => (a -> m c) -> Unfold m a b+nilM f = Unfold step return+    where+    {-# INLINE_LATE step #-}+    step x = f x >> return Stop++-- | Prepend a monadic single element generator function to an 'Unfold'.+--+-- /Internal/+{-# INLINE_NORMAL consM #-}+consM :: Monad m => (a -> m b) -> Unfold m a b -> Unfold m a b+consM action unf = Unfold step inject++    where++    inject = return . Left++    {-# INLINE_LATE step #-}+    step (Left a) = do+        action a >>= \r -> return $ Yield r (Right (D.unfold unf a))+    step (Right (UnStream step1 st)) = do+        res <- step1 defState 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++-- | Lift a monadic effect into an unfold generating a singleton stream.+--+{-# INLINE effect #-}+effect :: Monad m => m b -> Unfold m Void b+effect eff = Unfold step inject+    where+    inject _ = return True+    {-# INLINE_LATE step #-}+    step True = eff >>= \r -> return $ Yield r False+    step False = return Stop++-- | Lift a monadic function into an unfold generating a singleton stream.+--+{-# INLINE singleton #-}+singleton :: Monad m => (a -> m b) -> Unfold m a b+singleton f = Unfold step inject+    where+    inject x = return $ Just x+    {-# INLINE_LATE step #-}+    step (Just x) = f x >>= \r -> return $ Yield r Nothing+    step Nothing = return Stop++-- | Identity unfold. Generates a singleton stream with the seed as the only+-- element in the stream.+--+-- > identity = singleton return+--+{-# INLINE identity #-}+identity :: Monad m => Unfold m a a+identity = singleton return++const :: Monad m => m b -> Unfold m a b+const m = Unfold step inject+    where+    inject _ = return ()+    step () = m >>= \r -> return $ Yield r ()++-- | Generates a stream replicating the seed @n@ times.+--+{-# INLINE replicateM #-}+replicateM :: Monad m => Int -> Unfold m a a+replicateM n = Unfold step inject+    where+    inject x = return (x, n)+    {-# INLINE_LATE step #-}+    step (x, i) = return $+        if i <= 0+        then Stop+        else Yield x (x, (i - 1))++-- | Convert a list of pure values to a 'Stream'+{-# INLINE_LATE fromList #-}+fromList :: Monad m => Unfold m [a] a+fromList = Unfold step inject+  where+    inject x = return x+    {-# INLINE_LATE step #-}+    step (x:xs) = return $ Yield x xs+    step []     = return Stop++-- | Convert a list of monadic values to a 'Stream'+{-# INLINE_LATE fromListM #-}+fromListM :: Monad m => Unfold m [m a] a+fromListM = Unfold step inject+  where+    inject x = return x+    {-# INLINE_LATE step #-}+    step (x:xs) = x >>= \r -> return $ Yield r xs+    step []     = return Stop++-------------------------------------------------------------------------------+-- Filtering+-------------------------------------------------------------------------------++{-# INLINE_NORMAL take #-}+take :: Monad m => Int -> Unfold m a b -> Unfold m a b+take n (Unfold step1 inject1) = Unfold step inject+  where+    inject x = do+        s <- inject1 x+        return (s, 0)+    {-# INLINE_LATE step #-}+    step (st, i) | i < n = do+        r <- step1 st+        return $ case r of+            Yield x s -> Yield x (s, i + 1)+            Skip s -> Skip (s, i)+            Stop   -> Stop+    step (_, _) = return Stop++{-# INLINE_NORMAL takeWhileM #-}+takeWhileM :: Monad m => (b -> m Bool) -> Unfold m a b -> Unfold m a b+takeWhileM f (Unfold step1 inject1) = Unfold step inject1+  where+    {-# INLINE_LATE step #-}+    step st = do+        r <- step1 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 => (b -> Bool) -> Unfold m a b -> Unfold m a b+takeWhile f = takeWhileM (return . f)++{-# INLINE_NORMAL filterM #-}+filterM :: Monad m => (b -> m Bool) -> Unfold m a b -> Unfold m a b+filterM f (Unfold step1 inject1) = Unfold step inject1+  where+    {-# INLINE_LATE step #-}+    step st = do+        r <- step1 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 => (b -> Bool) -> Unfold m a b -> Unfold m a b+filter f = filterM (return . f)++-------------------------------------------------------------------------------+-- Enumeration+-------------------------------------------------------------------------------++-- | 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) => Unfold m (a, a) a+enumerateFromStepIntegral = Unfold step inject+    where+    inject (from, stride) = from `seq` stride `seq` return (from, stride)+    {-# INLINE_LATE step #-}+    step !(x, stride) = return $ Yield x $! (x + stride, 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 -> Unfold m a a+enumerateFromToIntegral to =+    takeWhile (<= to) $ supplySecond enumerateFromStepIntegral 1++{-# INLINE enumerateFromIntegral #-}+enumerateFromIntegral :: (Monad m, Integral a, Bounded a) => Unfold m a a+enumerateFromIntegral = enumerateFromToIntegral maxBound++-------------------------------------------------------------------------------+-- Nested+-------------------------------------------------------------------------------++data ConcatState s1 s2 = ConcatOuter s1 | ConcatInner s1 s2++{-# INLINE_NORMAL concat #-}+concat :: Monad m => Unfold m a b -> Unfold m b c -> Unfold m a c+concat (Unfold step1 inject1) (Unfold step2 inject2) = Unfold step inject+    where+    inject x = do+        s <- inject1 x+        return $ ConcatOuter s++    {-# INLINE_LATE step #-}+    step (ConcatOuter st) = do+        r <- step1 st+        case r of+            Yield x s -> do+                innerSt <- inject2 x+                return $ Skip (ConcatInner s innerSt)+            Skip s    -> return $ Skip (ConcatOuter s)+            Stop      -> return Stop++    step (ConcatInner ost ist) = do+        r <- step2 ist+        return $ case r of+            Yield x s -> Yield x (ConcatInner ost s)+            Skip s    -> Skip (ConcatInner ost s)+            Stop      -> Skip (ConcatOuter ost)++data OuterProductState s1 s2 sy x y =+    OuterProductOuter s1 y | OuterProductInner s1 sy s2 x++{-# INLINE_NORMAL outerProduct #-}+outerProduct :: Monad m+    => Unfold m a b -> Unfold m c d -> Unfold m (a, c) (b, d)+outerProduct (Unfold step1 inject1) (Unfold step2 inject2) = Unfold step inject+    where+    inject (x, y) = do+        s1 <- inject1 x+        return $ OuterProductOuter s1 y++    {-# INLINE_LATE step #-}+    step (OuterProductOuter st1 sy) = do+        r <- step1 st1+        case r of+            Yield x s -> do+                s2 <- inject2 sy+                return $ Skip (OuterProductInner s sy s2 x)+            Skip s    -> return $ Skip (OuterProductOuter s sy)+            Stop      -> return Stop++    step (OuterProductInner ost sy ist x) = do+        r <- step2 ist+        return $ case r of+            Yield y s -> Yield (x, y) (OuterProductInner ost sy s x)+            Skip s    -> Skip (OuterProductInner ost sy s x)+            Stop      -> Skip (OuterProductOuter ost sy)++-- XXX This can be used to implement a Monad instance for "Unfold m ()".++data ConcatMapState s1 s2 = ConcatMapOuter s1 | ConcatMapInner s1 s2++{-# INLINE_NORMAL concatMapM #-}+concatMapM :: Monad m+    => (b -> m (Unfold m () c)) -> Unfold m a b -> Unfold m a c+concatMapM f (Unfold step1 inject1) = Unfold step inject+    where+    inject x = do+        s <- inject1 x+        return $ ConcatMapOuter s++    {-# INLINE_LATE step #-}+    step (ConcatMapOuter st) = do+        r <- step1 st+        case r of+            Yield x s -> do+                Unfold step2 inject2 <- f x+                innerSt <- inject2 ()+                return $ Skip (ConcatMapInner s (Stream (\_ ss -> step2 ss)+                                                        innerSt))+            Skip s    -> return $ Skip (ConcatMapOuter s)+            Stop      -> return Stop++    step (ConcatMapInner ost (UnStream istep ist)) = do+        r <- istep defState ist+        return $ case r of+            Yield x s -> Yield x (ConcatMapInner ost (Stream istep s))+            Skip s    -> Skip (ConcatMapInner ost (Stream istep s))+            Stop      -> Skip (ConcatMapOuter ost)++------------------------------------------------------------------------------+-- Exceptions+------------------------------------------------------------------------------++-- | 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+    => (a -> m c)                           -- ^ before+    -> (forall s. m s -> m (Either e s))    -- ^ try (exception handling)+    -> (c -> m d)                           -- ^ after, on normal stop+    -> Unfold m (c, e) b                    -- ^ on exception+    -> Unfold m c b                         -- ^ unfold to run+    -> Unfold m a b+gbracket bef exc aft (Unfold estep einject) (Unfold step1 inject1) =+    Unfold step inject++    where++    inject x = do+        r <- bef x+        s <- inject1 r+        return $ Right (s, r)++    {-# INLINE_LATE step #-}+    step (Right (st, v)) = do+        res <- exc $ step1 st+        case res of+            Right r -> case r of+                Yield x s -> return $ Yield x (Right (s, v))+                Skip s    -> return $ Skip (Right (s, v))+                Stop      -> aft v >> return Stop+            Left e -> do+                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.+--+{-# INLINE_NORMAL _before #-}+_before :: Monad m => (a -> m c) -> Unfold m a b -> Unfold m a b+_before action unf = gbracket (\x -> action x >> return x) (fmap Right)+                             (\_ -> return ()) undefined unf++-- | Run a side effect before the unfold yields its first element.+--+-- /Internal/+{-# INLINE_NORMAL before #-}+before :: Monad m => (a -> m c) -> Unfold m a b -> Unfold m a b+before action (Unfold step1 inject1) = Unfold step inject++    where++    inject x = do+        _ <- action x+        st <- inject1 x+        return st++    {-# INLINE_LATE step #-}+    step st = do+        res <- step1 st+        case res of+            Yield x s -> return $ Yield x s+            Skip s    -> return $ Skip s+            Stop      -> return Stop++{-# INLINE_NORMAL _after #-}+_after :: Monad m => (a -> m c) -> Unfold m a b -> Unfold m a b+_after aft = gbracket return (fmap Right) aft undefined++-- | Run a side effect whenever the unfold stops normally.+--+-- /Internal/+{-# INLINE_NORMAL after #-}+after :: Monad m => (a -> m c) -> Unfold m a b -> Unfold m a b+after action (Unfold step1 inject1) = Unfold step inject++    where++    inject x = do+        s <- inject1 x+        return (s, x)++    {-# INLINE_LATE step #-}+    step (st, v) = do+        res <- step1 st+        case res of+            Yield x s -> return $ Yield x (s, v)+            Skip s    -> return $ Skip (s, v)+            Stop      -> action v >> return Stop++{-# INLINE_NORMAL _onException #-}+_onException :: MonadCatch m => (a -> m c) -> Unfold m a b -> Unfold m a b+_onException action unf =+    gbracket return MC.try+        (\_ -> return ())+        (nilM (\(a, (e :: MC.SomeException)) -> action a >> MC.throwM e)) unf++-- | Run a side effect whenever the unfold aborts due to an exception.+--+-- /Internal/+{-# INLINE_NORMAL onException #-}+onException :: MonadCatch m => (a -> m c) -> Unfold m a b -> Unfold m a b+onException action (Unfold step1 inject1) = Unfold step inject++    where++    inject x = do+        s <- inject1 x+        return (s, x)++    {-# INLINE_LATE step #-}+    step (st, v) = do+        res <- step1 st `MC.onException` action v+        case res of+            Yield x s -> return $ Yield x (s, v)+            Skip s    -> return $ Skip (s, v)+            Stop      -> return Stop++{-# INLINE_NORMAL _finally #-}+_finally :: MonadCatch m => (a -> m c) -> Unfold m a b -> Unfold m a b+_finally action unf =+    gbracket return MC.try action+        (nilM (\(a, (e :: MC.SomeException)) -> action a >> MC.throwM e)) unf++-- | Run a side effect whenever the unfold stops normally or aborts due to an+-- exception.+--+-- /Internal/+{-# INLINE_NORMAL finally #-}+finally :: MonadCatch m => (a -> m c) -> Unfold m a b -> Unfold m a b+finally action (Unfold step1 inject1) = Unfold step inject++    where++    inject x = do+        s <- inject1 x+        return (s, x)++    {-# INLINE_LATE step #-}+    step (st, v) = do+        res <- step1 st `MC.onException` action v+        case res of+            Yield x s -> return $ Yield x (s, v)+            Skip s    -> return $ Skip (s, v)+            Stop      -> action v >> return Stop++{-# INLINE_NORMAL _bracket #-}+_bracket :: MonadCatch m+    => (a -> m c) -> (c -> m d) -> Unfold m c b -> Unfold m a b+_bracket bef aft unf =+    gbracket bef MC.try aft (nilM (\(a, (e :: MC.SomeException)) -> aft a >>+    MC.throwM e)) unf++-- | @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.+--+-- /Internal/+{-# INLINE_NORMAL bracket #-}+bracket :: MonadCatch m+    => (a -> m c) -> (c -> m d) -> Unfold m c b -> Unfold m a b+bracket bef aft (Unfold step1 inject1) = Unfold step inject++    where++    inject x = do+        r <- bef x+        s <- inject1 r+        return (s, r)++    {-# INLINE_LATE step #-}+    step (st, v) = do+        res <- step1 st `MC.onException` aft v+        case res of+            Yield x s -> return $ Yield x (s, v)+            Skip s    -> return $ Skip (s, v)+            Stop      -> aft v >> return Stop++-- | When unfolding if an exception occurs, unfold the exception using the+-- exception unfold supplied as the first argument to 'handle'.+--+-- /Internal/+{-# INLINE_NORMAL handle #-}+handle :: (MonadCatch m, Exception e)+    => Unfold m e b -> Unfold m a b -> Unfold m a b+handle exc unf =+    gbracket return MC.try (\_ -> return ()) (discardFirst exc) unf
+ src/Streamly/Internal/Data/Unfold/Types.hs view
@@ -0,0 +1,32 @@+{-# OPTIONS_HADDOCK hide               #-}+{-# LANGUAGE CPP                       #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts          #-}++-- |+-- Module      : Streamly.Internal.Data.Unfold.Types+-- Copyright   : (c) 2019 Composewell Technologies+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++module Streamly.Internal.Data.Unfold.Types+    ( Unfold (..)+    )+where++import Streamly.Internal.Data.Stream.StreamD.Type (Step(..))++------------------------------------------------------------------------------+-- Monadic Unfolds+------------------------------------------------------------------------------++-- | An @Unfold m a b@ is a generator of a stream of values of type @b@ from a+-- seed of type 'a' in 'Monad' @m@.+--+-- @since 0.7.0++data Unfold m a b =+    -- | @Unfold step inject@+    forall s. Unfold (s -> m (Step s b)) (a -> m s)
+ src/Streamly/Internal/Data/Unicode/Char.hs view
@@ -0,0 +1,51 @@+{-# OPTIONS_HADDOCK hide      #-}+{-# LANGUAGE FlexibleContexts #-}++-- |+-- Module      : Streamly.Data.Internal.Unicode.Char+-- Copyright   : (c) 2018 Composewell Technologies+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+module Streamly.Internal.Data.Unicode.Char+    (+    -- * Unicode aware operations+    {-+      toCaseFold+    , toLower+    , toUpper+    , toTitle+    -}+    )+where++-- import Streamly (IsStream)++-------------------------------------------------------------------------------+-- Unicode aware operations on strings+-------------------------------------------------------------------------------++{-+-- |+-- /undefined/+toCaseFold :: IsStream t => Char -> t m Char+toCaseFold = undefined++-- |+-- /undefined/+toLower :: IsStream t => Char -> t m Char+toLower = undefined++-- |+-- /undefined/+toUpper :: IsStream t => Char -> t m Char+toUpper = undefined++-- |+-- /undefined/+toTitle :: IsStream t => Char -> t m Char+toTitle = undefined+-}
+ src/Streamly/Internal/Data/Unicode/Stream.hs view
@@ -0,0 +1,230 @@+{-# OPTIONS_HADDOCK hide      #-}+{-# LANGUAGE FlexibleContexts #-}++-- |+-- Module      : Streamly.Data.Internal.Unicode.Stream+-- Copyright   : (c) 2018 Composewell Technologies+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+module Streamly.Internal.Data.Unicode.Stream+    (+    -- * Construction (Decoding)+      decodeLatin1+    , decodeUtf8+    , decodeUtf8Lax+    , D.DecodeError(..)+    , D.DecodeState+    , D.CodePoint+    , decodeUtf8Either+    , resumeDecodeUtf8Either+    , decodeUtf8Arrays+    , decodeUtf8ArraysLenient++    -- * Elimination (Encoding)+    , encodeLatin1+    , encodeLatin1Lax+    , encodeUtf8+    {-+    -- * Operations on character strings+    , strip -- (dropAround isSpace)+    , stripEnd+    -}+    -- * Transformation+    , stripStart+    , lines+    , words+    , unlines+    , unwords+    )+where++import Control.Monad.IO.Class (MonadIO)+import Data.Char (ord)+import Data.Word (Word8)+import GHC.Base (unsafeChr)+import Streamly (IsStream)+import Prelude hiding (String, lines, words, unlines, unwords)+import Streamly.Data.Fold (Fold)+import Streamly.Memory.Array (Array)+import Streamly.Internal.Data.Unfold (Unfold)++import qualified Streamly.Internal.Prelude as S+import qualified Streamly.Streams.StreamD as D++-------------------------------------------------------------------------------+-- Encoding/Decoding Unicode Characters+-------------------------------------------------------------------------------++-- | Decode a stream of bytes to Unicode characters by mapping each byte to a+-- corresponding Unicode 'Char' in 0-255 range.+--+-- /Since: 0.7.0/+{-# INLINE decodeLatin1 #-}+decodeLatin1 :: (IsStream t, Monad m) => t m Word8 -> t m Char+decodeLatin1 = S.map (unsafeChr . fromIntegral)++-- | Encode a stream of Unicode characters to bytes by mapping each character+-- to a byte in 0-255 range. Throws an error if the input stream contains+-- characters beyond 255.+--+-- /Since: 0.7.0/+{-# INLINE encodeLatin1 #-}+encodeLatin1 :: (IsStream t, Monad m) => t m Char -> t m Word8+encodeLatin1 = S.map convert+    where+    convert c =+        let codepoint = ord c+        in if codepoint > 255+           then error $ "Streamly.String.encodeLatin1 invalid \+                    \input char codepoint " ++ show codepoint+           else fromIntegral codepoint++-- | Like 'encodeLatin1' but silently truncates and maps input characters beyond+-- 255 to (incorrect) chars in 0-255 range. No error or exception is thrown+-- when such truncation occurs.+--+-- /Since: 0.7.0/+{-# INLINE encodeLatin1Lax #-}+encodeLatin1Lax :: (IsStream t, Monad m) => t m Char -> t m Word8+encodeLatin1Lax = S.map (fromIntegral . ord)++-- | Decode a UTF-8 encoded bytestream to a stream of Unicode characters.+-- The incoming stream is truncated if an invalid codepoint is encountered.+--+-- /Since: 0.7.0/+{-# INLINE decodeUtf8 #-}+decodeUtf8 :: (Monad m, IsStream t) => t m Word8 -> t m Char+decodeUtf8 = D.fromStreamD . D.decodeUtf8 . D.toStreamD++-- |+--+-- /Internal/+{-# INLINE decodeUtf8Arrays #-}+decodeUtf8Arrays :: (MonadIO m, IsStream t) => t m (Array Word8) -> t m Char+decodeUtf8Arrays = D.fromStreamD . D.decodeUtf8Arrays . D.toStreamD++-- | Decode a UTF-8 encoded bytestream to a stream of Unicode characters.+-- Any invalid codepoint encountered is replaced with the unicode replacement+-- character.+--+-- /Since: 0.7.0/+{-# INLINE decodeUtf8Lax #-}+decodeUtf8Lax :: (Monad m, IsStream t) => t m Word8 -> t m Char+decodeUtf8Lax = D.fromStreamD . D.decodeUtf8Lenient . 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++-- |+--+-- /Internal/+{-# INLINE resumeDecodeUtf8Either #-}+resumeDecodeUtf8Either+    :: (Monad m, IsStream t)+    => D.DecodeState+    -> D.CodePoint+    -> t m Word8+    -> t m (Either D.DecodeError Char)+resumeDecodeUtf8Either st cp =+    D.fromStreamD . D.resumeDecodeUtf8Either st cp . D.toStreamD++-- |+--+-- /Internal/+{-# INLINE decodeUtf8ArraysLenient #-}+decodeUtf8ArraysLenient ::+       (MonadIO m, IsStream t) => t m (Array Word8) -> t m Char+decodeUtf8ArraysLenient =+    D.fromStreamD . D.decodeUtf8ArraysLenient . 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++{-+-------------------------------------------------------------------------------+-- Utility operations on strings+-------------------------------------------------------------------------------++strip :: IsStream t => t m Char -> t m Char+strip = undefined++stripEnd :: IsStream t => t m Char -> t m Char+stripEnd = undefined+-}++-- | Remove leading whitespace from a string.+--+-- > stripStart = S.dropWhile isSpace+--+-- /Internal/+{-# INLINE stripStart #-}+stripStart :: (Monad m, IsStream t) => t m Char -> t m Char+stripStart = S.dropWhile isSpace++-- | Fold each line of the stream using the supplied 'Fold'+-- and stream the result.+--+-- >>> S.toList $ lines FL.toList (S.fromList "lines\nthis\nstring\n\n\n")+-- ["lines", "this", "string", "", ""]+--+-- > lines = S.splitOnSuffix (== '\n')+--+-- /Internal/+{-# INLINE lines #-}+lines :: (Monad m, IsStream t) => Fold m Char b -> t m Char -> t m b+lines = S.splitOnSuffix (== '\n')++foreign import ccall unsafe "u_iswspace"+  iswspace :: Int -> Int++-- | Code copied from base/Data.Char to INLINE it+{-# INLINE isSpace #-}+isSpace :: Char -> Bool+isSpace c+  | uc <= 0x377 = uc == 32 || uc - 0x9 <= 4 || uc == 0xa0+  | otherwise = iswspace (ord c) /= 0+  where+    uc = fromIntegral (ord c) :: Word++-- | Fold each word of the stream using the supplied 'Fold'+-- and stream the result.+--+-- >>>  S.toList $ words FL.toList (S.fromList "fold these     words")+-- ["fold", "these", "words"]+--+-- > words = S.wordsBy isSpace+--+-- /Internal/+{-# INLINE words #-}+words :: (Monad m, IsStream t) => Fold m Char b -> t m Char -> t m b+words = S.wordsBy isSpace++-- | Unfold a stream to character streams using the supplied 'Unfold'+-- and concat the results suffixing a newline character @\\n@ to each stream.+--+-- /Internal/+{-# INLINE unlines #-}+unlines :: (MonadIO m, IsStream t) => Unfold m a Char -> t m a -> t m Char+unlines = S.interposeSuffix '\n'++-- | Unfold the elements of a stream to character streams using the supplied+-- 'Unfold' and concat the results with a whitespace character infixed between+-- the streams.+--+-- /Internal/+{-# INLINE unwords #-}+unwords :: (MonadIO m, IsStream t) => Unfold m a Char -> t m a -> t m Char+unwords = S.interpose ' '
+ src/Streamly/Internal/FileSystem/Dir.hs view
@@ -0,0 +1,421 @@+{-# OPTIONS_HADDOCK hide     #-}+{-# LANGUAGE CPP             #-}+{-# LANGUAGE BangPatterns    #-}+{-# LANGUAGE MagicHash       #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE UnboxedTuples   #-}++#include "inline.hs"++-- |+-- Module      : Streamly.Internal.FileSystem.Dir+-- Copyright   : (c) 2018 Composewell Technologies+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++module Streamly.Internal.FileSystem.Dir+    (+    -- ** Read from Directory+      read+    , readFiles+    , readDirs+    , readEither+    -- , readWithBufferOf++    , toStream+    , toEither+    , toFiles+    , toDirs+      {-+    , toStreamWithBufferOf++    , readChunks+    , readChunksWithBufferOf++    , toChunksWithBufferOf+    , toChunks++    , write+    , writeWithBufferOf++    -- Byte stream write (Streams)+    , fromStream+    , fromStreamWithBufferOf++    -- -- * Array Write+    , writeArray+    , writeChunks+    , writeChunksWithBufferOf++    -- -- * Array stream Write+    , fromChunks+    , fromChunksWithBufferOf+    -}+    )+where++import Control.Monad.IO.Class (MonadIO(..))+import Data.Either (isRight, isLeft)+-- import Data.Word (Word8)+-- import Foreign.ForeignPtr (withForeignPtr)+-- import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)+-- import Foreign.Ptr (minusPtr, plusPtr)+-- import Foreign.Storable (Storable(..))+-- import GHC.ForeignPtr (mallocPlainForeignPtrBytes)+-- import System.IO (Handle, hGetBufSome, hPutBuf)+import Prelude hiding (read)++-- import Streamly.Data.Fold (Fold)+import Streamly.Internal.Data.Unfold.Types (Unfold(..))+-- import Streamly.Internal.Memory.Array.Types+--        (Array(..), writeNUnsafe, defaultChunkSize, shrinkToFit,+--         lpackArraysChunksOf)+-- import Streamly.Streams.Serial (SerialT)+import Streamly.Streams.StreamK.Type (IsStream)+-- 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.Unfold as UF+-- import qualified Streamly.Internal.Memory.ArrayStream as AS+import qualified Streamly.Internal.Prelude as S+-- import qualified Streamly.Memory.Array as A+-- import qualified Streamly.Internal.Data.Stream.StreamD.Type as D+import qualified System.Directory as Dir++#if MIN_VERSION_base(4,10,0)+import Data.Either (fromRight, fromLeft)+#else+fromLeft :: a -> Either a b -> a+fromLeft _ (Left a) = a+fromLeft a _        = a++fromRight :: b -> Either a b -> b+fromRight _ (Right b) = b+fromRight b _         = b+#endif++{-+{-# INLINABLE readArrayUpto #-}+readArrayUpto :: Int -> Handle -> IO (Array Word8)+readArrayUpto size h = do+    ptr <- mallocPlainForeignPtrBytes size+    -- ptr <- mallocPlainForeignPtrAlignedBytes size (alignment (undefined :: Word8))+    withForeignPtr ptr $ \p -> do+        n <- hGetBufSome h p size+        let v = Array+                { aStart = ptr+                , aEnd   = p `plusPtr` n+                , aBound = p `plusPtr` size+                }+        -- XXX shrink only if the diff is significant+        shrinkToFit v++-------------------------------------------------------------------------------+-- Stream of Arrays IO+-------------------------------------------------------------------------------++-- | @toChunksWithBufferOf size h@ reads a stream of arrays from file handle @h@.+-- The maximum size of a single array is specified by @size@. The actual size+-- read may be less than or equal to @size@.+{-# INLINABLE _toChunksWithBufferOf #-}+_toChunksWithBufferOf :: (IsStream t, MonadIO m)+    => Int -> Handle -> t m (Array Word8)+_toChunksWithBufferOf size h = go+  where+    -- XXX use cons/nil instead+    go = mkStream $ \_ yld _ stp -> do+        arr <- liftIO $ readArrayUpto size h+        if A.length arr == 0+        then stp+        else yld arr go++-- | @toChunksWithBufferOf size handle@ reads a stream of arrays from the file+-- handle @handle@.  The maximum size of a single array is limited to @size@.+-- The actual size read may be less than or equal to @size@.+--+-- @since 0.7.0+{-# INLINE_NORMAL toChunksWithBufferOf #-}+toChunksWithBufferOf :: (IsStream t, MonadIO m) => Int -> Handle -> t m (Array Word8)+toChunksWithBufferOf size h = D.fromStreamD (D.Stream step ())+  where+    {-# INLINE_LATE step #-}+    step _ _ = do+        arr <- liftIO $ readArrayUpto size h+        return $+            case A.length arr of+                0 -> D.Stop+                _ -> D.Yield arr ()++-- | Unfold the tuple @(bufsize, handle)@ into a stream of 'Word8' arrays.+-- Read requests to the IO device are performed using a buffer of size+-- @bufsize@.  The size of an array in the resulting stream is always less than+-- or equal to @bufsize@.+--+-- @since 0.7.0+{-# INLINE_NORMAL readChunksWithBufferOf #-}+readChunksWithBufferOf :: MonadIO m => Unfold m (Int, Handle) (Array Word8)+readChunksWithBufferOf = Unfold step return+    where+    {-# INLINE_LATE step #-}+    step (size, h) = do+        arr <- liftIO $ readArrayUpto size h+        return $+            case A.length arr of+                0 -> D.Stop+                _ -> D.Yield arr (size, h)++-- XXX read 'Array a' instead of Word8+--+-- | @toChunks handle@ reads a stream of arrays from the specified file+-- handle.  The maximum size of a single array is limited to+-- @defaultChunkSize@. The actual size read may be less than or equal to+-- @defaultChunkSize@.+--+-- > toChunks = toChunksWithBufferOf defaultChunkSize+--+-- @since 0.7.0+{-# INLINE toChunks #-}+toChunks :: (IsStream t, MonadIO m) => Handle -> t m (Array Word8)+toChunks = toChunksWithBufferOf defaultChunkSize++-- | Unfolds a handle into a stream of 'Word8' arrays. Requests to the IO+-- device are performed using a buffer of size+-- 'Streamly.Internal.Memory.Array.Types.defaultChunkSize'. The+-- size of arrays in the resulting stream are therefore less than or equal to+-- 'Streamly.Internal.Memory.Array.Types.defaultChunkSize'.+--+-- @since 0.7.0+{-# INLINE readChunks #-}+readChunks :: MonadIO m => Unfold m Handle (Array Word8)+readChunks = UF.supplyFirst readChunksWithBufferOf defaultChunkSize++-------------------------------------------------------------------------------+-- Read File to Stream+-------------------------------------------------------------------------------++-- TODO for concurrent streams implement readahead IO. We can send multiple+-- read requests at the same time. For serial case we can use async IO. We can+-- also control the read throughput in mbps or IOPS.++-- | Unfolds the tuple @(bufsize, handle)@ into a byte stream, read requests+-- to the IO device are performed using buffers of @bufsize@.+--+-- @since 0.7.0+{-# INLINE readWithBufferOf #-}+readWithBufferOf :: MonadIO m => Unfold m (Int, Handle) Word8+readWithBufferOf = UF.concat readChunksWithBufferOf A.read++-- | @toStreamWithBufferOf bufsize handle@ reads a byte stream from a file+-- handle, reads are performed in chunks of up to @bufsize@.+--+-- /Internal/+{-# INLINE toStreamWithBufferOf #-}+toStreamWithBufferOf :: (IsStream t, MonadIO m) => Int -> Handle -> t m Word8+toStreamWithBufferOf chunkSize h = AS.concat $ toChunksWithBufferOf chunkSize h+-}++-- XXX exception handling+--  | Raw read of a directory+--+--  /Internal/+--+{-# INLINE read #-}+read :: MonadIO m => Unfold m String String+read =+    -- XXX use proper streaming read of the dir+    UF.lmapM (liftIO . Dir.getDirectoryContents) UF.fromList++-- XXX We can use a more general mechanism to filter the contents of a+-- directory. We can just stat each child and pass on the stat information. We+-- can then use that info to do a general filtering. "find" like filters can be+-- created.++-- | Read directories as Left and files as Right. Filter out "." and ".."+-- entries.+--+--  /Internal/+--+{-# INLINE readEither #-}+readEither :: MonadIO m => Unfold m String (Either String String)+readEither =+      UF.mapMWithInput classify+    $ UF.filter (\x -> x /= "." && x /= "..")+    -- XXX use proper streaming read of the dir+    $ UF.lmapM (liftIO . Dir.getDirectoryContents) UF.fromList+    where+    classify dir x = do+        r <- liftIO $ Dir.doesDirectoryExist (dir ++ "/" ++ x)+        return $ if r then Left x else Right x++--+-- | Read files only.+--+--  /Internal/+--+{-# INLINE readFiles #-}+readFiles :: MonadIO m => Unfold m String String+readFiles = UF.map (fromRight undefined) $ UF.filter isRight readEither++-- | Read directories only. Filter out "." and ".." entries.+--+--  /Internal/+--+{-# INLINE readDirs #-}+readDirs :: MonadIO m => Unfold m String String+readDirs = UF.map (fromLeft undefined) $ UF.filter isLeft readEither++-- | Raw read of a directory.+--+-- /Internal/+{-# INLINE toStream #-}+toStream :: (IsStream t, MonadIO m) => String -> t m String+toStream = S.unfold read++-- | Read directories as Left and files as Right. Filter out "." and ".."+-- entries.+--+-- /Internal/+{-# INLINE toEither #-}+toEither :: (IsStream t, MonadIO m)+    => String -> t m (Either String String)+toEither = S.unfold readEither++-- | Read files only.+--+--  /Internal/+--+{-# INLINE toFiles #-}+toFiles :: (IsStream t, MonadIO m) => String -> t m String+toFiles = S.unfold readFiles++-- | Read directories only.+--+--  /Internal/+--+{-# INLINE toDirs #-}+toDirs :: (IsStream t, MonadIO m) => String -> t m String+toDirs = S.unfold readDirs++{-+-------------------------------------------------------------------------------+-- Writing+-------------------------------------------------------------------------------++-------------------------------------------------------------------------------+-- Array IO (output)+-------------------------------------------------------------------------------++-- | Write an 'Array' to a file handle.+--+-- @since 0.7.0+{-# INLINABLE writeArray #-}+writeArray :: Storable a => Handle -> Array a -> IO ()+writeArray _ arr | A.length arr == 0 = return ()+writeArray h Array{..} = withForeignPtr aStart $ \p -> hPutBuf h p aLen+    where+    aLen =+        let p = unsafeForeignPtrToPtr aStart+        in aEnd `minusPtr` p++-------------------------------------------------------------------------------+-- Stream of Arrays IO+-------------------------------------------------------------------------------++-------------------------------------------------------------------------------+-- Writing+-------------------------------------------------------------------------------++-- | Write a stream of arrays to a handle.+--+-- @since 0.7.0+{-# INLINE fromChunks #-}+fromChunks :: (MonadIO m, Storable a)+    => Handle -> SerialT m (Array a) -> m ()+fromChunks h m = S.mapM_ (liftIO . writeArray h) m++-- | @fromChunksWithBufferOf bufsize handle stream@ writes a stream of arrays+-- to @handle@ after coalescing the adjacent arrays in chunks of @bufsize@.+-- The chunk size is only a maximum and the actual writes could be smaller as+-- we do not split the arrays to fit exactly to the specified size.+--+-- @since 0.7.0+{-# INLINE fromChunksWithBufferOf #-}+fromChunksWithBufferOf :: (MonadIO m, Storable a)+    => Int -> Handle -> SerialT m (Array a) -> m ()+fromChunksWithBufferOf n h xs = fromChunks h $ AS.compact n xs++-- | @fromStreamWithBufferOf bufsize handle stream@ writes @stream@ to @handle@+-- in chunks of @bufsize@.  A write is performed to the IO device as soon as we+-- collect the required input size.+--+-- @since 0.7.0+{-# INLINE fromStreamWithBufferOf #-}+fromStreamWithBufferOf :: MonadIO m => Int -> Handle -> SerialT m Word8 -> m ()+fromStreamWithBufferOf n h m = fromChunks h $ S.arraysOf n m+-- fromStreamWithBufferOf n h m = fromChunks h $ AS.arraysOf n m++-- > write = 'writeWithBufferOf' A.defaultChunkSize+--+-- | Write a byte stream to a file handle. Accumulates the input in chunks of+-- up to 'Streamly.Internal.Memory.Array.Types.defaultChunkSize' before writing.+--+-- NOTE: This may perform better than the 'write' fold, you can try this if you+-- need some extra perf boost.+--+-- @since 0.7.0+{-# INLINE fromStream #-}+fromStream :: MonadIO m => Handle -> SerialT m Word8 -> m ()+fromStream = fromStreamWithBufferOf defaultChunkSize++-- | Write a stream of arrays to a handle. Each array in the stream is written+-- to the device as a separate IO request.+--+-- @since 0.7.0+{-# INLINE writeChunks #-}+writeChunks :: (MonadIO m, Storable a) => Handle -> Fold m (Array a) ()+writeChunks h = FL.drainBy (liftIO . writeArray h)++-- | @writeChunksWithBufferOf bufsize handle@ writes a stream of arrays+-- to @handle@ 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 -> Handle -> Fold m (Array a) ()+writeChunksWithBufferOf n h = lpackArraysChunksOf n (writeChunks h)++-- GHC buffer size dEFAULT_FD_BUFFER_SIZE=8192 bytes.+--+-- XXX test this+-- Note that if you use a chunk size less than 8K (GHC's default buffer+-- size) then you are advised to use 'NOBuffering' mode on the 'Handle' in case you+-- do not want buffering to occur at GHC level as well. Same thing applies to+-- writes as well.++-- | @writeWithBufferOf reqSize handle@ writes the input stream to @handle@.+-- Bytes in the input stream are collected into a buffer until we have a chunk+-- of @reqSize@ and then written to the IO device.+--+-- @since 0.7.0+{-# INLINE writeWithBufferOf #-}+writeWithBufferOf :: MonadIO m => Int -> Handle -> Fold m Word8 ()+writeWithBufferOf n h = FL.lchunksOf n (writeNUnsafe n) (writeChunks h)++-- > write = 'writeWithBufferOf' A.defaultChunkSize+--+-- | Write a byte stream to a file handle. Accumulates the input in chunks of+-- up to 'Streamly.Internal.Memory.Array.Types.defaultChunkSize' before writing+-- to the IO device.+--+-- @since 0.7.0+{-# INLINE write #-}+write :: MonadIO m => Handle -> Fold m Word8 ()+write = writeWithBufferOf defaultChunkSize+-}
+ src/Streamly/Internal/FileSystem/File.hs view
@@ -0,0 +1,578 @@+{-# OPTIONS_HADDOCK hide      #-}+{-# LANGUAGE CPP              #-}+{-# LANGUAGE BangPatterns     #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MagicHash        #-}+{-# LANGUAGE RecordWildCards  #-}+{-# LANGUAGE UnboxedTuples    #-}++#include "inline.hs"++-- |+-- Module      : Streamly.Internal.FileSystem.File+-- Copyright   : (c) 2019 Harendra Kumar+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+-- Read and write streams and arrays to and from files specified by their paths+-- in the file system. Unlike the handle based APIs which can have a read/write+-- 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+-- leakage.+--+-- > import qualified Streamly.Internal.FileSystem.File as File+--++module Streamly.Internal.FileSystem.File+    (+    -- * Streaming IO+    -- | Stream data to or from a file or device sequentially.  When reading,+    -- the stream is lazy and generated on-demand as the consumer consumes it.+    -- Read IO requests to the IO device are performed in chunks limited to a+    -- maximum size of 32KiB, this is referred to as @defaultChunkSize@ in the+    -- documentation. One IO request may or may not read the full+    -- chunk. If the whole stream is not consumed, it is possible that we may+    -- read slightly more from the IO device than what the consumer needed.+    -- Unless specified otherwise in the API, writes are collected into chunks+    -- of @defaultChunkSize@ before they are written to the IO device.++    -- Streaming APIs work for all kind of devices, seekable or non-seekable;+    -- including disks, files, memory devices, terminals, pipes, sockets and+    -- fifos. While random access APIs work only for files or devices that have+    -- random access or seek capability for example disks, memory devices.+    -- Devices like terminals, pipes, sockets and fifos do not have random+    -- access capability.++    -- ** File IO Using Handle+      withFile++    -- ** Read From File+    , read+    -- , readShared+    -- , readTailForever++    -- , readUtf8+    -- , readLines+    -- , readFrames+    -- , readChunks++    , toBytes++    -- -- * Array Read+    -- , readArrayOf++    , toChunksWithBufferOf+    , toChunks++    -- ** Write To File+    , write+    -- , writeUtf8+    -- , writeUtf8ByLines+    -- , writeByFrames+    , writeWithBufferOf++    , fromBytes+    , fromBytesWithBufferOf++    -- -- * Array Write+    , writeArray+    , writeChunks+    , fromChunks++    -- ** Append To File+    , append+    , appendWithBufferOf+    -- , appendShared+    , appendArray+    , appendChunks+    )+where++import Control.Monad.Catch (MonadCatch)+import Control.Monad.IO.Class (MonadIO(..))+import Data.Word (Word8)+import Foreign.Storable (Storable(..))+import System.IO (Handle, openFile, IOMode(..), hClose)+import Prelude hiding (read)++import qualified Control.Monad.Catch as MC+import qualified System.IO as SIO++import Streamly.Internal.Data.Fold.Types (Fold(..))+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.SVar (MonadAsync)+-- import Streamly.Data.Fold (Fold)+-- import Streamly.String (encodeUtf8, decodeUtf8, foldLines)++import qualified Streamly.Internal.Data.Fold.Types as FL+import qualified Streamly.Internal.Data.Unfold as UF+import qualified Streamly.Internal.FileSystem.Handle as FH+import qualified Streamly.Internal.Memory.ArrayStream as AS+import qualified Streamly.Memory.Array as A+import qualified Streamly.Prelude as S++-------------------------------------------------------------------------------+-- References+-------------------------------------------------------------------------------+--+-- The following references may be useful to build an understanding about the+-- file API design:+--+-- http://www.linux-mag.com/id/308/ for blocking/non-blocking IO on linux.+-- https://lwn.net/Articles/612483/ Non-blocking buffered file read operations+-- https://en.wikipedia.org/wiki/C_file_input/output for C APIs.+-- https://docs.oracle.com/javase/tutorial/essential/io/file.html for Java API.+-- https://www.w3.org/TR/FileAPI/ for http file API.++-------------------------------------------------------------------------------+-- Safe file reading+-------------------------------------------------------------------------------++-- | @'withFile' name mode act@ opens a file using 'openFile' and passes+-- the resulting handle to the computation @act@.  The handle will be+-- closed on exit from 'withFile', whether by normal termination or by+-- raising an exception.  If closing the handle raises an exception, then+-- this exception will be raised by 'withFile' rather than any exception+-- raised by 'act'.+--+-- /Internal/+--+{-# INLINE withFile #-}+withFile :: (IsStream t, MonadCatch m, MonadIO m)+    => FilePath -> IOMode -> (Handle -> t m a) -> t m a+withFile file mode = S.bracket (liftIO $ openFile file mode) (liftIO . hClose)++-- | Transform an 'Unfold' from a 'Handle' to an unfold from a 'FilePath'.  The+-- resulting unfold opens a handle in 'ReadMode', uses it using the supplied+-- unfold and then makes sure that the handle is closed on normal termination+-- or in case of an exception.  If closing the handle raises an exception, then+-- this exception will be raised by 'usingFile'.+--+-- /Internal/+--+{-# INLINABLE usingFile #-}+usingFile :: (MonadCatch m, MonadIO m)+    => Unfold m Handle a -> Unfold m FilePath a+usingFile =+    UF.bracket (\file -> liftIO $ openFile file ReadMode)+               (liftIO . hClose)++-------------------------------------------------------------------------------+-- Array IO (Input)+-------------------------------------------------------------------------------++-- TODO readArrayOf++-------------------------------------------------------------------------------+-- Array IO (output)+-------------------------------------------------------------------------------++-- | Write an array to a file. Overwrites the file if it exists.+--+-- @since 0.7.0+{-# INLINABLE writeArray #-}+writeArray :: Storable a => FilePath -> Array a -> IO ()+writeArray file arr = SIO.withFile file WriteMode (\h -> FH.writeArray h arr)++-- | append an array to a file.+--+-- @since 0.7.0+{-# INLINABLE appendArray #-}+appendArray :: Storable a => FilePath -> Array a -> IO ()+appendArray file arr = SIO.withFile file AppendMode (\h -> FH.writeArray h arr)++-------------------------------------------------------------------------------+-- Stream of Arrays IO+-------------------------------------------------------------------------------++-- | @toChunksWithBufferOf size file@ reads a stream of arrays from file @file@.+-- The maximum size of a single array is specified by @size@. The actual size+-- read may be less than or equal to @size@.+{-# INLINABLE toChunksWithBufferOf #-}+toChunksWithBufferOf :: (IsStream t, MonadCatch m, MonadIO m)+    => Int -> FilePath -> t m (Array Word8)+toChunksWithBufferOf size file =+    withFile file ReadMode (FH.toChunksWithBufferOf size)++-- XXX read 'Array a' instead of Word8+--+-- | @toChunks file@ reads a stream of arrays from file @file@.+-- The maximum size of a single array is limited to @defaultChunkSize@. The+-- actual size read may be less than @defaultChunkSize@.+--+-- > toChunks = toChunksWithBufferOf defaultChunkSize+--+-- @since 0.7.0+{-# INLINE toChunks #-}+toChunks :: (IsStream t, MonadCatch m, MonadIO m)+    => FilePath -> t m (Array Word8)+toChunks = toChunksWithBufferOf defaultChunkSize++-------------------------------------------------------------------------------+-- Read File to Stream+-------------------------------------------------------------------------------++-- TODO for concurrent streams implement readahead IO. We can send multiple+-- read requests at the same time. For serial case we can use async IO. We can+-- also control the read throughput in mbps or IOPS.++{-+-- | Unfolds the tuple @(bufsize, filepath)@ into a byte stream, read requests+-- to the IO device are performed using buffers of @bufsize@.+--+-- @since 0.7.0+{-# INLINE readWithBufferOf #-}+readWithBufferOf :: MonadIO m => Unfold m (Int, FilePath) Word8+readWithBufferOf = UF.concat (usingFilexxx FH.readChunksWithBufferOf) A.read+-}++-- | Unfolds a file path into a byte stream. IO requests to the device are+-- performed in sizes of+-- 'Streamly.Internal.Memory.Array.Types.defaultChunkSize'.+--+-- @since 0.7.0+{-# INLINE read #-}+read :: (MonadCatch m, MonadIO m) => Unfold m FilePath Word8+read = UF.concat (usingFile FH.readChunks) A.read++{-+-- | @readInChunksOf chunkSize handle@ reads a byte stream from a file+-- handle, reads are performed in chunks of up to @chunkSize@.  The stream ends+-- as soon as EOF is encountered.+--+{-# INLINE readInChunksOf #-}+readInChunksOf :: (IsStream t, MonadIO m) => Int -> Handle -> t m Word8+readInChunksOf chunkSize h = A.flattenArrays $ toChunksWithBufferOf chunkSize h+-}++-- TODO+-- read :: (IsStream t, MonadIO m, Storable a) => Handle -> t m a+--+-- > read = 'readByChunks' defaultChunkSize+-- | Generate a stream of bytes from a file specified by path. The stream ends+-- when EOF is encountered. File is locked using multiple reader and single+-- writer locking mode.+--+-- /Internal/+--+{-# INLINE toBytes #-}+toBytes :: (IsStream t, MonadCatch m, MonadIO m) => FilePath -> t m Word8+toBytes file = AS.concat $ withFile file ReadMode FH.toChunks++{-+-- | Generate a stream of elements of the given type from a file 'Handle'. The+-- stream ends when EOF is encountered. File is not locked for exclusive reads,+-- writers can keep writing to the file.+--+-- @since 0.7.0+{-# INLINE readShared #-}+readShared :: (IsStream t, MonadIO m) => Handle -> t m Word8+readShared = undefined++-- | Read a stream from a given file path. When end of file (EOF) is reached+-- this API waits for more data to be written to the file and keeps reading it+-- as it is written.+--+-- @since 0.7.0+{-# INLINE readTailForever #-}+readTailForever :: (IsStream t, MonadIO m) => Handle -> t m Word8+readTailForever = undefined+-}++-------------------------------------------------------------------------------+-- Writing+-------------------------------------------------------------------------------++{-# INLINE fromChunksMode #-}+fromChunksMode :: (MonadAsync m, MonadCatch m, Storable a)+    => IOMode -> FilePath -> SerialT m (Array a) -> m ()+fromChunksMode mode file xs = S.drain $+    withFile file mode (\h -> S.mapM (liftIO . FH.writeArray h) xs)++-- | Write a stream of arrays to a file. Overwrites the file if it exists.+--+-- @since 0.7.0+{-# INLINE fromChunks #-}+fromChunks :: (MonadAsync m, MonadCatch m, Storable a)+    => FilePath -> SerialT m (Array a) -> m ()+fromChunks = fromChunksMode WriteMode++-- GHC buffer size dEFAULT_FD_BUFFER_SIZE=8192 bytes.+--+-- XXX test this+-- Note that if you use a chunk size less than 8K (GHC's default buffer+-- size) then you are advised to use 'NOBuffering' mode on the 'Handle' in case you+-- do not want buffering to occur at GHC level as well. Same thing applies to+-- writes as well.++-- | Like 'write' but provides control over the write buffer. Output will+-- be written to the IO device as soon as we collect the specified number of+-- input elements.+--+-- @since 0.7.0+{-# INLINE fromBytesWithBufferOf #-}+fromBytesWithBufferOf :: (MonadAsync m, MonadCatch m)+    => Int -> FilePath -> SerialT m Word8 -> m ()+fromBytesWithBufferOf n file xs = fromChunks file $ AS.arraysOf n xs++-- > write = 'writeWithBufferOf' defaultChunkSize+--+-- | Write a byte stream to a file. Combines the bytes in chunks of size+-- up to 'A.defaultChunkSize' before writing. If the file exists it is+-- truncated to zero size before writing. If the file does not exist it is+-- created. File is locked using single writer locking mode.+--+-- /Internal/+{-# INLINE fromBytes #-}+fromBytes :: (MonadAsync m, MonadCatch m) => FilePath -> SerialT m Word8 -> m ()+fromBytes = fromBytesWithBufferOf defaultChunkSize++{-+{-# INLINE write #-}+write :: (MonadIO m, Storable a) => Handle -> SerialT m a -> m ()+write = toHandleWith A.defaultChunkSize+-}++-- | Write a stream of chunks to a handle. Each chunk in the stream is written+-- to the device as a separate IO request.+--+-- /Internal/+{-# INLINE writeChunks #-}+writeChunks :: (MonadIO m, MonadCatch m, Storable a)+    => FilePath -> Fold m (Array a) ()+writeChunks path = Fold step initial extract+    where+    initial = do+        h <- liftIO (openFile path WriteMode)+        fld <- FL.initialize (FH.writeChunks h)+                `MC.onException` (liftIO $ hClose h)+        return (fld, h)+    step (fld, h) x = do+        r <- FL.runStep fld x `MC.onException` (liftIO $ hClose h)+        return (r, h)+    extract ((Fold _ initial1 extract1), h) = do+        liftIO $ hClose h+        initial1 >>= extract1++-- | @writeWithBufferOf chunkSize handle@ writes the input stream to @handle@.+-- Bytes in the input stream are collected into a buffer until we have a chunk+-- of size @chunkSize@ and then written to the IO device.+--+-- /Internal/+{-# INLINE writeWithBufferOf #-}+writeWithBufferOf :: (MonadIO m, MonadCatch m)+    => Int -> FilePath -> Fold m Word8 ()+writeWithBufferOf n path =+    FL.lchunksOf n (writeNUnsafe n) (writeChunks path)++-- > write = 'writeWithBufferOf' A.defaultChunkSize+--+-- | Write a byte stream to a file. Accumulates the input in chunks of up to+-- 'Streamly.Internal.Memory.Array.Types.defaultChunkSize' before writing to+-- the IO device.+--+-- /Internal/+--+{-# INLINE write #-}+write :: (MonadIO m, MonadCatch m) => FilePath -> Fold m Word8 ()+write = writeWithBufferOf defaultChunkSize++-- | Append a stream of arrays to a file.+--+-- @since 0.7.0+{-# INLINE appendChunks #-}+appendChunks :: (MonadAsync m, MonadCatch m, Storable a)+    => FilePath -> SerialT m (Array a) -> m ()+appendChunks = fromChunksMode AppendMode++-- | Like 'append' but provides control over the write buffer. Output will+-- be written to the IO device as soon as we collect the specified number of+-- input elements.+--+-- @since 0.7.0+{-# INLINE appendWithBufferOf #-}+appendWithBufferOf :: (MonadAsync m, MonadCatch m)+    => Int -> FilePath -> SerialT m Word8 -> m ()+appendWithBufferOf n file xs = appendChunks file $ AS.arraysOf n xs++-- | Append a byte stream to a file. Combines the bytes in chunks of size up to+-- 'A.defaultChunkSize' before writing.  If the file exists then the new data+-- is appended to the file.  If the file does not exist it is created. File is+-- locked using single writer locking mode.+--+-- @since 0.7.0+{-# INLINE append #-}+append :: (MonadAsync m, MonadCatch m) => FilePath -> SerialT m Word8 -> m ()+append = appendWithBufferOf defaultChunkSize++{-+-- | Like 'append' but the file is not locked for exclusive writes.+--+-- @since 0.7.0+{-# INLINE appendShared #-}+appendShared :: MonadIO m => Handle -> SerialT m Word8 -> m ()+appendShared = undefined+-}++-------------------------------------------------------------------------------+-- IO with encoding/decoding Unicode characters+-------------------------------------------------------------------------------++{-+-- |+-- > readUtf8 = decodeUtf8 . read+--+-- Read a UTF8 encoded stream of unicode characters from a file handle.+--+-- @since 0.7.0+{-# INLINE readUtf8 #-}+readUtf8 :: (IsStream t, MonadIO m) => Handle -> t m Char+readUtf8 = decodeUtf8 . read++-- |+-- > writeUtf8 h s = write h $ encodeUtf8 s+--+-- Encode a stream of unicode characters to UTF8 and write it to the given file+-- handle. Default block buffering applies to the writes.+--+-- @since 0.7.0+{-# INLINE writeUtf8 #-}+writeUtf8 :: MonadIO m => Handle -> SerialT m Char -> m ()+writeUtf8 h s = write h $ encodeUtf8 s++-- | Write a stream of unicode characters after encoding to UTF-8 in chunks+-- separated by a linefeed character @'\n'@. If the size of the buffer exceeds+-- @defaultChunkSize@ and a linefeed is not yet found, the buffer is written+-- anyway.  This is similar to writing to a 'Handle' with the 'LineBuffering'+-- option.+--+-- @since 0.7.0+{-# INLINE writeUtf8ByLines #-}+writeUtf8ByLines :: (IsStream t, MonadIO m) => Handle -> t m Char -> m ()+writeUtf8ByLines = undefined++-- | Read UTF-8 lines from a file handle and apply the specified fold to each+-- line. This is similar to reading a 'Handle' with the 'LineBuffering' option.+--+-- @since 0.7.0+{-# INLINE readLines #-}+readLines :: (IsStream t, MonadIO m) => Handle -> Fold m Char b -> t m b+readLines h f = foldLines (readUtf8 h) f++-------------------------------------------------------------------------------+-- Framing on a sequence+-------------------------------------------------------------------------------++-- | Read a stream from a file handle and split it into frames delimited by+-- the specified sequence of elements. The supplied fold is applied on each+-- frame.+--+-- @since 0.7.0+{-# INLINE readFrames #-}+readFrames :: (IsStream t, MonadIO m, Storable a)+    => Array a -> Handle -> Fold m a b -> t m b+readFrames = undefined -- foldFrames . read++-- | Write a stream to the given file handle buffering up to frames separated+-- by the given sequence or up to a maximum of @defaultChunkSize@.+--+-- @since 0.7.0+{-# INLINE writeByFrames #-}+writeByFrames :: (IsStream t, MonadIO m, Storable a)+    => Array a -> Handle -> t m a -> m ()+writeByFrames = undefined++-------------------------------------------------------------------------------+-- Random Access IO (Seek)+-------------------------------------------------------------------------------++-- XXX handles could be shared, so we may not want to use the handle state at+-- all for these APIs. we can use pread and pwrite instead. On windows we will+-- need to use readFile/writeFile with an offset argument.++-------------------------------------------------------------------------------++-- | Read the element at the given index treating the file as an array.+--+-- @since 0.7.0+{-# INLINE readIndex #-}+readIndex :: Storable a => Handle -> Int -> Maybe a+readIndex arr i = undefined++-- NOTE: To represent a range to read we have chosen (start, size) instead of+-- (start, end). This helps in removing the ambiguity of whether "end" is+-- included in the range or not.+--+-- We could avoid specifying the range to be read and instead use "take size"+-- on the stream, but it may end up reading more and then consume it partially.++-- | @readSliceWith chunkSize handle pos len@ reads up to @len@ bytes+-- from @handle@ starting at the offset @pos@ from the beginning of the file.+--+-- Reads are performed in chunks of size @chunkSize@.  For block devices, to+-- avoid reading partial blocks @chunkSize@ must align with the block size of+-- the underlying device. If the underlying block size is unknown, it is a good+-- idea to keep it a multiple 4KiB. This API ensures that the start of each+-- chunk is aligned with @chunkSize@ from second chunk onwards.+--+{-# INLINE readSliceWith #-}+readSliceWith :: (IsStream t, MonadIO m, Storable a)+    => Int -> Handle -> Int -> Int -> t m a+readSliceWith chunkSize h pos len = undefined++-- | @readSlice h i count@ streams a slice from the file handle @h@ starting+-- at index @i@ and reading up to @count@ elements in the forward direction+-- ending at the index @i + count - 1@.+--+-- @since 0.7.0+{-# INLINE readSlice #-}+readSlice :: (IsStream t, MonadIO m, Storable a)+    => Handle -> Int -> Int -> t m a+readSlice = readSliceWith defaultChunkSize++-- | @readSliceRev h i count@ streams a slice from the file handle @h@ starting+-- at index @i@ and reading up to @count@ elements in the reverse direction+-- ending at the index @i - count + 1@.+--+-- @since 0.7.0+{-# INLINE readSliceRev #-}+readSliceRev :: (IsStream t, MonadIO m, Storable a)+    => Handle -> Int -> Int -> t m a+readSliceRev h i count = undefined++-- | Write the given element at the given index in the file.+--+-- @since 0.7.0+{-# INLINE writeIndex #-}+writeIndex :: (MonadIO m, Storable a) => Handle -> Int -> a -> m ()+writeIndex h i a = undefined++-- | @writeSlice h i count stream@ writes a stream to the file handle @h@+-- starting at index @i@ and writing up to @count@ elements in the forward+-- direction ending at the index @i + count - 1@.+--+-- @since 0.7.0+{-# INLINE writeSlice #-}+writeSlice :: (IsStream t, Monad m, Storable a)+    => Handle -> Int -> Int -> t m a -> m ()+writeSlice h i len s = undefined++-- | @writeSliceRev h i count stream@ writes a stream to the file handle @h@+-- starting at index @i@ and writing up to @count@ elements in the reverse+-- direction ending at the index @i - count + 1@.+--+-- @since 0.7.0+{-# INLINE writeSliceRev #-}+writeSliceRev :: (IsStream t, Monad m, Storable a)+    => Handle -> Int -> Int -> t m a -> m ()+writeSliceRev arr i len s = undefined+-}
+ src/Streamly/Internal/FileSystem/Handle.hs view
@@ -0,0 +1,646 @@+{-# OPTIONS_HADDOCK hide     #-}+{-# LANGUAGE CPP             #-}+{-# LANGUAGE BangPatterns    #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MagicHash       #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE UnboxedTuples   #-}++#include "inline.hs"++-- |+-- Module      : Streamly.Internal.FileSystem.Handle+-- Copyright   : (c) 2018 Composewell Technologies+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC++module Streamly.Internal.FileSystem.Handle+    (+    -- ** Read from Handle+      read+    -- , readUtf8+    -- , readLines+    -- , readFrames+    , readWithBufferOf++    , toBytes+    , toBytesWithBufferOf+    , getBytes++    -- -- * Array Read+    -- , readArrayUpto+    -- , readArrayOf+    , readChunks+    , readChunksWithBufferOf++    , toChunksWithBufferOf+    , toChunks+    , getChunks++    -- ** Write to Handle+    -- Byte stream write (Folds)+    , write+    , write2+    -- , writeUtf8+    -- , writeUtf8ByLines+    -- , writeByFrames+    -- , writeLines+    , writeWithBufferOf++    -- Byte stream write (Streams)+    , fromBytes+    , fromBytesWithBufferOf++    -- -- * Array Write+    , writeArray+    , writeChunks+    , writeChunksWithBufferOf++    -- -- * Array stream Write+    , fromChunksWithBufferOf+    , fromChunks+    , putChunks+    , putStrings+    -- , putLines++    -- -- * Random Access (Seek)+    -- -- | Unlike the streaming APIs listed above, these APIs apply to devices or+    -- files that have random access or seek capability.  This type of devices+    -- include disks, files, memory devices and exclude terminals, pipes,+    -- sockets and fifos.+    --+    -- XXX need to decide whether to use readFromStepN style or readFromThenTo+    -- style. The latter is consistent with list enumeration. The former may be+    -- more unambiguous and it is easier and clearer to specify 0 elements.+    --+    -- We can also generate the request pattern using a funciton.+    --+    -- , readIndex+    -- , readFrom -- read from a given position to the end of file+    -- , readFromRev -- read from a given position the beginning of file+    -- , readTo   -- read from beginning up to the given position+    -- , readToRev -- read from end to the given position in file+    -- , readFromTo+    -- , readFromThenTo++    -- , readChunksFrom+    -- , readChunksFromTo+    -- , readChunksFromToWithBufferOf+    -- , readChunksFromThenToWithBufferOf++    -- , writeIndex+    -- , writeFrom -- start writing at the given position+    -- , writeFromRev+    -- , writeTo   -- write from beginning up to the given position+    -- , writeToRev+    -- , writeFromTo+    -- , writeFromThenTo+    --+    -- , writeChunksFrom+    -- , writeChunksFromTo+    -- , writeChunksFromToWithBufferOf+    -- , writeChunksFromThenToWithBufferOf+    )+where++import Control.Monad.IO.Class (MonadIO(..))+import Data.Word (Word8)+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)+import Foreign.Ptr (minusPtr, plusPtr)+import Foreign.Storable (Storable(..))+import GHC.ForeignPtr (mallocPlainForeignPtrBytes)+import System.IO (Handle, hGetBufSome, hPutBuf, stdin, stdout)+import Prelude hiding (read)++import Streamly (MonadAsync)+import Streamly.Data.Fold (Fold)+import Streamly.Internal.Data.Fold.Types (Fold2(..))+import Streamly.Internal.Data.Unfold.Types (Unfold(..))+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.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+import qualified Streamly.Internal.Prelude as S+import qualified Streamly.Memory.Array as A+import qualified Streamly.Internal.Data.Stream.StreamD.Type as D++-------------------------------------------------------------------------------+-- References+-------------------------------------------------------------------------------+--+-- The following references may be useful to build an understanding about the+-- file API design:+--+-- http://www.linux-mag.com/id/308/ for blocking/non-blocking IO on linux.+-- https://lwn.net/Articles/612483/ Non-blocking buffered file read operations+-- https://en.wikipedia.org/wiki/C_file_input/output for C APIs.+-- https://docs.oracle.com/javase/tutorial/essential/io/file.html for Java API.+-- https://www.w3.org/TR/FileAPI/ for http file API.++-------------------------------------------------------------------------------+-- Array IO (Input)+-------------------------------------------------------------------------------++-- | Read a 'ByteArray' from a file handle. If no data is available on the+-- handle it blocks until some data becomes available. If data is available+-- then it immediately returns that data without blocking. It reads a maximum+-- of up to the size requested.+{-# INLINABLE readArrayUpto #-}+readArrayUpto :: Int -> Handle -> IO (Array Word8)+readArrayUpto size h = do+    ptr <- mallocPlainForeignPtrBytes size+    -- ptr <- mallocPlainForeignPtrAlignedBytes size (alignment (undefined :: Word8))+    withForeignPtr ptr $ \p -> do+        n <- hGetBufSome h p size+        let v = Array+                { aStart = ptr+                , aEnd   = p `plusPtr` n+                , aBound = p `plusPtr` size+                }+        -- XXX shrink only if the diff is significant+        shrinkToFit v++-------------------------------------------------------------------------------+-- Stream of Arrays IO+-------------------------------------------------------------------------------++-- | @toChunksWithBufferOf size h@ reads a stream of arrays from file handle @h@.+-- The maximum size of a single array is specified by @size@. The actual size+-- read may be less than or equal to @size@.+{-# INLINABLE _toChunksWithBufferOf #-}+_toChunksWithBufferOf :: (IsStream t, MonadIO m)+    => Int -> Handle -> t m (Array Word8)+_toChunksWithBufferOf size h = go+  where+    -- XXX use cons/nil instead+    go = mkStream $ \_ yld _ stp -> do+        arr <- liftIO $ readArrayUpto size h+        if A.length arr == 0+        then stp+        else yld arr go++-- | @toChunksWithBufferOf size handle@ reads a stream of arrays from the file+-- handle @handle@.  The maximum size of a single array is limited to @size@.+-- The actual size read may be less than or equal to @size@.+--+-- @since 0.7.0+{-# INLINE_NORMAL toChunksWithBufferOf #-}+toChunksWithBufferOf :: (IsStream t, MonadIO m) => Int -> Handle -> t m (Array Word8)+toChunksWithBufferOf size h = D.fromStreamD (D.Stream step ())+  where+    {-# INLINE_LATE step #-}+    step _ _ = do+        arr <- liftIO $ readArrayUpto size h+        return $+            case A.length arr of+                0 -> D.Stop+                _ -> D.Yield arr ()++-- | Unfold the tuple @(bufsize, handle)@ into a stream of 'Word8' arrays.+-- Read requests to the IO device are performed using a buffer of size+-- @bufsize@.  The size of an array in the resulting stream is always less than+-- or equal to @bufsize@.+--+-- @since 0.7.0+{-# INLINE_NORMAL readChunksWithBufferOf #-}+readChunksWithBufferOf :: MonadIO m => Unfold m (Int, Handle) (Array Word8)+readChunksWithBufferOf = Unfold step return+    where+    {-# INLINE_LATE step #-}+    step (size, h) = do+        arr <- liftIO $ readArrayUpto size h+        return $+            case A.length arr of+                0 -> D.Stop+                _ -> D.Yield arr (size, h)++-- XXX read 'Array a' instead of Word8+--+-- | @toChunks handle@ reads a stream of arrays from the specified file+-- handle.  The maximum size of a single array is limited to+-- @defaultChunkSize@. The actual size read may be less than or equal to+-- @defaultChunkSize@.+--+-- > toChunks = toChunksWithBufferOf defaultChunkSize+--+-- @since 0.7.0+{-# INLINE toChunks #-}+toChunks :: (IsStream t, MonadIO m) => Handle -> t m (Array Word8)+toChunks = toChunksWithBufferOf defaultChunkSize++-- | Read a stream of chunks from standard input.  The maximum size of a single+-- chunk is limited to @defaultChunkSize@. The actual size read may be less+-- than @defaultChunkSize@.+--+-- > getChunks = toChunks stdin+--+-- /Internal/+--+{-# INLINE getChunks #-}+getChunks :: (IsStream t, MonadIO m) => t m (Array Word8)+getChunks = toChunks stdin++-- | Read a stream of bytes from standard input.+--+-- > getBytes = toBytes stdin+--+-- /Internal/+--+{-# INLINE getBytes #-}+getBytes :: (IsStream t, MonadIO m) => t m Word8+getBytes = toBytes stdin++-- | Unfolds a handle into a stream of 'Word8' arrays. Requests to the IO+-- device are performed using a buffer of size+-- 'Streamly.Internal.Memory.Array.Types.defaultChunkSize'. The+-- size of arrays in the resulting stream are therefore less than or equal to+-- 'Streamly.Internal.Memory.Array.Types.defaultChunkSize'.+--+-- @since 0.7.0+{-# INLINE readChunks #-}+readChunks :: MonadIO m => Unfold m Handle (Array Word8)+readChunks = UF.supplyFirst readChunksWithBufferOf defaultChunkSize++-------------------------------------------------------------------------------+-- Read File to Stream+-------------------------------------------------------------------------------++-- TODO for concurrent streams implement readahead IO. We can send multiple+-- read requests at the same time. For serial case we can use async IO. We can+-- also control the read throughput in mbps or IOPS.++-- | Unfolds the tuple @(bufsize, handle)@ into a byte stream, read requests+-- to the IO device are performed using buffers of @bufsize@.+--+-- @since 0.7.0+{-# INLINE readWithBufferOf #-}+readWithBufferOf :: MonadIO m => Unfold m (Int, Handle) Word8+readWithBufferOf = UF.concat readChunksWithBufferOf A.read++-- | @toBytesWithBufferOf bufsize handle@ reads a byte stream from a file+-- handle, reads are performed in chunks of up to @bufsize@.+--+-- /Internal/+{-# INLINE toBytesWithBufferOf #-}+toBytesWithBufferOf :: (IsStream t, MonadIO m) => Int -> Handle -> t m Word8+toBytesWithBufferOf chunkSize h = AS.concat $ toChunksWithBufferOf chunkSize h++-- TODO+-- Generate a stream of elements of the given type from a file 'Handle'.+-- read :: (IsStream t, MonadIO m, Storable a) => Handle -> t m a+--+-- | Unfolds a file handle into a byte stream. IO requests to the device are+-- performed in sizes of+-- 'Streamly.Internal.Memory.Array.Types.defaultChunkSize'.+--+-- @since 0.7.0+{-# INLINE read #-}+read :: MonadIO m => Unfold m Handle Word8+read = UF.supplyFirst readWithBufferOf defaultChunkSize++-- | Generate a byte stream from a file 'Handle'.+--+-- /Internal/+{-# INLINE toBytes #-}+toBytes :: (IsStream t, MonadIO m) => Handle -> t m Word8+toBytes = AS.concat . toChunks++-------------------------------------------------------------------------------+-- Writing+-------------------------------------------------------------------------------++-------------------------------------------------------------------------------+-- Array IO (output)+-------------------------------------------------------------------------------++-- | Write an 'Array' to a file handle.+--+-- @since 0.7.0+{-# INLINABLE writeArray #-}+writeArray :: Storable a => Handle -> Array a -> IO ()+writeArray _ arr | A.length arr == 0 = return ()+writeArray h Array{..} = withForeignPtr aStart $ \p -> hPutBuf h p aLen+    where+    aLen =+        let p = unsafeForeignPtrToPtr aStart+        in aEnd `minusPtr` p++-------------------------------------------------------------------------------+-- Stream of Arrays IO+-------------------------------------------------------------------------------++-------------------------------------------------------------------------------+-- Writing+-------------------------------------------------------------------------------++-- | Write a stream of arrays to a handle.+--+-- @since 0.7.0+{-# INLINE fromChunks #-}+fromChunks :: (MonadIO m, Storable a)+    => Handle -> SerialT m (Array a) -> m ()+fromChunks h m = S.mapM_ (liftIO . writeArray h) m++-- | Write a stream of chunks to standard output.+--+-- /Internal/+--+{-# INLINE putChunks #-}+putChunks :: (MonadIO m, Storable a) => SerialT m (Array a) -> m ()+putChunks = fromChunks stdout++-- | Write a stream of strings to standard output using Latin1 encoding.+--+-- /Internal/+--+{-# INLINE putStrings #-}+putStrings :: MonadAsync m => SerialT m String -> m ()+putStrings = putChunks . S.mapM (IA.fromStream . U.encodeLatin1 . S.fromList)++-- | @fromChunksWithBufferOf bufsize handle stream@ writes a stream of arrays+-- to @handle@ after coalescing the adjacent arrays in chunks of @bufsize@.+-- The chunk size is only a maximum and the actual writes could be smaller as+-- we do not split the arrays to fit exactly to the specified size.+--+-- @since 0.7.0+{-# INLINE fromChunksWithBufferOf #-}+fromChunksWithBufferOf :: (MonadIO m, Storable a)+    => Int -> Handle -> SerialT m (Array a) -> m ()+fromChunksWithBufferOf n h xs = fromChunks h $ AS.compact n xs++-- | @fromBytesWithBufferOf bufsize handle stream@ writes @stream@ to @handle@+-- in chunks of @bufsize@.  A write is performed to the IO device as soon as we+-- collect the required input size.+--+-- @since 0.7.0+{-# INLINE fromBytesWithBufferOf #-}+fromBytesWithBufferOf :: MonadIO m => Int -> Handle -> SerialT m Word8 -> m ()+fromBytesWithBufferOf n h m = fromChunks h $ S.arraysOf n m+-- fromBytesWithBufferOf n h m = fromChunks h $ AS.arraysOf n m++-- > write = 'writeWithBufferOf' A.defaultChunkSize+--+-- | Write a byte stream to a file handle. Accumulates the input in chunks of+-- up to 'Streamly.Internal.Memory.Array.Types.defaultChunkSize' before writing.+--+-- NOTE: This may perform better than the 'write' fold, you can try this if you+-- need some extra perf boost.+--+-- @since 0.7.0+{-# INLINE fromBytes #-}+fromBytes :: MonadIO m => Handle -> SerialT m Word8 -> m ()+fromBytes = fromBytesWithBufferOf defaultChunkSize++-- | Write a stream of arrays to a handle. Each array in the stream is written+-- to the device as a separate IO request.+--+-- @since 0.7.0+{-# INLINE writeChunks #-}+writeChunks :: (MonadIO m, Storable a) => Handle -> Fold m (Array a) ()+writeChunks h = FL.drainBy (liftIO . writeArray h)++{-# INLINE writeChunks2 #-}+writeChunks2 :: (MonadIO m, Storable a) => Fold2 m Handle (Array a) ()+writeChunks2 = Fold2 (\h arr -> liftIO $ writeArray h arr >> return h) return (\_ -> return ())++-- | @writeChunksWithBufferOf bufsize handle@ writes a stream of arrays+-- to @handle@ 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 -> Handle -> Fold m (Array a) ()+writeChunksWithBufferOf n h = lpackArraysChunksOf n (writeChunks h)++-- GHC buffer size dEFAULT_FD_BUFFER_SIZE=8192 bytes.+--+-- XXX test this+-- Note that if you use a chunk size less than 8K (GHC's default buffer+-- size) then you are advised to use 'NOBuffering' mode on the 'Handle' in case you+-- do not want buffering to occur at GHC level as well. Same thing applies to+-- writes as well.++-- | @writeWithBufferOf reqSize handle@ writes the input stream to @handle@.+-- Bytes in the input stream are collected into a buffer until we have a chunk+-- of @reqSize@ and then written to the IO device.+--+-- @since 0.7.0+{-# INLINE writeWithBufferOf #-}+writeWithBufferOf :: MonadIO m => Int -> Handle -> Fold m Word8 ()+writeWithBufferOf n h = FL.lchunksOf n (writeNUnsafe n) (writeChunks h)++{-# INLINE writeWithBufferOf2 #-}+writeWithBufferOf2 :: MonadIO m => Int -> Fold2 m Handle Word8 ()+writeWithBufferOf2 n = FL.lchunksOf2 n (writeNUnsafe n) writeChunks2++-- > write = 'writeWithBufferOf' A.defaultChunkSize+--+-- | Write a byte stream to a file handle. Accumulates the input in chunks of+-- up to 'Streamly.Internal.Memory.Array.Types.defaultChunkSize' before writing+-- to the IO device.+--+-- @since 0.7.0+{-# INLINE write #-}+write :: MonadIO m => Handle -> Fold m Word8 ()+write = writeWithBufferOf defaultChunkSize++{-# INLINE write2 #-}+write2 :: MonadIO m => Fold2 m Handle Word8 ()+write2 = writeWithBufferOf2 defaultChunkSize++{-+{-# INLINE write #-}+write :: (MonadIO m, Storable a) => Handle -> SerialT m a -> m ()+write = toHandleWith A.defaultChunkSize+-}++-- XXX mmap a file into an array. This could be useful for in-place operations+-- on a file. For example, we can quicksort the contents of a file by mmapping+-- it.++-------------------------------------------------------------------------------+-- IO with encoding/decoding Unicode characters+-------------------------------------------------------------------------------++{-+-- |+-- > readUtf8 = decodeUtf8 . read+--+-- Read a UTF8 encoded stream of unicode characters from a file handle.+--+-- @since 0.7.0+{-# INLINE readUtf8 #-}+readUtf8 :: (IsStream t, MonadIO m) => Handle -> t m Char+readUtf8 = decodeUtf8 . read++-- |+-- > writeUtf8 h s = write h $ encodeUtf8 s+--+-- Encode a stream of unicode characters to UTF8 and write it to the given file+-- handle. Default block buffering applies to the writes.+--+-- @since 0.7.0+{-# INLINE writeUtf8 #-}+writeUtf8 :: MonadIO m => Handle -> SerialT m Char -> m ()+writeUtf8 h s = write h $ encodeUtf8 s++-- | Write a stream of unicode characters after encoding to UTF-8 in chunks+-- separated by a linefeed character @'\n'@. If the size of the buffer exceeds+-- @defaultChunkSize@ and a linefeed is not yet found, the buffer is written+-- anyway.  This is similar to writing to a 'Handle' with the 'LineBuffering'+-- option.+--+-- @since 0.7.0+{-# INLINE writeUtf8ByLines #-}+writeUtf8ByLines :: (IsStream t, MonadIO m) => Handle -> t m Char -> m ()+writeUtf8ByLines = undefined++-- | Read UTF-8 lines from a file handle and apply the specified fold to each+-- line. This is similar to reading a 'Handle' with the 'LineBuffering' option.+--+-- @since 0.7.0+{-# INLINE readLines #-}+readLines :: (IsStream t, MonadIO m) => Handle -> Fold m Char b -> t m b+readLines h f = foldLines (readUtf8 h) f++-------------------------------------------------------------------------------+-- Framing on a sequence+-------------------------------------------------------------------------------++-- | Read a stream from a file handle and split it into frames delimited by+-- the specified sequence of elements. The supplied fold is applied on each+-- frame.+--+-- @since 0.7.0+{-# INLINE readFrames #-}+readFrames :: (IsStream t, MonadIO m, Storable a)+    => Array a -> Handle -> Fold m a b -> t m b+readFrames = undefined -- foldFrames . read++-- | Write a stream to the given file handle buffering up to frames separated+-- by the given sequence or up to a maximum of @defaultChunkSize@.+--+-- @since 0.7.0+{-# INLINE writeByFrames #-}+writeByFrames :: (IsStream t, MonadIO m, Storable a)+    => Array a -> Handle -> t m a -> m ()+writeByFrames = undefined++-------------------------------------------------------------------------------+-- Framing by time+-------------------------------------------------------------------------------++-- | Write collecting the input in sessions of n seconds or if chunkSize+-- gets exceeded.+{-# INLINE writeByChunksOrSessionsOf #-}+writeByChunksOrSessionsOf :: MonadIO m+    => Int -> Double -> Handle -> SerialT m Word8 -> m ()+writeByChunksOrSessionsOf chunkSize sessionSize h m = undefined++-- | Write collecting the input in sessions of n seconds or if defaultChunkSize+-- gets exceeded.+{-# INLINE writeBySessionsOf #-}+writeBySessionsOf :: MonadIO m => Double -> Handle -> SerialT m Word8 -> m ()+writeBySessionsOf n = writeByChunksOrSessionsOf defaultChunkSize n++-------------------------------------------------------------------------------+-- Random Access IO (Seek)+-------------------------------------------------------------------------------++-- XXX handles could be shared, so we may not want to use the handle state at+-- all for these APIs. we can use pread and pwrite instead. On windows we will+-- need to use readFile/writeFile with an offset argument.++-------------------------------------------------------------------------------++-- | Read the element at the given index treating the file as an array.+--+-- @since 0.7.0+{-# INLINE readIndex #-}+readIndex :: Storable a => Handle -> Int -> Maybe a+readIndex arr i = undefined++-- NOTE: To represent a range to read we have chosen (start, size) instead of+-- (start, end). This helps in removing the ambiguity of whether "end" is+-- included in the range or not.+--+-- We could avoid specifying the range to be read and instead use "take size"+-- on the stream, but it may end up reading more and then consume it partially.++-- | @readSliceWith chunkSize handle pos len@ reads up to @len@ bytes+-- from @handle@ starting at the offset @pos@ from the beginning of the file.+--+-- Reads are performed in chunks of size @chunkSize@.  For block devices, to+-- avoid reading partial blocks @chunkSize@ must align with the block size of+-- the underlying device. If the underlying block size is unknown, it is a good+-- idea to keep it a multiple 4KiB. This API ensures that the start of each+-- chunk is aligned with @chunkSize@ from second chunk onwards.+--+{-# INLINE readSliceWith #-}+readSliceWith :: (IsStream t, MonadIO m, Storable a)+    => Int -> Handle -> Int -> Int -> t m a+readSliceWith chunkSize h pos len = undefined++-- | @readSlice h i count@ streams a slice from the file handle @h@ starting+-- at index @i@ and reading up to @count@ elements in the forward direction+-- ending at the index @i + count - 1@.+--+-- @since 0.7.0+{-# INLINE readSlice #-}+readSlice :: (IsStream t, MonadIO m, Storable a)+    => Handle -> Int -> Int -> t m a+readSlice = readSliceWith A.defaultChunkSize++-- | @readSliceRev h i count@ streams a slice from the file handle @h@ starting+-- at index @i@ and reading up to @count@ elements in the reverse direction+-- ending at the index @i - count + 1@.+--+-- @since 0.7.0+{-# INLINE readSliceRev #-}+readSliceRev :: (IsStream t, MonadIO m, Storable a)+    => Handle -> Int -> Int -> t m a+readSliceRev h i count = undefined++-- | Write the given element at the given index in the file.+--+-- @since 0.7.0+{-# INLINE writeIndex #-}+writeIndex :: (MonadIO m, Storable a) => Handle -> Int -> a -> m ()+writeIndex h i a = undefined++-- | @writeSlice h i count stream@ writes a stream to the file handle @h@+-- starting at index @i@ and writing up to @count@ elements in the forward+-- direction ending at the index @i + count - 1@.+--+-- @since 0.7.0+{-# INLINE writeSlice #-}+writeSlice :: (IsStream t, Monad m, Storable a)+    => Handle -> Int -> Int -> t m a -> m ()+writeSlice h i len s = undefined++-- | @writeSliceRev h i count stream@ writes a stream to the file handle @h@+-- starting at index @i@ and writing up to @count@ elements in the reverse+-- direction ending at the index @i - count + 1@.+--+-- @since 0.7.0+{-# INLINE writeSliceRev #-}+writeSliceRev :: (IsStream t, Monad m, Storable a)+    => Handle -> Int -> Int -> t m a -> m ()+writeSliceRev arr i len s = undefined+-}
+ src/Streamly/Internal/Memory/Array.hs view
@@ -0,0 +1,468 @@+{-# OPTIONS_HADDOCK hide         #-}+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE MagicHash           #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE UnboxedTuples       #-}+{-# LANGUAGE ScopedTypeVariables #-}++#include "inline.hs"++-- |+-- Module      : Streamly.Internal.Memory.Array+-- Copyright   : (c) 2019 Composewell Technologies+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+-- To summarize:+--+--  * Arrays are finite and fixed in size+--  * provide /O(1)/ access to elements+--  * store only data and not functions+--  * provide efficient IO interfacing+--+-- 'Foldable' instance is not provided because the implementation would be much+-- less efficient compared to folding via streams.  'Semigroup' and 'Monoid'+-- instances should be used with care; concatenating arrays using binary+-- operations can be highly inefficient.  Instead, use+-- 'Streamly.Internal.Memory.ArrayStream.toArray' to concatenate N arrays at+-- once.+--+-- Each array is one pointer visible to the GC.  Too many small arrays (e.g.+-- single byte) are only as good as holding those elements in a Haskell list.+-- However, small arrays can be compacted into large ones to reduce the+-- overhead. To hold 32GB memory in 32k sized buffers we need 1 million arrays+-- if we use one array for each chunk. This is still significant to add+-- pressure to GC.++module Streamly.Internal.Memory.Array+    (+      Array++    -- , defaultChunkSize++    -- * Construction++    -- Pure List APIs+    , A.fromListN+    , A.fromList++    -- Stream Folds+    , fromStreamN+    , fromStream++    -- Monadic APIs+    -- , newArray+    , A.writeN      -- drop new+    , A.write       -- full buffer+    -- , writeLastN -- drop old (ring buffer)++    -- * Elimination++    , A.toList+    , toStream+    , toStreamRev+    , read+    -- , readChunksOf++    -- * Random Access+    , length+    , null+    , last+    -- , (!!)+    , readIndex+    -- , readIndices+    -- , readRanges++    -- , readFrom    -- read from a given position to the end of file+    -- , readFromRev -- read from a given position to the beginning of file+    -- , readTo      -- read from beginning up to the given position+    -- , readToRev   -- read from end to the given position in file+    -- , readFromTo+    -- , readFromThenTo++    -- , readChunksOfFrom+    -- , ...++    -- , writeIndex+    -- , writeFrom -- start writing at the given position+    -- , writeFromRev+    -- , writeTo   -- write from beginning up to the given position+    -- , writeToRev+    -- , writeFromTo+    -- , writeFromThenTo+    --+    -- , writeChunksOfFrom+    -- , ...++    , writeIndex+    --, writeIndices+    --, writeRanges++    -- -- * Search+    -- , bsearch+    -- , bsearchIndex+    -- , find+    -- , findIndex+    -- , findIndices++    -- -- * In-pace mutation (for Mutable Array type)+    -- , partitionBy+    -- , shuffleBy+    -- , foldtWith+    -- , foldbWith++    -- * Immutable Transformations+    , streamTransform++    -- * Folding Arrays+    , streamFold+    , fold+    )+where++import Control.Monad.IO.Class (MonadIO(..))+-- import Data.Functor.Identity (Identity)+import Foreign.ForeignPtr (withForeignPtr, touchForeignPtr)+import Foreign.Ptr (plusPtr)+import Foreign.Storable (Storable(..))+import Prelude hiding (length, null, last, map, (!!), read, concat)++import GHC.ForeignPtr (ForeignPtr(..))+import GHC.Ptr (Ptr(..))++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 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++-------------------------------------------------------------------------------+-- Construction+-------------------------------------------------------------------------------++{-+-- | Create a new uninitialized array of given length.+--+-- @since 0.7.0+newArray :: (MonadIO m, Storable a) => Int -> m (Array a)+newArray len = undefined+-}++-- | Create an 'Array' 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.+--+-- /Internal/+{-# INLINE fromStreamN #-}+fromStreamN :: (MonadIO m, Storable a) => Int -> SerialT m a -> m (Array a)+fromStreamN n m = do+    if n < 0 then error "writeN: negative write count specified" else return ()+    A.fromStreamDN n $ D.toStreamD m++-- | Create an 'Array' from a stream. This is useful when we want to create a+-- single array from a stream of unknown size. 'writeN' is at least twice+-- as efficient when the size is already known.+--+-- Note that if the input stream is too large memory allocation for the array+-- may fail.  When the stream size is not known, `arraysOf` followed by+-- processing of indvidual arrays in the resulting stream should be preferred.+--+-- /Internal/+{-# INLINE fromStream #-}+fromStream :: (MonadIO m, Storable a) => SerialT m a -> m (Array a)+fromStream = P.runFold A.write+-- write m = A.fromStreamD $ D.toStreamD m++-------------------------------------------------------------------------------+-- Elimination+-------------------------------------------------------------------------------++-- | Convert an 'Array' into a stream.+--+-- /Internal/+{-# INLINE_EARLY toStream #-}+toStream :: (Monad m, K.IsStream t, Storable a) => Array a -> t m a+toStream = D.fromStreamD . A.toStreamD+-- XXX add fallback to StreamK rule+-- {-# RULES "Streamly.Array.read fallback to StreamK" [1]+--     forall a. S.readK (read a) = K.fromArray a #-}++-- | Convert an 'Array' into a stream in reverse order.+--+-- /Internal/+{-# INLINE_EARLY toStreamRev #-}+toStreamRev :: (Monad m, IsStream t, Storable a) => Array a -> t m a+toStreamRev = D.fromStreamD . A.toStreamDRev+-- XXX add fallback to StreamK rule+-- {-# RULES "Streamly.Array.readRev fallback to StreamK" [1]+--     forall a. S.toStreamK (readRev a) = K.revFromArray a #-}++data ReadUState a = ReadUState+    {-# UNPACK #-} !(ForeignPtr a)  -- foreign ptr with end of array pointer+    {-# UNPACK #-} !(Ptr a)         -- current pointer++-- | Unfold an array into a stream.+--+-- @since 0.7.0+{-# INLINE_NORMAL read #-}+read :: forall m a. (Monad m, Storable a) => Unfold m (Array a) a+read = Unfold step inject+    where++    inject (Array (ForeignPtr start contents) (Ptr end) _) =+        return $ ReadUState (ForeignPtr end contents) (Ptr start)++    {-# INLINE_LATE step #-}+    step (ReadUState fp@(ForeignPtr end _) p) | p == (Ptr end) =+        let x = A.unsafeInlineIO $ touchForeignPtr fp+        in x `seq` return D.Stop+    step (ReadUState fp p) = 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 $ peek p+            return $ D.Yield x+                (ReadUState fp (p `plusPtr` (sizeOf (undefined :: a))))++-- | > null arr = length arr == 0+--+-- /Internal/+{-# INLINE null #-}+null :: Storable a => Array a -> Bool+null arr = length arr == 0++-- | > last arr = readIndex arr (length arr - 1)+--+-- /Internal/+{-# INLINE last #-}+last :: Storable a => Array a -> Maybe a+last arr = readIndex arr (length arr - 1)++-------------------------------------------------------------------------------+-- Random Access+-------------------------------------------------------------------------------++-------------------------------------------------------------------------------+-- Searching+-------------------------------------------------------------------------------++{-+-- | Perform a binary search in the array to find an element.+bsearch :: a -> Array a -> Maybe Bool+bsearch = undefined++-- | Perform a binary search in the array to find an element index.+{-# INLINE elemIndex #-}+bsearchIndex :: a -> Array a -> Maybe Int+bsearchIndex elem arr = undefined++-- find/findIndex etc can potentially be implemented more efficiently on arrays+-- compared to streams by using SIMD instructions.++find :: (a -> Bool) -> Array a -> Bool+find = undefined++findIndex :: (a -> Bool) -> Array a -> Maybe Int+findIndex = undefined++findIndices :: (a -> Bool) -> Array a -> Array Int+findIndices = undefined+-}++-------------------------------------------------------------------------------+-- Folds+-------------------------------------------------------------------------------++-- XXX We can potentially use SIMD instructions on arrays to fold faster.++-------------------------------------------------------------------------------+-- Slice and splice+-------------------------------------------------------------------------------++{-+slice :: Int -> Int -> Array a+slice begin end arr = undefined++splitAt :: Int -> Array a -> (Array a, Array a)+splitAt i arr = undefined++-- XXX This operation can be performed efficiently via streams.+-- | Append two arrays together to create a single array.+splice :: Array a -> Array a -> Array a+splice arr1 arr2 = undefined++-------------------------------------------------------------------------------+-- In-place mutation APIs+-------------------------------------------------------------------------------++-- | Partition an array into two halves using a partitioning predicate. The+-- first half retains values where the predicate is 'False' and the second half+-- retains values where the predicate is 'True'.+{-# INLINE partitionBy #-}+partitionBy :: (a -> Bool) -> Array a -> (Array a, Array a)+partitionBy f arr = undefined++-- | Shuffle corresponding elements from two arrays using a shuffle function.+-- If the shuffle function returns 'False' then do nothing otherwise swap the+-- elements. This can be used in a bottom up fold to shuffle or reorder the+-- elements.+shuffleBy :: (a -> a -> m Bool) -> Array a -> Array a -> m (Array a)+shuffleBy f arr1 arr2 = undefined++-- XXX we can also make the folds partial by stopping at a certain level.+--+-- | Perform a top down hierarchical recursive partitioning fold of items in+-- the container using the given function as the partition function.+--+-- This will perform a quick sort if the partition function is+-- 'partitionBy (< pivot)'.+--+-- @since 0.7.0+{-# INLINABLE foldtWith #-}+foldtWith :: Int -> (Array a -> Array a -> m (Array a)) -> Array a -> m (Array a)+foldtWith level f = undefined++-- | Perform a pairwise bottom up fold recursively merging the pairs. Level+-- indicates the level in the tree where the fold would stop.+--+-- This will perform a random shuffle if the shuffle function is random.+-- If we stop at level 0 and repeatedly apply the function then we can do a+-- bubble sort.+foldbWith :: Int -> (Array a -> Array a -> m (Array a)) -> Array a -> m (Array a)+foldbWith level f = undefined+-}++-- XXX consider the bulk update/accumulation/permutation APIs from vector.++-------------------------------------------------------------------------------+-- Random reads and writes+-------------------------------------------------------------------------------++-- | /O(1)/ Lookup the element at the given index, starting from 0.+--+-- /Internal/+{-# INLINE readIndex #-}+readIndex :: Storable a => Array a -> Int -> Maybe a+readIndex arr i =+    if i < 0 || i > length arr - 1+        then Nothing+        else A.unsafeInlineIO $+             withForeignPtr (aStart arr) $ \p -> fmap Just $ peekElemOff p i++{-+-- | @readSlice arr i count@ streams a slice of the array @arr@ starting+-- at index @i@ and reading up to @count@ elements in the forward direction+-- ending at the index @i + count - 1@.+--+-- @since 0.7.0+{-# INLINE readSlice #-}+readSlice :: (IsStream t, Monad m, Storable a)+    => Array a -> Int -> Int -> t m a+readSlice arr i len = undefined++-- | @readSliceRev arr i count@ streams a slice of the array @arr@ starting at+-- index @i@ and reading up to @count@ elements in the reverse direction ending+-- at the index @i - count + 1@.+--+-- @since 0.7.0+{-# INLINE readSliceRev #-}+readSliceRev :: (IsStream t, Monad m, Storable a)+    => Array a -> Int -> Int -> t m a+readSliceRev arr i len = undefined+-}++-- | /O(1)/ Write the given element at the given index in the array.+-- Performs in-place mutation of the array.+--+-- /Internal/+{-# INLINE writeIndex #-}+writeIndex :: (MonadIO m, Storable a) => Array a -> Int -> a -> m ()+writeIndex arr i a = do+    let maxIndex = length arr - 1+    if i < 0+    then error "writeIndex: negative array index"+    else if i > maxIndex+         then error $ "writeIndex: specified array index " ++ show i+                    ++ " is beyond the maximum index " ++ show maxIndex+         else+            liftIO $ withForeignPtr (aStart arr) $ \p ->+                pokeElemOff p i a++{-+-- | @writeSlice arr i count stream@ writes a stream to the array @arr@+-- starting at index @i@ and writing up to @count@ elements in the forward+-- direction ending at the index @i + count - 1@.+--+-- @since 0.7.0+{-# INLINE writeSlice #-}+writeSlice :: (IsStream t, Monad m, Storable a)+    => Array a -> Int -> Int -> t m a -> m ()+writeSlice arr i len s = undefined++-- | @writeSliceRev arr i count stream@ writes a stream to the array @arr@+-- starting at index @i@ and writing up to @count@ elements in the reverse+-- direction ending at the index @i - count + 1@.+--+-- @since 0.7.0+{-# INLINE writeSliceRev #-}+writeSliceRev :: (IsStream t, Monad m, Storable a)+    => Array a -> Int -> Int -> t m a -> m ()+writeSliceRev arr i len s = undefined+-}++-------------------------------------------------------------------------------+-- Transform via stream operations+-------------------------------------------------------------------------------++-- for non-length changing operations we can use the original length for+-- allocation. If we can predict the length then we can use the prediction for+-- new allocation. Otherwise we can use a hint and adjust dynamically.++{-+-- | Transform an array into another array using a pipe transformation+-- operation.+--+-- @since 0.7.0+{-# INLINE runPipe #-}+runPipe :: (MonadIO m, Storable a, Storable b)+    => Pipe m a b -> Array a -> m (Array b)+runPipe f arr = P.runPipe (toArrayMinChunk (length arr)) $ f (A.read arr)+-}++-- | Transform an array into another array using a stream transformation+-- operation.+--+-- /Internal/+{-# INLINE streamTransform #-}+streamTransform :: forall m a b. (MonadIO m, Storable a, Storable b)+    => (SerialT m a -> SerialT m b) -> Array a -> m (Array b)+streamTransform f arr =+    P.runFold (A.toArrayMinChunk (alignment (undefined :: a)) (length arr))+        $ f (toStream arr)++-- | Fold an array using a 'Fold'.+--+-- /Internal/+{-# INLINE fold #-}+fold :: forall m a b. (MonadIO m, Storable a) => Fold m a b -> Array a -> m b+fold f arr = P.runFold f $ (toStream arr :: Serial.SerialT m a)++-- | Fold an array using a stream fold operation.+--+-- /Internal/+{-# INLINE streamFold #-}+streamFold :: (MonadIO m, Storable a) => (SerialT m a -> m b) -> Array a -> m b+streamFold f arr = f (toStream arr)
+ src/Streamly/Internal/Memory/Array/Types.hs view
@@ -0,0 +1,1358 @@+{-# OPTIONS_HADDOCK hide               #-}+{-# LANGUAGE CPP                       #-}+{-# LANGUAGE BangPatterns              #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE MagicHash                 #-}+{-# LANGUAGE RecordWildCards           #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE UnboxedTuples             #-}+{-# LANGUAGE FlexibleContexts          #-}+#include "inline.hs"++-- |+-- Module      : Streamly.Internal.Memory.Array.Types+-- Copyright   : (c) 2019 Composewell Technologies+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+module Streamly.Internal.Memory.Array.Types+    (+      Array (..)++    -- * Construction+    , withNewArray+    , newArray+    , unsafeSnoc+    , snoc+    , spliceWithDoubling+    , spliceTwo++    , fromList+    , fromListN+    , fromStreamDN+    -- , fromStreamD++    -- * Streams of arrays+    , fromStreamDArraysOf+    , FlattenState (..) -- for inspection testing+    , flattenArrays+    , flattenArraysRev+    , packArraysChunksOf+    , lpackArraysChunksOf+#if !defined(mingw32_HOST_OS)+    , groupIOVecsOf+#endif+    , splitOn+    , breakOn++    -- * Elimination+    , unsafeIndexIO+    , unsafeIndex+    , length+    , byteLength+    , byteCapacity+    , foldl'+    , foldr+    , splitAt++    , toStreamD+    , toStreamDRev+    , toStreamK+    , toStreamKRev+    , toList+    , toArrayMinChunk+    , writeN+    , writeNUnsafe+    , writeNAligned+    , writeNAlignedUnmanaged+    , write+    , writeAligned++    -- * Utilities+    , defaultChunkSize+    , mkChunkSize+    , mkChunkSizeKB+    , unsafeInlineIO+    , realloc+    , shrinkToFit+    , memcpy+    , memcmp+    , bytesToElemCount++    , unlines+    )+where++import Control.Exception (assert)+import Control.DeepSeq (NFData(..))+import Control.Monad (when)+import Control.Monad.IO.Class (MonadIO(..))+import Data.Functor.Identity (runIdentity)+#if __GLASGOW_HASKELL__ < 808+import Data.Semigroup (Semigroup(..))+#endif+import Data.Word (Word8)+import Foreign.C.String (CString)+import Foreign.C.Types (CSize(..), CInt(..))+import Foreign.ForeignPtr (withForeignPtr, touchForeignPtr)+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)+import Foreign.Ptr (plusPtr, minusPtr, castPtr, nullPtr)+import Foreign.Storable (Storable(..))+import Prelude hiding (length, foldr, read, unlines, splitAt)+import Text.Read (readPrec, readListPrec, readListPrecDefault)++import GHC.Base (Addr#, nullAddr#, realWorld#, build)+import GHC.Exts (IsList, IsString(..))+import GHC.ForeignPtr (ForeignPtr(..), newForeignPtr_)+import GHC.IO (IO(IO), unsafePerformIO)+import GHC.Ptr (Ptr(..))++import Streamly.Internal.Data.Fold.Types (Fold(..))+import Streamly.Internal.Data.Strict (Tuple'(..))+import Streamly.Internal.Data.SVar (adaptState)++#if !defined(mingw32_HOST_OS)+import Streamly.FileSystem.FDIO (IOVec(..))+#endif++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 GHC.Exts as Exts++#ifdef DEVBUILD+import qualified Data.Foldable as F+#endif++#if MIN_VERSION_base(4,10,0)+import Foreign.ForeignPtr (plusForeignPtr)+#else+import GHC.Base (Int(..), plusAddr#)+import GHC.ForeignPtr (ForeignPtr(..))+plusForeignPtr :: ForeignPtr a -> Int -> ForeignPtr b+plusForeignPtr (ForeignPtr addr c) (I# d) = ForeignPtr (plusAddr# addr d) c+#endif++-------------------------------------------------------------------------------+-- Design Notes+-------------------------------------------------------------------------------++-- There are two goals that we want to fulfill with arrays.  One, holding large+-- amounts of data in non-GC memory and the ability to pass this data to and+-- from the operating system without an extra copy overhead. Two, allow random+-- access to elements based on their indices. The first one falls in the+-- category of storage buffers while the second one falls in the category of+-- maps/multisets/hashmaps.+--+-- For the first requirement we use an array of Storables and store it in a+-- ForeignPtr. We can have both immutable and mutable variants of this array+-- using wrappers over the same underlying type.+--+-- For the second requirement, we need a separate type for arrays of+-- polymorphic values, for example vectors of handler functions, lookup tables.+-- We can call this type a "vector" in contrast to arrays.  It should not+-- require Storable instance for the type. In that case we need to use an+-- Array# instead of a ForeignPtr. This type of array would not reduce the GC+-- overhead much because each element of the array still needs to be scanned by+-- the GC.  However, it can store polymorphic elements and allow random access+-- to those.  But in most cases random access means storage, and it means we+-- need to avoid GC scanning except in cases of trivially small storage. One+-- way to achieve that would be to put the array in a Compact region. However,+-- if and when we mutate this, we will have to use a manual GC copying out to+-- another CR and freeing the old one.++-------------------------------------------------------------------------------+-- Array Data Type+-------------------------------------------------------------------------------++-- We require that an array stores only Storable. Arrays are used for buffering+-- data while streams are used for processing. If you want something to be+-- buffered it better be Storable so that we can store it in non-GC memory.+--+-- We can use a "Storable" constraint in the Array type and the Constraint can+-- be automatically provided to a function that pattern matches on the Array+-- type. However, it has huge performance cost, so we do not use it.+-- XXX Can this cost be alleviated in GHC-8.10 specialization fix?+--+-- XXX Another way to not require the Storable constraint in array operations+-- is to store the elemSize in the array at construction and use that instead+-- of using sizeOf. Need to charaterize perf cost of this.+--+-- XXX rename the fields to "start, next, end".+--+data Array a =+#ifdef DEVBUILD+    Storable a =>+#endif+    Array+    { aStart :: {-# UNPACK #-} !(ForeignPtr a) -- first address+    , aEnd   :: {-# UNPACK #-} !(Ptr a)        -- first unused address+    , aBound :: {-# UNPACK #-} !(Ptr a)        -- first address beyond allocated memory+    }++-------------------------------------------------------------------------------+-- Utility functions+-------------------------------------------------------------------------------++foreign import ccall unsafe "string.h memcpy" c_memcpy+    :: Ptr Word8 -> Ptr Word8 -> CSize -> IO (Ptr Word8)++foreign import ccall unsafe "string.h strlen" c_strlen+    :: CString -> IO CSize++foreign import ccall unsafe "string.h memchr" c_memchr+    :: Ptr Word8 -> Word8 -> CSize -> IO (Ptr Word8)++-- XXX we are converting Int to CSize+memcpy :: Ptr Word8 -> Ptr Word8 -> Int -> IO ()+memcpy dst src len = c_memcpy dst src (fromIntegral len) >> return ()++foreign import ccall unsafe "string.h memcmp" c_memcmp+    :: Ptr Word8 -> Ptr Word8 -> CSize -> IO CInt++-- XXX we are converting Int to CSize+-- return True if the memory locations have identical contents+{-# INLINE memcmp #-}+memcmp :: Ptr Word8 -> Ptr Word8 -> Int -> IO Bool+memcmp p1 p2 len = do+    r <- c_memcmp p1 p2 (fromIntegral len)+    return $ r == 0++{-# INLINE unsafeInlineIO #-}+unsafeInlineIO :: IO a -> a+unsafeInlineIO (IO m) = case m realWorld# of (# _, r #) -> r++{-# INLINE bytesToElemCount #-}+bytesToElemCount :: Storable a => a -> Int -> Int+bytesToElemCount x n =+    let elemSize = sizeOf x+    in n + elemSize - 1 `div` elemSize++-------------------------------------------------------------------------------+-- Construction+-------------------------------------------------------------------------------++-- | allocate a new array using the provided allocator function.+{-# INLINE newArrayAlignedAllocWith #-}+newArrayAlignedAllocWith :: forall a. Storable a+    => (Int -> Int -> IO (ForeignPtr a)) -> Int -> Int -> IO (Array a)+newArrayAlignedAllocWith alloc alignSize count = do+    let size = count * sizeOf (undefined :: a)+    fptr <- alloc size alignSize+    let p = unsafeForeignPtrToPtr fptr+    return $ Array+        { aStart = fptr+        , aEnd   = p+        , aBound = p `plusPtr` size+        }++-- | Allocate a new array aligned to the specified alignmend and using+-- unmanaged pinned memory. The memory will not be automatically freed by GHC.+-- This could be useful in allocate once global data structures. Use carefully+-- as incorrect use can lead to memory leak.+{-# INLINE newArrayAlignedUnmanaged #-}+newArrayAlignedUnmanaged :: forall a. Storable a => Int -> Int -> IO (Array a)+newArrayAlignedUnmanaged =+    newArrayAlignedAllocWith Malloc.mallocForeignPtrAlignedUnmanagedBytes++{-# INLINE newArrayAligned #-}+newArrayAligned :: forall a. Storable a => Int -> Int -> IO (Array a)+newArrayAligned = newArrayAlignedAllocWith Malloc.mallocForeignPtrAlignedBytes++-- XXX can unaligned allocation be more efficient when alignment is not needed?+--+-- | Allocate an array that can hold 'count' items.  The memory of the array is+-- uninitialized.+--+-- Note that this is internal routine, the reference to this array cannot be+-- given out until the array has been written to and frozen.+{-# INLINE newArray #-}+newArray :: forall a. Storable a => Int -> IO (Array a)+newArray = newArrayAligned (alignment (undefined :: a))++-- | Allocate an Array of the given size and run an IO action passing the array+-- start pointer.+{-# INLINE withNewArray #-}+withNewArray :: forall a. Storable a => Int -> (Ptr a -> IO ()) -> IO (Array a)+withNewArray count f = do+    arr <- newArray count+    withForeignPtr (aStart arr) $ \p -> f p >> return arr++-- XXX grow the array when we are beyond bound.+--+-- 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.+{-# INLINE unsafeSnoc #-}+unsafeSnoc :: forall a. Storable a => Array a -> a -> IO (Array a)+unsafeSnoc arr@Array{..} x = do+    when (aEnd == aBound) $+        error "BUG: unsafeSnoc: writing beyond array bounds"+    poke aEnd x+    touchForeignPtr aStart+    return $ arr {aEnd = aEnd `plusPtr` (sizeOf (undefined :: a))}++{-# INLINE snoc #-}+snoc :: forall a. Storable a => Array a -> a -> IO (Array a)+snoc arr@Array {..} x = do+    if (aEnd == aBound)+    then do+        let oldStart = unsafeForeignPtrToPtr aStart+            size = aEnd `minusPtr` oldStart+            newSize = (size + (sizeOf (undefined :: a)))+        newPtr <- Malloc.mallocForeignPtrAlignedBytes+                    newSize (alignment (undefined :: a))+        withForeignPtr newPtr $ \pNew -> do+          memcpy (castPtr pNew) (castPtr oldStart) size+          poke (pNew `plusPtr` size) x+          touchForeignPtr aStart+          return $ Array+              { aStart = newPtr+              , aEnd   = pNew `plusPtr` (size + sizeOf (undefined :: a))+              , aBound = pNew `plusPtr` newSize+              }+    else do+        poke aEnd x+        touchForeignPtr aStart+        return $ arr {aEnd = aEnd `plusPtr` (sizeOf (undefined :: a))}++-- | Reallocate the array to the specified size in bytes. If the size is less+-- than the original array the array gets truncated.+{-# NOINLINE reallocAligned #-}+reallocAligned :: Int -> Int -> Array a -> IO (Array a)+reallocAligned alignSize newSize Array{..} = do+    assert (aEnd <= aBound) (return ())+    let oldStart = unsafeForeignPtrToPtr aStart+    let size = aEnd `minusPtr` oldStart+    newPtr <- Malloc.mallocForeignPtrAlignedBytes newSize alignSize+    withForeignPtr newPtr $ \pNew -> do+        memcpy (castPtr pNew) (castPtr oldStart) size+        touchForeignPtr aStart+        return $ Array+            { aStart = newPtr+            , aEnd   = pNew `plusPtr` size+            , aBound = pNew `plusPtr` newSize+            }++-- XXX can unaligned allocation be more efficient when alignment is not needed?+{-# INLINABLE realloc #-}+realloc :: forall a. Storable a => Int -> Array a -> IO (Array a)+realloc = reallocAligned (alignment (undefined :: a))++-- | Remove the free space from an Array.+shrinkToFit :: forall a. Storable a => Array a -> IO (Array a)+shrinkToFit arr@Array{..} = do+    assert (aEnd <= aBound) (return ())+    let start = unsafeForeignPtrToPtr aStart+    let used = aEnd `minusPtr` start+        waste = aBound `minusPtr` aEnd+    -- if used == waste == 0 then do not realloc+    -- if the wastage is more than 25% of the array then realloc+    if used < 3 * waste+    then realloc used arr+    else return arr++-- XXX when converting an array of Word8 from a literal string we can simply+-- refer to the literal string. Is it possible to write rules such that+-- fromList Word8 can be rewritten so that GHC does not first convert the+-- literal to [Char] and then we convert it back to an Array Word8?+--+-- Note that the address must be a read-only address (meant to be used for+-- read-only string literals) because we are sharing it, any modification to+-- the original address would change our array. That's why this function is+-- unsafe.+{-# INLINE _fromCStringAddrUnsafe #-}+_fromCStringAddrUnsafe :: Addr# -> IO (Array Word8)+_fromCStringAddrUnsafe addr# = do+    ptr <- newForeignPtr_ (castPtr cstr)+    len <- c_strlen cstr+    let n = fromIntegral len+    let p = unsafeForeignPtrToPtr ptr+    let end = p `plusPtr` n+    return $ Array+        { aStart = ptr+        , aEnd   = end+        , aBound = end+        }+  where+    cstr :: CString+    cstr = Ptr addr#++-------------------------------------------------------------------------------+-- Elimination+-------------------------------------------------------------------------------++-- | Return element at the specified index without checking the bounds.+--+-- Unsafe because it does not check the bounds of the array.+{-# INLINE_NORMAL unsafeIndexIO #-}+unsafeIndexIO :: forall a. Storable a => Array a -> Int -> IO a+unsafeIndexIO Array {..} i =+     withForeignPtr aStart $ \p -> do+        let elemSize = sizeOf (undefined :: a)+            elemOff = p `plusPtr` (elemSize * i)+        assert (i >= 0 && elemOff `plusPtr` elemSize <= aEnd)+               (return ())+        peek elemOff++-- | Return element at the specified index without checking the bounds.+{-# INLINE_NORMAL unsafeIndex #-}+unsafeIndex :: forall a. Storable a => Array a -> Int -> a+unsafeIndex arr i = let !r = unsafeInlineIO $ unsafeIndexIO arr i in r++-- | /O(1)/ Get the byte length of the array.+--+-- @since 0.7.0+{-# INLINE byteLength #-}+byteLength :: Array a -> Int+byteLength Array{..} =+    let p = unsafeForeignPtrToPtr aStart+        len = aEnd `minusPtr` p+    in assert (len >= 0) len++-- | /O(1)/ Get the length of the array i.e. the number of elements in the+-- array.+--+-- @since 0.7.0+{-# INLINE length #-}+length :: forall a. Storable a => Array a -> Int+length arr = byteLength arr `div` sizeOf (undefined :: a)++{-# INLINE byteCapacity #-}+byteCapacity :: Array a -> Int+byteCapacity Array{..} =+    let p = unsafeForeignPtrToPtr aStart+        len = aBound `minusPtr` p+    in assert (len >= 0) len++{-# INLINE_NORMAL toStreamD #-}+toStreamD :: forall m a. (Monad m, Storable a) => Array a -> D.Stream m a+toStreamD Array{..} =+    let p = unsafeForeignPtrToPtr aStart+    in D.Stream step p++    where++    {-# INLINE_LATE step #-}+    step _ p | p == aEnd = return D.Stop+    step _ p = 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 = unsafeInlineIO $ do+                    r <- peek p+                    touchForeignPtr aStart+                    return r+        return $ D.Yield x (p `plusPtr` (sizeOf (undefined :: a)))++{-# INLINE toStreamK #-}+toStreamK :: forall t m a. (K.IsStream t, Storable a) => Array a -> t m a+toStreamK Array{..} =+    let p = unsafeForeignPtrToPtr aStart+    in go p++    where++    go p | p == aEnd = K.nil+         | otherwise =+        -- See Note in toStreamD.+        let !x = unsafeInlineIO $ do+                    r <- peek p+                    touchForeignPtr aStart+                    return r+        in x `K.cons` go (p `plusPtr` (sizeOf (undefined :: a)))++{-# INLINE_NORMAL toStreamDRev #-}+toStreamDRev :: forall m a. (Monad m, Storable a) => Array a -> D.Stream m a+toStreamDRev Array{..} =+    let p = aEnd `plusPtr` negate (sizeOf (undefined :: a))+    in D.Stream step p++    where++    {-# INLINE_LATE step #-}+    step _ p | p < unsafeForeignPtrToPtr aStart = return D.Stop+    step _ p = do+        -- See comments in toStreamD for why we use unsafeInlineIO+        let !x = unsafeInlineIO $ do+                    r <- peek p+                    touchForeignPtr aStart+                    return r+        return $ D.Yield x (p `plusPtr` negate (sizeOf (undefined :: a)))++{-# INLINE toStreamKRev #-}+toStreamKRev :: forall t m a. (K.IsStream t, Storable a) => Array a -> t m a+toStreamKRev Array {..} =+    let p = aEnd `plusPtr` negate (sizeOf (undefined :: a))+    in go p++    where++    go p | p < unsafeForeignPtrToPtr aStart = K.nil+         | otherwise =+        let !x = unsafeInlineIO $ do+                    r <- peek p+                    touchForeignPtr aStart+                    return r+        in x `K.cons` go (p `plusPtr` negate (sizeOf (undefined :: a)))++{-# INLINE_NORMAL foldl' #-}+foldl' :: forall a b. Storable a => (b -> a -> b) -> b -> Array a -> b+foldl' f z arr = runIdentity $ D.foldl' f z $ toStreamD arr++{-# INLINE_NORMAL foldr #-}+foldr :: Storable a => (a -> b -> b) -> b -> Array a -> b+foldr f z arr = runIdentity $ D.foldr f z $ toStreamD arr++-------------------------------------------------------------------------------+-- Instances+-------------------------------------------------------------------------------++{-# INLINE_NORMAL writeNAllocWith #-}+writeNAllocWith :: forall m a. (MonadIO m, Storable a)+    => (Int -> IO (Array a)) -> Int -> Fold m a (Array a)+writeNAllocWith alloc n = Fold step initial extract++    where++    initial = liftIO $ alloc (max n 0)+    step arr@(Array _ end bound) _ | end == bound = return arr+    step (Array start end bound) x = do+        liftIO $ poke end x+        return $ Array start (end `plusPtr` sizeOf (undefined :: a)) bound+    -- XXX note that shirkToFit does not maintain alignment, in case we are+    -- using aligned allocation.+    extract = return -- liftIO . shrinkToFit++-- | @writeN n@ folds a maximum of @n@ elements from the input stream to an+-- 'Array'.+--+-- @since 0.7.0+{-# INLINE_NORMAL writeN #-}+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+-- stream to an 'Array' aligned to the given size.+--+-- /Internal/+--+{-# INLINE_NORMAL writeNAligned #-}+writeNAligned :: forall m a. (MonadIO m, Storable a)+    => Int -> Int -> Fold m a (Array a)+writeNAligned alignSize = writeNAllocWith (newArrayAligned alignSize)++-- | @writeNAlignedUnmanaged n@ folds a maximum of @n@ elements from the input+-- stream to an 'Array' aligned to the given size and using unmanaged memory.+-- This could be useful to allocate memory that we need to allocate only once+-- in the lifetime of the program.+--+-- /Internal/+--+{-# INLINE_NORMAL writeNAlignedUnmanaged #-}+writeNAlignedUnmanaged :: forall m a. (MonadIO m, Storable a)+    => Int -> Int -> Fold m a (Array a)+writeNAlignedUnmanaged alignSize =+    writeNAllocWith (newArrayAlignedUnmanaged alignSize)++data ArrayUnsafe a = ArrayUnsafe+    {-# UNPACK #-} !(ForeignPtr a) -- first address+    {-# UNPACK #-} !(Ptr a)        -- first unused address++-- | Like 'writeN' but does not check the array bounds when writing. The fold+-- driver must not call the step function more than 'n' times otherwise it will+-- corrupt the memory and crash. This function exists mainly because any+-- conditional in the step function blocks fusion causing 10x performance+-- slowdown.+--+-- @since 0.7.0+{-# INLINE_NORMAL writeNUnsafe #-}+writeNUnsafe :: forall m a. (MonadIO m, Storable a)+    => Int -> Fold m a (Array a)+writeNUnsafe n = Fold step initial extract++    where++    initial = do+        (Array start end _) <- liftIO $ newArray (max n 0)+        return $ ArrayUnsafe start end+    step (ArrayUnsafe start end) x = do+        liftIO $ poke end x+        return $ (ArrayUnsafe start (end `plusPtr` sizeOf (undefined :: a)))+    extract (ArrayUnsafe start end) = return $ Array start end end -- liftIO . shrinkToFit++-- XXX The realloc based implementation needs to make one extra copy if we use+-- shrinkToFit.  On the other hand, the stream of arrays implementation may+-- buffer the array chunk pointers in memory but it does not have to shrink as+-- we know the exact size in the end. However, memory copying does not seems to+-- be as expensive as the allocations. Therefore, we need to reduce the number+-- of allocations instead. Also, the size of allocations matters, right sizing+-- an allocation even at the cost of copying sems to help.  Should be measured+-- on a big stream with heavy calls to toArray to see the effect.+--+-- XXX check if GHC's memory allocator is efficient enough. We can try the C+-- malloc to compare against.++{-# INLINE_NORMAL toArrayMinChunk #-}+toArrayMinChunk :: forall m a. (MonadIO m, Storable a)+    => Int -> Int -> Fold m a (Array a)+-- toArrayMinChunk n = FL.mapM spliceArrays $ toArraysOf n+toArrayMinChunk alignSize elemCount = Fold step initial extract++    where++    insertElem (Array start end bound) x = do+        liftIO $ poke end x+        return $ Array start (end `plusPtr` sizeOf (undefined :: a)) bound++    initial = do+        when (elemCount < 0) $ error "toArrayMinChunk: elemCount is negative"+        liftIO $ newArrayAligned alignSize elemCount+    step arr@(Array start end bound) x | end == bound = do+        let p = unsafeForeignPtrToPtr start+            oldSize = end `minusPtr` p+            newSize = max (oldSize * 2) 1+        arr1 <- liftIO $ reallocAligned alignSize newSize arr+        insertElem arr1 x+    step arr x = insertElem arr x+    extract = liftIO . shrinkToFit++-- | Fold the whole input to a single array.+--+-- /Caution! Do not use this on infinite streams./+--+-- @since 0.7.0+{-# INLINE write #-}+write :: forall m a. (MonadIO m, Storable a) => Fold m a (Array a)+write = toArrayMinChunk (alignment (undefined :: a))+                        (bytesToElemCount (undefined :: a)+                        (mkChunkSize 1024))++-- | Like 'write' but the array memory is aligned according to the specified+-- alignment size. This could be useful when we have specific alignment, for+-- example, cache aligned arrays for lookup table etc.+--+-- /Caution! Do not use this on infinite streams./+--+-- @since 0.7.0+{-# INLINE writeAligned #-}+writeAligned :: forall m a. (MonadIO m, Storable a)+    => Int -> Fold m a (Array a)+writeAligned alignSize =+    toArrayMinChunk alignSize+                    (bytesToElemCount (undefined :: a)+                    (mkChunkSize 1024))++{-# INLINE_NORMAL fromStreamDN #-}+fromStreamDN :: forall m a. (MonadIO m, Storable a)+    => Int -> D.Stream m a -> m (Array a)+fromStreamDN limit str = do+    arr <- liftIO $ newArray limit+    end <- D.foldlM' fwrite (aEnd arr) $ D.take limit str+    return $ arr {aEnd = end}++    where++    fwrite ptr x = do+        liftIO $ poke ptr x+        return $ ptr `plusPtr` sizeOf (undefined :: a)++data GroupState s start end bound+    = GroupStart s+    | GroupBuffer s start end bound+    | GroupYield start end bound (GroupState s start end bound)+    | GroupFinish++-- | @fromStreamArraysOf n stream@ groups the input stream into a stream of+-- arrays of size n.+{-# INLINE_NORMAL fromStreamDArraysOf #-}+fromStreamDArraysOf :: forall m a. (MonadIO m, Storable a)+    => Int -> D.Stream m a -> D.Stream m (Array a)+-- fromStreamDArraysOf n str = D.groupsOf n (writeN n) str+fromStreamDArraysOf n (D.Stream step state) =+    D.Stream step' (GroupStart state)++    where++    {-# INLINE_LATE step' #-}+    step' _ (GroupStart st) = do+        when (n <= 0) $+            -- XXX we can pass the module string from the higher level API+            error $ "Streamly.Internal.Memory.Array.Types.fromStreamDArraysOf: the size of "+                 ++ "arrays [" ++ show n ++ "] must be a natural number"+        Array start end bound <- liftIO $ newArray n+        return $ D.Skip (GroupBuffer st start end bound)++    step' gst (GroupBuffer st start end bound) = do+        r <- step (adaptState gst) st+        case r of+            D.Yield x s -> do+                liftIO $ poke end x+                let end' = end `plusPtr` sizeOf (undefined :: a)+                return $+                    if end' >= bound+                    then D.Skip (GroupYield start end' bound (GroupStart s))+                    else D.Skip (GroupBuffer s start end' bound)+            D.Skip s -> return $ D.Skip (GroupBuffer s start end bound)+            D.Stop -> return $ D.Skip (GroupYield start end bound GroupFinish)++    step' _ (GroupYield start end bound next) =+        return $ D.Yield (Array start end bound) next++    step' _ GroupFinish = return D.Stop++-- XXX concatMap does not seem to have the best possible performance so we have+-- a custom way to concat arrays.+data FlattenState s a =+      OuterLoop s+    | InnerLoop s !(ForeignPtr a) !(Ptr a) !(Ptr a)++{-# INLINE_NORMAL flattenArrays #-}+flattenArrays :: forall m a. (MonadIO m, Storable a)+    => D.Stream m (Array a) -> D.Stream m a+flattenArrays (D.Stream step state) = D.Stream step' (OuterLoop state)++    where++    {-# INLINE_LATE step' #-}+    step' gst (OuterLoop st) = do+        r <- step (adaptState gst) st+        return $ case r of+            D.Yield Array{..} s ->+                let p = unsafeForeignPtrToPtr aStart+                in D.Skip (InnerLoop s aStart p aEnd)+            D.Skip s -> D.Skip (OuterLoop s)+            D.Stop -> D.Stop++    step' _ (InnerLoop st _ p end) | p == end =+        return $ D.Skip $ OuterLoop st++    step' _ (InnerLoop st startf p end) = do+        x <- liftIO $ do+                    r <- peek p+                    touchForeignPtr startf+                    return r+        return $ D.Yield x (InnerLoop st startf+                            (p `plusPtr` (sizeOf (undefined :: a))) end)++{-# INLINE_NORMAL flattenArraysRev #-}+flattenArraysRev :: forall m a. (MonadIO m, Storable a)+    => D.Stream m (Array a) -> D.Stream m a+flattenArraysRev (D.Stream step state) = D.Stream step' (OuterLoop state)++    where++    {-# INLINE_LATE step' #-}+    step' gst (OuterLoop st) = do+        r <- step (adaptState gst) st+        return $ case r of+            D.Yield Array{..} s ->+                let p = aEnd `plusPtr` negate (sizeOf (undefined :: a))+                -- XXX we do not need aEnd+                in D.Skip (InnerLoop s aStart p aEnd)+            D.Skip s -> D.Skip (OuterLoop s)+            D.Stop -> D.Stop++    step' _ (InnerLoop st start p _) | p < unsafeForeignPtrToPtr start =+        return $ D.Skip $ OuterLoop st++    step' _ (InnerLoop st startf p end) = do+        x <- liftIO $ do+                    r <- peek p+                    touchForeignPtr startf+                    return r+        return $ D.Yield x (InnerLoop st startf+                            (p `plusPtr` negate (sizeOf (undefined :: a))) end)++-- CAUTION: a very large number (millions) of arrays can degrade performance+-- due to GC overhead because we need to buffer the arrays before we flatten+-- all the arrays.+--+-- We could take the approach of doubling the memory allocation on each+-- overflow. This would result in more or less the same amount of copying as in+-- the chunking approach. However, if we have to shrink in the end then it may+-- result in an extra copy of the entire data.+--+{-# INLINE fromStreamD #-}+fromStreamD :: (MonadIO m, Storable a) => D.Stream m a -> m (Array a)+fromStreamD m = do+    let s = fromStreamDArraysOf defaultChunkSize m+    buffered <- D.foldr K.cons K.nil s+    len <- K.foldl' (+) 0 (K.map length buffered)+    fromStreamDN len $ flattenArrays $ D.fromStreamK buffered+{-+fromStreamD m = runFold write m+    where+    runFold (Fold step begin done) = D.foldlMx' step begin done+-}++-- Use foldr/build fusion to fuse with list consumers+-- This can be useful when using the IsList instance+{-# INLINE_LATE toListFB #-}+toListFB :: forall a b. Storable a => (a -> b -> b) -> b -> Array a -> b+toListFB c n Array{..} = go (unsafeForeignPtrToPtr aStart)+    where++    go p | p == aEnd = n+    go p =+        -- 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 = unsafeInlineIO $ do+                    r <- peek p+                    touchForeignPtr aStart+                    return r+        in c x (go (p `plusPtr` (sizeOf (undefined :: a))))++-- | Convert an 'Array' into a list.+--+-- @since 0.7.0+{-# INLINE toList #-}+toList :: Storable a => Array a -> [a]+toList s = build (\c n -> toListFB c n s)++instance (Show a, Storable a) => Show (Array a) where+    {-# INLINE showsPrec #-}+    showsPrec _ = shows . toList++-- | Create an 'Array' from the first N elements of a list. The array is+-- allocated to size N, if the list terminates before N elements then the+-- array may hold less than N elements.+--+-- @since 0.7.0+{-# INLINABLE fromListN #-}+fromListN :: Storable a => Int -> [a] -> Array a+fromListN n xs = unsafePerformIO $ fromStreamDN n $ D.fromList xs++-- | Create an 'Array' from a list. The list must be of finite size.+--+-- @since 0.7.0+{-# INLINABLE fromList #-}+fromList :: Storable a => [a] -> Array a+fromList xs = unsafePerformIO $ fromStreamD $ D.fromList xs++instance (Storable a, Read a, Show a) => Read (Array a) where+    {-# INLINE readPrec #-}+    readPrec = do+          xs <- readPrec+          return (fromList xs)+    readListPrec = readListPrecDefault++instance (a ~ Char) => IsString (Array a) where+    {-# INLINE fromString #-}+    fromString = fromList++-- GHC versions 8.0 and below cannot derive IsList+instance Storable a => IsList (Array a) where+    type (Item (Array a)) = a+    {-# INLINE fromList #-}+    fromList = fromList+    {-# INLINE fromListN #-}+    fromListN = fromListN+    {-# INLINE toList #-}+    toList = toList++{-# INLINE arrcmp #-}+arrcmp :: Array a -> Array a -> Bool+arrcmp arr1 arr2 =+    let !res = unsafeInlineIO $ do+            let ptr1 = unsafeForeignPtrToPtr $ aStart arr1+            let ptr2 = unsafeForeignPtrToPtr $ aStart arr2+            let len1 = aEnd arr1 `minusPtr` ptr1+            let len2 = aEnd arr2 `minusPtr` ptr2++            if len1 == len2+            then do+                r <- memcmp (castPtr ptr1) (castPtr ptr2) len1+                touchForeignPtr $ aStart arr1+                touchForeignPtr $ aStart arr2+                return r+            else return False+    in res++-- XXX we are assuming that Storable equality means element equality. This may+-- or may not be correct? arrcmp is 40% faster compared to stream equality.+instance (Storable a, Eq a) => Eq (Array a) where+    {-# INLINE (==) #-}+    (==) = arrcmp+    -- arr1 == arr2 = runIdentity $ D.eqBy (==) (toStreamD arr1) (toStreamD arr2)++instance (Storable a, NFData a) => NFData (Array a) where+    {-# INLINE rnf #-}+    rnf = foldl' (\_ x -> rnf x) ()++instance (Storable a, Ord a) => Ord (Array a) where+    {-# INLINE compare #-}+    compare arr1 arr2 = unsafePerformIO $+        D.cmpBy compare (toStreamD arr1) (toStreamD arr2)++    -- Default definitions defined in base do not have an INLINE on them, so we+    -- replicate them here with an INLINE.+    {-# 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 }++    -- These two default methods use '<=' rather than 'compare'+    -- because the latter is often more expensive+    {-# INLINE max #-}+    max x y = if x <= y then y else x++    {-# INLINE min #-}+    min x y = if x <= y then x else y++#ifdef DEVBUILD+-- Definitions using the Storable constraint from the Array type. These are to+-- make the Foldable instance possible though it is much slower (7x slower).+--+{-# INLINE_NORMAL toStreamD_ #-}+toStreamD_ :: forall m a. MonadIO m => Int -> Array a -> D.Stream m a+toStreamD_ size Array{..} =+    let p = unsafeForeignPtrToPtr aStart+    in D.Stream step p++    where++    {-# INLINE_LATE step #-}+    step _ p | p == aEnd = return D.Stop+    step _ p = do+        x <- liftIO $ do+                    r <- peek p+                    touchForeignPtr aStart+                    return r+        return $ D.Yield x (p `plusPtr` size)++{-# INLINE_NORMAL _foldr #-}+_foldr :: forall a b. (a -> b -> b) -> b -> Array a -> b+_foldr f z arr@Array {..} =+    let !n = sizeOf (undefined :: a)+    in unsafePerformIO $ D.foldr f z $ toStreamD_ n arr++-- | Note that the 'Foldable' instance is 7x slower than the direct+-- operations.+instance Foldable Array where+  foldr = _foldr+#endif++-------------------------------------------------------------------------------+-- Semigroup and Monoid+-------------------------------------------------------------------------------++-- Splice two immutable arrays creating a new array.+{-# INLINE spliceTwo #-}+spliceTwo :: (MonadIO m, Storable a) => Array a -> Array a -> m (Array a)+spliceTwo arr1 arr2 = do+    let src1 = unsafeForeignPtrToPtr (aStart arr1)+        src2 = unsafeForeignPtrToPtr (aStart arr2)+        len1 = aEnd arr1 `minusPtr` src1+        len2 = aEnd arr2 `minusPtr` src2++    arr <- liftIO $ newArray (len1 + len2)+    let dst = unsafeForeignPtrToPtr (aStart arr)++    -- XXX Should we use copyMutableByteArray# instead? Is there an overhead to+    -- ccall?+    liftIO $ do+        memcpy (castPtr dst) (castPtr src1) len1+        touchForeignPtr (aStart arr1)+        memcpy (castPtr (dst `plusPtr` len1)) (castPtr src2) len2+        touchForeignPtr (aStart arr2)+    return arr { aEnd = dst `plusPtr` (len1 + len2) }++instance Storable a => Semigroup (Array a) where+    arr1 <> arr2 = unsafePerformIO $ spliceTwo arr1 arr2++nullForeignPtr :: ForeignPtr a+nullForeignPtr = ForeignPtr nullAddr# (error "nullForeignPtr")++nil ::+#ifdef DEVBUILD+    Storable a =>+#endif+    Array a+nil = Array nullForeignPtr (Ptr nullAddr#) (Ptr nullAddr#)++instance Storable a => Monoid (Array a) where+    mempty = nil+    mappend = (<>)++-------------------------------------------------------------------------------+-- IO+-------------------------------------------------------------------------------++-- | GHC memory management allocation header overhead+allocOverhead :: Int+allocOverhead = 2 * sizeOf (undefined :: Int)++mkChunkSize :: Int -> Int+mkChunkSize n = let size = n - allocOverhead in max size 0++mkChunkSizeKB :: Int -> Int+mkChunkSizeKB n = mkChunkSize (n * k)+   where k = 1024++-- | Default maximum buffer size in bytes, for reading from and writing to IO+-- devices, the value is 32KB minus GHC allocation overhead, which is a few+-- bytes, so that the actual allocation is 32KB.+defaultChunkSize :: Int+defaultChunkSize = mkChunkSizeKB 32++{-# INLINE_NORMAL unlines #-}+unlines :: forall m a. (MonadIO m, Storable a)+    => a -> D.Stream m (Array a) -> D.Stream m a+unlines sep (D.Stream step state) = D.Stream step' (OuterLoop state)+    where+    {-# INLINE_LATE step' #-}+    step' gst (OuterLoop st) = do+        r <- step (adaptState gst) st+        return $ case r of+            D.Yield Array{..} s ->+                let p = unsafeForeignPtrToPtr aStart+                in D.Skip (InnerLoop s aStart p aEnd)+            D.Skip s -> D.Skip (OuterLoop s)+            D.Stop -> D.Stop++    step' _ (InnerLoop st _ p end) | p == end =+        return $ D.Yield sep $ OuterLoop st++    step' _ (InnerLoop st startf p end) = do+        x <- liftIO $ do+                    r <- peek p+                    touchForeignPtr startf+                    return r+        return $ D.Yield x (InnerLoop st startf+                            (p `plusPtr` (sizeOf (undefined :: a))) end)++-- Splice an array into a pre-reserved mutable array.  The user must ensure+-- that there is enough space in the mutable array.+{-# INLINE spliceWith #-}+spliceWith :: (MonadIO m) => Array a -> Array a -> m (Array a)+spliceWith dst@(Array _ end bound) src  = liftIO $ do+    let srcLen = byteLength src+    if end `plusPtr` srcLen > bound+    then error "Bug: spliceIntoUnsafe: Not enough space in the target array"+    else+        withForeignPtr (aStart dst) $ \_ -> do+            withForeignPtr (aStart src) $ \psrc -> do+                let pdst = aEnd dst+                memcpy (castPtr pdst) (castPtr psrc) srcLen+                return $ dst { aEnd = pdst `plusPtr` srcLen }++-- Splice a new array into a preallocated mutable array, doubling the space if+-- there is no space in the target array.+{-# INLINE spliceWithDoubling #-}+spliceWithDoubling :: (MonadIO m, Storable a)+    => Array a -> Array a -> m (Array a)+spliceWithDoubling dst@(Array start end bound) src  = do+    assert (end <= bound) (return ())+    let srcLen = aEnd src `minusPtr` unsafeForeignPtrToPtr (aStart src)++    dst1 <-+        if end `plusPtr` srcLen >= bound+        then do+            let oldStart = unsafeForeignPtrToPtr start+                oldSize = end `minusPtr` oldStart+                newSize = max (oldSize * 2) (oldSize + srcLen)+            liftIO $ realloc newSize dst+        else return dst+    spliceWith dst1 src++data SpliceState s arr+    = SpliceInitial s+    | SpliceBuffering s arr+    | SpliceYielding arr (SpliceState s arr)+    | SpliceFinish++-- XXX can use general grouping combinators to achieve this?+-- | Coalesce adjacent arrays in incoming stream to form bigger arrays of a+-- maximum specified size. Note that if a single array is bigger than the+-- specified size we do not split it to fit. When we coalesce multiple arrays+-- if the size would exceed the specified size we do not coalesce therefore the+-- actual array size may be less than the specified chunk size.+--+-- @since 0.7.0+{-# INLINE_NORMAL packArraysChunksOf #-}+packArraysChunksOf :: (MonadIO m, Storable a)+    => Int -> D.Stream m (Array a) -> D.Stream m (Array a)+packArraysChunksOf n (D.Stream step state) =+    D.Stream step' (SpliceInitial state)++    where++    {-# INLINE_LATE step' #-}+    step' gst (SpliceInitial st) = do+        when (n <= 0) $+            -- XXX we can pass the module string from the higher level API+            error $ "Streamly.Internal.Memory.Array.Types.packArraysChunksOf: the size of "+                 ++ "arrays [" ++ show n ++ "] must be a natural number"+        r <- step gst st+        case r of+            D.Yield arr s -> return $+                let len = byteLength arr+                 in if len >= n+                    then D.Skip (SpliceYielding arr (SpliceInitial s))+                    else D.Skip (SpliceBuffering s arr)+            D.Skip s -> return $ D.Skip (SpliceInitial s)+            D.Stop -> return $ D.Stop++    step' gst (SpliceBuffering st buf) = do+        r <- step gst st+        case r of+            D.Yield arr s -> do+                let len = byteLength buf + byteLength arr+                if len > n+                then return $+                    D.Skip (SpliceYielding buf (SpliceBuffering s arr))+                else do+                    buf' <- if byteCapacity buf < n+                            then liftIO $ realloc n buf+                            else return buf+                    buf'' <- spliceWith buf' arr+                    return $ D.Skip (SpliceBuffering s buf'')+            D.Skip s -> return $ D.Skip (SpliceBuffering s buf)+            D.Stop -> return $ D.Skip (SpliceYielding buf SpliceFinish)++    step' _ SpliceFinish = return D.Stop++    step' _ (SpliceYielding arr next) = return $ D.Yield arr next++-- XXX instead of writing two different versions of this operation, we should+-- write it as a pipe.+{-# INLINE_NORMAL lpackArraysChunksOf #-}+lpackArraysChunksOf :: (MonadIO m, Storable a)+    => Int -> Fold m (Array a) () -> Fold m (Array a) ()+lpackArraysChunksOf n (Fold step1 initial1 extract1) =+    Fold step initial extract++    where++    initial = do+        when (n <= 0) $+            -- XXX we can pass the module string from the higher level API+            error $ "Streamly.Internal.Memory.Array.Types.packArraysChunksOf: the size of "+                 ++ "arrays [" ++ show n ++ "] must be a natural number"+        r1 <- initial1+        return (Tuple' Nothing r1)++    extract (Tuple' Nothing r1) = extract1 r1+    extract (Tuple' (Just buf) r1) = do+        r <- step1 r1 buf+        extract1 r++    step (Tuple' Nothing r1) arr = do+            let len = byteLength arr+             in if len >= n+                then do+                    r <- step1 r1 arr+                    extract1 r+                    r1' <- initial1+                    return (Tuple' Nothing r1')+                else return (Tuple' (Just arr) r1)++    step (Tuple' (Just buf) r1) arr = do+            let len = byteLength buf + byteLength arr+            buf' <- if byteCapacity buf < len+                    then liftIO $ realloc (max n len) buf+                    else return buf+            buf'' <- spliceWith buf' arr++            if len >= n+            then do+                r <- step1 r1 buf''+                extract1 r+                r1' <- initial1+                return (Tuple' Nothing r1')+            else return (Tuple' (Just buf'') r1)++#if !defined(mingw32_HOST_OS)+data GatherState s arr+    = GatherInitial s+    | GatherBuffering s arr Int+    | GatherYielding arr (GatherState s arr)+    | GatherFinish++-- | @groupIOVecsOf maxBytes maxEntries@ groups arrays in the incoming stream+-- to create a stream of 'IOVec' arrays with a maximum of @maxBytes@ bytes in+-- each array and a maximum of @maxEntries@ entries in each array.+--+-- @since 0.7.0+{-# INLINE_NORMAL groupIOVecsOf #-}+groupIOVecsOf :: MonadIO m+    => Int -> Int -> D.Stream m (Array a) -> D.Stream m (Array IOVec)+groupIOVecsOf n maxIOVLen (D.Stream step state) =+    D.Stream step' (GatherInitial state)++    where++    {-# INLINE_LATE step' #-}+    step' gst (GatherInitial st) = do+        when (n <= 0) $+            -- XXX we can pass the module string from the higher level API+            error $ "Streamly.Internal.Memory.Array.Types.groupIOVecsOf: the size of "+                 ++ "groups [" ++ show n ++ "] must be a natural number"+        when (maxIOVLen <= 0) $+            -- XXX we can pass the module string from the higher level API+            error $ "Streamly.Internal.Memory.Array.Types.groupIOVecsOf: the number of "+                 ++ "IOVec entries [" ++ show n ++ "] must be a natural number"+        r <- step (adaptState gst) st+        case r of+            D.Yield arr s -> do+                let p = unsafeForeignPtrToPtr (aStart arr)+                    len = byteLength arr+                iov <- liftIO $ newArray maxIOVLen+                iov' <- liftIO $ unsafeSnoc iov (IOVec (castPtr p)+                                                (fromIntegral len))+                if len >= n+                then return $ D.Skip (GatherYielding iov' (GatherInitial s))+                else return $ D.Skip (GatherBuffering s iov' len)+            D.Skip s -> return $ D.Skip (GatherInitial s)+            D.Stop -> return $ D.Stop++    step' gst (GatherBuffering st iov len) = do+        r <- step (adaptState gst) st+        case r of+            D.Yield arr s -> do+                let p = unsafeForeignPtrToPtr (aStart arr)+                    alen = byteLength arr+                    len' = len + alen+                if len' > n || length iov >= maxIOVLen+                then do+                    iov' <- liftIO $ newArray maxIOVLen+                    iov'' <- liftIO $ unsafeSnoc iov' (IOVec (castPtr p)+                                                      (fromIntegral alen))+                    return $ D.Skip (GatherYielding iov+                                        (GatherBuffering s iov'' alen))+                else do+                    iov' <- liftIO $ unsafeSnoc iov (IOVec (castPtr p)+                                                    (fromIntegral alen))+                    return $ D.Skip (GatherBuffering s iov' len')+            D.Skip s -> return $ D.Skip (GatherBuffering s iov len)+            D.Stop -> return $ D.Skip (GatherYielding iov GatherFinish)++    step' _ GatherFinish = return D.Stop++    step' _ (GatherYielding iov next) = return $ D.Yield iov next+#endif++-- | Create two slices of an array without copying the original array. The+-- specified index @i@ is the first index of the second slice.+--+-- @since 0.7.0+splitAt :: forall a. Storable a => Int -> Array a -> (Array a, Array a)+splitAt i arr@Array{..} =+    let maxIndex = length arr - 1+    in  if i < 0+        then error "sliceAt: negative array index"+        else if i > maxIndex+             then error $ "sliceAt: specified array index " ++ show i+                        ++ " is beyond the maximum index " ++ show maxIndex+             else let off = i * sizeOf (undefined :: a)+                      p = unsafeForeignPtrToPtr aStart `plusPtr` off+                in ( Array+                  { aStart = aStart+                  , aEnd = p+                  , aBound = p+                  }+                , Array+                  { aStart = aStart `plusForeignPtr` off+                  , aEnd = aEnd+                  , aBound = aBound+                  }+                )++-- Drops the separator byte+{-# INLINE breakOn #-}+breakOn :: MonadIO m+    => Word8 -> Array Word8 -> m (Array Word8, Maybe (Array Word8))+breakOn sep arr@Array{..} = liftIO $ do+    let p = unsafeForeignPtrToPtr aStart+    loc <- c_memchr p sep (fromIntegral $ aEnd `minusPtr` p)+    return $+        if loc == nullPtr+        then (arr, Nothing)+        else+            ( Array+                { aStart = aStart+                , aEnd = loc+                , aBound = loc+                }+            , Just $ Array+                    { aStart = aStart `plusForeignPtr` (loc `minusPtr` p + 1)+                    , aEnd = aEnd+                    , aBound = aBound+                    }+            )++data SplitState s arr+    = Initial s+    | Buffering s arr+    | Splitting s arr+    | Yielding arr (SplitState s arr)+    | Finishing++-- | Split a stream of arrays on a given separator byte, dropping the separator+-- and coalescing all the arrays between two separators into a single array.+--+-- @since 0.7.0+{-# INLINE_NORMAL splitOn #-}+splitOn+    :: MonadIO m+    => Word8+    -> D.Stream m (Array Word8)+    -> D.Stream m (Array Word8)+splitOn byte (D.Stream step state) = D.Stream step' (Initial state)++    where++    {-# INLINE_LATE step' #-}+    step' gst (Initial st) = do+        r <- step gst st+        case r of+            D.Yield arr s -> do+                (arr1, marr2) <- breakOn byte arr+                return $ case marr2 of+                    Nothing   -> D.Skip (Buffering s arr1)+                    Just arr2 -> D.Skip (Yielding arr1 (Splitting s arr2))+            D.Skip s -> return $ D.Skip (Initial s)+            D.Stop -> return $ D.Stop++    step' gst (Buffering st buf) = do+        r <- step gst st+        case r of+            D.Yield arr s -> do+                (arr1, marr2) <- breakOn byte arr+                buf' <- spliceTwo buf arr1+                return $ case marr2 of+                    Nothing -> D.Skip (Buffering s buf')+                    Just x -> D.Skip (Yielding buf' (Splitting s x))+            D.Skip s -> return $ D.Skip (Buffering s buf)+            D.Stop -> return $+                if byteLength buf == 0+                then D.Stop+                else D.Skip (Yielding buf Finishing)++    step' _ (Splitting st buf) = do+        (arr1, marr2) <- breakOn byte buf+        return $ case marr2 of+                Nothing -> D.Skip $ Buffering st arr1+                Just arr2 -> D.Skip $ Yielding arr1 (Splitting st arr2)++    step' _ (Yielding arr next) = return $ D.Yield arr next+    step' _ Finishing = return $ D.Stop
+ src/Streamly/Internal/Memory/ArrayStream.hs view
@@ -0,0 +1,225 @@+{-# OPTIONS_HADDOCK hide         #-}+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE MagicHash           #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE UnboxedTuples       #-}+{-# LANGUAGE ScopedTypeVariables #-}++#include "inline.hs"++-- |+-- Module      : Streamly.Internal.Memory.ArrayStream+-- Copyright   : (c) 2019 Composewell Technologies+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+-- Combinators to efficiently manipulate streams of arrays.+--+module Streamly.Internal.Memory.ArrayStream+    (+    -- * Creation+      arraysOf++    -- * Flattening to elements+    , concat+    , concatRev+    , interpose+    , interposeSuffix+    , intercalateSuffix++    -- * Transformation+    , splitOn+    , splitOnSuffix+    , compact -- compact++    -- * Elimination+    , toArray+    )+where++import Control.Monad.IO.Class (MonadIO(..))+-- import Data.Functor.Identity (Identity)+import Data.Word (Word8)+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Ptr (minusPtr, plusPtr, castPtr)+import Foreign.Storable (Storable(..))+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 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++-- XXX efficiently compare two streams of arrays. Two streams can have chunks+-- of different sizes, we can handle that in the stream comparison abstraction.+-- This could be useful e.g. to fast compare whether two files differ.++-- | Convert a stream of arrays into a stream of their elements.+--+-- Same as the following but more efficient:+--+-- > concat = S.concatMap A.read+--+-- @since 0.7.0+{-# INLINE concat #-}+concat :: (IsStream t, MonadIO m, Storable a) => t m (Array a) -> t m a+-- concat m = D.fromStreamD $ A.flattenArrays (D.toStreamD m)+-- concat m = D.fromStreamD $ D.concatMap A.toStreamD (D.toStreamD m)+concat m = D.fromStreamD $ D.concatMapU A.read (D.toStreamD m)++-- XXX should we have a reverseArrays API to reverse the stream of arrays+-- instead?+--+-- | Convert a stream of arrays into a stream of their elements reversing the+-- contents of each array before flattening.+--+-- @since 0.7.0+{-# INLINE concatRev #-}+concatRev :: (IsStream t, MonadIO m, Storable a) => t m (Array a) -> t m a+concatRev m = D.fromStreamD $ A.flattenArraysRev (D.toStreamD m)++-- | Flatten a stream of arrays after inserting the given element between+-- arrays.+--+-- /Internal/+{-# INLINE interpose #-}+interpose :: (MonadIO m, IsStream t, Storable a) => a -> t m (Array a) -> t m a+interpose x = S.interpose x A.read++{-# INLINE intercalateSuffix #-}+intercalateSuffix :: (MonadIO m, IsStream t, Storable a)+    => Array a -> t m (Array a) -> t m a+intercalateSuffix arr = S.intercalateSuffix arr A.read++-- | Flatten a stream of arrays appending the given element after each+-- array.+--+-- @since 0.7.0+{-# INLINE interposeSuffix #-}+interposeSuffix :: (MonadIO m, IsStream t, Storable a)+    => a -> t m (Array a) -> t m a+-- interposeSuffix x = D.fromStreamD . A.unlines x . D.toStreamD+interposeSuffix x = S.interposeSuffix x A.read++-- | Split a stream of arrays on a given separator byte, dropping the separator+-- and coalescing all the arrays between two separators into a single array.+--+-- @since 0.7.0+{-# INLINE splitOn #-}+splitOn+    :: (IsStream t, MonadIO m)+    => Word8+    -> t m (Array Word8)+    -> t m (Array Word8)+splitOn byte s =+    D.fromStreamD $ D.splitInnerBy (A.breakOn byte) A.spliceTwo $ D.toStreamD s++{-# INLINE splitOnSuffix #-}+splitOnSuffix+    :: (IsStream t, MonadIO m)+    => Word8+    -> t m (Array Word8)+    -> t m (Array Word8)+-- splitOn byte s = D.fromStreamD $ A.splitOn byte $ D.toStreamD s+splitOnSuffix byte s =+    D.fromStreamD $ D.splitInnerBySuffix (A.breakOn byte) A.spliceTwo $ D.toStreamD s++-- | Coalesce adjacent arrays in incoming stream to form bigger arrays of a+-- maximum specified size in bytes.+--+-- @since 0.7.0+{-# INLINE compact #-}+compact :: (MonadIO m, Storable a)+    => Int -> SerialT m (Array a) -> SerialT m (Array a)+compact n xs = D.fromStreamD $ A.packArraysChunksOf n (D.toStreamD xs)++-- | @arraysOf n stream@ groups the elements in the input stream into arrays of+-- @n@ elements each.+--+-- Same as the following but 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 str =+    D.fromStreamD $ A.fromStreamDArraysOf n (D.toStreamD str)++-- XXX Both of these implementations of splicing seem to perform equally well.+-- We need to perform benchmarks over a range of sizes though.++-- CAUTION! length must more than equal to lengths of all the arrays in the+-- stream.+{-# INLINE spliceArraysLenUnsafe #-}+spliceArraysLenUnsafe :: (MonadIO m, Storable a)+    => Int -> SerialT m (Array a) -> m (Array a)+spliceArraysLenUnsafe len buffered = do+    arr <- liftIO $ A.newArray len+    end <- S.foldlM' writeArr (aEnd arr) buffered+    return $ arr {aEnd = end}++    where++    writeArr dst Array{..} =+        liftIO $ withForeignPtr aStart $ \src -> do+                        let count = aEnd `minusPtr` src+                        A.memcpy (castPtr dst) (castPtr src) count+                        return $ dst `plusPtr` count++{-# INLINE _spliceArraysBuffered #-}+_spliceArraysBuffered :: (MonadIO m, Storable a)+    => SerialT m (Array a) -> m (Array a)+_spliceArraysBuffered s = do+    buffered <- P.foldr S.cons S.nil s+    len <- S.sum (S.map length buffered)+    spliceArraysLenUnsafe len s++{-# INLINE spliceArraysRealloced #-}+spliceArraysRealloced :: forall m a. (MonadIO m, Storable a)+    => SerialT m (Array a) -> m (Array a)+spliceArraysRealloced s = do+    idst <- liftIO $ A.newArray (A.bytesToElemCount (undefined :: a)+                                (A.mkChunkSizeKB 4))++    arr <- S.foldlM' A.spliceWithDoubling idst s+    liftIO $ A.shrinkToFit arr++-- | Given a stream of arrays, splice them all together to generate a single+-- array. The stream must be /finite/.+--+-- @since 0.7.0+{-# INLINE toArray #-}+toArray :: (MonadIO m, Storable a) => SerialT m (Array a) -> m (Array a)+toArray = spliceArraysRealloced+-- spliceArrays = _spliceArraysBuffered++-- exponentially increasing sizes of the chunks upto the max limit.+-- XXX this will be easier to implement with parsers/terminating folds+-- With this we should be able to reduce the number of chunks/allocations.+-- The reallocation/copy based toArray can also be implemented using this.+--+{-+{-# INLINE toArraysInRange #-}+toArraysInRange :: (IsStream t, MonadIO m, Storable a)+    => Int -> Int -> Fold m (Array a) b -> Fold m a b+toArraysInRange low high (Fold step initial extract) =+-}++{-+-- | Fold the input to a pure buffered stream (List) of arrays.+{-# INLINE _toArraysOf #-}+_toArraysOf :: (MonadIO m, Storable a)+    => Int -> Fold m a (SerialT Identity (Array a))+_toArraysOf n = FL.lchunksOf n (A.writeNF n) FL.toStream+-}
+ src/Streamly/Internal/Memory/Unicode/Array.hs view
@@ -0,0 +1,87 @@+{-# OPTIONS_HADDOCK hide      #-}+{-# LANGUAGE FlexibleContexts #-}++-- |+-- Module      : Streamly.Memory.Internal.Unicode.Array+-- Copyright   : (c) 2018 Composewell Technologies+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+module Streamly.Internal.Memory.Unicode.Array+    (+    -- * Streams of Strings+      lines+    , words+    , unlines+    , unwords+    )+where++import Control.Monad.IO.Class (MonadIO)+import Streamly (IsStream, MonadAsync)+import Prelude hiding (String, lines, words, unlines, unwords)+import Streamly.Memory.Array (Array)++import qualified Streamly.Internal.Data.Unicode.Stream as S+import qualified Streamly.Memory.Array as A++-- | Break a string up into a stream of strings at newline characters.+-- The resulting strings do not contain newlines.+--+-- > lines = S.lines A.write+--+-- >>> S.toList $ lines $ S.fromList "lines\nthis\nstring\n\n\n"+-- ["lines","this","string","",""]+--+{-# INLINE lines #-}+lines :: (MonadIO m, IsStream t) => t m Char -> t m (Array Char)+lines = S.lines A.write++-- | Break a string up into a stream of strings, which were delimited+-- by characters representing white space.+--+-- > words = S.words A.write+--+-- >>> S.toList $ words $ S.fromList "A  newline\nis considered white space?"+-- ["A", "newline", "is", "considered", "white", "space?"]+--+{-# INLINE words #-}+words :: (MonadIO m, IsStream t) => t m Char -> t m (Array Char)+words = S.words A.write++-- | Flattens the stream of @Array Char@, after appending a terminating+-- newline to each string.+--+-- 'unlines' is an inverse operation to 'lines'.+--+-- >>> S.toList $ unlines $ S.fromList ["lines", "this", "string"]+-- "lines\nthis\nstring\n"+--+-- > unlines = S.unlines A.read+--+-- Note that, in general+--+-- > unlines . lines /= id+{-# INLINE unlines #-}+unlines :: (MonadIO m, IsStream t) => t m (Array Char) -> t m Char+unlines = S.unlines A.read++-- | Flattens the stream of @Array Char@, after appending a separating+-- space to each string.+--+-- 'unwords' is an inverse operation to 'words'.+--+-- >>> S.toList $ unwords $ S.fromList ["unwords", "this", "string"]+-- "unwords this string"+--+-- > unwords = S.unwords A.read+--+-- Note that, in general+--+-- > unwords . words /= id+{-# INLINE unwords #-}+unwords :: (MonadAsync m, IsStream t) => t m (Array Char) -> t m Char+unwords = S.unwords A.read
+ src/Streamly/Internal/Network/Inet/TCP.hs view
@@ -0,0 +1,388 @@+{-# OPTIONS_HADDOCK hide      #-}+{-# LANGUAGE CPP              #-}+{-# LANGUAGE BangPatterns     #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MagicHash        #-}+{-# LANGUAGE RecordWildCards  #-}+{-# LANGUAGE UnboxedTuples    #-}++#include "inline.hs"++-- |+-- Module      : Streamly.Internal.Network.Inet.TCP+-- Copyright   : (c) 2019 Composewell Technologies+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+-- Combinators to build Inet/TCP clients and servers.++module Streamly.Internal.Network.Inet.TCP+    (+    -- * TCP Servers+    -- ** Unfolds+      acceptOnAddr+    , acceptOnPort+    , acceptOnPortLocal++    -- ** Streams+    , connectionsOnAddr+    , connectionsOnPort+    , connectionsOnLocalHost++    -- * TCP clients+    -- | IP Address based operations.+    , connect+    , withConnectionM++    -- ** Unfolds+    , usingConnection+    , read++    -- ** Streams+    , withConnection+    -- *** Source+    , toBytes+    -- , readUtf8+    -- , readLines+    -- , readFrames+    -- , readByChunks++    -- -- * Array Read+    -- , readArrayUpto+    -- , readArrayOf++    -- , readChunksUpto+    -- , readChunksOf+    -- , readChunks++    -- *** Sink+    , write+    -- , writeUtf8+    -- , writeUtf8ByLines+    -- , writeByFrames+    , writeWithBufferOf+    , fromBytes+    , fromBytesWithBufferOf++    -- -- * Array Write+    -- , writeArray+    , writeChunks+    , fromChunks+    {-+    -- ** Sink Servers++    -- These abstractions can be applied to any setting where we need to do a+    -- sink processing of multiple streams e.g. output from multiple processes+    -- or data coming from multiple files.++    -- handle connections concurrently using a specified fold+    -- , handleConnections++    -- handle frames concurrently using a specified fold+    , handleFrames++    -- merge frames from all connection into a single stream. Frames can be+    -- created by a specified fold.+    , mergeFrames++    -- * UDP Servers+    , datagrams+    , datagramsOn+    -}+    )+where++import Control.Monad.Catch (MonadCatch, MonadMask, bracket)+import Control.Monad.IO.Class (MonadIO(..))+import Data.Word (Word8)+import Network.Socket+       (Socket, PortNumber, SocketOption(..), Family(..), SockAddr(..),+        SocketType(..), defaultProtocol, maxListenQueue, tupleToHostAddress,+        socket)+import Prelude hiding (read)++import Streamly (MonadAsync)+import Streamly.Internal.Data.Fold.Types (Fold(..))+import Streamly.Internal.Data.Unfold.Types (Unfold(..))+import Streamly.Internal.Network.Socket (SockSpec(..), accept, connections)+import Streamly.Streams.Serial (SerialT)+import Streamly.Internal.Memory.Array.Types (Array(..), defaultChunkSize, writeNUnsafe)+import Streamly.Streams.StreamK.Type (IsStream)++import qualified Control.Monad.Catch as MC+import qualified Network.Socket as Net++import qualified Streamly.Internal.Data.Unfold as UF+import qualified Streamly.Internal.Memory.Array as A+import qualified Streamly.Internal.Memory.ArrayStream as AS+import qualified Streamly.Internal.Data.Fold.Types as FL+import qualified Streamly.Prelude as S+import qualified Streamly.Network.Socket as SK+import qualified Streamly.Internal.Network.Socket as ISK++-------------------------------------------------------------------------------+-- 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+    :: MonadIO m+    => Unfold m ((Word8, Word8, Word8, Word8), PortNumber) Socket+acceptOnAddr = UF.lmap f accept+    where+    f (addr, port) =+        (maxListenQueue+        , SockSpec+            { sockFamily = AF_INET+            , sockType = Stream+            , sockProto = defaultProtocol -- TCP+            , sockOpts = [(NoDelay,1), (ReuseAddr,1)]+            }+        , SockAddrInet port (tupleToHostAddress addr)+        )++-- | 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.+--+-- > acceptOnPort = UF.supplyFirst acceptOnAddr (0,0,0,0)+--+-- @since 0.7.0+{-# INLINE acceptOnPort #-}+acceptOnPort :: MonadIO m => Unfold m PortNumber Socket+acceptOnPort = UF.supplyFirst acceptOnAddr (0,0,0,0)++-- | Like 'acceptOnAddr' but binds on the localhost IPv4 address @127.0.0.1@.+-- The server can only be accessed from the local host, it cannot be accessed+-- from other hosts on the network.+--+-- > acceptOnPortLocal = UF.supplyFirst acceptOnAddr (127,0,0,1)+--+-- @since 0.7.0+{-# INLINE acceptOnPortLocal #-}+acceptOnPortLocal :: MonadIO m => Unfold m PortNumber Socket+acceptOnPortLocal = UF.supplyFirst acceptOnAddr (127,0,0,1)++-------------------------------------------------------------------------------+-- Accept (streams)+-------------------------------------------------------------------------------++-- | Like 'connections' but binds on the specified IPv4 address of the machine+-- and listens for TCP connections on the specified port.+--+-- /Internal/+{-# INLINE connectionsOnAddr #-}+connectionsOnAddr+    :: MonadAsync m+    => (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))++-- | 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+-- the specified port.+--+-- > connectionsOnPort = connectionsOnAddr (0,0,0,0)+--+-- /Internal/+{-# INLINE connectionsOnPort #-}+connectionsOnPort :: MonadAsync m => PortNumber -> SerialT m Socket+connectionsOnPort = connectionsOnAddr (0,0,0,0)++-- | Like 'connections' but binds on the localhost IPv4 address @127.0.0.1@.+-- The server can only be accessed from the local host, it cannot be accessed+-- from other hosts on the network.+--+-- > connectionsOnLocalHost = connectionsOnAddr (127,0,0,1)+--+-- /Internal/+{-# INLINE connectionsOnLocalHost #-}+connectionsOnLocalHost :: MonadAsync m => PortNumber -> SerialT m Socket+connectionsOnLocalHost = connectionsOnAddr (127,0,0,1)++-------------------------------------------------------------------------------+-- TCP Clients+-------------------------------------------------------------------------------++-- | Connect to the specified IP address and port number.+--+-- @since 0.7.0+connect :: (Word8, Word8, Word8, Word8) -> PortNumber -> IO Socket+connect addr port = do+    sock <- socket AF_INET Stream defaultProtocol+    Net.connect sock $ SockAddrInet port (Net.tupleToHostAddress addr)+    return sock++-- | Connect to a remote host using IP address and port and run the supplied+-- action on the resulting socket.  'withConnectionM' makes sure that the+-- socket is closed on normal termination or in case of an exception.  If+-- closing the socket raises an exception, then this exception will be raised+-- by 'withConnectionM'.+--+-- /Internal/+{-# INLINABLE withConnectionM #-}+withConnectionM :: (MonadMask m, MonadIO m)+    => (Word8, Word8, Word8, Word8) -> PortNumber -> (Socket -> m ()) -> m ()+withConnectionM addr port =+    bracket (liftIO $ connect addr port) (liftIO . Net.close)++-------------------------------------------------------------------------------+-- Connect (unfolds)+-------------------------------------------------------------------------------++-- | Transform an 'Unfold' from a 'Socket' to an unfold from a remote IP+-- address and port. The resulting unfold opens a socket, uses it using the+-- supplied unfold and then makes sure that the socket is closed on normal+-- termination or in case of an exception.  If closing the socket raises an+-- exception, then this exception will be raised by 'usingConnection'.+--+-- /Internal/+{-# INLINABLE usingConnection #-}+usingConnection :: (MonadCatch m, MonadIO m)+    => Unfold m Socket a+    -> Unfold m ((Word8, Word8, Word8, Word8), PortNumber) a+usingConnection =+    UF.bracket (\(addr, port) -> liftIO $ connect addr port)+               (liftIO . Net.close)++-------------------------------------------------------------------------------+-- Connect (streams)+-------------------------------------------------------------------------------++-- | @'withConnection' addr port act@ opens a connection to the specified IPv4+-- host address and port and passes the resulting socket handle to the+-- computation @act@.  The handle will be closed on exit from 'withConnection',+-- whether by normal termination or by raising an exception.  If closing the+-- handle raises an exception, then this exception will be raised by+-- 'withConnection' rather than any exception raised by 'act'.+--+-- /Internal/+{-# INLINABLE withConnection #-}+withConnection :: (IsStream t, MonadCatch m, MonadIO m)+    => (Word8, Word8, Word8, Word8) -> PortNumber -> (Socket -> t m a) -> t m a+withConnection addr port =+    S.bracket (liftIO $ connect addr port) (liftIO . Net.close)++-------------------------------------------------------------------------------+-- Read Addr to Stream+-------------------------------------------------------------------------------++-- | Read a stream from the supplied IPv4 host address and port number.+--+-- @since 0.7.0+{-# INLINE read #-}+read :: (MonadCatch m, MonadIO m)+    => Unfold m ((Word8, Word8, Word8, Word8), PortNumber) Word8+read = UF.concat (usingConnection ISK.readChunks) A.read++-- | Read a stream from the supplied IPv4 host address and port number.+--+-- @since 0.7.0+{-# INLINE toBytes #-}+toBytes :: (IsStream t, MonadCatch m, MonadIO m)+    => (Word8, Word8, Word8, Word8) -> PortNumber -> t m Word8+toBytes addr port = AS.concat $ withConnection addr port ISK.toChunks++-------------------------------------------------------------------------------+-- Writing+-------------------------------------------------------------------------------++-- | Write a stream of arrays to the supplied IPv4 host address and port+-- number.+--+-- @since 0.7.0+{-# INLINE fromChunks #-}+fromChunks+    :: (MonadCatch m, MonadAsync m)+    => (Word8, Word8, Word8, Word8)+    -> PortNumber+    -> SerialT m (Array Word8)+    -> m ()+fromChunks addr port xs =+    S.drain $ withConnection addr port (\sk -> S.yieldM $ ISK.fromChunks sk xs)++-- | Write a stream of arrays to the supplied IPv4 host address and port+-- number.+--+-- @since 0.7.0+{-# INLINE writeChunks #-}+writeChunks+    :: (MonadAsync m, MonadCatch m)+    => (Word8, Word8, Word8, Word8)+    -> PortNumber+    -> Fold m (Array Word8) ()+writeChunks addr port = Fold step initial extract+    where+    initial = do+        skt <- liftIO (connect addr port)+        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)+        return (r, skt)+    extract ((Fold _ initial1 extract1), skt) = do+        liftIO $ Net.close skt+        initial1 >>= extract1++-- | Like 'write' but provides control over the write buffer. Output will+-- be written to the IO device as soon as we collect the specified number of+-- input elements.+--+-- @since 0.7.0+{-# INLINE fromBytesWithBufferOf #-}+fromBytesWithBufferOf+    :: (MonadCatch m, MonadAsync m)+    => Int+    -> (Word8, Word8, Word8, Word8)+    -> PortNumber+    -> SerialT m Word8+    -> m ()+fromBytesWithBufferOf n addr port m = fromChunks addr port $ AS.arraysOf n m++-- | Like 'write' but provides control over the write buffer. Output will+-- be written to the IO device as soon as we collect the specified number of+-- input elements.+--+-- @since 0.7.0+{-# INLINE writeWithBufferOf #-}+writeWithBufferOf+    :: (MonadAsync m, MonadCatch m)+    => Int+    -> (Word8, Word8, Word8, Word8)+    -> PortNumber+    -> Fold m Word8 ()+writeWithBufferOf n addr port =+    FL.lchunksOf n (writeNUnsafe n) (writeChunks addr port)++-- | Write a stream to the supplied IPv4 host address and port number.+--+-- @since 0.7.0+{-# INLINE fromBytes #-}+fromBytes :: (MonadCatch m, MonadAsync m)+    => (Word8, Word8, Word8, Word8) -> PortNumber -> SerialT m Word8 -> m ()+fromBytes = fromBytesWithBufferOf defaultChunkSize++-- | Write a stream to the supplied IPv4 host address and port number.+--+-- @since 0.7.0+{-# INLINE write #-}+write :: (MonadAsync m, MonadCatch m)+    => (Word8, Word8, Word8, Word8) -> PortNumber -> Fold m Word8 ()+write = writeWithBufferOf defaultChunkSize
+ src/Streamly/Internal/Network/Socket.hs view
@@ -0,0 +1,551 @@+{-# OPTIONS_HADDOCK hide      #-}+{-# LANGUAGE CPP              #-}+{-# LANGUAGE BangPatterns     #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MagicHash        #-}+{-# LANGUAGE RecordWildCards  #-}+{-# LANGUAGE UnboxedTuples    #-}++#include "inline.hs"++-- |+-- Module      : Streamly.Internal.Network.Socket+-- Copyright   : (c) 2018 Composewell Technologies+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+module Streamly.Internal.Network.Socket+    (+    SockSpec (..)+    -- * Use a socket+    , useSocketM+    , useSocket++    -- * Accept connections+    , accept+    , connections++    -- * Read from connection+    , read+    , readWithBufferOf+    -- , readUtf8+    -- , readLines+    -- , readFrames+    -- , readByChunks++    -- -- * Array Read+    -- , readArrayUpto+    -- , readArrayOf++    -- , readChunksUpto+    , readChunksWithBufferOf+    , readChunks++    , toChunksWithBufferOf+    , toChunks+    , toBytes++    -- * Write to connection+    , write+    -- , writeUtf8+    -- , writeUtf8ByLines+    -- , writeByFrames+    , writeWithBufferOf++    , fromChunks+    , fromBytesWithBufferOf+    , fromBytes++    -- -- * Array Write+    , writeArray+    , writeChunks+    , writeStrings++    -- reading/writing datagrams+    )+where++import Control.Concurrent (threadWaitWrite, rtsSupportsBoundThreads)+import Control.Monad.Catch (MonadCatch, finally, MonadMask)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad (when)+import Data.Word (Word8)+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)+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)+#if MIN_VERSION_network(3,1,0)+import Network.Socket (withFdSocket)+#else+import Network.Socket (fdSocket)+#endif+import Prelude hiding (read)++import qualified Network.Socket as Net++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.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+import qualified Streamly.Memory.Array as A+import qualified Streamly.Internal.Memory.ArrayStream as AS+import qualified Streamly.Internal.Memory.Array.Types as A+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',+-- 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'.+--+-- @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))++-- | Like 'useSocketM' but runs a streaming computation instead of a monadic+-- computation.+--+-- @since 0.7.0+{-# INLINE useSocket #-}+useSocket :: (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)++-------------------------------------------------------------------------------+-- Accept (Unfolds)+-------------------------------------------------------------------------------++-- XXX Protocol specific socket options should be separated from socket level+-- options.+--+-- | Specify the socket protocol details.+data SockSpec = SockSpec+    {+      sockFamily :: !Family+    , sockType   :: !SocketType+    , sockProto  :: !ProtocolNumber+    , sockOpts   :: ![(SocketOption, Int)]+    }++initListener :: Int -> SockSpec -> SockAddr -> IO Socket+initListener listenQLen SockSpec{..} addr =+  withSocketsDo $ do+    sock <- socket sockFamily sockType sockProto+    mapM_ (\(opt, val) -> setSocketOption sock opt val) sockOpts+    bind sock addr+    Net.listen sock listenQLen+    return sock++{-# INLINE listenTuples #-}+listenTuples :: MonadIO m+    => 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++    step listener = do+        r <- liftIO $ Net.accept listener+        -- XXX error handling+        return $ D.Yield r listener++-- | Unfold a three tuple @(listenQLen, spec, addr)@ into a stream of connected+-- protocol sockets corresponding to incoming connections. @listenQLen@ is the+-- maximum number of pending connections in the backlog. @spec@ is the socket+-- protocol and options specification and @addr@ is the protocol address where+-- the server listens for incoming connections.+--+-- @since 0.7.0+{-# INLINE accept #-}+accept :: MonadIO m => Unfold m (Int, SockSpec, SockAddr) Socket+accept = UF.map fst listenTuples++-------------------------------------------------------------------------------+-- Listen (Streams)+-------------------------------------------------------------------------------++{-# INLINE recvConnectionTuplesWith #-}+recvConnectionTuplesWith :: MonadAsync m+    => Int -> SockSpec -> SockAddr -> SerialT m (Socket, SockAddr)+recvConnectionTuplesWith tcpListenQ spec addr = S.unfoldrM step Nothing+    where+    step Nothing = do+        listener <- liftIO $ initListener tcpListenQ spec addr+        r <- liftIO $ Net.accept listener+        -- XXX error handling+        return $ Just (r, Just listener)++    step (Just listener) = do+        r <- liftIO $ Net.accept listener+        -- XXX error handling+        return $ Just (r, Just listener)++-- | Start a TCP stream server that listens for connections on the supplied+-- server address specification (address family, local interface IP address and+-- port). The server generates a stream of connected sockets.  The first+-- argument is the maximum number of pending connections in the backlog.+--+-- /Internal/+{-# INLINE connections #-}+connections :: MonadAsync m => Int -> SockSpec -> SockAddr -> SerialT m Socket+connections tcpListenQ spec addr = fmap fst $+    recvConnectionTuplesWith tcpListenQ spec addr++-------------------------------------------------------------------------------+-- Array IO (Input)+-------------------------------------------------------------------------------++{-# INLINABLE readArrayUptoWith #-}+readArrayUptoWith+    :: (h -> Ptr Word8 -> Int -> IO Int)+    -> Int+    -> h+    -> IO (Array Word8)+readArrayUptoWith f size h = do+    ptr <- mallocPlainForeignPtrBytes size+    -- ptr <- mallocPlainForeignPtrAlignedBytes size (alignment (undefined :: Word8))+    withForeignPtr ptr $ \p -> do+        n <- f h p size+        let v = Array+                { aStart = ptr+                , aEnd   = p `plusPtr` n+                , aBound = p `plusPtr` size+                }+        -- XXX shrink only if the diff is significant+        -- A.shrinkToFit v+        return v++-- | Read a 'ByteArray' from a file handle. If no data is available on the+-- handle it blocks until some data becomes available. If data is available+-- then it immediately returns that data without blocking. It reads a maximum+-- of up to the size requested.+{-# INLINABLE readArrayOf #-}+readArrayOf :: Int -> Socket -> IO (Array Word8)+readArrayOf = readArrayUptoWith recvBuf++-------------------------------------------------------------------------------+-- Array IO (output)+-------------------------------------------------------------------------------++waitWhen0 :: Int -> Socket -> IO ()+waitWhen0 0 s = when rtsSupportsBoundThreads $+#if MIN_VERSION_network(3,1,0)+    withFdSocket s $ \fd -> threadWaitWrite $ fromIntegral fd+#else+    let fd = fdSocket s in threadWaitWrite $ fromIntegral fd+#endif+waitWhen0 _ _ = return ()++sendAll :: Socket -> Ptr Word8 -> Int -> IO ()+sendAll _ _ len | len <= 0 = return ()+sendAll s p len = do+    sent <- sendBuf s p len+    waitWhen0 sent s+    -- assert (sent <= len)+    when (sent >= 0) $ sendAll s (p `plusPtr` sent) (len - sent)++{-# INLINABLE writeArrayWith #-}+writeArrayWith :: Storable a+    => (h -> Ptr Word8 -> Int -> IO ())+    -> h+    -> Array a+    -> IO ()+writeArrayWith _ _ arr | A.length arr == 0 = return ()+writeArrayWith f h Array{..} = withForeignPtr aStart $ \p ->+    f h (castPtr p) aLen+    where+    aLen =+        let p = unsafeForeignPtrToPtr aStart+        in aEnd `minusPtr` p++-- | Write an Array to a file handle.+--+-- @since 0.7.0+{-# INLINABLE writeArray #-}+writeArray :: Storable a => Socket -> Array a -> IO ()+writeArray = writeArrayWith sendAll++-------------------------------------------------------------------------------+-- Stream of Arrays IO+-------------------------------------------------------------------------------++{-# INLINABLE readChunksUptoWith #-}+readChunksUptoWith :: (IsStream t, MonadIO m)+    => (Int -> h -> IO (Array Word8))+    -> Int -> h -> t m (Array Word8)+readChunksUptoWith f size h = go+  where+    -- XXX use cons/nil instead+    go = mkStream $ \_ yld _ stp -> do+        arr <- liftIO $ f size h+        if A.length arr == 0+        then stp+        else yld arr go++-- | @toChunksWithBufferOf size h@ reads a stream of arrays from file handle @h@.+-- The maximum size of a single array is limited to @size@.+-- 'fromHandleArraysUpto' ignores the prevailing 'TextEncoding' and 'NewlineMode'+-- on the 'Handle'.+{-# INLINABLE toChunksWithBufferOf #-}+toChunksWithBufferOf :: (IsStream t, MonadIO m)+    => Int -> Socket -> t m (Array Word8)+toChunksWithBufferOf = readChunksUptoWith readArrayOf++-- XXX read 'Array a' instead of Word8+--+-- | @toChunks h@ reads a stream of arrays from socket handle @h@.+-- The maximum size of a single array is limited to @defaultChunkSize@.+--+-- @since 0.7.0+{-# INLINE toChunks #-}+toChunks :: (IsStream t, MonadIO m) => Socket -> t m (Array Word8)+toChunks = toChunksWithBufferOf A.defaultChunkSize++-- | Unfold the tuple @(bufsize, socket)@ into a stream of 'Word8' arrays.+-- Read requests to the socket are performed using a buffer of size @bufsize@.+-- The size of an array in the resulting stream is always less than or equal to+-- @bufsize@.+--+-- @since 0.7.0+{-# INLINE_NORMAL readChunksWithBufferOf #-}+readChunksWithBufferOf :: MonadIO m => Unfold m (Int, Socket) (Array Word8)+readChunksWithBufferOf = Unfold step return+    where+    {-# INLINE_LATE step #-}+    step (size, h) = do+        arr <- liftIO $ readArrayOf size h+        return $+            case A.length arr of+                0 -> D.Stop+                _ -> D.Yield arr (size, h)++-- | Unfolds a socket into a stream of 'Word8' arrays. Requests to the socket+-- are performed using a buffer of size+-- 'Streamly.Internal.Memory.Array.Types.defaultChunkSize'. The+-- size of arrays in the resulting stream are therefore less than or equal to+-- 'Streamly.Internal.Memory.Array.Types.defaultChunkSize'.+--+-- @since 0.7.0+{-# INLINE readChunks #-}+readChunks :: MonadIO m => Unfold m Socket (Array Word8)+readChunks = UF.supplyFirst readChunksWithBufferOf A.defaultChunkSize++-------------------------------------------------------------------------------+-- Read File to Stream+-------------------------------------------------------------------------------++-- TODO for concurrent streams implement readahead IO. We can send multiple+-- read requests at the same time. For serial case we can use async IO. We can+-- also control the read throughput in mbps or IOPS.++{-+-- | @readWithBufferOf bufsize handle@ reads a byte stream from a file+-- handle, reads are performed in chunks of up to @bufsize@.  The stream ends+-- as soon as EOF is encountered.+--+{-# INLINE readWithBufferOf #-}+readWithBufferOf :: (IsStream t, MonadIO m) => Int -> Handle -> t m Word8+readWithBufferOf chunkSize h = A.flattenArrays $ readChunksUpto chunkSize h+-}++-- TODO+-- read :: (IsStream t, MonadIO m, Storable a) => Handle -> t m a+--+-- > read = 'readByChunks' A.defaultChunkSize+-- | Generate a stream of elements of the given type from a socket. The+-- stream ends when EOF is encountered.+--+-- @since 0.7.0+{-# INLINE toBytes #-}+toBytes :: (IsStream t, MonadIO m) => Socket -> t m Word8+toBytes = AS.concat . toChunks++-- | Unfolds the tuple @(bufsize, socket)@ into a byte stream, read requests+-- to the socket are performed using buffers of @bufsize@.+--+-- @since 0.7.0+{-# INLINE readWithBufferOf #-}+readWithBufferOf :: MonadIO m => Unfold m (Int, Socket) Word8+readWithBufferOf = UF.concat readChunksWithBufferOf A.read++-- | Unfolds a 'Socket' into a byte stream.  IO requests to the socket are+-- performed in sizes of+-- 'Streamly.Internal.Memory.Array.Types.defaultChunkSize'.+--+-- @since 0.7.0+{-# INLINE read #-}+read :: MonadIO m => Unfold m Socket Word8+read = UF.supplyFirst readWithBufferOf A.defaultChunkSize++-------------------------------------------------------------------------------+-- Writing+-------------------------------------------------------------------------------++-- | Write a stream of arrays to a handle.+--+-- @since 0.7.0+{-# INLINE fromChunks #-}+fromChunks :: (MonadIO m, Storable a)+    => Socket -> SerialT m (Array a) -> m ()+fromChunks h m = S.mapM_ (liftIO . writeArray h) m++-- | Write a stream of arrays to a socket.  Each array in the stream is written+-- to the socket as a separate IO request.+--+-- @since 0.7.0+{-# INLINE writeChunks #-}+writeChunks :: (MonadIO m, Storable a) => Socket -> Fold m (Array a) ()+writeChunks h = FL.drainBy (liftIO . writeArray h)++-- | Write a stream of strings to a socket in Latin1 encoding.+--+-- /Internal/+--+{-# INLINE writeStrings #-}+writeStrings :: MonadIO m => Socket -> Fold m String ()+writeStrings h =+    FL.lmapM (IA.fromStream . U.encodeLatin1 . S.fromList) (writeChunks h)++-- GHC buffer size dEFAULT_FD_BUFFER_SIZE=8192 bytes.+--+-- XXX test this+-- Note that if you use a chunk size less than 8K (GHC's default buffer+-- size) then you are advised to use 'NOBuffering' mode on the 'Handle' in case you+-- do not want buffering to occur at GHC level as well. Same thing applies to+-- writes as well.++-- | Like 'write' but provides control over the write buffer. Output will+-- be written to the IO device as soon as we collect the specified number of+-- input elements.+--+-- @since 0.7.0+{-# INLINE fromBytesWithBufferOf #-}+fromBytesWithBufferOf :: MonadIO m => Int -> Socket -> SerialT m Word8 -> m ()+fromBytesWithBufferOf n h m = fromChunks h $ AS.arraysOf n m++-- | Write a byte stream to a socket. Accumulates the input in chunks of+-- specified number of bytes before writing.+--+-- @since 0.7.0+{-# INLINE writeWithBufferOf #-}+writeWithBufferOf :: MonadIO m => Int -> Socket -> Fold m Word8 ()+writeWithBufferOf n h = FL.lchunksOf n (A.writeNUnsafe n) (writeChunks h)++-- > write = 'writeWithBufferOf' A.defaultChunkSize+--+-- | Write a byte stream to a file handle. Combines the bytes in chunks of size+-- up to 'A.defaultChunkSize' before writing.  Note that the write behavior+-- depends on the 'IOMode' and the current seek position of the handle.+--+-- @since 0.7.0+{-# INLINE fromBytes #-}+fromBytes :: MonadIO m => Socket -> SerialT m Word8 -> m ()+fromBytes = fromBytesWithBufferOf A.defaultChunkSize++-- | Write a byte stream to a socket. Accumulates the input in chunks of+-- up to 'A.defaultChunkSize' bytes before writing.+--+-- @+-- write = 'writeWithBufferOf' 'A.defaultChunkSize'+-- @+--+-- @since 0.7.0+{-# INLINE write #-}+write :: MonadIO m => Socket -> Fold m Word8 ()+write = writeWithBufferOf A.defaultChunkSize++{-+{-# INLINE write #-}+write :: (MonadIO m, Storable a) => Handle -> SerialT m a -> m ()+write = toHandleWith A.defaultChunkSize+-}++-------------------------------------------------------------------------------+-- IO with encoding/decoding Unicode characters+-------------------------------------------------------------------------------++{-+-- |+-- > readUtf8 = decodeUtf8 . read+--+-- Read a UTF8 encoded stream of unicode characters from a file handle.+--+-- @since 0.7.0+{-# INLINE readUtf8 #-}+readUtf8 :: (IsStream t, MonadIO m) => Handle -> t m Char+readUtf8 = decodeUtf8 . read++-- |+-- > writeUtf8 h s = write h $ encodeUtf8 s+--+-- Encode a stream of unicode characters to UTF8 and write it to the given file+-- handle. Default block buffering applies to the writes.+--+-- @since 0.7.0+{-# INLINE writeUtf8 #-}+writeUtf8 :: MonadIO m => Handle -> SerialT m Char -> m ()+writeUtf8 h s = write h $ encodeUtf8 s++-- | Write a stream of unicode characters after encoding to UTF-8 in chunks+-- separated by a linefeed character @'\n'@. If the size of the buffer exceeds+-- @defaultChunkSize@ and a linefeed is not yet found, the buffer is written+-- anyway.  This is similar to writing to a 'Handle' with the 'LineBuffering'+-- option.+--+-- @since 0.7.0+{-# INLINE writeUtf8ByLines #-}+writeUtf8ByLines :: (IsStream t, MonadIO m) => Handle -> t m Char -> m ()+writeUtf8ByLines = undefined++-- | Read UTF-8 lines from a file handle and apply the specified fold to each+-- line. This is similar to reading a 'Handle' with the 'LineBuffering' option.+--+-- @since 0.7.0+{-# INLINE readLines #-}+readLines :: (IsStream t, MonadIO m) => Handle -> Fold m Char b -> t m b+readLines h f = foldLines (readUtf8 h) f++-------------------------------------------------------------------------------+-- Framing on a sequence+-------------------------------------------------------------------------------++-- | Read a stream from a file handle and split it into frames delimited by+-- the specified sequence of elements. The supplied fold is applied on each+-- frame.+--+-- @since 0.7.0+{-# INLINE readFrames #-}+readFrames :: (IsStream t, MonadIO m, Storable a)+    => Array a -> Handle -> Fold m a b -> t m b+readFrames = undefined -- foldFrames . read++-- | Write a stream to the given file handle buffering up to frames separated+-- by the given sequence or up to a maximum of @defaultChunkSize@.+--+-- @since 0.7.0+{-# INLINE writeByFrames #-}+writeByFrames :: (IsStream t, MonadIO m, Storable a)+    => Array a -> Handle -> t m a -> m ()+writeByFrames = undefined+-}
+ src/Streamly/Internal/Prelude.hs view
@@ -0,0 +1,3788 @@+{-# 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)++-- | When evaluating a stream if an exception occurs, stream evaluation aborts+-- and the specified exception handler is run with the exception as argument.+--+-- @since 0.7.0+{-# INLINE handle #-}+handle :: (IsStream t, MonadCatch m, Exception e)+    => (e -> t m a) -> t m a -> t m a+handle handler xs =+    D.fromStreamD $ D.handle (\e -> D.toStreamD $ handler e) $ D.toStreamD xs++------------------------------------------------------------------------------+-- Generalize the underlying monad+------------------------------------------------------------------------------++-- | Transform the inner monad of a stream using a natural transformation.+--+-- / Internal/+--+{-# INLINE hoist #-}+hoist :: (Monad m, Monad n)+    => (forall x. m x -> n x) -> SerialT m a -> SerialT n a+hoist f xs = fromStreamS $ S.hoist f (toStreamS xs)++-- | Generalize the inner monad of the stream from 'Identity' to any monad.+--+-- / Internal/+--+{-# INLINE generally #-}+generally :: (IsStream t, Monad m) => t Identity a -> t m a+generally xs = fromStreamS $ S.hoist (return . runIdentity) (toStreamS xs)++------------------------------------------------------------------------------+-- Add and remove a monad transformer+------------------------------------------------------------------------------++-- | Lift the inner monad of a stream using a monad transformer.+--+-- / Internal/+--+{-# INLINE liftInner #-}+liftInner :: (Monad m, IsStream t, MonadTrans tr, Monad (tr m))+    => t m a -> t (tr m) a+liftInner xs = fromStreamD $ D.liftInner (toStreamD xs)++-- | Evaluate the inner monad of a stream as 'ReaderT'.+--+-- / Internal/+--+{-# INLINE runReaderT #-}+runReaderT :: (IsStream t, Monad m) => s -> t (ReaderT s m) a -> t m a+runReaderT s xs = fromStreamD $ D.runReaderT s (toStreamD xs)++-- | Evaluate the inner monad of a stream as 'StateT'.+--+-- This is supported only for 'SerialT' as concurrent state updation may not be+-- safe.+--+-- / Internal/+--+{-# INLINE evalStateT #-}+evalStateT ::  Monad m => s -> SerialT (StateT s m) a -> SerialT m a+evalStateT s xs = fromStreamD $ D.evalStateT s (toStreamD xs)++-- | Run a stateful (StateT) stream transformation using a given state.+--+-- This is supported only for 'SerialT' as concurrent state updation may not be+-- safe.+--+-- / Internal/+--+{-# INLINE usingStateT #-}+usingStateT+    :: Monad m+    => s+    -> (SerialT (StateT s m) a -> SerialT (StateT s m) a)+    -> SerialT m a+    -> SerialT m a+usingStateT s f xs = evalStateT s $ f $ liftInner xs++-- | Evaluate the inner monad of a stream as 'StateT' and emit the resulting+-- state and value pair after each step.+--+-- This is supported only for 'SerialT' as concurrent state updation may not be+-- safe.+--+-- / Internal/+--+{-# INLINE runStateT #-}+runStateT :: Monad m => s -> SerialT (StateT s m) a -> SerialT m (s, a)+runStateT s xs = fromStreamD $ D.runStateT s (toStreamD xs)
− src/Streamly/List.hs 
@@ -1,188 +0,0 @@-{-# LANGUAGE CPP                        #-}-{-# LANGUAGE DeriveTraversable          #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE PatternSynonyms            #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE UndecidableInstances       #-} -- XXX-{-# LANGUAGE ViewPatterns               #-}---- |--- Module      : Streamly.List--- Copyright   : (c) 2018 Composewell Technologies------ License     : BSD3--- Maintainer  : harendra.kumar@gmail.com--- Stability   : experimental--- Portability : GHC------ Lists are just a special case of monadic streams. The stream type @SerialT--- Identity a@ can be used as a replacement for @[a]@.  The 'List' type in this--- module is just a newtype wrapper around @SerialT Identity@ for better type--- inference when using the 'OverloadedLists' GHC extension. @List a@ provides--- better performance compared to @[a]@. Standard list, string and list--- comprehension syntax can be used with the 'List' type by enabling--- 'OverloadedLists', 'OverloadedStrings' and 'MonadComprehensions' GHC--- extensions.  There would be a slight difference in the 'Show' and 'Read'--- strings of streamly list as compared to regular lists.------ Conversion to stream types is free, any stream combinator can be used on--- lists by converting them to streams.  However, for convenience, this module--- provides combinators that work directly on the 'List' type.--------- @--- List $ S.map (+ 1) $ toSerial (1 \`Cons\` Nil)--- @------ To convert a 'List' to regular lists, you can use any of the following:------ * @toList . toSerial@ and @toSerial . fromList@--- * 'Data.Foldable.toList' from "Data.Foldable"--- * 'GHC.Exts.toList' and 'GHC.Exts.fromList' from 'IsList' in "GHC.Exts"------ If you have made use of 'Nil' and 'Cons' constructors in the code and you--- want to replace streamly lists with standard lists, all you need to do is--- import these definitions:------ @--- type List = []--- pattern Nil <- [] where Nil = []--- pattern Cons x xs = x : xs--- infixr 5 `Cons`--- {-\# COMPLETE Cons, Nil #-}--- @------ See <src/docs/streamly-vs-lists.md> for more details and--- <src/test/PureStreams.hs> for comprehensive usage examples.----module Streamly.List-    (-#if __GLASGOW_HASKELL__ >= 800-    List (.., Nil, Cons)-#else-    List (..)-    , pattern Nil-    , pattern Cons-#endif-    -- XXX we may want to use rebindable syntax for variants instead of using-    -- different types (applicative do and apWith).-    , ZipList (..)-    , fromZipList-    , toZipList-    )-where--import Control.Arrow (second)-import Control.DeepSeq (NFData(..), NFData1(..))-import Data.Functor.Identity (Identity, runIdentity)-import Data.Semigroup (Semigroup(..))-import GHC.Exts (IsList(..), IsString(..))--import Streamly.Streams.Serial (SerialT)-import Streamly.Streams.Zip (ZipSerialM)--import qualified Streamly.Streams.Prelude as P-import qualified Streamly.Streams.StreamK as K---- We implement list as a newtype instead of a type synonym to make type--- inference easier when using -XOverloadedLists and -XOverloadedStrings. When--- using a stream type the programmer needs to specify the Monad otherwise the--- type remains ambiguous.------ XXX once we separate consM from IsStream or remove the MonadIO and--- MonadBaseControlIO dependency from it, then we can make this an instance of--- IsStream and use the regular polymorphic functions on Lists as well. Once--- that happens we can change the Show and Read instances as well to use "1 >:--- 2 >: nil" etc. or should we use a separate constructor indicating the "List"--- type ":>" for better inference?------ | @List a@ is a replacement for @[a]@.------ @since 0.6.0-newtype List a = List { toSerial :: SerialT Identity a }-    deriving (Show, Read, Eq, Ord, NFData, NFData1-             , Semigroup, Monoid, Functor, Foldable-             , Applicative, Traversable, Monad)--instance (a ~ Char) => IsString (List a) where-    {-# INLINE fromString #-}-    fromString = List . P.fromList---- GHC versions 8.0 and below cannot derive IsList-instance IsList (List a) where-    type (Item (List a)) = a-    {-# INLINE fromList #-}-    fromList = List . P.fromList-    {-# INLINE toList #-}-    toList = runIdentity . P.toList . toSerial----------------------------------------------------------------------------------- Patterns----------------------------------------------------------------------------------- Note: When using the OverloadedLists extension we should be able to pattern--- match using the regular list contructors. OverloadedLists uses 'toList' to--- perform the pattern match, it should not be too bad as it works lazily in--- the Identity monad. We need these patterns only when not using that--- extension.------ | An empty list constructor and pattern that matches an empty 'List'.--- Corresponds to '[]' for Haskell lists.------ @since 0.6.0-pattern Nil :: List a-pattern Nil <- (runIdentity . K.null . toSerial -> True) where-    Nil = List K.nil--infixr 5 `Cons`---- | A list constructor and pattern that deconstructs a 'List' into its head--- and tail. Corresponds to ':' for Haskell lists.------ @since 0.6.0-pattern Cons :: a -> List a -> List a-pattern Cons x xs <--    (fmap (second List) . runIdentity . K.uncons . toSerial-        -> Just (x, xs)) where-            Cons x xs = List $ K.cons x (toSerial xs)--#if __GLASGOW_HASKELL__ >= 802-{-# COMPLETE Nil, Cons #-}-#endif----------------------------------------------------------------------------------- ZipList----------------------------------------------------------------------------------- | Just like 'List' except that it has a zipping 'Applicative' instance--- and no 'Monad' instance.------ @since 0.6.0-newtype ZipList a = ZipList { toZipSerial :: ZipSerialM Identity a }-    deriving (Show, Read, Eq, Ord, NFData, NFData1-             , Semigroup, Monoid, Functor, Foldable-             , Applicative, Traversable)--instance (a ~ Char) => IsString (ZipList a) where-    {-# INLINE fromString #-}-    fromString = ZipList . P.fromList---- GHC versions 8.0 and below cannot derive IsList-instance IsList (ZipList a) where-    type (Item (ZipList a)) = a-    {-# INLINE fromList #-}-    fromList = ZipList . P.fromList-    {-# INLINE toList #-}-    toList = runIdentity . P.toList . toZipSerial---- | Convert a 'ZipList' to a regular 'List'------ @since 0.6.0-fromZipList :: ZipList a -> List a-fromZipList = List . K.adapt . toZipSerial---- | Convert a regular 'List' to a 'ZipList'------ @since 0.6.0-toZipList :: List a -> ZipList a-toZipList = ZipList . K.adapt . toSerial
+ src/Streamly/Memory/Array.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE ScopedTypeVariables #-}++#include "inline.hs"++-- |+-- Module      : Streamly.Memory.Array+-- Copyright   : (c) 2019 Composewell Technologies+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+-- This module provides immutable arrays in pinned memory (non GC memory)+-- suitable for long lived data storage, random access and for interfacing with+-- the operating system.+--+-- Arrays in this module are chunks of pinned memory that hold a sequence of+-- '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+-- copied across generations.  Moreover, pinned memory allows communication+-- with foreign consumers and producers (e.g. file or network IO) without+-- copying the data.+--+-- = Programmer Notes+--+-- To apply a transformation to an array use 'read' to unfold the array into a+-- stream, apply a transformation on the stream and then use 'write' to fold it+-- back to an array.+--+-- This module is designed to be imported qualified:+--+-- > import qualified Streamly.Array as A+--+-- For experimental APIs see "Streamly.Internal.Memory.Array".++module Streamly.Memory.Array+    (+      A.Array++    -- * Arrays+    -- ** Construction+    -- | When performance matters, the fastest way to generate an array is+    -- 'writeN'. 'IsList' and 'IsString' instances can be+    -- used to conveniently construct arrays from literal values.+    -- 'OverloadedLists' extension or 'fromList' can be used to construct an+    -- array from a list literal.  Similarly, 'OverloadedStrings' extension or+    -- 'fromList' can be used to construct an array from a string literal.++    -- Pure List APIs+    , A.fromListN+    , A.fromList++    -- Monadic APIs+    , A.writeN      -- drop new+    , A.write       -- full buffer+    -- , writeLastN -- drop old (ring buffer)++    -- ** Elimination+    -- 'GHC.Exts.toList' from "GHC.Exts" can be used to convert an array to a+    -- list.++    , A.toList+    , A.read++    -- ** Random Access+    , A.length+    -- , (!!)+    -- , A.readIndex+    )+where++import Streamly.Internal.Memory.Array as A
+ src/Streamly/Memory/Malloc.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE FlexibleContexts #-}++#include "inline.hs"++-- |+-- Module      : Streamly.Memory.Malloc+-- Copyright   : (c) 2019 Composewell Technologies+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+module Streamly.Memory.Malloc+    (+      mallocForeignPtrAlignedBytes+    , mallocForeignPtrAlignedUnmanagedBytes+    )+where++#define USE_GHC_MALLOC++import Foreign.ForeignPtr (ForeignPtr, newForeignPtr_)+import Foreign.Marshal.Alloc (mallocBytes)+#ifndef USE_GHC_MALLOC+import Foreign.ForeignPtr (newForeignPtr)+import Foreign.Marshal.Alloc (finalizerFree)+#endif++import qualified GHC.ForeignPtr as GHC++{-# INLINE mallocForeignPtrAlignedBytes #-}+mallocForeignPtrAlignedBytes :: Int -> Int -> IO (GHC.ForeignPtr a)+#ifdef USE_GHC_MALLOC+mallocForeignPtrAlignedBytes size alignment = do+    GHC.mallocPlainForeignPtrAlignedBytes size alignment+#else+mallocForeignPtrAlignedBytes size _alignment = do+    p <- mallocBytes size+    newForeignPtr finalizerFree p+#endif++-- memalign alignment size+-- foreign import ccall unsafe "stdlib.h posix_memalign" _memalign :: CSize -> CSize -> IO (Ptr a)++mallocForeignPtrAlignedUnmanagedBytes :: Int -> Int -> IO (ForeignPtr a)+mallocForeignPtrAlignedUnmanagedBytes size _alignment = do+    -- XXX use posix_memalign/aligned_alloc for aligned allocation+    p <- mallocBytes size+    newForeignPtr_ p
+ src/Streamly/Memory/Ring.hs view
@@ -0,0 +1,194 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ExistentialQuantification #-}++-- |+-- Module      : Streamly.Memory.Ring+-- Copyright   : (c) 2019 Composewell Technologies+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--++module Streamly.Memory.Ring+    ( Ring(..)++    -- * Construction+    , new++    -- * Modification+    , unsafeInsert++    -- * Folds+    , unsafeFoldRing+    , unsafeFoldRingM+    , unsafeFoldRingFullM++    -- * Fast Byte Comparisons+    , unsafeEqArray+    , unsafeEqArrayN+    ) where++import Control.Exception (assert)+import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)+import Foreign.Ptr (plusPtr, minusPtr, castPtr)+import Foreign.Storable (Storable(..))+import GHC.ForeignPtr (mallocPlainForeignPtrAlignedBytes)+import GHC.Ptr (Ptr(..))+import Prelude hiding (length, concat)++import qualified Streamly.Internal.Memory.Array.Types as A++-- | A ring buffer is a mutable array of fixed size. Initially the array is+-- empty, with ringStart pointing at the start of allocated memory. We call the+-- next location to be written in the ring as ringHead. Initially ringHead ==+-- ringStart. When the first item is added, ringHead points to ringStart ++-- sizeof item. When the buffer becomes full ringHead would wrap around to+-- ringStart. When the buffer is full, ringHead always points at the oldest+-- item in the ring and the newest item added always overwrites the oldest+-- item.+--+-- When using it we should keep in mind that a ringBuffer is a mutable data+-- structure. We should not leak out references to it for immutable use.+--+data Ring a = Ring+    { ringStart :: !(ForeignPtr a) -- first address+    , ringBound :: !(Ptr a)        -- first address beyond allocated memory+    }++-- | Create a new ringbuffer and return the ring buffer and the ringHead.+-- Returns the ring and the ringHead, the ringHead is same as ringStart.+{-# INLINE new #-}+new :: forall a. Storable a => Int -> IO (Ring a, Ptr a)+new count = do+    let size = count * sizeOf (undefined :: a)+    fptr <- mallocPlainForeignPtrAlignedBytes size (alignment (undefined :: a))+    let p = unsafeForeignPtrToPtr fptr+    return $ (Ring+        { ringStart = fptr+        , ringBound = p `plusPtr` size+        }, p)++-- | Advance the ringHead by 1 item, wrap around if we hit the end of the+-- array.+{-# INLINE advance #-}+advance :: forall a. Storable a => Ring a -> Ptr a -> Ptr a+advance Ring{..} ringHead =+    let ptr = ringHead `plusPtr` sizeOf (undefined :: a)+    in if ptr <  ringBound+       then ptr+       else unsafeForeignPtrToPtr ringStart++-- | Insert an item at the head of the ring, when the ring is full this+-- replaces the oldest item in the ring with the new item. This is unsafe+-- beause ringHead supplied is not verified to be within the Ring. Also,+-- the ringStart foreignPtr must be guaranteed to be alive by the caller.+{-# INLINE unsafeInsert #-}+unsafeInsert :: Storable a => Ring a -> Ptr a -> a -> IO (Ptr a)+unsafeInsert rb ringHead newVal = do+    poke ringHead newVal+    -- touchForeignPtr (ringStart rb)+    return $ advance rb ringHead++-- XXX remove all usage of A.unsafeInlineIO+--+-- | Like 'unsafeEqArray' but compares only N bytes instead of entire length of+-- the ring buffer. This is unsafe because the ringHead Ptr is not checked to+-- be in range.+{-# INLINE unsafeEqArrayN #-}+unsafeEqArrayN :: Ring a -> Ptr a -> A.Array a -> Int -> Bool+unsafeEqArrayN Ring{..} rh A.Array{..} n =+    let !res = A.unsafeInlineIO $ do+            let rs = unsafeForeignPtrToPtr ringStart+            let 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)+            r2 <- if n > len+                then A.memcmp (castPtr rs) (castPtr (as `plusPtr` len))+                              (min (rh `minusPtr` rs) (n - len))+                else return True+            -- XXX enable these, check perf impact+            -- touchForeignPtr ringStart+            -- touchForeignPtr aStart+            return (r1 && r2)+    in res++-- | Byte compare the entire length of ringBuffer with the given array,+-- starting at the supplied ringHead pointer.  Returns true if the Array and+-- the ringBuffer have identical contents.+--+-- This is unsafe because the ringHead Ptr is not checked to be in range. The+-- supplied array must be equal to or bigger than the ringBuffer, ARRAY BOUNDS+-- ARE NOT CHECKED.+{-# INLINE unsafeEqArray #-}+unsafeEqArray :: Ring a -> Ptr a -> A.Array a -> Bool+unsafeEqArray Ring{..} rh A.Array{..} =+    let !res = A.unsafeInlineIO $ do+            let rs = unsafeForeignPtrToPtr ringStart+            let as = unsafeForeignPtrToPtr aStart+            assert (aBound `minusPtr` as >= ringBound `minusPtr` rs)+                   (return ())+            let len = ringBound `minusPtr` rh+            r1 <- A.memcmp (castPtr rh) (castPtr as) len+            r2 <- A.memcmp (castPtr rs) (castPtr (as `plusPtr` len))+                           (rh `minusPtr` rs)+            -- XXX enable these, check perf impact+            -- touchForeignPtr ringStart+            -- touchForeignPtr aStart+            return (r1 && r2)+    in res++-- XXX use MonadIO+--+-- | Fold the buffer starting from ringStart up to the given 'Ptr' using a pure+-- step function. This is useful to fold the items in the ring when the ring is+-- not full. The supplied pointer is usually the end of the ring.+--+-- Unsafe because the supplied Ptr is not checked to be in range.+{-# INLINE unsafeFoldRing #-}+unsafeFoldRing :: forall a b. Storable a+    => Ptr a -> (b -> a -> b) -> b -> Ring a -> b+unsafeFoldRing ptr f z Ring{..} =+    let !res = A.unsafeInlineIO $ withForeignPtr ringStart $ \p ->+                    go z p ptr+    in res+    where+      go !acc !p !q+        | p == q = return acc+        | otherwise = do+            x <- peek p+            go (f acc x) (p `plusPtr` sizeOf (undefined :: a)) q++-- | Like unsafeFoldRing but with a monadic step function.+{-# INLINE unsafeFoldRingM #-}+unsafeFoldRingM :: forall m a b. (Monad 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+        | start == end = return acc+        | otherwise = do+            let !x = A.unsafeInlineIO $ peek start+            acc' <- f acc x+            go acc' (start `plusPtr` sizeOf (undefined :: a)) end++-- | Fold the entire length of a ring buffer starting at the supplied ringHead+-- pointer.  Assuming the supplied ringHead pointer points to the oldest item,+-- 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)+    => 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+            then return acc'+            else go acc' ptr
+ src/Streamly/Network/Inet/TCP.hs view
@@ -0,0 +1,49 @@+-- |+-- Module      : Streamly.Network.Server+-- Copyright   : (c) 2019 Composewell Technologies+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+-- Combinators to build Inet/TCP clients and servers.+--+-- > import qualified Streamly.Network.Inet.TCP as TCP+--++module Streamly.Network.Inet.TCP+    (+    -- * Accept Connections+      acceptOnAddr+    , acceptOnPort+    , acceptOnPortLocal++    -- * Connect to Servers+    , connect++    {-+    -- ** Sink Servers++    -- These abstractions can be applied to any setting where we need to do a+    -- sink processing of multiple streams e.g. output from multiple processes+    -- or data coming from multiple files.++    -- handle connections concurrently using a specified fold+    -- , handleConnections++    -- handle frames concurrently using a specified fold+    , handleFrames++    -- merge frames from all connection into a single stream. Frames can be+    -- created by a specified fold.+    , mergeFrames++    -- * UDP Servers+    , datagrams+    , datagramsOn+    -}+    )+where++import Streamly.Internal.Network.Inet.TCP
+ src/Streamly/Network/Socket.hs view
@@ -0,0 +1,57 @@+-- |+-- Module      : Streamly.Network.Socket+-- Copyright   : (c) 2018 Composewell Technologies+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+-- A socket is a handle to a protocol endpoint.+--+-- This module provides APIs to read and write streams and arrays to and from+-- 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.+-- APIs for unconnected sockets need to explicitly specify the remote endpoint.+--+-- = Programmer Notes+--+-- Read IO requests to connected stream sockets are performed in chunks of+-- 'Streamly.Internal.Memory.Array.Types.defaultChunkSize'.  Unless specified+-- otherwise in the API, writes are collected into chunks of+-- 'Streamly.Internal.Memory.Array.Types.defaultChunkSize' before they are+-- written to the socket. APIs are provided to control the chunking behavior.+--+-- > import qualified Streamly.Network.Socket as SK+--+-- For additional, experimental APIs take a look at+-- "Streamly.Internal.Network.Socket" module.++-- By design, connected socket IO APIs are similar to+-- "Streamly.Memory.Array" read write APIs. They are almost identical to the+-- sequential streaming APIs in "Streamly.Internal.FileSystem.File".+--+module Streamly.Network.Socket+    (+    -- * Socket Specification+      SockSpec(..)++    -- * Accept Connections+    , accept++    -- * Read+    , read+    , readWithBufferOf+    , readChunks+    , readChunksWithBufferOf++    -- * Write+    , write+    , writeWithBufferOf+    , writeChunks+    )+where++import Streamly.Internal.Network.Socket+import Prelude hiding (read)
src/Streamly/Prelude.hs view
@@ -1,1849 +1,932 @@ {-# LANGUAGE CPP                       #-}-{-# LANGUAGE FlexibleContexts          #-}--#if __GLASGOW_HASKELL__ >= 800-{-# OPTIONS_GHC -Wno-orphans #-}-#endif--#include "Streams/inline.hs"---- |--- Module      : Streamly.Prelude--- Copyright   : (c) 2017 Harendra Kumar------ License     : BSD3--- Maintainer  : harendra.kumar@gmail.com--- Stability   : experimental--- Portability : GHC------ This module is designed to be imported qualified:------ @--- import qualified Streamly.Prelude as S--- @------ Functions with the suffix @M@ are general functions that work on monadic--- arguments. The corresponding functions without the suffix @M@ work on pure--- arguments and can in general be derived from their monadic versions but are--- provided for convenience and for consistency with other pure APIs in the--- @base@ package.------ In many cases, short definitions of the combinators are provided in the--- documentation for illustration. The actual implementation may differ for--- performance reasons.------ Functions having a 'MonadAsync' constraint work concurrently when used with--- appropriate stream type combinator. Please be careful to not use 'parallely'--- with infinite streams.------ Deconstruction and folds accept a 'SerialT' type instead of a polymorphic--- type to ensure that streams always have a concrete monomorphic type by--- default, reducing type errors. In case you want to use any other type of--- stream you can use one of the type combinators provided in the "Streamly"--- module to convert the stream type.--module Streamly.Prelude-    (-    -- * Construction-    -- ** Primitives-    -- | Primitives to construct a stream from pure values or monadic actions.-    -- All other stream construction and generation combinators described later-    -- can be expressed in terms of these primitives. However, the special-    -- versions provided in this module can be much more efficient in most-    -- cases. Users can create custom combinators using these primitives.--      K.nil-    , K.cons-    , (K..:)--    , consM-    , (|:)--    -- ** From Values-    -- | Generate a monadic stream from a seed value or values.-    , yield-    , yieldM-    , K.repeat-    , repeatM-    , replicate-    , replicateM--    -- Note: Using enumeration functions e.g. 'Prelude.enumFromThen' turns out-    -- to be slightly faster than the idioms like @[from, then..]@.-    ---    -- ** Enumeration-    -- | We can use the 'Enum' type class to enumerate a type producing a list-    -- and then convert it to a stream:-    ---    -- @-    -- 'fromList' $ 'Prelude.enumFromThen' from then-    -- @-    ---    -- However, this is not particularly efficient.-    -- The 'Enumerable' type class provides corresponding functions that-    -- generate a stream instead of a list, efficiently.--    , Enumerable (..)-    , enumerate-    , enumerateTo--    -- ** From Generators-    -- | Generate a monadic stream from a seed value and a generator function.-    , unfoldr-    , unfoldrM-    , iterate-    , iterateM-    , fromIndices-    , fromIndicesM--    -- ** From Containers-    -- | Convert an input structure, container or source into a stream. All of-    -- these can be expressed in terms of primitives.-    , P.fromList-    , fromListM-    , K.fromFoldable-    , fromFoldableM--    -- ** From External Containers-    , fromHandle--    -- * Elimination--    -- ** Primitives-    -- | It is easy to express all the folds in terms of the 'uncons' primitive,-    -- however the specific implementations provided later are generally more-    -- efficient.  Folds are inherently serial as each step needs to use the-    -- result of the previous step.-    , uncons--    -- ** General Folds--- | Right and left folds.--- As a simple rule, always use lazy right fold for construction and strict--- left fold for reduction. By construction we mean using a constructor as the--- outermost operation in the fold function, by reduction we mean using a--- function as the outermost operation in the fold function.------ +-----------------------------------+--------------------------------------+--- | Right Fold                        | Left Fold                            |--- +===================================+======================================+--- | Construction consumes input       | Construction consumes all input,     |--- | lazily and streams it in FIFO     | and constructs in reverse (LIFO)     |--- | order                             | order                                |--- +-----------------------------------+--------------------------------------+--- | Reduction ends up buffering all   | Strict reduction works               |--- | input before it can be reduced    | incrementally, without buffering.    |--- +-----------------------------------+--------------------------------------+------ Almost always, we need lazy construction and strict reduction, therefore,--- strict @foldr@ and lazy @foldl@ are rarely useful. If needed, strict @foldr@--- and lazy @foldl@ can be expressed in terms of the available versions.  For--- example, a lazy @foldl@ can be replaced by a strict @foldl@ to reverse the--- structure followed by a @foldr@.------ The following equations may help understand the relation between the two--- folds for lists:------ @--- foldr f z xs = foldl (flip f) z (reverse xs)--- foldl f z xs = foldr (flip f) z (reverse xs)--- @------ More generally:------ @--- foldl f z xs = foldr g id xs z where g x k = k . flip f x--- foldr f z xs = foldl g id xs z where g k x = k . f x--- @--    , foldr-    , foldr1-    , foldrM-    , foldl'-    , foldl1'-    , foldlM'-    , foldx-    , foldxM--    -- ** Run Effects-    , runStream-    , runN-    , runWhile--    -- ** To Elements-    -- | Folds that extract selected elements of a stream or their properties.-    , (!!)-    , head-    , last-    , findM-    , find-    , lookup-    , findIndex-    , elemIndex--    -- ** To Parts-    -- | Folds that extract selected parts of a stream.-    , tail-    , init--    -- ** To Boolean-    -- | Folds that summarize the stream to a boolean value.-    , null-    , elem-    , notElem-    , all-    , any-    , and-    , or--    -- ** To Summary-    -- | Folds that summarize the stream to a single value.-    , length-    , sum-    , product--    -- ** To Summary (Maybe)-    -- | Folds that summarize a non-empty stream to a 'Just' value and return-    -- 'Nothing' for an empty stream.-    , maximumBy-    , maximum-    , minimumBy-    , minimum-    , the--    -- ** To Containers-    -- | Convert or divert a stream into an output structure, container or-    -- sink.-    , toList-    , toHandle--    -- * Transformation--    -- ** Scanning-    -- | Scans stream all the intermediate reduction steps of the corresponding-    -- folds. The following equations hold for lists:-    ---    -- > scanl f z xs == map (foldl f z) $ inits xs-    -- > scanr f z xs == map (foldr f z) $ tails-    ---    -- We do not provide a right associative scan, it can be recovered from a-    -- 'scanl'' as follows:-    ---    -- > scanr f z xs ==  reverse $ scanl' (flip f) z (reverse xs)-    ---    -- Scan is like a stateful map. If we discard the state, we get the map:-    ---    -- > S.drop 1 $ S.scanl' (\_ x -> f x) z xs == map f xs--    -- > S.postscanl' (\_ x -> f x) z xs == map f xs--    , scanl'-    , scanlM'-    -- , postscanl'-    -- , postscanlM'-    -- , prescanl'-    -- , prescanlM'-    , scanl1'-    , scanl1M'-    , scanx--    -- ** Mapping-    -- | Map is a strictly one-to-one transformation of stream elements. It-    -- cannot add or remove elements from the stream, just transforms them.-    , Serial.map--    -- ** Flattening-    , sequence-    , mapM--    -- ** Filtering-    -- | Filtering may remove some elements from the stream.--    , filter-    , filterM-    , take-    , takeWhile-    , takeWhileM-    , drop-    , dropWhile-    , dropWhileM-    , deleteBy-    , uniq--    -- ** Insertion-    -- | Insertion adds more elements to the stream.--    , insertBy-    , intersperseM--    -- ** Reordering-    , reverse--    -- * Hybrid Operations-    -- ** Map and Fold-    , mapM_--    -- ** Map and Filter-    , mapMaybe-    , mapMaybeM--    -- ** Scan and filter-    , findIndices-    , elemIndices--    -- * Multi-Stream Operations-    -- | New streams can be constructed by appending, merging or zipping-    -- existing streams.--    -- ** Appending-    -- | Streams form a 'Semigroup' and a 'Monoid' under the append-    -- operation.-    ---    -- @-    -- >> S.toList $ S.fromList [1,2] \<> S.fromList [3,4]-    -- [1,2,3,4]-    -- >> S.toList $ fold $ [S.fromList [1,2], S.fromList [3,4]]-    -- [1,2,3,4]-    -- @--    -- ** Merging-    -- | Streams form a commutative semigroup under the merge-    -- operation.--    -- , merge-    , mergeBy-    , mergeByM-    , mergeAsyncBy-    , mergeAsyncByM--    -- ** Zipping-    , zipWith-    , zipWithM-    , Z.zipAsyncWith-    , Z.zipAsyncWithM--    -- Special zips-    , indexed-    , indexedR--    -- ** Flattening-    , concatMapM-    , concatMap--    -- ** Folds-    , eqBy-    , cmpBy-    , isPrefixOf-    , isSubsequenceOf-    , stripPrefix--    -- * Deprecated-    , K.once-    , each-    , scan-    , foldl-    , foldlM-    )-where--import Control.Monad.IO.Class (MonadIO(..))-import Data.Maybe (isJust, fromJust)-import Prelude-       hiding (filter, drop, dropWhile, take, takeWhile, zipWith, foldr,-               foldl, mapM, mapM_, sequence, all, any, sum, product, elem,-               notElem, maximum, minimum, head, last, tail, length, null,-               reverse, iterate, init, and, or, lookup, foldr1, (!!),-               scanl, scanl1, replicate, concatMap)--import qualified Prelude-import qualified System.IO as IO--import Streamly.Enumeration (Enumerable(..), enumerate, enumerateTo)-import Streamly.SVar (MonadAsync, defState)-import Streamly.Streams.Async (mkAsync')-import Streamly.Streams.Combinators (maxYields)-import Streamly.Streams.Prelude (fromStreamS, toStreamS)-import Streamly.Streams.StreamD (fromStreamD, toStreamD)-import Streamly.Streams.StreamK (IsStream(..))-import Streamly.Streams.Serial (SerialT)--import qualified Streamly.Streams.Prelude as P-import qualified Streamly.Streams.StreamK as K-import qualified Streamly.Streams.StreamD as D-import qualified Streamly.Streams.Zip as Z--#ifdef USE_STREAMK_ONLY-import qualified Streamly.Streams.StreamK as S-import qualified Streamly.Streams.Zip as S-#else-import qualified Streamly.Streams.StreamD as S-#endif--import qualified Streamly.Streams.Serial as Serial----------------------------------------------------------------------------------- Deconstruction----------------------------------------------------------------------------------- | Decompose a stream into its head and tail. If the stream is empty, returns--- 'Nothing'. If the stream is non-empty, returns @Just (a, ma)@, where @a@ is--- the head of the stream and @ma@ its tail.------ @since 0.1.0-{-# INLINE uncons #-}-uncons :: (IsStream t, Monad m) => SerialT m a -> m (Maybe (a, t m a))-uncons m = K.uncons (K.adapt m)----------------------------------------------------------------------------------- Generation by Unfolding----------------------------------------------------------------------------------- |--- @--- unfoldr step s =---     case step s of---         Nothing -> 'K.nil'---         Just (a, b) -> a \`cons` unfoldr step b--- @------ Build a stream by unfolding a /pure/ step function @step@ starting from a--- seed @s@.  The step function returns the next element in the stream and the--- next seed value. When it is done it returns 'Nothing' and the stream ends.--- For example,------ @--- let f b =---         if b > 3---         then Nothing---         else Just (b, b + 1)--- in toList $ unfoldr f 0--- @--- @--- [0,1,2,3]--- @------ @since 0.1.0-{-# INLINE_EARLY unfoldr #-}-unfoldr :: (Monad m, IsStream t) => (b -> Maybe (a, b)) -> b -> t m a-unfoldr step seed = fromStreamS (S.unfoldr step seed)-{-# RULES "unfoldr fallback to StreamK" [1]-    forall a b. S.toStreamK (S.unfoldr a b) = K.unfoldr a b #-}---- | Build a stream by unfolding a /monadic/ step function starting from a--- seed.  The step function returns the next element in the stream and the next--- seed value. When it is done it returns 'Nothing' and the stream ends. For--- example,------ @--- let f b =---         if b > 3---         then return Nothing---         else print b >> return (Just (b, b + 1))--- in runStream $ unfoldrM f 0--- @--- @---  0---  1---  2---  3--- @--- When run concurrently, the next unfold step can run concurrently with the--- processing of the output of the previous step.  Note that more than one step--- cannot run concurrently as the next step depends on the output of the--- previous step.------ @--- (asyncly $ S.unfoldrM (\\n -> liftIO (threadDelay 1000000) >> return (Just (n, n + 1))) 0)---     & S.foldlM' (\\_ a -> threadDelay 1000000 >> print a) ()--- @------ /Concurrent/------ /Since: 0.1.0/-{-# INLINE_EARLY unfoldrM #-}-unfoldrM :: (IsStream t, MonadAsync m) => (b -> m (Maybe (a, b))) -> b -> t m a-unfoldrM = K.unfoldrM--{-# RULES "unfoldrM serial" unfoldrM = unfoldrMSerial #-}-{-# INLINE_EARLY unfoldrMSerial #-}-unfoldrMSerial :: MonadAsync m => (b -> m (Maybe (a, b))) -> b -> SerialT m a-unfoldrMSerial step seed = fromStreamS (S.unfoldrM step seed)----------------------------------------------------------------------------------- Specialized Generation----------------------------------------------------------------------------------- Faster than yieldM because there is no bind.------ |--- @--- yield a = a \`cons` nil--- @------ Create a singleton stream from a pure value.------ The following holds in monadic streams, but not in Zip streams:------ @--- yield = pure--- yield = yieldM . pure--- @------ In Zip applicative streams 'yield' is not the same as 'pure' because in that--- case 'pure' is equivalent to 'repeat' instead. 'yield' and 'pure' are--- equally efficient, in other cases 'yield' may be slightly more efficient--- than the other equivalent definitions.------ @since 0.4.0-{-# INLINE yield #-}-yield :: IsStream t => a -> t m a-yield = K.yield---- |--- @--- yieldM m = m \`consM` nil--- @------ Create a singleton stream from a monadic action.------ @--- > toList $ yieldM getLine--- hello--- ["hello"]--- @------ @since 0.4.0-{-# INLINE yieldM #-}-yieldM :: (Monad m, IsStream t) => m a -> t m a-yieldM = K.yieldM---- |--- @--- fromIndices f = let g i = f i \`cons` g (i + 1) in g 0--- @------ Generate an infinite stream, whose values are the output of a function @f@--- applied on the corresponding index.  Index starts at 0.------ @--- > S.toList $ S.take 5 $ S.fromIndices id--- [0,1,2,3,4]--- @------ @since 0.6.0-{-# INLINE fromIndices #-}-fromIndices :: (IsStream t, Monad m) => (Int -> a) -> t m a-fromIndices = fromStreamD . D.fromIndices---- XXX this needs to be concurrent------ |--- @--- fromIndicesM f = let g i = f i \`consM` g (i + 1) in g 0--- @------ Generate an infinite stream, whose values are the output of a monadic--- function @f@ applied on the corresponding index. Index starts at 0.------ @since 0.6.0-{-# INLINE fromIndicesM #-}-fromIndicesM :: (IsStream t, Monad m) => (Int -> m a) -> t m a-fromIndicesM = fromStreamD . D.fromIndicesM---- |--- @--- replicateM = take n . repeatM--- @------ Generate a stream by performing a monadic action @n@ times. Same as:------ @--- runStream $ serially $ S.replicateM 10 $ (threadDelay 1000000 >> print 1)--- runStream $ asyncly  $ S.replicateM 10 $ (threadDelay 1000000 >> print 1)--- @------ /Concurrent/------ @since 0.1.1-{-# INLINE_EARLY replicateM #-}-replicateM :: (IsStream t, MonadAsync m) => Int -> m a -> t m a-replicateM = K.replicateM--{-# RULES "replicateM serial" replicateM = replicateMSerial #-}-{-# INLINE replicateMSerial #-}-replicateMSerial :: MonadAsync m => Int -> m a -> SerialT m a-replicateMSerial n = fromStreamS . S.replicateM n---- |--- @--- replicate = take n . repeat--- @------ Generate a stream of length @n@ by repeating a value @n@ times.------ @since 0.6.0-replicate :: (IsStream t, Monad m) => Int -> a -> t m a-replicate n = fromStreamS . S.replicate n---- |--- @--- repeatM = fix . consM--- repeatM = cycle1 . yieldM--- @------ Generate a stream by repeatedly executing a monadic action forever.------ @--- runStream $ serially $ S.take 10 $ S.repeatM $ (threadDelay 1000000 >> print 1)--- runStream $ asyncly  $ S.take 10 $ S.repeatM $ (threadDelay 1000000 >> print 1)--- @------ /Concurrent, infinite (do not use with 'parallely')/------ @since 0.2.0-repeatM :: (IsStream t, MonadAsync m) => m a -> t m a-repeatM = go-    where go m = m |: go m---- |--- @--- iterate f x = x \`cons` iterate f x--- @------ Generate an infinite stream with @x@ as the first element and each--- successive element derived by applying the function @f@ on the previous--- element.------ @--- > S.toList $ S.take 5 $ S.iterate (+1) 1--- [1,2,3,4,5]--- @------ @since 0.1.2-iterate :: IsStream t => (a -> a) -> a -> t m a-iterate step = fromStream . go-    where-    go s = K.cons s (go (step s))---- |--- @--- iterateM f m = m \`consM` iterateM f m--- @------ Generate an infinite stream with the first element generated by the action--- @m@ and each successive element derived by applying the monadic function--- @f@ on the previous element.------ When run concurrently, the next iteration can run concurrently with the--- processing of the previous iteration. Note that more than one iteration--- cannot run concurrently as the next iteration depends on the output of the--- previous iteration.------ @--- runStream $ serially $ S.take 10 $ S.iterateM---      (\\x -> threadDelay 1000000 >> print x >> return (x + 1)) 0------ runStream $ asyncly  $ S.take 10 $ S.iterateM---      (\\x -> threadDelay 1000000 >> print x >> return (x + 1)) 0--- @------ /Concurrent/------ @since 0.1.2-iterateM :: (IsStream t, MonadAsync m) => (a -> m a) -> a -> t m a-iterateM step = go-    where-    go s = K.mkStream $ \st stp sng yld -> do-       next <- step s-       K.foldStreamShared st stp sng yld (return s |: go next)----------------------------------------------------------------------------------- Conversions----------------------------------------------------------------------------------- |--- @--- fromListM = 'Prelude.foldr' 'K.consM' 'K.nil'--- @------ Construct a stream from a list of monadic actions. This is more efficient--- than 'fromFoldableM' for serial streams.------ @since 0.4.0-{-# INLINE_EARLY fromListM #-}-fromListM :: (MonadAsync m, IsStream t) => [m a] -> t m a-fromListM = fromStreamD . D.fromListM-{-# RULES "fromListM fallback to StreamK" [1]-    forall a. D.toStreamK (D.fromListM a) = fromFoldableM a #-}---- |--- @--- fromFoldableM = 'Prelude.foldr' 'consM' 'K.nil'--- @------ Construct a stream from a 'Foldable' containing monadic actions.------ @--- runStream $ serially $ S.fromFoldableM $ replicateM 10 (threadDelay 1000000 >> print 1)--- runStream $ asyncly  $ S.fromFoldableM $ replicateM 10 (threadDelay 1000000 >> print 1)--- @------ /Concurrent (do not use with 'parallely' on infinite containers)/------ @since 0.3.0-{-# INLINE fromFoldableM #-}-fromFoldableM :: (IsStream t, MonadAsync m, Foldable f) => f (m a) -> t m a-fromFoldableM = Prelude.foldr consM K.nil---- | Same as 'fromFoldable'.------ @since 0.1.0-{-# DEPRECATED each "Please use fromFoldable instead." #-}-{-# INLINE each #-}-each :: (IsStream t, Foldable f) => f a -> t m a-each = K.fromFoldable---- | Read lines from an IO Handle into a stream of Strings.------ @since 0.1.0-fromHandle :: (IsStream t, MonadIO m) => IO.Handle -> t m String-fromHandle h = go-  where-  go = K.mkStream $ \_ yld _ stp -> do-        eof <- liftIO $ IO.hIsEOF h-        if eof-        then stp-        else do-            str <- liftIO $ IO.hGetLine h-            yld str go----------------------------------------------------------------------------------- Elimination by Folding----------------------------------------------------------------------------------- | Lazy right fold with a monadic step function. For example, to fold a--- stream into a list:------ @--- >> S.foldrM (\\x xs -> return (x : xs)) [] $ fromList [1,2,3]--- [1,2,3]--- @------ @since 0.2.0-{-# INLINE foldrM #-}-foldrM :: Monad m => (a -> b -> m b) -> b -> SerialT m a -> m b-foldrM = P.foldrM---- | Lazy right associative fold.------ For lists a @foldr@ looks like:------ @--- foldr f z []     = z--- foldr f z (x:xs) = x \`f` foldr f z xs--- @------ The recursive expression is the second argument of the fold step `f`.--- Therefore, the evaluation of the recursive call depends on `f`.  It can--- terminate recursion by not inspecting the second argument based on a--- condition.  When expanded fully, it results in the following right associated--- expression:------ @--- foldr f z xs == x1 \`f` (x2 \`f` ...(xn \`f` z))--- @------ When `f` is a constructor, we can see that the first deconstruction of this--- expression would be @x1@ on the left and the recursive expression on the--- right.  Therefore, we can deconstruct it to access the input elements in the--- first-in-first-out (FIFO) order and consume the reconstructed structure--- lazily.  The recursive expression on the right gets evaluated incrementall--- as demanded by the consumer. For example:------ @--- > S.foldr (:) [] $ S.fromList [1,2,3,4]--- [1,2,3,4]--- @------ When `f` is a function strict in its second argument, the right side of the--- expression gets evaluated as follows:------ @--- foldr f z xs == x1 \`f` tail1--- tail1        == x2 \`f` tail2--- tail2        == x3 \`f` tail3--- ...--- tailn        == xn \`f` z--- @------ In @foldl'@ we have both the arguments of `f` available at each step,--- therefore, each step can be reduced immediately. However, in @foldr@ the--- second argument to `f` is a recursive call, therefore, it ends up building--- the whole expression in memory before it can be reduced, consuming the whole--- input.  This makes @foldr@ much less efficient for reduction compared to--- @foldl'@. For example:------ @--- > S.foldr (+) 0 $ S.fromList [1,2,3,4]--- 10--- @------ When the underlying monad @m@ is strict (e.g. IO), then @foldr@ ends up--- evaluating all of its input because of strict evaluation of the recursive--- call:------ >> S.foldr (\_ _ -> []) [] $ S.fromList (1:undefined)--- >*** Exception: Prelude.undefined------ In a lazy monad, we can consume the input lazily, and terminate the fold--- by conditionally not inspecting the recursive expression.------ >> runIdentity $ S.foldr (\x rest -> if x == 3 then [] else x : rest) [] $ S.fromList (4:1:3:undefined)--- >[4,1]------ The arguments to the folding function (@a -> b -> b@) are in the head and--- tail order of the output, @a@ is the head and @b@ is the tail. Remember, in--- a right fold the zero is on the right, it is the tail end.------ @since 0.1.0-{-# INLINE foldr #-}-foldr :: Monad m => (a -> b -> b) -> b -> SerialT m a -> m b-foldr = P.foldr---- XXX This seems to be of limited use as it cannot be used to construct--- recursive structures and for reduction foldl1' is better.------ | Lazy right fold for non-empty streams, using first element as the starting--- value. Returns 'Nothing' if the stream is empty.------ @since 0.5.0-{-# INLINE foldr1 #-}-foldr1 :: Monad m => (a -> a -> a) -> SerialT m a -> m (Maybe a)-foldr1 f m = S.foldr1 f (toStreamS m)---- | Strict left fold with an extraction function. Like the standard strict--- left fold, but applies a user supplied extraction function (the third--- argument) to the folded value at the end. This is designed to work with the--- @foldl@ library. The suffix @x@ is a mnemonic for extraction.------ @since 0.2.0-{-# INLINE foldx #-}-foldx :: Monad m => (x -> a -> x) -> x -> (x -> b) -> SerialT m a -> m b-foldx = K.foldx---- |--- @since 0.1.0-{-# DEPRECATED foldl "Please use foldx instead." #-}-foldl :: Monad m => (x -> a -> x) -> x -> (x -> b) -> SerialT m a -> m b-foldl = foldx---- | Strict left associative fold.------ For lists a @foldl@ looks like:------ @--- foldl f z []     = z--- foldl f z (x:xs) = foldl f (z \`f` x) xs--- @------ The recursive call at the head of the output expression is bound to be--- evaluated until recursion terminates,--- /deconstructing the whole input container/ and building the following left--- associated expression:------ @--- foldl f z xs == (((z \`f` x1) \`f` x2) ...) \`f` xn--- @------ When `f` is a constructor, we can see that the first deconstruction of this--- expression would be the recursive expression on the left and `xn` on the--- right. Therefore, it can access the input elements only in the reverse--- (LIFO) order.  For example:------ @--- > S.foldl' (flip (:)) [] $ S.fromList [1,2,3,4]--- [4,3,2,1]--- @------ The strict left fold @foldl'@ forces the reduction of its argument @z \`f`--- x@ before using it, therefore it never builds the whole expression in--- memory.  Thus, @z \`f` x1@ would get reduced to @z1@ and then @z1 \`f` x2@--- would get reduced to @z2@ and so on, incrementally reducing the expression--- as it recurses.  However, it evaluates the accumulator only to WHNF, it may--- further help to use a strict data structure as accumulator. For example:------ @--- > S.foldl' (+) 0 $ S.fromList [1,2,3,4]--- 10--- @------ @--- 0 + 1--- (0 + 1) + 2--- ((0 + 1) + 2) + 3--- (((0 + 1) + 2) + 3) + 4--- @------ @foldl@ strictly deconstructs the whole input container irrespective of--- whether it needs it or not:------ >> S.foldl' (\acc x -> if x == 3 then acc else x : acc) [] $ S.fromList (4:1:3:undefined)--- >*** Exception: Prelude.undefined------ However, evaluation of the items contained in the input container is lazy as--- demanded by the fold step function:------ >> S.foldl' (\acc x -> if x == 3 then acc else x : acc) [] $ S.fromList [4,1,3,undefined]--- >[4,1]------ To perform a left fold without consuming all the input one can use @scanl@--- to stream the intermediate results of the fold and use them lazily.------ In stateful or event-driven programming, we can consider @z@ as the initial--- state and the stream being folded as a stream of events, thus @foldl'@--- processes all the events in the stream updating the state on each event and--- then ultimately returning the final state.------ The arguments to the folding function (@b -> a -> b@) are in the head and--- tail order of the output expression, @b@ is the head and @a@ is the tail.--- Remember, in a left fold the zero is on the left, at the head of the--- expression.------ @since 0.2.0-{-# INLINE foldl' #-}-foldl' :: Monad m => (b -> a -> b) -> b -> SerialT m a -> m b-foldl' = P.foldl'---- | Strict left fold, for non-empty streams, using first element as the--- starting value. Returns 'Nothing' if the stream is empty.------ @since 0.5.0-{-# INLINE foldl1' #-}-foldl1' :: Monad m => (a -> a -> a) -> SerialT m a -> m (Maybe a)-foldl1' step m = do-    r <- uncons m-    case r of-        Nothing -> return Nothing-        Just (h, t) -> do-            res <- foldl' step h t-            return $ Just res---- | Like 'foldx', but with a monadic step function.------ @since 0.2.0-{-# INLINE foldxM #-}-foldxM :: Monad m => (x -> a -> m x) -> m x -> (x -> m b) -> SerialT m a -> m b-foldxM = K.foldxM---- |--- @since 0.1.0-{-# DEPRECATED foldlM "Please use foldxM instead." #-}-foldlM :: Monad m => (x -> a -> m x) -> m x -> (x -> m b) -> SerialT m a -> m b-foldlM = foldxM---- | Like 'foldl'' but with a monadic step function.------ @since 0.2.0-{-# INLINE foldlM' #-}-foldlM' :: Monad m => (b -> a -> m b) -> b -> SerialT m a -> m b-foldlM' step begin m = S.foldlM' step begin $ toStreamS m----------------------------------------------------------------------------------- Specialized folds----------------------------------------------------------------------------------- | Run a stream, discarding the results. By default it interprets the stream--- as 'SerialT', to run other types of streams use the type adapting--- combinators for example @runStream . 'asyncly'@.------ @since 0.2.0-{-# INLINE runStream #-}-runStream :: Monad m => SerialT m a -> m ()-runStream = P.runStream---- |--- > runN n = runStream . take n------ Run maximum up to @n@ iterations of a stream.------ @since 0.6.0-{-# INLINE runN #-}-runN :: Monad m => Int -> SerialT m a -> m ()-runN n = runStream . take n---- |--- > runWhile p = runStream . takeWhile p------ Run a stream as long as the predicate holds true.------ @since 0.6.0-{-# INLINE runWhile #-}-runWhile :: Monad m => (a -> Bool) -> SerialT m a -> m ()-runWhile p = runStream . takeWhile p---- | Determine whether the stream is empty.------ @since 0.1.1-{-# INLINE null #-}-null :: Monad m => SerialT m a -> m Bool-null = K.null---- | Extract the first element of the stream, if any.------ > head = (!! 0)------ @since 0.1.0-{-# INLINE head #-}-head :: Monad m => SerialT m a -> m (Maybe a)-head = K.head---- | Extract all but the first element of the stream, if any.------ @since 0.1.1-{-# INLINE tail #-}-tail :: (IsStream t, Monad m) => SerialT m a -> m (Maybe (t m a))-tail m = K.tail (K.adapt m)---- | Extract all but the last element of the stream, if any.------ @since 0.5.0-{-# INLINE init #-}-init :: (IsStream t, Monad m) => SerialT m a -> m (Maybe (t m a))-init m = K.init (K.adapt m)---- | Extract the last element of the stream, if any.------ > last xs = xs !! (length xs - 1)------ @since 0.1.1-{-# INLINE last #-}-last :: Monad m => SerialT m a -> m (Maybe a)-last m = S.last $ toStreamS m---- | Determine whether an element is present in the stream.------ @since 0.1.0-{-# INLINE elem #-}-elem :: (Monad m, Eq a) => a -> SerialT m a -> m Bool-elem e m = S.elem e (toStreamS m)---- | Determine whether an element is not present in the stream.------ @since 0.1.0-{-# INLINE notElem #-}-notElem :: (Monad m, Eq a) => a -> SerialT m a -> m Bool-notElem e m = S.notElem e (toStreamS m)---- | Determine the length of the stream.------ @since 0.1.0-{-# INLINE length #-}-length :: Monad m => SerialT m a -> m Int-length = foldl' (\n _ -> n + 1) 0---- | Determine whether all elements of a stream satisfy a predicate.------ @since 0.1.0-{-# INLINE all #-}-all :: Monad m => (a -> Bool) -> SerialT m a -> m Bool-all p m = S.all p (toStreamS m)---- | Determine whether any of the elements of a stream satisfy a predicate.------ @since 0.1.0-{-# INLINE any #-}-any :: Monad m => (a -> Bool) -> SerialT m a -> m Bool-any p m = S.any p (toStreamS m)---- | Determines if all elements of a boolean stream are True.------ @since 0.5.0-{-# INLINE and #-}-and :: Monad m => SerialT m Bool -> m Bool-and = all (==True)---- | Determines whether at least one element of a boolean stream is True.------ @since 0.5.0-{-# INLINE or #-}-or :: Monad m => SerialT m Bool -> m Bool-or = any (==True)---- | Determine the sum of all elements of a stream of numbers. Returns @0@ when--- the stream is empty. Note that this is not numerically stable for floating--- point numbers.------ @since 0.1.0-{-# INLINE sum #-}-sum :: (Monad m, Num a) => SerialT m a -> m a-sum = foldl' (+) 0---- | Determine the product of all elements of a stream of numbers. Returns @1@--- when the stream is empty.------ @since 0.1.1-{-# INLINE product #-}-product :: (Monad m, Num a) => SerialT m a -> m a-product = foldl' (*) 1---- |--- @--- minimum = 'minimumBy' compare--- @------ Determine the minimum element in a stream.------ @since 0.1.0-{-# INLINE minimum #-}-minimum :: (Monad m, Ord a) => SerialT m a -> m (Maybe a)-minimum m = S.minimum (toStreamS m)---- | Determine the minimum element in a stream using the supplied comparison--- function.------ @since 0.6.0-{-# INLINE minimumBy #-}-minimumBy :: Monad m => (a -> a -> Ordering) -> SerialT m a -> m (Maybe a)-minimumBy cmp m = S.minimumBy cmp (toStreamS m)---- |--- @--- maximum = 'maximumBy' compare--- @------ Determine the maximum element in a stream.------ @since 0.1.0-{-# INLINE maximum #-}-maximum :: (Monad m, Ord a) => SerialT m a -> m (Maybe a)-maximum m = S.maximum (toStreamS m)---- | Determine the maximum element in a stream using the supplied comparison--- function.------ @since 0.6.0-{-# INLINE maximumBy #-}-maximumBy :: Monad m => (a -> a -> Ordering) -> SerialT m a -> m (Maybe a)-maximumBy cmp m = S.maximumBy cmp (toStreamS m)---- | Lookup the element at the given index.------ @since 0.6.0-{-# INLINE (!!) #-}-(!!) :: Monad m => SerialT m a -> Int -> m (Maybe a)-m !! i = toStreamS m S.!! i---- | In a stream of (key-value) pairs @(a, b)@, return the value @b@ of the--- first pair where the key equals the given value @a@.------ > lookup = snd <$> find ((==) . fst)------ @since 0.5.0-{-# INLINE lookup #-}-lookup :: (Monad m, Eq a) => a -> SerialT m (a, b) -> m (Maybe b)-lookup a m = S.lookup a (toStreamS m)---- | Like 'findM' but with a non-monadic predicate.------ > find p = findM (return . p)------ @since 0.5.0-{-# INLINE find #-}-find :: Monad m => (a -> Bool) -> SerialT m a -> m (Maybe a)-find p m = S.find p (toStreamS m)---- | Returns the first element that satisfies the given predicate.------ @since 0.6.0-{-# INLINE findM #-}-findM :: Monad m => (a -> m Bool) -> SerialT m a -> m (Maybe a)-findM p m = S.findM p (toStreamS m)---- | Find all the indices where the element in the stream satisfies the given--- predicate.------ @since 0.5.0-{-# INLINE findIndices #-}-findIndices :: (IsStream t, Monad m) => (a -> Bool) -> t m a -> t m Int-findIndices p m = fromStreamS $ S.findIndices p (toStreamS m)---- | Returns the first index that satisfies the given predicate.------ @since 0.5.0-{-# INLINE findIndex #-}-findIndex :: Monad m => (a -> Bool) -> SerialT m a -> m (Maybe Int)-findIndex p = head . findIndices p---- | Find all the indices where the value of the element in the stream is equal--- to the given value.------ @since 0.5.0-{-# INLINE elemIndices #-}-elemIndices :: (IsStream t, Eq a, Monad m) => a -> t m a -> t m Int-elemIndices a = findIndices (==a)---- | Returns the first index where a given value is found in the stream.------ > elemIndex a = findIndex (== a)------ @since 0.5.0-{-# INLINE elemIndex #-}-elemIndex :: (Monad m, Eq a) => a -> SerialT m a -> m (Maybe Int)-elemIndex a = findIndex (== a)---- | Map each element to a stream and then flatten the results into a single--- stream.------ > concatMap f = concatMapM (return . f)------ @since 0.6.0-{-# INLINE concatMap #-}-concatMap ::(IsStream t, Monad m) => (a -> t m b) -> t m a -> t m b-concatMap f m = fromStreamD $ D.concatMap (toStreamD . f) (toStreamD m)---- | Map each element to a stream using a monadic function and then flatten the--- results into a single stream.------ @since 0.6.0-{-# INLINE concatMapM #-}-concatMapM :: (IsStream t, Monad m) => (a -> m (t m b)) -> t m a -> t m b-concatMapM f m = fromStreamD $ D.concatMapM (fmap toStreamD . f) (toStreamD m)----------------------------------------------------------------------------------- Substreams----------------------------------------------------------------------------------- | Returns 'True' if the first stream is the same as or a prefix of the--- second.------ @--- > S.isPrefixOf (S.fromList "hello") (S.fromList "hello" :: SerialT IO Char)--- True--- @------ @since 0.6.0-{-# INLINE isPrefixOf #-}-isPrefixOf :: (Eq a, IsStream t, Monad m) => t m a -> t m a -> m Bool-isPrefixOf m1 m2 = D.isPrefixOf (toStreamD m1) (toStreamD m2)---- | Returns 'True' if all the elements of the first stream occur, in order, in--- the second stream. The elements do not have to occur consecutively. A stream--- is treated as a subsequence of itself.------ @--- > S.isSubsequenceOf (S.fromList "hlo") (S.fromList "hello" :: SerialT IO Char)--- True--- @------ @since 0.6.0-{-# INLINE isSubsequenceOf #-}-isSubsequenceOf :: (Eq a, IsStream t, Monad m) => t m a -> t m a -> m Bool-isSubsequenceOf m1 m2 = D.isSubsequenceOf (toStreamD m1) (toStreamD m2)---- | Drops the given prefix from a stream. Returns 'Nothing' if the stream does--- not start with the given prefix. Returns @Just nil@ when the prefix is the--- same as the stream.------ @since 0.6.0-{-# INLINE stripPrefix #-}-stripPrefix-    :: (Eq a, IsStream t, Monad m)-    => t m a -> t m a -> m (Maybe (t m a))-stripPrefix m1 m2 = fmap fromStreamD <$>-    D.stripPrefix (toStreamD m1) (toStreamD m2)----------------------------------------------------------------------------------- Map and Fold----------------------------------------------------------------------------------- XXX this can utilize parallel mapping if we implement it as runStream . mapM--- | Apply a monadic action to each element of the stream and discard the--- output of the action.------ @since 0.1.0-{-# INLINE mapM_ #-}-mapM_ :: Monad m => (a -> m b) -> SerialT m a -> m ()-mapM_ f m = S.mapM_ f $ toStreamS m----------------------------------------------------------------------------------- Conversions----------------------------------------------------------------------------------- |--- @--- toList = S.foldr (:) []--- @------ Convert a stream into a list in the underlying monad. Same as:------ @since 0.1.0-{-# INLINE toList #-}-toList :: Monad m => SerialT m a -> m [a]-toList = P.toList---- |--- @--- toHandle h = S.mapM_ $ hPutStrLn h--- @------ Write a stream of Strings to an IO Handle.------ @since 0.1.0-toHandle :: MonadIO m => IO.Handle -> SerialT m String -> m ()-toHandle h m = go m-    where-    go m1 =-        let stop = return ()-            single a = liftIO (IO.hPutStrLn h a)-            yieldk a r = liftIO (IO.hPutStrLn h a) >> go r-        in K.foldStream defState yieldk single stop m1----------------------------------------------------------------------------------- Transformation by Folding (Scans)----------------------------------------------------------------------------------- | Strict left scan with an extraction function. Like 'scanl'', but applies a--- user supplied extraction function (the third argument) at each step. This is--- designed to work with the @foldl@ library. The suffix @x@ is a mnemonic for--- extraction.------ @since 0.2.0-{-# INLINE scanx #-}-scanx :: IsStream t => (x -> a -> x) -> x -> (x -> b) -> t m a -> t m b-scanx = K.scanx---- |--- @since 0.1.1-{-# DEPRECATED scan "Please use scanx instead." #-}-scan :: IsStream t => (x -> a -> x) -> x -> (x -> b) -> t m a -> t m b-scan = scanx---- XXX this needs to be concurrent--- | Like 'scanl'' but with a monadic fold function.------ @since 0.4.0-{-# INLINE scanlM' #-}-scanlM' :: (IsStream t, Monad m) => (b -> a -> m b) -> b -> t m a -> t m b-scanlM' step begin m = fromStreamD $ D.scanlM' step begin $ toStreamD m---- | Strict left scan.------ @--- > S.toList $ S.scanl' (+) 0 $ fromList [1,2,3,4]--- [0,1,3,6,10]--- @------ @--- > S.toList $ S.scanl' (flip (:)) [] $ S.fromList [1,2,3,4]--- [[],[1],[2,1],[3,2,1],[4,3,2,1]]--- @------ The output of 'scanl'' is the initial value of the accumulator followed by--- all the intermediate steps and the final result of 'foldl''.------ By streaming the accumulated state after each fold step, we can share the--- state across multiple stages of stream composition. Each stage can modify or--- extend the state, do some processing with it and emit it for the next stage,--- thus modularizing the stream processing. This can be useful in--- stateful or event-driven programming.------ Consider the following example, computing the sum and the product of the--- elements in a stream in one go using a @foldl'@:------ @--- > S.foldl' (\\(s, p) x -> (s + x, p * x)) (0,1) $ S.fromList \[1,2,3,4]--- (10,24)--- @------ Using @scanl'@ we can compute the sum in the first stage and pass it down to--- the next stage for computing the product:------ @--- >   S.foldl' (\\(_, p) (s, x) -> (s, p * x)) (0,1)---   $ S.scanl' (\\(s, _) x -> (s + x, x)) (0,1)---   $ S.fromList \[1,2,3,4]--- (10,24)--- @------ IMPORTANT: 'scanl'' evaluates the accumulator to WHNF.  To avoid building--- lazy expressions inside the accumulator, it is recommended that a strict--- data structure is used for accumulator.------ @since 0.2.0-{-# INLINE scanl' #-}-scanl' :: (IsStream t, Monad m) => (b -> a -> b) -> b -> t m a -> t m b-scanl' step z m = fromStreamS $ S.scanl' step z $ toStreamS m---- XXX enable once the signature (monadic zero) change is settled--- | Like scanl' but does not stream the initial value of the accumulator.------ > postscanl' f z xs = S.drop 1 $ scanl' f z xs------ @since 0.6.0-{-# INLINE _postscanl' #-}-_postscanl' :: (IsStream t, Monad m) => (b -> a -> b) -> b -> t m a -> t m b-_postscanl' step z m = fromStreamD $ D.postscanl' step z $ toStreamD m---- XXX this needs to be concurrent--- | Like postscanl' but with a monadic step function.------ @since 0.6.0-{-# INLINE _postscanlM' #-}-_postscanlM' :: (IsStream t, Monad m) => (b -> a -> m b) -> b -> t m a -> t m b-_postscanlM' step z m = fromStreamD $ D.postscanlM' step z $ toStreamD m---- XXX prescanl does not sound very useful, enable only if there is a--- compelling use case.------ | Like scanl' but does not stream the final value of the accumulator.------ @since 0.6.0-{-# INLINE _prescanl' #-}-_prescanl' :: (IsStream t, Monad m) => (b -> a -> b) -> b -> t m a -> t m b-_prescanl' step z m = fromStreamD $ D.prescanl' step z $ toStreamD m---- XXX this needs to be concurrent--- | Like postscanl' but with a monadic step function.------ @since 0.6.0-{-# INLINE _prescanlM' #-}-_prescanlM' :: (IsStream t, Monad m) => (b -> a -> m b) -> m b -> t m a -> t m b-_prescanlM' step z m = fromStreamD $ D.prescanlM' step z $ toStreamD m---- XXX this needs to be concurrent--- | Like 'scanl1'' but with a monadic step function.------ @since 0.6.0-{-# INLINE scanl1M' #-}-scanl1M' :: (IsStream t, Monad m) => (a -> a -> m a) -> t m a -> t m a-scanl1M' step m = fromStreamD $ D.scanl1M' step $ toStreamD m---- | Like 'scanl'' but for a non-empty stream. The first element of the stream--- is used as the initial value of the accumulator. Does nothing if the stream--- is empty.------ @--- > S.toList $ S.scanl1 (+) $ fromList [1,2,3,4]--- [1,3,6,10]--- @------ @since 0.6.0-{-# INLINE scanl1' #-}-scanl1' :: (IsStream t, Monad m) => (a -> a -> a) -> t m a -> t m a-scanl1' step m = fromStreamD $ D.scanl1' step $ toStreamD m----------------------------------------------------------------------------------- Transformation by Filtering----------------------------------------------------------------------------------- | Include only those elements that pass a predicate.------ @since 0.1.0-{-# INLINE filter #-}-#if __GLASGOW_HASKELL__ != 802--- GHC 8.2.2 crashes with this code, when used with "stack"-filter :: (IsStream t, Monad m) => (a -> Bool) -> t m a -> t m a-filter p m = fromStreamS $ S.filter p $ toStreamS m-#else-filter :: IsStream t => (a -> Bool) -> t m a -> t m a-filter = K.filter-#endif---- | Same as 'filter' but with a monadic predicate.------ @since 0.4.0-{-# INLINE filterM #-}-filterM :: (IsStream t, Monad m) => (a -> m Bool) -> t m a -> t m a-filterM p m = fromStreamD $ D.filterM p $ toStreamD m---- | Drop repeated elements that are adjacent to each other.------ @since 0.6.0-{-# INLINE uniq #-}-uniq :: (Eq a, IsStream t, Monad m) => t m a -> t m a-uniq = fromStreamD . D.uniq . toStreamD---- | Ensures that all the elements of the stream are identical and then returns--- that unique element.------ @since 0.6.0-{-# INLINE the #-}-the :: (Eq a, Monad m) => SerialT m a -> m (Maybe a)-the m = S.the (toStreamS m)---- | Take first 'n' elements from the stream and discard the rest.------ @since 0.1.0-{-# INLINE take #-}-take :: (IsStream t, Monad m) => Int -> t m a -> t m a-take n m = fromStreamS $ S.take n $ toStreamS-    (maxYields (Just (fromIntegral n)) m)---- | End the stream as soon as the predicate fails on an element.------ @since 0.1.0-{-# INLINE takeWhile #-}-takeWhile :: (IsStream t, Monad m) => (a -> Bool) -> t m a -> t m a-takeWhile p m = fromStreamS $ S.takeWhile p $ toStreamS m---- | Same as 'takeWhile' but with a monadic predicate.------ @since 0.4.0-{-# INLINE takeWhileM #-}-takeWhileM :: (IsStream t, Monad m) => (a -> m Bool) -> t m a -> t m a-takeWhileM p m = fromStreamD $ D.takeWhileM p $ toStreamD m---- | Discard first 'n' elements from the stream and take the rest.------ @since 0.1.0-{-# INLINE drop #-}-drop :: (IsStream t, Monad m) => Int -> t m a -> t m a-drop n m = fromStreamS $ S.drop n $ toStreamS m---- | Drop elements in the stream as long as the predicate succeeds and then--- take the rest of the stream.------ @since 0.1.0-{-# INLINE dropWhile #-}-dropWhile :: (IsStream t, Monad m) => (a -> Bool) -> t m a -> t m a-dropWhile p m = fromStreamS $ S.dropWhile p $ toStreamS m---- | Same as 'dropWhile' but with a monadic predicate.------ @since 0.4.0-{-# INLINE dropWhileM #-}-dropWhileM :: (IsStream t, Monad m) => (a -> m Bool) -> t m a -> t m a-dropWhileM p m = fromStreamD $ D.dropWhileM p $ toStreamD m----------------------------------------------------------------------------------- Transformation by Mapping----------------------------------------------------------------------------------- |--- @--- mapM f = sequence . map f--- @------ Apply a monadic function to each element of the stream and replace it with--- the output of the resulting action.------ @--- > runStream $ S.mapM putStr $ S.fromList ["a", "b", "c"]--- abc------ runStream $ S.replicateM 10 (return 1)---           & (serially . S.mapM (\\x -> threadDelay 1000000 >> print x))------ runStream $ S.replicateM 10 (return 1)---           & (asyncly . S.mapM (\\x -> threadDelay 1000000 >> print x))--- @------ /Concurrent (do not use with 'parallely' on infinite streams)/------ @since 0.1.0-{-# INLINE_EARLY mapM #-}-mapM :: (IsStream t, MonadAsync m) => (a -> m b) -> t m a -> t m b-mapM = K.mapM--{-# RULES "mapM serial" mapM = mapMSerial #-}-{-# INLINE mapMSerial #-}-mapMSerial :: Monad m => (a -> m b) -> SerialT m a -> SerialT m b-mapMSerial = Serial.mapM---- |--- @--- sequence = mapM id--- @------ Replace the elements of a stream of monadic actions with the outputs of--- those actions.------ @--- > runStream $ S.sequence $ S.fromList [putStr "a", putStr "b", putStrLn "c"]--- abc------ runStream $ S.replicateM 10 (return $ threadDelay 1000000 >> print 1)---           & (serially . S.sequence)------ runStream $ S.replicateM 10 (return $ threadDelay 1000000 >> print 1)---           & (asyncly . S.sequence)--- @------ /Concurrent (do not use with 'parallely' on infinite streams)/------ @since 0.1.0-{-# INLINE sequence #-}-sequence :: (IsStream t, MonadAsync m) => t m (m a) -> t m a-sequence m = fromStreamS $ S.sequence (toStreamS m)----------------------------------------------------------------------------------- Transformation by Map and Filter----------------------------------------------------------------------------------- | Map a 'Maybe' returning function to a stream, filter out the 'Nothing'--- elements, and return a stream of values extracted from 'Just'.------ @since 0.3.0-{-# INLINE mapMaybe #-}-mapMaybe :: (IsStream t, Monad m) => (a -> Maybe b) -> t m a -> t m b-mapMaybe f m = fromStreamS $ S.mapMaybe f $ toStreamS m---- | Like 'mapMaybe' but maps a monadic function.------ /Concurrent (do not use with 'parallely' on infinite streams)/------ @since 0.3.0-{-# INLINE_EARLY mapMaybeM #-}-mapMaybeM :: (IsStream t, MonadAsync m, Functor (t m))-          => (a -> m (Maybe b)) -> t m a -> t m b-mapMaybeM f = fmap fromJust . filter isJust . K.mapM f--{-# RULES "mapMaybeM serial" mapMaybeM = mapMaybeMSerial #-}-{-# INLINE mapMaybeMSerial #-}-mapMaybeMSerial :: Monad m => (a -> m (Maybe b)) -> SerialT m a -> SerialT m b-mapMaybeMSerial f m = fromStreamD $ D.mapMaybeM f $ toStreamD m----------------------------------------------------------------------------------- Transformation by Reordering----------------------------------------------------------------------------------- XXX to scale this we need to use a slab allocated array backed--- representation for temporary storage.------ | Returns the elements of the stream in reverse order.--- The stream must be finite.------ @since 0.1.1-reverse :: (IsStream t) => t m a -> t m a-reverse m = go K.nil m-    where-    go rev rest = K.mkStream $ \st yld sng stp ->-        let runIt x = K.foldStream st yld sng stp x-            stop = runIt rev-            single a = runIt $ a `K.cons` rev-            yieldk a r = runIt $ go (a `K.cons` rev) r-         in K.foldStream st yieldk single stop rest----------------------------------------------------------------------------------- Transformation by Inserting----------------------------------------------------------------------------------- | Generate a stream by performing a monadic action between consecutive--- elements of the given stream.------ /Concurrent (do not use with 'parallely' on infinite streams)/------ @--- > S.toList $ S.intersperseM (putChar \'a' >> return ',') $ S.fromList "hello"--- aaaa"h,e,l,l,o"--- @------ @since 0.5.0-{-# INLINE intersperseM #-}-intersperseM :: (IsStream t, MonadAsync m) => m a -> t m a -> t m a-intersperseM = K.intersperseM---- | @insertBy cmp elem stream@ inserts @elem@ before the first element in--- @stream@ that is less than @elem@ when compared using @cmp@.------ @--- insertBy cmp x = 'mergeBy' cmp ('yield' x)--- @------ @--- > S.toList $ S.insertBy compare 2 $ S.fromList [1,3,5]--- [1,2,3,5]--- @------ @since 0.6.0-{-# INLINE insertBy #-}-insertBy ::-       (IsStream t, Monad m) => (a -> a -> Ordering) -> a -> t m a -> t m a-insertBy cmp x m = fromStreamS $ S.insertBy cmp x (toStreamS m)----------------------------------------------------------------------------------- Deleting----------------------------------------------------------------------------------- | Deletes the first occurence of the element in the stream that satisfies--- the given equality predicate.------ @--- > S.toList $ S.deleteBy (==) 3 $ S.fromList [1,3,3,5]--- [1,3,5]--- @------ @since 0.6.0-{-# INLINE deleteBy #-}-deleteBy :: (IsStream t, Monad m) => (a -> a -> Bool) -> a -> t m a -> t m a-deleteBy cmp x m = fromStreamS $ S.deleteBy cmp x (toStreamS m)----------------------------------------------------------------------------------- Zipping----------------------------------------------------------------------------------- |--- > indexed = S.zipWith (,) (S.intFrom 0)------ Pair each element in a stream with its index.------ @--- > S.toList $ S.indexed $ S.fromList "hello"--- [(0,'h'),(1,'e'),(2,'l'),(3,'l'),(4,'o')]--- @------ @since 0.6.0-{-# INLINE indexed #-}-indexed :: (IsStream t, Monad m) => t m a -> t m (Int, a)-indexed = fromStreamD . D.indexed . toStreamD---- |--- > indexedR n = S.zipWith (,) (S.intFromThen n (n - 1))------ Pair each element in a stream with its index, starting from the--- given index @n@ and counting down.------ @--- > S.toList $ S.indexedR 10 $ S.fromList "hello"--- [(9,'h'),(8,'e'),(7,'l'),(6,'l'),(5,'o')]--- @------ @since 0.6.0-{-# INLINE indexedR #-}-indexedR :: (IsStream t, Monad m) => Int -> t m a -> t m (Int, a)-indexedR n = fromStreamD . D.indexedR n . toStreamD---- | Like 'zipWith' but using a monadic zipping function.------ @since 0.4.0-{-# INLINABLE zipWithM #-}-zipWithM :: (IsStream t, Monad m) => (a -> b -> m c) -> t m a -> t m b -> t m c-zipWithM f m1 m2 = fromStreamS $ S.zipWithM f (toStreamS m1) (toStreamS m2)---- | Zip two streams serially using a pure zipping function.------ @--- > S.toList $ S.zipWith (+) (S.fromList [1,2,3]) (S.fromList [4,5,6])--- [5,7,9]--- @------ @since 0.1.0-{-# INLINABLE zipWith #-}-zipWith :: (IsStream t, Monad m) => (a -> b -> c) -> t m a -> t m b -> t m c-zipWith f m1 m2 = fromStreamS $ S.zipWith f (toStreamS m1) (toStreamS m2)----------------------------------------------------------------------------------- Comparison----------------------------------------------------------------------------------- | Compare two streams for equality using an equality function.------ @since 0.6.0-{-# INLINABLE eqBy #-}-eqBy :: (IsStream t, Monad m) => (a -> b -> Bool) -> t m a -> t m b -> m Bool-eqBy = P.eqBy---- | Compare two streams lexicographically using a comparison function.------ @since 0.6.0-{-# INLINABLE cmpBy #-}-cmpBy-    :: (IsStream t, Monad m)-    => (a -> b -> Ordering) -> t m a -> t m b -> m Ordering-cmpBy = P.cmpBy----------------------------------------------------------------------------------- Merge----------------------------------------------------------------------------------- | Merge two streams using a comparison function. The head elements of both--- the streams are compared and the smaller of the two elements is emitted, if--- both elements are equal then the element from the first stream is used--- first.------ If the streams are sorted in ascending order, the resulting stream would--- also remain sorted in ascending order.------ @--- > S.toList $ S.mergeBy compare (S.fromList [1,3,5]) (S.fromList [2,4,6,8])--- [1,2,3,4,5,6,8]--- @------ @since 0.6.0-{-# INLINABLE mergeBy #-}-mergeBy ::-       (IsStream t, Monad m) => (a -> a -> Ordering) -> t m a -> t m a -> t m a-mergeBy f m1 m2 = fromStreamS $ S.mergeBy f (toStreamS m1) (toStreamS m2)---- | Like 'mergeBy' but with a monadic comparison function.------ Merge two streams randomly:------ @--- > randomly _ _ = randomIO >>= \x -> return $ if x then LT else GT--- > S.toList $ S.mergeByM randomly (S.fromList [1,1,1,1]) (S.fromList [2,2,2,2])--- [2,1,2,2,2,1,1,1]--- @------ Merge two streams in a proportion of 2:1:------ @--- proportionately m n = do---  ref <- newIORef $ cycle $ concat [replicate m LT, replicate n GT]---  return $ \\_ _ -> do---      r <- readIORef ref---      writeIORef ref $ tail r---      return $ head r------ main = do---  f <- proportionately 2 1---  xs <- S.toList $ S.mergeByM f (S.fromList [1,1,1,1,1,1]) (S.fromList [2,2,2])---  print xs--- @--- @--- [1,1,2,1,1,2,1,1,2]--- @------ @since 0.6.0-{-# INLINABLE mergeByM #-}-mergeByM-    :: (IsStream t, Monad m)-    => (a -> a -> m Ordering) -> t m a -> t m a -> t m a-mergeByM f m1 m2 = fromStreamS $ S.mergeByM f (toStreamS m1) (toStreamS m2)---- Holding this back for now, we may want to use the name "merge" differently-{---- | Same as @'mergeBy' 'compare'@.------ @--- > S.toList $ S.merge (S.fromList [1,3,5]) (S.fromList [2,4,6,8])--- [1,2,3,4,5,6,8]--- @------ @since 0.6.0-{-# INLINABLE merge #-}-merge ::-       (IsStream t, Monad m, Ord a) => t m a -> t m a -> t m a-merge = mergeBy compare--}---- | Like 'mergeBy' but merges concurrently (i.e. both the elements being--- merged are generated concurrently).------ @since 0.6.0-mergeAsyncBy :: (IsStream t, MonadAsync m)-    => (a -> a -> Ordering) -> t m a -> t m a -> t m a-mergeAsyncBy f m1 m2 = K.mkStream $ \st stp sng yld -> do-    ma <- mkAsync' st m1-    mb <- mkAsync' st m2-    K.foldStream st stp sng yld (K.mergeBy f ma mb)---- | Like 'mergeByM' but merges concurrently (i.e. both the elements being--- merged are generated concurrently).------ @since 0.6.0-mergeAsyncByM :: (IsStream t, MonadAsync m)-    => (a -> a -> m Ordering) -> t m a -> t m a -> t m a-mergeAsyncByM f m1 m2 = K.mkStream $ \st stp sng yld -> do-    ma <- mkAsync' st m1-    mb <- mkAsync' st m2-    K.foldStream st stp sng yld (K.mergeByM f ma mb)+{-# LANGUAGE RankNTypes                #-}+{-# LANGUAGE FlexibleContexts          #-}++#if __GLASGOW_HASKELL__ >= 800+{-# OPTIONS_GHC -Wno-orphans #-}+#endif++#include "Streams/inline.hs"++-- |+-- Module      : Streamly.Prelude+-- Copyright   : (c) 2017 Harendra Kumar+--+-- License     : BSD3+-- Maintainer  : streamly@composewell.com+-- Stability   : experimental+-- Portability : GHC+--+-- This module is designed to be imported qualified:+--+-- @+-- import qualified Streamly.Prelude as S+-- @+--+-- Functions with the suffix @M@ are general functions that work on monadic+-- arguments. The corresponding functions without the suffix @M@ work on pure+-- arguments and can in general be derived from their monadic versions but are+-- provided for convenience and for consistency with other pure APIs in the+-- @base@ package.+--+-- In many cases, short definitions of the combinators are provided in the+-- documentation for illustration. The actual implementation may differ for+-- performance reasons.+--+-- Functions having a 'MonadAsync' constraint work concurrently when used with+-- appropriate stream type combinator. Please be careful to not use 'parallely'+-- with infinite streams.+--+-- Deconstruction and folds accept a 'SerialT' type instead of a polymorphic+-- type to ensure that streams always have a concrete monomorphic type by+-- default, reducing type errors. In case you want to use any other type of+-- stream you can use one of the type combinators provided in the "Streamly"+-- module to convert the stream type.++module Streamly.Prelude+    (+    -- * Construction+    -- ** Primitives+    -- | Primitives to construct a stream from pure values or monadic actions.+    -- All other stream construction and generation combinators described later+    -- can be expressed in terms of these primitives. However, the special+    -- versions provided in this module can be much more efficient in most+    -- cases. Users can create custom combinators using these primitives.++      nil+    , cons+    , (.:)++    , consM+    , (|:)++    -- ** From Values+    -- | Generate a monadic stream from a seed value or values.+    , yield+    , yieldM+    , repeat+    , repeatM+    , replicate+    , replicateM++    -- Note: Using enumeration functions e.g. 'Prelude.enumFromThen' turns out+    -- to be slightly faster than the idioms like @[from, then..]@.+    --+    -- ** Enumeration+    -- | We can use the 'Enum' type class to enumerate a type producing a list+    -- and then convert it to a stream:+    --+    -- @+    -- 'fromList' $ 'Prelude.enumFromThen' from then+    -- @+    --+    -- However, this is not particularly efficient.+    -- The 'Enumerable' type class provides corresponding functions that+    -- generate a stream instead of a list, efficiently.++    , Enumerable (..)+    , enumerate+    , enumerateTo++    -- ** From Generators+    -- | Generate a monadic stream from a seed value and a generator function.+    , unfoldr+    , unfoldrM+    , unfold+    , iterate+    , iterateM+    , fromIndices+    , fromIndicesM++    -- ** From Containers+    -- | Convert an input structure, container or source into a stream. All of+    -- these can be expressed in terms of primitives.+    , fromList+    , fromListM+    , fromFoldable+    , fromFoldableM++    -- * Elimination++    -- ** Deconstruction+    -- | It is easy to express all the folds in terms of the 'uncons' primitive,+    -- however the specific implementations provided later are generally more+    -- efficient.+    --+    , uncons+    , tail+    , init++    -- ** Folding+-- | In imperative terms a fold can be considered as a loop over the stream+-- that reduces the stream to a single value.+-- Left and right folds use a fold function @f@ and an identity element @z@+-- (@zero@) to recursively deconstruct a structure and then combine and reduce+-- the values or transform and reconstruct a new container.+--+-- In general, a right fold is suitable for transforming and reconstructing a+-- right associated structure (e.g. cons lists and streamly streams) and a left+-- fold is suitable for reducing a right associated structure.  The behavior of+-- right and left folds are described in detail in the individual fold's+-- documentation.  To illustrate the two folds for cons lists:+--+-- > foldr :: (a -> b -> b) -> b -> [a] -> b+-- > foldr f z [] = z+-- > foldr f z (x:xs) = x `f` foldr f z xs+-- >+-- > foldl :: (b -> a -> b) -> b -> [a] -> b+-- > foldl f z [] = z+-- > foldl f z (x:xs) = foldl f (z `f` x) xs+--+-- @foldr@ is conceptually equivalent to:+--+-- > foldr f z [] = z+-- > foldr f z [x] = f x z+-- > foldr f z xs = foldr f (foldr f z (tail xs)) [head xs]+--+-- @foldl@ is conceptually equivalent to:+--+-- > foldl f z [] = z+-- > foldl f z [x] = f z x+-- > foldl f z xs = foldl f (foldl f z (init xs)) [last xs]+--+-- Left and right folds are duals of each other.+--+-- @+-- foldr f z xs = foldl (flip f) z (reverse xs)+-- foldl f z xs = foldr (flip f) z (reverse xs)+-- @+--+-- More generally:+--+-- @+-- foldr f z xs = foldl g id xs z where g k x = k . f x+-- foldl f z xs = foldr g id xs z where g x k = k . flip f x+-- @+--++-- As a general rule, foldr cannot have state and foldl cannot have control.++-- NOTE: Folds are inherently serial as each step needs to use the result of+-- the previous step. However, it is possible to fold parts of the stream in+-- parallel and then combine the results using a monoid.++    -- ** Right Folds+    -- $rightfolds+    , foldrM+    -- , foldrS+    -- , foldrT+    , foldr++    -- ** Left Folds+    -- $leftfolds+    , foldl'+    , foldl1'+    , foldlM'++    -- ** Composable Left Folds+    -- $runningfolds++    , fold++    -- ** Full Folds+    -- | Folds that are guaranteed to evaluate the whole stream.++    -- -- ** To Summary (Full Folds)+    -- -- | Folds that summarize the stream to a single value.+    , drain+    , last+    , length+    , sum+    , product+    --, mconcat++    -- -- ** To Summary (Maybe) (Full Folds)+    -- -- | Folds that summarize a non-empty stream to a 'Just' value and return+    -- 'Nothing' for an empty stream.+    , maximumBy+    , maximum+    , minimumBy+    , minimum+    , the+    -- , toListRev -- experimental++    -- ** Lazy Folds+    --+    -- | Folds that generate a lazy structure. Note that the generated+    -- structure may not be lazy if the underlying monad is strict.++    -- -- ** To Containers (Full Folds)+    -- -- | Convert or divert a stream into an output structure, container or+    -- sink.+    , toList++    -- ** Partial Folds+    -- | Folds that may terminate before evaluating the whole stream. These+    -- folds strictly evaluate the stream until the result is determined.++    -- -- ** 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)+    -- -- | Folds that summarize the stream to a boolean value.+    , null+    , elem+    , notElem+    , all+    , any+    , and+    , or++    -- ** Multi-Stream folds+    , eqBy+    , cmpBy+    , isPrefixOf+    -- , isSuffixOf+    -- , isInfixOf+    , isSubsequenceOf++    -- trimming sequences+    , stripPrefix+    -- , stripSuffix+    -- , stripInfix++    -- * Transformation++    --, transform++    -- ** Mapping+    -- | In imperative terms a map operation can be considered as a loop over+    -- the stream that transforms the stream into another stream by performing+    -- an operation on each element of the stream.+    --+    -- 'map' is the least powerful transformation operation with strictest+    -- guarantees.  A map, (1) is a stateless loop which means that no state is+    -- allowed to be carried from one iteration to another, therefore,+    -- operations on different elements are guaranteed to not affect each+    -- other, (2) is a strictly one-to-one transformation of stream elements+    -- which means it guarantees that no elements can be added or removed from+    -- the stream, it can merely transform them.+    , map+    , sequence+    , mapM++    -- ** Special Maps+    , mapM_+    , trace+    , tap++    -- ** Scanning+    --+    -- | A scan is more powerful than map. While a 'map' is a stateless loop, a+    -- @scan@ is a stateful loop which means that a state can be shared across+    -- all the loop iterations, therefore, future iterations can be impacted by+    -- the state changes made by the past iterations. A scan yields the state+    -- of the loop after each iteration. Like a map, a @postscan@ or @prescan@+    -- does not add or remove elements in the stream, it just transforms them.+    -- However, a @scan@ adds one extra element to the stream.+    --+    -- A left associative scan, also known as a prefix sum, can be thought of+    -- as a stream transformation consisting of left folds of all prefixes of a+    -- stream.  Another way of thinking about it is that it streams all the+    -- intermediate values of the accumulator while applying a left fold on the+    -- input stream.  A right associative scan, on the other hand, can be+    -- thought of as a stream consisting of right folds of all the suffixes of+    -- a stream.+    --+    -- The following equations hold for lists:+    --+    -- > scanl f z xs == map (foldl f z) $ inits xs+    -- > scanr f z xs == map (foldr f z) $ tails xs+    --+    -- @+    -- > scanl (+) 0 [1,2,3,4]+    -- 0                 = 0+    -- 0 + 1             = 1+    -- 0 + 1 + 2         = 3+    -- 0 + 1 + 2 + 3     = 6+    -- 0 + 1 + 2 + 3 + 4 = 10+    --+    -- > scanr (+) 0 [1,2,3,4]+    -- 1 + 2 + 3 + 4 + 0 = 10+    --     2 + 3 + 4 + 0 = 9+    --         3 + 4 + 0 = 7+    --             4 + 0 = 4+    --                 0 = 0+    -- @+    --+    -- Left and right scans are duals:+    --+    -- > scanr f z xs ==  reverse $ scanl (flip f) z (reverse xs)+    -- > scanl f z xs ==  reverse $ scanr (flip f) z (reverse xs)+    --+    -- A scan is a stateful map i.e. a combination of map and fold:+    --+    -- > map f xs =           tail $ scanl (\_ x -> f x) z xs+    -- > map f xs = reverse $ head $ scanr (\_ x -> f x) z xs+    --+    -- > foldl f z xs = last $ scanl f z xs+    -- > foldr f z xs = head $ scanr f z xs++    -- ** Left scans+    , scanl'+    , scanlM'+    , postscanl'+    , postscanlM'+    -- , prescanl'+    -- , prescanlM'+    , scanl1'+    , scanl1M'++    -- ** Scan Using Fold+    , scan+    , postscan++    -- , lscanl'+    -- , lscanlM'+    -- , lscanl1'+    -- , lscanl1M'+    --+    -- , lpostscanl'+    -- , lpostscanlM'+    -- , lprescanl'+    -- , lprescanlM'++    -- ** Filtering+    -- | Remove some elements from the stream based on a predicate. In+    -- imperative terms a filter over a stream corresponds to a loop with a+    -- @continue@ clause for the cases when the predicate fails.++    , filter+    , filterM++    -- ** Mapping Filters+    -- | Mapping along with filtering++    , mapMaybe+    , mapMaybeM++    -- ** Deleting Elements+    -- | Deleting elements is a special case of de-interleaving streams.+    , deleteBy+    , uniq+    -- , uniqBy -- by predicate e.g. to remove duplicate "/" in a path+    -- , uniqOn -- to remove duplicate sequences+    -- , pruneBy -- dropAround + uniqBy - like words++    -- ** Inserting Elements+    -- | Inserting elements is a special case of interleaving/merging streams.++    , insertBy+    , intersperseM+    , intersperse+    -- , insertAfterEach+    -- , intersperseBySpan+    -- , intersperseByIndices -- using an index function/stream+    -- , intersperseByTime+    -- , intersperseByEvent++    -- -- * Inserting Streams in Streams+    -- , interposeBy+    -- , intercalate++    -- ** Indexing+    -- | Indexing can be considered as a special type of zipping where we zip a+    -- stream with an index stream.+    , indexed+    , indexedR+    -- , timestamped+    -- , timestampedR -- timer++    -- ** Reordering Elements+    , reverse+    -- , reverse'++    -- ** Trimming+    -- | Take or remove elements from one or both ends of a stream.+    , take+    -- , takeEnd+    , takeWhile+    , takeWhileM+    -- , takeWhileEnd+    , drop+    -- , dropEnd+    , dropWhile+    , dropWhileM+    -- , dropWhileEnd+    -- , dropAround++    -- -- ** Breaking++    -- By chunks+    -- , splitAt -- spanN+    -- , splitIn -- sessionN++    -- By elements+    -- , span  -- spanWhile+    -- , break -- breakBefore+    -- , breakAfter+    -- , breakOn+    -- , breakAround+    -- , spanBy+    -- , spanByRolling++    -- By sequences+    -- breakOnSeq/breakOnArray -- on a fixed sequence+    -- breakOnStream -- on a stream++    -- ** Slicing+    -- | Streams can be sliced into segments in space or in time. We use the+    -- term @chunk@ to refer to a spatial length of the stream (spatial window)+    -- and the term @session@ to refer to a length in time (time window).++    -- In imperative terms, grouped folding can be considered as a nested loop+    -- where we loop over the stream to group elements and then loop over+    -- individual groups to fold them to a single value that is yielded in the+    -- output stream.++    -- , groupScan++    , chunksOf+    , intervalsOf++    -- ** Searching+    -- | Finding the presence or location of an element, a sequence of elements+    -- or another stream within a stream.++    -- -- ** Searching Elements+    , findIndices+    , elemIndices++    -- -- *** Searching Sequences+    -- , seqIndices -- search a sequence in the stream++    -- -- *** Searching Multiple Sequences+    -- , seqIndices -- search a sequence in the stream++    -- -- ** Searching Streams+    -- -- | Finding a stream within another stream.++    -- ** Splitting+    -- | In general we can express splitting in terms of parser combinators.+    -- These are some common use functions for convenience and efficiency.+    -- While parsers can fail these functions are designed to transform a+    -- stream without failure with a predefined behavior for all cases.+    --+    -- In general, there are three possible ways of combining stream segments+    -- with a separator. The separator could be prefixed to each segment,+    -- suffixed to each segment, or it could be infixed between segments.+    -- 'intersperse' and 'intercalate' operations are examples of infixed+    -- combining whereas 'unlines' is an example of suffixed combining. When we+    -- split a stream with separators we can split in three different ways,+    -- each being an opposite of the three ways of combining.+    --+    -- Splitting may keep the separator or drop it. Depending on how we split,+    -- the separator may be kept attached to the stream segments in prefix or+    -- suffix position or as a separate element in infix position. Combinators+    -- like 'splitOn' that use @On@ in their names drop the separator and+    -- combinators that use 'With' in their names keep the separator. When a+    -- segment is missing it is considered as empty, therefore, we never+    -- encounter an error in parsing.++    -- -- ** Splitting By Elements+    , splitOn+    , splitOnSuffix+    -- , splitOnPrefix++    -- , splitBy+    , splitWithSuffix+    -- , splitByPrefix+    , wordsBy -- strip, compact and split++    -- -- *** Splitting By Sequences+    -- , splitOnSeq+    -- , splitOnSuffixSeq+    -- , splitOnPrefixSeq++    -- Keeping the delimiters+    -- , splitBySeq+    -- , splitBySeqSuffix+    -- , splitBySeqPrefix+    -- , wordsBySeq++    -- Splitting By Multiple Sequences+    -- , splitOnAnySeq+    -- , splitOnAnySuffixSeq+    -- , splitOnAnyPrefixSeq++    -- -- ** Splitting By Streams+    -- -- | Splitting a stream using another stream as separator.++    -- ** Grouping+    -- | Splitting a stream by combining multiple contiguous elements into+    -- groups using some criterion.+    , groups+    , groupsBy+    , groupsByRolling++    {-+    -- * Windowed Classification+    -- | Split the stream into windows or chunks in space or time. 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 is split+    -- into windows of specified size, the window can be terminated early if+    -- the closing flag is specified in the input stream.+    --+    -- The term "chunk" is used for a space window and the term "session" is+    -- used for a time window.++    -- ** Tumbling Windows+    -- | A new window starts after the previous window is finished.+    -- , classifyChunksOf+    -- , classifySessionsOf++    -- ** Keep Alive Windows+    -- | The window size is extended if an event arrives within the specified+    -- window size. This can represent sessions with idle or inactive timeout.+    -- , classifyKeepAliveChunks+    -- , classifyKeepAliveSessions++    {-+    -- ** Sliding Windows+    -- | A new window starts after the specified slide from the previous+    -- window. Therefore windows can overlap.+    , classifySlidingChunks+    , classifySlidingSessions+    -}+    -- ** Sliding Window Buffers+    -- , slidingChunkBuffer+    -- , slidingSessionBuffer+    -}++    -- * Combining Streams+    -- | New streams can be constructed by appending, merging or zipping+    -- existing streams.++    -- ** Appending+    -- | Streams form a 'Semigroup' and a 'Monoid' under the append+    -- operation. Appending can be considered as a generalization of the `cons`+    -- operation to consing a stream to a stream.+    --+    -- @+    --+    -- -------Stream m a------|-------Stream m a------|=>----Stream m a---+    --+    -- @+    --+    -- @+    -- >> S.toList $ S.fromList [1,2] \<> S.fromList [3,4]+    -- [1,2,3,4]+    -- >> S.toList $ fold $ [S.fromList [1,2], S.fromList [3,4]]+    -- [1,2,3,4]+    -- @++    -- ** Merging+    -- | Streams form a commutative semigroup under the merge+    -- operation. Merging can be considered as a generalization of inserting an+    -- element in a stream to interleaving a stream with another stream.+    --+    -- @+    --+    -- -------Stream m a------|+    --                        |=>----Stream m a---+    -- -------Stream m a------|+    -- @+    --++    -- , merge+    , mergeBy+    , mergeByM+    , mergeAsyncBy+    , mergeAsyncByM++    -- ** Zipping+    -- |+    -- @+    --+    -- -------Stream m a------|+    --                        |=>----Stream m c---+    -- -------Stream m b------|+    -- @+    --+    , zipWith+    , zipWithM+    , zipAsyncWith+    , zipAsyncWithM++    {-+    -- ** Folding Containers of Streams+    -- | These are variants of standard 'Foldable' fold functions that use a+    -- polymorphic stream sum operation (e.g. 'async' or 'wSerial') to fold a+    -- finite container of streams. Note that these are just special cases of+    -- the more general 'concatMapWith' operation.+    --+    , foldMapWith+    , forEachWith+    , foldWith+    -}++    -- ** Folding Streams of Streams+    -- | Stream operations like map and filter represent loop processing in+    -- imperative programming terms. Similarly, the imperative concept of+    -- nested loops are represented by streams of streams. The 'concatMap'+    -- operation represents nested looping.+    -- A 'concatMap' operation loops over the input stream and then for each+    -- element of the input stream generates another stream and then loops over+    -- that inner stream as well producing effects and generating a single+    -- output stream.+    -- The 'Monad' instances of different stream types provide a more+    -- convenient way of writing nested loops. Note that the monad bind+    -- operation is just @flip concatMap@.+    --+    -- One dimension loops are just a special case of nested loops.  For+    -- example, 'concatMap' can degenerate to a simple map operation:+    --+    -- > map f m = S.concatMap (\x -> S.yield (f x)) m+    --+    -- Similarly, 'concatMap' can perform filtering by mapping an element to a+    -- 'nil' stream:+    --+    -- > filter p m = S.concatMap (\x -> if p x then S.yield x else S.nil) m+    --++    -- XXX add stateful concatMapWith+    , concatMapWith+    --, bindWith+    , concatMap+    , concatMapM+    , concatUnfold++    -- * Exceptions+    , before+    , after+    , bracket+    , onException+    , finally+    , handle++    -- * Deprecated+    , once+    , each+    , scanx+    , foldx+    , foldxM+    , foldr1+    , runStream+    , runN+    , runWhile+    , fromHandle+    , toHandle+    )+where++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, repeat, replicate, concatMap, span)++import Streamly.Internal.Prelude++-- $rightfolds+--+-- Let's take a closer look at the @foldr@ definition for lists, as given+-- earlier:+--+-- @+-- foldr f z (x:xs) = x \`f` foldr f z xs+-- @+--+-- @foldr@ invokes the fold step function @f@ as @f x (foldr f z xs)@. At each+-- invocation of @f@, @foldr@ gives us the next element in the input container+-- @x@ and a recursive expression @foldr f z xs@ representing the yet unbuilt+-- (lazy thunk) part of the output.+--+-- When @f x xs@ is lazy in @xs@ it can consume the input one element at a time+-- in FIFO order to build a lazy output expression. For example,+--+-- > f x remaining = show x : remaining+--+-- @take 2 $ foldr f [] (1:2:undefined)@ would consume the input lazily on+-- demand, consuming only first two elements and resulting in ["1", "2"]. @f@+-- can terminate recursion by not evaluating the @remaining@ part:+--+-- > f 2 remaining = show 2 : []+-- > f x remaining = show x : remaining+--+-- @f@ would terminate recursion whenever it sees element @2@ in the input.+-- Therefore, @take 2 $ foldr f [] (1:2:undefined)@ would work without any+-- problem.+--+-- On the other hand, if @f a b@ is strict in @b@ it would end up consuming the+-- whole input right away and expanding the recursive expression @b@ (i.e.+-- @foldr f z xs@) fully before it yields an output expression, resulting in+-- the following /right associated expression/:+--+-- @+-- foldr f z xs == x1 \`f` (x2 \`f` ...(xn \`f` z))+-- @+--+-- For example,+--+-- > f x remaining = x + remaining+--+-- With this definition, @foldr f 0 [1..1000]@, would recurse completely until+-- it reaches the terminating case @... `f` (1000 `f` 0)@, and then+-- start reducing the whole expression from right to left, therefore, consuming+-- the input elements in LIFO order. Thus, such an evaluation would require+-- memory proportional to the size of input. Try out @foldr (+) 0 (map (\\x ->+-- trace (show x) x) [1..10])@.+--+-- Notice the order of the arguments to the step function @f a b@. It follows+-- the order of @a@ and @b@ in the right associative recursive expression+-- generated by expanding @a \`f` b@.+--+-- A right fold is a pull fold, the step function is the puller, it can pull+-- more data from the input container by using its second argument in the+-- output expression or terminate pulling by not using it. As a corollary:+--+-- 1. a step function which is lazy in its second argument (usually functions+-- or constructors that build a lazy structure e.g. @(:)@) can pull lazily on+-- demand.+-- 2. a step function strict in its second argument (usually reducers e.g.+-- (+)) would end up pulling all of its input and buffer it in memory before+-- potentially reducing it.+--+-- A right fold is suitable for lazy reconstructions e.g.  transformation,+-- mapping, filtering of /right associated input structures/ (e.g. cons lists).+-- Whereas a left fold is suitable for reductions (e.g. summing a stream of+-- numbers) of right associated structures. Note that these roles will reverse+-- for left associated structures (e.g. snoc lists). Most of our observations+-- here assume right associated structures, lists being the canonical example.+--+-- 1. A lazy FIFO style pull using a right fold allows pulling a potentially+-- /infinite/ input stream lazily, perform transformations on it, and+-- reconstruct a new structure without having to buffer the whole structure. In+-- contrast, a left fold would buffer the entire structure before the+-- reconstructed structure can be consumed.+-- 2. Even if buffering the entire input structure is ok, we need to keep in+-- mind that a right fold reconstructs structures in a FIFO style, whereas a+-- 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 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+-- irrespective of that.+-- 4. Reduction (e.g. using (+) on a stream of numbers) using a right fold+-- occurs in a LIFO style, which means that the entire input gets buffered+-- before reduction starts. Whereas with a strict left fold reductions occur+-- incrementally in FIFO style. Therefore, a strict left fold is more suitable+-- for reductions.+--++-- $leftfolds+--+-- Note that the observations below about the behavior of a left fold assume+-- that we are working on a right associated structure like cons lists and+-- streamly streams. If we are working on a left associated structure (e.g.+-- snoc lists) the roles of right and left folds would reverse.+--+-- Let's take a closer look at the @foldl@ definition for lists given above:+--+-- @+-- foldl f z (x:xs) = foldl f (z \`f` x) xs+-- @+--+-- @foldl@ calls itself recursively, in each call it invokes @f@ as @f z x@+-- providing it with the result accumulated till now @z@ (the state) and the+-- next element from the input container. First call to @f@ is supplied with+-- the initial value of the accumulator @z@ and each subsequent call uses the+-- output of the previous call to @f z x@.+--+-- >> foldl' (+) 0 [1,2,3]+-- > 6+--+-- The recursive call at the head of the output expression is bound to be+-- evaluated until recursion terminates, therefore, a left fold always+-- /consumes the whole input container/. The following would result in an+-- error, even though the fold is not using the values at all:+--+-- >> foldl' (\_ _ -> 0) 0 (1:undefined)+-- > *** Exception: Prelude.undefined+--+-- As @foldl@ recurses, it builds the left associated expression shown below.+-- Notice, the order of the arguments to the step function @f b a@. It follows+-- the left associative recursive expression generated by expanding @b \`f` a@.+--+-- @+-- foldl f z xs == (((z \`f` x1) \`f` x2) ...) \`f` xn+-- @+--+--+-- The strict left fold @foldl'@ forces the reduction of its argument @z \`f`+-- x@ before using it, therefore it never builds the whole expression in+-- memory.  Thus, @z \`f` x1@ would get reduced to @z1@ and then @z1 \`f` x2@+-- would get reduced to @z2@ and so on, incrementally reducing the expression+-- from left to right as it recurses, consuming the input in FIFO order.  Try+-- out @foldl' (+) 0 (map (\\x -> trace (show x) x) [1..10])@ to see how it+-- works. For example:+--+-- @+-- > S.foldl' (+) 0 $ S.fromList [1,2,3,4]+-- 10+-- @+--+-- @+-- 0 + 1 = 1+-- 1 + 2 = 3+-- 3 + 3 = 6+-- 6 + 4 = 10+-- @+--+-- However, @foldl'@ evaluates the accumulator only to WHNF. It may further+-- help if the step function uses a strict data structure as accumulator to+-- improve performance and to keep the expression fully reduced at all times+-- during the fold.+--+-- A left fold can also build a new structure instead of reducing one if a+-- constructor is used as a fold step. However, it may not be very useful+-- because it will consume the whole input and construct the new structure in+-- memory before we can consume it. Thus the whole structure gets buffered in+-- memory. When the list constructor is used it would build a new list in+-- reverse (LIFO) order:+--+-- @+-- > S.foldl' (flip (:)) [] $ S.fromList [1,2,3,4]+-- [4,3,2,1]+-- @+--+-- A left fold is a push fold. The producer pushes its contents to the step+-- function of the fold. The step function therefore has no control to stop the+-- input, it can only discard it if it does not need it. We can also consider a+-- left fold as a state machine where the state is store in the accumulator,+-- the state can be modified based on new inputs that are pushed to the fold.+--+-- In general, a strict left fold is a reducing fold, whereas a right fold is a+-- constructing fold. A strict left fold reduces in a FIFO order whereas it+-- constructs in a LIFO order, and vice-versa for the right fold. See the+-- documentation of 'foldrM' for a discussion on where a left or right fold is+-- suitable.+--+-- To perform a left fold lazily without having to consume all the input one+-- can use @scanl@ to stream the intermediate results of the fold and consume+-- the resulting stream lazily.+--++-- $runningfolds+--+-- "Streamly.Data.Fold" module defines composable left folds which can be combined+-- together in many interesting ways. Those folds can be run using 'fold'.+-- The following two ways of folding are equivalent in functionality and+-- performance,+--+-- >>> S.fold FL.sum (S.enumerateFromTo 1 100)+-- 5050+-- >>> S.sum (S.enumerateFromTo 1 100)+-- 5050+--+-- However, left folds cannot terminate early even if it does not need to+-- consume more input to determine the result.  Therefore, the performance is+-- equivalent only for full folds like 'sum' and 'length'. For partial folds+-- like 'head' or 'any' the the folds defined in this module may be much more+-- efficient because they are implemented as right folds that terminate as soon+-- as we get the result. Note that when a full fold is composed with a partial+-- fold in parallel the performance is not impacted as we anyway have to+-- consume the whole stream due to the full fold.+--+-- >>> S.head (1 `S.cons` undefined)+-- Just 1+-- >>> S.fold FL.head (1 `S.cons` undefined)+-- *** Exception: Prelude.undefined+--+-- However, we can wrap the fold in a scan to convert it into a lazy stream of+-- fold steps. We can then terminate the stream whenever we want.  For example,+--+-- >>> S.toList $ S.take 1 $ S.scan FL.head (1 `S.cons` undefined)+-- [Nothing]+--+-- The following example extracts the input stream up to a point where the+-- running average of elements is no more than 10:+--+-- @+-- > S.toList+--   $ S.map (fromJust . fst)+--   $ S.takeWhile (\\(_,x) -> x <= 10)+--   $ S.postscan ((,) \<$> FL.last \<*> avg) (S.enumerateFromTo 1.0 100.0)+-- @+-- @+--  [1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0,11.0,12.0,13.0,14.0,15.0,16.0,17.0,18.0,19.0]+-- @
− src/Streamly/SVar.hs 
@@ -1,2203 +0,0 @@-{-# LANGUAGE CPP                        #-}-{-# LANGUAGE KindSignatures             #-}-{-# LANGUAGE ConstraintKinds            #-}-{-# LANGUAGE ExistentialQuantification  #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase                 #-}-{-# LANGUAGE MagicHash                  #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE RankNTypes                 #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE UnboxedTuples              #-}---- |--- Module      : Streamly.SVar--- Copyright   : (c) 2017 Harendra Kumar------ License     : BSD3--- Maintainer  : harendra.kumar@gmail.com--- Stability   : experimental--- Portability : GHC--module Streamly.SVar-    (-      MonadAsync-    , SVarStyle (..)-    , SVar (..)--    -- State threaded around the stream-    , Limit (..)-    , State (streamVar)-    , defState-    , adaptState-    , getMaxThreads-    , setMaxThreads-    , getMaxBuffer-    , setMaxBuffer-    , getStreamRate-    , setStreamRate-    , setStreamLatency-    , getYieldLimit-    , setYieldLimit-    , getInspectMode-    , setInspectMode--    , cleanupSVar-    , cleanupSVarFromWorker--    -- SVar related-    , newAheadVar-    , newParallelVar-    , captureMonadState-    , RunInIO (..)--    , WorkerInfo (..)-    , YieldRateInfo (..)-    , ThreadAbort (..)-    , ChildEvent (..)-    , AheadHeapEntry (..)-    , send-    , sendYield-    , sendStop-    , enqueueLIFO-    , enqueueFIFO-    , enqueueAhead-    , reEnqueueAhead-    , pushWorkerPar--    , queueEmptyAhead-    , dequeueAhead--    , HeapDequeueResult(..)-    , dequeueFromHeap-    , dequeueFromHeapSeq-    , requeueOnHeapTop-    , updateHeapSeq-    , withIORef-    , heapIsSane--    , Rate (..)-    , getYieldRateInfo-    , newSVarStats-    , collectLatency-    , workerUpdateLatency-    , isBeyondMaxRate-    , workerRateControl-    , updateYieldCount-    , decrementYieldLimit-    , decrementYieldLimitPost-    , incrementYieldLimit-    , postProcessBounded-    , postProcessPaced-    , readOutputQBounded-    , readOutputQPaced-    , dispatchWorkerPaced-    , sendFirstWorker-    , delThread--    , toStreamVar-    , SVarStats (..)-    , dumpSVar-    )-where--import Control.Concurrent-       (ThreadId, myThreadId, threadDelay, throwTo)-import Control.Concurrent.MVar-       (MVar, newEmptyMVar, tryPutMVar, takeMVar, newMVar, tryReadMVar)-import Control.Exception-       (SomeException(..), catch, mask, assert, Exception, catches,-        throwIO, Handler(..), BlockedIndefinitelyOnMVar(..),-        BlockedIndefinitelyOnSTM(..))-import Control.Monad (when)-import Control.Monad.Catch (MonadThrow)-import Control.Monad.IO.Class (MonadIO(..))-import Control.Monad.Trans.Control (MonadBaseControl, control, StM)-import Streamly.Atomics-       (atomicModifyIORefCAS, atomicModifyIORefCAS_, writeBarrier,-        storeLoadBarrier)-import Data.Concurrent.Queue.MichaelScott (LinkedQueue, pushL)-import Data.Functor (void)-import Data.Heap (Heap, Entry(..))-import Data.Int (Int64)-import Data.IORef-       (IORef, modifyIORef, newIORef, readIORef, writeIORef, atomicModifyIORef)-import Data.List ((\\))-import Data.Maybe (fromJust)-import Data.Semigroup ((<>))-import Data.Set (Set)-import GHC.Conc (ThreadId(..))-import GHC.Exts-import GHC.IO (IO(..))-import Streamly.Time.Clock (Clock(..), getTime)-import Streamly.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--newtype Count = Count Int64-    deriving ( Eq-             , Read-             , Show-             , Enum-             , Bounded-             , Num-             , Real-             , Integral-             , Ord-             )----------------------------------------------------------------------------------- Parent child thread communication type---------------------------------------------------------------------------------data ThreadAbort = ThreadAbort deriving Show--instance Exception ThreadAbort---- | Events that a child thread may send to a parent thread.-data ChildEvent a =-      ChildYield a-    | ChildStop ThreadId (Maybe SomeException)---- | Sorting out-of-turn outputs in a heap for Ahead style streams-data AheadHeapEntry (t :: (* -> *) -> * -> *) m a =-      AheadEntryNull-    | AheadEntryPure a-    | AheadEntryStream (t m a)----------------------------------------------------------------------------------- State threaded around the monad for thread management----------------------------------------------------------------------------------- | Identify the type of the SVar. Two computations using the same style can--- be scheduled on the same SVar.-data SVarStyle =-      AsyncVar             -- depth first concurrent-    | WAsyncVar            -- breadth first concurrent-    | ParallelVar          -- all parallel-    | AheadVar             -- Concurrent look ahead-    deriving (Eq, Show)---- | An SVar or a Stream Var is a conduit to the output from multiple streams--- running concurrently and asynchronously. An SVar can be thought of as an--- asynchronous IO handle. We can write any number of streams to an SVar in a--- non-blocking manner and then read them back at any time at any pace.  The--- SVar would run the streams asynchronously and accumulate results. An SVar--- may not really execute the stream completely and accumulate all the results.--- However, it ensures that the reader can read the results at whatever paces--- it wants to read. The SVar monitors and adapts to the consumer's pace.------ An SVar is a mini scheduler, it has an associated workLoop that holds the--- stream tasks to be picked and run by a pool of worker threads. It has an--- associated output queue where the output stream elements are placed by the--- worker threads. A outputDoorBell is used by the worker threads to intimate the--- consumer thread about availability of new results in the output queue. More--- workers are added to the SVar by 'fromStreamVar' on demand if the output--- produced is not keeping pace with the consumer. On bounded SVars, workers--- block on the output queue to provide throttling of the producer  when the--- consumer is not pulling fast enough.  The number of workers may even get--- reduced depending on the consuming pace.------ New work is enqueued either at the time of creation of the SVar or as a--- result of executing the parallel combinators i.e. '<|' and '<|>' when the--- already enqueued computations get evaluated. See 'joinStreamVarAsync'.---- We measure the individual worker latencies to estimate the number of workers--- needed or the amount of time we have to sleep between dispatches to achieve--- a particular rate when controlled pace mode it used.-data WorkerInfo = WorkerInfo-    { workerYieldMax   :: Count -- 0 means unlimited-    -- total number of yields by the worker till now-    , workerYieldCount    :: IORef Count-    -- yieldCount at start, timestamp-    , workerLatencyStart  :: IORef (Count, AbsTime)-    }----- | Specifies the stream yield rate in yields per second (@Hertz@).--- We keep accumulating yield credits at 'rateGoal'. At any point of time we--- allow only as many yields as we have accumulated as per 'rateGoal' since the--- start of time. If the consumer or the producer is slower or faster, the--- actual rate may fall behind or exceed 'rateGoal'.  We try to recover the gap--- between the two by increasing or decreasing the pull rate from the producer.--- However, if the gap becomes more than 'rateBuffer' we try to recover only as--- much as 'rateBuffer'.------ 'rateLow' puts a bound on how low the instantaneous rate can go when--- recovering the rate gap.  In other words, it determines the maximum yield--- latency.  Similarly, 'rateHigh' puts a bound on how high the instantaneous--- rate can go when recovering the rate gap.  In other words, it determines the--- minimum yield latency. We reduce the latency by increasing concurrency,--- therefore we can say that it puts an upper bound on concurrency.------ If the 'rateGoal' is 0 or negative the stream never yields a value.--- If the 'rateBuffer' is 0 or negative we do not attempt to recover.------ @since 0.5.0-data Rate = Rate-    { rateLow    :: Double -- ^ The lower rate limit-    , rateGoal   :: Double -- ^ The target rate we want to achieve-    , rateHigh   :: Double -- ^ The upper rate limit-    , rateBuffer :: Int    -- ^ Maximum slack from the goal-    }--data LatencyRange = LatencyRange-    { minLatency :: NanoSecond64-    , maxLatency :: NanoSecond64-    } deriving Show---- Rate control.-data YieldRateInfo = YieldRateInfo-    { svarLatencyTarget    :: NanoSecond64-    , svarLatencyRange     :: LatencyRange-    , svarRateBuffer       :: Int-    , svarGainedLostYields :: IORef Count--    -- Actual latency/througput as seen from the consumer side, we count the-    -- yields and the time it took to generates those yields. This is used to-    -- increase or decrease the number of workers needed to achieve the desired-    -- rate. The idle time of workers is adjusted in this, so that we only-    -- account for the rate when the consumer actually demands data.-    -- XXX interval latency is enough, we can move this under diagnostics build-    , svarAllTimeLatency :: IORef (Count, AbsTime)--    -- XXX Worker latency specified by the user to be used before the first-    -- actual measurement arrives. Not yet implemented-    , workerBootstrapLatency :: Maybe NanoSecond64--    -- After how many yields the worker should update the latency information.-    -- If the latency is high, this count is kept lower and vice-versa.  XXX If-    -- the latency suddenly becomes too high this count may remain too high for-    -- long time, in such cases the consumer can change it.-    -- 0 means no latency computation-    -- XXX this is derivable from workerMeasuredLatency, can be removed.-    , workerPollingInterval :: IORef Count--    -- This is in progress latency stats maintained by the workers which we-    -- empty into workerCollectedLatency stats at certain intervals - whenever-    -- we process the stream elements yielded in this period. The first count-    -- is all yields, the second count is only those yields for which the-    -- latency was measured to be non-zero (note that if the timer resolution-    -- is low the measured latency may be zero e.g. on JS platform).-    -- (allYieldCount, yieldCount, timeTaken)-    , workerPendingLatency   :: IORef (Count, Count, NanoSecond64)--    -- This is the second level stat which is an accmulation from-    -- workerPendingLatency stats. We keep accumulating latencies in this-    -- bucket until we have stats for a sufficient period and then we reset it-    -- to start collecting for the next period and retain the computed average-    -- latency for the last period in workerMeasuredLatency.-    -- (allYieldCount, yieldCount, timeTaken)-    , workerCollectedLatency :: IORef (Count, Count, NanoSecond64)--    -- Latency as measured by workers, aggregated for the last period.-    , workerMeasuredLatency :: IORef NanoSecond64-    }--data SVarStats = SVarStats {-      totalDispatches  :: IORef Int-    , maxWorkers       :: IORef Int-    , maxOutQSize      :: IORef Int-    , maxHeapSize      :: IORef Int-    , maxWorkQSize     :: IORef Int-    , avgWorkerLatency :: IORef (Count, NanoSecond64)-    , minWorkerLatency :: IORef NanoSecond64-    , maxWorkerLatency :: IORef NanoSecond64-    , svarStopTime     :: IORef (Maybe AbsTime)-}--data Limit = Unlimited | Limited Word deriving Show--data SVar t m a = SVar-    {-    -- Read only state-      svarStyle       :: SVarStyle-    , svarMrun        :: RunInIO m--    -- Shared output queue (events, length)-    -- XXX For better efficiency we can try a preallocated array type (perhaps-    -- something like a vector) that allows an O(1) append. That way we will-    -- avoid constructing and reversing the list. Possibly we can also avoid-    -- the GC copying overhead. When the size increases we should be able to-    -- allocate the array in chunks.-    , outputQueue    :: IORef ([ChildEvent a], Int)-    , outputDoorBell :: MVar ()  -- signal the consumer about output-    , readOutputQ    :: m [ChildEvent a]-    , postProcess    :: m Bool--    -- Combined/aggregate parameters-    , maxWorkerLimit :: Limit-    , maxBufferLimit :: Limit-    , remainingWork  :: Maybe (IORef Count)-    , yieldRateInfo  :: Maybe YieldRateInfo--    -- Used only by bounded SVar types-    , enqueue        :: t m a -> IO ()-    , isWorkDone     :: IO Bool-    , isQueueDone    :: IO Bool-    , needDoorBell   :: IORef Bool-    , workLoop       :: Maybe WorkerInfo -> m ()--    -- Shared, thread tracking-    , workerThreads  :: IORef (Set ThreadId)-    , workerCount    :: IORef Int-    , accountThread  :: ThreadId -> m ()-    , workerStopMVar :: MVar ()--    , svarStats      :: SVarStats-    -- to track garbage collection of SVar-    , svarRef        :: Maybe (IORef ())--    -- Only for diagnostics-    , svarInspectMode :: Bool-    , svarCreator    :: ThreadId-    , outputHeap     :: IORef ( Heap (Entry Int (AheadHeapEntry t m a))-                              , Maybe Int)-    -- Shared work queue (stream, seqNo)-    , aheadWorkQueue :: IORef ([t m a], Int)-    }------------------------------------------------------------------------------------ State for concurrency control------------------------------------------------------------------------------------ XXX we can put the resettable fields in a oneShotConfig field and others in--- a persistentConfig field. That way reset would be fast and scalable--- irrespective of the number of fields.------ XXX make all these Limited types and use phantom types to distinguish them-data State t m a = State-    { -- one shot configuration, automatically reset for each API call-      streamVar   :: Maybe (SVar t m a)-    , _yieldLimit  :: Maybe Count--    -- persistent configuration, state that remains valid until changed by-    -- an explicit setting via a combinator.-    , _threadsHigh    :: Limit-    , _bufferHigh     :: Limit-    -- XXX these two can be collapsed into a single type-    , _streamLatency  :: Maybe NanoSecond64 -- bootstrap latency-    , _maxStreamRate  :: Maybe Rate-    , _inspectMode    :: Bool-    }------------------------------------------------------------------------------------ State defaults and reset------------------------------------------------------------------------------------ A magical value for the buffer size arrived at by running the smallest--- possible task and measuring the optimal value of the buffer for that.  This--- is obviously dependent on hardware, this figure is based on a 2.2GHz intel--- core-i7 processor.-magicMaxBuffer :: Word-magicMaxBuffer = 1500--defaultMaxThreads, defaultMaxBuffer :: Limit-defaultMaxThreads = Limited magicMaxBuffer-defaultMaxBuffer = Limited magicMaxBuffer---- The fields prefixed by an _ are not to be accessed or updated directly but--- via smart accessor APIs.-defState :: State t m a-defState = State-    { streamVar = Nothing-    , _yieldLimit = Nothing-    , _threadsHigh = defaultMaxThreads-    , _bufferHigh = defaultMaxBuffer-    , _maxStreamRate = Nothing-    , _streamLatency = Nothing-    , _inspectMode = False-    }---- XXX if perf gets affected we can have all the Nothing params in a single--- structure so that we reset is fast. We can also use rewrite rules such that--- reset occurs only in concurrent streams to reduce the impact on serial--- streams.--- We can optimize this so that we clear it only if it is a Just value, it--- results in slightly better perf for zip/zipM but the performance of scan--- worsens a lot, it does not fuse.------ XXX This has a side effect of clearing the SVar and yieldLimit, therefore it--- should not be used to convert from the same type to the same type, unless--- you want to clear the SVar. For clearing the SVar you should be using the--- appropriate unStream functions instead.------ | Adapt the stream state from one type to another.-adaptState :: State t m a -> State t m b-adaptState st = st-    { streamVar = Nothing-    , _yieldLimit = Nothing-    }------------------------------------------------------------------------------------ Smart get/set routines for State------------------------------------------------------------------------------------ Use get/set routines instead of directly accessing the State fields-setYieldLimit :: Maybe Int64 -> State t m a -> State t m a-setYieldLimit lim st =-    st { _yieldLimit =-            case lim of-                Nothing -> Nothing-                Just n  ->-                    if n <= 0-                    then Just 0-                    else Just (fromIntegral n)-       }--getYieldLimit :: State t m a -> Maybe Count-getYieldLimit = _yieldLimit--setMaxThreads :: Int -> State t m a -> State t m a-setMaxThreads n st =-    st { _threadsHigh =-            if n < 0-            then Unlimited-            else if n == 0-                 then defaultMaxThreads-                 else Limited (fromIntegral n)-       }--getMaxThreads :: State t m a -> Limit-getMaxThreads = _threadsHigh--setMaxBuffer :: Int -> State t m a -> State t m a-setMaxBuffer n st =-    st { _bufferHigh =-            if n < 0-            then Unlimited-            else if n == 0-                 then defaultMaxBuffer-                 else Limited (fromIntegral n)-       }--getMaxBuffer :: State t m a -> Limit-getMaxBuffer = _bufferHigh--setStreamRate :: Maybe Rate -> State t m a -> State t m a-setStreamRate r st = st { _maxStreamRate = r }--getStreamRate :: State t m a -> Maybe Rate-getStreamRate = _maxStreamRate--setStreamLatency :: Int -> State t m a -> State t m a-setStreamLatency n st =-    st { _streamLatency =-            if n <= 0-            then Nothing-            else Just (fromIntegral n)-       }--getStreamLatency :: State t m a -> Maybe NanoSecond64-getStreamLatency = _streamLatency--setInspectMode :: State t m a -> State t m a-setInspectMode st = st { _inspectMode = True }--getInspectMode :: State t m a -> Bool-getInspectMode = _inspectMode------------------------------------------------------------------------------------ Cleanup----------------------------------------------------------------------------------cleanupSVar :: SVar t m a -> IO ()-cleanupSVar sv = do-    workers <- readIORef (workerThreads sv)-    Prelude.mapM_ (`throwTo` ThreadAbort)-          (S.toList workers)--cleanupSVarFromWorker :: SVar t m a -> IO ()-cleanupSVarFromWorker sv = do-    workers <- readIORef (workerThreads sv)-    self <- myThreadId-    mapM_ (`throwTo` ThreadAbort)-          (S.toList workers \\ [self])------------------------------------------------------------------------------------ Worker latency data collection------------------------------------------------------------------------------------ Every once in a while workers update the latencies and check the yield rate.--- They return if we are above the expected yield rate. If we check too often--- it may impact performance, if we check less often we may have a stale--- picture. We update every minThreadDelay but we translate that into a yield--- count based on latency so that the checking overhead is little.------ XXX use a generation count to indicate that the value is updated. If the--- value is updated an existing worker must check it again on the next yield.--- Otherwise it is possible that we may keep updating it and because of the mod--- worker keeps skipping it.-updateWorkerPollingInterval :: YieldRateInfo -> NanoSecond64 -> IO ()-updateWorkerPollingInterval yinfo latency = do-    let periodRef = workerPollingInterval yinfo-        cnt = max 1 $ minThreadDelay `div` latency-        period = min cnt (fromIntegral magicMaxBuffer)--    writeIORef periodRef (fromIntegral period)--{-# INLINE recordMinMaxLatency #-}-recordMinMaxLatency :: SVar t m a -> NanoSecond64 -> IO ()-recordMinMaxLatency sv new = do-    let ss = svarStats sv-    minLat <- readIORef (minWorkerLatency ss)-    when (new < minLat || minLat == 0) $-        writeIORef (minWorkerLatency ss) new--    maxLat <- readIORef (maxWorkerLatency ss)-    when (new > maxLat) $ writeIORef (maxWorkerLatency ss) new--recordAvgLatency :: SVar t m a -> (Count, NanoSecond64) -> IO ()-recordAvgLatency sv (count, time) = do-    let ss = svarStats sv-    modifyIORef (avgWorkerLatency ss) $-        \(cnt, t) -> (cnt + count, t + time)---- Pour the pending latency stats into a collection bucket-{-# INLINE collectWorkerPendingLatency #-}-collectWorkerPendingLatency-    :: IORef (Count, Count, NanoSecond64)-    -> IORef (Count, Count, NanoSecond64)-    -> IO (Count, Maybe (Count, NanoSecond64))-collectWorkerPendingLatency cur col = do-    (fcount, count, time) <- atomicModifyIORefCAS cur $ \v -> ((0,0,0), v)--    (fcnt, cnt, t) <- readIORef col-    let totalCount = fcnt + fcount-        latCount   = cnt + count-        latTime    = t + time-    writeIORef col (totalCount, latCount, latTime)--    assert (latCount == 0 || latTime /= 0) (return ())-    let latPair =-            if latCount > 0 && latTime > 0-            then Just $ (latCount, latTime)-            else Nothing-    return (totalCount, latPair)--{-# INLINE shouldUseCollectedBatch #-}-shouldUseCollectedBatch-    :: Count-    -> NanoSecond64-    -> NanoSecond64-    -> NanoSecond64-    -> Bool-shouldUseCollectedBatch collectedYields collectedTime newLat prevLat =-    let r = fromIntegral newLat / fromIntegral prevLat :: Double-    in     (collectedYields > fromIntegral magicMaxBuffer)-        || (collectedTime > minThreadDelay)-        || (prevLat > 0 && (r > 2 || r < 0.5))-        || (prevLat == 0)---- Returns a triple, (1) yield count since last collection, (2) the base time--- when we started counting, (3) average latency in the last measurement--- period. The former two are used for accurate measurement of the going rate--- whereas the average is used for future estimates e.g. how many workers--- should be maintained to maintain the rate.--- CAUTION! keep it in sync with getWorkerLatency-collectLatency :: SVar t m a-               -> YieldRateInfo-               -> Bool-               -> IO (Count, AbsTime, NanoSecond64)-collectLatency sv yinfo drain = do-    let cur      = workerPendingLatency yinfo-        col      = workerCollectedLatency yinfo-        longTerm = svarAllTimeLatency yinfo-        measured = workerMeasuredLatency yinfo--    (newCount, newLatPair) <- collectWorkerPendingLatency cur col-    (lcount, ltime) <- readIORef longTerm-    prevLat <- readIORef measured--    let newLcount = lcount + newCount-        retWith lat = return (newLcount, ltime, lat)--    case newLatPair of-        Nothing -> retWith prevLat-        Just (count, time) -> do-            let newLat = time `div` (fromIntegral count)-            when (svarInspectMode sv) $ recordMinMaxLatency sv newLat-            -- When we have collected a significant sized batch we compute the-            -- new latency using that batch and return the new latency,-            -- otherwise we return the previous latency derived from the-            -- previous batch.-            if shouldUseCollectedBatch newCount time newLat prevLat || drain-            then do-                -- XXX make this NOINLINE?-                updateWorkerPollingInterval yinfo (max newLat prevLat)-                when (svarInspectMode sv) $ recordAvgLatency sv (count, time)-                writeIORef col (0, 0, 0)-                writeIORef measured ((prevLat + newLat) `div` 2)-                modifyIORef longTerm $ \(_, t) -> (newLcount, t)-                retWith newLat-            else retWith prevLat------------------------------------------------------------------------------------ Dumping the SVar for debug/diag----------------------------------------------------------------------------------dumpSVarStats :: SVar t m a -> SVarStats -> SVarStyle -> IO String-dumpSVarStats sv ss style = do-    case yieldRateInfo sv of-        Nothing -> return ()-        Just yinfo -> do-            _ <- liftIO $ collectLatency sv yinfo True-            return ()--    dispatches <- readIORef $ totalDispatches ss-    maxWrk <- readIORef $ maxWorkers ss-    maxOq <- readIORef $ maxOutQSize ss-    maxHp <- readIORef $ maxHeapSize ss-    minLat <- readIORef $ minWorkerLatency ss-    maxLat <- readIORef $ maxWorkerLatency ss-    (avgCnt, avgTime) <- readIORef $ avgWorkerLatency ss-    (svarCnt, svarGainLossCnt, svarLat) <- case yieldRateInfo sv of-        Nothing -> return (0, 0, 0)-        Just yinfo -> do-            (cnt, startTime) <- readIORef $ svarAllTimeLatency yinfo-            if cnt > 0-            then do-                t <- readIORef (svarStopTime ss)-                gl <- readIORef (svarGainedLostYields yinfo)-                case t of-                    Nothing -> do-                        now <- getTime Monotonic-                        let interval = diffAbsTime64 now startTime-                        return (cnt, gl, interval `div` fromIntegral cnt)-                    Just stopTime -> do-                        let interval = diffAbsTime64 stopTime startTime-                        return (cnt, gl, interval `div` fromIntegral cnt)-            else return (0, 0, 0)--    return $ unlines-        [ "total dispatches = " <> show dispatches-        , "max workers = " <> show maxWrk-        , "max outQSize = " <> show maxOq-            <> (if style == AheadVar-               then "\nheap max size = " <> show maxHp-               else "")-            <> (if minLat > 0-               then "\nmin worker latency = " <> showNanoSecond64 minLat-               else "")-            <> (if maxLat > 0-               then "\nmax worker latency = " <> showNanoSecond64 maxLat-               else "")-            <> (if avgCnt > 0-                then let lat = avgTime `div` fromIntegral avgCnt-                     in "\navg worker latency = " <> showNanoSecond64 lat-                else "")-            <> (if svarLat > 0-               then "\nSVar latency = " <> showRelTime64 svarLat-               else "")-            <> (if svarCnt > 0-               then "\nSVar yield count = " <> show svarCnt-               else "")-            <> (if svarGainLossCnt > 0-               then "\nSVar gain/loss yield count = " <> show svarGainLossCnt-               else "")-        ]--{-# NOINLINE dumpSVar #-}-dumpSVar :: SVar t m a -> IO String-dumpSVar sv = do-    (oqList, oqLen) <- readIORef $ outputQueue sv-    db <- tryReadMVar $ outputDoorBell sv-    aheadDump <--        if svarStyle sv == AheadVar-        then do-            (oheap, oheapSeq) <- readIORef $ outputHeap sv-            (wq, wqSeq) <- readIORef $ aheadWorkQueue sv-            return $ unlines-                [ "heap length = " <> show (H.size oheap)-                , "heap seqeunce = " <> show oheapSeq-                , "work queue length = " <> show (length wq)-                , "work queue sequence = " <> show wqSeq-                ]-        else return []--    let style = svarStyle sv-    waiting <--        if style /= ParallelVar-        then readIORef $ needDoorBell sv-        else return False-    rthread <- readIORef $ workerThreads sv-    workers <- readIORef $ workerCount sv-    stats <- dumpSVarStats sv (svarStats sv) (svarStyle sv)--    return $ unlines-        [-          "Creator tid = " <> show (svarCreator sv),-          "style = " <> show (svarStyle sv)-        , "---------CURRENT STATE-----------"-        , "outputQueue length computed  = " <> show (length oqList)-        , "outputQueue length maintained = " <> show oqLen-        -- XXX print the types of events in the outputQueue, first 5-        , "outputDoorBell = " <> show db-        ]-        <> aheadDump-        <> unlines-        [ "needDoorBell = " <> show waiting-        , "running threads = " <> show rthread-        -- XXX print the status of first 5 threads-        , "running thread count = " <> show workers-        ]-        <> "---------STATS-----------\n"-        <> stats---- 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--- until they are GCed because the consumer went away.--{-# NOINLINE mvarExcHandler #-}-mvarExcHandler :: SVar t m a -> String -> BlockedIndefinitelyOnMVar -> IO ()-mvarExcHandler sv label e@BlockedIndefinitelyOnMVar = do-    svInfo <- dumpSVar sv-    hPutStrLn stderr $ label <> " " <> "BlockedIndefinitelyOnMVar\n" <> svInfo-    throwIO e--{-# NOINLINE stmExcHandler #-}-stmExcHandler :: SVar t m a -> String -> BlockedIndefinitelyOnSTM -> IO ()-stmExcHandler sv label e@BlockedIndefinitelyOnSTM = do-    svInfo <- dumpSVar sv-    hPutStrLn stderr $ label <> " " <> "BlockedIndefinitelyOnSTM\n" <> svInfo-    throwIO e--withDiagMVar :: SVar t m a -> String -> IO () -> IO ()-withDiagMVar sv label action =-    if svarInspectMode sv-    then-        action `catches` [ Handler (mvarExcHandler sv label)-                         , Handler (stmExcHandler sv label)-                         ]-    else action----------------------------------------------------------------------------------- Spawning threads----------------------------------------------------------------------------------- | A monad that can perform concurrent or parallel IO operations. Streams--- that can be composed concurrently require the underlying monad to be--- 'MonadAsync'.------ @since 0.1.0-type MonadAsync m = (MonadIO m, MonadBaseControl IO m, MonadThrow m)---- When we run computations concurrently, we completely isolate the state of--- the concurrent computations from the parent computation.  The invariant is--- that we should never be running two concurrent computations in the same--- thread without using the runInIO function.  Also, we should never be running--- a concurrent computation in the parent thread, otherwise it may affect the--- state of the parent which is against the defined semantics of concurrent--- execution.-newtype RunInIO m = RunInIO { runInIO :: forall b. m b -> IO (StM m b) }--captureMonadState :: MonadBaseControl IO m => m (RunInIO m)-captureMonadState = control $ \run -> run (return $ RunInIO run)---- Stolen from the async package. The perf improvement is modest, 2% on a--- thread heavy benchmark (parallel composition using noop computations).--- A version of forkIO that does not include the outer exception--- handler: saves a bit of time when we will be installing our own--- exception handler.-{-# INLINE rawForkIO #-}-rawForkIO :: IO () -> IO ThreadId-rawForkIO action = IO $ \ s ->-   case fork# action s of (# s1, tid #) -> (# s1, ThreadId tid #)--{-# INLINE doFork #-}-doFork :: MonadBaseControl IO m-    => m ()-    -> RunInIO m-    -> (SomeException -> IO ())-    -> m ThreadId-doFork action (RunInIO mrun) exHandler =-    control $ \run ->-        mask $ \restore -> do-                tid <- rawForkIO $ catch (restore $ void $ mrun action)-                                         exHandler-                run (return tid)----------------------------------------------------------------------------------- Collecting results from child workers in a streamed fashion----------------------------------------------------------------------------------- XXX Can we make access to remainingWork and yieldRateInfo fields in sv--- faster, along with the fields in sv required by send?--- XXX make it noinline------ XXX we may want to employ an increment and decrement in batches when the--- througput is high or when the cost of synchronization is high. For example--- if the application is distributed then inc/dec of a shared variable may be--- very costly.------ Note that we need it to be an Int type so that we have the ability to undo a--- decrement that takes below zero.-{-# INLINE decrementYieldLimit #-}-decrementYieldLimit :: SVar t m a -> IO Bool-decrementYieldLimit sv =-    case remainingWork sv of-        Nothing -> return True-        Just ref -> do-            r <- atomicModifyIORefCAS ref $ \x -> (x - 1, x)-            return $ r >= 1---- decrementYieldLimit returns False when the old limit is 0. This one returns--- False when the old limit is 1.-{-# INLINE decrementYieldLimitPost #-}-decrementYieldLimitPost :: SVar t m a -> IO Bool-decrementYieldLimitPost sv =-    case remainingWork sv of-        Nothing -> return True-        Just ref -> do-            r <- atomicModifyIORefCAS ref $ \x -> (x - 1, x)-            return $ r > 1--{-# INLINE incrementYieldLimit #-}-incrementYieldLimit :: SVar t m a -> IO ()-incrementYieldLimit sv =-    case remainingWork sv of-        Nothing -> return ()-        Just ref -> atomicModifyIORefCAS_ ref (+ 1)---- XXX exception safety of all atomic/MVar operations---- TBD Each worker can have their own queue and the consumer can empty one--- queue at a time, that way contention can be reduced.---- XXX Only yields should be counted in the buffer limit and not the Stop--- events.---- | 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 Bool-send sv msg = do-    -- XXX can the access to outputQueue and maxBufferLimit be made faster-    -- somehow?-    len <- atomicModifyIORefCAS (outputQueue sv) $ \(es, n) ->-        ((msg : es, n + 1), n)-    when (len <= 0) $ do-        -- The wake up must happen only after the store has finished otherwise-        -- we can have lost wakeup problems.-        writeBarrier-        -- Since multiple workers can try this at the same time, it is possible-        -- that we may put a spurious MVar after the consumer has already seen-        -- the output. But that's harmless, at worst it may cause the consumer-        -- to read the queue again and find it empty.-        -- The important point is that the consumer is guaranteed to receive a-        -- doorbell if something was added to the queue after it empties it.-        void $ tryPutMVar (outputDoorBell sv) ()--    -- XXX we should reserve the buffer when we pick up the work from the-    -- queue, instead of checking it here when it is too late.-    let limit = maxBufferLimit sv-    case limit of-        Unlimited -> return True-        Limited lim -> do-            active <- readIORef (workerCount sv)-            return $ len < (fromIntegral lim - active)--workerCollectLatency :: WorkerInfo -> IO (Maybe (Count, NanoSecond64))-workerCollectLatency winfo = do-    (cnt0, t0) <- readIORef (workerLatencyStart winfo)-    cnt1 <- readIORef (workerYieldCount winfo)-    let cnt = cnt1 - cnt0--    if cnt > 0-    then do-        t1 <- getTime Monotonic-        let period = fromRelTime64 $ diffAbsTime64 t1 t0-        writeIORef (workerLatencyStart winfo) (cnt1, t1)-        return $ Just (cnt, period)-    else return Nothing---- XXX There are a number of gotchas in measuring latencies.--- 1) We measure latencies only when a worker yields a value--- 2) It is possible that a stream calls the stop continuation, in which case--- the worker would not yield a value and we would not account that worker in--- latencies. Even though this case should ideally be accounted we do not--- account it because we cannot or do not distinguish it from the case--- described next.--- 3) It is possible that a worker returns without yielding anything because it--- never got a chance to pick up work.--- 4) If the system timer resolution is lower than the latency, the latency--- computation turns out to be zero.------ We can fix this if we measure the latencies by counting the work items--- picked rather than based on the outputs yielded.-workerUpdateLatency :: YieldRateInfo -> WorkerInfo -> IO ()-workerUpdateLatency yinfo winfo = do-    r <- workerCollectLatency winfo-    case r of-        Just (cnt, period) -> do-        -- NOTE: On JS platform the timer resolution could be pretty low. When-        -- the timer resolution is low, measurement of latencies could be-        -- tricky. All the worker latencies will turn out to be zero if they-        -- are lower than the resolution. We only take into account those-        -- measurements which are more than the timer resolution.--            let ref = workerPendingLatency yinfo-                (cnt1, t1) = if period > 0 then (cnt, period) else (0, 0)-            atomicModifyIORefCAS_ ref $-                    \(fc, n, t) -> (fc + cnt, n + cnt1, t + t1)-        Nothing -> return ()--updateYieldCount :: WorkerInfo -> IO Count-updateYieldCount winfo = do-    cnt <- readIORef (workerYieldCount winfo)-    let cnt1 = cnt + 1-    writeIORef (workerYieldCount winfo) cnt1-    return cnt1--isBeyondMaxYield :: Count -> WorkerInfo -> Bool-isBeyondMaxYield cnt winfo =-    let ymax = workerYieldMax winfo-    in ymax /= 0 && cnt >= ymax---- XXX we should do rate control periodically based on the total yields rather--- than based on the worker local yields as other workers may have yielded more--- and we should stop based on the aggregate yields. However, latency update--- period can be based on individual worker yields.-{-# NOINLINE checkRatePeriodic #-}-checkRatePeriodic :: SVar t m a-                  -> YieldRateInfo-                  -> WorkerInfo-                  -> Count-                  -> IO Bool-checkRatePeriodic sv yinfo winfo ycnt = do-    i <- readIORef (workerPollingInterval yinfo)-    -- XXX use generation count to check if the interval has been updated-    if i /= 0 && (ycnt `mod` i) == 0-    then do-        workerUpdateLatency yinfo winfo-        -- XXX not required for parallel streams-        isBeyondMaxRate sv yinfo-    else return False---- CAUTION! this also updates the yield count and therefore should be called--- only when we are actually yielding an element.-{-# NOINLINE workerRateControl #-}-workerRateControl :: SVar t m a -> YieldRateInfo -> WorkerInfo -> IO Bool-workerRateControl sv yinfo winfo = do-    cnt <- updateYieldCount winfo-    beyondMaxRate <- checkRatePeriodic sv yinfo winfo cnt-    return $ not (isBeyondMaxYield cnt winfo || beyondMaxRate)---- XXX we should do rate control here but not latency update in case of ahead--- streams. latency update must be done when we yield directly to outputQueue--- or when we yield to heap.-{-# INLINE sendYield #-}-sendYield :: SVar t m a -> Maybe WorkerInfo -> ChildEvent a -> IO Bool-sendYield sv mwinfo msg = do-    r <- send sv msg-    rateLimitOk <--        case mwinfo of-            Just winfo ->-                case yieldRateInfo sv of-                    Nothing -> return True-                    Just yinfo -> workerRateControl sv yinfo winfo-            Nothing -> return True-    return $ r && rateLimitOk--{-# INLINE workerStopUpdate #-}-workerStopUpdate :: WorkerInfo -> YieldRateInfo -> IO ()-workerStopUpdate winfo info = do-    i <- readIORef (workerPollingInterval info)-    when (i /= 0) $ workerUpdateLatency info winfo--{-# INLINABLE sendStop #-}-sendStop :: SVar t m a -> Maybe WorkerInfo -> IO ()-sendStop sv mwinfo = do-    atomicModifyIORefCAS_ (workerCount sv) $ \n -> n - 1-    case (mwinfo, yieldRateInfo sv) of-      (Just winfo, Just info) ->-          workerStopUpdate winfo info-      _ ->-          return ()-    myThreadId >>= \tid -> void $ send sv (ChildStop tid Nothing)------------------------------------------------------------------------------------ Doorbell----------------------------------------------------------------------------------{-# INLINE ringDoorBell #-}-ringDoorBell :: SVar t m a -> IO ()-ringDoorBell sv = do-    storeLoadBarrier-    w <- readIORef $ needDoorBell sv-    when w $ do-        -- Note: the sequence of operations is important for correctness here.-        -- We need to set the flag to false strictly before sending the-        -- outputDoorBell, otherwise the outputDoorBell may get processed too-        -- early and then we may set the flag to False to later making the-        -- consumer lose the flag, even without receiving a outputDoorBell.-        atomicModifyIORefCAS_ (needDoorBell sv) (const False)-        void $ tryPutMVar (outputDoorBell sv) ()------------------------------------------------------------------------------------ Async------------------------------------------------------------------------------------ Note: For purely right associated expressions this queue should have at most--- one element. It grows to more than one when we have left associcated--- expressions. Large left associated compositions can grow this to a--- large size-{-# INLINE enqueueLIFO #-}-enqueueLIFO :: SVar t m a -> IORef [t m a] -> t m a -> IO ()-enqueueLIFO sv q m = do-    atomicModifyIORefCAS_ q $ \ms -> m : ms-    ringDoorBell sv------------------------------------------------------------------------------------ WAsync------------------------------------------------------------------------------------ XXX we can use the Ahead style sequence/heap mechanism to make the best--- effort to always try to finish the streams on the left side of an expression--- first as long as possible.--{-# INLINE enqueueFIFO #-}-enqueueFIFO :: SVar t m a -> LinkedQueue (t m a) -> t m a -> IO ()-enqueueFIFO sv q m = do-    pushL q m-    ringDoorBell sv------------------------------------------------------------------------------------ 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.---- XXX 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 one item in it.------ XXX we can fix this. When we queue more than one item on the queue we can--- mark the previously queued item as not-runnable. The not-runnable item is--- not dequeued until the already running one has finished and at that time we--- would also know the exact sequence number of the already queued item.------ we can even run the already queued items but they will have to be sorted in--- layers in the heap. We can use a list of heaps for that.-{-# INLINE enqueueAhead #-}-enqueueAhead :: SVar t m a -> IORef ([t m a], Int) -> t m a -> IO ()-enqueueAhead sv q m = do-    atomicModifyIORefCAS_ q $ \ case-        ([], n) -> ([m], n + 1)  -- increment sequence-        _ -> error "not empty"-    ringDoorBell sv---- enqueue without incrementing the sequence number-{-# INLINE reEnqueueAhead #-}-reEnqueueAhead :: SVar t m a -> IORef ([t m a], Int) -> t m a -> IO ()-reEnqueueAhead sv q m = do-    atomicModifyIORefCAS_ q $ \ case-        ([], n) -> ([m], n)  -- DO NOT increment sequence-        _ -> error "not empty"-    ringDoorBell sv---- Normally the thread that has the token should never go away. The token gets--- handed over to another thread, but someone or the other has the token at any--- point of time. But if the task that has the token finds that the outputQueue--- is full, in that case it can go away without even handing over the token to--- another thread. In that case it sets the nextSequence number in the heap its--- own sequence number before going away. To handle this case, any task that--- does not have the token tries to dequeue from the heap first before--- dequeuing from the work queue. If it finds that the task at the top of the--- heap is the one that owns the current sequence number then it grabs the--- token and starts with that.------ XXX instead of queueing just the head element and the remaining computation--- on the heap, evaluate as many as we can and place them on the heap. But we--- need to give higher priority to the lower sequence numbers so that lower--- priority tasks do not fill up the heap making higher priority tasks block--- due to full heap. Maybe we can have a weighted space for them in the heap.--- The weight is inversely proportional to the sequence number.------ XXX review for livelock----{-# INLINE queueEmptyAhead #-}-queueEmptyAhead :: MonadIO m => IORef ([t m a], Int) -> m Bool-queueEmptyAhead q = liftIO $ do-    (xs, _) <- readIORef q-    return $ null xs--{-# INLINE dequeueAhead #-}-dequeueAhead :: MonadIO m-    => IORef ([t m a], Int) -> m (Maybe (t m a, Int))-dequeueAhead q = liftIO $-    atomicModifyIORefCAS q $ \case-            ([], n) -> (([], n), Nothing)-            (x : [], n) -> (([], n), Just (x, n))-            _ -> error "more than one item on queue"------------------------------------------------------------------------------------ Heap manipulation----------------------------------------------------------------------------------withIORef :: IORef a -> (a -> IO b) -> IO b-withIORef ref f = readIORef ref >>= f--atomicModifyIORef_ :: IORef a -> (a -> a) -> IO ()-atomicModifyIORef_ ref f =-    atomicModifyIORef ref $ \x -> (f x, ())--data HeapDequeueResult t m a =-      Clearing-    | Waiting Int-    | Ready (Entry Int (AheadHeapEntry t m a))--{-# INLINE dequeueFromHeap #-}-dequeueFromHeap-    :: IORef (Heap (Entry Int (AheadHeapEntry t m a)), Maybe Int)-    -> IO (HeapDequeueResult t m a)-dequeueFromHeap hpVar =-    atomicModifyIORef hpVar $ \pair@(hp, snum) ->-        case snum of-            Nothing -> (pair, Clearing)-            Just n -> do-                let r = H.uncons hp-                case r of-                    Just (ent@(Entry seqNo _ev), hp') ->-                            if seqNo == n-                            then ((hp', Nothing), Ready ent)-                            else assert (seqNo >= n) (pair, Waiting n)-                    Nothing -> (pair, Waiting n)--{-# INLINE dequeueFromHeapSeq #-}-dequeueFromHeapSeq-    :: IORef (Heap (Entry Int (AheadHeapEntry t m a)), Maybe Int)-    -> Int-    -> IO (HeapDequeueResult t m a)-dequeueFromHeapSeq hpVar i =-    atomicModifyIORef hpVar $ \(hp, snum) ->-        case snum of-            Nothing -> do-                let r = H.uncons hp-                case r of-                    Just (ent@(Entry seqNo _ev), hp') ->-                        if seqNo == i-                        then ((hp', Nothing), Ready ent)-                        else assert (seqNo >= i) ((hp, Just i), Waiting i)-                    Nothing -> ((hp, Just i), Waiting i)-            Just _ -> error "dequeueFromHeapSeq: unreachable"--heapIsSane :: Maybe Int -> Int -> Bool-heapIsSane snum seqNo =-    case snum of-        Nothing -> True-        Just n -> seqNo >= n--{-# INLINE requeueOnHeapTop #-}-requeueOnHeapTop-    :: IORef (Heap (Entry Int (AheadHeapEntry t m a)), Maybe Int)-    -> Entry Int (AheadHeapEntry t m a)-    -> Int-    -> IO ()-requeueOnHeapTop hpVar ent seqNo =-    atomicModifyIORef_ hpVar $ \(hp, snum) ->-        assert (heapIsSane snum seqNo) (H.insert ent hp, Just seqNo)--{-# INLINE updateHeapSeq #-}-updateHeapSeq-    :: IORef (Heap (Entry Int (AheadHeapEntry t m a)), Maybe Int)-    -> Int-    -> IO ()-updateHeapSeq hpVar seqNo =-    atomicModifyIORef_ hpVar $ \(hp, snum) ->-        assert (heapIsSane snum seqNo) (hp, Just seqNo)------------------------------------------------------------------------------------ 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.------------------------------------------------------------------------------------ Dispatching workers and tracking them------------------------------------------------------------------------------------ Thread tracking is needed for two reasons:------ 1) Killing threads on exceptions. Threads may not be left to go away by--- themselves because they may run for significant times before going away or--- worse they may be stuck in IO and never go away.------ 2) To know when all threads are done and the stream has ended.--{-# NOINLINE addThread #-}-addThread :: MonadIO m => SVar t m a -> ThreadId -> m ()-addThread sv tid =-    liftIO $ modifyIORef (workerThreads sv) (S.insert tid)---- This is cheaper than modifyThread because we do not have to send a--- outputDoorBell This can make a difference when more workers are being--- dispatched.-{-# INLINE delThread #-}-delThread :: MonadIO m => SVar t m a -> ThreadId -> m ()-delThread sv tid =-    liftIO $ modifyIORef (workerThreads sv) (S.delete tid)---- If present then delete else add. This takes care of out of order add and--- delete i.e. a delete arriving before we even added a thread.--- This occurs when the forked thread is done even before the 'addThread' right--- after the fork gets a chance to run.-{-# INLINE modifyThread #-}-modifyThread :: MonadIO m => SVar t m a -> ThreadId -> m ()-modifyThread sv tid = do-    changed <- liftIO $ atomicModifyIORefCAS (workerThreads sv) $ \old ->-        if S.member tid old-        then let new = S.delete tid old in (new, new)-        else let new = S.insert tid old in (new, old)-    when (null changed) $-         liftIO $ do-            writeBarrier-            void $ tryPutMVar (outputDoorBell sv) ()---- | This is safe even if we are adding more threads concurrently because if--- a child thread is adding another thread then anyway 'workerThreads' will--- not be empty.-{-# INLINE allThreadsDone #-}-allThreadsDone :: MonadIO m => SVar t m a -> m Bool-allThreadsDone sv = liftIO $ S.null <$> readIORef (workerThreads sv)--{-# NOINLINE handleChildException #-}-handleChildException :: SVar t m a -> SomeException -> IO ()-handleChildException sv e = do-    tid <- myThreadId-    void $ send sv (ChildStop tid (Just e))--{-# NOINLINE recordMaxWorkers #-}-recordMaxWorkers :: MonadIO m => SVar t m a -> m ()-recordMaxWorkers sv = liftIO $ do-    active <- readIORef (workerCount sv)-    maxWrk <- readIORef (maxWorkers $ svarStats sv)-    when (active > maxWrk) $ writeIORef (maxWorkers $ svarStats sv) active-    modifyIORef (totalDispatches $ svarStats sv) (+1)--{-# NOINLINE pushWorker #-}-pushWorker :: MonadAsync m => Count -> SVar t m a -> m ()-pushWorker yieldMax sv = do-    liftIO $ atomicModifyIORefCAS_ (workerCount sv) $ \n -> n + 1-    when (svarInspectMode sv) $ recordMaxWorkers sv-    -- This allocation matters when significant number of workers are being-    -- sent. We allocate it only when needed.-    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 = yieldMax-                    , workerYieldCount = cntRef-                    , workerLatencyStart = lat-                    }-    doFork (workLoop sv winfo) (svarMrun sv) (handleChildException sv)-        >>= addThread sv---- XXX we can push the workerCount modification in accountThread and use the--- same pushWorker for Parallel case as well.------ | In contrast to pushWorker which always happens only from the consumer--- thread, a pushWorkerPar can happen concurrently from multiple threads on the--- producer side. So we need to use a thread safe modification of--- workerThreads. Alternatively, we can use a CreateThread event to avoid--- using a CAS based modification.-{-# INLINE pushWorkerPar #-}-pushWorkerPar-    :: MonadAsync m-    => SVar t m a -> (Maybe WorkerInfo -> m ()) -> m ()-pushWorkerPar sv wloop =-    if svarInspectMode sv-    then forkWithDiag-    else doFork (wloop Nothing) (svarMrun sv) (handleChildException sv)-            >>= modifyThread sv--    where--    {-# 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-                        }--        doFork (wloop winfo) (svarMrun sv) (handleChildException sv)-            >>= modifyThread sv---- Returns:--- True: can dispatch more--- False: cannot dispatch any more-dispatchWorker :: MonadAsync m => Count -> SVar t m a -> m Bool-dispatchWorker yieldCount sv = do-    let workerLimit = maxWorkerLimit sv-    -- XXX in case of Ahead streams we should not send more than one worker-    -- when the work queue is done but heap is not done.-    done <- liftIO $ isWorkDone sv-    -- Note, "done" may not mean that the work is actually finished if there-    -- are workers active, because there may be a worker which has not yet-    -- queued the leftover work.-    if not done-    then do-        qDone <- liftIO $ isQueueDone sv-        -- Note that the worker count is only decremented during event-        -- processing in fromStreamVar and therefore it is safe to read and-        -- use it without a lock.-        active <- liftIO $ readIORef $ workerCount sv-        if not qDone-        then do-            -- Note that we may deadlock if the previous workers (tasks in the-            -- stream) wait/depend on the future workers (tasks in the stream)-            -- executing. In that case we should either configure the maxWorker-            -- count to higher or use parallel style instead of ahead or async-            -- style.-            limit <- case remainingWork sv of-                Nothing -> return workerLimit-                Just ref -> do-                    n <- liftIO $ readIORef ref-                    case yieldRateInfo sv of-                        Just _ -> return workerLimit-                        Nothing ->-                            return $-                                case workerLimit of-                                    Unlimited -> Limited (fromIntegral n)-                                    Limited lim -> Limited $ min lim (fromIntegral n)--            -- XXX for ahead streams shall we take the heap yields into account-            -- for controlling the dispatch? We should not dispatch if the heap-            -- has already got the limit covered.-            let dispatch = pushWorker yieldCount sv >> return True-             in case limit of-                Unlimited -> dispatch-                -- Note that the use of remainingWork and workerCount is not-                -- atomic and the counts may even have changed between reading-                -- and using them here, so this is just approximate logic and-                -- we cannot rely on it for correctness. We may actually-                -- dispatch more workers than required.-                Limited lim | lim > fromIntegral active -> dispatch-                _ -> return False-        else do-            when (active <= 0) $ pushWorker 0 sv-            return False-    else return False------------------------------------------------------------------------------------ Dispatch workers with rate control------------------------------------------------------------------------------------ | This is a magic number and it is overloaded, and used at several places to--- achieve batching:------ 1. If we have to sleep to slowdown this is the minimum period that we---    accumulate before we sleep. Also, workers do not stop until this much---    sleep time is accumulated.--- 3. Collected latencies are computed and transferred to measured latency---    after a minimum of this period.-minThreadDelay :: NanoSecond64-minThreadDelay = 1000000---- | Another magic number! When we have to start more workers to cover up a--- number of yields that we are lagging by then we cannot start one worker for--- each yield because that may be a very big number and if the latency of the--- workers is low these number of yields could be very high. We assume that we--- run each extra worker for at least this much time.-rateRecoveryTime :: NanoSecond64-rateRecoveryTime = 1000000---- We either block, or send one worker with limited yield count or one or more--- workers with unlimited yield count.-data Work-    = BlockWait NanoSecond64-    | PartialWorker Count-    | ManyWorkers Int Count-    deriving Show---- XXX we can use phantom types to distinguish the duration/latency/expectedLat-estimateWorkers-    :: Limit-    -> Count-    -> Count-    -> NanoSecond64-    -> NanoSecond64-    -> NanoSecond64-    -> LatencyRange-    -> Work-estimateWorkers workerLimit svarYields gainLossYields-                svarElapsed wLatency targetLat range =-    -- XXX we can have a maxEfficiency combinator as well which runs the-    -- producer at the maximal efficiency i.e. the number of workers are chosen-    -- such that the latency is minimum or within a range. Or we can call it-    -- maxWorkerLatency.-    ---    let-        -- How many workers do we need to acheive 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-        -- capacity to process all the requests concurrently. If the IO-        -- bandwidth is saturated increasing the workers won't help. Also, if-        -- the CPU utilization in processing all these requests exceeds the CPU-        -- bandwidth, then increasing the number of workers won't help.-        ---        -- When the workers are purely CPU bound, increasing the workers beyond-        -- the number of CPUs won't help.-        ---        -- TODO - measure the CPU and IO requirements of the workers. Have a-        -- way to specify the max bandwidth of the underlying IO mechanism and-        -- 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.--        -- Calculate how many yields are we ahead or behind to match the exact-        -- required rate. Based on that we increase or decrease the effective-        -- workers.-        ---        -- When the worker latency is lower than required latency we begin with-        -- a yield and then wait rather than first waiting and then yielding.-        targetYields = (svarElapsed + wLatency + targetLat - 1) `div` targetLat-        effectiveYields = svarYields + gainLossYields-        deltaYields = fromIntegral targetYields - effectiveYields--        -- We recover the deficit by running at a higher/lower rate for a-        -- certain amount of time. To keep the effective rate in reasonable-        -- limits we use rateRecoveryTime, minLatency and maxLatency.-        in  if deltaYields > 0-            then-                let deltaYieldsFreq :: Double-                    deltaYieldsFreq =-                        fromIntegral deltaYields /-                            fromIntegral rateRecoveryTime-                    yieldsFreq = 1.0 / fromIntegral targetLat-                    totalYieldsFreq = yieldsFreq + deltaYieldsFreq-                    requiredLat = NanoSecond64 $ round $ 1.0 / totalYieldsFreq-                    adjustedLat = min (max requiredLat (minLatency range))-                                      (maxLatency range)-                in  assert (adjustedLat > 0) $-                    if wLatency <= adjustedLat-                    then PartialWorker deltaYields-                    else let workers = withLimit $ wLatency `div` adjustedLat-                             limited = min workers (fromIntegral deltaYields)-                         in ManyWorkers (fromIntegral limited) deltaYields-            else-                let expectedDuration = fromIntegral effectiveYields * targetLat-                    sleepTime = expectedDuration - svarElapsed-                    maxSleepTime = maxLatency range - wLatency-                    s = min sleepTime maxSleepTime-                in assert (sleepTime >= 0) $-                    -- if s is less than 0 it means our maxSleepTime is less-                    -- than the worker latency.-                    if s > 0 then BlockWait s else ManyWorkers 1 (Count 0)-    where-        withLimit n =-            case workerLimit of-                Unlimited -> n-                Limited x -> min n (fromIntegral x)---- | Get the worker latency without resetting workerPendingLatency--- Returns (total yield count, base time, measured latency)--- CAUTION! keep it in sync with collectLatency-getWorkerLatency :: YieldRateInfo -> IO (Count, AbsTime, NanoSecond64)-getWorkerLatency yinfo  = do-    let cur      = workerPendingLatency yinfo-        col      = workerCollectedLatency yinfo-        longTerm = svarAllTimeLatency yinfo-        measured = workerMeasuredLatency yinfo--    (curTotalCount, curCount, curTime) <- readIORef cur-    (colTotalCount, colCount, colTime) <- readIORef col-    (lcount, ltime)     <- readIORef longTerm-    prevLat             <- readIORef measured--    let latCount = colCount + curCount-        latTime  = colTime + curTime-        totalCount = colTotalCount + curTotalCount-        newLat =-            if latCount > 0 && latTime > 0-            then let lat = latTime `div` fromIntegral latCount-                 -- XXX Give more weight to new?-                 in (lat + prevLat) `div` 2-            else prevLat-    return (lcount + totalCount, ltime, newLat)--isBeyondMaxRate :: SVar t m a -> YieldRateInfo -> IO Bool-isBeyondMaxRate sv yinfo = do-    (count, tstamp, wLatency) <- getWorkerLatency yinfo-    now <- getTime Monotonic-    let duration = fromRelTime64 $ diffAbsTime64 now tstamp-    let targetLat = svarLatencyTarget yinfo-    gainLoss <- readIORef (svarGainedLostYields yinfo)-    let work = estimateWorkers (maxWorkerLimit sv) count gainLoss duration-                               wLatency targetLat (svarLatencyRange yinfo)-    cnt <- readIORef $ workerCount sv-    return $ case work of-        -- XXX set the worker's maxYields or polling interval based on yields-        PartialWorker _yields -> cnt > 1-        ManyWorkers n _ -> cnt > n-        BlockWait _ -> True---- XXX in case of ahead style stream we need to take the heap size into account--- because we return the workers on the basis of that which causes a condition--- where we keep dispatching and they keep returning. So we must have exactly--- the same logic for not dispatching and for returning.------ Returns:--- True: can dispatch more--- False: full, no more dispatches-dispatchWorkerPaced :: MonadAsync m => SVar t m a -> m Bool-dispatchWorkerPaced sv = do-    let yinfo = fromJust $ yieldRateInfo sv-    (svarYields, svarElapsed, wLatency) <- do-        now <- liftIO $ getTime Monotonic-        (yieldCount, baseTime, lat) <--            liftIO $ collectLatency sv yinfo False-        let elapsed = fromRelTime64 $ diffAbsTime64 now baseTime-        let latency =-                if lat == 0-                then-                    case workerBootstrapLatency yinfo of-                        Nothing -> lat-                        Just t -> t-                else lat--        return (yieldCount, elapsed, latency)--    if wLatency == 0-    -- Need to measure the latency with a single worker before we can perform-    -- any computation.-    then return False-    else do-        let workerLimit = maxWorkerLimit sv-        let targetLat = svarLatencyTarget yinfo-        let range = svarLatencyRange yinfo-        gainLoss <- liftIO $ readIORef (svarGainedLostYields yinfo)-        let work = estimateWorkers workerLimit svarYields gainLoss svarElapsed-                                   wLatency targetLat range--        -- XXX we need to take yieldLimit into account here. If we are at the-        -- end of the limit as well as the time, we should not be sleeping.-        -- If we are not actually planning to dispatch any more workers we need-        -- to take that in account.-        case work of-            BlockWait s -> do-                assert (s >= 0) (return ())-                -- XXX note that when we return from here we will block waiting-                -- for the result from the existing worker. If that takes too-                -- long we won't be able to send another worker until the-                -- result arrives.-                ---                -- Sleep only if there are no active workers, otherwise we will-                -- defer the output of those. Note we cannot use workerCount-                -- here as it is not a reliable way to ensure there are-                -- definitely no active workers. When workerCount is 0 we may-                -- still have a Stop event waiting in the outputQueue.-                done <- allThreadsDone sv-                when done $ void $ do-                    let us = fromRelTime64 (toRelTime64 s) :: MicroSecond64-                    liftIO $ threadDelay (fromIntegral us)-                    dispatchWorker 1 sv-                return False-            PartialWorker yields -> do-                assert (yields > 0) (return ())-                updateGainedLostYields yinfo yields--                done <- allThreadsDone sv-                when done $ void $ dispatchWorker yields sv-                return False-            ManyWorkers netWorkers yields -> do-                assert (netWorkers >= 1) (return ())-                assert (yields >= 0) (return ())-                updateGainedLostYields yinfo yields--                let periodRef = workerPollingInterval yinfo-                    ycnt = max 1 $ yields `div` fromIntegral netWorkers-                    period = min ycnt (fromIntegral magicMaxBuffer)--                old <- liftIO $ readIORef periodRef-                when (period < old) $-                    liftIO $ writeIORef periodRef period--                cnt <- liftIO $ readIORef $ workerCount sv-                if cnt < netWorkers-                then do-                    let total = netWorkers - cnt-                        batch = max 1 $ fromIntegral $-                                    minThreadDelay `div` targetLat-                    -- XXX stagger the workers over a period?-                    -- XXX cannot sleep, as that would mean we cannot process-                    -- the outputs. need to try a different mechanism to-                    -- stagger.-                    -- when (total > batch) $-                       -- liftIO $ threadDelay $ nanoToMicroSecs minThreadDelay-                    dispatchN (min total batch)-                else return False--    where--    updateGainedLostYields yinfo yields = do-        let buf = fromIntegral $ svarRateBuffer yinfo-        when (yields /= 0 && abs yields > buf) $ do-            let delta =-                   if yields > 0-                   then yields - buf-                   else yields + buf-            liftIO $ modifyIORef (svarGainedLostYields yinfo) (+ delta)--    dispatchN n =-        if n == 0-        then return True-        else do-            r <- dispatchWorker 0 sv-            if r-            then dispatchN (n - 1)-            else return False------------------------------------------------------------------------------------ Worker dispatch and wait loop----------------------------------------------------------------------------------sendWorkerDelayPaced :: SVar t m a -> IO ()-sendWorkerDelayPaced _ = return ()--sendWorkerDelay :: SVar t m a -> IO ()-sendWorkerDelay _sv =-    -- XXX we need a better way to handle this than hardcoded delays. The-    -- delays may be different for different systems.-    -- If there is a usecase where this is required we can create a combinator-    -- to set it as a config in the state.-    {--  do-    ncpu <- getNumCapabilities-    if ncpu <= 1-    then-        if (svarStyle sv == AheadVar)-        then threadDelay 100-        else threadDelay 25-    else-        if (svarStyle sv == AheadVar)-        then threadDelay 100-        else threadDelay 10-    -}-    return ()--{-# NOINLINE sendWorkerWait #-}-sendWorkerWait-    :: MonadAsync m-    => (SVar t m a -> IO ())-    -> (SVar t m a -> m Bool)-    -> SVar t m a-    -> m ()-sendWorkerWait delay dispatch sv = do-    -- Note that we are guaranteed to have at least one outstanding worker when-    -- we enter this function. So if we sleep we are guaranteed to be woken up-    -- by an outputDoorBell, when the worker exits.--    liftIO $ delay sv-    (_, n) <- liftIO $ readIORef (outputQueue sv)-    when (n <= 0) $ do-        -- The queue may be empty temporarily if the worker has dequeued the-        -- work item but has not enqueued the remaining part yet. For the same-        -- reason, a worker may come back if it tries to dequeue and finds the-        -- queue empty, even though the whole work has not finished yet.--        -- If we find that the queue is empty, but it may be empty-        -- temporarily, when we checked it. If that's the case we might-        -- sleep indefinitely unless the active workers produce some-        -- output. We may deadlock specially if the otuput from the active-        -- workers depends on the future workers that we may never send.-        -- So in case the queue was temporarily empty set a flag to inform-        -- the enqueue to send us a doorbell.--        -- Note that this is just a best effort mechanism to avoid a-        -- deadlock. Deadlocks may still happen if for some weird reason-        -- the consuming computation shares an MVar or some other resource-        -- with the producing computation and gets blocked on that resource-        -- and therefore cannot do any pushworker to add more threads to-        -- the producer. In such cases the programmer should use a parallel-        -- style so that all the producers are scheduled immediately and-        -- unconditionally. We can also use a separate monitor thread to-        -- push workers instead of pushing them from the consumer, but then-        -- we are no longer using pull based concurrency rate adaptation.-        ---        -- XXX update this in the tutorial.-        ---        -- Having pending active workers does not mean that we are guaranteed-        -- to be woken up if we sleep. In case of Ahead streams, there may be-        -- queued items in the heap even though the outputQueue is empty, and-        -- we may have active workers which are deadlocked on those items to be-        -- processed by the consumer. We should either guarantee that any-        -- worker, before returning, clears the heap or we send a worker to-        -- clear it. Normally we always send a worker if no output is seen, but-        -- if the thread limit is reached or we are using pacing then we may-        -- not send a worker. See the concurrentApplication test in the tests,-        -- that test case requires at least one yield from the producer to not-        -- deadlock, if the last workers output is stuck in the heap then this-        -- test fails.  This problem can be extended to n threads when the-        -- consumer may depend on the evaluation of next n items in the-        -- producer stream.--        -- register for the outputDoorBell before we check the queue so that if-        -- we sleep because the queue was empty we are guaranteed to get a-        -- doorbell on the next enqueue.--        liftIO $ atomicModifyIORefCAS_ (needDoorBell sv) $ const True-        liftIO storeLoadBarrier-        canDoMore <- dispatch sv--        -- XXX test for the case when we miss sending a worker when the worker-        -- count is more than 1500.-        ---        -- XXX Assert here that if the heap is not empty then there is at-        -- least one outstanding worker. Otherwise we could be sleeping-        -- forever.--        if canDoMore-        then sendWorkerWait delay dispatch sv-        else do-            liftIO $ withDiagMVar sv "sendWorkerWait: nothing to do"-                             $ takeMVar (outputDoorBell sv)-            (_, len) <- liftIO $ readIORef (outputQueue sv)-            when (len <= 0) $ sendWorkerWait delay dispatch sv------------------------------------------------------------------------------------ Reading from the workers' output queue/buffer----------------------------------------------------------------------------------{-# INLINE readOutputQRaw #-}-readOutputQRaw :: SVar t m a -> IO ([ChildEvent a], Int)-readOutputQRaw sv = do-    (list, len) <- atomicModifyIORefCAS (outputQueue sv) $ \x -> (([],0), x)-    when (svarInspectMode sv) $ do-        let ref = maxOutQSize $ svarStats sv-        oqLen <- readIORef ref-        when (len > oqLen) $ writeIORef ref len-    return (list, len)--readOutputQBounded :: MonadAsync m => SVar t m a -> m [ChildEvent a]-readOutputQBounded sv = do-    (list, len) <- liftIO $ readOutputQRaw sv-    -- When there is no output seen we dispatch more workers to help-    -- out if there is work pending in the work queue.-    if len <= 0-    then blockingRead-    else do-        -- send a worker proactively, if needed, even before we start-        -- processing the output.  This may degrade single processor-        -- perf but improves multi-processor, because of more-        -- parallelism-        sendOneWorker-        return list--    where--    sendOneWorker = do-        cnt <- liftIO $ readIORef $ workerCount sv-        when (cnt <= 0) $ do-            done <- liftIO $ isWorkDone sv-            when (not done) (pushWorker 0 sv)--    {-# INLINE blockingRead #-}-    blockingRead = do-        sendWorkerWait sendWorkerDelay (dispatchWorker 0) sv-        liftIO (fst `fmap` readOutputQRaw sv)--readOutputQPaced :: MonadAsync m => SVar t m a -> m [ChildEvent a]-readOutputQPaced sv = do-    (list, len) <- liftIO $ readOutputQRaw sv-    if len <= 0-    then blockingRead-    else do-        -- XXX send a worker proactively, if needed, even before we start-        -- processing the output.-        void $ dispatchWorkerPaced sv-        return list--    where--    {-# INLINE blockingRead #-}-    blockingRead = do-        sendWorkerWait sendWorkerDelayPaced dispatchWorkerPaced sv-        liftIO (fst `fmap` readOutputQRaw sv)--postProcessBounded :: MonadAsync m => SVar t m a -> m Bool-postProcessBounded sv = do-    workersDone <- allThreadsDone sv-    -- There may still be work pending even if there are no workers pending-    -- because all the workers may return if the outputQueue becomes full. In-    -- that case send off a worker to kickstart the work again.-    ---    -- Note that isWorkDone can only be safely checked if all workers are done.-    -- When some workers are in progress they may have decremented the yield-    -- Limit and later ending up incrementing it again. If we look at the yield-    -- limit in that window we may falsely say that it is 0 and therefore we-    -- are done.-    if workersDone-    then do-        r <- liftIO $ isWorkDone sv-        -- Note that we need to guarantee a worker, therefore we cannot just-        -- use dispatchWorker which may or may not send a worker.-        when (not r) (pushWorker 0 sv)-        -- XXX do we need to dispatch many here?-        -- void $ dispatchWorker sv-        return r-    else return False--postProcessPaced :: MonadAsync m => SVar t m a -> m Bool-postProcessPaced sv = do-    workersDone <- allThreadsDone sv-    -- XXX If during consumption we figure out we are getting delayed then we-    -- should trigger dispatch there as well.  We should try to check on the-    -- workers after consuming every n item from the buffer?-    if workersDone-    then do-        r <- liftIO $ isWorkDone sv-        when (not r) $ do-            void $ dispatchWorkerPaced sv-            -- Note that we need to guarantee a worker since the work is not-            -- finished, therefore we cannot just rely on dispatchWorkerPaced-            -- which may or may not send a worker.-            noWorker <- allThreadsDone sv-            when noWorker $ pushWorker 0 sv-        return r-    else return False------------------------------------------------------------------------------------ Creating an SVar----------------------------------------------------------------------------------getYieldRateInfo :: State t m a -> IO (Maybe YieldRateInfo)-getYieldRateInfo st = do-    -- convert rate in Hertz to latency in Nanoseconds-    let rateToLatency r = if r <= 0 then maxBound else round $ 1.0e9 / r-    case getStreamRate st of-        Just (Rate low goal high buf) ->-            let l    = rateToLatency goal-                minl = rateToLatency high-                maxl = rateToLatency low-            in mkYieldRateInfo l (LatencyRange minl maxl) buf-        Nothing -> return Nothing--    where--    mkYieldRateInfo latency latRange buf = do-        measured <- newIORef 0-        wcur     <- newIORef (0,0,0)-        wcol     <- newIORef (0,0,0)-        now      <- getTime Monotonic-        wlong    <- newIORef (0,now)-        period   <- newIORef 1-        gainLoss <- newIORef (Count 0)--        return $ Just YieldRateInfo-            { svarLatencyTarget      = latency-            , svarLatencyRange       = latRange-            , svarRateBuffer         = buf-            , svarGainedLostYields   = gainLoss-            , workerBootstrapLatency = getStreamLatency st-            , workerPollingInterval  = period-            , workerMeasuredLatency  = measured-            , workerPendingLatency   = wcur-            , workerCollectedLatency = wcol-            , svarAllTimeLatency     = wlong-            }--newSVarStats :: IO SVarStats-newSVarStats = do-    disp   <- newIORef 0-    maxWrk <- newIORef 0-    maxOq  <- newIORef 0-    maxHs  <- newIORef 0-    maxWq  <- newIORef 0-    avgLat <- newIORef (0, NanoSecond64 0)-    maxLat <- newIORef (NanoSecond64 0)-    minLat <- newIORef (NanoSecond64 0)-    stpTime <- newIORef Nothing--    return SVarStats-        { totalDispatches  = disp-        , maxWorkers       = maxWrk-        , maxOutQSize      = maxOq-        , maxHeapSize      = maxHs-        , maxWorkQSize     = maxWq-        , avgWorkerLatency = avgLat-        , minWorkerLatency = minLat-        , maxWorkerLatency = maxLat-        , svarStopTime     = stpTime-        }---- XXX remove polymorphism in t, inline f-getAheadSVar :: MonadAsync m-    => State t m a-    -> (   IORef ([t m a], Int)-        -> IORef (Heap (Entry Int (AheadHeapEntry t m a)), Maybe Int)-        -> State t m a-        -> SVar t m a-        -> Maybe WorkerInfo-        -> m ())-    -> RunInIO m-    -> IO (SVar t m a)-getAheadSVar st f mrun = do-    outQ    <- newIORef ([], 0)-    -- the second component of the tuple is "Nothing" when heap is being-    -- cleared, "Just n" when we are expecting sequence number n to arrive-    -- before we can start clearing the heap.-    outH    <- newIORef (H.empty, Just 0)-    outQMv  <- newEmptyMVar-    active  <- newIORef 0-    wfw     <- newIORef False-    running <- newIORef S.empty-    -- Sequence number is incremented whenever something is queued, therefore,-    -- first sequence number would be 0-    q <- newIORef ([], -1)-    stopMVar <- newMVar ()-    yl <- case getYieldLimit st of-            Nothing -> return Nothing-            Just x -> Just <$> newIORef x-    rateInfo <- getYieldRateInfo st--    stats <- newSVarStats-    tid <- myThreadId--    let getSVar sv readOutput postProc = SVar-            { outputQueue      = outQ-            , remainingWork  = yl-            , maxBufferLimit   = getMaxBuffer st-            , maxWorkerLimit   = getMaxThreads st-            , yieldRateInfo    = rateInfo-            , outputDoorBell   = outQMv-            , readOutputQ      = readOutput sv-            , postProcess      = postProc sv-            , workerThreads    = running-            , workLoop         = f q outH st{streamVar = Just sv} sv-            , enqueue          = enqueueAhead sv q-            , isWorkDone       = isWorkDoneAhead sv q outH-            , isQueueDone      = isQueueDoneAhead sv q-            , needDoorBell     = wfw-            , svarStyle        = AheadVar-            , svarMrun         = mrun-            , workerCount      = active-            , accountThread    = delThread sv-            , workerStopMVar   = stopMVar-            , svarRef          = Nothing-            , svarInspectMode  = getInspectMode st-            , svarCreator      = tid-            , aheadWorkQueue   = q-            , outputHeap       = outH-            , svarStats        = stats-            }--    let sv =-            case getStreamRate st of-                Nothing -> getSVar sv readOutputQBounded postProcessBounded-                Just _  -> getSVar sv readOutputQPaced postProcessPaced-     in return sv--    where--    {-# INLINE isQueueDoneAhead #-}-    isQueueDoneAhead sv q = do-        queueDone <- checkEmpty q-        yieldsDone <--                case remainingWork sv of-                    Just yref -> do-                        n <- readIORef yref-                        return (n <= 0)-                    Nothing -> return False-        -- XXX note that yieldsDone can only be authoritative only when there-        -- are no workers running. If there are active workers they can-        -- later increment the yield count and therefore change the result.-        return $ yieldsDone || queueDone--    {-# INLINE isWorkDoneAhead #-}-    isWorkDoneAhead sv q ref = do-        heapDone <- do-                (hp, _) <- readIORef ref-                return (H.size hp <= 0)-        queueDone <- isQueueDoneAhead sv q-        return $ heapDone && queueDone--    checkEmpty q = do-        (xs, _) <- readIORef q-        return $ null xs--getParallelSVar :: MonadIO m => State t m a -> RunInIO m -> IO (SVar t m a)-getParallelSVar st mrun = do-    outQ    <- newIORef ([], 0)-    outQMv  <- newEmptyMVar-    active  <- newIORef 0-    running <- newIORef S.empty-    yl <- case getYieldLimit st of-            Nothing -> return Nothing-            Just x -> Just <$> newIORef x-    rateInfo <- getYieldRateInfo st--    stats <- newSVarStats-    tid <- myThreadId--    let sv =-            SVar { outputQueue      = outQ-                 , remainingWork  = yl-                 , maxBufferLimit   = Unlimited-                 , maxWorkerLimit   = Unlimited-                 -- Used only for diagnostics-                 , yieldRateInfo    = rateInfo-                 , outputDoorBell   = outQMv-                 , readOutputQ      = readOutputQPar sv-                 , postProcess      = allThreadsDone sv-                 , workerThreads    = running-                 , workLoop         = undefined-                 , enqueue          = undefined-                 , isWorkDone       = undefined-                 , isQueueDone      = undefined-                 , needDoorBell     = undefined-                 , svarStyle        = ParallelVar-                 , svarMrun         = mrun-                 , workerCount      = active-                 , accountThread    = modifyThread sv-                 , workerStopMVar   = undefined-                 , svarRef          = Nothing-                 , svarInspectMode  = getInspectMode st-                 , svarCreator      = tid-                 , aheadWorkQueue   = undefined-                 , outputHeap       = undefined-                 , svarStats        = stats-                 }-     in return sv--    where--    readOutputQPar sv = liftIO $ do-        withDiagMVar sv "readOutputQPar: doorbell"-            $ takeMVar (outputDoorBell sv)-        case yieldRateInfo sv of-            Nothing -> return ()-            Just yinfo -> void $ collectLatency sv yinfo False-        fst `fmap` readOutputQRaw sv--sendFirstWorker :: MonadAsync m => SVar t m a -> t m a -> m (SVar t m a)-sendFirstWorker sv m = do-    -- Note: We must have all the work on the queue before sending the-    -- pushworker, otherwise the pushworker may exit before we even get a-    -- chance to push.-    liftIO $ enqueue sv m-    case yieldRateInfo sv of-        Nothing -> pushWorker 0 sv-        Just yinfo  ->-            if svarLatencyTarget yinfo == maxBound-            then liftIO $ threadDelay maxBound-            else pushWorker 1 sv-    return sv--{-# INLINABLE newAheadVar #-}-newAheadVar :: MonadAsync m-    => State t m a-    -> t m a-    -> (   IORef ([t m a], Int)-        -> IORef (Heap (Entry Int (AheadHeapEntry t m a)), Maybe Int)-        -> State t m a-        -> SVar t m a-        -> Maybe WorkerInfo-        -> m ())-    -> m (SVar t m a)-newAheadVar st m wloop = do-    mrun <- captureMonadState-    sv <- liftIO $ getAheadSVar st wloop mrun-    sendFirstWorker sv m--{-# INLINABLE newParallelVar #-}-newParallelVar :: MonadAsync m => State t m a -> m (SVar t m a)-newParallelVar st = do-    mrun <- captureMonadState-    liftIO $ getParallelSVar st mrun------------------------------------------------------------------------------------ Write a stream to an SVar------------------------------------------------------------------------------------ XXX this errors out for Parallel/Ahead SVars--- | Write a stream to an 'SVar' in a non-blocking manner. The stream can then--- be read back from the SVar using 'fromSVar'.-toStreamVar :: MonadAsync m => SVar t m a -> t m a -> m ()-toStreamVar sv m = do-    liftIO $ enqueue sv m-    done <- allThreadsDone sv-    -- XXX This is safe only when called from the consumer thread or when no-    -- consumer is present.  There may be a race if we are not running in the-    -- consumer thread.-    -- XXX do this only if the work queue is not empty. The work may have been-    -- carried out by existing workers.-    when done $-        case yieldRateInfo sv of-            Nothing -> pushWorker 0 sv-            Just _  -> pushWorker 1 sv
src/Streamly/Streams/Ahead.hs view
@@ -12,7 +12,7 @@ -- Copyright   : (c) 2017 Harendra Kumar -- -- License     : BSD3--- Maintainer  : harendra.kumar@gmail.com+-- Maintainer  : streamly@composewell.com -- Stability   : experimental -- Portability : GHC --@@ -39,14 +39,16 @@ 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.SVar+import Streamly.Internal.Data.SVar import Streamly.Streams.StreamK        (IsStream(..), Stream, mkStream, foldStream, foldStreamShared,         foldStreamSVar)@@ -588,14 +590,21 @@ -- AheadT ------------------------------------------------------------------------------ --- | Deep ahead composition or ahead composition with depth first traversal.--- The semigroup composition of 'AheadT' appends streams in a depth first--- manner just like 'SerialT' except that it can produce elements concurrently--- ahead of time. It is like 'AsyncT' except that 'AsyncT' produces the output--- as it arrives whereas 'AheadT' orders the output in the traversal order.+-- | 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. -- -- @--- main = ('toList' . 'aheadly' $ (fromFoldable [1,2]) \<> (fromFoldable [3,4])) >>= print+-- 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]@@ -604,16 +613,13 @@ -- Any exceptions generated by a constituent stream are propagated to the -- output stream. ----- Similarly, the monad instance of 'AheadT' may run each iteration--- concurrently ahead of time but presents the results in the same order as+-- 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'. -- -- @--- import "Streamly"--- import qualified "Streamly.Prelude" as S--- import Control.Concurrent------ main = 'runStream' . 'aheadly' $ do+-- main = S.drain . 'aheadly' $ do --     n <- return 3 \<\> return 2 \<\> return 1 --     S.yieldM $ do --          threadDelay (n * 1000000)@@ -625,12 +631,6 @@ -- ThreadId 38: Delay 3 -- @ ----- All iterations may run in the same thread if they do not block.------ Note that ahead composition with depth first traversal can be used to--- combine infinite number of streams as it explores only a bounded number of--- streams at a time.--- -- @since 0.3.0 newtype AheadT m a = AheadT {getAheadT :: Stream m a}     deriving (MonadTrans)@@ -677,23 +677,21 @@ -- Monad ------------------------------------------------------------------------------ -{-# INLINE bindAhead #-}-{-# SPECIALIZE bindAhead :: AheadT IO a -> (a -> AheadT IO b) -> AheadT IO b #-}-bindAhead :: MonadAsync m => AheadT m a -> (a -> AheadT m b) -> AheadT m b-bindAhead m f = fromStream $ K.bindWith ahead (K.adapt m) (\a -> K.adapt $ f a)+{-# 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-    (>>=) = bindAhead--{-# INLINE apAhead #-}-{-# SPECIALIZE apAhead :: AheadT IO (a -> b) -> AheadT IO a -> AheadT IO b #-}-apAhead :: MonadAsync m => AheadT m (a -> b) -> AheadT m a -> AheadT m b-apAhead mf m = ap (K.adapt mf) (K.adapt m)+    {-# INLINE (>>=) #-}+    (>>=) = flip concatMapAhead  instance (Monad m, MonadAsync m) => Applicative (AheadT m) where     pure = AheadT . K.yield-    (<*>) = apAhead+    {-# INLINE (<*>) #-}+    (<*>) = ap  ------------------------------------------------------------------------------ -- Other instances
src/Streamly/Streams/Async.hs view
@@ -14,7 +14,7 @@ -- Copyright   : (c) 2017 Harendra Kumar -- -- License     : BSD3--- Maintainer  : harendra.kumar@gmail.com+-- Maintainer  : streamly@composewell.com -- Stability   : experimental -- Portability : GHC --@@ -49,15 +49,17 @@ 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.Atomics (atomicModifyIORefCAS)+import Streamly.Internal.Data.Atomics (atomicModifyIORefCAS) import Streamly.Streams.SVar (fromSVar) import Streamly.Streams.Serial (map)-import Streamly.SVar+import Streamly.Internal.Data.SVar import Streamly.Streams.StreamK        (IsStream(..), Stream, mkStream, foldStream, adapt, foldStreamShared,         foldStreamSVar)@@ -294,7 +296,10 @@             { outputQueue      = outQ             , remainingWork    = yl             , maxBufferLimit   = getMaxBuffer st-            , maxWorkerLimit   = getMaxThreads st+            , pushBufferSpace  = undefined+            , pushBufferPolicy = undefined+            , pushBufferMVar   = undefined+            , maxWorkerLimit   = min (getMaxThreads st) (getMaxBuffer st)             , yieldRateInfo    = rateInfo             , outputDoorBell   = outQMv             , readOutputQ      = readOutput sv@@ -306,6 +311,8 @@             , isQueueDone      = workDone sv             , needDoorBell     = wfw             , svarStyle        = AsyncVar+            , svarStopStyle    = StopNone+            , svarStopBy       = undefined             , svarMrun         = mrun             , workerCount      = active             , accountThread    = delThread sv@@ -382,9 +389,12 @@             -> SVar Stream m a         getSVar sv readOutput postProc workDone wloop = SVar             { outputQueue      = outQ-            , remainingWork  = yl+            , remainingWork    = yl             , maxBufferLimit   = getMaxBuffer st-            , maxWorkerLimit   = getMaxThreads st+            , pushBufferSpace  = undefined+            , pushBufferPolicy = undefined+            , pushBufferMVar   = undefined+            , maxWorkerLimit   = min (getMaxThreads st) (getMaxBuffer st)             , yieldRateInfo    = rateInfo             , outputDoorBell   = outQMv             , readOutputQ      = readOutput sv@@ -396,6 +406,8 @@             , isQueueDone      = workDone sv             , needDoorBell     = wfw             , svarStyle        = WAsyncVar+            , svarStopStyle    = StopNone+            , svarStopBy       = undefined             , svarMrun         = mrun             , workerCount      = active             , accountThread    = delThread sv@@ -450,7 +462,7 @@ -- @since 0.2.0 {-# INLINABLE mkAsync #-} mkAsync :: (IsStream t, MonadAsync m) => t m a -> m (t m a)-mkAsync m = fmap fromSVar (newAsyncVar defState (toStream m))+mkAsync = mkAsync' defState  {-# INLINABLE mkAsync' #-} mkAsync' :: (IsStream t, MonadAsync m) => State Stream m a -> t m a -> m (t m a)@@ -588,14 +600,18 @@ -- AsyncT ------------------------------------------------------------------------------ --- | Deep async composition or async composition with depth first traversal. In--- a left to right 'Semigroup' composition it tries to yield elements from the--- left stream as long as it can, but it can run the right stream in parallel--- if it needs to, based on demand. The right stream can be run if the left--- stream blocks on IO or cannot produce elements fast enough for the consumer.+-- | 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. -- -- @--- main = ('toList' . 'asyncly' $ (fromFoldable [1,2]) \<> (fromFoldable [3,4])) >>= print+-- 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]@@ -614,11 +630,7 @@ -- consumer. -- -- @--- import "Streamly"--- import qualified "Streamly.Prelude" as S--- import Control.Concurrent------ main = 'runStream' . 'asyncly' $ do+-- main = 'drain' . 'asyncly' $ do --     n <- return 3 \<\> return 2 \<\> return 1 --     S.yieldM $ do --          threadDelay (n * 1000000)@@ -630,12 +642,6 @@ -- ThreadId 38: Delay 3 -- @ ----- All iterations may run in the same thread if they do not block.------ Note that async composition with depth first traversal can be used to--- combine infinite number of streams as it explores only a bounded number of--- streams at a time.--- -- @since 0.1.0 newtype AsyncT m a = AsyncT {getAsyncT :: Stream m a}     deriving (MonadTrans)@@ -684,11 +690,15 @@ -- 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@@ -727,13 +737,26 @@ wAsync :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a wAsync = joinStreamVarAsync WAsyncVar --- | Wide async composition or async composition with breadth first traversal.--- The Semigroup instance of 'WAsyncT' concurrently /traverses/ the composed--- streams using a depth first travesal or in a round robin fashion, yielding--- elements from both streams alternately.+-- | 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.+-- -- @--- main = ('toList' . 'wAsyncly' $ (fromFoldable [1,2]) \<> (fromFoldable [3,4])) >>= print+-- 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]@@ -750,11 +773,7 @@ -- concurrently using a round robin scheduling. -- -- @--- import "Streamly"--- import qualified "Streamly.Prelude" as S--- import Control.Concurrent------ main = 'runStream' . 'wAsyncly' $ do+-- main = 'drain' . 'wAsyncly' $ do --     n <- return 3 \<\> return 2 \<\> return 1 --     S.yieldM $ do --          threadDelay (n * 1000000)@@ -766,13 +785,6 @@ -- ThreadId 38: Delay 3 -- @ ----- Unlike 'AsyncT' all iterations are guaranteed to run fairly--- concurrently, unconditionally.------ Note that async composition with breadth first traversal can only combine a--- finite number of streams as it needs to retain state for each unfinished--- stream.--- -- @since 0.2.0 newtype WAsyncT m a = WAsyncT {getWAsyncT :: Stream m a}     deriving (MonadTrans)@@ -819,11 +831,15 @@ -- 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
src/Streamly/Streams/Combinators.hs view
@@ -7,7 +7,7 @@ -- Copyright   : (c) 2017 Harendra Kumar -- -- License     : BSD3--- Maintainer  : harendra.kumar@gmail.com+-- Maintainer  : streamly@composewell.com -- Stability   : experimental -- Portability : GHC --@@ -29,7 +29,7 @@ import Control.Monad.IO.Class (MonadIO(liftIO)) import Data.Int (Int64) -import Streamly.SVar+import Streamly.Internal.Data.SVar import Streamly.Streams.StreamK import Streamly.Streams.Serial (SerialT) @@ -42,7 +42,8 @@ -- | 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.+-- 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.
+ src/Streamly/Streams/Enumeration.hs view
@@ -0,0 +1,550 @@+{-# 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 view
@@ -9,7 +9,9 @@  #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)                            \@@ -54,6 +56,15 @@ -- 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;                                      \@@ -96,15 +107,17 @@     {-# INLINE fromString #-};                                                \     fromString = P.fromList };                                                \                                                                               \-instance NFData a => NFData (STREAM Identity a) where { rnf = rnf1 };         \-instance NFData1 (STREAM Identity) where {                                    \-    {-# INLINE liftRnf #-};                                                   \-    liftRnf r = runIdentity . P.foldl' (\_ x -> r x) () }+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 #-};                                                     \
src/Streamly/Streams/Parallel.hs view
@@ -12,7 +12,7 @@ -- Copyright   : (c) 2017 Harendra Kumar -- -- License     : BSD3--- Maintainer  : harendra.kumar@gmail.com+-- Maintainer  : streamly@composewell.com -- Stability   : experimental -- Portability : GHC --@@ -23,6 +23,9 @@     , Parallel     , parallely     , parallel+    , parallelFst+    , parallelMin+    , tapAsync      -- * Function application     , mkParallel@@ -33,6 +36,8 @@     ) 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)@@ -42,13 +47,18 @@ 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 Streamly.Streams.SVar (fromSVar)+import qualified Data.Set as Set++import Streamly.Streams.SVar (fromSVar, fromStreamVar) import Streamly.Streams.Serial (map)-import Streamly.SVar+import Streamly.Internal.Data.SVar import Streamly.Streams.StreamK (IsStream(..), Stream, mkStream, foldStream,                                  foldStreamShared, adapt) import qualified Streamly.Streams.StreamK as K@@ -63,47 +73,76 @@ runOne     :: MonadIO m     => State Stream m a -> Stream m a -> Maybe WorkerInfo -> m ()-runOne st m winfo = foldStreamShared st yieldk single stop 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-    mrun = runInIO $ svarMrun sv -    withLimitCheck action = do-        yieldLimitOk <- liftIO $ decrementYieldLimitPost sv+    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 action-        else liftIO $ cleanupSVarFromWorker sv+        then do+            liftIO $ decrementBufferLimit sv+            foldStreamShared st yieldk single stop m+        else do+            liftIO $ cleanupSVarFromWorker sv+            liftIO $ sendStop sv winfo -    stop = liftIO $ sendStop sv winfo-    sendit a = liftIO $ sendYield sv winfo (ChildYield a)-    single a = sendit a >> withLimitCheck stop+    sv = fromJust $ streamVar st -    -- XXX there is no flow control in parallel case. We should perhaps use a-    -- queue and queue it back on that and exit the thread when the outputQueue-    -- overflows. Parallel is dangerous because it can accumulate unbounded-    -- output in the buffer.-    yieldk a r = void (sendit a)-        >> withLimitCheck (void $ liftIO $ mrun $ runOne st r winfo)+    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) => t m a -> t m a -> t m a-forkSVarPar m r = mkStream $ \st yld sng stp -> do-    sv <- newParallelVar st+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 -> t m a -> t m a -> t m a-joinStreamVarPar style m1 m2 = mkStream $ \st yld sng stp ->+    => 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 -> do+        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 m1 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.@@ -118,15 +157,36 @@ -- @since 0.2.0 {-# INLINE parallel #-} parallel :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a-parallel = joinStreamVarPar ParallelVar+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 defState+    sv <- newParallelVar StopNone defState     pushWorkerPar sv (runOne defState{streamVar = Just sv} $ toStream m)     return $ fromSVar sv @@ -134,10 +194,10 @@ -- Stream to stream concurrent function application ------------------------------------------------------------------------------ -{-# INLINE applyWith #-}-applyWith :: (IsStream t, MonadAsync m) => (t m a -> t m b) -> t m a -> t m b-applyWith f m = mkStream $ \st yld sng stp -> do-    sv <- newParallelVar (adaptState st)+{-# 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 @@ -145,13 +205,93 @@ -- Stream runner concurrent function application ------------------------------------------------------------------------------ -{-# INLINE runWith #-}-runWith :: (IsStream t, MonadAsync m) => (t m a -> m b) -> t m a -> m b-runWith f m = do-    sv <- newParallelVar defState+{-# 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 ------------------------------------------------------------------------------@@ -169,7 +309,7 @@ -- -- -- @--- runStream $+-- drain $ --    S.mapM (\\x -> threadDelay 1000000 >> print x) --      |$ S.repeatM (threadDelay 1000000 >> return 1) -- @@@ -179,14 +319,14 @@ -- @since 0.3.0 {-# INLINE (|$) #-} (|$) :: (IsStream t, MonadAsync m) => (t m a -> t m b) -> t m a -> t m b-f |$ x = applyWith f x+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. -- -- @--- runStream $+-- drain $ --       S.repeatM (threadDelay 1000000 >> return 1) --    |& S.mapM (\\x -> threadDelay 1000000 >> print x) -- @@@ -214,7 +354,7 @@ -- @since 0.3.0 {-# INLINE (|$.) #-} (|$.) :: (IsStream t, MonadAsync m) => (t m a -> m b) -> t m a -> m b-f |$. x = runWith f x+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.@@ -235,49 +375,30 @@ -- ParallelT ------------------------------------------------------------------------------ --- | Async composition with simultaneous traversal of all streams.------ The Semigroup instance of 'ParallelT' concurrently /merges/ two streams,--- running both strictly concurrently and yielding elements from both streams--- as they arrive. When multiple streams are combined using 'ParallelT' each--- one is evaluated in its own thread and the results produced are presented in--- the combined stream on a first come first serve basis.+-- | Async composition with strict concurrent execution of all streams. ----- 'AsyncT' and 'WAsyncT' are /concurrent lookahead streams/ each with a--- specific type of consumption pattern (depth first or breadth first). Since--- they are lookahead, they may introduce certain default latency in starting--- more concurrent tasks for efficiency reasons or may put a default limitation--- on the resource consumption (e.g. number of concurrent threads for--- lookahead).  If we look at the implementation detail, they both can share a--- pool of worker threads to evaluate the streams in the desired pattern and at--- the desired rate. However, 'ParallelT' uses a separate runtime thread to--- evaluate each stream.+-- 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. ----- 'WAsyncT' is similar to 'ParallelT', as both of them evaluate the--- constituent streams fairly in a round robin fashion.--- However, the key difference is that 'WAsyncT' is lazy or pull driven--- whereas 'ParallelT' is strict or push driven.  'ParallelT' immediately--- starts concurrent evaluation of both the streams (in separate threads) and--- later picks the results whereas 'WAsyncT' may wait for a certain latency--- threshold before initiating concurrent evaluation of the next stream. The--- concurrent scheduling of the next stream or the degree of concurrency is--- driven by the feedback from the consumer. In case of 'ParallelT' each stream--- is evaluated in a separate thread and results are /pushed/ to a shared--- output buffer, the evaluation rate is controlled by blocking when the buffer--- is full.+-- 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. ----- Concurrent lookahead streams are generally more efficient than--- 'ParallelT' and can work pretty efficiently even for smaller tasks because--- they do not necessarily use a separate thread for each task. So they should--- be preferred over 'ParallelT' especially when efficiency is a concern and--- simultaneous strict evaluation is not a requirement.  'ParallelT' is useful--- for cases when the streams are required to be evaluated simultaneously--- irrespective of how the consumer consumes them e.g.  when we want to race--- two tasks and want to start both strictly at the same time or if we have--- timers in the parallel tasks and our results depend on the timers being--- started at the same time.  We can say that 'ParallelT' is almost the same--- (modulo some implementation differences) as 'WAsyncT' when the latter is--- used with unlimited lookahead and zero latency in initiating lookahead.+-- '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@@ -304,7 +425,7 @@ -- import qualified "Streamly.Prelude" as S -- import Control.Concurrent ----- main = 'runStream' . 'parallely' $ do+-- main = 'drain' . 'parallely' $ do --     n <- return 3 \<\> return 2 \<\> return 1 --     S.yieldM $ do --          threadDelay (n * 1000000)@@ -319,7 +440,9 @@ -- Note that parallel composition can only combine a finite number of -- streams as it needs to retain state for each unfinished stream. ----- @since 0.1.0+-- /Since: 0.7.0 (maxBuffer applies to ParallelT streams)/+--+-- /Since: 0.1.0/ newtype ParallelT m a = ParallelT {getParallelT :: Stream m a}     deriving (MonadTrans) @@ -379,8 +502,6 @@ instance MonadAsync m => Monad (ParallelT m) where     return = pure     (>>=) = bindParallel---- XXX Specialize the applicative instance  ------------------------------------------------------------------------------ -- Other instances
src/Streamly/Streams/Prelude.hs view
@@ -11,7 +11,7 @@ -- Copyright   : (c) 2017 Harendra Kumar -- -- License     : BSD3--- Maintainer  : harendra.kumar@gmail.com+-- Maintainer  : streamly@composewell.com -- Stability   : experimental -- Portability : GHC --@@ -23,7 +23,7 @@     , toStreamS      -- * Running Effects-    , runStream+    , drain      -- * Conversion operations     , fromList@@ -31,13 +31,31 @@      -- * 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@@ -45,9 +63,12 @@     ) 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@@ -75,11 +96,11 @@ -- Conversions ------------------------------------------------------------------------------ -{-# INLINE_EARLY runStream #-}-runStream :: (IsStream t, Monad m) => t m a -> m ()-runStream m = D.runStream $ D.fromStreamK (toStream m)-{-# RULES "runStream fallback to CPS" [1]-    forall a. D.runStream (D.fromStreamK a) = K.runStream a #-}+{-# 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@@ -112,13 +133,37 @@ ------------------------------------------------------------------------------  {-# INLINE foldrM #-}-foldrM :: (Monad m, IsStream t) => (a -> b -> m b) -> b -> t m a -> m b+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 = foldrM (\a b -> return (f a 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@@ -126,7 +171,66 @@ 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 ------------------------------------------------------------------------------ @@ -150,33 +254,73 @@ -- 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]@ ----- @since 0.1.0+-- 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 sum+-- on a 'Foldable' container and then fold it using the specified stream merge -- operation. -- -- @foldMapWith 'async' return [1..3]@ ----- @since 0.1.0+-- 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. ----- @since 0.1.0+-- 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
src/Streamly/Streams/SVar.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP                        #-} {-# LANGUAGE FlexibleContexts          #-}  -- |@@ -5,13 +6,14 @@ -- Copyright   : (c) 2017 Harendra Kumar -- -- License     : BSD3--- Maintainer  : harendra.kumar@gmail.com+-- Maintainer  : streamly@composewell.com -- Stability   : experimental -- Portability : GHC -- -- module Streamly.Streams.SVar     ( fromSVar+    , fromStreamVar     , toSVar     ) where@@ -22,13 +24,15 @@ 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.Time.Clock (Clock(Monotonic), getTime)+import Streamly.Internal.Data.Time.Clock (Clock(Monotonic), getTime) import System.Mem (performMajorGC) -import Streamly.SVar-import Streamly.Streams.StreamK+import Streamly.Internal.Data.SVar+import Streamly.Streams.StreamK hiding (reverse)  printSVar :: SVar t m a -> String -> IO () printSVar sv how = do@@ -68,12 +72,23 @@             ChildStop tid e -> do                 accountThread sv tid                 case e of-                    Nothing -> foldStream st yld sng stp rest+                    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
src/Streamly/Streams/Serial.hs view
@@ -13,7 +13,7 @@ -- Copyright   : (c) 2017 Harendra Kumar -- -- License     : BSD3--- Maintainer  : harendra.kumar@gmail.com+-- Maintainer  : streamly@composewell.com -- Stability   : experimental -- Portability : GHC --@@ -32,6 +32,8 @@     , InterleavedT      -- deprecated     , WSerial     , wSerial+    , wSerialFst+    , wSerialMin     , (<=>)            -- deprecated     , wSerially     , interleaving     -- deprecated@@ -43,7 +45,10 @@ where  import Control.Applicative (liftA2)-import Control.DeepSeq (NFData(..), NFData1(..), rnf1)+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)@@ -54,7 +59,9 @@ 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)@@ -73,16 +80,17 @@ -- SerialT ------------------------------------------------------------------------------ --- | Deep serial composition or serial composition with depth first traversal.--- The 'Semigroup' instance of 'SerialT' appends two streams serially in a--- depth first manner, yielding all elements from the first stream, and then--- all elements from the second stream.+-- | 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 = ('toList' . 'serially' $ (fromFoldable [1,2]) \<\> (fromFoldable [3,4])) >>= print+-- main = (S.toList . 'serially' $ (S.fromList [1,2]) \<\> (S.fromList [3,4])) >>= print -- @ -- @ -- [1,2,3,4]@@ -92,7 +100,7 @@ -- element of the stream, serially. -- -- @--- main = 'runStream' . 'serially' $ do+-- main = S.drain . 'serially' $ do --     x <- return 1 \<\> return 2 --     S.yieldM $ print x -- @@@ -104,7 +112,7 @@ -- 'SerialT' nests streams serially in a depth first manner. -- -- @--- main = 'runStream' . 'serially' $ do+-- main = S.drain . 'serially' $ do --     x <- return 1 \<\> return 2 --     y <- return 3 \<\> return 4 --     S.yieldM $ print (x, y)@@ -116,18 +124,18 @@ -- (2,4) -- @ ----- This behavior of 'SerialT' is exactly like a list transformer. We call the--- monadic code being run for each element of the stream a monadic+-- 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. ----- The 'serially' combinator can be omitted as the default stream type is--- 'SerialT'.--- Note that serial composition with depth first traversal can be used to--- combine an infinite number of streams as it explores only one stream at a--- time.+-- 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)@@ -166,8 +174,13 @@  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 ------------------------------------------------------------------------------@@ -196,6 +209,7 @@ MONAD_APPLICATIVE_INSTANCE(SerialT,) MONAD_COMMON_INSTANCES(SerialT,) LIST_INSTANCES(SerialT)+NFDATA1_INSTANCE(SerialT) FOLDABLE_INSTANCE(SerialT) TRAVERSABLE_INSTANCE(SerialT) @@ -203,16 +217,25 @@ -- WSerialT ------------------------------------------------------------------------------ --- | Wide serial composition or serial composition with a breadth first--- traversal. The 'Semigroup' instance of 'WSerialT' traverses--- the two streams in a breadth first manner. In other words, it interleaves--- two streams, yielding one element from each stream alternately.+-- | 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 = ('toList' . 'wSerially' $ (fromFoldable [1,2]) \<\> (fromFoldable [3,4])) >>= print+-- main = (S.toList . 'wSerially' $ (S.fromList [1,2]) \<\> (S.fromList [3,4])) >>= print -- @ -- @ -- [1,3,2,4]@@ -223,7 +246,7 @@ -- -- -- @--- main = 'runStream' . 'wSerially' $ do+-- main = S.drain . 'wSerially' $ do --     x <- return 1 \<\> return 2 --     y <- return 3 \<\> return 4 --     S.yieldM $ print (x, y)@@ -235,10 +258,6 @@ -- (2,4) -- @ ----- Note that a serial composition with breadth first traversal can only combine--- a finite number of streams as it needs to retain state for each unfinished--- stream.--- -- @since 0.2.0 newtype WSerialT m a = WSerialT {getWSerialT :: Stream m a}     deriving (MonadTrans)@@ -288,8 +307,17 @@ -- 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 #-}@@ -300,6 +328,35 @@         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 @@ -327,6 +384,7 @@  instance Monad m => Monad (WSerialT m) where     return = pure+    {-# INLINE (>>=) #-}     (>>=) = K.bindWith wSerial  ------------------------------------------------------------------------------@@ -336,5 +394,6 @@ 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 view
@@ -6,1459 +6,3945 @@ {-# LANGUAGE FlexibleInstances         #-} {-# LANGUAGE MultiParamTypeClasses     #-} {-# LANGUAGE PatternSynonyms           #-}-{-# LANGUAGE ViewPatterns              #-}-{-# LANGUAGE RankNTypes                #-}--#include "inline.hs"---- |--- Module      : Streamly.Streams.StreamD--- Copyright   : (c) 2018 Harendra Kumar--- Copyright   : (c) Roman Leshchinskiy 2008-2010------ License     : BSD3--- Maintainer  : harendra.kumar@gmail.com--- Stability   : experimental--- Portability : GHC------ Direct style re-implementation of CPS style stream in StreamK module.  The--- symbol or suffix 'D' in this module denotes the "Direct" style.  GHC is able--- to INLINE and fuse direct style better, providing better performance than--- CPS implementation.------ @--- import qualified Streamly.Streams.StreamD as D--- @---- Some of the functions in this file have been adapted from the vector--- library,  https://hackage.haskell.org/package/vector.--module Streamly.Streams.StreamD-    (-    -- * The stream type-      Step (..)-    , Stream (..)--    -- * Construction-    , nil-    , cons--    -- * Deconstruction-    , uncons--    -- * Generation-    -- ** Unfolds-    , unfoldr-    , unfoldrM--    -- ** Specialized Generation-    -- | Generate a monadic stream from a seed.-    , repeat-    , replicate-    , replicateM-    , fromIndices-    , fromIndicesM-    , generate-    , generateM--    -- ** Enumerations-    , enumerateFromStepIntegral-    , enumerateFromIntegral-    , enumerateFromThenIntegral-    , enumerateFromToIntegral-    , enumerateFromThenToIntegral--    , enumerateFromStepNum-    , numFrom-    , numFromThen-    , enumerateFromToFractional-    , enumerateFromThenToFractional--    -- ** Conversions-    -- | Transform an input structure into a stream.-    -- | Direct style stream does not support @fromFoldable@.-    , yield-    , yieldM-    , fromList-    , fromListM-    , fromStreamK-    , fromStreamD--    -- * Elimination-    -- ** General Folds-    , foldr-    , foldrM-    , foldr1-    , foldl'-    , foldlM'--    -- ** Specialized Folds-    , runStream-    , null-    , head-    , tail-    , last-    , elem-    , notElem-    , all-    , any-    , maximum-    , maximumBy-    , minimum-    , minimumBy-    , findIndices-    , lookup-    , findM-    , find-    , (!!)-    , concatMapM-    , concatMap--    -- ** Substreams-    , isPrefixOf-    , isSubsequenceOf-    , stripPrefix--    -- ** Map and Fold-    , mapM_--    -- ** Conversions-    -- | Transform a stream into another type.-    , toList-    , toStreamK-    , toStreamD--    -- * Transformation-    -- ** By folding (scans)-    , scanlM'-    , scanl'-    , scanlM-    , scanl-    , scanl1M'-    , scanl1'-    , scanl1M-    , scanl1--    , prescanl'-    , prescanlM'-    , postscanl-    , postscanlM-    , postscanl'-    , postscanlM'--    -- * Filtering-    , filter-    , filterM-    , uniq-    , take-    , takeWhile-    , takeWhileM-    , drop-    , dropWhile-    , dropWhileM--    -- * Mapping-    , map-    , mapM-    , sequence--    -- * Inserting-    , insertBy--    -- * Deleting-    , deleteBy--    -- ** Map and Filter-    , mapMaybe-    , mapMaybeM--    -- * Zipping-    , indexed-    , indexedR-    , zipWith-    , zipWithM--    -- * Comparisions-    , eqBy-    , cmpBy--    -- * Merging-    , mergeBy-    , mergeByM--    -- * Transformation comprehensions-    , the-    )-where--import Data.Maybe (fromJust, isJust)-import GHC.Types ( SPEC(..) )-import Prelude-       hiding (map, mapM, mapM_, repeat, foldr, last, take, filter,-               takeWhile, drop, dropWhile, all, any, maximum, minimum, elem,-               notElem, null, head, tail, zipWith, lookup, foldr1, sequence,-               (!!), scanl, scanl1, concatMap, replicate, enumFromTo)--import Streamly.SVar (MonadAsync, defState, adaptState)--import Streamly.Streams.StreamD.Type-import qualified Streamly.Streams.StreamK as K----------------------------------------------------------------------------------- Construction----------------------------------------------------------------------------------- | An empty 'Stream'.-{-# INLINE_NORMAL nil #-}-nil :: Monad m => Stream m a-nil = Stream (\_ _ -> return Stop) ()---- | Can fuse but has O(n^2) complexity.-{-# INLINE_NORMAL cons #-}-cons :: Monad m => a -> Stream m a -> Stream m a-cons x (Stream step state) = Stream step1 Nothing-    where-    {-# INLINE_LATE step1 #-}-    step1 _ Nothing   = return $ Yield x (Just state)-    step1 gst (Just st) = do-        r <- step gst st-        return $-          case r of-            Yield a s -> Yield a (Just s)-            Skip  s   -> Skip (Just s)-            Stop      -> Stop------------------------------------------------------------------------------------ Deconstruction------------------------------------------------------------------------------------ Does not fuse, has the same performance as the StreamK version.-{-# INLINE_NORMAL uncons #-}-uncons :: Monad m => Stream m a -> m (Maybe (a, Stream m a))-uncons (UnStream step state) = go state-  where-    go st = do-        r <- step defState st-        case r of-            Yield x s -> return $ Just (x, Stream step s)-            Skip  s   -> go s-            Stop      -> return Nothing----------------------------------------------------------------------------------- Generation by unfold---------------------------------------------------------------------------------{-# INLINE_NORMAL unfoldrM #-}-unfoldrM :: Monad m => (s -> m (Maybe (a, s))) -> s -> Stream m a-unfoldrM next state = Stream step state-  where-    {-# INLINE_LATE step #-}-    step _ st = do-        r <- next st-        return $ case r of-            Just (x, s) -> Yield x s-            Nothing     -> Stop--{-# INLINE_LATE unfoldr #-}-unfoldr :: Monad m => (s -> Maybe (a, s)) -> s -> Stream m a-unfoldr f = unfoldrM (return . f)----------------------------------------------------------------------------------- Specialized Generation---------------------------------------------------------------------------------repeat :: Monad m => a -> Stream m a-repeat x = Stream (\_ _ -> return $ Yield x ()) ()--{-# INLINE_NORMAL replicateM #-}-replicateM :: Monad m => Int -> m a -> Stream m a-replicateM n p = Stream step n-  where-    {-# INLINE_LATE step #-}-    step _ i | i <= 0    = return Stop-             | otherwise = do-                x <- p-                return $ Yield x (i - 1)--{-# INLINE_NORMAL replicate #-}-replicate :: Monad m => Int -> a -> Stream m a-replicate n x = replicateM n (return x)---- This would not work properly for floats, therefore we put an Integral--- constraint.--- | Can be used to enumerate unbounded integrals. This does not check for--- overflow or underflow for bounded integrals.-{-# INLINE_NORMAL enumerateFromStepIntegral #-}-enumerateFromStepIntegral :: (Integral a, Monad m) => a -> a -> Stream m a-enumerateFromStepIntegral from stride =-    from `seq` stride `seq` Stream step from-    where-        {-# INLINE_LATE step #-}-        step _ !x = return $ Yield x $! (x + stride)---- We are assuming that "to" is constrained by the type to be within--- max/min bounds.-{-# INLINE enumerateFromToIntegral #-}-enumerateFromToIntegral :: (Monad m, Integral a) => a -> a -> Stream m a-enumerateFromToIntegral from to =-    takeWhile (<= to) $ enumerateFromStepIntegral from 1--{-# INLINE enumerateFromIntegral #-}-enumerateFromIntegral :: (Monad m, Integral a, Bounded a) => a -> Stream m a-enumerateFromIntegral from = enumerateFromToIntegral from maxBound--data EnumState a = EnumInit | EnumYield a a a | EnumStop--{-# INLINE_NORMAL enumerateFromThenToIntegralUp #-}-enumerateFromThenToIntegralUp-    :: (Monad m, Integral a)-    => a -> a -> a -> Stream m a-enumerateFromThenToIntegralUp from next to = Stream step EnumInit-    where-    {-# INLINE_LATE step #-}-    step _ EnumInit =-        return $-            if to < next-            then if to < from-                 then Stop-                 else Yield from EnumStop-            else -- from <= next <= to-                let stride = next - from-                in Skip $ EnumYield from stride (to - stride)--    step _ (EnumYield x stride toMinus) =-        return $-            if x > toMinus-            then Yield x EnumStop-            else Yield x $ EnumYield (x + stride) stride toMinus--    step _ EnumStop = return Stop--{-# INLINE_NORMAL enumerateFromThenToIntegralDn #-}-enumerateFromThenToIntegralDn-    :: (Monad m, Integral a)-    => a -> a -> a -> Stream m a-enumerateFromThenToIntegralDn from next to = Stream step EnumInit-    where-    {-# INLINE_LATE step #-}-    step _ EnumInit =-        return $ if to > next-            then if to > from-                 then Stop-                 else Yield from EnumStop-            else -- from >= next >= to-                let stride = next - from-                in Skip $ EnumYield from stride (to - stride)--    step _ (EnumYield x stride toMinus) =-        return $-            if x < toMinus-            then Yield x EnumStop-            else Yield x $ EnumYield (x + stride) stride toMinus--    step _ EnumStop = return Stop--{-# INLINE_NORMAL enumerateFromThenToIntegral #-}-enumerateFromThenToIntegral-    :: (Monad m, Integral a)-    => a -> a -> a -> Stream m a-enumerateFromThenToIntegral from next to-    | next >= from = enumerateFromThenToIntegralUp from next to-    | otherwise    = enumerateFromThenToIntegralDn from next to--{-# INLINE_NORMAL enumerateFromThenIntegral #-}-enumerateFromThenIntegral-    :: (Monad m, Integral a, Bounded a)-    => a -> a -> Stream m a-enumerateFromThenIntegral from next =-    if next > from-    then enumerateFromThenToIntegralUp from next maxBound-    else enumerateFromThenToIntegralDn from next minBound---- For floating point numbers if the increment is less than the precision then--- it just gets lost. Therefore we cannot always increment it correctly by just--- repeated addition.--- 9007199254740992 + 1 + 1 :: Double => 9.007199254740992e15--- 9007199254740992 + 2     :: Double => 9.007199254740994e15---- Instead we accumulate the increment counter and compute the increment--- everytime before adding it to the starting number.------ This works for Integrals as well as floating point numbers, but--- enumerateFromStepIntegral is faster for integrals.-{-# INLINE_NORMAL enumerateFromStepNum #-}-enumerateFromStepNum :: (Monad m, Num a) => a -> a -> Stream m a-enumerateFromStepNum from stride = Stream step 0-    where-    {-# INLINE_LATE step #-}-    step _ !i = return $ (Yield $! (from + i * stride)) $! (i + 1)--{-# INLINE_NORMAL numFrom #-}-numFrom :: (Monad m, Num a) => a -> Stream m a-numFrom from = enumerateFromStepNum from 1--{-# INLINE_NORMAL numFromThen #-}-numFromThen :: (Monad m, Num a) => a -> a -> Stream m a-numFromThen from next = enumerateFromStepNum from (next - from)---- We cannot write a general function for Num.  The only way to write code--- portable between the two is to use a 'Real' constraint and convert between--- Fractional and Integral using fromRational which is horribly slow.-{-# INLINE_NORMAL enumerateFromToFractional #-}-enumerateFromToFractional-    :: (Monad m, Fractional a, Ord a)-    => a -> a -> Stream m a-enumerateFromToFractional from to =-    takeWhile (<= to + 1 / 2) $ enumerateFromStepNum from 1--{-# INLINE_NORMAL enumerateFromThenToFractional #-}-enumerateFromThenToFractional-    :: (Monad m, Fractional a, Ord a)-    => a -> a -> a -> Stream m a-enumerateFromThenToFractional from next to =-    takeWhile predicate $ numFromThen from next-    where-    mid = (next - from) / 2-    predicate | next >= from  = (<= to + mid)-              | otherwise     = (>= to + mid)------------------------------------------------------------------------------------ Generation by Conversion------------------------------------------------------------------------------------ | Create a singleton 'Stream' from a pure value.-{-# INLINE_NORMAL yield #-}-yield :: Monad m => a -> Stream m a-yield x = Stream (\_ s -> return $ step undefined s) True-  where-    {-# INLINE_LATE step #-}-    step _ True  = Yield x False-    step _ False = Stop---- | Create a singleton 'Stream' from a monadic action.-{-# INLINE_NORMAL yieldM #-}-yieldM :: Monad m => m a -> Stream m a-yieldM m = Stream step True-  where-    {-# INLINE_LATE step #-}-    step _ True  = m >>= \x -> return $ Yield x False-    step _ False = return Stop--{-# INLINE_NORMAL fromIndicesM #-}-fromIndicesM :: Monad m => (Int -> m a) -> Stream m a-fromIndicesM gen = Stream step 0-  where-    {-# INLINE_LATE step #-}-    step _ i = do-       x <- gen i-       return $ Yield x (i + 1)--{-# INLINE fromIndices #-}-fromIndices :: Monad m => (Int -> a) -> Stream m a-fromIndices gen = fromIndicesM (return . gen)--{-# INLINE_NORMAL generateM #-}-generateM :: Monad m => Int -> (Int -> m a) -> Stream m a-generateM n gen = n `seq` Stream step 0-  where-    {-# INLINE_LATE step #-}-    step _ i | i < n     = do-                           x <- gen i-                           return $ Yield x (i + 1)-             | otherwise = return Stop--{-# INLINE generate #-}-generate :: Monad m => Int -> (Int -> a) -> Stream m a-generate n gen = generateM n (return . gen)---- XXX we need the MonadAsync constraint because of a rewrite rule.--- | Convert a list of monadic actions to a 'Stream'-{-# INLINE_LATE fromListM #-}-fromListM :: MonadAsync m => [m a] -> Stream m a-fromListM = Stream step-  where-    {-# INLINE_LATE step #-}-    step _ (m:ms) = m >>= \x -> return $ Yield x ms-    step _ []     = return Stop---- | Convert a list of pure values to a 'Stream'-{-# INLINE_LATE fromList #-}-fromList :: Monad m => [a] -> Stream m a-fromList = Stream step-  where-    {-# INLINE_LATE step #-}-    step _ (x:xs) = return $ Yield x xs-    step _ []     = return Stop--{-# INLINE_LATE fromStreamK #-}-fromStreamK :: Monad m => K.Stream m a -> Stream m a-fromStreamK = Stream step-    where-    step gst m1 =-        let stop       = return Stop-            single a   = return $ Yield a K.nil-            yieldk a r = return $ Yield a r-         in K.foldStreamShared gst yieldk single stop m1--{-# INLINE toStreamD #-}-toStreamD :: (K.IsStream t, Monad m) => t m a -> Stream m a-toStreamD = fromStreamK . K.toStream----------------------------------------------------------------------------------- Elimination by Folds---------------------------------------------------------------------------------{-# INLINE_NORMAL foldrM #-}-foldrM :: Monad m => (a -> b -> m b) -> b -> Stream m a -> m b-foldrM f z (Stream step state) = go SPEC state-  where-    go !_ st = do-          r <- step defState st-          case r of-            Yield x s -> go SPEC s >>= f x-            Skip s    -> go SPEC s-            Stop      -> return z--{-# INLINE_NORMAL foldr #-}-foldr :: Monad m => (a -> b -> b) -> b -> Stream m a -> m b-foldr f = foldrM (\a b -> return (f a b))--{-# INLINE_NORMAL foldr1 #-}-foldr1 :: Monad m => (a -> a -> a) -> Stream m a -> m (Maybe a)-foldr1 f m = do-     r <- uncons m-     case r of-         Nothing   -> return Nothing-         Just (h, t) -> fmap Just (foldr f h t)--{-# INLINE_NORMAL foldlM' #-}-foldlM' :: Monad m => (b -> a -> m b) -> b -> Stream m a -> m b-foldlM' fstep begin (Stream step state) = go SPEC begin state-  where-    go !_ acc st = acc `seq` do-        r <- step defState st-        case r of-            Yield x s -> do-                acc' <- fstep acc x-                go SPEC acc' s-            Skip s -> go SPEC acc s-            Stop   -> return acc--{-# INLINE foldl' #-}-foldl' :: Monad m => (b -> a -> b) -> b -> Stream m a -> m b-foldl' fstep = foldlM' (\b a -> return (fstep b a))----------------------------------------------------------------------------------- Specialized Folds----------------------------------------------------------------------------------- | Run a streaming composition, discard the results.-{-# INLINE_LATE runStream #-}-runStream :: Monad m => Stream m a -> m ()-runStream (Stream step state) = go SPEC state-  where-    go !_ st = do-        r <- step defState st-        case r of-            Yield _ s -> go SPEC s-            Skip s    -> go SPEC s-            Stop      -> return ()--{-# INLINE_NORMAL null #-}-null :: Monad m => Stream m a -> m Bool-null (Stream step state) = go state-  where-    go st = do-        r <- step defState st-        case r of-            Yield _ _ -> return False-            Skip s    -> go s-            Stop      -> return True---- XXX SPEC?-{-# INLINE_NORMAL head #-}-head :: Monad m => Stream m a -> m (Maybe a)-head (Stream step state) = go state-  where-    go st = do-        r <- step defState st-        case r of-            Yield x _ -> return (Just x)-            Skip  s   -> go s-            Stop      -> return Nothing---- Does not fuse, has the same performance as the StreamK version.-{-# INLINE_NORMAL tail #-}-tail :: Monad m => Stream m a -> m (Maybe (Stream m a))-tail (UnStream step state) = go state-  where-    go st = do-        r <- step defState st-        case r of-            Yield _ s -> return (Just $ Stream step s)-            Skip  s   -> go s-            Stop      -> return Nothing---- XXX will it fuse? need custom impl?-{-# INLINE_NORMAL last #-}-last :: Monad m => Stream m a -> m (Maybe a)-last = foldl' (\_ y -> Just y) Nothing--{-# INLINE_NORMAL elem #-}-elem :: (Monad m, Eq a) => a -> Stream m a -> m Bool-elem e (Stream step state) = go state-  where-    go st = do-        r <- step defState st-        case r of-            Yield x s-              | x == e    -> return True-              | otherwise -> go s-            Skip s -> go s-            Stop   -> return False--{-# INLINE_NORMAL notElem #-}-notElem :: (Monad m, Eq a) => a -> Stream m a -> m Bool-notElem e s = fmap not (elem e s)--{-# INLINE_NORMAL all #-}-all :: Monad m => (a -> Bool) -> Stream m a -> m Bool-all p (Stream step state) = go state-  where-    go st = do-        r <- step defState st-        case r of-            Yield x s-              | p x       -> go s-              | otherwise -> return False-            Skip s -> go s-            Stop   -> return True--{-# INLINE_NORMAL any #-}-any :: Monad m => (a -> Bool) -> Stream m a -> m Bool-any p (Stream step state) = go state-  where-    go st = do-        r <- step defState st-        case r of-            Yield x s-              | p x       -> return True-              | otherwise -> go s-            Skip s -> go s-            Stop   -> return False--{-# INLINE_NORMAL maximum #-}-maximum :: (Monad m, Ord a) => Stream m a -> m (Maybe a)-maximum (Stream step state) = go Nothing state-  where-    go Nothing st = do-        r <- step defState st-        case r of-            Yield x s -> go (Just x) s-            Skip  s   -> go Nothing s-            Stop      -> return Nothing-    go (Just acc) st = do-        r <- step defState st-        case r of-            Yield x s-              | acc <= x  -> go (Just x) s-              | otherwise -> go (Just acc) s-            Skip s -> go (Just acc) s-            Stop   -> return (Just acc)--{-# INLINE_NORMAL maximumBy #-}-maximumBy :: Monad m => (a -> a -> Ordering) -> Stream m a -> m (Maybe a)-maximumBy cmp (Stream step state) = go Nothing state-  where-    go Nothing st = do-        r <- step defState st-        case r of-            Yield x s -> go (Just x) s-            Skip  s   -> go Nothing s-            Stop      -> return Nothing-    go (Just acc) st = do-        r <- step defState st-        case r of-            Yield x s -> case cmp acc x of-                GT -> go (Just acc) s-                _  -> go (Just x) s-            Skip s -> go (Just acc) s-            Stop   -> return (Just acc)--{-# INLINE_NORMAL minimum #-}-minimum :: (Monad m, Ord a) => Stream m a -> m (Maybe a)-minimum (Stream step state) = go Nothing state-  where-    go Nothing st = do-        r <- step defState st-        case r of-            Yield x s -> go (Just x) s-            Skip  s   -> go Nothing s-            Stop      -> return Nothing-    go (Just acc) st = do-        r <- step defState st-        case r of-            Yield x s-              | acc <= x  -> go (Just acc) s-              | otherwise -> go (Just x) s-            Skip s -> go (Just acc) s-            Stop   -> return (Just acc)--{-# INLINE_NORMAL minimumBy #-}-minimumBy :: Monad m => (a -> a -> Ordering) -> Stream m a -> m (Maybe a)-minimumBy cmp (Stream step state) = go Nothing state-  where-    go Nothing st = do-        r <- step defState st-        case r of-            Yield x s -> go (Just x) s-            Skip  s   -> go Nothing s-            Stop      -> return Nothing-    go (Just acc) st = do-        r <- step defState st-        case r of-            Yield x s -> case cmp acc x of-                GT -> go (Just x) s-                _  -> go (Just acc) s-            Skip s -> go (Just acc) s-            Stop   -> return (Just acc)--{-# INLINE_NORMAL (!!) #-}-(!!) :: (Monad m) => Stream m a -> Int -> m (Maybe a)-(Stream step state) !! i = go i state-  where-    go n st = do-        r <- step defState st-        case r of-            Yield x s | n < 0 -> return Nothing-                      | n == 0 -> return $ Just x-                      | otherwise -> go (n - 1) s-            Skip s -> go n s-            Stop   -> return Nothing--{-# INLINE_NORMAL lookup #-}-lookup :: (Monad m, Eq a) => a -> Stream m (a, b) -> m (Maybe b)-lookup e (Stream step state) = go state-  where-    go st = do-        r <- step defState st-        case r of-            Yield (a, b) s -> if e == a then return (Just b) else go s-            Skip s -> go s-            Stop -> return Nothing--{-# INLINE_NORMAL findM #-}-findM :: Monad m => (a -> m Bool) -> Stream m a -> m (Maybe a)-findM p (Stream step state) = go SPEC state-  where-    go !_ st = do-      r <- step defState st-      case r of-          Yield x s -> do-              b <- p x-              if b then return (Just x) else go SPEC s-          Skip s    -> go SPEC s-          Stop      -> return Nothing--{-# INLINE find #-}-find :: Monad m => (a -> Bool) -> Stream m a -> m (Maybe a)-find p = findM (return . p)--{-# INLINE_NORMAL findIndices #-}-findIndices :: Monad m => (a -> Bool) -> Stream m a -> Stream m Int-findIndices p (Stream step state) = Stream step' (state, 0)-  where-    {-# INLINE_LATE step' #-}-    step' gst (st, i) = do-      r <- step (adaptState gst) st-      return $ case r of-          Yield x s -> if p x then Yield i (s, i+1) else Skip (s, i+1)-          Skip s -> Skip (s, i+1)-          Stop   -> Stop--{-# INLINE_NORMAL concatMapM #-}-concatMapM :: Monad m => (a -> m (Stream m b)) -> Stream m a -> Stream m b-concatMapM f (Stream step state) = Stream step' (Left state)-  where-    {-# INLINE_LATE step' #-}-    step' gst (Left st) = do-        r <- step (adaptState gst) st-        case r of-            Yield a s -> do-                b_stream <- f a-                return $ Skip (Right (b_stream, s))-            Skip s -> return $ Skip (Left s)-            Stop -> return Stop--    -- XXX using the pattern synonym Stream causes a major performance issue-    -- here even if the synonym does not include a adaptState call. Need to-    -- find out why. Is that something to be fixed in GHC?-    step' _ (Right (UnStream inner_step inner_st, st)) = do-        r <- inner_step defState inner_st-        case r of-            Yield b inner_s ->-                return $ Yield b (Right (Stream inner_step inner_s, st))-            Skip inner_s ->-                return $ Skip (Right (Stream inner_step inner_s, st))-            Stop -> return $ Skip (Left st)--{-# INLINE concatMap #-}-concatMap :: Monad m => (a -> Stream m b) -> Stream m a -> Stream m b-concatMap f = concatMapM (return . f)----------------------------------------------------------------------------------- Substreams---------------------------------------------------------------------------------{-# INLINE_NORMAL isPrefixOf #-}-isPrefixOf :: (Eq a, Monad m) => Stream m a -> Stream m a -> m Bool-isPrefixOf (Stream stepa ta) (Stream stepb tb) = go (ta, tb, Nothing)-  where-    go (sa, sb, Nothing) = do-        r <- stepa defState sa-        case r of-            Yield x sa' -> go (sa', sb, Just x)-            Skip sa'    -> go (sa', sb, Nothing)-            Stop        -> return True--    go (sa, sb, Just x) = do-        r <- stepb defState sb-        case r of-            Yield y sb' ->-                if x == y-                    then go (sa, sb', Nothing)-                    else return False-            Skip sb' -> go (sa, sb', Just x)-            Stop     -> return False--{-# INLINE_NORMAL isSubsequenceOf #-}-isSubsequenceOf :: (Eq a, Monad m) => Stream m a -> Stream m a -> m Bool-isSubsequenceOf (Stream stepa ta) (Stream stepb tb) = go (ta, tb, Nothing)-  where-    go (sa, sb, Nothing) = do-        r <- stepa defState sa-        case r of-            Yield x sa' -> go (sa', sb, Just x)-            Skip sa'    -> go (sa', sb, Nothing)-            Stop        -> return True--    go (sa, sb, Just x) = do-        r <- stepb defState sb-        case r of-            Yield y sb' ->-                if x == y-                    then go (sa, sb', Nothing)-                    else go (sa, sb', Just x)-            Skip sb' -> go (sa, sb', Just x)-            Stop     -> return False--{-# INLINE_NORMAL stripPrefix #-}-stripPrefix-    :: (Eq a, Monad m)-    => Stream m a -> Stream m a -> m (Maybe (Stream m a))-stripPrefix (Stream stepa ta) (Stream stepb tb) = go (ta, tb, Nothing)-  where-    go (sa, sb, Nothing) = do-        r <- stepa defState sa-        case r of-            Yield x sa' -> go (sa', sb, Just x)-            Skip sa'    -> go (sa', sb, Nothing)-            Stop        -> return $ Just (Stream stepb sb)--    go (sa, sb, Just x) = do-        r <- stepb defState sb-        case r of-            Yield y sb' ->-                if x == y-                    then go (sa, sb', Nothing)-                    else return Nothing-            Skip sb' -> go (sa, sb', Just x)-            Stop     -> return Nothing----------------------------------------------------------------------------------- Map and Fold----------------------------------------------------------------------------------- | Execute a monadic action for each element of the 'Stream'-{-# INLINE_NORMAL mapM_ #-}-mapM_ :: Monad m => (a -> m b) -> Stream m a -> m ()-mapM_ m = runStream . mapM m----------------------------------------------------------------------------------- Converting folds---------------------------------------------------------------------------------{-# INLINE toList #-}-toList :: Monad m => Stream m a -> m [a]-toList = foldr (:) []---- Convert a direct stream to and from CPS encoded stream-{-# INLINE_LATE toStreamK #-}-toStreamK :: Monad m => Stream m a -> K.Stream m a-toStreamK (Stream step state) = go state-    where-    go st = K.mkStream $ \gst yld sng stp -> do-        r <- step gst st-        case r of-            Yield x s -> yld x (go s)-            Skip  s   -> K.foldStreamShared gst yld sng stp $ go s-            Stop      -> stp--#ifndef DISABLE_FUSION-{-# RULES "fromStreamK/toStreamK fusion"-    forall s. toStreamK (fromStreamK s) = s #-}-{-# RULES "toStreamK/fromStreamK fusion"-    forall s. fromStreamK (toStreamK s) = s #-}-#endif--{-# INLINE fromStreamD #-}-fromStreamD :: (K.IsStream t, Monad m) => Stream m a -> t m a-fromStreamD = K.fromStream . toStreamK----------------------------------------------------------------------------------- Transformation by Folding (Scans)----------------------------------------------------------------------------------- XXX Is a prescan useful, discarding the last step does not sound useful?  I--- am not sure about the utility of this function, so this is implemented but--- not exposed. We can expose it if someone provides good reasons why this is--- useful.------ XXX We have to execute the stream one step ahead to know that we are at the--- last step.  The vector implementation of prescan executes the last fold step--- but does not yield the result. This means we have executed the effect but--- discarded value. This does not sound right. In this implementation we are--- not executing the last fold step.-{-# INLINE_NORMAL prescanlM' #-}-prescanlM' :: Monad m => (b -> a -> m b) -> m b -> Stream m a -> Stream m b-prescanlM' f mz (Stream step state) = Stream step' (state, mz)-  where-    {-# INLINE_LATE step' #-}-    step' gst (st, prev) = do-        r <- step (adaptState gst) st-        case r of-            Yield x s -> do-                acc <- prev-                return $ Yield acc (s, f acc x)-            Skip s -> return $ Skip (s, prev)-            Stop   -> return Stop--{-# INLINE prescanl' #-}-prescanl' :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b-prescanl' f z = prescanlM' (\a b -> return (f a b)) (return z)---- XXX if we make the initial value of the accumulator monadic then should we--- execute it even if the stream is empty? In that case we would have generated--- the effect but discarded the value, but that is what a fold does when the--- stream is empty. Whatever we decide, need to reconcile this with prescan.--- If we execute the initial value here without even using it then it is ok to--- execute the last step there as well without using the value.--- Looking at the duality with right fold, in case of right fold we always--- perform the action when the construction terminates, so in case of left fold--- we should perform it only when the reduction starts.-{-# INLINE_NORMAL postscanlM' #-}-postscanlM' :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b-postscanlM' fstep begin (Stream step state) =-    begin `seq` Stream step' (state, begin)-  where-    {-# INLINE_LATE step' #-}-    step' gst (st, acc) = acc `seq` do-        r <- step (adaptState gst) st-        case r of-            Yield x s -> do-                y <- fstep acc x-                y `seq` return (Yield y (s, y))-            Skip s -> return $ Skip (s, acc)-            Stop   -> return Stop--{-# INLINE_NORMAL postscanl' #-}-postscanl' :: Monad m => (a -> b -> a) -> a -> Stream m b -> Stream m a-postscanl' f = postscanlM' (\a b -> return (f a b))--{-# INLINE_NORMAL postscanlM #-}-postscanlM :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b-postscanlM fstep begin (Stream step state) = Stream step' (state, begin)-  where-    {-# INLINE_LATE step' #-}-    step' gst (st, acc) = do-        r <- step (adaptState gst) st-        case r of-            Yield x s -> do-                y <- fstep acc x-                return (Yield y (s, y))-            Skip s -> return $ Skip (s, acc)-            Stop   -> return Stop--{-# INLINE_NORMAL postscanl #-}-postscanl :: Monad m => (a -> b -> a) -> a -> Stream m b -> Stream m a-postscanl f = postscanlM (\a b -> return (f a b))--{-# INLINE_NORMAL scanlM' #-}-scanlM' :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b-scanlM' fstep begin s = begin `seq` (begin `cons` postscanlM' fstep begin s)--{-# INLINE scanl' #-}-scanl' :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b-scanl' f = scanlM' (\a b -> return (f a b))--{-# INLINE_NORMAL scanlM #-}-scanlM :: Monad m => (b -> a -> m b) -> b -> Stream m a -> Stream m b-scanlM fstep begin s = begin `cons` postscanlM fstep begin s--{-# INLINE scanl #-}-scanl :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b-scanl f = scanlM (\a b -> return (f a b))--{-# INLINE_NORMAL scanl1M #-}-scanl1M :: Monad m => (a -> a -> m a) -> Stream m a -> Stream m a-scanl1M fstep (Stream step state) = Stream step' (state, Nothing)-  where-    {-# INLINE_LATE step' #-}-    step' gst (st, Nothing) = do-        r <- step gst st-        case r of-            Yield x s -> return $ Yield x (s, Just x)-            Skip s -> return $ Skip (s, Nothing)-            Stop   -> return Stop--    step' gst (st, Just acc) = do-        r <- step gst st-        case r of-            Yield y s -> do-                z <- fstep acc y-                return $ Yield z (s, Just z)-            Skip s -> return $ Skip (s, Just acc)-            Stop   -> return Stop--{-# INLINE scanl1 #-}-scanl1 :: Monad m => (a -> a -> a) -> Stream m a -> Stream m a-scanl1 f = scanl1M (\x y -> return (f x y))--{-# INLINE_NORMAL scanl1M' #-}-scanl1M' :: Monad m => (a -> a -> m a) -> Stream m a -> Stream m a-scanl1M' fstep (Stream step state) = Stream step' (state, Nothing)-  where-    {-# INLINE_LATE step' #-}-    step' gst (st, Nothing) = do-        r <- step gst st-        case r of-            Yield x s -> x `seq` return $ Yield x (s, Just x)-            Skip s -> return $ Skip (s, Nothing)-            Stop   -> return Stop--    step' gst (st, Just acc) = acc `seq` do-        r <- step gst st-        case r of-            Yield y s -> do-                z <- fstep acc y-                z `seq` return $ Yield z (s, Just z)-            Skip s -> return $ Skip (s, Just acc)-            Stop   -> return Stop--{-# INLINE scanl1' #-}-scanl1' :: Monad m => (a -> a -> a) -> Stream m a -> Stream m a-scanl1' f = scanl1M' (\x y -> return (f x y))------------------------------------------------------------------------------------ Filtering----------------------------------------------------------------------------------{-# INLINE_NORMAL take #-}-take :: Monad m => Int -> Stream m a -> Stream m a-take n (Stream step state) = n `seq` Stream step' (state, 0)-  where-    {-# INLINE_LATE step' #-}-    step' gst (st, i) | i < n = do-        r <- step gst st-        return $ case r of-            Yield x s -> Yield x (s, i + 1)-            Skip s    -> Skip (s, i)-            Stop      -> Stop-    step' _ (_, _) = return Stop--{-# INLINE_NORMAL takeWhileM #-}-takeWhileM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a-takeWhileM f (Stream step state) = Stream step' state-  where-    {-# INLINE_LATE step' #-}-    step' gst st = do-        r <- step gst st-        case r of-            Yield x s -> do-                b <- f x-                return $ if b then Yield x s else Stop-            Skip s -> return $ Skip s-            Stop   -> return Stop--{-# INLINE takeWhile #-}-takeWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a-takeWhile f = takeWhileM (return . f)--{-# INLINE_NORMAL drop #-}-drop :: Monad m => Int -> Stream m a -> Stream m a-drop n (Stream step state) = Stream step' (state, Just n)-  where-    {-# INLINE_LATE step' #-}-    step' gst (st, Just i)-      | i > 0 = do-          r <- step gst st-          return $-            case r of-              Yield _ s -> Skip (s, Just (i - 1))-              Skip s    -> Skip (s, Just i)-              Stop      -> Stop-      | otherwise = return $ Skip (st, Nothing)--    step' gst (st, Nothing) = do-      r <- step gst st-      return $-        case r of-          Yield x s -> Yield x (s, Nothing)-          Skip  s   -> Skip (s, Nothing)-          Stop      -> Stop--data DropWhileState s a-    = DropWhileDrop s-    | DropWhileYield a s-    | DropWhileNext s--{-# INLINE_NORMAL dropWhileM #-}-dropWhileM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a-dropWhileM f (Stream step state) = Stream step' (DropWhileDrop state)-  where-    {-# INLINE_LATE step' #-}-    step' gst (DropWhileDrop st) = do-        r <- step gst st-        case r of-            Yield x s -> do-                b <- f x-                if b-                then return $ Skip (DropWhileDrop s)-                else return $ Skip (DropWhileYield x s)-            Skip s -> return $ Skip (DropWhileDrop s)-            Stop -> return Stop--    step' gst (DropWhileNext st) =  do-        r <- step gst st-        case r of-            Yield x s -> return $ Skip (DropWhileYield x s)-            Skip s    -> return $ Skip (DropWhileNext s)-            Stop      -> return Stop--    step' _ (DropWhileYield x st) = return $ Yield x (DropWhileNext st)--{-# INLINE dropWhile #-}-dropWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a-dropWhile f = dropWhileM (return . f)--{-# INLINE_NORMAL filterM #-}-filterM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a-filterM f (Stream step state) = Stream step' state-  where-    {-# INLINE_LATE step' #-}-    step' gst st = do-        r <- step gst st-        case r of-            Yield x s -> do-                b <- f x-                return $ if b-                         then Yield x s-                         else Skip s-            Skip s -> return $ Skip s-            Stop   -> return Stop--{-# INLINE filter #-}-filter :: Monad m => (a -> Bool) -> Stream m a -> Stream m a-filter f = filterM (return . f)--{-# INLINE_NORMAL uniq #-}-uniq :: (Eq a, Monad m) => Stream m a -> Stream m a-uniq (Stream step state) = Stream step' (Nothing, state)-  where-    {-# INLINE_LATE step' #-}-    step' gst (Nothing, st) = do-        r <- step gst st-        case r of-            Yield x s -> return $ Yield x (Just x, s)-            Skip  s   -> return $ Skip  (Nothing, s)-            Stop      -> return Stop-    step' gst (Just x, st)  = do-         r <- step gst st-         case r of-             Yield y s | x == y   -> return $ Skip (Just x, s)-                       | otherwise -> return $ Yield x (Just y, s)-             Skip  s   -> return $ Skip (Just x, s)-             Stop      -> return Stop----------------------------------------------------------------------------------- Transformation by Mapping---------------------------------------------------------------------------------{-# INLINE_NORMAL sequence #-}-sequence :: Monad m => Stream m (m a) -> Stream m a-sequence (Stream step state) = Stream step' state-  where-    {-# INLINE_LATE step' #-}-    step' gst st = do-         r <- step (adaptState gst) st-         case r of-             Yield x s -> x >>= \a -> return (Yield a s)-             Skip s    -> return $ Skip s-             Stop      -> return Stop----------------------------------------------------------------------------------- Inserting---------------------------------------------------------------------------------{-# INLINE_NORMAL insertBy #-}-insertBy :: Monad m => (a -> a -> Ordering) -> a -> Stream m a -> Stream m a-insertBy cmp a (Stream step state) = Stream step' (state, False, Nothing)-  where-    {-# INLINE_LATE step' #-}-    step' gst (st, False, _) = do-        r <- step gst st-        case r of-            Yield x s -> case cmp a x of-                GT -> return $ Yield x (s, False, Nothing)-                _  -> return $ Yield a (s, True, Just x)-            Skip s -> return $ Skip (s, False, Nothing)-            Stop   -> return $ Yield a (st, True, Nothing)--    step' _ (_, True, Nothing) = return Stop--    step' gst (st, True, Just prev) = do-        r <- step gst st-        case r of-            Yield x s -> return $ Yield prev (s, True, Just x)-            Skip s    -> return $ Skip (s, True, Just prev)-            Stop      -> return $ Yield prev (st, True, Nothing)----------------------------------------------------------------------------------- Deleting---------------------------------------------------------------------------------{-# INLINE_NORMAL deleteBy #-}-deleteBy :: Monad m => (a -> a -> Bool) -> a -> Stream m a -> Stream m a-deleteBy eq x (Stream step state) = Stream step' (state, False)-  where-    {-# INLINE_LATE step' #-}-    step' gst (st, False) = do-        r <- step gst st-        case r of-            Yield y s -> return $-                if eq x y then Skip (s, True) else Yield y (s, False)-            Skip s -> return $ Skip (s, False)-            Stop   -> return Stop--    step' gst (st, True) = do-        r <- step gst st-        case r of-            Yield y s -> return $ Yield y (s, True)-            Skip s -> return $ Skip (s, True)-            Stop   -> return Stop----------------------------------------------------------------------------------- Transformation by Map and Filter----------------------------------------------------------------------------------- XXX Will this always fuse properly?-{-# INLINE_NORMAL mapMaybe #-}-mapMaybe :: Monad m => (a -> Maybe b) -> Stream m a -> Stream m b-mapMaybe f = fmap fromJust . filter isJust . map f--{-# INLINE_NORMAL mapMaybeM #-}-mapMaybeM :: Monad m => (a -> m (Maybe b)) -> Stream m a -> Stream m b-mapMaybeM f = fmap fromJust . filter isJust . mapM f----------------------------------------------------------------------------------- Zipping---------------------------------------------------------------------------------{-# INLINE_NORMAL indexed #-}-indexed :: Monad m => Stream m a -> Stream m (Int, a)-indexed (Stream step state) = Stream step' (state, 0)-  where-    {-# INLINE_LATE step' #-}-    step' gst (st, i) = i `seq` do-         r <- step (adaptState gst) st-         case r of-             Yield x s -> return $ Yield (i, x) (s, i+1)-             Skip    s -> return $ Skip (s, i)-             Stop      -> return Stop--{-# INLINE_NORMAL indexedR #-}-indexedR :: Monad m => Int -> Stream m a -> Stream m (Int, a)-indexedR m (Stream step state) = Stream step' (state, m)-  where-    {-# INLINE_LATE step' #-}-    step' gst (st, i) = i `seq` do-         r <- step (adaptState gst) st-         case r of-             Yield x s -> let i' = i - 1-                          in-                          return $ Yield (i', x) (s, i')-             Skip    s -> return $ Skip (s, i)-             Stop      -> return Stop--{-# INLINE_NORMAL zipWithM #-}-zipWithM :: Monad m-    => (a -> b -> m c) -> Stream m a -> Stream m b -> Stream m c-zipWithM f (Stream stepa ta) (Stream stepb tb) = Stream step (ta, tb, Nothing)-  where-    {-# INLINE_LATE step #-}-    step gst (sa, sb, Nothing) = do-        r <- stepa (adaptState gst) sa-        return $-          case r of-            Yield x sa' -> Skip (sa', sb, Just x)-            Skip sa'    -> Skip (sa', sb, Nothing)-            Stop        -> Stop--    step gst (sa, sb, Just x) = do-        r <- stepb (adaptState gst) sb-        case r of-            Yield y sb' -> do-                z <- f x y-                return $ Yield z (sa, sb', Nothing)-            Skip sb' -> return $ Skip (sa, sb', Just x)-            Stop     -> return Stop--{-# RULES "zipWithM xs xs"-    forall f xs. zipWithM f xs xs = mapM (\x -> f x x) xs #-}--{-# INLINE zipWith #-}-zipWith :: Monad m => (a -> b -> c) -> Stream m a -> Stream m b -> Stream m c-zipWith f = zipWithM (\a b -> return (f a b))----------------------------------------------------------------------------------- Comparisions---------------------------------------------------------------------------------{-# INLINE_NORMAL eqBy #-}-eqBy :: Monad m => (a -> b -> Bool) -> Stream m a -> Stream m b -> m Bool-eqBy eq (Stream step1 t1) (Stream step2 t2) = eq_loop0 SPEC t1 t2-  where-    eq_loop0 !_ s1 s2 = do-      r <- step1 defState s1-      case r of-        Yield x s1' -> eq_loop1 SPEC x s1' s2-        Skip    s1' -> eq_loop0 SPEC   s1' s2-        Stop        -> eq_null s2--    eq_loop1 !_ x s1 s2 = do-      r <- step2 defState s2-      case r of-        Yield y s2'-          | eq x y    -> eq_loop0 SPEC   s1 s2'-          | otherwise -> return False-        Skip    s2'   -> eq_loop1 SPEC x s1 s2'-        Stop          -> return False--    eq_null s2 = do-      r <- step2 defState s2-      case r of-        Yield _ _ -> return False-        Skip s2'  -> eq_null s2'-        Stop      -> return True---- | Compare two streams lexicographically-{-# INLINE_NORMAL cmpBy #-}-cmpBy-    :: Monad m-    => (a -> b -> Ordering) -> Stream m a -> Stream m b -> m Ordering-cmpBy cmp (Stream step1 t1) (Stream step2 t2) = cmp_loop0 SPEC t1 t2-  where-    cmp_loop0 !_ s1 s2 = do-      r <- step1 defState s1-      case r of-        Yield x s1' -> cmp_loop1 SPEC x s1' s2-        Skip    s1' -> cmp_loop0 SPEC   s1' s2-        Stop        -> cmp_null s2--    cmp_loop1 !_ x s1 s2 = do-      r <- step2 defState s2-      case r of-        Yield y s2' -> case x `cmp` y of-                         EQ -> cmp_loop0 SPEC s1 s2'-                         c  -> return c-        Skip    s2' -> cmp_loop1 SPEC x s1 s2'-        Stop        -> return GT--    cmp_null s2 = do-      r <- step2 defState s2-      case r of-        Yield _ _ -> return LT-        Skip s2'  -> cmp_null s2'-        Stop      -> return EQ----------------------------------------------------------------------------------- Merging---------------------------------------------------------------------------------{-# INLINE_NORMAL mergeByM #-}-mergeByM-    :: (Monad m)-    => (a -> a -> m Ordering) -> Stream m a -> Stream m a -> Stream m a-mergeByM cmp (Stream stepa ta) (Stream stepb tb) =-    Stream step (Just ta, Just tb, Nothing, Nothing)-  where-    {-# INLINE_LATE step #-}--    -- one of the values is missing, and the corresponding stream is running-    step gst (Just sa, sb, Nothing, b) = do-        r <- stepa gst sa-        return $ case r of-            Yield a sa' -> Skip (Just sa', sb, Just a, b)-            Skip sa'    -> Skip (Just sa', sb, Nothing, b)-            Stop        -> Skip (Nothing, sb, Nothing, b)--    step gst (sa, Just sb, a, Nothing) = do-        r <- stepb gst sb-        return $ case r of-            Yield b sb' -> Skip (sa, Just sb', a, Just b)-            Skip sb'    -> Skip (sa, Just sb', a, Nothing)-            Stop        -> Skip (sa, Nothing, a, Nothing)--    -- both the values are available-    step _ (sa, sb, Just a, Just b) = do-        res <- cmp a b-        return $ case res of-            GT -> Yield b (sa, sb, Just a, Nothing)-            _  -> Yield a (sa, sb, Nothing, Just b)--    -- one of the values is missing, corresponding stream is done-    step _ (Nothing, sb, Nothing, Just b) =-            return $ Yield b (Nothing, sb, Nothing, Nothing)--    step _ (sa, Nothing, Just a, Nothing) =-            return $ Yield a (sa, Nothing, Nothing, Nothing)--    step _ (Nothing, Nothing, Nothing, Nothing) = return Stop--{-# INLINE mergeBy #-}-mergeBy-    :: (Monad m)-    => (a -> a -> Ordering) -> Stream m a -> Stream m a -> Stream m a-mergeBy cmp = mergeByM (\a b -> return $ cmp a b)----------------------------------------------------------------------------------- Transformation comprehensions---------------------------------------------------------------------------------{-# INLINE_NORMAL the #-}-the :: (Eq a, Monad m) => Stream m a -> m (Maybe a)-the (Stream step state) = go state-  where-    go st = do-        r <- step defState st-        case r of-            Yield x s -> go' x s-            Skip s    -> go s-            Stop      -> return Nothing-    go' n st = do-        r <- step defState st-        case r of-            Yield x s | x == n -> go' n s-                      | otherwise -> return Nothing-            Skip s -> go' n s-            Stop   -> return (Just n)+{-# 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/StreamD/Type.hs 
@@ -1,100 +0,0 @@-{-# LANGUAGE BangPatterns              #-}-{-# LANGUAGE CPP                       #-}-{-# LANGUAGE ConstraintKinds           #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE FlexibleInstances         #-}-{-# LANGUAGE MultiParamTypeClasses     #-}-{-# LANGUAGE PatternSynonyms           #-}-{-# LANGUAGE ViewPatterns              #-}-{-# LANGUAGE RankNTypes                #-}--#include "../inline.hs"---- |--- Module      : Streamly.Streams.StreamD.Type--- Copyright   : (c) 2018 Harendra Kumar------ License     : BSD3--- Maintainer  : harendra.kumar@gmail.com--- Stability   : experimental--- Portability : GHC--module Streamly.Streams.StreamD.Type-    (-    -- * The stream type-      Step (..)-    -- XXX UnStream is exported to avoid a performance issue in concatMap if we-    -- use the pattern synonym "Stream".-#if __GLASGOW_HASKELL__ >= 800-    , Stream (Stream, UnStream)-#else-    , Stream (UnStream)-    , pattern Stream-#endif-    , map-    , mapM-    )-where--import Streamly.SVar (State(..), adaptState)-import qualified Streamly.Streams.StreamK as K-import Prelude hiding (map, mapM)----------------------------------------------------------------------------------- The direct style stream type----------------------------------------------------------------------------------- | A stream is a succession of 'Step's. A 'Yield' produces a single value and--- the next state of the stream. 'Stop' indicates there are no more values in--- the stream.-data Step s a = Yield a s | Skip s | Stop--instance Functor (Step s) where-    {-# INLINE fmap #-}-    fmap f (Yield x s) = Yield (f x) s-    fmap _ (Skip s) = Skip s-    fmap _ Stop = Stop---- gst = global state--- | A stream consists of a step function that generates the next step given a--- current state, and the current state.-data Stream m a =-    forall s. UnStream (State K.Stream m a -> s -> m (Step s a)) s--unShare :: Stream m a -> Stream m a-unShare (UnStream step state) = UnStream step' state-    where step' gst = step (adaptState gst)--pattern Stream :: (State K.Stream m a -> s -> m (Step s a)) -> s -> Stream m a-pattern Stream step state <- (unShare -> UnStream step state)-    where Stream = UnStream--#if __GLASGOW_HASKELL__ >= 802-{-# COMPLETE Stream #-}-#endif----------------------------------------------------------------------------------- Instances----------------------------------------------------------------------------------- | Map a monadic function over a 'Stream'-{-# INLINE_NORMAL mapM #-}-mapM :: Monad m => (a -> m b) -> Stream m a -> Stream m b-mapM f (Stream step state) = Stream step' state-  where-    {-# INLINE_LATE step' #-}-    step' gst st = do-        r <- step (adaptState gst) st-        case r of-            Yield x s -> f x >>= \a -> return $ Yield a s-            Skip s    -> return $ Skip s-            Stop      -> return Stop--{-# INLINE map #-}-map :: Monad m => (a -> b) -> Stream m a -> Stream m b-map f = mapM (return . f)--instance Monad m => Functor (Stream m) where-    {-# INLINE fmap #-}-    fmap = map
+ src/Streamly/Streams/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.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 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.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 view
@@ -16,7 +16,7 @@ -- Copyright   : (c) 2017 Harendra Kumar -- -- License     : BSD3--- Maintainer  : harendra.kumar@gmail.com+-- Maintainer  : streamly@composewell.com -- Stability   : experimental -- Portability : GHC --@@ -40,6 +40,7 @@     -- * Construction Primitives     , mkStream     , nil+    , nilM     , cons     , (.:) @@ -61,8 +62,11 @@      -- ** Specialized Generation     , repeat+    , repeatM     , replicate     , replicateM+    , fromIndices+    , fromIndicesM      -- ** Conversions     , yield@@ -71,18 +75,30 @@     , fromList     , fromStreamK +    -- * foldr/build+    , foldrS+    , foldrSM+    , buildS+    , buildM+    , augmentS+    , augmentSM+     -- * Elimination     -- ** General Folds     , foldr-    , foldrM     , foldr1+    , foldrM+    , foldrT+     , foldl'     , foldlM'-    , foldx-    , foldxM+    , foldlS+    , foldlT+    , foldlx'+    , foldlMx'      -- ** Specialized Folds-    , runStream+    , drain     , null     , head     , tail@@ -108,11 +124,12 @@     -- ** Conversions     , toList     , toStreamK+    , hoist      -- * Transformation     -- ** By folding (scans)     , scanl'-    , scanx+    , scanlx'      -- ** Filtering     , filter@@ -124,15 +141,20 @@     -- ** Mapping     , map     , mapM+    , mapMSerial     , sequence      -- ** Inserting     , intersperseM+    , intersperse     , insertBy      -- ** Deleting     , deleteBy +    -- ** Reordering+    , reverse+     -- ** Map and Filter     , mapMaybe @@ -144,6 +166,11 @@     , mergeBy     , mergeByM +    -- ** Nesting+    , concatMapBy+    , concatMap+    , bindWith+     -- ** Transformation comprehensions     , the @@ -152,7 +179,6 @@      -- * Utilities     , consMStream-    , bindWith     , withLocal      -- * Deprecated@@ -161,60 +187,19 @@     ) where -import Control.Monad (void)+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)+               foldr1, (!!), replicate, reverse, concatMap) import qualified Prelude -import Streamly.SVar+import Streamly.Internal.Data.SVar import Streamly.Streams.StreamK.Type --- | Detach a stream from an SVar-{-# INLINE unShare #-}-unShare :: IsStream t => t m a -> t m a-unShare x = mkStream $ \st yld sng stp ->-    foldStream st yld sng stp x----------------------------------------------------------------------------------- Construction---------------------------------------------------------------------------------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 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- ------------------------------------------------------------------------------- -- Deconstruction -------------------------------------------------------------------------------@@ -231,50 +216,46 @@ -- Generation ------------------------------------------------------------------------------- -{-# INLINE_NORMAL build #-}-build :: IsStream t => forall a. (forall b. (a -> b -> b) -> b -> b) -> t m a-build g = g cons nil--{-# INLINE_NORMAL _augment #-}-_augment-    :: IsStream t-    => forall a. (forall b. (a -> b -> b) -> b -> b) -> t m a -> t m a-_augment g xs = g cons xs--{-# INLINE_NORMAL _buildM #-}-_buildM-    :: (IsStream t, MonadAsync m)-    => forall a. ((m a -> t m a -> t m a) -> t m a -> t m a) -> t m a-_buildM g = g consM nil- {-# INLINE unfoldr #-} unfoldr :: IsStream t => (b -> Maybe (a, b)) -> b -> t m a-unfoldr step b0 = build $ \cns nl ->+unfoldr next s0 = build $ \yld stp ->     let go s =-            case step s of-                Just (a, b) -> a `cns` go b-                Nothing -> nl-    in go b0+            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 = mkStream $ \st yld sng stp -> do-        mayb <- step s-        case mayb of-            Nothing -> stp-            Just (a, b) ->-                foldStreamShared st yld sng stp $ return a |: go b+    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 ------------------------------------------------------------------------------- -{-# INLINE yield #-}-yield :: IsStream t => a -> t m a-yield a = mkStream $ \_ _ single _ -> single a- -- | Same as yieldM -- -- @since 0.2.0@@ -289,9 +270,16 @@ -- 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. ----- @since 0.4.0+-- /Internal/ {-# INLINE repeat #-} repeat :: IsStream t => a -> t m a repeat a = let x = cons a x in x@@ -308,6 +296,19 @@     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 -------------------------------------------------------------------------------@@ -339,24 +340,19 @@ -- | Lazy right associative fold. {-# INLINE foldr #-} foldr :: (IsStream t, Monad m) => (a -> b -> b) -> b -> t m a -> m b-foldr step acc m = go m-    where-    go m1 =-        let stop = return acc-            single a = return (step a acc)-            yieldk a r = go r >>= \b -> return (step a b)-        in foldStream defState yieldk single stop m1+foldr step acc = foldrM (\x xs -> xs >>= \b -> return (step x b)) (return acc) --- | Lazy right fold with a monadic step function.-{-# INLINE foldrM #-}-foldrM :: (IsStream t, Monad m) => (a -> b -> m b) -> b -> t m a -> m b-foldrM step acc m = go m-    where-    go m1 =-        let stop = return acc-            single a = step a acc-            yieldk a r = go r >>= step a-        in foldStream defState yieldk single stop m1+-- | 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)@@ -378,10 +374,10 @@ -- @foldl@ library. The suffix @x@ is a mnemonic for extraction. -- -- Note that the accumulator is always evaluated including the initial value.-{-# INLINE foldx #-}-foldx :: forall t m a b x. (IsStream t, Monad m)+{-# INLINE foldlx' #-}+foldlx' :: forall t m a b x. (IsStream t, Monad m)     => (x -> a -> x) -> x -> (x -> b) -> t m a -> m b-foldx step begin done m = get $ go m begin+foldlx' step begin done m = get $ go m begin     where     {-# NOINLINE get #-}     get :: t m x -> m b@@ -408,14 +404,14 @@ -- | Strict left associative fold. {-# INLINE foldl' #-} foldl' :: (IsStream t, Monad m) => (b -> a -> b) -> b -> t m a -> m b-foldl' step begin = foldx step begin id+foldl' step begin = foldlx' step begin id  -- XXX replace the recursive "go" with explicit continuations. -- | Like 'foldx', but with a monadic step function.-{-# INLINABLE foldxM #-}-foldxM :: (IsStream t, Monad m)+{-# INLINABLE foldlMx' #-}+foldlMx' :: (IsStream t, Monad m)     => (x -> a -> m x) -> m x -> (x -> m b) -> t m a -> m b-foldxM step begin done m = go begin m+foldlMx' step begin done m = go begin m     where     go !acc m1 =         let stop = acc >>= done@@ -426,27 +422,61 @@ -- | Like 'foldl'' but with a monadic step function. {-# INLINE foldlM' #-} foldlM' :: (IsStream t, Monad m) => (b -> a -> m b) -> b -> t m a -> m b-foldlM' step begin = foldxM step (return begin) return+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 ())+ -- |--- > runStream = foldl' (\_ _ -> ()) ()--- > runStream = mapM_ (\_ -> return ())-{-# INLINE runStream #-}-runStream :: (Monad m, IsStream t) => t m a -> m ()-runStream = go+-- > 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@@ -455,6 +485,7 @@  {-# 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)@@ -528,7 +559,7 @@ -- | Extract the last element of the stream, if any. {-# INLINE last #-} last :: (IsStream t, Monad m) => t m a -> m (Maybe a)-last = foldx (\_ y -> Just y) Nothing id+last = foldlx' (\_ y -> Just y) Nothing id  {-# INLINE minimum #-} minimum :: (IsStream t, Monad m, Ord a) => t m a -> m (Maybe a)@@ -696,13 +727,25 @@ 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 scanx #-}-scanx :: IsStream t => (x -> a -> x) -> x -> (x -> b) -> t m a -> t m b-scanx step begin done m =+{-# 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 ->@@ -714,7 +757,7 @@  {-# INLINE scanl' #-} scanl' :: IsStream t => (b -> a -> b) -> b -> t m a -> t m b-scanl' step begin = scanx step begin id+scanl' step begin = scanlx' step begin id  ------------------------------------------------------------------------------- -- Filtering@@ -781,17 +824,6 @@  -- Be careful when modifying this, this uses a consM (|:) deliberately to allow -- other stream types to overload it.-{-# INLINE mapM #-}-mapM :: (IsStream t, MonadAsync m) => (a -> m b) -> t m a -> t m b-mapM f m = go 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---- 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@@ -817,6 +849,10 @@             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@@ -846,6 +882,14 @@               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 -------------------------------------------------------------------------------@@ -953,26 +997,6 @@             yieldk a r | h == a    = go h r                        | otherwise = return Nothing          in foldStream defState yieldk single (return $ Just h) m1------------------------------------------------------------------------------------ Bind utility----------------------------------------------------------------------------------{-# 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  ------------------------------------------------------------------------------ -- Alternative & MonadPlus
src/Streamly/Streams/StreamK/Type.hs view
@@ -6,7 +6,11 @@ {-# LANGUAGE InstanceSigs              #-} {-# LANGUAGE MultiParamTypeClasses     #-} {-# LANGUAGE PatternSynonyms           #-}+{-# LANGUAGE KindSignatures            #-} {-# LANGUAGE ViewPatterns              #-}+#if __GLASGOW_HASKELL__ >= 806+{-# LANGUAGE QuantifiedConstraints     #-}+#endif {-# LANGUAGE RankNTypes                #-} {-# LANGUAGE UndecidableInstances      #-} -- XXX @@ -17,7 +21,7 @@ -- Copyright   : (c) 2017 Harendra Kumar -- -- License     : BSD3--- Maintainer  : harendra.kumar@gmail.com+-- Maintainer  : streamly@composewell.com -- Stability   : experimental -- Portability : GHC --@@ -45,25 +49,54 @@     , 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-    , yieldM+    , mapM+    , mapMSerial+    , unShare+    , concatMapBy+    , concatMap+    , bindWith      , Streaming   -- deprecated     ) where -import Control.Monad (void)+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(..))-import Prelude hiding (map)+#endif+import Prelude hiding (map, mapM, concatMap, foldr) -import Streamly.SVar+import Streamly.Internal.Data.SVar  ------------------------------------------------------------------------------ -- Basic stream type@@ -112,7 +145,15 @@ -- some monad 'm'. -- -- @since 0.2.0-class IsStream t where+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@@ -141,8 +182,8 @@     --     -- @     -- let delay = threadDelay 1000000 >> print 1-    -- runStream $ serially  $ delay |: delay |: delay |: nil-    -- runStream $ parallely $ delay |: delay |: delay |: nil+    -- drain $ serially  $ delay |: delay |: delay |: nil+    -- drain $ parallely $ delay |: delay |: delay |: nil     -- @     --     -- /Concurrent (do not use 'parallely' to construct infinite streams)/@@ -248,6 +289,81 @@ -- 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 ------------------------------------------------------------------------------ @@ -345,6 +461,323 @@     (|:) :: 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 ------------------------------------------------------------------------------@@ -356,6 +789,8 @@ -- @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 ->@@ -363,7 +798,13 @@                    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 @@ -371,18 +812,6 @@ -- Monoid ------------------------------------------------------------------------------ --- | An empty stream.------ @--- > toList nil--- []--- @------ @since 0.1.0-{-# INLINE nil #-}-nil :: IsStream t => t m a-nil = mkStream $ \_ _ _ stp -> stp- instance Monoid (Stream m a) where     mempty = nil     mappend = (<>)@@ -391,8 +820,30 @@ -- 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 =@@ -400,9 +851,50 @@             let single     = sng . f                 yieldk a r = yld (f a) (go r)             in foldStream (adaptState st) yieldk single stp m1+-} --- in fact use the Stream type everywhere and only use polymorphism in the high--- level modules/prelude.+{-# 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 @@ -410,9 +902,142 @@ -- Transformers ------------------------------------------------------------------------------- -{-# INLINE yieldM #-}-yieldM :: (Monad m, IsStream t) => m a -> t m a-yieldM m = fromStream $ mkStream $ \_ _ single _ -> m >>= single- instance MonadTrans Stream where     lift = yieldM++-------------------------------------------------------------------------------+-- 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 view
@@ -13,7 +13,7 @@ -- Copyright   : (c) 2017 Harendra Kumar -- -- License     : BSD3--- Maintainer  : harendra.kumar@gmail.com+-- Maintainer  : streamly@composewell.com -- Stability   : experimental -- Portability : GHC --@@ -39,10 +39,15 @@ where  import Control.Applicative (liftA2)-import Control.DeepSeq (NFData(..), NFData1(..), rnf1)+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)@@ -51,7 +56,7 @@ import Streamly.Streams.StreamK (IsStream(..), Stream, mkStream, foldStream) import Streamly.Streams.Async (mkAsync') import Streamly.Streams.Serial (map)-import Streamly.SVar (MonadAsync, adaptState)+import Streamly.Internal.Data.SVar (MonadAsync, adaptState)  import qualified Streamly.Streams.Prelude as P import qualified Streamly.Streams.StreamK as K@@ -124,6 +129,7 @@     (|:) = consMZip  LIST_INSTANCES(ZipSerialM)+NFDATA1_INSTANCE(ZipSerialM)  instance Monad m => Functor (ZipSerialM m) where     fmap = map
− src/Streamly/String.hs 
@@ -1,28 +0,0 @@--- |--- Module      : Streamly.String--- Copyright   : (c) 2018 Composewell Technologies------ License     : BSD3--- Maintainer  : harendra.kumar@gmail.com--- Stability   : experimental--- Portability : GHC------ The 'String' type in this module is just a synonym for the type @List Char@.--- It provides better performance compared to the standard Haskell @String@--- type and can be used almost as a drop-in replacement, especially when used--- with @OverloadedStrings@ extension, with little differences.------ See "Streamly.List", <src/docs/streamly-vs-lists.md> for more details and--- <src/test/PureStreams.hs> for comprehensive usage examples.-------module Streamly.String-    (-      String-    )-where--import Streamly.List (List)-import Prelude hiding (String)--type String = List Char
− src/Streamly/Time.hs 
@@ -1,74 +0,0 @@--- |--- Module      : Streamly.Time--- Copyright   : (c) 2017 Harendra Kumar------ License     : BSD3--- Maintainer  : harendra.kumar@gmail.com--- Stability   : experimental--- Portability : GHC------ Time utilities for reactive programming.--module Streamly.Time-{-# DEPRECATED-   "Please use the \"rate\" combinator instead of the functions in this module"-  #-}-    ( periodic-    , withClock-    )-where--import Control.Monad (when)-import Control.Concurrent (threadDelay)---- | Run an action forever periodically at the given frequency specified in per--- second (Hz).------ @since 0.1.0-{-# DEPRECATED periodic "Please use the \"rate\" combinator instead" #-}-periodic :: Int -> IO () -> IO ()-periodic freq action = do-    action-    threadDelay (1000000 `div` freq)-    periodic freq action---- | Run a computation on every clock tick, the clock runs at the specified--- frequency. It allows running a computation at high frequency efficiently by--- maintaining a local clock and adjusting it with the provided base clock at--- longer intervals.  The first argument is a base clock returning some notion--- of time in microseconds. The second argument is the frequency in per second--- (Hz). The third argument is the action to run, the action is provided the--- local time as an argument.------ @since 0.1.0-{-# DEPRECATED withClock "Please use the \"rate\" combinator instead" #-}-withClock :: IO Int -> Int -> (Int -> IO ()) -> IO ()-withClock clock freq action = do-    t <- clock-    go t period period t 0--    where--    period = 1000000 `div` freq--    -- Note that localTime is roughly but not exactly equal to (lastAdj + tick-    -- * n).  That is because we do not abruptly adjust the clock skew instead-    -- we adjust the tick size.-    go lastAdj delay tick localTime n = do-        action localTime-        when (delay > 0) $ threadDelay delay--        if n == freq-        then do-            (t, newTick, newDelay) <- adjustClock lastAdj localTime delay-            go t newDelay newTick (localTime + newTick) 0-        else go lastAdj delay tick (localTime + tick) (n + 1)--    -- Adjust the tick size rather than the clock to avoid abrupt changes-    -- resulting in jittery behavior at the end of every interval.-    adjustClock lastAdj localTime delay = do-        baseTime <- clock-        let newTick    = period + (baseTime - localTime) `div` freq-            lastPeriod = (baseTime - lastAdj) `div` freq-            newDelay   = max 0 (delay + period - lastPeriod)-        return (baseTime, newTick, newDelay)
− src/Streamly/Time/Clock.hsc 
@@ -1,309 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE ScopedTypeVariables #-}--#if __GLASGOW_HASKELL__ >= 800-{-# OPTIONS_GHC -Wno-identities #-}-{-# OPTIONS_GHC -Wno-orphans #-}-{-# OPTIONS_GHC -fno-warn-unused-imports #-}-#endif--#ifndef __GHCJS__-#include "config.h"-#endif---- |--- Module      : Streamly.Time.Clock--- Copyright   : (c) 2019 Harendra Kumar---               (c) 2009-2012, Cetin Sert---               (c) 2010, Eugene Kirpichov--- License     : BSD3--- Maintainer  : harendra.kumar@gmail.com--- Stability   : experimental--- Portability : GHC---- A majority of the code below has been stolen from the "clock" package.--#if __GHCJS__-#define HS_CLOCK_GHCJS 1-#elif (defined (HAVE_TIME_H) && defined(HAVE_CLOCK_GETTIME))-#define HS_CLOCK_POSIX 1-#elif __APPLE__-#define HS_CLOCK_OSX 1-#elif defined(_WIN32)-#define HS_CLOCK_WINDOWS 1-#else-#error "Time/Clock functionality not implemented for this system"-#endif--module Streamly.Time.Clock-    (-    -- * get time from the system clock-      Clock(..)-    , getTime-    )-where--import Data.Int (Int32, Int64)-import Data.Typeable (Typeable)-import Data.Word (Word32)-import Foreign.C (CInt(..), throwErrnoIfMinus1_, CTime(..), CLong(..))-import Foreign.Marshal.Alloc (alloca)-import Foreign.Ptr (Ptr)-import Foreign.Storable (Storable(..), peek)-import GHC.Generics (Generic)--import Streamly.Time.Units (TimeSpec(..), AbsTime(..))------------------------------------------------------------------------------------ Clock Types----------------------------------------------------------------------------------#if HS_CLOCK_POSIX-#include <time.h>--#if defined(CLOCK_MONOTONIC_RAW)-#define HAVE_CLOCK_MONOTONIC_RAW-#endif---- XXX this may be RAW on apple not RAW on linux-#if __linux__ && defined(CLOCK_MONOTONIC_COARSE)-#define HAVE_CLOCK_MONOTONIC_COARSE-#endif--#if __APPLE__ && defined(CLOCK_MONOTONIC_RAW_APPROX)-#define HAVE_CLOCK_MONOTONIC_COARSE-#endif--#if __linux__ && defined(CLOCK_BOOTTIME)-#define HAVE_CLOCK_MONOTONIC_UPTIME-#endif--#if __APPLE__ && defined(CLOCK_UPTIME_RAW)-#define HAVE_CLOCK_MONOTONIC_UPTIME-#endif--#if __linux__ && defined(CLOCK_REALTIME_COARSE)-#define HAVE_CLOCK_REALTIME_COARSE-#endif--#endif---- | Clock types. A clock may be system-wide (that is, visible to all processes)---   or per-process (measuring time that is meaningful only within a process).---   All implementations shall support CLOCK_REALTIME. (The only suspend-aware---   monotonic is CLOCK_BOOTTIME on Linux.)-data Clock--    -- | The identifier for the system-wide monotonic clock, which is defined as-    --   a clock measuring real time, whose value cannot be set via-    --   @clock_settime@ and which cannot have negative clock jumps. The maximum-    --   possible clock jump shall be implementation defined. For this clock,-    --   the value returned by 'getTime' represents the amount of time (in-    --   seconds and nanoseconds) since an unspecified point in the past (for-    --   example, system start-up time, or the Epoch). This point does not-    --   change after system start-up time. Note that the absolute value of the-    --   monotonic clock is meaningless (because its origin is arbitrary), and-    --   thus there is no need to set it. Furthermore, realtime applications can-    --   rely on the fact that the value of this clock is never set.-  = Monotonic--    -- | The identifier of the system-wide clock measuring real time. For this-    --   clock, the value returned by 'getTime' represents the amount of time (in-    --   seconds and nanoseconds) since the Epoch.-  | Realtime--#ifndef HS_CLOCK_GHCJS-    -- | The identifier of the CPU-time clock associated with the calling-    --   process. For this clock, the value returned by 'getTime' represents the-    --   amount of execution time of the current process.-  | ProcessCPUTime--    -- | The identifier of the CPU-time clock associated with the calling OS-    --   thread. For this clock, the value returned by 'getTime' represents the-    --   amount of execution time of the current OS thread.-  | ThreadCPUTime-#endif--#if defined (HAVE_CLOCK_MONOTONIC_RAW)-    -- | (since Linux 2.6.28; Linux and Mac OSX)-    --   Similar to CLOCK_MONOTONIC, but provides access to a-    --   raw hardware-based time that is not subject to NTP-    --   adjustments or the incremental adjustments performed by-    --   adjtime(3).-  | MonotonicRaw-#endif--#if defined (HAVE_CLOCK_MONOTONIC_COARSE)-    -- | (since Linux 2.6.32; Linux and Mac OSX)-    --   A faster but less precise version of CLOCK_MONOTONIC.-    --   Use when you need very fast, but not fine-grained timestamps.-  | MonotonicCoarse-#endif--#if defined (HAVE_CLOCK_MONOTONIC_UPTIME)-    -- | (since Linux 2.6.39; Linux and Mac OSX)-    --   Identical to CLOCK_MONOTONIC, except it also includes-    --   any time that the system is suspended.  This allows-    --   applications to get a suspend-aware monotonic clock-    --   without having to deal with the complications of-    --   CLOCK_REALTIME, which may have discontinuities if the-    --   time is changed using settimeofday(2).-  | Uptime-#endif--#if defined (HAVE_CLOCK_REALTIME_COARSE)-    -- | (since Linux 2.6.32; Linux-specific)-    --   A faster but less precise version of CLOCK_REALTIME.-    --   Use when you need very fast, but not fine-grained timestamps.-  | RealtimeCoarse-#endif--  deriving (Eq, Enum, Generic, Read, Show, Typeable)------------------------------------------------------------------------------------ Translate the Haskell "Clock" type to C----------------------------------------------------------------------------------#if HS_CLOCK_POSIX--- Posix systems (Linux and Mac OSX 10.12 and later)-clockToPosixClockId :: Clock -> #{type clockid_t}-clockToPosixClockId Monotonic      = #const CLOCK_MONOTONIC-clockToPosixClockId Realtime       = #const CLOCK_REALTIME-clockToPosixClockId ProcessCPUTime = #const CLOCK_PROCESS_CPUTIME_ID-clockToPosixClockId ThreadCPUTime  = #const CLOCK_THREAD_CPUTIME_ID--#if defined(CLOCK_MONOTONIC_RAW)-clockToPosixClockId MonotonicRaw = #const CLOCK_MONOTONIC_RAW-#endif--#if __linux__ && defined (CLOCK_MONOTONIC_COARSE)-clockToPosixClockId MonotonicCoarse = #const CLOCK_MONOTONIC_COARSE-#elif __APPLE__ && defined(CLOCK_MONOTONIC_RAW_APPROX)-clockToPosixClockId MonotonicCoarse = #const CLOCK_MONOTONIC_RAW_APPROX-#endif--#if __linux__ && defined (CLOCK_REALTIME_COARSE)-clockToPosixClockId RealtimeCoarse = #const CLOCK_REALTIME_COARSE-#endif--#if __linux__ && defined(CLOCK_BOOTTIME)-clockToPosixClockId Uptime = #const CLOCK_BOOTTIME-#elif __APPLE__ && defined(CLOCK_UPTIME_RAW)-clockToPosixClockId Uptime = #const CLOCK_UPTIME_RAW-#endif--#elif HS_CLOCK_OSX--- Mac OSX versions prior to 10.12-#include <time.h>-#include <mach/clock.h>--clockToOSXClockId :: Clock -> #{type clock_id_t}-clockToOSXClockId Monotonic      = #const SYSTEM_CLOCK-clockToOSXClockId Realtime       = #const CALENDAR_CLOCK-clockToOSXClockId ProcessCPUTime = #const SYSTEM_CLOCK-clockToOSXClockId ThreadCPUTime  = #const SYSTEM_CLOCK-#elif HS_CLOCK_GHCJS--- XXX need to implement a monotonic clock for JS using performance.now()-clockToJSClockId :: Clock -> CInt-clockToJSClockId Monotonic      = 0-clockToJSClockId Realtime       = 0-#endif------------------------------------------------------------------------------------ Clock time----------------------------------------------------------------------------------#if __GLASGOW_HASKELL__ < 800-#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)-#endif--#ifdef HS_CLOCK_GHCJS-instance Storable TimeSpec where-  sizeOf _ = 8-  alignment _ = 4-  peek p = do-    CTime  s <- peekByteOff p 0-    CLong ns <- peekByteOff p 4-    return (TimeSpec (fromIntegral s) (fromIntegral ns))-  poke p (TimeSpec s ns) = do-    pokeByteOff p 0 ((fromIntegral s) :: CTime)-    pokeByteOff p 4 ((fromIntegral ns) :: CLong)--#elif HS_CLOCK_WINDOWS-instance Storable TimeSpec where-  sizeOf _ = sizeOf (undefined :: Int64) * 2-  alignment _ = alignment (undefined :: Int64)-  peek ptr = do-    s <- peekByteOff ptr 0-    ns <- peekByteOff ptr (sizeOf (undefined :: Int64))-    return (TimeSpec s ns)-  poke ptr ts = do-      pokeByteOff ptr 0 (sec ts)-      pokeByteOff ptr (sizeOf (undefined :: Int64)) (nsec ts)-#else-instance Storable TimeSpec where-  sizeOf _ = #{size struct timespec}-  alignment _ = #{alignment struct timespec}-  peek ptr = do-      s :: #{type time_t} <- #{peek struct timespec, tv_sec} ptr-      ns :: #{type long} <- #{peek struct timespec, tv_nsec} ptr-      return $ TimeSpec (fromIntegral s) (fromIntegral ns)-  poke ptr ts = do-      let s :: #{type time_t} = fromIntegral $ sec ts-          ns :: #{type long} = fromIntegral $ nsec ts-      #{poke struct timespec, tv_sec} ptr (s)-      #{poke struct timespec, tv_nsec} ptr (ns)-#endif--{-# INLINE getTimeWith #-}-getTimeWith :: (Ptr TimeSpec -> IO ()) -> IO AbsTime-getTimeWith f = do-    t <- alloca (\ptr -> f ptr >> peek ptr)-    return $ AbsTime t--#if HS_CLOCK_GHCJS--foreign import ccall unsafe "time.h clock_gettime_js"-    clock_gettime_js :: CInt -> Ptr TimeSpec -> IO CInt--{-# INLINABLE getTime #-}-getTime :: Clock -> IO AbsTime-getTime clock =-    getTimeWith (throwErrnoIfMinus1_ "clock_gettime" .-        clock_gettime_js (clockToJSClockId clock))--#elif HS_CLOCK_POSIX--foreign import ccall unsafe "time.h clock_gettime"-    clock_gettime :: #{type clockid_t} -> Ptr TimeSpec -> IO CInt--{-# INLINABLE getTime #-}-getTime :: Clock -> IO AbsTime-getTime clock =-    getTimeWith (throwErrnoIfMinus1_ "clock_gettime" .-        clock_gettime (clockToPosixClockId clock))--#elif HS_CLOCK_OSX---- XXX perform error checks inside c implementation-foreign import ccall-    clock_gettime_darwin :: #{type clock_id_t} -> Ptr TimeSpec -> IO ()--{-# INLINABLE getTime #-}-getTime :: Clock -> IO AbsTime-getTime clock = getTimeWith $ clock_gettime_darwin (clockToOSXClockId clock)--#elif HS_CLOCK_WINDOWS---- XXX perform error checks inside c implementation-foreign import ccall clock_gettime_win32_monotonic :: Ptr TimeSpec -> IO ()--{-# INLINABLE getTime #-}-getTime :: Clock -> IO AbsTime-getTime Monotonic = getTimeWith $ clock_gettime_win32_monotonic-getTime RealTime = getTimeWith $ clock_gettime_win32_realtime-getTime ProcessCPUTime = getTimeWith $ clock_gettime_win32_processtime-getTime ThreadCPUTime = getTimeWith $ clock_gettime_win32_threadtime-#endif
− src/Streamly/Time/Darwin.c 
@@ -1,36 +0,0 @@-/*- * Code taken from the Haskell "clock" package.- *- * Copyright (c) 2009-2012, Cetin Sert- * Copyright (c) 2010, Eugene Kirpichov- *- * OS X code was contributed by Gerolf Seitz on 2013-10-15.- */--#ifdef __MACH__-#include <time.h>-#include <mach/clock.h>-#include <mach/mach.h>--void clock_gettime_darwin(clock_id_t clock, struct timespec *ts)-{-    clock_serv_t cclock;-    mach_timespec_t mts;-    host_get_clock_service(mach_host_self(), clock, &cclock);-    clock_get_time(cclock, &mts);-    mach_port_deallocate(mach_task_self(), cclock);-    ts->tv_sec = mts.tv_sec;-    ts->tv_nsec = mts.tv_nsec;-}--void clock_getres_darwin(clock_id_t clock, struct timespec *ts)-{-    clock_serv_t cclock;-    int nsecs;-    mach_msg_type_number_t count;-    host_get_clock_service(mach_host_self(), clock, &cclock);-    clock_get_attributes(cclock, CLOCK_GET_TIME_RES, (clock_attr_t)&nsecs, &count);-    mach_port_deallocate(mach_task_self(), cclock);-}--#endif  /* __MACH__ */
− src/Streamly/Time/Units.hs 
@@ -1,471 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE ScopedTypeVariables        #-}--#include "inline.hs"---- |--- Module      : Streamly.Time.Units--- Copyright   : (c) 2019 Harendra Kumar------ License     : BSD3--- Maintainer  : harendra.kumar@gmail.com--- Stability   : experimental--- Portability : GHC--module Streamly.Time.Units-    (-    -- * Time Unit Conversions-      TimeUnit()-    -- , TimeUnitWide()-    , TimeUnit64()--    -- * Time Units-    , TimeSpec(..)-    , NanoSecond64(..)-    , MicroSecond64(..)-    , MilliSecond64(..)-    , showNanoSecond64--    -- * Absolute times (using TimeSpec)-    , AbsTime(..)-    , toAbsTime-    , fromAbsTime--    -- * Relative times (using TimeSpec)-    , RelTime-    , toRelTime-    , fromRelTime-    , diffAbsTime-    , addToAbsTime--    -- * Relative times (using NanoSecond64)-    , RelTime64-    , toRelTime64-    , fromRelTime64-    , diffAbsTime64-    , addToAbsTime64-    , showRelTime64-    )-where--import Data.Int-import Text.Printf (printf)------------------------------------------------------------------------------------ Some constants----------------------------------------------------------------------------------{-# INLINE tenPower3 #-}-tenPower3 :: Int64-tenPower3 = 1000--{-# INLINE tenPower6 #-}-tenPower6 :: Int64-tenPower6 = 1000000--{-# INLINE tenPower9 #-}-tenPower9 :: Int64-tenPower9 = 1000000000------------------------------------------------------------------------------------ Time Unit Representations------------------------------------------------------------------------------------ XXX We should be able to use type families to use different represenations--- for a unit.------ Second Rational--- Second Double--- Second Int64--- Second Integer--- NanoSecond Int64--- ...---- Double or Fixed would be a much better representation so that we do not lose--- information between conversions. However, for faster arithmetic operations--- we use an 'Int64' here. When we need convservation of values we can use a--- different system of units with a Fixed precision.------------------------------------------------------------------------------------ Integral Units------------------------------------------------------------------------------------ | An 'Int64' time representation with a nanosecond resolution. It can--- represent time up to ~292 years.-newtype NanoSecond64 = NanoSecond64 Int64-    deriving ( Eq-             , Read-             , Show-             , Enum-             , Bounded-             , Num-             , Real-             , Integral-             , Ord-             )---- | An 'Int64' time representation with a microsecond resolution.--- It can represent time up to ~292,000 years.-newtype MicroSecond64 = MicroSecond64 Int64-    deriving ( Eq-             , Read-             , Show-             , Enum-             , Bounded-             , Num-             , Real-             , Integral-             , Ord-             )---- | An 'Int64' time representation with a millisecond resolution.--- It can represent time up to ~292 million years.-newtype MilliSecond64 = MilliSecond64 Int64-    deriving ( Eq-             , Read-             , Show-             , Enum-             , Bounded-             , Num-             , Real-             , Integral-             , Ord-             )------------------------------------------------------------------------------------ Fractional Units-------------------------------------------------------------------------------------------------------------------------------------------------------------------- TimeSpec representation------------------------------------------------------------------------------------ A structure storing seconds and nanoseconds as 'Int64' is the simplest and--- fastest way to store practically large quantities of time with efficient--- arithmetic operations. If we store nanoseconds using 'Integer' it can store--- practically unbounded quantities but it may not be as efficient to--- manipulate in performance critical applications. XXX need to measure the--- performance.------ | Data type to represent practically large quantities of time efficiently.--- It can represent time up to ~292 billion years at nanosecond resolution.-data TimeSpec = TimeSpec-  { sec  :: {-# UNPACK #-} !Int64 -- ^ seconds-  , nsec :: {-# UNPACK #-} !Int64 -- ^ nanoseconds-  } deriving (Eq, Read, Show)---- We assume that nsec is always less than 10^9. When TimeSpec is negative then--- both sec and nsec are negative.-instance Ord TimeSpec where-    compare (TimeSpec s1 ns1) (TimeSpec s2 ns2) =-        if s1 == s2-        then compare ns1 ns2-        else compare s1 s2---- make sure nsec is less than 10^9-{-# INLINE addWithOverflow #-}-addWithOverflow :: TimeSpec -> TimeSpec -> TimeSpec-addWithOverflow (TimeSpec s1 ns1) (TimeSpec s2 ns2) =-    let nsum = ns1 + ns2-        (s', ns) = if (nsum > tenPower9 || nsum < negate tenPower9)-                    then nsum `divMod` tenPower9-                    else (0, nsum)-    in TimeSpec (s1 + s2 + s') ns---- make sure both sec and nsec have the same sign-{-# INLINE adjustSign #-}-adjustSign :: TimeSpec -> TimeSpec-adjustSign (t@(TimeSpec s ns)) =-    if (s > 0 && ns < 0)-    then TimeSpec (s - 1) (ns + tenPower9)-    else if (s < 0 && ns > 0)-    then TimeSpec (s + 1) (ns - tenPower9)-    else t--{-# INLINE timeSpecToInteger #-}-timeSpecToInteger :: TimeSpec -> Integer-timeSpecToInteger (TimeSpec s ns) = toInteger $ s * tenPower9 + ns--instance Num TimeSpec where-    {-# INLINE (+) #-}-    t1 + t2 = adjustSign (addWithOverflow t1 t2)--    -- XXX will this be more optimal if imlemented without "negate"?-    {-# INLINE (-) #-}-    t1 - t2 = t1 + (negate t2)-    t1 * t2 = fromInteger $ timeSpecToInteger t1 * timeSpecToInteger t2--    {-# INLINE negate #-}-    negate (TimeSpec s ns) = TimeSpec (negate s) (negate ns)-    {-# INLINE abs #-}-    abs    (TimeSpec s ns) = TimeSpec (abs s) (abs ns)-    {-# INLINE signum #-}-    signum (TimeSpec s ns) | s == 0    = TimeSpec (signum ns) 0-                           | otherwise = TimeSpec (signum s) 0-    -- This is fromNanoSecond64 Integer-    {-# INLINE fromInteger #-}-    fromInteger nanosec = TimeSpec (fromInteger s) (fromInteger ns)-        where (s, ns) = nanosec `divMod` toInteger tenPower9------------------------------------------------------------------------------------ Time unit conversions------------------------------------------------------------------------------------ TODO: compare whether using TimeSpec instead of Integer provides significant--- performance boost. If not then we can just use Integer nanoseconds and get--- rid of TimeUnitWide.------ | A type class for converting between time units using 'Integer' as the--- intermediate and the widest representation with a nanosecond resolution.--- This system of units can represent arbitrarily large times but provides--- least efficient arithmetic operations due to 'Integer' arithmetic.------ NOTE: Converting to and from units may truncate the value depending on the--- original value and the size and resolution of the destination unit.-{--class TimeUnitWide a where-    toTimeInteger   :: a -> Integer-    fromTimeInteger :: Integer -> a--}---- | A type class for converting between units of time using 'TimeSpec' as the--- intermediate representation.  This system of units can represent up to ~292--- billion years at nanosecond resolution with reasonably efficient arithmetic--- operations.------ NOTE: Converting to and from units may truncate the value depending on the--- original value and the size and resolution of the destination unit.-class TimeUnit a where-    toTimeSpec   :: a -> TimeSpec-    fromTimeSpec :: TimeSpec -> a---- XXX we can use a fromNanoSecond64 for conversion with overflow check and--- fromNanoSecond64Unsafe for conversion without overflow check.------ | A type class for converting between units of time using 'Int64' as the--- intermediate representation with a nanosecond resolution.  This system of--- units can represent up to ~292 years at nanosecond resolution with fast--- arithmetic operations.------ NOTE: Converting to and from units may truncate the value depending on the--- original value and the size and resolution of the destination unit.-class TimeUnit64 a where-    toNanoSecond64   :: a -> NanoSecond64-    fromNanoSecond64 :: NanoSecond64 -> a------------------------------------------------------------------------------------ Time units----------------------------------------------------------------------------------instance TimeUnit TimeSpec where-    toTimeSpec = id-    fromTimeSpec = id--instance TimeUnit NanoSecond64 where-    {-# INLINE toTimeSpec #-}-    toTimeSpec (NanoSecond64 t) = TimeSpec s ns-        where (s, ns) = t `divMod` tenPower9--    {-# INLINE fromTimeSpec #-}-    fromTimeSpec (TimeSpec s ns) =-        NanoSecond64 $ s * tenPower9 + ns--instance TimeUnit64 NanoSecond64 where-    {-# INLINE toNanoSecond64 #-}-    toNanoSecond64 = id--    {-# INLINE fromNanoSecond64 #-}-    fromNanoSecond64 = id--instance TimeUnit MicroSecond64 where-    {-# INLINE toTimeSpec #-}-    toTimeSpec (MicroSecond64 t) = TimeSpec s us-        where (s, us) = t `divMod` tenPower6--    {-# INLINE fromTimeSpec #-}-    fromTimeSpec (TimeSpec s us) =-        MicroSecond64 $ s * tenPower6 + us--instance TimeUnit64 MicroSecond64 where-    {-# INLINE toNanoSecond64 #-}-    toNanoSecond64 (MicroSecond64 us) = NanoSecond64 $ us * tenPower3--    {-# INLINE fromNanoSecond64 #-}-    fromNanoSecond64 (NanoSecond64 ns) = MicroSecond64 $ ns `div` tenPower3--instance TimeUnit MilliSecond64 where-    {-# INLINE toTimeSpec #-}-    toTimeSpec (MilliSecond64 t) = TimeSpec s us-        where (s, us) = t `divMod` tenPower3--    {-# INLINE fromTimeSpec #-}-    fromTimeSpec (TimeSpec s us) =-        MilliSecond64 $ s * tenPower3 + us--instance TimeUnit64 MilliSecond64 where-    {-# INLINE toNanoSecond64 #-}-    toNanoSecond64 (MilliSecond64 us) = NanoSecond64 $ us * tenPower6--    {-# INLINE fromNanoSecond64 #-}-    fromNanoSecond64 (NanoSecond64 ns) = MilliSecond64 $ ns `div` tenPower6------------------------------------------------------------------------------------ Absolute time------------------------------------------------------------------------------------ | Absolute times are relative to a predefined epoch in time. 'AbsTime'--- represents times using 'TimeSpec' which can represent times up to ~292--- billion years at a nanosecond resolution.-newtype AbsTime = AbsTime TimeSpec-    deriving (Eq, Ord, Show)---- | Convert a 'TimeUnit' to an absolute time.-{-# INLINE_NORMAL toAbsTime #-}-toAbsTime :: TimeUnit a => a -> AbsTime-toAbsTime = AbsTime . toTimeSpec---- | Convert absolute time to a 'TimeUnit'.-{-# INLINE_NORMAL fromAbsTime #-}-fromAbsTime :: TimeUnit a => AbsTime -> a-fromAbsTime (AbsTime t) = fromTimeSpec t---- XXX We can also write rewrite rules to simplify divisions multiplications--- and additions when manipulating units. Though, that might get simplified at--- the assembly (llvm) level as well. Note to/from conversions may be lossy and--- therefore this equation may not hold, but that's ok.-{-# RULES "fromAbsTime/toAbsTime" forall a. toAbsTime (fromAbsTime a) = a #-}-{-# RULES "toAbsTime/fromAbsTime" forall a. fromAbsTime (toAbsTime a) = a #-}------------------------------------------------------------------------------------ Relative time using NaonoSecond64 as the underlying representation------------------------------------------------------------------------------------ We use a separate type to represent relative time for safety and speed.--- RelTime has a Num instance, absolute time doesn't.  Relative times are--- usually shorter and for our purposes an Int64 nanoseconds can hold close to--- thousand year duration. It is also faster to manipulate. We do not check for--- overflows during manipulations so use it only when you know the time cannot--- be too big. If you need a bigger RelTime representation then use RelTimeBig.---- | Relative times are relative to some arbitrary point of time. Unlike--- 'AbsTime' they are not relative to a predefined epoch.-newtype RelTime64 = RelTime64 NanoSecond64-    deriving ( Eq-             , Read-             , Show-             , Enum-             , Bounded-             , Num-             , Real-             , Integral-             , Ord-             )---- | Convert a 'TimeUnit' to a relative time.-{-# INLINE_NORMAL toRelTime64 #-}-toRelTime64 :: TimeUnit64 a => a -> RelTime64-toRelTime64 = RelTime64 . toNanoSecond64---- | Convert relative time to a 'TimeUnit'.-{-# INLINE_NORMAL fromRelTime64 #-}-fromRelTime64 :: TimeUnit64 a => RelTime64 -> a-fromRelTime64 (RelTime64 t) = fromNanoSecond64 t--{-# RULES "fromRelTime64/toRelTime64" forall a .-          toRelTime64 (fromRelTime64 a) = a #-}--{-# RULES "toRelTime64/fromRelTime64" forall a .-          fromRelTime64 (toRelTime64 a) = a #-}---- | Difference between two absolute points of time.-{-# INLINE diffAbsTime64 #-}-diffAbsTime64 :: AbsTime -> AbsTime -> RelTime64-diffAbsTime64 (AbsTime (TimeSpec s1 ns1)) (AbsTime (TimeSpec s2 ns2)) =-    RelTime64 $ NanoSecond64 $ ((s1 - s2) * tenPower9) + (ns1 - ns2)--{-# INLINE addToAbsTime64 #-}-addToAbsTime64 :: AbsTime -> RelTime64 -> AbsTime-addToAbsTime64 (AbsTime (TimeSpec s1 ns1)) (RelTime64 (NanoSecond64 ns2)) =-    AbsTime $ TimeSpec (s1 + s) ns-    where (s, ns) = (ns1 + ns2) `divMod` tenPower9------------------------------------------------------------------------------------ Relative time using TimeSpec as the underlying representation----------------------------------------------------------------------------------newtype RelTime = RelTime TimeSpec-    deriving ( Eq-             , Read-             , Show-             -- , Enum-             -- , Bounded-             , Num-             -- , Real-             -- , Integral-             , Ord-             )--{-# INLINE_NORMAL toRelTime #-}-toRelTime :: TimeUnit a => a -> RelTime-toRelTime = RelTime . toTimeSpec--{-# INLINE_NORMAL fromRelTime #-}-fromRelTime :: TimeUnit a => RelTime -> a-fromRelTime (RelTime t) = fromTimeSpec t--{-# RULES "fromRelTime/toRelTime" forall a. toRelTime (fromRelTime a) = a #-}-{-# RULES "toRelTime/fromRelTime" forall a. fromRelTime (toRelTime a) = a #-}---- XXX rename to diffAbsTimes?-{-# INLINE diffAbsTime #-}-diffAbsTime :: AbsTime -> AbsTime -> RelTime-diffAbsTime (AbsTime t1) (AbsTime t2) = RelTime (t1 - t2)--{-# INLINE addToAbsTime #-}-addToAbsTime :: AbsTime -> RelTime -> AbsTime-addToAbsTime (AbsTime t1) (RelTime t2) = AbsTime $ t1 + t2------------------------------------------------------------------------------------ Formatting and printing------------------------------------------------------------------------------------ | Convert nanoseconds to a string showing time in an appropriate unit.-showNanoSecond64 :: NanoSecond64 -> String-showNanoSecond64 time@(NanoSecond64 ns)-    | time < 0    = '-' : showNanoSecond64 (-time)-    | ns < 1000 = fromIntegral ns `with` "ns"-#ifdef mingw32_HOST_OS-    | ns < 1000000 = (fromIntegral ns / 1000) `with` "us"-#else-    | ns < 1000000 = (fromIntegral ns / 1000) `with` "μs"-#endif-    | ns < 1000000000 = (fromIntegral ns / 1000000) `with` "ms"-    | ns < (60 * 1000000000) = (fromIntegral ns / 1000000000) `with` "s"-    | ns < (60 * 60 * 1000000000) =-        (fromIntegral ns / (60 * 1000000000)) `with` "min"-    | ns < (24 * 60 * 60 * 1000000000) =-        (fromIntegral ns / (60 * 60 * 1000000000)) `with` "hr"-    | ns < (365 * 24 * 60 * 60 * 1000000000) =-        (fromIntegral ns / (24 * 60 * 60 * 1000000000)) `with` "days"-    | otherwise =-        (fromIntegral ns / (365 * 24 * 60 * 60 * 1000000000)) `with` "years"-     where with (t :: Double) (u :: String)-               | t >= 1e9  = printf "%.4g %s" t u-               | t >= 1e3  = printf "%.0f %s" t u-               | t >= 1e2  = printf "%.1f %s" t u-               | t >= 1e1  = printf "%.2f %s" t u-               | otherwise = printf "%.3f %s" t u---- In general we should be able to show the time in a specified unit, if we--- omit the unit we can show it in an automatically chosen one.-{--data UnitName =-      Nano-    | Micro-    | Milli-    | Sec--}--showRelTime64 :: RelTime64 -> String-showRelTime64 = showNanoSecond64 . fromRelTime64
− src/Streamly/Time/Windows.c 
@@ -1,115 +0,0 @@-/*- * Code taken from the Haskell "clock" package.- *- * Copyright (c) 2009-2012, Cetin Sert- * Copyright (c) 2010, Eugene Kirpichov- */--#ifdef _WIN32-#include <windows.h>--#if defined(_MSC_VER) || defined(_MSC_EXTENSIONS)-  #define U64(x) x##Ui64-#else-  #define U64(x) x##ULL-#endif--#define DELTA_EPOCH_IN_100NS  U64(116444736000000000)--static long ticks_to_nanos(LONGLONG subsecond_time, LONGLONG frequency)-{-    return (long)((1e9 * subsecond_time) / frequency);-}--static ULONGLONG to_quad_100ns(FILETIME ft)-{-    ULARGE_INTEGER li;-    li.LowPart = ft.dwLowDateTime;-    li.HighPart = ft.dwHighDateTime;-    return li.QuadPart;-}--static void to_timespec_from_100ns(ULONGLONG t_100ns, long long *t)-{-    t[0] = (long)(t_100ns / 10000000UL);-    t[1] = 100*(long)(t_100ns % 10000000UL);-}--void clock_gettime_win32_monotonic(long long* t)-{-   LARGE_INTEGER time;-   LARGE_INTEGER frequency;-   QueryPerformanceCounter(&time);-   QueryPerformanceFrequency(&frequency);-   // seconds-   t[0] = time.QuadPart / frequency.QuadPart;-   // nanos =-   t[1] = ticks_to_nanos(time.QuadPart % frequency.QuadPart, frequency.QuadPart);-}--void clock_gettime_win32_realtime(long long* t)-{-    FILETIME ft;-    ULONGLONG tmp;--    GetSystemTimeAsFileTime(&ft);--    tmp = to_quad_100ns(ft);-    tmp -= DELTA_EPOCH_IN_100NS;--    to_timespec_from_100ns(tmp, t);-}--void clock_gettime_win32_processtime(long long* t)-{-    FILETIME creation_time, exit_time, kernel_time, user_time;-    ULONGLONG time;--    GetProcessTimes(GetCurrentProcess(), &creation_time, &exit_time, &kernel_time, &user_time);-    // Both kernel and user, acc. to http://www.opengroup.org/onlinepubs/009695399/basedefs/xbd_chap03.html#tag_03_117--    time = to_quad_100ns(user_time) + to_quad_100ns(kernel_time);-    to_timespec_from_100ns(time, t);-}--void clock_gettime_win32_threadtime(long long* t)-{-    FILETIME creation_time, exit_time, kernel_time, user_time;-    ULONGLONG time;--    GetThreadTimes(GetCurrentThread(), &creation_time, &exit_time, &kernel_time, &user_time);-    // Both kernel and user, acc. to http://www.opengroup.org/onlinepubs/009695399/basedefs/xbd_chap03.html#tag_03_117--    time = to_quad_100ns(user_time) + to_quad_100ns(kernel_time);-    to_timespec_from_100ns(time, t);-}--void clock_getres_win32_monotonic(long long* t)-{-    LARGE_INTEGER frequency;-    QueryPerformanceFrequency(&frequency);--    ULONGLONG resolution = U64(1000000000)/frequency.QuadPart;-    t[0] = resolution / U64(1000000000);-    t[1] = resolution % U64(1000000000);-}--void clock_getres_win32_realtime(long long* t)-{-    t[0] = 0;-    t[1] = 100;-}--void clock_getres_win32_processtime(long long* t)-{-    t[0] = 0;-    t[1] = 100;-}--void clock_getres_win32_threadtime(long long* t)-{-    t[0] = 0;-    t[1] = 100;-}--#endif  /* _WIN32 */
− src/Streamly/Time/config.h.in 
@@ -1,55 +0,0 @@-/* src/Streamly/Time/config.h.in.  Generated from configure.ac by autoheader.  */--/* Define to 1 if you have the `clock_gettime' function. */-#undef HAVE_CLOCK_GETTIME--/* Define to 1 if you have the <inttypes.h> header file. */-#undef HAVE_INTTYPES_H--/* Define to 1 if you have the <memory.h> header file. */-#undef HAVE_MEMORY_H--/* Define to 1 if you have the <stdint.h> header file. */-#undef HAVE_STDINT_H--/* Define to 1 if you have the <stdlib.h> header file. */-#undef HAVE_STDLIB_H--/* Define to 1 if you have the <strings.h> header file. */-#undef HAVE_STRINGS_H--/* Define to 1 if you have the <string.h> header file. */-#undef HAVE_STRING_H--/* Define to 1 if you have the <sys/stat.h> header file. */-#undef HAVE_SYS_STAT_H--/* Define to 1 if you have the <sys/types.h> header file. */-#undef HAVE_SYS_TYPES_H--/* Define to 1 if you have the <time.h> header file. */-#undef HAVE_TIME_H--/* Define to 1 if you have the <unistd.h> header file. */-#undef HAVE_UNISTD_H--/* Define to the address where bug reports for this package should be sent. */-#undef PACKAGE_BUGREPORT--/* Define to the full name of this package. */-#undef PACKAGE_NAME--/* Define to the full name and version of this package. */-#undef PACKAGE_STRING--/* Define to the one symbol short name of this package. */-#undef PACKAGE_TARNAME--/* Define to the home page for this package. */-#undef PACKAGE_URL--/* Define to the version of this package. */-#undef PACKAGE_VERSION--/* Define to 1 if you have the ANSI C header files. */-#undef STDC_HEADERS
src/Streamly/Tutorial.hs view
@@ -4,21 +4,22 @@ -- Copyright   : (c) 2017 Harendra Kumar -- -- License     : BSD3--- Maintainer  : harendra.kumar@gmail.com+-- Maintainer  : streamly@composewell.com ----- Streamly is a general computing framework based on streaming IO. The IO--- monad and pure lists are a special case of streamly. On one hand, streamly--- extends the lists of pure values to lists of monadic actions, on the other--- hand it extends the IO monad with concurrent non-determinism. In simple--- imperative terms we can say that streamly extends the IO monad with @for@--- loops and nested @for@ loops with concurrency support. You can understand--- this analogy better once you can go through this tutorial.+-- Streamly is a general computing framework based on concurrent data flow+-- programming. The IO monad and pure lists are a special case of streamly. On+-- one hand, streamly extends the lists of pure values to lists of monadic+-- actions, on the other hand it extends the IO monad with concurrent+-- non-determinism. In simple imperative terms we can say that streamly extends+-- the IO monad with @for@ loops and nested @for@ loops with concurrency+-- support. Hopefully, this analogy becomes clearer once you go through this+-- tutorial. -- -- Streaming in general enables writing modular, composable and scalable -- applications with ease, and concurrency allows you to make them scale and -- perform well.  Streamly enables writing scalable concurrent applications -- without being aware of threads or synchronization. No explicit thread--- control is needed, where applicable the concurrency rate is automatically+-- control is needed. Where applicable, concurrency rate is automatically -- controlled based on the demand by the consumer. However, combinators can be -- used to fine tune the concurrency control. --@@ -29,12 +30,19 @@ -- programming in an elegant and simple API that is a natural extension of pure -- lists to monadic streams. ----- In this tutorial we will go over the basic concepts and how to--- use the library. See the last section for further reading resources.+-- In this tutorial we will go over the basic concepts and how to use the+-- library.  Before you go through this tutorial we recommend that you take a+-- look at:+--+--  * The quick overview in the package <README.md README file>.+--  * The overview of streams and folds in the "Streamly" module.+--+-- Once you finish this tutorial, see the last section for further reading+-- resources.  module Streamly.Tutorial     (-    -- * Streams+    -- * Stream Types     -- $streams      -- * Concurrent Streams@@ -75,7 +83,7 @@     -- *** Wide Serial Composition ('WSerial')     -- $interleaved -    -- *** Deep Ahead Composition ('Ahead')+    -- *** Deep Speculative Composition ('Ahead')     -- $ahead      -- *** Deep Asynchronous Composition ('Async')@@ -106,7 +114,7 @@     -- *** Wide Serial Nesting ('WSerial')     -- $interleavedNesting -    -- *** Deep Ahead Nesting ('Ahead')+    -- *** Deep Speculative Nesting ('Ahead')     -- $aheadNesting      -- *** Deep Asynchronous Nesting ('Async')@@ -162,7 +170,7 @@     ) where -import Streamly+import Streamly hiding (foldWith, foldMapWith, forEachWith) import Streamly.Prelude import Data.Semigroup import Control.Applicative@@ -172,22 +180,20 @@  -- $streams ----- The way a list represents a sequence of pure values, a stream represents a--- sequence of monadic actions. The monadic stream API offered by Streamly is--- very close to the Haskell "Prelude" pure lists' API, it can be considered as a--- natural extension of lists to monadic actions. Streamly streams provide--- concurrent composition and merging of streams. It can be considered as a--- concurrent list transformer. In contrast to the "Prelude" lists, merging or--- appending streams of arbitrary length is scalable and inexpensive.+-- The monadic stream API offered by Streamly is very close to the Haskell+-- "Prelude" pure lists' API, it can be considered as a natural extension of+-- lists to monadic actions. Streamly streams provide concurrent composition+-- and merging of streams. It can be considered as a concurrent list+-- transformer. -- -- The basic stream type is 'Serial', it represents a sequence of IO actions, -- and is a 'Monad'.  The 'Serial' monad is almost a drop in replacement for -- the 'IO' monad, IO monad is a special case of the 'Serial' monad; IO monad -- represents a single IO action whereas the 'Serial' monad represents a series -- of IO actions.  The only change you need to make to go from 'IO' to 'Serial'--- is to use 'runStream' to run the monad and to prefix the IO actions with+-- is to use 'drain' to run the monad and to prefix the IO actions with -- either 'yieldM' or 'liftIO'.  If you use liftIO you can switch from 'Serial'--- to IO monad by simply removing the 'runStream' function; no other changes+-- to IO monad by simply removing the 'drain' function; no other changes -- are needed unless you have used some stream specific composition or -- combinators. --@@ -326,9 +332,9 @@ -- singleton stream use 'lift' and to lift from an IO action use 'liftIO'. -- -- @--- > 'runStream' $ liftIO $ putStrLn "Hello world!"+-- > S.'drain' $ liftIO $ putStrLn "Hello world!" -- Hello world!--- > 'runStream' $ lift $ putStrLn "Hello world!"+-- > S.'drain' $ lift $ putStrLn "Hello world!" -- Hello world! -- @ --@@ -342,6 +348,8 @@ -- > import "Streamly" -- > import "Streamly.Prelude" ((|:)) -- > import qualified "Streamly.Prelude" as S+--+-- > import Control.Concurrent -- @ -- -- 'nil' represents an empty stream and 'consM' or its operator form '|:' adds@@ -364,7 +372,7 @@ -- @ -- > S.'toList' $ 'pure' 1 -- [1]--- > S.'toList' $ 'yield' 1+-- > S.'toList' $ S.'yield' 1 -- [1] -- > S.'toList' $ S.'yieldM' 'getLine' -- hello@@ -385,7 +393,7 @@ -- right fold using 'consM' and 'nil': -- -- @--- > 'runStream' $ 'Prelude.foldr' ('|:') S.'nil' ['putStr' "Hello ", 'putStrLn' "world!"]+-- > S.'drain' $ 'Prelude.foldr' ('|:') S.'nil' ['putStr' "Hello ", 'putStrLn' "world!"] -- Hello world! -- @ --@@ -412,14 +420,14 @@ -- The following finishes in 10 seconds (100 seconds when serial): -- -- @--- > 'runStream' $ 'asyncly' $ S.'replicateM' 10 $ p 10+-- > S.drain $ 'asyncly' $ S.'replicateM' 10 $ p 10 -- @ --  -- $eliminating ----- We have already seen 'runStream' and 'toList' to eliminate a stream in the--- examples above.  'runStream' runs a stream discarding the results i.e. only+-- We have already seen 'drain' and 'toList' to eliminate a stream in the+-- examples above.  'drain' runs a stream discarding the results i.e. only -- for effects.  'toList' runs the stream and collects the results in a list. -- -- For other ways to eliminate a stream see the @Folding@ section in@@ -439,7 +447,8 @@ -- forever: -- -- @--- > 'runStream' $ S.'repeatM' getLine & S.'mapM' putStrLn+-- > import Data.Function ((&))+-- > S.'drain' $ S.'repeatM' getLine & S.'mapM' putStrLn -- @ -- -- The following code snippet reads lines from standard input, filters blank@@ -452,7 +461,7 @@ -- import Data.Char (toUpper) -- import Data.Function ((&)) ----- main = 'runStream' $+-- main = S.'drain' $ --        S.'repeatM' getLine --      & S.'filter' (not . null) --      & S.'drop' 1@@ -473,7 +482,7 @@ -- -- @ -- > let p n = threadDelay (n * 1000000) >> return n--- > runStream $ aheadly $ S.'mapM' (\\x -> p 1 >> print x) (serially $ repeatM (p 1))+-- > S.'drain' $ S.aheadly $ S.'mapM' (\\x -> p 1 >> print x) (serially $ S.repeatM (p 1)) -- @ -- @@ -488,7 +497,7 @@ -- -- @ -- > let p n = threadDelay (n * 1000000) >> return n--- > runStream $ S.'repeatM' (p 1) '|&' S.'mapM' (\\x -> p 1 >> print x)+-- > S.'drain' $ S.'repeatM' (p 1) '|&' S.'mapM' (\\x -> p 1 >> print x) -- @  -- $semigroup@@ -544,7 +553,7 @@ -- 3, 4: -- -- @--- main = 'runStream' $ (print 1 |: print 2 |: nil) <> (print 3 |: print 4 |: nil)+-- main = S.'drain' $ (print 1 |: print 2 |: nil) <> (print 3 |: print 4 |: nil) -- @ -- @ -- 1@@ -558,7 +567,7 @@ -- same thread and take a combined total of @3 + 2 + 1 = 6@ seconds: -- -- @--- main = 'runStream' $ delay 3 <> delay 2 <> delay 1+-- main = S.'drain' $ delay 3 <> delay 2 <> delay 1 -- @ -- @ -- ThreadId 36: Delay 3@@ -571,7 +580,7 @@ -- irrespective of the type of stream: -- -- @--- main = 'runStream' $ (print 1 |: print 2 |: nil) \`serial` (print 3 |: print 4 |: nil)+-- main = S.'drain' $ (print 1 |: print 2 |: nil) \`serial` (print 3 |: print 4 |: nil) -- @  -- $interleaved@@ -588,7 +597,7 @@ -- The following example prints the sequence 1, 3, 2, 4 -- -- @--- main = 'runStream' . 'wSerially' $ (print 1 |: print 2 |: nil) <> (print 3 |: print 4 |: nil)+-- main = S.'drain' . 'wSerially' $ (print 1 |: print 2 |: nil) <> (print 3 |: print 4 |: nil) -- @ -- @ -- 1@@ -603,7 +612,7 @@ -- thread and take a combined total of @3 + 2 + 1 = 6@ seconds: -- -- @--- main = 'runStream' . 'wSerially' $ delay 3 <> delay 2 <> delay 1+-- main = S.'drain' . 'wSerially' $ delay 3 <> delay 2 <> delay 1 -- @ -- @ -- ThreadId 36: Delay 3@@ -617,7 +626,7 @@ -- combinator in the following example: -- -- @--- main = 'runStream' $ (print 1 |: print 2 |: nil) \`wSerial` (print 3 |: print 4 |: nil)+-- main = S.'drain' $ (print 1 |: print 2 |: nil) \`wSerial` (print 3 |: print 4 |: nil) -- @ -- @ -- 1@@ -647,7 +656,7 @@ -- -- @ -- main = do---  xs \<- 'toList' . 'aheadly' $ (p 1 |: p 2 |: nil) <> (p 3 |: p 4 |: nil)+--  xs \<- S.'toList' . 'aheadly' $ (p 1 |: p 2 |: nil) <> (p 3 |: p 4 |: nil) --  print xs --  where p n = threadDelay 1000000 >> return n -- @@@ -684,7 +693,7 @@ -- -- @ -- main = do---   xs \<- 'runStream' . 'asyncly' $ (p 1 |: p 2 |: nil) <> (p 3 |: p 4 |: nil)+--   xs \<- S.'toList' . 'asyncly' $ (p 1 |: p 2 |: nil) <> (p 3 |: p 4 |: nil) --   print xs --   where p n = threadDelay 1000000 >> return n -- @@@ -699,7 +708,7 @@ -- -- @ -- main = do---   xs \<- 'runStream' . 'asyncly' $ (serially $ p 1 |: p 2 |: nil) <> (serially $ p 3 |: p 4 |: nil)+--   xs \<- S.'toList' . 'asyncly' $ (serially $ p 1 |: p 2 |: nil) <> (serially $ p 3 |: p 4 |: nil) --   print xs --   where p n = threadDelay 1000000 >> return n -- @@@ -713,7 +722,7 @@ -- (3, 2, 1) = 3@ seconds: -- -- @--- main = 'runStream' . 'asyncly' $ delay 3 '<>' delay 2 '<>' delay 1+-- main = S.'drain' . 'asyncly' $ delay 3 '<>' delay 2 '<>' delay 1 -- @ -- @ -- ThreadId 42: Delay 1@@ -732,7 +741,7 @@ -- second as all of the actions are concurrent. -- -- @--- main = 'runStream' . 'asyncly' $ (delay 1 <> delay 2) <> (delay 3 <> delay 4)+-- main = S.'drain' . 'asyncly' $ (delay 1 <> delay 2) <> (delay 3 <> delay 4) -- @ -- @ -- 1@@ -749,7 +758,7 @@ -- even if none of them blocks: -- -- @--- main = 'runStream' . 'asyncly' $ traced (sqrt 9) '<>' traced (sqrt 16) '<>' traced (sqrt 25)+-- main = S.'drain' . 'asyncly' $ traced (sqrt 9) '<>' traced (sqrt 16) '<>' traced (sqrt 25) --  where traced m = S.'yieldM' (myThreadId >>= print) >> return m -- @ -- @@@ -767,7 +776,7 @@ -- not used the 'asyncly' combinator in the following example: -- -- @--- main = 'runStream' $ delay 3 \`async` delay 2 \`async` delay 1+-- main = S.'drain' $ delay 3 \`async` delay 2 \`async` delay 1 -- @ -- @ -- ThreadId 42: Delay 1@@ -783,11 +792,11 @@ -- all computations at once for any reason 'Parallel' style must be used -- instead. ----- 'Async' style should be preferred over 'Parallel' or 'WAsync' unless you--- really need those. It utilizes the resources optimally. It should be used+-- 'Async' style utilizes resources optimally and should be preferred over+-- 'Parallel' or 'WAsync' unless you really need those. 'Async' should be used -- when we know that the computations can run in parallel but we do not care if -- they actually run in parallel or not, that decision can be left to the--- scheduler based on demand. Also, note that this operator can be used to fold+-- scheduler based on demand. Also, note that 'async' operator can be used to fold -- infinite number of streams in contrast to the 'Parallel' or 'WAsync' styles, -- because it does not require us to run all of them at the same time in a fair -- manner.@@ -810,7 +819,7 @@ -- first traversal order but this is not guaranteed. -- -- @--- main = 'runStream' . 'wAsyncly' $ (serially $ print 1 |: print 2 |: nil) <> (serially $ print 3 |: print 4 |: nil)+-- main = S.'drain' . 'wAsyncly' $ (serially $ print 1 |: print 2 |: nil) <> (serially $ print 3 |: print 4 |: nil) -- @ -- @ -- 1@@ -825,7 +834,7 @@ -- the 'wAsyncly' combinator in the following example: -- -- @--- main = 'runStream' $ delay 3 \`wAsync` delay 2 \`wAsync` delay 1+-- main = S.'drain' $ delay 3 \`wAsync` delay 2 \`wAsync` delay 1 -- @ -- @ -- ThreadId 42: Delay 1@@ -860,14 +869,15 @@ -- -- The following example sends a query to all the three search engines in -- parallel and prints the name of the search engines in the order in which the--- responses arrive:+-- responses arrive. You need the [http-conduit](http://hackage.haskell.org/package/http-conduit)+-- package to run this example: -- -- @ -- import "Streamly" -- import qualified Streamly.Prelude as S -- import Network.HTTP.Simple ----- main = 'runStream' . 'parallely' $ google \<> bing \<> duckduckgo+-- main = S.'drain' . 'parallely' $ google \<> bing \<> duckduckgo --     where --         google     = get "https://www.google.com/search?q=haskell" --         bing       = get "https://www.bing.com/search?q=haskell"@@ -881,7 +891,7 @@ -- 'parallely' combinator in the following example: -- -- @--- main = 'runStream' $ delay 3 \`parallel` delay 2 \`wAsync` delay 1+-- main = S.'drain' $ delay 3 \`parallel` delay 2 \`wAsync` delay 1 -- @ -- @ -- ThreadId 42: Delay 1@@ -928,10 +938,10 @@ -- import Control.Concurrent -- -- main = do---  'runStream' $ 'asyncly' $ foldMap delay [1..10]---  'runStream' $ 'foldWith'    'async' (map delay [1..10])---  'runStream' $ 'foldMapWith' 'async' delay [1..10]---  'runStream' $ 'forEachWith' 'async' [1..10] delay+--  S.'drain' $ 'asyncly' $ foldMap delay [1..10]+--  S.'drain' $ S.'foldWith'    'async' (map delay [1..10])+--  S.'drain' $ S.'foldMapWith' 'async' delay [1..10]+--  S.'drain' $ S.'forEachWith' 'async' [1..10] delay --  where delay n = S.'yieldM' $ threadDelay (n * 1000000) >> print n -- @ @@ -980,7 +990,7 @@ -- import "Streamly" -- import qualified "Streamly.Prelude" as S ----- main = 'runStream' $ do+-- main = S.'drain' $ do --     x <- S.'fromFoldable' [3,2,1] --     delay x -- @@@ -1002,7 +1012,9 @@ -- import "Streamly" -- import qualified "Streamly.Prelude" as S ----- main = 'runStream' $ forever $ S.yieldM getLine >>= S.yieldM . putStrLn+-- import Control.Monad (forever)+--+-- main = S.'drain' $ forever $ S.yieldM getLine >>= S.yieldM . putStrLn -- @ -- -- When multiple streams are composed using this style they nest in a DFS@@ -1014,7 +1026,7 @@ -- import "Streamly" -- import qualified "Streamly.Prelude" as S ----- main = 'runStream' $ do+-- main = S.'drain' $ do --     x <- S.'fromFoldable' [1,2] --     y <- S.'fromFoldable' [3,4] --     S.'yieldM' $ putStrLn $ show (x, y)@@ -1041,13 +1053,13 @@ -- -- @ -- import "Streamly"--- import "Streamly.Prelude" as S+-- import qualified "Streamly.Prelude" as S ----- comp = 'toList' . 'aheadly' $ do+-- comp = S.'toList' . 'aheadly' $ do --     x <- S.'fromFoldable' [3,2,1] --     delay x >> return x ----- main = comp >> print+-- main = comp >>= print -- @ -- @ -- ThreadId 40: Delay 1@@ -1082,9 +1094,9 @@ -- -- @ -- import "Streamly"--- import "Streamly.Prelude"+-- import qualified "Streamly.Prelude" as S ----- main = 'runStream' . 'asyncly' $ do+-- main = S.'drain' . 'asyncly' $ do --     x <- S.'fromFoldable' [3,2,1] --     delay x -- @@@ -1111,7 +1123,7 @@ -- import "Streamly" -- import qualified "Streamly.Prelude" as S ----- main = 'runStream' . 'asyncly' $ do+-- main = S.'drain' . 'asyncly' $ do --     x <- S.'fromFoldable' [1,2] --     y <- S.'fromFoldable' [3,4] --     S.'yieldM' $ putStrLn $ show (x, y)@@ -1136,7 +1148,7 @@ -- import "Streamly" -- import qualified "Streamly.Prelude" as S ----- main = 'runStream' . 'wSerially' $ do+-- main = S.'drain' . 'wSerially' $ do --     x <- S.'fromFoldable' [1,2] --     y <- S.'fromFoldable' [3,4] --     S.yieldM $ putStrLn $ show (x, y)@@ -1164,7 +1176,7 @@ -- import "Streamly" -- import qualified "Streamly.Prelude" as S ----- main = 'runStream' . 'wAsyncly' $ do+-- main = S.'drain' . 'wAsyncly' $ do --     x <- S.'fromFoldable' [1,2] --     y <- S.'fromFoldable' [3,4] --     S.'yieldM' $ putStrLn $ show (x, y)@@ -1190,7 +1202,7 @@ -- import "Streamly" -- import qualified "Streamly.Prelude" as S ----- main = 'runStream' . 'parallely' $ do+-- main = S.'drain' . 'parallely' $ do --     x <- S.'fromFoldable' [3,2,1] --     delay x -- @@@ -1228,11 +1240,11 @@ -- Now we can interpret this in whatever way we want: -- -- @--- main = 'runStream' . 'serially'  $ composed--- main = 'runStream' . 'wSerially' $ composed--- main = 'runStream' . 'asyncly'   $ composed--- main = 'runStream' . 'wAsyncly'  $ composed--- main = 'runStream' . 'parallely' $ composed+-- main = S.'drain' . 'serially'  $ composed+-- main = S.'drain' . 'wSerially' $ composed+-- main = S.'drain' . 'asyncly'   $ composed+-- main = S.'drain' . 'wAsyncly'  $ composed+-- main = S.'drain' . 'parallely' $ composed -- @ -- --  As an exercise try to figure out the output of this code for each mode of@@ -1301,7 +1313,7 @@ -- @ -- -- 'Async' can run the iterations concurrently and therefore takes a total--- of 10 seconds (1 + 2 + 3 + 4):+-- of 6 seconds which is max (1, 2) + max (3, 4): -- -- @ -- main = (S.'toList' . 'asyncly' $ (,) \<$> s1 \<*> s2) >>= print@@ -1317,7 +1329,7 @@ -- @ -- -- Similarly 'WAsync' as well can run the iterations concurrently and--- therefore takes a total of 10 seconds (1 + 2 + 3 + 4):+-- therefore takes a total of 6 seconds (2 + 4): -- -- @ -- main = (S.'toList' . 'wAsyncly' $ (,) \<$> s1 \<*> s2) >>= print@@ -1513,7 +1525,7 @@ -- main = do --     putStrLn "Your health is deteriorating due to acid rain,\\ --              \\ type \\"potion\\" or \\"quit\\""---     let runGame = S.'runWhile' (== Alive) $ S.'mapM' getStatus runEvents+--     let runGame = S.'drainWhile' (== Alive) $ S.'mapM' getStatus runEvents --     void $ runStateT runGame 60 -- @ --@@ -1713,13 +1725,14 @@ -- that and takes a lazy pull approach versus transient's strict push approach. -- -- The non-determinism, concurrency and streaming combination make streamly a--- strong FRP capable library as well. FRP is fundamentally stream of events--- that can be processed concurrently. The example in this tutorial as well as--- the "Streamly.Examples.CirclingSquare" example from Yampa demonstrate the--- basic FRP capability of streamly. In core concepts streamly is strikingly--- similar to @dunai@. dunai was designed from a FRP perspective and streamly--- was originally designed from a concurrency perspective. However, both have--- similarity at the core.+-- strong reactive programming library as well. Reactive programming is+-- fundamentally stream of events that can be processed concurrently. The+-- example in this tutorial as well as the+-- <examples/CirclingSquare.hs CirclingSquare> example from Yampa demonstrate+-- the basic reactive capability of streamly. In core concepts streamly is+-- strikingly similar to @dunai@.  dunai was designed from a FRP perspective+-- and streamly was originally designed from a concurrency perspective.+-- However, both have similarity at the core.  -- $furtherReading --
− stack-7.10.yaml 
@@ -1,18 +0,0 @@-resolver: lts-6.35-packages:-- '.'-extra-deps:-    - QuickCheck-2.10-    - lockfree-queue-0.2.3.1-    - http-conduit-2.2.2-    - http-client-0.5.0-    - http-client-tls-0.3.0-    - SDL-0.6.5.1-    - gauge-0.2.4-    - basement-0.0.7-    - deepseq-1.4.4.0-flags: {}-extra-package-dbs: []-# For mac ports installed SDL library on Mac OS X-extra-include-dirs:-- /opt/local/include
− stack-8.0.yaml 
@@ -1,16 +0,0 @@-resolver: lts-9.20-packages:-- '.'-extra-deps:-    - QuickCheck-2.10-    - lockfree-queue-0.2.3.1-    - SDL-0.6.5.1-    - gauge-0.2.4-    - basement-0.0.4-    - deepseq-1.4.4.0-flags: {}-extra-package-dbs: []-rebuild-ghc-options: true-# For mac ports installed SDL library on Mac OS X-#extra-include-dirs:-#- /opt/local/include
stack.yaml view
@@ -1,13 +1,14 @@-resolver: lts-13.13+resolver: lts-13.25 packages: - '.' extra-deps:     - SDL-0.6.6.0-    - Chart-1.9-    - Chart-diagrams-1.9-    - SVGFonts-1.6.0.3+    - Chart-1.9.1+    - Chart-diagrams-1.9.2     - bench-show-0.2.2+    - inspection-testing-0.4.2.1 +#allow-newer: true flags: {} extra-package-dbs: [] rebuild-ghc-options: true
streamly.cabal view
@@ -1,61 +1,72 @@+cabal-version:      2.2 name:               streamly-version:            0.6.1+version:            0.7.0 synopsis:           Beautiful Streaming, Concurrent and Reactive Composition description:-  Streamly, short for streaming concurrently, provides monadic streams, with a-  simple API, almost identical to standard lists, and an in-built support for-  concurrency.  By using stream-style combinators on stream composition,-  streams can be generated, merged, chained, mapped, zipped, and consumed-  concurrently – providing a generalized high level programming framework-  unifying streaming and concurrency. Controlled concurrency allows even-  infinite streams to be evaluated concurrently.  Concurrency is auto scaled-  based on feedback from the stream consumer.  The programmer does not have to-  be aware of threads, locking or synchronization to write scalable concurrent-  programs.+  Streamly is a framework for writing programs in a high level, declarative+  data flow programming paradigm. It provides a simple API, very close to+  standard Haskell lists.  A program is expressed as a composition of data+  processing pipes, generally known as streams.  Streams can be generated,+  merged, chained, mapped, zipped, and consumed concurrently – enabling a high+  level, declarative yet concurrent composition of programs.  Programs can be+  concurrent or non-concurrent without any significant change.  Concurrency is+  auto scaled based on consumption rate.  Programmers do not have to be aware+  of threads, locking or synchronization to write scalable concurrent programs.+  Streamly provides C like performance, orders of magnitude better compared to+  existing streaming libraries.   .-  The basic streaming functionality of streamly is equivalent to that provided by-  streaming libraries like+  Streamly is designed to express the full spectrum of programs with highest+  performance. Do not think that if you are writing a small and simple program+  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. +  .+  Streamly covers the functionality provided by Haskell lists as well as the+  functionality provided by streaming libraries like   <https://hackage.haskell.org/package/streaming streaming>,   <https://hackage.haskell.org/package/pipes pipes>, and-  <https://hackage.haskell.org/package/conduit conduit>.-  In addition to providing streaming functionality, streamly subsumes the+  <https://hackage.haskell.org/package/conduit conduit> with a simpler API and+  better performance. Streamly provides+  advanced stream composition including various ways of appending, merging,+  zipping, splitting, grouping, distributing, partitioning and unzipping of+  streams with true streaming and with concurrency. Streamly subsumes the   functionality of list transformer libraries like @pipes@ or   <https://hackage.haskell.org/package/list-t list-t> and also the logic-  programming library <https://hackage.haskell.org/package/logict logict>. On-  the concurrency side, it subsumes the functionality of the-  <https://hackage.haskell.org/package/async async> package. Because it-  supports streaming with concurrency we can write FRP applications similar in-  concept to <https://hackage.haskell.org/package/Yampa Yampa> or-  <https://hackage.haskell.org/package/reflex reflex>.-  .-  For file IO, currently the library provides only one API to stream the lines-  in the file as Strings.  Future versions will provide better streaming file-  IO options.  Streamly interoperates with the popular streaming libraries, see-  the interoperation section in "Streamly.Tutorial".+  programming library <https://hackage.haskell.org/package/logict logict>.+  The grouping, splitting and windowing combinators in streamly can be compared+  to the window operators in <https://flink.apache.org/ Apache Flink>.+  However, compared to Flink streamly has a pure functional, succinct and+  expressive API.   .-  Why use streamly?+  The concurrency capabilities of streamly are much more advanced and powerful+  compared to the basic concurrency functionality provided by the+  <https://hackage.haskell.org/package/async async> package.  Streamly is a+  first class reactive programming library.  If you are familiar with+  <http://reactivex.io/ Reactive Extensions> you will find that it is very+  similar.  For most RxJs combinators you can find or write corresponding ones+  in streamly. Streamly can be used as an alternative to+  <https://hackage.haskell.org/package/Yampa Yampa> or+  <https://hackage.haskell.org/package/reflex reflex> as well.   .-  * /Simplicity/: Simple list like streaming API, if you know how to use lists-    then you know how to use streamly. This library is built with simplicity-    and ease of use as a primary design goal.-  * /Concurrency/: Simple, powerful, and scalable concurrency.  Concurrency is-    built-in, and not intrusive, concurrent programs are written exactly the-    same way as non-concurrent ones.-  * /Generality/: Unifies functionality provided by several disparate packages-    (streaming, concurrency, list transformer, logic programming, reactive-    programming) in a concise API.-  * /Performance/: Streamly is designed for high performance.-    It employs stream fusion optimizations for best possible performance.-    Serial peformance is equivalent to the venerable `vector` library in most-    cases and even better in some cases. Concurrent performance is unbeatable.-    See-    <https://github.com/composewell/streaming-benchmarks streaming-benchmarks>-    for a comparison of popular streaming libraries on micro-benchmarks.+  Streamly focuses on practical engineering with high performance. From well+  written streamly programs one can expect performance competitive to C.  High+  performance streaming eliminates the need for string and text libraries like+  <https://hackage.haskell.org/package/bytestring bytestring>,+  <https://hackage.haskell.org/package/text text> and their lazy and strict+  flavors. The confusion and cognitive overhead arising from different+  string types is eliminated. The two fundamental types in streamly are arrays+  for storage and streams for processing. Strings and text are simply streams+  or arrays of 'Char' as they should be. Arrays in streamly have performance+  at par with the vector library.   .   Where to find more information:   .   * /Quick Overview/: <src/README.md 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+    streaming libraries   * /Reference Documentation/: Haddock documentation for the respective modules   * /Examples/: <src/examples examples directory> in the package   * /Guides/: <src/docs docs directory> in the package, for documentation on@@ -63,53 +74,88 @@     cases.   * <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 bug-reports:         https://github.com/composewell/streamly/issues-license:             BSD3+license:             BSD-3-Clause license-file:        LICENSE tested-with:         GHC==7.10.3                    , GHC==8.0.2                    , GHC==8.4.4-                   , GHC==8.6.4+                   , GHC==8.6.5+                   , GHC==8.8.1 author:              Harendra Kumar-maintainer:          harendra.kumar@gmail.com+maintainer:          streamly@composewell.com copyright:           2017 Harendra Kumar category:            Control, Concurrency, Streaming, Reactivity stability:           Experimental build-type:          Configure-cabal-version:       >= 1.10  extra-source-files:     Changelog.md+    credits/*.md+    credits/base-4.12.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     README.md     docs/streamly-vs-async.md+    docs/streamly-vs-lists.md     docs/transformers.md     bench.sh-    stack-7.10.yaml-    stack-8.0.yaml     stack.yaml     src/Streamly/Streams/Instances.hs     src/Streamly/Streams/inline.hs     configure.ac     configure-    src/Streamly/Time/config.h.in+    src/Streamly/Internal/Data/Time/config.h.in  extra-tmp-files:     config.log     config.status     autom4te.cache-    src/Streamly/Time/config.h+    src/Streamly/Internal/Data/Time/config.h  source-repository head     type: git     location: https://github.com/composewell/streamly +flag benchmark+  description: Benchmark build+  manual: True+  default: False++flag inspection+  description: Enable inspection testing+  manual: True+  default: False++flag debug+  description: Debug build with asserts enabled+  manual: True+  default: False+ flag dev   description: Development build   manual: True   default: False +flag has-llvm+  description: Use llvm backend for better performance+  manual: True+  default: False+ flag no-charts   description: Disable chart generation   manual: True@@ -136,28 +182,105 @@   default: False  -------------------------------------------------------------------------------+-- Common stanzas+-------------------------------------------------------------------------------++common compile-options+    default-language: Haskell2010+    if flag(streamk)+      cpp-options:    -DUSE_STREAMK_ONLY++    if flag(no-fusion)+      cpp-options:    -DDISABLE_FUSION++    if flag(dev)+      cpp-options:    -DDEVBUILD++    if flag(inspection)+      cpp-options:    -DINSPECTION++    ghc-options:      -Wall++    if flag(has-llvm)+      ghc-options: -fllvm++    if flag(dev)+      ghc-options:    -Wmissed-specialisations+                      -Wall-missed-specialisations++    if flag(dev) || flag(debug)+      ghc-options:    -fno-ignore-asserts++    if impl(ghc >= 8.0)+      ghc-options:    -Wcompat+                      -Wunrecognised-warning-flags+                      -Widentities+                      -Wincomplete-record-updates+                      -Wincomplete-uni-patterns+                      -Wredundant-constraints+                      -Wnoncanonical-monad-instances++common optimization-options+  ghc-options: -O2+               -fspec-constr-recursive=16+               -fmax-worker-args=16++common threading-options+  ghc-options:  -threaded+                -with-rtsopts=-N++-- We need optimization options here to optimize internal (non-inlined)+-- versions of functions. Also, we have some benchmarking inspection tests+-- part of the library when built with --benchmarks flag. Thos tests fail+-- if we do not use optimization options here. It was observed that due to+-- -O2 here some concurrent/nested benchmarks improved and others regressed.+-- We can investigate a bit more here why the regression occurred.+common lib-options+  import: compile-options, optimization-options++-- Compilation for coverage builds on CI machines takes too long without -O0+-- XXX we should use coverage flag for that, -O0 may take too long to run tests+-- in general.+common test-options+  import: compile-options, threading-options+  ghc-options:  -O0+                -fno-ignore-asserts++-- Used by maxrate test, benchmarks and executables+common exe-options+  import: compile-options, optimization-options, threading-options++-- Some benchmarks are threaded some are not+common bench-options+  import: compile-options, optimization-options+  ghc-options: -with-rtsopts "-T"++------------------------------------------------------------------------------- -- Library -------------------------------------------------------------------------------  library+    import: lib-options     js-sources: jsbits/clock.js-    include-dirs:     src/Streamly/Time+    include-dirs:     src/Streamly/Internal/Data/Time                     , src/Streamly/Streams     if os(windows)-      c-sources:     src/Streamly/Time/Windows.c+      c-sources:     src/Streamly/Internal/Data/Time/Windows.c     if os(darwin)-      c-sources:     src/Streamly/Time/Darwin.c+      c-sources:     src/Streamly/Internal/Data/Time/Darwin.c     hs-source-dirs:    src-    other-modules:     Streamly.Atomics-                     , Streamly.SVar-                     , Streamly.Time.Units-                     , Streamly.Time.Clock+    other-modules:+                    -- Memory storage+                       Streamly.Memory.Malloc+                     , Streamly.Memory.Ring                      -- Base streams                      , Streamly.Streams.StreamK.Type                      , Streamly.Streams.StreamK-                     , Streamly.Streams.StreamD.Type+                     , Streamly.Streams.StreamDK.Type+                     , Streamly.Streams.StreamDK                      , Streamly.Streams.StreamD+                     , Streamly.Streams.Enumeration                      , Streamly.Streams.Prelude                      -- Higher level streams@@ -168,44 +291,70 @@                      , Streamly.Streams.Ahead                      , Streamly.Streams.Zip                      , Streamly.Streams.Combinators-                     , Streamly.List-                     , Streamly.String-                     , Streamly.Enumeration +                     , Streamly.FileSystem.IOVec+                     , Streamly.FileSystem.FDIO+                     , Streamly.FileSystem.FD+     exposed-modules:   Streamly.Prelude-                     , Streamly.Time                      , Streamly-                     , Streamly.Tutorial-                     , Streamly.Internal+                     , Streamly.Data.Fold+                     , Streamly.Data.Unfold+                     , Streamly.Data.Unicode.Stream -    default-language: Haskell2010-    ghc-options:      -Wall -fspec-constr-recursive=10+                    -- IO devices+                     , Streamly.Memory.Array+                     , Streamly.FileSystem.Handle -    if flag(streamk)-      cpp-options:    -DUSE_STREAMK_ONLY+                     , Streamly.Tutorial -    if flag(no-fusion)-      cpp-options:    -DDISABLE_FUSION+                     -- Internal modules+                     , 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.Memory.Array.Types+                     , Streamly.Internal.Memory.Array+                     , Streamly.Internal.Memory.ArrayStream+                     , Streamly.Internal.Data.Fold.Types+                     , Streamly.Internal.Data.Fold+                     , Streamly.Internal.Data.Sink.Types+                     , Streamly.Internal.Data.Sink+                     , Streamly.Internal.Data.Unfold.Types+                     , Streamly.Internal.Data.Unfold+                     , Streamly.Internal.Data.Pipe.Types+                     , Streamly.Internal.Data.Pipe+                     , Streamly.Internal.Data.List+                     , Streamly.Internal.FileSystem.Handle+                     , Streamly.Internal.FileSystem.Dir+                     , Streamly.Internal.FileSystem.File+                     , Streamly.Internal.Data.Unicode.Stream+                     , Streamly.Internal.Data.Unicode.Char+                     , Streamly.Internal.Memory.Unicode.Array+                     , Streamly.Internal.Prelude+    if !impl(ghcjs)+       exposed-modules:+                       Streamly.Network.Socket+                     , Streamly.Network.Inet.TCP -    if flag(dev)-      ghc-options:    -Wmissed-specialisations-                      -Wall-missed-specialisations-                      -fno-ignore-asserts-    if impl(ghc >= 8.0)-      ghc-options:    -Wcompat-                      -Wunrecognised-warning-flags-                      -Widentities-                      -Wincomplete-record-updates-                      -Wincomplete-uni-patterns-                      -Wredundant-constraints-                      -Wnoncanonical-monad-instances-                      -Wnoncanonical-monadfail-instances+                     , 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-                     , deepseq           >= 1.4.3 && < 1.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                      -- concurrency                      , atomic-primops    >= 0.8   && < 0.9@@ -218,6 +367,13 @@                      , 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++  if !impl(ghcjs)+    build-depends:+                     network           >= 2.6   && < 4   if impl(ghc < 8.0)     build-depends:         semigroups    >= 0.18   && < 0.19@@ -226,105 +382,51 @@ -- Test suites ------------------------------------------------------------------------------- --- Compilation for coverage builds on CI machines takes too long without -O0- test-suite test+  import: test-options   type: exitcode-stdio-1.0   main-is: Main.hs   js-sources: jsbits/clock.js   hs-source-dirs: test-  ghc-options:  -O0 -Wall -threaded -with-rtsopts=-N -fno-ignore-asserts-  if flag(dev)-    cpp-options:    -DDEVBUILD-    ghc-options:    -Wmissed-specialisations-                    -Wall-missed-specialisations-  if impl(ghc >= 8.0)-    ghc-options:    -Wcompat-                    -Wunrecognised-warning-flags-                    -Widentities-                    -Wincomplete-record-updates-                    -Wincomplete-uni-patterns-                    -Wredundant-constraints-                    -Wnoncanonical-monad-instances-                    -Wnoncanonical-monadfail-instances   build-depends:       streamly     , base              >= 4.8   && < 5     , hspec             >= 2.0   && < 3-    , containers        >= 0.5   && < 0.7+    , containers        >= 0.5.8.2   && < 0.7     , transformers      >= 0.4   && < 0.6     , mtl               >= 2.2   && < 3     , exceptions        >= 0.8   && < 0.11   default-language: Haskell2010 --- test-suite pure-streams-base---   type: exitcode-stdio-1.0---   main-is: PureStreams.hs---   hs-source-dirs: test---   ghc-options:  -O0 -Wall -threaded -with-rtsopts=-N -fno-ignore-asserts---   if flag(dev)---     cpp-options:    -DDEVBUILD---     ghc-options:    -Wmissed-specialisations---                     -Wall-missed-specialisations---   if impl(ghc >= 8.0)---     ghc-options:    -Wcompat---                     -Wunrecognised-warning-flags---                     -Widentities---                     -Wincomplete-record-updates---                     -Wincomplete-uni-patterns---                     -Wredundant-constraints---                     -Wnoncanonical-monad-instances---                     -Wnoncanonical-monadfail-instances---   build-depends:---       streamly---     , base              >= 4.8   && < 5---     , hspec             >= 2.0   && < 3---   default-language: Haskell2010--- --- test-suite pure-streams-streamly---   type: exitcode-stdio-1.0---   main-is: PureStreams.hs---   hs-source-dirs: test---   cpp-options:  -DUSE_STREAMLY_LIST---   ghc-options:  -O0 -Wall -threaded -with-rtsopts=-N -fno-ignore-asserts---   if flag(dev)---     cpp-options:    -DDEVBUILD---     ghc-options:    -Wmissed-specialisations---                     -Wall-missed-specialisations---   if impl(ghc >= 8.0)---     ghc-options:    -Wcompat---                     -Wunrecognised-warning-flags---                     -Widentities---                     -Wincomplete-record-updates---                     -Wincomplete-uni-patterns---                     -Wredundant-constraints---                     -Wnoncanonical-monad-instances---                     -Wnoncanonical-monadfail-instances---   build-depends:---       streamly---     , base              >= 4.8   && < 5---     , hspec             >= 2.0   && < 3---   default-language: Haskell2010+test-suite pure-streams-base+  import: test-options+  type: exitcode-stdio-1.0+  main-is: PureStreams.hs+  hs-source-dirs: test+  build-depends:+      streamly+    , base              >= 4.8   && < 5+    , hspec             >= 2.0   && < 3+  default-language: Haskell2010 +test-suite pure-streams-streamly+  import: test-options+  type: exitcode-stdio-1.0+  main-is: PureStreams.hs+  hs-source-dirs: test+  cpp-options:  -DUSE_STREAMLY_LIST+  build-depends:+      streamly+    , base              >= 4.8   && < 5+    , hspec             >= 2.0   && < 3+  default-language: Haskell2010+ test-suite properties+  import: test-options   type: exitcode-stdio-1.0   main-is: Prop.hs   js-sources: jsbits/clock.js   hs-source-dirs: test-  ghc-options:  -fno-ignore-asserts -Wall -O0 -threaded -with-rtsopts=-N-  if flag(dev)-    cpp-options:    -DDEVBUILD-    ghc-options:    -Wmissed-specialisations-                    -Wall-missed-specialisations-  if impl(ghc >= 8.0)-    ghc-options:    -Wcompat-                    -Wunrecognised-warning-flags-                    -Widentities-                    -Wincomplete-record-updates-                    -Wincomplete-uni-patterns-                    -Wredundant-constraints-                    -Wnoncanonical-monad-instances-                    -Wnoncanonical-monadfail-instances   build-depends:       streamly     , base              >= 4.8   && < 5@@ -335,51 +437,83 @@         transformers  >= 0.4 && < 0.6   default-language: Haskell2010 +test-suite array-test+  import: test-options+  type: exitcode-stdio-1.0+  main-is: Arrays.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 string-test+  import: test-options+  type: exitcode-stdio-1.0+  main-is: String.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 maxrate+  import: exe-options   type: exitcode-stdio-1.0   default-language: Haskell2010   main-is: MaxRate.hs   js-sources: jsbits/clock.js   hs-source-dirs:  test-  ghc-options:  -fno-ignore-asserts -O2 -Wall -threaded -with-rtsopts=-N   if flag(dev)     buildable: True     build-Depends:           streamly         , base   >= 4.8   && < 5-        , clock  >= 0.7.1 && < 0.8+        , clock  >= 0.7.1 && < 0.9         , hspec  >= 2.0   && < 3         , random >= 1.0.0 && < 2   else     buildable: False  test-suite loops+  import: test-options   type: exitcode-stdio-1.0   default-language: Haskell2010   main-is: loops.hs   hs-source-dirs:  test-  ghc-options:  -fno-ignore-asserts -O2 -Wall -threaded -with-rtsopts=-N   build-Depends:       streamly     , base >= 4.8   && < 5  test-suite nested-loops+  import: test-options   type: exitcode-stdio-1.0   default-language: Haskell2010   main-is: nested-loops.hs   hs-source-dirs:  test-  ghc-options:  -fno-ignore-asserts -O2 -Wall -threaded -with-rtsopts=-N   build-Depends:       streamly     , base   >= 4.8   && < 5     , random >= 1.0.0 && < 2  test-suite parallel-loops+  import: test-options   type: exitcode-stdio-1.0   default-language: Haskell2010   main-is: parallel-loops.hs   hs-source-dirs:  test-  ghc-options:  -fno-ignore-asserts -O2 -Wall -threaded -with-rtsopts=-N   build-Depends:       streamly     , base   >= 4.8   && < 5@@ -390,114 +524,144 @@ -------------------------------------------------------------------------------  benchmark linear+  import: bench-options   type: exitcode-stdio-1.0   hs-source-dirs: benchmark   main-is: Linear.hs-  other-modules: LinearOps-  default-language: Haskell2010-  ghc-options:  -O2 -Wall -fspec-constr-recursive=10-  if flag(dev)-    ghc-options:    -Wmissed-specialisations-                    -Wall-missed-specialisations-                    -fno-ignore-asserts-  if impl(ghc >= 8.0)-    ghc-options:    -Wcompat-                    -Wunrecognised-warning-flags-                    -Widentities-                    -Wincomplete-record-updates-                    -Wincomplete-uni-patterns-                    -Wredundant-constraints-                    -Wnoncanonical-monad-instances-                    -Wnoncanonical-monadfail-instances-  build-depends:-      streamly-    , base                >= 4.8   && < 5-    , deepseq             >= 1.4.3 && < 1.5-    , random              >= 1.0   && < 2.0-    , gauge               >= 0.2.4 && < 0.3+  if flag(benchmark)+    buildable: True+    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  benchmark linear-async+  import: bench-options+  cpp-options: -DLINEAR_ASYNC   type: exitcode-stdio-1.0   hs-source-dirs: benchmark   main-is: LinearAsync.hs-  other-modules: LinearOps-  default-language: Haskell2010-  ghc-options:  -O2 -Wall -fspec-constr-recursive=10-  cpp-options: -DLINEAR_ASYNC-  if flag(dev)-    ghc-options:    -Wmissed-specialisations-                    -Wall-missed-specialisations-                    -fno-ignore-asserts-  if impl(ghc >= 8.0)-    ghc-options:    -Wcompat-                    -Wunrecognised-warning-flags-                    -Widentities-                    -Wincomplete-record-updates-                    -Wincomplete-uni-patterns-                    -Wredundant-constraints-                    -Wnoncanonical-monad-instances-                    -Wnoncanonical-monadfail-instances+  if flag(benchmark)+    buildable: True+    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++benchmark linear-rate+  import: bench-options+  type: exitcode-stdio-1.0+  hs-source-dirs: benchmark+  main-is: LinearRate.hs+  if flag(benchmark)+    buildable: True+    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++benchmark nested+  import: bench-options+  type: exitcode-stdio-1.0+  hs-source-dirs: benchmark+  main-is: Nested.hs+  other-modules: NestedOps   build-depends:       streamly     , base                >= 4.8   && < 5-    , deepseq             >= 1.4.3 && < 1.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 linear-rate+benchmark nestedUnfold+  import: bench-options   type: exitcode-stdio-1.0   hs-source-dirs: benchmark-  main-is: LinearRate.hs-  other-modules: LinearOps-  default-language: Haskell2010-  ghc-options:  -O2 -Wall -fspec-constr-recursive=10-  if flag(dev)-    ghc-options:    -Wmissed-specialisations-                    -Wall-missed-specialisations-                    -fno-ignore-asserts-  if impl(ghc >= 8.0)-    ghc-options:    -Wcompat-                    -Wunrecognised-warning-flags-                    -Widentities-                    -Wincomplete-record-updates-                    -Wincomplete-uni-patterns-                    -Wredundant-constraints-                    -Wnoncanonical-monad-instances-                    -Wnoncanonical-monadfail-instances+  main-is: NestedUnfold.hs+  other-modules: NestedUnfoldOps   build-depends:       streamly     , base                >= 4.8   && < 5-    , deepseq             >= 1.4.3 && < 1.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 nested+benchmark array+  import: bench-options   type: exitcode-stdio-1.0   hs-source-dirs: benchmark-  main-is: Nested.hs-  other-modules: NestedOps-  default-language: Haskell2010-  ghc-options:  -O2 -Wall -fspec-constr-recursive=10-  if flag(dev)-    ghc-options:    -Wmissed-specialisations-                    -Wall-missed-specialisations-                    -fno-ignore-asserts-  if impl(ghc >= 8.0)-    ghc-options:    -Wcompat-                    -Wunrecognised-warning-flags-                    -Widentities-                    -Wincomplete-record-updates-                    -Wincomplete-uni-patterns-                    -Wredundant-constraints-                    -Wnoncanonical-monad-instances-                    -Wnoncanonical-monadfail-instances+  main-is: Array.hs+  other-modules: ArrayOps   build-depends:       streamly     , base                >= 4.8   && < 5-    , deepseq             >= 1.4.3 && < 1.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 fileio+  import: bench-options+  type: exitcode-stdio-1.0+  -- A value of 400 works better for some benchmarks, however, it takes+  -- extraordinary amount of time to compile with that.+  -- ghc-options: -funfolding-use-threshold=150+  hs-source-dirs: benchmark+  main-is: FileIO.hs+  if flag(benchmark)+    buildable: True+    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++benchmark concurrent+  import: bench-options+  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+ ------------------------------------------------------------------------------- -- Internal benchmarks for unexposed modules -------------------------------------------------------------------------------@@ -506,54 +670,43 @@ -- way to use unexposed modules from the library.  benchmark base+  import: bench-options   type: exitcode-stdio-1.0-  include-dirs:     src/Streamly/Time+  include-dirs:     src/Streamly/Internal/Data/Time                   , src/Streamly/Streams   if os(windows)-    c-sources:     src/Streamly/Time/Windows.c+    c-sources:     src/Streamly/Internal/Data/Time/Windows.c   if os(darwin)-    c-sources:     src/Streamly/Time/Darwin.c+    c-sources:     src/Streamly/Internal/Data/Time/Darwin.c   hs-source-dirs: benchmark, src   main-is: BaseStreams.hs-  other-modules:     Streamly.Atomics-                   , Streamly.Time.Units-                   , Streamly.Time.Clock-                   , Streamly.SVar+  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.Type                    , Streamly.Streams.StreamD                    , Streamly.Streams.Prelude+                   , Streamly.FileSystem.IOVec                     , StreamDOps                    , StreamKOps--  default-language: Haskell2010-  ghc-options:  -O2 -Wall -fspec-constr-recursive=10-  if flag(dev)-    ghc-options:    -Wmissed-specialisations-                    -Wall-missed-specialisations-                    -fno-ignore-asserts-  if impl(ghc >= 8.0)-    ghc-options:    -Wcompat-                    -Wunrecognised-warning-flags-                    -Widentities-                    -Wincomplete-record-updates-                    -Wincomplete-uni-patterns-                    -Wredundant-constraints-                    -Wnoncanonical-monad-instances-                    -Wnoncanonical-monadfail-instances+                   , StreamDKOps    if flag(dev)     buildable: True     build-depends:         base              >= 4.8   && < 5-      , deepseq           >= 1.4.3 && < 1.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   && < 0.7+      , containers        >= 0.5.8.2   && < 0.7       , heaps             >= 0.3   && < 0.4        -- concurrency@@ -573,32 +726,32 @@     buildable: False  executable nano-bench+  import: bench-options   hs-source-dirs: benchmark, src-  include-dirs:     src/Streamly/Time+  include-dirs:     src/Streamly/Internal/Data/Time                   , src/Streamly/Streams   if os(windows)-    c-sources:     src/Streamly/Time/Windows.c+    c-sources:     src/Streamly/Internal/Data/Time/Windows.c   if os(darwin)-    c-sources:     src/Streamly/Time/Darwin.c+    c-sources:     src/Streamly/Internal/Data/Time/Darwin.c   main-is: NanoBenchmarks.hs-  other-modules:     Streamly.Atomics-                   , Streamly.Time.Units-                   , Streamly.Time.Clock-                   , Streamly.SVar+  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.Streams.StreamD.Type+                   , Streamly.FileSystem.IOVec                    , Streamly.Streams.StreamD-  default-language: Haskell2010-  ghc-options:  -O2 -Wall-   if flag(dev)     buildable: True     build-depends:          base              >= 4.8   && < 5        , gauge             >= 0.2.4 && < 0.3        , ghc-prim          >= 0.2   && < 0.6-       , containers        >= 0.5   && < 0.7+       , containers        >= 0.5.8.2   && < 0.7+       , deepseq           >= 1.4.1 && < 1.5        , heaps             >= 0.3   && < 0.4        , random            >= 1.0   && < 2.0 @@ -610,15 +763,15 @@        , monad-control     >= 1.0   && < 2        , mtl               >= 2.2   && < 3        , transformers      >= 0.4   && < 0.6+       , transformers-base >= 0.4   && < 0.5   else     buildable: False  executable adaptive+  import: bench-options   hs-source-dirs: benchmark   main-is: Adaptive.hs   default-language: Haskell2010-  ghc-options:  -O2 -Wall-   if flag(dev)     buildable: True     build-depends:@@ -631,13 +784,14 @@  executable chart   default-language: Haskell2010+  ghc-options: -Wall   hs-source-dirs: benchmark   main-is: Chart.hs   if flag(dev) && !flag(no-charts) && !impl(ghcjs)     buildable: True     build-Depends:         base >= 4.8 && < 5-      , bench-show >= 0.2 && < 0.3+      , bench-show >= 0.3 && < 0.4       , split       , transformers >= 0.4   && < 0.6   else@@ -648,10 +802,9 @@ -------------------------------------------------------------------------------  executable SearchQuery-  default-language: Haskell2010+  import: exe-options   main-is: SearchQuery.hs   hs-source-dirs:  examples-  ghc-options: -Wall   if (flag(examples) || flag(examples-sdl)) && !impl(ghcjs)     buildable: True     build-Depends:@@ -662,16 +815,15 @@     buildable: False  executable ListDir-  default-language: Haskell2010+  import: exe-options   main-is: ListDir.hs   hs-source-dirs:  examples-  ghc-options: -Wall   if flag(examples) || flag(examples-sdl)     buildable: True     build-Depends:         streamly       , base    >= 4.8   && < 5-      , path-io >= 0.1.0 && < 1.5+      , directory >= 1.3 && < 1.4     if impl(ghc < 8.0)       build-depends:           transformers  >= 0.4    && < 0.6@@ -679,10 +831,9 @@     buildable: False  executable MergeSort-  default-language: Haskell2010+  import: exe-options   main-is: MergeSort.hs   hs-source-dirs:  examples-  ghc-options: -Wall   if flag(examples) || flag(examples-sdl)     buildable: True     build-Depends:@@ -693,10 +844,9 @@     buildable: False  executable AcidRain-  default-language: Haskell2010+  import: exe-options   main-is: AcidRain.hs   hs-source-dirs:  examples-  ghc-options: -Wall   if flag(examples) || flag(examples-sdl)     buildable: True     build-Depends:@@ -711,10 +861,9 @@     buildable: False  executable CirclingSquare-  default-language: Haskell2010+  import: exe-options   main-is: CirclingSquare.hs   hs-source-dirs:  examples-  ghc-options: -Wall   if flag(examples-sdl)     buildable: True     build-Depends:@@ -725,10 +874,9 @@     buildable: False  executable ControlFlow-  default-language: Haskell2010+  import: exe-options   main-is: ControlFlow.hs   hs-source-dirs:  examples-  ghc-options: -Wall   if flag(examples) || flag(examples-sdl)     buildable: True     build-Depends:@@ -740,5 +888,112 @@     if impl(ghc < 8.0)       build-depends:           semigroups    >= 0.18   && < 0.19+  else+    buildable: False++executable HandleIO+  import: exe-options+  main-is: HandleIO.hs+  hs-source-dirs:  examples+  if flag(examples) || flag(examples-sdl)+    buildable: True+    build-Depends:+        streamly+      , base              >= 4.8   && < 5+  else+    buildable: False++executable FileIOExamples+  import: exe-options+  main-is: FileIOExamples.hs+  hs-source-dirs:  examples+  if flag(examples) || flag(examples-sdl)+    buildable: True+    build-Depends:+        streamly+      , base              >= 4.8   && < 5+  else+    buildable: False++executable EchoServer+  import: exe-options+  main-is: EchoServer.hs+  hs-source-dirs:  examples+  if (flag(examples) || flag(examples-sdl)) && !impl(ghcjs)+    buildable: True+    build-Depends:+        streamly+      , base              >= 4.8   && < 5+      , network           >= 2.6   && < 4+    if impl(ghc < 8.0)+      build-depends:+          transformers  >= 0.4 && < 0.6+  else+    buildable: False++executable FileSinkServer+  import: exe-options+  main-is: FileSinkServer.hs+  hs-source-dirs:  examples+  if (flag(examples) || flag(examples-sdl)) && !impl(ghcjs)+    buildable: True+    build-Depends:+        streamly+      , base              >= 4.8   && < 5+      , network           >= 2.6   && < 4+    if impl(ghc < 8.0)+      build-depends:+          transformers  >= 0.4 && < 0.6+  else+    buildable: False++executable FromFileClient+  import: exe-options+  main-is: FromFileClient.hs+  hs-source-dirs:  examples+  if (flag(examples) || flag(examples-sdl)) && !impl(ghcjs)+    buildable: True+    build-Depends:+        streamly+      , base              >= 4.8   && < 5+  else+    buildable: False++executable WordClassifier+  import: exe-options+  main-is: WordClassifier.hs+  hs-source-dirs:  examples+  if (flag(examples) || flag(examples-sdl)) && !impl(ghcjs)+    buildable: True+    build-Depends:+        streamly+      , base                 >= 4.8   && < 5+      , hashable             >= 1.2   && < 1.4+      , unordered-containers >= 0.2   && < 0.3+  else+    buildable: False++executable WordCount+  import: exe-options+  main-is: WordCount.hs+  hs-source-dirs:  examples+  if (flag(examples) || flag(examples-sdl)) && !impl(ghcjs)+    buildable: True+    build-Depends:+        streamly+      , base                 >= 4.8   && < 5+      , vector               >= 0.12  && < 0.13+  else+    buildable: False++executable CamelCase+  import: exe-options+  main-is: CamelCase.hs+  hs-source-dirs:  examples+  if (flag(examples) || flag(examples-sdl)) && !impl(ghcjs)+    buildable: True+    build-Depends:+        streamly+      , base                 >= 4.8   && < 5   else     buildable: False
+ test/Arrays.hs view
@@ -0,0 +1,115 @@+{-# 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/Main.hs view
@@ -22,7 +22,9 @@  import Streamly import Streamly.Prelude ((.:), nil)+import qualified Streamly as S import qualified Streamly.Prelude as S+import qualified Streamly.Internal.Prelude as IP  singleton :: IsStream t => a -> t m a singleton a = a .: nil@@ -153,7 +155,7 @@     -> IO () checkCleanup d t op = do     r <- newIORef (-1 :: Int)-    runStream . serially $ do+    S.drain . serially $ do         _ <- t $ op $ delay r 0 S.|: delay r 1 S.|: delay r 2 S.|: S.nil         return ()     performMajorGC@@ -193,9 +195,9 @@         -- XXX move these to property tests         -- XXX use an IORef to store and check the side effects         it "simple serially" $-            (runStream . serially) (return (0 :: Int)) `shouldReturn` ()+            (S.drain . serially) (return (0 :: Int)) `shouldReturn` ()         it "simple serially with IO" $-            (runStream . serially) (S.yieldM $ putStrLn "hello") `shouldReturn` ()+            (S.drain . serially) (S.yieldM $ putStrLn "hello") `shouldReturn` ()      describe "Empty" $ -- do         it "Monoid - mempty" $@@ -487,18 +489,26 @@     it "takes n from stream of streams" (takeCombined 3 wAsyncly)      ----------------------------------------------------------------------------    -- Folds are strict enough+    -- Left folds are strict enough     --------------------------------------------------------------------------- +#ifdef DEVBUILD     it "foldx is strict enough" checkFoldxStrictness-    it "foldl' is strict enough" checkFoldl'Strictness     it "scanx is strict enough" checkScanxStrictness-    it "scanl' is strict enough" checkScanl'Strictness     it "foldxM is strict enough" (checkFoldMStrictness foldxMStrictCheck)+#endif+    it "foldl' is strict enough" checkFoldl'Strictness+    it "scanl' is strict enough" checkScanl'Strictness     it "foldlM' is strict enough" (checkFoldMStrictness foldlM'StrictCheck)     it "scanlM' is strict enough" (checkScanlMStrictness scanlM'StrictCheck)      ---------------------------------------------------------------------------+    -- Right folds are lazy enough+    ---------------------------------------------------------------------------++    it "foldrM is lazy enough" checkFoldrLaziness++    ---------------------------------------------------------------------------     -- Monadic state snapshot in concurrent tasks     --------------------------------------------------------------------------- @@ -535,12 +545,12 @@     ---------------------------------------------------------------------------      it "asyncly crosses thread limit (2000 threads)" $-        runStream (asyncly $ fold $+        S.drain (asyncly $ fold $                    replicate 2000 $ S.yieldM $ threadDelay 1000000)         `shouldReturn` ()      it "aheadly crosses thread limit (4000 threads)" $-        runStream (aheadly $ fold $+        S.drain (aheadly $ fold $                    replicate 4000 $ S.yieldM $ threadDelay 1000000)         `shouldReturn` () @@ -590,7 +600,7 @@        , MonadState Int (t (StateT Int IO))        )     => (t (StateT Int IO) () -> SerialT (StateT Int IO) ()) -> IO ()-monadicStateSnapshot t = void $ runStateT (runStream $ t stateComp) 0+monadicStateSnapshot t = void $ runStateT (S.drain $ t stateComp) 0  stateCompOp     :: (   AsyncT (StateT Int IO) ()@@ -613,7 +623,7 @@         -> AsyncT (StateT Int IO) ()        )     -> IO ()-monadicStateSnapshotOp op = void $ runStateT (runStream $ stateCompOp op) 0+monadicStateSnapshotOp op = void $ runStateT (S.drain $ stateCompOp op) 0  takeCombined :: (Monad m, Semigroup (t m Int), Show a, Eq a, IsStream t)     => Int -> (t m Int -> SerialT IO a) -> IO ()@@ -623,6 +633,23 @@             S.take n (constr ([] :: [Int]) <> constr ([] :: [Int]))     r `shouldBe` [] +checkFoldrLaziness :: IO ()+checkFoldrLaziness = do+    S.foldrM (\x xs -> if odd x then return True else xs)+             (return False) (S.fromList (2:4:5:undefined :: [Int]))+        `shouldReturn` True++    S.toList (IP.foldrS (\x xs -> if odd x then return True else xs)+                        (return False)+                        $ (S.fromList (2:4:5:undefined) :: SerialT IO Int))+        `shouldReturn` [True]++    S.toList (IP.foldrT (\x xs -> if odd x then return True else xs)+                        (return False)+                        $ (S.fromList (2:4:5:undefined) :: SerialT IO Int))+        `shouldReturn` [True]++#ifdef DEVBUILD checkFoldxStrictness :: IO () checkFoldxStrictness = do   let s = return (1 :: Int) `S.consM` error "failure"@@ -632,6 +659,7 @@             ErrorCall err -> return err             _ -> throw e)     `shouldReturn` "success"+#endif  checkFoldl'Strictness :: IO () checkFoldl'Strictness = do@@ -643,11 +671,12 @@             _ -> throw e)     `shouldReturn` "success" +#ifdef DEVBUILD checkScanxStrictness :: IO () checkScanxStrictness = do   let s = return (1 :: Int) `S.consM` error "failure"   catch-    (runStream (+    (S.drain (         S.scanx (\_ a ->                     if a == 1                     then error "success"@@ -660,12 +689,13 @@             ErrorCall err -> return err             _ -> throw e)     `shouldReturn` "success"+#endif  checkScanl'Strictness :: IO () checkScanl'Strictness = do     let s = return (1 :: Int) `S.consM` error "failure"     catch-        (runStream+        (S.drain              (S.scanl'                   (\_ a ->                        if a == 1@@ -683,8 +713,10 @@ foldlM'StrictCheck :: IORef Int -> SerialT IO Int -> IO () foldlM'StrictCheck ref = S.foldlM' (\_ _ -> writeIORef ref 1) () +#ifdef DEVBUILD foldxMStrictCheck :: IORef Int -> SerialT IO Int -> IO () foldxMStrictCheck ref = S.foldxM (\_ _ -> writeIORef ref 1) (return ()) return+#endif  checkFoldMStrictness :: (IORef Int -> SerialT IO Int -> IO ()) -> IO () checkFoldMStrictness f = do@@ -700,13 +732,13 @@ checkScanlMStrictness f = do   ref <- newIORef 0   let s = return 1 `S.consM` error "x"-  catch (runStream $ f ref s) (\(_ :: ErrorCall) -> return ())+  catch (S.drain $ f ref s) (\(_ :: ErrorCall) -> return ())   readIORef ref `shouldReturn` 1  takeInfinite :: IsStream t => (t IO Int -> SerialT IO Int) -> Spec takeInfinite t =     it "take 1" $-        runStream (t $ S.take 1 $ S.repeatM (print "hello" >> return (1::Int)))+        S.drain (t $ S.take 1 $ S.repeatM (print "hello" >> return (1::Int)))         `shouldReturn` ()  -- XXX need to test that we have promptly cleaned up everything after the error@@ -721,16 +753,16 @@ simpleMonadError = do {-     it "simple runExceptT" $ do-        (runExceptT $ runStream $ return ())+        (runExceptT $ S.drain $ return ())         `shouldReturn` (Right () :: Either String ())     it "simple runExceptT with error" $ do-        (runExceptT $ runStream $ throwError "E") `shouldReturn` Left "E"+        (runExceptT $ S.drain $ throwError "E") `shouldReturn` Left "E"         -}     it "simple try" $-        try (runStream $ return ())+        try (S.drain $ return ())         `shouldReturn` (Right () :: Either ExampleException ())     it "simple try with throw error" $-        try (runStream $ throwM $ ExampleException "E")+        try (S.drain $ throwM $ ExampleException "E")         `shouldReturn` (Left (ExampleException "E") :: Either ExampleException ())  composeWithMonadThrow@@ -768,8 +800,8 @@      oneLevelNestedProduct desc t1 =         it ("One level nested product" <> desc) $ do-            let s1 = t $ foldMapWith (<>) return [1..4]-                s2 = t1 $ foldMapWith (<>) return [5..8]+            let s1 = t $ S.foldMapWith (<>) return [1..4]+                s2 = t1 $ S.foldMapWith (<>) return [5..8]             try $ tl (do                 x <- adapt s1                 y <- s2@@ -794,8 +826,8 @@  nestTwoSerial :: Expectation nestTwoSerial =-    let s1 = foldMapWith (<>) return [1..4]-        s2 = foldMapWith (<>) return [5..8]+    let s1 = S.foldMapWith (<>) return [1..4]+        s2 = S.foldMapWith (<>) return [5..8]     in toListSerial (do         x <- s1         y <- s2@@ -804,8 +836,8 @@  nestTwoAhead :: Expectation nestTwoAhead =-    let s1 = foldMapWith (<>) return [1..4]-        s2 = foldMapWith (<>) return [5..8]+    let s1 = S.foldMapWith (<>) return [1..4]+        s2 = S.foldMapWith (<>) return [5..8]     in (S.toList . aheadly) (do         x <- s1         y <- s2@@ -814,22 +846,22 @@  nestTwoSerialApp :: Expectation nestTwoSerialApp =-    let s1 = foldMapWith (<>) return [1..4]-        s2 = foldMapWith (<>) return [5..8]+    let s1 = S.foldMapWith (<>) return [1..4]+        s2 = S.foldMapWith (<>) return [5..8]     in toListSerial ((+) <$> s1 <*> s2)         `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])  nestTwoAheadApp :: Expectation nestTwoAheadApp =-    let s1 = foldMapWith (<>) return [1..4]-        s2 = foldMapWith (<>) return [5..8]+    let s1 = S.foldMapWith (<>) return [1..4]+        s2 = S.foldMapWith (<>) return [5..8]     in (S.toList . aheadly) ((+) <$> s1 <*> s2)         `shouldReturn` ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])  nestTwoInterleaved :: Expectation nestTwoInterleaved =-    let s1 = foldMapWith (<>) return [1..4]-        s2 = foldMapWith (<>) return [5..8]+    let s1 = S.foldMapWith (<>) return [1..4]+        s2 = S.foldMapWith (<>) return [5..8]     in toListInterleaved (do         x <- s1         y <- s2@@ -838,15 +870,15 @@  nestTwoInterleavedApp :: Expectation nestTwoInterleavedApp =-    let s1 = foldMapWith (<>) return [1..4]-        s2 = foldMapWith (<>) return [5..8]+    let s1 = S.foldMapWith (<>) return [1..4]+        s2 = S.foldMapWith (<>) return [5..8]     in toListInterleaved ((+) <$> s1 <*> s2)         `shouldReturn` ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])  nestTwoAsync :: Expectation nestTwoAsync =-    let s1 = foldMapWith (<>) return [1..4]-        s2 = foldMapWith (<>) return [5..8]+    let s1 = S.foldMapWith (<>) return [1..4]+        s2 = S.foldMapWith (<>) return [5..8]     in sort <$> toListAsync (do         x <- s1         y <- s2@@ -855,15 +887,15 @@  nestTwoAsyncApp :: Expectation nestTwoAsyncApp =-    let s1 = foldMapWith (<>) return [1..4]-        s2 = foldMapWith (<>) return [5..8]+    let s1 = S.foldMapWith (<>) return [1..4]+        s2 = S.foldMapWith (<>) return [5..8]     in sort <$> toListAsync ((+) <$> s1 <*> s2)         `shouldReturn` sort ([6,7,8,9,7,8,9,10,8,9,10,11,9,10,11,12] :: [Int])  nestTwoWAsync :: Expectation nestTwoWAsync =-    let s1 = foldMapWith (<>) return [1..4]-        s2 = foldMapWith (<>) return [5..8]+    let s1 = S.foldMapWith (<>) return [1..4]+        s2 = S.foldMapWith (<>) return [5..8]     in sort <$> (S.toList . wAsyncly) (do         x <- s1         y <- s2@@ -872,8 +904,8 @@  nestTwoParallel :: Expectation nestTwoParallel =-    let s1 = foldMapWith (<>) return [1..4]-        s2 = foldMapWith (<>) return [5..8]+    let s1 = S.foldMapWith (<>) return [1..4]+        s2 = S.foldMapWith (<>) return [5..8]     in sort <$> (S.toList . parallely) (do         x <- s1         y <- s2@@ -882,15 +914,15 @@  nestTwoWAsyncApp :: Expectation nestTwoWAsyncApp =-    let s1 = foldMapWith (<>) return [1..4]-        s2 = foldMapWith (<>) return [5..8]+    let s1 = S.foldMapWith (<>) return [1..4]+        s2 = S.foldMapWith (<>) return [5..8]     in sort <$> (S.toList . wAsyncly) ((+) <$> s1 <*> s2)         `shouldReturn` sort ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int])  nestTwoParallelApp :: Expectation nestTwoParallelApp =-    let s1 = foldMapWith (<>) return [1..4]-        s2 = foldMapWith (<>) return [5..8]+    let s1 = S.foldMapWith (<>) return [1..4]+        s2 = S.foldMapWith (<>) return [5..8]     in sort <$> (S.toList . parallely) ((+) <$> s1 <*> s2)         `shouldReturn` sort ([6,7,7,8,8,8,9,9,9,9,10,10,10,11,11,12] :: [Int]) @@ -932,7 +964,7 @@         srt <$> tl (singleton 0 <> singleton 1)             `shouldReturn` [0, 1]     it "Compose many" $-        srt <$> tl (forEachWith (<>) [1..100] singleton)+        srt <$> tl (S.forEachWith (<>) [1..100] singleton)             `shouldReturn` [1..100]      -- These are not covered by the property tests@@ -962,7 +994,7 @@     -> (t2 IO Int -> t2 IO Int)     -> [[Int]] -> Spec composeAndComposeSimple t1 t2 answer = do-    let rfold = adapt . t2 . foldMapWith (<>) return+    let rfold = adapt . t2 . S.foldMapWith (<>) return     it "Compose right associated outer expr, right folded inner" $          (S.toList . t1) (rfold [1,2,3] <> (rfold [4,5,6] <> rfold [7,8,9]))             `shouldReturn` head answer@@ -1013,7 +1045,7 @@     -- XXX need a bind in the body of forEachWith instead of a simple return     it "Compose many (right fold) with bind" $         (sort <$> (S.toList . t1)-                    (adapt . t2 $ forEachWith (<>) [1..10 :: Int] return))+                    (adapt . t2 $ S.forEachWith (<>) [1..10 :: Int] return))             `shouldReturn` [1..10]      it "Compose many (left fold) with bind" $
test/Prop.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE TypeFamilies #-}  module Main (main) where @@ -10,25 +12,28 @@ import Control.Monad (when, forM_, replicateM, replicateM_) import Control.Monad.IO.Class (MonadIO(..)) import Data.Function ((&))-import Data.IORef (readIORef, modifyIORef, newIORef)+import Data.IORef (readIORef, modifyIORef, newIORef, modifyIORef', IORef) import Data.List        (sort, foldl', scanl', findIndices, findIndex, elemIndices,         elemIndex, find, insertBy, intersperse, foldl1', (\\),         maximumBy, minimumBy, deleteBy, isPrefixOf, isSubsequenceOf,-        stripPrefix)+        stripPrefix, intercalate) import Data.Maybe (mapMaybe) import GHC.Word (Word8)  import Test.Hspec.QuickCheck import Test.QuickCheck-       (counterexample, Property, withMaxSuccess, forAll, choose)+       (counterexample, Property, withMaxSuccess, forAll, choose, Gen,+       arbitrary, elements, frequency, listOf) --, listOf1, vectorOf, suchThat) import Test.QuickCheck.Monadic (run, monadicIO, monitor, assert, PropertyM)  import Test.Hspec as H  import Streamly import Streamly.Prelude ((.:), nil)+import Streamly as S import qualified Streamly.Prelude as S+import qualified Streamly.Data.Fold as FL  -- Coverage build takes too long with default number of tests maxTestCount :: Int@@ -142,16 +147,57 @@         in constructWithLen stream list op l #endif -constructWithIterate :: IsStream t => (t IO Int -> SerialT IO Int) -> Spec-constructWithIterate t = do-    it "iterate" $-        (S.toList . t . S.take 100) (S.iterate (+ 1) (0 :: Int))-        `shouldReturn` take 100 (iterate (+ 1) 0)-    it "iterateM" $ do-        let addM y = return (y + 1)-        S.toList . t . S.take 100 $ S.iterateM addM (0 :: Int)-        `shouldReturn` take 100 (iterate (+ 1) 0)+constructWithIterate ::+       IsStream t => (t IO Int -> SerialT IO Int) -> Word8 -> Property+constructWithIterate op len =+    withMaxSuccess maxTestCount $+    monadicIO $ do+        stream <-+            run $+            (S.toList . op . S.take (fromIntegral len))+                (S.iterate (+ 1) (0 :: Int))+        let list = take (fromIntegral len) (iterate (+ 1) 0)+        listEquals (==) stream list +constructWithIterateM ::+       IsStream t => (t IO Int -> SerialT IO Int) -> Word8 -> Property+constructWithIterateM op len =+    withMaxSuccess maxTestCount $+    monadicIO $ do+        mvl <- run (newIORef [] :: IO (IORef [Int]))+        let addM mv x y = modifyIORef' mv (++ [y + x]) >> return (y + x)+            list = take (fromIntegral len) (iterate (+ 1) 0)+        run $+            S.drain . op $+            S.take (fromIntegral len) $+            S.iterateM (addM mvl 1) (addM mvl 0 0 :: IO Int)+        streamEffect <- run $ readIORef mvl+        listEquals (==) streamEffect list++constructWithFromIndices ::+       IsStream t => (t IO Int -> SerialT IO Int) -> Word8 -> Property+constructWithFromIndices op len =+    withMaxSuccess maxTestCount $+    monadicIO $ do+        stream <-+            run $ (S.toList . op . S.take (fromIntegral len)) (S.fromIndices id)+        let list = take (fromIntegral len) (iterate (+ 1) 0)+        listEquals (==) stream list++constructWithFromIndicesM ::+       IsStream t => (t IO Int -> SerialT IO Int) -> Word8 -> Property+constructWithFromIndicesM op len =+    withMaxSuccess maxTestCount $+    monadicIO $ do+        mvl <- run (newIORef [] :: IO (IORef [Int]))+        let addIndex mv i = modifyIORef' mv (++ [i]) >> return i+            list = take (fromIntegral len) (iterate (+ 1) 0)+        run $+            S.drain . op $+            S.take (fromIntegral len) $ S.fromIndicesM (addIndex mvl)+        streamEffect <- run $ readIORef mvl+        listEquals (==) streamEffect list+ ------------------------------------------------------------------------------- -- Concurrent generation -------------------------------------------------------------------------------@@ -336,7 +382,8 @@         -- XXX we should test empty list case as well         let list = [0..n]         stream <- run $-            sourceUnfoldrM1 n |&. S.foldrM (\x xs -> return (x : xs)) []+            sourceUnfoldrM1 n |&. S.foldrM (\x xs -> xs >>= return . (x :))+                                           (return [])         listEquals (==) stream list  -------------------------------------------------------------------------------@@ -447,6 +494,7 @@      -- reordering     prop (desc <> " reverse") $ transform reverse t S.reverse+    -- prop (desc <> " reverse'") $ transform reverse t S.reverse'      -- inserting     prop (desc <> " intersperseM") $@@ -462,6 +510,76 @@             transform (concatMap (const [1..n]))                 t (S.concatMap (const (S.fromList [1..n]))) +toListFL :: Monad m => FL.Fold m a [a]+toListFL = FL.toList++groupSplitOps :: String -> Spec+groupSplitOps desc = do+    -- splitting+    -- XXX add tests with multichar separators too++{-+    prop (desc <> " intercalate . splitOnSeq == id (nil separator)") $+        forAll listWithZeroes $ \xs -> do+            withMaxSuccess maxTestCount $+                monadicIO $ do+                    ys <- S.toList $ FL.splitOnSeq [] toListFL (S.fromList xs)+                    listEquals (==) (intercalate [] ys) xs++    prop (desc <> " intercalate . splitOnSeq == id (single element separator)") $+        forAll listWithZeroes $ \xs -> do+            withMaxSuccess maxTestCount $+                monadicIO $ do+                    ys <- S.toList $ FL.splitOnSeq [0] toListFL (S.fromList xs)+                    listEquals (==) (intercalate [0] ys) xs++    prop (desc <> " concat . splitOnSeq . intercalate == concat (nil separator/possibly empty list)") $+        forAll listsWithoutZeroes $ \xss -> do+            withMaxSuccess maxTestCount $+                monadicIO $ do+                    let xs = intercalate [] xss+                    ys <- S.toList $ FL.splitOnSeq [0] toListFL (S.fromList xs)+                    listEquals (==) (concat ys) (concat xss)++    prop (desc <> " concat . splitOnSeq . intercalate == concat (non-nil separator/possibly empty list)") $+        forAll listsWithoutZeroes $ \xss -> do+            withMaxSuccess maxTestCount $+                monadicIO $ do+                    let xs = intercalate [0] xss+                    ys <- S.toList $ FL.splitOnSeq [0] toListFL (S.fromList xs)+                    listEquals (==) (concat ys) (concat xss)++    prop (desc <> " splitOnSeq . intercalate == id (exclusive separator/non-empty list)") $+        forAll listsWithoutZeroes1 $ \xss -> do+            withMaxSuccess maxTestCount $+                monadicIO $ do+                    let xs = intercalate [0] xss+                    ys <- S.toList $ FL.splitOnSeq [0] toListFL (S.fromList xs)+                    listEquals (==) ys xss+-}++    prop (desc <> " intercalate [x] . splitOn (== x) == id") $+        forAll listWithZeroes $ \xs -> do+            withMaxSuccess maxTestCount $+                monadicIO $ do+                    ys <- S.toList $ S.splitOn (== 0) toListFL (S.fromList xs)+                    listEquals (==) (intercalate [0] ys) xs++    where++    listWithZeroes :: Gen [Int]+    listWithZeroes = listOf $ frequency [(3, arbitrary), (1, elements [0])]++{-+    listWithoutZeroes = vectorOf 4 $ suchThat arbitrary (/= 0)++    listsWithoutZeroes :: Gen [[Int]]+    listsWithoutZeroes = listOf listWithoutZeroes++    listsWithoutZeroes1 :: Gen [[Int]]+    listsWithoutZeroes1 = listOf1 listWithoutZeroes+-}+ -- transformation tests that can only work reliably for ordered streams i.e. -- Serial, Ahead and Zip. For example if we use "take 1" on an async stream, it -- might yield a different result every time.@@ -495,7 +613,8 @@         transform (dropWhile (> 0)) t (S.dropWhile (> 0))     prop (desc <> " scan") $ transform (scanl' (+) 0) t (S.scanl' (+) 0) -    -- XXX add uniq+    prop (desc <> " uniq") $ transform referenceUniq t S.uniq+     prop (desc <> " deleteBy (<=) 0") $         transform (deleteBy (<=) 0) t (S.deleteBy (<=) 0) @@ -534,10 +653,23 @@                       | otherwise = Just (f x i)  wrapThe :: Eq a => [a] -> Maybe a-wrapThe (x:xs) | all (x ==) xs = Just x-                 | otherwise = Nothing+wrapThe (x:xs)+    | all (x ==) xs = Just x+    | otherwise = Nothing wrapThe [] = Nothing +-- This is the reference uniq implementation to compare uniq against,+-- we can use uniq from vector package, but for now this should+-- suffice.+referenceUniq :: Eq a => [a] -> [a]+referenceUniq = go+  where+    go [] = []+    go (x:[]) = [x]+    go (x:y:xs)+        | x == y = go (x : xs)+        | otherwise = x : go (y : xs)+ eliminationOps     :: ([Int] -> t IO Int)     -> String@@ -550,8 +682,10 @@         eliminateOp constr (foldl' (+) 0) $ S.foldl' (+) 0 . t     prop (desc <> " foldl1'") $         eliminateOp constr (wrapMaybe $ foldl1' (+)) $ S.foldl1' (+) . t+#ifdef DEVBUILD     prop (desc <> " foldr1") $         eliminateOp constr (wrapMaybe $ foldr1 (+)) $ S.foldr1 (+) . t+#endif     prop (desc <> " all") $ eliminateOp constr (all even) $ S.all even . t     prop (desc <> " any") $ eliminateOp constr (any even) $ S.any even . t     prop (desc <> " and") $ eliminateOp constr (and . fmap (> 0)) $@@ -690,8 +824,8 @@     -> (t IO Int -> SerialT IO Int)     -> Spec semigroupOps desc eq t = do-    prop (desc <> " <>") $ foldFromList (foldMapWith (<>) singleton) t eq-    prop (desc <> " mappend") $ foldFromList (foldMapWith mappend singleton) t eq+    prop (desc <> " <>") $ foldFromList (S.foldMapWith (<>) singleton) t eq+    prop (desc <> " mappend") $ foldFromList (S.foldMapWith mappend singleton) t eq  ------------------------------------------------------------------------------- -- Functor operations@@ -826,22 +960,41 @@         folded = serially . (\xs ->             case xs of                 [x] -> return x -- singleton stream case-                _ -> foldMapWith (<>) return xs+                _ -> S.foldMapWith (<>) return xs             ) -    let makeOps t =+    let makeCommonOps :: IsStream t => (t m a -> c) -> [(String, t m a -> c)]+        makeCommonOps t =             [ ("default", t) #ifndef COVERAGE_BUILD             , ("rate AvgRate 10000", t . avgRate 10000)             , ("rate Nothing", t . rate Nothing)             , ("maxBuffer 0", t . maxBuffer 0)-            , ("maxBuffer 1", t . maxBuffer 1)             , ("maxThreads 0", t . maxThreads 0)             , ("maxThreads 1", t . maxThreads 1)             , ("maxThreads -1", t . maxThreads (-1)) #endif             ] +    let makeOps :: IsStream t => (t m a -> c) -> [(String, t m a -> c)]+        makeOps t = makeCommonOps t +++            [+#ifndef COVERAGE_BUILD+              ("maxBuffer 1", t . maxBuffer 1)+#endif+            ]++    -- For concurrent application test we need a buffer of at least size 2 to+    -- allow two threads to run.+    let makeConcurrentAppOps :: IsStream t+            => (t m a -> c) -> [(String, t m a -> c)]+        makeConcurrentAppOps t = makeCommonOps t +++            [+#ifndef COVERAGE_BUILD+              ("maxBuffer 2", t . maxBuffer 2)+#endif+            ]+     let mapOps spec = mapM_ (\(desc, f) -> describe desc $ spec f)     let serialOps :: IsStream t => ((SerialT IO a -> t IO a) -> Spec) -> Spec         serialOps spec = mapOps spec $ makeOps serially@@ -870,13 +1023,23 @@ #ifndef COVERAGE_BUILD               <> [("maxBuffer (-1)", aheadly . maxBuffer (-1))] #endif-    let parallelOps :: IsStream t => ((ParallelT IO a -> t IO a) -> Spec) -> Spec-        parallelOps spec = mapOps spec $ makeOps parallely+    let parallelCommonOps :: IsStream t => [(String, ParallelT m a -> t m a)]+        parallelCommonOps = [] #ifndef COVERAGE_BUILD             <> [("rate AvgRate 0.00000001", parallely . avgRate 0.00000001)]             <> [("maxBuffer (-1)", parallely . maxBuffer (-1))] #endif-    let zipSerialOps :: IsStream t => ((ZipSerialM IO a -> t IO a) -> Spec) -> Spec+    let parallelOps :: IsStream t+            => ((ParallelT IO a -> t IO a) -> Spec) -> Spec+        parallelOps spec = mapOps spec $ makeOps parallely <> parallelCommonOps++    let parallelConcurrentAppOps :: IsStream t+            => ((ParallelT IO a -> t IO a) -> Spec) -> Spec+        parallelConcurrentAppOps spec =+            mapOps spec $ makeConcurrentAppOps parallely <> parallelCommonOps++    let zipSerialOps :: IsStream t+            => ((ZipSerialM IO a -> t IO a) -> Spec) -> Spec         zipSerialOps spec = mapOps spec $ makeOps zipSerially #ifndef COVERAGE_BUILD             <> [("rate AvgRate 0.00000001", zipSerially . avgRate 0.00000001)]@@ -903,10 +1066,24 @@         serialOps   $ prop "serially DoubleFromThenTo" .                             constructWithDoubleFromThenTo #endif++        serialOps   $ prop "serially iterate" . constructWithIterate+         -- XXX test for all types of streams-        constructWithIterate serially+        serialOps   $ prop "serially iterateM" . constructWithIterateM+        -- take doesn't work well on concurrent streams. Even though it+        -- seems like take only has a problem when used with parallely.+        -- wSerialOps $ prop "wSerially iterateM" wSerially . constructWithIterate+        -- aheadOps $ prop "aheadly iterateM" aheadly . onstructWithIterate+        -- asyncOps $ prop "asyncly iterateM" asyncly . constructWithIterate+        -- wAsyncOps $ prop "wAsyncly iterateM" wAsyncly . onstructWithIterate+        -- parallelOps $ prop "parallely iterateM" parallely . onstructWithIterate         -- XXX add tests for fromIndices +        serialOps $ prop "serially fromIndices" . constructWithFromIndices++        serialOps $ prop "serially fromIndicesM" . constructWithFromIndicesM+     describe "Functor operations" $ do         serialOps    $ functorOps S.fromFoldable "serially" (==)         serialOps    $ functorOps folded "serially folded" (==)@@ -1010,7 +1187,8 @@      -- These tests won't work with maxBuffer or maxThreads set to 1, so we     -- exclude those cases from these.-    let mkOps t =+    let mkOps :: IsStream t => (t m a -> c) -> [(String, t m a -> c)]+        mkOps t =             [ ("default", t) #ifndef COVERAGE_BUILD             , ("rate Nothing", t . rate Nothing)@@ -1036,7 +1214,8 @@         serialOps $ prop "serial" . concurrentApplication (==)         asyncOps $ prop "async" . concurrentApplication sortEq         aheadOps $ prop "ahead" . concurrentApplication (==)-        parallelOps $ prop "parallel" . concurrentApplication sortEq+        parallelConcurrentAppOps $+            prop "parallel" . concurrentApplication sortEq          prop "concurrent foldr application" $ withMaxSuccess maxTestCount             concurrentFoldrApplication@@ -1071,6 +1250,9 @@         aheadOps     $ transformCombineOpsOrdered folded "aheadly" (==)         zipSerialOps $ transformCombineOpsOrdered folded "zipSerially" (==)         zipAsyncOps  $ transformCombineOpsOrdered folded "zipAsyncly" (==)++    describe "Stream group and split operations" $ do+        groupSplitOps "serially"      describe "Stream elimination operations" $ do         serialOps    $ eliminationOps S.fromFoldable "serially"
+ test/PureStreams.hs view
@@ -0,0 +1,223 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MonadComprehensions #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Main (main) where++import Test.Hspec+import qualified GHC.Exts as GHC++import Streamly++#ifdef USE_STREAMLY_LIST+import Data.Functor.Identity+import Streamly.Internal.Data.List (List(..), pattern Cons, pattern Nil, ZipList(..),+                     fromZipList, toZipList)+import qualified Streamly.Prelude as S+#else+import Prelude -- to suppress compiler warning++type List = []++pattern Nil :: [a]+pattern Nil <- [] where Nil = []++pattern Cons :: a -> [a] -> [a]+pattern Cons x xs = x : xs+infixr 5 `Cons`++{-# COMPLETE Nil, Cons #-}+#endif++main :: IO ()+main = hspec $ do+#ifdef USE_STREAMLY_LIST+    describe "OverloadedLists for 'SerialT Identity' type" $ do+        it "Overloaded lists" $ do+            ([1..3] :: SerialT Identity Int) `shouldBe` S.fromList [1..3]+            GHC.toList ([1..3] :: SerialT Identity Int) `shouldBe` [1..3]++        it "Show instance" $ do+            show (S.fromList [1..3] :: SerialT Identity Int)+                `shouldBe` "fromList [1,2,3]"+        it "Read instance" $ do+            (read "fromList [1,2,3]" :: SerialT Identity Int) `shouldBe` [1..3]++        it "Eq instance" $ do+            ([1,2,3] :: SerialT Identity Int) == [1,2,3] `shouldBe` True++        it "Ord instance" $ do+            ([1,2,3] :: SerialT Identity Int) > [1,2,1] `shouldBe` True++        it "Monad comprehension" $ do+            [(x,y) | x <- [1..2], y <- [1..2]] `shouldBe`+                ([(1,1), (1,2), (2,1), (2,2)] :: SerialT Identity (Int, Int))++        it "Foldable (sum)" $ sum ([1..3] :: SerialT Identity Int)+            `shouldBe` 6++        it "Traversable (mapM)" $+            mapM return ([1..10] :: SerialT Identity Int)+                `shouldReturn` [1..10]++    describe "OverloadedStrings for 'SerialT Identity' type" $ do+        it "overloaded strings" $ do+            ("hello" :: SerialT Identity Char) `shouldBe` S.fromList "hello"+#endif++    describe "OverloadedLists for List type" $ do+        it "overloaded lists" $ do+            ([1..3] :: List Int) `shouldBe` GHC.fromList [1..3]+            GHC.toList ([1..3] :: List Int) `shouldBe` [1..3]++        it "Construct empty list" $ (Nil :: List Int) `shouldBe` []++        it "Construct a list" $ do+            (Nil :: List Int) `shouldBe` []+            ('x' `Cons` Nil) `shouldBe` ['x']+            (1 `Cons` [2 :: Int]) `shouldBe` [1,2]+            (1 `Cons` 2 `Cons` 3 `Cons` Nil :: List Int) `shouldBe` [1,2,3]++        it "pattern matches" $ do+            case [] of+                Nil -> return ()+                _ -> expectationFailure "not reached"++            case ['x'] of+                Cons 'x' Nil -> return ()+                _ -> expectationFailure "not reached"++            case [1..10 :: Int] of+                Cons x xs -> do+                    x `shouldBe` 1+                    xs `shouldBe` [2..10]+                _ -> expectationFailure "not reached"++            case [1..10 :: Int] of+                x `Cons` y `Cons` xs -> do+                    x `shouldBe` 1+                    y `shouldBe` 2+                    xs `shouldBe` [3..10]+                _ -> expectationFailure "not reached"++        it "Show instance" $ do+            show ([1..3] :: List Int) `shouldBe`+#ifdef USE_STREAMLY_LIST+                "List {toSerial = fromList [1,2,3]}"+#else+                "[1,2,3]"+#endif++        it "Read instance" $ do+            (read+#ifdef USE_STREAMLY_LIST+                "List {toSerial = fromList [1,2,3]}"+#else+                "[1,2,3]"+#endif+                :: List Int) `shouldBe` [1..3]++        it "Eq instance" $ do+            ([1,2,3] :: List Int) == [1,2,3] `shouldBe` True++        it "Ord instance" $ do+            ([1,2,3] :: List Int) > [1,2,1] `shouldBe` True++        it "Monad comprehension" $ do+            [(x,y) | x <- [1..2], y <- [1..2]] `shouldBe`+                ([(1,1), (1,2), (2,1), (2,2)] :: List (Int, Int))++        it "Foldable (sum)" $ sum ([1..3] :: List Int) `shouldBe` 6++        it "Traversable (mapM)" $+            mapM return ([1..10] :: List Int)+                `shouldReturn` [1..10]++    describe "OverloadedStrings for List type" $ do+        it "overloaded strings" $ do+            ("hello" :: List Char) `shouldBe` GHC.fromList "hello"++        it "pattern matches" $ do+#if __GLASGOW_HASKELL__ >= 802+            case "" of+#else+            case "" :: List Char of+#endif+                Nil -> return ()+                _ -> expectationFailure "not reached"++            case "a" of+                Cons x Nil -> x `shouldBe` 'a'+                _ -> expectationFailure "not reached"++            case "hello" <> "world" of+                Cons x1 (Cons x2 xs) -> do+                    x1 `shouldBe` 'h'+                    x2 `shouldBe` 'e'+                    xs `shouldBe` "lloworld"+                _ -> expectationFailure "not reached"++#ifdef USE_STREAMLY_LIST+    describe "OverloadedLists for ZipList type" $ do+        it "overloaded lists" $ do+            ([1..3] :: ZipList Int) `shouldBe` GHC.fromList [1..3]+            GHC.toList ([1..3] :: ZipList Int) `shouldBe` [1..3]++        it "toZipList" $ do+            toZipList (Nil :: List Int) `shouldBe` []+            toZipList ('x' `Cons` Nil) `shouldBe` ['x']+            toZipList (1 `Cons` [2 :: Int]) `shouldBe` [1,2]+            toZipList (1 `Cons` 2 `Cons` 3 `Cons` Nil :: List Int) `shouldBe` [1,2,3]++        it "fromZipList" $ do+            case fromZipList [] of+                Nil -> return ()+                _ -> expectationFailure "not reached"++            case fromZipList ['x'] of+                Cons 'x' Nil -> return ()+                _ -> expectationFailure "not reached"++            case fromZipList [1..10 :: Int] of+                Cons x xs -> do+                    x `shouldBe` 1+                    xs `shouldBe` [2..10]+                _ -> expectationFailure "not reached"++            case fromZipList [1..10 :: Int] of+                x `Cons` y `Cons` xs -> do+                    x `shouldBe` 1+                    y `shouldBe` 2+                    xs `shouldBe` [3..10]+                _ -> expectationFailure "not reached"++        it "Show instance" $ do+            show ([1..3] :: ZipList Int) `shouldBe`+                "ZipList {toZipSerial = fromList [1,2,3]}"++        it "Read instance" $ do+            (read "ZipList {toZipSerial = fromList [1,2,3]}" :: ZipList Int)+                `shouldBe` [1..3]++        it "Eq instance" $ do+            ([1,2,3] :: ZipList Int) == [1,2,3] `shouldBe` True++        it "Ord instance" $ do+            ([1,2,3] :: ZipList Int) > [1,2,1] `shouldBe` True++        it "Foldable (sum)" $ sum ([1..3] :: ZipList Int) `shouldBe` 6++        it "Traversable (mapM)" $+            mapM return ([1..10] :: ZipList Int)+                `shouldReturn` [1..10]++        it "Applicative Zip" $ do+            (,) <$> "abc" <*> [1..3] `shouldBe`+                ([('a',1),('b',2),('c',3)] :: ZipList (Char, Int))+#endif
+ test/String.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}++module Main (main) where++import Data.Char (ord, chr)+import Data.Word (Word8)+import Test.Hspec.QuickCheck+import Test.QuickCheck+       (Property, forAll, Gen, listOf, arbitraryUnicodeChar, arbitrary)+import Test.QuickCheck.Monadic (run, monadicIO, assert)++import           Test.Hspec as H++import qualified Streamly.Memory.Array as A+import qualified Streamly.Internal.Memory.ArrayStream as AS+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.Memory.Unicode.Array as IUA++-- Coverage build takes too long with default number of tests+{-+maxTestCount :: Int+#ifdef DEVBUILD+maxTestCount = 100+#else+maxTestCount = 10+#endif+-}++-- Use quickcheck-unicode instead?+genUnicode :: Gen String+genUnicode = listOf arbitraryUnicodeChar++genWord8 :: Gen [Word8]+genWord8 = listOf arbitrary++propDecodeEncodeId :: Property+propDecodeEncodeId =+    forAll genUnicode $ \list ->+        monadicIO $ do+            let wrds = SS.encodeUtf8 $ S.fromList list+            chrs <- S.toList $ SS.decodeUtf8 wrds+            assert (chrs == list)++-- XXX need to use invalid characters+propDecodeEncodeIdLenient :: Property+propDecodeEncodeIdLenient =+    forAll genUnicode $ \list ->+        monadicIO $ do+            let wrds = SS.encodeUtf8 $ S.fromList list+            chrs <- S.toList $ SS.decodeUtf8Lax wrds+            assert (chrs == list)++propDecodeEncodeIdArrays :: Property+propDecodeEncodeIdArrays =+    forAll genUnicode $ \list ->+        monadicIO $ do+            let wrds = SS.encodeUtf8 $ S.fromList list+            chrs <- S.toList $ IUS.decodeUtf8ArraysLenient+                                    (S.fold A.write wrds)+            assert (chrs == list)++testLines :: Property+testLines =+    forAll genUnicode $ \list ->+        monadicIO $ do+            xs <- S.toList+                $ S.map A.toList+                $ IUA.lines+                $ S.fromList list+            assert (xs == lines list)++testLinesArray :: Property+testLinesArray =+    forAll genWord8 $ \list ->+        monadicIO $ do+            xs <- S.toList+                    $ S.map A.toList+                    $ AS.splitOnSuffix 10+                    $ S.yield (A.fromList list)+            assert (xs == map (map (fromIntegral . ord))+                              (lines (map (chr .  fromIntegral) list)))++testWords :: Property+testWords =+    forAll genUnicode $ \list ->+        monadicIO $ do+            xs <- S.toList+                $ S.map A.toList+                $ IUA.words+                $ S.fromList list+            assert (xs == words list)++testUnlines :: Property+testUnlines =+  forAll genUnicode $ \list ->+      monadicIO $ do+          xs <- S.toList+              $ IUA.unlines+              $ IUA.lines+              $ S.fromList list+          assert (xs == unlines (lines list))++testUnwords :: Property+testUnwords =+  forAll genUnicode $ \list ->+      monadicIO $ do+          xs <- run+              $ S.toList+              $ IUA.unwords+              $ IUA.words+              $ S.fromList list+          assert (xs == unwords (words list))++main :: IO ()+main = hspec+    $ H.parallel+    $ modifyMaxSuccess (const 1000)+    $ do+    describe "UTF8 - Encoding / Decoding" $ do+        prop "decodeUtf8 . encodeUtf8 == id" $ propDecodeEncodeId+        prop "decodeUtf8Lax . encodeUtf8 == id" $ propDecodeEncodeIdLenient+        prop "decodeUtf8ArraysLenient . encodeUtf8 == id"+                $ propDecodeEncodeIdArrays+        prop "Streamly.Data.String.lines == Prelude.lines" $ testLines+        prop "Arrays Streamly.Data.String.lines == Prelude.lines" $ testLinesArray+        prop "Streamly.Data.String.words == Prelude.words" $ testWords+        prop+            "Streamly.Data.String.unlines . Streamly.Data.String.lines == unlines . lines"+             $ testUnlines+        prop+            "Streamly.Data.String.unwords . Streamly.Data.String.words == unwords . words"+             $ testUnwords
test/loops.hs view
@@ -1,38 +1,38 @@ import Streamly import System.IO (stdout, hSetBuffering, BufferMode(LineBuffering))-import Streamly.Prelude (nil, yieldM)+import Streamly.Prelude (nil, yieldM, drain)  main :: IO () main = do     hSetBuffering stdout LineBuffering      putStrLn "\nloopTail:\n"-    runStream $ do+    drain $ do         x <- loopTail 0         yieldM $ print (x :: Int)      putStrLn "\nloopHead:\n"-    runStream $ do+    drain $ do         x <- loopHead 0         yieldM $ print (x :: Int)      putStrLn "\nloopTailA:\n"-    runStream $ do+    drain $ do         x <- loopTailA 0         yieldM $ print (x :: Int)      putStrLn "\nloopHeadA:\n"-    runStream $ do+    drain $ do         x <- loopHeadA 0         yieldM $ print (x :: Int)      putStrLn "\nwSerial:\n"-    runStream $ do+    drain $ do         x <- (return 0 <> return 1) `wSerial` (return 100 <> return 101)         yieldM $ print (x :: Int)      putStrLn "\nParallel interleave:\n"-    runStream $ do+    drain $ do         x <- (return 0 <> return 1) `wAsync` (return 100 <> return 101)         yieldM $ print (x :: Int)
test/nested-loops.hs view
@@ -2,10 +2,10 @@ import System.IO (stdout, hSetBuffering, BufferMode(LineBuffering)) import System.Random (randomIO) import Streamly-import Streamly.Prelude (nil, yieldM)+import Streamly.Prelude (drain, nil, yieldM)  main :: IO ()-main = runStream $ do+main = drain $ do     yieldM $ hSetBuffering stdout LineBuffering     x <- loop "A " 2     y <- loop "B " 2
test/parallel-loops.hs view
@@ -7,7 +7,7 @@ main :: IO () main = do     hSetBuffering stdout LineBuffering-    runStream $ do+    S.drain $ do         x <- S.take 10 $ loop "A" `parallel` loop "B"         S.yieldM $ myThreadId >>= putStr . show                >> putStr " got "