diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,15 +2,72 @@ +## 0.11.1 (May 2026) + +* Fix `parDemuxScan` deadlock when a worker throws an exception while the + driver is blocked on a full input buffer. + +## 0.11.0 (Sep 2025) + +See +[0.10.1-0.11.0 API Changelog](https://github.com/composewell/streamly/blob/streamly-0.11.0/docs/User/Project/ApiChangelogs/0.10.1-0.11.0.txt) +for detailed API changes in this release. + +### Breaking Changes + +* Concurrent streams and folds now use separate concurrency config types. If you + were importing `Config` from the wrong module, you will need to update it. + +### Enhancements + +* Support for prompt cleanup of concurrent threads, allowing guaranteed + cleanup as an alternative to GC-based cleanup. +* Introduced `Streamly.Data.Scanl.Prelude` for using concurrent + operations with the new `Scanl` type. Scans can split a stream into + multiple streams, process them concurrently, and merge the results. +* Added new concurrent fold combinators in `Streamly.Data.Fold.Prelude`. +* Fixed rate control for ordered streams. + +### Internal + +* Internal `FileSystem.Event.*` modules are deprecated; use the + [streamly-fsevents](https://github.com/composewell/streamly-fsevents) package. + instead. + +## 0.10.1 (Jan 2024) + +* Fix TH macros in `Streamly.Data.Stream.MkType` for GHC 9.6 and above. + +## 0.10.0 (Nov 2023) + +See +[0.9.0-0.10.0 API Changelog](https://github.com/composewell/streamly/blob/streamly-0.10.0/docs/User/Project/ApiChangelogs/0.9.0-0.10.0.txt) +for a full list of API changes in this release. Only a few significant +changes are mentioned here. For changes to the core functionality +please see the changelog of the `streamly-core` package. + +### Breaking Changes + +* `MonadTrans` and `MonadBase` instances have been removed for `AsyncT`, + `ParallelT`, `AheadT` for GHC versions 9.6 onwards. This is due to a + breaking change in `transformers` 0.6. You can replace `lift` with + `fromEffect` when using these as top level monads in a monad stack. + +### Enhancements + +* __Concurrent Folds__: `Streamly.Data.Fold.Prelude` module added with + concurrent fold APIs and a container fold API to fold a key value + stream to a HashMap. + ## 0.9.0 (Mar 2023) Also see the following: -* [streamly-0.9.0 Upgrade Guide](/docs/User/ProjectRelated/Upgrading.md) or +* [streamly-0.9.0 Upgrade Guide](https://github.com/composewell/streamly/blob/streamly-0.10.0/docs/User/Project/Upgrading-0.8-to-0.9.md) or https://hackage.haskell.org/package/streamly-0.9.0/docs/docs/User/ProjectRelated/Upgrading.md -* [streamly-0.9.0 API Changelog](/docs/User/ProjectRelated/ApiChangelogs/0.8.3-0.9.0.txt) or +* [streamly-0.9.0 API Changelog](https://github.com/composewell/streamly/blob/streamly-0.10.0/docs/User/Project/ApiChangelogs/0.8.3-0.9.0.txt) or https://hackage.haskell.org/package/streamly-0.9.0/docs/docs/User/ProjectRelated/ApiChangelogs/0.8.3-0.9.0.txt -* [streamly-core-0.1.0 API Changelog](/core/docs/ApiChangelogs/0.1.0.txt) or +* [streamly-core-0.1.0 API Changelog](https://github.com/composewell/streamly/blob/streamly-0.10.0/core/docs/ApiChangelogs/0.1.0.txt) or https://hackage.haskell.org/package/streamly-core-0.1.0/docs/docs/ApiChangelogs/0.1.0.txt ### Package split @@ -57,8 +114,9 @@ `StreamK` types can be easily interconverted. The old code can be adapted to use the new modules with some changes. -See the [upgrade guide](/docs/User/ProjectRelated/Upgrading.md) for more -details on how to adapt your existing code to the new release. +See the +[streamly-0.9.0 Upgrade Guide](https://github.com/composewell/streamly/blob/streamly-0.10.0/docs/User/Project/Upgrading-0.8-to-0.9.md) +for more details on how to adapt your existing code to the new release. ### Enhancements @@ -111,7 +169,7 @@ ## 0.8.1 (Nov 2021) -See ApiChangelogs/0.8.3.txt for new APIs introduced. +See ApiChangelogs/0.8.0-0.8.1.txt for new APIs introduced. ### Bug Fixes @@ -139,7 +197,7 @@ ## 0.8.0 (Jun 2021) -See [API Changelog](/docs/User/ProjectRelated/ApiChangelogs/0.8.3.txt) for a complete list of signature +See [API Changelog](/docs/User/Project/ApiChangelogs/0.7.3-0.8.0.txt) for a complete list of signature changes and new APIs introduced. ### Breaking changes @@ -178,7 +236,7 @@ ### Enhancements -* See [API Changelog](/docs/User/ProjectRelated/ApiChangelogs/0.8.3.txt) for a complete list of new +* See [API Changelog](/docs/User/Project/ApiChangelogs/0.7.3-0.8.0.txt) for a complete list of new modules and APIs introduced. * The Fold type is now more powerful, the new termination behavior allows to express basic parsing of streams using folds. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -27,172 +27,6 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ------------------------------------------------------------------------------- -base-4.12.0.0 (http://hackage.haskell.org/package/base-4.12.0.0) -------------------------------------------------------------------------------- -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. - -------------------------------------------------------------------------------- -bjoern-2008-2009 (http://bjoern.hoehrmann.de/utf-8/decoder/dfa/) -------------------------------------------------------------------------------- -Copyright (c) 2008-2009 Bjoern Hoehrmann - -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. - -------------------------------------------------------------------------------- -clock-0.7.2 (http://hackage.haskell.org/package/clock-0.7.2) -------------------------------------------------------------------------------- -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. - -------------------------------------------------------------------------------- -foldl-1.4.5 (http://hackage.haskell.org/package/foldl-1.4.5) -------------------------------------------------------------------------------- -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. - -------------------------------------------------------------------------------- fsnotify-0.3.0.1 (http://hackage.haskell.org/package/fsnotify-0.3.0.1/) ------------------------------------------------------------------------------- Copyright (c) 2012, Mark Dittmer @@ -259,91 +93,3 @@ 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. - -------------------------------------------------------------------------------- -primitive-0.7.0.0 (https://hackage.haskell.org/package/primitive-0.7.0.0) -------------------------------------------------------------------------------- -Copyright (c) 2008-2009, Roman Leshchinskiy -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -- Redistributions of source code must retain the above copyright notice, -this list of conditions and the following disclaimer. - -- Redistributions in binary form must reproduce the above copyright notice, -this list of conditions and the following disclaimer in the documentation -and/or other materials provided with the distribution. - -- Neither name of the University nor the names of its contributors may be -used to endorse or promote products derived from this software without -specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF -GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, -INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT -LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY -OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH -DAMAGE. - -------------------------------------------------------------------------------- -transient-0.5.5 (http://hackage.haskell.org/package/transient-0.5.5) -------------------------------------------------------------------------------- -Copyright © 2014-2016 Alberto G. Corona - -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. - -------------------------------------------------------------------------------- -vector-0.12.0.2 (http://hackage.haskell.org/package/vector-0.12.0.2) -------------------------------------------------------------------------------- -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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,8 +1,15 @@ # [Streamly][]: Idiomatic Haskell with C-Like Performance [![Gitter chat](https://badges.gitter.im/composewell/gitter.svg)](https://gitter.im/composewell/streamly) +[![Hackage](https://img.shields.io/hackage/v/streamly-core.svg?style=flat)](https://hackage.haskell.org/package/streamly-core) [![Hackage](https://img.shields.io/hackage/v/streamly.svg?style=flat)](https://hackage.haskell.org/package/streamly) +## Upgrading to 0.9.0+ + +Please read the [Streamly 0.9.0 Upgrade Guide](/docs/User/Project/Upgrading-0.8-to-0.9.md). + +## Overview + Streamly is a powerful Haskell library that provides developers with the essential building blocks to create safe, scalable, modular, and high-performance software. With Streamly, developers can enjoy the @@ -17,11 +24,9 @@ * Fearless, declarative concurrency for seamless parallel execution. * A collection of ecosystem libraries for fast and efficient development. -Check out the [Streamly Setup and Usage -Guide](/docs/User/Tutorials/setup-and-usage.md) and [Quick -Overview](/docs/User/Tutorials/quick-overview.md) for an introduction -to the library. For more detailed documentation, visit the [Haskell -Streamly website][Streamly]. +Check out the [Learn By Examples](/docs/User/Tutorials/learn-by-examples.md) +page for an introduction to the library. For more detailed documentation, visit +the [Haskell Streamly website][Streamly]. ## Blazing Fast @@ -88,7 +93,7 @@ * Gabriella Gonzalez ([foldl](https://hackage.haskell.org/package/foldl)) * Alberto G. Corona ([transient](https://hackage.haskell.org/package/transient)) -Please see the [`credits`](/docs/User/ProjectRelated/Credits.md) directory for a full +Please see the [`credits`](/docs/User/Project/Credits.md) directory for a full list of contributors, credits and licenses. ## Licensing diff --git a/bench-test-lib/bench-test-lib.cabal b/bench-test-lib/bench-test-lib.cabal new file mode 100644 --- /dev/null +++ b/bench-test-lib/bench-test-lib.cabal @@ -0,0 +1,67 @@ +cabal-version: 3.0 +name: bench-test-lib +version: 0.1.0.0 +build-type: Simple + +common compile-options + default-language: Haskell2010 + ghc-options: -Weverything + -Wno-implicit-prelude + -Wno-missing-deriving-strategies + -Wno-missing-exported-signatures + -Wno-missing-import-lists + -Wno-missing-local-signatures + -Wno-missing-safe-haskell-mode + -Wno-missed-specialisations + -Wno-all-missed-specialisations + -Wno-monomorphism-restriction + -Wno-prepositive-qualified-module + -Wno-unsafe + -Rghc-timing + + if impl(ghc >= 9.2) + ghc-options: + -Wno-missing-kind-signatures + -Wno-redundant-bang-patterns + -Wno-operator-whitespace + + if impl(ghc >= 9.8) + ghc-options: + -Wno-missing-role-annotations + +common default-extensions + default-extensions: + BangPatterns + ConstraintKinds + DeriveDataTypeable + DeriveGeneric + DeriveTraversable + ExistentialQuantification + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + InstanceSigs + KindSignatures + MultiParamTypeClasses + RankNTypes + ScopedTypeVariables + TupleSections + TypeApplications + TypeOperators + + -- Not GHC2021 + CApiFFI + CPP + LambdaCase + MagicHash + RecordWildCards + +library + import: compile-options, default-extensions + exposed-modules: BenchTestLib.DirIO + build-depends: base + , streamly-core + , streamly + , directory + hs-source-dirs: src + default-language: Haskell2010 diff --git a/bench-test-lib/src/BenchTestLib/DirIO.hs b/bench-test-lib/src/BenchTestLib/DirIO.hs new file mode 100644 --- /dev/null +++ b/bench-test-lib/src/BenchTestLib/DirIO.hs @@ -0,0 +1,300 @@ +-- | +-- Module : BenchTestLib.DirIO +-- Copyright : (c) 2019 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +{-# LANGUAGE QuasiQuotes #-} + +module BenchTestLib.DirIO + ( createDirStucture + , listDirUnfoldDfs + , listDirUnfoldBfs + , listDirUnfoldBfsRev + , listDirConcatDfs + , listDirConcatBfs + , listDirConcatBfsRev + , listDirAppend + , listDirInterleave + , listDirPar + , listDirParInterleaved + , listDirParOrdered + , listDirChunkDfs + , listDirChunkBfs + , listDirChunkBfsRev + , listDirChunkAppend + , listDirChunkInterleave + , listDirChunkPar + , listDirChunkParInterleaved + , listDirChunkParOrdered +#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) + , listDirByteChunked +#endif + ) where + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +import Data.IORef (newIORef, modifyIORef', readIORef) +import Data.Maybe (fromJust) +import Data.Word (Word8) +#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) +import Streamly.Data.Array (Array) +#endif +import Streamly.Data.Stream (Stream) +import Streamly.Data.Unfold (Unfold) +import Streamly.FileSystem.Path (Path) +import Streamly.Unicode.String (str) +import System.Directory (createDirectoryIfMissing) +import Data.Foldable (for_) + +import qualified Streamly.Data.Stream.Prelude as Stream +import qualified Streamly.Data.Array as Array +import qualified Streamly.Internal.Data.Stream as Stream +import qualified Streamly.Data.StreamK as StreamK +import qualified Streamly.Internal.Data.StreamK as StreamK +import qualified Streamly.Data.Unfold as Unfold +import qualified Streamly.Internal.Data.Unfold as Unfold +import qualified Streamly.Internal.FileSystem.DirIO as Dir +import qualified Streamly.FileSystem.Path as Path +#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) +import qualified Streamly.Internal.FileSystem.Posix.ReadDir as Dir +#endif + +-------------------------------------------------------------------------------- +-- Helpers +-------------------------------------------------------------------------------- + +concatIterateWith :: Monad m => + (a -> Stream m a) + -> (StreamK.StreamK m a + -> StreamK.StreamK m a -> StreamK.StreamK m a) + -> Stream m a + -> Stream m a +concatIterateWith nxt f = + StreamK.toStream + . StreamK.concatIterateWith f (StreamK.fromStream . nxt) + . StreamK.fromStream + +mergeIterateWith :: Monad m => + (a -> Stream m a) + -> (StreamK.StreamK m a + -> StreamK.StreamK m a -> StreamK.StreamK m a) + -> Stream m a + -> Stream m a +mergeIterateWith nxt f = + StreamK.toStream + . StreamK.mergeIterateWith f (StreamK.fromStream . nxt) + . StreamK.fromStream + +streamDir + :: (Dir.ReadOptions -> Dir.ReadOptions) + -> Either Path b -> Stream IO (Either Path Path) +streamDir f = either (Dir.readEitherPaths f) (const Stream.nil) + +unfoldDir + :: (Dir.ReadOptions -> Dir.ReadOptions) + -> Unfold IO (Either Path b) (Either Path Path) +unfoldDir f = Unfold.either (Dir.eitherReaderPaths f) Unfold.nil + +streamDirMaybe + :: (Dir.ReadOptions -> Dir.ReadOptions) + -> Either Path b -> Maybe (Stream IO (Either Path Path)) +streamDirMaybe f = either (Just . Dir.readEitherPaths f) (const Nothing) + +#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) +_streamDirByteChunked + :: (Dir.ReadOptions -> Dir.ReadOptions) + -> Either [Path] b -> Stream IO (Either [Path] (Array Word8)) +_streamDirByteChunked f = either (Dir.readEitherByteChunks f) (const Stream.nil) + +streamDirByteChunkedMaybe + :: (Dir.ReadOptions -> Dir.ReadOptions) + -> Either [Path] b -> Maybe (Stream IO (Either [Path] (Array Word8))) +streamDirByteChunkedMaybe f = + either (Just . Dir.readEitherByteChunks f) (const Nothing) +#endif + +streamDirChunkedMaybe + :: (Dir.ReadOptions -> Dir.ReadOptions) + -> Either [Path] b -> Maybe (Stream IO (Either [Path] [Path])) +streamDirChunkedMaybe f = either (Just . Dir.readEitherChunks f) (const Nothing) + +streamDirChunked + :: (Dir.ReadOptions -> Dir.ReadOptions) + -> Either [Path] b -> Stream IO (Either [Path] [Path]) +streamDirChunked f = either (Dir.readEitherChunks f) (const Stream.nil) + +-------------------------------------------------------------------------------- +-- Functions +-------------------------------------------------------------------------------- + +createDirStucture :: FilePath -> Int -> Int -> IO [FilePath] +createDirStucture root d w = do + ref <- newIORef [root] + createDirStucture_ ref root d w + readIORef ref + where + createDirStucture_ _ _ depth _ | depth <= 0 = pure () + createDirStucture_ ref parentDir depth width = do + for_ [1..width] $ \i -> do + let iStr = show i + subDir = [str|#{parentDir}/dir_#{iStr}|] + createDirectoryIfMissing True subDir + modifyIORef' ref (subDir:) + createDirStucture_ ref subDir (depth - 1) width + +#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) +-- Fastest implementation, only works for posix as of now. +{-# INLINE listDirByteChunked #-} +listDirByteChunked :: FilePath -> Stream IO (Array Word8) +listDirByteChunked inp = do + Stream.catRights + $ Stream.concatIterate (streamDirByteChunkedMaybe id) + $ Stream.fromPure (Left [fromJust $ Path.fromString inp]) +#endif + +-- Faster than the listDir implementation below +{-# INLINE listDirChunkedWith #-} +listDirChunkedWith + :: (Stream IO (Either [Path] b) -> Stream IO (Either [Path] [Path])) + -> [Char] -> Stream IO Word8 +listDirChunkedWith act inp = do + Stream.unfoldEachEndBy 10 Array.reader + $ fmap (Array.asBytes . Path.toArray) + $ Stream.unfoldEach Unfold.fromList + $ fmap (either id id) + $ act + $ Stream.fromPure (Left [fromJust $ Path.fromString inp]) + +{-# INLINE listDirWith #-} +listDirWith + :: (Stream IO (Either Path Path) -> Stream IO (Either Path Path)) + -> [Char] -> Stream IO Word8 +listDirWith act inp = do + Stream.unfoldEachEndBy 10 Array.reader + $ fmap (Array.asBytes . Path.toArray . either id id) + $ act + $ Stream.fromPure (Left (fromJust $ Path.fromString inp)) + +-------------------------------------------------------------------------------- +-- Non chunked +-------------------------------------------------------------------------------- + +{-# INLINE listDirUnfoldDfs #-} +listDirUnfoldDfs + :: (Dir.ReadOptions -> Dir.ReadOptions) -> [Char] -> Stream IO Word8 +listDirUnfoldDfs f = listDirWith (Stream.unfoldIterate (unfoldDir f)) + +{-# INLINE listDirUnfoldBfs #-} +listDirUnfoldBfs + :: (Dir.ReadOptions -> Dir.ReadOptions) -> [Char] -> Stream IO Word8 +listDirUnfoldBfs f = listDirWith (Stream.bfsUnfoldIterate (unfoldDir f)) + +{-# INLINE listDirUnfoldBfsRev #-} +listDirUnfoldBfsRev + :: (Dir.ReadOptions -> Dir.ReadOptions) -> [Char] -> Stream IO Word8 +listDirUnfoldBfsRev f = listDirWith (Stream.altBfsUnfoldIterate (unfoldDir f)) + +{-# INLINE listDirConcatDfs #-} +listDirConcatDfs + :: (Dir.ReadOptions -> Dir.ReadOptions) -> [Char] -> Stream IO Word8 +listDirConcatDfs f = listDirWith (Stream.concatIterate (streamDirMaybe f)) + +{-# INLINE listDirConcatBfs #-} +listDirConcatBfs + :: (Dir.ReadOptions -> Dir.ReadOptions) -> [Char] -> Stream IO Word8 +listDirConcatBfs f = listDirWith (Stream.bfsConcatIterate (streamDirMaybe f)) + +{-# INLINE listDirConcatBfsRev #-} +listDirConcatBfsRev + :: (Dir.ReadOptions -> Dir.ReadOptions) -> [Char] -> Stream IO Word8 +listDirConcatBfsRev f = + listDirWith (Stream.altBfsConcatIterate (streamDirMaybe f)) + +{-# INLINE listDirAppend #-} +listDirAppend + :: (Dir.ReadOptions -> Dir.ReadOptions) -> [Char] -> Stream IO Word8 +listDirAppend f = listDirWith (concatIterateWith (streamDir f) StreamK.append) + +{-# INLINE listDirInterleave #-} +listDirInterleave + :: (Dir.ReadOptions -> Dir.ReadOptions) -> [Char] -> Stream IO Word8 +listDirInterleave f = + listDirWith (mergeIterateWith (streamDir f) StreamK.interleave) + +{-# INLINE listDirPar #-} +listDirPar + :: (Dir.ReadOptions -> Dir.ReadOptions) -> [Char] -> Stream IO Word8 +listDirPar f = listDirWith (Stream.parConcatIterate id (streamDir f)) + +{-# INLINE listDirParInterleaved #-} +listDirParInterleaved + :: (Dir.ReadOptions -> Dir.ReadOptions) -> [Char] -> Stream IO Word8 +listDirParInterleaved f = + listDirWith + (Stream.parConcatIterate (Stream.interleaved True) (streamDir f)) + +{-# INLINE listDirParOrdered #-} +listDirParOrdered + :: (Dir.ReadOptions -> Dir.ReadOptions) -> [Char] -> Stream IO Word8 +listDirParOrdered f = + listDirWith (Stream.parConcatIterate (Stream.ordered True) (streamDir f)) + +-------------------------------------------------------------------------------- +-- Chunked +-------------------------------------------------------------------------------- + +{-# INLINE listDirChunkDfs #-} +listDirChunkDfs + :: (Dir.ReadOptions -> Dir.ReadOptions) -> [Char] -> Stream IO Word8 +listDirChunkDfs f = + listDirChunkedWith (Stream.concatIterate (streamDirChunkedMaybe f)) + +{-# INLINE listDirChunkBfs #-} +listDirChunkBfs + :: (Dir.ReadOptions -> Dir.ReadOptions) -> [Char] -> Stream IO Word8 +listDirChunkBfs f = + listDirChunkedWith (Stream.bfsConcatIterate (streamDirChunkedMaybe f)) + +{-# INLINE listDirChunkBfsRev #-} +listDirChunkBfsRev + :: (Dir.ReadOptions -> Dir.ReadOptions) -> [Char] -> Stream IO Word8 +listDirChunkBfsRev f = + listDirChunkedWith (Stream.altBfsConcatIterate (streamDirChunkedMaybe f)) + +{-# INLINE listDirChunkAppend #-} +listDirChunkAppend + :: (Dir.ReadOptions -> Dir.ReadOptions) -> [Char] -> Stream IO Word8 +listDirChunkAppend f = + listDirChunkedWith (concatIterateWith (streamDirChunked f) StreamK.append) + +{-# INLINE listDirChunkInterleave #-} +listDirChunkInterleave + :: (Dir.ReadOptions -> Dir.ReadOptions) -> [Char] -> Stream IO Word8 +listDirChunkInterleave f = + listDirChunkedWith + (mergeIterateWith (streamDirChunked f) StreamK.interleave) + +{-# INLINE listDirChunkPar #-} +listDirChunkPar + :: (Dir.ReadOptions -> Dir.ReadOptions) -> [Char] -> Stream IO Word8 +listDirChunkPar f = + listDirChunkedWith (Stream.parConcatIterate id (streamDirChunked f)) + +{-# INLINE listDirChunkParInterleaved #-} +listDirChunkParInterleaved + :: (Dir.ReadOptions -> Dir.ReadOptions) -> [Char] -> Stream IO Word8 +listDirChunkParInterleaved f = + listDirChunkedWith + (Stream.parConcatIterate (Stream.interleaved True) (streamDirChunked f)) + +{-# INLINE listDirChunkParOrdered #-} +listDirChunkParOrdered + :: (Dir.ReadOptions -> Dir.ReadOptions) -> [Char] -> Stream IO Word8 +listDirChunkParOrdered f = + listDirChunkedWith + (Stream.parConcatIterate (Stream.ordered True) (streamDirChunked f)) diff --git a/benchmark/NanoBenchmarks.hs b/benchmark/NanoBenchmarks.hs --- a/benchmark/NanoBenchmarks.hs +++ b/benchmark/NanoBenchmarks.hs @@ -18,7 +18,7 @@ import qualified Streamly.Internal.Data.Stream as S import qualified Streamly.Internal.Data.Stream.IsStream as Internal -import Gauge +import Test.Tasty.Bench import System.Random maxValue :: Int diff --git a/benchmark/Streamly/Benchmark/Data/Array.hs b/benchmark/Streamly/Benchmark/Data/Array.hs --- a/benchmark/Streamly/Benchmark/Data/Array.hs +++ b/benchmark/Streamly/Benchmark/Data/Array.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -Wno-deprecations #-} {-# OPTIONS_GHC -Wno-orphans #-} {-# LANGUAGE CPP #-} @@ -6,6 +5,9 @@ #include "Streamly/Benchmark/Data/Array/CommonImports.hs" import Control.DeepSeq (deepseq) +#if __GLASGOW_HASKELL__ >= 810 +import Data.Kind (Type) +#endif import qualified Streamly.Internal.Data.Array as IA import qualified GHC.Exts as GHC @@ -13,6 +15,9 @@ -- import qualified Streamly.Data.Array as A import qualified Streamly.Internal.Data.Array as A +#if __GLASGOW_HASKELL__ >= 810 +type Stream :: Type -> Type +#endif type Stream = A.Array #include "Streamly/Benchmark/Data/Array/Common.hs" @@ -73,7 +78,7 @@ {-# INLINE sourceIntFromToFromStream #-} sourceIntFromToFromStream :: MonadIO m => Int -> Int -> m (Stream Int) -sourceIntFromToFromStream value n = S.fold A.write $ S.enumerateFromTo n (n + value) +sourceIntFromToFromStream value n = S.fold A.create $ S.enumerateFromTo n (n + value) ------------------------------------------------------------------------------- -- Bench groups @@ -98,10 +103,10 @@ o_1_space_elimination value = [ bgroup "elimination" [ benchPureSink value "length . IsList.toList" (length . GHC.toList) - , benchFold "writeLastN.1" - (S.fold (IA.writeLastN 1)) (P.sourceUnfoldrM value) - , benchFold "writeLastN.10" - (S.fold (IA.writeLastN 10)) (P.sourceUnfoldrM value) + , benchFold "createOfLast.1" + (S.fold (IA.createOfLast 1)) (P.sourceUnfoldrM value) + , benchFold "createOfLast.10" + (S.fold (IA.createOfLast 10)) (P.sourceUnfoldrM value) #ifdef DEVBUILD {- benchPureSink value "foldable/foldl'" foldableFoldl' @@ -116,7 +121,7 @@ [ bgroup "elimination" [ -- Converting the stream to an array - benchFold "writeLastN.Max" (S.fold (IA.writeLastN (value + 1))) + benchFold "createOfLast.Max" (S.fold (IA.createOfLast (value + 1))) (P.sourceUnfoldrM value) ] ] diff --git a/benchmark/Streamly/Benchmark/Data/Array/Common.hs b/benchmark/Streamly/Benchmark/Data/Array/Common.hs --- a/benchmark/Streamly/Benchmark/Data/Array/Common.hs +++ b/benchmark/Streamly/Benchmark/Data/Array/Common.hs @@ -26,7 +26,7 @@ {-# INLINE sourceUnfoldr #-} sourceUnfoldr :: MonadIO m => Int -> Int -> m (Stream Int) -sourceUnfoldr value n = S.fold (A.writeN value) $ S.unfoldr step n +sourceUnfoldr value n = S.fold (A.createOf value) $ S.unfoldr step n where step cnt = if cnt > n + value @@ -35,11 +35,11 @@ {-# INLINE sourceIntFromTo #-} sourceIntFromTo :: MonadIO m => Int -> Int -> m (Stream Int) -sourceIntFromTo value n = S.fold (A.writeN value) $ S.enumerateFromTo n (n + value) +sourceIntFromTo value n = S.fold (A.createOf value) $ S.enumerateFromTo n (n + value) {-# INLINE sourceFromList #-} sourceFromList :: MonadIO m => Int -> Int -> m (Stream Int) -sourceFromList value n = S.fold (A.writeN value) $ S.fromList [n..n+value] +sourceFromList value n = S.fold (A.createOf value) $ S.fromList [n..n+value] ------------------------------------------------------------------------------- -- Transformation @@ -69,9 +69,9 @@ :: MonadIO m => Int -> (Stream.Stream m Int -> Stream.Stream m Int) -> Stream Int -> m (Stream Int) -onArray value f arr = S.fold (A.writeN value) $ f $ S.unfold A.reader arr +onArray value f arr = S.fold (A.createOf value) $ f $ S.unfold A.reader arr -scanl' value n = composeN n $ onArray value $ S.scan (Fold.foldl' (+) 0) +scanl' value n = composeN n $ onArray value $ S.scanl (Scanl.mkScanl (+) 0) scanl1' value n = composeN n $ onArray value $ Stream.scanl1' (+) map value n = composeN n $ onArray value $ fmap (+1) -- map n = composeN n $ A.map (+1) @@ -149,7 +149,7 @@ [ bgroup "elimination" [ -- Converting the stream to an array - benchFold "writeN" (S.fold (A.writeN value)) + benchFold "writeN" (S.fold (A.createOf value)) (P.sourceUnfoldrM value) ] ] diff --git a/benchmark/Streamly/Benchmark/Data/Array/CommonImports.hs b/benchmark/Streamly/Benchmark/Data/Array/CommonImports.hs --- a/benchmark/Streamly/Benchmark/Data/Array/CommonImports.hs +++ b/benchmark/Streamly/Benchmark/Data/Array/CommonImports.hs @@ -6,10 +6,11 @@ import System.Random (randomRIO) import qualified Streamly.Data.Fold as Fold +import qualified Streamly.Data.Scanl as Scanl import qualified Streamly.Data.Stream as S -import qualified Streamly.Internal.Data.Stream.StreamD as Stream +import qualified Streamly.Internal.Data.Stream as Stream -import Gauge +import Test.Tasty.Bench import Streamly.Benchmark.Common hiding (benchPureSrc) import qualified Stream.Common as P diff --git a/benchmark/Streamly/Benchmark/Data/Array/Generic.hs b/benchmark/Streamly/Benchmark/Data/Array/Generic.hs --- a/benchmark/Streamly/Benchmark/Data/Array/Generic.hs +++ b/benchmark/Streamly/Benchmark/Data/Array/Generic.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -Wno-deprecations #-} {-# OPTIONS_GHC -Wno-orphans #-} {-# LANGUAGE CPP #-} @@ -58,7 +57,7 @@ {-# INLINE sourceIntFromToFromStream #-} sourceIntFromToFromStream :: MonadIO m => Int -> Int -> m (Stream Int) sourceIntFromToFromStream value n = - S.fold A.write $ S.enumerateFromTo n (n + value) + S.fold A.create $ S.enumerateFromTo n (n + value) ------------------------------------------------------------------------------- -- Bench groups @@ -77,10 +76,10 @@ o_1_space_elimination :: Int -> [Benchmark] o_1_space_elimination value = [ bgroup "elimination" - [ benchFold "writeLastN.1" - (S.fold (IA.writeLastN 1)) (P.sourceUnfoldrM value) - , benchFold "writeLastN.10" - (S.fold (IA.writeLastN 10)) (P.sourceUnfoldrM value) + [ benchFold "createOfLast.1" + (S.fold (IA.createOfLast 1)) (P.sourceUnfoldrM value) + , benchFold "createOfLast.10" + (S.fold (IA.createOfLast 10)) (P.sourceUnfoldrM value) #ifdef DEVBUILD {- benchPureSink value "foldable/foldl'" foldableFoldl' @@ -95,7 +94,7 @@ [ bgroup "elimination" [ -- Converting the stream to an array - benchFold "writeLastN.Max" (S.fold (IA.writeLastN (value + 1))) + benchFold "createOfLast.Max" (S.fold (IA.createOfLast (value + 1))) (P.sourceUnfoldrM value) ] ] diff --git a/benchmark/Streamly/Benchmark/Data/Array/Mut.hs b/benchmark/Streamly/Benchmark/Data/Array/Mut.hs deleted file mode 100644 --- a/benchmark/Streamly/Benchmark/Data/Array/Mut.hs +++ /dev/null @@ -1,300 +0,0 @@ -{-# OPTIONS_GHC -Wno-deprecations #-} -{-# OPTIONS_GHC -Wno-orphans #-} - --- | --- Module : Streamly.Benchmark.Data.Array.Unboxed.Mut --- Copyright : (c) 2021 Composewell Technologies --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com - -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} - -#ifdef __HADDOCK_VERSION__ -#undef INSPECTION -#endif - -#ifdef INSPECTION -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-} -#endif - -import Control.DeepSeq (NFData(..)) -import Control.Monad.IO.Class (MonadIO) -import Data.Functor ((<&>)) -import System.Random (randomRIO) -import Prelude - ( IO - , Int - , Integral(..) - , Maybe(..) - , Monad(..) - , Num(..) - , Ord(..) - , String - , ($) - , (.) - , (||) - , concat - , const - , fmap - , id - , undefined - ) -import Streamly.Internal.Data.Array.Mut (MutArray) - -import qualified Streamly.Internal.Data.Array as Array -import qualified Streamly.Internal.Data.Array.Mut as MArray -import qualified Streamly.Internal.Data.Fold as Fold -import qualified Streamly.Internal.Data.Stream.StreamD as Stream - -import Gauge -import Streamly.Benchmark.Common hiding (benchPureSrc) - -type Stream = MutArray - -instance NFData (MutArray a) where - {-# INLINE rnf #-} - rnf _ = () - -------------------------------------------------------------------------------- --- Benchmark helpers -------------------------------------------------------------------------------- - -{-# INLINE benchIO #-} -benchIO :: NFData b => String -> (Int -> IO a) -> (a -> b) -> Benchmark -benchIO name src f = bench name $ nfIO $ - (randomRIO (1,1) >>= src) <&> f - -{-# INLINE benchPureSink #-} -benchPureSink :: NFData b => Int -> String -> (Stream Int -> b) -> Benchmark -benchPureSink value name = benchIO name (sourceIntFromTo value) - -{-# 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 => Int -> String -> (Stream Int -> IO b) -> Benchmark -benchIOSink value name = benchIO' name (sourceIntFromTo value) - --- Drain a source that generates an array in the IO monad -{-# INLINE benchIOSrc #-} -benchIOSrc :: String -> (Int -> IO (Stream a)) -> Benchmark -benchIOSrc name src = benchIO name src id - -drain :: Monad m => Stream.Stream m a -> m () -drain = Stream.fold Fold.drain - -------------------------------------------------------------------------------- --- Bench Ops -------------------------------------------------------------------------------- - -{-# INLINE sourceUnfoldr #-} -sourceUnfoldr :: MonadIO m => Int -> Int -> m (Stream Int) -sourceUnfoldr value n = - Stream.fold (MArray.writeN value) $ Stream.unfoldr step n - - where - - step cnt = - if cnt > n + value - then Nothing - else Just (cnt, cnt + 1) - -{-# INLINE sourceIntFromTo #-} -sourceIntFromTo :: MonadIO m => Int -> Int -> m (Stream Int) -sourceIntFromTo value n = - Stream.fold (MArray.writeN value) $ Stream.enumerateFromTo n (n + value) - -{-# INLINE sourceFromList #-} -sourceFromList :: MonadIO m => Int -> Int -> m (Stream Int) -sourceFromList value n = - Stream.fold (MArray.writeN value) $ Stream.fromList [n .. n + value] - -{-# INLINE sourceIntFromToFromList #-} -sourceIntFromToFromList :: MonadIO m => Int -> Int -> m (Stream Int) -sourceIntFromToFromList value n = MArray.fromListN value [n..n + value] - -{-# INLINE sourceIntFromToFromStream #-} -sourceIntFromToFromStream :: MonadIO m => Int -> Int -> m (Stream Int) -sourceIntFromToFromStream value n = - Stream.fold MArray.write $ Stream.enumerateFromTo n (n + value) - -{-# INLINE sourceUnfoldrM #-} -sourceUnfoldrM :: Monad m => Int -> Int -> Stream.Stream m Int -sourceUnfoldrM value n = Stream.unfoldrM step n - where - step cnt = - if cnt > n + value - then return Nothing - else return (Just (cnt, cnt + 1)) - -------------------------------------------------------------------------------- --- Transformation -------------------------------------------------------------------------------- - -{-# INLINE composeN #-} -composeN :: 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 >>= f - 3 -> f x >>= f >>= f - 4 -> f x >>= f >>= f >>= f - _ -> undefined - -{-# INLINE scanl' #-} -scanl' :: MonadIO m => Int -> Int -> Stream Int -> m (Stream Int) -scanl' value n = composeN n $ onArray value $ Stream.scan (Fold.foldl' (+) 0) - -{-# INLINE scanl1' #-} -scanl1' :: MonadIO m => Int -> Int -> Stream Int -> m (Stream Int) -scanl1' value n = composeN n $ onArray value $ Stream.scanl1' (+) - -{-# INLINE map #-} -map :: MonadIO m => Int -> Int -> Stream Int -> m (Stream Int) -map value n = composeN n $ onArray value $ fmap (+ 1) - -{-# INLINE onArray #-} -onArray - :: MonadIO m => Int -> (Stream.Stream m Int -> Stream.Stream m Int) - -> Stream Int - -> m (Stream Int) -onArray value f arr = - Stream.fold (MArray.writeN value) $ f $ Stream.unfold MArray.reader arr - -------------------------------------------------------------------------------- --- Elimination -------------------------------------------------------------------------------- - -{-# INLINE unfoldReadDrain #-} -unfoldReadDrain :: MonadIO m => Stream Int -> m () -unfoldReadDrain = drain . Stream.unfold MArray.reader - -{-# INLINE unfoldReadRevDrain #-} -unfoldReadRevDrain :: MonadIO m => Stream Int -> m () -unfoldReadRevDrain = drain . Stream.unfold MArray.readerRev - -{-# INLINE toStreamDRevDrain #-} -toStreamDRevDrain :: MonadIO m => Stream Int -> m () -toStreamDRevDrain = drain . MArray.toStreamDRev - -{-# INLINE toStreamDDrain #-} -toStreamDDrain :: MonadIO m => Stream Int -> m () -toStreamDDrain = drain . MArray.toStreamD - -{-# INLINE unfoldFold #-} -unfoldFold :: MonadIO m => Stream Int -> m Int -unfoldFold = Stream.fold (Fold.foldl' (+) 0) . Stream.unfold MArray.reader - -------------------------------------------------------------------------------- --- Bench groups -------------------------------------------------------------------------------- - -o_1_space_generation :: Int -> [Benchmark] -o_1_space_generation value = - [ bgroup - "generation" - [ benchIOSrc "writeN . intFromTo" (sourceIntFromTo value) - , benchIOSrc - "fromList . intFromTo" - (sourceIntFromToFromList value) - , benchIOSrc "writeN . unfoldr" (sourceUnfoldr value) - , benchIOSrc "writeN . fromList" (sourceFromList value) - , benchIOSrc "write . intFromTo" (sourceIntFromToFromStream value) - ] - ] - -o_1_space_elimination :: Int -> [Benchmark] -o_1_space_elimination value = - [ bgroup "elimination" - [ benchPureSink value "id" id - , benchIOSink value "foldl'" unfoldFold - , benchIOSink value "read" unfoldReadDrain - , benchIOSink value "readRev" unfoldReadRevDrain - , benchIOSink value "toStream" toStreamDDrain - , benchIOSink value "toStreamRev" toStreamDRevDrain - ] - ] - -o_n_heap_serial :: Int -> [Benchmark] -o_n_heap_serial value = - [ bgroup "elimination" - [ - -- Converting the stream to an array - benchFold "writeN" (Stream.fold (MArray.writeN value)) - (sourceUnfoldrM value) - ] - ] - -o_1_space_transformation :: Int -> [Benchmark] -o_1_space_transformation value = - [ bgroup "transformation" - [ benchIOSink value "scanl'" (scanl' value 1) - , benchIOSink value "scanl1'" (scanl1' value 1) - , benchIOSink value "map" (map value 1) - ] - ] - -o_1_space_transformationX4 :: Int -> [Benchmark] -o_1_space_transformationX4 value = - [ bgroup "transformationX4" - [ benchIOSink value "scanl'" (scanl' value 4) - , benchIOSink value "scanl1'" (scanl1' value 4) - , benchIOSink value "map" (map value 4) - ] - ] - -o_1_space_serial_marray :: - Int -> (MutArray Int, Array.Array Int) -> [Benchmark] -o_1_space_serial_marray value ~(array, indices) = - [ benchIO' "partitionBy (< 0)" (const (return array)) - $ MArray.partitionBy (< 0) - , benchIO' "partitionBy (> 0)" (const (return array)) - $ MArray.partitionBy (> 0) - , benchIO' "partitionBy (< value/2)" (const (return array)) - $ MArray.partitionBy (< (value `div` 2)) - , benchIO' "partitionBy (> value/2)" (const (return array)) - $ MArray.partitionBy (> (value `div` 2)) - , benchIO' "strip (< value/2 || > value/2)" (const (return array)) - $ MArray.strip (\x -> x < value `div` 2 || x > value `div` 2) - , benchIO' "strip (> 0)" (const (return array)) - $ MArray.strip (> 0) - , benchIO' "modifyIndices (+ 1)" (const (return indices)) - $ Stream.fold (MArray.modifyIndices array (\_idx val -> val + 1)) - . Stream.unfold Array.reader - ] - -------------------------------------------------------------------------------- --- Driver -------------------------------------------------------------------------------- - -moduleName :: String -moduleName = "Data.Array.Mut" - -main :: IO () -main = do - runWithCLIOptsEnv defaultStreamSize alloc allBenchmarks - - where - - alloc value = do - marr <- MArray.fromStream (sourceUnfoldrM value 0 :: Stream.Stream IO Int) - indices <- Array.fromStream (sourceUnfoldrM value 0 :: Stream.Stream IO Int) - return (marr, indices) - - allBenchmarks array value = - [ bgroup (o_1_space_prefix moduleName) - $ concat - [ o_1_space_serial_marray value array - , o_1_space_generation value - , o_1_space_elimination value - , o_1_space_transformation value - , o_1_space_transformationX4 value - ] - , bgroup (o_n_heap_prefix moduleName) (o_n_heap_serial value) - ] diff --git a/benchmark/Streamly/Benchmark/Data/Array/Stream.hs b/benchmark/Streamly/Benchmark/Data/Array/Stream.hs --- a/benchmark/Streamly/Benchmark/Data/Array/Stream.hs +++ b/benchmark/Streamly/Benchmark/Data/Array/Stream.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -Wno-deprecations #-} -- | -- Module : Streamly.Benchmark.Data.ParserD @@ -31,30 +30,29 @@ import Data.Functor.Identity (runIdentity) import Data.Maybe (isJust) import Data.Word (Word8) -import Streamly.Internal.Data.Stream.StreamD (Stream) -import Streamly.Internal.Data.Stream.StreamK (StreamK) +import Streamly.Internal.Data.Stream (Stream) +import Streamly.Internal.Data.StreamK (StreamK) import System.IO (Handle) import System.Random (randomRIO) import Prelude hiding () import qualified Streamly.Data.Stream as Stream import qualified Streamly.Internal.Data.Array as Array -import qualified Streamly.Internal.Data.Stream.Chunked as ArrayStream import qualified Streamly.Internal.Data.Fold as Fold import qualified Streamly.Internal.Data.Parser as Parser -import qualified Streamly.Internal.Data.Stream.StreamD as Stream -import qualified Streamly.Internal.Data.Stream.StreamK as StreamK +import qualified Streamly.Internal.Data.Stream as Stream +import qualified Streamly.Internal.Data.StreamK as StreamK import qualified Streamly.Internal.FileSystem.Handle as Handle import qualified Streamly.Internal.Unicode.Stream as Unicode -import Gauge hiding (env) +import Test.Tasty.Bench hiding (env) import Streamly.Benchmark.Common import Streamly.Benchmark.Common.Handle import Control.Monad.IO.Class (MonadIO) #ifdef INSPECTION -import Streamly.Internal.Data.Unboxed (Unbox) -import Streamly.Internal.Data.Stream.StreamD.Type (Step(..)) +import Streamly.Internal.Data.MutByteArray (Unbox) +import Streamly.Internal.Data.Stream (Step(..)) import Test.Inspection #endif @@ -138,7 +136,7 @@ toChunksSplitOnSuffix :: Handle -> IO Int toChunksSplitOnSuffix = Stream.fold Fold.length - . ArrayStream.splitOnSuffix 10 + . Array.compactEndByByte_ 10 . Handle.readChunks #ifdef INSPECTION @@ -151,7 +149,7 @@ toChunksSplitOn :: Handle -> IO Int toChunksSplitOn = Stream.fold Fold.length - . ArrayStream.splitOn 32 + . Array.compactSepByByte_ 32 . Handle.readChunks #ifdef INSPECTION @@ -190,7 +188,7 @@ copyChunksSplitInterposeSuffix :: Handle -> Handle -> IO () copyChunksSplitInterposeSuffix inh outh = Stream.fold (Handle.write outh) - $ ArrayStream.interposeSuffix 10 . ArrayStream.splitOnSuffix 10 + $ Array.concatEndBy 10 . Array.compactEndByByte_ 10 $ Handle.readChunks inh #ifdef INSPECTION @@ -204,7 +202,7 @@ copyChunksSplitInterpose inh outh = Stream.fold (Handle.write outh) -- XXX this is not correct word splitting combinator - $ ArrayStream.interpose 32 . ArrayStream.splitOn 32 + $ Array.concatSepBy 32 . Array.compactSepByByte_ 32 $ Handle.readChunks inh #ifdef INSPECTION @@ -236,23 +234,25 @@ {-# INLINE fold #-} fold :: Stream IO (Array.Array Int) -> IO () -fold s = void $ ArrayStream.foldBreak Fold.drain $ StreamK.fromStream s +fold s = void $ Array.foldBreak Fold.drain $ StreamK.fromStream s {-# INLINE parse #-} parse :: Int -> Stream IO (Array.Array Int) -> IO () parse value s = - void $ ArrayStream.parseBreak (drainWhile (< value)) $ StreamK.fromStream s + void $ Array.parseBreak + (Array.toParserK (drainWhile (< value))) + (StreamK.fromStream s) {-# INLINE foldBreak #-} foldBreak :: StreamK IO (Array.Array Int) -> IO () foldBreak s = do - (r, s1) <- ArrayStream.foldBreak Fold.one s + (r, s1) <- Array.foldBreak Fold.one s when (isJust r) $ foldBreak s1 {-# INLINE parseBreak #-} parseBreak :: StreamK IO (Array.Array Int) -> IO () parseBreak s = do - r <- ArrayStream.parseBreak Parser.one s + r <- Array.parseBreak (Array.toParserK Parser.one) s case r of (Left _, _) -> return () (Right _, s1) -> parseBreak s1 @@ -295,8 +295,8 @@ then return (undefined, undefined) else do - small <- Stream.toList $ Stream.chunksOf 100 $ sourceUnfoldrM value 0 - big <- Stream.toList $ Stream.chunksOf value $ sourceUnfoldrM value 0 + small <- Stream.toList $ Array.chunksOf 100 $ sourceUnfoldrM value 0 + big <- Stream.toList $ Array.chunksOf value $ sourceUnfoldrM value 0 return (small, big) allBenchmarks env arrays value = diff --git a/benchmark/Streamly/Benchmark/Data/Fold.hs b/benchmark/Streamly/Benchmark/Data/Fold.hs --- a/benchmark/Streamly/Benchmark/Data/Fold.hs +++ b/benchmark/Streamly/Benchmark/Data/Fold.hs @@ -5,41 +5,72 @@ -- License : MIT -- Maintainer : streamly@composewell.com +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} {-# OPTIONS_GHC -Wno-orphans #-} +#undef FUSION_CHECK +#ifdef FUSION_CHECK +{-# OPTIONS_GHC -ddump-simpl -ddump-to-file -dsuppress-all #-} +#endif + +#ifdef __HADDOCK_VERSION__ +#undef INSPECTION +#endif + +#ifdef INSPECTION +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-} +#endif + module Main (main) where import Control.DeepSeq (NFData(..)) import Control.Monad (when) import Control.Monad.IO.Class (MonadIO(..)) +import Data.Char (ord) +import Streamly.Internal.Data.Array (Array) import Data.Functor.Identity (Identity(..)) import Data.Map.Strict (Map) -import Data.Hashable (Hashable) -import Data.HashMap.Strict (HashMap) import Data.IntMap.Strict (IntMap) import Data.Monoid (Last(..), Sum(..)) +import Data.Word (Word8) +import System.IO (Handle) import System.Random (randomRIO) -import Streamly.Internal.Data.Stream.StreamD (Stream) +import Streamly.Internal.Data.Stream (Stream) import Streamly.Internal.Data.Fold (Fold(..)) -import Streamly.Internal.Data.IsMap.HashMap () -import Streamly.Internal.Data.Array.Mut (MutArray) +import Streamly.Internal.Data.MutArray (MutArray) +import qualified Streamly.Internal.Data.Array as Array import qualified Streamly.Internal.Data.Fold as FL -import qualified Streamly.Internal.Data.Fold.Container as FL -import qualified Streamly.Internal.Data.Unfold as Unfold +import qualified Streamly.Internal.Data.Scanl as Scanl +import qualified Streamly.Internal.Data.Fold as Fold +import qualified Streamly.Internal.Data.Parser as Parser import qualified Streamly.Internal.Data.Pipe as Pipe -import qualified Streamly.Internal.Data.Stream.StreamD as Stream +-- import qualified Streamly.Internal.Data.Scan as Scan +import qualified Streamly.Internal.Data.Stream as Stream +import qualified Streamly.Internal.Data.Unfold as Unfold +import qualified Streamly.Internal.FileSystem.Handle as Handle +import qualified Streamly.Internal.Unicode.Stream as Unicode -import Gauge +import Test.Tasty.Bench hiding (env) import Streamly.Benchmark.Common -import Prelude hiding (all, any, take, unzip, sequence_, filter) +import Streamly.Benchmark.Common.Handle +import Prelude hiding (last, length, all, any, take, unzip, sequence_, filter) +#ifdef INSPECTION +import Streamly.Internal.Data.Stream (Step(..)) + +import qualified Streamly.Internal.Data.MutArray as MutArray +import qualified Streamly.Internal.Data.Unfold as Unfold + +import Test.Inspection +#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. @@ -99,27 +130,19 @@ {-# INLINE scanMaybe #-} scanMaybe :: Monad m => Int -> Stream m Int -> m () -scanMaybe _ = Stream.fold (FL.scanMaybe (FL.filtering even) FL.drain) +scanMaybe _ = Stream.fold (FL.postscanlMaybe (Scanl.filtering even) FL.drain) {-# INLINE scanMaybe2 #-} scanMaybe2 :: Monad m => Int -> Stream m Int -> m () scanMaybe2 _ = Stream.fold - $ FL.scanMaybe (FL.filtering even) - $ FL.scanMaybe (FL.filtering odd) FL.drain + $ FL.postscanlMaybe (Scanl.filtering even) + $ FL.postscanlMaybe (Scanl.filtering odd) FL.drain ------------------------------------------------------------------------------- --- Splitting by serial application +-- Splitting in two ------------------------------------------------------------------------------- -{-# INLINE takeEndBy_ #-} -takeEndBy_ :: Monad m => Int -> Stream m Int -> m () -takeEndBy_ value = Stream.fold (FL.takeEndBy_ (>= value) FL.drain) - -{-# INLINE many #-} -many :: Monad m => Stream m Int -> m () -many = Stream.fold (FL.many (FL.take 1 FL.drain) FL.drain) - {-# INLINE splitAllAny #-} splitAllAny :: Monad m => Int -> Stream m Int -> m (Bool, Bool) splitAllAny value = @@ -153,6 +176,201 @@ when (r /= 0) $ foldBreak s1 ------------------------------------------------------------------------------- +-- Split generated streams (not a file) +------------------------------------------------------------------------------- + +{-# INLINE many #-} +many :: Monad m => Stream m Int -> m () +many = Stream.fold (FL.many (FL.take 1 FL.drain) FL.drain) + +{-# INLINE takeEndBy_ #-} +takeEndBy_ :: Monad m => Int -> Stream m Int -> m () +takeEndBy_ value = Stream.fold (FL.takeEndBy_ (>= value) FL.drain) + +------------------------------------------------------------------------------- +-- Splitting a file stream into a stream by serial application +------------------------------------------------------------------------------- + +lf :: Word8 +lf = fromIntegral (ord '\n') + +toarr :: String -> Array Word8 +toarr = Array.fromList . map (fromIntegral . ord) + +-- | Split on line feed. +fileInfixTakeEndBy_ :: Handle -> IO Int +fileInfixTakeEndBy_ inh = + Stream.fold Fold.length + $ Stream.foldManyPost (FL.takeEndBy_ (== lf) Fold.drain) + $ Handle.read inh -- >>= print + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'fileInfixTakeEndBy_ +inspect $ 'fileInfixTakeEndBy_ `hasNoType` ''Step +inspect $ 'fileInfixTakeEndBy_ `hasNoType` ''Unfold.ConcatState -- FH.read/UF.many +inspect $ 'fileInfixTakeEndBy_ `hasNoType` ''MutArray.ArrayUnsafe -- FH.read/A.read +#endif + +-- | Split on line feed. +fileSuffixTakeEndBy_ :: Handle -> IO Int +fileSuffixTakeEndBy_ inh = + Stream.fold Fold.length + $ Stream.foldMany + (Fold.takeEndBy_ (== lf) Fold.drain) + (Handle.read inh) + -- >>= print + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'fileSuffixTakeEndBy_ +inspect $ 'fileSuffixTakeEndBy_ `hasNoType` ''Step +inspect $ 'fileSuffixTakeEndBy_ `hasNoType` ''Unfold.ConcatState -- FH.read/UF.many +inspect $ 'fileSuffixTakeEndBy_ `hasNoType` ''MutArray.ArrayUnsafe -- FH.read/A.read +#endif + +-- | Split on line feed. +parseFileSuffixTakeEndBy_ :: Handle -> IO Int +parseFileSuffixTakeEndBy_ inh = + Stream.fold Fold.length + $ Stream.parseMany + (Parser.fromFold $ Fold.takeEndBy_ (== lf) Fold.drain) + (Handle.read inh) + -- >>= print + +-- | Split suffix with line feed. +fileSuffixTakeEndBy :: Handle -> IO Int +fileSuffixTakeEndBy inh = + Stream.fold Fold.length + $ Stream.foldMany + (Fold.takeEndBy (== lf) Fold.drain) + (Handle.read inh) + -- >>= print + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'fileSuffixTakeEndBy +inspect $ 'fileSuffixTakeEndBy `hasNoType` ''Step +inspect $ 'fileSuffixTakeEndBy `hasNoType` ''Unfold.ConcatState -- FH.read/UF.many +inspect $ 'fileSuffixTakeEndBy `hasNoType` ''MutArray.ArrayUnsafe -- FH.read/A.read +#endif + +-- | Infix split on a word8 sequence. +splitOnSeq :: String -> Handle -> IO Int +splitOnSeq str inh = + Stream.fold Fold.length + $ Stream.foldManyPost (Fold.takeEndBySeq_ (toarr str) Fold.drain) + $ Handle.read inh -- >>= print + +#ifdef INSPECTION +-- inspect $ hasNoTypeClasses 'splitOnSeq +-- inspect $ 'splitOnSeq `hasNoType` ''Step +#endif + +-- | Infix split on a word8 sequence. +splitOnSeq100k :: Handle -> IO Int +splitOnSeq100k inh = do + arr <- Stream.fold Array.create $ Stream.replicate 100000 123 + Stream.fold Fold.length + $ Stream.foldManyPost (Fold.takeEndBySeq_ arr Fold.drain) + $ Handle.read inh -- >>= print + +-- | Split on suffix sequence. +splitOnSuffixSeq :: String -> Handle -> IO Int +splitOnSuffixSeq str inh = + Stream.fold Fold.length + $ Stream.foldMany (Fold.takeEndBySeq_ (toarr str) Fold.drain) + $ Handle.read inh -- >>= print + +#ifdef INSPECTION +-- inspect $ hasNoTypeClasses 'splitOnSuffixSeq +-- inspect $ 'splitOnSuffixSeq `hasNoType` ''Step +#endif + +-- | Split on suffix sequence. +splitWithSuffixSeq :: String -> Handle -> IO Int +splitWithSuffixSeq str inh = + Stream.fold Fold.length + $ Stream.foldMany (Fold.takeEndBySeq (toarr str) Fold.drain) + $ Handle.read inh -- >>= print + +o_1_space_reduce_read_split :: BenchEnv -> [Benchmark] +o_1_space_reduce_read_split env = + -- NOTE: keep the benchmark names consistent with Data.Stream.split* + [ bgroup "FileSplitElem" + -- Splitting on single element + [ + mkBench "takeEndBy_ infix (splitOn)" env $ \inh _ -> + fileInfixTakeEndBy_ inh + , mkBench "takeEndBy_ suffix (splitOnSuffix)" env $ \inh _ -> + fileSuffixTakeEndBy_ inh + , mkBench "takeEndBy_ suffix parseMany (splitOnSuffix)" env + $ \inh _ -> parseFileSuffixTakeEndBy_ inh + , mkBench "takeEndBy suffix (splitWithSuffix)" env $ \inh _ -> + fileSuffixTakeEndBy inh + ] + + -- Splitting on sequence + , bgroup "FileSplitSeq" + [ + -- Infix takeEndBySeq_ + mkBench "takeEndBySeq_ infix empty pattern" env $ \inh _ -> + splitOnSeq "" inh + , mkBench "takeEndBySeq_ infix lf" env $ \inh _ -> + splitOnSeq "\n" inh + , mkBench "takeEndBySeq_ infix a" env $ \inh _ -> + splitOnSeq "a" inh + , mkBench "takeEndBySeq_ infix crlf" env $ \inh _ -> + splitOnSeq "\r\n" inh + , mkBench "takeEndBySeq_ infix aa" env $ \inh _ -> + splitOnSeq "aa" inh + , mkBench "takeEndBySeq_ infix aaaa" env $ \inh _ -> + splitOnSeq "aaaa" inh + , mkBench "takeEndBySeq_ infix abcdefgh" env $ \inh _ -> + splitOnSeq "abcdefgh" inh + , mkBench "takeEndBySeq_ infix abcdefghi" env $ \inh _ -> + splitOnSeq "abcdefghi" inh + , mkBench "takeEndBySeq_ infix catcatcatcatcat" env $ \inh _ -> + splitOnSeq "catcatcatcatcat" inh + , mkBench "takeEndBySeq_ infix abcdefghijklmnopqrstuvwxyz" + env $ \inh _ -> splitOnSeq "abcdefghijklmnopqrstuvwxyz" inh + , mkBench "takeEndBySeq_ infix 100k long pattern" + env $ \inh _ -> splitOnSeq100k inh + + -- Suffix takeEndBySeq_ + , mkBench "takeEndBySeq_ suffix empty pattern" env $ \inh _ -> + splitOnSuffixSeq "" inh + , mkBench "takeEndBySeq_ suffix lf" env $ \inh _ -> + splitOnSuffixSeq "\n" inh + , mkBench "takeEndBySeq_ suffix crlf" env $ \inh _ -> + splitOnSuffixSeq "\r\n" inh + , mkBenchSmall "takeEndBySeq_ suffix abcdefghijklmnopqrstuvwxyz" + env $ \inh _ -> splitOnSuffixSeq "abcdefghijklmnopqrstuvwxyz" inh + + -- Suffix takeEndBySeq + , mkBench "takeEndBySeq suffix crlf" env $ \inh _ -> + splitWithSuffixSeq "\r\n" inh + , mkBenchSmall "takeEndBySeq suffix abcdefghijklmnopqrstuvwxyz" + env $ \inh _ -> splitWithSuffixSeq "abcdefghijklmnopqrstuvwxyz" inh + ] + ] + +-- | Infix split on a character sequence. +splitOnSeqUtf8 :: String -> Handle -> IO Int +splitOnSeqUtf8 str inh = + Stream.fold Fold.length + $ Stream.foldManyPost (Fold.takeEndBySeq_ (Array.fromList str) Fold.drain) + $ Unicode.decodeUtf8Chunks + $ Handle.readChunks inh -- >>= print + +o_1_space_reduce_toChunks_split :: BenchEnv -> [Benchmark] +o_1_space_reduce_toChunks_split env = + [ bgroup "FileSplitSeqUtf8" + [ mkBenchSmall "takeEndBySeq_ infix abcdefgh" + env $ \inh _ -> splitOnSeqUtf8 "abcdefgh" inh + , mkBenchSmall "takeEndBySeq_ infix abcdefghijklmnopqrstuvwxyz" + env $ \inh _ -> splitOnSeqUtf8 "abcdefghijklmnopqrstuvwxyz" inh + ] + ] + +------------------------------------------------------------------------------- -- Distributing by parallel application ------------------------------------------------------------------------------- @@ -205,28 +423,18 @@ {-# INLINE demuxToMap #-} demuxToMap :: (Monad m, Ord k) => - (a -> k) -> (a -> m (Fold m a b)) -> Stream m a -> m (Map k b) -demuxToMap f g = Stream.fold (FL.demuxToContainer f g) + (a -> k) -> (k -> m (Maybe (Fold m a b))) -> Stream m a -> m (Map k b) +demuxToMap f g = Stream.fold (FL.demuxerToContainer f g) {-# INLINE demuxToIntMap #-} demuxToIntMap :: Monad m => - (a -> Int) -> (a -> m (Fold m a b)) -> Stream m a -> m (IntMap b) -demuxToIntMap f g = Stream.fold (FL.demuxToContainer f g) - -{-# INLINE demuxToHashMap #-} -demuxToHashMap :: (Monad m, Ord k, Hashable k) => - (a -> k) -> (a -> m (Fold m a b)) -> Stream m a -> m (HashMap k b) -demuxToHashMap f g = Stream.fold (FL.demuxToContainer f g) + (a -> Int) -> (Int -> m (Maybe (Fold m a b))) -> Stream m a -> m (IntMap b) +demuxToIntMap f g = Stream.fold (FL.demuxerToContainer f g) {-# INLINE demuxToMapIO #-} demuxToMapIO :: (MonadIO m, Ord k) => - (a -> k) -> (a -> m (Fold m a b)) -> Stream m a -> m (Map k b) -demuxToMapIO f g = Stream.fold (FL.demuxToContainerIO f g) - -{-# INLINE demuxToHashMapIO #-} -demuxToHashMapIO :: (MonadIO m, Ord k, Hashable k) => - (a -> k) -> (a -> m (Fold m a b)) -> Stream m a -> m (HashMap k b) -demuxToHashMapIO f g = Stream.fold (FL.demuxToContainerIO f g) + (a -> k) -> (k -> m (Maybe (Fold m a b))) -> Stream m a -> m (Map k b) +demuxToMapIO f g = Stream.fold (FL.demuxerToContainerIO f g) {-# INLINE toMap #-} toMap :: @@ -248,11 +456,6 @@ (MonadIO m, Num a) => (a -> Int) -> Stream m a -> m (IntMap a) toIntMapIO f = Stream.fold (FL.toContainerIO f FL.sum) -{-# INLINE toHashMapIO #-} -toHashMapIO :: (MonadIO m, Ord k, Num a, Hashable k) => - (a -> k) -> Stream m a -> m (HashMap k a) -toHashMapIO f = Stream.fold (FL.toContainerIO f FL.sum) - ------------------------------------------------------------------------------- -- unzip ------------------------------------------------------------------------------- @@ -264,13 +467,13 @@ {-# INLINE unzipWithFstM #-} unzipWithFstM :: Monad m => Stream m Int -> m (Int, Int) unzipWithFstM = do - let f = \a -> return (a + 1, a) + let f a = return (a + 1, a) Stream.fold (FL.unzipWithFstM f FL.sum FL.length) {-# INLINE unzipWithMinM #-} unzipWithMinM :: Monad m => Stream m Int -> m (Int, Int) unzipWithMinM = do - let f = \a -> return (a + 1, a) + let f a = return (a + 1, a) Stream.fold (FL.unzipWithMinM f FL.sum FL.length) ------------------------------------------------------------------------------- @@ -303,9 +506,9 @@ o_1_space_serial_elimination value = [ bgroup "elimination" [ benchIOSink value "drain" (Stream.fold FL.drain) - , benchIOSink value "drainBy" (Stream.fold (FL.drainBy return)) + , benchIOSink value "drainBy" (Stream.fold (FL.drainMapM return)) , benchIOSink value "drainN" (Stream.fold (FL.drainN value)) - , benchIOSink value "last" (Stream.fold FL.last) + , benchIOSink value "last" (Stream.fold FL.latest) , benchIOSink value "length" (Stream.fold FL.length) , benchIOSink value "top" (Stream.fold $ FL.top 10) , benchIOSink value "bottom" (Stream.fold $ FL.bottom 10) @@ -320,6 +523,11 @@ value "mean" (Stream.fold FL.mean . fmap (fromIntegral :: Int -> Double)) +{- + -- These are already benchmarked in streamly-statistics package. If we + -- still want to keep these tests here, perhaps we should move them to a + -- different module so we can remove -fno-warn-warnings-deprecations. + , benchIOSink value "variance" @@ -328,6 +536,7 @@ value "stdDev" (Stream.fold FL.stdDev . fmap (fromIntegral :: Int -> Double)) +-} , benchIOSink value "mconcat" @@ -341,7 +550,7 @@ "foldMapM" (Stream.fold (FL.foldMapM (return . Last . Just))) , benchIOSink value "index" (Stream.fold (FL.index (value + 1))) - , benchIOSink value "head" (Stream.fold FL.head) + -- , benchIOSink value "head" (Stream.fold FL.head) , benchIOSink value "find" (Stream.fold (FL.find (== (value + 1)))) , benchIOSink value @@ -355,7 +564,7 @@ value "elemIndex" (Stream.fold (FL.elemIndex (value + 1))) - , benchIOSink value "null" (Stream.fold FL.null) + -- , benchIOSink value "null" (Stream.fold FL.null) , benchIOSink value "elem" (Stream.fold (FL.elem (value + 1))) , benchIOSink value "notElem" (Stream.fold (FL.notElem (value + 1))) , benchIOSink value "all" $ all value @@ -383,21 +592,30 @@ value "pipe-mapM" (Stream.fold - (FL.transform + (FL.pipe (Pipe.mapM (\x -> return $ x + 1)) FL.drain)) +{- , benchIOSink + value + "fold-runScan" + (Stream.fold + (FL.runScan + (Scan.functionM (\x -> return $ x + 1)) + FL.drain)) +-} + , benchIOSink value "fold-scan" - (Stream.fold $ FL.scan FL.sum FL.drain) + (Stream.fold $ FL.scanl Scanl.sum FL.drain) , benchIOSink value "fold-scanMany" - (Stream.fold $ FL.scanMany (FL.take 2 FL.drain) FL.drain) + (Stream.fold $ FL.scanlMany (Scanl.take 2 Scanl.drain) FL.drain) , benchIOSink value "fold-postscan" - (Stream.fold $ FL.postscan FL.sum FL.drain) + (Stream.fold $ FL.postscanl Scanl.sum FL.drain) ] ] @@ -453,15 +671,11 @@ , bgroup "key-value" [ benchIOSink value "demuxToMap (64 buckets) [sum, length]" - $ demuxToMap (getKey 64) (getFold . getKey 64) + $ demuxToMap (getKey 64) getFold , benchIOSink value "demuxToIntMap (64 buckets) [sum, length]" - $ demuxToIntMap (getKey 64) (getFold . getKey 64) - , benchIOSink value "demuxToHashMap (64 buckets) [sum, length]" - $ demuxToHashMap (getKey 64) (getFold . getKey 64) + $ demuxToIntMap (getKey 64) getFold , benchIOSink value "demuxToMapIO (64 buckets) [sum, length]" - $ demuxToMapIO (getKey 64) (getFold . getKey 64) - , benchIOSink value "demuxToHashMapIO (64 buckets) [sum, length]" - $ demuxToHashMapIO (getKey 64) (getFold . getKey 64) + $ demuxToMapIO (getKey 64) getFold -- classify: immutable , benchIOSink value "toMap (64 buckets) sum" @@ -478,12 +692,6 @@ $ toMapIO (getKey value) , benchIOSink value "toIntMapIO (64 buckets) sum" $ toIntMapIO (getKey 64) - , benchIOSink value "toHashMapIO (single bucket) sum" - $ toHashMapIO (getKey 1) - , benchIOSink value "toHashMapIO (64 buckets) sum" - $ toHashMapIO (getKey 64) - , benchIOSink value "toHashMapIO (max buckets) sum" - $ toHashMapIO (getKey value) ] ] @@ -492,7 +700,7 @@ getKey buckets = (`mod` buckets) getFold k = - return $ case k of + return $ Just $ case k of 0 -> FL.sum 1 -> FL.length _ -> FL.length @@ -502,16 +710,38 @@ ------------------------------------------------------------------------------- main :: IO () -main = runWithCLIOpts defaultStreamSize allBenchmarks +main = do +#ifndef FUSION_CHECK + env <- mkHandleBenchEnv + runWithCLIOpts defaultStreamSize (allBenchmarks env) where - allBenchmarks value = + allBenchmarks env value = [ bgroup (o_1_space_prefix moduleName) $ concat [ o_1_space_serial_elimination value , o_1_space_serial_transformation value , o_1_space_serial_composition value + , o_1_space_reduce_read_split env + , o_1_space_reduce_toChunks_split env ] , bgroup (o_n_space_prefix moduleName) (o_n_space_serial value) , bgroup (o_n_heap_prefix moduleName) (o_n_heap_serial value) ] +#else + -- Enable FUSION_CHECK macro at the beginning of the file + -- Enable one benchmark below, and run the benchmark + -- Check the .dump-simpl output + let value = 100000 + let input = source value 1 + let getKey buckets = (`mod` buckets) + let getFold k = + return $ case k of + 0 -> FL.sum + 1 -> FL.length + _ -> FL.length + + -- demuxToMap (getKey 64) (getFold . getKey 64) input + toIntMapIO (getKey 64) input + return () +#endif diff --git a/benchmark/Streamly/Benchmark/Data/Fold/Prelood.hs b/benchmark/Streamly/Benchmark/Data/Fold/Prelood.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Data/Fold/Prelood.hs @@ -0,0 +1,172 @@ +-- | +-- Module : Streamly.Benchmark.Data.Fold.Prelude +-- Copyright : (c) 2018 Composewell +-- +-- License : MIT +-- Maintainer : streamly@composewell.com + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +#undef FUSION_CHECK +#ifdef FUSION_CHECK +{-# OPTIONS_GHC -ddump-simpl -ddump-to-file -dsuppress-all #-} +#endif + +module Main (main) where + +import Control.DeepSeq (NFData(..)) +import Control.Monad.IO.Class (MonadIO(..)) +import Data.Functor.Identity (Identity(..)) +import Data.Hashable (Hashable) +import Data.HashMap.Strict (HashMap) +import System.Random (randomRIO) + +import Streamly.Internal.Data.Stream (Stream) +import Streamly.Internal.Data.Fold (Fold(..)) +import Streamly.Internal.Data.IsMap.HashMap () +import Streamly.Internal.Data.MutArray (MutArray) + +import qualified Streamly.Data.Fold.Prelude as Fold +import qualified Streamly.Internal.Data.Fold as Fold +import qualified Streamly.Internal.Data.Stream as Stream + +import Test.Tasty.Bench hiding (env) +import Streamly.Benchmark.Common +import Streamly.Benchmark.Common.Handle + +-- We need a monadic bind here to make sure that the function f does not get +-- completely optimized out by the compiler in some cases. + +{-# INLINE sourceUnfoldrM #-} +sourceUnfoldrM :: Monad m => Int -> Int -> Stream m Int +sourceUnfoldrM value n = Stream.unfoldrM step n + where + step cnt = + if cnt > n + value + then return Nothing + else return (Just (cnt, cnt + 1)) + +{-# INLINE source #-} +source :: Monad m => Int -> Int -> Stream m Int +source = sourceUnfoldrM + +-- | Takes a fold method, and uses it with a default source. +{-# INLINE benchIOSink #-} +benchIOSink + :: NFData b + => Int -> String -> (Stream IO Int -> IO b) -> Benchmark +benchIOSink value name f = bench name $ nfIO $ randomRIO (1,1) >>= f . source value + +------------------------------------------------------------------------------- +-- Partitioning +------------------------------------------------------------------------------- + +{-# INLINE demuxToHashMap #-} +demuxToHashMap :: (Monad m, Hashable k +#if __GLASGOW_HASKELL__ == 810 + , Eq k +#endif + ) => + (a -> k) -> (a -> m (Fold m a b)) -> Stream m a -> m (HashMap k b) +demuxToHashMap f g = Stream.fold (Fold.demuxToContainer f g) + +{-# INLINE demuxToHashMapIO #-} +demuxToHashMapIO :: (MonadIO m, Hashable k +#if __GLASGOW_HASKELL__ == 810 + , Eq k +#endif + ) => + (a -> k) -> (a -> m (Fold m a b)) -> Stream m a -> m (HashMap k b) +demuxToHashMapIO f g = Stream.fold (Fold.demuxToContainerIO f g) + +{-# INLINE toHashMapIO #-} +toHashMapIO :: (MonadIO m, Num a, Hashable k +#if __GLASGOW_HASKELL__ == 810 + , Eq k +#endif + ) => + (a -> k) -> Stream m a -> m (HashMap k a) +toHashMapIO f = Stream.fold (Fold.toHashMapIO f Fold.sum) + +------------------------------------------------------------------------------- +-- Benchmarks +------------------------------------------------------------------------------- + +moduleName :: String +moduleName = "Data.Fold.Prelude" + +instance NFData (MutArray a) where + {-# INLINE rnf #-} + rnf _ = () + +instance NFData a => NFData (Stream Identity a) where + {-# INLINE rnf #-} + rnf xs = runIdentity $ Stream.fold (Fold.foldl' (\_ x -> rnf x) ()) xs + +o_n_heap_serial :: Int -> [Benchmark] +o_n_heap_serial value = + [ bgroup "key-value" + [ + benchIOSink value "demuxToHashMap (64 buckets) [sum, length]" + $ demuxToHashMap (getKey 64) (getFold . getKey 64) + , benchIOSink value "demuxToHashMapIO (64 buckets) [sum, length]" + $ demuxToHashMapIO (getKey 64) (getFold . getKey 64) + + -- classify: mutable cells + , benchIOSink value "toHashMapIO (single bucket) sum" + $ toHashMapIO (getKey 1) + , benchIOSink value "toHashMapIO (64 buckets) sum" + $ toHashMapIO (getKey 64) + , benchIOSink value "toHashMapIO (max buckets) sum" + $ toHashMapIO (getKey value) + ] + ] + + where + + getKey buckets = (`mod` buckets) + + getFold k = + return $ case k of + 0 -> Fold.sum + 1 -> Fold.length + _ -> Fold.length + +------------------------------------------------------------------------------- +-- Driver +------------------------------------------------------------------------------- + +main :: IO () +main = do +#ifndef FUSION_CHECK + env <- mkHandleBenchEnv + runWithCLIOpts defaultStreamSize (allBenchmarks env) + + where + + allBenchmarks _env value = + [ bgroup (o_n_heap_prefix moduleName) (o_n_heap_serial value) + ] +#else + -- Enable FUSION_CHECK macro at the beginning of the file + -- Enable one benchmark below, and run the benchmark + -- Check the .dump-simpl output + let value = 100000 + let input = source value 1 + let getKey buckets = (`mod` buckets) + let getFold k = + return $ case k of + 0 -> Fold.sum + 1 -> Fold.length + _ -> Fold.length + + -- demuxToMap (getKey 64) (getFold . getKey 64) input + toIntMapIO (getKey 64) input + return () +#endif diff --git a/benchmark/Streamly/Benchmark/Data/Fold/Window.hs b/benchmark/Streamly/Benchmark/Data/Fold/Window.hs --- a/benchmark/Streamly/Benchmark/Data/Fold/Window.hs +++ b/benchmark/Streamly/Benchmark/Data/Fold/Window.hs @@ -4,16 +4,16 @@ import Control.DeepSeq (NFData) import Streamly.Data.Fold (Fold) -import Streamly.Internal.Data.Stream.StreamD (Stream) +import Streamly.Internal.Data.Stream (Stream) import System.Random (randomRIO) import qualified Streamly.Data.Fold as Fold -import qualified Streamly.Internal.Data.Ring.Unboxed as Ring -import qualified Streamly.Internal.Data.Fold.Window as Window -import qualified Streamly.Internal.Data.Stream.StreamD as Stream +import qualified Streamly.Internal.Data.Fold as Window +import qualified Streamly.Internal.Data.RingArray as RingArray +import qualified Streamly.Internal.Data.Stream as Stream import Streamly.Benchmark.Common -import Gauge +import Test.Tasty.Bench {-# INLINE source #-} source :: (Monad m, Num a, Stream.Enumerable a) => @@ -70,55 +70,55 @@ o_1_space_folds numElements = [ bgroup "fold" [ benchWithFold numElements "minimum (window size 100)" - (Window.minimum 100) + (Window.windowMinimum 100) , benchWithFold numElements "minimum (window size 1000)" - (Window.minimum 1000) + (Window.windowMinimum 1000) , benchWith sourceDescendingInt numElements "minimum descending (window size 1000)" - (Window.minimum 1000) + (Window.windowMinimum 1000) , benchWithFold numElements "maximum (window size 100)" - (Window.maximum 100) + (Window.windowMaximum 100) , benchWithFold numElements "maximum (window size 1000)" - (Window.maximum 1000) + (Window.windowMaximum 1000) , benchWith sourceDescendingInt numElements "maximum descending (window size 1000)" - (Window.maximum 1000) + (Window.windowMaximum 1000) , benchWithFold numElements "range (window size 100)" - (Window.range 100) + (Window.windowRange 100) , benchWithFold numElements "range (window size 1000)" - (Window.range 1000) + (Window.windowRange 1000) , benchWith sourceDescendingInt numElements "range descending (window size 1000)" - (Window.range 1000) + (Window.windowRange 1000) , benchWithFoldInt numElements "sumInt (window size 100)" - (Ring.slidingWindow 100 Window.sumInt) + (RingArray.slidingWindow 100 Window.windowSumInt) , benchWithFoldInt numElements "sum for Int (window size 100)" - (Ring.slidingWindow 100 Window.sum) + (RingArray.slidingWindow 100 Window.windowSum) , benchWithFold numElements "sum (window size 100)" - (Ring.slidingWindow 100 Window.sum) + (RingArray.slidingWindow 100 Window.windowSum) , benchWithFold numElements "sum (window size 1000)" - (Ring.slidingWindow 1000 Window.sum) + (RingArray.slidingWindow 1000 Window.windowSum) , benchWithFold numElements "sum (entire stream)" - (Window.cumulative Window.sum) + (Window.cumulative Window.windowSum) , benchWithFold numElements "sum (Data.Fold)" Fold.sum , benchWithFold numElements "mean (window size 100)" - (Ring.slidingWindow 100 Window.mean) + (RingArray.slidingWindow 100 Window.windowMean) , benchWithFold numElements "mean (window size 1000)" - (Ring.slidingWindow 1000 Window.mean) + (RingArray.slidingWindow 1000 Window.windowMean) , benchWithFold numElements "mean (entire stream)" - (Window.cumulative Window.mean) + (Window.cumulative Window.windowMean) , benchWithFold numElements "mean (Data.Fold)" Fold.mean , benchWithFold numElements "powerSum 2 (window size 100)" - (Ring.slidingWindow 100 (Window.powerSum 2)) + (RingArray.slidingWindow 100 (Window.windowPowerSum 2)) , benchWithFold numElements "powerSum 2 (entire stream)" - (Window.cumulative (Window.powerSum 2)) + (Window.cumulative (Window.windowPowerSum 2)) ] ] @@ -127,51 +127,51 @@ o_1_space_scans numElements = [ bgroup "scan" [ benchWithPostscan numElements "minimum (window size 10)" - (Window.minimum 10) + (Window.windowMinimum 10) -- Below window size 30 the linear search based impl performs better -- than the dequeue based implementation. , benchWithPostscan numElements "minimum (window size 30)" - (Window.minimum 30) + (Window.windowMinimum 30) , benchWithPostscan numElements "minimum (window size 1000)" - (Window.minimum 1000) + (Window.windowMinimum 1000) , benchScanWith sourceDescendingInt numElements "minimum descending (window size 1000)" - (Window.minimum 1000) + (Window.windowMinimum 1000) , benchWithPostscan numElements "maximum (window size 10)" - (Window.maximum 10) + (Window.windowMaximum 10) , benchWithPostscan numElements "maximum (window size 30)" - (Window.maximum 30) + (Window.windowMaximum 30) , benchWithPostscan numElements "maximum (window size 1000)" - (Window.maximum 1000) + (Window.windowMaximum 1000) , benchScanWith sourceDescendingInt numElements "maximum descending (window size 1000)" - (Window.maximum 1000) + (Window.windowMaximum 1000) , benchWithPostscan numElements "range (window size 10)" - (Window.range 10) + (Window.windowRange 10) , benchWithPostscan numElements "range (window size 30)" - (Window.range 30) + (Window.windowRange 30) , benchWithPostscan numElements "range (window size 1000)" - (Window.range 1000) + (Window.windowRange 1000) , benchScanWith sourceDescendingInt numElements "range descending (window size 1000)" - (Window.range 1000) + (Window.windowRange 1000) , benchWithPostscan numElements "sum (window size 100)" - (Ring.slidingWindow 100 Window.sum) + (RingArray.slidingWindow 100 Window.windowSum) , benchWithPostscan numElements "sum (window size 1000)" - (Ring.slidingWindow 1000 Window.sum) + (RingArray.slidingWindow 1000 Window.windowSum) , benchWithPostscan numElements "mean (window size 100)" - (Ring.slidingWindow 100 Window.mean) + (RingArray.slidingWindow 100 Window.windowMean) , benchWithPostscan numElements "mean (window size 1000)" - (Ring.slidingWindow 1000 Window.mean) + (RingArray.slidingWindow 1000 Window.windowMean) , benchWithPostscan numElements "powerSum 2 (window size 100)" - (Ring.slidingWindow 100 (Window.powerSum 2)) + (RingArray.slidingWindow 100 (Window.windowPowerSum 2)) , benchWithPostscan numElements "powerSum 2 (window size 1000)" - (Ring.slidingWindow 1000 (Window.powerSum 2)) + (RingArray.slidingWindow 1000 (Window.windowPowerSum 2)) ] ] diff --git a/benchmark/Streamly/Benchmark/Data/MutArray.hs b/benchmark/Streamly/Benchmark/Data/MutArray.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Data/MutArray.hs @@ -0,0 +1,306 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | +-- Module : Streamly.Benchmark.Data.Array.Unboxed.Mut +-- Copyright : (c) 2021 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +#ifdef __HADDOCK_VERSION__ +#undef INSPECTION +#endif + +#ifdef INSPECTION +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-} +#endif + +import Control.DeepSeq (NFData(..)) +import Control.Monad.IO.Class (MonadIO) +import Data.Functor ((<&>)) +#if __GLASGOW_HASKELL__ >= 810 +import Data.Kind (Type) +#endif +import System.Random (randomRIO) +import Prelude + ( IO + , Int + , Integral(..) + , Maybe(..) + , Monad(..) + , Num(..) + , Ord(..) + , String + , ($) + , (.) + , (||) + , concat + , const + , fmap + , id + , undefined + ) +import Streamly.Internal.Data.MutArray (MutArray) + +import qualified Streamly.Internal.Data.Array as Array +import qualified Streamly.Internal.Data.MutArray as MArray +import qualified Streamly.Internal.Data.Fold as Fold +import qualified Streamly.Internal.Data.Scanl as Scanl +import qualified Streamly.Internal.Data.Stream as Stream + +import Test.Tasty.Bench +import Streamly.Benchmark.Common hiding (benchPureSrc) + +#if __GLASGOW_HASKELL__ >= 810 +type Stream :: Type -> Type +#endif +type Stream = MutArray + +instance NFData (MutArray a) where + {-# INLINE rnf #-} + rnf _ = () + +------------------------------------------------------------------------------- +-- Benchmark helpers +------------------------------------------------------------------------------- + +{-# INLINE benchIO #-} +benchIO :: NFData b => String -> (Int -> IO a) -> (a -> b) -> Benchmark +benchIO name src f = bench name $ nfIO $ + (randomRIO (1,1) >>= src) <&> f + +{-# INLINE benchPureSink #-} +benchPureSink :: NFData b => Int -> String -> (Stream Int -> b) -> Benchmark +benchPureSink value name = benchIO name (sourceIntFromTo value) + +{-# 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 => Int -> String -> (Stream Int -> IO b) -> Benchmark +benchIOSink value name = benchIO' name (sourceIntFromTo value) + +-- Drain a source that generates an array in the IO monad +{-# INLINE benchIOSrc #-} +benchIOSrc :: String -> (Int -> IO (Stream a)) -> Benchmark +benchIOSrc name src = benchIO name src id + +drain :: Monad m => Stream.Stream m a -> m () +drain = Stream.fold Fold.drain + +------------------------------------------------------------------------------- +-- Bench Ops +------------------------------------------------------------------------------- + +{-# INLINE sourceUnfoldr #-} +sourceUnfoldr :: MonadIO m => Int -> Int -> m (Stream Int) +sourceUnfoldr value n = + Stream.fold (MArray.createOf value) $ Stream.unfoldr step n + + where + + step cnt = + if cnt > n + value + then Nothing + else Just (cnt, cnt + 1) + +{-# INLINE sourceIntFromTo #-} +sourceIntFromTo :: MonadIO m => Int -> Int -> m (Stream Int) +sourceIntFromTo value n = + Stream.fold (MArray.createOf value) $ Stream.enumerateFromTo n (n + value) + +{-# INLINE sourceFromList #-} +sourceFromList :: MonadIO m => Int -> Int -> m (Stream Int) +sourceFromList value n = + Stream.fold (MArray.createOf value) $ Stream.fromList [n .. n + value] + +{-# INLINE sourceIntFromToFromList #-} +sourceIntFromToFromList :: MonadIO m => Int -> Int -> m (Stream Int) +sourceIntFromToFromList value n = MArray.fromListN value [n..n + value] + +{-# INLINE sourceIntFromToFromStream #-} +sourceIntFromToFromStream :: MonadIO m => Int -> Int -> m (Stream Int) +sourceIntFromToFromStream value n = + Stream.fold MArray.create $ Stream.enumerateFromTo n (n + value) + +{-# INLINE sourceUnfoldrM #-} +sourceUnfoldrM :: Monad m => Int -> Int -> Stream.Stream m Int +sourceUnfoldrM value n = Stream.unfoldrM step n + where + step cnt = + if cnt > n + value + then return Nothing + else return (Just (cnt, cnt + 1)) + +------------------------------------------------------------------------------- +-- Transformation +------------------------------------------------------------------------------- + +{-# INLINE composeN #-} +composeN :: 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 >>= f + 3 -> f x >>= f >>= f + 4 -> f x >>= f >>= f >>= f + _ -> undefined + +{-# INLINE scanl' #-} +scanl' :: MonadIO m => Int -> Int -> Stream Int -> m (Stream Int) +scanl' value n = composeN n $ onArray value $ Stream.scanl (Scanl.mkScanl (+) 0) + +{-# INLINE scanl1' #-} +scanl1' :: MonadIO m => Int -> Int -> Stream Int -> m (Stream Int) +scanl1' value n = composeN n $ onArray value $ Stream.scanl1' (+) + +{-# INLINE map #-} +map :: MonadIO m => Int -> Int -> Stream Int -> m (Stream Int) +map value n = composeN n $ onArray value $ fmap (+ 1) + +{-# INLINE onArray #-} +onArray + :: MonadIO m => Int -> (Stream.Stream m Int -> Stream.Stream m Int) + -> Stream Int + -> m (Stream Int) +onArray value f arr = + Stream.fold (MArray.createOf value) $ f $ Stream.unfold MArray.reader arr + +------------------------------------------------------------------------------- +-- Elimination +------------------------------------------------------------------------------- + +{-# INLINE unfoldReadDrain #-} +unfoldReadDrain :: MonadIO m => Stream Int -> m () +unfoldReadDrain = drain . Stream.unfold MArray.reader + +{-# INLINE unfoldReadRevDrain #-} +unfoldReadRevDrain :: MonadIO m => Stream Int -> m () +unfoldReadRevDrain = drain . Stream.unfold MArray.readerRev + +{-# INLINE toStreamDRevDrain #-} +toStreamDRevDrain :: MonadIO m => Stream Int -> m () +toStreamDRevDrain = drain . MArray.readRev + +{-# INLINE toStreamDDrain #-} +toStreamDDrain :: MonadIO m => Stream Int -> m () +toStreamDDrain = drain . MArray.read + +{-# INLINE unfoldFold #-} +unfoldFold :: MonadIO m => Stream Int -> m Int +unfoldFold = Stream.fold (Fold.foldl' (+) 0) . Stream.unfold MArray.reader + +------------------------------------------------------------------------------- +-- Bench groups +------------------------------------------------------------------------------- + +o_1_space_generation :: Int -> [Benchmark] +o_1_space_generation value = + [ bgroup + "generation" + [ benchIOSrc "createOf . intFromTo" (sourceIntFromTo value) + , benchIOSrc + "fromList . intFromTo" + (sourceIntFromToFromList value) + , benchIOSrc "createOf . unfoldr" (sourceUnfoldr value) + , benchIOSrc "createOf . fromList" (sourceFromList value) + , benchIOSrc "write . intFromTo" (sourceIntFromToFromStream value) + ] + ] + +o_1_space_elimination :: Int -> [Benchmark] +o_1_space_elimination value = + [ bgroup "elimination" + [ benchPureSink value "id" id + , benchIOSink value "foldl'" unfoldFold + , benchIOSink value "read" unfoldReadDrain + , benchIOSink value "readRev" unfoldReadRevDrain + , benchIOSink value "toStream" toStreamDDrain + , benchIOSink value "toStreamRev" toStreamDRevDrain + ] + ] + +o_n_heap_serial :: Int -> [Benchmark] +o_n_heap_serial value = + [ bgroup "elimination" + [ + -- Converting the stream to an array + benchFold "createOf" (Stream.fold (MArray.createOf value)) + (sourceUnfoldrM value) + ] + ] + +o_1_space_transformation :: Int -> [Benchmark] +o_1_space_transformation value = + [ bgroup "transformation" + [ benchIOSink value "scanl'" (scanl' value 1) + , benchIOSink value "scanl1'" (scanl1' value 1) + , benchIOSink value "map" (map value 1) + ] + ] + +o_1_space_transformationX4 :: Int -> [Benchmark] +o_1_space_transformationX4 value = + [ bgroup "transformationX4" + [ benchIOSink value "scanl'" (scanl' value 4) + , benchIOSink value "scanl1'" (scanl1' value 4) + , benchIOSink value "map" (map value 4) + ] + ] + +o_1_space_serial_marray :: + Int -> (MutArray Int, Array.Array Int) -> [Benchmark] +o_1_space_serial_marray value ~(array, indices) = + [ benchIO' "partitionBy (< 0)" (const (return array)) + $ MArray.partitionBy (< 0) + , benchIO' "partitionBy (> 0)" (const (return array)) + $ MArray.partitionBy (> 0) + , benchIO' "partitionBy (< value/2)" (const (return array)) + $ MArray.partitionBy (< (value `div` 2)) + , benchIO' "partitionBy (> value/2)" (const (return array)) + $ MArray.partitionBy (> (value `div` 2)) + , benchIO' "strip (< value/2 || > value/2)" (const (return array)) + $ MArray.dropAround (\x -> x < value `div` 2 || x > value `div` 2) + , benchIO' "strip (> 0)" (const (return array)) + $ MArray.dropAround (> 0) + , benchIO' "modifyIndices (+ 1)" (const (return indices)) + $ Stream.fold (MArray.modifyIndices array (\_idx val -> val + 1)) + . Stream.unfold Array.reader + ] + +------------------------------------------------------------------------------- +-- Driver +------------------------------------------------------------------------------- + +moduleName :: String +moduleName = "Data.MutArray" + +main :: IO () +main = do + runWithCLIOptsEnv defaultStreamSize alloc allBenchmarks + + where + + alloc value = do + marr <- MArray.fromStream (sourceUnfoldrM value 0 :: Stream.Stream IO Int) + indices <- Array.fromStream (sourceUnfoldrM value 0 :: Stream.Stream IO Int) + return (marr, indices) + + allBenchmarks array value = + [ bgroup (o_1_space_prefix moduleName) + $ concat + [ o_1_space_serial_marray value array + , o_1_space_generation value + , o_1_space_elimination value + , o_1_space_transformation value + , o_1_space_transformationX4 value + ] + , bgroup (o_n_heap_prefix moduleName) (o_n_heap_serial value) + ] diff --git a/benchmark/Streamly/Benchmark/Data/Parser.hs b/benchmark/Streamly/Benchmark/Data/Parser.hs --- a/benchmark/Streamly/Benchmark/Data/Parser.hs +++ b/benchmark/Streamly/Benchmark/Data/Parser.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -Wno-deprecations #-} #undef FUSION_CHECK #ifdef FUSION_CHECK @@ -33,8 +32,8 @@ import System.Random (randomRIO) import Streamly.Internal.Data.Fold (Fold(..)) import Streamly.Internal.Data.Parser - (ParseError(..), Parser(..), Initial(..), Step(..)) -import Streamly.Internal.Data.Stream.StreamD (Stream) + (ParseError(..), Parser(..), Initial(..), Step(..), Final(..)) +import Streamly.Internal.Data.Stream (Stream) import Prelude hiding (any, all, take, sequence, sequence_, sequenceA, takeWhile, dropWhile, span) @@ -47,10 +46,9 @@ import qualified Streamly.Internal.Data.Parser as PR import qualified Streamly.Data.Stream as Stream import qualified Streamly.Internal.Data.Producer as Producer -import qualified Streamly.Internal.Data.Producer.Source as Source -import qualified Streamly.Internal.Data.Stream.StreamD as Stream +import qualified Streamly.Internal.Data.Stream as Stream -import Gauge hiding (env) +import Test.Tasty.Bench hiding (env) import Streamly.Benchmark.Common import Streamly.Benchmark.Common.Handle @@ -137,11 +135,11 @@ dropWhile :: Monad m => Int -> Stream m Int -> m (Either ParseError ()) dropWhile value = Stream.parse (PR.dropWhile (<= value)) -{-# INLINE takeStartBy #-} -takeStartBy :: Monad m => Int -> Stream m Int -> m (Either ParseError ()) -takeStartBy value stream = do +{-# INLINE takeBeginBy #-} +takeBeginBy :: Monad m => Int -> Stream m Int -> m (Either ParseError ()) +takeBeginBy value stream = do let stream2 = value `Stream.cons` stream - Stream.parse (PR.takeStartBy (== value) Fold.drain) stream2 + Stream.parse (PR.takeBeginBy (== value) Fold.drain) stream2 takeFramedByEsc_ :: Monad m => Int -> Stream m Char -> m (Either ParseError ()) takeFramedByEsc_ _ = Stream.parse parser @@ -349,7 +347,7 @@ -- PR.dropWhile (<= (value * 1 `div` 4)) *> PR.die "alt" {-# INLINE takeWhileFail #-} takeWhileFail :: Monad m => (a -> Bool) -> Fold m a b -> Parser a m b -takeWhileFail predicate (Fold fstep finitial fextract) = +takeWhileFail predicate (Fold fstep finitial _ ffinal) = Parser step initial extract where @@ -366,11 +364,11 @@ fres <- fstep s a return $ case fres of - Fold.Partial s1 -> Partial 0 s1 - Fold.Done b -> Done 0 b - else return $ Error "fail" + Fold.Partial s1 -> SPartial 1 s1 + Fold.Done b -> SDone 1 b + else return $ SError "fail" - extract s = fmap (Done 0) (fextract s) + extract s = fmap (FDone 0) (ffinal s) {-# INLINE alt2 #-} alt2 :: Monad m @@ -635,13 +633,13 @@ {-# INLINE parseManyUnfoldArrays #-} parseManyUnfoldArrays :: Int -> [Array.Array Int] -> IO () parseManyUnfoldArrays count arrays = do - let src = Source.source (Just (Producer.OuterLoop arrays)) + let src = Producer.source (Just (Producer.OuterLoop arrays)) let parser = PR.fromFold (Fold.take count Fold.drain) let readSrc = - Source.producer + Producer.producer $ Producer.concat Producer.fromList Array.producer let streamParser = - Producer.simplify (Source.parseMany parser readSrc) + Producer.simplify (Producer.parseMany parser readSrc) Stream.fold Fold.drain $ Stream.unfold streamParser src ------------------------------------------------------------------------------- @@ -715,13 +713,11 @@ o_1_space_serial :: Int -> [Benchmark] o_1_space_serial value = [ benchIOSink value "takeBetween" $ takeBetween value - , benchIOSink value "takeEQ" $ takeEQ value - , benchIOSink value "takeGE" $ takeGE value , benchIOSink value "takeWhile" $ takeWhile value , benchIOSink value "takeWhileP" $ takeWhileP value , benchIOSink value "takeP" $ takeP value , benchIOSink value "dropWhile" $ dropWhile value - , benchIOSink value "takeStartBy" $ takeStartBy value + , benchIOSink value "takeBeginBy" $ takeBeginBy value , benchIOSink value "takeEndBy_" $ takeEndBy_ value , benchIOSink value "groupBy" $ groupBy , benchIOSink value "groupByRolling" $ groupByRolling @@ -813,8 +809,11 @@ o_n_heap_serial :: Int -> [Benchmark] o_n_heap_serial value = [ + benchIOSink value "takeEQ" $ takeEQ value + , benchIOSink value "takeGE" $ takeGE value + -- lookahead benchmark holds the entire input till end - benchIOSink value "lookAhead" $ lookAhead value + , benchIOSink value "lookAhead" $ lookAhead value -- o-n-heap because of backtracking , benchIOSrc sourceEscapedFrames value "takeFramedByEsc_" @@ -856,7 +855,7 @@ where - alloc value = Stream.fold Fold.toList $ Stream.chunksOf 100 $ sourceUnfoldrM value 0 + alloc value = Stream.fold Fold.toList $ Array.chunksOf 100 $ sourceUnfoldrM value 0 allBenchmarks env arrays value = [ bgroup (o_1_space_prefix moduleName) (o_1_space_serial value) diff --git a/benchmark/Streamly/Benchmark/Data/Parser/ParserK.hs b/benchmark/Streamly/Benchmark/Data/Parser/ParserK.hs deleted file mode 100644 --- a/benchmark/Streamly/Benchmark/Data/Parser/ParserK.hs +++ /dev/null @@ -1,384 +0,0 @@ --- | --- Module : Streamly.Benchmark.Data.ParserK --- Copyright : (c) 2020 Composewell Technologies --- --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com - -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# OPTIONS_GHC -Wno-orphans #-} - -module Main - ( - main - ) where - -import Control.Applicative ((<|>)) -import Control.DeepSeq (NFData(..)) -import Control.Monad.IO.Class (MonadIO) -import Data.Foldable (asum) -import Streamly.Data.Array (Array, Unbox) -import Streamly.Internal.Data.Fold.Type (Fold(..)) -import Streamly.Data.StreamK (StreamK) -import Streamly.Internal.Data.Parser - (ParseError(..), Parser(..), Initial(..), Step(..)) -import Streamly.Internal.Data.Stream.StreamD (Stream) -import System.Random (randomRIO) -import Prelude hiding - (any, all, take, sequence, sequence_, sequenceA, takeWhile) - -import qualified Control.Applicative as AP -import qualified Data.Foldable as F -import qualified Data.Traversable as TR -import qualified Streamly.Data.Stream as Stream -import qualified Streamly.Data.Fold as FL -import qualified Streamly.Internal.Data.Fold as Fold -import qualified Streamly.Data.Parser as PRD -import qualified Streamly.Data.ParserK as PR -import qualified Streamly.Internal.Data.Stream.StreamK as StreamK - -import Gauge -import Streamly.Benchmark.Common - -------------------------------------------------------------------------------- --- Utilities -------------------------------------------------------------------------------- - --- XXX these can be moved to the common module - -{-# INLINE sourceUnfoldrM #-} -sourceUnfoldrM :: Monad m => Int -> Int -> Stream m Int -sourceUnfoldrM value n = Stream.unfoldrM step n - where - step cnt = - if cnt > n + value - then return Nothing - else return (Just (cnt, cnt + 1)) - --- | Takes a fold method, and uses it with a default source. -{-# INLINE benchIOSink #-} -benchIOSink - :: NFData b - => Int -> String -> (StreamK IO (Array Int) -> IO b) -> Benchmark -benchIOSink value name f = - bench name $ nfIO $ randomRIO (1,1) - >>= f - . StreamK.fromStream - . Stream.chunksOf 4000 - . sourceUnfoldrM value - -------------------------------------------------------------------------------- --- Parsers -------------------------------------------------------------------------------- - -#define PARSE_OP StreamK.parseChunks - -{-# INLINE one #-} -one :: MonadIO m => - Int -> StreamK m (Array Int) -> m (Either ParseError (Maybe Int)) -one value = StreamK.parseChunks p - - where - - p = do - m <- PR.fromFold FL.one - case m of - Just i -> if i >= value then pure m else p - Nothing -> pure Nothing - -{-# INLINE satisfy #-} -satisfy :: (MonadIO m, Unbox a) => (a -> Bool) -> PR.ParserK a m a -satisfy = PR.fromParser . PRD.satisfy - -{-# INLINE takeWhile #-} -takeWhile :: (MonadIO m, Unbox a) => (a -> Bool) -> PR.ParserK a m () -takeWhile p = PR.fromParser $ PRD.takeWhile p FL.drain - -{-# INLINE takeWhileK #-} -takeWhileK :: MonadIO m => - Int -> StreamK m (Array Int) -> m (Either ParseError ()) -takeWhileK value = PARSE_OP (takeWhile (<= value)) - -{-# INLINE splitAp2 #-} -splitAp2 :: MonadIO m - => Int -> StreamK m (Array Int) -> m (Either ParseError ((), ())) -splitAp2 value = - PARSE_OP - ((,) - <$> takeWhile (<= (value `div` 2)) - <*> takeWhile (<= value) - ) - -{-# INLINE splitAp8 #-} -splitAp8 :: MonadIO m - => Int -> StreamK m (Array Int) -> m (Either ParseError ()) -splitAp8 value = - PARSE_OP - ( (\() () () () () () () () -> ()) - <$> takeWhile (<= ( value `div` 8)) - <*> takeWhile (<= ((value * 2) `div` 8)) - <*> takeWhile (<= ((value * 3) `div` 8)) - <*> takeWhile (<= ((value * 4) `div` 8)) - <*> takeWhile (<= ((value * 5) `div` 8)) - <*> takeWhile (<= ((value * 6) `div` 8)) - <*> takeWhile (<= ((value * 7) `div` 8)) - <*> takeWhile (<= value) - ) - -{-# INLINE sequenceA #-} -sequenceA :: MonadIO m => Int -> StreamK m (Array Int) -> m Int -sequenceA value xs = do - let parser = satisfy (> 0) - list = Prelude.replicate value parser - x <- PARSE_OP (TR.sequenceA list) xs - return $ Prelude.length x - -{-# INLINE sequenceA_ #-} -sequenceA_ :: MonadIO m => - Int -> StreamK m (Array Int) -> m (Either ParseError ()) -sequenceA_ value xs = do - let parser = satisfy (> 0) - list = Prelude.replicate value parser - PARSE_OP (F.sequenceA_ list) xs - -{-# INLINE sequence #-} -sequence :: MonadIO m => Int -> StreamK m (Array Int) -> m Int -sequence value xs = do - let parser = satisfy (> 0) - list = Prelude.replicate value parser - x <- PARSE_OP (TR.sequence list) xs - return $ Prelude.length x - -{-# INLINE sequence_ #-} -sequence_ :: MonadIO m => - Int -> StreamK m (Array Int) -> m (Either ParseError ()) -sequence_ value = - let parser = satisfy (> 0) - list = Prelude.replicate value parser - in PARSE_OP (F.sequence_ list) - -{-# INLINE takeWhileFailD #-} -takeWhileFailD :: Monad m => (a -> Bool) -> Fold m a b -> Parser a m b -takeWhileFailD predicate (Fold fstep finitial fextract) = - Parser step initial extract - - where - - initial = do - res <- finitial - return $ case res of - Fold.Partial s -> IPartial s - Fold.Done b -> IDone b - - step s a = - if predicate a - then do - fres <- fstep s a - return - $ case fres of - Fold.Partial s1 -> Partial 0 s1 - Fold.Done b -> Done 0 b - else return $ Error "fail" - - extract s = fmap (Done 0) (fextract s) - -{-# INLINE takeWhileFail #-} -takeWhileFail :: (Monad m, Unbox a) => - (a -> Bool) -> Fold m a b -> PR.ParserK a m b -takeWhileFail p f = PR.fromParser (takeWhileFailD p f) - -{-# INLINE alt2 #-} -alt2 :: MonadIO m - => Int -> StreamK m (Array Int) -> m (Either ParseError ()) -alt2 value = - PARSE_OP - ( takeWhileFail (<= (value `div` 2)) Fold.drain - <|> takeWhile (<= value) - ) - -{-# INLINE alt8 #-} -alt8 :: MonadIO m - => Int -> StreamK m (Array Int) -> m (Either ParseError ()) -alt8 value = - PARSE_OP - ( takeWhileFail (<= ( value `div` 8)) Fold.drain - <|> takeWhileFail (<= ((value * 2) `div` 8)) Fold.drain - <|> takeWhileFail (<= ((value * 3) `div` 8)) Fold.drain - <|> takeWhileFail (<= ((value * 4) `div` 8)) Fold.drain - <|> takeWhileFail (<= ((value * 5) `div` 8)) Fold.drain - <|> takeWhileFail (<= ((value * 6) `div` 8)) Fold.drain - <|> takeWhileFail (<= ((value * 7) `div` 8)) Fold.drain - <|> takeWhile (<= value) - ) - -{-# INLINE alt16 #-} -alt16 :: MonadIO m - => Int -> StreamK m (Array Int) -> m (Either ParseError ()) -alt16 value = - PARSE_OP - ( takeWhileFail (<= ( value `div` 16)) Fold.drain - <|> takeWhileFail (<= ((value * 2) `div` 16)) Fold.drain - <|> takeWhileFail (<= ((value * 3) `div` 16)) Fold.drain - <|> takeWhileFail (<= ((value * 4) `div` 16)) Fold.drain - <|> takeWhileFail (<= ((value * 5) `div` 16)) Fold.drain - <|> takeWhileFail (<= ((value * 6) `div` 16)) Fold.drain - <|> takeWhileFail (<= ((value * 7) `div` 16)) Fold.drain - <|> takeWhileFail (<= ((value * 8) `div` 16)) Fold.drain - <|> takeWhileFail (<= ((value * 9) `div` 16)) Fold.drain - <|> takeWhileFail (<= ((value * 10) `div` 16)) Fold.drain - <|> takeWhileFail (<= ((value * 11) `div` 16)) Fold.drain - <|> takeWhileFail (<= ((value * 12) `div` 16)) Fold.drain - <|> takeWhileFail (<= ((value * 13) `div` 16)) Fold.drain - <|> takeWhileFail (<= ((value * 14) `div` 16)) Fold.drain - <|> takeWhileFail (<= ((value * 15) `div` 16)) Fold.drain - <|> takeWhile (<= value) - ) - -{-# INLINE manyAlt #-} -manyAlt :: MonadIO m => StreamK m (Array Int) -> m Int -manyAlt xs = do - x <- PARSE_OP (AP.many (satisfy (> 0))) xs - return $ Prelude.length x - -{-# INLINE someAlt #-} -someAlt :: MonadIO m => StreamK m (Array Int) -> m Int -someAlt xs = do - x <- PARSE_OP (AP.some (satisfy (> 0))) xs - return $ Prelude.length x - -{-# INLINE choice #-} -choice :: MonadIO m => - Int -> StreamK m (Array Int) -> m (Either ParseError Int) -choice value = - PARSE_OP (asum (replicate value (satisfy (< 0))) - AP.<|> satisfy (> 0)) - -{-# INLINE monad2 #-} -monad2 :: MonadIO m - => Int -> StreamK m (Array Int) -> m (Either ParseError ()) -monad2 value = - PARSE_OP $ do - takeWhile (<= (value `div` 2)) - takeWhile (<= value) - -{-# INLINE monad4 #-} -monad4 :: MonadIO m - => Int -> StreamK m (Array Int) -> m (Either ParseError ()) -monad4 value = - PARSE_OP $ do - takeWhile (<= ( value `div` 4)) - takeWhile (<= ((value * 2) `div` 4)) - takeWhile (<= ((value * 3) `div` 4)) - takeWhile (<= value) - -{-# INLINE monad8 #-} -monad8 :: MonadIO m - => Int -> StreamK m (Array Int) -> m (Either ParseError ()) -monad8 value = - PARSE_OP $ do - takeWhile (<= ( value `div` 8)) - takeWhile (<= ((value * 2) `div` 8)) - takeWhile (<= ((value * 3) `div` 8)) - takeWhile (<= ((value * 4) `div` 8)) - takeWhile (<= ((value * 5) `div` 8)) - takeWhile (<= ((value * 6) `div` 8)) - takeWhile (<= ((value * 7) `div` 8)) - takeWhile (<= value) - -{-# INLINE monad16 #-} -monad16 :: MonadIO m - => Int -> StreamK m (Array Int) -> m (Either ParseError ()) -monad16 value = - PARSE_OP $ do - takeWhile (<= ( value `div` 16)) - takeWhile (<= ((value * 2) `div` 16)) - takeWhile (<= ((value * 3) `div` 16)) - takeWhile (<= ((value * 4) `div` 16)) - takeWhile (<= ((value * 5) `div` 16)) - takeWhile (<= ((value * 6) `div` 16)) - takeWhile (<= ((value * 7) `div` 16)) - takeWhile (<= ((value * 8) `div` 16)) - takeWhile (<= ((value * 9) `div` 16)) - takeWhile (<= ((value * 10) `div` 16)) - takeWhile (<= ((value * 11) `div` 16)) - takeWhile (<= ((value * 12) `div` 16)) - takeWhile (<= ((value * 13) `div` 16)) - takeWhile (<= ((value * 14) `div` 16)) - takeWhile (<= ((value * 15) `div` 16)) - takeWhile (<= value) - -------------------------------------------------------------------------------- --- Benchmarks -------------------------------------------------------------------------------- - -moduleName :: String -moduleName = "Data.Parser.ParserK" - -instance NFData ParseError where - {-# INLINE rnf #-} - rnf (ParseError x) = rnf x - -o_1_space_serial :: Int -> [Benchmark] -o_1_space_serial value = - [ benchIOSink value "drain" (Stream.fold Fold.drain . StreamK.toStream) - , benchIOSink value "takeWhile" $ takeWhileK value - , benchIOSink value "splitAp2" $ splitAp2 value - , benchIOSink value "splitAp8" $ splitAp8 value - , benchIOSink value "alt2" $ alt2 value - , benchIOSink value "alt8" $ alt8 value - , benchIOSink value "alt16" $ alt16 value - , benchIOSink value "monad2" $ monad2 value - , benchIOSink value "monad4" $ monad4 value - , benchIOSink value "monad8" $ monad8 value - , benchIOSink value "monad16" $ monad16 value - ] - -{-# INLINE sepBy1 #-} -sepBy1 :: MonadIO m => StreamK m (Array Int) -> m Int -sepBy1 xs = do - x <- PARSE_OP (parser (satisfy odd) (satisfy even)) xs - return $ Prelude.length x - - where - - parser p sep = do - x <- p - fmap (x :) $ AP.many (sep >> p) - --- O(n) heap beacuse of accumulation of the list in strict IO monad? -o_n_heap_serial :: Int -> [Benchmark] -o_n_heap_serial value = - [ - -- accumulates the results in a list - -- XXX why should this take O(n) heap, it discards the results? - benchIOSink value "sequence_" $ sequence_ value - , benchIOSink value "sequenceA_" $ sequenceA_ value - , benchIOSink value "sequence" $ sequence value - , benchIOSink value "sequenceA" $ sequenceA value - , benchIOSink value "manyAlt" manyAlt - , benchIOSink value "sepBy1" sepBy1 - , benchIOSink value "someAlt" someAlt - , benchIOSink value "choice" $ choice value - ] - --- O(n) heap beacuse of accumulation of the list in strict IO monad? -o_1_space_recursive :: Int -> [Benchmark] -o_1_space_recursive value = - [ benchIOSink value "one (recursive)" $ one value - ] - -------------------------------------------------------------------------------- --- Driver -------------------------------------------------------------------------------- - -main :: IO () -main = runWithCLIOpts defaultStreamSize allBenchmarks - - where - - allBenchmarks value = - [ bgroup (o_1_space_prefix moduleName) (o_1_space_serial value) - , bgroup (o_1_space_prefix moduleName) (o_1_space_recursive value) - , bgroup (o_n_heap_prefix moduleName) (o_n_heap_serial value) - ] diff --git a/benchmark/Streamly/Benchmark/Data/ParserK.hs b/benchmark/Streamly/Benchmark/Data/ParserK.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Data/ParserK.hs @@ -0,0 +1,443 @@ +-- | +-- Module : Streamly.Benchmark.Data.ParserK +-- Copyright : (c) 2020 Composewell Technologies +-- +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com + +-- BENCH_CHUNKED -> parse from Array stream +-- BENCH_CHUNKED_GENERIC -> parse from Generic Array stream +-- BENCH_SINGULAR -> parse from single element stream + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Main + ( + main + ) where + +import Control.Applicative ((<|>)) +import Control.DeepSeq (NFData(..)) +import Control.Monad.IO.Class (MonadIO) +import Data.Foldable (asum) +#ifdef BENCH_CHUNKED +import Streamly.Data.Array (Array, Unbox) +#endif +#ifdef BENCH_CHUNKED_GENERIC +import Streamly.Data.Array.Generic (Array) +#endif +import Streamly.Internal.Data.Fold (Fold(..)) +import Streamly.Data.StreamK (StreamK) +import Streamly.Internal.Data.Parser + (ParseError(..), Parser(..), Initial(..), Step(..), Final(..)) +import Streamly.Internal.Data.Stream (Stream) +import System.Random (randomRIO) +import Prelude hiding + (any, all, take, sequence, sequence_, sequenceA, takeWhile) + +import qualified Control.Applicative as AP +import qualified Data.Foldable as F +import qualified Data.Traversable as TR +import qualified Streamly.Data.Stream as Stream +import qualified Streamly.Data.Fold as FL +import qualified Streamly.Internal.Data.Fold as Fold +import qualified Streamly.Data.Parser as PRD +import qualified Streamly.Internal.Data.ParserK as PR +import qualified Streamly.Internal.Data.StreamK as StreamK +#ifdef BENCH_CHUNKED +import qualified Streamly.Internal.Data.Array as Array +#elif defined(BENCH_CHUNKED_GENERIC) +import qualified Streamly.Internal.Data.Array.Generic as GenArr +#endif + +import Test.Tasty.Bench +import Streamly.Benchmark.Common + +------------------------------------------------------------------------------- +-- CPP Helpers +------------------------------------------------------------------------------- + +#ifdef BENCH_CHUNKED + +#define PARSE_OP Array.parse +#define FROM_PARSER Array.toParserK +#define INPUT (Array a) +#define PARSE_ELEM (Array Int) +#define CONSTRAINT_IO (MonadIO m, Unbox a) +#define CONSTRAINT (Monad m, Unbox a) +#define MODULE_NAME "Data.ParserK.Chunked" + +#endif + +#ifdef BENCH_CHUNKED_GENERIC + +#define PARSE_OP GenArr.parse +#define FROM_PARSER GenArr.toParserK +#define INPUT (Array a) +#define PARSE_ELEM (Array Int) +#define CONSTRAINT_IO (MonadIO m) +#define CONSTRAINT (Monad m) +#define MODULE_NAME "Data.ParserK.Chunked.Generic" + +#endif + +#ifdef BENCH_SINGULAR + +#define PARSE_OP StreamK.parse +#define FROM_PARSER PR.toParserK +#define INPUT a +#define PARSE_ELEM Int +#define CONSTRAINT_IO (MonadIO m) +#define CONSTRAINT (Monad m) +#define MODULE_NAME "Data.ParserK" + +#endif + +------------------------------------------------------------------------------- +-- Utilities +------------------------------------------------------------------------------- + +-- XXX these can be moved to the common module + +{-# INLINE sourceUnfoldrM #-} +sourceUnfoldrM :: Monad m => Int -> Int -> Stream m Int +sourceUnfoldrM value n = Stream.unfoldrM step n + where + step cnt = + if cnt > n + value + then return Nothing + else return (Just (cnt, cnt + 1)) + +-- | Takes a fold method, and uses it with a default source. +{-# INLINE benchIOSink #-} +benchIOSink + :: NFData b + => Int -> String -> (StreamK IO PARSE_ELEM -> IO b) -> Benchmark +benchIOSink value name f = + bench name $ nfIO $ randomRIO (1,1) + >>= f + . StreamK.fromStream +#ifdef BENCH_CHUNKED + . Array.chunksOf 4000 +#endif +#ifdef BENCH_CHUNKED_GENERIC + . GenArr.chunksOf 4000 +#endif + . sourceUnfoldrM value + +------------------------------------------------------------------------------- +-- Parsers +------------------------------------------------------------------------------- + +{-# INLINE one #-} +one :: MonadIO m => + Int -> StreamK m PARSE_ELEM -> m (Either ParseError (Maybe Int)) +one value = PARSE_OP p + + where + + p = do + m <- FROM_PARSER (PRD.fromFold FL.one) + case m of + Just i -> if i >= value then pure m else p + Nothing -> pure Nothing + +{-# INLINE satisfy #-} +satisfy :: CONSTRAINT_IO => (a -> Bool) -> PR.ParserK INPUT m a +satisfy = FROM_PARSER . PRD.satisfy + +{-# INLINE takeWhile #-} +takeWhile :: CONSTRAINT_IO => (a -> Bool) -> PR.ParserK INPUT m () +takeWhile p = FROM_PARSER $ PRD.takeWhile p FL.drain + +{-# INLINE takeWhileK #-} +takeWhileK :: MonadIO m => + Int -> StreamK m PARSE_ELEM -> m (Either ParseError ()) +takeWhileK value = PARSE_OP (takeWhile (<= value)) + +{-# INLINE splitAp2 #-} +splitAp2 :: MonadIO m + => Int -> StreamK m PARSE_ELEM -> m (Either ParseError ((), ())) +splitAp2 value = + PARSE_OP + ((,) + <$> takeWhile (<= (value `div` 2)) + <*> takeWhile (<= value) + ) + +{-# INLINE splitAp8 #-} +splitAp8 :: MonadIO m + => Int -> StreamK m PARSE_ELEM -> m (Either ParseError ()) +splitAp8 value = + PARSE_OP + ( (\() () () () () () () () -> ()) + <$> takeWhile (<= ( value `div` 8)) + <*> takeWhile (<= ((value * 2) `div` 8)) + <*> takeWhile (<= ((value * 3) `div` 8)) + <*> takeWhile (<= ((value * 4) `div` 8)) + <*> takeWhile (<= ((value * 5) `div` 8)) + <*> takeWhile (<= ((value * 6) `div` 8)) + <*> takeWhile (<= ((value * 7) `div` 8)) + <*> takeWhile (<= value) + ) + +{-# INLINE sequenceA #-} +sequenceA :: MonadIO m => Int -> StreamK m PARSE_ELEM -> m Int +sequenceA value xs = do + let parser = satisfy (> 0) + list = Prelude.replicate value parser + x <- PARSE_OP (TR.sequenceA list) xs + return $ Prelude.length x + +{-# INLINE sequenceA_ #-} +sequenceA_ :: MonadIO m => + Int -> StreamK m PARSE_ELEM -> m (Either ParseError ()) +sequenceA_ value xs = do + let parser = satisfy (> 0) + list = Prelude.replicate value parser + PARSE_OP (F.sequenceA_ list) xs + +{-# INLINE sequence #-} +sequence :: MonadIO m => Int -> StreamK m PARSE_ELEM -> m Int +sequence value xs = do + let parser = satisfy (> 0) + list = Prelude.replicate value parser + x <- PARSE_OP (TR.sequence list) xs + return $ Prelude.length x + +{-# INLINE sequence_ #-} +sequence_ :: MonadIO m => + Int -> StreamK m PARSE_ELEM -> m (Either ParseError ()) +sequence_ value = + let parser = satisfy (> 0) + list = Prelude.replicate value parser + in PARSE_OP (F.sequence_ list) + +{-# INLINE takeWhileFailD #-} +takeWhileFailD :: Monad m => (a -> Bool) -> Fold m a b -> Parser a m b +takeWhileFailD predicate (Fold fstep finitial _ ffinal) = + Parser step initial extract + + where + + initial = do + res <- finitial + return $ case res of + Fold.Partial s -> IPartial s + Fold.Done b -> IDone b + + step s a = + if predicate a + then do + fres <- fstep s a + return + $ case fres of + Fold.Partial s1 -> SContinue 1 s1 + Fold.Done b -> SDone 1 b + else return $ SError "fail" + + extract s = fmap (FDone 0) (ffinal s) + +{-# INLINE takeWhileFail #-} +takeWhileFail :: CONSTRAINT => + (a -> Bool) -> Fold m a b -> PR.ParserK INPUT m b +takeWhileFail p f = FROM_PARSER (takeWhileFailD p f) + +{-# INLINE alt2 #-} +alt2 :: MonadIO m + => Int -> StreamK m PARSE_ELEM -> m (Either ParseError ()) +alt2 value = + PARSE_OP + ( takeWhileFail (<= (value `div` 2)) Fold.drain + <|> takeWhile (<= value) + ) + +{-# INLINE alt8 #-} +alt8 :: MonadIO m + => Int -> StreamK m PARSE_ELEM -> m (Either ParseError ()) +alt8 value = + PARSE_OP + ( takeWhileFail (<= ( value `div` 8)) Fold.drain + <|> takeWhileFail (<= ((value * 2) `div` 8)) Fold.drain + <|> takeWhileFail (<= ((value * 3) `div` 8)) Fold.drain + <|> takeWhileFail (<= ((value * 4) `div` 8)) Fold.drain + <|> takeWhileFail (<= ((value * 5) `div` 8)) Fold.drain + <|> takeWhileFail (<= ((value * 6) `div` 8)) Fold.drain + <|> takeWhileFail (<= ((value * 7) `div` 8)) Fold.drain + <|> takeWhile (<= value) + ) + +{-# INLINE alt16 #-} +alt16 :: MonadIO m + => Int -> StreamK m PARSE_ELEM -> m (Either ParseError ()) +alt16 value = + PARSE_OP + ( takeWhileFail (<= ( value `div` 16)) Fold.drain + <|> takeWhileFail (<= ((value * 2) `div` 16)) Fold.drain + <|> takeWhileFail (<= ((value * 3) `div` 16)) Fold.drain + <|> takeWhileFail (<= ((value * 4) `div` 16)) Fold.drain + <|> takeWhileFail (<= ((value * 5) `div` 16)) Fold.drain + <|> takeWhileFail (<= ((value * 6) `div` 16)) Fold.drain + <|> takeWhileFail (<= ((value * 7) `div` 16)) Fold.drain + <|> takeWhileFail (<= ((value * 8) `div` 16)) Fold.drain + <|> takeWhileFail (<= ((value * 9) `div` 16)) Fold.drain + <|> takeWhileFail (<= ((value * 10) `div` 16)) Fold.drain + <|> takeWhileFail (<= ((value * 11) `div` 16)) Fold.drain + <|> takeWhileFail (<= ((value * 12) `div` 16)) Fold.drain + <|> takeWhileFail (<= ((value * 13) `div` 16)) Fold.drain + <|> takeWhileFail (<= ((value * 14) `div` 16)) Fold.drain + <|> takeWhileFail (<= ((value * 15) `div` 16)) Fold.drain + <|> takeWhile (<= value) + ) + +{-# INLINE manyAlt #-} +manyAlt :: MonadIO m => StreamK m PARSE_ELEM -> m Int +manyAlt xs = do + x <- PARSE_OP (AP.many (satisfy (> 0))) xs + return $ Prelude.length x + +{-# INLINE someAlt #-} +someAlt :: MonadIO m => StreamK m PARSE_ELEM -> m Int +someAlt xs = do + x <- PARSE_OP (AP.some (satisfy (> 0))) xs + return $ Prelude.length x + +{-# INLINE choice #-} +choice :: MonadIO m => + Int -> StreamK m PARSE_ELEM -> m (Either ParseError Int) +choice value = + PARSE_OP (asum (replicate value (satisfy (< 0))) + AP.<|> satisfy (> 0)) + +{-# INLINE monad2 #-} +monad2 :: MonadIO m + => Int -> StreamK m PARSE_ELEM -> m (Either ParseError ()) +monad2 value = + PARSE_OP $ do + takeWhile (<= (value `div` 2)) + takeWhile (<= value) + +{-# INLINE monad4 #-} +monad4 :: MonadIO m + => Int -> StreamK m PARSE_ELEM -> m (Either ParseError ()) +monad4 value = + PARSE_OP $ do + takeWhile (<= ( value `div` 4)) + takeWhile (<= ((value * 2) `div` 4)) + takeWhile (<= ((value * 3) `div` 4)) + takeWhile (<= value) + +{-# INLINE monad8 #-} +monad8 :: MonadIO m + => Int -> StreamK m PARSE_ELEM -> m (Either ParseError ()) +monad8 value = + PARSE_OP $ do + takeWhile (<= ( value `div` 8)) + takeWhile (<= ((value * 2) `div` 8)) + takeWhile (<= ((value * 3) `div` 8)) + takeWhile (<= ((value * 4) `div` 8)) + takeWhile (<= ((value * 5) `div` 8)) + takeWhile (<= ((value * 6) `div` 8)) + takeWhile (<= ((value * 7) `div` 8)) + takeWhile (<= value) + +{-# INLINE monad16 #-} +monad16 :: MonadIO m + => Int -> StreamK m PARSE_ELEM -> m (Either ParseError ()) +monad16 value = + PARSE_OP $ do + takeWhile (<= ( value `div` 16)) + takeWhile (<= ((value * 2) `div` 16)) + takeWhile (<= ((value * 3) `div` 16)) + takeWhile (<= ((value * 4) `div` 16)) + takeWhile (<= ((value * 5) `div` 16)) + takeWhile (<= ((value * 6) `div` 16)) + takeWhile (<= ((value * 7) `div` 16)) + takeWhile (<= ((value * 8) `div` 16)) + takeWhile (<= ((value * 9) `div` 16)) + takeWhile (<= ((value * 10) `div` 16)) + takeWhile (<= ((value * 11) `div` 16)) + takeWhile (<= ((value * 12) `div` 16)) + takeWhile (<= ((value * 13) `div` 16)) + takeWhile (<= ((value * 14) `div` 16)) + takeWhile (<= ((value * 15) `div` 16)) + takeWhile (<= value) + +------------------------------------------------------------------------------- +-- Benchmarks +------------------------------------------------------------------------------- + +moduleName :: String +moduleName = MODULE_NAME + +instance NFData ParseError where + {-# INLINE rnf #-} + rnf (ParseError x) = rnf x + +o_1_space_serial :: Int -> [Benchmark] +o_1_space_serial value = + [ benchIOSink value "drain" (Stream.fold Fold.drain . StreamK.toStream) + , benchIOSink value "takeWhile" $ takeWhileK value + , benchIOSink value "splitAp2" $ splitAp2 value + , benchIOSink value "splitAp8" $ splitAp8 value + , benchIOSink value "alt2" $ alt2 value + , benchIOSink value "monad2" $ monad2 value + , benchIOSink value "monad4" $ monad4 value + ] + +{-# INLINE sepBy1 #-} +sepBy1 :: MonadIO m => StreamK m PARSE_ELEM -> m Int +sepBy1 xs = do + x <- PARSE_OP (parser (satisfy odd) (satisfy even)) xs + return $ Prelude.length x + + where + + parser p sep = do + x <- p + fmap (x :) $ AP.many (sep >> p) + +-- O(n) heap beacuse of accumulation of the list in strict IO monad? +o_n_heap_serial :: Int -> [Benchmark] +o_n_heap_serial value = + [ + -- accumulates the results in a list + -- XXX why should this take O(n) heap, it discards the results? + benchIOSink value "sequence_" $ sequence_ value + , benchIOSink value "sequenceA_" $ sequenceA_ value + , benchIOSink value "sequence" $ sequence value + , benchIOSink value "sequenceA" $ sequenceA value + , benchIOSink value "manyAlt" manyAlt + , benchIOSink value "sepBy1" sepBy1 + , benchIOSink value "someAlt" someAlt + , benchIOSink value "choice" $ choice value + + -- XXX these take too much memory with --long, need to investigate + , benchIOSink value "alt8" $ alt8 value + , benchIOSink value "alt16" $ alt16 value + , benchIOSink value "monad8" $ monad8 value + , benchIOSink value "monad16" $ monad16 value + ] + +-- O(n) heap beacuse of accumulation of the list in strict IO monad? +o_1_space_recursive :: Int -> [Benchmark] +o_1_space_recursive value = + [ benchIOSink value "one (recursive)" $ one value + ] + +------------------------------------------------------------------------------- +-- Driver +------------------------------------------------------------------------------- + +main :: IO () +main = runWithCLIOpts defaultStreamSize allBenchmarks + + where + + allBenchmarks value = + [ bgroup (o_1_space_prefix moduleName) (o_1_space_serial value) + , bgroup (o_1_space_prefix moduleName) (o_1_space_recursive value) + , bgroup (o_n_heap_prefix moduleName) (o_n_heap_serial value) + ] diff --git a/benchmark/Streamly/Benchmark/Data/Ring/Unboxed.hs b/benchmark/Streamly/Benchmark/Data/Ring/Unboxed.hs deleted file mode 100644 --- a/benchmark/Streamly/Benchmark/Data/Ring/Unboxed.hs +++ /dev/null @@ -1,70 +0,0 @@ --- | --- Module : Streamly.Benchmark.Data.Ring.Unboxed --- Copyright : (c) 2022 Composewell --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com - -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Main (main) where - -import Control.Monad (void) -import GHC.Ptr (Ptr(..)) - -import qualified Streamly.Internal.Data.Array.Type as Array -import qualified Streamly.Internal.Data.Ring.Unboxed as Ring -import qualified Data.Foldable as P - -import Gauge -import Streamly.Benchmark.Common - -import Prelude as P - -------------------------------------------------------------------------------- --- Benchmark ops -------------------------------------------------------------------------------- - -unsafeEqArrayN :: (Int, Array.Array Int, (Ring.Ring Int, Ptr Int)) -> Bool -unsafeEqArrayN (value, arr, (ring, rh)) = Ring.unsafeEqArrayN ring rh arr value - -unsafeEqArray :: (Array.Array Int, (Ring.Ring Int, Ptr Int)) -> Bool -unsafeEqArray (arr, (ring, rh)) = Ring.unsafeEqArray ring rh arr - -------------------------------------------------------------------------------- --- Benchmark groups -------------------------------------------------------------------------------- - -o_1_space_serial :: - Int -> Array.Array Int -> (Ring.Ring Int, Ptr Int) -> [Benchmark] -o_1_space_serial value arr (ring, rh) = - [ bench "unsafeEqArrayN" $ nf unsafeEqArrayN (value, arr, (ring, rh)) - , bench "unsafeEqArray" $ nf unsafeEqArray (arr, (ring, rh)) - ] - -------------------------------------------------------------------------------- --- Main -------------------------------------------------------------------------------- - -moduleName :: String -moduleName = "Data.Ring.Unboxed" - -main :: IO () -main = do - runWithCLIOptsEnv defaultStreamSize alloc allBenchmarks - - where - - alloc value = do - let input = [1 .. value] :: [Int] - let arr = Array.fromList input - (ring, rh) <- Ring.new value - void $ P.foldlM (Ring.unsafeInsert ring) rh input - return (arr, (ring, rh)) - - allBenchmarks (arr, (ring, rh)) value = - [ bgroup - (o_1_space_prefix moduleName) - (o_1_space_serial value arr (ring, rh)) - ] diff --git a/benchmark/Streamly/Benchmark/Data/RingArray.hs b/benchmark/Streamly/Benchmark/Data/RingArray.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Data/RingArray.hs @@ -0,0 +1,67 @@ +-- | +-- Module : Streamly.Benchmark.Data.RingArray +-- Copyright : (c) 2022 Composewell +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main (main) where + +import qualified Streamly.Internal.Data.Array as Array +import qualified Streamly.Internal.Data.MutArray as MutArray +import qualified Streamly.Internal.Data.RingArray as RingArray + +import Test.Tasty.Bench +import Streamly.Benchmark.Common + +import Prelude as P + +------------------------------------------------------------------------------- +-- Benchmark ops +------------------------------------------------------------------------------- + +eqArrayN :: (Int, Array.Array Int, RingArray.RingArray Int) -> IO Bool +eqArrayN (value, arr, ring) = RingArray.eqArrayN ring arr value + +eqArray :: (Array.Array Int, RingArray.RingArray Int) -> IO Bool +eqArray (arr, ring) = RingArray.eqArray ring arr + +------------------------------------------------------------------------------- +-- Benchmark groups +------------------------------------------------------------------------------- + +o_1_space_serial :: Int -> Array.Array Int -> RingArray.RingArray Int -> [Benchmark] +o_1_space_serial value arr ring = + [ bench "eqArrayN" $ nfIO $ eqArrayN (value, arr, ring) + , bench "eqArray" $ nfIO $ eqArray (arr, ring) + ] + +------------------------------------------------------------------------------- +-- Main +------------------------------------------------------------------------------- + +moduleName :: String +moduleName = "Data.RingArray" + +main :: IO () +main = do + runWithCLIOptsEnv defaultStreamSize alloc allBenchmarks + + where + + alloc value = do + let input = [1 .. value] :: [Int] + let arr = Array.fromList input + marr <- MutArray.fromList input + let ring = maybe (error "cast failed") id (RingArray.castMutArray marr) + + return (arr, ring) + + allBenchmarks (arr, ring) value = + [ bgroup + (o_1_space_prefix moduleName) + (o_1_space_serial value arr ring) + ] diff --git a/benchmark/Streamly/Benchmark/Data/Scanl.hs b/benchmark/Streamly/Benchmark/Data/Scanl.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Data/Scanl.hs @@ -0,0 +1,127 @@ +-- | +-- Module : Streamly.Benchmark.Data.Scanl +-- Copyright : (c) 2018 Composewell +-- +-- License : MIT +-- Maintainer : streamly@composewell.com + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Main (main) where + +import Data.IORef (newIORef, readIORef, modifyIORef) +import Control.DeepSeq (NFData(..)) +import Data.Functor.Identity (Identity(..)) +import System.Random (randomRIO) + +import Streamly.Internal.Data.Stream (Stream) +import Streamly.Internal.Data.Scanl (Scanl(..)) +import Streamly.Internal.Data.MutArray (MutArray) + +import qualified Streamly.Internal.Data.Fold as FL +import qualified Streamly.Internal.Data.Scanl as Scanl +import qualified Streamly.Internal.Data.Stream as Stream + +import Test.Tasty.Bench hiding (env) +import Streamly.Benchmark.Common +import Prelude hiding (last, length, all, any, take, unzip, sequence_, filter) + +import qualified Data.Set as Set +import System.IO.Unsafe (unsafePerformIO) + +------------------------------------------------------------------------------- +-- Helpers +------------------------------------------------------------------------------- + +{-# INLINE source #-} +source :: (Monad m, Num a, Stream.Enumerable a) => + Int -> a -> Stream m a +source len from = + Stream.enumerateFromThenTo from (from + 1) (from + fromIntegral len) + +{-# INLINE benchScanWith #-} +benchScanWith :: Num a => + (Int -> a -> Stream IO a) -> Int -> String -> Scanl IO a b -> Benchmark +benchScanWith src len name f = + bench name + $ nfIO + $ randomRIO (1, 1 :: Int) + >>= Stream.fold FL.drain + . Stream.postscanl f + . src len + . fromIntegral + +{-# INLINE benchWithPostscan #-} +benchWithPostscan :: Int -> String -> Scanl IO Int a -> Benchmark +benchWithPostscan = benchScanWith source + +------------------------------------------------------------------------------- +-- Benchmarks +------------------------------------------------------------------------------- + +moduleName :: String +moduleName = "Data.Scanl" + +instance NFData (MutArray a) where + {-# INLINE rnf #-} + rnf _ = () + +instance NFData a => NFData (Stream Identity a) where + {-# INLINE rnf #-} + rnf xs = runIdentity $ Stream.fold (FL.foldl' (\_ x -> rnf x) ()) xs + +o_1_space_serial :: Int -> [Benchmark] +o_1_space_serial value = + [ bgroup "key-value" + [ + benchWithPostscan value "demuxIO (1-shot) (64 buckets) [sum 100]" + $ Scanl.demuxIO (getKey 64) getScanl + , benchWithPostscan value "demuxIO (64 buckets) [sum]" + $ Scanl.demuxIO (getKey 64) (const (pure (Just Scanl.sum))) + , benchWithPostscan value "classifyIO (64 buckets) [sum 100]" + $ Scanl.classifyIO (getKey 64) (limitedSum 100) + , benchWithPostscan value "classifyIO (64 buckets) [sum]" + $ Scanl.classifyIO (getKey 64) Scanl.sum + ] + ] + + where + + limitedSum n = Scanl.take n Scanl.sum + + getKey buckets = (`mod` buckets) + + afterDone action (Scanl.Scanl step i e f) = Scanl.Scanl step1 i e f + where + step1 x a = do + res <- step x a + case res of + Scanl.Partial s1 -> pure $ Scanl.Partial s1 + Scanl.Done b -> action >> pure (Scanl.Done b) + + ref = unsafePerformIO $ newIORef Set.empty + getScanl k = do + set <- readIORef ref + if Set.member k set + then pure Nothing + else pure + $ Just + $ afterDone (modifyIORef ref (Set.insert k)) (limitedSum 100) + +------------------------------------------------------------------------------- +-- Driver +------------------------------------------------------------------------------- + +main :: IO () +main = runWithCLIOpts defaultStreamSize allBenchmarks + + where + + allBenchmarks value = + [ bgroup (o_1_space_prefix moduleName) (o_1_space_serial value) + ] diff --git a/benchmark/Streamly/Benchmark/Data/Scanl/Concurrent.hs b/benchmark/Streamly/Benchmark/Data/Scanl/Concurrent.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Data/Scanl/Concurrent.hs @@ -0,0 +1,76 @@ +module Main (main) where + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +import Data.Function ((&)) +-- import Streamly.Internal.Data.Scanl (Scanl) +import Streamly.Internal.Data.Stream (Stream) +import System.Random (randomRIO) + +import qualified Streamly.Data.Fold as Fold +import qualified Streamly.Data.Stream as Stream +import qualified Streamly.Internal.Data.Scanl as Scanl +import qualified Streamly.Internal.Data.Scanl.Prelude as Scanl + +import Data.IORef +import Streamly.Benchmark.Common +import Test.Tasty.Bench + +-------------------------------------------------------------------------------- +-- Helpers +-------------------------------------------------------------------------------- + +type Seed = Int + +{-# INLINE source #-} +source :: (Monad m, Num a, Stream.Enumerable a) => + Int -> a -> Stream m a +source len from = + Stream.enumerateFromThenTo from (from + 1) (from + fromIntegral len) + +{-# INLINE mkBench #-} +mkBench :: String -> (Seed -> IO ()) -> Benchmark +mkBench name f = + bench name $ nfIO $ randomRIO (1, 1 :: Int) >>= f + +-------------------------------------------------------------------------------- +-- Benchmarks +-------------------------------------------------------------------------------- + +parDistributeScanM :: Int -> Seed -> IO () +parDistributeScanM len seed = do + ref <- newIORef [Scanl.latest] + let gen = atomicModifyIORef ref (\xs -> ([], xs)) + Scanl.parDistributeScanM id gen (source len seed) + & Stream.fold Fold.drain + +-------------------------------------------------------------------------------- +-- Groups +-------------------------------------------------------------------------------- + +o_1_space_scans :: Int -> [Benchmark] +o_1_space_scans numElements = + [ bgroup "scan" + [ mkBench "parDistributeScanM" (parDistributeScanM numElements) + ] + ] + +-------------------------------------------------------------------------------- +-- Main +-------------------------------------------------------------------------------- + +moduleName :: String +moduleName = "Data.Scanl.Concurrent" + +main :: IO () +main = runWithCLIOpts defaultStreamSize allBenchmarks + + where + + allBenchmarks value = + [ bgroup (o_1_space_prefix moduleName) + ( o_1_space_scans value + ) + ] diff --git a/benchmark/Streamly/Benchmark/Data/Scanl/Window.hs b/benchmark/Streamly/Benchmark/Data/Scanl/Window.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Data/Scanl/Window.hs @@ -0,0 +1,113 @@ +module Main (main) where + +import Streamly.Internal.Data.Scanl (Scanl) +import Streamly.Internal.Data.Stream (Stream) +import System.Random (randomRIO) + +import qualified Streamly.Internal.Data.Fold as Fold +import qualified Streamly.Internal.Data.Scanl as Scanl +import qualified Streamly.Internal.Data.Stream as Stream + +import Streamly.Benchmark.Common +import Test.Tasty.Bench + +{-# INLINE source #-} +source :: (Monad m, Num a, Stream.Enumerable a) => + Int -> a -> Stream m a +source len from = + Stream.enumerateFromThenTo from (from + 1) (from + fromIntegral len) + +{-# INLINE sourceDescending #-} +sourceDescending :: (Monad m, Num a, Stream.Enumerable a) => + Int -> a -> Stream m a +sourceDescending len from = + Stream.enumerateFromThenTo + (from + fromIntegral len) + (from + fromIntegral (len - 1)) + from + +{-# INLINE sourceDescendingInt #-} +sourceDescendingInt :: Monad m => Int -> Int -> Stream m Int +sourceDescendingInt = sourceDescending + +{-# INLINE benchScanWith #-} +benchScanWith :: Num a => + (Int -> a -> Stream IO a) -> Int -> String -> Scanl IO a b -> Benchmark +benchScanWith src len name f = + bench name + $ nfIO + $ randomRIO (1, 1 :: Int) + >>= Stream.fold Fold.drain + . Stream.postscanl f + . src len + . fromIntegral + +{-# INLINE benchWithPostscan #-} +benchWithPostscan :: Int -> String -> Scanl IO Double a -> Benchmark +benchWithPostscan = benchScanWith source + +o_1_space_scans :: Int -> [Benchmark] +o_1_space_scans numElements = + [ bgroup "scan" + [ benchWithPostscan numElements "minimum (window size 10)" + (Scanl.windowMinimum 10) + -- Below window size 30 the linear search based impl performs better + -- than the dequeue based implementation. + , benchWithPostscan numElements "minimum (window size 30)" + (Scanl.windowMinimum 30) + , benchWithPostscan numElements "minimum (window size 1000)" + (Scanl.windowMinimum 1000) + , benchScanWith sourceDescendingInt numElements + "minimum descending (window size 1000)" + (Scanl.windowMinimum 1000) + + , benchWithPostscan numElements "maximum (window size 10)" + (Scanl.windowMaximum 10) + , benchWithPostscan numElements "maximum (window size 30)" + (Scanl.windowMaximum 30) + , benchWithPostscan numElements "maximum (window size 1000)" + (Scanl.windowMaximum 1000) + , benchScanWith sourceDescendingInt numElements + "maximum descending (window size 1000)" + (Scanl.windowMaximum 1000) + + , benchWithPostscan numElements "range (window size 10)" + (Scanl.windowRange 10) + , benchWithPostscan numElements "range (window size 30)" + (Scanl.windowRange 30) + , benchWithPostscan numElements "range (window size 1000)" + (Scanl.windowRange 1000) + , benchScanWith sourceDescendingInt numElements + "range descending (window size 1000)" + (Scanl.windowRange 1000) + + , benchWithPostscan numElements "sum (window size 100)" + (Scanl.incrScan 100 Scanl.incrSum) + , benchWithPostscan numElements "sum (window size 1000)" + (Scanl.incrScan 1000 Scanl.incrSum) + + , benchWithPostscan numElements "mean (window size 100)" + (Scanl.incrScan 100 Scanl.incrMean) + , benchWithPostscan numElements "mean (window size 1000)" + (Scanl.incrScan 1000 Scanl.incrMean) + + , benchWithPostscan numElements "powerSum 2 (window size 100)" + (Scanl.incrScan 100 (Scanl.incrPowerSum 2)) + , benchWithPostscan numElements "powerSum 2 (window size 1000)" + (Scanl.incrScan 1000 (Scanl.incrPowerSum 2)) + ] + ] + +moduleName :: String +moduleName = "Data.Scanl.Window" + +main :: IO () +main = runWithCLIOpts defaultStreamSize allBenchmarks + + where + + allBenchmarks value = + [ bgroup (o_1_space_prefix moduleName) + ( o_1_space_scans value + ) + ] diff --git a/benchmark/Streamly/Benchmark/Data/Serialize.hs b/benchmark/Streamly/Benchmark/Data/Serialize.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Data/Serialize.hs @@ -0,0 +1,596 @@ +{-# LANGUAGE TemplateHaskell #-} +{- HLINT ignore -} + +#undef FUSION_CHECK +#ifdef FUSION_CHECK +{-# OPTIONS_GHC -ddump-simpl -ddump-to-file -dsuppress-all #-} +#endif + +-- | +-- Module : Streamly.Benchmark.Data.Serialize +-- Copyright : (c) 2023 Composewell +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com + +module Main (main) where + +------------------------------------------------------------------------------- +-- Imports +------------------------------------------------------------------------------- + +import Control.DeepSeq (NFData(..), deepseq) +import Control.Monad (when, void) +import GHC.Generics (Generic) +import System.Random (randomRIO) +#ifndef USE_UNBOX +import Test.QuickCheck (Arbitrary, arbitrary) +#endif + +import Streamly.Internal.Data.MutByteArray +import qualified Streamly.Internal.Data.MutByteArray as MBA +#ifdef USE_UNBOX +import Data.Proxy (Proxy(..)) +#else +import Control.DeepSeq (force) +import Test.QuickCheck (oneof, generate) +#endif + +import Test.Tasty.Bench +import Streamly.Benchmark.Common + +#ifndef USE_UNBOX +import Streamly.Benchmark.Data.Serialize.RecCompatible +import Streamly.Benchmark.Data.Serialize.RecNonCompatible +#endif + +#ifdef USE_UNBOX +#define SERIALIZE_CLASS Unbox +#define DERIVE_CLASS(typ) $(deriveUnbox [d|instance Unbox typ|]) +#define SERIALIZE_OP pokeAt +#define DESERIALIZE_OP peekAt +#else +#define SERIALIZE_CLASS Serialize +#define DERIVE_CLASS(typ) $(deriveSerialize [d|instance Serialize typ|]) +#define SERIALIZE_OP serializeAt +#define DESERIALIZE_OP deserializeAt +#endif + +import Prelude hiding (length) +#ifndef USE_UNBOX +import qualified Prelude as P +#endif + +------------------------------------------------------------------------------- +-- Types +------------------------------------------------------------------------------- + +data Unit = Unit + deriving (Generic, Show, Eq) + +#ifndef USE_TH +instance SERIALIZE_CLASS Unit +#else +DERIVE_CLASS(Unit) +#endif + +instance NFData Unit where + {-# INLINE rnf #-} + rnf _ = () + +data Sum2 + = Sum21 + | Sum22 + deriving (Generic, Show, Eq) + +#ifndef USE_TH +instance SERIALIZE_CLASS Sum2 +#else +DERIVE_CLASS(Sum2) +#endif + +instance NFData Sum2 where + {-# INLINE rnf #-} + rnf _ = () + +data Sum25 + = Sum251 + | Sum252 + | Sum253 + | Sum254 + | Sum255 + | Sum256 + | Sum257 + | Sum258 + | Sum259 + | Sum2510 + | Sum2511 + | Sum2512 + | Sum2513 + | Sum2514 + | Sum2515 + | Sum2516 + | Sum2517 + | Sum2518 + | Sum2519 + | Sum2520 + | Sum2521 + | Sum2522 + | Sum2523 + | Sum2524 + | Sum2525 + deriving (Generic, Show, Eq) + +#ifndef USE_TH +instance SERIALIZE_CLASS Sum25 +#else +DERIVE_CLASS(Sum25) +#endif + +instance NFData Sum25 where + {-# INLINE rnf #-} + rnf _ = () + +data Product25 + = Product25 + Int + Int + Int + Int + Int + Int + Int + Int + Int + Int + Int + Int + Int + Int + Int + Int + Int + Int + Int + Int + Int + Int + Int + Int + Int + deriving (Generic, Show) + +#ifndef USE_TH +instance SERIALIZE_CLASS Product25 +#else +DERIVE_CLASS(Product25) +#endif + +instance NFData Product25 where + {-# INLINE rnf #-} + rnf + (Product25 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23 a24 a25) + = a1 + `seq` a2 + `seq` a3 + `seq` a4 + `seq` a5 + `seq` a6 + `seq` a7 + `seq` a8 + `seq` a9 + `seq` a10 + `seq` a11 + `seq` a12 + `seq` a13 + `seq` a14 + `seq` a15 + `seq` a16 + `seq` a17 + `seq` a18 + `seq` a19 + `seq` a20 + `seq` a21 + `seq` a22 + `seq` a23 + `seq` a24 + `seq` a25 + `seq` () + +-- XXX derived Eq instance is not inlined +instance Eq Product25 where + {-# INLINE (==) #-} + (==) + (Product25 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23 a24 a25) + (Product25 b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 b11 b12 b13 b14 b15 b16 b17 b18 b19 b20 b21 b22 b23 b24 b25) + = a1 == b1 + && a2 == b2 + && a3 == b3 + && a4 == b4 + && a5 == b5 + && a6 == b6 + && a7 == b7 + && a8 == b8 + && a9 == b9 + && a10 == b10 + && a11 == b11 + && a12 == b12 + && a13 == b13 + && a14 == b14 + && a15 == b15 + && a16 == b16 + && a17 == b17 + && a18 == b18 + && a19 == b19 + && a20 == b20 + && a21 == b21 + && a22 == b22 + && a23 == b23 + && a24 == b24 + && a25 == b25 + +------------------------------------------------------------------------------- +-- Simple non-recursive ADT +------------------------------------------------------------------------------- + +{- +data CustomDT1 + = CDT1C1 + | CDT1C2 Int + | CDT1C3 Int Int + deriving (Generic, Show, Eq) + +#ifndef USE_TH +instance SERIALIZE_CLASS CustomDT1 +#else +DERIVE_CLASS(CustomDT1) +#endif + +instance NFData CustomDT1 where + {-# INLINE rnf #-} + rnf CDT1C1 = () + rnf (CDT1C2 i) = i `seq` () + rnf (CDT1C3 i1 i2) = i1 `seq` i2 `seq` () +-} + +------------------------------------------------------------------------------- +-- Recursive ADT +------------------------------------------------------------------------------- + +#ifndef USE_UNBOX +data BinTree a + = Tree (BinTree a) (BinTree a) + | Leaf a + deriving (Show, Read, Eq, Generic) + +#ifndef USE_TH +instance Serialize (BinTree a) +#else +$(deriveSerialize [d|instance Serialize a => Serialize (BinTree a)|]) +#endif + +instance NFData a => NFData (BinTree a) where + {-# INLINE rnf #-} + rnf (Leaf a) = rnf a `seq` () + rnf (Tree l r) = rnf l `seq` rnf r + +-- XXX This may not terminate, or could become really large. +instance Arbitrary a => Arbitrary (BinTree a) where + arbitrary = oneof [Leaf <$> arbitrary, Tree <$> arbitrary <*> arbitrary] + +mkBinTree :: (Arbitrary a) => Int -> IO (BinTree a) +mkBinTree = go (generate arbitrary) + + where + + go r 0 = Leaf <$> r + go r n = Tree <$> go r (n - 1) <*> go r (n - 1) + +#endif + +------------------------------------------------------------------------------- +-- Size helpers +------------------------------------------------------------------------------- + +{-# INLINE getSize #-} +getSize :: forall a. SERIALIZE_CLASS a => a -> Int +#ifdef USE_UNBOX +getSize _ = sizeOf (Proxy :: Proxy a) +#else +getSize = addSizeTo 0 +#endif + +------------------------------------------------------------------------------- +-- Common helpers +------------------------------------------------------------------------------- + +{- HLINT ignore "Eta reduce" -} +-- Parts of "f" that are dependent on val will not be optimized out. +{-# INLINE loop #-} +loop :: Int -> (a -> IO b) -> a -> IO () +loop count f val = go count val + where + + go n x = when (n > 0) $ f x >> go (n-1) x + +-- The first arg of "f" is the environment which is not threaded around in the +-- loop. +{-# INLINE loopWith #-} +loopWith :: Int -> (e -> a -> IO b) -> e -> a -> IO () +loopWith count f e val = go count val + where + + go n x = when (n > 0) $ f e x >> go (n-1) x + +benchSink :: NFData b => String -> Int -> (Int -> IO b) -> Benchmark +benchSink name times f = bench name (nfIO (randomRIO (times, times) >>= f)) + +------------------------------------------------------------------------------- +-- Serialization Helpers +------------------------------------------------------------------------------- + +{- +{-# INLINE pokeWithSize #-} +pokeWithSize :: SERIALIZE_CLASS a => MutByteArray -> a -> IO () +pokeWithSize arr val = do + let n = getSize val + n `seq` SERIALIZE_OP 0 arr val >> return () + +{-# INLINE pokeTimesWithSize #-} +pokeTimesWithSize :: SERIALIZE_CLASS a => a -> Int -> IO () +pokeTimesWithSize val times = do + let n = getSize val + arr <- MBA.new n + loopWith times pokeWithSize arr val +-} + +{-# INLINE poke #-} +poke :: SERIALIZE_CLASS a => MutByteArray -> a -> IO () +poke arr val = void (SERIALIZE_OP 0 arr val) + +{-# INLINE pokeTimes #-} +pokeTimes :: SERIALIZE_CLASS a => a -> Int -> IO () +pokeTimes val times = do + let n = getSize val + arr <- MBA.new n + loopWith times poke arr val + +{-# INLINE encode #-} +encode :: SERIALIZE_CLASS a => a -> IO () +encode val = do + let n = getSize val + arr <- MBA.new n + void (SERIALIZE_OP 0 arr val) + +{-# INLINE encodeTimes #-} +encodeTimes :: SERIALIZE_CLASS a => a -> Int -> IO () +encodeTimes val times = loop times encode val + +{-# INLINE peek #-} +peek :: forall a. (NFData a, SERIALIZE_CLASS a) => + (a, Int) -> MutByteArray -> IO () +#ifdef USE_UNBOX +peek (_val, _) arr = do + (val1 :: a) <- DESERIALIZE_OP 0 arr +#else +peek (_val, n) arr = do + (_, val1 :: a) <- DESERIALIZE_OP 0 arr n +#endif + -- If the datatype is not deeply strict or deepseq is not used then use + -- Equality. + -- Ensure that we are actually constructing the type and using it. This + -- is important, otherwise the structure is created and discarded, the + -- cost of creation of the structure is not accounted. Otherwise we may + -- just read the values and discard them. The comparison adds to the + -- cost though. We could use deepseq but then we need to write + -- instances of NFData and ensure that they are correct and perform + -- well. Equality check also ensures correctness. + {- + if (val1 /= val) + then error "peek: no match" + else return () + -} + val1 `deepseq` return () + +{-# INLINE peekTimes #-} +peekTimes :: (NFData a, SERIALIZE_CLASS a) => Int -> a -> Int -> IO () +peekTimes n val times = do + arr <- MBA.new n + _ <- SERIALIZE_OP 0 arr val + loopWith times peek (val, n) arr + +{-# INLINE trip #-} +trip :: forall a. (NFData a, SERIALIZE_CLASS a) => a -> IO () +trip val = do + let n = getSize val + arr <- MBA.new n + _ <- SERIALIZE_OP 0 arr val +#ifdef USE_UNBOX + (val1 :: a) <- DESERIALIZE_OP 0 arr +#else + (_, val1 :: a) <- DESERIALIZE_OP 0 arr n +#endif + -- Do not remove this or use deepseq, see the comments in peek. + {- + if (val1 /= val) + then error "roundtrip: no match" + else return () + -} + -- Note: deepseq is not needed if the datatype is strict + val1 `deepseq` return () + +{-# INLINE roundtrip #-} +roundtrip :: (NFData a, SERIALIZE_CLASS a) => a -> Int -> IO () +roundtrip val times = loop times trip val + +------------------------------------------------------------------------------- +-- Benchmarks +------------------------------------------------------------------------------- + +{-# INLINE benchConst #-} +benchConst :: + String + -> (forall a. (NFData a, SERIALIZE_CLASS a) => + Int -> a -> Int -> IO ()) + -> Int + -> Benchmark +benchConst gname f times = + bgroup gname + [ let !n = getSize Unit + in benchSink "Unit" times (f n Unit) + {- + , let !n = getSize CDT1C1 + in benchSink "C1" times (f n CDT1C1) + , let val = CDT1C2 5 + !n = getSize val + in benchSink "C2" (times `div` 2) (f n val) + , let val = CDT1C3 5 2 + !n = getSize val + in benchSink "C3" (times `div` 3) (f n val) + -} + , let !n = getSize Sum21 + in benchSink "Sum2" times (f n Sum21) + , let !n = getSize Sum2525 + in benchSink "Sum25" times (f n Sum2525) + , let val = Product25 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 + !n = getSize val + in benchSink "Product25" (times `div` 26) (f n val) + ] + +#ifndef USE_UNBOX +{-# INLINE benchVar #-} +benchVar :: + String + -> (forall a. (NFData a, SERIALIZE_CLASS a) => + Int -> a -> Int -> IO ()) + -> BinTree Int + -> [Int] + -> Int + -> Benchmark +benchVar gname f tInt lInt times = + bgroup gname + [ let !n = getSize tInt + in benchSink "bintree-int" times (f n tInt) + , let !n = getSize lInt + in benchSink "list-int" times (f n lInt) + ] + +{- +{-# INLINE benchGeneric #-} +benchGeneric + :: (NFData b, Serialize b) + => String + -> String + -> (forall a. (NFData a, Serialize a) => + Int -> a -> Int -> IO ()) + -> b + -> Int + -> Benchmark +benchGeneric gname valId f val times = + bgroup gname + [ let !n = getSize val + in benchSink valId times (f n val) + ] +-} + +{-# INLINE benchLargeRec #-} +benchLargeRec :: + String + -> (forall a. (NFData a, Serialize a) => + Int -> a -> Int -> IO ()) + -> RecNonCompatible + -> RecCompatible + -> Int + -> Benchmark +benchLargeRec gname f recL recR times = + bgroup gname + [ let !n = getSize recL + in benchSink "RecNonCompatible" times (f n recL) + , let !n = getSize recR + in benchSink "RecCompatible" times (f n recR) + ] +#endif + +-- Times is scaled by the number of constructors to normalize +#ifdef USE_UNBOX +allBenchmarks :: Int -> [Benchmark] +allBenchmarks times = +#else +allBenchmarks :: + BinTree Int -> [Int] -> RecNonCompatible -> RecCompatible -> Int -> [Benchmark] +allBenchmarks tInt lInt recL recR times = +#endif + [ bgroup "sizeOf" + [ +#ifndef USE_UNBOX + bench "bintree-int" $ nf getSize tInt + , bench "list-int" $ nf getSize lInt +#endif + ] + , benchConst "poke" (const pokeTimes) times + -- , benchConst "pokeWithSize" (const pokeTimesWithSize) times + , benchConst "encode" (const encodeTimes) times + , benchConst "peek" peekTimes times + , benchConst "roundtrip" (const roundtrip) times +#ifndef USE_UNBOX + , benchVar "poke" (const pokeTimes) tInt lInt 1 + -- , benchVar "pokeWithSize" (const pokeTimesWithSize) tInt lInt 1 + , benchVar "encode" (const encodeTimes) tInt lInt 1 + , benchVar "peek" peekTimes tInt lInt 1 + , benchVar "roundtrip" (const roundtrip) tInt lInt 1 + , benchLargeRec "poke" (const pokeTimes) recL recR times + , benchLargeRec "encode" (const encodeTimes) recL recR times + , benchLargeRec "peek" peekTimes recL recR times + , benchLargeRec "roundtrip" (const roundtrip) recL recR times +#endif + ] + +------------------------------------------------------------------------------- +-- Driver +------------------------------------------------------------------------------- + +main :: IO () +main = do +#ifndef USE_UNBOX + -- Approximately 100000 constructors + -- Assuming Leaf nodes constitute two constructors (Leaf, Int) and internal + -- nodes 1 level = log_2 (100001/3) + 1 = 16 + !(tInt :: BinTree Int) <- force <$> mkBinTree 16 + + let !recL = valRecNonCompatible + let !recR = valRecCompatible + + -- Approximately 100000 constructors, assuming two constructors (Cons, Int) + -- per element. + let lInt = [1..50000 :: Int] + let !len = P.length lInt -- evaluate the list +#endif +#ifndef FUSION_CHECK +#ifdef USE_UNBOX + runWithCLIOpts defaultStreamSize allBenchmarks +#else + len + `seq` runWithCLIOpts + defaultStreamSize + (allBenchmarks tInt lInt recL recR) +#endif +#else + -- Enable FUSION_CHECK macro at the beginning of the file + -- Enable one benchmark below, and run the benchmark + -- Check the .dump-simpl output + let value = 100000 + -- print $ getSize (CDT1C3 4 2) + -- print $ getSize tInt + -- print $ getSize lInt + + -- pokeTimes tInt 1 + + -- peekTimes ((CDT1C2 (5 :: Int)) :: CustomDT1) value + -- peekTimes (Sum2525) value + -- peekTimes (Product25 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25) value + -- peekTimes tInt 1 + let !n = getSize lInt + peekTimes n lInt 1 + + -- roundtrip ((CDT1C2 (5 :: Int)) :: CustomDT1) value + return () +#endif diff --git a/benchmark/Streamly/Benchmark/Data/Serialize/RecCompatible.hs b/benchmark/Streamly/Benchmark/Data/Serialize/RecCompatible.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Data/Serialize/RecCompatible.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Streamly.Benchmark.Data.Serialize.RecCompatible + ( RecCompatible(..) + , valRecCompatible + ) where + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +import Streamly.Internal.Data.MutByteArray (Serialize) +import Streamly.Benchmark.Data.Serialize.TH (genLargeRecord) + +import qualified Streamly.Internal.Data.MutByteArray as Serialize + +-------------------------------------------------------------------------------- +-- Code +-------------------------------------------------------------------------------- + +$(genLargeRecord "RecCompatible" 50) +$(Serialize.deriveSerializeWith + (Serialize.encodeRecordFields True) + [d|instance Serialize RecCompatible|]) diff --git a/benchmark/Streamly/Benchmark/Data/Serialize/RecNonCompatible.hs b/benchmark/Streamly/Benchmark/Data/Serialize/RecNonCompatible.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Data/Serialize/RecNonCompatible.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Streamly.Benchmark.Data.Serialize.RecNonCompatible + ( RecNonCompatible(..) + , valRecNonCompatible + ) where + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +import Streamly.Benchmark.Data.Serialize.TH (genLargeRecord) + +import qualified Streamly.Internal.Data.MutByteArray as Serialize + +-------------------------------------------------------------------------------- +-- Code +-------------------------------------------------------------------------------- + +$(genLargeRecord "RecNonCompatible" 50) +$(Serialize.deriveSerialize [d|instance Serialize.Serialize RecNonCompatible|]) diff --git a/benchmark/Streamly/Benchmark/Data/Serialize/TH.hs b/benchmark/Streamly/Benchmark/Data/Serialize/TH.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Data/Serialize/TH.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Streamly.Benchmark.Data.Serialize.TH (genLargeRecord) where + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +import Language.Haskell.TH + +import Streamly.Internal.Data.MutByteArray (makeI) +import Control.DeepSeq (NFData(..)) + +-------------------------------------------------------------------------------- +-- Large Record +-------------------------------------------------------------------------------- + +genLargeRecord :: String -> Int -> Q [Dec] +genLargeRecord tyName numFields = + sequence + [ dataD + (pure []) + (mkName tyName) + [] + Nothing + [mkCon tyName] + [derivClause Nothing [conT ''Eq, conT ''Show]] + , mkValueSigDec + , mkValueDec + , nfDataInstance tyName + ] + + where + + fieldTypeChoices = [conT ''()] + chooseCycle i xs = xs !! (i `mod` length xs) + nfDataInstance nm = + instanceD + (pure []) + (appT (conT ''NFData) (conT (mkName nm))) + [ funD + 'rnf + [ clause + [ conP + (mkName nm) + (varP . makeI <$> [0 .. (numFields - 1)]) + ] + (normalB + (foldl + (\b a -> [|rnf $(b) `seq` rnf $(a)|]) + [|()|] + (varE . makeI <$> [0 .. (numFields - 1)]))) + [] + ] + ] + valueName = mkName $ "val" ++ tyName + mkValueSigDec = sigD valueName [t|$(conT (mkName tyName))|] + mkValueDec = + funD + valueName + [ clause + [] + (normalB + (foldl + (\b a -> [|$(b) $(a)|]) + (conE (mkName tyName)) + (conE '() <$ [0 .. (numFields - 1)]))) + [] + ] + mkCon nm = recC (mkName nm) (mkField <$> [0 .. (numFields - 1)]) + mkField i = + varBangType + (mkName ("field" ++ show i)) + (bangType + (bang noSourceUnpackedness noSourceStrictness) + (chooseCycle i fieldTypeChoices)) diff --git a/benchmark/Streamly/Benchmark/Data/Stream.hs b/benchmark/Streamly/Benchmark/Data/Stream.hs --- a/benchmark/Streamly/Benchmark/Data/Stream.hs +++ b/benchmark/Streamly/Benchmark/Data/Stream.hs @@ -26,7 +26,7 @@ import qualified Stream.Generate as Generation import qualified Stream.Lift as Lift import qualified Stream.Reduce as NestedFold -#ifdef USE_PRELUDE +#ifndef USE_PRELUDE import qualified Stream.Split as Split #endif import qualified Stream.Transform as Transformation @@ -36,18 +36,14 @@ #ifdef FUSION_CHECK import Data.Function ((&)) import Streamly.Data.Stream (Stream) -import qualified Streamly.Internal.Data.Stream.StreamD as Stream +import qualified Streamly.Internal.Data.Stream as Stream import qualified Streamly.Internal.Data.Fold as Fold import qualified Data.Foldable as Foldable import Stream.Common #endif moduleName :: String -#ifdef USE_STREAMK -moduleName = "Data.Stream.StreamDK" -#else moduleName = "Data.Stream" -#endif ------------------------------------------------------------------------------- -- Main @@ -70,7 +66,7 @@ #ifndef USE_STREAMLY_CORE , Exceptions.benchmarks moduleName env size #endif -#ifdef USE_PRELUDE +#ifndef USE_PRELUDE , Split.benchmarks moduleName env #endif , Transformation.benchmarks moduleName size diff --git a/benchmark/Streamly/Benchmark/Data/Stream/Adaptive.hs b/benchmark/Streamly/Benchmark/Data/Stream/Adaptive.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Data/Stream/Adaptive.hs @@ -0,0 +1,160 @@ +-- | +-- Module : Main +-- Copyright : (c) 2018 Composewell Technologies +-- License : BSD3 +-- Maintainer : streamly@composewell.com + +import Control.Concurrent (threadDelay) +import Control.Monad (when) +import Control.Monad.IO.Class (MonadIO(liftIO)) +import Streamly.Data.Stream.Prelude (Stream, Config) +import System.Random (randomRIO) + +import qualified Streamly.Data.Fold as Fold +import qualified Streamly.Data.Stream.Prelude as Stream + +import Test.Tasty.Bench + +-- Note that we should also compare the cpuTime especially when threaded +-- runtime is used with this benchmark because thread scheduling is not +-- predictable and can add non-deterministic delay to the total time measured. +-- +-- Also, the worker dispatch depends on the worker dispatch latency which is +-- set to fixed 200 us. We need to keep that in mind when designing tests. + +moduleName :: String +moduleName = "Data.Stream.Adaptive" + +value :: Int +value = 1000 + +produce :: MonadIO m => (Int, Int) -> m Int +produce range = do + r <- randomRIO range + when (r /= 0) $ liftIO $ threadDelay r + return r + +consume :: MonadIO m => (Int, Int) -> Int -> m Int +consume crange x = liftIO $ do + d <- randomRIO crange + when (d /= 0) $ threadDelay d + return x + +{-# INLINE serialSrc #-} +serialSrc :: (Int, Int) -> Stream IO Int +serialSrc range = Stream.replicateM value $ produce range + +{-# INLINE parSrc #-} +parSrc :: (Config -> Config) -> (Int, Int) -> Stream IO Int +parSrc cfg range = Stream.parReplicateM cfg value $ produce range + +{-# INLINE serialRun #-} +serialRun :: (Int, Int) -> (Int, Int) -> IO () +serialRun srange crange = + Stream.fold Fold.drain + $ Stream.mapM (consume crange) (serialSrc srange) + +{-# INLINE parRun #-} +parRun :: (Config -> Config) -> (Int, Int) -> (Int, Int) -> IO () +parRun cfg srange crange = + Stream.fold Fold.drain + $ Stream.parMapM cfg (consume crange) (parSrc cfg srange) + +low, medium, high :: Int +low = 10 +medium = 20 +high = 30 + +{-# INLINE noDelaySerial #-} +noDelaySerial :: IO () +noDelaySerial = serialRun (0,0) (0,0) + +{-# INLINE noDelay #-} +noDelay :: (Config -> Config) -> IO () +noDelay cfg = parRun cfg (0,0) (0,0) + +{-# INLINE alwaysConstSlowSerial #-} +alwaysConstSlowSerial :: IO () +alwaysConstSlowSerial = serialRun (0,0) (medium,medium) + +{-# INLINE alwaysConstSlow #-} +alwaysConstSlow :: (Config -> Config) -> IO () +alwaysConstSlow cfg = parRun cfg (low,low) (medium,medium) + +{-# INLINE alwaysConstFast #-} +alwaysConstFast :: (Config -> Config) -> IO () +alwaysConstFast cfg = parRun cfg (high,high) (medium,medium) + +{-# INLINE alwaysVarSlow #-} +alwaysVarSlow :: (Config -> Config) -> IO () +alwaysVarSlow cfg = parRun cfg (low,low) (low,high) + +{-# INLINE alwaysVarFast #-} +alwaysVarFast :: (Config -> Config) -> IO () +alwaysVarFast cfg = parRun cfg (high,high) (low,high) + +-- XXX add variable producer tests as well + +{-# INLINE runVarSometimesFast #-} +runVarSometimesFast :: (Config -> Config) -> IO () +runVarSometimesFast cfg = parRun cfg (medium,medium) (low,high) + +{-# INLINE randomVar #-} +randomVar :: (Config -> Config) -> IO () +randomVar cfg = parRun cfg (low,high) (low,high) + +main :: IO () +main = + defaultMain [bgroup moduleName allBenchmarks] + + where + + allBenchmarks = + [ + bgroup "serialConstantSlowConsumer" + [ bench "serial" $ nfIO alwaysConstSlowSerial + ] + , bgroup "default" + [ bench "serial" $ nfIO noDelaySerial + , bench "async" $ nfIO $ noDelay id + , bench "ordered" $ nfIO $ noDelay (Stream.ordered True) + , bench "interleaved" $ nfIO $ noDelay (Stream.interleaved True) + , bench "parallel" $ nfIO $ noDelay (Stream.eager True) + ] + , bgroup "constantSlowConsumer" + [ bench "async" $ nfIO $ alwaysConstSlow id + , bench "ordered" $ nfIO $ alwaysConstSlow (Stream.ordered True) + , bench "interleaved" $ nfIO $ alwaysConstSlow (Stream.interleaved True) + , bench "parallel" $ nfIO $ alwaysConstSlow (Stream.eager True) + ] + , bgroup "constantFastConsumer" + [ bench "async" $ nfIO $ alwaysConstFast id + , bench "ordered" $ nfIO $ alwaysConstFast (Stream.ordered True) + , bench "interleaved" $ nfIO $ alwaysConstFast (Stream.interleaved True) + , bench "parallel" $ nfIO $ alwaysConstFast (Stream.eager True) + ] + , bgroup "variableSlowConsumer" + [ bench "async" $ nfIO $ alwaysVarSlow id + , bench "ordered" $ nfIO $ alwaysVarSlow (Stream.ordered True) + , bench "interleaved" $ nfIO $ alwaysVarSlow (Stream.interleaved True) + , bench "parallel" $ nfIO $ alwaysVarSlow (Stream.eager True) + ] + , bgroup "variableFastConsumer" + [ bench "async" $ nfIO $ alwaysVarFast id + , bench "ordered" $ nfIO $ alwaysVarFast (Stream.ordered True) + , bench "interleaved" $ nfIO $ alwaysVarFast (Stream.interleaved True) + , bench "parallel" $ nfIO $ alwaysVarFast (Stream.eager True) + ] + , bgroup "variableSometimesFastConsumer" + [ bench "async" $ nfIO $ runVarSometimesFast id + , bench "ordered" $ nfIO $ runVarSometimesFast (Stream.ordered True) + , bench "interleaved" $ nfIO $ runVarSometimesFast (Stream.interleaved True) + , bench "parallel" $ nfIO $ runVarSometimesFast (Stream.eager True) + ] + , bgroup "variableFullOverlap" + [ bench "async" $ nfIO $ randomVar id + , bench "ordered" $ nfIO $ randomVar (Stream.ordered True) + , bench "interleaved" $ nfIO $ randomVar (Stream.interleaved True) + , bench "parallel" $ nfIO $ randomVar (Stream.eager True) + ] + ] diff --git a/benchmark/Streamly/Benchmark/Data/Stream/Common.hs b/benchmark/Streamly/Benchmark/Data/Stream/Common.hs --- a/benchmark/Streamly/Benchmark/Data/Stream/Common.hs +++ b/benchmark/Streamly/Benchmark/Data/Stream/Common.hs @@ -10,15 +10,11 @@ -- Maintainer : streamly@composewell.com #ifdef USE_PRELUDE -{-# OPTIONS_GHC -Wno-deprecations #-} #endif module Stream.Common ( MonadAsync - , fromStream - , toStream - -- Generation , fromListM , fromFoldableM @@ -40,14 +36,17 @@ -- Benchmark stream elimination , benchIOSink + , benchIOSinkPureSrc , benchIOSrc , benchIO + , toNullApPure + , toNullMPure + , toNullM3Pure + , filterAllOutMPure + , filterAllInMPure + -- Benchmarking functions -#ifdef USE_STREAMK - , concatStreamsWith - , mergeMapWith -#endif , apDiscardFst , apDiscardSnd , apLiftA2 @@ -67,11 +66,18 @@ , transformMapM , transformComposeMapM , transformTeeMapM - , transformZipMapM + -- , transformZipMapM +#ifndef USE_PRELUDE + , scanMapM + , scanComposeMapM + , scanTeeMapM +#endif ) where +#if !MIN_VERSION_base(4,18,0) import Control.Applicative (liftA2) +#endif import Control.DeepSeq (NFData) import Control.Exception (try) import GHC.Exception (ErrorCall) @@ -79,45 +85,24 @@ import qualified Streamly.Internal.Data.Fold as Fold import qualified Streamly.Internal.Data.Pipe as Pipe +import qualified Streamly.Internal.Data.Scanl as Scanl +import qualified Streamly.Internal.Data.Scanr as Scanr #ifdef USE_PRELUDE import Streamly.Prelude (foldl', scanl') import qualified Streamly.Internal.Data.Stream.IsStream as Stream import qualified Streamly.Prelude as Stream -import qualified Streamly.Prelude as StreamK import Streamly.Benchmark.Prelude ( composeN, sourceConcatMapId, benchIOSink - , concatStreamsWith ) #else -import Streamly.Internal.Data.Stream.StreamD (Stream) -import qualified Streamly.Internal.Data.Stream.StreamD as D -#ifdef USE_STREAMK -import Streamly.Internal.Data.Stream.StreamK (StreamK) -import qualified Streamly.Internal.Data.Stream.StreamD as Stream -import qualified Streamly.Internal.Data.Stream.StreamK as StreamK -#else -import qualified Streamly.Internal.Data.Stream.StreamD as Stream -import qualified Streamly.Internal.Data.Stream.StreamD as StreamK -#endif +import Streamly.Internal.Data.Stream (Stream) +import qualified Streamly.Internal.Data.Stream as D +import qualified Streamly.Internal.Data.Stream as Stream #endif -import Gauge -import Prelude hiding (mapM, replicate) - -#ifdef USE_STREAMK -toStream :: Applicative m => StreamK m a -> Stream m a -toStream = StreamK.toStream - -fromStream :: Monad m => Stream m a -> StreamK m a -fromStream = StreamK.fromStream -#else -fromStream :: a -> a -fromStream = id - -toStream :: a -> a -toStream = id -#endif +import Test.Tasty.Bench +import Prelude hiding (Foldable(..), mapM, replicate) #ifdef USE_PRELUDE type Stream = Stream.SerialT @@ -127,19 +112,11 @@ #else type MonadAsync = Monad -#ifdef USE_STREAMK -mkCross :: StreamK m a -> StreamK.CrossStreamK m a -mkCross = StreamK.mkCross - -unCross :: StreamK.CrossStreamK m a -> StreamK m a -unCross = StreamK.unCross -#else -mkCross :: Stream m a -> Stream.CrossStream m a -mkCross = Stream.mkCross +mkCross :: Stream m a -> Stream.Nested m a +mkCross = Stream.Nested -unCross :: Stream.CrossStream m a -> Stream m a -unCross = Stream.unCross -#endif +unCross :: Stream.Nested m a -> Stream m a +unCross = Stream.unNested #endif #ifdef USE_PRELUDE @@ -147,14 +124,9 @@ append :: Monad m => Stream m a -> Stream m a -> Stream m a append = Stream.serial #else -#ifdef USE_STREAMK -append :: StreamK m a -> StreamK m a -> StreamK m a -append = StreamK.append -#else append :: Monad m => Stream m a -> Stream m a -> Stream m a append = Stream.append #endif -#endif {-# INLINE append2 #-} append2 :: Monad m => Stream m a -> Stream m a -> Stream m a @@ -189,7 +161,7 @@ #ifdef USE_PRELUDE fromFoldableM = Stream.fromFoldableM #else -fromFoldableM = Stream.sequence . toStream . StreamK.fromFoldable +fromFoldableM = Stream.sequence . Stream.fromFoldable #endif {-# INLINE sourceUnfoldrM #-} @@ -227,7 +199,7 @@ {-# INLINE sourceFromFoldable #-} sourceFromFoldable :: Monad m => Int -> Int -> Stream m Int -sourceFromFoldable value n = toStream $ StreamK.fromFoldable [n..n+value] +sourceFromFoldable value n = Stream.fromFoldable [n..n+value] #ifndef USE_PRELUDE {-# INLINE benchIOSink #-} @@ -236,6 +208,13 @@ => Int -> String -> (Stream IO Int -> IO b) -> Benchmark benchIOSink value name f = bench name $ nfIO $ randomRIO (1,1) >>= f . sourceUnfoldrM value + +{-# INLINE benchIOSinkPureSrc #-} +benchIOSinkPureSrc + :: (NFData b) + => Int -> String -> (Stream IO Int -> IO b) -> Benchmark +benchIOSinkPureSrc value name f = + bench name $ nfIO $ randomRIO (1,1) >>= f . sourceUnfoldr value #endif -- | Takes a source, and uses it with a default drain/fold method. @@ -252,32 +231,6 @@ benchIO name f = bench name $ nfIO $ randomRIO (1,1) >>= f #ifndef USE_PRELUDE -#ifdef USE_STREAMK -{-# INLINE concatStreamsWith #-} -concatStreamsWith - :: (StreamK IO Int -> StreamK IO Int -> StreamK IO Int) - -> Int - -> Int - -> Int - -> IO () -concatStreamsWith op outer inner n = - drain $ toStream $ StreamK.concatMapWith op - (fromStream . sourceUnfoldrM inner) - (fromStream $ sourceUnfoldrM outer n) - -{-# INLINE mergeMapWith #-} -mergeMapWith - :: (StreamK IO Int -> StreamK IO Int -> StreamK IO Int) - -> Int - -> Int - -> Int - -> IO () -mergeMapWith op outer inner n = - drain $ toStream $ StreamK.mergeMapWith op - (fromStream . sourceUnfoldrM inner) - (fromStream $ sourceUnfoldrM outer n) -#endif - {-# INLINE sourceConcatMapId #-} sourceConcatMapId :: (Monad m) => Int -> Int -> Stream m (Stream m Int) @@ -288,9 +241,9 @@ {-# INLINE apDiscardFst #-} apDiscardFst :: MonadAsync m => Int -> Int -> m () -apDiscardFst linearCount start = drain $ toStream $ unCross $ - mkCross (fromStream $ sourceUnfoldrM nestedCount2 start) - *> mkCross (fromStream $ sourceUnfoldrM nestedCount2 start) +apDiscardFst linearCount start = drain $ unCross $ + mkCross (sourceUnfoldrM nestedCount2 start) + *> mkCross (sourceUnfoldrM nestedCount2 start) where @@ -298,9 +251,9 @@ {-# INLINE apDiscardSnd #-} apDiscardSnd :: MonadAsync m => Int -> Int -> m () -apDiscardSnd linearCount start = drain $ toStream $ unCross $ - mkCross (fromStream $ sourceUnfoldrM nestedCount2 start) - <* mkCross (fromStream $ sourceUnfoldrM nestedCount2 start) +apDiscardSnd linearCount start = drain $ unCross $ + mkCross (sourceUnfoldrM nestedCount2 start) + <* mkCross (sourceUnfoldrM nestedCount2 start) where @@ -308,9 +261,9 @@ {-# INLINE apLiftA2 #-} apLiftA2 :: MonadAsync m => Int -> Int -> m () -apLiftA2 linearCount start = drain $ toStream $ unCross $ - liftA2 (+) (mkCross (fromStream $ sourceUnfoldrM nestedCount2 start)) - (mkCross (fromStream $ sourceUnfoldrM nestedCount2 start)) +apLiftA2 linearCount start = drain $ unCross $ + liftA2 (+) (mkCross (sourceUnfoldrM nestedCount2 start)) + (mkCross (sourceUnfoldrM nestedCount2 start)) where @@ -318,19 +271,29 @@ {-# INLINE toNullAp #-} toNullAp :: MonadAsync m => Int -> Int -> m () -toNullAp linearCount start = drain $ toStream $ unCross $ - (+) <$> mkCross (fromStream $ sourceUnfoldrM nestedCount2 start) - <*> mkCross (fromStream $ sourceUnfoldrM nestedCount2 start) +toNullAp linearCount start = drain $ unCross $ + (+) <$> mkCross (sourceUnfoldrM nestedCount2 start) + <*> mkCross (sourceUnfoldrM nestedCount2 start) where nestedCount2 = round (fromIntegral linearCount**(1/2::Double)) +{-# INLINE toNullApPure #-} +toNullApPure :: MonadAsync m => Int -> Int -> m () +toNullApPure linearCount start = drain $ unCross $ + (+) <$> mkCross (sourceUnfoldr nestedCount2 start) + <*> mkCross (sourceUnfoldr nestedCount2 start) + + where + + nestedCount2 = round (fromIntegral linearCount**(1/2::Double)) + {-# INLINE monadThen #-} monadThen :: MonadAsync m => Int -> Int -> m () -monadThen linearCount start = drain $ toStream $ unCross $ do - mkCross (fromStream $ sourceUnfoldrM nestedCount2 start) >> - mkCross (fromStream $ sourceUnfoldrM nestedCount2 start) +monadThen linearCount start = drain $ unCross $ do + mkCross (sourceUnfoldrM nestedCount2 start) >> + mkCross (sourceUnfoldrM nestedCount2 start) where @@ -338,67 +301,112 @@ {-# INLINE toNullM #-} toNullM :: MonadAsync m => Int -> Int -> m () -toNullM linearCount start = drain $ toStream $ unCross $ do - x <- mkCross (fromStream $ sourceUnfoldrM nestedCount2 start) - y <- mkCross (fromStream $ sourceUnfoldrM nestedCount2 start) +toNullM linearCount start = drain $ unCross $ do + x <- mkCross (sourceUnfoldrM nestedCount2 start) + y <- mkCross (sourceUnfoldrM nestedCount2 start) return $ x + y where nestedCount2 = round (fromIntegral linearCount**(1/2::Double)) +{-# INLINE toNullMPure #-} +toNullMPure :: MonadAsync m => Int -> Int -> m () +toNullMPure linearCount start = drain $ unCross $ do + x <- mkCross (sourceUnfoldr nestedCount2 start) + y <- mkCross (sourceUnfoldr nestedCount2 start) + return $ x + y + + where + + nestedCount2 = round (fromIntegral linearCount**(1/2::Double)) + {-# INLINE toNullM3 #-} toNullM3 :: MonadAsync m => Int -> Int -> m () -toNullM3 linearCount start = drain $ toStream $ unCross $ do - x <- mkCross (fromStream $ sourceUnfoldrM nestedCount3 start) - y <- mkCross (fromStream $ sourceUnfoldrM nestedCount3 start) - z <- mkCross (fromStream $ sourceUnfoldrM nestedCount3 start) +toNullM3 linearCount start = drain $ unCross $ do + x <- mkCross (sourceUnfoldrM nestedCount3 start) + y <- mkCross (sourceUnfoldrM nestedCount3 start) + z <- mkCross (sourceUnfoldrM nestedCount3 start) return $ x + y + z where nestedCount3 = round (fromIntegral linearCount**(1/3::Double)) +{-# INLINE toNullM3Pure #-} +toNullM3Pure :: MonadAsync m => Int -> Int -> m () +toNullM3Pure linearCount start = drain $ unCross $ do + x <- mkCross (sourceUnfoldr nestedCount3 start) + y <- mkCross (sourceUnfoldr nestedCount3 start) + z <- mkCross (sourceUnfoldr nestedCount3 start) + return $ x + y + z + where + nestedCount3 = round (fromIntegral linearCount**(1/3::Double)) + {-# INLINE filterAllOutM #-} filterAllOutM :: MonadAsync m => Int -> Int -> m () -filterAllOutM linearCount start = drain $ toStream $ unCross $ do - x <- mkCross (fromStream $ sourceUnfoldrM nestedCount2 start) - y <- mkCross (fromStream $ sourceUnfoldrM nestedCount2 start) +filterAllOutM linearCount start = drain $ unCross $ do + x <- mkCross (sourceUnfoldrM nestedCount2 start) + y <- mkCross (sourceUnfoldrM nestedCount2 start) let s = x + y if s < 0 then return s - else mkCross StreamK.nil + else mkCross Stream.nil where nestedCount2 = round (fromIntegral linearCount**(1/2::Double)) {-# INLINE filterAllInM #-} filterAllInM :: MonadAsync m => Int -> Int -> m () -filterAllInM linearCount start = drain $ toStream $ unCross $ do - x <- mkCross (fromStream $ sourceUnfoldrM nestedCount2 start) - y <- mkCross (fromStream $ sourceUnfoldrM nestedCount2 start) +filterAllInM linearCount start = drain $ unCross $ do + x <- mkCross (sourceUnfoldrM nestedCount2 start) + y <- mkCross (sourceUnfoldrM nestedCount2 start) let s = x + y if s > 0 then return s - else mkCross StreamK.nil + else mkCross Stream.nil where nestedCount2 = round (fromIntegral linearCount**(1/2::Double)) +{-# INLINE filterAllOutMPure #-} +filterAllOutMPure :: MonadAsync m => Int -> Int -> m () +filterAllOutMPure linearCount start = drain $ unCross $ do + x <- mkCross (sourceUnfoldr nestedCount2 start) + y <- mkCross (sourceUnfoldr nestedCount2 start) + let s = x + y + if s < 0 + then return s + else mkCross Stream.nil + where + nestedCount2 = round (fromIntegral linearCount**(1/2::Double)) + +{-# INLINE filterAllInMPure #-} +filterAllInMPure :: MonadAsync m => Int -> Int -> m () +filterAllInMPure linearCount start = drain $ unCross $ do + x <- mkCross (sourceUnfoldr nestedCount2 start) + y <- mkCross (sourceUnfoldr nestedCount2 start) + let s = x + y + if s > 0 + then return s + else mkCross Stream.nil + where + nestedCount2 = round (fromIntegral linearCount**(1/2::Double)) + {-# INLINE filterSome #-} filterSome :: MonadAsync m => Int -> Int -> m () -filterSome linearCount start = drain $ toStream $ unCross $ do - x <- mkCross (fromStream $ sourceUnfoldrM nestedCount2 start) - y <- mkCross (fromStream $ sourceUnfoldrM nestedCount2 start) +filterSome linearCount start = drain $ unCross $ do + x <- mkCross (sourceUnfoldrM nestedCount2 start) + y <- mkCross (sourceUnfoldrM nestedCount2 start) let s = x + y if s > 1100000 then return s - else mkCross StreamK.nil + else mkCross Stream.nil where nestedCount2 = round (fromIntegral linearCount**(1/2::Double)) {-# INLINE breakAfterSome #-} breakAfterSome :: Int -> Int -> IO () breakAfterSome linearCount start = do - (_ :: Either ErrorCall ()) <- try $ drain $ toStream $ unCross $ do - x <- mkCross (fromStream $ sourceUnfoldrM nestedCount2 start) - y <- mkCross (fromStream $ sourceUnfoldrM nestedCount2 start) + (_ :: Either ErrorCall ()) <- try $ drain $ unCross $ do + x <- mkCross (sourceUnfoldrM nestedCount2 start) + y <- mkCross (sourceUnfoldrM nestedCount2 start) let s = x + y if s > 1100000 then error "break" @@ -409,9 +417,9 @@ {-# INLINE toListM #-} toListM :: MonadAsync m => Int -> Int -> m [Int] -toListM linearCount start = toList $ toStream $ unCross $ do - x <- mkCross (fromStream $ sourceUnfoldrM nestedCount2 start) - y <- mkCross (fromStream $ sourceUnfoldrM nestedCount2 start) +toListM linearCount start = toList $ unCross $ do + x <- mkCross (sourceUnfoldrM nestedCount2 start) + y <- mkCross (sourceUnfoldrM nestedCount2 start) return $ x + y where nestedCount2 = round (fromIntegral linearCount**(1/2::Double)) @@ -421,9 +429,9 @@ {-# INLINE toListSome #-} toListSome :: MonadAsync m => Int -> Int -> m [Int] toListSome linearCount start = - toList $ Stream.take 10000 $ toStream $ unCross $ do - x <- mkCross (fromStream $ sourceUnfoldrM nestedCount2 start) - y <- mkCross (fromStream $ sourceUnfoldrM nestedCount2 start) + toList $ Stream.take 10000 $ unCross $ do + x <- mkCross (sourceUnfoldrM nestedCount2 start) + y <- mkCross (sourceUnfoldrM nestedCount2 start) return $ x + y where nestedCount2 = round (fromIntegral linearCount**(1/2::Double)) @@ -466,7 +474,7 @@ foldl' f z = Stream.fold (Fold.foldl' f z) scanl' :: Monad m => (b -> a -> b) -> b -> Stream m a -> Stream m b -scanl' f z = Stream.scan (Fold.foldl' f z) +scanl' f z = Stream.scanl (Scanl.mkScanl f z) #endif {-# INLINE transformMapM #-} @@ -475,8 +483,22 @@ => Int -> Stream m Int -> m () +#ifndef USE_PRELUDE +transformMapM n = composeN n $ Stream.pipe (Pipe.mapM return) +#else transformMapM n = composeN n $ Stream.transform (Pipe.mapM return) +#endif +#ifndef USE_PRELUDE +{-# INLINE scanMapM #-} +scanMapM :: + (Monad m) + => Int + -> Stream m Int + -> m () +scanMapM n = composeN n $ Stream.scanr (Scanr.functionM return) +#endif + {-# INLINE transformComposeMapM #-} transformComposeMapM :: (Monad m) @@ -485,10 +507,28 @@ -> m () transformComposeMapM n = composeN n $ +#ifndef USE_PRELUDE + Stream.pipe +#else Stream.transform +#endif (Pipe.mapM (\x -> return (x + 1)) `Pipe.compose` Pipe.mapM (\x -> return (x + 2))) +#ifndef USE_PRELUDE +{-# INLINE scanComposeMapM #-} +scanComposeMapM :: + (Monad m) + => Int + -> Stream m Int + -> m () +scanComposeMapM n = + composeN n $ + Stream.scanr + (Scanr.functionM (\x -> return (x + 1)) `Scanr.compose` + Scanr.functionM (\x -> return (x + 2))) +#endif + {-# INLINE transformTeeMapM #-} transformTeeMapM :: (Monad m) @@ -497,10 +537,29 @@ -> m () transformTeeMapM n = composeN n $ +#ifndef USE_PRELUDE + Stream.pipe +#else Stream.transform - (Pipe.mapM (\x -> return (x + 1)) `Pipe.tee` +#endif + (Pipe.mapM (\x -> return (x + 1)) `Pipe.teeMerge` Pipe.mapM (\x -> return (x + 2))) +#ifndef USE_PRELUDE +{-# INLINE scanTeeMapM #-} +scanTeeMapM :: + (Monad m) + => Int + -> Stream m Int + -> m () +scanTeeMapM n = + composeN n $ + Stream.scanr + (Scanr.teeWith (+) (Scanr.functionM (\x -> return (x + 1))) + (Scanr.functionM (\x -> return (x + 2)))) +#endif + +{- {-# INLINE transformZipMapM #-} transformZipMapM :: (Monad m) @@ -509,8 +568,9 @@ -> m () transformZipMapM n = composeN n $ - Stream.transform + Stream.pipe (Pipe.zipWith (+) (Pipe.mapM (\x -> return (x + 1))) (Pipe.mapM (\x -> return (x + 2)))) +-} diff --git a/benchmark/Streamly/Benchmark/Data/Stream/ConcurrentCommon.hs b/benchmark/Streamly/Benchmark/Data/Stream/ConcurrentCommon.hs --- a/benchmark/Streamly/Benchmark/Data/Stream/ConcurrentCommon.hs +++ b/benchmark/Streamly/Benchmark/Data/Stream/ConcurrentCommon.hs @@ -14,14 +14,14 @@ import Stream.Common (composeN, benchIO, benchIOSink, benchIOSrc, sourceUnfoldrM) import Streamly.Data.Stream (Stream) -import Streamly.Internal.Data.Stream.Concurrent (MonadAsync, Config) +import Streamly.Internal.Data.Stream.Prelude (MonadAsync, Config) import qualified Data.List as List import qualified Streamly.Data.Fold as Fold import qualified Streamly.Data.Stream as Stream -import qualified Streamly.Internal.Data.Stream.Concurrent as Async +import qualified Streamly.Internal.Data.Stream.Prelude as Async -import Gauge +import Test.Tasty.Bench import Prelude hiding (mapM) import Streamly.Benchmark.Common @@ -56,7 +56,7 @@ o_n_heap_buffering value f = [ bgroup "buffered" [ benchIOSink value "mkAsync" - (Stream.fold Fold.drain . Async.parEval f) + (Stream.fold Fold.drain . Async.parBuffered f) ] ] @@ -147,10 +147,10 @@ $ Async.parConcat f $ fmap (sourceUnfoldrM inner) (sourceUnfoldrM outer n) -o_1_space_concatMap :: Int -> (Config -> Config) -> [Benchmark] -o_1_space_concatMap value f = +o_1_space_concatMap :: String -> Int -> (Config -> Config) -> [Benchmark] +o_1_space_concatMap label value f = value2 `seq` - [ bgroup "concat" + [ bgroup ("concat" ++ label) [ benchIO "parConcatMap (n of 1)" (concatMapStreamsWith f value 1) , benchIO "parConcatMap (sqrt x of sqrt x)" @@ -174,7 +174,7 @@ toNullAp :: (Config -> Config) -> Int -> Int -> IO () toNullAp f linearCount start = Stream.fold Fold.drain - $ Async.parApply f + $ Async.parCrossApply f (fmap (+) (sourceUnfoldrM nestedCount2 start)) (sourceUnfoldrM nestedCount2 start) @@ -198,7 +198,9 @@ [ bgroup (o_1_space_prefix moduleName) $ concat [ o_1_space_mapping value modifier , o_1_space_concatFoldable value modifier - , o_1_space_concatMap value modifier + , o_1_space_concatMap "" value modifier + , o_1_space_concatMap "-maxThreads-1" value (modifier . Async.maxThreads 1) + , o_1_space_concatMap "-rate-Nothing" value (modifier . Async.rate Nothing) , o_1_space_joining value modifier ] ++ if wide then [] else o_1_space_outerProduct value modifier , bgroup (o_n_heap_prefix moduleName) $ concat diff --git a/benchmark/Streamly/Benchmark/Data/Stream/ConcurrentEager.hs b/benchmark/Streamly/Benchmark/Data/Stream/ConcurrentEager.hs --- a/benchmark/Streamly/Benchmark/Data/Stream/ConcurrentEager.hs +++ b/benchmark/Streamly/Benchmark/Data/Stream/ConcurrentEager.hs @@ -9,7 +9,7 @@ import Stream.ConcurrentCommon (allBenchmarks) import Streamly.Benchmark.Common (runWithCLIOpts, defaultStreamSize) -import qualified Streamly.Internal.Data.Stream.Concurrent as Async +import qualified Streamly.Internal.Data.Stream.Prelude as Async moduleName :: String moduleName = "Data.Stream.ConcurrentEager" diff --git a/benchmark/Streamly/Benchmark/Data/Stream/ConcurrentInterleaved.hs b/benchmark/Streamly/Benchmark/Data/Stream/ConcurrentInterleaved.hs --- a/benchmark/Streamly/Benchmark/Data/Stream/ConcurrentInterleaved.hs +++ b/benchmark/Streamly/Benchmark/Data/Stream/ConcurrentInterleaved.hs @@ -9,7 +9,7 @@ import Stream.ConcurrentCommon (allBenchmarks) import Streamly.Benchmark.Common (runWithCLIOpts, defaultStreamSize) -import qualified Streamly.Internal.Data.Stream.Concurrent as Async +import qualified Streamly.Internal.Data.Stream.Prelude as Async moduleName :: String moduleName = "Data.Stream.ConcurrentInterleaved" diff --git a/benchmark/Streamly/Benchmark/Data/Stream/ConcurrentOrdered.hs b/benchmark/Streamly/Benchmark/Data/Stream/ConcurrentOrdered.hs --- a/benchmark/Streamly/Benchmark/Data/Stream/ConcurrentOrdered.hs +++ b/benchmark/Streamly/Benchmark/Data/Stream/ConcurrentOrdered.hs @@ -9,7 +9,7 @@ import Stream.ConcurrentCommon (allBenchmarks) import Streamly.Benchmark.Common (runWithCLIOpts, defaultStreamSize) -import qualified Streamly.Internal.Data.Stream.Concurrent as Async +import qualified Streamly.Internal.Data.Stream.Prelude as Async moduleName :: String moduleName = "Data.Stream.ConcurrentOrdered" diff --git a/benchmark/Streamly/Benchmark/Data/Stream/ConcurrentThreadHeavy.hs b/benchmark/Streamly/Benchmark/Data/Stream/ConcurrentThreadHeavy.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Data/Stream/ConcurrentThreadHeavy.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} +-- | +-- Module : Main +-- Copyright : (c) 2018 Composewell Technologies +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com + +import Control.Concurrent +import Control.Monad (when, replicateM) +import Streamly.Data.Stream.Prelude (Config) + +import qualified Streamly.Data.Fold as Fold +import qualified Streamly.Data.Stream.Prelude as Stream + +import Test.Tasty (localOption) +import Test.Tasty.Bench + +------------------------------------------------------------------------------- +-- Append +------------------------------------------------------------------------------- + +-- | Run @tcount@ number of actions concurrently using the given concurrency +-- style. Each thread produces a single output after a delay of @d@ +-- microseconds. +-- +{-# INLINE append #-} +append :: Int -> Int -> Int -> (Config -> Config) -> IO () +append buflen tcount d modifier = + let work i = when (d /= 0) (threadDelay d) >> return i + cfg = + modifier + . Stream.maxBuffer buflen + . Stream.maxThreads (-1) + in Stream.fold Fold.drain + $ Stream.parMapM cfg work + $ Stream.fromList [1..tcount] + +-- | Run @threads@ concurrently, each producing streams of @elems@ elements +-- with a delay of @d@ microseconds between successive elements, and merge +-- their outputs in a single output stream. The individual streams are produced +-- serially but merged using the provided concurrency style. +-- +{-# INLINE concated #-} +concated + :: Int + -> Int + -> Int + -> Int + -> (Config -> Config) + -> IO () +concated buflen threads d elems modifier = + let work i = + Stream.replicateM i (when (d /= 0) (threadDelay d) >> return i) + cfg = + modifier + . Stream.maxBuffer buflen + . Stream.maxThreads (-1) + in Stream.fold Fold.drain + $ Stream.parConcatMap cfg work + $ Stream.replicate threads elems + +appendGroup :: Int -> Int -> Int -> [Benchmark] +appendGroup buflen threads usec = + [ -- bench "serial" $ nfIO $ append buflen threads delay fromSerial + bench "async" + $ nfIO $ append buflen threads usec id + , bench "ordered" + $ nfIO $ append buflen threads usec (Stream.ordered True) + , bench "interleaved" + $ nfIO $ append buflen threads usec (Stream.interleaved True) + , bench "parallel" + $ nfIO $ append buflen threads usec (Stream.eager True) + ] + +concatGroup :: Int -> Int -> Int -> Int -> [Benchmark] +concatGroup buflen threads usec n = + [ -- bench "serial" $ nfIO $ concated buflen threads usec n serial + bench "async" + $ nfIO $ concated buflen threads usec n id + , bench "ordered" + $ nfIO $ concated buflen threads usec n (Stream.ordered True) + , bench "interleaved" + $ nfIO $ concated buflen threads usec n (Stream.interleaved True) + , bench "parallel" + $ nfIO $ concated buflen threads usec n (Stream.eager True) + ] + +main :: IO () +main = + defaultMain $ map (localOption (RelStDev 100000)) + [ -- bgroup "append/buf-1-threads-10k-0sec" (appendGroup 1 10000 0) + -- , bgroup "append/buf-100-threads-100k-0sec" (appendGroup 100 100000 0) + bgroup "streamly/threads10k-delay5s-singleton(buf10k)" (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 "streamly/threads100-delay0s-stream500k(buf100)" (concatGroup 100 100 0 500000) + + , bench "forkIO/threads10k-delay5s-singleton" $ + let delay = threadDelay 5000000 + count = 10000 :: Int + list = [1..count] + work i = delay >> return i + in nfIO $ do + ref <- newEmptyMVar + mapM_ (\i -> forkIO (work i >>= \j -> putMVar ref j)) list + replicateM 10000 (takeMVar ref) + ] diff --git a/benchmark/Streamly/Benchmark/Data/Stream/Eliminate.hs b/benchmark/Streamly/Benchmark/Data/Stream/Eliminate.hs --- a/benchmark/Streamly/Benchmark/Data/Stream/Eliminate.hs +++ b/benchmark/Streamly/Benchmark/Data/Stream/Eliminate.hs @@ -12,7 +12,6 @@ {-# OPTIONS_GHC -Wno-orphans #-} #ifdef USE_PRELUDE -{-# OPTIONS_GHC -Wno-deprecations #-} #endif #ifdef __HADDOCK_VERSION__ @@ -26,6 +25,7 @@ module Stream.Eliminate (benchmarks) where +import Control.Monad (when) import Control.DeepSeq (NFData(..)) import Data.Functor.Identity (Identity, runIdentity) import System.Random (randomRIO) @@ -37,27 +37,20 @@ #ifdef INSPECTION import GHC.Types (SPEC(..)) import Test.Inspection -import qualified Streamly.Internal.Data.Stream.StreamD as D +import qualified Streamly.Internal.Data.Stream as D #endif #ifdef USE_PRELUDE import Streamly.Prelude (fromSerial) import Streamly.Benchmark.Prelude import qualified Streamly.Internal.Data.Stream.IsStream as S -import qualified Streamly.Internal.Data.Stream.IsStream as StreamK #else import Stream.Common -import Streamly.Internal.Data.Stream.StreamD (Stream) -import qualified Streamly.Internal.Data.Stream.StreamD as S -#ifdef USE_STREAMK -import Streamly.Internal.Data.Stream.StreamK (StreamK) -import qualified Streamly.Data.StreamK as StreamK -#else -import qualified Streamly.Internal.Data.Stream.StreamD as StreamK -#endif +import Streamly.Internal.Data.Stream (Stream) +import qualified Streamly.Internal.Data.Stream as S #endif -import Gauge +import Test.Tasty.Bench import Streamly.Benchmark.Common import Prelude hiding (length, sum, or, and, any, all, notElem, elem, (!!), lookup, repeat, minimum, maximum, product, last, mapM_, init) @@ -132,12 +125,14 @@ foldableAny value n = Prelude.any (> (value + 1)) (sourceUnfoldr value n :: Stream Identity Int) +{- HLINT ignore "Use all"-} {-# INLINE foldableAnd #-} foldableAnd :: Int -> Int -> Bool foldableAnd value n = Prelude.and $ fmap (<= (value + 1)) (sourceUnfoldr value n :: Stream Identity Int) +{- HLINT ignore "Use any"-} {-# INLINE foldableOr #-} foldableOr :: Int -> Int -> Bool foldableOr value n = @@ -275,27 +270,35 @@ ------------------------------------------------------------------------------- {-# INLINE uncons #-} -#ifdef USE_STREAMK -uncons :: Monad m => StreamK m Int -> m () -#else uncons :: Monad m => Stream m Int -> m () -#endif uncons s = do - r <- StreamK.uncons s + r <- S.uncons s case r of Nothing -> return () Just (_, t) -> uncons t +#ifndef USE_PRELUDE +{-# INLINE toNull #-} +toNull :: Monad m => Stream m Int -> m () +toNull = S.drain +#endif + #ifdef USE_PRELUDE {-# INLINE init #-} init :: Monad m => Stream m a -> m () init s = S.init s >>= Prelude.mapM_ S.drain +#endif {-# INLINE mapM_ #-} mapM_ :: Monad m => Stream m Int -> m () mapM_ = S.mapM_ (\_ -> return ()) -#endif +{-# INLINE foldBreak #-} +foldBreak :: Monad m => Stream m Int -> m () +foldBreak s = do + (r, s1) <- S.foldBreak (Fold.take 1 Fold.length) s + when (r /= 0) $ foldBreak s1 + {-# INLINE foldrMElem #-} foldrMElem :: Monad m => Int -> Stream m Int -> m Bool foldrMElem e = @@ -306,25 +309,23 @@ else xs) (return False) -#ifdef USE_STREAMK -{-# INLINE foldrToStream #-} -foldrToStream :: Monad m => Stream m Int -> m (StreamK Identity Int) -foldrToStream = S.foldr StreamK.cons StreamK.nil -#else -- {-# INLINE foldrToStream #-} -- foldrToStream :: Monad m => Stream m Int -> m (Stream Identity Int) -- foldrToStream = S.foldr S.cons S.nil -#endif {-# INLINE foldrMBuild #-} foldrMBuild :: Monad m => Stream m Int -> m [Int] foldrMBuild = S.foldrM (\x xs -> (x :) <$> xs) (return []) -#ifdef USE_PRELUDE {-# INLINE foldl'Reduce #-} foldl'Reduce :: Monad m => Stream m Int -> m Int foldl'Reduce = S.foldl' (+) 0 +{-# INLINE last #-} +last :: Monad m => Stream m Int -> m (Maybe Int) +last = S.last + +#ifdef USE_PRELUDE {-# INLINE foldl1'Reduce #-} foldl1'Reduce :: Monad m => Stream m Int -> m (Maybe Int) foldl1'Reduce = S.foldl1' (+) @@ -333,10 +334,6 @@ foldlM'Reduce :: Monad m => Stream m Int -> m Int foldlM'Reduce = S.foldlM' (\xs a -> return $ a + xs) (return 0) -{-# INLINE last #-} -last :: Monad m => Stream m Int -> m (Maybe Int) -last = S.last - {-# INLINE _head #-} _head :: Monad m => Stream m Int -> m (Maybe Int) _head = S.head @@ -458,19 +455,10 @@ ] , bgroup "Identity" [ benchIdentitySink value "foldrMElem" (foldrMElem value) -#ifdef USE_STREAMK - , benchIdentitySink value "foldrToStreamLength" - (S.fold Fold.length . toStream . runIdentity . foldrToStream) {- , benchIdentitySink 16 "foldrToStreamLength (16)" - (S.fold Fold.length . toStream . runIdentity . foldrToStream) - -} -#else - {- - , benchIdentitySink 16 "foldrToStreamLength (16)" (S.fold Fold.length . runIdentity . foldrToStream) -} -#endif {- , benchPureSink 16 "foldrMToListLength (16)" (Prelude.length . runIdentity . foldrMBuild) @@ -481,10 +469,15 @@ ] -- deconstruction - , benchIOSink value "uncons" (uncons . fromStream) + , benchIOSink value "uncons" uncons + , benchIOSink value "mapM_" mapM_ + , benchIOSink value "last" last #ifndef USE_PRELUDE , benchHoistSink value "length . generalizeInner" (S.fold Fold.length . S.generalizeInner) + , benchIOSink value "toNull" toNull + , benchIOSink value "foldBreak" foldBreak + , benchIOSink value "foldl" foldl'Reduce #endif #ifdef USE_PRELUDE , benchIOSink value "init" init @@ -494,11 +487,9 @@ , benchIOSink value "drainN" $ drainN value , benchIOSink value "drainWhile" drainWhile , benchPureSink value "drain (pure)" id - , benchIOSink value "mapM_" mapM_ -- this is too fast, causes all benchmarks reported in ns -- , benchIOSink value "head" head - , benchIOSink value "last" last , benchIOSink value "length" length , benchIOSink value "sum" sum , benchIOSink value "product" product @@ -587,6 +578,10 @@ -- expression needs to be fully built before it can be reduced. , benchIdentitySink value "foldrM/reduce/Identity (sum)" foldrMReduce , benchIOSink value "foldrM/reduce/IO (sum)" foldrMReduce + + -- This is horribly slow, never finishes + -- let foldlS = composeN n $ S.foldlS (flip S.cons) S.nil + -- in benchFold "foldlS" (foldlS 1) sourceUnfoldrM ] ] diff --git a/benchmark/Streamly/Benchmark/Data/Stream/Exceptions.hs b/benchmark/Streamly/Benchmark/Data/Stream/Exceptions.hs --- a/benchmark/Streamly/Benchmark/Data/Stream/Exceptions.hs +++ b/benchmark/Streamly/Benchmark/Data/Stream/Exceptions.hs @@ -11,7 +11,6 @@ {-# LANGUAGE ScopedTypeVariables #-} #ifdef USE_PRELUDE -{-# OPTIONS_GHC -Wno-deprecations #-} #endif #ifdef __HADDOCK_VERSION__ @@ -36,24 +35,25 @@ import qualified Streamly.FileSystem.Handle as FH import qualified Streamly.Internal.FileSystem.Handle as IFH import qualified Streamly.Internal.Data.Unfold as IUF -import qualified Streamly.Internal.Data.Unfold.Exception as IUF +import qualified Streamly.Internal.Data.Unfold.Prelude as IUF #ifdef USE_PRELUDE import qualified Streamly.Internal.Data.Stream.IsStream as Stream #else -import qualified Streamly.Internal.Data.Stream.StreamD as Stream -import qualified Streamly.Internal.Data.Stream.Exception.Lifted as Stream +import qualified Streamly.Internal.Data.Stream as Stream +import qualified Streamly.Internal.Data.Stream.Prelude as Stream #endif -import Gauge hiding (env) +import Test.Tasty.Bench hiding (env) import Prelude hiding (last, length) import Streamly.Benchmark.Common import Streamly.Benchmark.Common.Handle #ifdef INSPECTION +import Control.Monad.Catch (MonadCatch) import Test.Inspection -import qualified Streamly.Internal.Data.Stream.StreamD as D +import qualified Streamly.Internal.Data.Stream as D #endif #ifdef USE_PRELUDE @@ -177,7 +177,12 @@ -- | Send the file contents to /dev/null with exception handling readWriteHandleExceptionStream :: Handle -> Handle -> IO () readWriteHandleExceptionStream inh devNull = - let handler (_e :: SomeException) = Stream.fromEffect (hClose inh >> return 10) + let handler (_e :: SomeException) = +#ifndef USE_PRELUDE + return $ Stream.fromEffect (hClose inh >> return 10) +#else + Stream.fromEffect (hClose inh >> return 10) +#endif readEx = Stream.handle handler (Stream.unfold FH.reader inh) in Stream.fold (FH.write devNull) readEx @@ -285,8 +290,12 @@ in IUF.fold (IFH.writeChunks devNull) readEx inh #ifdef INSPECTION +#if __GLASGOW_HASKELL__ >= 906 +inspect $ hasNoTypeClassesExcept 'readChunksOnException [''MonadCatch] +#else inspect $ hasNoTypeClasses 'readChunksOnException #endif +#endif -- | Send the file contents to /dev/null with exception handling readChunksBracket_ :: Handle -> Handle -> IO () @@ -295,7 +304,11 @@ in IUF.fold (IFH.writeChunks devNull) readEx inh #ifdef INSPECTION +#if __GLASGOW_HASKELL__ >= 906 +inspect $ hasNoTypeClassesExcept 'readChunksBracket_ [''MonadCatch] +#else inspect $ hasNoTypeClasses 'readChunksBracket_ +#endif #endif readChunksBracket :: Handle -> Handle -> IO () diff --git a/benchmark/Streamly/Benchmark/Data/Stream/Expand.hs b/benchmark/Streamly/Benchmark/Data/Stream/Expand.hs --- a/benchmark/Streamly/Benchmark/Data/Stream/Expand.hs +++ b/benchmark/Streamly/Benchmark/Data/Stream/Expand.hs @@ -8,10 +8,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TupleSections #-} #ifdef USE_PRELUDE -{-# OPTIONS_GHC -Wno-deprecations #-} #endif #ifdef __HADDOCK_VERSION__ @@ -29,7 +27,7 @@ import GHC.Types (SPEC(..)) import Test.Inspection -import qualified Streamly.Internal.Data.Stream.StreamD as D +import qualified Streamly.Internal.Data.Stream as D #endif import qualified Stream.Common as Common @@ -37,72 +35,25 @@ #ifdef USE_PRELUDE import qualified Streamly.Internal.Data.Stream.IsStream as S -import qualified Streamly.Internal.Data.Stream.IsStream as StreamK import Streamly.Benchmark.Prelude ( sourceFoldMapM, sourceFoldMapWith, sourceFoldMapWithM , sourceFoldMapWithStream, concatFoldableWith, concatForFoldableWith) #else -import qualified Streamly.Internal.Data.Stream.StreamD as S -#ifdef USE_STREAMK -import Streamly.Internal.Data.Stream.StreamD (Stream) -import Streamly.Internal.Data.Stream.StreamK (StreamK, CrossStreamK) -import qualified Control.Applicative as AP +import Streamly.Data.Stream (Stream) +import Streamly.Data.Unfold (Unfold) +import qualified Streamly.Internal.Data.Stream as S +import qualified Streamly.Internal.Data.Unfold as Unfold import qualified Streamly.Internal.Data.Fold as Fold -import qualified Streamly.Internal.Data.Stream.StreamK as StreamK -#else -import qualified Streamly.Internal.Data.Stream.StreamD as StreamK -#endif +import qualified Streamly.Internal.Data.Stream as Stream +import qualified Streamly.Internal.Data.StreamK as StreamK #endif -import Gauge +import Test.Tasty.Bench import Stream.Common import Streamly.Benchmark.Common import Prelude hiding (concatMap) ------------------------------------------------------------------------------- --- Iteration/looping utilities -------------------------------------------------------------------------------- - -#ifdef USE_STREAMK -{-# INLINE iterateN #-} -iterateN :: (Int -> a -> a) -> a -> Int -> a -iterateN g initial count = f count initial - - where - - f (0 :: Int) x = x - f i x = f (i - 1) (g i x) - --- Iterate a transformation over a singleton stream -{-# INLINE iterateSingleton #-} -iterateSingleton :: Applicative m => - (Int -> CrossStreamK m Int -> CrossStreamK m Int) - -> Int - -> Int - -> Stream m Int -iterateSingleton g count n = - toStream - $ StreamK.unCross - $ iterateN g (StreamK.mkCross (StreamK.fromPure n)) count -#endif - -{- --- XXX need to check why this is slower than the explicit recursion above, even --- if the above code is written in a foldr like head recursive way. We also --- need to try this with foldlM' once #150 is fixed. --- However, it is perhaps best to keep the iteration benchmarks independent of --- foldrM and any related fusion issues. -{-# INLINE _iterateSingleton #-} -_iterateSingleton :: - Monad m - => (Int -> Stream m Int -> Stream m Int) - -> Int - -> Int - -> Stream m Int -_iterateSingleton g value n = S.foldrM g (return n) $ sourceIntFromTo value n --} - -------------------------------------------------------------------------------- -- Multi-Stream ------------------------------------------------------------------------------- @@ -113,22 +64,22 @@ {-# INLINE serial2 #-} serial2 :: Int -> Int -> IO () serial2 count n = - drain $ toStream $ + drain $ Common.append - (fromStream $ sourceUnfoldrM count n) - (fromStream $ sourceUnfoldrM count (n + 1)) + (sourceUnfoldrM count n) + (sourceUnfoldrM count (n + 1)) {-# INLINE serial4 #-} serial4 :: Int -> Int -> IO () serial4 count n = - drain $ toStream $ + drain $ Common.append (Common.append - (fromStream $ sourceUnfoldrM count n) - (fromStream $ sourceUnfoldrM count (n + 1))) + (sourceUnfoldrM count n) + (sourceUnfoldrM count (n + 1))) (Common.append - (fromStream $ sourceUnfoldrM count (n + 2)) - (fromStream $ sourceUnfoldrM count (n + 3))) + (sourceUnfoldrM count (n + 2)) + (sourceUnfoldrM count (n + 3))) o_1_space_joining :: Int -> [Benchmark] o_1_space_joining value = @@ -170,11 +121,21 @@ {-# INLINE concatMap #-} concatMap :: Int -> Int -> Int -> IO () concatMap outer inner n = - drain $ toStream $ StreamK.concatMap - (\_ -> fromStream $ sourceUnfoldrM inner n) - (fromStream $ sourceUnfoldrM outer n) + drain $ S.concatMap + (\_ -> sourceUnfoldrM inner n) + (sourceUnfoldrM outer n) -#ifndef USE_STREAMK +{-# INLINE concatMapViaUnfoldEach #-} +concatMapViaUnfoldEach :: Int -> Int -> Int -> IO () +concatMapViaUnfoldEach outer inner n = + drain $ cmap + (\_ -> sourceUnfoldrM inner n) + (sourceUnfoldrM outer n) + + where + + cmap f = Stream.unfoldEach (UF.lmap f UF.fromStream) + {-# INLINE concatMapM #-} concatMapM :: Int -> Int -> Int -> IO () concatMapM outer inner n = @@ -186,213 +147,169 @@ inspect $ hasNoTypeClasses 'concatMap inspect $ 'concatMap `hasNoType` ''SPEC #endif -#endif -- concatMap unfoldr/unfoldr {-# INLINE concatMapPure #-} concatMapPure :: Int -> Int -> Int -> IO () concatMapPure outer inner n = - drain $ toStream $ StreamK.concatMap - (\_ -> fromStream $ sourceUnfoldr inner n) - (fromStream $ sourceUnfoldr outer n) + drain $ S.concatMap + (\_ -> sourceUnfoldr inner n) + (sourceUnfoldr outer n) #ifdef INSPECTION +#if __GLASGOW_HASKELL__ >= 906 +inspect $ hasNoTypeClassesExcept 'concatMapPure [''Applicative] +#else inspect $ hasNoTypeClasses 'concatMapPure -inspect $ 'concatMapPure `hasNoType` ''SPEC #endif - --- concatMap replicate/unfoldrM - -{-# INLINE concatMapRepl #-} -concatMapRepl :: Int -> Int -> Int -> IO () -concatMapRepl outer inner n = - drain $ toStream $ StreamK.concatMap - (fromStream . S.replicate inner) (fromStream $ sourceUnfoldrM outer n) - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'concatMapRepl -inspect $ 'concatMapRepl `hasNoType` ''SPEC +inspect $ 'concatMapPure `hasNoType` ''SPEC #endif --- concatMapWith +{-# INLINE sourceUnfoldrMUnfold #-} +sourceUnfoldrMUnfold :: Monad m => Int -> Int -> Unfold m Int Int +sourceUnfoldrMUnfold size start = UF.unfoldrM step -#ifdef USE_STREAMK -{-# INLINE concatMapWithSerial #-} -concatMapWithSerial :: Int -> Int -> Int -> IO () -concatMapWithSerial = concatStreamsWith Common.append + where -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'concatMapWithSerial -inspect $ 'concatMapWithSerial `hasNoType` ''SPEC -#endif + step i = + return + $ if i < start + size + then Just (i, i + 1) + else Nothing -{- -{-# INLINE concatMapWithAppend #-} -concatMapWithAppend :: Int -> Int -> Int -> IO () -concatMapWithAppend = concatStreamsWith Common.append2 +{-# INLINE unfoldEach #-} +unfoldEach :: Int -> Int -> Int -> IO () +unfoldEach outer inner start = drain $ + -- XXX the replicateM takes much more time compared to unfoldrM, is there + -- a perf issue or this is just because of accessing outer loop variables? + -- S.unfoldEach (UF.lmap ((inner,) . return) UF.replicateM) + S.unfoldEach (sourceUnfoldrMUnfold inner start) + $ sourceUnfoldrM outer start #ifdef INSPECTION -inspect $ hasNoTypeClasses 'concatMapWithAppend -inspect $ 'concatMapWithAppend `hasNoType` ''SPEC -#endif --} - --- mergeMapWith - -{-# INLINE mergeMapWithSerial #-} -mergeMapWithSerial :: Int -> Int -> Int -> IO () -mergeMapWithSerial = mergeMapWith Common.append - -{- -{-# INLINE mergeMapWithAppend #-} -mergeMapWithAppend :: Int -> Int -> Int -> IO () -mergeMapWithAppend = mergeMapWith Common.append2 --} +inspect $ hasNoTypeClasses 'unfoldEach +inspect $ 'unfoldEach `hasNoType` ''D.ConcatMapUState +inspect $ 'unfoldEach `hasNoType` ''SPEC #endif --- unfoldMany - --- unfoldMany replicate/unfoldrM +{-# INLINE unfoldEach2 #-} +unfoldEach2 :: Int -> Int -> Int -> IO () +unfoldEach2 outer inner start = drain $ + S.unfoldEach (UF.carry (sourceUnfoldrMUnfold inner start)) + $ sourceUnfoldrM outer start -{-# INLINE unfoldManyRepl #-} -unfoldManyRepl :: Int -> Int -> Int -> IO () -unfoldManyRepl outer inner n = - drain - $ S.unfoldMany - UF.replicateM - (fmap ((inner,) . return) (sourceUnfoldrM outer n)) +{-# INLINE unfoldEach3 #-} +unfoldEach3 :: Int -> Int -> IO () +unfoldEach3 linearCount start = drain $ do + S.unfoldEach (UF.carry (UF.lmap snd (sourceUnfoldrMUnfold nestedCount3 start))) + $ S.unfoldEach (UF.carry (sourceUnfoldrMUnfold nestedCount3 start)) + $ sourceUnfoldrM nestedCount3 start + where + nestedCount3 = round (fromIntegral linearCount**(1/3::Double)) -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'unfoldManyRepl -inspect $ 'unfoldManyRepl `hasNoType` ''D.ConcatMapUState -inspect $ 'unfoldManyRepl `hasNoType` ''SPEC -#endif +{-# INLINE unfoldCross #-} +unfoldCross :: Int -> Int -> Int -> IO () +unfoldCross outer inner start = drain $ + Stream.unfoldCross + UF.identity + (sourceUnfoldrM outer start) + (sourceUnfoldrM inner start) o_1_space_concat :: Int -> [Benchmark] o_1_space_concat value = sqrtVal `seq` [ bgroup "concat" - [ benchIOSrc1 "concatMapPure (n of 1)" + [ benchIOSrc1 "concatMapPure outer=Max inner=1" (concatMapPure value 1) - , benchIOSrc1 "concatMapPure (sqrt n of sqrt n)" + , benchIOSrc1 "concatMapPure outer=inner=(sqrt Max)" (concatMapPure sqrtVal sqrtVal) - , benchIOSrc1 "concatMapPure (1 of n)" + , benchIOSrc1 "concatMapPure outer=1 inner=Max" (concatMapPure 1 value) - , benchIOSrc1 "concatMap (n of 1)" + , benchIOSrc1 "concatMap outer=max inner=1" (concatMap value 1) - , benchIOSrc1 "concatMap (sqrt n of sqrt n)" + , benchIOSrc1 "concatMap outer=inner=(sqrt Max)" (concatMap sqrtVal sqrtVal) - , benchIOSrc1 "concatMap (1 of n)" + , benchIOSrc1 "concatMap outer=1 inner=Max" (concatMap 1 value) -#ifndef USE_STREAMK -- This is for comparison with foldMapWith - , benchIOSrc "concatMapId (n of 1) (fromFoldable)" + , benchIOSrc "concatMapId outer=max inner=1 (fromFoldable)" (S.concatMap id . sourceConcatMapId value) - , benchIOSrc1 "concatMapM (n of 1)" + , benchIOSrc1 "concatMapM outer=max inner=1" (concatMapM value 1) - , benchIOSrc1 "concatMapM (sqrt n of sqrt n)" + , benchIOSrc1 "concatMapM outer=inner=(sqrt Max)" (concatMapM sqrtVal sqrtVal) - , benchIOSrc1 "concatMapM (1 of n)" + , benchIOSrc1 "concatMapM outer=1 inner=Max" (concatMapM 1 value) -#endif -#ifdef USE_STREAMK - {- - -- This is for comparison with foldMapWith - , benchIOSrc "concatMapWithId (n of 1) (fromFoldable)" - (toStream . S.concatMapWith Common.append id . sourceConcatMapId value) - -} - - , benchIOSrc1 "concatMapWith (n of 1)" - (concatMapWithSerial value 1) - , benchIOSrc1 "concatMapWith (sqrt n of sqrt n)" - (concatMapWithSerial sqrtVal sqrtVal) - , benchIOSrc1 "concatMapWith (1 of n)" - (concatMapWithSerial 1 value) - - {- - -- quadratic with number of outer streams - , benchIOSrc1 "concatMapWithAppend (2 of n/2)" - (concatMapWithAppend 2 (value `div` 2)) - -} -#endif - - -- concatMap vs unfoldMany - , benchIOSrc1 "concatMapRepl (sqrt n of sqrt n)" - (concatMapRepl sqrtVal sqrtVal) - , benchIOSrc1 "unfoldManyRepl (sqrt n of sqrt n)" - (unfoldManyRepl sqrtVal sqrtVal) - ] - ] - - where - - sqrtVal = round $ sqrt (fromIntegral value :: Double) + , benchIOSrc1 "concatMapViaUnfoldEach outer=max inner=1" + (concatMapViaUnfoldEach value 1) + , benchIOSrc1 "concatMapViaUnfoldEach outer=inner=(sqrt Max)" + (concatMapViaUnfoldEach sqrtVal sqrtVal) + , benchIOSrc1 "concatMapViaUnfoldEach outer=1 inner=Max" + (concatMapViaUnfoldEach 1 value) -#ifdef USE_STREAMK -o_n_space_merge :: Int -> [Benchmark] -o_n_space_merge value = sqrtVal `seq` - [ bgroup "concat" - [ - -------------------mergeMapWith----------------- + , benchIOSrc1 "unfoldCross outer=max inner=1" + (unfoldCross value 1) + , benchIOSrc1 "unfoldCross outer=inner=(sqrt Max)" + (unfoldCross sqrtVal sqrtVal) + , benchIOSrc1 "unfoldCross outer=1 inner=Max" + (unfoldCross 1 value) - -- Use large number of streams to check scalability + -- concatMap vs unfoldEach + , benchIOSrc1 "unfoldEach outer=Max inner=1" + (unfoldEach value 1) + , benchIOSrc1 "unfoldEach outer=inner=(sqrt Max)" + (unfoldEach sqrtVal sqrtVal) + , benchIOSrc1 "unfoldEach outer=1 inner=Max" + (unfoldEach 1 value) - benchIOSrc1 "mergeMapWithSerial (n of 1)" - (mergeMapWithSerial value 1) - , benchIOSrc1 "mergeMapWithSerial (sqrtVal of sqrtVal)" - (mergeMapWithSerial sqrtVal sqrtVal) - , benchIOSrc1 "mergeMapWithSerial (2 of n/2)" - (mergeMapWithSerial 2 (value `div` 2)) + , benchIOSrc1 "unfoldEach2 outer=Max inner=1" + (unfoldEach2 value 1) + , benchIOSrc1 "unfoldEach2 outer=inner=(sqrt Max)" + (unfoldEach2 sqrtVal sqrtVal) + , benchIOSrc1 "unfoldEach2 outer=1 inner=Max" + (unfoldEach2 1 value) - {- - , benchIOSrc1 "mergeMapWithAppend (n of 1)" - (mergeMapWithAppend value 1) - , benchIOSrc1 "mergeMapWithAppend (sqrtVal of sqrtVal)" - (mergeMapWithAppend sqrtVal sqrtVal) - -} + , benchIOSrc1 "unfoldEach3 outer=inner=(cubert Max)" + (unfoldEach3 value) ] ] where sqrtVal = round $ sqrt (fromIntegral value :: Double) -#endif ------------------------------------------------------------------------------- -- Applicative ------------------------------------------------------------------------------- +{-# INLINE cross2 #-} +cross2 :: MonadAsync m => Int -> Int -> m () +cross2 linearCount start = drain $ + Stream.crossWith (+) + (sourceUnfoldr nestedCount2 start) + (sourceUnfoldr nestedCount2 start) + + where + + nestedCount2 = round (fromIntegral linearCount**(1/2::Double)) + o_1_space_applicative :: Int -> [Benchmark] o_1_space_applicative value = [ bgroup "Applicative" - [ benchIO "(*>) (sqrt n x sqrt n)" $ apDiscardFst value - , benchIO "(<*) (sqrt n x sqrt n)" $ apDiscardSnd value - , benchIO "(<*>) (sqrt n x sqrt n)" $ toNullAp value - , benchIO "liftA2 (sqrt n x sqrt n)" $ apLiftA2 value + [ benchIO "(*>)" $ apDiscardFst value + , benchIO "(<*)" $ apDiscardSnd value + , benchIO "(<*>)" $ toNullAp value + , benchIO "liftA2" $ apLiftA2 value + , benchIO "pureDrain2" $ toNullApPure value + , benchIO "pureCross2" $ cross2 value ] ] -#ifdef USE_STREAMK -o_n_space_applicative :: Int -> [Benchmark] -o_n_space_applicative value = - [ bgroup "iterated" - [ benchIOSrc "(*>) (n times)" $ - iterateSingleton ((*>) . pure) value - , benchIOSrc "(<*) (n times)" $ - iterateSingleton (\x xs -> xs <* pure x) value - , benchIOSrc "(<*>) (n times)" $ - iterateSingleton (\x xs -> pure (+ x) <*> xs) value - , benchIOSrc "liftA2 (n times)" $ - iterateSingleton (AP.liftA2 (+) . pure) value - ] - ] -#endif - ------------------------------------------------------------------------------- -- Monad ------------------------------------------------------------------------------- @@ -400,61 +317,323 @@ o_1_space_monad :: Int -> [Benchmark] o_1_space_monad value = [ bgroup "Monad" - [ benchIO "(>>) (sqrt n x sqrt n)" $ monadThen value - , benchIO "(>>=) (sqrt n x sqrt n)" $ toNullM value - , benchIO "(>>=) (sqrt n x sqrt n) (filterAllOut)" $ - filterAllOutM value - , benchIO "(>>=) (sqrt n x sqrt n) (filterAllIn)" $ - filterAllInM value - , benchIO "(>>=) (sqrt n x sqrt n) (filterSome)" $ - filterSome value - , benchIO "(>>=) (sqrt n x sqrt n) (breakAfterSome)" $ - breakAfterSome value - , benchIO "(>>=) (cubert n x cubert n x cubert n)" $ - toNullM3 value + [ benchIO "then2" $ monadThen value + , benchIO "drain2" $ toNullM value + , benchIO "drain3" $ toNullM3 value + , benchIO "filterAllOut2" $ filterAllOutM value + , benchIO "filterAllIn2" $ filterAllInM value + , benchIO "filterSome2" $ filterSome value + , benchIO "breakAfterSome2" $ breakAfterSome value + , benchIO "pureDrain2" $ toNullMPure value + , benchIO "pureDrain3" $ toNullM3Pure value + , benchIO "pureFilterAllIn2" $ filterAllInMPure value + , benchIO "pureFilterAllOut2" $ filterAllOutMPure value ] ] -#ifdef USE_STREAMK --- This is a good benchmark but inefficient way to compute primes. As we see a --- new prime we keep appending a division filter for all the future numbers. -{-# INLINE sieve #-} -sieve :: Monad m => StreamK m Int -> StreamK m Int -sieve s = StreamK.concatEffect $ do - r <- StreamK.uncons s - case r of - Just (prime, rest) -> - -- XXX Use K.filter or rewrite to K.filter - let f = S.filter (\n -> n `mod` prime /= 0) - in pure $ prime `StreamK.cons` sieve (fromStream $ f $ toStream rest) - Nothing -> pure StreamK.nil +o_n_space_monad :: Int -> [Benchmark] +o_n_space_monad value = + [ bgroup "Monad" + [ benchIO "toList2" $ toListM value + , benchIO "toListSome2" $ toListSome value + ] + ] -o_n_space_iterated :: Int -> [Benchmark] -o_n_space_iterated value = - [ bgroup "iterated" - [ - benchIO "concatEffect prime sieve (n/4)" - (\n -> - S.fold Fold.sum - $ toStream - $ sieve - $ fromStream - $ S.enumerateFromTo 2 (value `div` 4 + n)) - , benchIOSrc "(>>) (n times)" $ - iterateSingleton ((>>) . pure) value - , benchIOSrc "(>>=) (n times)" $ - iterateSingleton (\x xs -> xs >>= \y -> return (x + y)) value +{-# INLINE drainConcatFor1 #-} +drainConcatFor1 :: Monad m => Stream m Int -> m () +drainConcatFor1 s = drain $ do + Stream.concatFor s $ \x -> + Stream.fromPure $ x + 1 + +{-# INLINE drainConcatFor #-} +drainConcatFor :: Monad m => Stream m Int -> m () +drainConcatFor s = drain $ do + Stream.concatFor s $ \x -> + Stream.concatFor s $ \y -> + Stream.fromPure $ x + y + +{-# INLINE drainConcatForM #-} +drainConcatForM :: Monad m => Stream m Int -> m () +drainConcatForM s = drain $ do + Stream.concatForM s $ \x -> + pure $ Stream.concatForM s $ \y -> + pure $ Stream.fromPure $ x + y + +{-# INLINE drainConcatFor3 #-} +drainConcatFor3 :: Monad m => Stream m Int -> m () +drainConcatFor3 s = drain $ do + Stream.concatFor s $ \x -> + Stream.concatFor s $ \y -> + Stream.concatFor s $ \z -> + Stream.fromPure $ x + y + z + +{-# INLINE drainConcatFor4 #-} +drainConcatFor4 :: Monad m => Stream m Int -> m () +drainConcatFor4 s = drain $ do + Stream.concatFor s $ \x -> + Stream.concatFor s $ \y -> + Stream.concatFor s $ \z -> + Stream.concatFor s $ \w -> + Stream.fromPure $ x + y + z + w + +{-# INLINE drainConcatFor5 #-} +drainConcatFor5 :: Monad m => Stream m Int -> m () +drainConcatFor5 s = drain $ do + Stream.concatFor s $ \x -> + Stream.concatFor s $ \y -> + Stream.concatFor s $ \z -> + Stream.concatFor s $ \w -> + Stream.concatFor s $ \u -> + Stream.fromPure $ x + y + z + w + u + +{-# INLINE drainConcatFor3M #-} +drainConcatFor3M :: Monad m => Stream m Int -> m () +drainConcatFor3M s = drain $ do + Stream.concatForM s $ \x -> + pure $ Stream.concatForM s $ \y -> + pure $ Stream.concatForM s $ \z -> + pure $ Stream.fromPure $ x + y + z + +{-# INLINE filterAllInConcatFor #-} +filterAllInConcatFor + :: Monad m + => Stream m Int -> m () +filterAllInConcatFor s = drain $ do + Stream.concatFor s $ \x -> + Stream.concatFor s $ \y -> + let s1 = x + y + in if s1 > 0 + then Stream.fromPure s1 + else Stream.nil + +{-# INLINE filterAllOutConcatFor #-} +filterAllOutConcatFor + :: Monad m + => Stream m Int -> m () +filterAllOutConcatFor s = drain $ do + Stream.concatFor s $ \x -> + Stream.concatFor s $ \y -> + let s1 = x + y + in if s1 < 0 + then Stream.fromPure s1 + else Stream.nil + +o_1_space_bind :: Int -> [Benchmark] +o_1_space_bind streamLen = + [ bgroup "concatFor" + [ benchFold "drain1" drainConcatFor1 (sourceUnfoldrM streamLen) + , benchFold "drain2" drainConcatFor (sourceUnfoldrM streamLen2) + , benchFold "drain3" drainConcatFor3 (sourceUnfoldrM streamLen3) + , benchFold "drain4" drainConcatFor4 (sourceUnfoldrM streamLen4) + , benchFold "drain5" drainConcatFor5 (sourceUnfoldrM streamLen5) + , benchFold "drainM2" drainConcatForM (sourceUnfoldrM streamLen2) + , benchFold "drainM3" drainConcatFor3M (sourceUnfoldrM streamLen3) + , benchFold "filterAllIn2" filterAllInConcatFor (sourceUnfoldrM streamLen2) + , benchFold "filterAllOut2" filterAllOutConcatFor (sourceUnfoldrM streamLen2) ] ] -#endif -o_n_space_monad :: Int -> [Benchmark] -o_n_space_monad value = - [ bgroup "Monad" - [ benchIO "(>>=) (sqrt n x sqrt n) (toList)" $ - toListM value - , benchIO "(>>=) (sqrt n x sqrt n) (toListSome)" $ - toListSome value + where + + streamLen2 = round (fromIntegral streamLen**(1/2::Double)) -- double nested loop + streamLen3 = round (fromIntegral streamLen**(1/3::Double)) -- triple nested loop + streamLen4 = round (fromIntegral streamLen**(1/4::Double)) -- 4 times nested loop + streamLen5 = round (fromIntegral streamLen**(1/5::Double)) -- 5 times nested loop + +-- search space |x| = 1000, |y| = 1000 +{-# INLINE boundedInts #-} +boundedInts :: Monad m => Int -> Int -> Stream m Int +boundedInts n _ = + Stream.interleave + (Stream.enumerateFromTo (0 :: Int) n) + (Stream.enumerateFromThenTo (-1) (-2) (-n)) + +{-# INLINE infiniteInts #-} +infiniteInts :: Monad m => Int -> Int -> Stream m Int +infiniteInts _ _ = + Stream.interleave + (Stream.enumerateFrom (0 :: Int)) + (Stream.enumerateFromThen (-1) (-2)) + +{-# INLINE boundedIntsUnfold #-} +boundedIntsUnfold :: Monad m => Int -> Int -> Unfold m ((), ()) Int +boundedIntsUnfold n _ = + Unfold.interleave + (Unfold.supply (0 :: Int, n) Unfold.enumerateFromTo) + (Unfold.supply (-1, -2, -n) Unfold.enumerateFromThenTo) + +{-# INLINE infiniteIntsUnfold #-} +infiniteIntsUnfold :: Monad m => Int -> Int -> Unfold m ((), ()) Int +infiniteIntsUnfold _ _ = + Unfold.interleave + (Unfold.supply (0 :: Int) Unfold.enumerateFrom) + (Unfold.supply (-1, -2) Unfold.enumerateFromThen) + +{-# INLINE checkStream #-} +checkStream :: Applicative m => + Int -> Int -> Stream m (Maybe (Maybe (Int, Int))) +checkStream x y = + let eq1 = x + y == 0 + eq2 = x - y == 1994 + in if eq1 && eq2 + then Stream.fromPure (Just (Just (x,y))) + else if abs x > 1000 && abs y > 1000 + then Stream.fromPure (Just Nothing) + else Stream.fromPure Nothing + +{-# INLINE checkStreamK #-} +checkStreamK :: Int -> Int -> StreamK.StreamK m (Maybe (Maybe (Int, Int))) +checkStreamK x y = + let eq1 = x + y == 0 + eq2 = x - y == 1994 + in if eq1 && eq2 + then StreamK.fromPure (Just (Just (x,y))) + else if abs x > 1000 && abs y > 1000 + then StreamK.fromPure (Just Nothing) + else StreamK.fromPure Nothing + +{-# INLINE checkPair #-} +checkPair :: Monad m => (Int, Int) -> m (Maybe (Maybe (Int, Int))) +checkPair (x, y) = + let eq1 = x + y == 0 + eq2 = x - y == 1994 + in if eq1 && eq2 + then pure (Just (Just (x,y))) + else if abs x > 1000 && abs y > 1000 + then pure (Just Nothing) + else pure Nothing + +result :: Monad m => Stream m (Maybe a) -> m () +result = Stream.fold (Fold.take 1 Fold.drain) . Stream.catMaybes + +fairConcatForEqn :: Monad m => Stream m Int -> m () +fairConcatForEqn input = + result + $ Stream.fairConcatFor input $ \x -> + Stream.fairConcatForM input $ \y -> do + return $ checkStream x y + +fairConcatForEqnK :: Monad m => Stream m Int -> m () +fairConcatForEqnK input = + let inputK = StreamK.fromStream input + in result + $ StreamK.toStream + $ StreamK.fairConcatFor inputK $ \x -> + StreamK.fairConcatForM inputK $ \y -> do + return $ checkStreamK x y + +concatForEqn :: Monad m => Stream m Int -> m () +concatForEqn input = + result + $ Stream.concatFor input $ \x -> + Stream.concatForM input $ \y -> do + return $ checkStream x y + +fairSchedForEqn :: Monad m => Stream m Int -> m () +fairSchedForEqn input = + result + $ Stream.fairSchedFor input $ \x -> + Stream.fairSchedForM input $ \y -> do + return $ checkStream x y + +_schedForEqn :: Monad m => Stream m Int -> m () +_schedForEqn input = + result + $ Stream.schedFor input $ \x -> + Stream.schedForM input $ \y -> do + return $ checkStream x y + +streamCrossEqn :: Monad m => Stream m Int -> m () +streamCrossEqn input = + result + $ Stream.mapM checkPair + $ Stream.cross input input + +fairStreamCrossEqn :: Monad m => Stream m Int -> m () +fairStreamCrossEqn input = + result + $ Stream.mapM checkPair + $ Stream.fairCross input input + +unfoldCrossEqn :: Monad m => Unfold m ((), ()) Int -> m () +unfoldCrossEqn input = + result + $ Stream.mapM checkPair + $ Stream.unfold (Unfold.cross input input) (undefined, undefined) + +fairUnfoldCrossEqn :: Monad m => Unfold m ((), ()) Int -> m () +fairUnfoldCrossEqn input = + result + $ Stream.mapM checkPair + $ Stream.unfold (Unfold.fairCross input input) (undefined, undefined) + +unfoldEachEqn :: Monad m => Unfold m ((), ()) Int -> Stream m Int -> m () +unfoldEachEqn input ints = + let intu = Unfold.carry $ Unfold.lmap (const (undefined, undefined)) input + in result + $ Stream.mapM checkPair + $ Stream.unfoldEach intu ints + +fairUnfoldEachEqn :: Monad m => Unfold m ((), ()) Int -> Stream m Int -> m () +fairUnfoldEachEqn input ints = + let intu = Unfold.carry $ Unfold.lmap (const (undefined, undefined)) input + in result + $ Stream.mapM checkPair + $ Stream.fairUnfoldEach intu ints + +unfoldSchedEqn :: Monad m => Unfold m ((), ()) Int -> Stream m Int -> m () +unfoldSchedEqn input ints = + let intu = Unfold.carry $ Unfold.lmap (const (undefined, undefined)) input + in result + $ Stream.mapM checkPair + $ Stream.unfoldSched intu ints + +fairUnfoldSchedEqn :: Monad m => Unfold m ((), ()) Int -> Stream m Int -> m () +fairUnfoldSchedEqn input ints = + let intu = Unfold.carry $ Unfold.lmap (const (undefined, undefined)) input + in result + $ Stream.mapM checkPair + $ Stream.fairUnfoldSched intu ints + +-- Solve simultaneous equations by exploring all possibilities +o_1_space_equations :: Int -> [Benchmark] +o_1_space_equations _ = + [ bgroup "equations" + [ benchFold "concatFor (bounded)" concatForEqn (boundedInts 1000) + , benchFold "fairConcatFor (bounded)" + fairConcatForEqn (boundedInts 1000) + , benchFold "fairConcatForK (bounded)" + fairConcatForEqnK (boundedInts 1000) + , benchFold "fairConcatFor (infinite)" + fairConcatForEqn (infiniteInts 1000) + , benchFold "fairSchedFor (bounded)" + fairSchedForEqn (boundedInts 1000) + , benchFold "fairSchedFor (infinite)" + fairSchedForEqn (infiniteInts 1000) + , benchFold "streamCross (bounded)" + streamCrossEqn (boundedInts 1000) + , benchFold "fairStreamCross (bounded)" + fairStreamCrossEqn (boundedInts 1000) + , benchFold "fairStreamCross (infinite)" + fairStreamCrossEqn (infiniteInts 1000) + , bench "unfoldCross (bounded)" + $ nfIO $ unfoldCrossEqn (boundedIntsUnfold 1000 0) + , bench "fairUnfoldCross (bounded)" + $ nfIO $ fairUnfoldCrossEqn (boundedIntsUnfold 1000 0) + , bench "fairUnfoldCross (infinite)" + $ nfIO $ fairUnfoldCrossEqn (infiniteIntsUnfold 1000 0) + , benchFold "unfoldEach (bounded)" + (unfoldEachEqn (boundedIntsUnfold 1000 0)) (boundedInts 1000) + , benchFold "fairUnfoldEach (bounded)" + (fairUnfoldEachEqn (boundedIntsUnfold 1000 0)) (boundedInts 1000) + , benchFold "fairUnfoldEach (infinite)" + (fairUnfoldEachEqn (infiniteIntsUnfold 1000 0)) (infiniteInts 1000) + , benchFold "unfoldSched (bounded)" + (unfoldSchedEqn (boundedIntsUnfold 1000 0)) (boundedInts 1000) + , benchFold "fairUnfoldSched (bounded)" + (fairUnfoldSchedEqn (boundedIntsUnfold 1000 0)) (boundedInts 1000) + , benchFold "fairUnfoldSched (infinite)" + (fairUnfoldSchedEqn (infiniteIntsUnfold 1000 0)) (infiniteInts 1000) ] ] @@ -507,6 +686,9 @@ $ joinWith S.filterInStreamGenericBy sqrtVal , benchIOSrc1 "filterInStreamAscBy" $ joinMapWith (S.filterInStreamAscBy compare) halfVal + -- Note: schedFor does a bfs scheduling, therefore, can take a lot of + -- memory. + , benchFold "schedFor (bounded)" schedForEqn (boundedInts 1000) ] ] @@ -536,16 +718,13 @@ , o_1_space_concat size , o_1_space_applicative size , o_1_space_monad size + , o_1_space_bind size + , o_1_space_equations size ] , bgroup (o_n_space_prefix moduleName) $ Prelude.concat [ -- multi-stream o_n_space_monad size -#ifdef USE_STREAMK - , o_n_space_merge size - , o_n_space_iterated size - , o_n_space_applicative size -#endif ] {- , bgroup (o_n_heap_prefix moduleName) $ diff --git a/benchmark/Streamly/Benchmark/Data/Stream/Generate.hs b/benchmark/Streamly/Benchmark/Data/Stream/Generate.hs --- a/benchmark/Streamly/Benchmark/Data/Stream/Generate.hs +++ b/benchmark/Streamly/Benchmark/Data/Stream/Generate.hs @@ -12,7 +12,6 @@ {-# OPTIONS_GHC -Wno-orphans #-} #ifdef USE_PRELUDE -{-# OPTIONS_GHC -Wno-deprecations #-} #endif module Stream.Generate (benchmarks) where @@ -31,16 +30,11 @@ import qualified Streamly.Internal.Data.Stream.IsStream as Stream #else import Stream.Common -import Streamly.Internal.Data.Stream.StreamD (Stream) -import qualified Streamly.Internal.Data.Stream.StreamD as Stream -#ifdef USE_STREAMK -import System.IO.Unsafe (unsafeInterleaveIO) -import qualified Streamly.Internal.Data.Stream.StreamK as StreamK -import qualified Stream.Common as Common -#endif +import Streamly.Internal.Data.Stream (Stream) +import qualified Streamly.Internal.Data.Stream as Stream #endif -import Gauge +import Test.Tasty.Bench import Streamly.Benchmark.Common import qualified Prelude @@ -182,18 +176,6 @@ fromIndicesM value n = S.take value $ S.fromIndicesM (return <$> (+ n)) #endif -#ifdef USE_STREAMK -{-# INLINE mfixUnfold #-} -mfixUnfold :: Int -> Int -> Stream IO (Int, Int) -mfixUnfold count start = toStream $ StreamK.mfix f - where - f action = StreamK.unCross $ do - let incr n act = fmap ((+n) . snd) $ unsafeInterleaveIO act - x <- StreamK.mkCross (fromStream $ Common.fromListM [incr 1 action, incr 2 action]) - y <- StreamK.mkCross (fromStream $ Common.sourceUnfoldr count start) - return (x, y) -#endif - o_1_space_generation :: Int -> [Benchmark] o_1_space_generation value = [ bgroup "generation" @@ -225,22 +207,12 @@ , benchIOSrc "fromIndicesM" (fromIndicesM value) #endif - -- These essentially test cons and consM -#ifdef USE_STREAMK - , benchIOSrc "fromFoldable" (sourceFromFoldable value) - -- , benchIOSrc "fromFoldable 16" (sourceFromFoldable 16) -#else + -- These essentially test cons and consM -- , benchIOSrc "fromFoldable 16" (sourceFromFoldable 16) -#endif #ifdef USE_PRELUDE , benchIOSrc "fromFoldableM" (sourceFromFoldableM value) , benchIOSrc "absTimes" $ absTimes value -#endif -#ifdef USE_STREAMK - , Common.benchIOSrc "mfix_10" (mfixUnfold 10) - , Common.benchIOSrc "mfix_100" (mfixUnfold 100) - , Common.benchIOSrc "mfix_1000" (mfixUnfold 1000) #endif ] ] diff --git a/benchmark/Streamly/Benchmark/Data/Stream/Lift.hs b/benchmark/Streamly/Benchmark/Data/Stream/Lift.hs --- a/benchmark/Streamly/Benchmark/Data/Stream/Lift.hs +++ b/benchmark/Streamly/Benchmark/Data/Stream/Lift.hs @@ -10,7 +10,6 @@ {-# LANGUAGE RankNTypes #-} #ifdef USE_PRELUDE -{-# OPTIONS_GHC -Wno-deprecations #-} #endif module Stream.Lift (benchmarks) where @@ -27,17 +26,11 @@ #ifdef USE_PRELUDE import qualified Streamly.Internal.Data.Stream.IsStream as Stream #else -import Streamly.Internal.Data.Stream.StreamD (Stream) -import qualified Streamly.Internal.Data.Stream.StreamD as Stream -#ifdef USE_STREAMK -import Stream.Common (benchIO, drain) -import Streamly.Internal.Data.Stream.StreamK (StreamK) -import qualified Streamly.Internal.Data.Stream.StreamK as StreamK -import qualified Control.Monad.State.Strict as State -#endif +import Streamly.Internal.Data.Stream (Stream) +import qualified Streamly.Internal.Data.Stream as Stream #endif -import Gauge +import Test.Tasty.Bench import Streamly.Benchmark.Common import Prelude hiding (reverse, tail) @@ -93,43 +86,6 @@ ] ] -#ifdef USE_STREAMK -{-# INLINE iterateStateIO #-} -iterateStateIO :: - Monad m - => Int - -> StateT Int m Int -iterateStateIO n = do - x <- get - if x > n - then do - put (x - 1) - iterateStateIO n - else return x - --- XXX This is basically testing the perf of concatEffect, change it to just --- use concatEffect and move it along with other concatMap benchmarks. -{-# INLINE iterateStateT #-} -iterateStateT :: Int -> StreamK (StateT Int IO) Int -iterateStateT n = StreamK.concatEffect $ do - x <- get - if x > n - then do - put (x - 1) - return $ iterateStateT n - else return $ StreamK.fromPure x - -o_n_heap_transformer :: Int -> [Benchmark] -o_n_heap_transformer value = - [ bgroup "transformer" - [ benchIO "StateT Int IO (n times) (baseline)" $ \n -> - State.evalStateT (iterateStateIO n) value - , benchIO "Stream (StateT Int IO) (n times)" $ \n -> - State.evalStateT (drain $ Common.toStream (iterateStateT n)) value - ] - ] -#endif - ------------------------------------------------------------------------------- -- Main ------------------------------------------------------------------------------- @@ -140,7 +96,4 @@ benchmarks :: String -> Int -> [Benchmark] benchmarks moduleName size = [ bgroup (o_1_space_prefix moduleName) (o_1_space_hoisting size) -#ifdef USE_STREAMK - , bgroup (o_n_heap_prefix moduleName) (o_n_heap_transformer size) -#endif ] diff --git a/benchmark/Streamly/Benchmark/Data/Stream/Rate.hs b/benchmark/Streamly/Benchmark/Data/Stream/Rate.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Data/Stream/Rate.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | +-- Module : Main +-- Copyright : (c) 2018 Composewell Technologies +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com + +import Stream.Common (benchIOSrc, sourceUnfoldrM) +import Streamly.Data.Stream (Stream) +import Streamly.Internal.Data.Stream.Prelude (MonadAsync, Config) + +import qualified Streamly.Data.Stream.Prelude as Stream + +import Streamly.Benchmark.Common +import Test.Tasty.Bench + +moduleName :: String +moduleName = "Data.Stream.Rate" + +------------------------------------------------------------------------------- +-- Average Rate +------------------------------------------------------------------------------- + +{-# INLINE rateNothing #-} +rateNothing :: MonadAsync m => + ((Config -> Config) -> Stream m Int -> Stream m Int) + -> (Config -> Config) -> Int -> Int -> Stream m Int +rateNothing f cfg value = f (Stream.rate Nothing . cfg) . sourceUnfoldrM value + +{-# INLINE avgRate #-} +avgRate :: MonadAsync m => + ((Config -> Config) -> Stream m Int -> Stream m Int) + -> (Config -> Config) -> Int -> Double -> Int -> Stream m Int +avgRate f cfg value rt = f (Stream.avgRate rt . cfg) . sourceUnfoldrM value + +{- +-- parBuffered should be maxThreads 1 anyway +{-# INLINE avgRateThreads1 #-} +avgRateThreads1 :: MonadAsync m => + ((Config -> Config) -> Stream m Int -> Stream m Int) + -> (Config -> Config) -> Int -> Double -> Int -> Stream m Int +avgRateThreads1 f cfg value rt = + f (Stream.maxThreads 1 . Stream.avgRate rt . cfg) . sourceUnfoldrM value +-} + +{-# INLINE minRate #-} +minRate :: MonadAsync m => + ((Config -> Config) -> Stream m Int -> Stream m Int) + -> (Config -> Config) -> Int -> Double -> Int -> Stream m Int +minRate f cfg value rt = f (Stream.minRate rt . cfg) . sourceUnfoldrM value + +{-# INLINE maxRate #-} +maxRate :: MonadAsync m => + ((Config -> Config) -> Stream m Int -> Stream m Int) + -> (Config -> Config) -> Int -> Double -> Int -> Stream m Int +maxRate f cfg value rt = f (Stream.minRate rt . cfg) . sourceUnfoldrM value + +{-# INLINE constRate #-} +constRate :: MonadAsync m => + ((Config -> Config) -> Stream m Int -> Stream m Int) + -> (Config -> Config) -> Int -> Double -> Int -> Stream m Int +constRate f cfg value rt = f (Stream.constRate rt . cfg) . sourceUnfoldrM value + +-- XXX arbitrarily large rate should be the same as rate Nothing +-- XXX Add tests for multiworker cases as well - parMapM +o_1_space_async :: Int -> [Benchmark] +o_1_space_async value = + [ bgroup + "default/parBuffered" + [ bgroup + "avgRate" + -- benchIO "unfoldr" $ toNull + [ benchIOSrc "baseline" (Stream.parBuffered id . sourceUnfoldrM value) + , benchIOSrc "Nothing" $ rateNothing Stream.parBuffered id value + , benchIOSrc "1M" $ avgRate Stream.parBuffered id value 1000000 + , benchIOSrc "3M" $ avgRate Stream.parBuffered id value 3000000 + -- , benchIOSrc "10M/maxThreads1" $ avgRateThreads1 Stream.parBuffered value 10000000 + , benchIOSrc "10M" $ avgRate Stream.parBuffered id value 10000000 + , benchIOSrc "20M" $ avgRate Stream.parBuffered id value 20000000 + ] + , bgroup + "minRate" + [ benchIOSrc "1M" $ minRate Stream.parBuffered id value 1000000 + , benchIOSrc "10M" $ minRate Stream.parBuffered id value 10000000 + , benchIOSrc "20M" $ minRate Stream.parBuffered id value 20000000 + ] + , bgroup + "maxRate" + [ -- benchIOSrc "10K" $ maxRate value 10000 + benchIOSrc "10M" $ maxRate Stream.parBuffered id value 10000000 + ] + , bgroup + "constRate" + [ -- benchIOSrc "10K" $ constRate value 10000 + benchIOSrc "1M" $ constRate Stream.parBuffered id value 1000000 + , benchIOSrc "10M" $ constRate Stream.parBuffered id value 10000000 + ] + ] + ] + +o_1_space_ahead :: Int -> [Benchmark] +o_1_space_ahead value = + [ bgroup + "ordered/parBuffered" + [ benchIOSrc "avgRate/1M" + $ avgRate Stream.parBuffered (Stream.ordered True) value 1000000 + , benchIOSrc "minRate/1M" + $ minRate Stream.parBuffered (Stream.ordered True) value 1000000 + , benchIOSrc "maxRate/1M" + $ maxRate Stream.parBuffered (Stream.ordered True) value 1000000 + , benchIOSrc "constRate/1M" + $ constRate Stream.parBuffered (Stream.ordered True) value 1000000 + ] + ] + +------------------------------------------------------------------------------- +-- Main +------------------------------------------------------------------------------- + +main :: IO () +main = runWithCLIOpts defaultStreamSize allBenchmarks + + where + + allBenchmarks value = + [ bgroup (o_1_space_prefix moduleName) + $ concat [o_1_space_async value, o_1_space_ahead value]] diff --git a/benchmark/Streamly/Benchmark/Data/Stream/Reduce.hs b/benchmark/Streamly/Benchmark/Data/Stream/Reduce.hs --- a/benchmark/Streamly/Benchmark/Data/Stream/Reduce.hs +++ b/benchmark/Streamly/Benchmark/Data/Stream/Reduce.hs @@ -12,13 +12,14 @@ {-# LANGUAGE RankNTypes #-} #ifdef USE_PRELUDE -{-# OPTIONS_GHC -Wno-deprecations #-} #endif module Stream.Reduce (benchmarks) where import Control.DeepSeq (NFData(..)) +import Control.Monad (when) import Control.Monad.IO.Class (MonadIO(..)) +import Data.Maybe (isJust) import Data.Monoid (Sum(..)) import GHC.Generics (Generic) @@ -33,7 +34,6 @@ #endif #ifdef USE_PRELUDE -import Control.Monad (when) import qualified Streamly.Internal.Data.Stream.IsStream as S import qualified Streamly.Prelude as S import Streamly.Prelude (fromSerial) @@ -44,24 +44,15 @@ , transformComposeMapM, transformTeeMapM, transformZipMapM) #else -import Streamly.Internal.Data.Stream.StreamD (Stream) -import qualified Streamly.Internal.Data.Stream.StreamD as S +import Streamly.Internal.Data.Stream (Stream) +import qualified Streamly.Internal.Data.Stream as S #ifndef USE_STREAMLY_CORE import qualified Streamly.Data.Stream.Prelude as S -import qualified Streamly.Internal.Data.Stream.Time as S +import qualified Streamly.Internal.Data.Stream.Prelude as S #endif - -#ifdef USE_STREAMK -import Streamly.Internal.Data.Stream.StreamK (StreamK) -import qualified Streamly.Internal.Data.Parser as PR -import qualified Streamly.Internal.Data.Stream.StreamK as K -#else -import qualified Streamly.Internal.Data.Stream.StreamD as K #endif -#endif - -import Gauge +import Test.Tasty.Bench import Streamly.Benchmark.Common import Stream.Common import Prelude hiding (reverse, tail) @@ -71,25 +62,9 @@ #endif -- Apply transformation g count times on a stream of length len -#ifdef USE_STREAMK {-# INLINE iterateSource #-} iterateSource :: MonadAsync m - => (StreamK m Int -> StreamK m Int) - -> Int - -> Int - -> Int - -> StreamK m Int -iterateSource g count len n = f count (fromStream $ sourceUnfoldrM len n) - - where - - f (0 :: Int) stream = stream - f i stream = f (i - 1) (g stream) -#else -{-# INLINE iterateSource #-} -iterateSource :: - MonadAsync m => (Stream m Int -> Stream m Int) -> Int -> Int @@ -101,36 +76,55 @@ f (0 :: Int) stream = stream f i stream = f (i - 1) (g stream) -#endif ------------------------------------------------------------------------------- -- Grouping transformations ------------------------------------------------------------------------------- -#ifdef USE_PRELUDE {-# INLINE groups #-} groups :: MonadIO m => Stream m Int -> m () -groups = Common.drain . S.groups FL.drain +groups = +#ifdef USE_PRELUDE + Common.drain . S.groups FL.drain +#else + Common.drain . S.groupsWhile (==) FL.drain +#endif --- XXX Change this test when the order of comparison is later changed -{-# INLINE groupsByGT #-} -groupsByGT :: MonadIO m => Stream m Int -> m () -groupsByGT = Common.drain . S.groupsBy (>) FL.drain +{-# INLINE groupsWhileLT #-} +groupsWhileLT :: MonadIO m => Stream m Int -> m () +groupsWhileLT = +#ifdef USE_PRELUDE + Common.drain . S.groupsBy (>) FL.drain +#else + Common.drain . S.groupsWhile (<) FL.drain +#endif -{-# INLINE groupsByEq #-} -groupsByEq :: MonadIO m => Stream m Int -> m () -groupsByEq = Common.drain . S.groupsBy (==) FL.drain +{-# INLINE groupsWhileEq #-} +groupsWhileEq :: MonadIO m => Stream m Int -> m () +groupsWhileEq = +#ifdef USE_PRELUDE + Common.drain . S.groupsBy (==) FL.drain +#else + Common.drain . S.groupsWhile (==) FL.drain +#endif --- XXX Change this test when the order of comparison is later changed + {-# INLINE groupsByRollingLT #-} groupsByRollingLT :: MonadIO m => Stream m Int -> m () groupsByRollingLT = +#ifdef USE_PRELUDE Common.drain . S.groupsByRolling (<) FL.drain +#else + Common.drain . S.groupsRollingBy (<) FL.drain +#endif {-# INLINE groupsByRollingEq #-} groupsByRollingEq :: MonadIO m => Stream m Int -> m () groupsByRollingEq = +#ifdef USE_PRELUDE Common.drain . S.groupsByRolling (==) FL.drain +#else + Common.drain . S.groupsRollingBy (==) FL.drain #endif {-# INLINE foldMany #-} @@ -141,13 +135,15 @@ . S.foldMany (FL.take 2 FL.mconcat) . fmap Sum -{-# INLINE foldManyPost #-} -foldManyPost :: Monad m => Stream m Int -> m () -foldManyPost = +#ifndef USE_PRELUDE +{-# INLINE foldMany1 #-} +foldMany1 :: Monad m => Stream m Int -> m () +foldMany1 = Common.drain . fmap getSum . S.foldManyPost (FL.take 2 FL.mconcat) . fmap Sum +#endif {-# INLINE refoldMany #-} refoldMany :: Monad m => Stream m Int -> m () @@ -175,40 +171,28 @@ (Refold.take 2 Refold.sconcat) (return (Sum 0)) . fmap Sum -#ifdef USE_STREAMK -{-# INLINE parseBreak #-} -parseBreak :: Monad m => StreamK m Int -> m () -parseBreak s = do - r <- K.parseDBreak PR.one s - case r of - (Left _, _) -> return () - (Right _, s1) -> parseBreak s1 -#endif - o_1_space_grouping :: Int -> [Benchmark] o_1_space_grouping value = -- Buffering operations using heap proportional to group/window sizes. [ bgroup "grouping" [ -#ifdef USE_PRELUDE benchIOSink value "groups" groups - , benchIOSink value "groupsByGT" groupsByGT - , benchIOSink value "groupsByEq" groupsByEq + , benchIOSink value "groupsWhileLT" groupsWhileLT + , benchIOSink value "groupsWhileEq" groupsWhileEq , benchIOSink value "groupsByRollingLT" groupsByRollingLT , benchIOSink value "groupsByRollingEq" groupsByRollingEq , -#endif + -- XXX parseMany/parseIterate benchmarks are in the Parser/ParserD -- modules we can bring those here. chunksOf benchmarks are in -- Parser/ParserD/Array.Stream/FileSystem.Handle. benchIOSink value "foldMany" foldMany - , benchIOSink value "foldManyPost" foldManyPost +#ifndef USE_PRELUDE + , benchIOSink value "foldMany1" foldMany1 +#endif , benchIOSink value "refoldMany" refoldMany , benchIOSink value "foldIterateM" foldIterateM , benchIOSink value "refoldIterateM" refoldIterateM -#ifdef USE_STREAMK - , benchIOSink value "parseBreak (recursive)" (parseBreak . fromStream) -#endif #ifndef USE_STREAMLY_CORE , benchIOSink value "classifySessionsOf (10000 buckets)" @@ -237,7 +221,7 @@ #ifndef USE_PRELUDE {-# INLINE reverse #-} reverse :: MonadIO m => Int -> Stream m Int -> m () -reverse n = composeN n (toStream . K.reverse . fromStream) +reverse n = composeN n S.reverse {-# INLINE reverse' #-} reverse' :: MonadIO m => Int -> Stream m Int -> m () @@ -364,12 +348,40 @@ -- need monolithic implementations of these. [ bgroup "mixed" [ benchIOSink value "scanl-map" (scanMap 1) + , benchIOSink value "drop-map" (dropMap 1) + , benchIOSink value "drop-scan" (dropScan 1) + , benchIOSink value "take-drop" (takeDrop value 1) + , benchIOSink value "take-scan" (takeScan value 1) + , benchIOSink value "take-map" (takeMap value 1) + , benchIOSink value "filter-drop" (filterDrop value 1) + , benchIOSink value "filter-take" (filterTake value 1) + , benchIOSink value "filter-scan" (filterScan 1) + , benchIOSink value "filter-map" (filterMap value 1) , benchIOSink value "foldl-map" foldl'ReduceMap , benchIOSink value "sum-product-fold" sumProductFold , benchIOSink value "sum-product-scan" sumProductScan ] ] +o_1_space_transformations_mixedX2 :: Int -> [Benchmark] +o_1_space_transformations_mixedX2 value = + [ bgroup "mixedX2" + [ benchIOSink value "scan-map" (scanMap 2) + , benchIOSink value "drop-map" (dropMap 2) + , benchIOSink value "drop-scan" (dropScan 2) + , benchIOSink value "take-drop" (takeDrop value 2) + , benchIOSink value "take-scan" (takeScan value 2) + , benchIOSink value "take-map" (takeMap value 2) + , benchIOSink value "filter-drop" (filterDrop value 2) + , benchIOSink value "filter-take" (filterTake value 2) + , benchIOSink value "filter-scan" (filterScan 2) +#ifdef USE_PRELUDE + , benchIOSink value "filter-scanl1" (filterScanl1 2) +#endif + , benchIOSink value "filter-map" (filterMap value 2) + ] + ] + o_1_space_transformations_mixedX4 :: Int -> [Benchmark] o_1_space_transformations_mixedX4 value = [ bgroup "mixedX4" @@ -393,49 +405,9 @@ -- Iterating a transformation over and over again ------------------------------------------------------------------------------- -#ifdef USE_STREAMK -{- -- this is quadratic {-# INLINE iterateScan #-} iterateScan :: MonadAsync m => Int -> Int -> Int -> Stream m Int -iterateScan count len = toStream . iterateSource (K.scanl' (+) 0) count len --} - -{-# INLINE iterateMapM #-} -iterateMapM :: MonadAsync m => Int -> Int -> Int -> Stream m Int -iterateMapM count len = toStream . iterateSource (K.mapM return) count len - -{-# INLINE iterateFilterEven #-} -iterateFilterEven :: MonadAsync m => Int -> Int -> Int -> Stream m Int -iterateFilterEven count len = - toStream . iterateSource (K.filter even) count len - -{-# INLINE iterateTakeAll #-} -iterateTakeAll :: MonadAsync m => Int -> Int -> Int -> Int -> Stream m Int -iterateTakeAll value count len = - toStream . iterateSource (K.take (value + 1)) count len - -{-# INLINE iterateDropOne #-} -iterateDropOne :: MonadAsync m => Int -> Int -> Int -> Stream m Int -iterateDropOne count len = toStream . iterateSource (K.drop 1) count len - -{-# INLINE iterateDropWhileTrue #-} -iterateDropWhileTrue :: MonadAsync m - => Int -> Int -> Int -> Int -> Stream m Int -iterateDropWhileTrue value count len = - toStream . iterateSource (K.dropWhile (<= (value + 1))) count len - -{-# INLINE iterateDropWhileFalse #-} -iterateDropWhileFalse :: MonadAsync m - => Int -> Int -> Int -> Int -> Stream m Int -iterateDropWhileFalse value count len = - toStream . iterateSource (K.dropWhile (> (value + 1))) count len - -#else - --- this is quadratic -{-# INLINE iterateScan #-} -iterateScan :: MonadAsync m => Int -> Int -> Int -> Stream m Int iterateScan = iterateSource (Common.scanl' (+) 0) #ifdef USE_PRELUDE @@ -465,9 +437,12 @@ iterateDropWhileTrue :: MonadAsync m => Int -> Int -> Int -> Int -> Stream m Int iterateDropWhileTrue value = iterateSource (S.dropWhile (<= (value + 1))) -#endif -#ifdef USE_PRELUDE +{-# INLINE iterateDropWhileFalse #-} +iterateDropWhileFalse :: MonadAsync m + => Int -> Int -> Int -> Int -> Stream m Int +iterateDropWhileFalse value = iterateSource (S.dropWhile (> (value + 1))) + {-# INLINE tail #-} tail :: Monad m => Stream m a -> m () tail s = S.tail s >>= mapM_ tail @@ -479,17 +454,24 @@ when (not r) $ do _ <- S.head s S.tail s >>= mapM_ nullHeadTail -#endif +nullTail :: Monad m => Stream m Int -> m () +nullTail s = do + r <- S.null s + when (not r) $ S.tail s >>= mapM_ nullTail + +headTail :: Monad m => Stream m Int -> m () +headTail s = do + h <- S.head s + when (isJust h) $ S.tail s >>= mapM_ headTail + -- Head recursive operations. o_n_stack_iterated :: Int -> [Benchmark] o_n_stack_iterated value = by10 `seq` by100 `seq` [ bgroup "iterated" [ benchIOSrc "mapM (n/10 x 10)" $ iterateMapM by10 10 -#ifndef USE_STREAMK , benchIOSrc "scanl' (quadratic) (n/100 x 100)" $ iterateScan by100 100 -#endif #ifdef USE_PRELUDE , benchIOSrc "scanl1' (n/10 x 10)" $ iterateScanl1 by10 10 #endif @@ -498,17 +480,15 @@ , benchIOSrc "takeAll (n/10 x 10)" $ iterateTakeAll value by10 10 , benchIOSrc "dropOne (n/10 x 10)" $ iterateDropOne by10 10 -#ifdef USE_STREAMK - , benchIOSrc "dropWhileFalse (n/10 x 10)" $ - iterateDropWhileFalse value by10 10 -#endif , benchIOSrc "dropWhileTrue (n/10 x 10)" $ iterateDropWhileTrue value by10 10 -#ifdef USE_PRELUDE + , benchIOSrc "dropWhileFalse (n/10 x 10)" $ + iterateDropWhileFalse value by10 10 , benchIOSink value "tail" tail + , benchIOSink value "nullTail" nullTail + , benchIOSink value "headTail" headTail , benchIOSink value "nullHeadTail" nullHeadTail -#endif - ] + ] ] where @@ -528,7 +508,7 @@ , benchIOSink value "tee" (transformTeeMapM 1) #ifdef DEVBUILD -- XXX this take 1 GB memory to compile - , benchIOSink value "zip" (transformZipMapM 1) + -- , benchIOSink value "zip" (transformZipMapM 1) #endif ] ] @@ -541,12 +521,37 @@ , benchIOSink value "tee" (transformTeeMapM 4) #ifdef DEVBUILD -- XXX this take 1 GB memory to compile - , benchIOSink value "zip" (transformZipMapM 4) + -- , benchIOSink value "zip" (transformZipMapM 4) #endif ] ] ------------------------------------------------------------------------------- +-- Scans +------------------------------------------------------------------------------- + +#ifndef USE_PRELUDE +o_1_space_scans :: Int -> [Benchmark] +o_1_space_scans value = + [ bgroup "scans" + [ + benchIOSink value "mapM" (scanMapM 1) + , benchIOSink value "compose" (scanComposeMapM 1) + , benchIOSink value "tee" (scanTeeMapM 1) + ] + ] + +o_1_space_scansX4 :: Int -> [Benchmark] +o_1_space_scansX4 value = + [ bgroup "scansX4" + [ benchIOSink value "mapM" (scanMapM 4) + , benchIOSink value "compose" (scanComposeMapM 4) + , benchIOSink value "tee" (scanTeeMapM 4) + ] + ] +#endif + +------------------------------------------------------------------------------- -- Main ------------------------------------------------------------------------------- @@ -558,11 +563,18 @@ [ bgroup (o_1_space_prefix moduleName) $ Prelude.concat [ o_1_space_grouping size , o_1_space_transformations_mixed size + , o_1_space_transformations_mixedX2 size , o_1_space_transformations_mixedX4 size -- pipes , o_1_space_pipes size , o_1_space_pipesX4 size + +#ifndef USE_PRELUDE + -- scans + , o_1_space_scans size + , o_1_space_scansX4 size +#endif ] , bgroup (o_n_stack_prefix moduleName) (o_n_stack_iterated size) , bgroup (o_n_heap_prefix moduleName) (o_n_heap_buffering size) diff --git a/benchmark/Streamly/Benchmark/Data/Stream/Split.hs b/benchmark/Streamly/Benchmark/Data/Stream/Split.hs --- a/benchmark/Streamly/Benchmark/Data/Stream/Split.hs +++ b/benchmark/Streamly/Benchmark/Data/Stream/Split.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -Wno-deprecations #-} -- | -- Module : Stream.Split @@ -25,26 +24,24 @@ import Data.Char (ord) import Data.Word (Word8) import System.IO (Handle) +import Streamly.Internal.Data.Array (Array) -import qualified Streamly.FileSystem.Handle as FH -import qualified Streamly.Internal.Data.Array as A -import qualified Streamly.Internal.Data.Fold as FL -import qualified Streamly.Internal.Data.Parser as PR -import qualified Streamly.Internal.Data.Stream.IsStream as IP -import qualified Streamly.Internal.FileSystem.Handle as IFH -import qualified Streamly.Internal.Unicode.Stream as IUS -import qualified Streamly.Prelude as S +import qualified Streamly.Internal.Data.Array as Array +import qualified Streamly.Internal.Data.Fold as Fold +import qualified Streamly.Internal.Data.Stream as Stream +import qualified Streamly.Internal.FileSystem.Handle as Handle +import qualified Streamly.Internal.Unicode.Stream as Unicode -import Gauge hiding (env) +import Test.Tasty.Bench hiding (env) import Prelude hiding (last, length) import Streamly.Benchmark.Common import Streamly.Benchmark.Common.Handle #ifdef INSPECTION -import Streamly.Internal.Data.Stream.StreamD.Type (Step(..)) +import Streamly.Internal.Data.Stream (Step(..)) -import qualified Streamly.Internal.Data.Array.Mut.Type as MA -import qualified Streamly.Internal.Data.Unfold as IUF +import qualified Streamly.Internal.Data.MutArray as MutArray +import qualified Streamly.Internal.Data.Unfold as Unfold import Test.Inspection #endif @@ -56,102 +53,106 @@ lf :: Word8 lf = fromIntegral (ord '\n') -toarr :: String -> A.Array Word8 -toarr = A.fromList . map (fromIntegral . ord) +toarr :: String -> Array Word8 +toarr = Array.fromList . map (fromIntegral . ord) -- | Split on line feed. splitOn :: Handle -> IO Int splitOn inh = - (S.length $ S.splitOn (== lf) FL.drain - $ S.unfold FH.read inh) -- >>= print + (Stream.fold Fold.length + $ Stream.splitSepBy_ (== lf) Fold.drain + $ Handle.read inh) -- >>= print #ifdef INSPECTION inspect $ hasNoTypeClasses 'splitOn inspect $ 'splitOn `hasNoType` ''Step -inspect $ 'splitOn `hasNoType` ''IUF.ConcatState -- FH.read/UF.many -inspect $ 'splitOn `hasNoType` ''MA.ArrayUnsafe -- FH.read/A.read -#endif - --- | Split suffix on line feed. -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` ''IUF.ConcatState -- FH.read/UF.many -inspect $ 'splitOnSuffix `hasNoType` ''MA.ArrayUnsafe -- FH.read/A.read -#endif - --- | Split suffix with line feed. -splitWithSuffix :: Handle -> IO Int -splitWithSuffix inh = - (S.length $ S.splitWithSuffix (== lf) FL.drain - $ S.unfold FH.read inh) -- >>= print - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'splitWithSuffix -inspect $ 'splitWithSuffix `hasNoType` ''Step -inspect $ 'splitWithSuffix `hasNoType` ''IUF.ConcatState -- FH.read/UF.many -inspect $ 'splitWithSuffix `hasNoType` ''MA.ArrayUnsafe -- FH.read/A.read +inspect $ 'splitOn `hasNoType` ''Unfold.ConcatState -- FH.read/UF.many +inspect $ 'splitOn `hasNoType` ''MutArray.ArrayUnsafe -- FH.read/A.read #endif --- | Split on line feed. -foldManySepBy :: Handle -> IO Int -foldManySepBy inh = - (S.length - $ IP.foldMany - (FL.takeEndBy_ (== lf) FL.drain) - (S.unfold FH.read inh) - ) -- >>= print - --- | Split on line feed. -parseManySepBy :: Handle -> IO Int -parseManySepBy inh = - (S.length - $ IP.parseMany - (PR.fromFold $ FL.takeEndBy_ (== lf) FL.drain) - (S.unfold FH.read inh) - ) -- >>= print - -- | Words by space wordsBy :: Handle -> IO Int wordsBy inh = - (S.length $ S.wordsBy isSp FL.drain - $ S.unfold FH.read inh) -- >>= print + Stream.fold Fold.length + $ Stream.wordsBy isSp Fold.drain + $ Handle.read inh -- >>= print #ifdef INSPECTION inspect $ hasNoTypeClasses 'wordsBy inspect $ 'wordsBy `hasNoType` ''Step -inspect $ 'wordsBy `hasNoType` ''IUF.ConcatState -- FH.read/UF.many -inspect $ 'wordsBy `hasNoType` ''MA.ArrayUnsafe -- FH.read/A.read +inspect $ 'wordsBy `hasNoType` ''Unfold.ConcatState -- FH.read/UF.many +inspect $ 'wordsBy `hasNoType` ''MutArray.ArrayUnsafe -- FH.read/A.read #endif -- | Split on a word8 sequence. splitOnSeq :: String -> Handle -> IO Int splitOnSeq str inh = - (S.length $ IP.splitOnSeq (toarr str) FL.drain - $ S.unfold FH.read inh) -- >>= print + (Stream.fold Fold.length $ Stream.splitSepBySeq_ (toarr str) Fold.drain + $ Handle.read inh) -- >>= print #ifdef INSPECTION -- inspect $ hasNoTypeClasses 'splitOnSeq -- inspect $ 'splitOnSeq `hasNoType` ''Step #endif +takeEndBy :: Word8 -> Handle -> IO Int +takeEndBy c inh = + (Stream.fold Fold.length + $ Stream.takeEndBy (== c) + $ Stream.filter (/= fromIntegral (ord 'a')) + $ Handle.read inh) -- >>= print + +takeEndBy_ :: Word8 -> Handle -> IO Int +takeEndBy_ c inh = + (Stream.fold Fold.length + $ Stream.takeEndBy_ (== c) + $ Stream.filter (/= fromIntegral (ord 'a')) + $ Handle.read inh) -- >>= print + +takeEndBySeq :: String -> Handle -> IO Int +takeEndBySeq str inh = + (Stream.fold Fold.length + $ Stream.takeEndBySeq (toarr str) + $ Stream.filter (/= fromIntegral (ord 'a')) + $ Handle.read inh) -- >>= print + +takeEndBySeq_ :: String -> Handle -> IO Int +takeEndBySeq_ str inh = + (Stream.fold Fold.length + $ Stream.takeEndBySeq_ (toarr str) + $ Stream.filter (/= fromIntegral (ord 'a')) + $ Handle.read inh) -- >>= print + +takeEndBySeq100k :: Handle -> IO Int +takeEndBySeq100k inh = do + arr <- Stream.fold Array.create $ Stream.replicate 100000 123 + (Stream.fold Fold.length + $ Stream.takeEndBySeq arr + $ Stream.filter (/= fromIntegral (ord 'a')) + $ Handle.read inh) -- >>= print + +takeEndBySeq_100k :: Handle -> IO Int +takeEndBySeq_100k inh = do + arr <- Stream.fold Array.create $ Stream.replicate 100000 123 + (Stream.fold Fold.length + $ Stream.takeEndBySeq_ arr + $ Stream.filter (/= fromIntegral (ord 'a')) + $ Handle.read inh) -- >>= print + -- | Split on a word8 sequence. splitOnSeq100k :: Handle -> IO Int splitOnSeq100k inh = do - arr <- A.fromStream $ IP.toStream $ S.fromSerial $ S.replicate 100000 123 - (S.length $ IP.splitOnSeq arr FL.drain - $ S.unfold FH.read inh) -- >>= print + arr <- Stream.fold Array.create $ Stream.replicate 100000 123 + (Stream.fold Fold.length + $ Stream.splitSepBySeq_ arr Fold.drain + $ Handle.read inh) -- >>= print -- | Split on suffix sequence. splitOnSuffixSeq :: String -> Handle -> IO Int splitOnSuffixSeq str inh = - (S.length $ IP.splitOnSuffixSeq (toarr str) FL.drain - $ S.unfold FH.read inh) -- >>= print + (Stream.fold Fold.length + $ Stream.splitOnSuffixSeq False (toarr str) Fold.drain + $ Handle.read inh) -- >>= print #ifdef INSPECTION -- inspect $ hasNoTypeClasses 'splitOnSuffixSeq @@ -161,76 +162,135 @@ -- | Split on suffix sequence. splitWithSuffixSeq :: String -> Handle -> IO Int splitWithSuffixSeq str inh = - S.length $ IP.splitWithSuffixSeq (toarr str) FL.drain - $ S.unfold FH.read inh -- >>= print + Stream.fold Fold.length + $ Stream.splitOnSuffixSeq True (toarr str) Fold.drain + $ Handle.read inh -- >>= print o_1_space_reduce_read_split :: BenchEnv -> [Benchmark] o_1_space_reduce_read_split env = - [ bgroup "split" - [ mkBench "S.foldMany (FL.takeEndBy_ (== lf) FL.drain)" env - $ \inh _ -> foldManySepBy inh - , mkBench "S.parseMany (FL.takeEndBy_ (== lf) FL.drain)" env - $ \inh _ -> parseManySepBy inh - , mkBench "S.wordsBy isSpace FL.drain" env $ \inh _ -> - wordsBy inh - , mkBench "S.splitOn (== lf) FL.drain" env $ \inh _ -> + -- NOTE: keep the benchmark names consistent with Data.Fold.takeEndBy* + [ bgroup "FileSplitElem" + [ mkBench "splitOn infix lf" env $ \inh _ -> splitOn inh - , mkBench "S.splitOnSuffix (== lf) FL.drain" env $ \inh _ -> - splitOnSuffix inh - , mkBench "S.splitWithSuffix (== lf) FL.drain" env $ \inh _ -> - splitWithSuffix inh - , mkBench "S.splitOnSeq \"\" FL.drain" env $ \inh _ -> + ] + -- splitting on a sequence + , bgroup "FileSplitSeq" + [ + mkBench "wordsBy infix isSpace" env $ \inh _ -> + wordsBy inh + + -- Infix + , mkBench "splitOnSeq empty infix" env $ \inh _ -> splitOnSeq "" inh - , mkBench "S.splitOnSuffixSeq \"\" FL.drain" env $ \inh _ -> - splitOnSuffixSeq "" inh - , mkBench "S.splitOnSeq \"\\n\" FL.drain" env $ \inh _ -> + , mkBench "splitOnSeq single infix lf" env $ \inh _ -> splitOnSeq "\n" inh - , mkBench "S.splitOnSuffixSeq \"\\n\" FL.drain" env $ \inh _ -> - splitOnSuffixSeq "\n" inh - , mkBench "S.splitOnSeq \"a\" FL.drain" env $ \inh _ -> + , mkBench "splitOnSeq single infix a" env $ \inh _ -> splitOnSeq "a" inh - , mkBench "S.splitOnSeq \"\\r\\n\" FL.drain" env $ \inh _ -> + , mkBench "splitOnSeq word infix crlf" env $ \inh _ -> splitOnSeq "\r\n" inh - , mkBench "S.splitOnSuffixSeq \"\\r\\n\" FL.drain" env $ \inh _ -> - splitOnSuffixSeq "\r\n" inh - , mkBench "S.splitWithSuffixSeq \"\\r\\n\" FL.drain" env $ \inh _ -> - splitWithSuffixSeq "\r\n" inh - , mkBench "S.splitOnSeq \"aa\" FL.drain" env $ \inh _ -> + , mkBench "splitOnSeq word infix aa" env $ \inh _ -> splitOnSeq "aa" inh - , mkBench "S.splitOnSeq \"aaaa\" FL.drain" env $ \inh _ -> + , mkBench "splitOnSeq word infix aaaa" env $ \inh _ -> splitOnSeq "aaaa" inh - , mkBench "S.splitOnSeq \"abcdefgh\" FL.drain" env $ \inh _ -> + , mkBench "splitOnSeq word infix abcdefgh" env $ \inh _ -> splitOnSeq "abcdefgh" inh - , mkBench "S.splitOnSeq \"abcdefghi\" FL.drain" env $ \inh _ -> + , mkBench "splitOnSeq KR infix abcdefghi" env $ \inh _ -> splitOnSeq "abcdefghi" inh - , mkBench "S.splitOnSeq \"catcatcatcatcat\" FL.drain" env $ \inh _ -> + , mkBench "splitOnSeq KR infix catcatcatcatcat" env $ \inh _ -> splitOnSeq "catcatcatcatcat" inh - , mkBench "S.splitOnSeq \"abcdefghijklmnopqrstuvwxyz\" FL.drain" + , mkBench "splitOnSeq KR infix abcdefghijklmnopqrstuvwxyz" env $ \inh _ -> splitOnSeq "abcdefghijklmnopqrstuvwxyz" inh - , mkBench "S.splitOnSeq 100k long pattern" + , mkBench "splitOnSeq KR infix 100k long pattern" env $ \inh _ -> splitOnSeq100k inh - , mkBenchSmall "S.splitOnSuffixSeq \"abcdefghijklmnopqrstuvwxyz\" FL.drain" + + -- Suffix + , mkBench "splitOnSuffixSeq empty suffix" env $ \inh _ -> + splitOnSuffixSeq "" inh + , mkBench "splitOnSuffixSeq single suffix lf" env $ \inh _ -> + splitOnSuffixSeq "\n" inh + , mkBench "splitOnSuffixSeq word suffix crlf" env $ \inh _ -> + splitOnSuffixSeq "\r\n" inh + , mkBenchSmall "splitOnSuffixSeq KR suffix abcdefghijklmnopqrstuvwxyz" env $ \inh _ -> splitOnSuffixSeq "abcdefghijklmnopqrstuvwxyz" inh - , mkBenchSmall "S.splitWithSuffixSeq \"abcdefghijklmnopqrstuvwxyz\" FL.drain" + + -- Suffix with separator + , mkBench "splitWithSuffixSeq single suffix lf" env $ \inh _ -> + splitWithSuffixSeq "\n" inh + , mkBench "splitWithSuffixSeq word suffix crlf" env $ \inh _ -> + splitWithSuffixSeq "\r\n" inh + , mkBench "splitWithSuffixSeq KR suffix abcdefghi" env $ \inh _ -> + splitWithSuffixSeq "abcdefghi" inh + , mkBenchSmall "splitWithSuffixSeq KR suffix abcdefghijklmnopqrstuvwxyz" env $ \inh _ -> splitWithSuffixSeq "abcdefghijklmnopqrstuvwxyz" inh ] + + , bgroup "FileTakeSeq" + [ + {- + mkBench "takeEndBySeq empty" env $ \inh _ -> + takeEndBySeq "" inh + -} + -- IMPORTANT: the pattern must contain a, because we filter a's out + -- from the stream so that we do not terminate too early and + -- unpredictably. + mkBench "takeEndBy" env $ \inh _ -> + takeEndBy (fromIntegral $ ord 'a') inh + , mkBench "takeEndBy_" env $ \inh _ -> + takeEndBy_ (fromIntegral $ ord 'a') inh + , mkBench "takeEndBySeq single a" env $ \inh _ -> + takeEndBySeq "a" inh + , mkBench "takeEndBySeq word aa" env $ \inh _ -> + takeEndBySeq "aa" inh + , mkBench "takeEndBySeq word aaaa" env $ \inh _ -> + takeEndBySeq "aaaa" inh + , mkBench "takeEndBySeq word abcdefgh" env $ \inh _ -> + takeEndBySeq "abcdefgh" inh + , mkBench "takeEndBySeq KR abcdefghi" env $ \inh _ -> + takeEndBySeq "abcdefghi" inh + , mkBench "takeEndBySeq KR catcatcatcatcat" env $ \inh _ -> + takeEndBySeq "catcatcatcatcat" inh + , mkBench "takeEndBySeq KR abcdefghijklmnopqrstuvwxyz" + env $ \inh _ -> takeEndBySeq "abcdefghijklmnopqrstuvwxyz" inh + , mkBench "takeEndBySeq KR 100k long pattern" + env $ \inh _ -> takeEndBySeq100k inh + + {- + , mkBench "takeEndBySeq_ empty" env $ \inh _ -> + takeEndBySeq_ "" inh + -} + , mkBench "takeEndBySeq_ single a" env $ \inh _ -> + takeEndBySeq_ "a" inh + , mkBench "takeEndBySeq_ word aa" env $ \inh _ -> + takeEndBySeq_ "aa" inh + , mkBench "takeEndBySeq_ word aaaa" env $ \inh _ -> + takeEndBySeq_ "aaaa" inh + , mkBench "takeEndBySeq_ word abcdefgh" env $ \inh _ -> + takeEndBySeq_ "abcdefgh" inh + , mkBench "takeEndBySeq_ KR abcdefghi" env $ \inh _ -> + takeEndBySeq_ "abcdefghi" inh + , mkBench "takeEndBySeq_ KR catcatcatcatcat" env $ \inh _ -> + takeEndBySeq_ "catcatcatcatcat" inh + , mkBench "takeEndBySeq_ KR abcdefghijklmnopqrstuvwxyz" + env $ \inh _ -> takeEndBySeq_ "abcdefghijklmnopqrstuvwxyz" inh + , mkBench "takeEndBySeq_ KR 100k long pattern" + env $ \inh _ -> takeEndBySeq_100k inh + ] ] -- | Split on a character sequence. splitOnSeqUtf8 :: String -> Handle -> IO Int splitOnSeqUtf8 str inh = - (S.length $ IP.splitOnSeq (A.fromList str) FL.drain - $ IP.fromStream - $ IUS.decodeUtf8Arrays - $ IFH.readChunks inh) -- >>= print + (Stream.fold Fold.length + $ Stream.splitSepBySeq_ (Array.fromList str) Fold.drain + $ Unicode.decodeUtf8Chunks + $ Handle.readChunks inh) -- >>= print o_1_space_reduce_toChunks_split :: BenchEnv -> [Benchmark] o_1_space_reduce_toChunks_split env = - [ bgroup "split/toChunks" - [ mkBenchSmall ("S.splitOnSeqUtf8 \"abcdefgh\" FL.drain " - ++ ". US.decodeUtf8Arrays") env $ \inh _ -> - splitOnSeqUtf8 "abcdefgh" inh - , mkBenchSmall "S.splitOnSeqUtf8 \"abcdefghijklmnopqrstuvwxyz\" FL.drain" + [ bgroup "FileSplitSeqUtf8" + [ mkBenchSmall "splitOnSeqUtf8 word abcdefgh" + env $ \inh _ -> splitOnSeqUtf8 "abcdefgh" inh + , mkBenchSmall "splitOnSeqUtf8 KR abcdefghijklmnopqrstuvwxyz" env $ \inh _ -> splitOnSeqUtf8 "abcdefghijklmnopqrstuvwxyz" inh ] ] diff --git a/benchmark/Streamly/Benchmark/Data/Stream/StreamD.hs b/benchmark/Streamly/Benchmark/Data/Stream/StreamD.hs --- a/benchmark/Streamly/Benchmark/Data/Stream/StreamD.hs +++ b/benchmark/Streamly/Benchmark/Data/Stream/StreamD.hs @@ -22,15 +22,17 @@ module Main (main) where +#if !MIN_VERSION_base(4,18,0) import Control.Applicative (liftA2) +#endif import Control.Monad (when) import Data.Maybe (isJust) -import Gauge (bench, nfIO, bgroup, Benchmark, defaultMain) +import Test.Tasty.Bench (bench, nfIO, bgroup, Benchmark, defaultMain) import System.Random (randomRIO) import Prelude hiding (tail, mapM_, foldl, last, map, mapM, concatMap, zip) import qualified Prelude as P -import qualified Streamly.Internal.Data.Stream.StreamD as S +import qualified Streamly.Internal.Data.Stream as S import qualified Streamly.Internal.Data.Unfold as UF import qualified Streamly.Internal.Data.Fold as FL @@ -446,7 +448,7 @@ unfoldManyRepl :: Int -> Int -> Int -> IO () unfoldManyRepl outer inner n = S.drain - $ S.unfoldMany + $ S.unfoldEach UF.replicateM (S.map ((inner,) . return) (sourceUnfoldrMN outer n)) @@ -461,7 +463,7 @@ ------------------------------------------------------------------------------- moduleName :: String -moduleName = "Data.Stream.StreamD" +moduleName = "Data.StreamD" o_1_space :: [Benchmark] o_1_space = diff --git a/benchmark/Streamly/Benchmark/Data/Stream/StreamDK.hs b/benchmark/Streamly/Benchmark/Data/Stream/StreamDK.hs deleted file mode 100644 --- a/benchmark/Streamly/Benchmark/Data/Stream/StreamDK.hs +++ /dev/null @@ -1,455 +0,0 @@ -{-# OPTIONS_GHC -Wno-deprecations #-} - --- | --- Module : Streamly.Benchmark.Data.Stream.StreamDK --- Copyright : (c) 2018 Composewell Technologies --- --- License : BSD3 --- Maintainer : streamly@composewell.com - -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Main (main) where - --- import Control.Monad (when) --- import Data.Maybe (isJust) -import Prelude hiding () --- import qualified Prelude as P --- import qualified Data.List as List - -import qualified Streamly.Internal.Data.Stream.StreamDK as S --- import qualified Streamly.Internal.Data.Stream.Common as SP --- import qualified Streamly.Internal.Data.SVar as S - -import Streamly.Benchmark.Common -import Gauge (bgroup, Benchmark, defaultMain) - -value :: Int -value = 100000 -{- -value2, value3, value16, maxValue :: Int -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.fromPure [n..n+value] - -{-# INLINE sourceFoldMapWithM #-} -sourceFoldMapWithM :: Monad m => Int -> Stream m Int -sourceFoldMapWithM n = SP.foldMapWith S.serial (S.fromEffect . return) [n..n+value] --} - -------------------------------------------------------------------------------- --- 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 [] --} - -------------------------------------------------------------------------------- --- Benchmarks -------------------------------------------------------------------------------- - -moduleName :: String -moduleName = "Data.Stream.StreamDK" - -o_1_space :: [Benchmark] -o_1_space = - [ bgroup (o_1_space_prefix moduleName) - [ bgroup "generation" - [ benchFold "unfoldr" toNull sourceUnfoldr - , benchFold "unfoldrM" toNull sourceUnfoldrM - ] - , bgroup "elimination" - [ benchFold "toNull" toNull sourceUnfoldrM - , benchFold "uncons" uncons sourceUnfoldrM - ] - ] - ] - -main :: IO () -main = defaultMain $ concat [o_1_space] diff --git a/benchmark/Streamly/Benchmark/Data/Stream/StreamK.hs b/benchmark/Streamly/Benchmark/Data/Stream/StreamK.hs deleted file mode 100644 --- a/benchmark/Streamly/Benchmark/Data/Stream/StreamK.hs +++ /dev/null @@ -1,933 +0,0 @@ --- | --- Module : Streamly.Benchmark.Data.Stream.StreamK --- Copyright : (c) 2018 Composewell Technologies --- --- License : BSD3 --- Maintainer : streamly@composewell.com - -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wno-orphans #-} - -#ifdef __HADDOCK_VERSION__ -#undef INSPECTION -#endif - -#ifdef INSPECTION -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-} -#endif - -module Main (main) where - -import Control.Applicative (liftA2) -import Control.Monad (when) -import Data.Maybe (isJust) -import System.Random (randomRIO) -import Prelude hiding - ( tail, mapM_, foldl, last, map, mapM, concatMap, zipWith, init, iterate - , repeat, replicate - ) - -import qualified Prelude as P -import qualified Data.List as List - -import qualified Streamly.Internal.Data.Stream.StreamK.Type as S -import qualified Streamly.Internal.Data.Stream.StreamK as S - -import Gauge (bench, nfIO, bgroup, Benchmark, defaultMain) - -import Streamly.Benchmark.Common - -#ifdef INSPECTION -import Test.Inspection -#endif - -{- - -Benchmarks that need to be added - --- fromList - --- bindWith --- concatPairsWith --- apWith --- apSerial --- apSerialDiscardFst --- apSerialDiscardSnd - --- the --- serial --- consMStream --- withLocal --- mfix - --- elem --- notElem --- all --- any --- minimum --- minimumBy --- maximum --- maximumBy --- findIndices --- lookup --- findM --- find --- (!!) - --- foldlM' --- foldlT --- foldlx' --- foldlMx' --- fold - --- sequence - --- foldrSM --- buildS --- buildM --- augmentS --- augmentSM --- foldr --- foldr1 --- foldrM --- foldrT - --- intersperseM --- insertBy --- deleteBy --- reverse --- mapMaybe - --- zipWithM --- mergeBy --- mergeByM - --- toStreamK (Probably can be skipped) --- hoist - --- scanlx' - --} - -------------------------------------------------------------------------------- --- Stream generation and elimination -------------------------------------------------------------------------------- - -type Stream m a = S.StreamK m a - -{-# INLINE unfoldr #-} -unfoldr :: Int -> Int -> Stream m Int -unfoldr streamLen n = S.unfoldr step n - where - step cnt = - if cnt > n + streamLen - then Nothing - else Just (cnt, cnt + 1) - -{-# INLINE unfoldrM #-} -unfoldrM :: Monad m => Int -> Int -> Stream m Int -unfoldrM streamLen n = S.unfoldrMWith S.consM step n - where - step cnt = - if cnt > n + streamLen - then return Nothing - else return (Just (cnt, cnt + 1)) - -{-# INLINE repeat #-} -repeat :: Int -> Int -> Stream m Int -repeat streamLen = S.take streamLen . S.repeat - -{-# INLINE repeatM #-} -repeatM :: Monad m => Int -> Int -> Stream m Int -repeatM streamLen = S.take streamLen . S.repeatM . return - -{-# INLINE replicate #-} -replicate :: Int -> Int -> Stream m Int -replicate = S.replicate - -{-# INLINE replicateM #-} -replicateM :: Monad m => Int -> Int -> Stream m Int -replicateM streamLen = S.replicateMWith S.consM streamLen . return - -{-# INLINE iterate #-} -iterate :: Int -> Int -> Stream m Int -iterate streamLen = S.take streamLen . S.iterate (+1) - -{-# INLINE iterateM #-} -iterateM :: Monad m => Int -> Int -> Stream m Int -iterateM streamLen = S.take streamLen . S.iterateM (return . (+1)) . return - -{-# INLINE fromFoldable #-} -fromFoldable :: Int -> Int -> Stream m Int -fromFoldable streamLen n = S.fromFoldable [n..n+streamLen] - -{-# INLINE fromFoldableM #-} -fromFoldableM :: Monad m => Int -> Int -> Stream m Int -fromFoldableM streamLen n = - Prelude.foldr S.consM S.nil (Prelude.fmap return [n..n+streamLen]) - -{-# INLINABLE concatMapFoldableWith #-} -concatMapFoldableWith :: Foldable f - => (Stream m b -> Stream m b -> Stream m b) - -> (a -> Stream m b) - -> f a - -> Stream m b -concatMapFoldableWith f g = Prelude.foldr (f . g) S.nil - -{-# INLINE concatMapFoldableSerial #-} -concatMapFoldableSerial :: Int -> Int -> Stream m Int -concatMapFoldableSerial streamLen n = - concatMapFoldableWith S.append S.fromPure [n..n+streamLen] - -{-# INLINE concatMapFoldableSerialM #-} -concatMapFoldableSerialM :: Monad m => Int -> Int -> Stream m Int -concatMapFoldableSerialM streamLen n = - concatMapFoldableWith S.append (S.fromEffect . return) [n..n+streamLen] - -------------------------------------------------------------------------------- --- Elimination -------------------------------------------------------------------------------- - -{-# INLINE drain #-} -drain :: Monad m => Stream m a -> m () -drain = S.drain - -{-# INLINE mapM_ #-} -mapM_ :: Monad m => Stream m a -> m () -mapM_ = S.mapM_ (\_ -> return ()) - -{-# 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 = do - t <- S.init s - P.mapM_ S.drain t - -{-# INLINE tail #-} -tail :: Monad m => Stream m a -> m () -tail s = S.tail s >>= P.mapM_ tail - -{-# INLINE nullTail #-} -nullTail :: Monad m => Stream m Int -> m () -nullTail s = do - r <- S.null s - when (not r) $ S.tail s >>= P.mapM_ nullTail - -{-# INLINE headTail #-} -headTail :: Monad m => Stream m Int -> m () -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 composeN #-} -composeN - :: Monad m - => Int -> (Stream m Int -> Stream m Int) -> Stream m Int -> m () -composeN n f = - case n of - 1 -> drain . f - 2 -> drain . f . f - 3 -> drain . f . f . f - 4 -> drain . f . f . f . f - _ -> undefined - -{-# INLINE scanl' #-} -scanl' :: Monad m => Int -> Stream m Int -> m () -scanl' n = composeN n $ S.scanl' (+) 0 - -{-# INLINE map #-} -map :: Monad m => Int -> Stream m Int -> m () -map n = composeN n $ S.map (+ 1) - -{-# INLINE fmapK #-} -fmapK :: Monad m => Int -> Stream m Int -> m () -fmapK n = composeN n $ P.fmap (+ 1) - -{-# INLINE mapM #-} -mapM :: Monad m => Int -> Stream m Int -> m () -mapM n = composeN n $ S.mapMWith S.consM return - -{-# INLINE mapMSerial #-} -mapMSerial :: Monad m => Int -> Stream m Int -> m () -mapMSerial n = composeN n $ S.mapMSerial return - -{-# INLINE filterEven #-} -filterEven :: Monad m => Int -> Stream m Int -> m () -filterEven n = composeN n $ S.filter even - -{-# INLINE filterAllOut #-} -filterAllOut :: Monad m => Int -> Int -> Stream m Int -> m () -filterAllOut streamLen n = composeN n $ S.filter (> streamLen) - -{-# INLINE filterAllIn #-} -filterAllIn :: Monad m => Int -> Int -> Stream m Int -> m () -filterAllIn streamLen n = composeN n $ S.filter (<= streamLen) - -{-# INLINE _takeOne #-} -_takeOne :: Monad m => Int -> Stream m Int -> m () -_takeOne n = composeN n $ S.take 1 - -{-# INLINE takeAll #-} -takeAll :: Monad m => Int -> Int -> Stream m Int -> m () -takeAll streamLen n = composeN n $ S.take streamLen - -{-# INLINE takeWhileTrue #-} -takeWhileTrue :: Monad m => Int -> Int -> Stream m Int -> m () -takeWhileTrue streamLen n = composeN n $ S.takeWhile (<= streamLen) - -{-# INLINE dropOne #-} -dropOne :: Monad m => Int -> Stream m Int -> m () -dropOne n = composeN n $ S.drop 1 - -{-# INLINE dropAll #-} -dropAll :: Monad m => Int -> Int -> Stream m Int -> m () -dropAll streamLen n = composeN n $ S.drop streamLen - -{-# INLINE dropWhileTrue #-} -dropWhileTrue :: Monad m => Int -> Int -> Stream m Int -> m () -dropWhileTrue streamLen n = composeN n $ S.dropWhile (<= streamLen) - -{-# INLINE dropWhileFalse #-} -dropWhileFalse :: Monad m => Int -> Stream m Int -> m () -dropWhileFalse n = composeN n $ S.dropWhile (<= 1) - -{-# INLINE foldrS #-} -foldrS :: Monad m => Int -> Stream m Int -> m () -foldrS n = composeN n $ S.foldrS S.cons S.nil - -{-# INLINE foldlS #-} -foldlS :: Monad m => Int -> Stream m Int -> m () -foldlS n = composeN n $ S.foldlS (flip S.cons) S.nil - -{-# INLINE intersperse #-} -intersperse :: Monad m => Int -> Int -> Stream m Int -> m () -intersperse streamLen n = composeN n $ S.intersperse streamLen - -------------------------------------------------------------------------------- --- Iteration -------------------------------------------------------------------------------- - -{-# INLINE iterateSource #-} -iterateSource - :: Monad m => Int -> (Stream m Int -> Stream m Int) -> Int -> Int -> Stream m Int -iterateSource iterStreamLen g i n = f i (unfoldrM iterStreamLen n) - where - f (0 :: Int) m = g m - f x m = g (f (x P.- 1) m) - --- this is quadratic -{-# INLINE iterateScan #-} -iterateScan :: Monad m => Int -> Int -> Int -> Stream m Int -iterateScan iterStreamLen maxIters = - iterateSource iterStreamLen (S.scanl' (+) 0) (maxIters `div` 10) - --- this is quadratic -{-# INLINE iterateDropWhileFalse #-} -iterateDropWhileFalse :: Monad m => Int -> Int -> Int -> Int -> Stream m Int -iterateDropWhileFalse streamLen iterStreamLen maxIters = - iterateSource iterStreamLen (S.dropWhile (> streamLen)) (maxIters `div` 10) - -{-# INLINE iterateMapM #-} -iterateMapM :: Monad m => Int -> Int -> Int -> Stream m Int -iterateMapM iterStreamLen = - iterateSource iterStreamLen (S.mapMWith S.consM return) - -{-# INLINE iterateFilterEven #-} -iterateFilterEven :: Monad m => Int -> Int -> Int -> Stream m Int -iterateFilterEven iterStreamLen = iterateSource iterStreamLen (S.filter even) - -{-# INLINE iterateTakeAll #-} -iterateTakeAll :: Monad m => Int -> Int -> Int -> Int -> Stream m Int -iterateTakeAll streamLen iterStreamLen = - iterateSource iterStreamLen (S.take streamLen) - -{-# INLINE iterateDropOne #-} -iterateDropOne :: Monad m => Int -> Int -> Int -> Stream m Int -iterateDropOne iterStreamLen = iterateSource iterStreamLen (S.drop 1) - -{-# INLINE iterateDropWhileTrue #-} -iterateDropWhileTrue :: - Monad m => Int -> Int -> Int -> Int -> Stream m Int -iterateDropWhileTrue streamLen iterStreamLen = - iterateSource iterStreamLen (S.dropWhile (<= streamLen)) - -------------------------------------------------------------------------------- --- Zipping -------------------------------------------------------------------------------- - -{-# INLINE zipWith #-} -zipWith :: Monad m => Stream m Int -> m () -zipWith src = drain $ S.zipWith (,) src src - -{-# INLINE zipWithM #-} -zipWithM :: Monad m => Stream m Int -> m () -zipWithM src = drain $ S.zipWithM (curry return) src src - -{-# INLINE sortByK #-} -sortByK :: (a -> a -> Ordering) -> Stream m a -> Stream m a -sortByK f = S.mergeMapWith (S.mergeBy f) S.fromPure - -{-# INLINE sortBy #-} -sortBy :: Monad m => Stream m Int -> m () -sortBy = drain . sortByK compare - -------------------------------------------------------------------------------- --- Mixed Composition -------------------------------------------------------------------------------- - -{-# INLINE scanMap #-} -scanMap :: Monad m => Int -> Stream m Int -> m () -scanMap n = composeN n $ S.map (subtract 1) . S.scanl' (+) 0 - -{-# INLINE dropMap #-} -dropMap :: Monad m => Int -> Stream m Int -> m () -dropMap n = composeN n $ S.map (subtract 1) . S.drop 1 - -{-# INLINE dropScan #-} -dropScan :: Monad m => Int -> Stream m Int -> m () -dropScan n = composeN n $ S.scanl' (+) 0 . S.drop 1 - -{-# INLINE takeDrop #-} -takeDrop :: Monad m => Int -> Int -> Stream m Int -> m () -takeDrop streamLen n = composeN n $ S.drop 1 . S.take streamLen - -{-# INLINE takeScan #-} -takeScan :: Monad m => Int -> Int -> Stream m Int -> m () -takeScan streamLen n = composeN n $ S.scanl' (+) 0 . S.take streamLen - -{-# INLINE takeMap #-} -takeMap :: Monad m => Int -> Int -> Stream m Int -> m () -takeMap streamLen n = composeN n $ S.map (subtract 1) . S.take streamLen - -{-# INLINE filterDrop #-} -filterDrop :: Monad m => Int -> Int -> Stream m Int -> m () -filterDrop streamLen n = composeN n $ S.drop 1 . S.filter (<= streamLen) - -{-# INLINE filterTake #-} -filterTake :: Monad m => Int -> Int -> Stream m Int -> m () -filterTake streamLen n = composeN n $ S.take streamLen . S.filter (<= streamLen) - -{-# INLINE filterScan #-} -filterScan :: Monad m => Int -> Stream m Int -> m () -filterScan n = composeN n $ S.scanl' (+) 0 . S.filter (<= maxBound) - -{-# INLINE filterMap #-} -filterMap :: Monad m => Int -> Int -> Stream m Int -> m () -filterMap streamLen n = composeN n $ S.map (subtract 1) . S.filter (<= streamLen) - -------------------------------------------------------------------------------- --- ConcatMap -------------------------------------------------------------------------------- - --- concatMap unfoldrM/unfoldrM - -{-# INLINE concatMap #-} -concatMap :: Int -> Int -> Int -> IO () -concatMap outer inner n = - S.drain $ S.concatMap - (\_ -> unfoldrM inner n) - (unfoldrM outer n) - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'concatMap -#endif - --- concatMap unfoldr/unfoldr - -{-# INLINE concatMapPure #-} -concatMapPure :: Int -> Int -> Int -> IO () -concatMapPure outer inner n = - S.drain $ S.concatMap - (\_ -> unfoldr inner n) - (unfoldr outer n) - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'concatMapPure -#endif - --- concatMap replicate/unfoldrM - -{-# INLINE concatMapRepl #-} -concatMapRepl :: Int -> Int -> Int -> IO () -concatMapRepl outer inner n = - S.drain $ S.concatMap (S.replicate inner) (unfoldrM outer n) - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'concatMapRepl -#endif - --- concatMapWith - -{-# INLINE sourceConcatMapId #-} -sourceConcatMapId :: Monad m - => Int -> Int -> Stream m (Stream m Int) -sourceConcatMapId val n = - S.fromFoldable $ fmap (S.fromEffect . return) [n..n+val] - -{-# INLINE concatMapBySerial #-} -concatMapBySerial :: Int -> Int -> Int -> IO () -concatMapBySerial outer inner n = - S.drain $ S.concatMapWith S.append - (unfoldrM inner) - (unfoldrM outer n) - -------------------------------------------------------------------------------- --- Nested Composition -------------------------------------------------------------------------------- - -instance Monad m => Applicative (S.StreamK m) where - {-# INLINE pure #-} - pure = S.fromPure - - {-# INLINE (<*>) #-} - (<*>) = S.crossApply - - {-# INLINE liftA2 #-} - liftA2 f x = (<*>) (fmap f x) - - {-# INLINE (*>) #-} - (*>) = S.crossApplySnd - - {-# INLINE (<*) #-} - (<*) = S.crossApplyFst - --- 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 (S.StreamK m) where - {-# INLINE return #-} - return = pure - - {-# INLINE (>>=) #-} - (>>=) = flip S.concatMap - -{-# INLINE drainApplicative #-} -drainApplicative :: Monad m => Stream m Int -> m () -drainApplicative s = drain $ do - (+) <$> s <*> s - -{-# INLINE drainMonad #-} -drainMonad :: Monad m => Stream m Int -> m () -drainMonad s = drain $ do - x <- s - y <- s - return $ x + y - -{-# INLINE drainMonad3 #-} -drainMonad3 :: Monad m => Stream m Int -> m () -drainMonad3 s = drain $ do - x <- s - y <- s - z <- s - return $ x + y + z - -{-# INLINE filterAllOutMonad #-} -filterAllOutMonad - :: Monad m - => Stream m Int -> m () -filterAllOutMonad str = drain $ do - x <- str - y <- str - let s = x + y - if s < 0 - then return s - else S.nil - -{-# INLINE filterAllInMonad #-} -filterAllInMonad - :: Monad m - => Stream m Int -> m () -filterAllInMonad str = drain $ do - x <- str - y <- str - let s = x + y - if s > 0 - then return s - else S.nil - -------------------------------------------------------------------------------- --- Nested Composition Pure lists -------------------------------------------------------------------------------- - --- There are several list benchmarks here for comparison with lists. It is easy --- and convenient to see the comparisons when they are here, otherwise we'll --- have to add a separate module for list benchmarks with the same names and --- then add a comparison in bench.sh. - -{-# INLINE unfoldrList #-} -unfoldrList :: Int -> Int -> [Int] -unfoldrList 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 [] - -------------------------------------------------------------------------------- --- Benchmarks -------------------------------------------------------------------------------- - -moduleName :: String -moduleName = "Data.Stream.StreamK" - -o_1_space_generation :: Int -> Benchmark -o_1_space_generation streamLen = - bgroup "generation" - [ benchFold "unfoldr" drain (unfoldr streamLen) - , benchFold "unfoldrM" drain (unfoldrM streamLen) - , benchFold "repeat" drain (repeat streamLen) - , benchFold "repeatM" drain (repeatM streamLen) - , benchFold "replicate" drain (replicate streamLen) - , benchFold "replicateM" drain (replicateM streamLen) - , benchFold "iterate" drain (iterate streamLen) - , benchFold "iterateM" drain (iterateM streamLen) - - , benchFold "fromFoldable" drain (fromFoldable streamLen) - , benchFold "fromFoldableM" drain (fromFoldableM streamLen) - - -- appends - , benchFold "concatMapFoldableWith" drain (concatMapFoldableSerial streamLen) - , benchFold "concatMapFoldableWithM" drain (concatMapFoldableSerialM streamLen) - ] - -o_1_space_elimination :: Int -> Benchmark -o_1_space_elimination streamLen = - bgroup "elimination" - [ benchFold "toNull" drain (unfoldrM streamLen) - , benchFold "mapM_" mapM_ (unfoldrM streamLen) - , benchFold "uncons" uncons (unfoldrM streamLen) - , benchFold "init" init (unfoldrM streamLen) - , benchFold "foldl'" foldl' (unfoldrM streamLen) - , benchFold "last" last (unfoldrM streamLen) - ] - -o_1_space_nested :: Int -> Benchmark -o_1_space_nested streamLen = - bgroup "nested" - [ benchFold "drainApplicative" drainApplicative (unfoldrM streamLen2) - , benchFold "drainMonad" drainMonad (unfoldrM streamLen2) - , benchFold "drainMonad3" drainMonad3 (unfoldrM streamLen3) - , benchFold "filterAllInMonad" filterAllInMonad (unfoldrM streamLen2) - , benchFold "filterAllOutMonad" filterAllOutMonad (unfoldrM streamLen2) - , benchFold "drainApplicative (pure)" drainApplicative (unfoldr streamLen2) - , benchFold "drainMonad (pure)" drainMonad (unfoldr streamLen2) - , benchFold "drainMonad3 (pure)" drainMonad3 (unfoldr streamLen3) - , benchFold "filterAllInMonad (pure)" filterAllInMonad (unfoldr streamLen2) - , benchFold "filterAllOutMonad (pure)" filterAllOutMonad (unfoldr streamLen2) - ] - where - streamLen2 = round (P.fromIntegral streamLen**(1/2::P.Double)) -- double nested loop - streamLen3 = round (P.fromIntegral streamLen**(1/3::P.Double)) -- triple nested loop - -o_1_space_transformation :: Int -> Benchmark -o_1_space_transformation streamLen = - bgroup "transformation" - [ benchFold "foldrS" (foldrS 1) (unfoldrM streamLen) - , benchFold "scanl'" (scanl' 1) (unfoldrM streamLen) - , benchFold "map" (map 1) (unfoldrM streamLen) - , benchFold "fmap" (fmapK 1) (unfoldrM streamLen) - , benchFold "mapM" (mapM 1) (unfoldrM streamLen) - , benchFold "mapMSerial" (mapMSerial 1) (unfoldrM streamLen) - ] - -o_1_space_transformationX4 :: Int -> Benchmark -o_1_space_transformationX4 streamLen = - bgroup "transformationX4" - [ benchFold "scanl'" (scanl' 4) (unfoldrM streamLen) - , benchFold "map" (map 4) (unfoldrM streamLen) - , benchFold "fmap" (fmapK 4) (unfoldrM streamLen) - , benchFold "mapM" (mapM 4) (unfoldrM streamLen) - , benchFold "mapMSerial" (mapMSerial 4) (unfoldrM streamLen) - -- XXX this is horribly slow - -- , benchFold "concatMap" (concatMap 4) (unfoldrM streamLen16) - ] - -o_1_space_concat :: Int -> Benchmark -o_1_space_concat streamLen = - bgroup "concat" - [ benchIOSrc1 "concatMapPure (n of 1)" - (concatMapPure streamLen 1) - , benchIOSrc1 "concatMapPure (sqrt n of sqrt n)" - (concatMapPure streamLen2 streamLen2) - , benchIOSrc1 "concatMapPure (1 of n)" - (concatMapPure 1 streamLen) - - , benchIOSrc1 "concatMap (n of 1)" - (concatMap streamLen 1) - , benchIOSrc1 "concatMap (sqrt n of sqrt n)" - (concatMap streamLen2 streamLen2) - , benchIOSrc1 "concatMap (1 of n)" - (concatMap 1 streamLen) - - , benchIOSrc1 "concatMapRepl (sqrt n of sqrt n)" - (concatMapRepl streamLen2 streamLen2) - - -- This is for comparison with concatMapFoldableWith - , benchIOSrc1 "concatMapWithId (n of 1) (fromFoldable)" - (S.drain - . S.concatMapWith S.append id - . sourceConcatMapId streamLen) - - , benchIOSrc1 "concatMapBy serial (n of 1)" - (concatMapBySerial streamLen 1) - , benchIOSrc1 "concatMapBy serial (sqrt n of sqrt n)" - (concatMapBySerial streamLen2 streamLen2) - , benchIOSrc1 "concatMapBy serial (1 of n)" - (concatMapBySerial 1 streamLen) - , benchFold "sortBy" sortBy (unfoldrM streamLen) - ] - where - streamLen2 = round (P.fromIntegral streamLen**(1/2::P.Double)) -- double nested loop - -o_1_space_filtering :: Int -> Benchmark -o_1_space_filtering streamLen = - bgroup "filtering" - [ benchFold "filter-even" (filterEven 1) (unfoldrM streamLen) - , benchFold "filter-all-out" (filterAllOut streamLen 1) (unfoldrM streamLen) - , benchFold "filter-all-in" (filterAllIn streamLen 1) (unfoldrM streamLen) - , benchFold "take-all" (takeAll streamLen 1) (unfoldrM streamLen) - , benchFold "takeWhile-true" (takeWhileTrue streamLen 1) (unfoldrM streamLen) - , benchFold "drop-one" (dropOne 1) (unfoldrM streamLen) - , benchFold "drop-all" (dropAll streamLen 1) (unfoldrM streamLen) - , benchFold "dropWhile-true" (dropWhileTrue streamLen 1) (unfoldrM streamLen) - , benchFold "dropWhile-false" (dropWhileFalse 1) (unfoldrM streamLen) - ] - -o_1_space_filteringX4 :: Int -> Benchmark -o_1_space_filteringX4 streamLen = - bgroup "filteringX4" - [ benchFold "filter-even" (filterEven 4) (unfoldrM streamLen) - , benchFold "filter-all-out" (filterAllOut streamLen 4) (unfoldrM streamLen) - , benchFold "filter-all-in" (filterAllIn streamLen 4) (unfoldrM streamLen) - , benchFold "take-all" (takeAll streamLen 4) (unfoldrM streamLen) - , benchFold "takeWhile-true" (takeWhileTrue streamLen 4) (unfoldrM streamLen) - , benchFold "drop-one" (dropOne 4) (unfoldrM streamLen) - , benchFold "drop-all" (dropAll streamLen 4) (unfoldrM streamLen) - , benchFold "dropWhile-true" (dropWhileTrue streamLen 4) (unfoldrM streamLen) - , benchFold "dropWhile-false" (dropWhileFalse 4) (unfoldrM streamLen) - ] - -o_1_space_zipping :: Int -> Benchmark -o_1_space_zipping streamLen = - bgroup "zipping" - [ benchFold "zipWith" zipWith (unfoldrM streamLen) - , benchFold "zipWithM" zipWithM (unfoldrM streamLen) - ] - -o_1_space_mixed :: Int -> Benchmark -o_1_space_mixed streamLen = - bgroup "mixed" - [ benchFold "scan-map" (scanMap 1) (unfoldrM streamLen) - , benchFold "drop-map" (dropMap 1) (unfoldrM streamLen) - , benchFold "drop-scan" (dropScan 1) (unfoldrM streamLen) - , benchFold "take-drop" (takeDrop streamLen 1) (unfoldrM streamLen) - , benchFold "take-scan" (takeScan streamLen 1) (unfoldrM streamLen) - , benchFold "take-map" (takeMap streamLen 1) (unfoldrM streamLen) - , benchFold "filter-drop" (filterDrop streamLen 1) (unfoldrM streamLen) - , benchFold "filter-take" (filterTake streamLen 1) (unfoldrM streamLen) - , benchFold "filter-scan" (filterScan 1) (unfoldrM streamLen) - , benchFold "filter-map" (filterMap streamLen 1) (unfoldrM streamLen) - ] - -o_1_space_mixedX2 :: Int -> Benchmark -o_1_space_mixedX2 streamLen = - bgroup "mixedX2" - [ benchFold "scan-map" (scanMap 2) (unfoldrM streamLen) - , benchFold "drop-map" (dropMap 2) (unfoldrM streamLen) - , benchFold "drop-scan" (dropScan 2) (unfoldrM streamLen) - , benchFold "take-drop" (takeDrop streamLen 2) (unfoldrM streamLen) - , benchFold "take-scan" (takeScan streamLen 2) (unfoldrM streamLen) - , benchFold "take-map" (takeMap streamLen 2) (unfoldrM streamLen) - , benchFold "filter-drop" (filterDrop streamLen 2) (unfoldrM streamLen) - , benchFold "filter-take" (filterTake streamLen 2) (unfoldrM streamLen) - , benchFold "filter-scan" (filterScan 2) (unfoldrM streamLen) - , benchFold "filter-map" (filterMap streamLen 2) (unfoldrM streamLen) - ] - -o_1_space_mixedX4 :: Int -> Benchmark -o_1_space_mixedX4 streamLen = - bgroup "mixedX4" - [ benchFold "scan-map" (scanMap 4) (unfoldrM streamLen) - , benchFold "drop-map" (dropMap 4) (unfoldrM streamLen) - , benchFold "drop-scan" (dropScan 4) (unfoldrM streamLen) - , benchFold "take-drop" (takeDrop streamLen 4) (unfoldrM streamLen) - , benchFold "take-scan" (takeScan streamLen 4) (unfoldrM streamLen) - , benchFold "take-map" (takeMap streamLen 4) (unfoldrM streamLen) - , benchFold "filter-drop" (filterDrop streamLen 4) (unfoldrM streamLen) - , benchFold "filter-take" (filterTake streamLen 4) (unfoldrM streamLen) - , benchFold "filter-scan" (filterScan 4) (unfoldrM streamLen) - , benchFold "filter-map" (filterMap streamLen 4) (unfoldrM streamLen) - ] - -o_1_space_list :: Int -> Benchmark -o_1_space_list streamLen = - bgroup "list" - [ bgroup "elimination" - [ benchList "last" (\xs -> [List.last xs]) (unfoldrList streamLen) - ] - , bgroup "nested" - [ benchList "toNullAp" toNullApNestedList (unfoldrList streamLen2) - , benchList "toNull" toNullNestedList (unfoldrList streamLen2) - , benchList "toNull3" toNullNestedList3 (unfoldrList streamLen3) - , benchList "filterAllIn" filterAllInNestedList (unfoldrList streamLen2) - , benchList "filterAllOut" filterAllOutNestedList (unfoldrList streamLen2) - ] - ] - where - - streamLen2 = round (P.fromIntegral streamLen**(1/2::P.Double)) -- double nested loop - streamLen3 = round (P.fromIntegral streamLen**(1/3::P.Double)) -- triple nested loop - -o_1_space :: Int -> Benchmark -o_1_space streamLen = - bgroup (o_1_space_prefix moduleName) - [ o_1_space_generation streamLen - , o_1_space_elimination streamLen - , o_1_space_nested streamLen - , o_1_space_transformation streamLen - , o_1_space_transformationX4 streamLen - , o_1_space_concat streamLen - , o_1_space_filtering streamLen - , o_1_space_filteringX4 streamLen - , o_1_space_zipping streamLen - , o_1_space_mixed streamLen - , o_1_space_mixedX2 streamLen - , o_1_space_mixedX4 streamLen - , o_1_space_list streamLen - ] - -o_n_heap :: Int -> Benchmark -o_n_heap streamLen = - bgroup (o_n_heap_prefix moduleName) - [ bgroup "transformation" - [ benchFold "foldlS" (foldlS 1) (unfoldrM streamLen) - ] - ] - -{-# INLINE benchK #-} -benchK :: P.String -> (Int -> Stream P.IO Int) -> Benchmark -benchK name f = bench name $ nfIO $ randomRIO (1,1) >>= drain . f - -o_n_stack :: Int -> Int -> Int -> Benchmark -o_n_stack streamLen iterStreamLen maxIters = - bgroup (o_n_stack_prefix moduleName) - [ bgroup "elimination" - [ benchFold "tail" tail (unfoldrM streamLen) - , benchFold "nullTail" nullTail (unfoldrM streamLen) - , benchFold "headTail" headTail (unfoldrM streamLen) - ] - , bgroup "transformation" - [ - -- XXX why do these need so much stack - benchFold "intersperse" (intersperse streamLen 1) (unfoldrM streamLen2) - , benchFold "interspersePure" (intersperse streamLen 1) (unfoldr streamLen2) - ] - , bgroup "transformationX4" - [ - benchFold "intersperse" (intersperse streamLen 4) (unfoldrM streamLen16) - ] - , bgroup "iterated" - [ benchK "mapM" (iterateMapM iterStreamLen maxIters) - , benchK "scan(1/10)" (iterateScan iterStreamLen maxIters) - , benchK "filterEven" (iterateFilterEven iterStreamLen maxIters) - , benchK "takeAll" (iterateTakeAll streamLen iterStreamLen maxIters) - , benchK "dropOne" (iterateDropOne iterStreamLen maxIters) - , benchK "dropWhileFalse(1/10)" (iterateDropWhileFalse streamLen iterStreamLen maxIters) - , benchK "dropWhileTrue" (iterateDropWhileTrue streamLen iterStreamLen maxIters) - ] - ] - where - streamLen2 = round (P.fromIntegral streamLen**(1/2::P.Double)) -- double nested loop - streamLen16 = round (P.fromIntegral streamLen**(1/16::P.Double)) -- triple nested loop - -o_n_space :: Int -> Benchmark -o_n_space streamLen = - bgroup (o_n_space_prefix moduleName) - [ bgroup "elimination" - [ benchFold "toList" toList (unfoldrM streamLen) - ] - ] - -{-# INLINE benchList #-} -benchList :: P.String -> ([Int] -> [Int]) -> (Int -> [Int]) -> Benchmark -benchList name run f = bench name $ nfIO $ randomRIO (1,1) >>= return . run . f - -main :: IO () -main = - defaultMain - [ o_1_space streamLen - , o_n_stack streamLen iterStreamLen maxIters - , o_n_heap streamLen - , o_n_space streamLen - ] - - where - - streamLen = 100000 - maxIters = 10000 - iterStreamLen = 10 diff --git a/benchmark/Streamly/Benchmark/Data/Stream/ToStreamK.hs b/benchmark/Streamly/Benchmark/Data/Stream/ToStreamK.hs deleted file mode 100644 --- a/benchmark/Streamly/Benchmark/Data/Stream/ToStreamK.hs +++ /dev/null @@ -1,939 +0,0 @@ --- | --- Module : Streamly.Benchmark.Data.Stream.StreamK --- Copyright : (c) 2018 Composewell Technologies --- --- License : BSD3 --- Maintainer : streamly@composewell.com - -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wno-orphans #-} - -#ifdef __HADDOCK_VERSION__ -#undef INSPECTION -#endif - -#ifdef INSPECTION -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-} -#endif - -module Main (main) where - --- import Control.Applicative (liftA2) --- import Control.Monad (when) --- import Data.Maybe (isJust) --- import System.Random (randomRIO) -import Prelude hiding - ( tail, mapM_, foldl, last, map, mapM, concatMap, zipWith, init, iterate - , repeat, replicate - ) - -import qualified Prelude as P --- import qualified Data.List as List - -import qualified Streamly.Internal.Data.Stream.StreamK.Type as S -import qualified Streamly.Internal.Data.Stream.StreamK as S -import qualified Streamly.Internal.Data.Stream.StreamD as D -import qualified Streamly.Internal.Data.Fold as Fold - -import Gauge (bgroup, Benchmark, defaultMain) - -import Streamly.Benchmark.Common - -#ifdef INSPECTION -import Test.Inspection -#endif - -------------------------------------------------------------------------------- --- Stream generation and elimination -------------------------------------------------------------------------------- - -type Stream m a = S.Stream m a - -{-# INLINE unfoldrD #-} -unfoldrD :: Monad m => Int -> Int -> Stream m Int -unfoldrD streamLen n = D.toStreamK (D.unfoldr step n) - where - step cnt = - if cnt > n + streamLen - then Nothing - else Just (cnt, cnt + 1) - -{-# INLINE unfoldrMD #-} -unfoldrMD :: Monad m => Int -> Int -> Stream m Int -unfoldrMD streamLen n = D.toStreamK (D.unfoldrM step n) - where - step cnt = - if cnt > n + streamLen - then return Nothing - else return (Just (cnt, cnt + 1)) - -{- -{-# INLINE unfoldrK #-} -unfoldrK :: Int -> Int -> Stream m Int -unfoldrK streamLen n = S.unfoldr step n - where - step cnt = - if cnt > n + streamLen - then Nothing - else Just (cnt, cnt + 1) --} - -{-# INLINE unfoldrMK #-} -unfoldrMK :: Monad m => Int -> Int -> Stream m Int -unfoldrMK streamLen n = S.unfoldrMWith S.consM step n - where - step cnt = - if cnt > n + streamLen - then return Nothing - else return (Just (cnt, cnt + 1)) - -{-# INLINE repeat #-} -repeat :: Monad m => Int -> Int -> Stream m Int -repeat streamLen = S.take streamLen . D.toStreamK . D.repeat - -{-# INLINE repeatM #-} -repeatM :: Monad m => Int -> Int -> Stream m Int -repeatM streamLen = S.take streamLen . D.toStreamK . D.repeatM . return - -{-# INLINE replicate #-} -replicate :: Monad m => Int -> Int -> Stream m Int -replicate x y = D.toStreamK $ D.replicate x y - -{-# INLINE replicateM #-} -replicateM :: Monad m => Int -> Int -> Stream m Int -replicateM streamLen = D.toStreamK . D.replicateM streamLen . return - -{-# INLINE iterate #-} -iterate :: Monad m => Int -> Int -> Stream m Int -iterate streamLen = S.take streamLen . D.toStreamK . D.iterate (+1) - -{-# INLINE iterateM #-} -iterateM :: Monad m => Int -> Int -> Stream m Int -iterateM streamLen = S.take streamLen . D.toStreamK . D.iterateM (return . (+1)) . return - -{-# INLINE fromFoldable #-} -fromFoldable :: Int -> Int -> Stream m Int -fromFoldable streamLen n = S.fromFoldable [n..n+streamLen] - -{-# INLINE fromFoldableM #-} -fromFoldableM :: Monad m => Int -> Int -> Stream m Int -fromFoldableM streamLen n = - Prelude.foldr S.consM S.nil (Prelude.fmap return [n..n+streamLen]) - -{- -{-# INLINABLE concatMapFoldableWith #-} -concatMapFoldableWith :: Foldable f - => (Stream m b -> Stream m b -> Stream m b) - -> (a -> Stream m b) - -> f a - -> Stream m b -concatMapFoldableWith f g = Prelude.foldr (f . g) S.nil --} - -{-# INLINE concatMapFoldableSerial #-} -concatMapFoldableSerial :: Monad m => Int -> Int -> Stream m Int -concatMapFoldableSerial streamLen n = - D.toStreamK $ D.concatMap D.fromPure $ D.fromStreamK $ S.fromList [n..n+streamLen] - -{-# INLINE concatMapFoldableSerialM #-} -concatMapFoldableSerialM :: Monad m => Int -> Int -> Stream m Int -concatMapFoldableSerialM streamLen n = - -- concatMapFoldableWith S.serial (S.fromEffect . return) [n..n+streamLen] - D.toStreamK $ D.concatMap (D.fromEffect . return) $ D.fromStreamK $ S.fromList [n..n+streamLen] - -------------------------------------------------------------------------------- --- Elimination -------------------------------------------------------------------------------- - -{-# INLINE drainD #-} -drainD :: Monad m => Stream m a -> m () -drainD = D.drain . D.fromStreamK - -{-# INLINE drain #-} -drain :: Monad m => Stream m a -> m () -drain = S.drain - -{-# INLINE mapM_ #-} -mapM_ :: Monad m => Stream m a -> m () -mapM_ s = D.mapM_ (\_ -> return ()) $ D.fromStreamK s - -{- -{-# INLINE uncons #-} -uncons :: Monad m => Stream m Int -> m () -uncons s = do - r <- D.uncons $ D.fromStreamK s - case r of - Nothing -> return () - Just (_, t) -> uncons (D.toStreamK t) - -{-# INLINE init #-} -init :: Monad m => Stream m a -> m () -init s = do - t <- S.init s - P.mapM_ S.drain t - -{-# INLINE tail #-} -tail :: Monad m => Stream m a -> m () -tail s = S.tail s >>= P.mapM_ tail - -{-# INLINE nullTail #-} -nullTail :: Monad m => Stream m Int -> m () -nullTail s = do - r <- S.null s - when (not r) $ S.tail s >>= P.mapM_ nullTail - -{-# INLINE headTail #-} -headTail :: Monad m => Stream m Int -> m () -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 = D.fold Fold.toList . D.fromStreamK - -{-# INLINE foldl' #-} -foldl' :: Monad m => Stream m Int -> m Int -foldl' = D.fold (Fold.foldl' (+) 0) . D.fromStreamK - -{-# INLINE last #-} -last :: Monad m => Stream m Int -> m (Maybe Int) -last = D.fold Fold.latest . D.fromStreamK - -------------------------------------------------------------------------------- --- Transformation -------------------------------------------------------------------------------- - -{-# INLINE composeN #-} -composeN - :: Monad m - => Int -> (Stream m Int -> Stream m Int) -> Stream m Int -> m () -composeN n f = - case n of - 1 -> drain . f - 2 -> drain . f . f - 3 -> drain . f . f . f - 4 -> drain . f . f . f . f - _ -> undefined - -{-# INLINE scanl' #-} -scanl' :: Monad m => Int -> Stream m Int -> m () -scanl' n = - composeN n (D.toStreamK . D.scan (Fold.foldl' (+) 0) . D.fromStreamK) - -{-# INLINE map #-} -map :: Monad m => Int -> Stream m Int -> m () -map n = composeN n (D.toStreamK . D.map (+ 1) . D.fromStreamK) - -{- -{-# INLINE fmapK #-} -fmapK :: Monad m => Int -> Stream m Int -> m () -fmapK n = composeN n $ P.fmap (+ 1) --} - -{-# INLINE mapM #-} -mapM :: Monad m => Int -> Stream m Int -> m () -mapM n = composeN n (D.toStreamK . D.mapM return . D.fromStreamK) - -{- -{-# INLINE mapMSerial #-} -mapMSerial :: S.MonadAsync m => Int -> Stream m Int -> m () -mapMSerial n = composeN n $ S.mapMSerial return --} - -{-# INLINE filterEven #-} -filterEven :: Monad m => Int -> Stream m Int -> m () -filterEven n = composeN n (D.toStreamK . D.filter even . D.fromStreamK) - -{- -{-# INLINE filterAllOut #-} -filterAllOut :: Monad m => Int -> Int -> Stream m Int -> m () -filterAllOut streamLen n = composeN n $ S.filter (> streamLen) - -{-# INLINE filterAllIn #-} -filterAllIn :: Monad m => Int -> Int -> Stream m Int -> m () -filterAllIn streamLen n = composeN n $ S.filter (<= streamLen) - -{-# INLINE _takeOne #-} -_takeOne :: Monad m => Int -> Stream m Int -> m () -_takeOne n = composeN n $ S.take 1 - -{-# INLINE takeAll #-} -takeAll :: Monad m => Int -> Int -> Stream m Int -> m () -takeAll streamLen n = composeN n $ S.take streamLen - -{-# INLINE takeWhileTrue #-} -takeWhileTrue :: Monad m => Int -> Int -> Stream m Int -> m () -takeWhileTrue streamLen n = composeN n $ S.takeWhile (<= streamLen) - -{-# INLINE dropOne #-} -dropOne :: Monad m => Int -> Stream m Int -> m () -dropOne n = composeN n $ S.drop 1 - -{-# INLINE dropAll #-} -dropAll :: Monad m => Int -> Int -> Stream m Int -> m () -dropAll streamLen n = composeN n $ S.drop streamLen - -{-# INLINE dropWhileTrue #-} -dropWhileTrue :: Monad m => Int -> Int -> Stream m Int -> m () -dropWhileTrue streamLen n = composeN n $ S.dropWhile (<= streamLen) - -{-# INLINE dropWhileFalse #-} -dropWhileFalse :: Monad m => Int -> Stream m Int -> m () -dropWhileFalse n = composeN n $ S.dropWhile (<= 1) --} - -{- -{-# INLINE foldrS #-} -foldrS :: Monad m => Int -> Stream m Int -> m () -foldrS n = composeN n $ S.foldrS S.cons S.nil - -{-# INLINE foldlS #-} -foldlS :: Monad m => Int -> Stream m Int -> m () -foldlS n = composeN n $ S.foldlS (flip S.cons) S.nil --} - -{- -{-# INLINE intersperse #-} -intersperse :: S.MonadAsync m => Int -> Int -> Stream m Int -> m () -intersperse streamLen n = composeN n $ S.intersperse streamLen --} - -------------------------------------------------------------------------------- --- Iteration -------------------------------------------------------------------------------- - -{- -{-# INLINE iterateSource #-} -iterateSource - :: S.MonadAsync m - => Int -> (Stream m Int -> Stream m Int) -> Int -> Int -> Stream m Int -iterateSource iterStreamLen g i n = f i (unfoldrM iterStreamLen n) - where - f (0 :: Int) m = g m - f x m = g (f (x P.- 1) m) - --- this is quadratic -{-# INLINE iterateScan #-} -iterateScan :: S.MonadAsync m => Int -> Int -> Int -> Stream m Int -iterateScan iterStreamLen maxIters = - iterateSource iterStreamLen (S.scanl' (+) 0) (maxIters `div` 10) - --- this is quadratic -{-# INLINE iterateDropWhileFalse #-} -iterateDropWhileFalse :: S.MonadAsync m => Int -> Int -> Int -> Int -> Stream m Int -iterateDropWhileFalse streamLen iterStreamLen maxIters = - iterateSource iterStreamLen (S.dropWhile (> streamLen)) (maxIters `div` 10) - -{-# INLINE iterateMapM #-} -iterateMapM :: S.MonadAsync m => Int -> Int -> Int -> Stream m Int -iterateMapM iterStreamLen = - iterateSource iterStreamLen (S.mapMWith S.consM return) - -{-# INLINE iterateFilterEven #-} -iterateFilterEven :: S.MonadAsync m => Int -> Int -> Int -> Stream m Int -iterateFilterEven iterStreamLen = iterateSource iterStreamLen (S.filter even) - -{-# INLINE iterateTakeAll #-} -iterateTakeAll :: S.MonadAsync m => Int -> Int -> Int -> Int -> Stream m Int -iterateTakeAll streamLen iterStreamLen = - iterateSource iterStreamLen (S.take streamLen) - -{-# INLINE iterateDropOne #-} -iterateDropOne :: S.MonadAsync m => Int -> Int -> Int -> Stream m Int -iterateDropOne iterStreamLen = iterateSource iterStreamLen (S.drop 1) - -{-# INLINE iterateDropWhileTrue #-} -iterateDropWhileTrue :: S.MonadAsync m => - Int -> Int -> Int -> Int -> Stream m Int -iterateDropWhileTrue streamLen iterStreamLen = - iterateSource iterStreamLen (S.dropWhile (<= streamLen)) --} - -------------------------------------------------------------------------------- --- Zipping -------------------------------------------------------------------------------- - -{- -{-# INLINE zipWith #-} -zipWith :: Monad m => Stream m Int -> m () -zipWith src = drain $ S.zipWith (,) src src - -{-# INLINE zipWithM #-} -zipWithM :: Monad m => Stream m Int -> m () -zipWithM src = drain $ S.zipWithM (curry return) src src - -{-# INLINE sortByK #-} -sortByK :: (a -> a -> Ordering) -> Stream m a -> Stream m a -sortByK f = S.concatPairsWith (S.mergeBy f) S.fromPure - -{-# INLINE sortBy #-} -sortBy :: Monad m => Stream m Int -> m () -sortBy = drain . sortByK compare - -------------------------------------------------------------------------------- --- Mixed Composition -------------------------------------------------------------------------------- - -{-# INLINE scanMap #-} -scanMap :: Monad m => Int -> Stream m Int -> m () -scanMap n = composeN n $ S.map (subtract 1) . S.scanl' (+) 0 - -{-# INLINE dropMap #-} -dropMap :: Monad m => Int -> Stream m Int -> m () -dropMap n = composeN n $ S.map (subtract 1) . S.drop 1 - -{-# INLINE dropScan #-} -dropScan :: Monad m => Int -> Stream m Int -> m () -dropScan n = composeN n $ S.scanl' (+) 0 . S.drop 1 - -{-# INLINE takeDrop #-} -takeDrop :: Monad m => Int -> Int -> Stream m Int -> m () -takeDrop streamLen n = composeN n $ S.drop 1 . S.take streamLen - -{-# INLINE takeScan #-} -takeScan :: Monad m => Int -> Int -> Stream m Int -> m () -takeScan streamLen n = composeN n $ S.scanl' (+) 0 . S.take streamLen - -{-# INLINE takeMap #-} -takeMap :: Monad m => Int -> Int -> Stream m Int -> m () -takeMap streamLen n = composeN n $ S.map (subtract 1) . S.take streamLen - -{-# INLINE filterDrop #-} -filterDrop :: Monad m => Int -> Int -> Stream m Int -> m () -filterDrop streamLen n = composeN n $ S.drop 1 . S.filter (<= streamLen) - -{-# INLINE filterTake #-} -filterTake :: Monad m => Int -> Int -> Stream m Int -> m () -filterTake streamLen n = composeN n $ S.take streamLen . S.filter (<= streamLen) - -{-# INLINE filterScan #-} -filterScan :: Monad m => Int -> Stream m Int -> m () -filterScan n = composeN n $ S.scanl' (+) 0 . S.filter (<= maxBound) - -{-# INLINE filterMap #-} -filterMap :: Monad m => Int -> Int -> Stream m Int -> m () -filterMap streamLen n = composeN n $ S.map (subtract 1) . S.filter (<= streamLen) --} - -------------------------------------------------------------------------------- --- ConcatMap -------------------------------------------------------------------------------- - --- concatMap unfoldrM/unfoldrM - -{-# INLINE concatMap #-} -concatMap :: Int -> Int -> Int -> IO () -concatMap outer inner n = - S.drain $ D.toStreamK $ D.concatMap - (\_ -> D.fromStreamK $ unfoldrMK inner n) - (D.fromStreamK $ unfoldrMK outer n) - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'concatMap -#endif - --- concatMap unfoldr/unfoldr - -{- -{-# INLINE concatMapPure #-} -concatMapPure :: Int -> Int -> Int -> IO () -concatMapPure outer inner n = - S.drain $ S.concatMap - (\_ -> unfoldr inner n) - (unfoldr outer n) - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'concatMapPure -#endif - --- concatMap replicate/unfoldrM - -{-# INLINE concatMapRepl #-} -concatMapRepl :: Int -> Int -> Int -> IO () -concatMapRepl outer inner n = - S.drain $ S.concatMap (S.replicate inner) (unfoldrM outer n) - -#ifdef INSPECTION -inspect $ hasNoTypeClasses 'concatMapRepl -#endif - --- concatMapWith - -{-# INLINE sourceConcatMapId #-} -sourceConcatMapId :: Monad m - => Int -> Int -> Stream m (Stream m Int) -sourceConcatMapId val n = - S.fromFoldable $ fmap (S.fromEffect . return) [n..n+val] - -{-# INLINE concatMapBySerial #-} -concatMapBySerial :: Int -> Int -> Int -> IO () -concatMapBySerial outer inner n = - S.drain $ S.concatMapWith S.serial - (unfoldrM inner) - (unfoldrM outer n) --} - -{- -------------------------------------------------------------------------------- --- Nested Composition -------------------------------------------------------------------------------- - -instance Monad m => Applicative (S.Stream m) where - {-# INLINE pure #-} - pure = S.fromPure - - {-# INLINE (<*>) #-} - (<*>) = S.crossApply - - {-# INLINE liftA2 #-} - liftA2 f x = (<*>) (fmap f x) - - {-# INLINE (*>) #-} - (*>) = S.crossApplySnd - - {-# INLINE (<*) #-} - (<*) = S.crossApplyFst - --- 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 (S.Stream m) where - {-# INLINE return #-} - return = pure - - {-# INLINE (>>=) #-} - (>>=) = flip S.concatMap - -{-# INLINE drainApplicative #-} -drainApplicative :: Monad m => Stream m Int -> m () -drainApplicative s = drain $ do - (+) <$> s <*> s - -{-# INLINE drainMonad #-} -drainMonad :: Monad m => Stream m Int -> m () -drainMonad s = drain $ do - x <- s - y <- s - return $ x + y - -{-# INLINE drainMonad3 #-} -drainMonad3 :: Monad m => Stream m Int -> m () -drainMonad3 s = drain $ do - x <- s - y <- s - z <- s - return $ x + y + z - -{-# INLINE filterAllOutMonad #-} -filterAllOutMonad - :: Monad m - => Stream m Int -> m () -filterAllOutMonad str = drain $ do - x <- str - y <- str - let s = x + y - if s < 0 - then return s - else S.nil - -{-# INLINE filterAllInMonad #-} -filterAllInMonad - :: Monad m - => Stream m Int -> m () -filterAllInMonad str = drain $ do - x <- str - y <- str - let s = x + y - if s > 0 - then return s - else S.nil - -------------------------------------------------------------------------------- --- Nested Composition Pure lists -------------------------------------------------------------------------------- - --- There are several list benchmarks here for comparison with lists. It is easy --- and convenient to see the comparisons when they are here, otherwise we'll --- have to add a separate module for list benchmarks with the same names and --- then add a comparison in bench.sh. - -{-# INLINE unfoldrList #-} -unfoldrList :: Int -> Int -> [Int] -unfoldrList 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 [] - -} - -------------------------------------------------------------------------------- --- Benchmarks -------------------------------------------------------------------------------- - -moduleName :: String -moduleName = "Data.Stream.ToStreamK" - --- Generation of StreamK using StreamD generation functions and eleminating --- using StreamK drain. -o_1_space_generation :: Int -> Benchmark -o_1_space_generation streamLen = - bgroup "generation" - [ benchFold "unfoldr" drain (unfoldrD streamLen) - , benchFold "unfoldrM" drain (unfoldrMD streamLen) - , benchFold "repeat" drain (repeat streamLen) - , benchFold "repeatM" drain (repeatM streamLen) - , benchFold "replicate" drain (replicate streamLen) - , benchFold "replicateM" drain (replicateM streamLen) - , benchFold "iterate" drain (iterate streamLen) - , benchFold "iterateM" drain (iterateM streamLen) - - , benchFold "fromFoldable" drain (fromFoldable streamLen) - , benchFold "fromFoldableM" drain (fromFoldableM streamLen) - - -- appends - , benchFold "concatMapFoldableWith" drain (concatMapFoldableSerial streamLen) - , benchFold "concatMapFoldableWithM" drain (concatMapFoldableSerialM streamLen) - ] - --- Generating using StreamK and eliminating using StreamD folds. -o_1_space_elimination :: Int -> Benchmark -o_1_space_elimination streamLen = - bgroup "elimination" - [ benchFold "toNull" drainD (unfoldrMK streamLen) - , benchFold "mapM_" mapM_ (unfoldrMK streamLen) - -- , benchFold "uncons" uncons (unfoldrMK streamLen) - -- , benchFold "init" init (unfoldrM streamLen) - , benchFold "foldl'" foldl' (unfoldrMK streamLen) - , benchFold "last" last (unfoldrMK streamLen) - ] - -{- -o_1_space_nested :: Int -> Benchmark -o_1_space_nested streamLen = - bgroup "nested" - [ benchFold "drainApplicative" drainApplicative (unfoldrM streamLen2) - , benchFold "drainMonad" drainMonad (unfoldrM streamLen2) - , benchFold "drainMonad3" drainMonad3 (unfoldrM streamLen3) - , benchFold "filterAllInMonad" filterAllInMonad (unfoldrM streamLen2) - , benchFold "filterAllOutMonad" filterAllOutMonad (unfoldrM streamLen2) - , benchFold "drainApplicative (pure)" drainApplicative (unfoldr streamLen2) - , benchFold "drainMonad (pure)" drainMonad (unfoldr streamLen2) - , benchFold "drainMonad3 (pure)" drainMonad3 (unfoldr streamLen3) - , benchFold "filterAllInMonad (pure)" filterAllInMonad (unfoldr streamLen2) - , benchFold "filterAllOutMonad (pure)" filterAllOutMonad (unfoldr streamLen2) - ] - where - streamLen2 = round (P.fromIntegral streamLen**(1/2::P.Double)) -- double nested loop - streamLen3 = round (P.fromIntegral streamLen**(1/3::P.Double)) -- triple nested loop --} - --- Generate using StreamK and transform using StreamD transformation functions --- and then drain using StreamK. -o_1_space_transformation :: Int -> Benchmark -o_1_space_transformation streamLen = - bgroup "transformation" - [ -- benchFold "foldrS" (foldrS 1) (unfoldrM streamLen) - benchFold "scanl'" (scanl' 1) (unfoldrMK streamLen) - , benchFold "map" (map 1) (unfoldrMK streamLen) - -- , benchFold "fmap" (fmapK 1) (unfoldrM streamLen) - , benchFold "mapM" (mapM 1) (unfoldrMK streamLen) - -- , benchFold "mapMSerial" (mapMSerial 1) (unfoldrM streamLen) - ] - -o_1_space_transformationX4 :: Int -> Benchmark -o_1_space_transformationX4 streamLen = - bgroup "transformationX4" - [ benchFold "scanl'" (scanl' 4) (unfoldrMK streamLen) - , benchFold "map" (map 4) (unfoldrMK streamLen) - -- , benchFold "fmap" (fmapK 4) (unfoldrMK streamLen) - , benchFold "mapM" (mapM 4) (unfoldrMK streamLen) - -- , benchFold "mapMSerial" (mapMSerial 4) (unfoldrM streamLen) - -- XXX this is horribly slow - -- , benchFold "concatMap" (concatMap 4) (unfoldrM streamLen16) - ] - --- Generate using K, fold using K, concat using D.concatMap -o_1_space_concat :: Int -> Benchmark -o_1_space_concat streamLen = - bgroup "concat" - [ {- benchIOSrc1 "concatMapPure (n of 1)" - (concatMapPure streamLen 1) - , benchIOSrc1 "concatMapPure (sqrt n of sqrt n)" - (concatMapPure streamLen2 streamLen2) - , benchIOSrc1 "concatMapPure (1 of n)" - (concatMapPure 1 streamLen) - -} - - benchIOSrc1 "concatMap (n of 1)" - (concatMap streamLen 1) - , benchIOSrc1 "concatMap (sqrt n of sqrt n)" - (concatMap streamLen2 streamLen2) - , benchIOSrc1 "concatMap (1 of n)" - (concatMap 1 streamLen) - -{- - , benchIOSrc1 "concatMapRepl (sqrt n of sqrt n)" - (concatMapRepl streamLen2 streamLen2) - - -- This is for comparison with concatMapFoldableWith - , benchIOSrc1 "concatMapWithId (n of 1) (fromFoldable)" - (S.drain - . S.concatMapWith S.serial id - . sourceConcatMapId streamLen) - - , benchIOSrc1 "concatMapBy serial (n of 1)" - (concatMapBySerial streamLen 1) - , benchIOSrc1 "concatMapBy serial (sqrt n of sqrt n)" - (concatMapBySerial streamLen2 streamLen2) - , benchIOSrc1 "concatMapBy serial (1 of n)" - (concatMapBySerial 1 streamLen) - , benchFold "sortBy" sortBy (unfoldrM streamLen) - -} - ] - where - streamLen2 = round (P.fromIntegral streamLen**(1/2::P.Double)) -- double nested loop - -o_1_space_filtering :: Int -> Benchmark -o_1_space_filtering streamLen = - bgroup "filtering" - [ benchFold "filter-even" (filterEven 1) (unfoldrMK streamLen) - {- - , benchFold "filter-all-out" (filterAllOut streamLen 1) (unfoldrM streamLen) - , benchFold "filter-all-in" (filterAllIn streamLen 1) (unfoldrM streamLen) - , benchFold "take-all" (takeAll streamLen 1) (unfoldrM streamLen) - , benchFold "takeWhile-true" (takeWhileTrue streamLen 1) (unfoldrM streamLen) - , benchFold "drop-one" (dropOne 1) (unfoldrM streamLen) - , benchFold "drop-all" (dropAll streamLen 1) (unfoldrM streamLen) - , benchFold "dropWhile-true" (dropWhileTrue streamLen 1) (unfoldrM streamLen) - , benchFold "dropWhile-false" (dropWhileFalse 1) (unfoldrM streamLen) - -} - ] - -o_1_space_filteringX4 :: Int -> Benchmark -o_1_space_filteringX4 streamLen = - bgroup "filteringX4" - [ benchFold "filter-even" (filterEven 4) (unfoldrMK streamLen) - {- - , benchFold "filter-all-out" (filterAllOut streamLen 4) (unfoldrM streamLen) - , benchFold "filter-all-in" (filterAllIn streamLen 4) (unfoldrM streamLen) - , benchFold "take-all" (takeAll streamLen 4) (unfoldrM streamLen) - , benchFold "takeWhile-true" (takeWhileTrue streamLen 4) (unfoldrM streamLen) - , benchFold "drop-one" (dropOne 4) (unfoldrM streamLen) - , benchFold "drop-all" (dropAll streamLen 4) (unfoldrM streamLen) - , benchFold "dropWhile-true" (dropWhileTrue streamLen 4) (unfoldrM streamLen) - , benchFold "dropWhile-false" (dropWhileFalse 4) (unfoldrM streamLen) - -} - ] - -{- -o_1_space_zipping :: Int -> Benchmark -o_1_space_zipping streamLen = - bgroup "zipping" - [ benchFold "zipWith" zipWith (unfoldrM streamLen) - , benchFold "zipWithM" zipWithM (unfoldrM streamLen) - ] - -o_1_space_mixed :: Int -> Benchmark -o_1_space_mixed streamLen = - bgroup "mixed" - [ benchFold "scan-map" (scanMap 1) (unfoldrM streamLen) - , benchFold "drop-map" (dropMap 1) (unfoldrM streamLen) - , benchFold "drop-scan" (dropScan 1) (unfoldrM streamLen) - , benchFold "take-drop" (takeDrop streamLen 1) (unfoldrM streamLen) - , benchFold "take-scan" (takeScan streamLen 1) (unfoldrM streamLen) - , benchFold "take-map" (takeMap streamLen 1) (unfoldrM streamLen) - , benchFold "filter-drop" (filterDrop streamLen 1) (unfoldrM streamLen) - , benchFold "filter-take" (filterTake streamLen 1) (unfoldrM streamLen) - , benchFold "filter-scan" (filterScan 1) (unfoldrM streamLen) - , benchFold "filter-map" (filterMap streamLen 1) (unfoldrM streamLen) - ] - -o_1_space_mixedX2 :: Int -> Benchmark -o_1_space_mixedX2 streamLen = - bgroup "mixedX2" - [ benchFold "scan-map" (scanMap 2) (unfoldrM streamLen) - , benchFold "drop-map" (dropMap 2) (unfoldrM streamLen) - , benchFold "drop-scan" (dropScan 2) (unfoldrM streamLen) - , benchFold "take-drop" (takeDrop streamLen 2) (unfoldrM streamLen) - , benchFold "take-scan" (takeScan streamLen 2) (unfoldrM streamLen) - , benchFold "take-map" (takeMap streamLen 2) (unfoldrM streamLen) - , benchFold "filter-drop" (filterDrop streamLen 2) (unfoldrM streamLen) - , benchFold "filter-take" (filterTake streamLen 2) (unfoldrM streamLen) - , benchFold "filter-scan" (filterScan 2) (unfoldrM streamLen) - , benchFold "filter-map" (filterMap streamLen 2) (unfoldrM streamLen) - ] - -o_1_space_mixedX4 :: Int -> Benchmark -o_1_space_mixedX4 streamLen = - bgroup "mixedX4" - [ benchFold "scan-map" (scanMap 4) (unfoldrM streamLen) - , benchFold "drop-map" (dropMap 4) (unfoldrM streamLen) - , benchFold "drop-scan" (dropScan 4) (unfoldrM streamLen) - , benchFold "take-drop" (takeDrop streamLen 4) (unfoldrM streamLen) - , benchFold "take-scan" (takeScan streamLen 4) (unfoldrM streamLen) - , benchFold "take-map" (takeMap streamLen 4) (unfoldrM streamLen) - , benchFold "filter-drop" (filterDrop streamLen 4) (unfoldrM streamLen) - , benchFold "filter-take" (filterTake streamLen 4) (unfoldrM streamLen) - , benchFold "filter-scan" (filterScan 4) (unfoldrM streamLen) - , benchFold "filter-map" (filterMap streamLen 4) (unfoldrM streamLen) - ] - -} - -{- -o_1_space_list :: Int -> Benchmark -o_1_space_list streamLen = - bgroup "list" - [ bgroup "elimination" - [ benchList "last" (\xs -> [List.last xs]) (unfoldrList streamLen) - ] - , bgroup "nested" - [ benchList "toNullAp" toNullApNestedList (unfoldrList streamLen2) - , benchList "toNull" toNullNestedList (unfoldrList streamLen2) - , benchList "toNull3" toNullNestedList3 (unfoldrList streamLen3) - , benchList "filterAllIn" filterAllInNestedList (unfoldrList streamLen2) - , benchList "filterAllOut" filterAllOutNestedList (unfoldrList streamLen2) - ] - ] - where - - streamLen2 = round (P.fromIntegral streamLen**(1/2::P.Double)) -- double nested loop - streamLen3 = round (P.fromIntegral streamLen**(1/3::P.Double)) -- triple nested loop --} - -o_1_space :: Int -> Benchmark -o_1_space streamLen = - bgroup (o_1_space_prefix moduleName) - [ o_1_space_generation streamLen - , o_1_space_elimination streamLen - -- , o_1_space_nested streamLen - , o_1_space_transformation streamLen - , o_1_space_transformationX4 streamLen - , o_1_space_concat streamLen - , o_1_space_filtering streamLen - , o_1_space_filteringX4 streamLen - -- , o_1_space_zipping streamLen - -- , o_1_space_mixed streamLen - -- , o_1_space_mixedX2 streamLen - -- , o_1_space_mixedX4 streamLen - -- , o_1_space_list streamLen - ] - -{- -o_n_heap :: Int -> Benchmark -o_n_heap streamLen = - bgroup (o_n_heap_prefix moduleName) - [ bgroup "transformation" - [ benchFold "foldlS" (foldlS 1) (unfoldrM streamLen) - ] - ] - -{-# INLINE benchK #-} -benchK :: P.String -> (Int -> Stream P.IO Int) -> Benchmark -benchK name f = bench name $ nfIO $ randomRIO (1,1) >>= drain . f - -o_n_stack :: Int -> Int -> Int -> Benchmark -o_n_stack streamLen iterStreamLen maxIters = - bgroup (o_n_stack_prefix moduleName) - [ bgroup "elimination" - [ benchFold "tail" tail (unfoldrM streamLen) - , benchFold "nullTail" nullTail (unfoldrM streamLen) - , benchFold "headTail" headTail (unfoldrM streamLen) - ] - , bgroup "transformation" - [ - -- XXX why do these need so much stack - benchFold "intersperse" (intersperse streamLen 1) (unfoldrM streamLen2) - , benchFold "interspersePure" (intersperse streamLen 1) (unfoldr streamLen2) - ] - , bgroup "transformationX4" - [ - benchFold "intersperse" (intersperse streamLen 4) (unfoldrM streamLen16) - ] - , bgroup "iterated" - [ benchK "mapM" (iterateMapM iterStreamLen maxIters) - , benchK "scan(1/10)" (iterateScan iterStreamLen maxIters) - , benchK "filterEven" (iterateFilterEven iterStreamLen maxIters) - , benchK "takeAll" (iterateTakeAll streamLen iterStreamLen maxIters) - , benchK "dropOne" (iterateDropOne iterStreamLen maxIters) - , benchK "dropWhileFalse(1/10)" (iterateDropWhileFalse streamLen iterStreamLen maxIters) - , benchK "dropWhileTrue" (iterateDropWhileTrue streamLen iterStreamLen maxIters) - ] - ] - where - streamLen2 = round (P.fromIntegral streamLen**(1/2::P.Double)) -- double nested loop - streamLen16 = round (P.fromIntegral streamLen**(1/16::P.Double)) -- triple nested loop --} - -o_n_space :: Int -> Benchmark -o_n_space streamLen = - bgroup (o_n_space_prefix moduleName) - [ bgroup "elimination" - [ benchFold "toList" toList (unfoldrMK streamLen) - ] - ] - -{- -{-# INLINE benchList #-} -benchList :: P.String -> ([Int] -> [Int]) -> (Int -> [Int]) -> Benchmark -benchList name run f = bench name $ nfIO $ randomRIO (1,1) >>= return . run . f --} - -main :: IO () -main = - defaultMain - [ o_1_space streamLen - -- , o_n_stack streamLen iterStreamLen maxIters - -- , o_n_heap streamLen - , o_n_space streamLen - ] - - where - - streamLen = 100000 - -- maxIters = 10000 - -- iterStreamLen = 10 diff --git a/benchmark/Streamly/Benchmark/Data/Stream/Transform.hs b/benchmark/Streamly/Benchmark/Data/Stream/Transform.hs --- a/benchmark/Streamly/Benchmark/Data/Stream/Transform.hs +++ b/benchmark/Streamly/Benchmark/Data/Stream/Transform.hs @@ -12,7 +12,6 @@ {-# OPTIONS_GHC -Wno-orphans #-} #ifdef USE_PRELUDE -{-# OPTIONS_GHC -Wno-deprecations #-} #endif #ifdef __HADDOCK_VERSION__ @@ -31,6 +30,7 @@ import System.Random (randomRIO) import qualified Streamly.Internal.Data.Fold as FL +import qualified Streamly.Internal.Data.Scanl as Scanl import qualified Stream.Common as Common import qualified Streamly.Internal.Data.Unfold as Unfold @@ -40,25 +40,18 @@ import Data.Functor.Identity (Identity(..)) import qualified Prelude import qualified Streamly.Internal.Data.Fold as Fold +import qualified Streamly.Internal.Data.Scanl as Scanl import qualified Streamly.Internal.Data.Stream.IsStream as Stream import Streamly.Internal.Data.Time.Units #else -import Streamly.Internal.Data.Stream.StreamD (Stream) -import qualified Streamly.Internal.Data.Stream.StreamD as Stream +import Streamly.Internal.Data.Stream (Stream) +import qualified Streamly.Internal.Data.Stream as Stream #ifndef USE_STREAMLY_CORE -import qualified Streamly.Internal.Data.Stream.Time as Stream -#endif -#ifdef USE_STREAMK -import Control.DeepSeq (NFData(..)) -import Data.Functor.Identity (Identity(..)) -import qualified Prelude -import qualified Streamly.Internal.Data.Fold as Fold -import Streamly.Internal.Data.Stream.StreamK (StreamK) -import qualified Streamly.Internal.Data.Stream.StreamK as StreamK +import qualified Streamly.Internal.Data.Stream.Prelude as Stream #endif #endif -import Gauge +import Test.Tasty.Bench import Stream.Common hiding (scanl') import Streamly.Benchmark.Common import Prelude hiding (sequence, mapM) @@ -76,54 +69,6 @@ ------------------------------------------------------------------------------- ------------------------------------------------------------------------------- --- Traversable Instance -------------------------------------------------------------------------------- - -#ifdef USE_STREAMK -{-# INLINE traversableTraverse #-} -traversableTraverse :: StreamK Identity Int -> IO (StreamK Identity Int) -traversableTraverse = traverse return - -{-# INLINE traversableSequenceA #-} -traversableSequenceA :: StreamK Identity Int -> IO (StreamK Identity Int) -traversableSequenceA = sequenceA . Prelude.fmap return - -{-# INLINE traversableMapM #-} -traversableMapM :: StreamK Identity Int -> IO (StreamK Identity Int) -traversableMapM = Prelude.mapM return - -{-# INLINE traversableSequence #-} -traversableSequence :: StreamK Identity Int -> IO (StreamK Identity Int) -traversableSequence = Prelude.sequence . Prelude.fmap return - -{-# INLINE benchPureSinkIO #-} -benchPureSinkIO - :: NFData b - => Int -> String -> (StreamK Identity Int -> IO b) -> Benchmark -benchPureSinkIO value name f = - bench name - $ nfIO $ randomRIO (1, 1) >>= f . fromStream . sourceUnfoldr value - -instance NFData a => NFData (StreamK Identity a) where - {-# INLINE rnf #-} - rnf xs = - runIdentity - $ Stream.fold (Fold.foldl' (\_ x -> rnf x) ()) (toStream xs) - -o_n_space_traversable :: Int -> [Benchmark] -o_n_space_traversable value = - -- Buffering operations using heap proportional to number of elements. - [ bgroup "traversable" - -- Traversable instance - [ benchPureSinkIO value "traverse" traversableTraverse - , benchPureSinkIO value "sequenceA" traversableSequenceA - , benchPureSinkIO value "mapM" traversableMapM - , benchPureSinkIO value "sequence" traversableSequence - ] - ] -#endif - -------------------------------------------------------------------------------- -- maps and scans ------------------------------------------------------------------------------- @@ -145,10 +90,16 @@ scanl1M' n = composeN n $ Stream.scanl1M' (\b a -> return $ b + a) #endif +#ifndef USE_PRELUDE {-# INLINE scan #-} scan :: MonadIO m => Int -> Stream m Int -> m () -scan n = composeN n $ Stream.scan FL.sum +scan n = composeN n $ Stream.scanl Scanl.sum +{-# INLINE postscan #-} +postscan :: MonadIO m => Int -> Stream m Int -> m () +postscan n = composeN n $ Stream.postscanl Scanl.sum +#endif + #ifdef USE_PRELUDE {-# INLINE postscanl' #-} postscanl' :: MonadIO m => Int -> Stream m Int -> m () @@ -159,10 +110,6 @@ postscanlM' n = composeN n $ Stream.postscanlM' (\b a -> return $ b + a) (return 0) #endif -{-# INLINE postscan #-} -postscan :: MonadIO m => Int -> Stream m Int -> m () -postscan n = composeN n $ Stream.postscan FL.sum - {-# INLINE sequence #-} sequence :: MonadAsync m => Stream m (m Int) -> m () sequence = Common.drain . Stream.sequence @@ -186,22 +133,6 @@ timestamped = Stream.drain . Stream.timestamped #endif -#ifdef USE_STREAMK -{-# INLINE foldrS #-} -foldrS :: MonadIO m => Int -> Stream m Int -> m () -foldrS n = - composeN n (toStream . StreamK.foldrS StreamK.cons StreamK.nil . fromStream) - -{-# INLINE foldrSMap #-} -foldrSMap :: MonadIO m => Int -> Stream m Int -> m () -foldrSMap n = - composeN n - ( toStream - . StreamK.foldrS (\x xs -> x + 1 `StreamK.cons` xs) StreamK.nil - . fromStream - ) -#endif - {- {-# INLINE foldrT #-} foldrT :: MonadIO m => Int -> Stream m Int -> m () @@ -223,12 +154,6 @@ [ bgroup "mapping" [ -#ifdef USE_STREAMK - -- Right folds - benchIOSink value "foldrS" (foldrS 1) - , benchIOSink value "foldrSMap" (foldrSMap 1) - , -#endif -- , benchIOSink value "foldrT" (foldrT 1) -- , benchIOSink value "foldrTMap" (foldrTMap 1) @@ -250,8 +175,10 @@ , benchIOSink value "postscanl'" (postscanl' 1) , benchIOSink value "postscanlM'" (postscanlM' 1) #endif +#ifndef USE_PRELUDE , benchIOSink value "scan" (scan 1) , benchIOSink value "postscan" (postscan 1) +#endif ] ] @@ -270,25 +197,39 @@ , benchIOSink value "postscanl'" (postscanl' 4) , benchIOSink value "postscanlM'" (postscanlM' 4) #endif +#ifndef USE_PRELUDE + , benchIOSink value "scan" (scan 4) + , benchIOSink value "postscan" (postscan 4) +{- + -- XXX this is horribly slow + , let value16 = round (fromIntegral value**(1/16::Double)) + benchFold "concatMap" (concatMap 4) (sourceUnfoldrMN value16) +-} +#endif ] ] +#ifndef USE_PRELUDE {-# INLINE sieveScan #-} sieveScan :: Monad m => Stream m Int -> Stream m Int sieveScan = Stream.mapMaybe snd - . Stream.scan (FL.foldlM' (\(primes, _) n -> do + . Stream.scanl (Scanl.mkScanlM (\(primes, _) n -> do return $ let ps = takeWhile (\p -> p * p <= n) primes in if all (\p -> n `mod` p /= 0) ps then (primes ++ [n], Just n) else (primes, Nothing)) (return ([2], Just 2))) +#endif o_n_space_mapping :: Int -> [Benchmark] o_n_space_mapping value = [ bgroup "mapping" - [ benchIO "naive prime sieve" + [ +#ifndef USE_PRELUDE + benchIO "naive prime sieve" (\n -> Stream.fold FL.sum $ sieveScan $ Stream.enumerateFromTo 2 (value + n)) +#endif ] ] @@ -317,25 +258,14 @@ f (0 :: Int) x = x f i x = f (i - 1) (g i x) -#ifdef USE_STREAMK -- Iterate a transformation over a singleton stream {-# INLINE iterateSingleton #-} iterateSingleton :: Applicative m => - (Int -> StreamK m Int -> StreamK m Int) - -> Int - -> Int - -> Stream m Int -iterateSingleton g count n = toStream $ iterateN g (StreamK.fromPure n) count -#else --- Iterate a transformation over a singleton stream -{-# INLINE iterateSingleton #-} -iterateSingleton :: Applicative m => (Int -> Stream m Int -> Stream m Int) -> Int -> Int -> Stream m Int iterateSingleton g count n = iterateN g (Stream.fromPure n) count -#endif {- -- XXX need to check why this is slower than the explicit recursion above, even @@ -601,12 +531,12 @@ {-# INLINE interposeSuffix #-} interposeSuffix :: Monad m => Int -> Int -> Stream m Int -> m () interposeSuffix value n = - composeN n $ Stream.interposeSuffix (value + 1) Unfold.identity + composeN n $ Stream.unfoldEachSepBy (value + 1) Unfold.identity {-# INLINE intercalateSuffix #-} intercalateSuffix :: Monad m => Int -> Int -> Stream m Int -> m () intercalateSuffix value n = - composeN n $ Stream.intercalateSuffix Unfold.identity (value + 1) + composeN n $ Stream.unfoldEachSepBySeq (value + 1) Unfold.identity o_1_space_inserting :: Int -> [Benchmark] o_1_space_inserting value = @@ -616,6 +546,7 @@ , benchIOSink value "insertBy" (insertBy value 1) , benchIOSink value "interposeSuffix" (interposeSuffix value 1) , benchIOSink value "intercalateSuffix" (intercalateSuffix value 1) + , benchIOSinkPureSrc value "interspersePure" (intersperse value 1) ] ] @@ -677,10 +608,6 @@ ] , bgroup (o_n_space_prefix moduleName) $ Prelude.concat [ -#ifdef USE_STREAMK - o_n_space_traversable size - , -#endif o_n_space_mapping size , o_n_space_iterated size ] diff --git a/benchmark/Streamly/Benchmark/Data/StreamK.hs b/benchmark/Streamly/Benchmark/Data/StreamK.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Data/StreamK.hs @@ -0,0 +1,980 @@ +-- | +-- Module : Streamly.Benchmark.Data.StreamK +-- Copyright : (c) 2018 Composewell Technologies +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +#ifdef __HADDOCK_VERSION__ +#undef INSPECTION +#endif + +#ifdef INSPECTION +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-} +#endif + +module Main (main) where + +#if !MIN_VERSION_base(4,18,0) +import Control.Applicative (liftA2) +#endif +import Control.Monad (when) +import Data.Maybe (isJust) +import Streamly.Internal.Data.StreamK (StreamK) +import System.Random (randomRIO) +import Test.Tasty.Bench (bench, nfIO, bgroup, Benchmark) + +import qualified Data.List as List +import qualified Prelude as P +import qualified Streamly.Internal.Data.StreamK as StreamK + +import Prelude hiding + ( Foldable(..), tail, mapM_, last, map, mapM, concatMap, zipWith, init + , iterate, repeat, replicate + ) +import Streamly.Benchmark.Common +#ifdef INSPECTION +import Test.Inspection +#endif + +------------------------------------------------------------------------------- +-- Stream generation and elimination +------------------------------------------------------------------------------- + +{-# INLINE unfoldr #-} +unfoldr :: Int -> Int -> StreamK m Int +unfoldr streamLen n = StreamK.unfoldr step n + where + step cnt = + if cnt > n + streamLen + then Nothing + else Just (cnt, cnt + 1) + +{-# INLINE unfoldrM #-} +unfoldrM :: Monad m => Int -> Int -> StreamK m Int +unfoldrM streamLen n = StreamK.unfoldrMWith StreamK.consM step n + where + step cnt = + if cnt > n + streamLen + then return Nothing + else return (Just (cnt, cnt + 1)) + +{-# INLINE repeat #-} +repeat :: Int -> Int -> StreamK m Int +repeat streamLen = StreamK.take streamLen . StreamK.repeat + +{-# INLINE repeatM #-} +repeatM :: Monad m => Int -> Int -> StreamK m Int +repeatM streamLen = StreamK.take streamLen . StreamK.repeatM . return + +{-# INLINE replicate #-} +replicate :: Int -> Int -> StreamK m Int +replicate = StreamK.replicate + +{-# INLINE replicateM #-} +replicateM :: Monad m => Int -> Int -> StreamK m Int +replicateM streamLen = StreamK.replicateMWith StreamK.consM streamLen . return + +{-# INLINE iterate #-} +iterate :: Int -> Int -> StreamK m Int +iterate streamLen = StreamK.take streamLen . StreamK.iterate (+1) + +{-# INLINE iterateM #-} +iterateM :: Monad m => Int -> Int -> StreamK m Int +iterateM streamLen = StreamK.take streamLen . StreamK.iterateM (return . (+1)) . return + +{-# INLINE fromFoldable #-} +fromFoldable :: Int -> Int -> StreamK m Int +fromFoldable streamLen n = StreamK.fromFoldable [n..n+streamLen] + +{- HLINT ignore "Fuse foldr/fmap" -} +{-# INLINE fromFoldableM #-} +fromFoldableM :: Monad m => Int -> Int -> StreamK m Int +fromFoldableM streamLen n = + List.foldr StreamK.consM StreamK.nil (Prelude.fmap return [n..n+streamLen]) + +{-# INLINABLE concatMapFoldableWith #-} +concatMapFoldableWith :: P.Foldable f + => (StreamK m b -> StreamK m b -> StreamK m b) + -> (a -> StreamK m b) + -> f a + -> StreamK m b +concatMapFoldableWith f g = P.foldr (f . g) StreamK.nil + +{-# INLINE concatMapFoldableSerial #-} +concatMapFoldableSerial :: Int -> Int -> StreamK m Int +concatMapFoldableSerial streamLen n = + concatMapFoldableWith StreamK.append StreamK.fromPure [n..n+streamLen] + +{-# INLINE concatMapFoldableSerialM #-} +concatMapFoldableSerialM :: Monad m => Int -> Int -> StreamK m Int +concatMapFoldableSerialM streamLen n = + concatMapFoldableWith StreamK.append (StreamK.fromEffect . return) [n..n+streamLen] + +------------------------------------------------------------------------------- +-- Elimination +------------------------------------------------------------------------------- + +{-# INLINE drain #-} +drain :: Monad m => StreamK m a -> m () +drain = StreamK.drain + +{-# INLINE mapM_ #-} +mapM_ :: Monad m => StreamK m a -> m () +mapM_ = StreamK.mapM_ (\_ -> return ()) + +{-# INLINE uncons #-} +uncons :: Monad m => StreamK m Int -> m () +uncons s = do + r <- StreamK.uncons s + case r of + Nothing -> return () + Just (_, t) -> uncons t + +{-# INLINE init #-} +init :: Monad m => StreamK m a -> m () +init s = do + t <- StreamK.init s + P.mapM_ StreamK.drain t + +{-# INLINE tail #-} +tail :: Monad m => StreamK m a -> m () +tail s = StreamK.tail s >>= P.mapM_ tail + +{-# INLINE nullTail #-} +nullTail :: Monad m => StreamK m Int -> m () +nullTail s = do + r <- StreamK.null s + when (not r) $ StreamK.tail s >>= P.mapM_ nullTail + +{-# INLINE headTail #-} +headTail :: Monad m => StreamK m Int -> m () +headTail s = do + h <- StreamK.head s + when (isJust h) $ StreamK.tail s >>= P.mapM_ headTail + +{-# INLINE toList #-} +toList :: Monad m => StreamK m Int -> m [Int] +toList = StreamK.toList + +{-# INLINE foldl' #-} +foldl' :: Monad m => StreamK m Int -> m Int +foldl' = StreamK.foldl' (+) 0 + +{-# INLINE foldlM' #-} +foldlM' :: Monad m => StreamK m Int -> m Int +foldlM' = StreamK.foldlM' (\b a -> return (b + a)) (return 0) + +{-# INLINE last #-} +last :: Monad m => StreamK m Int -> m (Maybe Int) +last = StreamK.last + +------------------------------------------------------------------------------- +-- Transformation +------------------------------------------------------------------------------- + +{-# INLINE composeN #-} +composeN + :: Monad m + => Int -> (StreamK m Int -> StreamK m Int) -> StreamK m Int -> m () +composeN n f = + case n of + 1 -> drain . f + 2 -> drain . f . f + 3 -> drain . f . f . f + 4 -> drain . f . f . f . f + _ -> undefined + +{-# INLINE scanl' #-} +scanl' :: Monad m => Int -> StreamK m Int -> m () +scanl' n = composeN n $ StreamK.scanl' (+) 0 + +{-# INLINE map #-} +map :: Monad m => Int -> StreamK m Int -> m () +map n = composeN n $ StreamK.map (+ 1) + +{-# INLINE fmapK #-} +fmapK :: Monad m => Int -> StreamK m Int -> m () +fmapK n = composeN n $ P.fmap (+ 1) + +{-# INLINE mapM #-} +mapM :: Monad m => Int -> StreamK m Int -> m () +mapM n = composeN n $ StreamK.mapMWith StreamK.consM return + +{-# INLINE mapMSerial #-} +mapMSerial :: Monad m => Int -> StreamK m Int -> m () +mapMSerial n = composeN n $ StreamK.mapMSerial return + +{-# INLINE filterEven #-} +filterEven :: Monad m => Int -> StreamK m Int -> m () +filterEven n = composeN n $ StreamK.filter even + +{-# INLINE filterAllOut #-} +filterAllOut :: Monad m => Int -> Int -> StreamK m Int -> m () +filterAllOut streamLen n = composeN n $ StreamK.filter (> streamLen) + +{-# INLINE filterAllIn #-} +filterAllIn :: Monad m => Int -> Int -> StreamK m Int -> m () +filterAllIn streamLen n = composeN n $ StreamK.filter (<= streamLen) + +{-# INLINE _takeOne #-} +_takeOne :: Monad m => Int -> StreamK m Int -> m () +_takeOne n = composeN n $ StreamK.take 1 + +{-# INLINE takeAll #-} +takeAll :: Monad m => Int -> Int -> StreamK m Int -> m () +takeAll streamLen n = composeN n $ StreamK.take streamLen + +{-# INLINE takeWhileTrue #-} +takeWhileTrue :: Monad m => Int -> Int -> StreamK m Int -> m () +takeWhileTrue streamLen n = composeN n $ StreamK.takeWhile (<= streamLen) + +{-# INLINE dropOne #-} +dropOne :: Monad m => Int -> StreamK m Int -> m () +dropOne n = composeN n $ StreamK.drop 1 + +{-# INLINE dropAll #-} +dropAll :: Monad m => Int -> Int -> StreamK m Int -> m () +dropAll streamLen n = composeN n $ StreamK.drop streamLen + +{-# INLINE dropWhileTrue #-} +dropWhileTrue :: Monad m => Int -> Int -> StreamK m Int -> m () +dropWhileTrue streamLen n = composeN n $ StreamK.dropWhile (<= streamLen) + +{-# INLINE dropWhileFalse #-} +dropWhileFalse :: Monad m => Int -> StreamK m Int -> m () +dropWhileFalse n = composeN n $ StreamK.dropWhile (<= 1) + +{-# INLINE foldrS #-} +foldrS :: Monad m => Int -> StreamK m Int -> m () +foldrS n = composeN n $ StreamK.foldrS StreamK.cons StreamK.nil + +{-# INLINE foldlS #-} +foldlS :: Monad m => Int -> StreamK m Int -> m () +foldlS n = composeN n $ StreamK.foldlS (flip StreamK.cons) StreamK.nil + +{-# INLINE intersperse #-} +intersperse :: Monad m => Int -> Int -> StreamK m Int -> m () +intersperse streamLen n = composeN n $ StreamK.intersperse streamLen + +------------------------------------------------------------------------------- +-- Iteration +------------------------------------------------------------------------------- + +{-# INLINE iterateSource #-} +iterateSource + :: Monad m => Int -> (StreamK m Int -> StreamK m Int) -> Int -> Int -> StreamK m Int +iterateSource iterStreamLen g i n = f i (unfoldrM iterStreamLen n) + where + f (0 :: Int) m = g m + f x m = g (f (x P.- 1) m) + +-- this is quadratic +{-# INLINE iterateScan #-} +iterateScan :: Monad m => Int -> Int -> Int -> StreamK m Int +iterateScan iterStreamLen maxIters = + iterateSource iterStreamLen (StreamK.scanl' (+) 0) (maxIters `div` 10) + +-- this is quadratic +{-# INLINE iterateDropWhileFalse #-} +iterateDropWhileFalse :: Monad m => Int -> Int -> Int -> Int -> StreamK m Int +iterateDropWhileFalse streamLen iterStreamLen maxIters = + iterateSource iterStreamLen (StreamK.dropWhile (> streamLen)) (maxIters `div` 10) + +{-# INLINE iterateMapM #-} +iterateMapM :: Monad m => Int -> Int -> Int -> StreamK m Int +iterateMapM iterStreamLen = + iterateSource iterStreamLen (StreamK.mapMWith StreamK.consM return) + +{-# INLINE iterateFilterEven #-} +iterateFilterEven :: Monad m => Int -> Int -> Int -> StreamK m Int +iterateFilterEven iterStreamLen = iterateSource iterStreamLen (StreamK.filter even) + +{-# INLINE iterateTakeAll #-} +iterateTakeAll :: Monad m => Int -> Int -> Int -> Int -> StreamK m Int +iterateTakeAll streamLen iterStreamLen = + iterateSource iterStreamLen (StreamK.take streamLen) + +{-# INLINE iterateDropOne #-} +iterateDropOne :: Monad m => Int -> Int -> Int -> StreamK m Int +iterateDropOne iterStreamLen = iterateSource iterStreamLen (StreamK.drop 1) + +{-# INLINE iterateDropWhileTrue #-} +iterateDropWhileTrue :: + Monad m => Int -> Int -> Int -> Int -> StreamK m Int +iterateDropWhileTrue streamLen iterStreamLen = + iterateSource iterStreamLen (StreamK.dropWhile (<= streamLen)) + +------------------------------------------------------------------------------- +-- Zipping +------------------------------------------------------------------------------- + +{-# INLINE zipWith #-} +zipWith :: Monad m => StreamK m Int -> m () +zipWith src = drain $ StreamK.zipWith (,) src src + +{-# INLINE zipWithM #-} +zipWithM :: Monad m => StreamK m Int -> m () +zipWithM src = drain $ StreamK.zipWithM (curry return) src src + +{-# INLINE sortByK #-} +sortByK :: (a -> a -> Ordering) -> StreamK m a -> StreamK m a +sortByK f = StreamK.mergeMapWith (StreamK.mergeBy f) StreamK.fromPure + +{-# INLINE sortBy #-} +sortBy :: Monad m => StreamK m Int -> m () +sortBy = drain . sortByK compare + +------------------------------------------------------------------------------- +-- Mixed Composition +------------------------------------------------------------------------------- + +{-# INLINE scanMap #-} +scanMap :: Monad m => Int -> StreamK m Int -> m () +scanMap n = composeN n $ StreamK.map (subtract 1) . StreamK.scanl' (+) 0 + +{-# INLINE dropMap #-} +dropMap :: Monad m => Int -> StreamK m Int -> m () +dropMap n = composeN n $ StreamK.map (subtract 1) . StreamK.drop 1 + +{-# INLINE dropScan #-} +dropScan :: Monad m => Int -> StreamK m Int -> m () +dropScan n = composeN n $ StreamK.scanl' (+) 0 . StreamK.drop 1 + +{-# INLINE takeDrop #-} +takeDrop :: Monad m => Int -> Int -> StreamK m Int -> m () +takeDrop streamLen n = composeN n $ StreamK.drop 1 . StreamK.take streamLen + +{-# INLINE takeScan #-} +takeScan :: Monad m => Int -> Int -> StreamK m Int -> m () +takeScan streamLen n = composeN n $ StreamK.scanl' (+) 0 . StreamK.take streamLen + +{-# INLINE takeMap #-} +takeMap :: Monad m => Int -> Int -> StreamK m Int -> m () +takeMap streamLen n = composeN n $ StreamK.map (subtract 1) . StreamK.take streamLen + +{-# INLINE filterDrop #-} +filterDrop :: Monad m => Int -> Int -> StreamK m Int -> m () +filterDrop streamLen n = composeN n $ StreamK.drop 1 . StreamK.filter (<= streamLen) + +{-# INLINE filterTake #-} +filterTake :: Monad m => Int -> Int -> StreamK m Int -> m () +filterTake streamLen n = composeN n $ StreamK.take streamLen . StreamK.filter (<= streamLen) + +{-# INLINE filterScan #-} +filterScan :: Monad m => Int -> StreamK m Int -> m () +filterScan n = composeN n $ StreamK.scanl' (+) 0 . StreamK.filter (<= maxBound) + +{-# INLINE filterMap #-} +filterMap :: Monad m => Int -> Int -> StreamK m Int -> m () +filterMap streamLen n = composeN n $ StreamK.map (subtract 1) . StreamK.filter (<= streamLen) + +------------------------------------------------------------------------------- +-- ConcatMap +------------------------------------------------------------------------------- + +-- concatMap unfoldrM/unfoldrM + +{-# INLINE concatMap #-} +concatMap :: Int -> Int -> Int -> IO () +concatMap outer inner n = + StreamK.drain $ StreamK.concatMap + (\_ -> unfoldrM inner n) + (unfoldrM outer n) + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'concatMap +#endif + +-- concatMap unfoldr/unfoldr + +{-# INLINE concatMapPure #-} +concatMapPure :: Int -> Int -> Int -> IO () +concatMapPure outer inner n = + StreamK.drain $ StreamK.concatMap + (\_ -> unfoldr inner n) + (unfoldr outer n) + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'concatMapPure +#endif + +-- concatMap replicate/unfoldrM + +{-# INLINE concatMapRepl #-} +concatMapRepl :: Int -> Int -> Int -> IO () +concatMapRepl outer inner n = + StreamK.drain $ StreamK.concatMap (StreamK.replicate inner) (unfoldrM outer n) + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'concatMapRepl +#endif + +-- concatMapWith + +{-# INLINE sourceConcatMapId #-} +sourceConcatMapId :: Monad m + => Int -> Int -> StreamK m (StreamK m Int) +sourceConcatMapId val n = + StreamK.fromFoldable $ fmap (StreamK.fromEffect . return) [n..n+val] + +{-# INLINE concatMapBySerial #-} +concatMapBySerial :: Int -> Int -> Int -> IO () +concatMapBySerial outer inner n = + StreamK.drain $ StreamK.concatMapWith StreamK.append + (unfoldrM inner) + (unfoldrM outer n) + +------------------------------------------------------------------------------- +-- Nested Composition +------------------------------------------------------------------------------- + +instance Monad m => Applicative (StreamK.StreamK m) where + {-# INLINE pure #-} + pure = StreamK.fromPure + + {-# INLINE (<*>) #-} + (<*>) = StreamK.crossApply + + {-# INLINE liftA2 #-} + liftA2 f x = (<*>) (fmap f x) + + {-# INLINE (*>) #-} + (*>) = StreamK.crossApplySnd + + {-# INLINE (<*) #-} + (<*) = StreamK.crossApplyFst + +-- 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 (StreamK.StreamK m) where + {-# INLINE return #-} + return = pure + + {-# INLINE (>>=) #-} + (>>=) = flip StreamK.concatMap + +{-# INLINE drainApplicative #-} +drainApplicative :: Monad m => StreamK m Int -> m () +drainApplicative s = drain $ do + (+) <$> s <*> s + +{-# INLINE drainMonad #-} +drainMonad :: Monad m => StreamK m Int -> m () +drainMonad s = drain $ do + x <- s + y <- s + return $ x + y + +{-# INLINE drainConcatFor1 #-} +drainConcatFor1 :: Monad m => StreamK m Int -> m () +drainConcatFor1 s = drain $ do + StreamK.concatFor s $ \x -> + StreamK.fromPure $ x + 1 + +{-# INLINE drainConcatFor #-} +drainConcatFor :: Monad m => StreamK m Int -> m () +drainConcatFor s = drain $ do + StreamK.concatFor s $ \x -> + StreamK.concatFor s $ \y -> + StreamK.fromPure $ x + y + +{-# INLINE drainConcatForM #-} +drainConcatForM :: Monad m => StreamK m Int -> m () +drainConcatForM s = drain $ do + StreamK.concatForM s $ \x -> + pure $ StreamK.concatForM s $ \y -> + pure $ StreamK.fromPure $ x + y + +{-# INLINE drainMonad3 #-} +drainMonad3 :: Monad m => StreamK m Int -> m () +drainMonad3 s = drain $ do + x <- s + y <- s + z <- s + return $ x + y + z + +{-# INLINE drainConcatFor3 #-} +drainConcatFor3 :: Monad m => StreamK m Int -> m () +drainConcatFor3 s = drain $ do + StreamK.concatFor s $ \x -> + StreamK.concatFor s $ \y -> + StreamK.concatFor s $ \z -> + StreamK.fromPure $ x + y + z + +{-# INLINE drainConcatFor3M #-} +drainConcatFor3M :: Monad m => StreamK m Int -> m () +drainConcatFor3M s = drain $ do + StreamK.concatForM s $ \x -> + pure $ StreamK.concatForM s $ \y -> + pure $ StreamK.concatForM s $ \z -> + pure $ StreamK.fromPure $ x + y + z + +{-# INLINE drainConcatFor4 #-} +drainConcatFor4 :: Monad m => StreamK m Int -> m () +drainConcatFor4 s = drain $ do + StreamK.concatFor s $ \x -> + StreamK.concatFor s $ \y -> + StreamK.concatFor s $ \z -> + StreamK.concatFor s $ \w -> + StreamK.fromPure $ x + y + z + w + +{-# INLINE drainConcatFor5 #-} +drainConcatFor5 :: Monad m => StreamK m Int -> m () +drainConcatFor5 s = drain $ do + StreamK.concatFor s $ \x -> + StreamK.concatFor s $ \y -> + StreamK.concatFor s $ \z -> + StreamK.concatFor s $ \w -> + StreamK.concatFor s $ \u -> + StreamK.fromPure $ x + y + z + w + u + +{-# INLINE filterAllOutMonad #-} +filterAllOutMonad + :: Monad m + => StreamK m Int -> m () +filterAllOutMonad str = drain $ do + x <- str + y <- str + let s = x + y + if s < 0 + then return s + else StreamK.nil + +{-# INLINE filterAllOutConcatFor #-} +filterAllOutConcatFor + :: Monad m + => StreamK m Int -> m () +filterAllOutConcatFor s = drain $ do + StreamK.concatFor s $ \x -> + StreamK.concatFor s $ \y -> + let s1 = x + y + in if s1 < 0 + then StreamK.fromPure s1 + else StreamK.nil + +{-# INLINE filterAllInMonad #-} +filterAllInMonad + :: Monad m + => StreamK m Int -> m () +filterAllInMonad str = drain $ do + x <- str + y <- str + let s = x + y + if s > 0 + then return s + else StreamK.nil + +{-# INLINE filterAllInConcatFor #-} +filterAllInConcatFor + :: Monad m + => StreamK m Int -> m () +filterAllInConcatFor s = drain $ do + StreamK.concatFor s $ \x -> + StreamK.concatFor s $ \y -> + let s1 = x + y + in if s1 > 0 + then StreamK.fromPure s1 + else StreamK.nil + +------------------------------------------------------------------------------- +-- Nested Composition Pure lists +------------------------------------------------------------------------------- + +-- There are several list benchmarks here for comparison with lists. It is easy +-- and convenient to see the comparisons when they are here, otherwise we'll +-- have to add a separate module for list benchmarks with the same names and +-- then add a comparison in bench.sh. + +{-# INLINE unfoldrList #-} +unfoldrList :: Int -> Int -> [Int] +unfoldrList 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 [] + +------------------------------------------------------------------------------- +-- Benchmarks +------------------------------------------------------------------------------- + +moduleName :: String +moduleName = "Data.StreamK" + +o_1_space_generation :: Int -> Benchmark +o_1_space_generation streamLen = + bgroup "generation" + [ benchFold "unfoldr" drain (unfoldr streamLen) + , benchFold "unfoldrM" drain (unfoldrM streamLen) + , benchFold "repeat" drain (repeat streamLen) + , benchFold "repeatM" drain (repeatM streamLen) + , benchFold "replicate" drain (replicate streamLen) + , benchFold "replicateM" drain (replicateM streamLen) + , benchFold "iterate" drain (iterate streamLen) + , benchFold "iterateM" drain (iterateM streamLen) + + , benchFold "fromFoldable" drain (fromFoldable streamLen) + , benchFold "fromFoldableM" drain (fromFoldableM streamLen) + + -- appends + , benchFold "concatMapFoldableWith" drain (concatMapFoldableSerial streamLen) + , benchFold "concatMapFoldableWithM" drain (concatMapFoldableSerialM streamLen) + ] + +o_1_space_elimination :: Int -> Benchmark +o_1_space_elimination streamLen = + bgroup "elimination" + [ benchFold "toNull" drain (unfoldrM streamLen) + , benchFold "mapM_" mapM_ (unfoldrM streamLen) + , benchFold "uncons" uncons (unfoldrM streamLen) + , benchFold "init" init (unfoldrM streamLen) + , benchFold "foldl'" foldl' (unfoldrM streamLen) + , benchFold "foldlM'" foldlM' (unfoldrM streamLen) + , benchFold "last" last (unfoldrM streamLen) + ] + +o_1_space_ap :: Int -> Benchmark +o_1_space_ap streamLen = + bgroup "Applicative" + [ benchFold "drain2" drainApplicative (unfoldrM streamLen2) + , benchFold "pureDrain2" drainApplicative (unfoldr streamLen2) + ] + where + streamLen2 = round (P.fromIntegral streamLen**(1/2::P.Double)) -- double nested loop + +o_1_space_monad :: Int -> Benchmark +o_1_space_monad streamLen = + bgroup "Monad" + [ benchFold "drain2" drainMonad (unfoldrM streamLen2) + , benchFold "drain3" drainMonad3 (unfoldrM streamLen3) + , benchFold "filterAllIn2" filterAllInMonad (unfoldrM streamLen2) + , benchFold "filterAllOut2" filterAllOutMonad (unfoldrM streamLen2) + , benchFold "pureDrain2" drainMonad (unfoldr streamLen2) + , benchFold "pureDrain3" drainMonad3 (unfoldr streamLen3) + , benchFold "pureFilterAllIn2" filterAllInMonad (unfoldr streamLen2) + , benchFold "pureFilterAllOut2" filterAllOutMonad (unfoldr streamLen2) + ] + where + streamLen2 = round (P.fromIntegral streamLen**(1/2::P.Double)) -- double nested loop + streamLen3 = round (P.fromIntegral streamLen**(1/3::P.Double)) -- triple nested loop + +o_1_space_bind :: Int -> Benchmark +o_1_space_bind streamLen = + bgroup "concatFor" + [ benchFold "drain1" drainConcatFor1 (unfoldrM streamLen) + , benchFold "drain2" drainConcatFor (unfoldrM streamLen2) + , benchFold "drainM2" drainConcatForM (unfoldrM streamLen2) + , benchFold "drain3" drainConcatFor3 (unfoldrM streamLen3) + , benchFold "drain4" drainConcatFor4 (unfoldrM streamLen4) + , benchFold "drain5" drainConcatFor5 (unfoldrM streamLen5) + , benchFold "drainM3" drainConcatFor3M (unfoldrM streamLen3) + , benchFold "filterAllIn2" filterAllInConcatFor (unfoldrM streamLen2) + , benchFold "filterAllOut2" filterAllOutConcatFor (unfoldrM streamLen2) + ] + where + streamLen2 = round (P.fromIntegral streamLen**(1/2::P.Double)) -- double nested loop + streamLen3 = round (P.fromIntegral streamLen**(1/3::P.Double)) -- triple nested loop + streamLen4 = round (P.fromIntegral streamLen**(1/4::P.Double)) -- 4 times nested loop + streamLen5 = round (P.fromIntegral streamLen**(1/5::P.Double)) -- 5 times nested loop + +o_1_space_transformation :: Int -> Benchmark +o_1_space_transformation streamLen = + bgroup "transformation" + [ benchFold "foldrS" (foldrS 1) (unfoldrM streamLen) + , benchFold "scanl'" (scanl' 1) (unfoldrM streamLen) + , benchFold "map" (map 1) (unfoldrM streamLen) + , benchFold "fmap" (fmapK 1) (unfoldrM streamLen) + , benchFold "mapM" (mapM 1) (unfoldrM streamLen) + , benchFold "mapMSerial" (mapMSerial 1) (unfoldrM streamLen) + ] + +o_1_space_transformationX4 :: Int -> Benchmark +o_1_space_transformationX4 streamLen = + bgroup "transformationX4" + [ benchFold "scanl'" (scanl' 4) (unfoldrM streamLen) + , benchFold "map" (map 4) (unfoldrM streamLen) + , benchFold "fmap" (fmapK 4) (unfoldrM streamLen) + , benchFold "mapM" (mapM 4) (unfoldrM streamLen) + , benchFold "mapMSerial" (mapMSerial 4) (unfoldrM streamLen) + -- XXX this is horribly slow + -- , benchFold "concatMap" (concatMap 4) (unfoldrM streamLen16) + ] + +o_1_space_concat :: Int -> Benchmark +o_1_space_concat streamLen = + bgroup "concat" + [ benchIOSrc1 "concatMapPure outer=Max inner=1" + (concatMapPure streamLen 1) + , benchIOSrc1 "concatMapPure outer=inner=(sqrt Max)" + (concatMapPure streamLen2 streamLen2) + , benchIOSrc1 "concatMapPure outer=1 inner=Max" + (concatMapPure 1 streamLen) + + , benchIOSrc1 "concatMap outer=Max inner=1" + (concatMap streamLen 1) + , benchIOSrc1 "concatMap outer=inner=(sqrt Max)" + (concatMap streamLen2 streamLen2) + , benchIOSrc1 "concatMap outer=1 inner=Max" + (concatMap 1 streamLen) + + , benchIOSrc1 "concatMapRepl outer=inner=(sqrt Max)" + (concatMapRepl streamLen2 streamLen2) + + -- This is for comparison with concatMapFoldableWith + , benchIOSrc1 "concatMapWithId outer=Max inner=1 (fromFoldable)" + (StreamK.drain + . StreamK.concatMapWith StreamK.append id + . sourceConcatMapId streamLen) + + , benchIOSrc1 "concatMapWith append outer=Max inner=1" + (concatMapBySerial streamLen 1) + , benchIOSrc1 "concatMapWith append outer=inner=(sqrt Max)" + (concatMapBySerial streamLen2 streamLen2) + , benchIOSrc1 "concatMapWith append outer=1 inner=Max" + (concatMapBySerial 1 streamLen) + ] + where + streamLen2 = round (P.fromIntegral streamLen**(1/2::P.Double)) -- double nested loop + +o_1_space_filtering :: Int -> Benchmark +o_1_space_filtering streamLen = + bgroup "filtering" + [ benchFold "filter-even" (filterEven 1) (unfoldrM streamLen) + , benchFold "filter-all-out" (filterAllOut streamLen 1) (unfoldrM streamLen) + , benchFold "filter-all-in" (filterAllIn streamLen 1) (unfoldrM streamLen) + , benchFold "take-all" (takeAll streamLen 1) (unfoldrM streamLen) + , benchFold "takeWhile-true" (takeWhileTrue streamLen 1) (unfoldrM streamLen) + , benchFold "drop-one" (dropOne 1) (unfoldrM streamLen) + , benchFold "drop-all" (dropAll streamLen 1) (unfoldrM streamLen) + , benchFold "dropWhile-true" (dropWhileTrue streamLen 1) (unfoldrM streamLen) + , benchFold "dropWhile-false" (dropWhileFalse 1) (unfoldrM streamLen) + ] + +o_1_space_filteringX4 :: Int -> Benchmark +o_1_space_filteringX4 streamLen = + bgroup "filteringX4" + [ benchFold "filter-even" (filterEven 4) (unfoldrM streamLen) + , benchFold "filter-all-out" (filterAllOut streamLen 4) (unfoldrM streamLen) + , benchFold "filter-all-in" (filterAllIn streamLen 4) (unfoldrM streamLen) + , benchFold "take-all" (takeAll streamLen 4) (unfoldrM streamLen) + , benchFold "takeWhile-true" (takeWhileTrue streamLen 4) (unfoldrM streamLen) + , benchFold "drop-one" (dropOne 4) (unfoldrM streamLen) + , benchFold "drop-all" (dropAll streamLen 4) (unfoldrM streamLen) + , benchFold "dropWhile-true" (dropWhileTrue streamLen 4) (unfoldrM streamLen) + , benchFold "dropWhile-false" (dropWhileFalse 4) (unfoldrM streamLen) + ] + +o_1_space_zipping :: Int -> Benchmark +o_1_space_zipping streamLen = + bgroup "zipping" + [ benchFold "zipWith" zipWith (unfoldrM streamLen) + , benchFold "zipWithM" zipWithM (unfoldrM streamLen) + ] + +o_1_space_mixed :: Int -> Benchmark +o_1_space_mixed streamLen = + bgroup "mixed" + [ benchFold "scan-map" (scanMap 1) (unfoldrM streamLen) + , benchFold "drop-map" (dropMap 1) (unfoldrM streamLen) + , benchFold "drop-scan" (dropScan 1) (unfoldrM streamLen) + , benchFold "take-drop" (takeDrop streamLen 1) (unfoldrM streamLen) + , benchFold "take-scan" (takeScan streamLen 1) (unfoldrM streamLen) + , benchFold "take-map" (takeMap streamLen 1) (unfoldrM streamLen) + , benchFold "filter-drop" (filterDrop streamLen 1) (unfoldrM streamLen) + , benchFold "filter-take" (filterTake streamLen 1) (unfoldrM streamLen) + , benchFold "filter-scan" (filterScan 1) (unfoldrM streamLen) + , benchFold "filter-map" (filterMap streamLen 1) (unfoldrM streamLen) + ] + +o_1_space_mixedX2 :: Int -> Benchmark +o_1_space_mixedX2 streamLen = + bgroup "mixedX2" + [ benchFold "scan-map" (scanMap 2) (unfoldrM streamLen) + , benchFold "drop-map" (dropMap 2) (unfoldrM streamLen) + , benchFold "drop-scan" (dropScan 2) (unfoldrM streamLen) + , benchFold "take-drop" (takeDrop streamLen 2) (unfoldrM streamLen) + , benchFold "take-scan" (takeScan streamLen 2) (unfoldrM streamLen) + , benchFold "take-map" (takeMap streamLen 2) (unfoldrM streamLen) + , benchFold "filter-drop" (filterDrop streamLen 2) (unfoldrM streamLen) + , benchFold "filter-take" (filterTake streamLen 2) (unfoldrM streamLen) + , benchFold "filter-scan" (filterScan 2) (unfoldrM streamLen) + , benchFold "filter-map" (filterMap streamLen 2) (unfoldrM streamLen) + ] + +o_1_space_mixedX4 :: Int -> Benchmark +o_1_space_mixedX4 streamLen = + bgroup "mixedX4" + [ benchFold "scan-map" (scanMap 4) (unfoldrM streamLen) + , benchFold "drop-map" (dropMap 4) (unfoldrM streamLen) + , benchFold "drop-scan" (dropScan 4) (unfoldrM streamLen) + , benchFold "take-drop" (takeDrop streamLen 4) (unfoldrM streamLen) + , benchFold "take-scan" (takeScan streamLen 4) (unfoldrM streamLen) + , benchFold "take-map" (takeMap streamLen 4) (unfoldrM streamLen) + , benchFold "filter-drop" (filterDrop streamLen 4) (unfoldrM streamLen) + , benchFold "filter-take" (filterTake streamLen 4) (unfoldrM streamLen) + , benchFold "filter-scan" (filterScan 4) (unfoldrM streamLen) + , benchFold "filter-map" (filterMap streamLen 4) (unfoldrM streamLen) + ] + +o_1_space_list :: Int -> Benchmark +o_1_space_list streamLen = + bgroup "list" + [ bgroup "elimination" + [ benchList "last" (\xs -> [List.last xs]) (unfoldrList streamLen) + ] + , bgroup "Applicative" + [ benchList "drain2" toNullApNestedList (unfoldrList streamLen2) + ] + , bgroup "Monad" + [ benchList "drain2" toNullNestedList (unfoldrList streamLen2) + , benchList "drain3" toNullNestedList3 (unfoldrList streamLen3) + , benchList "filterAllIn2" filterAllInNestedList (unfoldrList streamLen2) + , benchList "filterAllOut2" filterAllOutNestedList (unfoldrList streamLen2) + ] + ] + where + + streamLen2 = round (P.fromIntegral streamLen**(1/2::P.Double)) -- double nested loop + streamLen3 = round (P.fromIntegral streamLen**(1/3::P.Double)) -- triple nested loop + +o_1_space :: Int -> Benchmark +o_1_space streamLen = + bgroup (o_1_space_prefix moduleName) + [ o_1_space_generation streamLen + , o_1_space_elimination streamLen + , o_1_space_ap streamLen + , o_1_space_monad streamLen + , o_1_space_bind streamLen + , o_1_space_transformation streamLen + , o_1_space_transformationX4 streamLen + , o_1_space_concat streamLen + , o_1_space_filtering streamLen + , o_1_space_filteringX4 streamLen + , o_1_space_zipping streamLen + , o_1_space_mixed streamLen + , o_1_space_mixedX2 streamLen + , o_1_space_mixedX4 streamLen + , o_1_space_list streamLen + ] + +o_n_heap :: Int -> Benchmark +o_n_heap streamLen = + bgroup (o_n_heap_prefix moduleName) + [ bgroup "transformation" + [ benchFold "foldlS" (foldlS 1) (unfoldrM streamLen) + ] + , bgroup "concat" + [ benchFold "sortBy" sortBy (unfoldrM streamLen) + ] + ] + +{-# INLINE benchK #-} +benchK :: P.String -> (Int -> StreamK P.IO Int) -> Benchmark +benchK name f = bench name $ nfIO $ randomRIO (1,1) >>= drain . f + +o_n_stack :: Int -> Int -> Int -> Benchmark +o_n_stack streamLen iterStreamLen maxIters = + bgroup (o_n_stack_prefix moduleName) + [ bgroup "elimination" + [ benchFold "tail" tail (unfoldrM streamLen) + , benchFold "nullTail" nullTail (unfoldrM streamLen) + , benchFold "headTail" headTail (unfoldrM streamLen) + ] + , bgroup "transformation" + [ + -- XXX why do these need so much stack + benchFold "intersperse" (intersperse streamLen 1) (unfoldrM streamLen2) + , benchFold "interspersePure" (intersperse streamLen 1) (unfoldr streamLen2) + ] + , bgroup "transformationX4" + [ + benchFold "intersperse" (intersperse streamLen 4) (unfoldrM streamLen16) + ] + , bgroup "iterated" + [ benchK "mapM" (iterateMapM iterStreamLen maxIters) + , benchK "scan(1/10)" (iterateScan iterStreamLen maxIters) + , benchK "filterEven" (iterateFilterEven iterStreamLen maxIters) + , benchK "takeAll" (iterateTakeAll streamLen iterStreamLen maxIters) + , benchK "dropOne" (iterateDropOne iterStreamLen maxIters) + , benchK "dropWhileFalse(1/10)" (iterateDropWhileFalse streamLen iterStreamLen maxIters) + , benchK "dropWhileTrue" (iterateDropWhileTrue streamLen iterStreamLen maxIters) + ] + ] + where + streamLen2 = round (P.fromIntegral streamLen**(1/2::P.Double)) -- double nested loop + streamLen16 = round (P.fromIntegral streamLen**(1/16::P.Double)) -- triple nested loop + +o_n_space :: Int -> Benchmark +o_n_space streamLen = + bgroup (o_n_space_prefix moduleName) + [ bgroup "elimination" + [ benchFold "toList" toList (unfoldrM streamLen) + ] + ] + +{- HLINT ignore "Use <&>" -} +{-# INLINE benchList #-} +benchList :: P.String -> ([Int] -> [Int]) -> (Int -> [Int]) -> Benchmark +benchList name run f = bench name $ nfIO $ randomRIO (1,1) >>= return . run . f + +main :: IO () +main = do + runWithCLIOpts defaultStreamSize allBenchmarks + + where + + allBenchmarks streamLen = + let !iterStreamLen = 10 + !maxIters = streamLen `div` iterStreamLen + in [ o_1_space streamLen + , o_n_stack streamLen iterStreamLen maxIters + , o_n_heap streamLen + , o_n_space streamLen + ] diff --git a/benchmark/Streamly/Benchmark/Data/StreamK/FromStream.hs b/benchmark/Streamly/Benchmark/Data/StreamK/FromStream.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Data/StreamK/FromStream.hs @@ -0,0 +1,1497 @@ +-- | +-- Module : Streamly.Benchmark.Data.StreamK.FromStream +-- Copyright : (c) 2018 Composewell Technologies +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- +-- There are two ways to benchmark mixed use of Stream and StreamK. +-- +-- First, benchmark one StreamK operation using all other operations from +-- Stream. This is for comparison of all pure StreamK operations vs using +-- operations from Stream whenever possible. We should compare these benchmarks +-- with pure StreamK benchmarks. +-- +-- Second, benchmark one Stream operation with all other operations from +-- StreamK. +-- +-- XXX This module uses both of the above, we need to separate the two in +-- separate benchmark groups. + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +#ifdef __HADDOCK_VERSION__ +#undef INSPECTION +#endif + +#ifdef INSPECTION +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-} +#endif + +module Main (main) where + +-- import Control.Applicative (liftA2) +-- import Control.Monad (when) +-- import Data.Maybe (isJust) +-- import System.Random (randomRIO) + +import Control.DeepSeq (NFData(..)) +import Control.Exception (try) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.State.Strict (StateT, get, put) +import Data.Functor.Identity (Identity, runIdentity) +import GHC.Exception (ErrorCall) +import Streamly.Internal.Data.Stream (Stream) +import Streamly.Internal.Data.StreamK (StreamK, CrossStreamK) +import System.IO.Unsafe (unsafeInterleaveIO) +import System.Random (randomRIO) +import Test.Tasty.Bench (bgroup, Benchmark, defaultMain, nf, nfIO, bench) + +import qualified Prelude as P +-- import qualified Data.List as List +import qualified Control.Monad.State.Strict as State +import qualified Streamly.Internal.Data.Parser as Parser +import qualified Streamly.Internal.Data.StreamK as StreamK +import qualified Streamly.Internal.Data.Stream as Stream +import qualified Streamly.Internal.Data.Fold as Fold + +import Prelude hiding + ( tail, mapM_, foldl, last, map, mapM, concatMap, zipWith, init, iterate + , repeat, replicate, reverse + ) +import Streamly.Benchmark.Common +#ifdef INSPECTION +import Test.Inspection +#endif + +------------------------------------------------------------------------------- +-- Bench utilities +------------------------------------------------------------------------------- + +{-# NOINLINE benchIO #-} +benchIO :: (NFData b) => String -> (Int -> IO b) -> Benchmark +benchIO name f = bench name $ nfIO $ randomRIO (1,1) >>= f + +-- | Takes a source, and uses it with a default drain/fold method. +{-# INLINE benchIOSrc #-} +benchIOSrc + :: String + -> (Int -> StreamK IO a) + -> Benchmark +benchIOSrc name f = + bench name $ nfIO $ randomRIO (1,1) >>= drain . f + +{-# INLINE benchIOSink #-} +benchIOSink + :: (NFData b) + => Int -> String -> (StreamK IO Int -> IO b) -> Benchmark +benchIOSink value name f = + bench name $ nfIO $ randomRIO (1,1) >>= f . unfoldrMD value + +-- XXX We should be using sourceUnfoldrM for fair comparison with IO monad, but +-- we can't use it as it requires MonadAsync constraint. +{-# INLINE benchIdentitySink #-} +benchIdentitySink + :: (NFData b) + => Int -> String -> (Stream Identity Int -> Identity b) -> Benchmark +benchIdentitySink value name f = bench name $ nf (f . unfoldr value) 1 + +------------------------------------------------------------------------------- +-- Stream generation and elimination +------------------------------------------------------------------------------- + +{-# INLINE unfoldr #-} +unfoldr :: Monad m => Int -> Int -> Stream m Int +unfoldr streamLen n = Stream.unfoldr step n + where + step cnt = + if cnt > n + streamLen + then Nothing + else Just (cnt, cnt + 1) + +{-# INLINE unfoldrD #-} +unfoldrD :: Monad m => Int -> Int -> StreamK m Int +unfoldrD streamLen n = Stream.toStreamK $ unfoldr streamLen n + +{-# INLINE unfoldrMD #-} +unfoldrMD :: Monad m => Int -> Int -> StreamK m Int +unfoldrMD streamLen n = Stream.toStreamK (Stream.unfoldrM step n) + where + step cnt = + if cnt > n + streamLen + then return Nothing + else return (Just (cnt, cnt + 1)) + +{- +{-# INLINE unfoldrK #-} +unfoldrK :: Int -> Int -> StreamK m Int +unfoldrK streamLen n = StreamK.unfoldr step n + where + step cnt = + if cnt > n + streamLen + then Nothing + else Just (cnt, cnt + 1) +-} + +{-# INLINE unfoldrMK #-} +unfoldrMK :: Monad m => Int -> Int -> StreamK m Int +unfoldrMK streamLen n = StreamK.unfoldrMWith StreamK.consM step n + where + step cnt = + if cnt > n + streamLen + then return Nothing + else return (Just (cnt, cnt + 1)) + +{-# INLINE repeat #-} +repeat :: Monad m => Int -> Int -> StreamK m Int +repeat streamLen = StreamK.take streamLen . Stream.toStreamK . Stream.repeat + +{-# INLINE repeatM #-} +repeatM :: Monad m => Int -> Int -> StreamK m Int +repeatM streamLen = StreamK.take streamLen . Stream.toStreamK . Stream.repeatM . return + +{-# INLINE replicate #-} +replicate :: Monad m => Int -> Int -> StreamK m Int +replicate x y = Stream.toStreamK $ Stream.replicate x y + +{-# INLINE replicateM #-} +replicateM :: Monad m => Int -> Int -> StreamK m Int +replicateM streamLen = Stream.toStreamK . Stream.replicateM streamLen . return + +{-# INLINE iterate #-} +iterate :: Monad m => Int -> Int -> StreamK m Int +iterate streamLen = StreamK.take streamLen . Stream.toStreamK . Stream.iterate (+1) + +{-# INLINE iterateM #-} +iterateM :: Monad m => Int -> Int -> StreamK m Int +iterateM streamLen = StreamK.take streamLen . Stream.toStreamK . Stream.iterateM (return . (+1)) . return + +{-# INLINE fromFoldable #-} +fromFoldable :: Int -> Int -> StreamK m Int +fromFoldable streamLen n = StreamK.fromFoldable [n..n+streamLen] + +{-# INLINE fromFoldableM #-} +fromFoldableM :: Monad m => Int -> Int -> StreamK m Int +fromFoldableM streamLen n = + Prelude.foldr (StreamK.consM . return) StreamK.nil [n .. n + streamLen] + +{- +{-# INLINABLE concatMapFoldableWith #-} +concatMapFoldableWith :: Foldable f + => (StreamK m b -> StreamK m b -> StreamK m b) + -> (a -> StreamK m b) + -> f a + -> StreamK m b +concatMapFoldableWith f g = Prelude.foldr (f . g) StreamK.nil +-} + +{-# INLINE concatMapFoldableSerial #-} +concatMapFoldableSerial :: Monad m => Int -> Int -> StreamK m Int +concatMapFoldableSerial streamLen n = + Stream.toStreamK $ Stream.concatMap Stream.fromPure $ Stream.fromStreamK $ StreamK.fromList [n..n+streamLen] + +{-# INLINE concatMapFoldableSerialM #-} +concatMapFoldableSerialM :: Monad m => Int -> Int -> StreamK m Int +concatMapFoldableSerialM streamLen n = + -- concatMapFoldableWith StreamK.serial (StreamK.fromEffect . return) [n..n+streamLen] + Stream.toStreamK $ Stream.concatMap (Stream.fromEffect . return) $ Stream.fromStreamK $ StreamK.fromList [n..n+streamLen] + +{-# INLINE mfixUnfold #-} +mfixUnfold :: Int -> Int -> StreamK IO (Int, Int) +mfixUnfold count start = StreamK.mfix f + where + f action = StreamK.unCross $ do + let incr n act = fmap ((+n) . snd) $ unsafeInterleaveIO act + x <- StreamK.mkCross (StreamK.fromStream $ Stream.fromListM [incr 1 action, incr 2 action]) + y <- StreamK.mkCross (unfoldrD count start) + return (x, y) + +------------------------------------------------------------------------------- +-- Elimination +------------------------------------------------------------------------------- + +{-# INLINE drainD #-} +drainD :: Monad m => StreamK m a -> m () +drainD = Stream.drain . Stream.fromStreamK + +{-# INLINE drain #-} +drain :: Monad m => StreamK m a -> m () +-- XXX Use "Stream" instead of "StreamK" when eliminating? +-- drain = drainD +drain = StreamK.drain + +{-# INLINE mapM_ #-} +mapM_ :: Monad m => StreamK m a -> m () +mapM_ s = Stream.mapM_ (\_ -> return ()) $ Stream.fromStreamK s + +{-# INLINE uncons #-} +uncons :: Monad m => StreamK m Int -> m () +uncons s = do + r <- StreamK.uncons s + case r of + Nothing -> return () + Just (_, t) -> uncons t + +-- Recursive call, does it work well? +{-# INLINE unconsD #-} +unconsD :: Monad m => StreamK m Int -> m () +unconsD s = do + r <- Stream.uncons $ Stream.fromStreamK s + case r of + Nothing -> return () + Just (_, t) -> uncons (Stream.toStreamK t) + +{- +{-# INLINE init #-} +init :: Monad m => StreamK m a -> m () +init s = do + t <- StreamK.init s + P.mapM_ StreamK.drain t + +{-# INLINE tail #-} +tail :: Monad m => StreamK m a -> m () +tail s = StreamK.tail s >>= P.mapM_ tail + +{-# INLINE nullTail #-} +nullTail :: Monad m => StreamK m Int -> m () +nullTail s = do + r <- StreamK.null s + when (not r) $ StreamK.tail s >>= P.mapM_ nullTail + +{-# INLINE headTail #-} +headTail :: Monad m => StreamK m Int -> m () +headTail s = do + h <- StreamK.head s + when (isJust h) $ StreamK.tail s >>= P.mapM_ headTail +-} + +{-# INLINE toList #-} +toList :: Monad m => StreamK m Int -> m [Int] +toList = Stream.fold Fold.toList . Stream.fromStreamK + +{-# INLINE foldl' #-} +foldl' :: Monad m => StreamK m Int -> m Int +foldl' = Stream.fold (Fold.foldl' (+) 0) . Stream.fromStreamK + +{-# INLINE last #-} +last :: Monad m => StreamK m Int -> m (Maybe Int) +last = Stream.fold Fold.latest . Stream.fromStreamK + +------------------------------------------------------------------------------- +-- Transformation +------------------------------------------------------------------------------- + +{-# INLINE composeN #-} +composeN + :: Monad m + => Int -> (StreamK m Int -> StreamK m Int) -> StreamK m Int -> m () +composeN n f = + case n of + 1 -> drain . f + 2 -> drain . f . f + 3 -> drain . f . f . f + 4 -> drain . f . f . f . f + _ -> undefined + +{-# INLINE scanl' #-} +scanl' :: Monad m => Int -> StreamK m Int -> m () +scanl' n = + composeN n (Stream.toStreamK . Stream.scan (Fold.foldl' (+) 0) . Stream.fromStreamK) + +{-# INLINE map #-} +map :: Monad m => Int -> StreamK m Int -> m () +map n = composeN n (Stream.toStreamK . Stream.map (+ 1) . Stream.fromStreamK) + +{- +{-# INLINE fmapK #-} +fmapK :: Monad m => Int -> StreamK m Int -> m () +fmapK n = composeN n $ P.fmap (+ 1) +-} + +{-# INLINE mapM #-} +mapM :: Monad m => Int -> StreamK m Int -> m () +mapM n = composeN n (Stream.toStreamK . Stream.mapM return . Stream.fromStreamK) + +{- +{-# INLINE mapMSerial #-} +mapMSerial :: StreamK.MonadAsync m => Int -> StreamK m Int -> m () +mapMSerial n = composeN n $ StreamK.mapMSerial return +-} + +{-# INLINE filterEven #-} +filterEven :: Monad m => Int -> StreamK m Int -> m () +filterEven n = composeN n (Stream.toStreamK . Stream.filter even . Stream.fromStreamK) + +{- +{-# INLINE filterAllOut #-} +filterAllOut :: Monad m => Int -> Int -> StreamK m Int -> m () +filterAllOut streamLen n = composeN n $ StreamK.filter (> streamLen) + +{-# INLINE filterAllIn #-} +filterAllIn :: Monad m => Int -> Int -> StreamK m Int -> m () +filterAllIn streamLen n = composeN n $ StreamK.filter (<= streamLen) + +{-# INLINE _takeOne #-} +_takeOne :: Monad m => Int -> StreamK m Int -> m () +_takeOne n = composeN n $ StreamK.take 1 + +{-# INLINE takeAll #-} +takeAll :: Monad m => Int -> Int -> StreamK m Int -> m () +takeAll streamLen n = composeN n $ StreamK.take streamLen + +{-# INLINE takeWhileTrue #-} +takeWhileTrue :: Monad m => Int -> Int -> StreamK m Int -> m () +takeWhileTrue streamLen n = composeN n $ StreamK.takeWhile (<= streamLen) + +{-# INLINE dropOne #-} +dropOne :: Monad m => Int -> StreamK m Int -> m () +dropOne n = composeN n $ StreamK.drop 1 + +{-# INLINE dropAll #-} +dropAll :: Monad m => Int -> Int -> StreamK m Int -> m () +dropAll streamLen n = composeN n $ StreamK.drop streamLen + +{-# INLINE dropWhileTrue #-} +dropWhileTrue :: Monad m => Int -> Int -> StreamK m Int -> m () +dropWhileTrue streamLen n = composeN n $ StreamK.dropWhile (<= streamLen) + +{-# INLINE dropWhileFalse #-} +dropWhileFalse :: Monad m => Int -> StreamK m Int -> m () +dropWhileFalse n = composeN n $ StreamK.dropWhile (<= 1) +-} + +{- +{-# INLINE foldlS #-} +foldlS :: Monad m => Int -> StreamK m Int -> m () +foldlS n = composeN n $ StreamK.foldlS (flip StreamK.cons) StreamK.nil +-} + +{-# INLINE foldrS #-} +foldrS :: MonadIO m => Int -> StreamK m Int -> m () +foldrS n = + composeN n (StreamK.foldrS StreamK.cons StreamK.nil) + +{-# INLINE foldrSMap #-} +foldrSMap :: MonadIO m => Int -> StreamK m Int -> m () +foldrSMap n = + composeN n + ( + StreamK.foldrS (\x xs -> x + 1 `StreamK.cons` xs) StreamK.nil + ) + +{-# INLINE foldrToStream #-} +foldrToStream :: Monad m => Stream m Int -> m (StreamK Identity Int) +foldrToStream = Stream.foldr StreamK.cons StreamK.nil + +{- +{-# INLINE intersperse #-} +intersperse :: StreamK.MonadAsync m => Int -> Int -> StreamK m Int -> m () +intersperse streamLen n = composeN n $ StreamK.intersperse streamLen +-} + +------------------------------------------------------------------------------- +-- Traversable Instance +------------------------------------------------------------------------------- + +{-# INLINE traversableTraverse #-} +traversableTraverse :: StreamK Identity Int -> IO (StreamK Identity Int) +traversableTraverse = traverse return + +{- HLINT ignore "Use traverse" -} +{-# INLINE traversableSequenceA #-} +traversableSequenceA :: StreamK Identity Int -> IO (StreamK Identity Int) +traversableSequenceA = sequenceA . Prelude.fmap return + +{-# INLINE traversableMapM #-} +traversableMapM :: StreamK Identity Int -> IO (StreamK Identity Int) +traversableMapM = P.mapM return + +{- HLINT ignore "Use mapM" -} +{-# INLINE traversableSequence #-} +traversableSequence :: StreamK Identity Int -> IO (StreamK Identity Int) +traversableSequence = Prelude.sequence . Prelude.fmap return + +{-# INLINE benchPureSinkIO #-} +benchPureSinkIO + :: NFData b + => Int -> String -> (StreamK Identity Int -> IO b) -> Benchmark +benchPureSinkIO value name f = + bench name + $ nfIO $ randomRIO (1, 1) >>= f . unfoldrD value + +instance NFData a => NFData (StreamK Identity a) where + {-# INLINE rnf #-} + rnf xs = + runIdentity + $ Stream.fold (Fold.foldl' (\_ x -> rnf x) ()) (StreamK.toStream xs) + +o_n_space_traversable :: Int -> Benchmark +o_n_space_traversable value = + -- Buffering operations using heap proportional to number of elements. + bgroup "traversable" + -- Traversable instance + [ benchPureSinkIO value "traverse" traversableTraverse + , benchPureSinkIO value "sequenceA" traversableSequenceA + , benchPureSinkIO value "mapM" traversableMapM + , benchPureSinkIO value "sequence" traversableSequence + ] + +o_1_space_mapping :: Int -> Benchmark +o_1_space_mapping value = + bgroup + "mapping" + [ + -- Right folds + benchIOSink value "foldrS" (foldrS 1) + , benchIOSink value "foldrSMap" (foldrSMap 1) + ] + +------------------------------------------------------------------------------- +-- Iteration of transformations +------------------------------------------------------------------------------- + +{-# INLINE iterateSource #-} +iterateSource :: + Monad m + => (StreamK m Int -> StreamK m Int) + -> Int + -> Int + -> Int + -> StreamK m Int +iterateSource g count len n = f count (unfoldrMD len n) + + where + + f (0 :: Int) stream = stream + f i stream = f (i - 1) (g stream) + +-- this is quadratic +{-# INLINE iterateScan #-} +iterateScan :: Monad m => Int -> Int -> Int -> StreamK m Int +iterateScan = iterateSource (StreamK.scanl' (+) 0) + +{-# INLINE iterateMapM #-} +iterateMapM :: Monad m => Int -> Int -> Int -> StreamK m Int +iterateMapM = iterateSource (StreamK.mapM return) + +{-# INLINE iterateFilterEven #-} +iterateFilterEven :: Monad m => Int -> Int -> Int -> StreamK m Int +iterateFilterEven = iterateSource (StreamK.filter even) + +{-# INLINE iterateTakeAll #-} +iterateTakeAll :: Monad m => Int -> Int -> Int -> Int -> StreamK m Int +iterateTakeAll value = iterateSource (StreamK.take (value + 1)) + +{-# INLINE iterateDropOne #-} +iterateDropOne :: Monad m => Int -> Int -> Int -> StreamK m Int +iterateDropOne = iterateSource (StreamK.drop 1) + +{-# INLINE iterateDropWhileTrue #-} +iterateDropWhileTrue :: Monad m + => Int -> Int -> Int -> Int -> StreamK m Int +iterateDropWhileTrue value = iterateSource (StreamK.dropWhile (<= (value + 1))) + +{-# INLINE iterateDropWhileFalse #-} +iterateDropWhileFalse :: Monad m + => Int -> Int -> Int -> Int -> StreamK m Int +iterateDropWhileFalse value = iterateSource (StreamK.dropWhile (> (value + 1))) + +-- Head recursive operations. +o_n_stack_iterated :: Int -> Benchmark +o_n_stack_iterated value = by10 `seq` by100 `seq` + bgroup "iterated" + [ + benchIOSrc "mapM (n/10 x 10)" $ iterateMapM by10 10 + , benchIOSrc "scanl' (quadratic) (n/100 x 100)" $ + iterateScan by100 100 + , benchIOSrc "filterEven (n/10 x 10)" $ + iterateFilterEven by10 10 + , benchIOSrc "takeAll (n/10 x 10)" $ + iterateTakeAll value by10 10 + , benchIOSrc "dropOne (n/10 x 10)" $ iterateDropOne by10 10 + , benchIOSrc "dropWhileTrue (n/10 x 10)" $ + iterateDropWhileTrue value by10 10 + , benchIOSrc "dropWhileFalse (n/10 x 10)" $ + iterateDropWhileFalse value by10 10 + {- + , benchFold "tail" tail (unfoldrM streamLen) + , benchFold "nullTail" nullTail (unfoldrM streamLen) + , benchFold "headTail" headTail (unfoldrM streamLen) + -} + ] + + where + + by10 = value `div` 10 + by100 = value `div` 100 + +------------------------------------------------------------------------------- +-- Iteration Applicative +------------------------------------------------------------------------------- + +{-# INLINE iterateN #-} +iterateN :: (Int -> a -> a) -> a -> Int -> a +iterateN g initial count = f count initial + + where + + f (0 :: Int) x = x + f i x = f (i - 1) (g i x) + +-- Iterate a transformation over a singleton stream +{-# INLINE iterateSingleton #-} +iterateSingleton :: + (Int -> CrossStreamK m Int -> CrossStreamK m Int) + -> Int + -> Int + -> StreamK m Int +iterateSingleton g count n = + StreamK.unCross + $ iterateN g (StreamK.mkCross (StreamK.fromPure n)) count + +{- +-- XXX need to check why this is slower than the explicit recursion above, even +-- if the above code is written in a foldr like head recursive way. We also +-- need to try this with foldlM' once #150 is fixed. +-- However, it is perhaps best to keep the iteration benchmarks independent of +-- foldrM and any related fusion issues. +{-# INLINE _iterateSingleton #-} +_iterateSingleton :: + Monad m + => (Int -> Stream m Int -> Stream m Int) + -> Int + -> Int + -> Stream m Int +_iterateSingleton g value n = S.foldrM g (return n) $ sourceIntFromTo value n +-} + +{- HLINT ignore "Redundant <*" -} +o_n_space_applicative :: Int -> Benchmark +o_n_space_applicative value = + bgroup "iterated" + [ benchIOSrc "(*>) (n times)" $ + iterateSingleton ((*>) . pure) value + , benchIOSrc "(<*) (n times)" $ + iterateSingleton (\x xs -> xs <* pure x) value + , benchIOSrc "(<*>) (n times)" $ + iterateSingleton (\x xs -> pure (+ x) <*> xs) value + , benchIOSrc "liftA2 (n times)" $ + iterateSingleton (liftA2 (+) . pure) value + ] + +------------------------------------------------------------------------------- +-- Iteration Monadic +------------------------------------------------------------------------------- + +-- This is a good benchmark but inefficient way to compute primes. As we see a +-- new prime we keep appending a division filter for all the future numbers. +{-# INLINE sieve #-} +sieve :: Monad m => StreamK m Int -> StreamK m Int +sieve s = StreamK.concatEffect $ do + r <- StreamK.uncons s + case r of + Just (prime, rest) -> + -- XXX Use K.filter or rewrite to K.filter + let f = Stream.filter (\n -> n `mod` prime /= 0) + in pure $ prime `StreamK.cons` sieve (StreamK.fromStream $ f $ StreamK.toStream rest) + Nothing -> pure StreamK.nil + +o_n_space_iterated :: Int -> Benchmark +o_n_space_iterated value = + bgroup "iterated" + [ + benchIO "concatEffect prime sieve (n/4)" + (\n -> + Stream.fold Fold.sum + $ StreamK.toStream + $ sieve + $ StreamK.fromStream + $ Stream.enumerateFromTo 2 (value `div` 4 + n)) + , benchIOSrc "(>>) (n times)" $ + iterateSingleton ((>>) . pure) value + , benchIOSrc "(>>=) (n times)" $ + iterateSingleton (\x xs -> xs >>= \y -> return (x + y)) value + ] + +------------------------------------------------------------------------------- +-- Zipping +------------------------------------------------------------------------------- + +{- +{-# INLINE zipWith #-} +zipWith :: Monad m => StreamK m Int -> m () +zipWith src = drain $ StreamK.zipWith (,) src src + +{-# INLINE zipWithM #-} +zipWithM :: Monad m => StreamK m Int -> m () +zipWithM src = drain $ StreamK.zipWithM (curry return) src src + +{-# INLINE sortByK #-} +sortByK :: (a -> a -> Ordering) -> StreamK m a -> StreamK m a +sortByK f = StreamK.concatPairsWith (StreamK.mergeBy f) StreamK.fromPure + +{-# INLINE sortBy #-} +sortBy :: Monad m => StreamK m Int -> m () +sortBy = drain . sortByK compare + +------------------------------------------------------------------------------- +-- Mixed Composition +------------------------------------------------------------------------------- + +{-# INLINE scanMap #-} +scanMap :: Monad m => Int -> StreamK m Int -> m () +scanMap n = composeN n $ StreamK.map (subtract 1) . StreamK.scanl' (+) 0 + +{-# INLINE dropMap #-} +dropMap :: Monad m => Int -> StreamK m Int -> m () +dropMap n = composeN n $ StreamK.map (subtract 1) . StreamK.drop 1 + +{-# INLINE dropScan #-} +dropScan :: Monad m => Int -> StreamK m Int -> m () +dropScan n = composeN n $ StreamK.scanl' (+) 0 . StreamK.drop 1 + +{-# INLINE takeDrop #-} +takeDrop :: Monad m => Int -> Int -> StreamK m Int -> m () +takeDrop streamLen n = composeN n $ StreamK.drop 1 . StreamK.take streamLen + +{-# INLINE takeScan #-} +takeScan :: Monad m => Int -> Int -> StreamK m Int -> m () +takeScan streamLen n = composeN n $ StreamK.scanl' (+) 0 . StreamK.take streamLen + +{-# INLINE takeMap #-} +takeMap :: Monad m => Int -> Int -> StreamK m Int -> m () +takeMap streamLen n = composeN n $ StreamK.map (subtract 1) . StreamK.take streamLen + +{-# INLINE filterDrop #-} +filterDrop :: Monad m => Int -> Int -> StreamK m Int -> m () +filterDrop streamLen n = composeN n $ StreamK.drop 1 . StreamK.filter (<= streamLen) + +{-# INLINE filterTake #-} +filterTake :: Monad m => Int -> Int -> StreamK m Int -> m () +filterTake streamLen n = composeN n $ StreamK.take streamLen . StreamK.filter (<= streamLen) + +{-# INLINE filterScan #-} +filterScan :: Monad m => Int -> StreamK m Int -> m () +filterScan n = composeN n $ StreamK.scanl' (+) 0 . StreamK.filter (<= maxBound) + +{-# INLINE filterMap #-} +filterMap :: Monad m => Int -> Int -> StreamK m Int -> m () +filterMap streamLen n = composeN n $ StreamK.map (subtract 1) . StreamK.filter (<= streamLen) +-} + +------------------------------------------------------------------------------- +-- Applicative +------------------------------------------------------------------------------- + +{-# INLINE apDiscardFst #-} +apDiscardFst :: Monad m => + Int -> Int -> m () +apDiscardFst linearCount start = drain $ StreamK.unCross $ + StreamK.mkCross (unfoldrMD nestedCount2 start) + *> StreamK.mkCross (unfoldrMD nestedCount2 start) + + where + + nestedCount2 = round (fromIntegral linearCount**(1/2::Double)) + +{-# INLINE apDiscardSnd #-} +apDiscardSnd :: Monad m => Int -> Int -> m () +apDiscardSnd linearCount start = drain $ StreamK.unCross $ + StreamK.mkCross (unfoldrMD nestedCount2 start) + <* StreamK.mkCross (unfoldrMD nestedCount2 start) + + where + + nestedCount2 = round (fromIntegral linearCount**(1/2::Double)) + +{-# INLINE apLiftA2 #-} +apLiftA2 :: Monad m => Int -> Int -> m () +apLiftA2 linearCount start = drain $ StreamK.unCross $ + liftA2 (+) (StreamK.mkCross (unfoldrMD nestedCount2 start)) + (StreamK.mkCross (unfoldrMD nestedCount2 start)) + + where + + nestedCount2 = round (fromIntegral linearCount**(1/2::Double)) + +{-# INLINE toNullAp #-} +toNullAp :: Monad m => Int -> Int -> m () +toNullAp linearCount start = drain $ StreamK.unCross $ + (+) <$> StreamK.mkCross (unfoldrMD nestedCount2 start) + <*> StreamK.mkCross (unfoldrMD nestedCount2 start) + + where + + nestedCount2 = round (fromIntegral linearCount**(1/2::Double)) + +o_1_space_applicative :: Int -> Benchmark +o_1_space_applicative value = + bgroup "Applicative" + [ benchIO "(*>) (sqrt n x sqrt n)" $ apDiscardFst value + , benchIO "(<*) (sqrt n x sqrt n)" $ apDiscardSnd value + , benchIO "(<*>) (sqrt n x sqrt n)" $ toNullAp value + , benchIO "liftA2 (sqrt n x sqrt n)" $ apLiftA2 value + ] + +------------------------------------------------------------------------------- +-- Monad +------------------------------------------------------------------------------- + +{-# INLINE monadThen #-} +monadThen :: Monad m => Int -> Int -> m () +monadThen linearCount start = drain $ StreamK.unCross $ do + StreamK.mkCross (unfoldrMD nestedCount2 start) >> + StreamK.mkCross (unfoldrMD nestedCount2 start) + + where + + nestedCount2 = round (fromIntegral linearCount**(1/2::Double)) + +{-# INLINE toNullM #-} +toNullM :: Monad m => Int -> Int -> m () +toNullM linearCount start = drain $ StreamK.unCross $ do + x <- StreamK.mkCross (unfoldrMD nestedCount2 start) + y <- StreamK.mkCross (unfoldrMD nestedCount2 start) + return $ x + y + + where + + nestedCount2 = round (fromIntegral linearCount**(1/2::Double)) + +{-# INLINE toNullM3 #-} +toNullM3 :: Monad m => Int -> Int -> m () +toNullM3 linearCount start = drain $ StreamK.unCross $ do + x <- StreamK.mkCross (unfoldrMD nestedCount3 start) + y <- StreamK.mkCross (unfoldrMD nestedCount3 start) + z <- StreamK.mkCross (unfoldrMD nestedCount3 start) + return $ x + y + z + where + nestedCount3 = round (fromIntegral linearCount**(1/3::Double)) + +{-# INLINE filterAllOutM #-} +filterAllOutM :: Monad m => Int -> Int -> m () +filterAllOutM linearCount start = drain $ StreamK.unCross $ do + x <- StreamK.mkCross (unfoldrMD nestedCount2 start) + y <- StreamK.mkCross (unfoldrMD nestedCount2 start) + let s = x + y + if s < 0 + then return s + else StreamK.mkCross StreamK.nil + where + nestedCount2 = round (fromIntegral linearCount**(1/2::Double)) + +{-# INLINE filterAllInM #-} +filterAllInM :: Monad m => Int -> Int -> m () +filterAllInM linearCount start = drain $ StreamK.unCross $ do + x <- StreamK.mkCross (unfoldrMD nestedCount2 start) + y <- StreamK.mkCross (unfoldrMD nestedCount2 start) + let s = x + y + if s > 0 + then return s + else StreamK.mkCross StreamK.nil + where + nestedCount2 = round (fromIntegral linearCount**(1/2::Double)) + +{-# INLINE filterSome #-} +filterSome :: Monad m => Int -> Int -> m () +filterSome linearCount start = drain $ StreamK.unCross $ do + x <- StreamK.mkCross (unfoldrMD nestedCount2 start) + y <- StreamK.mkCross (unfoldrMD nestedCount2 start) + let s = x + y + if s > 1100000 + then return s + else StreamK.mkCross StreamK.nil + where + nestedCount2 = round (fromIntegral linearCount**(1/2::Double)) + +{-# INLINE breakAfterSome #-} +breakAfterSome :: Int -> Int -> IO () +breakAfterSome linearCount start = do + (_ :: Either ErrorCall ()) <- try $ drain $ StreamK.unCross $ do + x <- StreamK.mkCross (unfoldrMD nestedCount2 start) + y <- StreamK.mkCross (unfoldrMD nestedCount2 start) + let s = x + y + if s > 1100000 + then error "break" + else return s + return () + where + nestedCount2 = round (fromIntegral linearCount**(1/2::Double)) + +{-# INLINE toListM #-} +toListM :: Monad m => Int -> Int -> m [Int] +toListM linearCount start = toList $ StreamK.unCross $ do + x <- StreamK.mkCross (unfoldrMD nestedCount2 start) + y <- StreamK.mkCross (unfoldrMD nestedCount2 start) + return $ x + y + where + nestedCount2 = round (fromIntegral linearCount**(1/2::Double)) + +-- Taking a specified number of elements is very expensive in logict so we have +-- a test to measure the same. +{-# INLINE toListSome #-} +toListSome :: Monad m => Int -> Int -> m [Int] +toListSome linearCount start = + toList $ StreamK.take 10000 $ StreamK.unCross $ do + x <- StreamK.mkCross (unfoldrMD nestedCount2 start) + y <- StreamK.mkCross (unfoldrMD nestedCount2 start) + return $ x + y + where + nestedCount2 = round (fromIntegral linearCount**(1/2::Double)) + +o_1_space_monad :: Int -> Benchmark +o_1_space_monad value = + bgroup "Monad" + [ benchIO "(>>) (sqrt n x sqrt n)" $ monadThen value + , benchIO "(>>=) (sqrt n x sqrt n)" $ toNullM value + , benchIO "(>>=) (sqrt n x sqrt n) (filterAllOut)" $ + filterAllOutM value + , benchIO "(>>=) (sqrt n x sqrt n) (filterAllIn)" $ + filterAllInM value + , benchIO "(>>=) (sqrt n x sqrt n) (filterSome)" $ + filterSome value + , benchIO "(>>=) (sqrt n x sqrt n) (breakAfterSome)" $ + breakAfterSome value + , benchIO "(>>=) (cubert n x cubert n x cubert n)" $ + toNullM3 value + ] + +o_n_space_monad :: Int -> Benchmark +o_n_space_monad value = + bgroup "Monad" + [ benchIO "(>>=) (sqrt n x sqrt n) (toList)" $ + toListM value + , benchIO "(>>=) (sqrt n x sqrt n) (toListSome)" $ + toListSome value + ] + +------------------------------------------------------------------------------- +-- Append +------------------------------------------------------------------------------- + +{-# INLINE serial2 #-} +serial2 :: Int -> Int -> IO () +serial2 count n = + drain $ + StreamK.append + (unfoldrMD count n) + (unfoldrMD count (n + 1)) + +{-# INLINE serial4 #-} +serial4 :: Int -> Int -> IO () +serial4 count n = + drain $ + StreamK.append + (StreamK.append + (unfoldrMD count n) + (unfoldrMD count (n + 1))) + (StreamK.append + (unfoldrMD count (n + 2)) + (unfoldrMD count (n + 3))) + +o_1_space_joining :: Int -> Benchmark +o_1_space_joining value = + bgroup "joining" + [ benchIOSrc1 "serial (2,x/2)" (serial2 (value `div` 2)) + , benchIOSrc1 "serial (2,2,x/4)" (serial4 (value `div` 4)) + ] + +------------------------------------------------------------------------------- +-- ConcatMap +------------------------------------------------------------------------------- + +-- concatMap unfoldrM/unfoldrM + +{-# INLINE sourceConcatMapId #-} +sourceConcatMapId :: Monad m + => Int -> Int -> StreamK m (StreamK m Int) +sourceConcatMapId val n = + StreamK.fromFoldable $ fmap (StreamK.fromEffect . return) [n..n+val] + +{-# INLINE concatMap #-} +concatMap :: Int -> Int -> Int -> IO () +concatMap outer inner n = + drain $ StreamK.concatMap + (\_ -> unfoldrMD inner n) + (unfoldrMD outer n) + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'concatMap +#endif + +{-# INLINE concatMapPure #-} +concatMapPure :: Int -> Int -> Int -> IO () +concatMapPure outer inner n = + drain $ StreamK.concatMap + (\_ -> unfoldrMD inner n) + (unfoldrMD outer n) + +#ifdef INSPECTION +#if __GLASGOW_HASKELL__ >= 906 +inspect $ hasNoTypeClassesExcept 'concatMapPure [''Applicative] +#else +inspect $ hasNoTypeClasses 'concatMapPure +#endif +inspect $ 'concatMapPure `hasNoType` ''SPEC +#endif + +{-# INLINE concatMapRepl #-} +concatMapRepl :: Int -> Int -> Int -> IO () +concatMapRepl outer inner n = + drain $ StreamK.concatMap + (StreamK.replicate inner) (unfoldrMD outer n) + +#ifdef INSPECTION +#if __GLASGOW_HASKELL__ >= 906 +inspect $ hasNoTypeClassesExcept 'concatMapRepl [''Applicative] +#else +inspect $ hasNoTypeClasses 'concatMapRepl +#endif +inspect $ 'concatMapRepl `hasNoType` ''SPEC +#endif + +-- concatMapWith + +{-# INLINE concatStreamsWith #-} +concatStreamsWith + :: (StreamK IO Int -> StreamK IO Int -> StreamK IO Int) + -> Int + -> Int + -> Int + -> IO () +concatStreamsWith op outer inner n = + drain $ StreamK.concatMapWith op + (unfoldrMD inner) + (unfoldrMD outer n) + +{-# INLINE mergeMapWith #-} +mergeMapWith + :: (StreamK IO Int -> StreamK IO Int -> StreamK IO Int) + -> Int + -> Int + -> Int + -> IO () +mergeMapWith op outer inner n = + drain $ StreamK.mergeMapWith op + (unfoldrMD inner) + (unfoldrMD outer n) + +{-# INLINE concatMapWithSerial #-} +concatMapWithSerial :: Int -> Int -> Int -> IO () +concatMapWithSerial = concatStreamsWith StreamK.append + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'concatMapWithSerial +inspect $ 'concatMapWithSerial `hasNoType` ''SPEC +#endif + +{- +{-# INLINE concatMapWithAppend #-} +concatMapWithAppend :: Int -> Int -> Int -> IO () +concatMapWithAppend = concatStreamsWith Stream.append + +#ifdef INSPECTION +inspect $ hasNoTypeClasses 'concatMapWithAppend +inspect $ 'concatMapWithAppend `hasNoType` ''SPEC +#endif +-} + +-- mergeMapWith + +{-# INLINE mergeMapWithSerial #-} +mergeMapWithSerial :: Int -> Int -> Int -> IO () +mergeMapWithSerial = mergeMapWith StreamK.append + +{- +{-# INLINE mergeMapWithAppend #-} +mergeMapWithAppend :: Int -> Int -> Int -> IO () +mergeMapWithAppend = mergeMapWith Stream.append +-} + +{- +------------------------------------------------------------------------------- +-- Nested Composition +------------------------------------------------------------------------------- + +-- XXX Use CrossStreamK instead +instance Monad m => Applicative (StreamK.Stream m) where + {-# INLINE pure #-} + pure = StreamK.fromPure + + {-# INLINE (<*>) #-} + (<*>) = StreamK.crossApply + + {-# INLINE liftA2 #-} + liftA2 f x = (<*>) (fmap f x) + + {-# INLINE (*>) #-} + (*>) = StreamK.crossApplySnd + + {-# INLINE (<*) #-} + (<*) = StreamK.crossApplyFst + +-- 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 (StreamK.Stream m) where + {-# INLINE return #-} + return = pure + + {-# INLINE (>>=) #-} + (>>=) = flip StreamK.concatMap + +{-# INLINE drainApplicative #-} +drainApplicative :: Monad m => StreamK m Int -> m () +drainApplicative s = drain $ do + (+) <$> s <*> s + +{-# INLINE drainMonad #-} +drainMonad :: Monad m => StreamK m Int -> m () +drainMonad s = drain $ do + x <- s + y <- s + return $ x + y + +{-# INLINE drainMonad3 #-} +drainMonad3 :: Monad m => StreamK m Int -> m () +drainMonad3 s = drain $ do + x <- s + y <- s + z <- s + return $ x + y + z + +{-# INLINE filterAllOutMonad #-} +filterAllOutMonad + :: Monad m + => StreamK m Int -> m () +filterAllOutMonad str = drain $ do + x <- str + y <- str + let s = x + y + if s < 0 + then return s + else StreamK.nil + +{-# INLINE filterAllInMonad #-} +filterAllInMonad + :: Monad m + => StreamK m Int -> m () +filterAllInMonad str = drain $ do + x <- str + y <- str + let s = x + y + if s > 0 + then return s + else StreamK.nil +-} + +------------------------------------------------------------------------------- +-- Buffering +------------------------------------------------------------------------------- + +{-# INLINE reverse #-} +reverse :: MonadIO m => Int -> StreamK m Int -> m () +reverse n = composeN n StreamK.reverse + +------------------------------------------------------------------------------- +-- Reduce +------------------------------------------------------------------------------- + +{-# INLINE parseBreak #-} +parseBreak :: Monad m => StreamK m Int -> m () +parseBreak s = do + r <- StreamK.parseDBreak Parser.one s + case r of + (Left _, _) -> return () + (Right _, s1) -> parseBreak s1 + +------------------------------------------------------------------------------- +-- Lift +------------------------------------------------------------------------------- + +{-# INLINE iterateStateIO #-} +iterateStateIO :: + Monad m + => Int + -> StateT Int m Int +iterateStateIO n = do + x <- get + if x > n + then do + put (x - 1) + iterateStateIO n + else return x + +-- XXX This is basically testing the perf of concatEffect, change it to just +-- use concatEffect and move it along with other concatMap benchmarks. +{-# INLINE iterateStateT #-} +iterateStateT :: Int -> StreamK (StateT Int IO) Int +iterateStateT n = StreamK.concatEffect $ do + x <- get + if x > n + then do + put (x - 1) + return $ iterateStateT n + else return $ StreamK.fromPure x + +o_n_heap_transformer :: Int -> Benchmark +o_n_heap_transformer value = + bgroup "transformer" + [ benchIO "StateT Int IO (n times) (baseline)" $ \n -> + State.evalStateT (iterateStateIO n) value + , benchIO "Stream (StateT Int IO) (n times)" $ \n -> + State.evalStateT (drain (iterateStateT n)) value + ] + +------------------------------------------------------------------------------- +-- Benchmarks +------------------------------------------------------------------------------- + +moduleName :: String +moduleName = "Data.StreamK.FromStream" + +-- Generation of StreamK using StreamD generation functions and eleminating +-- using StreamK drain. +o_1_space_generation :: Int -> Benchmark +o_1_space_generation streamLen = + bgroup "generation" + [ benchFold "unfoldr" drain (unfoldrD streamLen) + , benchFold "unfoldrM" drain (unfoldrMD streamLen) + , benchFold "repeat" drain (repeat streamLen) + , benchFold "repeatM" drain (repeatM streamLen) + , benchFold "replicate" drain (replicate streamLen) + , benchFold "replicateM" drain (replicateM streamLen) + , benchFold "iterate" drain (iterate streamLen) + , benchFold "iterateM" drain (iterateM streamLen) + + , benchFold "fromFoldable" drain (fromFoldable streamLen) + , benchFold "fromFoldableM" drain (fromFoldableM streamLen) + + , benchIOSrc "mfix_10" (mfixUnfold 10) + , benchIOSrc "mfix_100" (mfixUnfold 100) + , benchIOSrc "mfix_1000" (mfixUnfold 1000) + + -- appends + , benchFold "concatMapFoldableWith" drain (concatMapFoldableSerial streamLen) + , benchFold "concatMapFoldableWithM" drain (concatMapFoldableSerialM streamLen) + ] + +-- Generating using StreamK and eliminating using StreamD folds. +o_1_space_elimination :: Int -> Benchmark +o_1_space_elimination streamLen = + bgroup "elimination" + [ benchFold "toNull" drainD (unfoldrMK streamLen) + , benchFold "mapM_" mapM_ (unfoldrMK streamLen) + , benchIOSink streamLen "uncons" uncons + , benchFold "unconsD" unconsD (unfoldrMK streamLen) + -- , benchFold "init" init (unfoldrM streamLen) + , benchFold "foldl'" foldl' (unfoldrMK streamLen) + , benchFold "last" last (unfoldrMK streamLen) + , bgroup "build" + [ + bgroup "Identity" + [ + benchIdentitySink streamLen "foldrToStreamLength" + (Stream.fold Fold.length . StreamK.toStream . runIdentity . foldrToStream) + {- + , benchIdentitySink 16 "foldrToStreamLength (16)" + (S.fold Fold.length . toStream . runIdentity . foldrToStream) + -} + ] + ] + ] + +{- +o_1_space_nested :: Int -> Benchmark +o_1_space_nested streamLen = + bgroup "nested" + [ benchFold "drainApplicative" drainApplicative (unfoldrM streamLen2) + , benchFold "drainMonad" drainMonad (unfoldrM streamLen2) + , benchFold "drainMonad3" drainMonad3 (unfoldrM streamLen3) + , benchFold "filterAllInMonad" filterAllInMonad (unfoldrM streamLen2) + , benchFold "filterAllOutMonad" filterAllOutMonad (unfoldrM streamLen2) + , benchFold "drainApplicative (pure)" drainApplicative (unfoldr streamLen2) + , benchFold "drainMonad (pure)" drainMonad (unfoldr streamLen2) + , benchFold "drainMonad3 (pure)" drainMonad3 (unfoldr streamLen3) + , benchFold "filterAllInMonad (pure)" filterAllInMonad (unfoldr streamLen2) + , benchFold "filterAllOutMonad (pure)" filterAllOutMonad (unfoldr streamLen2) + ] + where + streamLen2 = round (P.fromIntegral streamLen**(1/2::P.Double)) -- double nested loop + streamLen3 = round (P.fromIntegral streamLen**(1/3::P.Double)) -- triple nested loop +-} + +-- Generate using StreamK and transform using StreamD transformation functions +-- and then drain using StreamK. +o_1_space_transformation :: Int -> Benchmark +o_1_space_transformation streamLen = + bgroup "transformation" + [ -- benchFold "foldrS" (foldrS 1) (unfoldrM streamLen) + benchFold "scanl'" (scanl' 1) (unfoldrMK streamLen) + , benchFold "map" (map 1) (unfoldrMK streamLen) + -- , benchFold "fmap" (fmapK 1) (unfoldrM streamLen) + , benchFold "mapM" (mapM 1) (unfoldrMK streamLen) + -- , benchFold "mapMSerial" (mapMSerial 1) (unfoldrM streamLen) + ] + +o_1_space_transformationX4 :: Int -> Benchmark +o_1_space_transformationX4 streamLen = + bgroup "transformationX4" + [ benchFold "scanl'" (scanl' 4) (unfoldrMK streamLen) + , benchFold "map" (map 4) (unfoldrMK streamLen) + -- , benchFold "fmap" (fmapK 4) (unfoldrMK streamLen) + , benchFold "mapM" (mapM 4) (unfoldrMK streamLen) + -- , benchFold "mapMSerial" (mapMSerial 4) (unfoldrM streamLen) + -- XXX this is horribly slow + -- , benchFold "concatMap" (concatMap 4) (unfoldrM streamLen16) + ] + +o_1_space_concat :: Int -> Benchmark +o_1_space_concat streamLen = + bgroup "concat" + [ benchIOSrc1 "concatMapPure (n of 1)" + (concatMapPure streamLen 1) + , benchIOSrc1 "concatMapPure (sqrt n of sqrt n)" + (concatMapPure streamLen2 streamLen2) + , benchIOSrc1 "concatMapPure (1 of n)" + (concatMapPure 1 streamLen) + + , benchIOSrc1 "concatMap (n of 1)" + (concatMap streamLen 1) + , benchIOSrc1 "concatMap (sqrt n of sqrt n)" + (concatMap streamLen2 streamLen2) + , benchIOSrc1 "concatMap (1 of n)" + (concatMap 1 streamLen) + + -- This is for comparison with foldMapWith + , benchIOSrc "concatMapWithId (n of 1) (fromFoldable)" + (StreamK.concatMapWith StreamK.append id . sourceConcatMapId streamLen) + + , benchIOSrc1 "concatMapWith (n of 1)" + (concatMapWithSerial streamLen 1) + , benchIOSrc1 "concatMapWith (sqrt n of sqrt n)" + (concatMapWithSerial streamLen2 streamLen2) + , benchIOSrc1 "concatMapWith (1 of n)" + (concatMapWithSerial 1 streamLen) + + {- + -- quadratic with number of outer streams + , benchIOSrc1 "concatMapWithAppend (2 of n/2)" + (concatMapWithAppend 2 (value `div` 2)) + -} + + , benchIOSrc1 "concatMapRepl (sqrt n of sqrt n)" + (concatMapRepl streamLen2 streamLen2) + + {- + , benchFold "sortBy" sortBy (unfoldrM streamLen) + -} + ] + where + streamLen2 = round (P.fromIntegral streamLen**(1/2::P.Double)) -- double nested loop + +o_n_space_merge :: Int -> Benchmark +o_n_space_merge value = sqrtVal `seq` + bgroup "concat" + [ + -------------------mergeMapWith----------------- + + -- Use large number of streams to check scalability + + benchIOSrc1 "mergeMapWithSerial (n of 1)" + (mergeMapWithSerial value 1) + , benchIOSrc1 "mergeMapWithSerial (sqrtVal of sqrtVal)" + (mergeMapWithSerial sqrtVal sqrtVal) + , benchIOSrc1 "mergeMapWithSerial (2 of n/2)" + (mergeMapWithSerial 2 (value `div` 2)) + + {- + , benchIOSrc1 "mergeMapWithAppend (n of 1)" + (mergeMapWithAppend value 1) + , benchIOSrc1 "mergeMapWithAppend (sqrtVal of sqrtVal)" + (mergeMapWithAppend sqrtVal sqrtVal) + -} + ] + + where + + sqrtVal = round $ sqrt (fromIntegral value :: Double) + +o_1_space_filtering :: Int -> Benchmark +o_1_space_filtering streamLen = + bgroup "filtering" + [ benchFold "filter-even" (filterEven 1) (unfoldrMK streamLen) + {- + , benchFold "filter-all-out" (filterAllOut streamLen 1) (unfoldrM streamLen) + , benchFold "filter-all-in" (filterAllIn streamLen 1) (unfoldrM streamLen) + , benchFold "take-all" (takeAll streamLen 1) (unfoldrM streamLen) + , benchFold "takeWhile-true" (takeWhileTrue streamLen 1) (unfoldrM streamLen) + , benchFold "drop-one" (dropOne 1) (unfoldrM streamLen) + , benchFold "drop-all" (dropAll streamLen 1) (unfoldrM streamLen) + , benchFold "dropWhile-true" (dropWhileTrue streamLen 1) (unfoldrM streamLen) + , benchFold "dropWhile-false" (dropWhileFalse 1) (unfoldrM streamLen) + -} + ] + +o_1_space_filteringX4 :: Int -> Benchmark +o_1_space_filteringX4 streamLen = + bgroup "filteringX4" + [ benchFold "filter-even" (filterEven 4) (unfoldrMK streamLen) + {- + , benchFold "filter-all-out" (filterAllOut streamLen 4) (unfoldrM streamLen) + , benchFold "filter-all-in" (filterAllIn streamLen 4) (unfoldrM streamLen) + , benchFold "take-all" (takeAll streamLen 4) (unfoldrM streamLen) + , benchFold "takeWhile-true" (takeWhileTrue streamLen 4) (unfoldrM streamLen) + , benchFold "drop-one" (dropOne 4) (unfoldrM streamLen) + , benchFold "drop-all" (dropAll streamLen 4) (unfoldrM streamLen) + , benchFold "dropWhile-true" (dropWhileTrue streamLen 4) (unfoldrM streamLen) + , benchFold "dropWhile-false" (dropWhileFalse 4) (unfoldrM streamLen) + -} + ] + +{- +o_1_space_zipping :: Int -> Benchmark +o_1_space_zipping streamLen = + bgroup "zipping" + [ benchFold "zipWith" zipWith (unfoldrM streamLen) + , benchFold "zipWithM" zipWithM (unfoldrM streamLen) + ] + +o_1_space_mixed :: Int -> Benchmark +o_1_space_mixed streamLen = + bgroup "mixed" + [ benchFold "scan-map" (scanMap 1) (unfoldrM streamLen) + , benchFold "drop-map" (dropMap 1) (unfoldrM streamLen) + , benchFold "drop-scan" (dropScan 1) (unfoldrM streamLen) + , benchFold "take-drop" (takeDrop streamLen 1) (unfoldrM streamLen) + , benchFold "take-scan" (takeScan streamLen 1) (unfoldrM streamLen) + , benchFold "take-map" (takeMap streamLen 1) (unfoldrM streamLen) + , benchFold "filter-drop" (filterDrop streamLen 1) (unfoldrM streamLen) + , benchFold "filter-take" (filterTake streamLen 1) (unfoldrM streamLen) + , benchFold "filter-scan" (filterScan 1) (unfoldrM streamLen) + , benchFold "filter-map" (filterMap streamLen 1) (unfoldrM streamLen) + ] + +o_1_space_mixedX2 :: Int -> Benchmark +o_1_space_mixedX2 streamLen = + bgroup "mixedX2" + [ benchFold "scan-map" (scanMap 2) (unfoldrM streamLen) + , benchFold "drop-map" (dropMap 2) (unfoldrM streamLen) + , benchFold "drop-scan" (dropScan 2) (unfoldrM streamLen) + , benchFold "take-drop" (takeDrop streamLen 2) (unfoldrM streamLen) + , benchFold "take-scan" (takeScan streamLen 2) (unfoldrM streamLen) + , benchFold "take-map" (takeMap streamLen 2) (unfoldrM streamLen) + , benchFold "filter-drop" (filterDrop streamLen 2) (unfoldrM streamLen) + , benchFold "filter-take" (filterTake streamLen 2) (unfoldrM streamLen) + , benchFold "filter-scan" (filterScan 2) (unfoldrM streamLen) + , benchFold "filter-map" (filterMap streamLen 2) (unfoldrM streamLen) + ] + +o_1_space_mixedX4 :: Int -> Benchmark +o_1_space_mixedX4 streamLen = + bgroup "mixedX4" + [ benchFold "scan-map" (scanMap 4) (unfoldrM streamLen) + , benchFold "drop-map" (dropMap 4) (unfoldrM streamLen) + , benchFold "drop-scan" (dropScan 4) (unfoldrM streamLen) + , benchFold "take-drop" (takeDrop streamLen 4) (unfoldrM streamLen) + , benchFold "take-scan" (takeScan streamLen 4) (unfoldrM streamLen) + , benchFold "take-map" (takeMap streamLen 4) (unfoldrM streamLen) + , benchFold "filter-drop" (filterDrop streamLen 4) (unfoldrM streamLen) + , benchFold "filter-take" (filterTake streamLen 4) (unfoldrM streamLen) + , benchFold "filter-scan" (filterScan 4) (unfoldrM streamLen) + , benchFold "filter-map" (filterMap streamLen 4) (unfoldrM streamLen) + ] +-} + +o_1_space_grouping :: Int -> Benchmark +o_1_space_grouping value = + bgroup "grouping" + [ + benchIOSink value "parseBreak (recursive)" parseBreak + ] + +o_1_space :: Int -> Benchmark +o_1_space streamLen = + bgroup (o_1_space_prefix moduleName) + [ o_1_space_generation streamLen + , o_1_space_elimination streamLen + -- , o_1_space_nested streamLen + , o_1_space_joining streamLen + , o_1_space_mapping streamLen + , o_1_space_transformation streamLen + , o_1_space_transformationX4 streamLen + , o_1_space_concat streamLen + , o_1_space_applicative streamLen + , o_1_space_monad streamLen + , o_1_space_filtering streamLen + , o_1_space_filteringX4 streamLen + , o_1_space_grouping streamLen + -- , o_1_space_zipping streamLen + -- , o_1_space_mixed streamLen + -- , o_1_space_mixedX2 streamLen + -- , o_1_space_mixedX4 streamLen + -- , o_1_space_list streamLen + ] + +o_n_heap :: Int -> Benchmark +o_n_heap streamLen = + bgroup (o_n_heap_prefix moduleName) + [ {- bgroup "transformation" + [ benchFold "foldlS" (foldlS 1) (unfoldrM streamLen) + ] -} + bgroup "buffered" [benchIOSink streamLen "reverse" (reverse 1)] + , o_n_heap_transformer streamLen + ] + +o_n_stack :: Int -> Benchmark +o_n_stack streamLen = + bgroup (o_n_stack_prefix moduleName) + [ + {- + , bgroup "transformation" + [ + -- XXX why do these need so much stack + benchFold "intersperse" (intersperse streamLen 1) (unfoldrM streamLen2) + , benchFold "interspersePure" (intersperse streamLen 1) (unfoldr streamLen2) + ] + , bgroup "transformationX4" + [ + benchFold "intersperse" (intersperse streamLen 4) (unfoldrM streamLen16) + ] + -} + o_n_stack_iterated streamLen + ] + {- + where + streamLen2 = round (P.fromIntegral streamLen**(1/2::P.Double)) -- double nested loop + streamLen16 = round (P.fromIntegral streamLen**(1/16::P.Double)) -- triple nested loop + -} + +o_n_space :: Int -> Benchmark +o_n_space streamLen = + bgroup (o_n_space_prefix moduleName) + [ bgroup "elimination" + [ benchFold "toList" toList (unfoldrMK streamLen) + ] + , o_n_space_merge streamLen + , o_n_space_monad streamLen + , o_n_space_iterated streamLen + , o_n_space_applicative streamLen + , o_n_space_traversable streamLen + ] + +main :: IO () +main = + defaultMain + [ o_1_space streamLen + , o_n_stack streamLen + , o_n_heap streamLen + , o_n_space streamLen + ] + + where + + streamLen = 100000 diff --git a/benchmark/Streamly/Benchmark/Data/StreamK/StreamKAlt.hs b/benchmark/Streamly/Benchmark/Data/StreamK/StreamKAlt.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Data/StreamK/StreamKAlt.hs @@ -0,0 +1,454 @@ + +-- | +-- Module : Streamly.Benchmark.Data.Stream.StreamDK +-- Copyright : (c) 2018 Composewell Technologies +-- +-- License : BSD3 +-- Maintainer : streamly@composewell.com + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main (main) where + +-- import Control.Monad (when) +-- import Data.Maybe (isJust) +import Prelude hiding () +-- import qualified Prelude as P +-- import qualified Data.List as List + +import qualified Streamly.Internal.Data.StreamK.Alt as S +-- import qualified Streamly.Internal.Data.Stream.Common as SP +-- import qualified Streamly.Internal.Data.SVar as S + +import Streamly.Benchmark.Common +import Test.Tasty.Bench (bgroup, Benchmark, defaultMain) + +value :: Int +value = 100000 +{- +value2, value3, value16, maxValue :: Int +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.fromPure [n..n+value] + +{-# INLINE sourceFoldMapWithM #-} +sourceFoldMapWithM :: Monad m => Int -> Stream m Int +sourceFoldMapWithM n = SP.foldMapWith S.serial (S.fromEffect . return) [n..n+value] +-} + +------------------------------------------------------------------------------- +-- 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 [] +-} + +------------------------------------------------------------------------------- +-- Benchmarks +------------------------------------------------------------------------------- + +moduleName :: String +moduleName = "Data.Stream.StreamDK" + +o_1_space :: [Benchmark] +o_1_space = + [ bgroup (o_1_space_prefix moduleName) + [ bgroup "generation" + [ benchFold "unfoldr" toNull sourceUnfoldr + , benchFold "unfoldrM" toNull sourceUnfoldrM + ] + , bgroup "elimination" + [ benchFold "toNull" toNull sourceUnfoldrM + , benchFold "uncons" uncons sourceUnfoldrM + ] + ] + ] + +main :: IO () +main = defaultMain [o_1_space] diff --git a/benchmark/Streamly/Benchmark/Data/Unfold.hs b/benchmark/Streamly/Benchmark/Data/Unfold.hs --- a/benchmark/Streamly/Benchmark/Data/Unfold.hs +++ b/benchmark/Streamly/Benchmark/Data/Unfold.hs @@ -31,17 +31,20 @@ import qualified Streamly.FileSystem.Handle as FH import qualified Streamly.Internal.Data.Fold as FL import qualified Streamly.Internal.Data.Unfold as UF -import qualified Streamly.Internal.Data.Unfold.Exception as UF -import qualified Streamly.Internal.Data.Stream.StreamD as S -import qualified Streamly.Internal.Data.Stream.StreamD as D -import qualified Streamly.Internal.Data.Stream.StreamK as K +#ifndef USE_STREAMLY_CORE +import qualified Streamly.Internal.Data.Unfold.Prelude as UF +#endif +import qualified Streamly.Internal.Data.Stream as S +import qualified Streamly.Internal.Data.Stream as D +import qualified Streamly.Internal.Data.StreamK as K -import Gauge hiding (env) +import Test.Tasty.Bench hiding (env) import Prelude hiding (take, filter, zipWith, map, mapM, takeWhile) import Streamly.Benchmark.Common import Streamly.Benchmark.Common.Handle #ifdef INSPECTION +import Control.Monad.Catch (MonadCatch) import Test.Inspection #endif @@ -117,7 +120,7 @@ {-# INLINE both #-} both :: Monad m => Int -> Int -> m () both size start = - drainTransformationDefault (size + start) (UF.both start) undefined + drainTransformationDefault (size + start) (UF.supply start) () {-# INLINE first #-} @@ -200,9 +203,9 @@ _const size start = drainGeneration (UF.take size (UF.fromEffect (return start))) undefined -{-# INLINE unfoldrM #-} -unfoldrM :: Monad m => Int -> Int -> m () -unfoldrM size start = drainGeneration (UF.unfoldrM step) start +{-# INLINE sourceUnfoldrM #-} +sourceUnfoldrM :: Monad m => Int -> Int -> Unfold m Int Int +sourceUnfoldrM size start = UF.unfoldrM step where @@ -212,6 +215,10 @@ then Just (i, i + 1) else Nothing +{-# INLINE unfoldrM #-} +unfoldrM :: Monad m => Int -> Int -> m () +unfoldrM size start = drainGeneration (sourceUnfoldrM size start) start + {-# INLINE fromList #-} fromList :: Monad m => Int -> Int -> m () fromList size start = drainGeneration UF.fromList [start .. start + size] @@ -309,7 +316,7 @@ mapM2 size start = drainTransformationDefault size - (UF.mapM2 (\a b -> return $ a + b)) + (UF.mapM (\(a, b) -> return $ a + b) . UF.carry) start ------------------------------------------------------------------------------- @@ -426,7 +433,7 @@ let end = start + nthRoot 2 value s = source end -- in UF.fold ((+) <$> s <*> s) FL.drain start - in UF.fold FL.drain ((+) `fmap` s `UF.crossApply` s) start + in UF.fold FL.drain (((+) `fmap` s) `UF.crossApply` s) start {-# INLINE _apDiscardFst #-} _apDiscardFst :: Int -> Int -> m () @@ -440,16 +447,17 @@ -- Monad ------------------------------------------------------------------------------- +-- XXX to keep the benchmarks same as Stream we should use sourceUnfoldrM in +-- all of these, and other benchmarks too. {-# INLINE concatMapM #-} -concatMapM :: Monad m => Int -> Int -> m () -concatMapM value start = - val `seq` drainGeneration (UF.concatMapM unfoldInGen unfoldOut) start +concatMapM :: Monad m => Int -> Int -> Int -> m () +concatMapM inner outer start = + drainGeneration (UF.concatMapM unfoldInGen unfoldOut) start where - val = nthRoot 2 value - unfoldInGen i = return (UF.second (i + val) UF.enumerateFromToIntegral) - unfoldOut = UF.second (start + val) UF.enumerateFromToIntegral + unfoldInGen i = return (UF.second (i + inner) UF.enumerateFromToIntegral) + unfoldOut = UF.second (start + outer) UF.enumerateFromToIntegral {-# INLINE toNull #-} toNull :: Monad m => Int -> Int -> m () @@ -482,7 +490,8 @@ -} u = src `UF.bind` \x -> src `UF.bind` \y -> - UF.fromPure (x + y) + src `UF.bind` \z -> + UF.fromPure (x + y + z) in UF.fold FL.drain u start {-# INLINE toList #-} @@ -595,16 +604,13 @@ -- Benchmark ops ------------------------------------------------------------------------------- --- n * (n + 1) / 2 == linearCount -concatCount :: Int -> Int -concatCount linearCount = - round (((1 + 8 * fromIntegral linearCount)**(1/2::Double) - 1) / 2) - -{-# INLINE many #-} -many :: Monad m => Int -> Int -> m () -many linearCount start = do - let end = start + concatCount linearCount - UF.fold FL.drain (UF.many (source end) (source end)) start +{-# INLINE unfoldEach #-} +unfoldEach :: Monad m => Int -> Int -> Int -> m () +unfoldEach inner outer start = do + UF.fold + FL.drain + (UF.unfoldEach (sourceUnfoldrM inner start) (sourceUnfoldrM outer start)) + start ------------------------------------------------------------------------------- -- Benchmarks @@ -714,31 +720,37 @@ o_1_space_nested env size = [ bgroup "nested" - [ benchIO "(<*>) (sqrt n x sqrt n)" $ toNullAp size + [ benchIO "crossApply outer=inner=(sqrt Max)" $ toNullAp size -- Unimplemented -- , benchIO "apDiscardFst" $ apDiscardFst size -- , benchIO "apDiscardSnd" $ apDiscardSnd size - , benchIO "concatMapM (sqrt n x sqrt n)" $ concatMapM size - , benchIO "(>>=) (sqrt n x sqrt n)" $ toNull size - , benchIO "(>>=) (cubert n x cubert n x cubert n)" $ toNull3 size - , benchIO "breakAfterSome" $ breakAfterSome size - , benchIO "filterAllOut" $ filterAllOut size - , benchIO "filterAllIn" $ filterAllIn size - , benchIO "filterSome" $ filterSome size + , benchIO "concatMapM outer=inner=(sqrt Max)" $ concatMapM sqrtVal sqrtVal + , benchIO "bind2" $ toNull size + , benchIO "bind3" $ toNull3 size + , benchIO "breakAfterSome2" $ breakAfterSome size + , benchIO "filterAllOut2" $ filterAllOut size + , benchIO "filterAllIn2" $ filterAllIn size + , benchIO "filterSome2" $ filterSome size - , benchIO "many" $ many size + , benchIO "unfoldEach inner=outer=(sqrt Max)" $ unfoldEach sqrtVal sqrtVal + , benchIO "unfoldEach inner=1 outer=Max" $ unfoldEach 1 size + , benchIO "unfoldEach inner=Max outer=1" $ unfoldEach size 1 , mkBench "foldMany (Fold.takeEndBy_ (== lf) Fold.drain)" env $ \inh _ -> foldManySepBy inh ] ] + where + + sqrtVal = round $ sqrt (fromIntegral size :: Double) + o_n_space_nested :: Int -> [Benchmark] o_n_space_nested size = [ bgroup "nested" - [ benchIO "toList" $ toList size - , benchIO "toListSome" $ toListSome size + [ benchIO "toList2" $ toList size + , benchIO "toListSome2" $ toListSome size ] ] @@ -776,14 +788,20 @@ in S.fold (FH.write devNull) $ S.unfold readEx inh #ifdef INSPECTION +#if __GLASGOW_HASKELL__ >= 906 +inspect $ hasNoTypeClassesExcept 'readWriteFinally_Unfold [''MonadCatch] +#else inspect $ hasNoTypeClasses 'readWriteFinally_Unfold +#endif -- inspect $ 'readWriteFinallyUnfold `hasNoType` ''Step #endif +#ifndef USE_STREAMLY_CORE readWriteFinallyUnfold :: Handle -> Handle -> IO () readWriteFinallyUnfold inh devNull = let readEx = UF.finally (\_ -> hClose inh) FH.reader in S.fold (FH.write devNull) $ S.unfold readEx inh +#endif -- | Send the file contents to /dev/null with exception handling readWriteBracket_Unfold :: Handle -> Handle -> IO () @@ -792,14 +810,20 @@ in S.fold (FH.write devNull) $ S.unfold readEx inh #ifdef INSPECTION +#if __GLASGOW_HASKELL__ >= 906 +inspect $ hasNoTypeClassesExcept 'readWriteBracket_Unfold [''MonadCatch] +#else inspect $ hasNoTypeClasses 'readWriteBracket_Unfold +#endif -- inspect $ 'readWriteBracketUnfold `hasNoType` ''Step #endif +#ifndef USE_STREAMLY_CORE readWriteBracketUnfold :: Handle -> Handle -> IO () readWriteBracketUnfold inh devNull = let readEx = UF.bracket return (\_ -> hClose inh) FH.reader in S.fold (FH.write devNull) $ S.unfold readEx inh +#endif o_1_space_copy_read_exceptions :: BenchEnv -> [Benchmark] o_1_space_copy_read_exceptions env = @@ -810,12 +834,14 @@ readWriteHandleExceptionUnfold inh (nullH env) , mkBenchSmall "UF.finally_" env $ \inh _ -> readWriteFinally_Unfold inh (nullH env) - , mkBenchSmall "UF.finally" env $ \inh _ -> - readWriteFinallyUnfold inh (nullH env) , mkBenchSmall "UF.bracket_" env $ \inh _ -> readWriteBracket_Unfold inh (nullH env) +#ifndef USE_STREAMLY_CORE + , mkBenchSmall "UF.finally" env $ \inh _ -> + readWriteFinallyUnfold inh (nullH env) , mkBenchSmall "UF.bracket" env $ \inh _ -> readWriteBracketUnfold inh (nullH env) +#endif ] ] diff --git a/benchmark/Streamly/Benchmark/FileSystem/DirIO.hs b/benchmark/Streamly/Benchmark/FileSystem/DirIO.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/FileSystem/DirIO.hs @@ -0,0 +1,93 @@ +-- | +-- Module : Streamly.Benchmark.FileSystem.DirIO +-- Copyright : (c) 2019 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +{-# LANGUAGE CPP #-} + +module Main (main) where + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +import Control.Monad (void) +import GHC.IO.Encoding (setLocaleEncoding, utf8) +import Streamly.Benchmark.Common (o_1_space_prefix) + +import qualified Streamly.Data.Stream.Prelude as Stream +import qualified Streamly.Data.Fold as Fold + +import Prelude hiding (last, length) +import Test.Tasty.Bench +import BenchTestLib.DirIO + +-------------------------------------------------------------------------------- +-- Main +-------------------------------------------------------------------------------- + +moduleName :: String +moduleName = "FileSystem.DirIO" + +-- | List the current directory recursively +main :: IO () +main = do + setLocaleEncoding utf8 + + let smallTree = "benchmark-tmp/dir-structure-small" + bigTree = "benchmark-tmp/dir-structure-big" + void $ createDirStucture smallTree 2 3 + void $ createDirStucture bigTree 5 5 + + defaultMain + [ bgroup (o_1_space_prefix moduleName) +#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) + $ bench "listDirByteChunked (big)" (nfIO $ + Stream.fold Fold.drain $ listDirByteChunked bigTree) : +#endif + -- NOTE: The BFS traversal fails with: + -- openDirStream: resource exhausted (Too many open files) + -- if a bigger directory tree is used + [ bench "listDirUnfoldDfs (big)" $ nfIO $ + Stream.fold Fold.drain $ listDirUnfoldDfs id bigTree + , bench "listDirUnfoldBfs (small)" $ nfIO $ + Stream.fold Fold.drain $ listDirUnfoldBfs id smallTree + , bench "listDirUnfoldBfsRev (small)" $ nfIO $ + Stream.fold Fold.drain $ listDirUnfoldBfsRev id smallTree + , bench "listDirConcatDfs (big)" $ nfIO $ + Stream.fold Fold.drain $ listDirConcatDfs id bigTree + , bench "listDirConcatBfs (small)" $ nfIO $ + Stream.fold Fold.drain $ listDirConcatBfs id smallTree + , bench "listDirConcatBfsRev (small)" $ nfIO $ + Stream.fold Fold.drain $ listDirConcatBfsRev id smallTree + , bench "listDirAppend (big)" $ nfIO $ + Stream.fold Fold.drain $ listDirAppend id bigTree + , bench "listDirInterleave (big)" $ nfIO $ + Stream.fold Fold.drain $ listDirInterleave id bigTree + , bench "listDirPar (big)" $ nfIO $ + Stream.fold Fold.drain $ listDirPar id bigTree + , bench "listDirParInterleaved (big)" $ nfIO $ + Stream.fold Fold.drain $ listDirParInterleaved id bigTree + , bench "listDirParOrdered (big)" $ nfIO $ + Stream.fold Fold.drain $ listDirParOrdered id bigTree + , bench "listDirChunkDfs (big)" $ nfIO $ + Stream.fold Fold.drain $ listDirChunkDfs id bigTree + , bench "listDirChunkBfs (small)" $ nfIO $ + Stream.fold Fold.drain $ listDirChunkBfs id smallTree + , bench "listDirChunkBfsRev (small)" $ nfIO $ + Stream.fold Fold.drain $ listDirChunkBfsRev id smallTree + , bench "listDirChunkAppend (big)" $ nfIO $ + Stream.fold Fold.drain $ listDirChunkAppend id bigTree + , bench "listDirChunkInterleave (big)" $ nfIO $ + Stream.fold Fold.drain $ listDirChunkInterleave id bigTree + , bench "listDirChunkPar (big)" $ nfIO $ + Stream.fold Fold.drain $ listDirChunkPar id bigTree + , bench "listDirChunkParInterleaved (big)" $ nfIO $ + Stream.fold Fold.drain $ listDirChunkParInterleaved id bigTree + , bench "listDirChunkParOrdered (big)" $ nfIO $ + Stream.fold Fold.drain $ listDirChunkParOrdered id bigTree + ] + ] diff --git a/benchmark/Streamly/Benchmark/FileSystem/Handle.hs b/benchmark/Streamly/Benchmark/FileSystem/Handle.hs --- a/benchmark/Streamly/Benchmark/FileSystem/Handle.hs +++ b/benchmark/Streamly/Benchmark/FileSystem/Handle.hs @@ -22,7 +22,7 @@ import qualified Handle.ReadWrite as RW import qualified Handle.Read as RO -import Gauge hiding (env) +import Test.Tasty.Bench hiding (env) import Prelude hiding (last, length) import Streamly.Benchmark.Common diff --git a/benchmark/Streamly/Benchmark/FileSystem/Handle/Read.hs b/benchmark/Streamly/Benchmark/FileSystem/Handle/Read.hs --- a/benchmark/Streamly/Benchmark/FileSystem/Handle/Read.hs +++ b/benchmark/Streamly/Benchmark/FileSystem/Handle/Read.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -Wno-deprecations #-} -- | -- Module : Streamly.Benchmark.FileSystem.Handle @@ -29,27 +28,25 @@ import GHC.Magic (noinline) import System.IO (Handle) -import qualified Streamly.Data.Stream as Stream import qualified Streamly.Data.Fold as Fold import qualified Streamly.FileSystem.Handle as FH import qualified Streamly.Internal.Data.Array as A -import qualified Streamly.Internal.Data.Array.Type as AT import qualified Streamly.Internal.Data.Fold as FL -import qualified Streamly.Internal.Data.Stream.StreamD as IP +import qualified Streamly.Internal.Data.Stream as IP import qualified Streamly.Internal.FileSystem.Handle as IFH import qualified Streamly.Internal.Unicode.Stream as IUS import qualified Streamly.Data.Stream.Prelude as S import qualified Streamly.Unicode.Stream as SS -import Gauge hiding (env) +import Test.Tasty.Bench hiding (env) import Prelude hiding (last, length) import Streamly.Benchmark.Common.Handle #ifdef INSPECTION -import Streamly.Internal.Data.Stream.StreamD.Type (Step(..), FoldMany) +import Streamly.Internal.Data.Stream (Step(..), FoldMany) -import qualified Streamly.Internal.Data.Array.Mut.Type as MA -import qualified Streamly.Internal.Data.Stream.StreamD as D +import qualified Streamly.Internal.Data.MutArray as MutArray +import qualified Streamly.Internal.Data.Stream as D import qualified Streamly.Internal.Data.Unfold as IUF import Test.Inspection @@ -63,13 +60,13 @@ -- | Get the last byte from a file bytestream. readLast :: Handle -> IO (Maybe Word8) -readLast = S.fold Fold.last . S.unfold FH.reader +readLast = S.fold Fold.latest . S.unfold FH.reader #ifdef INSPECTION inspect $ hasNoTypeClasses 'readLast inspect $ 'readLast `hasNoType` ''Step -- S.unfold inspect $ 'readLast `hasNoType` ''IUF.ConcatState -- FH.read/UF.many -inspect $ 'readLast `hasNoType` ''MA.ArrayUnsafe -- FH.read/A.read +inspect $ 'readLast `hasNoType` ''MutArray.ArrayUnsafe -- FH.read/A.read #endif -- assert that flattenArrays constructors are not present @@ -81,7 +78,7 @@ inspect $ hasNoTypeClasses 'readCountBytes inspect $ 'readCountBytes `hasNoType` ''Step -- S.unfold inspect $ 'readCountBytes `hasNoType` ''IUF.ConcatState -- FH.read/UF.many -inspect $ 'readCountBytes `hasNoType` ''MA.ArrayUnsafe -- FH.read/A.read +inspect $ 'readCountBytes `hasNoType` ''MutArray.ArrayUnsafe -- FH.read/A.read #endif -- | Count the number of lines in a file. @@ -96,7 +93,7 @@ inspect $ hasNoTypeClasses 'readCountLines inspect $ 'readCountLines `hasNoType` ''Step inspect $ 'readCountLines `hasNoType` ''IUF.ConcatState -- FH.read/UF.many -inspect $ 'readCountLines `hasNoType` ''MA.ArrayUnsafe -- FH.read/A.read +inspect $ 'readCountLines `hasNoType` ''MutArray.ArrayUnsafe -- FH.read/A.read #endif -- | Count the number of words in a file. @@ -120,7 +117,7 @@ inspect $ hasNoTypeClasses 'readSumBytes inspect $ 'readSumBytes `hasNoType` ''Step inspect $ 'readSumBytes `hasNoType` ''IUF.ConcatState -- FH.read/UF.many -inspect $ 'readSumBytes `hasNoType` ''MA.ArrayUnsafe -- FH.read/A.read +inspect $ 'readSumBytes `hasNoType` ''MutArray.ArrayUnsafe -- FH.read/A.read #endif -- XXX When we mark this with INLINE and we have two benchmarks using S.drain @@ -193,7 +190,7 @@ $ IUS.lines FL.drain $ SS.decodeLatin1 -- XXX replace with toBytes - $ S.unfoldMany A.reader (IFH.readChunks inh) + $ S.unfoldEach A.reader (IFH.readChunks inh) #ifdef INSPECTION inspect $ hasNoTypeClasses 'getChunksConcatUnfoldCountLines @@ -217,8 +214,8 @@ chunksOfSum n inh = S.fold Fold.length $ IP.groupsOf n FL.sum (S.unfold FH.reader inh) -foldManyPostChunksOfSum :: Int -> Handle -> IO Int -foldManyPostChunksOfSum n inh = +foldMany1ChunksOfSum :: Int -> Handle -> IO Int +foldMany1ChunksOfSum n inh = S.fold Fold.length $ IP.foldManyPost (FL.take n FL.sum) (S.unfold FH.reader inh) @@ -236,13 +233,13 @@ groupsOf n inh = -- writeNUnsafe gives 2.5x boost here over writeN. S.fold Fold.length - $ IP.groupsOf n (AT.writeNUnsafe n) (S.unfold FH.reader inh) + $ IP.groupsOf n (A.unsafeCreateOf n) (S.unfold FH.reader inh) #ifdef INSPECTION inspect $ hasNoTypeClasses 'groupsOf inspect $ 'groupsOf `hasNoType` ''Step inspect $ 'groupsOf `hasNoType` ''FoldMany -inspect $ 'groupsOf `hasNoType` ''AT.ArrayUnsafe -- AT.writeNUnsafe +inspect $ 'groupsOf `hasNoType` ''MutArray.ArrayUnsafe -- AT.writeNUnsafe -- FH.read/A.read inspect $ 'groupsOf `hasNoType` ''IUF.ConcatState -- FH.read/UF.many #endif @@ -250,7 +247,7 @@ {-# INLINE chunksOf #-} chunksOf :: Int -> Handle -> IO Int chunksOf n inh = - S.fold Fold.length $ Stream.chunksOf n (S.unfold FH.reader inh) + S.fold Fold.length $ A.chunksOf n (S.unfold FH.reader inh) o_1_space_reduce_read_grouped :: BenchEnv -> [Benchmark] o_1_space_reduce_read_grouped env = @@ -264,13 +261,13 @@ -- XXX investigate why we need inline/noinline in these cases (GHC) -- Chunk using parsers , mkBench - ("S.foldManyPost (FL.take " ++ show (bigSize env) ++ " FL.sum)") + ("S.foldMany1 (FL.take " ++ show (bigSize env) ++ " FL.sum)") env - $ \inh _ -> noinline foldManyPostChunksOfSum (bigSize env) inh + $ \inh _ -> noinline foldMany1ChunksOfSum (bigSize env) inh , mkBench - "S.foldManyPost (FL.take 1 FL.sum)" + "S.foldMany1 (FL.take 1 FL.sum)" env - $ \inh _ -> inline foldManyPostChunksOfSum 1 inh + $ \inh _ -> inline foldMany1ChunksOfSum 1 inh , mkBench ("S.foldMany (FL.take " ++ show (bigSize env) ++ " FL.sum)") env @@ -289,11 +286,11 @@ groupsOf 1000 inh -- chunksOf may use a different impl than groupsOf - , mkBenchSmall "S.chunksOf 1" env $ \inh _ -> + , mkBenchSmall "A.chunksOf 1" env $ \inh _ -> chunksOf 1 inh - , mkBench "S.chunksOf 10" env $ \inh _ -> + , mkBench "A.chunksOf 10" env $ \inh _ -> chunksOf 10 inh - , mkBench "S.chunksOf 1000" env $ \inh _ -> + , mkBench "A.chunksOf 1000" env $ \inh _ -> chunksOf 1000 inh ] ] diff --git a/benchmark/Streamly/Benchmark/FileSystem/Handle/ReadWrite.hs b/benchmark/Streamly/Benchmark/FileSystem/Handle/ReadWrite.hs --- a/benchmark/Streamly/Benchmark/FileSystem/Handle/ReadWrite.hs +++ b/benchmark/Streamly/Benchmark/FileSystem/Handle/ReadWrite.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -Wno-deprecations #-} -- | -- Module : Streamly.Benchmark.FileSystem.Handle @@ -34,16 +33,15 @@ import qualified Streamly.Data.Array as A import qualified Streamly.Data.Stream.Prelude as S -import Gauge hiding (env) +import Test.Tasty.Bench hiding (env) import Streamly.Benchmark.Common.Handle #ifdef INSPECTION -import Streamly.Internal.Data.Stream.StreamD.Type (Step(..)) +import Streamly.Internal.Data.Stream (Step(..)) -import qualified Streamly.Internal.Data.Stream.StreamD.Type as D +import qualified Streamly.Internal.Data.Stream as D import qualified Streamly.Internal.Data.Tuple.Strict as Strict -import qualified Streamly.Internal.Data.Array.Mut.Stream as MAS -import qualified Streamly.Internal.Data.Array.Type as AT +import qualified Streamly.Internal.Data.MutArray as MutArray import Test.Inspection #endif @@ -83,7 +81,7 @@ inspect $ hasNoTypeClasses 'copyStream inspect $ 'copyStream `hasNoType` ''Step -- S.unfold inspect $ 'copyStream `hasNoType` ''IUF.ConcatState -- FH.read/UF.many -inspect $ 'copyStream `hasNoType` ''AT.ArrayUnsafe -- FH.write/writeNUnsafe +inspect $ 'copyStream `hasNoType` ''MutArray.ArrayUnsafe -- FH.write/writeNUnsafe -- FH.read/A.read inspect $ 'copyStream `hasNoType` ''Strict.Tuple3' -- FH.write/chunksOf #endif @@ -109,8 +107,8 @@ #ifdef INSPECTION inspect $ hasNoTypeClasses 'readFromBytesNull inspect $ 'readFromBytesNull `hasNoType` ''Step -inspect $ 'readFromBytesNull `hasNoType` ''MAS.SpliceState -inspect $ 'readFromBytesNull `hasNoType` ''AT.ArrayUnsafe -- FH.fromBytes/S.chunksOf +inspect $ 'readFromBytesNull `hasNoType` ''MutArray.SpliceState +inspect $ 'readFromBytesNull `hasNoType` ''MutArray.ArrayUnsafe -- FH.fromBytes/S.chunksOf inspect $ 'readFromBytesNull `hasNoType` ''D.FoldMany #endif @@ -123,8 +121,8 @@ #ifdef INSPECTION inspect $ hasNoTypeClasses 'readWithFromBytesNull inspect $ 'readWithFromBytesNull `hasNoType` ''Step -inspect $ 'readWithFromBytesNull `hasNoType` ''MAS.SpliceState -inspect $ 'readWithFromBytesNull `hasNoType` ''AT.ArrayUnsafe -- FH.fromBytes/S.chunksOf +inspect $ 'readWithFromBytesNull `hasNoType` ''MutArray.SpliceState +inspect $ 'readWithFromBytesNull `hasNoType` ''MutArray.ArrayUnsafe -- FH.fromBytes/S.chunksOf inspect $ 'readWithFromBytesNull `hasNoType` ''D.FoldMany #endif @@ -136,7 +134,7 @@ where fld = FH.write devNull - unf = IUF.many A.reader FH.chunkReader + unf = IUF.unfoldEach A.reader FH.chunkReader -- | Send the chunk content to /dev/null -- Implicitly benchmarked via 'readWithFromBytesNull' @@ -146,7 +144,7 @@ where fld = FH.write devNull - unf = IUF.many A.reader FH.chunkReaderWith + unf = IUF.unfoldEach A.reader FH.chunkReaderWith o_1_space_copy_fromBytes :: BenchEnv -> [Benchmark] o_1_space_copy_fromBytes env = @@ -171,7 +169,7 @@ inspect $ hasNoTypeClasses 'writeReadWith inspect $ 'writeReadWith `hasNoType` ''Step inspect $ 'writeReadWith `hasNoType` ''IUF.ConcatState -- FH.read/UF.many -inspect $ 'writeReadWith `hasNoType` ''AT.ArrayUnsafe -- FH.write/writeNUnsafe +inspect $ 'writeReadWith `hasNoType` ''MutArray.ArrayUnsafe -- FH.write/writeNUnsafe -- FH.read/A.read #endif @@ -188,7 +186,7 @@ inspect $ hasNoTypeClasses 'writeRead inspect $ 'writeRead `hasNoType` ''Step inspect $ 'writeRead `hasNoType` ''IUF.ConcatState -- FH.read/UF.many -inspect $ 'writeRead `hasNoType` ''AT.ArrayUnsafe -- FH.write/writeNUnsafe +inspect $ 'writeRead `hasNoType` ''MutArray.ArrayUnsafe -- FH.write/writeNUnsafe -- FH.read/A.read #endif diff --git a/benchmark/Streamly/Benchmark/Prelude/Adaptive.hs b/benchmark/Streamly/Benchmark/Prelude/Adaptive.hs --- a/benchmark/Streamly/Benchmark/Prelude/Adaptive.hs +++ b/benchmark/Streamly/Benchmark/Prelude/Adaptive.hs @@ -10,7 +10,7 @@ import Control.Concurrent (threadDelay) import Control.Monad (when) import Control.Monad.IO.Class (liftIO) -import Gauge +import Test.Tasty.Bench import Streamly.Prelude as S import System.Random (randomRIO) diff --git a/benchmark/Streamly/Benchmark/Prelude/Ahead.hs b/benchmark/Streamly/Benchmark/Prelude/Ahead.hs --- a/benchmark/Streamly/Benchmark/Prelude/Ahead.hs +++ b/benchmark/Streamly/Benchmark/Prelude/Ahead.hs @@ -15,7 +15,7 @@ import Streamly.Benchmark.Common import Streamly.Benchmark.Prelude -import Gauge +import Test.Tasty.Bench moduleName :: String moduleName = "Prelude.Ahead" diff --git a/benchmark/Streamly/Benchmark/Prelude/Async.hs b/benchmark/Streamly/Benchmark/Prelude/Async.hs --- a/benchmark/Streamly/Benchmark/Prelude/Async.hs +++ b/benchmark/Streamly/Benchmark/Prelude/Async.hs @@ -16,7 +16,7 @@ import Streamly.Benchmark.Common import Streamly.Benchmark.Prelude -import Gauge +import Test.Tasty.Bench moduleName :: String moduleName = "Prelude.Async" diff --git a/benchmark/Streamly/Benchmark/Prelude/Concurrent.hs b/benchmark/Streamly/Benchmark/Prelude/Concurrent.hs --- a/benchmark/Streamly/Benchmark/Prelude/Concurrent.hs +++ b/benchmark/Streamly/Benchmark/Prelude/Concurrent.hs @@ -15,7 +15,7 @@ , fromWAsync, parallel, fromParallel ) -import Gauge +import Test.Tasty.Bench import qualified Streamly.Prelude as S ------------------------------------------------------------------------------- diff --git a/benchmark/Streamly/Benchmark/Prelude/Merge.hs b/benchmark/Streamly/Benchmark/Prelude/Merge.hs --- a/benchmark/Streamly/Benchmark/Prelude/Merge.hs +++ b/benchmark/Streamly/Benchmark/Prelude/Merge.hs @@ -30,13 +30,13 @@ import Streamly.Benchmark.Common import Streamly.Benchmark.Prelude -import Gauge +import Test.Tasty.Bench #ifdef INSPECTION import GHC.Types (SPEC(..)) import Test.Inspection -import qualified Streamly.Internal.Data.Stream.StreamD as D +import qualified Streamly.Internal.Data.Stream as D #endif moduleName :: String diff --git a/benchmark/Streamly/Benchmark/Prelude/Parallel.hs b/benchmark/Streamly/Benchmark/Prelude/Parallel.hs --- a/benchmark/Streamly/Benchmark/Prelude/Parallel.hs +++ b/benchmark/Streamly/Benchmark/Prelude/Parallel.hs @@ -22,7 +22,7 @@ import Streamly.Benchmark.Common import Streamly.Benchmark.Prelude -import Gauge +import Test.Tasty.Bench moduleName :: String moduleName = "Prelude.Parallel" diff --git a/benchmark/Streamly/Benchmark/Prelude/Rate.hs b/benchmark/Streamly/Benchmark/Prelude/Rate.hs --- a/benchmark/Streamly/Benchmark/Prelude/Rate.hs +++ b/benchmark/Streamly/Benchmark/Prelude/Rate.hs @@ -14,7 +14,7 @@ import Streamly.Benchmark.Common import Streamly.Benchmark.Prelude -import Gauge +import Test.Tasty.Bench moduleName :: String moduleName = "Prelude.Rate" diff --git a/benchmark/Streamly/Benchmark/Prelude/WAsync.hs b/benchmark/Streamly/Benchmark/Prelude/WAsync.hs --- a/benchmark/Streamly/Benchmark/Prelude/WAsync.hs +++ b/benchmark/Streamly/Benchmark/Prelude/WAsync.hs @@ -15,7 +15,7 @@ import Streamly.Benchmark.Common import Streamly.Benchmark.Prelude -import Gauge +import Test.Tasty.Bench moduleName :: String moduleName = "Prelude.WAsync" diff --git a/benchmark/Streamly/Benchmark/Prelude/WSerial.hs b/benchmark/Streamly/Benchmark/Prelude/WSerial.hs --- a/benchmark/Streamly/Benchmark/Prelude/WSerial.hs +++ b/benchmark/Streamly/Benchmark/Prelude/WSerial.hs @@ -29,13 +29,13 @@ import Streamly.Benchmark.Common import Streamly.Benchmark.Prelude -import Gauge +import Test.Tasty.Bench #ifdef INSPECTION import GHC.Types (SPEC(..)) import Test.Inspection -import qualified Streamly.Internal.Data.Stream.StreamD as D +import qualified Streamly.Internal.Data.Stream as D #endif moduleName :: String diff --git a/benchmark/Streamly/Benchmark/Prelude/ZipAsync.hs b/benchmark/Streamly/Benchmark/Prelude/ZipAsync.hs --- a/benchmark/Streamly/Benchmark/Prelude/ZipAsync.hs +++ b/benchmark/Streamly/Benchmark/Prelude/ZipAsync.hs @@ -15,7 +15,7 @@ import Streamly.Benchmark.Common import Streamly.Benchmark.Prelude -import Gauge +import Test.Tasty.Bench moduleName :: String moduleName = "Prelude.ZipAsync" diff --git a/benchmark/Streamly/Benchmark/Prelude/ZipSerial.hs b/benchmark/Streamly/Benchmark/Prelude/ZipSerial.hs --- a/benchmark/Streamly/Benchmark/Prelude/ZipSerial.hs +++ b/benchmark/Streamly/Benchmark/Prelude/ZipSerial.hs @@ -29,13 +29,13 @@ import Streamly.Benchmark.Common import Streamly.Benchmark.Prelude hiding (sourceUnfoldrM) -import Gauge +import Test.Tasty.Bench #ifdef INSPECTION import GHC.Types (SPEC(..)) import Test.Inspection -import qualified Streamly.Internal.Data.Stream.StreamD as D +import qualified Streamly.Internal.Data.Stream as D #endif moduleName :: String diff --git a/benchmark/Streamly/Benchmark/Unicode/Char.hs b/benchmark/Streamly/Benchmark/Unicode/Char.hs --- a/benchmark/Streamly/Benchmark/Unicode/Char.hs +++ b/benchmark/Streamly/Benchmark/Unicode/Char.hs @@ -16,7 +16,7 @@ import Streamly.Internal.Data.Array (Array) import System.FilePath (dropExtensions, takeFileName) import System.FilePath.Posix (()) -import Gauge.Main (Benchmark, bench, bgroup, defaultMain, env, nfIO) +import Test.Tasty.Bench (Benchmark, bench, bgroup, defaultMain, env, nfIO) import Streamly.Internal.Unicode.Char ( NormalizationMode(NFC, NFD, NFKC, NFKD) , normalize @@ -24,7 +24,7 @@ import Streamly.Benchmark.Common (o_1_space_prefix) import qualified Streamly.Internal.Data.Array as Array -import qualified Streamly.Internal.Data.Stream.StreamD as IsStream +import qualified Streamly.Internal.Data.Stream as IsStream import qualified System.Directory as Dir -------------------------------------------------------------------------------- diff --git a/benchmark/Streamly/Benchmark/Unicode/Parser.hs b/benchmark/Streamly/Benchmark/Unicode/Parser.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Unicode/Parser.hs @@ -0,0 +1,107 @@ +-- | +-- Module : Streamly.Benchmark.Data.Parser +-- Copyright : (c) 2020 Composewell Technologies +-- +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +#undef FUSION_CHECK +#ifdef FUSION_CHECK +{-# OPTIONS_GHC -ddump-simpl -ddump-to-file -dsuppress-all #-} +#endif + +module Main + ( + main + ) where + +import Control.DeepSeq (NFData(..)) +import Control.Monad (replicateM_) +import Streamly.Internal.Data.Parser (ParseError(..)) +import Streamly.Internal.Data.Stream (Stream) +import Prelude hiding + (any, all, take, sequence, sequence_, sequenceA, takeWhile, dropWhile) + +import qualified Streamly.Data.Array as Array +import qualified Streamly.Data.Stream as Stream +import qualified Streamly.Internal.Unicode.Parser as PRU + +import Test.Tasty.Bench hiding (env) +import Streamly.Benchmark.Common + +runParser :: Int -> (Stream IO Char -> IO a) -> IO () +runParser count p = do + let v = "+123456789.123456789e-123" + let !(arr :: Array.Array Char) = Array.fromListN (length v) v + let s = Stream.unfold Array.reader arr + replicateM_ count (p s) + +-- | Takes a fold method, and uses it with a default source. +{-# INLINE benchIOSink #-} +benchIOSink :: Int -> String -> (Stream IO Char -> IO b) -> Benchmark +benchIOSink value name f = bench name $ nfIO $ runParser value f + +{-# INLINE doubleParser #-} +doubleParser :: Monad m => Stream m Char -> m (Either ParseError (Int, Int)) +doubleParser = Stream.parse PRU.doubleParser + +{-# INLINE number #-} +number :: Monad m => Stream m Char -> m (Either ParseError (Integer, Int)) +number = Stream.parse PRU.number + +{-# INLINE double #-} +double :: Monad m => Stream m Char -> m (Either ParseError Double) +double = Stream.parse PRU.double + +{-# INLINE numberDouble #-} +numberDouble :: Monad m => Stream m Char -> m (Either ParseError Double) +numberDouble = Stream.parse p + where p = uncurry PRU.mkDouble <$> PRU.number + +------------------------------------------------------------------------------- +-- Benchmarks +------------------------------------------------------------------------------- + +moduleName :: String +moduleName = "Unicode.Parser" + +instance NFData ParseError where + {-# INLINE rnf #-} + rnf (ParseError x) = rnf x + +o_n_heap_serial :: Int -> [Benchmark] +o_n_heap_serial value = + [ + benchIOSink value "doubleParser" doubleParser + , benchIOSink value "number" number + , benchIOSink value "double (doubleParser)" double + , benchIOSink value "double (number)" numberDouble + ] + +------------------------------------------------------------------------------- +-- Driver +------------------------------------------------------------------------------- + +main :: IO () +main = do +#ifndef FUSION_CHECK + runWithCLIOpts defaultStreamSize allBenchmarks + + where + + allBenchmarks value = + [ bgroup (o_n_heap_prefix moduleName) (o_n_heap_serial value) + ] +#else + -- Enable FUSION_CHECK macro at the beginning of the file + -- Enable one benchmark below, and run the benchmark + -- Check the .dump-simpl output + let value = 100000 + runParser value double + return () +#endif diff --git a/benchmark/Streamly/Benchmark/Unicode/Stream.hs b/benchmark/Streamly/Benchmark/Unicode/Stream.hs --- a/benchmark/Streamly/Benchmark/Unicode/Stream.hs +++ b/benchmark/Streamly/Benchmark/Unicode/Stream.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -Wno-deprecations #-} -- -- Module : Streamly.Unicode.Stream @@ -11,6 +10,11 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} +#undef FUSION_CHECK +#ifdef FUSION_CHECK +{-# OPTIONS_GHC -ddump-simpl -ddump-to-file -dsuppress-all #-} +#endif + #ifdef __HADDOCK_VERSION__ #undef INSPECTION #endif @@ -24,25 +28,27 @@ import Streamly.Data.Fold (Fold) import Prelude hiding (last, length) import System.IO (Handle) +import Streamly.Internal.System.IO (arrayPayloadSize) import qualified Streamly.Data.Array as Array import qualified Streamly.Data.Fold as Fold -import qualified Streamly.Internal.Data.Stream.StreamD as Stream +import qualified Streamly.Internal.Data.Stream as Stream import qualified Streamly.Internal.Data.Unfold as Unfold import qualified Streamly.Internal.FileSystem.Handle as Handle import qualified Streamly.Internal.Unicode.Array as UnicodeArr import qualified Streamly.Internal.Unicode.Stream as Unicode +import qualified Streamly.Internal.Data.Array as Array -import Gauge hiding (env) +import Test.Tasty.Bench hiding (env) import Streamly.Benchmark.Common import Streamly.Benchmark.Common.Handle #ifdef INSPECTION -import Streamly.Internal.Data.Unboxed (Unbox) -import Streamly.Internal.Data.Stream.StreamD.Type (Step(..)) -import qualified Streamly.Internal.Data.Fold.Type as Fold +import Streamly.Internal.Data.MutByteArray (Unbox) +import Streamly.Internal.Data.Stream (Step(..)) +import qualified Streamly.Internal.Data.MutArray as MutArray +import qualified Streamly.Internal.Data.Fold as Fold import qualified Streamly.Internal.Data.Tuple.Strict as Strict -import qualified Streamly.Internal.Data.Array.Type as Array import Test.Inspection #endif @@ -97,8 +103,8 @@ linesUnlinesArrayWord8Copy :: Handle -> Handle -> IO () linesUnlinesArrayWord8Copy inh outh = Stream.fold (Handle.write outh) - $ Stream.interposeSuffix 10 Array.reader - $ splitOnSuffix (== 10) Array.write + $ Stream.unfoldEachEndBy 10 Array.reader + $ splitOnSuffix (== 10) Array.create $ Stream.unfold Handle.reader inh -- XXX splitSuffixOn requires -funfolding-use-threshold=150 for better fusion @@ -137,7 +143,7 @@ wordsUnwordsCopyWord8 :: Handle -> Handle -> IO () wordsUnwordsCopyWord8 inh outh = Stream.fold (Handle.write outh) - $ Stream.interposeSuffix 32 Unfold.fromList + $ Stream.unfoldEachEndBy 32 Unfold.fromList $ Stream.wordsBy isSp Fold.toList $ Stream.unfold Handle.reader inh @@ -218,7 +224,7 @@ inspect $ 'copyStreamLatin1' `hasNoType` ''Unfold.ConcatState -- Handle.read/UF.many inspect $ 'copyStreamLatin1' `hasNoType` ''Fold.Step -inspect $ 'copyStreamLatin1' `hasNoType` ''Array.ArrayUnsafe -- Handle.write/writeNUnsafe +inspect $ 'copyStreamLatin1' `hasNoType` ''MutArray.ArrayUnsafe -- Handle.write/writeNUnsafe -- Handle.read/Array.read inspect $ 'copyStreamLatin1' `hasNoType` ''Strict.Tuple3' -- Handle.write/chunksOf #endif @@ -239,7 +245,7 @@ inspect $ 'copyStreamLatin1 `hasNoType` ''Fold.ManyState inspect $ 'copyStreamLatin1 `hasNoType` ''Fold.Step -inspect $ 'copyStreamLatin1 `hasNoType` ''Array.ArrayUnsafe -- Handle.write/writeNUnsafe +inspect $ 'copyStreamLatin1 `hasNoType` ''MutArray.ArrayUnsafe -- Handle.write/writeNUnsafe -- Handle.read/Array.read inspect $ 'copyStreamLatin1 `hasNoType` ''Strict.Tuple3' -- Handle.write/chunksOf #endif @@ -252,6 +258,17 @@ $ Unicode.decodeUtf8' $ Stream.unfold Handle.reader inh +-- | Copy file +{-# NOINLINE copyStreamUtf16 #-} +copyStreamUtf16 :: Handle -> Handle -> IO () +copyStreamUtf16 inh outh = + Stream.fold (Handle.writeChunks outh) + $ fmap Array.unsafeCast $ Array.chunksOf (arrayPayloadSize (16 * 1024)) + $ Unicode.encodeUtf16le' + $ Unicode.decodeUtf16le + $ Array.concat $ fmap Array.unsafeCast $ Unicode.mkEvenW8Chunks + $ Handle.readChunks inh + #ifdef INSPECTION inspect $ hasNoTypeClasses '_copyStreamUtf8' -- inspect $ '_copyStreamUtf8 `hasNoType` ''Step @@ -280,7 +297,8 @@ _copyStreamUtf8'Fold inh outh = Stream.fold (Handle.write outh) $ Unicode.encodeUtf8 - $ Stream.foldMany Unicode.writeCharUtf8' + $ Stream.catRights + $ Stream.parseMany Unicode.writeCharUtf8' $ Stream.unfold Handle.reader inh {-# NOINLINE _copyStreamUtf8Parser #-} @@ -312,11 +330,14 @@ $ \inh outh -> _copyStreamUtf8Parser inh outh , mkBenchSmall "encodeUtf8 . decodeUtf8" env $ \inh outh -> copyStreamUtf8 inh outh + , mkBenchSmall "encodeUtf16 . decodeUtf16" env $ \inh outh -> + copyStreamUtf16 inh outh ] ] main :: IO () main = do +#ifndef FUSION_CHECK env <- mkHandleBenchEnv defaultMain (allBenchmarks env) @@ -329,3 +350,13 @@ , o_1_space_decode_encode_read env ] ] +#else + -- Enable FUSION_CHECK macro at the beginning of the file + -- Enable one benchmark below, and run the benchmark + -- Check the .dump-simpl output + env <- mkHandleBenchEnv + let mkHandles (RefHandles {bigInH = inh, outputH = outh}) = Handles inh outh + (Handles inh outh) <- getHandles env mkHandles + copyStreamLatin1' inh outh + return () +#endif diff --git a/benchmark/Streamly/Benchmark/Unicode/Utf8.hs b/benchmark/Streamly/Benchmark/Unicode/Utf8.hs --- a/benchmark/Streamly/Benchmark/Unicode/Utf8.hs +++ b/benchmark/Streamly/Benchmark/Unicode/Utf8.hs @@ -13,7 +13,7 @@ import Data.Char (chr) import Streamly.Internal.Unicode.Utf8 (Utf8) -import Gauge hiding (env) +import Test.Tasty.Bench hiding (env) import Streamly.Benchmark.Common import qualified Streamly.Internal.Unicode.Utf8 as Utf8 diff --git a/benchmark/bench-runner/Main.hs b/benchmark/bench-runner/Main.hs --- a/benchmark/bench-runner/Main.hs +++ b/benchmark/bench-runner/Main.hs @@ -16,9 +16,11 @@ benchName = drop 4 benchName0 general - | "o-1-sp" `isInfixOf` benchName = "-K36K -M16M" + -- GHC-9.6 requires 32M heap vs 16M for GHC-9.4 + | "o-1-sp" `isInfixOf` benchName = "-K36K -M32M" | "o-n-h" `isInfixOf` benchName = "-K36K -M32M" - | "o-n-st" `isInfixOf` benchName = "-K1M -M16M" + -- GHC-9.6 requires 32M heap vs 16M for GHC-9.4 + | "o-n-st" `isInfixOf` benchName = "-K1M -M32M" | "o-n-sp" `isInfixOf` benchName = "-K1M -M32M" | otherwise = "" @@ -27,6 +29,17 @@ | otherwise = "" benchSpecific + -- GHC-9.6 requires 64M, earlier it was 16M + | "Data.Fold/o-n-heap.key-value.toHashMapIO (max buckets) sum" == benchName = + "-M64M" + + -- This is required only for the --long case because we allocate all + -- the arrays upfront. depends on the size of the stream. + | "Data.Parser/o-1-space" `isPrefixOf` benchName = + "-M128M" + + ----------------------------------------------------------------------- + | "Prelude.Parallel/o-n-heap.mapping.mapM" == benchName = "-M256M" | "Prelude.Parallel/o-n-heap.monad-outer-product." `isPrefixOf` benchName = "-M256M" @@ -47,23 +60,15 @@ | "Prelude.WAsync/o-n-space.monad-outer-product." `isPrefixOf` benchName = "-K4M" - -- This module is dev only now, and can be removed at some point - | "Data.Stream.StreamDK/o-1-space.grouping.classifySessionsOf" - `isPrefixOf` benchName = "-K512K" - | "Data.Stream.StreamDK/o-n-space.foldr.foldrM/" - `isPrefixOf` benchName = "-K4M" - | "Data.Stream.StreamDK/o-n-space.iterated." - `isPrefixOf` benchName = "-K4M -M64M" - -- GHC 9.4.4 requires 4M - | "Data.Stream.StreamDK/o-n-space.traversable." - `isPrefixOf` benchName = "-K4M" - ----------------------------------------------------------------------- - | "Data.Stream.StreamD/o-n-space.elimination.toList" == benchName = + | "Data.StreamD/o-n-space.elimination.toList" == benchName = "-K2M" - | "Data.Stream.StreamK/o-n-space.elimination.toList" == benchName = + | "Data.StreamK/o-n-space.elimination.toList" == benchName = "-K2M" + -- XXX Memory required for these has increased in streamly-core 0.3 + | "Data.StreamK/o-1-space.list.nested" `isPrefixOf` benchName = + "-M640M" ----------------------------------------------------------------------- @@ -74,8 +79,15 @@ | "Data.Stream/o-n-space.iterated." `isPrefixOf` benchName = "-K4M" + -- GHC-9.6 requires 64M, earlier it was 32M + | "Data.Stream/o-n-heap.buffered.showPrec Haskell lists" == benchName = + "-M64M" + -- GHC-9.6 requires 64M, earlier it was 32M + | "Data.Stream/o-n-heap.buffered.readsPrec pure streams" == benchName = + "-M64M" + | "Data.Stream.ConcurrentEager/o-n-heap.monad-outer-product.toNullAp" - `isPrefixOf` benchName = "-M1024M" + `isPrefixOf` benchName = "-M1500M" | "Data.Stream.ConcurrentEager/o-1-space." `isPrefixOf` benchName = "-M128M" @@ -86,10 +98,12 @@ | "Data.Array" `isPrefixOf` benchName && "/o-1-space.generation.read" `isSuffixOf` benchName = "-M32M" + -- XXX GHC 9.6 onwards needs 64M, earlier it was 32M | "Data.Array" `isPrefixOf` benchName - && "/o-1-space.generation.show" `isSuffixOf` benchName = "-M32M" + && "/o-1-space.generation.show" `isSuffixOf` benchName = "-M64M" + -- XXX GHC 9.6 onwards needs 64M, earlier it was 32M | "Data.Array.Generic/o-1-space.transformationX4.map" - `isPrefixOf` benchName = "-M32M" + `isPrefixOf` benchName = "-M64M" -- XXX For --long option, need to check why so much heap is required. -- Note, if we remove the chunked stream module we need to keep the @@ -98,8 +112,19 @@ `isPrefixOf` benchName = "-K4M -M512M" -- XXX Takes up to 160MB heap for --long, we use chunked stream for -- this, so the reason may be related to chunked streams. - | "Data.Parser.ParserK/o-1-space" + | "Data.ParserK/o-1-space" `isPrefixOf` benchName = "-K4M -M256M" + | "Data.ParserK.Chunked/o-1-space" + `isPrefixOf` benchName = "-K4M -M256M" + | "Data.ParserK.Chunked.Generic/o-1-space" + `isPrefixOf` benchName = "-K4M -M256M" + +{- + -- XXX This options does not seem to take effect. "ParserK.Chunked" + -- needs more memory to work with --long option + | "Data.ParserK.Chunked.Generic/o-1-space" + `isPrefixOf` benchName = "-K4M -M256M" +-} ----------------------------------------------------------------------- diff --git a/benchmark/lib/Streamly/Benchmark/Common.hs b/benchmark/lib/Streamly/Benchmark/Common.hs --- a/benchmark/lib/Streamly/Benchmark/Common.hs +++ b/benchmark/lib/Streamly/Benchmark/Common.hs @@ -54,9 +54,9 @@ import System.Random (randomRIO) import qualified Streamly.Internal.Data.Fold as Fold -import qualified Streamly.Internal.Data.Stream.StreamD as S +import qualified Streamly.Internal.Data.Stream as S -import Gauge +import Test.Tasty.Bench ------------------------------------------------------------------------------- -- Benchmark Prefixes diff --git a/benchmark/lib/Streamly/Benchmark/Common/Handle.hs b/benchmark/lib/Streamly/Benchmark/Common/Handle.hs --- a/benchmark/lib/Streamly/Benchmark/Common/Handle.hs +++ b/benchmark/lib/Streamly/Benchmark/Common/Handle.hs @@ -30,6 +30,8 @@ , isSpace , isSp , mkHandleBenchEnv + , Handles(..) + , getHandles ) where @@ -46,7 +48,7 @@ import Data.IORef import Prelude hiding (last, length) -import Gauge hiding (env) +import Test.Tasty.Bench hiding (env) scratchDir :: String diff --git a/benchmark/lib/Streamly/Benchmark/Prelude.hs b/benchmark/lib/Streamly/Benchmark/Prelude.hs --- a/benchmark/lib/Streamly/Benchmark/Prelude.hs +++ b/benchmark/lib/Streamly/Benchmark/Prelude.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -Wno-deprecations #-} -- | -- Module : Streamly.Benchmark.Prelude @@ -62,7 +61,7 @@ , transformComposeMapM , transformMapM , transformTeeMapM - , transformZipMapM + -- , transformZipMapM ) where @@ -78,11 +77,11 @@ import qualified Data.List as List import qualified Streamly.Prelude as S import qualified Streamly.Internal.Data.Stream.IsStream as Internal -import qualified Streamly.Internal.Data.Stream.IsStream.Type as IsStream +import qualified Streamly.Internal.Data.Stream.IsStream as IsStream import qualified Streamly.Internal.Data.Pipe as Pipe import qualified Streamly.Internal.Data.Stream.Serial as Serial -import Gauge +import Test.Tasty.Bench import Streamly.Internal.Data.Time.Units -- Common polymorphic stream APIs used across multiple stream modules @@ -318,9 +317,10 @@ composeN n $ t . Internal.transform - (Pipe.mapM (\x -> return (x + 1)) `Pipe.tee` + (Pipe.mapM (\x -> return (x + 1)) `Pipe.teeMerge` Pipe.mapM (\x -> return (x + 2))) +{- {-# INLINE transformZipMapM #-} transformZipMapM :: (S.IsStream t, S.MonadAsync m) @@ -336,6 +336,7 @@ (+) (Pipe.mapM (\x -> return (x + 1))) (Pipe.mapM (\x -> return (x + 2)))) +-} ------------------------------------------------------------------------------- -- Streams of streams diff --git a/benchmark/streamly-benchmarks.cabal b/benchmark/streamly-benchmarks.cabal --- a/benchmark/streamly-benchmarks.cabal +++ b/benchmark/streamly-benchmarks.cabal @@ -54,11 +54,6 @@ manual: True default: True -flag use-gauge - description: Use gauge instead of tasty-bench for benchmarking - manual: True - default: False - flag use-streamly-core description: Benchmark only core package manual: True @@ -74,10 +69,23 @@ ------------------------------------------------------------------------------- common default-extensions + default-language: Haskell2010 + + -- GHC2024 may include more extensions than we are actually using, see the + -- full list below. We enable this to ensure that we are able to compile + -- with this i.e. there is no interference by other extensions. + if impl(ghc >= 9.10) + default-language: GHC2024 + + if impl(ghc >= 9.2) && impl(ghc < 9.10) + default-language: GHC2021 + + if impl(ghc >= 8.10) + default-extensions: StandaloneKindSignatures + + -- In GHC 2024 default-extensions: BangPatterns - CApiFFI - CPP ConstraintKinds DeriveDataTypeable DeriveGeneric @@ -89,29 +97,20 @@ InstanceSigs KindSignatures LambdaCase - MagicHash MultiParamTypeClasses - PatternSynonyms RankNTypes - RecordWildCards ScopedTypeVariables TupleSections TypeApplications - TypeFamilies TypeOperators - ViewPatterns - -- MonoLocalBinds, enabled by TypeFamilies, causes performance - -- regressions. Disable it. This must come after TypeFamilies, - -- otherwise TypeFamilies will enable it again. - NoMonoLocalBinds - - -- UndecidableInstances -- Does not show any perf impact - -- UnboxedTuples -- interferes with (#.) + -- Not in GHC2024 + CPP + MagicHash + RecordWildCards common compile-options import: default-extensions - default-language: Haskell2010 if flag(use-streamly-core) cpp-options: -DUSE_STREAMLY_CORE @@ -145,6 +144,10 @@ -Wno-missing-kind-signatures -Wno-operator-whitespace + if impl(ghc >= 9.8) + ghc-options: + -Wno-missing-role-annotations + if flag(has-llvm) ghc-options: -fllvm @@ -152,15 +155,17 @@ ghc-options: -Wmissed-specialisations -Wall-missed-specialisations - if flag(dev) || flag(debug) - ghc-options: -fno-ignore-asserts - common optimization-options if flag(opt) ghc-options: -O2 -fdicts-strict -fspec-constr-recursive=16 -fmax-worker-args=16 + + -- For this to be effective it must come after the -O2 option + if flag(dev) || flag(debug) + ghc-options: -fno-ignore-asserts + if flag(fusion-plugin) && !impl(ghcjs) && !impl(ghc < 8.6) ghc-options: -fplugin Fusion.Plugin else @@ -174,43 +179,36 @@ -- Core libraries shipped with ghc, the min and max -- constraints of these libraries should match with -- the GHC versions we support - base >= 4.9 && < 4.18 - , deepseq >= 1.4.1 && < 1.5 - , mtl >= 2.2 && < 2.3 + base >= 4.9 && < 4.23 + , deepseq >= 1.4.1 && < 1.6 + , mtl >= 2.2 && < 2.4 -- other libraries + , exceptions >= 0.8 && < 0.11 , random >= 1.0 && < 2.0 , transformers >= 0.4 && < 0.7 - , containers >= 0.5 && < 0.7 - , hashable >= 1.3 && < 1.5 + , containers >= 0.5 && < 0.9 + , hashable >= 1.3 && < 1.6 , unordered-containers >= 0.2 && < 0.3 , process >= 1.4 && < 1.7 , directory >= 1.2.2 && < 1.4 - , filepath >= 1.4.1 && < 1.5 - , ghc-prim >= 0.4 && < 0.10 - - if flag(use-streamly-core) - build-depends: streamly-core - else - build-depends: streamly - , streamly-core + , filepath >= 1.4.1 && < 1.6 + , ghc-prim >= 0.4 && < 0.14 + , tasty-bench >= 0.3 && < 0.6 + , tasty >= 1.4.1 && < 1.6 + , streamly-core - if flag(use-gauge) - build-depends: gauge >= 0.2.4 && < 0.3 - else - build-depends: tasty-bench >= 0.3 && < 0.4 - , tasty >= 1.4.1 && < 1.5 - mixins: tasty-bench - (Test.Tasty.Bench as Gauge - , Test.Tasty.Bench as Gauge.Main - ) + if !flag(use-streamly-core) + build-depends: + streamly + , bench-test-lib if flag(fusion-plugin) && !impl(ghcjs) && !impl(ghc < 8.6) build-depends: fusion-plugin >= 0.2 && < 0.3 if flag(inspection) - build-depends: template-haskell >= 2.14 && < 2.20 - , inspection-testing >= 0.4 && < 0.5 + build-depends: template-haskell >= 2.14 && < 2.25 + , inspection-testing >= 0.4 && < 0.7 -- Array uses a Storable constraint in dev build making several inspection -- tests fail if flag(dev) && flag(inspection) @@ -236,7 +234,7 @@ common bench-options import: compile-options, optimization-options, bench-depends include-dirs: . - ghc-options: -rtsopts + ghc-options: -rtsopts -with-rtsopts "-t" if flag(limit-build-mem) ghc-options: +RTS -M512M -RTS build-depends: streamly-benchmarks == 0.0.0 @@ -246,42 +244,205 @@ import: compile-options, optimization-options, bench-depends -- -threaded and -N2 is important because some GC and space leak issues -- trigger only with these options. - ghc-options: -threaded -rtsopts -with-rtsopts "-N2" + ghc-options: -threaded -rtsopts -with-rtsopts "-t -N2" if flag(limit-build-mem) ghc-options: +RTS -M512M -RTS build-depends: streamly-benchmarks == 0.0.0 ------------------------------------------------------------------------------- --- Serial Streams +-- Listed in alphabetical order ------------------------------------------------------------------------------- -benchmark Data.Stream +benchmark Data.Array import: bench-options type: exitcode-stdio-1.0 - hs-source-dirs: Streamly/Benchmark/Data - main-is: Stream.hs + hs-source-dirs: ., Streamly/Benchmark/Data + main-is: Streamly/Benchmark/Data/Array.hs other-modules: - Stream.Generate - Stream.Eliminate - Stream.Transform - Stream.Reduce - Stream.Expand - Stream.Lift Stream.Common - if !flag(use-streamly-core) - other-modules: - Stream.Exceptions + if flag(use-streamly-core) + buildable: False + else + buildable: True if flag(limit-build-mem) + ghc-options: +RTS -M1500M -RTS + +benchmark Data.Array.Generic + import: bench-options + type: exitcode-stdio-1.0 + hs-source-dirs: ., Streamly/Benchmark/Data + main-is: Streamly/Benchmark/Data/Array/Generic.hs + other-modules: + Stream.Common + if flag(use-streamly-core) + buildable: False + else + buildable: True + if flag(limit-build-mem) + ghc-options: +RTS -M1000M -RTS + +benchmark Data.Array.Stream + import: bench-options + type: exitcode-stdio-1.0 + hs-source-dirs: Streamly/Benchmark/Data/Array + main-is: Stream.hs + if flag(use-streamly-core) || impl(ghcjs) + buildable: False + else + buildable: True + build-depends: exceptions >= 0.8 && < 0.11 + +benchmark Data.Fold + import: bench-options + type: exitcode-stdio-1.0 + hs-source-dirs: Streamly/Benchmark/Data + main-is: Fold.hs + if impl(ghcjs) + buildable: False + else + buildable: True + +benchmark Data.Fold.Prelude + import: bench-options + type: exitcode-stdio-1.0 + hs-source-dirs: Streamly/Benchmark/Data/Fold + -- XXX Using the name Prelude.hs causes compilation error + main-is: Prelood.hs + if flag(use-streamly-core) || impl(ghcjs) + buildable: False + else + buildable: True + +benchmark Data.Fold.Window + import: bench-options + type: exitcode-stdio-1.0 + hs-source-dirs: Streamly/Benchmark/Data/Fold + main-is: Window.hs + -- MonoLocalBinds increases the memory requirement from 400MB to 1000MB, + -- observed on macOS. + if flag(limit-build-mem) + ghc-options: +RTS -M1000M -RTS + +benchmark Data.MutArray + import: bench-options + type: exitcode-stdio-1.0 + main-is: Streamly/Benchmark/Data/MutArray.hs + if flag(limit-build-mem) + ghc-options: +RTS -M1500M -RTS + if flag(use-streamly-core) + buildable: False + else + buildable: True + +benchmark Data.Parser + import: bench-options + type: exitcode-stdio-1.0 + hs-source-dirs: Streamly/Benchmark/Data + main-is: Parser.hs + if impl(ghcjs) + buildable: False + else + buildable: True + build-depends: exceptions >= 0.8 && < 0.11 + if flag(limit-build-mem) if flag(dev) - ghc-options: +RTS -M3500M -RTS + ghc-options: +RTS -M3000M -RTS else ghc-options: +RTS -M2500M -RTS --- Use StreamK functions where possible, converting to StreaK to StreamD -benchmark Data.Stream.StreamDK +benchmark Data.ParserK import: bench-options type: exitcode-stdio-1.0 hs-source-dirs: Streamly/Benchmark/Data + cpp-options: -DBENCH_SINGULAR + main-is: ParserK.hs + if impl(ghcjs) + buildable: False + else + buildable: True + build-depends: exceptions >= 0.8 && < 0.11 + +benchmark Data.ParserK.Chunked + import: bench-options + type: exitcode-stdio-1.0 + hs-source-dirs: Streamly/Benchmark/Data + cpp-options: -DBENCH_CHUNKED + main-is: ParserK.hs + if impl(ghcjs) + buildable: False + else + buildable: True + build-depends: exceptions >= 0.8 && < 0.11 + +benchmark Data.ParserK.Chunked.Generic + import: bench-options + type: exitcode-stdio-1.0 + hs-source-dirs: Streamly/Benchmark/Data + cpp-options: -DBENCH_CHUNKED_GENERIC + main-is: ParserK.hs + if impl(ghcjs) + buildable: False + else + buildable: True + build-depends: exceptions >= 0.8 && < 0.11 + +benchmark Data.RingArray + import: bench-options + type: exitcode-stdio-1.0 + main-is: Streamly/Benchmark/Data/RingArray.hs + if flag(limit-build-mem) + ghc-options: +RTS -M1500M -RTS + +benchmark Data.Scanl + import: bench-options + type: exitcode-stdio-1.0 + hs-source-dirs: Streamly/Benchmark/Data + main-is: Scanl.hs + +benchmark Data.Scanl.Window + import: bench-options + type: exitcode-stdio-1.0 + hs-source-dirs: Streamly/Benchmark/Data/Scanl + main-is: Window.hs + +benchmark Data.Scanl.Concurrent + import: bench-options + type: exitcode-stdio-1.0 + hs-source-dirs: Streamly/Benchmark/Data/Scanl + main-is: Concurrent.hs + if flag(use-streamly-core) || impl(ghcjs) + buildable: False + else + buildable: True + +-- XXX Should be renamed to MutByteArray +benchmark Data.Serialize + import: bench-options + type: exitcode-stdio-1.0 + hs-source-dirs: . + cpp-options: -DUSE_TH + main-is: Streamly/Benchmark/Data/Serialize.hs + build-depends: QuickCheck, template-haskell + other-modules: + Streamly.Benchmark.Data.Serialize.TH + Streamly.Benchmark.Data.Serialize.RecCompatible + Streamly.Benchmark.Data.Serialize.RecNonCompatible + if flag(limit-build-mem) + ghc-options: +RTS -M1000M -RTS + +benchmark Data.SmallArray + import: bench-options + type: exitcode-stdio-1.0 + main-is: Streamly/Benchmark/Data/Array/SmallArray.hs + if flag(dev) && !flag(use-streamly-core) + buildable: True + else + buildable: False + +benchmark Data.Stream + import: bench-options + type: exitcode-stdio-1.0 + hs-source-dirs: Streamly/Benchmark/Data main-is: Stream.hs other-modules: Stream.Generate @@ -290,20 +451,27 @@ Stream.Reduce Stream.Expand Stream.Lift + Stream.Split Stream.Common if !flag(use-streamly-core) other-modules: Stream.Exceptions - -- Cannot use USE_STREAMK and USE_PRELUDE together - if flag(use-prelude) - buildable: False - cpp-options: -DUSE_STREAMK if flag(limit-build-mem) if flag(dev) ghc-options: +RTS -M3500M -RTS else ghc-options: +RTS -M2500M -RTS +benchmark Data.Stream.Adaptive + import: bench-options-threaded + type: exitcode-stdio-1.0 + hs-source-dirs: Streamly/Benchmark/Data/Stream + main-is: Adaptive.hs + if flag(use-streamly-core) || impl(ghcjs) + buildable: False + else + buildable: True + benchmark Data.Stream.Concurrent import: bench-options-threaded type: exitcode-stdio-1.0 @@ -317,11 +485,11 @@ else buildable: True -benchmark Data.Stream.ConcurrentInterleaved +benchmark Data.Stream.ConcurrentEager import: bench-options-threaded type: exitcode-stdio-1.0 hs-source-dirs: Streamly/Benchmark/Data/Stream/, Streamly/Benchmark/Data/ - main-is: ConcurrentInterleaved.hs + main-is: ConcurrentEager.hs other-modules: Stream.ConcurrentCommon Stream.Common @@ -330,11 +498,11 @@ else buildable: True -benchmark Data.Stream.ConcurrentEager +benchmark Data.Stream.ConcurrentInterleaved import: bench-options-threaded type: exitcode-stdio-1.0 hs-source-dirs: Streamly/Benchmark/Data/Stream/, Streamly/Benchmark/Data/ - main-is: ConcurrentEager.hs + main-is: ConcurrentInterleaved.hs other-modules: Stream.ConcurrentCommon Stream.Common @@ -356,116 +524,122 @@ else buildable: True - -benchmark Data.Unfold - import: bench-options +benchmark Data.Stream.ConcurrentThreadHeavy + import: bench-options-threaded type: exitcode-stdio-1.0 - hs-source-dirs: . - main-is: Streamly/Benchmark/Data/Unfold.hs + hs-source-dirs: Streamly/Benchmark/Data/Stream + main-is: ConcurrentThreadHeavy.hs if flag(use-streamly-core) || impl(ghcjs) buildable: False else buildable: True -benchmark Data.Fold - import: bench-options +benchmark Data.Stream.Rate + import: bench-options-threaded type: exitcode-stdio-1.0 - hs-source-dirs: Streamly/Benchmark/Data - main-is: Fold.hs + hs-source-dirs: Streamly/Benchmark/Data/Stream/, Streamly/Benchmark/Data/ + main-is: Rate.hs + other-modules: + Stream.ConcurrentCommon + Stream.Common if flag(use-streamly-core) || impl(ghcjs) buildable: False else buildable: True -benchmark Data.Fold.Window +benchmark Data.StreamK import: bench-options type: exitcode-stdio-1.0 - hs-source-dirs: Streamly/Benchmark/Data/Fold - main-is: Window.hs - if flag(use-streamly-core) + hs-source-dirs: Streamly/Benchmark/Data + main-is: StreamK.hs + if impl(ghcjs) buildable: False - else - buildable: True -benchmark Data.Parser +-- XXX This needs to be cleaned up +benchmark Data.StreamK.FromStream import: bench-options type: exitcode-stdio-1.0 - hs-source-dirs: Streamly/Benchmark/Data - main-is: Parser.hs - if impl(ghcjs) + hs-source-dirs: Streamly/Benchmark/Data/StreamK + main-is: FromStream.hs + if !flag(dev) || impl(ghcjs) buildable: False - else - buildable: True - build-depends: exceptions >= 0.8 && < 0.11 - if flag(limit-build-mem) - if flag(dev) - ghc-options: +RTS -M3000M -RTS - else - ghc-options: +RTS -M1000M -RTS -benchmark Data.Parser.ParserK +benchmark Data.StreamK.StreamKAlt import: bench-options type: exitcode-stdio-1.0 - hs-source-dirs: Streamly/Benchmark/Data/Parser - main-is: ParserK.hs - if impl(ghcjs) + hs-source-dirs: Streamly/Benchmark/Data/StreamK + main-is: StreamKAlt.hs + if !flag(dev) || impl(ghcjs) buildable: False - else - buildable: True - build-depends: exceptions >= 0.8 && < 0.11 --- Note: to use this we have to set DISABLE_FUSION in ParserD.hs so that --- the rewrite rules are disabled. We can also use the "no-fusion" build --- flag but we need to keep in mind that it disables fusion for streams --- as well. -benchmark Data.Parser.FromParserK +benchmark Data.Unbox import: bench-options type: exitcode-stdio-1.0 - hs-source-dirs: Streamly/Benchmark/Data/Parser - cpp-options: -DFROM_PARSERK - main-is: ParserK.hs - if flag(use-streamly-core) || impl(ghcjs) - buildable: False - else - buildable: True - build-depends: exceptions >= 0.8 && < 0.11 + hs-source-dirs: . + cpp-options: -DUSE_UNBOX + main-is: Streamly/Benchmark/Data/Serialize.hs -------------------------------------------------------------------------------- --- Raw Streams -------------------------------------------------------------------------------- +benchmark Data.Unbox.Derive.TH + import: bench-options + type: exitcode-stdio-1.0 + hs-source-dirs: . + cpp-options: -DUSE_UNBOX + cpp-options: -DUSE_TH + main-is: Streamly/Benchmark/Data/Serialize.hs -benchmark Data.Stream.StreamD +benchmark Data.Unfold import: bench-options type: exitcode-stdio-1.0 - hs-source-dirs: Streamly/Benchmark/Data/Stream - main-is: StreamD.hs + hs-source-dirs: . + main-is: Streamly/Benchmark/Data/Unfold.hs if impl(ghcjs) buildable: False + else + buildable: True -benchmark Data.Stream.StreamK +benchmark FileSystem.Handle import: bench-options type: exitcode-stdio-1.0 - hs-source-dirs: Streamly/Benchmark/Data/Stream - main-is: StreamK.hs - if impl(ghcjs) + hs-source-dirs: Streamly/Benchmark/FileSystem + main-is: Handle.hs + other-modules: + Handle.Read + , Handle.ReadWrite + if flag(limit-build-mem) + ghc-options: +RTS -M1000M -RTS + if flag(use-streamly-core) buildable: False + else + buildable: True -benchmark Data.Stream.ToStreamK +benchmark FileSystem.DirIO import: bench-options type: exitcode-stdio-1.0 - hs-source-dirs: Streamly/Benchmark/Data/Stream - main-is: ToStreamK.hs - if !flag(dev) || impl(ghcjs) + hs-source-dirs: Streamly/Benchmark/FileSystem + main-is: DirIO.hs + if flag(use-streamly-core) buildable: False + else + buildable: True + -- Fix this benchmark for Windows + if os(windows) + buildable: False -benchmark Data.Stream.StreamK.Alt +benchmark Unicode.Char import: bench-options type: exitcode-stdio-1.0 - hs-source-dirs: Streamly/Benchmark/Data/Stream - main-is: StreamDK.hs - if !flag(dev) || impl(ghcjs) + hs-source-dirs: Streamly/Benchmark/Unicode + main-is: Char.hs + -- Takes too much memory for ghcjs + if flag(use-streamly-core) || impl(ghcjs) buildable: False +benchmark Unicode.Parser + import: bench-options + type: exitcode-stdio-1.0 + hs-source-dirs: Streamly/Benchmark/Unicode + main-is: Parser.hs + executable nano-bench import: bench-options hs-source-dirs: . @@ -473,8 +647,30 @@ if !flag(dev) buildable: False +benchmark Unicode.Stream + import: bench-options + type: exitcode-stdio-1.0 + hs-source-dirs: Streamly/Benchmark/Unicode + main-is: Stream.hs + if flag(limit-build-mem) + ghc-options: +RTS -M1000M -RTS + if flag(use-streamly-core) + buildable: False + else + buildable: True + +benchmark Unicode.Utf8 + import: bench-options + type: exitcode-stdio-1.0 + hs-source-dirs: Streamly/Benchmark/Unicode + main-is: Utf8.hs + if flag(use-streamly-core) + buildable: False + else + buildable: True + ------------------------------------------------------------------------------- --- Streamly.Prelude +-- Deprecated ------------------------------------------------------------------------------- benchmark Prelude @@ -490,7 +686,6 @@ Stream.Expand Stream.Lift Stream.Common - Stream.Split Stream.Exceptions cpp-options: -DUSE_PRELUDE if !flag(use-prelude) @@ -579,10 +774,6 @@ if flag(limit-build-mem) ghc-options: +RTS -M2000M -RTS -------------------------------------------------------------------------------- --- Concurrent Streams -------------------------------------------------------------------------------- - benchmark Prelude.Concurrent import: bench-options-threaded type: exitcode-stdio-1.0 @@ -609,135 +800,3 @@ cpp-options: -DUSE_PRELUDE if !flag(use-prelude) buildable: False - -------------------------------------------------------------------------------- --- Array Benchmarks -------------------------------------------------------------------------------- - -benchmark Data.Array.Generic - import: bench-options - type: exitcode-stdio-1.0 - hs-source-dirs: ., Streamly/Benchmark/Data - main-is: Streamly/Benchmark/Data/Array/Generic.hs - other-modules: - Stream.Common - if flag(use-streamly-core) - buildable: False - else - buildable: True - if flag(limit-build-mem) - ghc-options: +RTS -M1000M -RTS - -benchmark Data.SmallArray - import: bench-options - type: exitcode-stdio-1.0 - main-is: Streamly/Benchmark/Data/Array/SmallArray.hs - if flag(dev) && !flag(use-streamly-core) - buildable: True - else - buildable: False - -benchmark Data.Array - import: bench-options - type: exitcode-stdio-1.0 - hs-source-dirs: ., Streamly/Benchmark/Data - main-is: Streamly/Benchmark/Data/Array.hs - other-modules: - Stream.Common - if flag(use-streamly-core) - buildable: False - else - buildable: True - if flag(limit-build-mem) - ghc-options: +RTS -M1500M -RTS - -benchmark Data.Array.Mut - import: bench-options - type: exitcode-stdio-1.0 - main-is: Streamly/Benchmark/Data/Array/Mut.hs - if flag(limit-build-mem) - ghc-options: +RTS -M1500M -RTS - if flag(use-streamly-core) - buildable: False - else - buildable: True - -------------------------------------------------------------------------------- --- Ring Benchmarks -------------------------------------------------------------------------------- - -benchmark Data.Ring.Unboxed - import: bench-options - type: exitcode-stdio-1.0 - main-is: Streamly/Benchmark/Data/Ring/Unboxed.hs - if flag(limit-build-mem) - ghc-options: +RTS -M1500M -RTS - -------------------------------------------------------------------------------- --- Array Stream Benchmarks -------------------------------------------------------------------------------- - -benchmark Data.Array.Stream - import: bench-options - type: exitcode-stdio-1.0 - hs-source-dirs: Streamly/Benchmark/Data/Array - main-is: Stream.hs - if flag(use-streamly-core) || impl(ghcjs) - buildable: False - else - buildable: True - build-depends: exceptions >= 0.8 && < 0.11 - -------------------------------------------------------------------------------- --- FileIO Benchmarks -------------------------------------------------------------------------------- - -benchmark FileSystem.Handle - import: bench-options - type: exitcode-stdio-1.0 - hs-source-dirs: Streamly/Benchmark/FileSystem - main-is: Handle.hs - other-modules: - Handle.Read - , Handle.ReadWrite - if flag(limit-build-mem) - ghc-options: +RTS -M1000M -RTS - if flag(use-streamly-core) - buildable: False - else - buildable: True - -------------------------------------------------------------------------------- --- Unicode Benchmarks -------------------------------------------------------------------------------- - -benchmark Unicode.Stream - import: bench-options - type: exitcode-stdio-1.0 - hs-source-dirs: Streamly/Benchmark/Unicode - main-is: Stream.hs - if flag(limit-build-mem) - ghc-options: +RTS -M1000M -RTS - if flag(use-streamly-core) - buildable: False - else - buildable: True - -benchmark Unicode.Char - import: bench-options - type: exitcode-stdio-1.0 - hs-source-dirs: Streamly/Benchmark/Unicode - main-is: Char.hs - -- Takes too much memory for ghcjs - if flag(use-streamly-core) || impl(ghcjs) - buildable: False - -benchmark Unicode.Utf8 - import: bench-options - type: exitcode-stdio-1.0 - hs-source-dirs: Streamly/Benchmark/Unicode - main-is: Utf8.hs - if flag(use-streamly-core) - buildable: False - else - buildable: True diff --git a/configure b/configure --- a/configure +++ b/configure @@ -1,11 +1,11 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.71 for streamly 0.9.0. +# Generated by GNU Autoconf 2.72 for streamly 0.11.1. # # Report bugs to . # # -# Copyright (C) 1992-1996, 1998-2017, 2020-2021 Free Software Foundation, +# Copyright (C) 1992-1996, 1998-2017, 2020-2023 Free Software Foundation, # Inc. # # @@ -17,7 +17,6 @@ # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh -as_nop=: if test ${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1 then : emulate sh @@ -26,12 +25,13 @@ # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST -else $as_nop - case `(set -o) 2>/dev/null` in #( +else case e in #( + e) case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; +esac ;; esac fi @@ -103,7 +103,7 @@ ;; esac -# We did not find ourselves, most probably we were run as `sh COMMAND' +# We did not find ourselves, most probably we were run as 'sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 @@ -133,15 +133,14 @@ esac exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} # Admittedly, this is quite paranoid, since all the known shells bail -# out after a failed `exec'. +# out after a failed 'exec'. printf "%s\n" "$0: could not re-execute with $CONFIG_SHELL" >&2 exit 255 fi # We don't want this to propagate to other subprocesses. { _as_can_reexec=; unset _as_can_reexec;} if test "x$CONFIG_SHELL" = x; then - as_bourne_compatible="as_nop=: -if test \${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1 + as_bourne_compatible="if test \${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1 then : emulate sh NULLCMD=: @@ -149,12 +148,13 @@ # is contrary to our usage. Disable this feature. alias -g '\${1+\"\$@\"}'='\"\$@\"' setopt NO_GLOB_SUBST -else \$as_nop - case \`(set -o) 2>/dev/null\` in #( +else case e in #( + e) case \`(set -o) 2>/dev/null\` in #( *posix*) : set -o posix ;; #( *) : ;; +esac ;; esac fi " @@ -172,8 +172,9 @@ if ( set x; as_fn_ret_success y && test x = \"\$1\" ) then : -else \$as_nop - exitcode=1; echo positional parameters were not saved. +else case e in #( + e) exitcode=1; echo positional parameters were not saved. ;; +esac fi test x\$exitcode = x0 || exit 1 blah=\$(echo \$(echo blah)) @@ -186,14 +187,15 @@ if (eval "$as_required") 2>/dev/null then : as_have_required=yes -else $as_nop - as_have_required=no +else case e in #( + e) as_have_required=no ;; +esac fi if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null then : -else $as_nop - as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +else case e in #( + e) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR as_found=false for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH do @@ -226,12 +228,13 @@ if $as_found then : -else $as_nop - if { test -f "$SHELL" || test -f "$SHELL.exe"; } && +else case e in #( + e) if { test -f "$SHELL" || test -f "$SHELL.exe"; } && as_run=a "$SHELL" -c "$as_bourne_compatible""$as_required" 2>/dev/null then : CONFIG_SHELL=$SHELL as_have_required=yes -fi +fi ;; +esac fi @@ -253,7 +256,7 @@ esac exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} # Admittedly, this is quite paranoid, since all the known shells bail -# out after a failed `exec'. +# out after a failed 'exec'. printf "%s\n" "$0: could not re-execute with $CONFIG_SHELL" >&2 exit 255 fi @@ -273,7 +276,8 @@ $0: under such a shell if you do have one." fi exit 1 -fi +fi ;; +esac fi fi SHELL=${CONFIG_SHELL-/bin/sh} @@ -312,14 +316,6 @@ as_fn_set_status $1 exit $1 } # as_fn_exit -# as_fn_nop -# --------- -# Do nothing but, unlike ":", preserve the value of $?. -as_fn_nop () -{ - return $? -} -as_nop=as_fn_nop # as_fn_mkdir_p # ------------- @@ -388,11 +384,12 @@ { eval $1+=\$2 }' -else $as_nop - as_fn_append () +else case e in #( + e) as_fn_append () { eval $1=\$$1\$2 - } + } ;; +esac fi # as_fn_append # as_fn_arith ARG... @@ -406,21 +403,14 @@ { as_val=$(( $* )) }' -else $as_nop - as_fn_arith () +else case e in #( + e) as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` - } + } ;; +esac fi # as_fn_arith -# as_fn_nop -# --------- -# Do nothing but, unlike ":", preserve the value of $?. -as_fn_nop () -{ - return $? -} -as_nop=as_fn_nop # as_fn_error STATUS ERROR [LINENO LOG_FD] # ---------------------------------------- @@ -494,6 +484,8 @@ /[$]LINENO/= ' <$as_myself | sed ' + t clear + :clear s/[$]LINENO.*/&-/ t lineno b @@ -542,7 +534,6 @@ as_echo='printf %s\n' as_echo_n='printf %s' - rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file @@ -554,9 +545,9 @@ if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: - # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. - # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. - # In both cases, we have to default to `cp -pR'. + # 1) On MSYS, both 'ln -s file dir' and 'ln file dir' fail. + # 2) DJGPP < 2.04 has no symlinks; 'ln -s' creates a wrapper executable. + # In both cases, we have to default to 'cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then @@ -581,10 +572,12 @@ as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. -as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" +as_sed_cpp="y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g" +as_tr_cpp="eval sed '$as_sed_cpp'" # deprecated # Sed expression to map a string onto a valid variable name. -as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" +as_sed_sh="y%*+%pp%;s%[^_$as_cr_alnum]%_%g" +as_tr_sh="eval sed '$as_sed_sh'" # deprecated test -n "$DJDIR" || exec 7<&0 /dev/null && - as_fn_error $? "invalid feature name: \`$ac_useropt'" + as_fn_error $? "invalid feature name: '$ac_useropt'" ac_useropt_orig=$ac_useropt ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in @@ -810,7 +803,7 @@ ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && - as_fn_error $? "invalid feature name: \`$ac_useropt'" + as_fn_error $? "invalid feature name: '$ac_useropt'" ac_useropt_orig=$ac_useropt ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in @@ -1023,7 +1016,7 @@ ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && - as_fn_error $? "invalid package name: \`$ac_useropt'" + as_fn_error $? "invalid package name: '$ac_useropt'" ac_useropt_orig=$ac_useropt ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in @@ -1039,7 +1032,7 @@ ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && - as_fn_error $? "invalid package name: \`$ac_useropt'" + as_fn_error $? "invalid package name: '$ac_useropt'" ac_useropt_orig=$ac_useropt ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in @@ -1069,8 +1062,8 @@ | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) x_libraries=$ac_optarg ;; - -*) as_fn_error $? "unrecognized option: \`$ac_option' -Try \`$0 --help' for more information" + -*) as_fn_error $? "unrecognized option: '$ac_option' +Try '$0 --help' for more information" ;; *=*) @@ -1078,7 +1071,7 @@ # Reject names that are not valid shell variable names. case $ac_envvar in #( '' | [0-9]* | *[!_$as_cr_alnum]* ) - as_fn_error $? "invalid variable name: \`$ac_envvar'" ;; + as_fn_error $? "invalid variable name: '$ac_envvar'" ;; esac eval $ac_envvar=\$ac_optarg export $ac_envvar ;; @@ -1128,7 +1121,7 @@ as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" done -# There might be people who depend on the old broken behavior: `$host' +# There might be people who depend on the old broken behavior: '$host' # used to hold the argument of --host etc. # FIXME: To remove some day. build=$build_alias @@ -1196,7 +1189,7 @@ test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir" fi -ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" +ac_msg="sources are in $srcdir, but 'cd $srcdir' does not work" ac_abs_confdir=`( cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" pwd)` @@ -1224,7 +1217,7 @@ # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF -\`configure' configures streamly 0.9.0 to adapt to many kinds of systems. +'configure' configures streamly 0.11.1 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... @@ -1238,11 +1231,11 @@ --help=short display options specific to this package --help=recursive display the short help of all the included packages -V, --version display version information and exit - -q, --quiet, --silent do not print \`checking ...' messages + -q, --quiet, --silent do not print 'checking ...' messages --cache-file=FILE cache test results in FILE [disabled] - -C, --config-cache alias for \`--cache-file=config.cache' + -C, --config-cache alias for '--cache-file=config.cache' -n, --no-create do not create output files - --srcdir=DIR find the sources in DIR [configure dir or \`..'] + --srcdir=DIR find the sources in DIR [configure dir or '..'] Installation directories: --prefix=PREFIX install architecture-independent files in PREFIX @@ -1250,10 +1243,10 @@ --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX [PREFIX] -By default, \`make install' will install all the files in -\`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify -an installation prefix other than \`$ac_default_prefix' using \`--prefix', -for instance \`--prefix=\$HOME'. +By default, 'make install' will install all the files in +'$ac_default_prefix/bin', '$ac_default_prefix/lib' etc. You can specify +an installation prefix other than '$ac_default_prefix' using '--prefix', +for instance '--prefix=\$HOME'. For better control, use the options below. @@ -1286,7 +1279,7 @@ if test -n "$ac_init_help"; then case $ac_init_help in - short | recursive ) echo "Configuration of streamly 0.9.0:";; + short | recursive ) echo "Configuration of streamly 0.11.1:";; esac cat <<\_ACEOF @@ -1304,7 +1297,7 @@ CPPFLAGS (Objective) C/C++ preprocessor flags, e.g. -I if you have headers in a nonstandard directory -Use these variables to override the choices made by `configure' or to help +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 . @@ -1372,10 +1365,10 @@ test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF -streamly configure 0.9.0 -generated by GNU Autoconf 2.71 +streamly configure 0.11.1 +generated by GNU Autoconf 2.72 -Copyright (C) 2021 Free Software Foundation, Inc. +Copyright (C) 2023 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. _ACEOF @@ -1414,11 +1407,12 @@ } && test -s conftest.$ac_objext then : ac_retval=0 -else $as_nop - printf "%s\n" "$as_me: failed program was:" >&5 +else case e in #( + e) printf "%s\n" "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 - ac_retval=1 + ac_retval=1 ;; +esac fi eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval @@ -1438,8 +1432,8 @@ if eval test \${$3+y} then : printf %s "(cached) " >&6 -else $as_nop - as_decl_use=`echo $2|sed -e 's/(/((/' -e 's/)/) 0&/' -e 's/,/) 0& (/g'` +else case e in #( + e) as_decl_use=`echo $2|sed -e 's/(/((/' -e 's/)/) 0&/' -e 's/,/) 0& (/g'` eval ac_save_FLAGS=\$$6 as_fn_append $6 " $5" cat confdefs.h - <<_ACEOF >conftest.$ac_ext @@ -1463,12 +1457,14 @@ if ac_fn_c_try_compile "$LINENO" then : eval "$3=yes" -else $as_nop - eval "$3=no" +else case e in #( + e) eval "$3=no" ;; +esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext eval $6=\$ac_save_FLAGS - + ;; +esac fi eval ac_res=\$$3 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 @@ -1500,8 +1496,8 @@ This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. -It was created by streamly $as_me 0.9.0, which was -generated by GNU Autoconf 2.71. Invocation command line was +It was created by streamly $as_me 0.11.1, which was +generated by GNU Autoconf 2.72. Invocation command line was $ $0$ac_configure_args_raw @@ -1747,10 +1743,10 @@ printf "%s\n" "$as_me: loading site script $ac_site_file" >&6;} sed 's/^/| /' "$ac_site_file" >&5 . "$ac_site_file" \ - || { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} + || { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} as_fn_error $? "failed to load site script $ac_site_file -See \`config.log' for more details" "$LINENO" 5; } +See 'config.log' for more details" "$LINENO" 5; } fi done @@ -1786,9 +1782,7 @@ /* Most of the following tests are stolen from RCS 5.7 src/conf.sh. */ struct buf { int x; }; struct buf * (*rcsopen) (struct buf *, struct stat *, int); -static char *e (p, i) - char **p; - int i; +static char *e (char **p, int i) { return p[i]; } @@ -1802,6 +1796,21 @@ return s; } +/* C89 style stringification. */ +#define noexpand_stringify(a) #a +const char *stringified = noexpand_stringify(arbitrary+token=sequence); + +/* C89 style token pasting. Exercises some of the corner cases that + e.g. old MSVC gets wrong, but not very hard. */ +#define noexpand_concat(a,b) a##b +#define expand_concat(a,b) noexpand_concat(a,b) +extern int vA; +extern int vbee; +#define aye A +#define bee B +int *pvA = &expand_concat(v,aye); +int *pvbee = &noexpand_concat(v,bee); + /* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has function prototypes and stuff, but not \xHH hex character constants. These do not provoke an error unfortunately, instead are silently treated @@ -1829,16 +1838,19 @@ # Test code for whether the C compiler supports C99 (global declarations) ac_c_conftest_c99_globals=' -// Does the compiler advertise C99 conformance? +/* Does the compiler advertise C99 conformance? */ #if !defined __STDC_VERSION__ || __STDC_VERSION__ < 199901L # error "Compiler does not advertise C99 conformance" #endif +// See if C++-style comments work. + #include extern int puts (const char *); extern int printf (const char *, ...); extern int dprintf (int, const char *, ...); extern void *malloc (size_t); +extern void free (void *); // Check varargs macros. These examples are taken from C99 6.10.3.5. // dprintf is used instead of fprintf to avoid needing to declare @@ -1888,7 +1900,6 @@ static inline int test_restrict (ccp restrict text) { - // See if C++-style comments work. // Iterate through items via the restricted pointer. // Also check for declarations in for loops. for (unsigned int i = 0; *(text+i) != '\''\0'\''; ++i) @@ -1954,6 +1965,8 @@ ia->datasize = 10; for (int i = 0; i < ia->datasize; ++i) ia->data[i] = i * 1.234; + // Work around memory leak warnings. + free (ia); // Check named initializers. struct named_init ni = { @@ -1975,7 +1988,7 @@ # Test code for whether the C compiler supports C11 (global declarations) ac_c_conftest_c11_globals=' -// Does the compiler advertise C11 conformance? +/* Does the compiler advertise C11 conformance? */ #if !defined __STDC_VERSION__ || __STDC_VERSION__ < 201112L # error "Compiler does not advertise C11 conformance" #endif @@ -2089,12 +2102,12 @@ eval ac_new_val=\$ac_env_${ac_var}_value case $ac_old_set,$ac_new_set in set,) - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 -printf "%s\n" "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: '$ac_var' was set to '$ac_old_val' in the previous run" >&5 +printf "%s\n" "$as_me: error: '$ac_var' was set to '$ac_old_val' in the previous run" >&2;} ac_cache_corrupted=: ;; ,set) - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5 -printf "%s\n" "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: '$ac_var' was not set in the previous run" >&5 +printf "%s\n" "$as_me: error: '$ac_var' was not set in the previous run" >&2;} ac_cache_corrupted=: ;; ,);; *) @@ -2103,18 +2116,18 @@ ac_old_val_w=`echo x $ac_old_val` ac_new_val_w=`echo x $ac_new_val` if test "$ac_old_val_w" != "$ac_new_val_w"; then - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5 -printf "%s\n" "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: '$ac_var' has changed since the previous run:" >&5 +printf "%s\n" "$as_me: error: '$ac_var' has changed since the previous run:" >&2;} ac_cache_corrupted=: else - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 -printf "%s\n" "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in '$ac_var' since the previous run:" >&5 +printf "%s\n" "$as_me: warning: ignoring whitespace changes in '$ac_var' since the previous run:" >&2;} eval $ac_var=\$ac_old_val fi - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5 -printf "%s\n" "$as_me: former value: \`$ac_old_val'" >&2;} - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5 -printf "%s\n" "$as_me: current value: \`$ac_new_val'" >&2;} + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: former value: '$ac_old_val'" >&5 +printf "%s\n" "$as_me: former value: '$ac_old_val'" >&2;} + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: current value: '$ac_new_val'" >&5 +printf "%s\n" "$as_me: current value: '$ac_new_val'" >&2;} fi;; esac # Pass precious variables to config.status. @@ -2130,11 +2143,11 @@ fi done if $ac_cache_corrupted; then - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 printf "%s\n" "$as_me: error: changes in the environment can compromise the build" >&2;} - as_fn_error $? "run \`${MAKE-make} distclean' and/or \`rm $cache_file' + as_fn_error $? "run '${MAKE-make} distclean' and/or 'rm $cache_file' and start over" "$LINENO" 5 fi ## -------------------- ## @@ -2181,8 +2194,8 @@ if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 -else $as_nop - if test -n "$CC"; then +else case e in #( + e) if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -2204,7 +2217,8 @@ done IFS=$as_save_IFS -fi +fi ;; +esac fi CC=$ac_cv_prog_CC if test -n "$CC"; then @@ -2226,8 +2240,8 @@ if test ${ac_cv_prog_ac_ct_CC+y} then : printf %s "(cached) " >&6 -else $as_nop - if test -n "$ac_ct_CC"; then +else case e in #( + e) if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -2249,7 +2263,8 @@ done IFS=$as_save_IFS -fi +fi ;; +esac fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then @@ -2284,8 +2299,8 @@ if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 -else $as_nop - if test -n "$CC"; then +else case e in #( + e) if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -2307,7 +2322,8 @@ done IFS=$as_save_IFS -fi +fi ;; +esac fi CC=$ac_cv_prog_CC if test -n "$CC"; then @@ -2329,8 +2345,8 @@ if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 -else $as_nop - if test -n "$CC"; then +else case e in #( + e) if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else ac_prog_rejected=no @@ -2369,7 +2385,8 @@ ac_cv_prog_CC="$as_dir$ac_word${1+' '}$@" fi fi -fi +fi ;; +esac fi CC=$ac_cv_prog_CC if test -n "$CC"; then @@ -2393,8 +2410,8 @@ if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 -else $as_nop - if test -n "$CC"; then +else case e in #( + e) if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -2416,7 +2433,8 @@ done IFS=$as_save_IFS -fi +fi ;; +esac fi CC=$ac_cv_prog_CC if test -n "$CC"; then @@ -2442,8 +2460,8 @@ if test ${ac_cv_prog_ac_ct_CC+y} then : printf %s "(cached) " >&6 -else $as_nop - if test -n "$ac_ct_CC"; then +else case e in #( + e) if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -2465,7 +2483,8 @@ done IFS=$as_save_IFS -fi +fi ;; +esac fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then @@ -2503,8 +2522,8 @@ if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 -else $as_nop - if test -n "$CC"; then +else case e in #( + e) if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -2526,7 +2545,8 @@ done IFS=$as_save_IFS -fi +fi ;; +esac fi CC=$ac_cv_prog_CC if test -n "$CC"; then @@ -2548,8 +2568,8 @@ if test ${ac_cv_prog_ac_ct_CC+y} then : printf %s "(cached) " >&6 -else $as_nop - if test -n "$ac_ct_CC"; then +else case e in #( + e) if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -2571,7 +2591,8 @@ done IFS=$as_save_IFS -fi +fi ;; +esac fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then @@ -2600,10 +2621,10 @@ fi -test -z "$CC" && { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} +test -z "$CC" && { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} as_fn_error $? "no acceptable C compiler found in \$PATH -See \`config.log' for more details" "$LINENO" 5; } +See 'config.log' for more details" "$LINENO" 5; } # Provide some information about the compiler. printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for C compiler version" >&5 @@ -2675,8 +2696,8 @@ printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } then : - # Autoconf-2.13 could set the ac_cv_exeext variable to `no'. -# So ignore a value of `no', otherwise this would lead to `EXEEXT = no' + # Autoconf-2.13 could set the ac_cv_exeext variable to 'no'. +# So ignore a value of 'no', otherwise this would lead to 'EXEEXT = no' # in a Makefile. We should not override ac_cv_exeext if it was cached, # so that the user can short-circuit this test for compilers unknown to # Autoconf. @@ -2696,7 +2717,7 @@ ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` fi # We set ac_cv_exeext here because the later test for it is not - # safe: cross compilers may not add the suffix if given an `-o' + # safe: cross compilers may not add the suffix if given an '-o' # argument, so we may need to know it at that point already. # Even if this section looks crufty: it has the advantage of # actually working. @@ -2707,8 +2728,9 @@ done test "$ac_cv_exeext" = no && ac_cv_exeext= -else $as_nop - ac_file='' +else case e in #( + e) ac_file='' ;; +esac fi if test -z "$ac_file" then : @@ -2717,13 +2739,14 @@ printf "%s\n" "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -{ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} +{ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} as_fn_error 77 "C compiler cannot create executables -See \`config.log' for more details" "$LINENO" 5; } -else $as_nop - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 -printf "%s\n" "yes" >&6; } +See 'config.log' for more details" "$LINENO" 5; } +else case e in #( + e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } ;; +esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for C compiler default output file name" >&5 printf %s "checking for C compiler default output file name... " >&6; } @@ -2747,10 +2770,10 @@ printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } then : - # If both `conftest.exe' and `conftest' are `present' (well, observable) -# catch `conftest.exe'. For instance with Cygwin, `ls conftest' will -# work properly (i.e., refer to `conftest.exe'), while it won't with -# `rm'. + # If both 'conftest.exe' and 'conftest' are 'present' (well, observable) +# catch 'conftest.exe'. For instance with Cygwin, 'ls conftest' will +# work properly (i.e., refer to 'conftest.exe'), while it won't with +# 'rm'. for ac_file in conftest.exe conftest conftest.*; do test -f "$ac_file" || continue case $ac_file in @@ -2760,11 +2783,12 @@ * ) break;; esac done -else $as_nop - { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} +else case e in #( + e) { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} as_fn_error $? "cannot compute suffix of executables: cannot compile and link -See \`config.log' for more details" "$LINENO" 5; } +See 'config.log' for more details" "$LINENO" 5; } ;; +esac fi rm -f conftest conftest$ac_cv_exeext { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5 @@ -2780,6 +2804,8 @@ main (void) { FILE *f = fopen ("conftest.out", "w"); + if (!f) + return 1; return ferror (f) || fclose (f) != 0; ; @@ -2819,26 +2845,27 @@ if test "$cross_compiling" = maybe; then cross_compiling=yes else - { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} as_fn_error 77 "cannot run C compiled programs. -If you meant to cross compile, use \`--host'. -See \`config.log' for more details" "$LINENO" 5; } +If you meant to cross compile, use '--host'. +See 'config.log' for more details" "$LINENO" 5; } fi fi fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $cross_compiling" >&5 printf "%s\n" "$cross_compiling" >&6; } -rm -f conftest.$ac_ext conftest$ac_cv_exeext conftest.out +rm -f conftest.$ac_ext conftest$ac_cv_exeext \ + conftest.o conftest.obj conftest.out ac_clean_files=$ac_clean_files_save { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5 printf %s "checking for suffix of object files... " >&6; } if test ${ac_cv_objext+y} then : printf %s "(cached) " >&6 -else $as_nop - cat confdefs.h - <<_ACEOF >conftest.$ac_ext +else case e in #( + e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int @@ -2870,16 +2897,18 @@ break;; esac done -else $as_nop - printf "%s\n" "$as_me: failed program was:" >&5 +else case e in #( + e) printf "%s\n" "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -{ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} +{ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} as_fn_error $? "cannot compute suffix of object files: cannot compile -See \`config.log' for more details" "$LINENO" 5; } +See 'config.log' for more details" "$LINENO" 5; } ;; +esac fi -rm -f conftest.$ac_cv_objext conftest.$ac_ext +rm -f conftest.$ac_cv_objext conftest.$ac_ext ;; +esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_objext" >&5 printf "%s\n" "$ac_cv_objext" >&6; } @@ -2890,8 +2919,8 @@ if test ${ac_cv_c_compiler_gnu+y} then : printf %s "(cached) " >&6 -else $as_nop - cat confdefs.h - <<_ACEOF >conftest.$ac_ext +else case e in #( + e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int @@ -2908,12 +2937,14 @@ if ac_fn_c_try_compile "$LINENO" then : ac_compiler_gnu=yes -else $as_nop - ac_compiler_gnu=no +else case e in #( + e) ac_compiler_gnu=no ;; +esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ac_cv_c_compiler_gnu=$ac_compiler_gnu - + ;; +esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_compiler_gnu" >&5 printf "%s\n" "$ac_cv_c_compiler_gnu" >&6; } @@ -2931,8 +2962,8 @@ if test ${ac_cv_prog_cc_g+y} then : printf %s "(cached) " >&6 -else $as_nop - ac_save_c_werror_flag=$ac_c_werror_flag +else case e in #( + e) ac_save_c_werror_flag=$ac_c_werror_flag ac_c_werror_flag=yes ac_cv_prog_cc_g=no CFLAGS="-g" @@ -2950,8 +2981,8 @@ if ac_fn_c_try_compile "$LINENO" then : ac_cv_prog_cc_g=yes -else $as_nop - CFLAGS="" +else case e in #( + e) CFLAGS="" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ @@ -2966,8 +2997,8 @@ if ac_fn_c_try_compile "$LINENO" then : -else $as_nop - ac_c_werror_flag=$ac_save_c_werror_flag +else case e in #( + e) ac_c_werror_flag=$ac_save_c_werror_flag CFLAGS="-g" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ @@ -2984,12 +3015,15 @@ then : ac_cv_prog_cc_g=yes fi -rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; +esac fi -rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; +esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext - ac_c_werror_flag=$ac_save_c_werror_flag + ac_c_werror_flag=$ac_save_c_werror_flag ;; +esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_g" >&5 printf "%s\n" "$ac_cv_prog_cc_g" >&6; } @@ -3016,8 +3050,8 @@ if test ${ac_cv_prog_cc_c11+y} then : printf %s "(cached) " >&6 -else $as_nop - ac_cv_prog_cc_c11=no +else case e in #( + e) ac_cv_prog_cc_c11=no ac_save_CC=$CC cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ @@ -3034,25 +3068,28 @@ test "x$ac_cv_prog_cc_c11" != "xno" && break done rm -f conftest.$ac_ext -CC=$ac_save_CC +CC=$ac_save_CC ;; +esac fi if test "x$ac_cv_prog_cc_c11" = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 printf "%s\n" "unsupported" >&6; } -else $as_nop - if test "x$ac_cv_prog_cc_c11" = x +else case e in #( + e) if test "x$ac_cv_prog_cc_c11" = x then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 printf "%s\n" "none needed" >&6; } -else $as_nop - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c11" >&5 +else case e in #( + e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c11" >&5 printf "%s\n" "$ac_cv_prog_cc_c11" >&6; } - CC="$CC $ac_cv_prog_cc_c11" + CC="$CC $ac_cv_prog_cc_c11" ;; +esac fi ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c11 - ac_prog_cc_stdc=c11 + ac_prog_cc_stdc=c11 ;; +esac fi fi if test x$ac_prog_cc_stdc = xno @@ -3062,8 +3099,8 @@ if test ${ac_cv_prog_cc_c99+y} then : printf %s "(cached) " >&6 -else $as_nop - ac_cv_prog_cc_c99=no +else case e in #( + e) ac_cv_prog_cc_c99=no ac_save_CC=$CC cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ @@ -3080,25 +3117,28 @@ test "x$ac_cv_prog_cc_c99" != "xno" && break done rm -f conftest.$ac_ext -CC=$ac_save_CC +CC=$ac_save_CC ;; +esac fi if test "x$ac_cv_prog_cc_c99" = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 printf "%s\n" "unsupported" >&6; } -else $as_nop - if test "x$ac_cv_prog_cc_c99" = x +else case e in #( + e) if test "x$ac_cv_prog_cc_c99" = x then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 printf "%s\n" "none needed" >&6; } -else $as_nop - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c99" >&5 +else case e in #( + e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c99" >&5 printf "%s\n" "$ac_cv_prog_cc_c99" >&6; } - CC="$CC $ac_cv_prog_cc_c99" + CC="$CC $ac_cv_prog_cc_c99" ;; +esac fi ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c99 - ac_prog_cc_stdc=c99 + ac_prog_cc_stdc=c99 ;; +esac fi fi if test x$ac_prog_cc_stdc = xno @@ -3108,8 +3148,8 @@ if test ${ac_cv_prog_cc_c89+y} then : printf %s "(cached) " >&6 -else $as_nop - ac_cv_prog_cc_c89=no +else case e in #( + e) ac_cv_prog_cc_c89=no ac_save_CC=$CC cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ @@ -3126,25 +3166,28 @@ test "x$ac_cv_prog_cc_c89" != "xno" && break done rm -f conftest.$ac_ext -CC=$ac_save_CC +CC=$ac_save_CC ;; +esac fi if test "x$ac_cv_prog_cc_c89" = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 printf "%s\n" "unsupported" >&6; } -else $as_nop - if test "x$ac_cv_prog_cc_c89" = x +else case e in #( + e) if test "x$ac_cv_prog_cc_c89" = x then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 printf "%s\n" "none needed" >&6; } -else $as_nop - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5 +else case e in #( + e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5 printf "%s\n" "$ac_cv_prog_cc_c89" >&6; } - CC="$CC $ac_cv_prog_cc_c89" + CC="$CC $ac_cv_prog_cc_c89" ;; +esac fi ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c89 - ac_prog_cc_stdc=c89 + ac_prog_cc_stdc=c89 ;; +esac fi fi @@ -3160,8 +3203,8 @@ if test ${ac_cv_c_undeclared_builtin_options+y} then : printf %s "(cached) " >&6 -else $as_nop - ac_save_CFLAGS=$CFLAGS +else case e in #( + e) ac_save_CFLAGS=$CFLAGS ac_cv_c_undeclared_builtin_options='cannot detect' for ac_arg in '' -fno-builtin; do CFLAGS="$ac_save_CFLAGS $ac_arg" @@ -3180,8 +3223,8 @@ if ac_fn_c_try_compile "$LINENO" then : -else $as_nop - # This test program should compile successfully. +else case e in #( + e) # This test program should compile successfully. # No library function is consistently available on # freestanding implementations, so test against a dummy # declaration. Include always-available headers on the @@ -3209,26 +3252,29 @@ if test x"$ac_arg" = x then : ac_cv_c_undeclared_builtin_options='none needed' -else $as_nop - ac_cv_c_undeclared_builtin_options=$ac_arg +else case e in #( + e) ac_cv_c_undeclared_builtin_options=$ac_arg ;; +esac fi break fi -rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; +esac fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext done CFLAGS=$ac_save_CFLAGS - + ;; +esac fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_undeclared_builtin_options" >&5 printf "%s\n" "$ac_cv_c_undeclared_builtin_options" >&6; } case $ac_cv_c_undeclared_builtin_options in #( 'cannot detect') : - { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} as_fn_error $? "cannot make $CC report undeclared builtins -See \`config.log' for more details" "$LINENO" 5; } ;; #( +See 'config.log' for more details" "$LINENO" 5; } ;; #( 'none needed') : ac_c_undeclared_builtin_options='' ;; #( *) : @@ -3240,8 +3286,9 @@ if test "x$ac_cv_have_decl_IN_MASK_CREATE" = xyes then : ac_have_decl=1 -else $as_nop - ac_have_decl=0 +else case e in #( + e) ac_have_decl=0 ;; +esac fi printf "%s\n" "#define HAVE_DECL_IN_MASK_CREATE $ac_have_decl" >>confdefs.h @@ -3250,8 +3297,9 @@ if test "x$ac_cv_have_decl_IN_EXCL_UNLINK" = xyes then : ac_have_decl=1 -else $as_nop - ac_have_decl=0 +else case e in #( + e) ac_have_decl=0 ;; +esac fi printf "%s\n" "#define HAVE_DECL_IN_EXCL_UNLINK $ac_have_decl" >>confdefs.h @@ -3262,8 +3310,9 @@ if test "x$ac_cv_have_decl_kFSEventStreamCreateFlagFileEvents" = xyes then : ac_have_decl=1 -else $as_nop - ac_have_decl=0 +else case e in #( + e) ac_have_decl=0 ;; +esac fi printf "%s\n" "#define HAVE_DECL_KFSEVENTSTREAMCREATEFLAGFILEEVENTS $ac_have_decl" >>confdefs.h @@ -3272,8 +3321,9 @@ if test "x$ac_cv_have_decl_kFSEventStreamCreateFlagFullHistory" = xyes then : ac_have_decl=1 -else $as_nop - ac_have_decl=0 +else case e in #( + e) ac_have_decl=0 ;; +esac fi printf "%s\n" "#define HAVE_DECL_KFSEVENTSTREAMCREATEFLAGFULLHISTORY $ac_have_decl" >>confdefs.h @@ -3282,8 +3332,9 @@ if test "x$ac_cv_have_decl_kFSEventStreamEventFlagItemCloned" = xyes then : ac_have_decl=1 -else $as_nop - ac_have_decl=0 +else case e in #( + e) ac_have_decl=0 ;; +esac fi printf "%s\n" "#define HAVE_DECL_KFSEVENTSTREAMEVENTFLAGITEMCLONED $ac_have_decl" >>confdefs.h @@ -3292,8 +3343,9 @@ if test "x$ac_cv_have_decl_kFSEventStreamEventFlagItemIsHardlink" = xyes then : ac_have_decl=1 -else $as_nop - ac_have_decl=0 +else case e in #( + e) ac_have_decl=0 ;; +esac fi printf "%s\n" "#define HAVE_DECL_KFSEVENTSTREAMEVENTFLAGITEMISHARDLINK $ac_have_decl" >>confdefs.h @@ -3311,8 +3363,8 @@ # config.status only pays attention to the cache file if you give it # the --recheck option to rerun configure. # -# `ac_cv_env_foo' variables (set or unset) will be overridden when -# loading this file, other *unset* `ac_cv_foo' will be assigned the +# 'ac_cv_env_foo' variables (set or unset) will be overridden when +# loading this file, other *unset* 'ac_cv_foo' will be assigned the # following values. _ACEOF @@ -3342,14 +3394,14 @@ (set) 2>&1 | case $as_nl`(ac_space=' '; set) 2>&1` in #( *${as_nl}ac_space=\ *) - # `set' does not quote correctly, so add quotes: double-quote + # 'set' does not quote correctly, so add quotes: double-quote # substitution turns \\\\ into \\, and sed turns \\ into \. sed -n \ "s/'/'\\\\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" ;; #( *) - # `set' quotes correctly as required by POSIX, so do not add quotes. + # 'set' quotes correctly as required by POSIX, so do not add quotes. sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" ;; esac | @@ -3439,7 +3491,6 @@ # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh -as_nop=: if test ${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1 then : emulate sh @@ -3448,12 +3499,13 @@ # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST -else $as_nop - case `(set -o) 2>/dev/null` in #( +else case e in #( + e) case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; +esac ;; esac fi @@ -3525,7 +3577,7 @@ ;; esac -# We did not find ourselves, most probably we were run as `sh COMMAND' +# We did not find ourselves, most probably we were run as 'sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 @@ -3554,7 +3606,6 @@ } # as_fn_error - # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. @@ -3594,11 +3645,12 @@ { eval $1+=\$2 }' -else $as_nop - as_fn_append () +else case e in #( + e) as_fn_append () { eval $1=\$$1\$2 - } + } ;; +esac fi # as_fn_append # as_fn_arith ARG... @@ -3612,11 +3664,12 @@ { as_val=$(( $* )) }' -else $as_nop - as_fn_arith () +else case e in #( + e) as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` - } + } ;; +esac fi # as_fn_arith @@ -3699,9 +3752,9 @@ if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: - # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. - # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. - # In both cases, we have to default to `cp -pR'. + # 1) On MSYS, both 'ln -s file dir' and 'ln file dir' fail. + # 2) DJGPP < 2.04 has no symlinks; 'ln -s' creates a wrapper executable. + # In both cases, we have to default to 'cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then @@ -3782,10 +3835,12 @@ as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. -as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" +as_sed_cpp="y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g" +as_tr_cpp="eval sed '$as_sed_cpp'" # deprecated # Sed expression to map a string onto a valid variable name. -as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" +as_sed_sh="y%*+%pp%;s%[^_$as_cr_alnum]%_%g" +as_tr_sh="eval sed '$as_sed_sh'" # deprecated exec 6>&1 @@ -3800,8 +3855,8 @@ # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" -This file was extended by streamly $as_me 0.9.0, which was -generated by GNU Autoconf 2.71. Invocation command line was +This file was extended by streamly $as_me 0.11.1, which was +generated by GNU Autoconf 2.72. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS @@ -3828,7 +3883,7 @@ cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 ac_cs_usage="\ -\`$as_me' instantiates files and other configuration actions +'$as_me' instantiates files and other configuration actions from templates according to the current configuration. Unless the files and actions are specified as TAGs, all are instantiated by default. @@ -3856,11 +3911,11 @@ cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config='$ac_cs_config_escaped' ac_cs_version="\\ -streamly config.status 0.9.0 -configured by $0, generated by GNU Autoconf 2.71, +streamly config.status 0.11.1 +configured by $0, generated by GNU Autoconf 2.72, with options \\"\$ac_cs_config\\" -Copyright (C) 2021 Free Software Foundation, Inc. +Copyright (C) 2023 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." @@ -3911,8 +3966,8 @@ ac_need_defaults=false;; --he | --h) # Conflict between --help and --header - as_fn_error $? "ambiguous option: \`$1' -Try \`$0 --help' for more information.";; + as_fn_error $? "ambiguous option: '$1' +Try '$0 --help' for more information.";; --help | --hel | -h ) printf "%s\n" "$ac_cs_usage"; exit ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ @@ -3920,8 +3975,8 @@ ac_cs_silent=: ;; # This is an error. - -*) as_fn_error $? "unrecognized option: \`$1' -Try \`$0 --help' for more information." ;; + -*) as_fn_error $? "unrecognized option: '$1' +Try '$0 --help' for more information." ;; *) as_fn_append ac_config_targets " $1" ac_need_defaults=false ;; @@ -3971,7 +4026,7 @@ case $ac_config_target in "src/config.h") CONFIG_HEADERS="$CONFIG_HEADERS src/config.h" ;; - *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;; + *) as_fn_error $? "invalid argument: '$ac_config_target'" "$LINENO" 5;; esac done @@ -3989,7 +4044,7 @@ # creating and moving files from /tmp can sometimes cause problems. # Hook for its removal unless debugging. # Note that there is a small window in which the directory will not be cleaned: -# after its creation but before its name has been assigned to `$tmp'. +# after its creation but before its name has been assigned to '$tmp'. $debug || { tmp= ac_tmp= @@ -4013,13 +4068,13 @@ # Set up the scripts for CONFIG_HEADERS section. # No need to generate them if there are no CONFIG_HEADERS. -# This happens for instance with `./config.status Makefile'. +# This happens for instance with './config.status Makefile'. if test -n "$CONFIG_HEADERS"; then cat >"$ac_tmp/defines.awk" <<\_ACAWK || BEGIN { _ACEOF -# Transform confdefs.h into an awk script `defines.awk', embedded as +# Transform confdefs.h into an awk script 'defines.awk', embedded as # here-document in config.status, that substitutes the proper values into # config.h.in to produce config.h. @@ -4129,7 +4184,7 @@ esac case $ac_mode$ac_tag in :[FHL]*:*);; - :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;; + :L* | :C*:*) as_fn_error $? "invalid tag '$ac_tag'" "$LINENO" 5;; :[FH]-) ac_tag=-:-;; :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; esac @@ -4151,19 +4206,19 @@ -) ac_f="$ac_tmp/stdin";; *) # Look for the file first in the build tree, then in the source tree # (if the path is not absolute). The absolute path cannot be DOS-style, - # because $ac_f cannot contain `:'. + # because $ac_f cannot contain ':'. test -f "$ac_f" || case $ac_f in [\\/$]*) false;; *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; esac || - as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;; + as_fn_error 1 "cannot find input file: '$ac_f'" "$LINENO" 5;; esac case $ac_f in *\'*) ac_f=`printf "%s\n" "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac as_fn_append ac_file_inputs " '$ac_f'" done - # Let's still pretend it is `configure' which instantiates (i.e., don't + # Let's still pretend it is 'configure' which instantiates (i.e., don't # use $as_me), people would be surprised to read: # /* config.h. Generated by config.status. */ configure_input='Generated from '` diff --git a/configure.ac b/configure.ac --- a/configure.ac +++ b/configure.ac @@ -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.9.0], [streamly@composewell.com], [streamly], [https://streamly.composewell.com]) +AC_INIT([streamly], [0.11.1], [streamly@composewell.com], [streamly], [https://streamly.composewell.com]) # To suppress "WARNING: unrecognized options: --with-compiler" AC_ARG_WITH([compiler], [GHC]) diff --git a/docs/Developer/MAINTAINING.md b/docs/Developer/MAINTAINING.md --- a/docs/Developer/MAINTAINING.md +++ b/docs/Developer/MAINTAINING.md @@ -158,14 +158,11 @@ * Run packcheck on the uploaded package. To get the latest uploaded version from hackage, run `cabal unpack `. You might have to run `cabal update`. - * Create a git tag corresponding to the release where X.Y.Z is the new - package version (`git tag vX.Y.Z && git push -f origin vX.Y.Z`). + * Create a git tag of the form P-X.Y.Z corresponding to the release + where X.Y.Z is the new package version and P is the package name (`git + tag P-X.Y.Z && git push -f origin P-X.Y.Z`). If the package name is + implicit, P can be omitted and the tag can be of the form vX.Y.Z * Add to stackage (`build-constraints.yaml` in Stackage repo) if needed - * Optionally upload `package-X.Y.Z-sdist.tar.gz` to github release page - * `gh release create vX.Y.Z --title "vX.Y.Z"` - * `gh release upload vX.Y.Z package-X.Y.Z-sdist.tar.gz` - * Update release contributors on github release page - (`git shortlog -s prev_tag..new_tag | sed $'s/^[0-9 \t]*/* /' | sort -f`) * Update and if needed release streaming-benchmarks package * Check https://matrix.hackage.haskell.org/package/streamly * Check haddocks on Hackage, upload if not built @@ -178,7 +175,7 @@ package.yaml to the next major release target. * Bump the package version in configure.ac to the next major release target and run autoreconf. - * Sync the package version of `streamly` and `streamly-docs`. + * Sync the package version of `streamly`. * Add an `Unreleased` section at the top of changelog file with the next major release target. diff --git a/docs/Developer/container-api.md b/docs/Developer/container-api.md --- a/docs/Developer/container-api.md +++ b/docs/Developer/container-api.md @@ -16,9 +16,14 @@ ## Unfolds and Folds -* Unfolds are named as "read" or with a "read" prefix (e.g. readChunks). +* Unfolds are named as "reader" or with a "reader" suffix (e.g. chunkReader). +* Refolds are named as "writer" or with a "writer" suffix. +* Streams are names as "read" or with a "read" prefix. * Folds are named as "write" or with a "write" prefix (e.g. writeChunks). +Streams and fold API names are in line with the file system calls for reading +writing. + ## To and from Stream ### From and Put @@ -59,6 +64,9 @@ ## Random Access (Arrays) ### Single elements + +Especially for mutable arrays, the names "get" and "put" make better +sense as effectful APIs. * getIndex (for arrays) * putIndex (for mutable arrays) diff --git a/docs/Developer/linked-lists.md b/docs/Developer/linked-lists.md deleted file mode 100644 --- a/docs/Developer/linked-lists.md +++ /dev/null @@ -1,32 +0,0 @@ -# Linked Lists - -The immutable Haskell lists or streams are great for stream processing. -However, they may not be suitable for purposes where we need to store data for -a longer while. In such cases we need mutable linked lists in pinned memory for -high performance applications i.e. we need the C like linked lists. Here are -some cases where linked-lists may be warranted instead of immutable lists: - -* Let's say we want to buffer incoming data in a list. The buffered data may be - millions of elements. When we are buffering we may allocate cells from - different areas of the GC heap. When there are other activities going on we - may have to keep copying this buffered data during GCs. When we consume this - buffer, again it creates a fragmented heap and we may have to copy some other - long-lived data to defragment the heap. The point is that we should not have - long-lived data in the GC heap. - -* When we delete a node in the list, Haskell lists have to be recreated - generating a lot of garbage. We cannot take a reference to the unmodified - segments and reuse them in the new list. On the other hand with mutable - linked-lists we can delete a node cheaply. This could be a common case in a - hash table collision chain which requires deletion of elements. - -* Similar to deletion, if we need to insert an element in the middle of the - list, an immutable list has to be re-created. - -* To implement a queue, two lists in the immutable model can be used - efficiently if we are strictly adding at the end and deleting from the front - and if there is sufficient batching so that swapping of the lists is not a - common operation. If we have to insert elements in the middle or if we have - to swap too many times again we will have the same GC issues as stated above. - For example, in implementations of priority search queues or timer wheels we - have to mutate the lists. diff --git a/docs/Developer/module-organization.md b/docs/Developer/module-organization.md --- a/docs/Developer/module-organization.md +++ b/docs/Developer/module-organization.md @@ -4,11 +4,17 @@ We keep all modules exposed to facilitate convenient exposure of experimental APIs and constructors to users. It allows users of the library to experiment -much more easily and carry a caveat that these APIs can change in future +much more easily but carry a caveat that these APIs can change in future without notice. Since everything is exposed, maintainers do not have to think about what to expose as experimental and what remains completely hidden every time something is added to the library. +However, some modules are created purely for the purpose of breaking a module +into multiple smaller modules, or for organizing similar functionality in a +separate file, such modules are exported as entire module from a higher level +modules. These modules can remain hidden as they are fully exported via another +module. + ## Internal module Namespace We expose the internal modules via `Streamly.Internal.*` namespace to keep all @@ -21,7 +27,7 @@ * Keep the implementation of all the APIs in an internal module and just reexport selected APIs through the external module. The disadvantages of this -are: +approach are: 1) users may not be able to easily figure out what unexposed APIs are available other than the ones exposed through the external module. To avoid this problem @@ -29,12 +35,13 @@ 2) In tests and benchmarks we will be using internal modules to test internal and unexposed APIs. Since exposed APIs are exported via both internal and - external modules we will have to be careful in not using the internal module - for testing accidentally, instead we should always be using the exposed module - so that we are always testing exactly the way users will be using the APIs. + external modules we will have to be careful in not accidentally using + the internal module for testing, instead we should always be using the + exposed module so that we are always testing exactly the way users + will be using the APIs. -* Keep the implementations of unexposed modules in the internal module file -and exposed module in the external module file. In this approach, users can +* Keep the implementations of unexposed APIs in the internal module file +and exposed APIs in the external module file. In this approach, users can easily figure out the unexposed vs exposed APIs. But maintaining this would require us to move the APIs from internal to external module file whenever we expose an API. @@ -71,25 +78,26 @@ ## Constrained Modules -Some modules represent operations on a type which constrain a type using a type +Some modules represent operations on a type which constrain the type using a type class or a specific instance of a general type. For example, we may have Arrays -that operate on a `Storable` or a `Prim` type. +that operate on an `Unbox` type. -One possible way to organize such module is to have a `Storable` or `Prim` +One possible way to organize such modules is to have an `Unbox` hierarchy and all data structures using that type constraint are bundled under it. However, in general, a data structure may have multiple such constraints or may have to be organized based on some other dimension like an abstract interface it is implementing. -General purpose constraints like `Prim` can be defined in their own module +General purpose constraints like `Unbox` can be defined in their own module hierarchy and can be used everywhere. For example, we can have the following -Array types, here we have organized the types under the `Array` hierarchy -rather than putting the `PrimArray` under a `Prim` hierarchy. +Array types, here we have organized all array types under the `Array` hierarchy +rather than having e.g. `Unbox.Array` for unboxed arrays. ``` -Streamly.Internal.Data.Array.Boxed -Streamly.Internal.Data.Array.Prim -Streamly.Internal.Data.Array.Prim.Pinned +Streamly.Internal.Data.Array -- Unboxed arrays +Streamly.Internal.Data.Array.Generic -- Boxed arrays +Streamly.Internal.Data.MutArray -- Unboxed mutable arrays +Streamly.Internal.Data.MutArray.Generic -- Boxed mutable arrays ``` ## Common Modules @@ -171,71 +179,36 @@ ## Stream modules -By default the streaming modules are effectful. The basic effectful -stream types are: +Effectful streams are fused or CPS types: * `Streamly.Data.Stream` -* `Streamly.Data.Stream.Async` -* `Streamly.Data.Stream.Ahead` -* `Streamly.Data.Stream.Parallel` -* `Streamly.Data.Stream.IsStream` -- polymorphic operations -* `Streamly.Data.Stream.Using` -- e.g. mapMUsing consMAsync - -The above streams have an append-like multi-stream combining behavior -i.e. `concatMap` and `bind` would by default evaluate the streams one -after another. Alternative implementations of `concatMap` and `bind` are -possible. We can either use rebindable syntax to use a different bind or -define newtypes with a different bind behavior, all other operations for -these remain the same as the base type: - -* `Streamly.Data.Stream.Zip` -* `Streamly.Data.Stream.Interleaved` -* `Streamly.Data.Stream.RoundRobin` -* `Streamly.Data.Stream.Async.Zip` -* `Streamly.Data.Stream.Async.Interleaved` -* `Streamly.Data.Stream.Async.RoundRobin` -* ... +* `Streamly.Data.StreamK` +* `Streamly.Data.Stream.Prelude` Pure streams are a special case of effectful streams and have the same interface as lists, so we put them under `Streamly.Data.List`: * `Streamly.Data.List` -* `Streamly.Data.List.Zip` -* `Streamly.Data.List.Interleaved` -* `Streamly.Data.List.RoundRobin` -* ... - -We could possibly use the same type named `Stream` for all stream -types, as the names of all stream operation are also the same and we -distinguish only by the module name. +* `Streamly.Data.ListK` ## Array modules Similarly, the immutable Array modules would go in: -* `Streamly.Data.Array.Generic` -- unpinned, native memory arrays -* `Streamly.Data.Array.Storable` -- unpinned, unboxed, native memory arrays -* `Streamly.Data.Array.Storable.Pinned` -- pinned, unboxed, native memory arrays -* `Streamly.Data.Array.Foreign` -- pinned, unboxed, foreign capable arrays - -Unboxed arrays, based on `Prim` type class: - -* `Streamly.Data.Array.Prim` -* `Streamly.Data.Array.Prim.Pinned` +* Streamly.Data.Array -- Unboxed arrays +* Streamly.Data.Array.Generic -- Boxed arrays Mutable arrays are a generalization of immutable arrays: -* `Streamly.Data.Array.Mut` -* `Streamly.Data.Array.Storable.Mut` -* `Streamly.Data.Array.Storable.Pinned.Mut` -* ... +* Streamly.Data.MutArray -- Unboxed mutable arrays +* Streamly.Data.MutArray.Generic -- Boxed mutable arrays ## Stream and Fold Channels (SVar) * `Streamly.Data.Stream.Channel` -* `Streamly.Data.Stream.Channel.Storable` +* `Streamly.Data.Stream.Channel.Unboxed` * `Streamly.Data.Fold.Channel` -* `Streamly.Data.Fold.Channel.Storable` +* `Streamly.Data.Fold.Channel.Unboxed` ## Mutable variables diff --git a/docs/Developer/optimization-guidelines.md b/docs/Developer/optimization-guidelines.md --- a/docs/Developer/optimization-guidelines.md +++ b/docs/Developer/optimization-guidelines.md @@ -25,7 +25,7 @@ before you optimize: * See if you actually need more performance -* See if the code you are optimizing is in fast path +* See if the code you are optimizing is in fast path of your application ### Stream Fusion @@ -54,7 +54,7 @@ * Use unfolds especially when higher order operations are involved. For example, `unfoldMany` can fuse completely whereas `concatMap` would not fuse. -* Use `outerProduct` in `Unfold` module instead of using the monad instance of +* Use `outerProduct` from the `Unfold` module instead of using the monad instance of streams to fuse nested loops where performance matters. See the unfold benchmarks for an example. `outerProduct` can give you C like nested loop performance. @@ -85,7 +85,7 @@ ### Streams and Unfolds -Stream and Unfold State. Direct style stream and unfold combinators use a +Stream and Unfold State: Direct style stream and unfold combinators use a state data type to represent the internal state of the stream/unfold generator. * In some cases we may have to add a `FUSE` annotation on the state type to @@ -191,6 +191,18 @@ itself, in fact we may have to occasionally use a `NOINLINE` so that the compiler does not inline it. +We need to be careful about NOINLINE on polymorphic functions. When +NOINLINE is used, the function cannot be specialized causing huge +performance degradation. To avoid that we can either make the +function monomorphic or sometimes using `NOINLINE [0]` can do the +trick. `NOINLINE [0]` blocks inlining in earlier phases but lets it +specialize in the last phase, inlining in the last phase is left to +the compiler. `INLINE [0]` may sound the same as `NOINLINE [0]`, +however, it behaves differently because we ask the compiler to INLINE +it compulsorily and it may not give us the desired results. The +Data.Fold.createOfLast benchmark is one such case where `NOINLINE [0]` +provides much better performance than `INLINE [0]`. + ### NoSpecConstr It is not always useful to specialize function calls for all constructors, some @@ -200,19 +212,34 @@ ### StreamK operations -StreamK uses foldr/build fusion to a very limited degree. StreamK is not the -primary representation in streamly but is used for several operations that -cannot scale in StreamD representation. StreamK is relatively immune to compiler -optimizations. In some cases you may need an INLINE pragma to improve the -performance. +StreamK (CPS based stream type) uses foldr/build fusion to a very +limited degree. StreamK is not the primary representation in streamly +but is used for several operations that cannot scale in fused `Stream` +type representation. StreamK is relatively immune to compiler +optimizations. In some cases you may need an INLINE pragma on the +StreamK operation to improve its performance. +## Debugging Fusion Issues + +### How to find non-fusing code? + +The fusion-plugin reports operations that do not fuse. It has many verbosity +options to give even more information about the constructors that are not +fusing. Read the readme of the fusion-plugin package for more details. + +When the code is not fusing you will see a lot more (e.g. 10x) allocations +compared to the case when it is fusing. + + + ### How to debug non-fusing code? Strip down the code to a minimal version until it starts fusing and then start building it up from there adding more things incrementally. At each stage keep checking if the code is fusing. At some point it won't fuse. See what we added that made the code not fuse. Go through -the guidelines above to check if we did something that that is not +the guidelines above to check if we did something that is not recommended. Or raise an issue for GHC to be fixed if possible. # GHC Optimizations In Streamly @@ -244,7 +271,7 @@ The combinators in `Streamly.Prelude` are defined in terms of combinators in `Streamly.Internal.Data.Stream.StreamD` (Direct style streams) or -`Streamly.Internal.Data.Stream.StreamK` (CPS style streams). We convert the +`Streamly.Internal.Data.StreamK` (CPS style streams). We convert the stream from `StreamD` to `StreamK` representation or vice versa in some cases. Most operations use the StreamD representation, however, stream append @@ -317,18 +344,22 @@ as `INLINE` or `INLINE_EARLY`, instead they should all be marked as `INLINE_NORMAL` because higher order functions like `concatMap`/`map`/`mapM` etc are marked as `INLINE_NORMAL`. `StreamD` functions in other modules like -`Streamly.Data.Array.Foreign` should also follow the same rules. +`Streamly.Data.Array` should also follow the same rules. +Use INLINE_NORMAL on functions like `pipe`, `Pipe.compose`, `Pipe.teeMerge` for +complete fusion in a pipeline of multiple such operations e.g. in the `pipesX4` +benchmarks. + ## Stream Fusion -In StreamD combinators, inlining the inner step or loop functions too early +In fused `Stream` type combinators, inlining the inner step or loop functions too early i.e. in the same phase or before the outer function is inlined may block stream fusion opportunities. Therefore, the inner step functions and folding loops are marked as INLINE_LATE. ## Specialization -In some cases, the `step` function in `StreamD` does not get specialized when +In some cases, the `step` function in `Stream` does not get specialized when inlined unless it is provided with an explicit signature or made a lambda, for example, in the `replicate/replicateM` combinator we need the type annotation on `i` to get it specialized: @@ -356,3 +387,51 @@ these code blocks which in turn can affect stream fusion. See https://gitlab.haskell.org/ghc/ghc/issues/17075 . + +## Avoiding polymorphism + +Polymorphism can add unwanted inefficiencies, so avoid where possible. For +example, more efficient code: + +``` +asPtrUnsafe :: MonadIO m => MutArray a -> (Ptr a -> IO b) -> m b +``` + +Less efficient version, because of a wroker-wrapper indirection (see +https://github.com/composewell/streamly/issues/2589): + +``` +asPtrUnsafe :: MonadIO m => MutArray a -> (Ptr a -> m b) -> m b +``` + +Using explicit type annotation +------------------------------ + +Having polymorphic types may hinder specialization and hurt performance. See +the specialization section in design/inlining.md in streamly docs + +In some cases, the `step` function in `Stream` does not get specialized when +inlined unless it is provided with an explicit signature or made a lambda, for +example, in the `replicate/replicateM` combinator we need the type annotation +on `i` to get it specialized: + +``` + {-# INLINE_LATE step #-} + step _ (i :: Int) = + if i <= 0 + then return Stop + else do + x <- action + return $ Yield x (i - 1) +``` + +In this case if the compiler does not infer the type of i automatically then we +will be forced to provide the type and get it specialized. + +Strict State in Streams +----------------------- + +Depending on the context, sometimes using strict data structures for +stream state can provide better performance. In case the state does not +fuse, making it strict will avoid performance problems due to state +being lazy. diff --git a/docs/Developer/paths.rst b/docs/Developer/paths.rst --- a/docs/Developer/paths.rst +++ b/docs/Developer/paths.rst @@ -140,12 +140,35 @@ it differently, the user may use the displayed result to find the file and may not find it. +OS Specific Path Encodings +-------------------------- + +In general, the OS does not have to look inside the path components +other than the ability to recognize the separator char to parse the +path into components and to construct it from components. However, in +some cases the OS may may have to look inside the path e.g. "." or ".." +special paths on Unix. + +On Unix a path component is just a blob of bytes. The user can encode +and decode this blob of bytes as they desire. All they need to care +about is that the path separator byte is respected. However, the the +path component blobs may be changed by the underlying filesystem +e.g. apple HFS may normalize the path before storing, therefore, the +representation may change when it is returned back to the user. + +On modern Windows systems a path component is UTF16-LE +encoded. Theoretically, from the OS perspective, it does not have to +look inside the path components other than determining whether a 16-bit +unit represents the separator character, therefore, users can use any +encoding as long as it encodes to 16-bit multiples and the separator is +preserved as equivalent to the UTF16-LE representation. + Type Safety Requirements ------------------------ * Safety against using an absolute path where a relative path is to be - used and vice-versa. - + used and vice-versa. + * Validations for absolute or relative path when constructing a path. * We cannot append an absolute path to another path * Safety against using a file name where a directory name is to be used and @@ -228,3 +251,13 @@ * https://unix.stackexchange.com/questions/2089/what-charset-encoding-is-used-for-filenames-and-paths-on-linux * https://docs.microsoft.com/en-us/windows/win32/intl/character-sets-used-in-file-names * https://beets.io/blog/paths.html + +Related Packages +---------------- + +* https://hackage.haskell.org/package/paths +* https://hackage.haskell.org/package/path +* https://hackage.haskell.org/package/hpath +* https://hackage.haskell.org/package/filepath +* https://hackage.haskell.org/package/file-io +* https://hackage.haskell.org/package/os-string diff --git a/docs/Developer/resources.md b/docs/Developer/resources.md --- a/docs/Developer/resources.md +++ b/docs/Developer/resources.md @@ -30,6 +30,7 @@ * [Stackless purescript](http://blog.functorial.com/posts/2015-07-31-Stackless-PureScript.html) * [Coroutine Pipelines](https://themonadreader.files.wordpress.com/2011/10/issue19.pdf) * [Faster Coroutine Pipelines](https://dl.acm.org/ft_gateway.cfm?id=3110249&ftid=1902054&dwn=1&CFID=982135108&CFTOKEN=78426775) +* [Faster Coroutine Pipelines: A Reconstruction](https://rubenpieters.github.io/assets/papers/JFP20-pipes.pdf) ## Distributed * [Making reliable distributed systems in the presence of software errors](http://erlang.org/download/armstrong_thesis_2003.pdf) diff --git a/docs/Documentation.md b/docs/Documentation.md new file mode 100644 --- /dev/null +++ b/docs/Documentation.md @@ -0,0 +1,5 @@ +# Documentation + +Browse the documentation tree by clicking on the links on the left. Please +write to us at [streamly@composewell.com](mailto:streamly@composewell.com) if +you see something incorrect. diff --git a/docs/Setup.hs b/docs/Setup.hs deleted file mode 100644 --- a/docs/Setup.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Main (main) where - -import Distribution.Simple - -main :: IO () -main = defaultMain diff --git a/docs/User/Explanatory/Overview.md b/docs/User/Explanatory/Overview.md deleted file mode 100644 --- a/docs/User/Explanatory/Overview.md +++ /dev/null @@ -1,468 +0,0 @@ -# Streaming - -These are some notes from an old version of README that may be -useful. For a quick introduction please read the README.md at the repo -root first. - -## Streamly - -Streamly is a general computing framework based on data flow programming also -known as streaming. Moreover streamly supports concurrent dataflow programming. - -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, concurrency rate is automatically -controlled based on the demand by the consumer. However, combinators can be -used to fine tune the concurrency control. - -Streaming and concurrency together enable expressing reactive applications -conveniently. See the @CirclingSquare@ example in - for -a simple SDL based FRP example. To summarize, streamly provides a unified -computing framework for streaming, non-determinism and functional reactive -programming in an elegant and simple API that is a natural extension of pure -lists to monadic streams. - -## What are streams? - -In simple terms, streams are the functional equivalent of loops in -imperative programming. - -A stream is a representation of potentially infinite data sequence. You -can compose a pipeline of functions or stream processors to process -an input stream of data to produce an output stream. We call it a -form of dataflow programming as data flows through the processing -logic. In imperative programming there is no clear separation of data -and logic. The logic can arbitrarily examine and mutate data which -creates a problem due to complex interleaving of state and logic in the -program. - -In streamly there are two fundamental data structures, streams and arrays. -Streams are for dataflow style processing while arrays are for storing data. -Both taken together are powerful tools for general purpose programming in a -functional or dataflow style. - -## Loops vs Streams - -In imperative programming when we have to process a sequence of items -or an array of data we run a loop over it, each iteration of the loop -examines the data to do something with it and produce an output. - -Loops are a low level, monolithic and general concept. Whereas streams -are high level, structured and modular way of expressing what you usualy -do with loops. Streams allow you to write different parts of the loop -as separate modular combinators and then compose them to create bigger -loops. - -## Streaming Concurrently - -Haskell lists express pure computations using composable stream operations like -`:`, `unfold`, `map`, `filter`, `zip` and `fold`. Streamly is exactly like -lists except that it can express sequences of pure as well as monadic -computations aka streams. More importantly, it can express monadic sequences -with concurrent execution semantics without introducing any additional APIs. - -Streamly expresses concurrency using standard, well known abstractions. -Concurrency semantics are defined for list operations, semigroup, applicative -and monadic compositions. Programmer does not need to know any low level -notions of concurrency like threads, locking or synchronization. Concurrent -and non-concurrent programs are fundamentally the same. A chosen segment of -the program can be made concurrent by annotating it with an appropriate -combinator. We can choose a combinator for lookahead style or asynchronous -concurrency. Concurrency is automatically scaled up or down based on the -demand from the consumer application, we can finally say goodbye to managing -thread pools and associated sizing issues. The result is truly fearless -and declarative monadic concurrency. - -## Where to use streamly? - -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 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/User/HowTo/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 -paradigm itself then try to answer this question - why do we use lists in -Haskell? It boils down to why we use functional programming in the first place. -Haskell is successful in enforcing the functional data flow paradigm for pure -computations using lists, but not for monadic computations. In the absence of a -standard and easy to use data flow programming paradigm for monadic -computations, and the IO monad providing an escape hatch to an imperative -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? - -## Streaming Pipelines - -The following snippet provides a simple stream composition example that reads -numbers from stdin, prints the squares of even numbers and exits if an even -number more than 9 is entered. - -``` haskell -import qualified Streamly.Prelude as S -import Data.Function ((&)) - -main = S.drain $ - S.repeatM getLine - & fmap read - & S.filter even - & S.takeWhile (<= 9) - & fmap (\x -> x * x) - & S.mapM print -``` - -Unlike `pipes` or `conduit` and like `vector` and `streaming`, `streamly` -composes stream data instead of stream processors (functions). A stream is -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. - -## Concurrent Stream Generation - -`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. `fromAsync`, `fromAhead` or `fromParallel`). - -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 $ S.fromAsync $ p 3 |: p 2 |: p 1 |: S.nil -[1,2,3] -``` - -Use `fromAhead` 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 $ S.fromAhead $ p 3 |: p 2 |: p 1 |: S.nil -[3,2,1] -``` - -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 -S.drain $ S.fromAsync $ S.replicateM 10 $ p 10 -``` - -## Concurrent Streaming Pipelines - -Use `|&` or `|$` to apply stream processing functions concurrently. The -following example prints a "hello" every second; if you use `&` instead of -`|&` you will see that the delay doubles to 2 seconds instead because of serial -application. - -``` haskell -main = S.drain $ - S.repeatM (threadDelay 1000000 >> return "hello") - |& S.mapM (\x -> threadDelay 1000000 >> putStrLn x) -``` - -## Mapping Concurrently - -We can use `mapM` or `sequence` functions concurrently on a stream. - -``` haskell -> let p n = threadDelay (n * 1000000) >> return n -> S.drain $ S.fromAhead $ S.mapM (\x -> p 1 >> print x) (S.fromSerial $ S.repeatM (p 1)) -``` - -## Serial and Concurrent Merging - -Semigroup and Monoid instances can be used to fold streams serially or -concurrently. In the following example we compose ten actions in the -stream, each with a delay of 1 to 10 seconds, respectively. Since all the -actions are concurrent we see one output printed every second: - -``` haskell -import qualified Streamly.Prelude as S -import Control.Concurrent (threadDelay) - -main = S.toList $ S.fromParallel $ foldMap delay [1..10] - where delay n = S.fromEffect $ threadDelay (n * 1000000) >> print n -``` - -Streams can be combined together in many ways. We provide some examples -below, see the tutorial for more ways. We use the following `delay` -function in the examples to demonstrate the concurrency aspects: - -``` haskell -import qualified Streamly.Prelude as S -import Control.Concurrent - -delay n = S.fromEffect $ do - threadDelay (n * 1000000) - tid <- myThreadId - putStrLn (show tid ++ ": Delay " ++ show n) -``` -### Serial - -``` haskell -main = S.drain $ delay 3 <> delay 2 <> delay 1 -``` -``` -ThreadId 36: Delay 3 -ThreadId 36: Delay 2 -ThreadId 36: Delay 1 -``` - -### Parallel - -``` haskell -main = S.drain . S.fromParallel $ delay 3 <> delay 2 <> delay 1 -``` -``` -ThreadId 42: Delay 1 -ThreadId 41: Delay 2 -ThreadId 40: Delay 3 -``` - -## Nested Loops (aka List Transformer) - -The monad instance composes like a list monad. - -``` haskell -import qualified Streamly.Prelude as S - -loops = do - x <- S.fromFoldable [1,2] - y <- S.fromFoldable [3,4] - S.fromEffect $ putStrLn $ show (x, y) - -main = S.drain loops -``` -``` -(1,3) -(1,4) -(2,3) -(2,4) -``` - -## Concurrent Nested Loops - -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 = S.drain $ S.fromAhead $ loops -``` - -Different stream types execute the loop iterations in different ways. For -example, `fromWSerial` 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 - -Streams can perform semigroup (<>) and monadic bind (>>=) operations -concurrently using combinators like `fromAsync`, `parallelly`. For example, -to concurrently generate squares of a stream of numbers and then concurrently -sum the square roots of all combinations of two streams: - -``` haskell -import qualified Streamly.Prelude as S - -main = do - s <- S.sum $ S.fromAsync $ do - -- Each square is performed concurrently, (<>) is concurrent - x2 <- foldMap (\x -> return $ x * x) [1..100] - y2 <- foldMap (\y -> return $ y * y) [1..100] - -- Each addition is performed concurrently, monadic bind is concurrent - return $ sqrt (x2 + y2) - print s -``` - -## Rate Limiting - -For bounded concurrent streams, stream yield rate can be specified. For -example, to print hello once every second you can simply write this: - -``` haskell -import Streamly.Prelude as S - -main = S.drain $ S.fromAsync $ S.avgRate 1 $ S.repeatM $ putStrLn "hello" -``` - -For some practical uses of rate control, see -[AcidRain.hs](https://github.com/composewell/streamly-examples/tree/master/examples/AcidRain.hs) -and -[CirclingSquare.hs](https://github.com/composewell/streamly-examples/tree/master/examples/CirclingSquare.hs) -. -Concurrency of the stream is automatically controlled to match the specified -rate. Rate control works precisely even at throughputs as high as millions of -yields per second. For more sophisticated rate control see the haddock -documentation. - -## Arrays - -The `Streamly.Data.Array.Foreign` 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.Data.Array.Foreign` 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 -[CoreUtilsHandle.hs](https://github.com/composewell/streamly-examples/blob/master/examples/CoreUtilsHandle.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.Data.Array.Foreign 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 -``` - -## Exceptions - -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! diff --git a/docs/User/Explanatory/performance-benchmarks.md b/docs/User/Explanatory/performance-benchmarks.md new file mode 100644 --- /dev/null +++ b/docs/User/Explanatory/performance-benchmarks.md @@ -0,0 +1,7 @@ +# Performance + +Streamly is highly optimized for performance, it is designed for +high performing, concurrent and scalable applications. Please see the +[streaming-benchmarks](https://github.com/composewell/streaming-benchmarks) +package for microbencmarks measuring the performance of streamly and comparing +it with other streaming libraries. diff --git a/docs/User/Explanatory/performance.md b/docs/User/Explanatory/performance.md deleted file mode 100644 --- a/docs/User/Explanatory/performance.md +++ /dev/null @@ -1,7 +0,0 @@ -# Performance - -Streamly is highly optimized for performance, it is designed for -high performing, concurrent and scalable applications. Please see the -[streaming-benchmarks](https://github.com/composewell/streaming-benchmarks) -package for microbencmarks measuring the performance of streamly and comparing -it with other streaming libraries. diff --git a/docs/User/Explanatory/streams.md b/docs/User/Explanatory/streams.md new file mode 100644 --- /dev/null +++ b/docs/User/Explanatory/streams.md @@ -0,0 +1,88 @@ +# Stream Fusion + +The fused 'Stream' type employs stream fusion for C-like performance when +looping over data. It represents the stream as a state machine using an +explicit state, and a step function working on the state. A typical stream +operation consumes elements from the previous state machine in a stream +pipeline, transforms the elements and yields new values for the next stage to +consume. One stream operation typically represents one stage of a modular +pipeline, representing a single task, stages in the pipeline have no knowledge +of the state of the previous or next stage. + +A typical stream pipeline consists of a stream producer, several stream +transformation operations and a stream consumer. All these operations taken +together form a closed loop (like a for or while loop) processing the stream +elements. Elements are transferred between stages using a boxed data +constructor. However, all the stages of the pipeline are "fused" together by +GHC, eliminating the boxing of intermediate constructors, and thus forming a +tight C like loop without any boxed data being used in the loop. + +Stream fusion works effectively when: + +* the stream pipeline is composed statically (known at compile time) +* all the operations forming the loop are inlined +* the loop is not recursively defined, recursion breaks inlining + +If these conditions cannot be met, the CPS style stream type 'StreamK' may +turn out to be a better choice than the fused stream type 'Stream'. + +## Stream vs StreamK + +The fused stream model avoids constructor allocations and function call +overheads. However, the stream is represented as a state machine, and to +generate stream elements it has to navigate the decision tree of the state +machine. Moreover, the state machine is cranked for each element in the stream. +This performs extremely well when the number of states are limited. The state +machine starts getting expensive as the number of states increase. For example, +generating a stream from a list requires a single state and is very efficient, +even if it has millions of elements, there is only one state machine. However, +using 'cons' to construct a million element stream would be a disaster because +it is statically fusing a million state machines. + +A typical worst case scenario for fused stream model is a large number of +`cons` or `append` operations. A few static `cons` or `append` operations +are very fast, much faster than a CPS style stream because CPS involves a +function call for each element whereas fused stream involves a few +conditional branches in the state machine. However, constructing a large +stream using `cons` introduces as many states in the state machine as the +number of elements. If we compose `cons` as a balanced binary tree it will +take @n * log n@ time to navigate the tree, and @n * n@ if it is a right +associative composition. + +Operations like 'cons' or 'append' are typically recursively called to +construct a lazy infinite stream. For such use cases the CPS style 'StreamK' +should be used. CPS streams do not use an explicit state machine that needs to be +cranked for each element, past state has no effect on the future element +processing. However, CPS incurs a function call overhead for each element +processed, the overhead could be large compared to a fused state machine +even if it has many states. However, because of its linear performance +characteristics, after a certain threshold of stream compositions the CPS +stream would perform much better than the quadratic fused stream operations. + +As a general guideline, you need to use 'StreamK' when you have to use +'cons', 'append' or other operations having quadratic complexity at a large +scale. Typically, in such cases you need to compose the stream recursively, +by calling an operation in a loop. The decision to compose the stream is +taken at run time rather than statically at compile time. + +Typically you would compose a 'StreamK' of chunks of data so that the StreamK +function call overhead is mitigated, and then process each chunk using 'Stream' +type operations by using statically fused stream pipeline operations on the +chunks. + +'Stream' and 'StreamK' types can be interconverted. See +"Streamly.Data.StreamK" module for conversion operations. + +## Fold Fusion + +Folds support stream fusion for generating loops comparable to the speed of +C. However, it has some limitations. For fusion to work, the folds must be +inlined, folds must be statically known and not generated dynamically, folds +should not be passed recursively. + +Another limitation is due to the quadratic complexity causing slowdown when +too many nested compositions are used. Especially, the performance of the +Applicative instance and splitting operations (e.g. 'splitWith') degrades +quadratically (O(n^2)) when combined @n@ times, roughly 8 or less sequenced +operations are fine. For these cases folds can be converted to parsers and +then used as ParserK. diff --git a/docs/User/Explanatory/unified-abstractions.md b/docs/User/Explanatory/unified-abstractions.md --- a/docs/User/Explanatory/unified-abstractions.md +++ b/docs/User/Explanatory/unified-abstractions.md @@ -8,7 +8,7 @@ This document discusses the related packages in the Haskell ecosystem and how streamly unifies, overlaps, or compares with those. We provide simple code snippets for illustrations, for a better overview of the -library please see the [Streamly Quick Overview](/docs/User/Tutorials/quick-overview.md) document. +library please see the [Streamly Quick Overview](/docs/User/Tutorials/learn-by-examples.md) document. ## Existing Haskell Libraries @@ -79,11 +79,15 @@ This simple console echo program shows the simplicity of Streamly API and its similarity with the list API: -```haskell +```haskell unshared +import Data.Function ((&)) +import qualified Streamly.Data.Stream as Stream +import qualified Streamly.Data.Fold as Fold + echo = Stream.repeatM getLine & Stream.mapM putStrLn - & Stream.drain + & Stream.fold Fold.drain ``` Streamly uses dual representation for streams. On top it uses Scott @@ -105,20 +109,35 @@ programming. List transformers are the basic implementations for non-determinism. -The stream monad in Streamly is a list-transformer with behavior similar -to the list monad. It provides the functionality provided by `list-t` or -`logict` packages for free. Here is an example of nested looping using -the serial stream monad: +You can use `Streamly.Data.Stream.MkType` to create a custom type and specify +the behaviour of non-determinism. The basic `concatMap` would result in a +list-transformer with behavior similar to the list monad. It provides the +functionality provided by `list-t` or `logict` packages for free. Here is an +example of nested looping using the new type: ```haskell -import qualified Streamly.Prelude as S +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} -loops = do - x <- Stream.fromFoldable [1,2] - y <- Stream.fromFoldable [3,4] - Stream.fromEffect $ print (x, y) +import Streamly.Data.Stream.Prelude (Stream, MonadAsync) +import qualified Streamly.Data.Stream.Prelude as Stream +import qualified Streamly.Data.StreamK as StreamK +import Streamly.Data.Stream.MkType + +bindSerial :: Monad m => Stream m a -> (a -> Stream m b) -> Stream m b +bindSerial = flip Stream.concatMap +$(mkCrossType "CrossT" "bindSerial" False) + +loopsCross :: Stream IO () +loopsCross = unCrossT $ do + x <- CrossT $ Stream.fromList [1,2] + y <- CrossT $ Stream.fromList [3,4] + CrossT $ Stream.fromEffect $ print (x, y) ``` +`Streamly.Data.Stream.CrossStream` and `Streamly.Data.StreamK.CrossStreamK` +provide the same functionality as `CrossT` type created above. + Moreover, the list transformer in Streamly can be concurrent. The Scott encoding of streams also avoids the quadratic performance issue of `logict`. @@ -142,12 +161,18 @@ The monad instance provides a convenient way to combine streams in different ways. It is just non-determinism with different flavors of -scheduling behavior. The example from the previous section can be run -with interleaved scheduling behavior as follows, without changing the -code at all: +scheduling behavior. The scheduling behavior can be controlled as follows. ```haskell -main = Stream.drain $ Stream.fromWserial loops +bindWSerialK = StreamK.bfsConcatFor +bindWSerial a f = StreamK.toStream $ bindWSerialK (StreamK.fromStream a) (StreamK.fromStream . f) +$(mkCrossType "WSerialT" "bindWSerial" True) + +loopsWSerial :: Stream IO () +loopsWSerial = unWSerialT $ do + x <- WSerialT $ Stream.fromList [1,2] + y <- WSerialT $ Stream.fromList [3,4] + WSerialT $ Stream.fromEffect $ print (x, y) ``` Scheduling is fundamental to expressing many common programming problems @@ -159,6 +184,9 @@ The same combinators that are used for serial streams e.g. 'unfoldrM', 'replicateM', 'repeatM' work concurrently when used at the appropriate type. + +There are several concurrent combinators in streamly which are prefixed with +`par`. These combinators fit into the default composition very cleanly. It allows concurrent programs to be written declaratively and composed idiomatically. They are not much different than serial programs. See [Streamly vs async](/docs/User/HowTo/streamly-vs-async.md) @@ -168,18 +196,33 @@ [OpenMP](https://en.wikipedia.org/wiki/OpenMP) and [Cilk](https://en.wikipedia.org/wiki/Cilk) but with a more declarative style. The list transformer example can be run with concurrent -execution of loop iterations as follows, without changing the code at -all: +execution of loop iterations as follows: ```haskell -main = Stream.drain $ Stream.fromAhead loops +bindAhead :: MonadAsync m => Stream m a -> (a -> Stream m b) -> Stream m b +bindAhead = flip (Stream.parConcatMap (Stream.ordered True)) +$(mkCrossType "AheadT" "bindAhead" True) + +loopsAhead :: Stream IO () +loopsAhead = unAheadT $ do + x <- AheadT $ Stream.fromList [1,2] + y <- AheadT $ Stream.fromList [3,4] + AheadT $ Stream.fromEffect $ print (x, y) ``` And interleaving with concurrent execution of the loop iterations can be written like this: ```haskell -main = Stream.drain $ Stream.fromWAsync loops +bindWAsync :: MonadAsync m => Stream m a -> (a -> Stream m b) -> Stream m b +bindWAsync = flip (Stream.parConcatMap (Stream.interleaved True)) +$(mkCrossType "WAsyncT" "bindWAsync" True) + +loopsWAsync :: Stream IO () +loopsWAsync = unWAsyncT $ do + x <- WAsyncT $ Stream.fromList [1,2] + y <- WAsyncT $ Stream.fromList [3,4] + WAsyncT $ Stream.fromEffect $ print (x, y) ``` All this comes with no change in the streaming APIs. diff --git a/docs/User/HowTo/Compiling.md b/docs/User/HowTo/Compiling.md --- a/docs/User/HowTo/Compiling.md +++ b/docs/User/HowTo/Compiling.md @@ -4,9 +4,16 @@ ### Compiler (GHC) Versions -Do not use ghc 9.0.x and 9.2.1. For best performance use -`fusion-plugin` (see below) when compiling. +1. Do not use ghc 8.2 or earlier because in those versions it is not + safe to pass heap allocated objects to unsafe FFI calls. We depend on this + for array implementation. +2. Do not use ghc 9.0.x and 9.2.1 becuse of performance issues. GHC 9.6.x may + have a small memory leak issue in some concurrent stream cases, + see below for more details. ghc 9.10 shows significant performance + degradations, should not be used until it is fixed. +For best performance, use `fusion-plugin` (see below) when compiling. + ### Memory requirements Building streamly itself may require upto 4GB memory. Depending on the @@ -63,7 +70,8 @@ * `-fdicts-strict` is needed to avoid [a GHC issue](https://gitlab.haskell.org/ghc/ghc/issues/17745) leading to -memory leak in some cases. +memory leak in some cases. In GHC 9.6.x this issue cannot be avoided +even with `-fdicts-strict` option. * `-fspec-constr-recursive` is needed for better stream fusion, it allows the `SpecConstr` optimization to occur in more cases. Large @@ -108,25 +116,36 @@ error: ld: framework not found Cocoa ``` -### Native build +#### cabal build Usually, if you have a working GHC you would already have the SDK installed. See the documentation of `Xcode` or `xcode-select` tool for more details. -### Nix build +#### Nix build Please note that `cabal2nix` may not always be able to generate a complete nix expression on `macOS`. See [this issue](https://github.com/NixOS/cabal2nix/issues/470). -You may need to add ``nixpkgs.darwin.apple_sdk.frameworks.Cocoa`` to -your ``buildInputs`` or ``executableFrameworkDepends``. Something like -this: +You may need to add ``nixpkgs.darwin.apple_sdk.frameworks.Cocoa`` +to ``librarySystemDepends``. For example, to create a streamly-0.9.0 +derivation from Hackage: ``` -executableFrameworkDepends = - if builtins.currentSystem == "x86_64-darwin" - then [nixpkgs.darwin.apple_sdk.frameworks.Cocoa] - else []; + streamly = + nixpkgs.haskell.lib.overrideCabal + ( + super.callHackageDirect + { pkg = "streamly"; + ver = "0.9.0"; + sha256 = "sha256-eOxVb8qQjZDo1+S7CStqYSExOg2QHWkMY+zlOYqwZak="; + } {} + ) + (old: + { librarySystemDepends = + if nixpkgs.lib.strings.hasInfix "darwin" builtins.currentSystem + then [nixpkgs.darwin.apple_sdk.frameworks.Cocoa] + else []; + }); ``` diff --git a/docs/User/HowTo/Examples.link b/docs/User/HowTo/Examples.link deleted file mode 100644 --- a/docs/User/HowTo/Examples.link +++ /dev/null @@ -1,1 +0,0 @@ -https://github.com/composewell/streamly-examples diff --git a/docs/User/HowTo/faq.md b/docs/User/HowTo/faq.md --- a/docs/User/HowTo/faq.md +++ b/docs/User/HowTo/faq.md @@ -1,8 +1,8 @@ # Frequently Asked Questions This document provides idioms or examples to solve common programming -problems using streamly. To start with please go through [Streamly Quick -Overview](/docs/User/Tutorials/quick-overview.md) and [`Streamly examples repository`][streamly-examples]. +problems using streamly. To start with please go through the [Learn By +Examples](/docs/User/Tutorials/learn-by-examples.md) page and [`Examples Package`](https://github.com/composewell/streamly-examples). This document provides additional examples. ## Distribute and Zip Concurrently @@ -13,41 +13,45 @@ Distributing a value to a stream of consumers concurrently: -```haskell ghci -{-# LANGUAGE FlexibleContexts #-} - -import Data.Function ((&)) -import qualified Streamly.Data.Fold as Fold -import qualified Streamly.Data.Stream.Prelude as Stream +```haskell docspec +>>> :set -XFlexibleContexts +>>> import Data.Function ((&)) +>>> import qualified Streamly.Data.Fold as Fold +>>> import qualified Streamly.Data.Stream.Prelude as Stream +>>> :{ f1 x = Stream.fromList [return . (+ 1), return . (+ 2)] -- Stream of functions & fmap ($ x) -- Stream of lazy actions & Stream.parSequence (Stream.ordered True) -- Evaluate concurrently & Stream.fold Fold.toList -- Fold to list +:} ``` -Use `parApply` to zip streams concurrently. Here, we zip three singleton +Use `parZipWith` to zip streams concurrently. Here, we zip three singleton streams: -```haskell ghci - +```haskell docspec +>>> :{ f2 x = - let app = Stream.parApply id + let app = Stream.parZipWith id ($) in (,,) `fmap` Stream.fromEffect (return $ show x) `app` Stream.fromEffect (return $ x + 1) `app` Stream.fromEffect (return $ fromIntegral x / 2) & Stream.fold Fold.one +:} ``` Applying a function concurrently to your input stream: -```haskell ghci +```haskell docspec +>>> :{ g f xs = Stream.fromList xs & Stream.parMapM (Stream.ordered True) f & Stream.fold Fold.toList +:} ``` You can now use the concurrent map to pipe each element through multiple @@ -61,31 +65,34 @@ [Just ("1",2,0.5),Just ("2",3,1.0),Just ("3",4,1.5),Just ("4",5,2.0)] ``` -Instead of using `parApply` directly, you can use `mkZipType` to +Instead of using `parZipWith` directly, you can use `mkZipType` to create a zip Applicative newtype so that you can use the `Applicative` instance. ```haskell -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} -import Streamly.Internal.Data.Stream.TypeGen +import Control.Monad.Trans.Control (MonadBaseControl) +import Streamly.Data.Stream.Prelude (MonadAsync, Stream) +import qualified Streamly.Data.Stream.Prelude as Stream +import Streamly.Data.Stream.MkType -app = parApply id -$(mkZippingType "ZipConcurrent" "app" True) +app :: MonadAsync m => Stream m (a -> b) -> Stream m a -> Stream m b +app = Stream.parZipWith id ($) +$(mkZipType "ZipConcurrent" "app" True) ``` ## Sliding Window -The `writeLastN` fold can be used to create a stream of sliding windows. +The `createOfLast` fold can be used to create a stream of sliding windows. ```haskell docspec +>>> :set -Wno-deprecations >>> import qualified Streamly.Data.Array as Array >>> :{ Stream.fromList [1,2,3,4,5::Int] -& Stream.scan (Array.writeLastN 2) +& Stream.scan (Array.createOfLast 2) & Stream.fold Fold.toList :} [fromList [],fromList [1],fromList [1,2],fromList [2,3],fromList [3,4],fromList [4,5]] diff --git a/docs/User/HowTo/optimizing.md b/docs/User/HowTo/optimizing.md --- a/docs/User/HowTo/optimizing.md +++ b/docs/User/HowTo/optimizing.md @@ -1,7 +1,23 @@ -# Optimization Guide +# Haskell Streamly Optimization Guide -## Performance Optimizations +See also the streamly developer's optimization guide. +## When to Optimize? + +Focus on performance only where it truly matters. Avoid optimizing +everything blindly—concentrate on the *fast path* or the parts of the +code that run most frequently. Optimizing rarely executed code offers +little benefit and can introduce unnecessary complexity. Prioritize the +hot spots where performance gains will have the greatest impact. + +It’s important to be deliberate and informed about what to +optimize. Many developers fall into the trap of over-optimizing +unimportant code, while overlooking bottlenecks that actually impact +performance. Strive to profile first, understand the real costs, and +then optimize where it makes a measurable difference. + +## Loop Optimizations: Stream Fusion + A "closed loop" is any streamly code that generates a stream using unfold (or conceptually any stream generation combinator) and ends up eliminating it with a fold (conceptually any stream elimination @@ -9,35 +25,52 @@ a stream sequence, just like a `for` or `while` loop in imperative programming. -Closed loops are generated in a modular fashion by stream generation, +Closed loops are synthesized in a modular fashion by stream generation, transformation and elimination combinators in streamly. Combinators transfer data to the next stream pipeline stage using data constructors. These data constructors are eliminated by the compiler using `stream -fusion` optimizations, generating a very efficient loop. +fusion` optimizations, generating a very efficient loop. Streamly is designed +to utilize the stream fusion opitmization to the fullest such that the loops +are highly optimized providing similar performance as hand written C. -However, stream fusion optimization depends on proper inlining of the -combinators involved. The fusion-plugin package mentioned earlier -fills gaps for several optimizations that GHC does not perform -automatically. It automatically inlines the internal definitions +### Fusion Plugin + +Stream fusion optimization depends on proper inlining of the combinators +involved. To take full advantage of stream fusion in streamly you should +compile your code with the `fusion-plugin` enabled. The fusion-plugin +package fills the gaps for several optimizations that GHC does not +perform automatically. It automatically inlines the internal definitions that involve the constructors we want to eliminate. In some cases fusion-plugin may not help and programmer may have to annotate the code -manually for complete fusion. In this section we mention some of the -cases where programmer annotation may help in stream fusion. +manually for complete fusion. -Remember, you need to worry about performance only where it matters, try -to optimize the fast path and not everything blindly. +In the following sections we mention some of the cases where programmer +annotation may help in stream fusion. -### INLINE annotations +### INLINE Annotations -It may help to add INLINE annotations on any intermediate functions -involved in a closed loop. In some cases you may have to add an inline -phase as well as described below. +It can be helpful to add `INLINE` annotations to intermediate functions +involved in a closed loop. In some cases, you may also need to specify +an `INLINE` phase, as discussed in the following sections. -Usually GHC has three inline phases - the first phase is pahse-2, the -second phase is phase-1 and the last one is phase-0. +As a rule of thumb, any function that takes `Stream`, `Fold`, or +`Unfold` types as arguments — or returns these types — should be +inlined. -#### Early INLINE +GHC typically uses three inline phases: +- **Phase 2** (the earliest), +- **Phase 1**, and +- **Phase 0** (the latest). + +Inlining can be controlled with phase-specific annotations like: +``` haskell +{-# INLINE [1] functionName #-} +``` +to guide when inlining occurs during compilation. + +### Early INLINE + Generally, you only have to inline the combinators or functions participating in a loop and not the whole loop itself. But sometimes you may want to inline the whole loop itself inside a larger @@ -53,7 +86,7 @@ not very common but may be needed sometimes. Perhaps GHC can be fixed or we can resolve this using fusion-plugin in future. -#### Delayed INLINE +### Delayed INLINE When a function is passed to a higher order function e.g. a function passed to `concatMap` or `unfoldMany` then we want the function to be @@ -61,23 +94,468 @@ higher order function can occur. For such cases we usually add INLINE[1] on the function being passed to instruct GHC not to inline it too early. -### Strictness annotations +## Chunked Processing (Inner and Outer Loops) +Processing data in larger chunks can significantly reduce loop overhead +by minimizing the number of iterations. Chunked processing enables the +inner loop to run more efficiently through stream fusion—reducing +heap allocations, improving cache locality, minimizing branching, and +enhancing opportunities for vectorization. + +In libraries like *streamly*, this can be achieved by streaming arrays +and applying a fused operation to each array—either using built-in +combinators or writing custom logic per chunk. Whether the **outer +loop** is fused or not is usually less important, so you can choose +either the fused `Stream` type or the more flexible CPS-based `StreamK` +type. + +However, for the **inner loop**, fusion is more critical, especially +when it runs frequently. To achieve this, you should prefer using +`Unfold` or fused `Stream` operations for chunk processing. Likewise, on +the consumer side, it's recommended to use the fused `Fold` or `Parser` +types to maintain performance. + +This chunking strategy is especially effective in performance-critical +applications, such as numerical computing or high-throughput data +processing. + +## When Fusion Matters + +In stream processing, **fusion is most important in inner loops**—the +parts of your program that run most frequently. Outer loops, which are +executed less often, can afford to use non-fused combinators without +significant performance penalties. + +Some operations in Streamly explicitly break fusion. These are clearly +annotated in the documentation. It's best to place such fusion-breaking +operations in the outer loop to keep the fast path—the inner +loop—fully fused and efficient. + +That said, breaking fusion doesn't always have a noticeable performance +impact. The cost is primarily proportional to the number of loop +iterations. For example: + +- A stream of 1,000 items, each 1KB in size, will likely show negligible +impact from a fusion break. +- A stream of 1 million items, each just 1 byte, will suffer +significantly—even though the total data volume is the same—because +the loop runs far more times. + +This overhead arises from copying intermediate structures when fusion is +broken. The more iterations, the greater the cumulative cost. + +In imperative programming, it's easier to see this: the loop body +is explicit, and the number of iterations is obvious. In stream +abstractions, however, the loop is hidden, making it harder to notice +when fusion matters. + +Think of a fused stream as a **superhighway** for data processing. A +fusion break is like a **toll booth** or **junction** where each item +pays a small tax. Whether that toll matters depends on how much load you are +carrying per trip. + +To give you a rough idea: let's assume the overhead of breaking fusion is +around **30–50 nanoseconds per item**. If you're processing something +like a database row and the processing takes a few microseconds per +item, this overhead is negligible—less than 0.05% of the total +cost. But if you're doing lightweight processing—say, ~100ns per +item—the toll becomes significant. + +In general: **Optimize the core processing first. Once that’s +efficient, look at fusion.** + +## Breaking fusion: Monad binds + +If fusion matters it is always good to have function having a type `... +-> Stream m a` instead of `... -> m (Stream m a)`. The first one is a +stream that can fuse with other streams, whereas the second is a monadic +action that returns a stream, the monadic action needs to be flattened +e.g. using `concatEffect` to generate a stream. Also, note that since +fusion breaks anyway inlining a function returning a `m (Stream m a)` +may not matter as much from fusion perspective. + +The simple rule is that you do not break a stream pipeline to perform +an action and return the stream from the monad. If you do that then you +are deliberately breaking a fused pipeline. You need to compose all the +stream functions without cutting the pipeline by sandwiching a monadic +effect. Stream has an underlying monad and you should use available +stream combinators to perform any action in that monad and not outside +of the stream. + +## Breaking Fusion: Monad Binds + +When fusion performance matters, it's generally better to use functions +of type `... -> Stream m a` rather than `... -> m (Stream m a)`. + +The former creates a stream directly, allowing it to fuse seamlessly +with other stream operations. The latter wraps the stream in a monadic +action, requiring an additional step—such as `concatEffect`—to +flatten it into a stream, which breaks fusion. + +Guiding Principle: +Avoid interrupting a fused stream pipeline with monadic effects that +return new streams. Doing so effectively breaks the pipeline, making it +harder for the compiler to optimize and fuse subsequent operations. + +Instead, try to express all effects within the stream itself. Streamly +provides combinators that work inside the stream’s underlying monad, +allowing you to stay within the fused pipeline. Use those to perform +effects without stepping outside the streaming abstraction. + +## `concatMap` vs `unfoldEach` + +As mentioned in the previous section, `concatEffect` belongs to the +class of `concatMap`-style operations. These operations do **not** +fuse, because they generate streams *dynamically* at runtime. Since the +structure of the resulting stream isn't statically known, the compiler +cannot apply fusion optimizations effectively. + +To achieve full fusion in nested streams, use the `unfoldEach` family +of operations instead. These operate with statically known structure, +allowing the compiler to completely fuse the inner and outer loops. This +results in highly optimized code with minimal allocation and maximum +performance. + +## Breaking Fusion: Stream Conversion + +The `Stream` type in Streamly is fully fused—operations on it can +be composed without allocating intermediate structures. However, +when converting a `Stream` to or from other stream types—such as +the CPS-based `StreamK`, or third-party libraries like `streaming`, +`conduit`, or `pipes`—fusion is broken. + +Such conversions involve exiting the fused pipeline and constructing +a new stream representation. This results in allocation of new data +constructors and loss of compiler optimizations that rely on the fusible +stream structure. + +While interoperation with other libraries is sometimes necessary, +it's important to be aware that converting stream types introduces +overhead. To preserve fusion and maximize performance, stay within the +fused `Stream` type whenever possible. + +## Strictness annotations + * Strictness annotations on data, specially the data used as accumulator in folds and scans, can help in improving performance. * Strictness annotations on function arguments can help the compiler unbox constructors in certain cases, improving performance. * Sometimes using `-XStrict` extension can help improve performance, if so you may be missing some strictness annotations. `-XStrict` can be used as an aid - to detect missing annotations, using it blindly may regress performance. + to detect missing annotations, but using it blindly may regress performance. -### Use tail recursion +## Use tail recursion -Do not use a strict `foldr` or lazy `foldl` unless you know what you are -doing. Use lazy `foldr` for lazily transforming the stream and strict -`foldl` for reducing the stream. If you are manually writing recursive -code, try to use tail recursion where possible. +If you are manually writing recursive code, try to use tail recursion +where possible. When using recursion via fold operations, do not use a +strict `foldr` or a lazy `foldl` unless you know what you are doing. +Always use lazy `foldr` for lazily transforming the stream and strict +`foldl` for reducing the stream. In streamly, this comes naturally as +the stream operations are lazy foldr like and the fold operations via +the Fold module are strict foldl like. +## Static Argument Transformation + +Static Argument Transformation (SAT) is a valuable optimization for +reducing unnecessary overhead in recursive loops. It becomes especially +impactful when other inefficiencies have already been addressed. + +GHC includes support for SAT via the `-fstatic-argument-transformation` +flag, which is enabled with the `-O2` optimization level. However, it +may not always trigger automatically or optimally in all cases. + +For this reason, it's recommended that programmers understand and apply +this transformation manually when appropriate. Fortunately, it's simple +to do by habit, and in practice, we've observed substantial performance +improvements from applying it by hand in certain critical code paths. + +See the `loopDir` function in [this example](https://github.com/composewell/streamly-examples/blob/ebf9470ce2e96f9882653bb1e0ae1b1a239487e3/examples/BasicDirStream.hsc) +for a case where static argument transformation was used to acheive +performance equivalent to C. + + + +## Using `SpecConstr` in Recursive Loops + +Consider leveraging the `SpecConstr` optimization when writing recursive +loops manually, this happens automatically when recursion is implemented +using combinators from streamly e.g. using streams or folds. By passing the +`SPEC` argument, you can guide GHC to specialize the loop based on the +constructor of the argument being threaded through the recursion. + +This can lead to significant performance improvements in certain cases, +especially when the recursive argument has a known or predictable +constructor. + +Understanding when and why this helps requires some familiarity with how +`SpecConstr` works internally. If you understand the mechanics of this +optimization, you'll be better equipped to spot opportunities where it +can make a real difference. + +## Reducing Duplicate Branches + +Duplicating branches in conditional expressions is a common pattern +in Haskell. This often occurs because an `if` expression in Haskell +**requires both** a `then` and an `else` branch. + +In contrast, languages like C allow a series of single-branch `if` +statements, followed by a common operation. In Haskell, programmers +often end up duplicating that common operation in each `else` branch. + +### Better Approaches + +Instead of duplicating code: + +- **Use `when`** from `Control.Monad` for single-branch conditions where +there's no `else`. This avoids unnecessary duplication. +- **Extract common code** into a `let` binding. This ensures the code is +only written once and reused across branches. + +### Example + +Instead of: + +``` haskell +if condition1 + then doSomething1 + else doCommonThing + +if condition2 + then doSomething2 + else doCommonThing +``` + +Refactor to: + +``` haskell + when condition1 doSomething1 + when condition2 doSomething2 + doCommonThing +``` + +Or, if multiple branches share a computation: + +``` haskell + let common = doCommonThing + in if condition + then doSomething >> common + else doSomethingElse >> common +``` + +Using shared definitions not only improves readability and +maintainability but also reduces code bloat and allows the compiler to +optimize common expressions more effectively. + +## Delay the Specialization + +Suppose we want to choose between two functions, `f` and `g`, based on +a flag. One option is to make this decision early and pass the chosen +(inner) function to other parts of the code (outer). Another option is +to pass the flag itself and defer the decision until inside the outer +function that needs it. + +In many cases, **delaying the decision**—i.e., passing the flag—is +preferable. This makes it easier for the compiler to optimize, since it +doesn't need to inline the outer function in order to inline the inner +one. By postponing specialization, the code stays more flexible and +often performs better, especially in larger or more abstract codebases. + +## Reduce Allocations + +One useful way to gauge whether an optimization is effective is by +measuring memory allocations. Most optimizations work by reducing the +number of allocations, though some CPU-focused optimizations may not. + +Fewer allocations result in lower CPU utilization and reduced GC +pressure. In general, when writing code, keep in mind how it will be +translated by the compiler, and aim to be frugal with allocations. + + + +## Mutable Memory in Local Loops + +Using mutable memory in local loops can improve performance +significantly due to better cache utilization and reduced allocations +and garbage collection overhead. Instead of repeatedly allocating and +deallocating memory, we can reuse the same memory buffer. + +For example, consider a print buffer that's copied during the print +operation. Rather than allocating and freeing the buffer on each +iteration, we can use a mutable buffer that persists across loop +iterations. This avoids unnecessary heap traffic. + +Haskell currently lacks ergonomic abstractions for mutable memory, which +is a gap that should be addressed. However, we can still use low-level +tools like `allocaBytes` to allocate pinned mutable memory within a +loop. + +In C, local memory is typically allocated on the stack, which is +automatically and efficiently deallocated as the function returns. In +contrast, Haskell makes minimal use of the stack—most allocations +occur on the heap. While heap allocation in Haskell can be as cheap +as in C, deallocation involves garbage collection, which introduces +overhead. To mitigate this, we can simulate stack-like behavior using +reusable mutable buffers, improving performance in performance-critical +code. + +Interestingly, in multithreaded programs, Haskell may have an advantage: +each C thread requires a dedicated stack (with potential memory limits), +whereas Haskell uses the heap for all memory needs, avoiding stack-size +constraints. This makes memory use in Haskell more flexible and often +more efficient in highly concurrent applications. + +See the `loopDir0` function in [this example](https://github.com/composewell/streamly-examples/blob/ebf9470ce2e96f9882653bb1e0ae1b1a239487e3/examples/BasicDirStream.hsc) +for a case where a mutable `buffer` is passed to the function which is +reused in each iteration of the loop to avoid unnecessary allocation +work to achieve performance equivalent to C. + +## `unsafePerformIO` + +When using `unsafePerformIO`, you should almost always add the +`NOINLINE` pragma. Without it, the compiler may inline the expression, +potentially duplicating side effects or violating assumptions about +evaluation order—leading to unsafe or unpredictable behavior. It can +also result in reduced performance. + +``` haskell + {-# NOINLINE myGlobal #-} + myGlobal :: IORef Int + myGlobal = unsafePerformIO (newIORef 0) +``` + +Using `NOINLINE` ensures that the `IO` action is performed only once, +helping preserve referential transparency as much as possible when +working with `unsafePerformIO`. + +### File IO + +Avoid using the standard file read/write functions from the `base` +library, as they are not optimized for performance. Instead, prefer +`streamly`’s file IO operations, which are significantly more +efficient—especially for high-throughput or streaming applications. + +Alternatively, if you’re not using `streamly`, consider the lazy +`ByteString` or `Text`-based file IO functions from the `bytestring` +and `text` libraries. These provide better performance than the default +`String`-based APIs in `base`. + +## Accumulating Folds vs Streaming + +Consider the following fold function a Streamly user wanted to use for +stream processing: + +``` haskell + runQueryFold + :: QueryRunner columns haskells + -> Postgres.Connection + -> Query columns + -> b + -> (b -> haskells -> IO b) + -> IO b +``` + +This function starts with an initial value `b`, repeatedly applies +the step function `(b -> haskells -> IO b)`, and finally returns the +accumulated result `b`. + +The user proposed to use this fold to build a stream, then process that +stream—for example: + +``` haskell + runQueryFold conn q StreamK.nil $ \xs x -> pure $ StreamK.cons x xs +``` + +This approach is counter-productive. The fold above runs an IO loop +that *accumulates* all input elements into a stream in memory before +returning it. The memory consumption grows proportionally with input +size, so for infinite or very large inputs, this will lead to memory +exhaustion. + +### Why This Is a Problem + +This is *not* how streaming is intended to be used. Streaming is +for *on-the-fly* processing, not accumulation. Instead of building +the entire stream first and then consuming it, the generation and +consumption should happen simultaneously in the same loop. This way, +each element is processed as soon as it is generated, keeping memory +usage constant regardless of input size. + +Streaming operations are part of a *generate-transform-eliminate* +loop, fused together for efficiency. In each iteration, one element is +generated, processed by subsequent stream operations (like `map` or +`fold`), and then the loop continues with the next element. + +### Proper Streaming Pipeline + +To use streaming properly in this context, you can lift a step-wise +generation function into a stream with `unfoldrM`. For example, if your +generation logic provides a step function returning `Maybe` values, you +can convert it into a stream like this: + +``` haskell + Stream.unfoldrM step -- generate step in the pipeline + & Stream.mapM transform -- transform step + & ... -- additional stream operations + & Stream.fold Fold.drain -- eliminate step +``` + +This way, the entire pipeline remains fused, processes elements +incrementally, and avoids accumulating the entire input in memory. + + + +## Streamly Specific Optimizations + +### `fold` vs `foldBreak` + +`fold` and `foldBreak` provide two different ways to consume a +stream. We can compose the cosumer folds into a single `Fold` type and +then run it using `fold`. Alternatively, we can use `foldBreak` to run +individual folds on the stream and get back the remaining stream each +time, then run the next fold on the remaining stream. For streams that +use a mutable state e.g. a stream from a file handle or a socket, the +`foldBreak` method may turn out to be more efficient. + ## Build times and space considerations Haskell, being a pure functional language, confers special powers on @@ -96,3 +574,10 @@ modules moving some non-inlined parts in another module. There is another advantage of breaking large modules, it can take advantage of parallel compilation if they do not depend on each other. + +## perf-lint + +A `perf-lint` tool is planned as part of the roadmap to help automate +many of these performance optimizations. The goal is to provide +actionable feedback on common performance pitfalls and suggest +improvements—similar to how `hlint` works for general code style. diff --git a/docs/User/HowTo/streamly-vs-async.md b/docs/User/HowTo/streamly-vs-async.md --- a/docs/User/HowTo/streamly-vs-async.md +++ b/docs/User/HowTo/streamly-vs-async.md @@ -48,11 +48,12 @@ Use the following imports to run the snippets shown below: ```haskell -import Streamly -import Streamly.Prelude ((|:)) -import qualified Streamly.Prelude as S +import qualified Streamly.Data.Stream.Prelude as S +import qualified Streamly.Data.Fold as F import qualified Data.Text as Text import Control.Concurrent (threadDelay) +import Control.Exception (Exception, SomeException) +import Control.Monad.Catch (throwM, try) ``` Let us simulate a URL fetch with a delay of `n` seconds using the following @@ -71,7 +72,7 @@ concurrently: ```haskell - urls <- S.toList $ fromParallel $ getURL 2 |: getURL 1 |: S.nil +getUrlsConcurrently = S.parSequence id $ S.fromList [getURL 2, getURL 1] ``` This would return the results in their arrival order i.e. first 1 and then 2. @@ -81,7 +82,7 @@ return 2 first and then 1. ```haskell - urls <- S.toList $ fromAhead $ getURL 2 |: getURL 1 |: S.nil +getUrlsOrdered = S.parSequence (S.ordered True) $ S.fromList [getURL 2, getURL 1] ``` ### concurrently_ @@ -89,18 +90,17 @@ Use `drain` instead of `toList` to run the actions but ignore the results: ```haskell - S.drain $ fromParallel $ getURL 1 |: getURL 2 |: S.nil +drainUrlsConcurrently = S.fold F.drain $ S.parMapM id getURL $ S.fromList [1, 2] ``` -### Concurrent Applicative +### Concurrent Zipping If the actions that you are executing result in different output types you can -use applicative zip to collect the results or to directly apply them to a -function: +use zip to collect the results or to directly apply them to a function: ```haskell - tuples <- S.toList $ fromZipAsync $ - (,) <$> S.fromEffect (getURLString 1) <*> S.fromEffect (getURLText 2) +concurrentZipping = + S.parZipWith id (,) (S.fromEffect (getURLString 1)) (S.fromEffect (getURLText 2)) ``` ### race @@ -114,14 +114,14 @@ arrives: ```haskell - urls <- S.toList $ S.take 1 $ fromParallel $ getURL 1 |: getURL 2 |: S.nil +fastest = S.toList $ S.take 1 $ S.parSequence id $ S.fromList [getURL 1, getURL 2] ``` After the first result arrives, the rest of the actions are canceled automatically. In general, we can take first `n` results as they arrive: ```haskell - urls <- S.toList $ S.take 2 $ fromParallel $ getURL 1 |: getURL 2 |: S.nil +fastestN n = S.toList $ S.take n $ S.parSequence id $ S.fromList [getURL 1, getURL 2] ``` #### `race` Using Exceptions @@ -133,54 +133,38 @@ other actions will be canceled, for example: ```haskell - data Result = Result String deriving Show - instance Exception Result +data Result = Result String deriving Show +instance Exception Result - main = do - url <- try $ S.drain $ fromParallel $ - (getURL 2 >>= throwM . Result) - |: (getURL 1 >>= throwM . Result) - |: S.nil - case url of - Left (e :: SomeException) -> print e - Right _ -> undefined +raceUsingExceptions = do + url <- try $ S.fold F.drain $ S.parSequence id $ S.fromList + [ (getURL 2 >>= throwM . Result) + , (getURL 1 >>= throwM . Result) + ] + case url of + Left (e :: SomeException) -> print e + Right _ -> undefined ``` ### mapConcurrently -There are many ways to map concurrently on a container and collect the results: - -You can create a concurrent stream from a `Foldable` container of monadic -actions: - -```haskell - urls <- S.toList $ fromAhead $ S.fromFoldableM $ fmap getURL [1..3] -``` - -You can first convert a `Foldable` into a stream and then map an action on the -stream concurrently: - -```haskell - urls <- S.toList $ fromAhead $ S.mapM getURL $ foldMap return [1..3] -``` - -You can map a monadic action to a `Foldable` container to convert it into a -stream and at the same time fold it: +There are many ways to map concurrently on a container and collect the results. +The recommended way is to first convert itinto a stream and then map an action +on the stream concurrently: ```haskell - urls <- S.toList $ fromAhead $ foldMap (S.fromEffect . getURL) [1..3] +mapConcurrently = S.toList $ S.parMapM id getURL $ S.fromList [1..3] ``` ### replicateConcurrently Streamly has not just the equivalent of `replicateConcurrently` which is -`replicateM` but many more ways to generate concurrent streams, for example, -`|:`, `unfoldrM`, `repeatM`, `iterateM`, `fromFoldableM` etc. See the -[Streamly.Prelude](https://hackage.haskell.org/package/streamly/docs/Streamly-Prelude.html) -module documentation for more details. +`parReplicateM` but many more ways to generate concurrent streams, for example, +`parRepeatM`, `parBuffered`, etc. See the `Streamly.Data.Stream.Prelude` module +documentation for more details. ```haskell - xs <- S.toList $ fromParallel $ S.replicateM 2 $ getURL 1 +replicateConcurrently = S.toList $ S.parReplicateM id 2 $ getURL 1 ``` ### Functor @@ -191,14 +175,15 @@ To map serially just use `fmap`: ```haskell - xs <- S.toList $ fromParallel $ fmap (+1) $ return 1 |: return 2 |: S.nil +serialMap = S.toList $ fmap (+1) (S.fromList [1, 2] :: S.Stream IO Int) + ``` -To map a monadic action concurrently on all elements of the stream use `mapM`: +To map a monadic action concurrently on all elements of the stream use `parMapM`: ```haskell - xs <- S.toList $ fromParallel $ S.mapM (\x -> return (x + 1)) - $ return 1 |: return 2 |: S.nil +concurrentMap = + S.toList $ S.parMapM id (\x -> pure (x + 1) :: IO Int) $ S.fromList [1, 2] ``` ### Semigroup diff --git a/docs/User/HowTo/streamly-vs-lists.md b/docs/User/HowTo/streamly-vs-lists.md --- a/docs/User/HowTo/streamly-vs-lists.md +++ b/docs/User/HowTo/streamly-vs-lists.md @@ -22,12 +22,16 @@ lists can be used in a streaming style processing. For example, this is streaming style processing: -``` - replicate 10 1 +```haskell docspec +>>> import Data.Function ((&)) +>>> :{ +replicate 10 1 & zipWith (+) [1..10] & map (+1) & filter odd & sum +:} +35 ``` However, if a list is generated in a strict monad (e.g. IO) it cannot be @@ -37,12 +41,16 @@ large lists. For example, the following code accumulates `xs` before it processes it: -``` - xs <- replicateM 10 (return 1) - zipWith (+) [1..10] xs +```haskell docspec +>>> import Control.Monad (replicateM) +>>> xs <- replicateM 10 (return 1) +>>> :{ +zipWith (+) [1..10] xs & map (+1) & filter odd & sum +:} +35 ``` Monadic streams solve this problem. To be able to consume elements from @@ -52,12 +60,17 @@ 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) +```haskell docspec +>>> import qualified Streamly.Data.Stream as S +>>> import qualified Streamly.Data.Fold as F +>>> :{ +S.replicateM 10 (return 1) & S.zipWith (+) (S.fromList [1..10]) - & S.map (+1) + & fmap (+1) & S.filter odd - & S.sum + & S.fold F.sum +:} +35 ``` Streamly's monadic streams are a generalization of pure streams (aka lists) and @@ -66,7 +79,7 @@ ## Streamly as lists -`SerialT Identity a` can be used in place of `[a]` with equivalent or better +`Stream 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. @@ -75,20 +88,19 @@ Lists are constructed using `[]` and `:`. -``` -> "hello" : "world" : [] +```haskell docspec +>>> "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 +```haskell docspec +>>> import Data.Functor.Identity (Identity) +>>> import Streamly.Data.StreamK (StreamK) +>>> import qualified Streamly.Data.StreamK as StreamK +>>> "hello" `StreamK.cons` "world" `StreamK.cons` StreamK.nil :: StreamK Identity String fromList ["hello","world"] ``` @@ -97,34 +109,44 @@ 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 +unexposed `Streamly.Internal.Data.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` +`Stream Identity a` is an instance of `Show`, `Read`, `Eq`, `Ord`, `IsList`, +`Foldable` and `Traversable` type classes. Furthermore, `Stream 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. +Along with these we can use combinators from `Streamly.Data.Stream` to perform +all list operations on pure streams. Lists: -``` -> replicate 10 1 -> map (+1) $ replicate 10 1 -> length $ replicate 10 1 +```haskell docspec +>>> replicate 10 1 +[1,1,1,1,1,1,1,1,1,1] + +>>> map (+1) $ replicate 10 1 +[2,2,2,2,2,2,2,2,2,2] + +>>> length $ replicate 10 1 +10 ``` 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) +>>> S.replicate 10 1 :: S.Stream Identity Int +fromList [1,1,1,1,1,1,1,1,1,1] + +>>> S.map (+1) $ S.replicate 10 1 :: S.Stream Identity Int +fromList [2,2,2,2,2,2,2,2,2,2] + +>>> S.fold F.length (S.replicate 10 1 :: S.Stream Identity Int) +10 ``` ## Monadic Operations @@ -142,8 +164,9 @@ Unsafe monadic operations involving lists, run these example with `+RTS -s` options: -``` +```haskell unshared import Control.Monad + main = do xs <- replicateM 10000000 (pure 1) ys <- mapM (\x -> return $ x + 1) xs @@ -152,11 +175,12 @@ Streams: -``` -import Streamly -import qualified Streamly.Prelude as S +```haskell unshared +import qualified Streamly.Data.Stream as S +import qualified Streamly.Data.Fold as F + main = do - n <- S.length + n <- S.fold F.length $ S.mapM (\x -> return $ x + 1) $ S.replicateM 10000000 (pure 1) print n @@ -176,16 +200,15 @@ 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 +>>> import qualified Streamly.Data.StreamK as StreamK +>>> StreamK.toList $ getLine `StreamK.cons` getLine `StreamK.cons` StreamK.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. @@ -199,38 +222,40 @@ The following code prints one element every second: -```haskell -import Control.Concurrent -import Streamly -import qualified Streamly.Prelude as S +```haskell docspec +>>> import Control.Concurrent +>>> import qualified Streamly.Data.Stream.Prelude as S +>>> import qualified Streamly.Data.Fold as F -func = S.mapM (\x -> threadDelay 1000000 >> print x) $ S.replicate 10 1 -main = runStream func +>>> func = S.mapM (\x -> threadDelay 1000000 >> print x) $ S.replicate 10 1 +>>> main = S.fold F.drain func ``` -To run it concurrently, just run the same code with `fromAsync` combinator: +To run it concurrently, depending on what you want to make concurrent, you can +use `parMapM` or `parBuffered`. -```haskell -main = runStream $ fromAsync func +```haskell docspec +>>> func = S.parMapM id (\x -> threadDelay 1000000 >> print x) $ S.replicate 10 1 +>>> main = S.fold F.drain 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 `parMapM` 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 $ fromAsync $ S.replicateM (threadDelay 1000000 >> print 1) -main = runStream func +```haskell docspec +>>> func = S.parReplicateM id 10 (threadDelay 1000000 >> print 1) +>>> main = S.fold F.drain func ``` -Here, the `replicateM` operation replicates the action concurrently. In real +Here, the `parReplicateM` 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` +(`base-4.12`) vs `Stream 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 diff --git a/docs/User/Project/ApiChangelogs/0.10.1-0.11.0.txt b/docs/User/Project/ApiChangelogs/0.10.1-0.11.0.txt new file mode 100644 --- /dev/null +++ b/docs/User/Project/ApiChangelogs/0.10.1-0.11.0.txt @@ -0,0 +1,261 @@ +--------------------------------- +API Annotations +--------------------------------- + +[A] : Added +[R] : Removed +[C] : Changed +[O] : Old definition +[N] : New definition +[D] : Deprecated + +--------------------------------- +API diff +--------------------------------- + +[C] Streamly.Data.Stream.Prelude + [A] useAcquire :: AcquireIO -> Config -> Config + [D] parEval :: MonadAsync m => (Config -> Config) -> Stream m a -> Stream m a + [A] parCrossApply :: MonadAsync m => (Config -> Config) -> Stream m (a -> b) -> Stream m a -> Stream m b + [A] parBuffered :: MonadAsync m => (Config -> Config) -> Stream m a -> Stream m a + [D] parApply :: MonadAsync m => (Config -> Config) -> Stream m (a -> b) -> Stream m a -> Stream m b + [A] clearAcquire :: Config -> Config +[A] Streamly.Data.Scanl.Prelude + [A] Config + [A] parTeeWith :: MonadAsync m => (Config -> Config) -> (a -> b -> c) -> Scanl m x a -> Scanl m x b -> Scanl m x c + [A] parDistributeScanM :: MonadAsync m => (Config -> Config) -> m [Scanl m a b] -> Stream m a -> Stream m [b] + [A] parDistributeScan :: MonadAsync m => (Config -> Config) -> [Scanl m a b] -> Stream m a -> Stream m [b] + [A] parDemuxScanM :: (MonadAsync m, Ord k) => (Config -> Config) -> (a -> k) -> (k -> m (Scanl m a b)) -> Stream m a -> Stream m [(k, b)] + [A] parDemuxScan :: (MonadAsync m, Ord k) => (Config -> Config) -> (a -> k) -> (k -> Scanl m a b) -> Stream m a -> Stream m [(k, b)] + [A] maxBuffer :: Int -> Config -> Config + [A] inspect :: Bool -> Config -> Config + [A] boundThreads :: Bool -> Config -> Config +[C] Streamly.Data.Fold.Prelude + [C] toHashMapIO + [O] toHashMapIO :: (MonadIO m, Hashable k, Ord k) => (a -> k) -> Fold m a b -> Fold m a (HashMap k b) + [N] toHashMapIO :: (MonadIO m, Hashable k) => (a -> k) -> Fold m a b -> Fold m a (HashMap k b) + [A] parUnzip :: MonadAsync m => (Config -> Config) -> Fold m b x -> Fold m c y -> Fold m (b, c) (x, y) + [A] parTee :: MonadAsync m => (Config -> Config) -> Fold m x a -> Fold m x b -> Fold m x (a, b) + [A] parPartition :: MonadAsync m => (Config -> Config) -> Fold m b x -> Fold m c y -> Fold m (Either b c) (x, y) + [D] parEval :: MonadAsync m => (Config -> Config) -> Fold m a b -> Fold m a b + [A] parDistributeScan :: MonadAsync m => (Config -> Config) -> m [Fold m a b] -> Stream m a -> Stream m [b] + [A] parDistribute :: MonadAsync m => (Config -> Config) -> [Fold m a b] -> Fold m a [b] + [A] parDemuxScan :: (MonadAsync m, Ord k) => (Config -> Config) -> (a -> k) -> (k -> m (Fold m a b)) -> Stream m a -> Stream m [(k, b)] + [A] parBuffered :: MonadAsync m => (Config -> Config) -> Fold m a b -> Fold m a b + +--------------------------------- +Internal API diff +--------------------------------- + +[C] Streamly.Internal.Network.Inet.TCP + [A] pipeChunks :: (MonadAsync m, MonadCatch m) => (Word8, Word8, Word8, Word8) -> PortNumber -> Stream m (Array Word8) -> Stream m (Array Word8) +[D] Streamly.Internal.FileSystem.Event.Linux +[D] Streamly.Internal.FileSystem.Event +[C] Streamly.Internal.Data.Stream.Prelude + [C] Channel + [C] [enqueue] + [O] [enqueue] :: Channel m a -> Bool -> (RunInIO m, StreamK m a) -> IO () + [N] [enqueue] :: Channel m a -> (RunInIO m, StreamK m a) -> IO () + [A] [channelStopping] :: Channel m a -> IORef Bool + [A] [channelStopped] :: Channel m a -> MVar Bool + [C] Channel + [O] Channel :: RunInIO m -> IORef ([ChildEvent a], Int) -> MVar () -> m [ChildEvent a] -> m Bool -> Limit -> Limit -> Maybe (IORef Count) -> Maybe YieldRateInfo -> (Bool -> (RunInIO m, StreamK m a) -> IO ()) -> m () -> IO Bool -> IO Bool -> IORef Bool -> (Maybe WorkerInfo -> m ()) -> IORef (Set ThreadId) -> IORef Int -> (ThreadId -> m ()) -> MVar () -> Maybe (IORef ()) -> SVarStats -> Bool -> ThreadId -> Channel m a + [N] Channel :: RunInIO m -> Limit -> IORef ([ChildEvent a], Int) -> MVar () -> m [ChildEvent a] -> m Bool -> Maybe (IORef Count) -> IO Bool -> Maybe YieldRateInfo -> IORef Bool -> m () -> ((RunInIO m, StreamK m a) -> IO ()) -> IO Bool -> (Maybe WorkerInfo -> m ()) -> IORef Bool -> MVar Bool -> Limit -> IORef (Set ThreadId) -> IORef Int -> (ThreadId -> m ()) -> MVar () -> Maybe (IORef ()) -> SVarStats -> Bool -> ThreadId -> Channel m a + [A] yieldWith :: Maybe WorkerInfo -> Channel m a -> a -> IO Bool + [R] yield :: Channel m a -> Maybe WorkerInfo -> a -> IO Bool + [A] useAcquire :: AcquireIO -> Config -> Config + [A] timedGroupsOf :: MonadAsync m => Double -> Int -> Fold m a b -> Stream m a -> Stream m b + [A] timedChunksOf' :: (MonadAsync m, Unbox a) => Double -> Int -> Stream m a -> Stream m (Array a) + [A] timedChunksOf :: (MonadAsync m, Unbox a) => Double -> Int -> Stream m a -> Stream m (Array a) + [A] stopWith :: Maybe WorkerInfo -> Channel m a -> IO () + [R] stopChannel :: MonadIO m => Channel m a -> m () + [R] stop :: Channel m a -> Maybe WorkerInfo -> IO () + [C] startChannel + [O] startChannel :: MonadRunInIO m => Channel m a -> m () + [N] startChannel :: MonadIO m => Channel m a -> m () + [A] shutdown :: MonadIO m => Channel m a -> m () + [R] sendWorkerWait :: MonadIO m => Bool -> (Channel m a -> IO ()) -> (Channel m a -> m Bool) -> Channel m a -> m () + [C] readOutputQPaced + [O] readOutputQPaced :: MonadRunInIO m => Channel m a -> m [ChildEvent a] + [N] readOutputQPaced :: MonadIO m => Channel m a -> m [ChildEvent a] + [C] readOutputQBounded + [O] readOutputQBounded :: MonadRunInIO m => Bool -> Channel m a -> m [ChildEvent a] + [N] readOutputQBounded :: MonadIO m => Bool -> Channel m a -> m [ChildEvent a] + [R] pushWorker :: MonadRunInIO m => Count -> Channel m a -> m () + [C] postProcessPaced + [O] postProcessPaced :: MonadRunInIO m => Channel m a -> m Bool + [N] postProcessPaced :: MonadIO m => Channel m a -> m Bool + [C] postProcessBounded + [O] postProcessBounded :: MonadRunInIO m => Channel m a -> m Bool + [N] postProcessBounded :: MonadIO m => Channel m a -> m Bool + [A] parYieldWith :: (Config -> Config) -> ((a -> m b) -> m c) -> Stream m a + [A] parMergeMap :: (Config -> Config) -> (a -> Stream m b) -> Stream m a -> Stream m b + [A] parMergeIterate :: (Config -> Config) -> (a -> Stream m a) -> Stream m a -> Stream m a + [D] parEval :: MonadAsync m => (Config -> Config) -> Stream m a -> Stream m a + [A] parCrossApply :: MonadAsync m => (Config -> Config) -> Stream m (a -> b) -> Stream m a -> Stream m b + [A] parBuffered :: MonadAsync m => (Config -> Config) -> Stream m a -> Stream m a + [D] parApply :: MonadAsync m => (Config -> Config) -> Stream m (a -> b) -> Stream m a -> Stream m b + [A] newStreamAndCallback :: MonadAsync m => m (a -> m (), Stream m a) + [A] newRateInfo :: Config -> IO (Maybe YieldRateInfo) + [A] maxYields :: Maybe Int64 -> Config -> Config + [D] groupsOfTimeout :: MonadAsync m => Int -> Double -> Fold m a b -> Stream m a -> Stream m b + [A] getYieldLimit :: Config -> Maybe Count + [A] getStreamRate :: Config -> Maybe Rate + [A] getOrdered :: Config -> Bool + [A] getMaxThreads :: Config -> Limit + [A] getMaxBuffer :: Config -> Limit + [A] getInterleaved :: Config -> Bool + [A] getInspectMode :: Config -> Bool + [A] getEagerDispatch :: Config -> Bool + [A] getCleanup :: Config -> Maybe (IO () -> IO ()) + [C] fromChannelK + [O] fromChannelK :: MonadAsync m => Channel m a -> StreamK m a + [N] fromChannelK :: MonadAsync m => Maybe (IO () -> IO ()) -> Channel m a -> StreamK m a + [A] forkWorker :: MonadIO m => Count -> Channel m a -> m () + [A] exceptionWith :: Maybe WorkerInfo -> Channel m a -> SomeException -> IO () + [R] dumpSVar :: Channel m a -> IO String + [A] dumpChannel :: Channel m a -> IO String + [C] dispatchWorkerPaced + [O] dispatchWorkerPaced :: MonadRunInIO m => Channel m a -> m Bool + [N] dispatchWorkerPaced :: MonadIO m => Channel m a -> m Bool + [C] dispatchWorker + [O] dispatchWorker :: MonadRunInIO m => Count -> Channel m a -> m Bool + [N] dispatchWorker :: MonadIO m => Count -> Channel m a -> m Bool + [A] dispatchAllWait :: MonadIO m => Bool -> (Channel m a -> IO ()) -> (Channel m a -> m Bool) -> Channel m a -> m () + [A] clearAcquire :: Config -> Config + [A] cleanupChan :: Channel m a -> String -> IO () + [A] channelDone :: Channel m a -> String -> IO () + [A] chanConcatMapK :: MonadAsync m => (Config -> Config) -> Channel m b -> (a -> StreamK m b) -> StreamK m a -> StreamK m b + [A] boundedIntervalsOf :: Int -> Double -> Int -> Fold m a b -> Stream m a -> Stream m b + [A] boundThreads :: Bool -> Config -> Config +[A] Streamly.Internal.Data.Scanl.Prelude + [A] OutEvent + [A] FoldPartial :: b -> OutEvent b + [A] FoldException :: ThreadId -> SomeException -> OutEvent b + [A] FoldEOF :: ThreadId -> OutEvent b + [A] FoldDone :: ThreadId -> b -> OutEvent b + [A] Config + [A] Channel + [A] [svarStats] :: Channel m a b -> SVarStats + [A] [svarRef] :: Channel m a b -> Maybe (IORef ()) + [A] [svarInspectMode] :: Channel m a b -> Bool + [A] [svarCreator] :: Channel m a b -> ThreadId + [A] [readInputQ] :: Channel m a b -> m [ChildEvent a] + [A] [outputQueue] :: Channel m a b -> IORef ([OutEvent b], Int) + [A] [outputDoorBell] :: Channel m a b -> MVar () + [A] [maxInputBuffer] :: Channel m a b -> Limit + [A] [inputSpaceDoorBell] :: Channel m a b -> MVar () + [A] [inputQueue] :: Channel m a b -> IORef ([ChildEvent a], Int) + [A] [inputItemDoorBell] :: Channel m a b -> MVar () + [A] [closedForInput] :: Channel m a b -> IORef Bool + [A] Channel :: IORef ([ChildEvent a], Int) -> Limit -> MVar () -> IORef Bool -> MVar () -> m [ChildEvent a] -> IORef ([OutEvent b], Int) -> MVar () -> Maybe (IORef ()) -> SVarStats -> Bool -> ThreadId -> Channel m a b + [A] sendToWorker_ :: MonadAsync m => Channel m a b -> a -> m () + [A] sendToWorker :: MonadAsync m => Channel m a b -> a -> m (Maybe b) + [A] parTeeWith :: MonadAsync m => (Config -> Config) -> (a -> b -> c) -> Scanl m x a -> Scanl m x b -> Scanl m x c + [A] parDistributeScanM :: MonadAsync m => (Config -> Config) -> m [Scanl m a b] -> Stream m a -> Stream m [b] + [A] parDistributeScan :: MonadAsync m => (Config -> Config) -> [Scanl m a b] -> Stream m a -> Stream m [b] + [A] parDemuxScanM :: (MonadAsync m, Ord k) => (Config -> Config) -> (a -> k) -> (k -> m (Scanl m a b)) -> Stream m a -> Stream m [(k, b)] + [A] parDemuxScan :: (MonadAsync m, Ord k) => (Config -> Config) -> (a -> k) -> (k -> Scanl m a b) -> Stream m a -> Stream m [(k, b)] + [A] newScanChannel :: MonadRunInIO m => (Config -> Config) -> Scanl m a b -> m (Channel m a b) + [A] newChannelWithScan :: MonadRunInIO m => IORef ([OutEvent b], Int) -> MVar () -> (Config -> Config) -> Scanl m a b -> m (Channel m a b, ThreadId) + [A] newChannelWith :: MonadRunInIO m => IORef ([OutEvent b], Int) -> MVar () -> (Config -> Config) -> Fold m a b -> m (Channel m a b, ThreadId) + [A] newChannel :: MonadRunInIO m => (Config -> Config) -> Fold m a b -> m (Channel m a b) + [A] maxBuffer :: Int -> Config -> Config + [A] inspect :: Bool -> Config -> Config + [A] finalize :: MonadIO m => Channel m a b -> m () + [A] dumpChannel :: Channel m a b -> IO String + [A] defaultConfig :: Config + [A] cleanup :: MonadIO m => Channel m a b -> m () + [A] checkFoldStatus :: MonadAsync m => Channel m a b -> m (Maybe b) + [A] boundThreads :: Bool -> Config -> Config +[C] Streamly.Internal.Data.Fold.Prelude + [A] OutEvent + [A] FoldPartial :: b -> OutEvent b + [A] FoldException :: ThreadId -> SomeException -> OutEvent b + [A] FoldEOF :: ThreadId -> OutEvent b + [A] FoldDone :: ThreadId -> b -> OutEvent b + [C] Channel + [R] [readOutputQ] :: Channel m a b -> m [ChildEvent a] + [A] [readInputQ] :: Channel m a b -> m [ChildEvent a] + [C] [outputQueue] + [O] [outputQueue] :: Channel m a b -> IORef ([ChildEvent a], Int) + [N] [outputQueue] :: Channel m a b -> IORef ([OutEvent b], Int) + [R] [outputQueueFromConsumer] :: Channel m a b -> IORef ([ChildEvent b], Int) + [R] [outputDoorBellFromConsumer] :: Channel m a b -> MVar () + [A] [maxInputBuffer] :: Channel m a b -> Limit + [R] [maxBufferLimit] :: Channel m a b -> Limit + [A] [inputSpaceDoorBell] :: Channel m a b -> MVar () + [A] [inputQueue] :: Channel m a b -> IORef ([ChildEvent a], Int) + [A] [inputItemDoorBell] :: Channel m a b -> MVar () + [A] [closedForInput] :: Channel m a b -> IORef Bool + [R] [bufferSpaceDoorBell] :: Channel m a b -> MVar () + [C] Channel + [O] Channel :: IORef ([ChildEvent a], Int) -> Limit -> MVar () -> m [ChildEvent a] -> IORef ([ChildEvent b], Int) -> MVar () -> MVar () -> Maybe (IORef ()) -> SVarStats -> Bool -> ThreadId -> Channel m a b + [N] Channel :: IORef ([ChildEvent a], Int) -> Limit -> MVar () -> IORef Bool -> MVar () -> m [ChildEvent a] -> IORef ([OutEvent b], Int) -> MVar () -> Maybe (IORef ()) -> SVarStats -> Bool -> ThreadId -> Channel m a b + [A] sendToWorker_ :: MonadAsync m => Channel m a b -> a -> m () + [A] parUnzipWithM :: MonadAsync m => (Config -> Config) -> (a -> m (b, c)) -> Fold m b x -> Fold m c y -> Fold m a (x, y) + [A] parUnzip :: MonadAsync m => (Config -> Config) -> Fold m b x -> Fold m c y -> Fold m (b, c) (x, y) + [A] parTeeWith :: MonadAsync m => (Config -> Config) -> (a -> b -> c) -> Fold m x a -> Fold m x b -> Fold m x c + [A] parTee :: MonadAsync m => (Config -> Config) -> Fold m x a -> Fold m x b -> Fold m x (a, b) + [A] parPartition :: MonadAsync m => (Config -> Config) -> Fold m b x -> Fold m c y -> Fold m (Either b c) (x, y) + [A] parLmapM :: (Config -> Config) -> (a -> m b) -> Fold m b r -> Fold m a r + [D] parEval :: MonadAsync m => (Config -> Config) -> Fold m a b -> Fold m a b + [A] parDistributeScan :: MonadAsync m => (Config -> Config) -> m [Fold m a b] -> Stream m a -> Stream m [b] + [A] parDistribute :: MonadAsync m => (Config -> Config) -> [Fold m a b] -> Fold m a [b] + [A] parDemuxScan :: (MonadAsync m, Ord k) => (Config -> Config) -> (a -> k) -> (k -> m (Fold m a b)) -> Stream m a -> Stream m [(k, b)] + [A] parBuffered :: MonadAsync m => (Config -> Config) -> Fold m a b -> Fold m a b + [A] newScanChannel :: MonadRunInIO m => (Config -> Config) -> Scanl m a b -> m (Channel m a b) + [A] newChannelWithScan :: MonadRunInIO m => IORef ([OutEvent b], Int) -> MVar () -> (Config -> Config) -> Scanl m a b -> m (Channel m a b, ThreadId) + [A] newChannelWith :: MonadRunInIO m => IORef ([OutEvent b], Int) -> MVar () -> (Config -> Config) -> Fold m a b -> m (Channel m a b, ThreadId) + [A] finalize :: MonadIO m => Channel m a b -> m () + [R] dumpSVar :: Channel m a b -> IO String + [A] dumpChannel :: Channel m a b -> IO String + [A] defaultConfig :: Config + [A] cleanup :: MonadIO m => Channel m a b -> m () +[C] Streamly.Internal.Data.Channel + [C] YieldRateInfo + [R] Config + [R] workerRateControl :: Limit -> IORef Int -> YieldRateInfo -> WorkerInfo -> IO Bool + [R] stopWhen :: StopWhen -> Config -> Config + [R] setStreamLatency :: Int -> Config -> Config + [C] sendYield + [O] sendYield :: Limit -> Limit -> IORef Int -> Maybe WorkerInfo -> Maybe YieldRateInfo -> IORef ([ChildEvent a], Int) -> MVar () -> ChildEvent a -> IO Bool + [N] sendYield :: Limit -> Limit -> IORef Int -> Maybe YieldRateInfo -> IORef ([ChildEvent a], Int) -> MVar () -> Maybe WorkerInfo -> a -> IO Bool + [R] sendWithDoorBell :: IORef ([ChildEvent a], Int) -> MVar () -> ChildEvent a -> IO Int + [C] sendStop + [O] sendStop :: IORef Int -> Maybe WorkerInfo -> Maybe YieldRateInfo -> IORef ([ChildEvent a], Int) -> MVar () -> IO () + [N] sendStop :: IORef Int -> Maybe YieldRateInfo -> IORef ([ChildEvent a], Int) -> MVar () -> Maybe WorkerInfo -> IO () + [A] sendException :: IORef Int -> IORef ([ChildEvent a], Int) -> MVar () -> SomeException -> IO () + [A] sendEvent :: IORef ([a], Int) -> MVar () -> a -> IO Int + [C] readOutputQBasic + [O] readOutputQBasic :: IORef ([ChildEvent a], Int) -> IO ([ChildEvent a], Int) + [N] readOutputQBasic :: IORef ([a], Int) -> IO ([a], Int) + [R] rate :: Maybe Rate -> Config -> Config + [R] ordered :: Bool -> Config -> Config + [R] newRateInfo :: Config -> IO (Maybe YieldRateInfo) + [R] minRate :: Double -> Config -> Config + [R] maxYields :: Maybe Int64 -> Config -> Config + [R] maxThreads :: Int -> Config -> Config + [R] maxRate :: Double -> Config -> Config + [R] maxBuffer :: Int -> Config -> Config + [R] interleaved :: Bool -> Config -> Config + [R] inspect :: Bool -> Config -> Config + [A] incrWorkerYieldCount :: Limit -> IORef Int -> YieldRateInfo -> WorkerInfo -> IO Bool + [R] handleChildException :: IORef ([ChildEvent a], Int) -> MVar () -> SomeException -> IO () + [R] getYieldLimit :: Config -> Maybe Count + [R] getStreamRate :: Config -> Maybe Rate + [R] getStreamLatency :: Config -> Maybe NanoSecond64 + [R] getStopWhen :: Config -> StopWhen + [R] getOrdered :: Config -> Bool + [R] getMaxThreads :: Config -> Limit + [R] getMaxBuffer :: Config -> Limit + [R] getInterleaved :: Config -> Bool + [R] getInspectMode :: Config -> Bool + [R] getEagerDispatch :: Config -> Bool + [R] getBound :: Config -> Bool + [R] eager :: Bool -> Config -> Config + [R] defaultConfig :: Config + [R] constRate :: Double -> Config -> Config + [R] cleanupSVar :: IORef (Set ThreadId) -> IO () + [R] boundThreads :: Bool -> Config -> Config + [R] avgRate :: Double -> Config -> Config diff --git a/docs/User/Project/ApiChangelogs/0.7.3-0.8.0.txt b/docs/User/Project/ApiChangelogs/0.7.3-0.8.0.txt new file mode 100644 --- /dev/null +++ b/docs/User/Project/ApiChangelogs/0.7.3-0.8.0.txt @@ -0,0 +1,253 @@ +# API diff as generated by cabal-diff with minor edits. +# ~~~ means deprecated module +# ~~ means deprecated symbol + +#---------------------------- +# Changes from 0.7.3 to 0.8.0 +#---------------------------- + +# Deprecated, merged into Streamly.Prelude +~~~ Streamly +# Fixity changes +++ infixr 6 `ahead` +++ infixr 6 `async` +++ infixr 6 `parallel` +++ infixr 6 `serial` +++ infixr 6 `wAsync` +++ infixr 6 `wSerial` + +# Added +@@@ Streamly.Console.Stdio + +# Deprecated, renamed +~~~ Streamly.Memory.Array +@@@ Streamly.Data.Array.Foreign + +# Moved from Streamly.Memory.Array +++ data Array a +++ fromList :: Storable a => [a] -> Array a +++ fromListN :: Storable a => Int -> [a] -> Array a +++ length :: forall a. Storable a => Array a -> Int +++ read :: forall m a. (Monad m, Storable a) => Unfold m (Array a) a +++ toList :: Storable a => Array a -> [a] +++ write :: forall m a. (MonadIO m, Storable a) => Fold m a (Array a) +++ writeN :: forall m a. (MonadIO m, Storable a) => Int -> Fold m a (Array a) + +# Added +++ asBytes :: Array a -> Array Word8 +++ cast :: forall a b. Storable b => Array a -> Maybe (Array b) +++ getIndex :: Storable a => Array a -> Int -> Maybe a +++ readRev :: forall m a. (Monad m, Storable a) => Unfold m (Array a) a +++ writeLastN :: (Storable a, MonadIO m) => Int -> Fold m a (Array a) + +@@@ Streamly.Data.Fold +# Signature changed + - product :: (Monad m, Num a) => Fold m a a + + product :: (Monad m, Num a, Eq a) => Fold m a a + +# Removed (Moved to the Streamly.Data.Fold.Tee module) +-- instance (Monad m, Floating b) => Floating (Fold m a b) +-- instance (Monad m, GHC.Num.Num b) => GHC.Num.Num (Fold m a b) +-- instance (Monad m, GHC.Real.Fractional b) => GHC.Real.Fractional (Fold m a b) +-- instance (Semigroup b, Monad m) => Semigroup (Fold m a b) +-- instance (Semigroup b, Monoid b, Monad m) => Monoid (Fold m a b) +-- instance Applicative m => Applicative (Fold m a) + +# Renamed +~~ mapM :: Monad m => (b -> m c) -> Fold m a b -> Fold m a c +++ rmapM :: Monad m => (b -> m c) -> Fold m a b -> Fold m a c + +# Deprecated +~~ sequence :: Monad m => Fold m a (m b) -> Fold m a b + +# Added +++ catMaybes :: Monad m => Fold m a b -> Fold m (Maybe a) b +++ chunksOf :: Monad m => Int -> Fold m a b -> Fold m b c -> Fold m a c +++ concatMap :: Monad m => (b -> Fold m a c) -> Fold m a b -> Fold m a c +++ filter :: Monad m => (a -> Bool) -> Fold m a r -> Fold m a r +++ filterM :: Monad m => (a -> m Bool) -> Fold m a r -> Fold m a r +++ foldl' :: Monad m => (b -> a -> b) -> b -> Fold m a b +++ foldlM' :: Monad m => (b -> a -> m b) -> m b -> Fold m a b +++ foldr :: Monad m => (a -> b -> b) -> b -> Fold m a b +++ lmap :: (a -> b) -> Fold m b r -> Fold m a r +++ lmapM :: Monad m => (a -> m b) -> Fold m b r -> Fold m a r +++ many :: Monad m => Fold m a b -> Fold m b c -> Fold m a c +++ mapMaybe :: Monad m => (a -> Maybe b) -> Fold m b r -> Fold m a r +++ rollingHash :: (Monad m, Enum a) => Fold m a Int64 +++ rollingHashWithSalt :: (Monad m, Enum a) => Int64 -> Fold m a Int64 +++ sconcat :: (Monad m, Semigroup a) => a -> Fold m a a +++ serialWith :: Monad m => (a -> b -> c) -> Fold m x a -> Fold m x b -> Fold m x c +++ take :: Monad m => Int -> Fold m a b -> Fold m a b +++ takeEndBy :: Monad m => (a -> Bool) -> Fold m a b -> Fold m a b +++ takeEndBy_ :: Monad m => (a -> Bool) -> Fold m a b -> Fold m a b +++ teeWith :: Monad m => (a -> b -> c) -> Fold m x a -> Fold m x b -> Fold m x c +++ toListRev :: Monad m => Fold m a [a] + +# Added +@@@ Streamly.Data.Fold.Tee + +@@@ Streamly.Data.Unfold +# Added +++ crossWith :: Monad m => (b -> c -> d) -> Unfold m a b -> Unfold m a c -> Unfold m a d +++ drop :: Applicative m => Int -> Unfold m a b -> Unfold m a b +++ dropWhile :: Monad m => (b -> Bool) -> Unfold m a b -> Unfold m a b +++ dropWhileM :: Monad m => (b -> m Bool) -> Unfold m a b -> Unfold m a b +++ filter :: Monad m => (b -> Bool) -> Unfold m a b -> Unfold m a b +++ filterM :: Monad m => (b -> m Bool) -> Unfold m a b -> Unfold m a b +++ fromList :: Applicative m => Unfold m [a] a +++ fromListM :: Applicative m => Unfold m [m a] a +++ fromStream :: (IsStream t, Applicative m) => Unfold m (t m a) a +++ function :: Applicative m => (a -> b) -> Unfold m a b +++ functionM :: Applicative m => (a -> m b) -> Unfold m a b +++ iterateM :: Monad m => (a -> m a) -> Unfold m (m a) a +++ lmap :: (a -> c) -> Unfold m c b -> Unfold m a b +++ lmapM :: Monad m => (a -> m c) -> Unfold m c b -> Unfold m a b +++ many :: Monad m => Unfold m a b -> Unfold m b c -> Unfold m a c +++ mapM :: Monad m => (b -> m c) -> Unfold m a b -> Unfold m a c +++ repeatM :: Monad m => Unfold m (m a) a +++ replicateM :: Monad m => Int -> Unfold m (m a) a +++ take :: Monad m => Int -> Unfold m a b -> Unfold m a b +++ takeWhile :: Monad m => (b -> Bool) -> Unfold m a b -> Unfold m a b +++ takeWhileM :: Monad m => (b -> m Bool) -> Unfold m a b -> Unfold m a b +++ unfoldr :: Applicative m => (a -> Maybe (b, a)) -> Unfold m a b +++ unfoldrM :: Applicative m => (a -> m (Maybe (b, a))) -> Unfold m a b +++ zipWith :: Monad m => (b -> c -> d) -> Unfold m a b -> Unfold m a c -> Unfold m a d + +# Deprecated, renamed to Streamly.Unicode.Stream +~~~ Streamly.Data.Unicode.Stream + +@@@ Streamly.Network.Socket +# Added +++ forSocketM :: (MonadMask m, MonadIO m) => (Socket -> m ()) -> Socket -> m () +++ readChunk :: Int -> Socket -> IO (Array Word8) +++ writeChunk :: Storable a => Socket -> Array a -> IO () +++ writeChunksWithBufferOf :: (MonadIO m, Storable a) => Int -> Socket -> Fold m (Array a) () + +@@@ Streamly.Prelude +# Signature changed + - after :: (IsStream t, Monad m) => m b -> t m a -> t m a + + after :: (IsStream t, MonadIO m, MonadBaseControl IO m) => m b -> t m a -> t m a + - bracket :: (IsStream t, MonadCatch m) => m b -> (b -> m c) -> (b -> t m a) -> t m a + + bracket :: (IsStream t, MonadAsync m, MonadCatch m) => m b -> (b -> m c) -> (b -> t m a) -> t m a + - 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 :: IsStream t => (t m b -> t m b -> t m b) -> (a -> t m b) -> t m a -> t m b + - finally :: (IsStream t, MonadCatch m) => m b -> t m a -> t m a + + finally :: (IsStream t, MonadAsync m, MonadCatch m) => m b -> t m a -> t m a + - foldlM' :: Monad m => (b -> a -> m b) -> b -> SerialT m a -> m b + + foldlM' :: Monad m => (b -> a -> m b) -> m b -> SerialT m a -> m b + - postscanlM' :: (IsStream t, Monad m) => (b -> a -> m b) -> b -> t m a -> t m b + + postscanlM' :: (IsStream t, Monad m) => (b -> a -> m b) -> m b -> t m a -> t m b + - scanlM' :: (IsStream t, Monad m) => (b -> a -> m b) -> b -> t m a -> t m b + + scanlM' :: (IsStream t, Monad m) => (b -> a -> m b) -> m b -> t m a -> t m b + +# Renamed +~~ yieldM :: (Monad m, IsStream t) => m a -> t m a +++ fromEffect :: (Monad m, IsStream t) => m a -> t m a +~~ yield :: IsStream t => a -> t m a +++ fromPure :: IsStream t => a -> t m a +~~ concatUnfold :: (IsStream t, Monad m) => Unfold m a b -> t m a -> t m b +++ unfoldMany :: (IsStream t, Monad m) => Unfold m a b -> t m a -> t m b + +# Moved from "Streamly" module +## Fixity change +++ infixr 6 `ahead` +++ infixr 6 `async` +++ infixr 6 `parallel` +++ infixr 6 `serial` +++ infixr 6 `wAsync` +++ infixr 6 `wSerial` +## Renamed +~~ foldWith :: (IsStream t, Foldable f) => (t m a -> t m a -> t m a) -> f (t m a) -> t m a +++ concatFoldableWith :: (IsStream t, Foldable f) => (t m a -> t m a -> t m a) -> f (t m a) -> t m a +~~ forEachWith :: (IsStream t, Foldable f) => (t m b -> t m b -> t m b) -> f a -> (a -> t m b) -> t m b +++ concatForFoldableWith :: (IsStream t, Foldable f) => (t m b -> t m b -> t m b) -> f a -> (a -> t m b) -> t m b +~~ foldMapWith :: (IsStream t, Foldable f) => (t m b -> t m b -> t m b) -> (a -> t m b) -> f a -> t m b +++ concatMapFoldableWith :: (IsStream t, Foldable f) => (t m b -> t m b -> t m b) -> (a -> t m b) -> f a -> t m b +~~ aheadly :: IsStream t => AheadT m a -> t m a +++ fromAhead :: IsStream t => AheadT m a -> t m a +~~ asyncly :: IsStream t => AsyncT m a -> t m a +++ fromAsync :: IsStream t => AsyncT m a -> t m a +~~ parallely :: IsStream t => ParallelT m a -> t m a +++ fromParallel :: IsStream t => ParallelT m a -> t m a +~~ serially :: IsStream t => SerialT m a -> t m a +++ fromSerial :: IsStream t => SerialT m a -> t m a +~~ wAsyncly :: IsStream t => WAsyncT m a -> t m a +++ fromWAsync :: IsStream t => WAsyncT m a -> t m a +~~ wSerially :: IsStream t => WSerialT m a -> t m a +++ fromWSerial :: IsStream t => WSerialT m a -> t m a +~~ zipAsyncly :: IsStream t => ZipAsyncM m a -> t m a +++ fromZipAsync :: IsStream t => ZipAsyncM m a -> t m a +~~ zipSerially :: IsStream t => ZipSerialM m a -> t m a +++ fromZipSerial :: IsStream t => ZipSerialM m a -> t m a +## unchanged +++ class (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)) => IsStream t +++ data AheadT m a +++ data AsyncT m a +++ data ParallelT m a +++ data Rate Rate :: Double -> Double -> Double -> Int -> Rate +++ data SerialT m a +++ data WAsyncT m a +++ data WSerialT m a +++ data ZipAsyncM m a +++ data ZipSerialM m a +++ type Ahead = AheadT IO +++ type Async = AsyncT IO +++ type MonadAsync m = (MonadIO m, MonadBaseControl IO m, MonadThrow m) +++ type Parallel = ParallelT IO +++ type Serial = SerialT IO +++ type WAsync = WAsyncT IO +++ type WSerial = WSerialT IO +++ type ZipAsync = ZipAsyncM IO +++ type ZipSerial = ZipSerialM IO +++ (|$) :: (IsStream t, MonadAsync m) => (t m a -> t m b) -> t m a -> t m b +++ (|$.) :: (IsStream t, MonadAsync m) => (t m a -> m b) -> t m a -> m b +++ (|&) :: (IsStream t, MonadAsync m) => t m a -> (t m a -> t m b) -> t m b +++ (|&.) :: (IsStream t, MonadAsync m) => t m a -> (t m a -> m b) -> m b +++ [rateBuffer] :: Rate -> Int +++ [rateGoal] :: Rate -> Double +++ [rateHigh] :: Rate -> Double +++ [rateLow] :: Rate -> Double +++ adapt :: (IsStream t1, IsStream t2) => t1 m a -> t2 m a +++ ahead :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a +++ async :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a +++ avgRate :: IsStream t => Double -> t m a -> t m a +++ constRate :: IsStream t => Double -> t m a -> t m a +++ maxBuffer :: IsStream t => Int -> t m a -> t m a +++ maxRate :: IsStream t => Double -> t m a -> t m a +++ maxThreads :: IsStream t => Int -> t m a -> t m a +++ minRate :: IsStream t => Double -> t m a -> t m a +++ mkAsync :: (IsStream t, MonadAsync m) => t m a -> t m a +++ parallel :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a +++ rate :: IsStream t => Maybe Rate -> t m a -> t m a +++ serial :: IsStream t => t m a -> t m a -> t m a +++ wAsync :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a +++ wSerial :: IsStream t => t m a -> t m a -> t m a + +# Added +++ delay :: (IsStream t, MonadIO m) => Double -> t m a -> t m a +++ foldMany :: (IsStream t, Monad m) => Fold m a b -> t m a -> t m b +++ intercalate :: (IsStream t, Monad m) => Unfold m b c -> b -> t m b -> t m c +++ intercalateSuffix :: (IsStream t, Monad m) => Unfold m b c -> b -> t m b -> t m c +++ liftInner :: (Monad m, IsStream t, MonadTrans tr, Monad (tr m)) => t m a -> t (tr m) a +++ runReaderT :: (IsStream t, Monad m) => m s -> t (ReaderT s m) a -> t m a +++ runStateT :: Monad m => m s -> SerialT (StateT s m) a -> SerialT m (s, a) + +# Removed: documentation moved to streamly-docs module in docs dir +@@@ Streamly.Tutorial + +# Deprecated, renamed +~~~ Streamly.Data.Unicode.Stream +@@@ Streamly.Unicode.Stream +# Moved from Streamly.Data.Unicode.Stream +## Behavior changed +++ decodeUtf8 :: (Monad m, IsStream t) => t m Word8 -> t m Char +++ encodeLatin1 :: (IsStream t, Monad m) => t m Char -> t m Word8 +++ encodeUtf8 :: (Monad m, IsStream t) => t m Char -> t m Word8 +## Unchanged +++ decodeLatin1 :: (IsStream t, Monad m) => t m Word8 -> t m Char + +# Added +++ decodeUtf8' :: (Monad m, IsStream t) => t m Word8 -> t m Char +++ encodeLatin1' :: (IsStream t, Monad m) => t m Char -> t m Word8 +++ encodeStrings :: (MonadIO m, IsStream t) => (SerialT m Char -> SerialT m Word8) -> t m String -> t m (Array Word8) +++ encodeUtf8' :: (Monad m, IsStream t) => t m Char -> t m Word8 diff --git a/docs/User/Project/ApiChangelogs/0.8.0-0.8.1.txt b/docs/User/Project/ApiChangelogs/0.8.0-0.8.1.txt new file mode 100644 --- /dev/null +++ b/docs/User/Project/ApiChangelogs/0.8.0-0.8.1.txt @@ -0,0 +1,11 @@ +# API diff as generated by cabal-diff with minor edits. +# ~~~ means deprecated module +# ~~ means deprecated symbol + +#---------------------------- +# Changes from 0.8.0 to 0.8.1 +#---------------------------- + +@@@ Streamly.FileSystem.Handle +++ getChunk :: MonadIO m => Int -> Handle -> m (Array Word8) +++ putChunk :: (MonadIO m, Storable a) => Handle -> Array a -> m () diff --git a/docs/User/Project/ApiChangelogs/0.8.3-0.9.0.txt b/docs/User/Project/ApiChangelogs/0.8.3-0.9.0.txt new file mode 100644 --- /dev/null +++ b/docs/User/Project/ApiChangelogs/0.8.3-0.9.0.txt @@ -0,0 +1,175 @@ +--------------------------------- +Terminology +--------------------------------- + +[A]: Added +[R]: Removed +[C]: Changed +[D]: Deprecated +[O]: Old +[N]: New + +--------------------------------- +Difference +--------------------------------- + +[R] Streamly.Unicode.Stream +[D] Streamly.Prelude + [A] toStreamK :: IsStream t => t m a -> StreamK m a + [A] toStream :: (IsStream t, Monad m) => t m a -> Stream m a + [C] mergeBy + [O] mergeBy :: (IsStream t, Monad m) => (a -> a -> Ordering) -> t m a -> t m a -> t m a + [N] mergeBy :: IsStream t => (a -> a -> Ordering) -> t m a -> t m a -> t m a + [A] fromStreamK :: IsStream t => StreamK m a -> t m a + [A] fromStream :: (IsStream t, Monad m) => Stream m a -> t m a +[C] Streamly.Network.Socket + [D] writeWithBufferOf :: MonadIO m => Int -> Socket -> Fold m Word8 () + [A] writeWith :: MonadIO m => Int -> Socket -> Fold m Word8 () + [D] writeChunksWithBufferOf :: (MonadIO m, Unbox a) => Int -> Socket -> Fold m (Array a) () + [A] writeChunksWith :: (MonadIO m, Unbox a) => Int -> Socket -> Fold m (Array a) () + [C] writeChunks + [O] writeChunks :: (MonadIO m, Storable a) => Socket -> Fold m (Array a) () + [N] writeChunks :: (MonadIO m, Unbox a) => Socket -> Fold m (Array a) () + [D] writeChunk :: Unbox a => Socket -> Array a -> IO () + [A] readerWith :: MonadIO m => Unfold m (Int, Socket) Word8 + [A] reader :: MonadIO m => Unfold m Socket Word8 + [D] readWithBufferOf :: MonadIO m => Unfold m (Int, Socket) Word8 + [D] readChunksWithBufferOf :: MonadIO m => Unfold m (Int, Socket) (Array Word8) + [D] readChunks :: MonadIO m => Unfold m Socket (Array Word8) + [D] readChunk :: Int -> Socket -> IO (Array Word8) + [D] read :: MonadIO m => Unfold m Socket Word8 + [A] putChunk :: Unbox a => Socket -> Array a -> IO () + [A] getChunk :: Int -> Socket -> IO (Array Word8) + [A] chunkReaderWith :: MonadIO m => Unfold m (Int, Socket) (Array Word8) + [A] chunkReader :: MonadIO m => Unfold m Socket (Array Word8) + [A] acceptor :: MonadIO m => Unfold m (Int, SockSpec, SockAddr) Socket + [D] accept :: MonadIO m => Unfold m (Int, SockSpec, SockAddr) Socket +[C] Streamly.Network.Inet.TCP + [A] acceptorOnPortLocal :: MonadIO m => Unfold m PortNumber Socket + [A] acceptorOnPort :: MonadIO m => Unfold m PortNumber Socket + [A] acceptorOnAddr :: MonadIO m => Unfold m ((Word8, Word8, Word8, Word8), PortNumber) Socket + [D] acceptOnPortLocal :: MonadIO m => Unfold m PortNumber Socket + [D] acceptOnPort :: MonadIO m => Unfold m PortNumber Socket + [D] acceptOnAddr :: MonadIO m => Unfold m ((Word8, Word8, Word8, Word8), PortNumber) Socket +[R] Streamly.FileSystem.Handle +[R] Streamly.Data.Unfold +[A] Streamly.Data.Stream.Prelude + [A] StopWhen + [A] FirstStops :: StopWhen + [A] AnyStops :: StopWhen + [A] AllStop :: StopWhen + [A] Rate + [A] [rateLow] :: Rate -> Double + [A] [rateHigh] :: Rate -> Double + [A] [rateGoal] :: Rate -> Double + [A] [rateBuffer] :: Rate -> Int + [A] Rate :: Double -> Double -> Double -> Int -> Rate + [A] Config + [A] type MonadAsync m = (MonadIO m, MonadBaseControl IO m, MonadThrow m) + [A] tapCount :: MonadAsync m => (a -> Bool) -> (Stream m Int -> m b) -> Stream m a -> Stream m a + [A] takeInterval :: MonadAsync m => Double -> Stream m a -> Stream m a + [A] stopWhen :: StopWhen -> Config -> Config + [A] sampleIntervalStart :: MonadAsync m => Double -> Stream m a -> Stream m a + [A] sampleIntervalEnd :: MonadAsync m => Double -> Stream m a -> Stream m a + [A] sampleBurstStart :: MonadAsync m => Double -> Stream m a -> Stream m a + [A] sampleBurstEnd :: MonadAsync m => Double -> Stream m a -> Stream m a + [A] rate :: Maybe Rate -> Config -> Config + [A] parZipWithM :: MonadAsync m => (Config -> Config) -> (a -> b -> m c) -> Stream m a -> Stream m b -> Stream m c + [A] parZipWith :: MonadAsync m => (Config -> Config) -> (a -> b -> c) -> Stream m a -> Stream m b -> Stream m c + [A] parSequence :: MonadAsync m => (Config -> Config) -> Stream m (m a) -> Stream m a + [A] parReplicateM :: MonadAsync m => (Config -> Config) -> Int -> m a -> Stream m a + [A] parRepeatM :: MonadAsync m => (Config -> Config) -> m a -> Stream m a + [A] parMergeByM :: MonadAsync m => (Config -> Config) -> (a -> a -> m Ordering) -> Stream m a -> Stream m a -> Stream m a + [A] parMergeBy :: MonadAsync m => (Config -> Config) -> (a -> a -> Ordering) -> Stream m a -> Stream m a -> Stream m a + [A] parMapM :: MonadAsync m => (Config -> Config) -> (a -> m b) -> Stream m a -> Stream m b + [A] parList :: MonadAsync m => (Config -> Config) -> [Stream m a] -> Stream m a + [A] parEval :: MonadAsync m => (Config -> Config) -> Stream m a -> Stream m a + [A] parConcatMap :: MonadAsync m => (Config -> Config) -> (a -> Stream m b) -> Stream m a -> Stream m b + [A] parConcatIterate :: MonadAsync m => (Config -> Config) -> (a -> Stream m a) -> Stream m a -> Stream m a + [A] parConcat :: MonadAsync m => (Config -> Config) -> Stream m (Stream m a) -> Stream m a + [A] parApply :: MonadAsync m => (Config -> Config) -> Stream m (a -> b) -> Stream m a -> Stream m b + [A] ordered :: Bool -> Config -> Config + [A] minRate :: Double -> Config -> Config + [A] maxThreads :: Int -> Config -> Config + [A] maxRate :: Double -> Config -> Config + [A] maxBuffer :: Int -> Config -> Config + [A] intervalsOf :: MonadAsync m => Double -> Fold m a b -> Stream m a -> Stream m b + [A] interleaved :: Bool -> Config -> Config + [A] interject :: MonadAsync m => m a -> Double -> Stream m a -> Stream m a + [A] inspect :: Bool -> Config -> Config + [A] fromCallback :: MonadAsync m => ((a -> m ()) -> m ()) -> Stream m a + [A] finally :: (MonadAsync m, MonadCatch m) => m b -> Stream m a -> Stream m a + [A] eager :: Bool -> Config -> Config + [A] dropInterval :: MonadAsync m => Double -> Stream m a -> Stream m a + [A] constRate :: Double -> Config -> Config + [A] bracket :: (MonadAsync m, MonadCatch m) => m b -> (b -> m c) -> (b -> Stream m a) -> Stream m a + [A] avgRate :: Double -> Config -> Config + [A] after :: (MonadIO m, MonadBaseControl IO m) => m b -> Stream m a -> Stream m a +[A] Streamly.Data.Stream.MkType + [A] class Monad m => MonadReader r (m :: Type -> Type) | m -> r + [A] class MonadTrans (t :: Type -> Type -> Type -> Type) + [A] class Read a + [A] class IsString a + [A] class IsList l + [A] Identity + [A] throwM :: (MonadThrow m, Exception e) => e -> m a + [A] readsPrec :: Read a => Int -> ReadS a + [A] reader :: MonadReader r m => (r -> a) -> m a + [A] readPrec :: Read a => ReadPrec a + [A] readListPrec :: Read a => ReadPrec [a] + [A] readList :: Read a => ReadS [a] + [A] mkZipType :: String -> String -> Bool -> Q [Dec] + [A] mkCrossType :: String -> String -> Bool -> Q [Dec] + [A] local :: MonadReader r m => (r -> r) -> m a -> m a + [A] liftIO :: MonadIO m => IO a -> m a + [A] lift :: (MonadTrans t, Monad m) => m a -> t m a + [A] ask :: MonadReader r m => m r + [A] ap :: Monad m => m (a -> b) -> m a -> m b +[D] Streamly.Data.Fold.Tee + [C] Tee + [A] [unTee] :: Tee (m :: Type -> Type) a b -> Fold m a b + [R] [toFold] :: Tee m a b -> Fold m a b + [C] Tee + [O] Tee :: Fold m a b -> Tee m a b + [N] Tee :: Fold m a b -> Tee (m :: Type -> Type) a b + [A] toFold :: forall (m :: Type -> Type) a b. Tee m a b -> Fold m a b +[R] Streamly.Data.Fold +[D] Streamly.Data.Array.Foreign + [A] Control.DeepSeq.NFData1 + [A] instance Control.DeepSeq.NFData1 Streamly.Internal.Data.Array.Type.Array + [A] Control.DeepSeq.NFData + [A] instance Control.DeepSeq.NFData (Streamly.Internal.Data.Array.Type.Array a) + [C] writeN + [O] writeN :: forall m a. (MonadIO m, Storable a) => Int -> Fold m a (Array a) + [N] writeN :: forall (m :: Type -> Type) a. (MonadIO m, Unbox a) => Int -> Fold m a (Array a) + [C] writeLastN + [O] writeLastN :: (Storable a, MonadIO m) => Int -> Fold m a (Array a) + [N] writeLastN :: forall a (m :: Type -> Type). (Storable a, Unbox a, MonadIO m) => Int -> Fold m a (Array a) + [C] write + [O] write :: forall m a. (MonadIO m, Storable a) => Fold m a (Array a) + [N] write :: forall (m :: Type -> Type) a. (MonadIO m, Unbox a) => Fold m a (Array a) + [C] toList + [O] toList :: Storable a => Array a -> [a] + [N] toList :: Unbox a => Array a -> [a] + [C] readRev + [O] readRev :: forall m a. (Monad m, Storable a) => Unfold m (Array a) a + [N] readRev :: forall (m :: Type -> Type) a. (Monad m, Unbox a) => Array a -> Stream m a + [C] read + [O] read :: forall m a. (Monad m, Storable a) => Unfold m (Array a) a + [N] read :: forall (m :: Type -> Type) a. (Monad m, Unbox a) => Array a -> Stream m a + [C] length + [O] length :: forall a. Storable a => Array a -> Int + [N] length :: Unbox a => Array a -> Int + [C] getIndex + [O] getIndex :: forall a. Storable a => Array a -> Int -> Maybe a + [N] getIndex :: Unbox a => Int -> Array a -> Maybe a + [C] fromListN + [O] fromListN :: Storable a => Int -> [a] -> Array a + [N] fromListN :: Unbox a => Int -> [a] -> Array a + [C] fromList + [O] fromList :: Storable a => [a] -> Array a + [N] fromList :: Unbox a => [a] -> Array a + [C] cast + [O] cast :: forall a b. Storable b => Array a -> Maybe (Array b) + [N] cast :: forall a b. Unbox b => Array a -> Maybe (Array b) +[R] Streamly.Console.Stdio diff --git a/docs/User/Project/ApiChangelogs/0.9.0-0.10.0.txt b/docs/User/Project/ApiChangelogs/0.9.0-0.10.0.txt new file mode 100644 --- /dev/null +++ b/docs/User/Project/ApiChangelogs/0.9.0-0.10.0.txt @@ -0,0 +1,424 @@ +--------------------------------- +API Annotations +--------------------------------- + +[A] : Added +[R] : Removed +[C] : Changed +[O] : Old definition +[N] : New definition +[D] : Deprecated + +--------------------------------- +API diff +--------------------------------- + +[C] Streamly.Network.Socket + [A] readWith :: MonadIO m => Int -> Socket -> Stream m Word8 + [A] readChunksWith :: MonadIO m => Int -> Socket -> Stream m (Array Word8) +[C] Streamly.Network.Inet.TCP + [D] acceptorOnPortLocal :: MonadIO m => Unfold m PortNumber Socket + [D] acceptorOnPort :: MonadIO m => Unfold m PortNumber Socket + [A] acceptorLocal :: MonadIO m => Unfold m PortNumber Socket + [A] acceptor :: MonadIO m => Unfold m PortNumber Socket + [A] acceptOnAddrWith :: MonadIO m => [(SocketOption, Int)] -> (Word8, Word8, Word8, Word8) -> PortNumber -> Stream m Socket + [A] acceptLocal :: MonadIO m => PortNumber -> Stream m Socket + [A] accept :: MonadIO m => PortNumber -> Stream m Socket +[C] Streamly.Data.Stream.Prelude + [D] tapCount :: MonadAsync m => (a -> Bool) -> (Stream m Int -> m b) -> Stream m a -> Stream m a + [A] parTapCount :: MonadAsync m => (a -> Bool) -> (Stream m Int -> m b) -> Stream m a -> Stream m a +[A] Streamly.Data.Fold.Prelude + [A] Config + [A] toHashMapIO :: (MonadIO m, Hashable k, Ord k) => (a -> k) -> Fold m a b -> Fold m a (HashMap k b) + [A] parEval :: MonadAsync m => (Config -> Config) -> Fold m a b -> Fold m a b + [A] maxBuffer :: Int -> Config -> Config + [A] inspect :: Bool -> Config -> Config + [A] boundThreads :: Bool -> Config -> Config + +--------------------------------- +Internal API diff +--------------------------------- + +[C] Streamly.Internal.Network.Inet.TCP + [A] acceptorWith :: MonadIO m => [(SocketOption, Int)] -> Unfold m PortNumber Socket + [R] acceptorOnPortWith :: MonadIO m => [(SocketOption, Int)] -> Unfold m PortNumber Socket + [D] acceptorOnPortLocal :: MonadIO m => Unfold m PortNumber Socket + [D] acceptorOnPort :: MonadIO m => Unfold m PortNumber Socket + [A] acceptorLocal :: MonadIO m => Unfold m PortNumber Socket + [A] acceptor :: MonadIO m => Unfold m PortNumber Socket + [R] acceptOnPortLocal :: MonadIO m => PortNumber -> Stream m Socket + [R] acceptOnPort :: MonadIO m => PortNumber -> Stream m Socket + [A] acceptLocal :: MonadIO m => PortNumber -> Stream m Socket + [A] accept :: MonadIO m => PortNumber -> Stream m Socket +[R] Streamly.Internal.Data.Unfold.SVar +[A] Streamly.Internal.Data.Unfold.Prelude + [A] gbracket :: MonadRunInIO m => (a -> m c) -> (c -> m d) -> Unfold m (c, e) b -> (forall s. m s -> m (Either e s)) -> Unfold m c b -> Unfold m a b + [A] fromSVar :: MonadAsync m => Unfold m (SVar t m a) a + [A] fromProducer :: MonadAsync m => Unfold m (SVar t m a) a + [A] finally :: (MonadAsync m, MonadCatch m) => (a -> m c) -> Unfold m a b -> Unfold m a b + [A] bracket :: (MonadAsync m, MonadCatch m) => (a -> m c) -> (c -> m d) -> Unfold m c b -> Unfold m a b + [A] after :: MonadRunInIO m => (a -> m c) -> Unfold m a b -> Unfold m a b +[R] Streamly.Internal.Data.Unfold.Exception +[R] Streamly.Internal.Data.Stream.Zip.Concurrent +[D] Streamly.Internal.Data.Stream.Zip + [C] GHC.Base.Functor + [A] instance GHC.Base.Monad m => GHC.Base.Functor (Streamly.Internal.Data.Stream.Zip.ZipConcurrent m) + [C] GHC.Base.Applicative + [A] instance Streamly.Internal.Control.Concurrent.MonadAsync m => GHC.Base.Applicative (Streamly.Internal.Data.Stream.Zip.ZipConcurrent m) + [A] ZipConcurrent + [A] [getZipConcurrent] :: ZipConcurrent m a -> Stream m a + [A] ZipConcurrent :: Stream m a -> ZipConcurrent m a +[R] Streamly.Internal.Data.Stream.Time +[R] Streamly.Internal.Data.Stream.SVar.Generate +[R] Streamly.Internal.Data.Stream.SVar.Eliminate +[A] Streamly.Internal.Data.Stream.Prelude + [A] StopWhen + [A] FirstStops :: StopWhen + [A] AnyStops :: StopWhen + [A] AllStop :: StopWhen + [A] Rate + [A] [rateLow] :: Rate -> Double + [A] [rateHigh] :: Rate -> Double + [A] [rateGoal] :: Rate -> Double + [A] [rateBuffer] :: Rate -> Int + [A] Rate :: Double -> Double -> Double -> Int -> Rate + [A] Config + [A] Channel + [A] [yieldRateInfo] :: Channel m a -> Maybe YieldRateInfo + [A] [workerThreads] :: Channel m a -> IORef (Set ThreadId) + [A] [workerStopMVar] :: Channel m a -> MVar () + [A] [workerCount] :: Channel m a -> IORef Int + [A] [workLoop] :: Channel m a -> Maybe WorkerInfo -> m () + [A] [svarStats] :: Channel m a -> SVarStats + [A] [svarRef] :: Channel m a -> Maybe (IORef ()) + [A] [svarMrun] :: Channel m a -> RunInIO m + [A] [svarInspectMode] :: Channel m a -> Bool + [A] [svarCreator] :: Channel m a -> ThreadId + [A] [remainingWork] :: Channel m a -> Maybe (IORef Count) + [A] [readOutputQ] :: Channel m a -> m [ChildEvent a] + [A] [postProcess] :: Channel m a -> m Bool + [A] [outputQueue] :: Channel m a -> IORef ([ChildEvent a], Int) + [A] [outputDoorBell] :: Channel m a -> MVar () + [A] [maxWorkerLimit] :: Channel m a -> Limit + [A] [maxBufferLimit] :: Channel m a -> Limit + [A] [isWorkDone] :: Channel m a -> IO Bool + [A] [isQueueDone] :: Channel m a -> IO Bool + [A] [enqueue] :: Channel m a -> Bool -> (RunInIO m, StreamK m a) -> IO () + [A] [eagerDispatch] :: Channel m a -> m () + [A] [doorBellOnWorkQ] :: Channel m a -> IORef Bool + [A] [accountThread] :: Channel m a -> ThreadId -> m () + [A] Channel :: RunInIO m -> IORef ([ChildEvent a], Int) -> MVar () -> m [ChildEvent a] -> m Bool -> Limit -> Limit -> Maybe (IORef Count) -> Maybe YieldRateInfo -> (Bool -> (RunInIO m, StreamK m a) -> IO ()) -> m () -> IO Bool -> IO Bool -> IORef Bool -> (Maybe WorkerInfo -> m ()) -> IORef (Set ThreadId) -> IORef Int -> (ThreadId -> m ()) -> MVar () -> Maybe (IORef ()) -> SVarStats -> Bool -> ThreadId -> Channel m a + [A] type MonadAsync m = (MonadIO m, MonadBaseControl IO m, MonadThrow m) + [A] yield :: Channel m a -> Maybe WorkerInfo -> a -> IO Bool + [A] withChannelK :: MonadAsync m => (Config -> Config) -> StreamK m a -> (Channel m b -> StreamK m a -> StreamK m b) -> StreamK m b + [A] withChannel :: MonadAsync m => (Config -> Config) -> Stream m a -> (Channel m b -> Stream m a -> Stream m b) -> Stream m b + [A] toChannelK :: MonadRunInIO m => Channel m a -> StreamK m a -> m () + [A] toChannel :: MonadRunInIO m => Channel m a -> Stream m a -> m () + [A] ticksRate :: MonadAsync m => Rate -> Stream m () + [A] ticks :: MonadIO m => Double -> Stream m () + [A] takeLastInterval :: Double -> Stream m a -> Stream m a + [A] takeInterval :: MonadAsync m => Double -> Stream m a -> Stream m a + [A] stopWhen :: StopWhen -> Config -> Config + [A] stopChannel :: MonadIO m => Channel m a -> m () + [A] stop :: Channel m a -> Maybe WorkerInfo -> IO () + [A] startChannel :: MonadRunInIO m => Channel m a -> m () + [A] sendWorkerWait :: MonadIO m => Bool -> (Channel m a -> IO ()) -> (Channel m a -> m Bool) -> Channel m a -> m () + [A] sendWorkerDelayPaced :: Channel m a -> IO () + [A] sendWorkerDelay :: Channel m a -> IO () + [A] sampleIntervalStart :: MonadAsync m => Double -> Stream m a -> Stream m a + [A] sampleIntervalEnd :: MonadAsync m => Double -> Stream m a -> Stream m a + [A] sampleBurstStart :: MonadAsync m => Double -> Stream m a -> Stream m a + [A] sampleBurstEnd :: MonadAsync m => Double -> Stream m a -> Stream m a + [A] sampleBurst :: MonadAsync m => Bool -> Double -> Stream m a -> Stream m a + [A] retryD :: forall e m a. (Exception e, Ord e, MonadCatch m) => Map e Int -> (e -> Stream m a) -> Stream m a -> Stream m a + [A] retry :: (MonadCatch m, Exception e, Ord e) => Map e Int -> (e -> Stream m a) -> Stream m a -> Stream m a + [A] readOutputQPaced :: MonadRunInIO m => Channel m a -> m [ChildEvent a] + [A] readOutputQBounded :: MonadRunInIO m => Bool -> Channel m a -> m [ChildEvent a] + [A] rate :: Maybe Rate -> Config -> Config + [A] pushWorker :: MonadRunInIO m => Count -> Channel m a -> m () + [A] postProcessPaced :: MonadRunInIO m => Channel m a -> m Bool + [A] postProcessBounded :: MonadRunInIO m => Channel m a -> m Bool + [A] periodic :: MonadIO m => m a -> Double -> Stream m a + [A] parZipWithM :: MonadAsync m => (Config -> Config) -> (a -> b -> m c) -> Stream m a -> Stream m b -> Stream m c + [A] parZipWith :: MonadAsync m => (Config -> Config) -> (a -> b -> c) -> Stream m a -> Stream m b -> Stream m c + [A] parTwo :: MonadAsync m => (Config -> Config) -> Stream m a -> Stream m a -> Stream m a + [A] parTapCount :: MonadAsync m => (a -> Bool) -> (Stream m Int -> m b) -> Stream m a -> Stream m a + [A] parSequence :: MonadAsync m => (Config -> Config) -> Stream m (m a) -> Stream m a + [A] parReplicateM :: MonadAsync m => (Config -> Config) -> Int -> m a -> Stream m a + [A] parRepeatM :: MonadAsync m => (Config -> Config) -> m a -> Stream m a + [A] parMergeByM :: MonadAsync m => (Config -> Config) -> (a -> a -> m Ordering) -> Stream m a -> Stream m a -> Stream m a + [A] parMergeBy :: MonadAsync m => (Config -> Config) -> (a -> a -> Ordering) -> Stream m a -> Stream m a -> Stream m a + [A] parMapM :: MonadAsync m => (Config -> Config) -> (a -> m b) -> Stream m a -> Stream m b + [A] parListOrdered :: MonadAsync m => [Stream m a] -> Stream m a + [A] parListLazy :: MonadAsync m => [Stream m a] -> Stream m a + [A] parListInterleaved :: MonadAsync m => [Stream m a] -> Stream m a + [A] parListEagerMin :: MonadAsync m => [Stream m a] -> Stream m a + [A] parListEagerFst :: MonadAsync m => [Stream m a] -> Stream m a + [A] parListEager :: MonadAsync m => [Stream m a] -> Stream m a + [A] parList :: MonadAsync m => (Config -> Config) -> [Stream m a] -> Stream m a + [A] parEval :: MonadAsync m => (Config -> Config) -> Stream m a -> Stream m a + [A] parConcatMap :: MonadAsync m => (Config -> Config) -> (a -> Stream m b) -> Stream m a -> Stream m b + [A] parConcatIterate :: MonadAsync m => (Config -> Config) -> (a -> Stream m a) -> Stream m a -> Stream m a + [A] parConcat :: MonadAsync m => (Config -> Config) -> Stream m (Stream m a) -> Stream m a + [A] parApply :: MonadAsync m => (Config -> Config) -> Stream m (a -> b) -> Stream m a -> Stream m b + [A] ordered :: Bool -> Config -> Config + [A] newInterleaveChannel :: MonadAsync m => (Config -> Config) -> m (Channel m a) + [A] newChannel :: MonadAsync m => (Config -> Config) -> m (Channel m a) + [A] newAppendChannel :: MonadRunInIO m => (Config -> Config) -> m (Channel m a) + [A] minRate :: Double -> Config -> Config + [A] maxThreads :: Int -> Config -> Config + [A] maxRate :: Double -> Config -> Config + [A] maxBuffer :: Int -> Config -> Config + [A] intervalsOf :: MonadAsync m => Double -> Fold m a b -> Stream m a -> Stream m b + [A] interleaved :: Bool -> Config -> Config + [A] interject :: MonadAsync m => m a -> Double -> Stream m a -> Stream m a + [A] inspect :: Bool -> Config -> Config + [A] groupsOfTimeout :: MonadAsync m => Int -> Double -> Fold m a b -> Stream m a -> Stream m b + [A] getStopWhen :: Config -> StopWhen + [A] fromChannelK :: MonadAsync m => Channel m a -> StreamK m a + [A] fromChannel :: MonadAsync m => Channel m a -> Stream m a + [A] fromCallback :: MonadAsync m => ((a -> m ()) -> m ()) -> Stream m a + [A] finally :: (MonadAsync m, MonadCatch m) => m b -> Stream m a -> Stream m a + [A] eager :: Bool -> Config -> Config + [A] dumpSVar :: Channel m a -> IO String + [A] dropLastInterval :: Int -> Stream m a -> Stream m a + [A] dropInterval :: MonadAsync m => Double -> Stream m a -> Stream m a + [A] dispatchWorkerPaced :: MonadRunInIO m => Channel m a -> m Bool + [A] dispatchWorker :: MonadRunInIO m => Count -> Channel m a -> m Bool + [A] defaultConfig :: Config + [A] constRate :: Double -> Config -> Config + [A] classifySessionsOf :: (MonadAsync m, Ord k) => (Int -> m Bool) -> Double -> Fold m a b -> Stream m (AbsTime, (k, a)) -> Stream m (k, b) + [A] classifySessionsByGeneric :: forall m f a b. (MonadAsync m, IsMap f) => Proxy (f :: Type -> Type) -> Double -> Bool -> (Int -> m Bool) -> Double -> Fold m a b -> Stream m (AbsTime, (Key f, a)) -> Stream m (Key f, b) + [A] classifySessionsBy :: (MonadAsync m, Ord k) => Double -> Bool -> (Int -> m Bool) -> Double -> Fold m a b -> Stream m (AbsTime, (k, a)) -> Stream m (k, b) + [A] classifyKeepAliveSessions :: (MonadAsync m, Ord k) => (Int -> m Bool) -> Double -> Fold m a b -> Stream m (AbsTime, (k, a)) -> Stream m (k, b) + [A] bufferOldestN :: Int -> Stream m a -> Stream m a + [A] bufferLatestN :: Int -> Stream m a -> Stream m a + [A] bufferLatest :: Stream m a -> Stream m (Maybe a) + [A] bracket3D :: (MonadAsync m, MonadCatch m) => m b -> (b -> m c) -> (b -> m d) -> (b -> m e) -> (b -> Stream m a) -> Stream m a + [A] bracket3 :: (MonadAsync m, MonadCatch m) => m b -> (b -> m c) -> (b -> m d) -> (b -> m e) -> (b -> Stream m a) -> Stream m a + [A] bracket :: (MonadAsync m, MonadCatch m) => m b -> (b -> m c) -> (b -> Stream m a) -> Stream m a + [A] avgRate :: Double -> Config -> Config + [A] afterD :: MonadRunInIO m => m b -> Stream m a -> Stream m a + [A] after :: (MonadIO m, MonadBaseControl IO m) => m b -> Stream m a -> Stream m a +[R] Streamly.Internal.Data.Stream.Exception.Lifted +[R] Streamly.Internal.Data.Stream.Concurrent.Channel.Type +[R] Streamly.Internal.Data.Stream.Concurrent.Channel.Operations +[R] Streamly.Internal.Data.Stream.Concurrent.Channel.Interleave +[R] Streamly.Internal.Data.Stream.Concurrent.Channel.Dispatcher +[R] Streamly.Internal.Data.Stream.Concurrent.Channel.Consumer +[R] Streamly.Internal.Data.Stream.Concurrent.Channel.Append +[R] Streamly.Internal.Data.Stream.Concurrent.Channel +[R] Streamly.Internal.Data.Stream.Concurrent +[R] Streamly.Internal.Data.Stream.Channel.Worker +[R] Streamly.Internal.Data.Stream.Channel.Types +[R] Streamly.Internal.Data.Stream.Channel.Dispatcher +[R] Streamly.Internal.Data.SVar.Worker +[R] Streamly.Internal.Data.SVar.Pull +[R] Streamly.Internal.Data.SVar.Dispatch +[D] Streamly.Internal.Data.SVar + [A] Work + [A] PartialWorker :: Count -> Work + [A] ManyWorkers :: Int -> Count -> Work + [A] BlockWait :: NanoSecond64 -> Work + [A] workerUpdateLatency :: YieldRateInfo -> WorkerInfo -> IO () + [A] workerRateControl :: SVar t m a -> YieldRateInfo -> WorkerInfo -> IO Bool + [A] withDiagMVar :: SVar t m a -> String -> IO () -> IO () + [A] updateYieldCount :: WorkerInfo -> IO Count + [A] sendYield :: SVar t m a -> Maybe WorkerInfo -> ChildEvent a -> IO Bool + [A] sendWorkerWait :: MonadAsync m => (SVar t m a -> IO ()) -> (SVar t m a -> m Bool) -> SVar t m a -> m () + [A] sendWorkerDelayPaced :: SVar t m a -> IO () + [A] sendWorkerDelay :: SVar t m a -> IO () + [A] sendToProducer :: SVar t m a -> ChildEvent a -> IO Int + [A] sendStopToProducer :: MonadIO m => SVar t m a -> m () + [A] sendStop :: SVar t m a -> Maybe WorkerInfo -> IO () + [A] sendFirstWorker :: MonadAsync m => SVar t m a -> t m a -> m (SVar t m a) + [A] send :: SVar t m a -> ChildEvent a -> IO Int + [A] ringDoorBell :: SVar t m a -> IO () + [A] resetBufferLimit :: SVar t m a -> IO () + [A] recordMaxWorkers :: MonadIO m => SVar t m a -> m () + [A] readOutputQRaw :: SVar t m a -> IO ([ChildEvent a], Int) + [A] readOutputQPaced :: MonadAsync m => SVar t m a -> m [ChildEvent a] + [A] readOutputQBounded :: MonadAsync m => SVar t m a -> m [ChildEvent a] + [A] readOutputQBasic :: IORef ([ChildEvent a], Int) -> IO ([ChildEvent a], Int) + [A] pushWorkerPar :: MonadAsync m => SVar t m a -> (Maybe WorkerInfo -> m ()) -> m () + [A] pushWorker :: MonadAsync m => Count -> SVar t m a -> m () + [A] printSVar :: SVar t m a -> String -> IO () + [A] postProcessPaced :: MonadAsync m => SVar t m a -> m Bool + [A] postProcessBounded :: MonadAsync m => SVar t m a -> m Bool + [A] modifyThread :: MonadIO m => SVar t m a -> ThreadId -> m () + [A] minThreadDelay :: NanoSecond64 + [A] isBeyondMaxRate :: SVar t m a -> YieldRateInfo -> IO Bool + [A] incrementYieldLimit :: SVar t m a -> IO () + [A] incrementBufferLimit :: SVar t m a -> IO () + [A] handleFoldException :: SVar t m a -> SomeException -> IO () + [A] handleChildException :: SVar t m a -> SomeException -> IO () + [A] estimateWorkers :: Limit -> Count -> Count -> NanoSecond64 -> NanoSecond64 -> NanoSecond64 -> LatencyRange -> Work + [A] dumpSVar :: SVar t m a -> IO String + [A] dispatchWorkerPaced :: MonadAsync m => SVar t m a -> m Bool + [A] dispatchWorker :: MonadAsync m => Count -> SVar t m a -> m Bool + [A] delThread :: MonadIO m => SVar t m a -> ThreadId -> m () + [A] decrementYieldLimit :: SVar t m a -> IO Bool + [A] decrementBufferLimit :: SVar t m a -> IO () + [A] collectLatency :: SVar t m a -> YieldRateInfo -> Bool -> IO (Count, AbsTime, NanoSecond64) + [A] cleanupSVarFromWorker :: SVar t m a -> IO () + [A] cleanupSVar :: SVar t m a -> IO () + [A] allThreadsDone :: MonadIO m => SVar t m a -> m Bool +[C] Streamly.Internal.Data.IsMap.HashMap + [C] Streamly.Internal.Data.IsMap.IsMap + [C] (Data.HashMap.Internal.HashMap k) + [O] instance (Data.Hashable.Class.Hashable k, GHC.Classes.Eq k) => Streamly.Internal.Data.IsMap.IsMap (Data.HashMap.Internal.HashMap k) + [N] instance Data.Hashable.Class.Hashable k => Streamly.Internal.Data.IsMap.IsMap (Data.HashMap.Internal.HashMap k) +[C] Streamly.Internal.Data.IOFinalizer.Lifted + [C] IOFinalizer +[R] Streamly.Internal.Data.Fold.SVar +[A] Streamly.Internal.Data.Fold.Prelude + [A] Config + [A] Channel + [A] [svarStats] :: Channel m a b -> SVarStats + [A] [svarRef] :: Channel m a b -> Maybe (IORef ()) + [A] [svarInspectMode] :: Channel m a b -> Bool + [A] [svarCreator] :: Channel m a b -> ThreadId + [A] [readOutputQ] :: Channel m a b -> m [ChildEvent a] + [A] [outputQueue] :: Channel m a b -> IORef ([ChildEvent a], Int) + [A] [outputQueueFromConsumer] :: Channel m a b -> IORef ([ChildEvent b], Int) + [A] [outputDoorBell] :: Channel m a b -> MVar () + [A] [outputDoorBellFromConsumer] :: Channel m a b -> MVar () + [A] [maxBufferLimit] :: Channel m a b -> Limit + [A] [bufferSpaceDoorBell] :: Channel m a b -> MVar () + [A] Channel :: IORef ([ChildEvent a], Int) -> Limit -> MVar () -> m [ChildEvent a] -> IORef ([ChildEvent b], Int) -> MVar () -> MVar () -> Maybe (IORef ()) -> SVarStats -> Bool -> ThreadId -> Channel m a b + [A] writeLimited :: MonadIO m => SVar t m a -> Maybe WorkerInfo -> Fold m a () + [A] write :: MonadIO m => SVar t m a -> Maybe WorkerInfo -> Fold m a () + [A] takeInterval :: MonadAsync m => Double -> Fold m a b -> Fold m a b + [A] sendToWorker :: MonadAsync m => Channel m a b -> a -> m (Maybe b) + [A] parEval :: MonadAsync m => (Config -> Config) -> Fold m a b -> Fold m a b + [A] newChannel :: MonadRunInIO m => (Config -> Config) -> Fold m a b -> m (Channel m a b) + [A] maxBuffer :: Int -> Config -> Config + [A] intervalsOf :: MonadAsync m => Double -> Fold m a b -> Fold m b c -> Fold m a c + [A] inspect :: Bool -> Config -> Config + [A] dumpSVar :: Channel m a b -> IO String + [A] checkFoldStatus :: MonadAsync m => Channel m a b -> m (Maybe b) + [A] boundThreads :: Bool -> Config -> Config +[R] Streamly.Internal.Data.Fold.Concurrent.Channel.Type +[R] Streamly.Internal.Data.Fold.Concurrent.Channel +[R] Streamly.Internal.Data.Fold.Concurrent +[R] Streamly.Internal.Data.Fold.Async +[A] Streamly.Internal.Data.Channel + [A] YieldRateInfo + [A] [workerPollingInterval] :: YieldRateInfo -> IORef Count + [A] [workerPendingLatency] :: YieldRateInfo -> IORef (Count, Count, NanoSecond64) + [A] [workerMeasuredLatency] :: YieldRateInfo -> IORef NanoSecond64 + [A] [workerCollectedLatency] :: YieldRateInfo -> IORef (Count, Count, NanoSecond64) + [A] [workerBootstrapLatency] :: YieldRateInfo -> Maybe NanoSecond64 + [A] [svarRateBuffer] :: YieldRateInfo -> Int + [A] [svarLatencyTarget] :: YieldRateInfo -> NanoSecond64 + [A] [svarLatencyRange] :: YieldRateInfo -> LatencyRange + [A] [svarGainedLostYields] :: YieldRateInfo -> IORef Count + [A] [svarAllTimeLatency] :: YieldRateInfo -> IORef (Count, AbsTime) + [A] YieldRateInfo :: NanoSecond64 -> LatencyRange -> Int -> IORef Count -> IORef (Count, AbsTime) -> Maybe NanoSecond64 -> IORef Count -> IORef (Count, Count, NanoSecond64) -> IORef (Count, Count, NanoSecond64) -> IORef NanoSecond64 -> YieldRateInfo + [A] WorkerInfo + [A] [workerYieldMax] :: WorkerInfo -> Count + [A] [workerYieldCount] :: WorkerInfo -> IORef Count + [A] [workerLatencyStart] :: WorkerInfo -> IORef (Count, AbsTime) + [A] WorkerInfo :: Count -> IORef Count -> IORef (Count, AbsTime) -> WorkerInfo + [A] Work + [A] PartialWorker :: Count -> Work + [A] ManyWorkers :: Int -> Count -> Work + [A] BlockWait :: NanoSecond64 -> Work + [A] ThreadAbort + [A] ThreadAbort :: ThreadAbort + [A] StopWhen + [A] FirstStops :: StopWhen + [A] AnyStops :: StopWhen + [A] AllStop :: StopWhen + [A] SVarStats + [A] [totalDispatches] :: SVarStats -> IORef Int + [A] [svarStopTime] :: SVarStats -> IORef (Maybe AbsTime) + [A] [minWorkerLatency] :: SVarStats -> IORef NanoSecond64 + [A] [maxWorkers] :: SVarStats -> IORef Int + [A] [maxWorkerLatency] :: SVarStats -> IORef NanoSecond64 + [A] [maxWorkQSize] :: SVarStats -> IORef Int + [A] [maxOutQSize] :: SVarStats -> IORef Int + [A] [maxHeapSize] :: SVarStats -> IORef Int + [A] [avgWorkerLatency] :: SVarStats -> IORef (Count, NanoSecond64) + [A] SVarStats :: IORef Int -> IORef Int -> IORef Int -> IORef Int -> IORef Int -> IORef (Count, NanoSecond64) -> IORef NanoSecond64 -> IORef NanoSecond64 -> IORef (Maybe AbsTime) -> SVarStats + [A] Rate + [A] [rateLow] :: Rate -> Double + [A] [rateHigh] :: Rate -> Double + [A] [rateGoal] :: Rate -> Double + [A] [rateBuffer] :: Rate -> Int + [A] Rate :: Double -> Double -> Double -> Int -> Rate + [A] Limit + [A] Unlimited :: Limit + [A] Limited :: Word -> Limit + [A] LatencyRange + [A] [minLatency] :: LatencyRange -> NanoSecond64 + [A] [maxLatency] :: LatencyRange -> NanoSecond64 + [A] LatencyRange :: NanoSecond64 -> NanoSecond64 -> LatencyRange + [A] Config + [A] ChildEvent + [A] ChildYield :: a -> ChildEvent a + [A] ChildStopChannel :: ChildEvent a + [A] ChildStop :: ThreadId -> Maybe SomeException -> ChildEvent a + [A] Count + [A] Count :: Int64 -> Count + [A] workerRateControl :: Limit -> IORef Int -> YieldRateInfo -> WorkerInfo -> IO Bool + [A] withDiagMVar :: Bool -> IO String -> String -> IO () -> IO () + [A] stopWhen :: StopWhen -> Config -> Config + [A] setStreamLatency :: Int -> Config -> Config + [A] sendYield :: Limit -> Limit -> IORef Int -> Maybe WorkerInfo -> Maybe YieldRateInfo -> IORef ([ChildEvent a], Int) -> MVar () -> ChildEvent a -> IO Bool + [A] sendWithDoorBell :: IORef ([ChildEvent a], Int) -> MVar () -> ChildEvent a -> IO Int + [A] sendStop :: IORef Int -> Maybe WorkerInfo -> Maybe YieldRateInfo -> IORef ([ChildEvent a], Int) -> MVar () -> IO () + [A] ringDoorBell :: IORef Bool -> MVar () -> IO () + [A] recordMaxWorkers :: MonadIO m => IORef Int -> SVarStats -> m () + [A] readOutputQRaw :: IORef ([ChildEvent a], Int) -> Maybe SVarStats -> IO ([ChildEvent a], Int) + [A] readOutputQBasic :: IORef ([ChildEvent a], Int) -> IO ([ChildEvent a], Int) + [A] rate :: Maybe Rate -> Config -> Config + [A] printSVar :: IO String -> String -> IO () + [A] ordered :: Bool -> Config -> Config + [A] newSVarStats :: IO SVarStats + [A] newRateInfo :: Config -> IO (Maybe YieldRateInfo) + [A] modifyThread :: MonadIO m => IORef (Set ThreadId) -> MVar () -> ThreadId -> m () + [A] minThreadDelay :: NanoSecond64 + [A] minRate :: Double -> Config -> Config + [A] maxYields :: Maybe Int64 -> Config -> Config + [A] maxThreads :: Int -> Config -> Config + [A] maxRate :: Double -> Config -> Config + [A] maxBuffer :: Int -> Config -> Config + [A] magicMaxBuffer :: Word + [A] isBeyondMaxRate :: Limit -> IORef Int -> YieldRateInfo -> IO Bool + [A] interleaved :: Bool -> Config -> Config + [A] inspect :: Bool -> Config -> Config + [A] incrementYieldLimit :: Maybe (IORef Count) -> IO () + [A] handleChildException :: IORef ([ChildEvent a], Int) -> MVar () -> SomeException -> IO () + [A] getYieldLimit :: Config -> Maybe Count + [A] getStreamRate :: Config -> Maybe Rate + [A] getStreamLatency :: Config -> Maybe NanoSecond64 + [A] getStopWhen :: Config -> StopWhen + [A] getOrdered :: Config -> Bool + [A] getMaxThreads :: Config -> Limit + [A] getMaxBuffer :: Config -> Limit + [A] getInterleaved :: Config -> Bool + [A] getInspectMode :: Config -> Bool + [A] getEagerDispatch :: Config -> Bool + [A] getBound :: Config -> Bool + [A] estimateWorkers :: Limit -> Count -> Count -> NanoSecond64 -> NanoSecond64 -> NanoSecond64 -> LatencyRange -> Work + [A] eager :: Bool -> Config -> Config + [A] dumpWorkerCount :: Show a => IORef a -> IO String + [A] dumpSVarStats :: Bool -> Maybe YieldRateInfo -> SVarStats -> IO String + [A] dumpRunningThreads :: Show a => IORef a -> IO String + [A] dumpOutputQ :: (Foldable t, Show a1) => IORef (t a2, a1) -> IO String + [A] dumpNeedDoorBell :: Show a => IORef a -> IO String + [A] dumpDoorBell :: Show a => MVar a -> IO String + [A] dumpCreator :: Show a => a -> String + [A] delThread :: MonadIO m => IORef (Set ThreadId) -> ThreadId -> m () + [A] defaultConfig :: Config + [A] decrementYieldLimit :: Maybe (IORef Count) -> IO Bool + [A] constRate :: Double -> Config -> Config + [A] collectLatency :: Bool -> SVarStats -> YieldRateInfo -> Bool -> IO (Count, AbsTime, NanoSecond64) + [A] cleanupSVar :: IORef (Set ThreadId) -> IO () + [A] boundThreads :: Bool -> Config -> Config + [A] avgRate :: Double -> Config -> Config + [A] allThreadsDone :: MonadIO m => IORef (Set ThreadId) -> m Bool + [A] addThread :: MonadIO m => IORef (Set ThreadId) -> ThreadId -> m () +[C] Streamly.Internal.Control.ForkLifted + [A] doForkWith :: MonadRunInIO m => Bool -> m () -> RunInIO m -> (SomeException -> IO ()) -> m ThreadId diff --git a/docs/User/Project/CONTRIBUTORS.md b/docs/User/Project/CONTRIBUTORS.md new file mode 100644 --- /dev/null +++ b/docs/User/Project/CONTRIBUTORS.md @@ -0,0 +1,178 @@ +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.11.1 + +* Harendra Kumar +* John Hampton + +## 0.11.0 + +* Harendra Kumar +* Adithya Kumar +* Alice Rixte +* Domen Kožar +* He Zhenxing +* ericpashman + +## 0.10.0 + +* Adithya Kumar +* Harendra Kumar +* Ranjeet Kumar Ranjan +* Shlok Datye +* Bodigrim + +## 0.9.0 + +* Harendra Kumar +* Ranjeet Kumar Ranjan +* Adithya Kumar +* Francesco Gazzetta +* Ishan Bhanuka + +## 0.8.2 + +* Adithya Kumar +* Harendra Kumar +* Ranjeet Kumar Ranjan +* Anurag Hooda +* andremarianiello + +## 0.8.1.1 + +* Harendra Kumar +* Julian Ospald + +## 0.8.1 + +* Harendra Kumar +* Adithya Kumar +* Ranjeet Kumar Ranjan +* Julian Ospald +* Sanchayan Maity + +## 0.8.0 + +* Harendra Kumar +* Adithya Kumar +* Pranay Sashank +* Ranjeet Kumar Ranjan +* Anurag Hooda +* Ahmed Zaheer Dadarkar +* Shruti Umat +* Joseph Koshy (Google LLC.) +* Sanchayan Maity +* Kirill Elagin +* Shlok Datye +* Julian Ospald +* George Thomas +* endgame + +## 0.7.3 + +* Pranay Sashank +* Adithya Kumar +* Julian Ospald + +## 0.7.2 + +* Harendra Kumar +* Pranay Sashank +* Adithya Kumar +* Sanchayan Maity +* Julian Ospald +* Shlok Datye + +## 0.7.1 + +* Harendra Kumar +* Pranay Sashank +* Adithya Kumar +* Sanchayan Maity +* Brian Wignall +* Julian Ospald +* Lucian Ursu + +## 0.7.0 + +* Harendra Kumar +* Pranay Sashank +* Artyom Kazak +* David Feuer +* Adithya Kumar +* Aravind Gopal + +## 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 diff --git a/docs/User/Project/Changelog.md b/docs/User/Project/Changelog.md new file mode 100644 --- /dev/null +++ b/docs/User/Project/Changelog.md @@ -0,0 +1,694 @@ +# Changelog + + + +## 0.11.1 (May 2026) + +* Fix `parDemuxScan` deadlock when a worker throws an exception while the + driver is blocked on a full input buffer. + +## 0.11.0 (Sep 2025) + +See +[0.10.1-0.11.0 API Changelog](https://github.com/composewell/streamly/blob/streamly-0.11.0/docs/User/Project/ApiChangelogs/0.10.1-0.11.0.txt) +for detailed API changes in this release. + +### Breaking Changes + +* Concurrent streams and folds now use separate concurrency config types. If you + were importing `Config` from the wrong module, you will need to update it. + +### Enhancements + +* Support for prompt cleanup of concurrent threads, allowing guaranteed + cleanup as an alternative to GC-based cleanup. +* Introduced `Streamly.Data.Scanl.Prelude` for using concurrent + operations with the new `Scanl` type. Scans can split a stream into + multiple streams, process them concurrently, and merge the results. +* Added new concurrent fold combinators in `Streamly.Data.Fold.Prelude`. +* Fixed rate control for ordered streams. + +### Internal + +* Internal `FileSystem.Event.*` modules are deprecated; use the + [streamly-fsevents](https://github.com/composewell/streamly-fsevents) package. + instead. + +## 0.10.1 (Jan 2024) + +* Fix TH macros in `Streamly.Data.Stream.MkType` for GHC 9.6 and above. + +## 0.10.0 (Nov 2023) + +See +[0.9.0-0.10.0 API Changelog](https://github.com/composewell/streamly/blob/streamly-0.10.0/docs/User/Project/ApiChangelogs/0.9.0-0.10.0.txt) +for a full list of API changes in this release. Only a few significant +changes are mentioned here. For changes to the core functionality +please see the changelog of the `streamly-core` package. + +### Breaking Changes + +* `MonadTrans` and `MonadBase` instances have been removed for `AsyncT`, + `ParallelT`, `AheadT` for GHC versions 9.6 onwards. This is due to a + breaking change in `transformers` 0.6. You can replace `lift` with + `fromEffect` when using these as top level monads in a monad stack. + +### Enhancements + +* __Concurrent Folds__: `Streamly.Data.Fold.Prelude` module added with + concurrent fold APIs and a container fold API to fold a key value + stream to a HashMap. + +## 0.9.0 (Mar 2023) + +Also see the following: + +* [streamly-0.9.0 Upgrade Guide](https://github.com/composewell/streamly/blob/streamly-0.10.0/docs/User/Project/Upgrading-0.8-to-0.9.md) or + https://hackage.haskell.org/package/streamly-0.9.0/docs/docs/User/ProjectRelated/Upgrading.md +* [streamly-0.9.0 API Changelog](https://github.com/composewell/streamly/blob/streamly-0.10.0/docs/User/Project/ApiChangelogs/0.8.3-0.9.0.txt) or + https://hackage.haskell.org/package/streamly-0.9.0/docs/docs/User/ProjectRelated/ApiChangelogs/0.8.3-0.9.0.txt +* [streamly-core-0.1.0 API Changelog](https://github.com/composewell/streamly/blob/streamly-0.10.0/core/docs/ApiChangelogs/0.1.0.txt) or + https://hackage.haskell.org/package/streamly-core-0.1.0/docs/docs/ApiChangelogs/0.1.0.txt + +### Package split + +`streamly` package is split into two packages, (1) `streamly-core` that +has only GHC boot library depdendecies, and (2) `streamly` that contains +higher level operations (including concurrent ones) with additional +dependencies. Make sure you add a dependency on `streamly-core` to keep old +code working. + +* Moved the following modules from `streamly` package to the + `streamly-core` package: + * Streamly.Console.Stdio + * Streamly.Data.Fold + * Streamly.Data.Unfold + * Streamly.FileSystem.Handle + * Streamly.Unicode.Stream + +### Breaking Changes + +* Unboxed arrays now require `Unbox` constraint instead of `Storable`. + The `Unbox` typeclass can be imported from `Streamly.Data.Array`. You + can use generic deriving to derive Unbox instances. +* Stream type in all modules has been changed to the new `Stream` type + replacing the existing `IsStream t` or `SerialT` types. Use `fromStream`, + `toStream` from `Streamly.Prelude` module to adapt the types. +* Signatures changed in `Streamly.Data.Unfold`: + * `fromStream` + * `replicateM` + +### Major Changes + +`Streamly.Prelude` module has been deprecated, equivalent +functionality is covered by the `Streamly.Data.Stream`, +`Streamly.Data.Stream.Prelude`, and `Streamly.Data.Fold` modules. The +new modules use a monomorphic `Stream` type instead of the polymorphic +`IsStream t` type. + +`Streamly.Data.Stream` module and the `Stream` type are meant for +writing high-performance fused pipelines not involving explicit +recursion. For writing code that may require recursive function calls, +`Streamly.Data.Stream.StreamK` module and the `StreamK` type have been +added which provide a CPS based stream implementation. `Stream` and +`StreamK` types can be easily interconverted. + +The old code can be adapted to use the new modules with some changes. +See the +[streamly-0.9.0 Upgrade Guide](https://github.com/composewell/streamly/blob/streamly-0.10.0/docs/User/Project/Upgrading-0.8-to-0.9.md) +for more details on how to adapt your existing code to the new release. + +### Enhancements + +* Added the following new modules to the `streamly` package: + * Streamly.Data.Stream.MkType + * Streamly.Data.Stream.Prelude +* Added the following new modules to the `streamly-core` package: + * Streamly.Data.Array + * Streamly.Data.Array.Generic + * Streamly.Data.MutArray + * Streamly.Data.MutArray.Generic + * Streamly.Data.Parser + * Streamly.Data.ParserK + * Streamly.Data.Stream + * Streamly.Data.StreamK + * Streamly.FileSystem.Dir + * Streamly.FileSystem.File + * Streamly.Unicode.Parser + * Streamly.Unicode.String + +### Deprecations + +* Remove support for GHC 8.4.* + +Several modules and functions have been deprecated, equivalent modules or +functions are suggested in the deprecation warning messages by the compiler. + +### Internal module changes + +If you cannot find an internal module that you were using, it may have +been moved to the `streamly-core` package or may have been renamed. + +Following modules are moved to `streamly-core` package and renamed: + * Streamly.Internal.Data.Array.Stream.Foreign -> Streamly.Internal.Data.Stream.Chunked + * Streamly.Internal.Data.Array.Stream.Mut.Foreign -> Streamly.Internal.Data.Array.Mut.Stream + +## 0.8.3 (September 2022) + +* Fix build with GHC 9.4 + +## 0.8.2 (Mar 2022) + +* Fix performance issues for GHC-9. These changes coupled with GHC changes + expected to land in 9.2.2 will bring the performance back to the same levels + as before. + +## 0.8.1.1 (Dec 2021) + +* Disable building FileSystem.Events where FS Events isn't supported. + +## 0.8.1 (Nov 2021) + +See ApiChangelogs/0.8.0-0.8.1.txt for new APIs introduced. + +### Bug Fixes + +* Several bug fixes in the Array module: + * Fix writeN fold eating away one element when applied multiple times + [#1258](https://github.com/composewell/streamly/issues/1258). + * Fix potentially writing beyond allocated memory when shrinking. Likely + cause of [#944](https://github.com/composewell/streamly/issues/944). + * Fix potentially writing beyond allocated memory when writing the last + element. Likely cause of + [#944](https://github.com/composewell/streamly/issues/944). + * Fix missing pointer touch could potentially cause use of freed memory. + * Fix unnecessary additional allocation due to a bug +* Fix a bug in classifySessionsBy, see + [PR #1311](https://github.com/composewell/streamly/pull/1311). The bug + could cause premature ejection of a session when input events with the + same key are split into multiple sessions. + +### Notable Internal API Changes + +* `tapAsync` from `Streamly.Internal.Data.Stream.Parallel` has been moved to + `Streamly.Internal.Data.Stream.IsStream` and renamed to `tapAsyncK`. +* `Fold2` has now been renamed to `Refold` and the corresponding `Fold2` + combinators have been either renamed or removed. + +## 0.8.0 (Jun 2021) + +See [API Changelog](/docs/User/Project/ApiChangelogs/0.7.3-0.8.0.txt) for a complete list of signature +changes and new APIs introduced. + +### Breaking changes + +* `Streamly.Prelude` + * `fold`: this function may now terminate early without consuming + the entire stream. For example, `fold Fold.head stream` would + now terminate immediately after consuming the head element from + `stream`. This may result in change of behavior in existing programs + if the program relies on the evaluation of the full stream. +* `Streamly.Data.Unicode.Stream` + * The following APIs no longer throw errors on invalid input, use new + APIs suffixed with a prime for strict behavior: + * decodeUtf8 + * encodeLatin1 + * encodeUtf8 +* `Streamly.Data.Fold`: + * Several instances have been moved to the `Streamly.Data.Fold.Tee` + module, please use the `Tee` type to adapt to the changes. + +### Bug Fixes + +* Concurrent Streams: The monadic state for the stream is now propagated across + threads. Please refer to + [#369](https://github.com/composewell/streamly/issues/369) for more info. +* `Streamly.Prelude`: + * `bracket`, `handle`, and `finally` now also work correctly on streams + that aren't fully drained. Also, the resource acquisition and release is + atomic with respect to async exceptions. + * `iterate`, `iterateM` now consume O(1) space instead of O(n). + * `fromFoldableM` is fixed to be concurrent. +* `Streamly.Network.Inet.TCP`: `accept` and `connect` APIs now close the socket + if an exception is thrown. +* `Streamly.Network.Socket`: `accept` now closes the socket if an exception is + thrown. + +### Enhancements + +* See [API Changelog](/docs/User/Project/ApiChangelogs/0.7.3-0.8.0.txt) for a complete list of new + modules and APIs introduced. +* The Fold type is now more powerful, the new termination behavior allows + to express basic parsing of streams using folds. +* Many new Fold and Unfold APIs are added. +* A new module for console IO APIs is added. +* Experimental modules for the following are added: + * Parsing + * Deserialization + * File system event handling (fsnotify/inotify) + * Folds for streams of arrays +* Experimental `use-c-malloc` build flag to use the c library `malloc` for + array allocations. This could be useful to avoid pinned memory fragmentation. + + +### Notable Internal/Pre-release API Changes + +Breaking changes: + +* The `Fold` type has changed to accommodate terminating folds. +* Rename: `Streamly.Internal.Prelude` => `Streamly.Internal.Data.Stream.IsStream` +* Several other internal modules have been renamed and re-factored. + +Bug fixes: + +* A bug was fixed in the conversion of `MicroSecond64` and `MilliSecond64` + (commit e5119626) +* Bug fix: `classifySessionsBy` now flushes sessions at the end and terminates. + +### Miscellaneous + +* Drop support for GHC 7.10.3. +* The examples in this package are moved to a new github repo + [streamly-examples](https://github.com/composewell/streamly-examples) + +## 0.7.3 (February 2021) + +### Build Issues + +* Fix build issues with primitive package version >= 0.7.1. +* Fix build issues on armv7. + +## 0.7.2 (April 2020) + +### Bug Fixes + +* Fix a bug in the `Applicative` and `Functor` instances of the `Fold` + data type. + +### Build Issues + +* Fix a bug that occasionally caused a build failure on windows when + used with `stack` or `stack ghci`. +* Now builds on 32-bit machines. +* Now builds with `primitive` package version >= 0.5.4 && <= 0.6.4.0 +* Now builds with newer `QuickCheck` package version >= 2.14 && < 2.15. +* Now builds with GHC 8.10. + +## 0.7.1 (February 2020) + +### Bug Fixes + +* Fix a bug that caused `findIndices` to return wrong indices in some + cases. +* Fix a bug in `tap`, `chunksOf` that caused memory consumption to + increase in some cases. +* Fix a space leak in concurrent streams (`async`, `wAsync`, and `ahead`) that + caused memory consumption to increase with the number of elements in the + stream, especially when built with `-threaded` and used with `-N` RTS option. + The issue occurs only in cases when a worker thread happens to be used + continuously for a long time. +* Fix scheduling of WAsyncT stream style to be in round-robin fashion. +* Now builds with `containers` package version < 0.5.8. +* Now builds with `network` package version >= 3.0.0.0 && < 3.1.0.0. + +### Behavior change + +* Combinators in `Streamly.Network.Inet.TCP` no longer use TCP `NoDelay` and + `ReuseAddr` socket options by default. These options can now be specified + using appropriate combinators. + +### Performance + +* Now uses `fusion-plugin` package for predictable stream fusion optimizations +* Significant improvement in performance of concurrent stream operations. +* Improved space and time performance of `Foldable` instance. + +## 0.7.0 (November 2019) + +### 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. +* Fix unbounded memory usage (leak) in `parallel` combinator. The bug manifests + when large streams are combined using `parallel`. + +### 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 (March 2019) + +### Bug Fixes + +* Fix a bug that caused `maxThreads` directive to be ignored when rate control + was not used. + +### Enhancements + +* Add GHCJS support +* Remove dependency on "clock" package + +## 0.6.0 (December 2018) + +### Breaking changes + +* `Monad` constraint may be needed on some of the existing APIs (`findIndices` + and `elemIndices`). + +### Enhancements + +* Add the following functions to Streamly.Prelude: + * Generation: `replicate`, `fromIndices`, `fromIndicesM` + * Enumeration: `Enumerable` type class, `enumerateFrom`, `enumerateFromTo`, + `enumerateFromThen`, `enumerateFromThenTo`, `enumerate`, `enumerateTo` + * Running: `runN`, `runWhile` + * Folds: `(!!)`, `maximumBy`, `minimumBy`, `the` + * Scans: `scanl1'`, `scanl1M' + * Filters: `uniq`, `insertBy`, `deleteBy`, `findM` + * Multi-stream: `eqBy`, `cmpBy`, `mergeBy`, `mergeByM`, `mergeAsyncBy`, + `mergeAsyncByM`, `isPrefixOf`, `isSubsequenceOf`, `stripPrefix`, + `concatMap`, `concatMapM`, `indexed`, `indexedR` +* Following instances were added for `SerialT m`, `WSerialT m` and + `ZipSerialM m`: + * When `m` ~ `Identity`: IsList, Eq, Ord, Show, Read, IsString, NFData, + NFData1, Traversable + * When `m` is `Foldable`: Foldable +* Performance improvements +* Add benchmarks to measure composed and iterated operations + +## 0.5.2 (October 2018) + +### Bug Fixes + +* Cleanup any pending threads when an exception occurs. +* Fixed a livelock in ahead style streams. The problem manifests sometimes when + multiple streams are merged together in ahead style and one of them is a nil + stream. +* As per expected concurrency semantics each forked concurrent task must run + with the monadic state captured at the fork point. This release fixes a bug, + which, in some cases caused an incorrect monadic state to be used for a + concurrent action, leading to unexpected behavior when concurrent streams are + used in a stateful monad e.g. `StateT`. Particularly, this bug cannot affect + `ReaderT`. + +## 0.5.1 (September 2018) + +* Performance improvements, especially space consumption, for concurrent + streams + +## 0.5.0 (September 2018) + +### Bug Fixes + +* Leftover threads are now cleaned up as soon as the consumer is garbage + collected. +* Fix a bug in concurrent function application that in certain cases would + unnecessarily share the concurrency state resulting in incorrect output + stream. +* Fix passing of state across `parallel`, `async`, `wAsync`, `ahead`, `serial`, + `wSerial` combinators. Without this fix combinators that rely on state + passing e.g. `maxThreads` and `maxBuffer` won't work across these + combinators. + +### Enhancements + +* Added rate limiting combinators `rate`, `avgRate`, `minRate`, `maxRate` and + `constRate` to control the yield rate of a stream. +* Add `foldl1'`, `foldr1`, `intersperseM`, `find`, `lookup`, `and`, `or`, + `findIndices`, `findIndex`, `elemIndices`, `elemIndex`, `init` to Prelude + +### Deprecations + +* The `Streamly.Time` module is now deprecated, its functionality is subsumed + by the new rate limiting combinators. + +## 0.4.1 (July 2018) + +### Bug Fixes + +* foldxM was not fully strict, fixed. + +## 0.4.0 (July 2018) + +### Breaking changes + +* Signatures of `zipWithM` and `zipAsyncWithM` have changed +* Some functions in prelude now require an additional `Monad` constraint on + the underlying type of the stream. + +### Deprecations + +* `once` has been deprecated and renamed to `yieldM` + +### Enhancements + +* Add concurrency control primitives `maxThreads` and `maxBuffer`. +* Concurrency of a stream with bounded concurrency when used with `take` is now + limited by the number of elements demanded by `take`. +* Significant performance improvements utilizing stream fusion optimizations. +* Add `yield` to construct a singleton stream from a pure value +* Add `repeat` to generate an infinite stream by repeating a pure value +* Add `fromList` and `fromListM` to generate streams from lists, faster than + `fromFoldable` and `fromFoldableM` +* Add `map` as a synonym of fmap +* Add `scanlM'`, the monadic version of scanl' +* Add `takeWhileM` and `dropWhileM` +* Add `filterM` + +## 0.3.0 (June 2018) + +### Breaking changes + +* Some prelude functions, to whom concurrency capability has been added, will + now require a `MonadAsync` constraint. + +### Bug Fixes + +* Fixed a race due to which, in a rare case, we might block indefinitely on + an MVar due to a lost wakeup. +* Fixed an issue in adaptive concurrency. The issue caused us to stop creating + more worker threads in some cases due to a race. This bug would not cause any + functional issue but may reduce concurrency in some cases. + +### Enhancements +* Added a concurrent lookahead stream type `Ahead` +* Added `fromFoldableM` API that creates a stream from a container of monadic + actions +* Monadic stream generation functions `consM`, `|:`, `unfoldrM`, `replicateM`, + `repeatM`, `iterateM` and `fromFoldableM` can now generate streams + concurrently when used with concurrent stream types. +* Monad transformation functions `mapM` and `sequence` can now map actions + concurrently when used at appropriate stream types. +* Added concurrent function application operators to run stages of a + stream processing function application pipeline concurrently. +* Added `mapMaybe` and `mapMaybeM`. + +## 0.2.1 (June 2018) + +### Bug Fixes +* Fixed a bug that caused some transformation ops to return incorrect results + when used with concurrent streams. The affected ops are `take`, `filter`, + `takeWhile`, `drop`, `dropWhile`, and `reverse`. + +## 0.2.0 (May 2018) + +### Breaking changes +* Changed the semantics of the Semigroup instance for `InterleavedT`, `AsyncT` + and `ParallelT`. The new semantics are as follows: + * For `InterleavedT`, `<>` operation interleaves two streams + * For `AsyncT`, `<>` now concurrently merges two streams in a left biased + manner using demand based concurrency. + * For `ParallelT`, the `<>` operation now concurrently meges the two streams + in a fairly parallel manner. + + To adapt to the new changes, replace `<>` with `serial` wherever it is used + for stream types other than `StreamT`. + +* Remove the `Alternative` instance. To adapt to this change replace any usage + of `<|>` with `parallel` and `empty` with `nil`. +* Stream type now defaults to the `SerialT` type unless explicitly specified + using a type combinator or a monomorphic type. This change reduces puzzling + type errors for beginners. It includes the following two changes: + * Change the type of all stream elimination functions to use `SerialT` + instead of a polymorphic type. This makes sure that the stream type is + always fixed at all exits. + * Change the type combinators (e.g. `parallely`) to only fix the argument + stream type and the output stream type remains polymorphic. + + Stream types may have to be changed or type combinators may have to be added + or removed to adapt to this change. +* Change the type of `foldrM` to make it consistent with `foldrM` in base. +* `async` is renamed to `mkAsync` and `async` is now a new API with a different + meaning. +* `ZipAsync` is renamed to `ZipAsyncM` and `ZipAsync` is now ZipAsyncM + specialized to the IO Monad. +* Remove the `MonadError` instance as it was not working correctly for + parallel compositions. Use `MonadThrow` instead for error propagation. +* Remove Num/Fractional/Floating instances as they are not very useful. Use + `fmap` and `liftA2` instead. + +### Deprecations +* Deprecate and rename the following symbols: + * `Streaming` to `IsStream` + * `runStreaming` to `runStream` + * `StreamT` to `SerialT` + * `InterleavedT` to `WSerialT` + * `ZipStream` to `ZipSerialM` + * `ZipAsync` to `ZipAsyncM` + * `interleaving` to `wSerially` + * `zipping` to `zipSerially` + * `zippingAsync` to `zipAsyncly` + * `<=>` to `wSerial` + * `<|` to `async` + * `each` to `fromFoldable` + * `scan` to `scanx` + * `foldl` to `foldx` + * `foldlM` to `foldxM` +* Deprecate the following symbols for future removal: + * `runStreamT` + * `runInterleavedT` + * `runAsyncT` + * `runParallelT` + * `runZipStream` + * `runZipAsync` + +### Enhancements +* Add the following functions: + * `consM` and `|:` operator to construct streams from monadic actions + * `once` to create a singleton stream from a monadic action + * `repeatM` to construct a stream by repeating a monadic action + * `scanl'` strict left scan + * `foldl'` strict left fold + * `foldlM'` strict left fold with a monadic fold function + * `serial` run two streams serially one after the other + * `async` run two streams asynchronously + * `parallel` run two streams in parallel (replaces `<|>`) + * `WAsyncT` stream type for BFS version of `AsyncT` composition +* Add simpler stream types that are specialized to the IO monad +* Put a bound (1500) on the output buffer used for asynchronous tasks +* Put a limit (1500) on the number of threads used for Async and WAsync types + +## 0.1.2 (March 2018) + +### Enhancements +* Add `iterate`, `iterateM` stream operations + +### Bug Fixes +* Fixed a bug that caused unexpected behavior when `pure` was used to inject + values in Applicative composition of `ZipStream` and `ZipAsync` types. + +## 0.1.1 (March 2018) + +### Enhancements +* Make `cons` right associative and provide an operator form `.:` for it +* Add `null`, `tail`, `reverse`, `replicateM`, `scan` stream operations +* Improve performance of some stream operations (`foldl`, `dropWhile`) + +### Bug Fixes +* Fix the `product` operation. Earlier, it always returned 0 due to a bug +* Fix the `last` operation, which returned `Nothing` for singleton streams + +## 0.1.0 (December 2017) + +* Initial release diff --git a/docs/User/Project/Credits.md b/docs/User/Project/Credits.md new file mode 100644 --- /dev/null +++ b/docs/User/Project/Credits.md @@ -0,0 +1,43 @@ +# Credits and Contributions + +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 LICENSE 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 diff --git a/docs/User/Project/Github.link b/docs/User/Project/Github.link new file mode 100644 --- /dev/null +++ b/docs/User/Project/Github.link @@ -0,0 +1,1 @@ +https://github.com/composewell/streamly diff --git a/docs/User/Project/README.md b/docs/User/Project/README.md new file mode 100644 --- /dev/null +++ b/docs/User/Project/README.md @@ -0,0 +1,139 @@ +# [Streamly][]: Idiomatic Haskell with C-Like Performance + +[![Gitter chat](https://badges.gitter.im/composewell/gitter.svg)](https://gitter.im/composewell/streamly) +[![Hackage](https://img.shields.io/hackage/v/streamly-core.svg?style=flat)](https://hackage.haskell.org/package/streamly-core) +[![Hackage](https://img.shields.io/hackage/v/streamly.svg?style=flat)](https://hackage.haskell.org/package/streamly) + +## Upgrading to 0.9.0+ + +Please read the [Streamly 0.9.0 Upgrade Guide](/docs/User/Project/Upgrading-0.8-to-0.9.md). + +## Overview + +Streamly is a powerful Haskell library that provides developers with +the essential building blocks to create safe, scalable, modular, and +high-performance software. With Streamly, developers can enjoy the +benefits of Haskell's type safety while leveraging C-like program +performance. Streamly offers a comprehensive range of features, +comprising: + +* Haskell's strong type safety. +* C-program-like performance capabilities. +* Flexible, modular building blocks. +* Idiomatic functional programming. +* Fearless, declarative concurrency for seamless parallel execution. +* A collection of ecosystem libraries for fast and efficient development. + +Check out the [Learn By Examples](/docs/User/Tutorials/learn-by-examples.md) +page for an introduction to the library. For more detailed documentation, visit +the [Haskell Streamly website][Streamly]. + +## Blazing Fast + +Streamly delivers C-like speed in Haskell by fusing stream pipelines +using the stream-fusion technique, resulting in compiled code that is +equivalent to handwritten C code, eliminating intermediate allocations +and function calls. + +For a comprehensive comparison of Streamly to other Haskell streaming +libraries, check out our [streaming benchmarks][streaming-benchmarks] +page. In fact, Streamly's fused loops can be up to 100 times faster than +those of libraries without stream fusion. + +## Declarative Concurrency + +Streamly introduces declarative concurrency to standard functional +streaming abstractions. Declarative concurrency abstracts away the +low-level details of concurrency management, such as locks and threads, +and allows for easier and safer parallelization of code. For example, +with Streamly you can do things like repeat actions concurrently to +generate a stream of results, map functions concurrently on a stream, +and combine multiple streams concurrently to create a single output +stream. + +## Unified API + +Streamly provides a comprehensive and unified API for basic programming +needs, covering a wide range of areas including streaming, concurrency, +logic programming, reactive programming, pinned and unpinned arrays, +serialization, builders, parsers, unicode processing, file-io, file +system events, and network-io. By unifying functionality from disparate +Haskell libraries, Streamly simplifies development while delivering +equivalent or improved performance. Additionally, the complexity +of handling combinations of lazy, strict, bytestring, and text is +eliminated by using streams for lazy evaluation, and by generalizing +bytestring and text to arrays. + +Check out [Streamly's documentation][Streamly] for more information +about Streamly's features. + +## Batteries Included + +In addition to the fundamental programming constructs, Streamly also +provides higher-level functionality through supporting packages such as +[streamly-process][], [streamly-shell][], and [streamly-coreutils][] +that are essential for general programming tasks. Check out the +[streamly-examples][] repository for some program snippets. + +## Highly Modular + +Traditionally, you must choose between modularity and performance when +writing code. However, with [Haskell Streamly][Streamly], you can have +the best of both worlds. By taking advantage of GHC's stream fusion +optimizations (such as `case-of-case` and `spec-constr`), Streamly achieves +performance comparable to an equivalent C program while still allowing +for highly modular code. + +## Credits + +The following authors/libraries have influenced or inspired this library in a +significant way: + + * Roman Leshchinskiy ([vector](http://hackage.haskell.org/package/vector)) + * Gabriella Gonzalez ([foldl](https://hackage.haskell.org/package/foldl)) + * Alberto G. Corona ([transient](https://hackage.haskell.org/package/transient)) + +Please see the [`credits`](/docs/User/Project/Credits.md) directory for a full +list of contributors, credits and licenses. + +## Licensing + +Streamly is an [open source](https://github.com/composewell/streamly) +project available under a liberal [BSD-3-Clause license][LICENSE] + +## Contributing to Streamly + +As an open project we welcome contributions: + +* [Streamly Contributor's Guide][CONTRIBUTING.md] +* [Contact the streamly development team](mailto:streamly@composewell.com) + +## Getting Support + +Professional support is available for [Streamly][]: please contact +[support@composewell.com](mailto:support@composewell.com). + +You can also join our [community chat +channel](https://gitter.im/composewell/streamly) on Gitter. + + + +[Streamly]: https://streamly.composewell.com/ +[streaming-benchmarks]: https://github.com/composewell/streaming-benchmarks +[concurrency-benchmarks]: https://github.com/composewell/concurrency-benchmarks +[streamly-examples]: https://github.com/composewell/streamly-examples +[streamly-process]: https://github.com/composewell/streamly-process +[streamly-shell]: https://github.com/composewell/streamly-shell +[streamly-coreutils]: https://github.com/composewell/streamly-coreutils + + + + +[LICENSE]: /LICENSE +[CONTRIBUTING.md]: /docs/Developer/Contributing.md +[docs]: docs/ diff --git a/docs/User/Project/Roadmap.link b/docs/User/Project/Roadmap.link new file mode 100644 --- /dev/null +++ b/docs/User/Project/Roadmap.link @@ -0,0 +1,1 @@ +https://github.com/composewell/streamly/issues/1046 diff --git a/docs/User/Project/Upgrading-0.8-to-0.9.md b/docs/User/Project/Upgrading-0.8-to-0.9.md new file mode 100644 --- /dev/null +++ b/docs/User/Project/Upgrading-0.8-to-0.9.md @@ -0,0 +1,392 @@ +# Upgrading to streamly 0.9.0 + +```haskell docspec +>>> :set -Wno-deprecations +``` + +Also see the detailed changelog describing all the changes in the release: + +* [0.9.0 API Changelog](/docs/User/Project/ApiChangelogs/0.8.3-0.9.0.txt) or +* [0.9.0 API Changelog](https://hackage.haskell.org/package/streamly-0.9.0/docs/docs/User/ProjectRelated/ApiChangelogs/0.8.3-0.9.0.txt) + +`Streamly.Prelude` module has been deprecated, equivalent +functionality is covered by the `Streamly.Data.Stream`, +`Streamly.Data.Stream.Prelude`, and `Streamly.Data.Fold` modules. The +new modules use a monomorphic `Stream` type instead of the polymorphic +`IsStream t` type. + +`Streamly.Data.Stream` module and the `Stream` type are designed +for writing high-performance fused pipelines not involving explicit +recursion. For writing code that may require recursive function calls, +`Streamly.Data.Stream.StreamK` module and the `StreamK` type have been +introduced which provide a CPS based stream implementation. `Stream` and +`StreamK` types can be easily interconverted. These changes have been made to +make performance robust and not rely on GHC rewrite rules which could be +fragile. For example, GHC 9.0.x had broken the rewrite rule which was +not fixed until GHC-9.2.2. This split also gives more power and +transparency of the performance behavior to the programmer. + +Instead of using separate stream types for concurrent code, now +you have to use explicit concurrent combinators with appropriate +concurrency parameters. These combinators are available in the +`Streamly.Data.Stream.Prelude` module. This change has been made to allow +programmers to control concurrent behavior in a more robust way and +reduce pitfalls. + +The old code can be adapted to use the new modules with some +changes. More details about this is supplied in the following sections. +Please open an issue if you cannot find a way to adapt the code to the new +release. + +Assume the following imports in the code snippets below: + +```haskell docspec +>>> import qualified Streamly.Data.Stream as Stream +>>> import qualified Streamly.Data.StreamK as StreamK +>>> import qualified Streamly.Data.Stream.Prelude as Stream +>>> import qualified Streamly.Data.Fold as Fold +>>> import qualified Streamly.Data.Parser as Parser +``` + +## Dependencies in cabal file + +If you allow streamly < 0.9 in version bounds in your package then you +may not be able to build if any of the following is true: + +* there is a dependency on `streamly-core` (module name conflicts) +* there is a dependency on `streamly-bytestring` >= 0.2 (type conflict) + +You can define and use a build flag in your package to allow older +streamly versions: + +``` +flag old-streamly + description: Allow streamly versions lower than 0.9 + manual: True + default: False +``` + +``` + if flag(old-streamly) + build-depends: + streamly >=0.8.3 && < 0.9 + else + build-depends: + streamly-core >= 0.1.0 && < 0.2, + streamly >=0.9.0 && < 0.10 +``` + +## The `Stream` and `StreamK` types + +The following types are removed: + +* `IsStream` +* `ZipSerialM` +* `ZipAsyncM` +* `WSerialT` +* `WAsyncT` +* `SerialT` +* `ParallelT` +* `AsyncT` +* `AheadT` + +In the new release, the `Stream` type is the primary stream type that +you will use most of the time. You can think of it as a replacement for +the `SerialT` type. However, it does not provide an Applicative or Monad +instance. + +The `CrossStream` type in `Streamly.Internal.Data.Stream` is a +wrapper over `Stream` type supplying the Monad instance. However, see +the "Stream Fusion" section in the `Streamly.Data.Stream` module for +limitations of the `Stream` type. The `StreamK` type and `CrossStreamK` +(in Streamly.Internal.Data.Stream.StreamK) could be used to overcome the +limitations of `Stream` type. + +If required, you can use the template-haskell functions in +`Streamly.Data.Stream.MkType` to create stream type wrappers (like +ZipSerialM or WSerialT) with custom Applicative or Monadic properties. +But in general, try to avoid specific types and use explicit functions +from the stream module. + +Here are the TH macro based recipes to define types equivalent to all the older +types: + +``` +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +import Streamly.Data.Stream.MkType +import qualified Streamly.Data.Stream.Prelude as Stream +import qualified Streamly.Internal.Data.StreamK as StreamK +import Language.Haskell.TH +``` + +`SerialT`: Use `CrossStreamK` from `Streamly.Internal.Data.StreamK` equivalent +Monad and other instances. + +For `WSerialT`, create a newtype wrapper using the following monad bind +operation: + +``` +bind = StreamK.bindWith StreamK.interleave +``` + +`WSerialT` requires `StreamK`, therefore you can not generate the code directly +using TH macros. However, you can print the code generated by the TH macro. +Then you can tweak that code, replacing `Stream` type with `StreamK`. + +``` +expr <- runQ (mkCrossType "WSerialT" "bind" True) +putStrLn $ pprint expr +``` + +For `AsyncT`: + +``` +bind = flip (Stream.parConcatMap id) +$(mkCrossType "AsyncT" "bind" True) +``` + +For `WAsyncT`: + +``` +bind = flip (Stream.parConcatMap (Stream.interleaved True)) +$(mkCrossType "WAsyncT" "bind" True) +``` + +For `AheadT`: + +``` +bind = flip (Stream.parConcatMap (Stream.ordered True)) +$(mkCrossType "AheadT" "bind" True) +``` + +For `ParallelT`: + +``` +bind = flip (Stream.parConcatMap (Stream.eager True)) +$(mkCrossType "ParallelT" "bind" True) +``` + +For `ZipSerialM`: + +``` +apply = Stream.zipWith ($) +$(mkZipType "ZipSerialM" "apply" False) +``` + +For `ZipAsync`: + +``` +apply = Stream.parApply id +$(mkZipType "ZipAsync" "apply" False) +``` + +`adapt` is not needed anymore. + +```haskell docspec +>>> (.:) = StreamK.cons +>>> cons = StreamK.cons +>>> wSerial = StreamK.interleave +>>> serial = StreamK.append +>>> fromIndicesM f = Stream.mapM f $ Stream.enumerateFrom 0 +>>> fromIndices f = fmap f $ Stream.enumerateFrom 0 +>>> fromListM = Stream.sequence . Stream.fromList +>>> fromFoldable = StreamK.toStream . StreamK.fromFoldable +>>> fromFoldableM = Stream.sequence . fromFoldable +``` + +## Stream folding functions + +Explicit stream fold functions have been omitted from the new stream +module. You can use the following equivalent definitions: + +```haskell docspec +>>> the = Stream.fold Fold.the +>>> sum = Stream.fold Fold.sum +>>> product = Stream.fold Fold.product +>>> or = Stream.fold Fold.or +>>> null = Stream.fold Fold.null +>>> elemIndex a = Stream.fold (Fold.elemIndex a) +>>> elem a = Stream.fold (Fold.elem a) +>>> notElem a = Stream.fold (Fold.notElem a) +>>> minimumBy ordering = Stream.fold (Fold.minimumBy ordering) +>>> minimum = Stream.fold Fold.minimum +>>> maximumBy ordering = Stream.fold (Fold.maximumBy ordering) +>>> maximum = Stream.fold Fold.maximum +>>> mapM_ f = Stream.fold (Fold.drainMapM f) +>>> lookup a = Stream.fold (Fold.lookup a) +>>> length = Stream.fold Fold.length +>>> last = Stream.fold Fold.latest +>>> head = Stream.fold Fold.one +>>> foldlM' f a = Stream.fold (Fold.foldlM' f a) +>>> foldl1 f = Stream.fold (Fold.foldl1' f) +>>> foldl' f a = Stream.fold (Fold.foldl' f a) +>>> findIndex eq = Stream.fold (Fold.findIndex eq) +>>> find eq = Stream.fold (Fold.find eq) +>>> findM eq = Stream.fold (Fold.findM eq) +>>> drainWhile p = Stream.fold Fold.drain . Stream.takeWhile p +>>> drainN i = Stream.fold Fold.drain . Stream.take i +>>> drain = Stream.fold Fold.drain +>>> any p = Stream.fold (Fold.any p) +>>> and = Stream.fold Fold.and +>>> all p = Stream.fold (Fold.all p) +>>> (!!) i = Stream.fold (Fold.index i) +>>> tail = Streamly.Internal.Data.StreamK.tail +>>> init = Streamly.Internal.Data.StreamK.init +``` + +Mapping functions: + +```haskell docspec +>>> map = fmap +``` + +Similarly for scanning use `Stream.scan` or `Stream.postscan` +with an appropriate fold. + +```haskell docspec +>>> scanl' f z = Stream.scan (Fold.foldl' f z) +>>> scanlM' f z = Stream.scan (Fold.foldlM' f z) +>>> postscanl' f z = Stream.postscan (Fold.foldl' f z) +>>> postscanlM' f z = Stream.postscan (Fold.foldlM' f z) +>>> scanl1' f = Stream.catMaybes . Stream.scan (Fold.foldl1' f) +>>> scanl1M' f = Stream.catMaybes . Stream.scan (Fold.foldlM1' f) +>>> concatMapWith = StreamK.concatMapWith +>>> concatFoldableWith f = Prelude.foldr f StreamK.nil +>>> concatMapFoldableWith f g = Prelude.foldr (f . g) StreamK.nil +>>> concatForFoldableWith f xs g = Prelude.foldr (f . g) StreamK.nil xs +``` + +Filters: + +```haskell docspec +>>> deleteBy cmp x = Stream.scanMaybe (Fold.deleteBy cmp x) +>>> findIndices p = Stream.scanMaybe (Fold.findIndices p) +>>> elemIndices a = findIndices (== a) +``` + +Custom implementations of most of these folds, scans and filters are also +available in the `Streamly.Internal.Data.Stream` module. + +## Stream splitting and grouping functions + +Stream splitting and grouping functions like `splitOn`, `wordsBy`, and +`groupsBy` have been omitted from the new stream module as these can +now be implemented using `foldMany` and an appropriate fold from the +`Streamly.Data.Fold` module, or using `parseMany` and an appropriate +parser from the `Streamly.Data.Parser` module. + +```haskell docspec +>>> uniq = Stream.scanMaybe (Fold.uniqBy (==)) +>>> splitWithSuffix p f = Stream.foldMany (Fold.takeEndBy p f) +>>> splitOn = Streamly.Internal.Data.Stream.splitOn +>>> splitOnSuffix p f = Stream.foldMany (Fold.takeEndBy_ p f) +>>> indexedR = Streamly.Internal.Data.Stream.indexedR +>>> groupsBy eq fld = Stream.parseMany (Parser.groupBy (flip eq) fld) +>>> groups = groupsBy (==) +>>> groupsByRolling = Streamly.Internal.Data.Stream.groupsRollingBy +>>> wordsBy p f = Stream.parseMany (Parser.wordBy p f) +>>> chunksOf n f = Stream.foldMany (Fold.take n f) +``` + +**Caution**: In `streamly-0.8`, The `groupsBy` comparison function took the new +element as the first argument and the previous element as the second. The order +is flipped in the newer versions of streamly. + +Direct implementation of these are also available in +`Streamly.Internal.Data.Stream`. + +## Concurrency + +Earlier, concurrent and non-concurrent code used the same +combinators. The code was made concurrent by using different concurrent +stream types such as `AsyncT`, `ParallelT` etc. Now you use the same +stream type everywhere, you have to choose a concurrent combinator +for concurrent behavior. For example, use `mapM` for serial behavior +and `parMapM` for concurrent behavior. Concurrent combinators can +be imported from `Streamly.Data.Stream.Prelude` module. Concurrent +combinators are prefixed with `par`. + +Parallel combinators take a concurrency config argument to specify the +concurrency control parameters. The following combinators have the same +meaning as before except that they are used to set the config parameters +instead of being applied on the stream: + +* `rate` +* `maxRate` +* `constRate` +* `avgRate` +* `minRate` +* `maxThreads` +* `maxBuffer` + +A stream is evaluated asynchronously using `parEval`: + +```haskell docspec +>>> :set -XFlexibleContexts +>>> mkAsync = Stream.parEval id +``` + +Earlier `consM` was used to create an implicitly concurrent stream of +actions. In the new release, an equivalent effect is achieved by using +a serial `consM` to create a stream of actions and then explicitly using +`Stream.parEval` on it to evaluate it concurrently. + +```haskell docspec +>>> consM = StreamK.consM +>>> (|:) = consM +``` + +Note that you will have to use `StreamK.toStream` to covert it to `Stream` +before using `parEval` on it. + +Existing generation combinators that can be implemented using new primitives: + +```haskell docspec +>>> repeatM = Stream.parRepeatM +>>> replicateM = Stream.parReplicateM +>>> unfoldrM step = Stream.parEval id . Stream.unfoldrM step +>>> iterateM step = Stream.parEval id . Stream.iterateM step +>>> fromIndicesM f = Stream.parEval id . fromIndicesM f +>>> fromListM = Stream.parSequence id . Stream.fromList +>>> fromFoldableM = Stream.parSequence id . StreamK.toStream . StreamK.fromFoldable +``` + +Existing transformation combinators that can be implemented using `parEval`: + +```haskell docspec +>>> (|$.) f = f . Stream.parEval id +>>> (|&.) = flip (|$.) +>>> (|$) f = f . Stream.parEval id +>>> (|&) = flip (|$) +>>> sequence = Stream.parSequence +>>> mapM = Stream.parMapM +``` + +`parList` is used to evaluate multiple streams concurrently and combine the +outputs. Existing combinators that can be implemented using `parList`: + +```haskell docspec +>>> async x y = Stream.parList id [x, y] +>>> wAsync x y = Stream.parList (Stream.interleaved True) [x, y] +>>> parallel x y = Stream.parList (Stream.eager True) [x, y] +>>> ahead x y = Stream.parList (Stream.ordered True) [x, y] +``` + +Concurrent zipping and merging combinators: + +```haskell docspec +>>> zipAsyncWithM = Stream.parZipWith id +>>> zipAsyncWith = Stream.parZipWith id +>>> mergeAsyncByM = Stream.parMergeByM id +>>> mergeAsyncBy = Stream.parMergeBy id +``` + +The equivalent of `concatMapWith` using a concurrent combining operation in the +new release is `parConcatMap`. The config argument in `parConcatMap` can +specify an equivalent of the combining operation. Similarly, concurrent +`concatFoldableWith`, `concatMapFoldableWith`, `concatForFoldableWith` can also +be expressed using `parConcatMap`. diff --git a/docs/User/ProjectRelated/ApiChangelogs/0.8.3-0.9.0.txt b/docs/User/ProjectRelated/ApiChangelogs/0.8.3-0.9.0.txt deleted file mode 100644 --- a/docs/User/ProjectRelated/ApiChangelogs/0.8.3-0.9.0.txt +++ /dev/null @@ -1,175 +0,0 @@ ---------------------------------- -Terminology ---------------------------------- - -[A]: Added -[R]: Removed -[C]: Changed -[D]: Deprecated -[O]: Old -[N]: New - ---------------------------------- -Difference ---------------------------------- - -[R] Streamly.Unicode.Stream -[D] Streamly.Prelude - [A] toStreamK :: IsStream t => t m a -> StreamK m a - [A] toStream :: (IsStream t, Monad m) => t m a -> Stream m a - [C] mergeBy - [O] mergeBy :: (IsStream t, Monad m) => (a -> a -> Ordering) -> t m a -> t m a -> t m a - [N] mergeBy :: IsStream t => (a -> a -> Ordering) -> t m a -> t m a -> t m a - [A] fromStreamK :: IsStream t => StreamK m a -> t m a - [A] fromStream :: (IsStream t, Monad m) => Stream m a -> t m a -[C] Streamly.Network.Socket - [D] writeWithBufferOf :: MonadIO m => Int -> Socket -> Fold m Word8 () - [A] writeWith :: MonadIO m => Int -> Socket -> Fold m Word8 () - [D] writeChunksWithBufferOf :: (MonadIO m, Unbox a) => Int -> Socket -> Fold m (Array a) () - [A] writeChunksWith :: (MonadIO m, Unbox a) => Int -> Socket -> Fold m (Array a) () - [C] writeChunks - [O] writeChunks :: (MonadIO m, Storable a) => Socket -> Fold m (Array a) () - [N] writeChunks :: (MonadIO m, Unbox a) => Socket -> Fold m (Array a) () - [D] writeChunk :: Unbox a => Socket -> Array a -> IO () - [A] readerWith :: MonadIO m => Unfold m (Int, Socket) Word8 - [A] reader :: MonadIO m => Unfold m Socket Word8 - [D] readWithBufferOf :: MonadIO m => Unfold m (Int, Socket) Word8 - [D] readChunksWithBufferOf :: MonadIO m => Unfold m (Int, Socket) (Array Word8) - [D] readChunks :: MonadIO m => Unfold m Socket (Array Word8) - [D] readChunk :: Int -> Socket -> IO (Array Word8) - [D] read :: MonadIO m => Unfold m Socket Word8 - [A] putChunk :: Unbox a => Socket -> Array a -> IO () - [A] getChunk :: Int -> Socket -> IO (Array Word8) - [A] chunkReaderWith :: MonadIO m => Unfold m (Int, Socket) (Array Word8) - [A] chunkReader :: MonadIO m => Unfold m Socket (Array Word8) - [A] acceptor :: MonadIO m => Unfold m (Int, SockSpec, SockAddr) Socket - [D] accept :: MonadIO m => Unfold m (Int, SockSpec, SockAddr) Socket -[C] Streamly.Network.Inet.TCP - [A] acceptorOnPortLocal :: MonadIO m => Unfold m PortNumber Socket - [A] acceptorOnPort :: MonadIO m => Unfold m PortNumber Socket - [A] acceptorOnAddr :: MonadIO m => Unfold m ((Word8, Word8, Word8, Word8), PortNumber) Socket - [D] acceptOnPortLocal :: MonadIO m => Unfold m PortNumber Socket - [D] acceptOnPort :: MonadIO m => Unfold m PortNumber Socket - [D] acceptOnAddr :: MonadIO m => Unfold m ((Word8, Word8, Word8, Word8), PortNumber) Socket -[R] Streamly.FileSystem.Handle -[R] Streamly.Data.Unfold -[A] Streamly.Data.Stream.Prelude - [A] StopWhen - [A] FirstStops :: StopWhen - [A] AnyStops :: StopWhen - [A] AllStop :: StopWhen - [A] Rate - [A] [rateLow] :: Rate -> Double - [A] [rateHigh] :: Rate -> Double - [A] [rateGoal] :: Rate -> Double - [A] [rateBuffer] :: Rate -> Int - [A] Rate :: Double -> Double -> Double -> Int -> Rate - [A] Config - [A] type MonadAsync m = (MonadIO m, MonadBaseControl IO m, MonadThrow m) - [A] tapCount :: MonadAsync m => (a -> Bool) -> (Stream m Int -> m b) -> Stream m a -> Stream m a - [A] takeInterval :: MonadAsync m => Double -> Stream m a -> Stream m a - [A] stopWhen :: StopWhen -> Config -> Config - [A] sampleIntervalStart :: MonadAsync m => Double -> Stream m a -> Stream m a - [A] sampleIntervalEnd :: MonadAsync m => Double -> Stream m a -> Stream m a - [A] sampleBurstStart :: MonadAsync m => Double -> Stream m a -> Stream m a - [A] sampleBurstEnd :: MonadAsync m => Double -> Stream m a -> Stream m a - [A] rate :: Maybe Rate -> Config -> Config - [A] parZipWithM :: MonadAsync m => (Config -> Config) -> (a -> b -> m c) -> Stream m a -> Stream m b -> Stream m c - [A] parZipWith :: MonadAsync m => (Config -> Config) -> (a -> b -> c) -> Stream m a -> Stream m b -> Stream m c - [A] parSequence :: MonadAsync m => (Config -> Config) -> Stream m (m a) -> Stream m a - [A] parReplicateM :: MonadAsync m => (Config -> Config) -> Int -> m a -> Stream m a - [A] parRepeatM :: MonadAsync m => (Config -> Config) -> m a -> Stream m a - [A] parMergeByM :: MonadAsync m => (Config -> Config) -> (a -> a -> m Ordering) -> Stream m a -> Stream m a -> Stream m a - [A] parMergeBy :: MonadAsync m => (Config -> Config) -> (a -> a -> Ordering) -> Stream m a -> Stream m a -> Stream m a - [A] parMapM :: MonadAsync m => (Config -> Config) -> (a -> m b) -> Stream m a -> Stream m b - [A] parList :: MonadAsync m => (Config -> Config) -> [Stream m a] -> Stream m a - [A] parEval :: MonadAsync m => (Config -> Config) -> Stream m a -> Stream m a - [A] parConcatMap :: MonadAsync m => (Config -> Config) -> (a -> Stream m b) -> Stream m a -> Stream m b - [A] parConcatIterate :: MonadAsync m => (Config -> Config) -> (a -> Stream m a) -> Stream m a -> Stream m a - [A] parConcat :: MonadAsync m => (Config -> Config) -> Stream m (Stream m a) -> Stream m a - [A] parApply :: MonadAsync m => (Config -> Config) -> Stream m (a -> b) -> Stream m a -> Stream m b - [A] ordered :: Bool -> Config -> Config - [A] minRate :: Double -> Config -> Config - [A] maxThreads :: Int -> Config -> Config - [A] maxRate :: Double -> Config -> Config - [A] maxBuffer :: Int -> Config -> Config - [A] intervalsOf :: MonadAsync m => Double -> Fold m a b -> Stream m a -> Stream m b - [A] interleaved :: Bool -> Config -> Config - [A] interject :: MonadAsync m => m a -> Double -> Stream m a -> Stream m a - [A] inspect :: Bool -> Config -> Config - [A] fromCallback :: MonadAsync m => ((a -> m ()) -> m ()) -> Stream m a - [A] finally :: (MonadAsync m, MonadCatch m) => m b -> Stream m a -> Stream m a - [A] eager :: Bool -> Config -> Config - [A] dropInterval :: MonadAsync m => Double -> Stream m a -> Stream m a - [A] constRate :: Double -> Config -> Config - [A] bracket :: (MonadAsync m, MonadCatch m) => m b -> (b -> m c) -> (b -> Stream m a) -> Stream m a - [A] avgRate :: Double -> Config -> Config - [A] after :: (MonadIO m, MonadBaseControl IO m) => m b -> Stream m a -> Stream m a -[A] Streamly.Data.Stream.MkType - [A] class Monad m => MonadReader r (m :: Type -> Type) | m -> r - [A] class MonadTrans (t :: Type -> Type -> Type -> Type) - [A] class Read a - [A] class IsString a - [A] class IsList l - [A] Identity - [A] throwM :: (MonadThrow m, Exception e) => e -> m a - [A] readsPrec :: Read a => Int -> ReadS a - [A] reader :: MonadReader r m => (r -> a) -> m a - [A] readPrec :: Read a => ReadPrec a - [A] readListPrec :: Read a => ReadPrec [a] - [A] readList :: Read a => ReadS [a] - [A] mkZipType :: String -> String -> Bool -> Q [Dec] - [A] mkCrossType :: String -> String -> Bool -> Q [Dec] - [A] local :: MonadReader r m => (r -> r) -> m a -> m a - [A] liftIO :: MonadIO m => IO a -> m a - [A] lift :: (MonadTrans t, Monad m) => m a -> t m a - [A] ask :: MonadReader r m => m r - [A] ap :: Monad m => m (a -> b) -> m a -> m b -[D] Streamly.Data.Fold.Tee - [C] Tee - [A] [unTee] :: Tee (m :: Type -> Type) a b -> Fold m a b - [R] [toFold] :: Tee m a b -> Fold m a b - [C] Tee - [O] Tee :: Fold m a b -> Tee m a b - [N] Tee :: Fold m a b -> Tee (m :: Type -> Type) a b - [A] toFold :: forall (m :: Type -> Type) a b. Tee m a b -> Fold m a b -[R] Streamly.Data.Fold -[D] Streamly.Data.Array.Foreign - [A] Control.DeepSeq.NFData1 - [A] instance Control.DeepSeq.NFData1 Streamly.Internal.Data.Array.Type.Array - [A] Control.DeepSeq.NFData - [A] instance Control.DeepSeq.NFData (Streamly.Internal.Data.Array.Type.Array a) - [C] writeN - [O] writeN :: forall m a. (MonadIO m, Storable a) => Int -> Fold m a (Array a) - [N] writeN :: forall (m :: Type -> Type) a. (MonadIO m, Unbox a) => Int -> Fold m a (Array a) - [C] writeLastN - [O] writeLastN :: (Storable a, MonadIO m) => Int -> Fold m a (Array a) - [N] writeLastN :: forall a (m :: Type -> Type). (Storable a, Unbox a, MonadIO m) => Int -> Fold m a (Array a) - [C] write - [O] write :: forall m a. (MonadIO m, Storable a) => Fold m a (Array a) - [N] write :: forall (m :: Type -> Type) a. (MonadIO m, Unbox a) => Fold m a (Array a) - [C] toList - [O] toList :: Storable a => Array a -> [a] - [N] toList :: Unbox a => Array a -> [a] - [C] readRev - [O] readRev :: forall m a. (Monad m, Storable a) => Unfold m (Array a) a - [N] readRev :: forall (m :: Type -> Type) a. (Monad m, Unbox a) => Array a -> Stream m a - [C] read - [O] read :: forall m a. (Monad m, Storable a) => Unfold m (Array a) a - [N] read :: forall (m :: Type -> Type) a. (Monad m, Unbox a) => Array a -> Stream m a - [C] length - [O] length :: forall a. Storable a => Array a -> Int - [N] length :: Unbox a => Array a -> Int - [C] getIndex - [O] getIndex :: forall a. Storable a => Array a -> Int -> Maybe a - [N] getIndex :: Unbox a => Int -> Array a -> Maybe a - [C] fromListN - [O] fromListN :: Storable a => Int -> [a] -> Array a - [N] fromListN :: Unbox a => Int -> [a] -> Array a - [C] fromList - [O] fromList :: Storable a => [a] -> Array a - [N] fromList :: Unbox a => [a] -> Array a - [C] cast - [O] cast :: forall a b. Storable b => Array a -> Maybe (Array b) - [N] cast :: forall a b. Unbox b => Array a -> Maybe (Array b) -[R] Streamly.Console.Stdio diff --git a/docs/User/ProjectRelated/ApiChangelogs/0.8.3.txt b/docs/User/ProjectRelated/ApiChangelogs/0.8.3.txt deleted file mode 100644 --- a/docs/User/ProjectRelated/ApiChangelogs/0.8.3.txt +++ /dev/null @@ -1,261 +0,0 @@ -# API diff as generated by cabal-diff with minor edits. -# ~~~ means deprecated module -# ~~ means deprecated symbol - -#---------------------------- -# Changes from 0.8.0 to 0.8.1 -#---------------------------- - -@@@ Streamly.FileSystem.Handle -++ getChunk :: MonadIO m => Int -> Handle -> m (Array Word8) -++ putChunk :: (MonadIO m, Storable a) => Handle -> Array a -> m () - -#---------------------------- -# Changes from 0.7.3 to 0.8.0 -#---------------------------- - -# Deprecated, merged into Streamly.Prelude -~~~ Streamly -# Fixity changes -++ infixr 6 `ahead` -++ infixr 6 `async` -++ infixr 6 `parallel` -++ infixr 6 `serial` -++ infixr 6 `wAsync` -++ infixr 6 `wSerial` - -# Added -@@@ Streamly.Console.Stdio - -# Deprecated, renamed -~~~ Streamly.Memory.Array -@@@ Streamly.Data.Array.Foreign - -# Moved from Streamly.Memory.Array -++ data Array a -++ fromList :: Storable a => [a] -> Array a -++ fromListN :: Storable a => Int -> [a] -> Array a -++ length :: forall a. Storable a => Array a -> Int -++ read :: forall m a. (Monad m, Storable a) => Unfold m (Array a) a -++ toList :: Storable a => Array a -> [a] -++ write :: forall m a. (MonadIO m, Storable a) => Fold m a (Array a) -++ writeN :: forall m a. (MonadIO m, Storable a) => Int -> Fold m a (Array a) - -# Added -++ asBytes :: Array a -> Array Word8 -++ cast :: forall a b. Storable b => Array a -> Maybe (Array b) -++ getIndex :: Storable a => Array a -> Int -> Maybe a -++ readRev :: forall m a. (Monad m, Storable a) => Unfold m (Array a) a -++ writeLastN :: (Storable a, MonadIO m) => Int -> Fold m a (Array a) - -@@@ Streamly.Data.Fold -# Signature changed - - product :: (Monad m, Num a) => Fold m a a - + product :: (Monad m, Num a, Eq a) => Fold m a a - -# Removed (Moved to the Streamly.Data.Fold.Tee module) --- instance (Monad m, Floating b) => Floating (Fold m a b) --- instance (Monad m, GHC.Num.Num b) => GHC.Num.Num (Fold m a b) --- instance (Monad m, GHC.Real.Fractional b) => GHC.Real.Fractional (Fold m a b) --- instance (Semigroup b, Monad m) => Semigroup (Fold m a b) --- instance (Semigroup b, Monoid b, Monad m) => Monoid (Fold m a b) --- instance Applicative m => Applicative (Fold m a) - -# Renamed -~~ mapM :: Monad m => (b -> m c) -> Fold m a b -> Fold m a c -++ rmapM :: Monad m => (b -> m c) -> Fold m a b -> Fold m a c - -# Deprecated -~~ sequence :: Monad m => Fold m a (m b) -> Fold m a b - -# Added -++ catMaybes :: Monad m => Fold m a b -> Fold m (Maybe a) b -++ chunksOf :: Monad m => Int -> Fold m a b -> Fold m b c -> Fold m a c -++ concatMap :: Monad m => (b -> Fold m a c) -> Fold m a b -> Fold m a c -++ filter :: Monad m => (a -> Bool) -> Fold m a r -> Fold m a r -++ filterM :: Monad m => (a -> m Bool) -> Fold m a r -> Fold m a r -++ foldl' :: Monad m => (b -> a -> b) -> b -> Fold m a b -++ foldlM' :: Monad m => (b -> a -> m b) -> m b -> Fold m a b -++ foldr :: Monad m => (a -> b -> b) -> b -> Fold m a b -++ lmap :: (a -> b) -> Fold m b r -> Fold m a r -++ lmapM :: Monad m => (a -> m b) -> Fold m b r -> Fold m a r -++ many :: Monad m => Fold m a b -> Fold m b c -> Fold m a c -++ mapMaybe :: Monad m => (a -> Maybe b) -> Fold m b r -> Fold m a r -++ rollingHash :: (Monad m, Enum a) => Fold m a Int64 -++ rollingHashWithSalt :: (Monad m, Enum a) => Int64 -> Fold m a Int64 -++ sconcat :: (Monad m, Semigroup a) => a -> Fold m a a -++ serialWith :: Monad m => (a -> b -> c) -> Fold m x a -> Fold m x b -> Fold m x c -++ take :: Monad m => Int -> Fold m a b -> Fold m a b -++ takeEndBy :: Monad m => (a -> Bool) -> Fold m a b -> Fold m a b -++ takeEndBy_ :: Monad m => (a -> Bool) -> Fold m a b -> Fold m a b -++ teeWith :: Monad m => (a -> b -> c) -> Fold m x a -> Fold m x b -> Fold m x c -++ toListRev :: Monad m => Fold m a [a] - -# Added -@@@ Streamly.Data.Fold.Tee - -@@@ Streamly.Data.Unfold -# Added -++ crossWith :: Monad m => (b -> c -> d) -> Unfold m a b -> Unfold m a c -> Unfold m a d -++ drop :: Applicative m => Int -> Unfold m a b -> Unfold m a b -++ dropWhile :: Monad m => (b -> Bool) -> Unfold m a b -> Unfold m a b -++ dropWhileM :: Monad m => (b -> m Bool) -> Unfold m a b -> Unfold m a b -++ filter :: Monad m => (b -> Bool) -> Unfold m a b -> Unfold m a b -++ filterM :: Monad m => (b -> m Bool) -> Unfold m a b -> Unfold m a b -++ fromList :: Applicative m => Unfold m [a] a -++ fromListM :: Applicative m => Unfold m [m a] a -++ fromStream :: (IsStream t, Applicative m) => Unfold m (t m a) a -++ function :: Applicative m => (a -> b) -> Unfold m a b -++ functionM :: Applicative m => (a -> m b) -> Unfold m a b -++ iterateM :: Monad m => (a -> m a) -> Unfold m (m a) a -++ lmap :: (a -> c) -> Unfold m c b -> Unfold m a b -++ lmapM :: Monad m => (a -> m c) -> Unfold m c b -> Unfold m a b -++ many :: Monad m => Unfold m a b -> Unfold m b c -> Unfold m a c -++ mapM :: Monad m => (b -> m c) -> Unfold m a b -> Unfold m a c -++ repeatM :: Monad m => Unfold m (m a) a -++ replicateM :: Monad m => Int -> Unfold m (m a) a -++ take :: Monad m => Int -> Unfold m a b -> Unfold m a b -++ takeWhile :: Monad m => (b -> Bool) -> Unfold m a b -> Unfold m a b -++ takeWhileM :: Monad m => (b -> m Bool) -> Unfold m a b -> Unfold m a b -++ unfoldr :: Applicative m => (a -> Maybe (b, a)) -> Unfold m a b -++ unfoldrM :: Applicative m => (a -> m (Maybe (b, a))) -> Unfold m a b -++ zipWith :: Monad m => (b -> c -> d) -> Unfold m a b -> Unfold m a c -> Unfold m a d - -# Deprecated, renamed to Streamly.Unicode.Stream -~~~ Streamly.Data.Unicode.Stream - -@@@ Streamly.Network.Socket -# Added -++ forSocketM :: (MonadMask m, MonadIO m) => (Socket -> m ()) -> Socket -> m () -++ readChunk :: Int -> Socket -> IO (Array Word8) -++ writeChunk :: Storable a => Socket -> Array a -> IO () -++ writeChunksWithBufferOf :: (MonadIO m, Storable a) => Int -> Socket -> Fold m (Array a) () - -@@@ Streamly.Prelude -# Signature changed - - after :: (IsStream t, Monad m) => m b -> t m a -> t m a - + after :: (IsStream t, MonadIO m, MonadBaseControl IO m) => m b -> t m a -> t m a - - bracket :: (IsStream t, MonadCatch m) => m b -> (b -> m c) -> (b -> t m a) -> t m a - + bracket :: (IsStream t, MonadAsync m, MonadCatch m) => m b -> (b -> m c) -> (b -> t m a) -> t m a - - 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 :: IsStream t => (t m b -> t m b -> t m b) -> (a -> t m b) -> t m a -> t m b - - finally :: (IsStream t, MonadCatch m) => m b -> t m a -> t m a - + finally :: (IsStream t, MonadAsync m, MonadCatch m) => m b -> t m a -> t m a - - foldlM' :: Monad m => (b -> a -> m b) -> b -> SerialT m a -> m b - + foldlM' :: Monad m => (b -> a -> m b) -> m b -> SerialT m a -> m b - - postscanlM' :: (IsStream t, Monad m) => (b -> a -> m b) -> b -> t m a -> t m b - + postscanlM' :: (IsStream t, Monad m) => (b -> a -> m b) -> m b -> t m a -> t m b - - scanlM' :: (IsStream t, Monad m) => (b -> a -> m b) -> b -> t m a -> t m b - + scanlM' :: (IsStream t, Monad m) => (b -> a -> m b) -> m b -> t m a -> t m b - -# Renamed -~~ yieldM :: (Monad m, IsStream t) => m a -> t m a -++ fromEffect :: (Monad m, IsStream t) => m a -> t m a -~~ yield :: IsStream t => a -> t m a -++ fromPure :: IsStream t => a -> t m a -~~ concatUnfold :: (IsStream t, Monad m) => Unfold m a b -> t m a -> t m b -++ unfoldMany :: (IsStream t, Monad m) => Unfold m a b -> t m a -> t m b - -# Moved from "Streamly" module -## Fixity change -++ infixr 6 `ahead` -++ infixr 6 `async` -++ infixr 6 `parallel` -++ infixr 6 `serial` -++ infixr 6 `wAsync` -++ infixr 6 `wSerial` -## Renamed -~~ foldWith :: (IsStream t, Foldable f) => (t m a -> t m a -> t m a) -> f (t m a) -> t m a -++ concatFoldableWith :: (IsStream t, Foldable f) => (t m a -> t m a -> t m a) -> f (t m a) -> t m a -~~ forEachWith :: (IsStream t, Foldable f) => (t m b -> t m b -> t m b) -> f a -> (a -> t m b) -> t m b -++ concatForFoldableWith :: (IsStream t, Foldable f) => (t m b -> t m b -> t m b) -> f a -> (a -> t m b) -> t m b -~~ foldMapWith :: (IsStream t, Foldable f) => (t m b -> t m b -> t m b) -> (a -> t m b) -> f a -> t m b -++ concatMapFoldableWith :: (IsStream t, Foldable f) => (t m b -> t m b -> t m b) -> (a -> t m b) -> f a -> t m b -~~ aheadly :: IsStream t => AheadT m a -> t m a -++ fromAhead :: IsStream t => AheadT m a -> t m a -~~ asyncly :: IsStream t => AsyncT m a -> t m a -++ fromAsync :: IsStream t => AsyncT m a -> t m a -~~ parallely :: IsStream t => ParallelT m a -> t m a -++ fromParallel :: IsStream t => ParallelT m a -> t m a -~~ serially :: IsStream t => SerialT m a -> t m a -++ fromSerial :: IsStream t => SerialT m a -> t m a -~~ wAsyncly :: IsStream t => WAsyncT m a -> t m a -++ fromWAsync :: IsStream t => WAsyncT m a -> t m a -~~ wSerially :: IsStream t => WSerialT m a -> t m a -++ fromWSerial :: IsStream t => WSerialT m a -> t m a -~~ zipAsyncly :: IsStream t => ZipAsyncM m a -> t m a -++ fromZipAsync :: IsStream t => ZipAsyncM m a -> t m a -~~ zipSerially :: IsStream t => ZipSerialM m a -> t m a -++ fromZipSerial :: IsStream t => ZipSerialM m a -> t m a -## unchanged -++ class (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)) => IsStream t -++ data AheadT m a -++ data AsyncT m a -++ data ParallelT m a -++ data Rate Rate :: Double -> Double -> Double -> Int -> Rate -++ data SerialT m a -++ data WAsyncT m a -++ data WSerialT m a -++ data ZipAsyncM m a -++ data ZipSerialM m a -++ type Ahead = AheadT IO -++ type Async = AsyncT IO -++ type MonadAsync m = (MonadIO m, MonadBaseControl IO m, MonadThrow m) -++ type Parallel = ParallelT IO -++ type Serial = SerialT IO -++ type WAsync = WAsyncT IO -++ type WSerial = WSerialT IO -++ type ZipAsync = ZipAsyncM IO -++ type ZipSerial = ZipSerialM IO -++ (|$) :: (IsStream t, MonadAsync m) => (t m a -> t m b) -> t m a -> t m b -++ (|$.) :: (IsStream t, MonadAsync m) => (t m a -> m b) -> t m a -> m b -++ (|&) :: (IsStream t, MonadAsync m) => t m a -> (t m a -> t m b) -> t m b -++ (|&.) :: (IsStream t, MonadAsync m) => t m a -> (t m a -> m b) -> m b -++ [rateBuffer] :: Rate -> Int -++ [rateGoal] :: Rate -> Double -++ [rateHigh] :: Rate -> Double -++ [rateLow] :: Rate -> Double -++ adapt :: (IsStream t1, IsStream t2) => t1 m a -> t2 m a -++ ahead :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a -++ async :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a -++ avgRate :: IsStream t => Double -> t m a -> t m a -++ constRate :: IsStream t => Double -> t m a -> t m a -++ maxBuffer :: IsStream t => Int -> t m a -> t m a -++ maxRate :: IsStream t => Double -> t m a -> t m a -++ maxThreads :: IsStream t => Int -> t m a -> t m a -++ minRate :: IsStream t => Double -> t m a -> t m a -++ mkAsync :: (IsStream t, MonadAsync m) => t m a -> t m a -++ parallel :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a -++ rate :: IsStream t => Maybe Rate -> t m a -> t m a -++ serial :: IsStream t => t m a -> t m a -> t m a -++ wAsync :: (IsStream t, MonadAsync m) => t m a -> t m a -> t m a -++ wSerial :: IsStream t => t m a -> t m a -> t m a - -# Added -++ delay :: (IsStream t, MonadIO m) => Double -> t m a -> t m a -++ foldMany :: (IsStream t, Monad m) => Fold m a b -> t m a -> t m b -++ intercalate :: (IsStream t, Monad m) => Unfold m b c -> b -> t m b -> t m c -++ intercalateSuffix :: (IsStream t, Monad m) => Unfold m b c -> b -> t m b -> t m c -++ liftInner :: (Monad m, IsStream t, MonadTrans tr, Monad (tr m)) => t m a -> t (tr m) a -++ runReaderT :: (IsStream t, Monad m) => m s -> t (ReaderT s m) a -> t m a -++ runStateT :: Monad m => m s -> SerialT (StateT s m) a -> SerialT m (s, a) - -# Removed: documentation moved to streamly-docs module in docs dir -@@@ Streamly.Tutorial - -# Deprecated, renamed -~~~ Streamly.Data.Unicode.Stream -@@@ Streamly.Unicode.Stream -# Moved from Streamly.Data.Unicode.Stream -## Behavior changed -++ decodeUtf8 :: (Monad m, IsStream t) => t m Word8 -> t m Char -++ encodeLatin1 :: (IsStream t, Monad m) => t m Char -> t m Word8 -++ encodeUtf8 :: (Monad m, IsStream t) => t m Char -> t m Word8 -## Unchanged -++ decodeLatin1 :: (IsStream t, Monad m) => t m Word8 -> t m Char - -# Added -++ decodeUtf8' :: (Monad m, IsStream t) => t m Word8 -> t m Char -++ encodeLatin1' :: (IsStream t, Monad m) => t m Char -> t m Word8 -++ encodeStrings :: (MonadIO m, IsStream t) => (SerialT m Char -> SerialT m Word8) -> t m String -> t m (Array Word8) -++ encodeUtf8' :: (Monad m, IsStream t) => t m Char -> t m Word8 diff --git a/docs/User/ProjectRelated/CONTRIBUTORS.md b/docs/User/ProjectRelated/CONTRIBUTORS.md deleted file mode 100644 --- a/docs/User/ProjectRelated/CONTRIBUTORS.md +++ /dev/null @@ -1,156 +0,0 @@ -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.9.0 - -Harendra Kumar -Ranjeet Kumar Ranjan -Adithya Kumar -Francesco Gazzetta -Ishan Bhanuka - -## 0.8.2 - -* Adithya Kumar -* Harendra Kumar -* Ranjeet Kumar Ranjan -* Anurag Hooda -* andremarianiello - -## 0.8.1.1 - -* Harendra Kumar -* Julian Ospald - -## 0.8.1 - -* Harendra Kumar -* Adithya Kumar -* Ranjeet Kumar Ranjan -* Julian Ospald -* Sanchayan Maity - -## 0.8.0 - -* Harendra Kumar -* Adithya Kumar -* Pranay Sashank -* Ranjeet Kumar Ranjan -* Anurag Hooda -* Ahmed Zaheer Dadarkar -* Shruti Umat -* Joseph Koshy (Google LLC.) -* Sanchayan Maity -* Kirill Elagin -* Shlok Datye -* Julian Ospald -* George Thomas -* endgame - -## 0.7.3 - -* Pranay Sashank -* Adithya Kumar -* Julian Ospald - -## 0.7.2 - -* Harendra Kumar -* Pranay Sashank -* Adithya Kumar -* Sanchayan Maity -* Julian Ospald -* Shlok Datye - -## 0.7.1 - -* Harendra Kumar -* Pranay Sashank -* Adithya Kumar -* Sanchayan Maity -* Brian Wignall -* Julian Ospald -* Lucian Ursu - -## 0.7.0 - -* Harendra Kumar -* Pranay Sashank -* Artyom Kazak -* David Feuer -* Adithya Kumar -* Aravind Gopal - -## 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 diff --git a/docs/User/ProjectRelated/Changelog.md b/docs/User/ProjectRelated/Changelog.md deleted file mode 100644 --- a/docs/User/ProjectRelated/Changelog.md +++ /dev/null @@ -1,636 +0,0 @@ -# Changelog - - - -## 0.9.0 (Mar 2023) - -Also see the following: - -* [streamly-0.9.0 Upgrade Guide](/docs/User/ProjectRelated/Upgrading.md) or - https://hackage.haskell.org/package/streamly-0.9.0/docs/docs/User/ProjectRelated/Upgrading.md -* [streamly-0.9.0 API Changelog](/docs/User/ProjectRelated/ApiChangelogs/0.8.3-0.9.0.txt) or - https://hackage.haskell.org/package/streamly-0.9.0/docs/docs/User/ProjectRelated/ApiChangelogs/0.8.3-0.9.0.txt -* [streamly-core-0.1.0 API Changelog](/core/docs/ApiChangelogs/0.1.0.txt) or - https://hackage.haskell.org/package/streamly-core-0.1.0/docs/docs/ApiChangelogs/0.1.0.txt - -### Package split - -`streamly` package is split into two packages, (1) `streamly-core` that -has only GHC boot library depdendecies, and (2) `streamly` that contains -higher level operations (including concurrent ones) with additional -dependencies. Make sure you add a dependency on `streamly-core` to keep old -code working. - -* Moved the following modules from `streamly` package to the - `streamly-core` package: - * Streamly.Console.Stdio - * Streamly.Data.Fold - * Streamly.Data.Unfold - * Streamly.FileSystem.Handle - * Streamly.Unicode.Stream - -### Breaking Changes - -* Unboxed arrays now require `Unbox` constraint instead of `Storable`. - The `Unbox` typeclass can be imported from `Streamly.Data.Array`. You - can use generic deriving to derive Unbox instances. -* Stream type in all modules has been changed to the new `Stream` type - replacing the existing `IsStream t` or `SerialT` types. Use `fromStream`, - `toStream` from `Streamly.Prelude` module to adapt the types. -* Signatures changed in `Streamly.Data.Unfold`: - * `fromStream` - * `replicateM` - -### Major Changes - -`Streamly.Prelude` module has been deprecated, equivalent -functionality is covered by the `Streamly.Data.Stream`, -`Streamly.Data.Stream.Prelude`, and `Streamly.Data.Fold` modules. The -new modules use a monomorphic `Stream` type instead of the polymorphic -`IsStream t` type. - -`Streamly.Data.Stream` module and the `Stream` type are meant for -writing high-performance fused pipelines not involving explicit -recursion. For writing code that may require recursive function calls, -`Streamly.Data.Stream.StreamK` module and the `StreamK` type have been -added which provide a CPS based stream implementation. `Stream` and -`StreamK` types can be easily interconverted. - -The old code can be adapted to use the new modules with some changes. -See the [upgrade guide](/docs/User/ProjectRelated/Upgrading.md) for more -details on how to adapt your existing code to the new release. - -### Enhancements - -* Added the following new modules to the `streamly` package: - * Streamly.Data.Stream.MkType - * Streamly.Data.Stream.Prelude -* Added the following new modules to the `streamly-core` package: - * Streamly.Data.Array - * Streamly.Data.Array.Generic - * Streamly.Data.MutArray - * Streamly.Data.MutArray.Generic - * Streamly.Data.Parser - * Streamly.Data.ParserK - * Streamly.Data.Stream - * Streamly.Data.StreamK - * Streamly.FileSystem.Dir - * Streamly.FileSystem.File - * Streamly.Unicode.Parser - * Streamly.Unicode.String - -### Deprecations - -* Remove support for GHC 8.4.* - -Several modules and functions have been deprecated, equivalent modules or -functions are suggested in the deprecation warning messages by the compiler. - -### Internal module changes - -If you cannot find an internal module that you were using, it may have -been moved to the `streamly-core` package or may have been renamed. - -Following modules are moved to `streamly-core` package and renamed: - * Streamly.Internal.Data.Array.Stream.Foreign -> Streamly.Internal.Data.Stream.Chunked - * Streamly.Internal.Data.Array.Stream.Mut.Foreign -> Streamly.Internal.Data.Array.Mut.Stream - -## 0.8.3 (September 2022) - -* Fix build with GHC 9.4 - -## 0.8.2 (Mar 2022) - -* Fix performance issues for GHC-9. These changes coupled with GHC changes - expected to land in 9.2.2 will bring the performance back to the same levels - as before. - -## 0.8.1.1 (Dec 2021) - -* Disable building FileSystem.Events where FS Events isn't supported. - -## 0.8.1 (Nov 2021) - -See ApiChangelogs/0.8.3.txt for new APIs introduced. - -### Bug Fixes - -* Several bug fixes in the Array module: - * Fix writeN fold eating away one element when applied multiple times - [#1258](https://github.com/composewell/streamly/issues/1258). - * Fix potentially writing beyond allocated memory when shrinking. Likely - cause of [#944](https://github.com/composewell/streamly/issues/944). - * Fix potentially writing beyond allocated memory when writing the last - element. Likely cause of - [#944](https://github.com/composewell/streamly/issues/944). - * Fix missing pointer touch could potentially cause use of freed memory. - * Fix unnecessary additional allocation due to a bug -* Fix a bug in classifySessionsBy, see - [PR #1311](https://github.com/composewell/streamly/pull/1311). The bug - could cause premature ejection of a session when input events with the - same key are split into multiple sessions. - -### Notable Internal API Changes - -* `tapAsync` from `Streamly.Internal.Data.Stream.Parallel` has been moved to - `Streamly.Internal.Data.Stream.IsStream` and renamed to `tapAsyncK`. -* `Fold2` has now been renamed to `Refold` and the corresponding `Fold2` - combinators have been either renamed or removed. - -## 0.8.0 (Jun 2021) - -See [API Changelog](/docs/User/ProjectRelated/ApiChangelogs/0.8.3.txt) for a complete list of signature -changes and new APIs introduced. - -### Breaking changes - -* `Streamly.Prelude` - * `fold`: this function may now terminate early without consuming - the entire stream. For example, `fold Fold.head stream` would - now terminate immediately after consuming the head element from - `stream`. This may result in change of behavior in existing programs - if the program relies on the evaluation of the full stream. -* `Streamly.Data.Unicode.Stream` - * The following APIs no longer throw errors on invalid input, use new - APIs suffixed with a prime for strict behavior: - * decodeUtf8 - * encodeLatin1 - * encodeUtf8 -* `Streamly.Data.Fold`: - * Several instances have been moved to the `Streamly.Data.Fold.Tee` - module, please use the `Tee` type to adapt to the changes. - -### Bug Fixes - -* Concurrent Streams: The monadic state for the stream is now propagated across - threads. Please refer to - [#369](https://github.com/composewell/streamly/issues/369) for more info. -* `Streamly.Prelude`: - * `bracket`, `handle`, and `finally` now also work correctly on streams - that aren't fully drained. Also, the resource acquisition and release is - atomic with respect to async exceptions. - * `iterate`, `iterateM` now consume O(1) space instead of O(n). - * `fromFoldableM` is fixed to be concurrent. -* `Streamly.Network.Inet.TCP`: `accept` and `connect` APIs now close the socket - if an exception is thrown. -* `Streamly.Network.Socket`: `accept` now closes the socket if an exception is - thrown. - -### Enhancements - -* See [API Changelog](/docs/User/ProjectRelated/ApiChangelogs/0.8.3.txt) for a complete list of new - modules and APIs introduced. -* The Fold type is now more powerful, the new termination behavior allows - to express basic parsing of streams using folds. -* Many new Fold and Unfold APIs are added. -* A new module for console IO APIs is added. -* Experimental modules for the following are added: - * Parsing - * Deserialization - * File system event handling (fsnotify/inotify) - * Folds for streams of arrays -* Experimental `use-c-malloc` build flag to use the c library `malloc` for - array allocations. This could be useful to avoid pinned memory fragmentation. - - -### Notable Internal/Pre-release API Changes - -Breaking changes: - -* The `Fold` type has changed to accommodate terminating folds. -* Rename: `Streamly.Internal.Prelude` => `Streamly.Internal.Data.Stream.IsStream` -* Several other internal modules have been renamed and re-factored. - -Bug fixes: - -* A bug was fixed in the conversion of `MicroSecond64` and `MilliSecond64` - (commit e5119626) -* Bug fix: `classifySessionsBy` now flushes sessions at the end and terminates. - -### Miscellaneous - -* Drop support for GHC 7.10.3. -* The examples in this package are moved to a new github repo - [streamly-examples](https://github.com/composewell/streamly-examples) - -## 0.7.3 (February 2021) - -### Build Issues - -* Fix build issues with primitive package version >= 0.7.1. -* Fix build issues on armv7. - -## 0.7.2 (April 2020) - -### Bug Fixes - -* Fix a bug in the `Applicative` and `Functor` instances of the `Fold` - data type. - -### Build Issues - -* Fix a bug that occasionally caused a build failure on windows when - used with `stack` or `stack ghci`. -* Now builds on 32-bit machines. -* Now builds with `primitive` package version >= 0.5.4 && <= 0.6.4.0 -* Now builds with newer `QuickCheck` package version >= 2.14 && < 2.15. -* Now builds with GHC 8.10. - -## 0.7.1 (February 2020) - -### Bug Fixes - -* Fix a bug that caused `findIndices` to return wrong indices in some - cases. -* Fix a bug in `tap`, `chunksOf` that caused memory consumption to - increase in some cases. -* Fix a space leak in concurrent streams (`async`, `wAsync`, and `ahead`) that - caused memory consumption to increase with the number of elements in the - stream, especially when built with `-threaded` and used with `-N` RTS option. - The issue occurs only in cases when a worker thread happens to be used - continuously for a long time. -* Fix scheduling of WAsyncT stream style to be in round-robin fashion. -* Now builds with `containers` package version < 0.5.8. -* Now builds with `network` package version >= 3.0.0.0 && < 3.1.0.0. - -### Behavior change - -* Combinators in `Streamly.Network.Inet.TCP` no longer use TCP `NoDelay` and - `ReuseAddr` socket options by default. These options can now be specified - using appropriate combinators. - -### Performance - -* Now uses `fusion-plugin` package for predictable stream fusion optimizations -* Significant improvement in performance of concurrent stream operations. -* Improved space and time performance of `Foldable` instance. - -## 0.7.0 (November 2019) - -### 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. -* Fix unbounded memory usage (leak) in `parallel` combinator. The bug manifests - when large streams are combined using `parallel`. - -### 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 (March 2019) - -### Bug Fixes - -* Fix a bug that caused `maxThreads` directive to be ignored when rate control - was not used. - -### Enhancements - -* Add GHCJS support -* Remove dependency on "clock" package - -## 0.6.0 (December 2018) - -### Breaking changes - -* `Monad` constraint may be needed on some of the existing APIs (`findIndices` - and `elemIndices`). - -### Enhancements - -* Add the following functions to Streamly.Prelude: - * Generation: `replicate`, `fromIndices`, `fromIndicesM` - * Enumeration: `Enumerable` type class, `enumerateFrom`, `enumerateFromTo`, - `enumerateFromThen`, `enumerateFromThenTo`, `enumerate`, `enumerateTo` - * Running: `runN`, `runWhile` - * Folds: `(!!)`, `maximumBy`, `minimumBy`, `the` - * Scans: `scanl1'`, `scanl1M' - * Filters: `uniq`, `insertBy`, `deleteBy`, `findM` - * Multi-stream: `eqBy`, `cmpBy`, `mergeBy`, `mergeByM`, `mergeAsyncBy`, - `mergeAsyncByM`, `isPrefixOf`, `isSubsequenceOf`, `stripPrefix`, - `concatMap`, `concatMapM`, `indexed`, `indexedR` -* Following instances were added for `SerialT m`, `WSerialT m` and - `ZipSerialM m`: - * When `m` ~ `Identity`: IsList, Eq, Ord, Show, Read, IsString, NFData, - NFData1, Traversable - * When `m` is `Foldable`: Foldable -* Performance improvements -* Add benchmarks to measure composed and iterated operations - -## 0.5.2 (October 2018) - -### Bug Fixes - -* Cleanup any pending threads when an exception occurs. -* Fixed a livelock in ahead style streams. The problem manifests sometimes when - multiple streams are merged together in ahead style and one of them is a nil - stream. -* As per expected concurrency semantics each forked concurrent task must run - with the monadic state captured at the fork point. This release fixes a bug, - which, in some cases caused an incorrect monadic state to be used for a - concurrent action, leading to unexpected behavior when concurrent streams are - used in a stateful monad e.g. `StateT`. Particularly, this bug cannot affect - `ReaderT`. - -## 0.5.1 (September 2018) - -* Performance improvements, especially space consumption, for concurrent - streams - -## 0.5.0 (September 2018) - -### Bug Fixes - -* Leftover threads are now cleaned up as soon as the consumer is garbage - collected. -* Fix a bug in concurrent function application that in certain cases would - unnecessarily share the concurrency state resulting in incorrect output - stream. -* Fix passing of state across `parallel`, `async`, `wAsync`, `ahead`, `serial`, - `wSerial` combinators. Without this fix combinators that rely on state - passing e.g. `maxThreads` and `maxBuffer` won't work across these - combinators. - -### Enhancements - -* Added rate limiting combinators `rate`, `avgRate`, `minRate`, `maxRate` and - `constRate` to control the yield rate of a stream. -* Add `foldl1'`, `foldr1`, `intersperseM`, `find`, `lookup`, `and`, `or`, - `findIndices`, `findIndex`, `elemIndices`, `elemIndex`, `init` to Prelude - -### Deprecations - -* The `Streamly.Time` module is now deprecated, its functionality is subsumed - by the new rate limiting combinators. - -## 0.4.1 (July 2018) - -### Bug Fixes - -* foldxM was not fully strict, fixed. - -## 0.4.0 (July 2018) - -### Breaking changes - -* Signatures of `zipWithM` and `zipAsyncWithM` have changed -* Some functions in prelude now require an additional `Monad` constraint on - the underlying type of the stream. - -### Deprecations - -* `once` has been deprecated and renamed to `yieldM` - -### Enhancements - -* Add concurrency control primitives `maxThreads` and `maxBuffer`. -* Concurrency of a stream with bounded concurrency when used with `take` is now - limited by the number of elements demanded by `take`. -* Significant performance improvements utilizing stream fusion optimizations. -* Add `yield` to construct a singleton stream from a pure value -* Add `repeat` to generate an infinite stream by repeating a pure value -* Add `fromList` and `fromListM` to generate streams from lists, faster than - `fromFoldable` and `fromFoldableM` -* Add `map` as a synonym of fmap -* Add `scanlM'`, the monadic version of scanl' -* Add `takeWhileM` and `dropWhileM` -* Add `filterM` - -## 0.3.0 (June 2018) - -### Breaking changes - -* Some prelude functions, to whom concurrency capability has been added, will - now require a `MonadAsync` constraint. - -### Bug Fixes - -* Fixed a race due to which, in a rare case, we might block indefinitely on - an MVar due to a lost wakeup. -* Fixed an issue in adaptive concurrency. The issue caused us to stop creating - more worker threads in some cases due to a race. This bug would not cause any - functional issue but may reduce concurrency in some cases. - -### Enhancements -* Added a concurrent lookahead stream type `Ahead` -* Added `fromFoldableM` API that creates a stream from a container of monadic - actions -* Monadic stream generation functions `consM`, `|:`, `unfoldrM`, `replicateM`, - `repeatM`, `iterateM` and `fromFoldableM` can now generate streams - concurrently when used with concurrent stream types. -* Monad transformation functions `mapM` and `sequence` can now map actions - concurrently when used at appropriate stream types. -* Added concurrent function application operators to run stages of a - stream processing function application pipeline concurrently. -* Added `mapMaybe` and `mapMaybeM`. - -## 0.2.1 (June 2018) - -### Bug Fixes -* Fixed a bug that caused some transformation ops to return incorrect results - when used with concurrent streams. The affected ops are `take`, `filter`, - `takeWhile`, `drop`, `dropWhile`, and `reverse`. - -## 0.2.0 (May 2018) - -### Breaking changes -* Changed the semantics of the Semigroup instance for `InterleavedT`, `AsyncT` - and `ParallelT`. The new semantics are as follows: - * For `InterleavedT`, `<>` operation interleaves two streams - * For `AsyncT`, `<>` now concurrently merges two streams in a left biased - manner using demand based concurrency. - * For `ParallelT`, the `<>` operation now concurrently meges the two streams - in a fairly parallel manner. - - To adapt to the new changes, replace `<>` with `serial` wherever it is used - for stream types other than `StreamT`. - -* Remove the `Alternative` instance. To adapt to this change replace any usage - of `<|>` with `parallel` and `empty` with `nil`. -* Stream type now defaults to the `SerialT` type unless explicitly specified - using a type combinator or a monomorphic type. This change reduces puzzling - type errors for beginners. It includes the following two changes: - * Change the type of all stream elimination functions to use `SerialT` - instead of a polymorphic type. This makes sure that the stream type is - always fixed at all exits. - * Change the type combinators (e.g. `parallely`) to only fix the argument - stream type and the output stream type remains polymorphic. - - Stream types may have to be changed or type combinators may have to be added - or removed to adapt to this change. -* Change the type of `foldrM` to make it consistent with `foldrM` in base. -* `async` is renamed to `mkAsync` and `async` is now a new API with a different - meaning. -* `ZipAsync` is renamed to `ZipAsyncM` and `ZipAsync` is now ZipAsyncM - specialized to the IO Monad. -* Remove the `MonadError` instance as it was not working correctly for - parallel compositions. Use `MonadThrow` instead for error propagation. -* Remove Num/Fractional/Floating instances as they are not very useful. Use - `fmap` and `liftA2` instead. - -### Deprecations -* Deprecate and rename the following symbols: - * `Streaming` to `IsStream` - * `runStreaming` to `runStream` - * `StreamT` to `SerialT` - * `InterleavedT` to `WSerialT` - * `ZipStream` to `ZipSerialM` - * `ZipAsync` to `ZipAsyncM` - * `interleaving` to `wSerially` - * `zipping` to `zipSerially` - * `zippingAsync` to `zipAsyncly` - * `<=>` to `wSerial` - * `<|` to `async` - * `each` to `fromFoldable` - * `scan` to `scanx` - * `foldl` to `foldx` - * `foldlM` to `foldxM` -* Deprecate the following symbols for future removal: - * `runStreamT` - * `runInterleavedT` - * `runAsyncT` - * `runParallelT` - * `runZipStream` - * `runZipAsync` - -### Enhancements -* Add the following functions: - * `consM` and `|:` operator to construct streams from monadic actions - * `once` to create a singleton stream from a monadic action - * `repeatM` to construct a stream by repeating a monadic action - * `scanl'` strict left scan - * `foldl'` strict left fold - * `foldlM'` strict left fold with a monadic fold function - * `serial` run two streams serially one after the other - * `async` run two streams asynchronously - * `parallel` run two streams in parallel (replaces `<|>`) - * `WAsyncT` stream type for BFS version of `AsyncT` composition -* Add simpler stream types that are specialized to the IO monad -* Put a bound (1500) on the output buffer used for asynchronous tasks -* Put a limit (1500) on the number of threads used for Async and WAsync types - -## 0.1.2 (March 2018) - -### Enhancements -* Add `iterate`, `iterateM` stream operations - -### Bug Fixes -* Fixed a bug that caused unexpected behavior when `pure` was used to inject - values in Applicative composition of `ZipStream` and `ZipAsync` types. - -## 0.1.1 (March 2018) - -### Enhancements -* Make `cons` right associative and provide an operator form `.:` for it -* Add `null`, `tail`, `reverse`, `replicateM`, `scan` stream operations -* Improve performance of some stream operations (`foldl`, `dropWhile`) - -### Bug Fixes -* Fix the `product` operation. Earlier, it always returned 0 due to a bug -* Fix the `last` operation, which returned `Nothing` for singleton streams - -## 0.1.0 (December 2017) - -* Initial release diff --git a/docs/User/ProjectRelated/Credits.md b/docs/User/ProjectRelated/Credits.md deleted file mode 100644 --- a/docs/User/ProjectRelated/Credits.md +++ /dev/null @@ -1,43 +0,0 @@ -# Credits and Contributions - -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 LICENSE 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 diff --git a/docs/User/ProjectRelated/Github.link b/docs/User/ProjectRelated/Github.link deleted file mode 100644 --- a/docs/User/ProjectRelated/Github.link +++ /dev/null @@ -1,1 +0,0 @@ -https://github.com/composewell/streamly diff --git a/docs/User/ProjectRelated/README.md b/docs/User/ProjectRelated/README.md deleted file mode 100644 --- a/docs/User/ProjectRelated/README.md +++ /dev/null @@ -1,134 +0,0 @@ -# [Streamly][]: Idiomatic Haskell with C-Like Performance - -[![Gitter chat](https://badges.gitter.im/composewell/gitter.svg)](https://gitter.im/composewell/streamly) -[![Hackage](https://img.shields.io/hackage/v/streamly.svg?style=flat)](https://hackage.haskell.org/package/streamly) - -Streamly is a powerful Haskell library that provides developers with -the essential building blocks to create safe, scalable, modular, and -high-performance software. With Streamly, developers can enjoy the -benefits of Haskell's type safety while leveraging C-like program -performance. Streamly offers a comprehensive range of features, -comprising: - -* Haskell's strong type safety. -* C-program-like performance capabilities. -* Flexible, modular building blocks. -* Idiomatic functional programming. -* Fearless, declarative concurrency for seamless parallel execution. -* A collection of ecosystem libraries for fast and efficient development. - -Check out the [Streamly Setup and Usage -Guide](/docs/User/Tutorials/setup-and-usage.md) and [Quick -Overview](/docs/User/Tutorials/quick-overview.md) for an introduction -to the library. For more detailed documentation, visit the [Haskell -Streamly website][Streamly]. - -## Blazing Fast - -Streamly delivers C-like speed in Haskell by fusing stream pipelines -using the stream-fusion technique, resulting in compiled code that is -equivalent to handwritten C code, eliminating intermediate allocations -and function calls. - -For a comprehensive comparison of Streamly to other Haskell streaming -libraries, check out our [streaming benchmarks][streaming-benchmarks] -page. In fact, Streamly's fused loops can be up to 100 times faster than -those of libraries without stream fusion. - -## Declarative Concurrency - -Streamly introduces declarative concurrency to standard functional -streaming abstractions. Declarative concurrency abstracts away the -low-level details of concurrency management, such as locks and threads, -and allows for easier and safer parallelization of code. For example, -with Streamly you can do things like repeat actions concurrently to -generate a stream of results, map functions concurrently on a stream, -and combine multiple streams concurrently to create a single output -stream. - -## Unified API - -Streamly provides a comprehensive and unified API for basic programming -needs, covering a wide range of areas including streaming, concurrency, -logic programming, reactive programming, pinned and unpinned arrays, -serialization, builders, parsers, unicode processing, file-io, file -system events, and network-io. By unifying functionality from disparate -Haskell libraries, Streamly simplifies development while delivering -equivalent or improved performance. Additionally, the complexity -of handling combinations of lazy, strict, bytestring, and text is -eliminated by using streams for lazy evaluation, and by generalizing -bytestring and text to arrays. - -Check out [Streamly's documentation][Streamly] for more information -about Streamly's features. - -## Batteries Included - -In addition to the fundamental programming constructs, Streamly also -provides higher-level functionality through supporting packages such as -[streamly-process][], [streamly-shell][], and [streamly-coreutils][] -that are essential for general programming tasks. Check out the -[streamly-examples][] repository for some program snippets. - -## Highly Modular - -Traditionally, you must choose between modularity and performance when -writing code. However, with [Haskell Streamly][Streamly], you can have -the best of both worlds. By taking advantage of GHC's stream fusion -optimizations (such as `case-of-case` and `spec-constr`), Streamly achieves -performance comparable to an equivalent C program while still allowing -for highly modular code. - -## Credits - -The following authors/libraries have influenced or inspired this library in a -significant way: - - * Roman Leshchinskiy ([vector](http://hackage.haskell.org/package/vector)) - * Gabriella Gonzalez ([foldl](https://hackage.haskell.org/package/foldl)) - * Alberto G. Corona ([transient](https://hackage.haskell.org/package/transient)) - -Please see the [`credits`](/docs/User/ProjectRelated/Credits.md) directory for a full -list of contributors, credits and licenses. - -## Licensing - -Streamly is an [open source](https://github.com/composewell/streamly) -project available under a liberal [BSD-3-Clause license][LICENSE] - -## Contributing to Streamly - -As an open project we welcome contributions: - -* [Streamly Contributor's Guide][CONTRIBUTING.md] -* [Contact the streamly development team](mailto:streamly@composewell.com) - -## Getting Support - -Professional support is available for [Streamly][]: please contact -[support@composewell.com](mailto:support@composewell.com). - -You can also join our [community chat -channel](https://gitter.im/composewell/streamly) on Gitter. - - - -[Streamly]: https://streamly.composewell.com/ -[streaming-benchmarks]: https://github.com/composewell/streaming-benchmarks -[concurrency-benchmarks]: https://github.com/composewell/concurrency-benchmarks -[streamly-examples]: https://github.com/composewell/streamly-examples -[streamly-process]: https://github.com/composewell/streamly-process -[streamly-shell]: https://github.com/composewell/streamly-shell -[streamly-coreutils]: https://github.com/composewell/streamly-coreutils - - - - -[LICENSE]: /LICENSE -[CONTRIBUTING.md]: /docs/Developer/Contributing.md -[docs]: docs/ diff --git a/docs/User/ProjectRelated/Roadmap.link b/docs/User/ProjectRelated/Roadmap.link deleted file mode 100644 --- a/docs/User/ProjectRelated/Roadmap.link +++ /dev/null @@ -1,1 +0,0 @@ -https://github.com/composewell/streamly/issues/1046 diff --git a/docs/User/ProjectRelated/Upgrading.md b/docs/User/ProjectRelated/Upgrading.md deleted file mode 100644 --- a/docs/User/ProjectRelated/Upgrading.md +++ /dev/null @@ -1,279 +0,0 @@ -# Upgrading to streamly 0.9.0 - -Also see: - -* [0.9.0 API Changelog](/docs/User/ProjectRelated/ApiChangelogs/0.8.3-0.9.0.txt) or - https://hackage.haskell.org/package/streamly-0.9.0/docs/docs/User/ProjectRelated/ApiChangelogs/0.8.3-0.9.0.txt - -`Streamly.Prelude` module has been deprecated, equivalent -functionality is covered by the `Streamly.Data.Stream`, -`Streamly.Data.Stream.Prelude`, and `Streamly.Data.Fold` modules. The -new modules use a monomorphic `Stream` type instead of the polymorphic -`IsStream t` type. - -`Streamly.Data.Stream` module and the `Stream` type are designed -for writing high-performance fused pipelines not involving explicit -recursion. For writing code that may require recursive function calls, -`Streamly.Data.Stream.StreamK` module and the `StreamK` type have been -introduced which provide a CPS based stream implementation. `Stream` and -`StreamK` types can be easily interconverted. These changes have been made to -make performance robust and not rely on GHC rewrite rules which could be -fragile. For example, GHC 9.0.x had broken the rewrite rule which was -not fixed until GHC-9.2.2. This split also gives more power and -transparency of the performance behavior to the programmer. - -Instead of using separate stream types for concurrent code, now -you have to use explicit concurrent combinators with appropriate -concurrency parameters. These combinators are available in the -`Streamly.Data.Stream.Prelude` module. This change has been made to allow -programmers to control concurrent behavior in a more robust way and -reduce pitfalls. - -The old code can be adapted to use the new modules with some -changes. More details about this is supplied in the following sections. -Please open an issue if you cannot find a way to adapt the code to the new -release. - -Assume the following imports in the code snippets below: - -```haskell docspec ->>> import qualified Streamly.Data.Stream as Stream ->>> import qualified Streamly.Data.StreamK as StreamK ->>> import qualified Streamly.Data.Stream.Prelude as Stream ->>> import qualified Streamly.Data.Fold as Fold ->>> import qualified Streamly.Data.Parser as Parser -``` - -## The `Stream` and `StreamK` types - -The following types are removed: - -* `IsStream` -* `ZipSerialM` -* `ZipAsyncM` -* `WSerialT` -* `WAsyncT` -* `SerialT` -* `ParallelT` -* `AsyncT` -* `AheadT` - -In the new release, the `Stream` type is the primary stream type that -you will use most of the time. You can think of it as a replacement for -the `SerialT` type. However, it does not provide an Applicative or Monad -instance. - -The `CrossStream` type in `Streamly.Internal.Data.Stream` is a -wrapper over `Stream` type supplying the Monad instance. However, see -the "Stream Fusion" section in the `Streamly.Data.Stream` module for -limitations of the `Stream` type. The `StreamK` type and `CrossStreamK` -(in Streamly.Internal.Data.Stream.StreamK) could be used to overcome the -limitations of `Stream` type. - -If required, you can use the template-haskell functions in -`Streamly.Data.Stream.MkType` to create stream type wrappers (like -ZipSerialM or WSerialT) with custom Applicative or Monadic properties. -But in general, try to avoid specific types and use explicit functions -from the stream module. - -`adapt` is not needed anymore. - -```haskell docspec ->>> (.:) = StreamK.cons ->>> cons = StreamK.cons ->>> wSerial = StreamK.interleave ->>> serial = StreamK.append ->>> fromIndicesM f = Stream.mapM f $ Stream.enumerateFrom 0 ->>> fromIndices f = fmap f $ Stream.enumerateFrom 0 ->>> fromListM = Stream.sequence . Stream.fromList ->>> fromFoldable = StreamK.toStream . StreamK.fromFoldable ->>> fromFoldableM = Stream.sequence . fromFoldable -``` - -## Stream folding functions - -Explicit stream fold functions have been omitted from the new stream -module. You can use the following equivalent definitions: - -```haskell docspec ->>> the = Stream.fold Fold.the ->>> sum = Stream.fold Fold.sum ->>> product = Stream.fold Fold.product ->>> or = Stream.fold Fold.or ->>> null = Stream.fold Fold.null ->>> elemIndex a = Stream.fold (Fold.elemIndex a) ->>> elem a = Stream.fold (Fold.elem a) ->>> notElem a = Stream.fold (Fold.notElem a) ->>> minimumBy ordering = Stream.fold (Fold.minimumBy ordering) ->>> minimum = Stream.fold Fold.minimum ->>> maximumBy ordering = Stream.fold (Fold.maximumBy ordering) ->>> maximum = Stream.fold Fold.maximum ->>> mapM_ f = Stream.fold (Fold.drainMapM f) ->>> lookup a = Stream.fold (Fold.lookup a) ->>> length = Stream.fold Fold.length ->>> last = Stream.fold Fold.latest ->>> head = Stream.fold Fold.one ->>> foldlM' f a = Stream.fold (Fold.foldlM' f a) ->>> foldl1 f = Stream.fold (Fold.foldl1' f) ->>> foldl' f a = Stream.fold (Fold.foldl' f a) ->>> findIndex eq = Stream.fold (Fold.findIndex eq) ->>> find eq = Stream.fold (Fold.find eq) ->>> findM eq = Stream.fold (Fold.findM eq) ->>> drainWhile p = Stream.fold Fold.drain . Stream.takeWhile p ->>> drainN i = Stream.fold Fold.drain . Stream.take i ->>> drain = Stream.fold Fold.drain ->>> any p = Stream.fold (Fold.any p) ->>> and = Stream.fold Fold.and ->>> all p = Stream.fold (Fold.all p) ->>> (!!) i = Stream.fold (Fold.index i) ->>> tail = Streamly.Internal.Data.Stream.StreamK.tail ->>> init = Streamly.Internal.Data.Stream.StreamK.init -``` - -Mapping functions: - -```haskell docspec ->>> map = fmap -``` - -Similarly for scanning use `Stream.scan` or `Stream.postscan` -with an appropriate fold. - -```haskell docspec ->>> scanl' f z = Stream.scan (Fold.foldl' f z) ->>> scanlM' f z = Stream.scan (Fold.foldlM' f z) ->>> postscanl' f z = Stream.postscan (Fold.foldl' f z) ->>> postscanlM' f z = Stream.postscan (Fold.foldlM' f z) ->>> scanl1' f = Stream.catMaybes . Stream.scan (Fold.foldl1' f) ->>> scanl1M' f = Stream.catMaybes . Stream.scan (Fold.foldlM1' f) ->>> concatMapWith = StreamK.concatMapWith ->>> concatFoldableWith f = Prelude.foldr f StreamK.nil ->>> concatMapFoldableWith f g = Prelude.foldr (f . g) StreamK.nil ->>> concatForFoldableWith f xs g = Prelude.foldr (f . g) StreamK.nil xs -``` - -Filters: - -```haskell docspec ->>> deleteBy cmp x = Stream.scanMaybe (Fold.deleteBy cmp x) ->>> findIndices p = Stream.scanMaybe (Fold.findIndices p) ->>> elemIndices a = findIndices (== a) -``` - -Custom implementations of most of these folds, scans and filters are also -available in the `Streamly.Internal.Data.Stream` module. - -## Stream splitting and grouping functions - -Stream splitting and grouping functions like `splitOn`, `wordsBy`, and -`groupsBy` have been omitted from the new stream module as these can -now be implemented using `foldMany` and an appropriate fold from the -`Streamly.Data.Fold` module, or using `parseMany` and an appropriate -parser from the `Streamly.Data.Parser` module. - -```haskell docspec ->>> uniq = Stream.scanMaybe (Fold.uniqBy (==)) ->>> splitWithSuffix p f = Stream.foldMany (Fold.takeEndBy p f) ->>> splitOn = Streamly.Internal.Data.Stream.splitOn ->>> splitOnSuffix p f = Stream.foldMany (Fold.takeEndBy_ p f) ->>> indexedR = Streamly.Internal.Data.Stream.indexedR ->>> groupsBy eq fld = Stream.parseMany (Parser.groupBy eq fld) ->>> groups = groupsBy (==) ->>> groupsByRolling = Streamly.Internal.Data.Stream.groupsRollingBy ->>> wordsBy p f = Stream.parseMany (Parser.wordBy p f) ->>> chunksOf n f = Stream.foldMany (Fold.take n f) -``` - -Direct implementation of these are also available in -`Streamly.Internal.Data.Stream`. - -## Concurrency - -Earlier, concurrent and non-concurrent code used the same -combinators. The code was made concurrent by using different concurrent -stream types such as `AsyncT`, `ParallelT` etc. Now you use the same -stream type everywhere, you have to choose a concurrent combinator -for concurrent behavior. For example, use `mapM` for serial behavior -and `parMapM` for concurrent behavior. Concurrent combinators can -be imported from `Streamly.Data.Stream.Prelude` module. Concurrent -combinators are prefixed with `par`. - -Parallel combinators take a concurrency config argument to specify the -concurrency control parameters. The following combinators have the same -meaning as before except that they are used to set the config parameters -instead of being applied on the stream. -* `rate` -* `maxRate` -* `constRate` -* `avgRate` -* `minRate` -* `maxThreads` -* `maxBuffer` - -A stream is evaluated asynchronously using `parEval`: - -```haskell docspec ->>> :set -XFlexibleContexts ->>> mkAsync = Stream.parEval id -``` - -Earlier `consM` was used to create an implicitly concurrent stream of -actions. In the new release, an equivalent effect is achieved by using -a serial `consM` to create a stream of actions and then explicitly using -`Stream.parEval` on it to evaluate it concurrently. - -```haskell docspec ->>> consM = StreamK.consM ->>> (|:) = consM -``` - -Note that you will have to use `StreamK.toStream` to covert it to `Stream` -before using `parEval` on it. - -Existing generation combinators that can be implemented using new primitives: - -```haskell docspec ->>> repeatM = Stream.parRepeatM ->>> replicateM = Stream.parReplicateM ->>> unfoldrM step = Stream.parEval id . Stream.unfoldrM step ->>> iterateM step = Stream.parEval id . Stream.iterateM step ->>> fromIndicesM f = Stream.parEval id . fromIndicesM f ->>> fromListM = Stream.parSequence id . Stream.fromList ->>> fromFoldableM = Stream.parSequence id . StreamK.toStream . StreamK.fromFoldable -``` - -Existing transformation combinators that can be implemented using `parEval`: - -```haskell docspec ->>> (|$.) f = f . Stream.parEval id ->>> (|&.) = flip (|$.) ->>> (|$) f = f . Stream.parEval id ->>> (|&) = flip (|$) ->>> sequence = Stream.parSequence ->>> mapM = Stream.parMapM -``` - -`parList` is used to evaluate multiple streams concurrently and combine the -outputs. Existing combinators that can be implemented using `parList`: - -```haskell docspec ->>> async x y = Stream.parList id [x, y] ->>> wAsync x y = Stream.parList (Stream.interleaved True) [x, y] ->>> parallel x y = Stream.parList (Stream.eager True) [x, y] ->>> ahead x y = Stream.parList (Stream.ordered True) [x, y] -``` - -Concurrent zipping and merging combinators: - -```haskell docspec ->>> zipAsyncWithM = Stream.parZipWith id ->>> zipAsyncWith = Stream.parZipWith id ->>> mergeAsyncByM = Stream.parMergeByM id ->>> mergeAsyncBy = Stream.parMergeBy id -``` - -The equivalent of `concatMapWith` using a concurrent combining operation in the -new release is `parConcatMap`. The config argument in `parConcatMap` can -specify an equivalent of the combining operation. Similarly, concurrent -`concatFoldableWith`, `concatMapFoldableWith`, `concatForFoldableWith` can also -be expressed using `parConcatMap`. diff --git a/docs/User/Tutorials/ConcurrentStreams.hs b/docs/User/Tutorials/ConcurrentStreams.hs deleted file mode 100644 --- a/docs/User/Tutorials/ConcurrentStreams.hs +++ /dev/null @@ -1,771 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-unused-imports #-} --- | --- Module : User.Tutorials.ConcurrentStreams --- Copyright : (c) 2017 Composewell Technologies --- --- License : BSD3 --- Maintainer : streamly@composewell.com --- --- THIS TUTORIAL IS OBSOLETE. --- --- In this tutorial we will show how streamly can be used for idiomatic and --- declarative concurrent programming. Before you go through this tutorial we --- recommend that you take a look at the Streamly serial streams tutorial. - -module User.Tutorials.ConcurrentStreams - ( - -- * Imports - -- $setup - - -- * Concurrent Streams - -- $concurrentStreams - - -- * Combining Streams - -- $flavors - - -- * Imports and Supporting Code - -- $imports - - -- * Generating Streams Concurrently - -- $generatingConcurrently - - -- * Concurrent Pipeline Stages - -- $concurrentApplication - - -- * Mapping Concurrently - -- $concurrentTransformation - - -- * Merging Streams - - -- ** Semigroup Style - - -- *** Deep Speculative Composition ('Ahead') - -- $ahead - - -- *** Deep Asynchronous Composition ('Async') - -- $async - - -- *** Wide Asynchronous Composition ('WAsync') - -- $wasync - - -- *** Parallel Asynchronous Composition ('Parallel') - -- $parallel - - -- XXX we should deprecate and remove the mkAsync API - -- Custom composition - -- custom - - -- ** Monoid Style - -- $monoid - - -- * Nesting Streams - - -- ** Monad - -- *** Deep Speculative Nesting ('Ahead') - -- $aheadNesting - - -- *** Deep Asynchronous Nesting ('Async') - -- $concurrentNesting - - -- *** Wide Asynchronous Nesting ('WAsync') - -- $wasyncNesting - - -- *** Parallel Asynchronous Nesting ('Parallel') - -- $parallelNesting - - -- ** Applicative - -- $applicative - - -- * Zipping Streams - - -- ** Parallel Zipping - -- $parallelzip - - -- * Concurrent Programming - -- $concurrent - - -- * Writing Concurrent Programs - -- $programs - - -- * Where to go next? - -- $furtherReading - ) -where - -import Streamly.Data.Stream -import Data.Semigroup -import Control.Applicative -import Control.Monad -import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.Trans.Class (MonadTrans (lift)) - --- CAUTION: please keep setup and imports sections in sync - --- XXX This tutorial has to be rewritten. - --- $setup --- In most of example snippets we do not repeat the imports. Where imports are --- not explicitly specified use the imports shown below. --- --- >>> :m --- >>> :set -fno-warn-deprecations --- >>> import Data.Function ((&)) --- >>> import Streamly.Prelude ((|:), (|&)) --- >>> import Streamly.Internal.Data.Stream.Cross (CrossStream(..)) --- >>> import qualified Streamly.Prelude as Stream --- >>> import qualified Streamly.Data.Fold as Fold --- --- To illustrate concurrent vs serial composition aspects, we will use the --- following @delay@ function to introduce a sleep or delay specified in --- seconds. After the delay it prints the number of seconds it slept. --- --- >>> import Control.Concurrent (threadDelay, myThreadId) --- >>> :{ --- delay n = Stream.fromEffect $ do --- threadDelay (n * 1000000) --- tid <- myThreadId --- putStrLn (show tid ++ ": Delay " ++ show n) --- :} --- --- For concurrent examples, use line buffering, otherwise output from different --- threads may get mixed: --- --- >>> import System.IO (stdout, hSetBuffering, BufferMode(LineBuffering)) --- >>> hSetBuffering stdout LineBuffering --- - --- $concurrentStreams --- --- Many stream operations can be done concurrently: --- --- * Streams can be generated concurrently. --- --- * Streams can be merged concurrently. --- --- * Multiple stages in a streaming pipeline can run concurrently. --- --- * Streams can be mapped and zipped concurrently. --- --- * In monadic composition they combine like a list transformer, --- providing concurrent non-determinism. --- --- There are three basic concurrent stream styles, 'Ahead', 'Async', and --- 'Parallel'. The 'Ahead' style streams are similar to 'Serial' except that --- they can speculatively execute multiple stream actions concurrently in --- advance. 'Ahead' would return exactly the same stream as 'Serial' except --- that it may execute the actions concurrently. The 'Async' style streams, --- like 'Ahead', speculatively execute multiple stream actions in advance but --- return the results in their finishing order rather than in the stream --- traversal order. 'Parallel' is like 'Async' except that it provides --- unbounded parallelism instead of controlled parallelism. --- --- For easy reference, we can classify the stream types based on /execution order/, --- /consumption order/, and /bounded or unbounded/ concurrency. --- Execution could be serial (i.e. synchronous) or asynchronous. In serial --- execution we execute the next action in the stream only after the previous --- one has finished executing. In asynchronous execution multiple actions in --- the stream can be executed asynchronously i.e. the next action can start --- executing even before the first one has finished. Consumption order --- determines the order in which the outputs generated by the composition are --- consumed. Consumption could be serial or asynchronous. In serial --- consumption, the outputs are consumed in the traversal order, in --- asynchronous consumption the outputs are consumed as they arrive i.e. first --- come first serve order. --- --- +------------+--------------+--------------+--------------+ --- | Type | Execution | Consumption | Concurrency | --- +============+==============+==============+==============+ --- | 'Serial' | Serial | Serial | None | --- +------------+--------------+--------------+--------------+ --- | 'Ahead' | Asynchronous | Serial | bounded | --- +------------+--------------+--------------+--------------+ --- | 'Async' | Asynchronous | Asynchronous | bounded | --- +------------+--------------+--------------+--------------+ --- | 'Parallel' | Asynchronous | Asynchronous | unbounded | --- +------------+--------------+--------------+--------------+ --- --- All these types can be freely inter-converted using type conversion --- combinators or type annotations, without any cost, to achieve the desired --- composition style. To force a particular type of composition, we coerce the --- stream type using the corresponding type adapting combinator from --- 'fromSerial', 'fromAhead', 'fromAsync', or 'fromParallel'. The default stream type --- is inferred as 'Serial' unless you change it by using one of the combinators --- or by using a type annotation. - --- $flavors --- --- Streams can be combined using '<>' or 'mappend' to form a --- composite. Composite streams can be interpreted in a depth first or --- breadth first manner using an appropriate type conversion before --- consumption. Deep (e.g. 'Serial') stream type variants traverse a --- composite stream in a depth first manner, such that each stream is --- traversed fully before traversing the next stream. Wide --- (e.g. 'WSerial') stream types traverse it in a breadth first --- manner, such that one element from each stream is traversed before --- coming back to the first stream again. --- --- Each stream type has a wide traversal variant prefixed by 'W'. The wide --- variant differs only in the Semigroup\/Monoid, Applicative\/Monad --- compositions of the streams. --- The following table summarizes the basic types and the corresponding wide --- variants: --- --- @ --- +------------+-----------+ --- | Deep | Wide | --- +============+===========+ --- | 'Serial' | 'WSerial' | --- +------------+-----------+ --- | 'Ahead' | 'WAhead' | --- +------------+-----------+ --- | 'Async' | 'WAsync' | --- +------------+-----------+ --- @ --- --- Other than these types there are also 'ZipSerial' and 'ZipAsync' types that --- zip streams serially or concurrently using 'Applicative' operation. These --- types are not monads they are only applicatives and they do not differ in --- 'Semigroup' composition. --- - --- $programs --- --- When writing concurrent programs it is advised to not use the concurrent --- style stream combinators blindly at the top level. That might create too --- much concurrency where it is not even required, and can even degrade --- performance in some cases. In some cases it can also lead to surprising --- behavior because of some code that is supposed to be serial becoming --- concurrent. Please be aware that all concurrency capable APIs that you may --- have used under the scope of a concurrent stream combinator will become --- concurrent. For example if you have a 'repeatM' somewhere in your program --- and you use 'fromParallel' on top, the 'repeatM' becomes fully parallel, --- resulting into an infinite parallel execution . Instead, use the --- /Keep It Serial and Stupid/ principle, start with the default serial --- composition and enable concurrent combinators only when and where necessary. --- When you use a concurrent combinator you can use an explicit 'fromSerial' --- combinator to suppress any unnecessary concurrency under the scope of that --- combinator. - --- $generatingConcurrently --- --- Monadic construction and generation functions like 'consM', 'unfoldrM', --- 'replicateM', 'repeatM', 'iterateM' and 'fromFoldableM' work concurrently --- when used with appropriate stream type combinator. The pure versions of --- these APIs are not concurrent, however you can use the monadic versions even --- for pure computations by wrapping the pure value in a monad to get the --- concurrent generation capability where required. --- --- The following code finishes in 3 seconds (6 seconds when serial): --- --- >>> let p n = threadDelay (n * 1000000) >> return n --- >>> Stream.toList $ Stream.fromParallel $ p 3 |: p 2 |: p 1 |: Stream.nil --- [1,2,3] --- --- >>> Stream.toList $ Stream.fromAhead $ p 3 |: p 2 |: p 1 |: Stream.nil --- [3,2,1] --- --- The following finishes in 10 seconds (100 seconds when serial): --- --- >>> Stream.drain $ Stream.fromAsync $ Stream.replicateM 10 $ p 10 --- - --- $concurrentTransformation --- --- Monadic transformation functions 'mapM' and 'sequence' work concurrently --- when used with appropriate stream type combinators. The pure versions do not --- work concurrently, however you can use the monadic versions even for pure --- computations to get the concurrent transformation capability where required. --- --- This would print a value every second (2 seconds when serial): --- --- >>> let p n = threadDelay (n * 1000000) >> return n --- >>> :{ --- parMap = --- Stream.repeatM (p 1) --- & Stream.fromSerial -- repeatM is serial --- & Stream.mapM (\x -> p 1 >> print x) --- & Stream.fromAhead -- mapM is cocnurrent using Ahead style --- & Stream.drain --- :} --- - --- $concurrentApplication --- --- The concurrent function application operators '|$' and '|&' apply a stream --- argument to a stream function concurrently to compose a concurrent pipeline --- of stream processing functions: --- --- Because both the stages run concurrently, we would see a delay of only 1 --- second instead of 2 seconds in the following: --- --- >>> let p n = threadDelay (n * 1000000) >> return n --- >>> :{ --- parApp = --- Stream.repeatM (p 1) --- |& Stream.mapM (\x -> p 1 >> print x) --- & Stream.drain --- :} - --- $ahead --- --- The 'Semigroup' operation '<>' of the 'Ahead' type combines two streams in a --- /serial depth first/ manner with concurrent lookahead. We use the 'fromAhead' --- type combinator to effect 'Ahead' style of composition. We can also use an --- explicit 'Ahead' type annotation for the stream to achieve the same effect. --- --- When two streams are combined in this manner, the streams are traversed in --- depth first manner just like 'Serial', however it can execute the next --- stream concurrently and keep the results ready when its turn arrives. --- Concurrent execution of the next stream(s) is performed if the first stream --- blocks or if it cannot produce output at the rate that is enough to meet the --- consumer demand. Multiple streams can be executed concurrently to meet the --- demand. The following example would print the result in a second even --- though each action in each stream takes one second: --- --- >>> p n = threadDelay 1000000 >> return n --- >>> stream1 = p 1 |: p 2 |: Stream.nil --- >>> stream2 = p 3 |: p 4 |: Stream.nil --- >>> Stream.toList $ Stream.fromAhead $ stream1 <> stream2 --- [1,2,3,4] --- --- Each stream is constructed 'fromAhead' and then both the streams are merged --- 'fromAhead', therefore, all the actions can run concurrently but the result is --- presented in serial order. --- --- You can also use the polymorphic combinator 'ahead' in place of '<>' to --- compose any type of streams in this manner. - --- $async --- --- The 'Semigroup' operation '<>' of the 'Async' type combines the two --- streams in a depth first manner with parallel look ahead. We use the --- 'fromAsync' type combinator to effect 'Async' style of composition. We --- can also use the 'Async' type annotation for the stream type to achieve --- the same effect. --- --- When two streams with multiple elements are combined in this manner, the --- streams are traversed in depth first manner just like 'Serial', however it --- can execute the next stream concurrently and return the results from it --- as they arrive i.e. the results from the next stream may be yielded even --- before the results from the first stream. Concurrent execution of the next --- stream(s) is performed if the first stream blocks or if it cannot produce --- output at the rate that is enough to meet the consumer demand. Multiple --- streams can be executed concurrently to meet the demand. --- In the example below each element in the stream introduces a constant delay --- of 1 second, however, it takes just one second to produce all the results. --- The results are not guaranteed to be in any particular order: --- --- >>> p n = threadDelay 1000000 >> return n --- >>> stream1 = p 1 |: p 2 |: Stream.nil --- >>> stream2 = p 3 |: p 4 |: Stream.nil --- >>> Stream.toList $ Stream.fromAsync $ stream1 <> stream2 --- ... --- --- The constituent streams are also composed in 'Async' manner and the --- composition of streams too. We can compose the constituent streams to run --- serially, in that case it would take 2 seconds to produce all the results. --- The elements in the serial streams would be in serial order in the results: --- --- >>> p n = threadDelay 1000000 >> return n --- >>> stream = (Stream.fromSerial stream1) <> (Stream.fromSerial stream2) --- >>> Stream.toList $ Stream.fromAsync stream --- ... --- --- In the following example we can see that new threads are started when a --- computation blocks. Notice that the output from the stream with the --- shortest delay is printed first. The whole computation takes @maximum of --- (3, 2, 1) = 3@ seconds: --- --- >>> Stream.drain $ Stream.fromAsync $ delay 3 <> delay 2 <> delay 1 --- ThreadId ...: Delay 1 --- ThreadId ...: Delay 2 --- ThreadId ...: Delay 3 --- --- When we have a tree of computations composed using this style, the tree is --- traversed in DFS style just like the 'Serial' style, the only difference is --- that here we can move on to executing the next stream if a stream blocks. --- However, we will not start new threads if we have sufficient output to --- saturate the consumer. This is why we call it left-biased demand driven or --- adaptive concurrency style, the concurrency tends to stay on the left side --- of the composition as long as possible. More threads are started based on --- the pull rate of the consumer. The following example prints an output every --- second as all of the actions are concurrent. --- --- >>> Stream.drain $ Stream.fromAsync $ (delay 1 <> delay 2) <> (delay 3 <> delay 4) --- ThreadId ...: Delay 1 --- ThreadId ...: Delay 2 --- ThreadId ...: Delay 3 --- ThreadId ...: Delay 4 --- --- All the computations may even run in a single thread when more threads are --- not needed. As you can see, in the following example the computations are --- run in a single thread one after another, because none of them blocks. --- However, if the thread consuming the stream were faster than the producer --- then it would have started parallel threads for each computation to keep up --- even if none of them blocks: --- --- >>> :{ --- traced m = Stream.fromEffect (myThreadId >>= print) >> return m --- stream = traced (sqrt 9) <> traced (sqrt 16) <> traced (sqrt 25) --- main = Stream.drain $ Stream.fromAsync stream --- :} --- --- Note that the order of printing in the above examples may change due to --- variations in scheduling latencies for concurrent threads. --- --- The polymorphic version of the 'Async' binary operation '<>' is called --- 'async'. We can use 'async' to join streams in a left biased --- adaptively concurrent manner irrespective of the type, notice that we have --- not used the 'fromAsync' combinator in the following example: --- --- >>> Stream.drain $ delay 3 `Stream.async` delay 2 `Stream.async` delay 1 --- ThreadId ...: Delay 1 --- ThreadId ...: Delay 2 --- ThreadId ...: Delay 3 --- --- Since the concurrency provided by this operator is demand driven it cannot --- be used when the composed computations start timers that are relative to --- each other because all computations may not be started at the same time and --- therefore timers in all of them may not start at the same time. When --- relative timing among all computations is important or when we need to start --- all computations at once for any reason 'Parallel' style must be used --- instead. --- --- '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 '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. - --- $wasync --- --- The 'Semigroup' operation '<>' of the 'WAsync' type combines two streams in --- a concurrent manner using /breadth first traversal/. We use the 'fromWAsync' --- type combinator to effect 'WAsync' style of composition. We can also use the --- 'WAsync' type annotation for the stream to achieve the same effect. --- --- When streams with multiple elements are combined in this manner, we traverse --- all the streams concurrently in a breadth first manner i.e. one action from --- each stream is performed and yielded to the resulting stream before we come --- back to the first stream again and so on. Even though we execute the actions --- in a breadth first order the outputs are consumed on a first come first --- serve basis. --- --- In the following example we can see that outputs are produced in the breadth --- first traversal order but this is not guaranteed. --- --- >>> stream1 = print 1 |: print 2 |: Stream.nil --- >>> stream2 = print 3 |: print 4 |: Stream.nil --- >>> Stream.drain $ Stream.fromWAsync $ stream1 <> stream2 --- 1 --- 3 --- 2 --- 4 --- --- The polymorphic version of the binary operation '<>' of the 'WAsync' type is --- 'wAsync'. We can use 'wAsync' to join streams using a breadth first --- concurrent traversal irrespective of the type, notice that we have not used --- the 'fromWAsync' combinator in the following example: --- --- >>> Stream.drain $ delay 3 `Stream.wAsync` delay 2 `Stream.wAsync` delay 1 --- ThreadId ...: Delay 1 --- ThreadId ...: Delay 2 --- ThreadId ...: Delay 3 --- --- Since the concurrency provided by this style is demand driven it may not --- be used when the composed computations start timers that are relative to --- each other because all computations may not be started at the same time and --- therefore timers in all of them may not start at the same time. When --- relative timing among all computations is important or when we need to start --- all computations at once for any reason 'Parallel' style must be used --- instead. --- - --- $parallel --- --- The 'Semigroup' operation '<>' of the 'Parallel' type combines the two --- streams in a fairly concurrent manner with round robin scheduling. We use --- the 'fromParallel' type combinator to effect 'Parallel' style of composition. --- We can also use the 'Parallel' type annotation for the stream type to --- achieve the same effect. --- --- When two streams with multiple elements are combined in this manner, the --- monadic actions in both the streams are performed concurrently with a fair --- round robin scheduling. The outputs are yielded in the order in which the --- actions complete. This is pretty similar to the 'WAsync' type, the --- difference is that 'WAsync' is adaptive to the consumer demand and may or --- may not execute all actions in parallel depending on the demand, whereas --- 'Parallel' runs all the streams in parallel irrespective of the demand. --- --- The polymorphic version of the binary operation '<>' of the 'Parallel' type --- is 'parallel'. We can use 'parallel' to join streams in a fairly concurrent --- manner irrespective of the type, notice that we have not used the --- 'fromParallel' combinator in the following example: --- --- >>> Stream.drain $ delay 3 `Stream.parallel` delay 2 `Stream.wAsync` delay 1 --- ThreadId ...: Delay 1 --- ThreadId ...: Delay 2 --- ThreadId ...: Delay 3 --- --- Note that this style of composition cannot be used to combine infinite --- number of streams, as it will lead to an infinite sized scheduling queue. --- - --- XXX to be removed --- $custom --- --- The 'mkAsync' API can be used to create references to asynchronously running --- stream computations. We can then use 'uncons' to explore the streams --- arbitrarily and then recompose individual elements to create a new stream. --- This way we can dynamically decide which stream to explore at any given --- time. Take an example of a merge sort of two sorted streams. We need to --- keep consuming items from the stream which has the lowest item in the sort --- order. This can be achieved using async references to streams. See --- "MergeSort.hs" in . - --- $monoid --- --- All of the following are equivalent and start ten concurrent tasks each with --- a delay from 1 to 10 seconds, resulting in the printing of each number every --- second: --- --- >>> :{ --- main = do --- Stream.drain $ Stream.fromAsync $ foldMap delay [1..10] --- Stream.drain $ Stream.concatFoldableWith Stream.async (map delay [1..10]) --- Stream.drain $ Stream.concatMapFoldableWith Stream.async delay [1..10] --- Stream.drain $ Stream.concatForFoldableWith Stream.async [1..10] delay --- :} --- - --- $aheadNesting --- --- The 'Monad' composition of 'Ahead' type behaves just like 'Serial' except --- that it can speculatively perform a bounded number of next iterations of a --- loop concurrently. --- --- >>> :{ --- Stream.toList $ Stream.fromAhead $ do --- x <- Stream.fromFoldable [3,2,1] --- delay x --- return x --- :} --- ThreadId ...: Delay 1 --- ThreadId ...: Delay 2 --- ThreadId ...: Delay 3 --- [3,2,1] --- --- This code finishes in 3 seconds, 'Serial' would take 6 seconds. As we can --- see all the three iterations are concurrent and run in different threads, --- however, the results are returned in the serial order. --- --- Concurrency is demand driven, when multiple streams are composed using this --- style, the iterations are executed in a depth first manner just like --- 'Serial' i.e. nested iterations are executed before we proceed to the next --- outer iteration. The only difference is that we may execute multiple future --- iterations concurrently and keep the results ready. --- --- The 'fromAhead' type combinator can be used to switch to this style of --- composition. Alternatively, a type annotation can be used to specify the --- type of the stream as 'Ahead'. --- - --- $concurrentNesting --- --- The 'Monad' composition of 'Async' type can perform the iterations of a --- loop concurrently. --- --- >>> :{ --- Stream.drain $ Stream.fromAsync $ do --- x <- Stream.fromFoldable [3,2,1] --- delay x --- :} --- ThreadId ...: Delay 1 --- ThreadId ...: Delay 2 --- ThreadId ...: Delay 3 --- --- As we can see the code after the @fromFoldable@ statement is run three --- times, once for each value of @x@. All the three iterations are concurrent --- and run in different threads. The iteration with least delay finishes first. --- When compared to imperative programming, this can be viewed as a @for@ loop --- with three concurrent iterations. --- --- Concurrency is demand driven i.e. more concurrent iterations are started --- only if the previous iterations are not able to saturate the consumer of the --- output stream. This works exactly the same way as the merging of two --- streams using 'async' works. --- --- The 'fromAsync' type combinator can be used to switch to this style of --- composition. Alternatively, a type annotation can be used to specify the --- type of the stream as 'Async'. --- --- When multiple streams are nested using this style, the iterations are --- concurrently evaluated in a depth first manner: --- --- --- >>> :{ --- Stream.drain $ Stream.fromAsync $ do --- x <- Stream.fromFoldable [1,2] --- y <- Stream.fromFoldable [3,4] --- Stream.fromEffect $ putStrLn $ show (x, y) --- :} --- (1,3) --- ... --- ... --- ... --- --- Nested iterations are given preference for concurrent evaluation i.e. --- (1,4) will be scheduled in preference to (2,3). - --- $wasyncNesting --- --- Like 'Async', the 'Monad' composition of 'WAsync' runs the iterations of a --- loop concurrently. It differs from 'Async' in the nested loop behavior. Like --- 'WSerial', the nested loops in this type are traversed and executed in a --- breadth first manner rather than the depth first manner of 'Async' style. --- --- >>> :{ --- Stream.drain $ Stream.fromWAsync $ do --- x <- Stream.fromSerial $ Stream.fromFoldable [1,2] --- y <- Stream.fromSerial $ Stream.fromFoldable [3,4] --- Stream.fromEffect $ putStrLn $ show (x, y) --- :} --- (1,3) --- (1,4) --- (2,3) --- (2,4) --- --- Note that (2,3) is preferred to (1,4) when evaluating the iterations --- concurrently. This works exactly the same way as the merging of two streams --- using 'wAsync' works. --- --- The 'fromWAsync' type combinator can be used to switch to this style of --- composition. Alternatively, a type annotation can be used to specify the --- type of the stream as 'WAsync'. --- - --- $parallelNesting --- --- Just like 'Async' or 'WAsync' the 'Monad' composition of 'Parallel' runs the --- iterations of a loop concurrently. --- --- >>> :{ --- Stream.drain $ Stream.fromParallel $ do --- x <- Stream.fromFoldable [3,2,1] --- delay x --- :} --- ThreadId ...: Delay 1 --- ThreadId ...: Delay 2 --- ThreadId ...: Delay 3 --- --- It differs from 'Async' and 'WAsync' in the nested loop behavior. All --- iterations of the loop are run fully concurrently irrespective of the --- demand. This works exactly the same way as the merging of streams using --- 'parallel' works. --- --- The 'fromParallel' type combinator can be used to switch to this style of --- composition. Alternatively, a type annotation can be used to specify the --- type of the stream as 'Parallel'. --- - --- $applicative --- --- 'Async' can run the iterations concurrently, therefore, it takes a total --- of 6 seconds which is max (1, 2) + max (3, 4): --- --- >>> (Stream.toList $ Stream.fromAsync $ (,) <$> s1 <*> s2) >>= print --- ... --- --- @ --- ThreadId 34: Delay 1 --- ThreadId 36: Delay 2 --- ThreadId 35: Delay 3 --- ThreadId 36: Delay 3 --- ThreadId 35: Delay 4 --- ThreadId 36: Delay 4 --- [(1,3),(2,3),(1,4),(2,4)] --- @ --- --- Similarly, 'WAsync' as well can run the iterations concurrently, but with a --- different style of scheduling than 'Async' as explained in the Monad --- section, therefore, it too takes a total of 6 seconds (2 + 4): --- --- >>> (Stream.toList $ Stream.fromWAsync $ (,) <$> s1 <*> s2) >>= print --- ... --- --- @ --- ThreadId 34: Delay 1 --- ThreadId 36: Delay 2 --- ThreadId 35: Delay 3 --- ThreadId 36: Delay 3 --- ThreadId 35: Delay 4 --- ThreadId 36: Delay 4 --- [(1,3),(2,3),(1,4),(2,4)] --- @ - --- $parallelzip --- --- The applicative instance of 'ZipAsync' type zips streams concurrently. --- 'fromZipAsync' type combinator can be used to switch to parallel applicative --- zip composition: --- --- >>> d n = unCrossStream (CrossStream (delay n) >> return n) --- >>> s1 = Stream.fromSerial $ d 2 <> d 4 --- >>> s2 = Stream.fromSerial $ d 3 <> d 1 --- >>> (Stream.toList $ Stream.fromZipAsync $ (,) <$> s1 <*> s2) >>= print --- ThreadId ...: Delay 2 --- ThreadId ...: Delay 3 --- ThreadId ...: Delay 1 --- ThreadId ...: Delay 4 --- [(2,3),(4,1)] --- --- The actions within each stream are executed serially, however, the two --- streams are run concurrently with respect to each other. Therefore, it takes --- 6 seconds to zip the two streams, which is the maximum of the time to --- evaluate stream s1 (2 + 4 = 6 seconds) and stream s2 (3 + 1 = 4 seconds). - --- $concurrent --- --- When writing concurrent programs there are two distinct places where the --- programmer can control the concurrency. First, when /composing/ a stream by --- merging multiple streams we can choose an appropriate sum style operators to --- combine them concurrently or serially. Second, when /processing/ a stream in --- a monadic composition we can choose one of the monad composition types to --- choose the desired type of concurrency. --- --- In the following example the squares of @x@ and @y@ are computed --- concurrently using the 'async' operation and the square roots of their --- sum are computed serially because of the 'fromSerial' combinator. We can --- choose different combinators for the monadic processing and the stream --- generation, to control the concurrency. We can also use the 'fromAsync' --- combinator instead of explicitly folding with 'async'. --- --- >>> import Data.List (sum) --- >>> :{ --- main = do --- z <- Stream.toList --- $ Stream.fromSerial -- Serial monadic processing (sqrt below) --- $ unCrossStream $ do --- -- Concurrent @"for"@ loop --- x2 <- CrossStream (Stream.concatForFoldableWith Stream.async [1..100] $ --- \x -> Stream.fromPure $ x * x) -- body of the loop --- y2 <- CrossStream (Stream.concatForFoldableWith Stream.async [1..100] $ --- \y -> Stream.fromPure $ y * y) --- return $ sqrt (x2 + y2) --- print $ sum z --- :} --- --- We can see how this directly maps to the imperative style --- model, we use combinators --- and operators instead of the ugly pragmas. --- --- For more concurrent programming examples see, --- . - --- $furtherReading --- --- * Read the reactive programming tutorial --- * See the examples in repo. diff --git a/docs/User/Tutorials/Examples.link b/docs/User/Tutorials/Examples.link deleted file mode 100644 --- a/docs/User/Tutorials/Examples.link +++ /dev/null @@ -1,1 +0,0 @@ -https://github.com/composewell/streamly-examples diff --git a/docs/User/Tutorials/ReactiveProgramming.hs b/docs/User/Tutorials/ReactiveProgramming.hs deleted file mode 100644 --- a/docs/User/Tutorials/ReactiveProgramming.hs +++ /dev/null @@ -1,126 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-unused-imports #-} --- | --- Module : User.Tutorials.ReactiveProgramming --- Copyright : (c) 2017 Composewell Technologies --- --- License : BSD3 --- Maintainer : streamly@composewell.com --- --- THIS TUTORIAL IS OBSOLETE. --- --- In this tutorial we will show how Streamly can be used for reactive --- programming. Before you go through this tutorial we recommend that you take --- a look at the Streamly concurrent programming tutorial. - -module User.Tutorials.ReactiveProgramming - ( - -- * Reactive Programming - -- $reactive - - -- * Where to go next? - -- $furtherReading - ) -where - -import Streamly.Data.Stream -import Data.Semigroup -import Control.Applicative -import Control.Monad -import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.Trans.Class (MonadTrans (lift)) - --- $reactive --- --- Reactive programming is nothing but concurrent streaming which is what --- streamly is all about. With streamly we can generate streams of events, --- merge streams that are generated concurrently and process events --- concurrently. We can do all this without any knowledge about the specifics --- of the implementation of concurrency. In the following example you will see --- that the code is just regular Haskell code without much streamly APIs used --- (active hyperlinks are the streamly APIs) and yet it is a reactive --- application. --- --- This application has two independent and concurrent sources of event --- streams, @acidRain@ and @userAction@. @acidRain@ continuously generates --- events that deteriorate the health of the character in the game. --- @userAction@ can be "potion" or "quit". When the user types "potion" the --- health improves and the game continues. --- --- @ --- {-\# LANGUAGE FlexibleContexts \#-} --- --- import "Streamly.Prelude" (MonadAsync, SerialT) --- import "Streamly.Prelude" as Stream --- import Control.Monad (void) --- import Control.Monad.IO.Class (MonadIO(liftIO)) --- import Control.Monad.State (MonadState, get, modify, runStateT) --- --- data Event = Quit | Harm Int | Heal Int deriving (Show) --- --- userAction :: MonadAsync m => 'SerialT' m Event --- userAction = Stream.'repeatM' $ liftIO askUser --- where --- askUser = do --- command <- getLine --- case command of --- "potion" -> return (Heal 10) --- "harm" -> return (Harm 10) --- "quit" -> return Quit --- _ -> putStrLn "Type potion or harm or quit" >> askUser --- --- acidRain :: MonadAsync m => 'SerialT' m Event --- acidRain = Stream.'fromAsync' $ Stream.'constRate' 1 $ Stream.'repeatM' $ liftIO $ return $ Harm 1 --- --- data Result = Check | Done --- --- runEvents :: (MonadAsync m, MonadState Int m) => 'SerialT' m Result --- runEvents = do --- event \<- userAction \`Stream.'parallel'` acidRain --- case event of --- Harm n -> modify (\\h -> h - n) >> return Check --- Heal n -> modify (\\h -> h + n) >> return Check --- Quit -> return Done --- --- data Status = Alive | GameOver deriving Eq --- --- getStatus :: (MonadAsync m, MonadState Int m) => Result -> m Status --- getStatus result = --- case result of --- Done -> liftIO $ putStrLn "You quit!" >> return GameOver --- Check -> do --- h <- get --- liftIO $ if (h <= 0) --- then putStrLn "You die!" >> return GameOver --- else putStrLn ("Health = " <> show h) >> return Alive --- --- main :: IO () --- main = do --- putStrLn "Your health is deteriorating due to acid rain, type \\\"potion\\\" or \\\"quit\\\"" --- let runGame = Stream.'drainWhile' (== Alive) $ Stream.'mapM' getStatus runEvents --- void $ runStateT runGame 60 --- @ --- --- You can also find the source of this example in the streamly-examples repo --- as . --- It has been adapted from Gabriel's --- --- package. --- This is much simpler compared to the pipes version because of the builtin --- concurrency in streamly. You can also find a SDL based reactive programming --- example adapted from Yampa in --- . - --- $performance --- --- Streamly is highly optimized for performance, it is designed for serious --- high performing, concurrent and scalable applications. We have created the --- --- package which is specifically and carefully designed to measure the --- performance of Haskell streaming libraries fairly and squarely in the right --- way. Streamly performs at par or even better than most streaming libraries --- for serial operations even though it needs to deal with the concurrency --- capability. - --- $furtherReading --- --- * See the examples in repo. diff --git a/docs/User/Tutorials/Tutorial.hs b/docs/User/Tutorials/Tutorial.hs deleted file mode 100644 --- a/docs/User/Tutorials/Tutorial.hs +++ /dev/null @@ -1,521 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-unused-imports #-} --- | --- Module : User.Tutorials.Tutorial --- Copyright : (c) 2017 Composewell Technologies --- --- License : BSD3 --- Maintainer : streamly@composewell.com --- --- THIS TUTORIAL IS OBSOLETE. --- --- In this tutorial we will show how Streamly can be used for idiomatic --- dataflow programming. Before you go through this tutorial we recommend that --- you take a look at the Streamly Getting Started guide so that you are ready --- to try out the examples. - -module User.Tutorials.Tutorial - ( - -- * Imports - -- $setup - - -- * Stream Types - -- $streams - - -- * Imports and Supporting Code - -- $imports - - -- * Generating Streams - -- $generating - - -- * Eliminating Streams - -- $eliminating - - -- * Transforming Streams - -- $transformation - - -- * Merging Streams - - -- ** Semigroup Style - -- $semigroup - - -- *** Deep Serial Composition ('Serial') - -- $serial - - -- *** Wide Serial Composition ('WSerial') - -- $interleaved - - -- ** Monoid Style - -- $monoid - - -- * Nesting Streams - -- $nesting - - -- ** Monad - -- $monad - - -- *** Deep Serial Nesting ('Serial') - -- $regularSerial - - -- *** Wide Serial Nesting ('WSerial') - -- $interleavedNesting - - -- *** Exercise - -- $monadExercise - - -- ** Applicative - -- $applicative - - -- ** Functor - -- $functor - - -- * Zipping Streams - -- $zipping - - -- ** Serial Zipping - -- $serialzip - - -- * Where to go next? - -- $furtherReading - ) -where - -import Streamly.Data.Stream -import Data.Semigroup -import Control.Applicative -import Control.Monad -import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.Trans.Class (MonadTrans (lift)) - --- CAUTION: please keep setup and imports sections in sync - --- XXX This tutorial has to be re-written. - --- $setup --- --- In most of example snippets we do not repeat the imports. Where --- imports are not explicitly specified use the imports shown below. --- --- >>> :m --- >>> :set -fno-warn-deprecations --- >>> import Data.Function ((&)) --- >>> import Streamly.Prelude ((|:), (|&)) --- >>> import Streamly.Data.Stream (Stream) --- >>> import Streamly.Internal.Data.Stream.Cross (CrossStream(..)) --- >>> import qualified Streamly.Prelude as Stream --- >>> import qualified Streamly.Data.Fold as Fold --- - --- $streams --- --- 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 'Serial' type is almost a drop in replacement for pure lists, --- pure lists are a special case of monadic streams. If you use 'nil' in place --- of '[]' and '|:' in place ':' you can replace a list with a 'Serial' stream. --- The only difference is that the elements must be monadic type and to operate --- on the streams we must use the corresponding functions from --- "Streamly.Prelude" instead of using the base "Prelude". - --- $generating --- --- 'nil' represents an empty stream and 'consM' or its operator form '|:' adds --- a monadic action at the head of the stream. --- --- >>> Stream.toList Stream.nil --- [] --- --- Stream.toList $ getLine |: getLine |: Stream.nil --- hello --- world --- ["hello","world"] --- --- To create a singleton stream from a pure value use 'fromPure' and to --- create a singleton stream from a monadic action use 'fromEffect'. --- --- >>> Stream.toList $ Stream.fromPure 1 --- [1] --- --- Stream.toList $ Stream.fromEffect getLine --- hello --- ["hello"] --- --- To create a stream from pure values in a 'Foldable' container use --- 'fromFoldable' which is equivalent to a fold using 'cons' and 'nil': --- --- >>> Stream.toList $ Stream.fromFoldable [1..3] --- [1,2,3] --- --- >>> Stream.toList $ Prelude.foldr Stream.cons Stream.nil [1..3] --- [1,2,3] --- --- To create a stream from monadic actions in a 'Foldable' container just use a --- right fold using 'consM' and 'nil': --- --- >>> Stream.drain $ Prelude.foldr (|:) Stream.nil [putStr "Hello ", putStrLn "world!"] --- Hello world! --- --- For more ways to construct a stream see the module "Streamly.Prelude". - --- $eliminating --- --- 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 --- "Streamly.Prelude" module. - --- $transformation --- --- Transformation over a stream is the equivalent of a @for@ loop construct in --- imperative paradigm. We iterate over every element in the stream and perform --- certain transformations for each element. Transformations may involve --- mapping functions over the elements, filtering elements from the stream or --- folding all the elements in the stream into a single value. Streamly streams --- are exactly like lists and you can perform all the transformations in the --- same way as you would on lists. --- --- Here is a simple console echo program that just echoes every input line, --- forever: --- --- >>> :{ --- echo = --- Stream.repeatM getLine --- & Stream.mapM putStrLn --- & Stream.drain --- :} --- --- The following code snippet reads lines from standard input, filters blank --- lines, drops the first non-blank line, takes the next two, up cases them, --- numbers them and prints them: --- --- >>> import Data.Char (toUpper) --- >>> :{ --- main = --- Stream.repeatM getLine --- & Stream.filter (not . null) --- & Stream.drop 1 --- & Stream.take 2 --- & fmap (map toUpper) --- & Stream.zipWith (\n s -> show n ++ " " ++ s) (Stream.fromFoldable [1..]) --- & Stream.mapM putStrLn --- & Stream.drain --- :} --- - --- $semigroup --- --- We can combine two streams into a single stream using semigroup composition --- operation '<>'. Streams can be combined in many different ways as described --- in the following sections, the '<>' operation behaves differently depending --- on the stream type in effect. The stream type and therefore the composition --- style can be changed at any point using one of the type combinators as --- discussed earlier. - --- $serial --- --- The 'Semigroup' operation '<>' of the 'Serial' type combines the two streams --- in a /serial depth first/ manner. We use the 'fromSerial' type combinator to --- effect 'Serial' style of composition. We can also use an explicit 'Serial' --- type annotation for the stream to achieve the same effect. However, since --- 'Serial' is the default type unless explicitly specified by using a --- combinator, we can omit using an explicit combinator or type annotation for --- this style of composition. --- --- When two streams with multiple elements are combined in this manner, the --- monadic actions in the two streams are performed sequentially i.e. first all --- actions in the first stream are performed sequentially and then all actions --- in the second stream are performed sequentially. We call it --- /serial depth first/ as the full depth of one stream is fully traversed --- before we move to the next. The following example prints the sequence 1, 2, --- 3, 4: --- --- >>> stream1 = print 1 |: print 2 |: Stream.nil --- >>> stream2 = print 3 |: print 4 |: Stream.nil --- >>> Stream.drain $ stream1 <> stream2 --- 1 --- 2 --- 3 --- 4 --- --- All actions in both the streams are performed serially in the same thread. --- --- The polymorphic version of the binary operation '<>' of the 'Serial' type is --- 'serial'. We can use 'serial' to join streams in a sequential manner --- irrespective of the type of stream: --- --- >>> Stream.drain $ stream1 `Stream.serial` stream2 --- 1 --- 2 --- 3 --- 4 --- - --- $interleaved --- --- The 'Semigroup' operation '<>' of the 'WSerial' type combines the two --- streams in a /serial breadth first/ manner. We use the fromWSerial type --- combinator to effect 'WSerial' style of composition. We can also use the --- 'WSerial' type annotation for the stream to achieve the same effect. --- --- When two streams with multiple elements are combined in this manner, we --- traverse all the streams in a breadth first manner i.e. one action from each --- stream is performed and yielded to the resulting stream before we come back --- to the first stream again and so on. --- The following example prints the sequence 1, 3, 2, 4 --- --- >>> stream1 = print 1 |: print 2 |: Stream.nil --- >>> stream2 = print 3 |: print 4 |: Stream.nil --- >>> Stream.drain $ Stream.fromWSerial $ stream1 <> stream2 --- 1 --- 3 --- 2 --- 4 --- --- Even though the monadic actions of the two streams are performed in an --- interleaved manner they are all performed serially in the same thread. --- --- The polymorphic version of the 'WSerial' binary operation '<>' is called --- 'wSerial'. We can use 'wSerial' to join streams in an interleaved manner --- irrespective of the type, notice that we have not used the fromWSerial --- combinator in the following example: --- --- >>> Stream.drain $ stream1 `Stream.wSerial` stream2 --- 1 --- 3 --- 2 --- 4 --- --- Note that this composition cannot be used to fold infinite number of streams --- since it requires preserving the state until a stream is finished. - --- $monoid --- --- We can use 'Monoid' instances to fold a container of streams in the desired --- style using 'fold' or 'foldMap'. We have also provided some fold utilities --- to fold streams using the polymorphic combine operations: --- --- * 'concatFoldableWith' is like 'fold', it folds a 'Foldable' container of --- streams using the given composition operator. --- * 'concatMapFoldableWith' is like 'foldMap', it folds like --- @concatFoldableWith@ but also maps a function before folding. --- * 'concatForFoldableWith' is like @concatMapFoldableWith@ but the container --- argument comes before the function argument. --- --- All of the following are equivalent: --- --- >>> :{ --- traced = Stream.fromEffect . print --- main = do --- Stream.drain $ foldMap traced [1..10] --- Stream.drain $ Stream.concatFoldableWith Stream.serial (map traced [1..10]) --- Stream.drain $ Stream.concatMapFoldableWith Stream.serial traced [1..10] --- Stream.drain $ Stream.concatForFoldableWith Stream.serial [1..10] traced --- :} --- - --- $nesting --- --- Till now we discussed ways to apply transformations on a stream or to merge --- streams together to create another stream. We mentioned earlier that --- transforming a stream is similar to a @for@ loop in the imperative paradigm. --- We will now discuss the concept of a nested composition of streams which is --- analogous to nested @for@ loops in the imperative paradigm. Functional --- programmers call this style of composition a list transformer or @ListT@. --- Logic programmers call it a logic monad or non-deterministic composition, --- but for ordinary imperative minded people like me it is easier to think in --- terms of good old nested @for@ loops. --- --- $monad --- --- In functional programmer's parlance the 'Monad' instances of different --- 'IsStream' types implement non-determinism, exploring all possible --- combination of choices from both the streams. From an imperative --- programmer's point of view it behaves like nested loops i.e. for each --- element in the first stream and for each element in the second stream --- execute the body of the loop. --- --- The 'Monad' instances of 'Serial', 'WSerial', 'Async' and 'WAsync' --- stream types support different flavors of nested looping. In other words, --- they are all variants of list transformer. The nesting behavior of these --- types correspond exactly to the way they merge streams as we discussed in --- the previous section. --- - --- $regularSerial --- --- The 'Monad' composition of the 'CrossStream' type behaves like a standard list --- transformer. --- --- Let's start with an example with a simple @for@ loop without any nesting. --- For simplicity of illustration we are using streams of pure values in all --- the examples. However, the streams could also be made of monadic actions --- instead. --- --- >>> :{ --- Stream.drain $ unCrossStream $ do --- x <- CrossStream (Stream.fromFoldable [3,2,1]) --- CrossStream (Stream.fromEffect $ print x) --- :} --- 3 --- 2 --- 1 --- --- As we can see, the code after the @fromFoldable@ statement is run three --- times, once for each value of @x@ drawn from the stream. All the three --- iterations are serial and run in the same thread one after another. In --- imperative terms this is equivalent to a @for@ loop with three iterations. --- --- We can write the console echo program that we wrote earlier using the monad --- instance: --- --- >>> :{ --- main = --- Stream.drain $ unCrossStream $ do --- x <- CrossStream (Stream.repeatM getLine) --- CrossStream (Stream.fromEffect $ putStrLn x) --- :} --- --- When multiple streams are composed using this style they nest in a DFS --- manner: --- --- >>> :{ --- Stream.drain $ unCrossStream $ do --- x <- CrossStream (Stream.fromFoldable [1,2]) --- y <- CrossStream (Stream.fromFoldable [3,4]) --- CrossStream (Stream.fromEffect $ print (x, y)) --- :} --- (1,3) --- (1,4) --- (2,3) --- (2,4) --- --- i.e. inner loop iterations ((1,3), (1,4)) are executed before we proceed to --- the next iteration of the outer loop ((2,3), (2,4)). This behaves just like --- nested @for@ loops in imperative programming. --- --- Notice that this is analogous to merging streams of type 'Serial' or merging --- streams using 'serial'. - --- $interleavedNesting --- --- TBD: generate the WSerial type using the TH utils. --- --- The 'Monad' composition of 'WSerial' type interleaves the iterations of --- outer and inner loops in a nested loop composition. --- --- >> :{ --- Stream.drain $ getWSerial $ do --- x <- WSerialStream (Stream.fromFoldable [1,2]) --- y <- WSerialStream (Stream.fromFoldable [3,4]) --- WSerialStream (Stream.fromEffect $ print (x, y)) --- :} --- (1,3) --- (2,3) --- (1,4) --- (2,4) --- --- Note that (2,3) is preferred to (1,4). This works exactly the same way as --- the merging of two streams using 'wSerial' works. --- --- The fromWSerial type combinator can be used to switch to this style of --- composition. Alternatively, a type annotation can be used to specify the --- type of the stream as 'WSerial'. --- - --- $monadExercise --- --- >>> :{ --- composed :: Stream IO () --- composed = unCrossStream $ do --- sz <- CrossStream sizes --- cl <- CrossStream colors --- sh <- CrossStream shapes --- CrossStream (Stream.fromEffect $ print (sz, cl, sh)) --- where --- sizes = Stream.fromFoldable [1, 2, 3] --- colors = Stream.fromFoldable ["red", "green", "blue"] --- shapes = Stream.fromFoldable ["triangle", "square", "circle"] --- :} --- - --- $functor --- --- 'fmap' transforms a stream by mapping a function on all elements of the --- stream. 'fmap' behaves in the same way for all stream types, it is always --- serial. --- --- >>> (Stream.toList $ fmap show $ Stream.fromFoldable [1..10]) >>= print --- ["1","2","3","4","5","6","7","8","9","10"] --- --- Also see functions 'mapM' and 'sequence' from "Streamly.Prelude" module --- which can map actions concurrently depending on the type of the input stream. - --- $applicative --- --- Applicative is precisely the same as the 'ap' operation of 'Monad'. For --- zipping applicatives separate types 'ZipStream' and 'ZipAsync' are --- provided. --- --- The following is an example of 'CrossStream' applicative, it runs all iterations --- serially: --- --- >>> p n = Stream.fromEffect (print n >> pure n) --- >>> s1 = p 1 <> p 2 --- >>> s2 = p 3 <> p 4 --- --- >>> (Stream.toList $ unCrossStream $ (,) <$> CrossStream s1 <*> CrossStream s2) >>= print --- 1 --- 3 --- 4 --- 2 --- 3 --- 4 --- [(1,3),(1,4),(2,3),(2,4)] --- --- Similarly, 'WSerial' applicative runs the iterations in an interleaved --- order but being serial it too takes a total of 17 seconds: --- --- >> (Stream.toList $ Stream.WSerialStream $ (,) <$> WSerialStream s1 <*> WSerialStream s2) >>= print --- 1 --- 3 --- 2 --- 3 --- 4 --- 4 --- [(1,3),(2,3),(1,4),(2,4)] - --- $zipping --- --- Zipping is a special transformation where the corresponding elements of two --- streams are combined together using a zip function producing a new stream of --- outputs. Two different types are provided for serial and concurrent zipping. --- These types provide an applicative instance that can be used to lift --- functions to zip the argument streams. --- Also see the zipping functions in the "Streamly.Prelude" module. - --- $serialzip --- --- The applicative instance of 'ZipSerial' type zips streams serially. --- 'fromZipSerial' type combinator can be used to switch to serial applicative --- zip composition: --- --- >>> p n = Stream.fromEffect (print n >> pure n) --- >>> s1 = Stream.fromSerial $ p 1 <> p 2 --- >>> s2 = Stream.fromSerial $ p 3 <> p 4 --- >>> (Stream.toList $ Stream.fromZipSerial $ (,) <$> s1 <*> s2) >>= print --- 1 --- 3 --- 2 --- 4 --- [(1,3),(2,4)] --- - --- $furtherReading --- --- * Read the concurrent streams tutorial --- * See the examples in repo. diff --git a/docs/User/Tutorials/all-your-base.jpg b/docs/User/Tutorials/all-your-base.jpg new file mode 100644 Binary files /dev/null and b/docs/User/Tutorials/all-your-base.jpg differ diff --git a/docs/User/Tutorials/before-you-begin.md b/docs/User/Tutorials/before-you-begin.md deleted file mode 100644 --- a/docs/User/Tutorials/before-you-begin.md +++ /dev/null @@ -1,58 +0,0 @@ - - -# Before You Begin - -In this tutorial, we assume basic knowledge of Haskell syntax, constructs and -lazy evaluation. The [Haskell wikibook](https://en.wikibooks.org/wiki/Haskell) -may be a good place to start and get familiar with Haskell. - -If you wish to follow along and run the examples in this tutorial, you will -need to have [Streamly][] installed. Please see the [Setup and -Usage](/docs/User/Tutorials/setup-and-usage.md) guide for instructions -on how to install and use [Streamly][]. - -If you wish to run benchmarks, please be sure to build your -application using the instructions in the [Build Guide](/docs/User/HowTo/Compiling.md). - -## Streamly Library Packages - -Streamly comprises two packages, the -[streamly-core](https://hackage.haskell.org/package/streamly-core) -package provides functionality that depends only on boot libraries, and -the [streamly](https://hackage.haskell.org/package/streamly) package -provides additional functionality like concurrency, time, lifted -exceptions, and networking. - -For high-level functionality built over streamly like streaming -system processes, shell programming, GNU coreutils, statistics, -and compression libraries please see the [streamly ecosystem -packages](https://streamly.composewell.com/ecosystem.html). - -## Released and Pre-release modules - -Some of the examples in this tutorial may use modules from the -`Internal` Streamly module hierarchy. These modules are not really -internal to the library. We classify `Streamly` modules into two -categories: - -* _Released modules and APIs_: These modules and APIs are - stable. Significant changes to these modules and APIs will cause - Streamly's version number to change according to the package versioning - policy. -* _Pre-release modules and APIs_: These modules and APIs have not been - formally released yet. They may change in the near future, and such - changes will not necessarily be reflected in Streamly's package - version number. As yet unreleased modules and APIs reside in the - `Internal` namespace. - -Please use a minor release upper bound to adhere to the Haskell PVP when -using a pre-release (internal) module. - - - -[Streamly]: https://streamly.composewell.com/ diff --git a/docs/User/Tutorials/examples-package.link b/docs/User/Tutorials/examples-package.link new file mode 100644 --- /dev/null +++ b/docs/User/Tutorials/examples-package.link @@ -0,0 +1,1 @@ +https://github.com/composewell/streamly-examples/blob/master/README.md diff --git a/docs/User/Tutorials/functionality-overview.md b/docs/User/Tutorials/functionality-overview.md new file mode 100644 --- /dev/null +++ b/docs/User/Tutorials/functionality-overview.md @@ -0,0 +1,135 @@ +# Functionality At a Glance + +Streamly allows the programmer to write high-performance code +concisely and idiomatically using high level constructs, and with high +expressivity. + +## Streams + +**Streaming**: Streamly is a general purpose computing framework +based on data flow programming paradigm also known as the streaming +paradigm. Streaming enables writing modular and composable applications +declaratively. + +**High Performance**: Streamly focuses on high performance in all +areas comparable to low programming languages like C. To achieve that +streamly uses a GHC optimization popularly known as stream fusion. All +abstractions in streamly are designed for stream fusion. It makes sure +that stream fusion works reliably. The abstractions in streamly also +allow nested stream fusion, for example, the `Unfold` abstraction is +specifically designed for nested fusion (an alternative to `concatMap`) +which does not fuse. + +**Unified Abstractions**: Furthermore, streamly provides a range +of unified streaming abstractions for representing real life +applications. In general, it includes stream producers and consumers. In +particular, streaming abstractions include `Stream` representing the +stream producers, `Scan` the stream transformers, `Fold` representing +the stream consumers, `Parser` representing the stream consumers with +failure and backtracking. All these abstractions are unified, interwork +with each other, they are all designed based on the same underlying +principles. All other functionality in streamly and applications based +on streamly are designed based on these fundamental abstractions. + +**Concise**: The functionality of lists, list-transformer, +logic-programming, streaming, streaming folds, parsers which is covered +by numerous library in the Haskell ecosystem are all represented +efficiently, with the highest possible performance with just these few +abstractions. + +**Interworking**: Streamly streams can be converted to and from other streaming +types in the Haskell ecosystem. See the [interop +examples](https://github.com/composewell/streamly-examples/tree/master/examples/Interop) +in the [streamly-examples](https://github.com/composewell/streamly-examples) +repository. + +## Arrays + +**Arrays**: Arrays complement streams. While streams are used for +in-flight data processing, arrays are used for storing data-at-rest +and for random access. If you look carefully, the core functionality +in streamly is _only_ streams and arrays, the remaining part is just +high level functionality built on these two. All you need to build +any application is streams and arrays. Streamly unifies these two +fundamental concepts, they are intertwined, some stream functionality +requires arrays and some array functionality requires streams. That is +also the reason why we cannot separate these two cleanly in different +packages. + +**High Performance**: Similar to streams, arrays are designed for high +performance. While arrays also provide native and high-performance +operations utilizing the random and chunked access nature of arrays, +in most cases they can be processed and transformed efficiently using +streams. Thus, providing a concise API utilizing streams. Unboxed arrays +provide the highest performance. + +**Unified Abstractions**: Streamly provides a wide range of abstractions +using arrays to express all types of applications. Unboxed arrays +provide the highest performance whereas boxed arrays provide more +flexibility. Immutable arrays (the `Array` type) guarantee that the data +does not change whereas mutable arrays (the `MutArray` type) provide +in-place mutation for performance where needed. Pinned arrays provide +interfacing with the OS whereas unpinned arrays provide freedom from +fragmentation of memory. The `Unbox` and `Serialize` type classes assist +in high-performance serialization of Haskell data to and from arrays. + +**Concise**: The functionality of array processing and serialization +which is covered by numerous library in the Haskell ecosystem are all +represented efficiently, well-integrated with streams, with the highest +possible performance, and in a concise and unified way. Especially, the +functionality of `bytestring`, `text` and `vector` packages can all be +represented by the single `Array` type in streamly and `MutArray` if you +want them to be mutable. + +**Interworking**: Streamly arrays can be converted to and from +other popular array types (e.g. bytestring, text and vector) in +the Haskell ecosystem at zero cost i.e. without copying. See the +[streamly-bytestring](https://github.com/psibi/streamly-bytestring) +repository. + + +## Declarative Concurrency + +Streamly introduces concurrency to the streaming paradigm preserving +the modularity and composability of serial composition. It enables the +programmer to write concurrent programs in a high-level declarative +manner, without using low level concurrency primitives like threads +and synchronization. No explicit thread pools are needed. The degree +of concurrency can be automatically adjusted dynamically based on the +demand by the consumer. + +Arrays are processed using streams and streams are concurrent, +therefore, arrays can be processed concurrently. + +## Reactive Programming + +Streaming and concurrency together enable expressing reactive +applications conveniently. See the `AcidRain` game in [Streamly +Examples](https://github.com/composewell/streamly-examples) for a simple +reactive programming example. See the `CirclingSquare` example in +[Streamly Examples](https://github.com/composewell/streamly-examples) +for a simple SDL based reactive programming example. To summarize, +streamly provides a unified computing framework for streaming, +non-determinism and functional reactive programming in an elegant and +simple API that is a natural extension of pure lists to monadic streams. + + + +## Batteries Included + +As we discussed above the core abstractions in streamly are streams +and arrays. For basic programming needs we also need console IO, file +IO, network IO and unicode text processing. All this functionality is +provided by streamly using the core streaming and array abstractions. diff --git a/docs/User/Tutorials/haskell-lazy-evaluation.md b/docs/User/Tutorials/haskell-lazy-evaluation.md deleted file mode 100644 --- a/docs/User/Tutorials/haskell-lazy-evaluation.md +++ /dev/null @@ -1,215 +0,0 @@ - - -# Haskell Lazy Evaluation - -Haskell is fundamentally different from other languages. In most -languages, a variable name refers to some concrete data in memory; in -Haskell, a variable may refer to concrete data or it could refer to -a computation or expression which when evaluated would produce the -concrete data that the variable is referring to. When the value of the -variable is needed, the computation is evaluated and replaced by -the result. - -When a Haskell program starts, the entire program is an unevaluated -expression which is evaluated on-demand as needed. The top level -expression is forced to produce data when a result is demanded from it -for IO. Parts of the expression are reduced as needed, the reduction -process can be controlled by the programmer. - -## Unevaluated Expressions - -When we assign a value to a name, the name refers to the unevaluated -expression and not what it would produce when evaluated. For example: - -``` ->>> infiniteList = [1..] -``` - -The name `infiniteList` refers to an expression which when evaluated -would generate the list. `infiniteList` is not an actual physical list -but just an expression to generate the list `when needed`. Because we -are not storing the actual list in memory, we can represent an infinite -list without requiring infinite amount of memory. - -Let's try to get the length of this list: - -``` ->>> len = length infiniteList -``` - -Like before, the name `len` refers to an expression that when evaluated -would give us the length of the list. Till now Haskell has been saying -that I duly noted how to do what you want to do but I will do it only -when you need it. Let's ask it to do that now: - -``` ->>> len -...hangs forever -``` - -Now, Haskell has no choice but to start evaluating the expression but we -know it can never finish because the list is infinite. - -All expressions in Haskell are unevaluated by default. Haskell -evaluates the expressions only when it is absolutely required e.g. when -we have to print something, or write it to a file or to network. - -## On-demand Expression Evaluation - -Let us illustrate expression evaluation in Haskell with an example. Write -this little program in a file `example.hs`: - -```haskell -main = - let largeList = [1..1000000::Int] - n = length largeList - in print n -``` - -The expression `largeList` is never evaluated to generate the entire -list at once. It is evaluated on-demand one element at a time by the -`length` function. The `length` function is in turn evaluated by the -`print` function when it evaluates its argument `n`. The `print` -function is evaluated by the top level program because it wants to print -`n` to the console. - -We can verify that the whole list is not stored in memory by looking at -the memory usage of this program. Let's compile and run it: - -``` -$ ghc -O example.hs -$ ./example +RTS -s -1000000 - 51,480 bytes allocated in the heap - 24 bytes copied during GC - 44,328 bytes maximum residency (1 sample(s)) -``` - -`largeList` is an expression representing a million element list, but -the program takes only 44K maximum memory. The `length` function -evaluates `largeList` one element at a time to count them, as soon as -an element is counted it can be garbage collected as there are no more -references to it in the entire program. - -## Expressions Holding up Heap Memory - -Let's try this program instead: - -```haskell -main = do - let largeList = [1..1000000::Int] - x1 = last largeList - x2 = head largeList - in print (x1, x2) -``` - -``` -$ ghc -O example.hs -$ ./example +RTS -s -(1000000,1) - 64,051,552 bytes allocated in the heap - 400 bytes copied during GC - 26,233,360 bytes maximum residency (4 sample(s)) -``` - -This program is showing 26MB maximum residency instead of 44K -earlier. Why is it so? To evaluate the first element of the tuple, `x1`, -we need to evaluate the entire list to get to the last element. However, -the head of the list is referenced by the element `x2` as well which -is yet to be evaluated and used. Therefore, we need to retain the head -until `x2` is printed and freed. But head of the list is referencing the -next element in the list which in turn is referring to the next element -and so on, therefore, the entire list is retained in memory between the -evaluation of `x1` and `x2`. - -If we change the print statement to `(x2, x1)` then we do not need to -retain the entire list between the two evaluations. - -When memory is unexpectedly retained in a program it is known as a -"space-leak" in the Haskell parlance. - -## Forcing Expression Evaluation - -Even if there is no explicit dependency in the program forcing -evaluation of an expression, the programmer can force the evaluation of -an expression using `seq`: - -```haskell -main = do - let largeList = [1..1000000::Int] - x1 = last largeList - x2 = head largeList - in print (x1 `seq` x2) -``` - -Similar to the example in previous section, this example also retains -the entire list in memory because `seq` forces `x1` to be evaluated -before `x2` and then returns `x2`, the evaluated list is held until `x2` is -returned. - -## Avoiding Unnecessary Memory Retention - -Memory retention can be avoided by changing the way we construct the -expression to process the data. We can use Streamly to avoid memory -retention in the above program. - -Let's first write it using streamly and reproduce the same problem: - -```haskell -import Data.Functor.Identity (runIdentity) -import qualified Streamly.Data.Stream as Stream -import qualified Streamly.Data.Fold as Fold - -main = do - let largeList = Stream.fromList [1..1000000::Int] - x1 = runIdentity $ Stream.fold Fold.latest largeList - x2 = runIdentity $ Stream.fold Fold.one largeList - in print (x1, x2) -``` - -This program has the same behavior as the list based program, and for -the same reasons. - -``` -$ ghc -O2 example.hs -$ ./example +RTS -s -(Just 1000000,Just 1) - 64,052,520 bytes allocated in the heap - 400 bytes copied during GC - 26,233,360 bytes maximum residency (4 sample(s)) -``` - -However, we can compose the two folds using the `teeWith` combinator -such that we distribute a each element of the list to both the folds -simultaneously, thus avoiding the retainment of the entire list: - -```haskell -import Data.Functor.Identity (runIdentity) -import qualified Streamly.Data.Stream as Stream -import qualified Streamly.Data.Fold as Fold - -main = do - let largeList = Stream.fromList [1..1000000::Int] - x = Fold.teeWith (,) Fold.latest Fold.one - in print $ runIdentity $ Stream.fold x largeList -``` - -``` -$ ghc -O2 example.hs -$ ./example +RTS -s -(Just 1000000,Just 1) - 64,052,736 bytes allocated in the heap - 280 bytes copied during GC - 44,328 bytes maximum residency (2 sample(s)) -``` - -This program uses constant small memory footprint (44K) irrespective of -the order of the elements in the tuple. When an element is generated by -the list it is supplied to both the folds before generating the next -element, therefore, it can be immediately freed. - -Streamly covers all the functionality of standard Haskell lists but in addition -provides powerful composition tools for better efficiency. diff --git a/docs/User/Tutorials/installing-haskell.md b/docs/User/Tutorials/installing-haskell.md new file mode 100644 --- /dev/null +++ b/docs/User/Tutorials/installing-haskell.md @@ -0,0 +1,30 @@ + + +# Installing Haskell + +In this tutorial, we assume basic knowledge of Haskell syntax, constructs and +lazy evaluation. The [Haskell wikibook](https://en.wikibooks.org/wiki/Haskell) +may be a good place to start and get familiar with Haskell. + +If you wish to follow along and run the examples in this tutorial, you will +need to have Haskell tool chain installed. + +You can choose one of the following options. + +## Haskell Toolchain + +To get started, you will need a fairly recent version (latest three major +versions will work) of the Haskell compiler `ghc` and the build tool +`cabal` installed on your system. Please see the install instructions +at https://www.haskell.org/downloads/ . + +## Development Environment using Nix + +If you use the nix package manager, a nix shell for complete Haskell +development environment - including a consistent set of latest streamly +ecosystem packages, hoogle documentation, vim and vscode editors, +Haskell language server (HLS) and other tools - is available at +[streamly-packages](https://github.com/composewell/streamly-packages). diff --git a/docs/User/Tutorials/learn-by-examples.md b/docs/User/Tutorials/learn-by-examples.md new file mode 100644 --- /dev/null +++ b/docs/User/Tutorials/learn-by-examples.md @@ -0,0 +1,741 @@ + + +# [Streamly][] Quick Tutorial +## About This Document + +This guide introduces programming with [Streamly][] using a few practical +examples: + +* We will start with a simple program that [counts the number of words + in a text](#modular-word-counting). We will then transform this program + into a [concurrent](#concurrent-word-counting) program that can efficiently + use multiprocessing hardware. +* Next, we will create a [concurrent network + server](#a-concurrent-network-server). We then show + how to write a network server that [merges multiple + streams](#merging-incoming-streams) concurrently. +* Our third example shows how to list a directory tree concurrently, + by reading [multiple directories in + parallel](#listing-directories-recursivelyconcurrently). +* Finally, we will look at how to [rate limit](#rate-limiting) stream + processing. + +It [concludes](#further-reading) with suggestions for further reading. + +## Getting Started + +### Installing Streamly + +If you wish to follow along and run examples in this guide, please see +the [Using Streamly](/docs/User/Tutorials/using-streamly.md) guide +for instructions on how to use the `streamly` package interactively or +in a project. + +Additionally, see [Installing +Haskell](/docs/User/Tutorials/installing-haskell.md) for instructions on how to +install haskell. + +### An overview of the types used in these examples + +As an expository device, we have indicated the types at the intermediate +stages of stream computations as comments in the examples below. +The meaning of these types are: + +* A `Stream IO a` is a representation of a sequence of values of type + `a` in the IO Monad. +* A `Fold IO a b` is a representation of a function that converts a stream of + type `a` to a final accumulator of type `b` in the IO Monad. + +## The Examples + +The code snippets below should work in GHCi if all of those are typed +in sequence. For brevity, imports that are already used in earlier +snippets are omitted from the latter ones. + +### Modular Word Counting + +A `Fold` in Streamly is a composable stream consumer. For our first +example, we will use `Fold`s to count the number of bytes, words and lines +present in a file. We will then compose individual `Fold`s together to +count words, bytes and lines at the same time. + +Please see the file [WordCountModular.hs][] for the complete example +program. + +#### Count Bytes (wc -c) + +We start with a code fragment that counts the number of bytes in a file: + +```haskell docspec +>>> import Data.Function ((&)) +>>> import Streamly.FileSystem.Path (Path) +>>> import qualified Streamly.FileSystem.Path as Path +>>> import qualified Streamly.Data.Fold as Fold +>>> import qualified Streamly.Data.Stream as Stream +>>> import qualified Streamly.FileSystem.FileIO as File + +>>> :{ +wcb :: Path -> IO Int +wcb file = do + File.read file -- Stream IO Word8 + & Stream.fold Fold.length -- IO Int +:} +``` + +### Count Lines (wc -l) + +The next code fragment shows how to count the number of lines in a file: + +```haskell docspec +>>> import Data.Word (Word8) +>>> import Streamly.Data.Fold (Fold) +>>> :{ +-- ASCII character 10 is a newline. +countl :: Int -> Word8 -> Int +countl n ch = if ch == 10 then n + 1 else n +:} +>>> :{ +-- The `nlines` fold accepts a stream of `Word8` and returns a line count (`Int`). +nlines :: Monad m => Fold m Word8 Int +nlines = Fold.foldl' countl 0 +:} +>>> :{ +wcl :: Path -> IO Int +wcl file = + File.read file -- Stream IO Word8 + & Stream.fold nlines -- IO Int +:} +``` + +### Count Words (wc -w) + +Our final code fragment counts the number of whitespace-separated words +in a stream: + +```haskell docspec +>>> import Data.Char (chr, isSpace) +>>> :{ +countw :: (Int, Bool) -> Word8 -> (Int, Bool) +countw (n, wasSpace) ch = + if isSpace $ chr $ fromIntegral ch + then (n, True) + else (if wasSpace then n + 1 else n, False) +:} +>>> :{ +-- The `nwords` fold accepts a stream of `Word8` and returns a word count (`Int`). +nwords :: Monad m => Fold m Word8 Int +nwords = fst <$> Fold.foldl' countw (0, True) +:} +>>> :{ +wcw :: Path -> IO Int +wcw file = + File.read file -- Stream IO Word8 + & Stream.fold nwords -- IO Int +:} +``` + +### Counting Bytes, Words and Lines Together + +By using the `Tee` combinator we can compose the three folds that count +bytes, lines and words individually into a single fold that counts all +three at once. The applicative instance of `Tee` distributes its input +to all the supplied folds (`Fold.length`, `nlines`, and `nwords`) and +then combines the outputs from the folds using the supplied combiner +function (`(,,)`). + +```haskell docspec +>>> import Streamly.Data.Fold (Tee(..)) +>>> :{ +-- The fold accepts a stream of `Word8` and returns the three counts. +countAll :: Fold IO Word8 (Int, Int, Int) +countAll = unTee $ (,,) <$> Tee Fold.length <*> Tee nlines <*> Tee nwords +:} +>>> :{ +wc :: Path -> IO (Int, Int, Int) +wc file = + File.read file -- Stream IO Word8 + & Stream.fold countAll -- IO (Int, Int, Int) +:} +``` + +This example demonstrates the excellent modularity offered by +[Streamly][]'s simple and concise API. + +### The Performance of Word Counting + +We compare two equivalent implementations: one using [Streamly][], +and the other using C. + +The performance of the [Streamly word counting +implementation][WordCount.hs] (using ghc-9.4.4 and fusion-plugin) is: + +``` +$ time WordCount-hs gutenberg-500MB.txt +11242220 97050938 574714449 gutenberg-500MB.txt + +real 0m2.033s +user 0m1.821s +sys 0m0.209s +``` + +The performance of an equivalent [wc implementation in C][WordCount.c] is: + +``` +$ time WordCount-c gutenberg-500MB.txt +11242220 97050938 574714449 gutenberg-500MB.txt + +real 0m2.113s +user 0m1.928s +sys 0m0.185s +``` + +### Concurrent Word Counting + +In our next example we show how the task of counting words, lines, +and bytes could be done in parallel on multiprocessor hardware. + +To count words in parallel we first divide the stream into chunks +(arrays), do the counting within each chunk, and then add all the +counts across chunks. We use the same code as above except that we use +arrays for our input data. + +Please see the file [WordCountParallel.hs][] for the complete working +code for this example, including the imports that we have omitted below. + +First we create a new data type `Counts` that holds all the context. + +```haskell docspec +>>> :{ +-- Counts lines words chars lastCharWasSpace +data Counts = Counts !Int !Int !Int !Bool deriving Show +:} +>>> :{ +{-# INLINE count #-} +count :: Counts -> Char -> Counts +count (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 +:} +``` + +The `countArray` function counts the line, word, char counts in one chunk: + +```haskell docspec +>>> import Streamly.Data.Array (Array) + +>>> import qualified Streamly.Data.Array as Array +>>> import qualified Streamly.Unicode.Stream as Unicode + +>>> :{ +countArray :: Array Word8 -> IO Counts +countArray arr = + Array.read arr -- Stream IO Word8 + & Unicode.decodeLatin1 -- Stream IO Char + & Stream.fold (Fold.foldl' count (Counts 0 0 0 True)) -- IO Counts +:} +``` + +Here the function `count` and the `Counts` data type are defined in the +`WordCount` helper module defined in [WordCount.hs][]. + +When combining the counts in two contiguous chunks, we need to check +whether the first element of the next chunk is a whitespace character +in order to determine if the same word continues in the next chunk or +whether the chunk starts with a new word. The `partialCounts` function +adds a `Bool` flag to `Counts` returned by `countArray` to indicate +whether the first character in the chunk is a space. + +```haskell docspec +>>> :{ +partialCounts :: Array Word8 -> IO (Bool, Counts) +partialCounts arr = do + let r = Array.getIndex 0 arr + case r of + Just x -> do + counts <- countArray arr + return (isSpace (chr (fromIntegral x)), counts) + Nothing -> return (False, Counts 0 0 0 True) +:} +``` + +`addCounts` then adds the counts from two consecutive chunks: + +```haskell docspec +>>> :{ +addCounts :: (Bool, Counts) -> (Bool, Counts) -> (Bool, Counts) +addCounts (sp1, Counts l1 w1 c1 ws1) (sp2, Counts l2 w2 c2 ws2) = + let wcount = + if not ws1 && not sp2 -- No space between two chunks. + then w1 + w2 - 1 + else w1 + w2 + in (sp1, Counts (l1 + l2) wcount (c1 + c2) ws2) +:} +``` + +To count in parallel we now only need to divide the stream into arrays, +apply our counting function to each array, and then combine the counts +from each chunk. + +```haskell docspec +>>> :set -XFlexibleContexts +>>> import GHC.Conc (numCapabilities) +>>> import qualified Streamly.Data.Stream.Prelude as Stream + +>>> :{ +wc :: Path -> IO (Bool, Counts) +wc file = do + File.readChunks file -- Stream IO (Array Word8) + & Stream.parMapM cfg partialCounts -- Stream IO (Bool, Counts) + & Stream.fold add -- IO (Bool, Counts) + + where + + cfg = Stream.maxThreads numCapabilities . Stream.ordered True + add = Fold.foldl' addCounts (False, Counts 0 0 0 True) +:} +``` + +We can replace `parMapM` with `mapM` to get a serial version of the program. + +A benchmark with 2 CPUs: + +``` +$ time WordCount-hs-parallel gutenberg-500MB.txt +11242220 97050938 574714449 gutenberg-500MB.txt + +real 0m1.443s +user 0m2.095s +sys 0m0.202s +``` + +These example programs have assumed ASCII encoded input data. For UTF-8 +streams, we have a [concurrent wc implementation][WordCountParallelUTF8.hs] +with UTF-8 decoding. This concurrent implementation performs as well +as the standard `wc` program in serial benchmarks. In concurrent mode +[Streamly][]'s implementation can utilise multiple processing cores if +these are present, and can thereby run much faster than the standard +binary. + +Streamly provides concurrency facilities similar +to [OpenMP](https://en.wikipedia.org/wiki/OpenMP) and +[Cilk](https://en.wikipedia.org/wiki/Cilk) but with a more declarative +style of expression. With Streamly you can write concurrent programs +with ease, with support for different types of concurrent scheduling. + +### A Concurrent Network Server + +We now move to a slightly more complicated example: we simulate a +dictionary lookup server which can serve word meanings to multiple +clients concurrently. + +Please see the file [WordServer.hs][] for the complete code for this +example. + +```haskell docspec +>>> import Control.Concurrent (threadDelay) +>>> import Control.Exception (finally) +>>> import Network.Socket (Socket, close) + +>>> import qualified Streamly.Data.Parser as Parser +>>> import qualified Streamly.Network.Inet.TCP as TCP +>>> import qualified Streamly.Network.Socket as Socket +>>> import qualified Streamly.Unicode.Stream as Unicode + +>>> :{ +-- Simulate network/db query by adding a delay. +fetch :: String -> IO (String, String) +fetch w = threadDelay 1000000 >> return (w,w) +:} + +>>> :{ +-- Read lines of whitespace separated list of words from a socket, fetch the +-- meanings of each word concurrently and return the meanings separated by +-- newlines, in same order as the words were received. Repeat until the +-- connection is closed. +lookupWords :: Socket -> IO () +lookupWords sk = + Socket.read sk -- Stream IO Word8 + & Unicode.decodeLatin1 -- Stream IO Char + & Stream.wordsBy isSpace Fold.toList -- Stream IO String + & Stream.parMapM cfg fetch -- Stream IO (String, String) + & fmap show -- Stream IO String + & Stream.intersperse "\n" -- Stream IO String + & Unicode.encodeStrings Unicode.encodeLatin1 -- Stream IO (Array Word8) + & Stream.fold (Socket.writeChunks sk) + + where + + cfg = Stream.ordered True +:} + +>>> :{ +serve :: Socket -> IO () +serve sk = finally (lookupWords sk) (close sk) +:} + +>>> :{ +-- | Run a server on port 8091. Accept and handle connections concurrently. The +-- connection handler is "serve" (i.e. lookupWords). You can use "telnet" or +-- "nc" as a client to try it out. +main :: IO () +main = + TCP.accept 8091 -- Stream IO Socket + & Stream.parMapM id serve -- Stream IO () + & Stream.fold Fold.drain -- IO () +:} +``` + +### Merging Incoming Streams + +In the next example, we show how to merge logs coming from multiple +nodes in your network. These logs are merged at line boundaries and +the merged logs are written to a file or to a network destination. +This example uses the `concatMapWith` combinator to merge multiple +streams concurrently. + +Please see the file [MergeServer.hs][] for the complete working code, +including the imports that we have omitted below. + + +```haskell docspec +>>> import Streamly.Data.Stream (Stream) +>>> import System.IO (IOMode(AppendMode), Handle, withFile) + +>>> import qualified Streamly.Network.Socket as Socket +>>> import qualified Streamly.FileSystem.Handle as Handle + +>>> :{ +-- | Read a line stream from a socket. +-- Note: lines are buffered, and we could add a limit to the +-- buffering for safety. +-- readLines :: Socket -> Stream IO (Array Char) +readLines sk = + Socket.read sk -- Stream IO Word8 + & Unicode.decodeLatin1 -- Stream IO Char + & Stream.foldMany line -- Stream IO (Array Char) + + where + + line = Fold.takeEndBy (== '\n') Array.create +:} + +>>> :{ +-- recv :: Socket -> Stream IO (Array Char) +recv sk = Stream.finallyIO (close sk) (readLines sk) +:} + +>>> :{ +-- | Starts a server at port 8091 listening for lines with space separated +-- words. Multiple clients can connect to the server and send streams of lines. +-- The server handles all the connections concurrently, merges the incoming +-- streams at line boundaries and writes the merged stream to a file. +-- server :: Handle -> IO () +server file = + TCP.accept 8090 -- Stream IO Socket + & Stream.parConcatMap (Stream.eager True) recv -- Stream IO (Array Char) + & Stream.unfoldEach Array.reader -- Stream IO Char + & Unicode.encodeLatin1 -- Stream IO Word8 + & Stream.fold (Handle.write file) -- IO () +:} + +>>> :{ +main :: IO () +main = withFile "output.txt" AppendMode server +:} +``` + +### Listing Directories Recursively/Concurrently + +Our next example lists a directory tree recursively, and concurrently. + +This example uses the tree traversing combinator `parConcatIterate`. This +combinator maps a stream generator function on the input stream and then +recursively on the generated stream as well and flattens the results. We map a +directory to a stream generating its children and a file to a nil stream. This +results in a concurrent recursive depth first traversal of the directory tree. + +Please see [ListDir.hs][] for the complete working code. + +```haskell docspec +>>> import System.IO (stdout, hSetBuffering, BufferMode(LineBuffering)) +>>> import qualified Streamly.Internal.FileSystem.DirIO as Dir (readEitherPaths) + +>>> :set -XQuasiQuotes +>>> import Streamly.FileSystem.Path (path) +>>> import qualified Streamly.FileSystem.Path as Path +>>> import Data.Bifunctor(bimap) + +>>> :{ +main :: IO () +main = do + hSetBuffering stdout LineBuffering + let start = Stream.fromPure (Left [path|.|]) + f = either (Dir.readEitherPaths id) (const Stream.nil) + ls = Stream.parConcatIterate id f start + in Stream.fold (Fold.drainMapM (print . bimap Path.toString Path.toString)) ls +:} +``` + +### Rate Limiting + +For concurrent streams, a stream evaluation rate can be specified. For +example, to print "tick" once every second you can simply write: + +```haskell docspec +>>> import qualified Streamly.Internal.Data.Stream as Stream (timestamped) + +>>> :{ +main :: IO () +main = + Stream.parRepeatM (Stream.avgRate 1) (pure "tick") -- Stream IO String + & Stream.timestamped -- Stream IO (AbsTime, String) + & Stream.fold (Fold.drainMapM print) -- IO () +:} +``` + +Please see the file [Rate.hs][] for the complete working code. + +The concurrency of the stream is automatically controlled to match the +specified rate. [Streamly][]'s rate control works precisely even at +throughputs as high as millions of yields per second. + +For more sophisticated rate control needs please see the Streamly [reference +documentation][Streamly]. + +## Reactive Programming: Acid Rain Game + +### Objective of the Game + +The game starts with a certain measure of health of the player. As time +passes the health of the player keeps on deteriorating because acid rain is +going on. If the health reaches 0 the player dies and the game is over. If the +player types "potion" on the CLI, the health is improved, the game continues if +the player keeps typing potion rapidly enough. If the player types "harm" +instead the health of the player deteriorates and the player dies sooner. If +the player types "quit" then the game ends. + +### Importing Required Modules + +Let's first import the required modules from `streamly` and `base`. + +```haskell +{-# LANGUAGE FlexibleContexts #-} +import Control.Monad.IO.Class (MonadIO(liftIO)) +import Control.Monad.State (MonadState, get, modify) +import Data.Function ((&)) +import Streamly.Data.Stream.Prelude (MonadAsync, Stream) + +import qualified Streamly.Data.Fold as Fold +import qualified Streamly.Data.Stream.Prelude as Stream +``` + +### Events + +The possible events in the system are represented by the `Event` data type. +Acid rain generates the `Harm` event, typing "potion" on the CLI generates the +`Heal` event, typing "harm" generates the `Harm` event, and typing "quit" +generates the `Quit` event. Harm and Heal events have an integer associated +which represents the degree of harm or healing. + +```haskell +data Event = Quit | Harm Int | Heal Int deriving (Eq, Show) +``` + +This application has two independent and concurrent sources of event +streams, `acidRain` and `userAction`. + +### Acid Rain Stream + +Now let's simulate acid rain. The acidRain function below generates a stream of +`Harm 1` events, one event is generated per second. + +```haskell +acidRain :: MonadAsync m => Stream m Event +acidRain = Stream.parRepeatM (Stream.constRate 1) (return $ Harm 1) +``` + +### User Event Stream + +The second stream is the stream of events generated by the user by typing +commands on the CI. The `userAction` function reads the standard input, +interprets the command typed and generates the appropriate event. It keeps +doing this forever, this is an infinite stream. + +```haskell +userAction :: MonadAsync m => Stream m Event +userAction = Stream.repeatM $ liftIO askUser + + where + + askUser = do + command <- getLine + case command of + "potion" -> return (Heal 10) + "harm" -> return (Harm 10) + "quit" -> return Quit + _ -> putStrLn "Type potion or harm or quit" >> askUser +``` + +### Combined Stream + +Now let's combine the streams generated by acid rain and the stream generated +by the CLI. Both the streams should be generated concurrently, therefore, we +use the `parList` function to combine them, this function combines a list of +streams concurrently. We use the `eager True` option to ensure that both the +streams are evaluated as soon as possible. + +```haskell +parallel :: MonadAsync m => [Stream m a] -> Stream m a +parallel = Stream.parList (Stream.eager True) + +eventStream :: MonadAsync m => Stream m Event +eventStream = parallel [userAction, acidRain] +``` + +### Process Health Events + +The `runEvents` function below maintains the health of the player as an integer +value in the `State` monad. It maps the `processEvents` function on the event +stream. The `Harm` or `Heal` events decrement or increment the player health +value appropriately. If we encounter a `Quit` event the function returns `Done` +otherwise it returns `Continue`. The resulting stream is a stream of `Result` +values. + +```haskell +data Result = Continue | Done + +runEvents :: (MonadAsync m, MonadState Int m) => Stream m Result +runEvents = Stream.mapM processEvents eventStream + + where + + processEvents event = + case event of + Harm n -> modify (\h -> h - n) >> return Continue + Heal n -> modify (\h -> h + n) >> return Continue + Quit -> return Done +``` + +### Check the Player Status + +The `runEvents` function above returns a stream of results after processing the +health events. The stream consists of results indicating whether the game +should continue or end, the `State` monad supplies the current health of the +player. + +Now we map the `getStatus` function on the `Result` stream. If we encounter a +`Done` in the result stream then it means the user has quit the game, so we +return `GameOver`, if the health of the player is 0 or less then the player has +died and we return `GameOver`, otherwise we return `Alive`. + +```haskell +data Status = Alive | GameOver deriving Eq + +getStatus :: (MonadAsync m, MonadState Int m) => Result -> m Status +getStatus result = + case result of + Done -> liftIO $ putStrLn "You quit!" >> return GameOver + Continue -> do + h <- get + liftIO + $ if (h <= 0) + then putStrLn "You die!" >> return GameOver + else putStrLn ("Health = " <> show h) >> return Alive +``` + +### Tying it all Together + +We start with the `Result` stream using the `runEvents` function. Then we map +the `getStatus` function on this stream and turn it into a `Status` stream. +Then we run the `State` monad using `runStateT`, supplying the initial health +to be 60, the resulting stream is a tuple of (health, status) in the IO monad. +We then discard the health and just keep the status, resulting in a `Status` +stream. We then fold this `Status` stream using the `takeEndBy` fold, this fold +terminates as soon as a `GameOver` value is encountered in the stream. + +```haskell +main :: IO () +main = do + putStrLn "Your health is deteriorating due to acid rain,\ + \ type \"potion\" or \"quit\"" + runEvents -- Stream (StateT Int IO) Result + & Stream.mapM getStatus -- Stream (StateT Int IO) Status + & Stream.runStateT (pure 60) -- Stream IO (Int, Status) + & fmap snd -- Stream IO Status + & Stream.fold (Fold.takeEndBy (== GameOver) Fold.drain) -- IO () + return () +``` + +### Complete Working Example + +You can find a complete working source of this example in the +streamly-examples repo as +[AcidRain.hs](https://github.com/composewell/streamly-examples/tree/master/examples/AcidRain.hs). +The idea of this game example has been taken from Gabriella Gonzalez's +[pipes-concurrency](https://hackage.haskell.org/package/pipes-concurrency-2.0.8/docs/Pipes-Concurrent-Tutorial.html) +package. + +## Reactive Programming: Circling Square + +For a simple graphical example where we generate an animation by +rendering a graphics frame periodically, see the SDL based circling +square example adapted from Yampa in +[CirclingSquare.hs](https://github.com/composewell/streamly-examples/tree/master/examples/CirclingSquare.hs). + +### More Examples + +If you would like to view more examples, please visit the [Streamly +Examples][streamly-examples] web page. + + + + + +[Streamly]: https://streamly.composewell.com/ +[streamly-examples]: https://github.com/composewell/streamly-examples +[streaming-benchmarks]: https://github.com/composewell/streaming-benchmarks +[concurrency-benchmarks]: https://github.com/composewell/concurrency-benchmarks + + + + +[WordCountModular.hs]: https://github.com/composewell/streamly-examples/blob/master/examples/WordCountModular.hs +[WordCount.hs]: https://github.com/composewell/streamly-examples/blob/master/examples/WordCount.hs +[WordCount.c]: https://github.com/composewell/streamly-examples/blob/master/examples/WordCount.c +[WordCountParallel.hs]: https://github.com/composewell/streamly-examples/blob/master/examples/WordCountParallel.hs +[WordCountParallelUTF8.hs]: https://github.com/composewell/streamly-examples/blob/master/examples/WordCountParallelUTF8.hs +[WordServer.hs]: https://github.com/composewell/streamly-examples/blob/master/examples/WordServer.hs +[MergeServer.hs]: https://github.com/composewell/streamly-examples/blob/master/examples/MergeServer.hs +[ListDir.hs]: https://github.com/composewell/streamly-examples/blob/master/examples/ListDir.hs +[Rate.hs]: https://github.com/composewell/streamly-examples/blob/master/examples/Rate.hs +[AcidRain.hs]: https://github.com/composewell/streamly-examples/tree/master/examples/AcidRain.hs +[CirclingSquare.hs]: https://github.com/composewell/streamly-examples/tree/master/examples/CirclingSquare.hs + + +[LICENSE]: /LICENSE +[CONTRIBUTING.md]: /CONTRIBUTING.md +[docs]: docs/ diff --git a/docs/User/Tutorials/performance-considerations.md b/docs/User/Tutorials/performance-considerations.md new file mode 100644 --- /dev/null +++ b/docs/User/Tutorials/performance-considerations.md @@ -0,0 +1,123 @@ +# Performance Considerations + + + +## Streams + +From performance behavior perspective, the stream operations can be divided +into three categories: + +* Byte level loops: Fused streams as the lowest level building blocks. +* Chunk level loops: CPS streams as scalable wrappers to wrap fused streams. +* Thread level loops: Byte or chunk level loops evaluated in multiple threads. + +| Fused | CPS | Concurrent Combinators | +|--------|---------|------------------------------| +| Stream | StreamK | Streamly.Data.Stream.Prelude | +| Fold | ParserK | Streamly.Data.Fold.Prelude | +| Parser | ParserK | | + + +## Fused Streams + +The fused stream types provide the statically optimized loops giving the +highest performance with no function calls, thus no memory allocations for +wrapping constructors. Such loops provide C like performance. + +## CPS Streams + +In many cases you cannot determine the loops statically, in which case a +function call overhead or constructor allocation cannot be avoided. Note +this is not Haskell specific, even in C such cases would require a +function call overhead. For such cases we have stream types which use +function composition rather than constructor fusion. In general we use +such streams to generate large chunks of data which is then processed by +fused streams loops embedded in CPS streams. Because of larger chunks +the number of function calls, therefore, the function call overhead due +to CPS streams is reduced. + +## Concurrent Combinators + +Concurrent streams use concurrency channels to evaluate streams +concurrently. Concurrent combinators are provided corresponding to most +serial stream combinator for concurrent evaluation. These combinators +consume fused or CPS streams, process them in a multithreaded manner and +generate a fused or CPS stream where the output is a stream. + +## Arrays + +Streams are for processing data, therefore, performance of streams +mostly involves CPU optimization. Arrays are for storing data, +therefore, performance of arrays mostly involves memory aspects e.g. +boxed or unboxed, pinned or unpinned. + +For highest performance we recommend the use of unboxed arrays. Unboxed +arrays store data without an additional heap pointer wrapper +(boxing). The arrays in the following modules are unboxed arrays: + +* Streamly.Data.Array +* Streamly.Data.MutArray +* Streamly.Data.RingArray + +For storing boxed heap objects, boxed arrays are provided in the following +modules: + +* Streamly.Data.Array.Generic +* Streamly.Data.MutArray.Generic + +Unboxed arrays can be pinned (cannot be moved by GC) or +unpinned. However, pinned or unpinned nature of the memory is not +statically typed in the array type. The same array may be created in +pinned or unpinned memory, an unpinned array can be dynamically moved +to pinned memory or vice-versa. For this purpose pinned or unpinned +versions of functions are provided in the unboxed array modules. diff --git a/docs/User/Tutorials/quick-overview.md b/docs/User/Tutorials/quick-overview.md deleted file mode 100644 --- a/docs/User/Tutorials/quick-overview.md +++ /dev/null @@ -1,519 +0,0 @@ - - -# [Streamly][] Quick Tutorial -## About This Document - -This guide introduces programming with [Streamly][] using a few practical -examples: - -* We will start with a simple program that [counts the number of words - in a text](#modular-word-counting). We will then transform this program - into a [concurrent](#concurrent-word-counting) program that can efficiently - use multiprocessing hardware. -* Next, we will create a [concurrent network - server](#a-concurrent-network-server). We then show - how to write a network server that [merges multiple - streams](#merging-incoming-streams) concurrently. -* Our third example shows how to list a directory tree concurrently, - by reading [multiple directories in - parallel](#listing-directories-recursivelyconcurrently). -* Finally, we will look at how to [rate limit](#rate-limiting) stream - processing. - -It [concludes](#further-reading) with suggestions for further reading. - -## Getting Started - -### Installing Streamly - -If you wish to follow along and run examples in this guide, please see -the [Before You Begin](/docs/User/Tutorials/before-you-begin.md) guide -for instructions on how to use the `streamly` package interactively or -in a project. - -### An overview of the types used in these examples - -As an expository device, we have indicated the types at the intermediate -stages of stream computations as comments in the examples below. -The meaning of these types are: - -* A `Stream IO a` is a representation of a sequence of values of type - `a` in the IO Monad. -* A `Fold IO a b` is a representation of a function that converts a stream of - type `a` to a final accumulator of type `b` in the IO Monad. -* An `Unfold IO a b` is a representation of a function that converts a seed - value of type `a` into a stream of values of type `b` in the IO Monad. - -## The Examples - -The code snippets below should work in GHCi if all of those are typed -in sequence. For brevity, imports that are already used in earlier -snippets are omitted from the latter ones. - -### Modular Word Counting - -A `Fold` in Streamly is a composable stream consumer. For our first -example, we will use `Fold`s to count the number of bytes, words and lines -present in a file. We will then compose individual `Fold`s together to -count words, bytes and lines at the same time. - -Please see the file [WordCountModular.hs][] for the complete example -program. - -#### Count Bytes (wc -c) - -We start with a code fragment that counts the number of bytes in a file: - -```haskell ghci -import Data.Function ((&)) - -import qualified Streamly.Data.Fold as Fold -import qualified Streamly.Data.Stream as Stream -import qualified Streamly.FileSystem.File as File - -wcb :: String -> IO Int -wcb file = - File.read file -- Stream IO Word8 - & Stream.fold Fold.length -- IO Int -``` - -### Count Lines (wc -l) - -The next code fragment shows how to count the number of lines in a file: - -```haskell ghci -import Data.Word (Word8) -import Streamly.Data.Fold (Fold) - --- ASCII character 10 is a newline. -countl :: Int -> Word8 -> Int -countl n ch = if ch == 10 then n + 1 else n - --- The `nlines` fold accepts a stream of `Word8` and returns a line count (`Int`). -nlines :: Monad m => Fold m Word8 Int -nlines = Fold.foldl' countl 0 - -wcl :: String -> IO Int -wcl file = - File.read file -- Stream IO Word8 - & Stream.fold nlines -- IO Int -``` - -### Count Words (wc -w) - -Our final code fragment counts the number of whitespace-separated words -in a stream: - -```haskell ghci -import Data.Char (chr, isSpace) - -countw :: (Int, Bool) -> Word8 -> (Int, Bool) -countw (n, wasSpace) ch = - if isSpace $ chr $ fromIntegral ch - then (n, True) - else (if wasSpace then n + 1 else n, False) - --- The `nwords` fold accepts a stream of `Word8` and returns a word count (`Int`). -nwords :: Monad m => Fold m Word8 Int -nwords = fst <$> Fold.foldl' countw (0, True) - -wcw :: String -> IO Int -wcw file = - File.read file -- Stream IO Word8 - & Stream.fold nwords -- IO Int -``` - -### Counting Bytes, Words and Lines Together - -By using the `Tee` combinator we can compose the three folds that count -bytes, lines and words individually into a single fold that counts all -three at once. The applicative instance of `Tee` distributes its input -to all the supplied folds (`Fold.length`, `nlines`, and `nwords`) and -then combines the outputs from the folds using the supplied combiner -function (`(,,)`). - -```haskell ghci -import Streamly.Data.Fold (Tee(..)) - --- The fold accepts a stream of `Word8` and returns the three counts. -countAll :: Fold IO Word8 (Int, Int, Int) -countAll = unTee $ (,,) <$> Tee Fold.length <*> Tee nlines <*> Tee nwords - -wc :: String -> IO (Int, Int, Int) -wc file = - File.read file -- Stream IO Word8 - & Stream.fold countAll -- IO (Int, Int, Int) -``` - -This example demonstrates the excellent modularity offered by -[Streamly][]'s simple and concise API. - -### The Performance of Word Counting - -We compare two equivalent implementations: one using [Streamly][], -and the other using C. - -The performance of the [Streamly word counting -implementation][WordCount.hs] (using ghc-9.4.4 and fusion-plugin) is: - -``` -$ time WordCount-hs gutenberg-500MB.txt -11242220 97050938 574714449 gutenberg-500MB.txt - -real 0m2.033s -user 0m1.821s -sys 0m0.209s -``` - -The performance of an equivalent [wc implementation in C][WordCount.c] is: - -``` -$ time WordCount-c gutenberg-500MB.txt -11242220 97050938 574714449 gutenberg-500MB.txt - -real 0m2.113s -user 0m1.928s -sys 0m0.185s -``` - -### Concurrent Word Counting - -In our next example we show how the task of counting words, lines, -and bytes could be done in parallel on multiprocessor hardware. - -To count words in parallel we first divide the stream into chunks -(arrays), do the counting within each chunk, and then add all the -counts across chunks. We use the same code as above except that we use -arrays for our input data. - -Please see the file [WordCountParallel.hs][] for the complete working -code for this example, including the imports that we have omitted below. - -First we create a new data type `Counts` that holds all the context. - -```haskell ghci --- Counts lines words chars lastCharWasSpace -data Counts = Counts !Int !Int !Int !Bool deriving Show - -{-# INLINE count #-} -count :: Counts -> Char -> Counts -count (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 -``` - -The `countArray` function counts the line, word, char counts in one chunk: - -```haskell ghci -import Streamly.Data.Array (Array) - -import qualified Streamly.Data.Array as Array -import qualified Streamly.Unicode.Stream as Unicode - -countArray :: Array Word8 -> IO Counts -countArray arr = - Stream.unfold Array.reader arr -- Stream IO Word8 - & Unicode.decodeLatin1 -- Stream IO Char - & Stream.fold (Fold.foldl' count (Counts 0 0 0 True)) -- IO Counts -``` - -Here the function `count` and the `Counts` data type are defined in the -`WordCount` helper module defined in [WordCount.hs][]. - -When combining the counts in two contiguous chunks, we need to check -whether the first element of the next chunk is a whitespace character -in order to determine if the same word continues in the next chunk or -whether the chunk starts with a new word. The `partialCounts` function -adds a `Bool` flag to `Counts` returned by `countArray` to indicate -whether the first character in the chunk is a space. - -```haskell ghci -partialCounts :: Array Word8 -> IO (Bool, Counts) -partialCounts arr = do - let r = Array.getIndex 0 arr - case r of - Just x -> do - counts <- countArray arr - return (isSpace (chr (fromIntegral x)), counts) - Nothing -> return (False, Counts 0 0 0 True) -``` - -`addCounts` then adds the counts from two consecutive chunks: - -```haskell ghci -addCounts :: (Bool, Counts) -> (Bool, Counts) -> (Bool, Counts) -addCounts (sp1, Counts l1 w1 c1 ws1) (sp2, Counts l2 w2 c2 ws2) = - let wcount = - if not ws1 && not sp2 -- No space between two chunks. - then w1 + w2 - 1 - else w1 + w2 - in (sp1, Counts (l1 + l2) wcount (c1 + c2) ws2) -``` - -To count in parallel we now only need to divide the stream into arrays, -apply our counting function to each array, and then combine the counts -from each chunk. - -```haskell ghci -{-# LANGUAGE FlexibleContexts #-} - -import GHC.Conc (numCapabilities) -import qualified Streamly.Data.Stream.Prelude as Stream - -wc :: String -> IO (Bool, Counts) -wc file = do - File.readChunks file -- Stream IO (Array Word8) - & Stream.parMapM cfg partialCounts -- Stream IO (Bool, Counts) - & Stream.fold add -- IO (Bool, Counts) - - where - - cfg = Stream.maxThreads numCapabilities . Stream.ordered True - add = Fold.foldl' addCounts (False, Counts 0 0 0 True) -``` - -We can replace `parMapM` with `mapM` to get a serial version of the program. - -A benchmark with 2 CPUs: - -``` -$ time WordCount-hs-parallel gutenberg-500MB.txt -11242220 97050938 574714449 gutenberg-500MB.txt - -real 0m1.443s -user 0m2.095s -sys 0m0.202s -``` - -These example programs have assumed ASCII encoded input data. For UTF-8 -streams, we have a [concurrent wc implementation][WordCountParallelUTF8.hs] -with UTF-8 decoding. This concurrent implementation performs as well -as the standard `wc` program in serial benchmarks. In concurrent mode -[Streamly][]'s implementation can utilise multiple processing cores if -these are present, and can thereby run much faster than the standard -binary. - -Streamly provides concurrency facilities similar -to [OpenMP](https://en.wikipedia.org/wiki/OpenMP) and -[Cilk](https://en.wikipedia.org/wiki/Cilk) but with a more declarative -style of expression. With Streamly you can write concurrent programs -with ease, with support for different types of concurrent scheduling. - -### A Concurrent Network Server - -We now move to a slightly more complicated example: we simulate a -dictionary lookup server which can serve word meanings to multiple -clients concurrently. - -Please see the file [WordServer.hs][] for the complete code for this -example. - -```haskell ghci -import Control.Concurrent (threadDelay) -import Control.Exception (finally) -import Network.Socket (Socket, close) - -import qualified Streamly.Data.Parser as Parser -import qualified Streamly.Network.Inet.TCP as TCP -import qualified Streamly.Network.Socket as Socket -import qualified Streamly.Unicode.Stream as Unicode - --- Simulate network/db query by adding a delay. -fetch :: String -> IO (String, String) -fetch w = threadDelay 1000000 >> return (w,w) - --- Read lines of whitespace separated list of words from a socket, fetch the --- meanings of each word concurrently and return the meanings separated by --- newlines, in same order as the words were received. Repeat until the --- connection is closed. -lookupWords :: Socket -> IO () -lookupWords sk = - Stream.unfold Socket.reader sk -- Stream IO Word8 - & Unicode.decodeLatin1 -- Stream IO Char - & Stream.parseMany word -- Stream IO String - & Stream.parMapM cfg fetch -- Stream IO (String, String) - & fmap show -- Stream IO String - & Stream.intersperse "\n" -- Stream IO String - & Unicode.encodeStrings Unicode.encodeLatin1 -- Stream IO (Array Word8) - & Stream.fold (Socket.writeChunks sk) - - where - - word = Parser.wordBy isSpace Fold.toList - cfg = Stream.ordered True - -serve :: Socket -> IO () -serve sk = finally (lookupWords sk) (close sk) - --- | Run a server on port 8091. Accept and handle connections concurrently. The --- connection handler is "serve" (i.e. lookupWords). You can use "telnet" or --- "nc" as a client to try it out. -main :: IO () -main = - Stream.unfold TCP.acceptorOnPort 8091 -- Stream IO Socket - & Stream.parMapM id serve -- Stream IO () - & Stream.fold Fold.drain -- IO () -``` - -### Merging Incoming Streams - -In the next example, we show how to merge logs coming from multiple -nodes in your network. These logs are merged at line boundaries and -the merged logs are written to a file or to a network destination. -This example uses the `concatMapWith` combinator to merge multiple -streams concurrently. - -Please see the file [MergeServer.hs][] for the complete working code, -including the imports that we have omitted below. - -```haskell ghci -{-# LANGUAGE FlexibleContexts #-} - -import Streamly.Data.Stream (Stream) -import System.IO (IOMode(AppendMode), Handle, withFile) - -import qualified Streamly.Data.Unfold as Unfold -import qualified Streamly.Network.Socket as Socket -import qualified Streamly.FileSystem.Handle as Handle - --- | Read a line stream from a socket. --- Note: lines are buffered, and we could add a limit to the --- buffering for safety. -readLines :: Socket -> Stream IO (Array Char) -readLines sk = - Stream.unfold Socket.reader sk -- Stream IO Word8 - & Unicode.decodeLatin1 -- Stream IO Char - & Stream.foldMany line -- Stream IO (Array Char) - - where - - line = Fold.takeEndBy (== '\n') Array.write - -recv :: Socket -> Stream IO (Array Char) -recv sk = Stream.finallyIO (close sk) (readLines sk) - --- | Starts a server at port 8091 listening for lines with space separated --- words. Multiple clients can connect to the server and send streams of lines. --- The server handles all the connections concurrently, merges the incoming --- streams at line boundaries and writes the merged stream to a file. -server :: Handle -> IO () -server file = - Stream.unfold TCP.acceptorOnPort 8090 -- Stream IO Socket - & Stream.parConcatMap (Stream.eager True) recv -- Stream IO (Array Char) - & Stream.unfoldMany Array.reader -- Stream IO Char - & Unicode.encodeLatin1 -- Stream IO Word8 - & Stream.fold (Handle.write file) -- IO () - -main :: IO () -main = withFile "output.txt" AppendMode server -``` - -### Listing Directories Recursively/Concurrently - -Our next example lists a directory tree recursively, and concurrently. - -This example uses the tree traversing combinator `parConcatIterate`. This -combinator maps a stream generator function on the input stream and then -recursively on the generated stream as well and flattens the results. We map a -directory to a stream generating its children and a file to a nil stream. This -results in a concurrent recursive depth first traversal of the directory tree. - -Please see [ListDir.hs][] for the complete working code. - -```haskell ghci -import System.IO (stdout, hSetBuffering, BufferMode(LineBuffering)) -import qualified Streamly.Internal.FileSystem.Dir as Dir (readEitherPaths) - -main :: IO () -main = do - hSetBuffering stdout LineBuffering - let start = Stream.fromPure (Left ".") - f = either Dir.readEitherPaths (const Stream.nil) - ls = Stream.parConcatIterate id f start - in Stream.fold (Fold.drainMapM print) ls -``` - -### Rate Limiting - -For concurrent streams, a stream evaluation rate can be specified. For -example, to print "tick" once every second you can simply write: - -```haskell ghci -import qualified Streamly.Internal.Data.Stream as Stream (timestamped) - -main :: IO () -main = - Stream.parRepeatM (Stream.avgRate 1) (pure "tick") -- Stream IO String - & Stream.timestamped -- Stream IO (AbsTime, String) - & Stream.fold (Fold.drainMapM print) -- IO () -``` - -Please see the file [Rate.hs][] for the complete working code. - -The concurrency of the stream is automatically controlled to match the -specified rate. [Streamly][]'s rate control works precisely even at -throughputs as high as millions of yields per second. - -For more sophisticated rate control needs please see the Streamly [reference -documentation][Streamly]. - -### Reactive Programming - -Streamly supports reactive (time domain) programming because of its support for -declarative concurrency. Please see the `Streamly.Data.Stream.Prelude` -module for time-specific and sampling combinators. - -The examples [AcidRain.hs][] and [CirclingSquare.hs][] demonstrate -reactive programming using [Streamly][]. - -### More Examples - -If you would like to view more examples, please visit the [Streamly -Examples][streamly-examples] web page. - -### Further Reading - -* [Streaming Benchmarks][streaming-benchmarks] -* [Concurrency Benchmarks][concurrency-benchmarks] -* Functional Conf 2019 [Video](https://www.youtube.com/watch?v=uzsqgdMMgtk) | [Slides](https://www.slideshare.net/HarendraKumar10/streamly-concurrent-data-flow-programming) -* [Other Guides](/) -* [Streamly Homepage][Streamly] - - - -[Streamly]: https://streamly.composewell.com/ -[streamly-examples]: https://github.com/composewell/streamly-examples -[streaming-benchmarks]: https://github.com/composewell/streaming-benchmarks -[concurrency-benchmarks]: https://github.com/composewell/concurrency-benchmarks - - - - -[WordCountModular.hs]: https://github.com/composewell/streamly-examples/blob/master/examples/WordCountModular.hs -[WordCount.hs]: https://github.com/composewell/streamly-examples/blob/master/examples/WordCount.hs -[WordCount.c]: https://github.com/composewell/streamly-examples/blob/master/examples/WordCount.c -[WordCountParallel.hs]: https://github.com/composewell/streamly-examples/blob/master/examples/WordCountParallel.hs -[WordCountParallelUTF8.hs]: https://github.com/composewell/streamly-examples/blob/master/examples/WordCountParallelUTF8.hs -[WordServer.hs]: https://github.com/composewell/streamly-examples/blob/master/examples/WordServer.hs -[MergeServer.hs]: https://github.com/composewell/streamly-examples/blob/master/examples/MergeServer.hs -[ListDir.hs]: https://github.com/composewell/streamly-examples/blob/master/examples/ListDir.hs -[Rate.hs]: https://github.com/composewell/streamly-examples/blob/master/examples/Rate.hs -[AcidRain.hs]: https://github.com/composewell/streamly-examples/tree/master/examples/AcidRain.hs -[CirclingSquare.hs]: https://github.com/composewell/streamly-examples/tree/master/examples/CirclingSquare.hs - - -[LICENSE]: /LICENSE -[CONTRIBUTING.md]: /CONTRIBUTING.md -[docs]: docs/ diff --git a/docs/User/Tutorials/setup-and-usage.md b/docs/User/Tutorials/setup-and-usage.md deleted file mode 100644 --- a/docs/User/Tutorials/setup-and-usage.md +++ /dev/null @@ -1,226 +0,0 @@ - - -# Getting started with `Haskell Streamly` - -This guide shows you how to install Haskell and the `streamly` package, -and then use Streamly in a simple program. - - - -No prior knowledge of Haskell is needed. We do however assume that you -are using a command-line shell on a POSIX operating system. If you are -running Windows™ then you may need to run a command-line shell -under `msys` and some of the commands below may also need to be changed -in small ways to make them work. - -## Installing Haskell - -You can choose one of the following options. - -### Installing the Haskell Toolchain - -To get started, you will need a fairly recent version (last three major -versions will work) of the Haskell compiler `ghc` and the build tool -`cabal` installed on your system. Please see the install instructions -at https://www.haskell.org/downloads/ . - -### Development Environment using Nix - -If you use the nix package manager, a nix shell for complete -development environment - including a consistent set of latest streamly -ecosystem packages, hoogle documentation, vim and vscode editors, -Haskell language server (HLS) and other tools - is available at -[streamly-packages][streamly-packages]. - -## Using `streamly` Interactively in REPL - -You can try out `streamly` using `GHCi`, the interactive Haskell -read-eval-print-loop (REPL). - -Streamly consists of two packages, namely `streamly-core` and -`streamly`. The former package provides basic functionality and the -latter provides higher level functionality. To start up the GHCi REPL -using the latest released `streamly-core` package from Hackage, please -use: - -``` -$ cabal repl --build-depends streamly-core -... plenty of build messages, the first time around ... -GHCi, version 9.2.2: https://www.haskell.org/ghc/ :? for help -ghci> -``` - -This command may take a while to build the package first time around, -please be patient. - -Once at the `ghci>` prompt, you can import Haskell modules from the -`streamly-core` package and use the available functions in the REPL: - -``` -ghci> import qualified Streamly.Data.Stream as Stream -ghci> import qualified Streamly.Data.Fold as Fold - -ghci> Stream.fold Fold.drain $ Stream.mapM print $ Stream.fromList [1..3] -1 -2 -3 -ghci> -``` - -For the curious, here is a high level overview of what these lines -do: - -1. `import qualified Streamly.Data.Stream as Stream` imports the Streamly - Stream module into GHCi, and makes it available under the name `Stream`. -2. `[1..3]` generates the Haskell list `[1, 2, 3]`. -3. `Stream.fromList` transforms that list into a stream of integers. -4. `Stream.mapM print` transforms the stream of integers into a stream of - actions that would print those integers when executed. -5. `Stream.fold Fold.drain` folds that stream using the `drain` fold, - transforming it into an IO action that evaluates the stream. - -### Using a specific version of `streamly` in the REPL - -You can also ask `cabal` to use a specific version of `streamly-core` by -adding a version number constraint to the `--build-depends` flag: - -``` -$ cabal repl --build-depends streamly-core==0.1.0 -... -ghci> -``` - -## Using `streamly` in a Project - -Create a project directory for our example project. - -``` -$ mkdir streamly-project -``` - -### Add `streamly` as project dependency - -Run `cabal init` in the project directory to create an initial set of -project files: - -``` -$ cd streamly-project -$ cabal init --minimal --dependency base --dependency streamly-core - -... -Generating app/Main.hs... -Generating streamly-project.cabal... -... -``` - -This invocation sets up a Haskell package named `streamly-project` -with two build dependencies, namely `base` (the Haskell standard -library) and `streamly-core`. You can add additional dependencies -later, by editing the `build-depends` section of the generated -cabal file `streamly-project.cabal`. Please see the [Cabal User -Guide](https://www.haskell.org/cabal/users-guide/) for more information -on `.cabal` files. - -This invocation also creates a skeletal `app/Main.hs` file which we -will now use to write our streamly based program. - -### Import `streamly` modules in the project code - -Let us now turn the single-line stanza we used in the REPL into a -standalone program. - -Edit `app/Main.hs` to contain the following: - -```haskell -module Main where - -import qualified Streamly.Data.Stream as Stream -import qualified Streamly.Data.Fold as Fold - -main :: IO () -main = Stream.fold Fold.drain $ Stream.mapM print $ Stream.fromList [1..3] -``` - -Build and run this program using `cabal run`: - -``` -$ cabal run -... build messages ... -1 -2 -3 -``` - -### Running GHCi REPL for the project code - -To start up the GHCi REPL for your project, please use: - -``` -$ cabal repl -... -ghci> -``` - -The repl will load all the dependencies and modules of the project. You can now -run your project code or any other code snippets as you desire. - -### (Advanced) Using the development version of `streamly` - -To use the development version of `streamly`, we need to configure -`cabal` to fetch it from Github. - -Create a `cabal.project` file in the project directory with the -following content: - -``` -packages: . --- fetch streamly-core dependency package from github -source-repository-package - type: git - location: https://github.com/composewell/streamly - subdir: core - tag: master -``` - -With this file present, `cabal` will fetch and build the current -version of `streamly-core` from Github. For example: - -``` -$ cabal repl -Cloning into '/home/harendra/streamly-project/... -... -In order, the following will be built (use -v for more details): - - streamly-core-0.1.0 (lib:streamly-core) (requires build) - - streamly-project-0.1.0.0 (exe:streamly-project) (configuration changed) - ... -ghci> -``` - -## Which version of `streamly` should you use? - -If you are new to Streamly, we recommend using the latest [stable release -of streamly][streamly-hackage] on Hackage. - -If you need access to cutting edge features (and do not mind the -occasional breakage), please use the [development version of -streamly][streamly-github] from Github. - -## Next Steps - -If you got this far successfully, congratulations! For an overview -of the `streamly` package, please read the [Streamly Quick -Overview](/docs/User/Tutorials/quick-overview.md). - - - - [Streamly]: https://streamly.composewell.com/ - [streamly-hackage]: https://hackage.haskell.org/package/streamly - [streamly-github]: https://github.com/composewell/streamly - [streamly-packages]: https://github.com/composewell/streamly-packages diff --git a/docs/User/Tutorials/streamly-core.svg b/docs/User/Tutorials/streamly-core.svg new file mode 100644 --- /dev/null +++ b/docs/User/Tutorials/streamly-core.svg @@ -0,0 +1,3 @@ + +Control.ExceptionResource ManagementStringStreamParserUnicodePathHandleDirIOFileIOConsole.StdioFile SystemSerializeUnboxMutByteArraySerializationRingArrayMutArray.GenericMutArrayMutableArray.GenericArrayImmutableArraysParserKParserFoldConsumptionScanlTransformationUnfoldStreamKStreamGenerationStreams(types and modules)streamly-core diff --git a/docs/User/Tutorials/streamly-ecosystem.md b/docs/User/Tutorials/streamly-ecosystem.md new file mode 100644 --- /dev/null +++ b/docs/User/Tutorials/streamly-ecosystem.md @@ -0,0 +1,111 @@ +# Streamly Ecosystem + +The Streamly ecosystem is a collection of packages built on top of +Streamly, extending its core with higher-level functionality for +real-world programming. + +For a combined view of the reference documentation across all ecosystem +packages, visit: +👉 [Streamly Module Listing](https://streamly.composewell.com/module-listing.html) + +## streamly-process + +**`streamly-process`** lets you use operating system (OS) commands in +Haskell programs as if they were native functions, by treating their +inputs and outputs as Haskell streams. This makes it easy to write +high-level Haskell scripts that perform tasks similar to shell pipelines +but with **C-like performance, strong safety guarantees, modularity, and +refactorability**. + +For example, the shell command: + +```bash +echo "hello world" | tr [a-z] [A-Z] +``` + +can be expressed in Haskell as: + + +``` +>>> :{ + Command.toBytes [str|echo "hello world"|] -- Stream IO Word8 + & Command.pipeBytes [str|tr [a-z] [A-Z]|] -- Stream IO Word8 + & Stream.fold Stdio.write -- IO () +:} +HELLO WORLD +``` + +👉 [streamly-process on GitHub](https://github.com/composewell/streamly-process) + +## streamly-coreutils + +**`streamly-coreutils`** reimplements GNU coreutils utilities as +composable Haskell functions—concurrent where possible. Examples include +`test`, `cp`, `ls`, `ln`, `mv`, `rm`, `touch`, `mkdir`, `pwd`, `cd`, +`stat`, `readlink`, `which`, `sleep`, and more. + +This allows you to use familiar Unix-style tools directly within +streaming Haskell programs, combining the convenience of shell scripting +with the safety, modularity, and performance of Haskell. + +👉 [streamly-coreutils on GitHub](https://github.com/composewell/streamly-coreutils) + +## streamly-statistics + +**`streamly-statistics`** offers functionality similar to the Haskell +`statistics` package, but with streaming APIs. Its unique strength is +support for **incremental statistical analysis on sliding windows of +data**, seamlessly integrated into streaming pipelines. This makes it +ideal for real-time analytics, monitoring systems, or any application +that processes continuous data streams. + +👉 [streamly-statistics on GitHub](https://github.com/composewell/streamly-statistics) + +## streamly-fsevents + +**`streamly-fsevents`** provides a streaming interface to file system +events. It allows you to **watch files or directories for changes**— +such as creation, modification, deletion, or renaming—and consume those +events as Haskell streams. Internally, it uses efficient system +facilities like `inotify` on Linux for scalable event monitoring. + +This makes it well-suited for building **real-time file watchers, +synchronization tools, live-reload servers, or monitoring pipelines**. + +👉 [streamly-fsevents on GitHub](https://github.com/composewell/streamly-fsevents) + + + +## Compatibility Packages + +Streamly can interwork with other packages in the Haskell ecosystem +providing similar functionality. These packages enable the +interconversion. + +### streamly-bytestring + +Package for converting streamly `Array` type to the bytestring package's +`ByteString` type and vice-versa. + +👉 [streamly-bytestring on GitHub](https://github.com/psibi/streamly-bytestring) + +### streamly-text + +Package for converting streamly `Array` type to the `text` package's +`Text` type and vice-versa. + +👉 [streamly-text on GitHub](https://github.com/composewell/streamly-text) + +### streamly-filepath + +Package for converting streamly `Path` type to the `filepath` package's +`OsPath` type and vice-versa. + +👉 [streamly-filepath on GitHub](https://github.com/composewell/streamly-filepath) diff --git a/docs/User/Tutorials/streamly.svg b/docs/User/Tutorials/streamly.svg new file mode 100644 --- /dev/null +++ b/docs/User/Tutorials/streamly.svg @@ -0,0 +1,3 @@ + +Network.Inet.TCPNetwork.SocketNetworkFold.PreludeConsumptionScanl.PreludeTransformationStream.PreludeGenerationConcurrent Streamsstreamly diff --git a/docs/User/Tutorials/streams-as-loops.md b/docs/User/Tutorials/streams-as-loops.md new file mode 100644 --- /dev/null +++ b/docs/User/Tutorials/streams-as-loops.md @@ -0,0 +1,190 @@ +# Streaming Pipelines as Functional Loops + +Streaming pipelines are the functional equivalent of loops in imperative +programming. In imperative programming when we have to process a +sequence of data items we run a loop over all the items. Each iteration +of the loop examines a single element of data to change the state of the +program or produce an output. + + + +## Data as Stream + +In the streaming paradigm, we represent the user data that we have to +loop over as a stream. A stream is a representation of potentially +infinite sequence of data items. + +A finite stream consisting of integer data elements 1,2,3: + +```haskell docspec +>>> import Streamly.Data.Stream (Stream) +>>> import qualified Streamly.Data.Stream as Stream +>>> s1 = Stream.enumerateFromTo 1 3 :: Stream IO Int +``` + +An infinite stream consisting of integers from 1 to infinity: + +```haskell docspec +>>> s2 = Stream.enumerateFrom 1 :: Stream IO Int +``` + +## Stream Transformation + +We have represented data as stream, now we have to operate on it. To +operate on the data in the stream we use stream transformation +functions, for example, if we have to increment each element in the +stream by one we use the `fmap` function. After applying the `fmap (+1)` +function on the stream we get an output stream in which each element of +the input stream is incremented by 1. Stream `s3` consists of elements +2,3,4: + +```haskell docspec +>>> import Data.Function ((&)) +>>> :{ +s3 = + Stream.enumerateFromTo 1 3 -- Stream IO Int + & fmap (+1) -- Stream IO Int +:} +``` + +Another example of a stream transformation operation is `take`, it trims +the stream to the specified number of elements. For example, the stream +`s4` in the code below consists of only two items 1,2: + +```haskell docspec +>>> :{ +s4 = + Stream.enumerateFromTo 1 3 -- Stream IO Int + & Stream.take 2 -- Stream IO Int +:} +``` + +## Modular Streaming Operations + +Similar to `fmap` and `take` there are many transformation operations +available in the library to perform different type of operations on the +stream. Each operation performs a specific job. We can combine multiple such +operations successively in a pipeline of operations to perform a desired +operation on the stream. For example, if we want to increment each element by 1 +and want to take only first two items, then we can do it as follows. The +resulting stream `s5` consists of items 2,4. + +```haskell docspec +>>> :{ +s5 = + Stream.enumerateFromTo 1 3 -- Stream IO Int + & fmap (+1) -- Stream IO Int + & Stream.take 2 -- Stream IO Int +:} +``` + +Each stream transformation operation maintains its own internal state +which is hidden from the programmer. In an imperative language loop we +will have to maintain the state explicitly in a monolithic loop, for +example if we have to stop after processing 2 elements we will have to +maintain a counter and check that counter in each iteration. Here we are +able to hide the state locally in each transformation operation and we +can build a larger processing loop by putting together smaller parts in +a modular fashion. + +The programmer only needs to pick the operations required for the +job and put them together. The resulting code is highly modular, +maintainable and readable. You can add an operation in the pipeline +without worrying about breaking anything else as the state for each +operation is private and cannot be meddled with by the programmer. + +## Stream Consumption + +Previously, we looked at operations that transform a stream to another +stream. Now let us look at another class of operations that consume a +stream and produce a single value or a single structure from it. This is +known as consuming the stream or eliminating the stream. The entities +that consume the stream are called consumers or folds (they help fold a +stream into a single value). + +The `sum` fold consumes a stream of integers and adds them all, when +done it returns the sum. The `Stream.fold` operation takes a stream +and a fold and connects them together, feeding the stream to the fold +and then returning the result. We refer to this operation as the fold +driver. The variable `total` contains the value `1+2+3` i.e. 6. + +```haskell docspec +>>> import Streamly.Data.Fold as Fold +>>> :{ +total <- + Stream.enumerateFromTo 1 3 -- Stream IO Int + & Stream.fold Fold.sum -- IO Int +:} +``` + +## The Streaming Pipeline + +Using all the operations described above we can create a data processing +pipeline that increments each data item one by 1, takes the first two +elements, adds them and prints the result: + +```haskell docspec +>>> :{ +main = + Stream.enumerateFromTo 1 3 -- Stream IO Int + & fmap (+1) -- Stream IO Int + & Stream.take 2 -- Stream IO Int + & Stream.fold Fold.sum -- IO Int + >>= print -- IO () +:} +``` + +The following snippet provides a simple stream composition example that reads +numbers from stdin, prints the squares of even numbers and exits if an even +number more than 9 is entered. + +``` haskell ghci +>>> import qualified Streamly.Data.Stream as Stream + +>>> :{ +main = Stream.drain $ + Stream.repeatM getLine + & fmap read + & Stream.filter even + & Stream.takeWhile (<= 9) + & fmap (\x -> x * x) + & Stream.mapM print +:} +``` + +## Data Flow Programming + +We have demonstrated above how you can compose a pipeline of functions +or stream processors to process an input stream of data to produce an +output stream. We call it a form of dataflow programming as data flows +through the processing logic. In imperative programming there is no +clear separation of data and logic. The logic can arbitrarily examine +and mutate data which creates a problem due to complex interleaving of +state and logic in the program. + +Imperative looping is a low level and monolithic concept, it is +difficult for programmers to implement and is error prone. Whereas +streams are high level, declarative, structured and modular way of +expressing what you usually do with low level loops. Streams allow +you to write different parts of the loop as modular combinators and +then compose them to create bigger loops. Streamly uses stream fusion +optimizations to ensure that the composed loop has the same performance +as a hand-written monolithic loop. + +## Performance Optimizations + +The streaming pipeline is translated into actual imperative loops by +the Haskell compiler GHC. The programmer writes a very high level +declarative code while the heavy lifting is done by the compiler to fuse +all that code together in a tight imperative loop. + +You might think that the code above may not perform as well as a +handwritten code for the same job. But you will be surprised how +efficiently GHC optimizes this code using a technique called stream +fusion which is based on two important optimizations done by GHC namely, +case-of-case and spec-constructor. There are no intermediate streams, +no constructor allocations, all heap values are unboxed while being +processed in the loop, thus resulting in the same code as a C compiler +would generate from a handwritten C loop. Essentially, the imperative +loop is written by the compiler using the high level instructions +provided by the programmer. diff --git a/docs/User/Tutorials/the-swiss-army-knife.md b/docs/User/Tutorials/the-swiss-army-knife.md new file mode 100644 --- /dev/null +++ b/docs/User/Tutorials/the-swiss-army-knife.md @@ -0,0 +1,335 @@ +# Streamly: The Swiss Army Knife for Haskell + + + + +Streamly provides a comprehensive suite of functionality through +a **consistent, concise, and modular interface**, backed by +**high-performance APIs**. Designed from the ground up, it **minimizes +abstractions** while **maximizing functionality and efficiency**. By +unifying features from many disparate Haskell packages on Hackage—and +often outperforming them—**Streamly acts as a Swiss army knife for +Haskell programmers**. + +Importantly, Streamly does **not** aim to replicate functionality that +already exists elsewhere. Instead, it focuses on creating **foundational +building blocks** that naturally deliver **broad, unified, and concise +capabilities** with **peak performance**. This approach embodies the +Haskell principle of **“don’t repeat yourself” (DRY)**, addressing +a gap often overlooked in the Haskell library ecosystem. + +Below, we provide an overview of Streamly’s functionality and show +how its modular building blocks unify disparate features into a single, +coherent framework. Streamly offers a unified alternative to several +existing packages. For new projects, it can reduce dependency bloat, +enable concise and expressive solutions to domain-specific problems, and +often deliver better performance out of the box. + +## Streaming + +Streamly offers **high-performance, feature-rich streaming** and data +flow programming operations. We are briefly mentioning some of the +key capabilities here among many others. + +### Three Core Abstractions + +Streamly provides three types of streams, each one allows transformation and +stateful processing of sequential streams of data but they differ in how they +can be composed: + +- **Producers (`Stream`)** – these are essentially generators or + source of data streams, multiple sources can be combined to create + a single source. +- **Transformers (`Scanl`)** – these are essentially pipes connecting sources + to sources or sinks, multiple scans can be combined together such that + a source stream can be split over multiple pipes and the resulting + streams can be the combined back into a single source stream. +- **Consumers (`Fold`)** – these are essentially final consumers or sinks of + data, multiple consumers can be combined together into a single + consumer such that a source stream can be distributed to all consumers + and the results can be combined. + +**Parsers** are a specialization of folds that support backtracking +and errors handling. Folds and parsers are **first-class building +blocks** for stateful data processing. Grouping, chunking and many other +operations over streams, scans and folds are implemented using folds and +parsers — making the library extremely versatile, modular, and yet +high-performing due to stream fusion. + +### Nested and Structured Stream Processing + +Streamly supports **nested stream processing** (the functional +equivalent of nested loops) in several styles: + +- **Depth-first** – inner loops run to completion before the next + outer loop iteration. +- **Breadth-first** – all outer loop iterations advance one step at a + time. +- **Fair interleaving** – inner and outer loops advance fairly in + parallel. + +With `concatIterate`, the output of a stream can be fed back into +its input, allowing recursion and control flow at the stream level. +It can be used for traversing **trees and graphs breadth-first or +depth-first**. `mergeMapWith` merges streams pairwise to form balanced +merge trees, for example you can merge sorted data from many files using +this combinator. + +### Sliding Windows and Sessions + +**Sliding windows** are an integral part of scans and folds, +enabling incremental window based computations for use cases +such as **time-series analysis, statistical metrics, and trading +indicators**—without recomputing the results over the entire dataset. + +Elements in streams can be **classified by keys** to route them to +different sessions, fold each substream differently in its own session, +and generate a stream of end results from these sessions. + +### Expressiveness and Performance + +These modular abstractions allow complex problems to be expressed in +**succinct and idiomatic way**. For example, merge sort in Streamly +is implemented in just a few lines of idiomatic code using only +general-purpose building blocks—yet the performance matches or exceeds +the highly optimized list implementation in base. + +Streamly provides a unified, expressive, and high-level alternative to +stream processing packages like `streaming`, `conduit`, `pipes`, and +`foldl`, with unmatched performance. + +## Concurrency + +Streamly is built for concurrency, all abstractions are designed for +concurrency, it provides native concurrent evaluation of streams, scans +and folds. All the ways in which stream processing pipelines can be +composed with serial processing can also be composed with concurrent +processing. For example, you can: + +- Map a function over a stream concurrently. +- generate multiple streams in parallel and merge the results in a single + stream. +- Split streams, scan each branch concurrently, and combine them back + into a single stream. +- Distribute a stream to different concurrent folds and merge back the results. +- Traverse trees or graphs, feed output streams back to input for + recursive processing, concurrently. +- Perform time-based operations such as sampling, throttling, or debouncing. +- Group items over time intervals or intersperse actions in a stream + periodically. + +Concurrent streaming with time based operations can be used to implement +programs based on functional reactive programming model. The operations +you can perform with Streamly often overlap with what libraries like +**Apache Flink** provide, but in a **lightweight, unified, and purely +functional way**. + +With all these facilities streamly allows you to express your domain +specific problems much more succinctly and effortlessly. For example, +the concurrent directory traversal written with streamly is just a +few lines of code, built from low level basic building blocks, and +outperforms rust based implementations. + +Streamly is much more higher level alternative to low level packages like +async, pipes-concurrency, streamling-concurrency etc. Take a look at the +`Streamly.Data.Stream.Prelude`, `Streamly.Data.Scanl.Prelude`, +`Streamly.Data.Fold.Prelude` modules in the streamly package. + +## Reactive Programming + +Streamly supports reactive (time domain) programming because of its support for +declarative concurrency. Please see the `Streamly.Data.Stream.Prelude` +module for time-specific and time based sampling combinators. + +Reactive programming is modeled beautifully using concurrent streaming in +streamly. It involves generation of streams of events, merging concurrent +streams and processing events concurrently. Streamly provides native +high-level facilities to do all this easily. + +The examples [AcidRain.hs][] and [CirclingSquare.hs][] demonstrate +reactive programming using [Streamly][]. + +[AcidRain.hs]: https://github.com/composewell/streamly-examples/tree/master/examples/AcidRain.hs +[CirclingSquare.hs]: https://github.com/composewell/streamly-examples/tree/master/examples/CirclingSquare.hs + +## Parsing + +Parsing in Streamly is first-class, high-performance, and integrated +with streams. Streamly treats parsers as core building blocks for +data processing. Many tasks—such as **sorting, chunking, and +structured transformations**—are expressed naturally with folds and +parsers. Parsers are not restricted to byte streams, any type of streams +can be parsed. It provides full-fledged parsing functionality equivalent +to the standard parser combinator libraries like `parsec`. Performance +is equivalent or better than some of the best performing libraries like +`attoparsec`. + +## Prompt Resource Cleanup + +One of the many challenges in a concurrent environment is safe, +correct and timely resource cleanup in all cases and races. Streamly +provides built-in prompt resource cleanup operations in a concurrent +environment. It provides basic IO level building blocks as well as +stream based resource management combinators, everything that you can do +with `resourcet` is built into the library. + +## Lists and Strings + +Streamly modules `Streamly.Data.Stream` and `Streamly.Data.Fold` cover +the entire functionality of `Data.List` from the `base` package. While +lists are sufficient and easy to use for many cases, it can be +problematic when you need to **interleave IO effects** such as tracing +or debug prints. Streamly streams provide the same interface as lists +but allow you to **inject IO effects anywhere** without buffering the +entire dataset in memory. Additionally, **Streamly streams often +outperform lists** when combining transformations. + +By virtue of its modularity it is able to express the string (stream) +splitting operations similar to the `split` package without any custom +implementation. In the same manner it implements search operations +similar to the `stringsearch` package. For string search, `splitOnSeq` +and `takeEndBySeq` in Streamly use the **Rabin-Karp algorithm** for +fast pattern matching. Benchmarks show performance comparable to the +Rust `ripgrep` tool. `Streamly.Unicode.String` also provides string +interpolation. + +## Non-determinism and List Transformers + +Streamly provides full list transformer functionality (e.g. equivalent +to the `ListT` from list-t package) and more. It does not provide a +Monad instance for streams, as there are many possible ways to define +the bind operation. Instead, it offers bind-style operations such as +'concatFor', 'concatForM', and their variants (e.g. fair interleaving +and breadth-first nesting). These can be used for convenient ListT-style +stream composition. Additionally, it provides applicative-style cross +product operations like 'cross' and its variants which are many times +faster than the monad style operations. + +## Logic Programming + +Streamly does not provide a 'LogicT'-style Monad instance, but it +offers comprehensive logic programming functionality. Operations like +'fairCross' and 'fairConcatFor' nest outer and inner streams fairly, +ensuring that no stream is starved when exploring cross products. + +This enables balanced exploration across all dimensions in backtracking +problems, while also supporting infinite streams without starvation. It +effectively replaces the core functionality of 'LogicT' from the +@logict@ package, with significantly better performance. In particular, +it avoids the quadratic slowdown seen with @observeMany@, and the +applicative 'fairCross' runs many times faster, achieving loop nesting +performance comparable to C. + +## Arrays + +Streamly provides comprehensive array functionality. Arrays are equal +partners to streams in general purpose programming. Arrays in streamly +can be mutable or immutable, boxed or unboxed, pinned or unpinned. Thus +they unify the functionality provided by the `bytestring`, `text` and +`vector` packages. The API is integrated with streams, it is concise and +modular because all the processing is done via streams. There is no +need of thinking about lazy bytestring vs strict bytestring, bytestring +vs text, text vs lazy text. Lazy in streamly is equivalent to stream +processing or stream of arrays, and strict is equivalent to arrays. + +The `streamly-bytestring` package provides interoperation of +streamly arrays with `bytestring`. `streamly-text` package provides +interoperability with `text`. + +Streamly also implements ring arrays which are essentially mutable +circular buffers. Ring Arrays help in implementing sliding windows +efficiently and conveniently. + +Streamly can potentially replace most array like package for example +`array`, `primitive`, `vector`, `vector-algorithms`, `ring-buffer`, +`bytestring`. + +## Serialization + +Binary serialization in streamly is built into arrays. Unboxed arrays +are in fact store data in binary serialized form. The `Unbox` and +`Serialize` type classes provide fast binary serialization and +deserialization. The `MutByteArray`, `MutArray` and `Array` modules +provide functions that can serialize Haskell data types using the +`Unbox` and `Serialize` type classes. + +Thus arrays in streamly are high performance alternative to +serialization packages like `binary`, `cereal`, `store` etc. + + + + + +## File System + +Streamly provides native, high-performance streaming APIs for file +system operations. There is also a module for file path representation +which leverages streamly arrays for high performance and safe path +operations. Path module is designed to allow gradual typing, you can +choose to use untyped path, absolute vs relative distinction, file vs +dir distinction or all four. The typed versions are not released yet but +available as internal modules. + +Paths and directory modules in streamly can be used as an alternative +for `filepath`, `directory`, and `path` packages. + +## Network + +Streamly provides native streaming APIs for network operations as a higher +level alternative to the `network` package functionality. + +## Clock and Time + +Streamly provides clock, time and timer APIs for high-performance +streaming use. See the `Streamly.Internal.Data.Time.Clock`, +`Streamly.Internal.Data.Time.Units` modules. These are currently +internal but will be released in a future release. + +## Compatibility + +Streamly can interwork with other packages in the Haskell ecosystem +providing similar functionality. Following is a list of examples or +packages providing interconversion: + + + + +| Interop with | Example, package | +|----------------|-----------------------------------------------------------------------| +| streaming | [streamly-examples](https://github.com/composewell/streamly-examples) | +| pipes | [streamly-examples](https://github.com/composewell/streamly-examples) | +| conduit | [streamly-examples](https://github.com/composewell/streamly-examples) | +| bytestring | [streamly-bytestring](https://github.com/psibi/streamly-bytestring) | +| text | [streamly-text](https://github.com/composewell/streamly-text) | +| filepath | [streamly-filepath](https://github.com/composewell/streamly-filepath) | + +See the `streamly-ecosystem` chapter for more details. diff --git a/docs/User/Tutorials/types-and-modules(examples).md b/docs/User/Tutorials/types-and-modules(examples).md new file mode 100644 --- /dev/null +++ b/docs/User/Tutorials/types-and-modules(examples).md @@ -0,0 +1,515 @@ +# Packages and Modules + +Streamly is a self sufficient, batteries included library for general +purpose programming. It has been designed for ease of use and high +performance. + +Streamly consists of two packages: "streamly-core" and "streamly". +[streamly-core](https://hackage.haskell.org/package/streamly-core) +provides most of the core functionality, and depends only on GHC boot libraries, while +[streamly](https://hackage.haskell.org/package/streamly) provides +higher-level features like concurrency, time based streaming +combinators, lifted exceptions, and streaming network operations. + +Streamly is built around two core data structures: streams and +arrays. They are computational duals—streams enable dataflow-style +processing, while arrays provide efficient data storage. Together, they +form a powerful foundation for general-purpose programming in +functional and dataflow paradigms. + +The general data processing functionality in `streamly` can be divided +into following categories: + +* Streams: for processing of in flight data +* Arrays: for in-memory storage of data at rest +* Serialization: for on-disk storage of data at rest +* Concurrency: for scaling your applications across CPUs + +The essential domain specific functionality can be divided into the +following categories: + +* Console IO: reading from and writing to stdin, stdout and stderr +* File system IO: for interfacing with the file system +* Network IO: for interfacing with the network +* Unicode: stream processing of Unicode text + +## Streams + +In functional programming, the **stream processing paradigm** offers +a higher-level alternative to the low-level looping constructs of +imperative programming. In Streamly, the `Stream` abstraction models +data as a sequence of items of the same type. Functional operations can +then be applied to process and transform each item, producing a new +stream of either the same or a different type. + +### Stream Type + +The following contrived example generates a stream of integers, +increments each element by 1, takes the first two elements, adds them +together, and prints the result: + +```haskell +import Data.Function ((&)) +import qualified Streamly.Data.Stream as Stream +import qualified Streamly.Data.Fold as Fold +import qualified Streamly.Data.Scanl as Scanl + +main1 = + Stream.enumerateFromTo 1 3 -- Stream IO Int + & fmap ((+1) :: Int -> Int) -- Stream IO Int + & Stream.take 2 -- Stream IO Int + & Stream.fold Fold.sum -- IO Int + >>= print -- IO () +``` + +See "Streamly.Data.Stream" module. + +### Fold Type + +Just like the `Stream` type represents a producer of a sequence of +items, the `Fold` type represents a consumer of a sequence of items of +the same type. A fold consumes a stream and returns a single value as +output. The `Fold.sum` function above is a `Fold` which consumes an +integer stream as input and returns their sum as output. The fold is +driven using the `Stream.fold` combinator. + +Folds can be composed using combinators. For example, the `teeWith` +combinator combines two folds so that the input stream is fed into both +the folds simultaneously. + +```haskell +f :: Monad m => Fold.Fold m Int (Int, Int) +f = Fold.teeWith (,) Fold.sum (Fold.lmap (\x -> x * x) Fold.sum) +main2 = + Stream.enumerateFromTo 1 3 -- Stream IO Int + & Stream.fold f -- IO Int + >>= print -- IO () +``` + +See "Streamly.Data.Fold" module. + +### Scanl Type + +The `Scanl` type represents a stateful transformation from a stream +to another stream. As a contrived example to demonstrate the basic +functionality of scans let us compute the expression `x^4 + 3x^2 + 4` for +each number in a stream. + +```haskell +scan1 :: Monad m => Scanl.Scanl m Int Int +scan1 = Scanl.mkScanl (\_ x -> x * x) undefined + +scan2 :: Monad m => Scanl.Scanl m Int Int +scan2 = Scanl.mkScanl (\_ x -> 3 * x) undefined + +scan3 :: Monad m => Scanl.Scanl m Int Int +scan3 = Scanl.teeWith (+) scan1 scan2 -- Compute x^2 + 3x + +scan4 :: Monad m => Scanl.Scanl m Int Int +scan4 = Scanl.postscanl scan1 scan3 -- compute x^2 then pass it to scan3 + +main3 = + Stream.enumerateFromTo 1 3 -- Stream IO Int + & Stream.scanl scan4 -- Stream IO Int + & fmap (+4) -- Stream IO Int + & Stream.fold (Fold.drainMapM print) -- IO () +``` + +`scan3` splits the computation into two parts, one part computes `x^2` +using `scan1` and the other part computes `3x` using `scan2` and then it +zips the two parts back into a single stream by summing them. `scan4` +first passes an element through `scan1` thus squaring it and then it +passes the result through `scan3`, the final result is +`x^4 + 3x^2`. Then we add 4 in the resulting stream and print each +element in the stream. + +In general, using scans, we can split the stream into multiple streams +and perform different stateful computations in each branch and then +merge them back into a single stream. + +See "Streamly.Data.Scanl" module. + +### Parser Type + +The `Parser` type represents a stream consumer just like the `Fold` type +but it adds failure handling and backtracking of input on failure. + +For example, to parse a sequence of digits: + +```haskell docspec +>>> import Data.Function ((&)) +>>> import qualified Data.Char as Char +>>> import qualified Streamly.Data.Stream.Prelude as Stream +>>> import qualified Streamly.Data.Parser as Parser +>>> import qualified Streamly.Data.Fold as Fold +>>> import qualified Streamly.Internal.Data.Stream as Stream (parsePos) +>>> decimal = Parser.takeWhile1 Char.isDigit Fold.toList +>>> Stream.parsePos decimal $ Stream.fromList "1234 is the number" +Right "1234" +>>> Stream.parsePos decimal $ Stream.fromList "this is the number" +Left (ParseErrorPos 1 "takeWhile1: predicate failed on first element") +``` + +On failure we can return a default value: + +```haskell docspec +>>> import Control.Applicative ((<|>)) +>>> Stream.parse (decimal <|> pure "0") $ Stream.fromList "this is the number" +Right "0" +``` + +See "Streamly.Data.Parser" module. + +## Arrays + + + +While streams are meant for sequential processing of in-flight data, arrays +are meant for storing data in memory with serial or random access. Processing +of the data stored by arrays is done using streams. + +### Immutable Arrays + +The `Array` type is used to represent immutable arrays which cannot be +modified in-place. + +```haskell docspec +>>> import qualified Streamly.Data.Array as Array +>>> arr = Array.fromList "hello" +>>> Array.length arr +5 +>>> Array.getIndex 1 arr +Just 'e' +``` + +Arrays provide streaming interfaces. Like all other data in streamly, arrays +are transformed using stream transformations. + +```haskell docspec +>>> arr <- Stream.fold Array.create $ Stream.enumerateFromTo 1 (5 :: Int) +>>> show arr +"fromList [1,2,3,4,5]" +>>> arr1 <- Stream.fold Array.create $ fmap (+1) $ Array.read arr +>>> show arr1 +"fromList [2,3,4,5,6]" +``` + +See "Streamly.Data.Array" and "Streamly.Data.Array.Generic" modules. + +### Mutable Arrays + +The `MutArray` type is used to represent mutable arrays which can be +modified in-place. Mutable arrays also have a reserved capacity to grow +without reallocation. + +```haskell docspec +>>> import qualified Streamly.Data.MutArray as MutArray +>>> arr <- Stream.fold (MutArray.createOf 12) $ Stream.fromList "hello" +>>> arr1 <- MutArray.snoc arr ' ' +>>> arr2 <- Stream.fold (MutArray.append2 arr1) $ Stream.fromList "world " +>>> MutArray.toList arr2 +"hello world " +>>> MutArray.putIndex 11 arr2 '!' +>>> MutArray.toList arr2 +"hello world!" +``` + +Since we allocated an array of 12 elements to begin with, `snoc` and +`append` operations do not reallocate the array, they just append to the +existing array. + +See "Streamly.Data.MutArray" and "Streamly.Data.MutArray.Generic" modules. + +## Serialization + +### MutByteArray + +The `MutByteArray` type is used to represent low level mutable byte +arrays which can be modified in-place. `Unbox` and `Serialize` type +classes use this data type to serialize Haskell data structures. + +### Unbox + +Unbox provides fast serialization of fixed size data types. +`deriveUnbox` can be used to automatically derive the instances of +`Unbox`. `Unbox` can also be derived using `Generic`. `Unbox` type +class provides `pokeAt` and `peekAt` operations to serialize and +deserialize Haskell data types: + +```haskell docspec +>>> import qualified Streamly.Data.MutByteArray as MutByteArray +>>> import Data.Proxy (Proxy(..)) +>>> arr <- MutByteArray.new 10 +>>> MutByteArray.pokeAt 0 arr 'h' +>>> offset = MutByteArray.sizeOf (Proxy :: Proxy Char) +>>> MutByteArray.pokeAt offset arr (1234 :: Int) +>>> r :: Char <- MutByteArray.peekAt 0 arr +>>> r +'h' +>>> r1 :: Int <- MutByteArray.peekAt offset arr +>>> r1 +1234 +``` + +The `Array` and MutArray types are unboxed arrays, they require an +`Unbox` instance. Writing to an `Array` or `MutArray` is in fact +exactly the same as serializing the type, and reading from them is +deserializing it. + +### Serialize + +`Serialize` provides fast serialization of any Haskell data types. +`deriveSerialize` can be used to automatically derive the instances +of `Serialize`. `Serialize` type class provides `serializeAt` and +`deserializeAt` operations to serialize and deserialize Haskell data +types: + +```haskell docspec +>>> import qualified Streamly.Data.MutByteArray as MutByteArray +>>> arr <- MutByteArray.new 10 +>>> offset <- MutByteArray.serializeAt 0 arr 'h' +>>> offset1 <- MutByteArray.serializeAt offset arr (1234 :: Int) +>>> (next, r :: Char) <- MutByteArray.deserializeAt 0 arr offset1 +>>> r +'h' +>>> (next1, r1 :: Int) <- MutByteArray.deserializeAt next arr offset1 +>>> r1 +1234 +``` + +The Array module also provides operations to serialize and deserialize a +Haskell data type to an `Array Word8`, using the `Serialize` type class: + +```haskell docspec +>>> import qualified Streamly.Data.Array as Array +>>> arr = Array.serialize' (1234 :: Int) +>>> fst (Array.deserialize arr) :: Int +1234 +``` + +## Concurrency and Time + +Concurrency and time operations can be found in the `streamly` package. +Stream operations can be performed concurrently by using the concurrent +combinators. + +### Concurrent Streams + +The following example uses `parMapM` which is a concurrent version of `mapM`, +consequently it prints a value every second even though there is a 2 second +serial delay for each element. + +```haskell docspec +>>> import Control.Concurrent (threadDelay) +>>> let delay n = threadDelay (n * 1000000) >> return n +>>> :{ +parMap = + Stream.repeatM (delay 1) + & Stream.parMapM (Stream.ordered True) (\x -> delay 1 >> print x) + & Stream.fold Fold.drain +:} +``` + +See `Streamly.Data.Stream.Prelude` module. + +### Concurrent Folds + +The following example evaluates each fold in a separate thread, therefore, even +though each fold introduces a serial delay of 1 second, the total delay is +still only 1 second instead of 2 seconds. + +```haskell docspec +>>> import qualified Streamly.Data.Fold.Prelude as Fold +>>> p x = delay 1 >> print x +>>> f1 = Fold.parBuffered id (Fold.drainMapM p) +>>> f2 = Fold.parBuffered id (Fold.lmap (\x -> x * x) (Fold.drainMapM p)) +>>> f = Fold.teeWith (\_ _ -> pure ()) f1 f2 +>>> :{ +parFolds = + Stream.enumerateFromTo 1 3 -- Stream IO Int + & Stream.fold f -- IO () +:} +``` + +See `Streamly.Data.Fold.Prelude` module. + +### Time Domain Operations + +Streamly provides time domain stream operations for reactive programming +including event sampling operations like throttle and debounce. + +For example, the `intervalsOf` operation collapses stream elements within a +specified time interval. + +```haskell docspec +>>> input = Stream.parBuffered (Stream.constRate 2) $ Stream.enumerateFrom 1 +>>> intervals = Stream.intervalsOf 1 Fold.toList input +>>> Stream.fold Fold.toList $ Stream.take 2 intervals +[[1,2],[3,4]] +``` + +See `Streamly.Data.Fold.Prelude` module. + +## Console IO + +The `Streamly.Console.Stdio` module provides facilities to read a stream +from stdin and to write a stream to stdout and stderr. + +Implementation of a console echo program: + +```haskell unshared +import Data.Function ((&)) +import qualified Streamly.Console.Stdio as Stdio + +main = + Stdio.readChunks -- Stream IO (Array Word8) + & Stdio.putChunks -- IO () +``` + +An example to read two numbers from separate lines on stdin and sum them: + +```haskell unshared +import Data.Function ((&)) +import qualified Streamly.Internal.Console.Stdio as Stdio +import qualified Streamly.Data.Stream as Stream +import qualified Streamly.Data.Fold as Fold + +main = + Stdio.readChars -- Stream IO Char + & Stream.splitSepBy_ (== '\n') Fold.toList -- Stream IO String + & fmap read -- Stream IO Int + & Stream.take 2 -- Stream IO Int + & Stream.fold Fold.sum -- IO Int + >>= print -- IO () +``` + +## File IO + +Implementation of the Unix `cp` utility to copy `input.txt` to `output.txt`: + +```haskell unshared +{-# LANGUAGE QuasiQuotes #-} + +import Data.Function ((&)) +import Streamly.FileSystem.Path (path) +import qualified Streamly.FileSystem.FileIO as File +import qualified Streamly.FileSystem.Path as Path +import qualified Streamly.Data.Stream as Stream + +main = + File.readChunks [path|input.txt|] -- Stream IO (Array Word8) + & Stream.fold (File.writeChunks [path|output.txt|]) -- IO () + +``` + +Implementation of the Unix `cat` utility to read all files from +the current directory on standard output. + +```haskell unshared +{-# LANGUAGE QuasiQuotes #-} + +import Data.Function ((&)) +import Streamly.FileSystem.Path (path) +import qualified Streamly.FileSystem.DirIO as Dir +import qualified Streamly.FileSystem.Path as Path +import qualified Streamly.Data.Stream as Stream +import qualified Streamly.Console.Stdio as Console +import qualified Streamly.FileSystem.FileIO as File + +main = + Dir.read [path|.|] -- Stream IO Path + & Stream.concatMap File.readChunks -- Stream IO (Array Word8) + & Console.putChunks -- IO () +``` + +## Network IO + +Streaming network operations can be found in `Streamly.Network.*` modules. Here +is a streaming implementation of a concurrent network server which echo's back +whatever it receives. + +```haskell docspec +>>> import Control.Exception (finally) +>>> import Network.Socket (Socket) +>>> import qualified Network.Socket as Net +>>> import qualified Streamly.Network.Inet.TCP as TCP +>>> import qualified Streamly.Network.Socket as Socket +>>> :{ +main :: IO () +main = + TCP.accept 8091 -- Stream IO Socket + & Stream.parMapM id (handleExceptions echo) -- Stream IO () + & Stream.fold Fold.drain -- IO () + where + echo :: Socket -> IO () + echo sk = + Socket.readChunksWith 32768 sk -- Stream IO (Array Word8) + & Stream.fold (Socket.writeChunks sk) -- IO () + handleExceptions :: (Socket -> IO ()) -> Socket -> IO () + handleExceptions f sk = finally (f sk) (Net.close sk) +:} +``` + +## Unicode Operations + +The `Streamly.Unicode.*` modules provide stream operations like UTF-8, UTF-16 +encoding and decoding, splitting Unicode char streams into lines, words and +joining lines and words etc. + +String quasiquoter: + +```haskell docspec +>>> :set -XQuasiQuotes +>>> import Streamly.Unicode.String (str) +>>> [str|this is a string|] +"this is a string" +``` + +String interpolation: + +```haskell docspec +>>> x = "interpolated" +>>> [str|this is an #{x} string|] +"this is an interpolated string" +``` + +Splitting a string into lines, each line is collected in a list fold and +all the lines are collected in a list fold.: + +```haskell docspec +>>> import qualified Streamly.Internal.Unicode.Stream as Unicode +>>> Stream.fold Fold.toList $ Unicode.lines Fold.toList (Stream.fromList "lines\nthis\nstring\n\n\n") +["lines","this","string","",""] +``` + +You could supply any fold to consume the lines in a different way, for example +use `Fold.length` to print the lengths of the lines: + +```haskell docspec +>>> Stream.fold Fold.toList $ Unicode.lines Fold.length (Stream.fromList "lines\nthis\nstring\n\n\n") +[5,4,6,0,0] +``` + +Decoding the contents of a file into a stream of Unicode chars: + +```haskell docspec +>>> import Streamly.FileSystem.FileIO as File +>>> import Streamly.FileSystem.Path as Path +>>> :{ +countChars inpFilePath = do + inp <- Path.fromString inpFilePath + File.readChunks inp & Unicode.decodeUtf8Chunks & Stream.fold Fold.length +:} +``` + +Streamly.Unicode.Parser provides Unicode char and sequence parsers: + +```haskell docspec +>>> import qualified Streamly.Unicode.Parser as Unicode +>>> Stream.parse Unicode.double $ Stream.fromList "3.14" +Right 3.14 +``` diff --git a/docs/User/Tutorials/types-and-modules(summary).md b/docs/User/Tutorials/types-and-modules(summary).md new file mode 100644 --- /dev/null +++ b/docs/User/Tutorials/types-and-modules(summary).md @@ -0,0 +1,102 @@ +# Streamly: Types & Modules Cheat Sheet + +This guide gives you a quick overview of Streamly’s core modules, +types, and their typical use cases. Use it as a reference map when +navigating the library. + +## streamly-core package + +![Streamly Core Modules](./streamly-core.svg) + +## streamly package + +![Streamly Modules](./streamly.svg) + +## Streams + +### Sources +- `Stream m a` — statically fused, composable source streams
+ **Module:** `Streamly.Data.Stream` +- `Unfold m a b` — statically fused streams, for nested fusion
+ **Module:** `Streamly.Data.Unfold` +- `StreamK m a` — CPS based source streams for dynamic composition
+ **Module:** `Streamly.Data.StreamK` + +### Transformations + +- `Scanl m a b` — statically fused scans, for composable stateful transformation
+ **Module:** `Streamly.Data.Scanl` + +### Consumers + +- `Fold m a b` — statically fused, composable stream consumers
+ **Module:** `Streamly.Data.Fold` +- `Parser a m b` — statically fused, composable parsers
+ **Module:** `Streamly.Data.Parser` +- `ParserK a m b` — CPS based parsers for dynamic composition
+ **Module:** `Streamly.Data.ParserK` + +--- + +## Arrays + +### Immutable + +- `Array a => Unbox a` — immutable, unboxed (pinned/unpinned)
+ **Module:** `Streamly.Data.Array` +- `Array a` — unconstrained type
+ **Module:** `Streamly.Data.Array.Generic` + +### Mutable + +- `MutArray a => Unbox a` — mutable, unboxed (pinned/unpinned)
+ **Module:** `Streamly.Data.MutArray` +- `MutArray a` — unconstrained type
+ **Module:** `Streamly.Data.MutArray.Generic` +- `RingArray a => Unbox a` — unboxed, circular buffer (pinned/unpinned)
+ **Module:** `Streamly.Data.RingArray` + +### Serialization + +- `Unbox a` — type class for fixed length binary serialization
+ **Module:** `Streamly.Data.MutByteArray` +- `Serialize a` — type class for variable length binary serialization
+ **Module:** `Streamly.Data.MutByteArray` +- `MutByteArray` — raw mutable byte arrays
+ **Module:** `Streamly.Data.MutByteArray` + +--- + +## Unicode Operations + +- `Streamly.Unicode.Stream` — encode/decode streams of text +- `Streamly.Unicode.Parser` — parsers for Unicode chars/strings +- `Streamly.Unicode.String` — string interpolation utilities + +--- + +## Concurrent Operations + +High-level concurrent, time-based, and lifted operations. + +- `Streamly.Data.Stream.Prelude` — concurrent operations for `Stream` type +- `Streamly.Data.Scanl.Prelude` — concurrent operations for `Scanl` type +- `Streamly.Data.Fold.Prelude` — concurrent operations for `Fold` type +- `Streamly.Data.Stream.MkType` — define custom monad/applicative stream types + +--- + +## File System + +- `Streamly.Console.Stdio` — console (stdin/stdout/stderr) streams +- `Streamly.FileSystem.Handle` — handle-based I/O streams +- `Streamly.FileSystem.FileIO` — path-based file I/O streams +- `Streamly.FileSystem.DirIO` — directory read streams +- `Streamly.FileSystem.Path` — file path operations + +--- + +## Network + +- `Streamly.Network.Socket` — socket-level stream operations +- `Streamly.Network.Inet.TCP` — TCP accept streams/connect diff --git a/docs/User/Tutorials/using-streamly.md b/docs/User/Tutorials/using-streamly.md new file mode 100644 --- /dev/null +++ b/docs/User/Tutorials/using-streamly.md @@ -0,0 +1,268 @@ + + +# Getting started with `Haskell Streamly` + +This guide shows you how to use Streamly in the GHCi REPL, in a simple +program, or in a Haskell project. + + + +No prior knowledge of Haskell is needed. We do however assume that you +are using a command-line shell on a POSIX operating system. If you are +running Windows™ then you may need to run a command-line shell +under `msys` and some of the commands below may also need to be changed +in small ways to make them work. + +## Streamly Library Packages + +Streamly comprises two packages, the +[streamly-core](https://hackage.haskell.org/package/streamly-core) +package provides functionality that depends only on boot libraries, and +the [streamly](https://hackage.haskell.org/package/streamly) package +provides additional functionality like concurrency, time, lifted +exceptions, and networking. + +For high-level functionality built over streamly like streaming +system processes, shell programming, GNU coreutils, statistics, +and compression libraries please see the [streamly ecosystem +packages](https://streamly.composewell.com/module-listing.html). + +## Released and Pre-release modules + +Some of the examples in the tutorials may use modules from the +`Internal` Streamly module hierarchy. These modules are not really +internal to the library. We classify `Streamly` modules into two +categories: + +* _Released modules and APIs_: These modules and APIs are + stable. Significant changes to these modules and APIs will cause + Streamly's version number to change according to the package versioning + policy. +* _Pre-release modules and APIs_: These modules and APIs have not been + formally released yet. They may change in the near future, and such + changes will not necessarily be reflected in Streamly's package + version number. As yet unreleased modules and APIs reside in the + `Internal` namespace. + +Please use a minor release upper bound to adhere to the Haskell PVP when +using a pre-release (internal) module. + + + +## Using `streamly` Interactively in REPL + +You can try out `streamly` using `GHCi`, the interactive Haskell +read-eval-print-loop (REPL). + +Streamly consists of two packages, namely `streamly-core` and +`streamly`. The former package provides basic functionality and the +latter provides higher level functionality. To start up the GHCi REPL +using the latest released `streamly-core` package from Hackage, please +use: + +``` +$ cabal repl --build-depends streamly-core +... plenty of build messages, the first time around ... +GHCi, version 9.2.2: https://www.haskell.org/ghc/ :? for help +ghci> +``` + +This command may take a while to build the package first time around, +please be patient. + +Once at the `ghci>` prompt, you can import Haskell modules from the +`streamly-core` package and use the available functions in the REPL: + +``` +ghci> import qualified Streamly.Data.Stream as Stream +ghci> import qualified Streamly.Data.Fold as Fold + +ghci> Stream.fold Fold.drain $ Stream.mapM print $ Stream.fromList [1..3] +1 +2 +3 +ghci> +``` + +For the curious, here is a high level overview of what these lines +do: + +1. `import qualified Streamly.Data.Stream as Stream` imports the Streamly + Stream module into GHCi, and makes it available under the name `Stream`. +2. `[1..3]` generates the Haskell list `[1, 2, 3]`. +3. `Stream.fromList` transforms that list into a stream of integers. +4. `Stream.mapM print` transforms the stream of integers into a stream of + actions that would print those integers when executed. +5. `Stream.fold Fold.drain` folds that stream using the `drain` fold, + transforming it into an IO action that evaluates the stream. + +### Using a specific version of `streamly` in the REPL + +You can also ask `cabal` to use a specific version of `streamly-core` by +adding a version number constraint to the `--build-depends` flag: + +``` +$ cabal repl --build-depends streamly-core==0.1.0 +... +ghci> +``` + +## Using `streamly` in a Project + +Create a project directory for our example project. + +``` +$ mkdir streamly-project +``` + +### Add `streamly` as project dependency + +Run `cabal init` in the project directory to create an initial set of +project files: + +``` +$ cd streamly-project +$ cabal init --non-interactive --minimal --dependency base --dependency streamly-core + +... +Generating app/Main.hs... +Generating streamly-project.cabal... +... +``` + +This invocation sets up a Haskell package named `streamly-project` +with two build dependencies, namely `base` (the Haskell standard +library) and `streamly-core`. You can add additional dependencies +later, by editing the `build-depends` section of the generated +cabal file `streamly-project.cabal`. Please see the [Cabal User +Guide](https://www.haskell.org/cabal/users-guide/) for more information +on `.cabal` files. + +IMPORTANT: Because of a bug in cabal 3.8, which is fixed in cabal 3.10, +this does not generate a dependency on `base`, please edit the generated +cabal file and add `base` in the `build-depends` section: + +``` + build-depends: base, streamly-core +``` + +This invocation also creates a skeletal `app/Main.hs`, therefore, we can +compile and run it right away: + +``` +$ cabal run +Hello, Haskell! +``` + +### Import `streamly` modules in the project code + +Let us now turn the single-line stanza we used in the REPL into a +standalone program. + +Edit `app/Main.hs` to contain the following: + +```haskell +module Main where + +import qualified Streamly.Data.Stream as Stream +import qualified Streamly.Data.Fold as Fold + +main :: IO () +main = Stream.fold Fold.drain $ Stream.mapM print $ Stream.fromList [1..3] +``` + +Build and run this program using `cabal run`: + +``` +$ cabal run +... build messages ... +1 +2 +3 +``` + +### Running GHCi REPL for the project code + +To start up the GHCi REPL for your project, please use: + +``` +$ cabal repl +... +Ok, one module loaded. +ghci> main +1 +2 +3 +ghci> +``` + +The repl will load all the dependencies and modules of the project. You can now +run your project code or any other code snippets as you desire. + +### (Advanced) Using the development version of `streamly` + +To use the development version of `streamly`, we need to configure +`cabal` to fetch it from Github. + +Create a `cabal.project` file in the project directory with the +following content: + +``` +packages: . +-- fetch streamly-core dependency package from github +source-repository-package + type: git + location: https://github.com/composewell/streamly + subdir: core + tag: master +``` + +With this file present, `cabal` will fetch and build the current +version of `streamly-core` from Github. For example: + +``` +$ cabal repl +Cloning into '/home/harendra/streamly-project/... +... +In order, the following will be built (use -v for more details): + - streamly-core-0.1.0 (lib:streamly-core) (requires build) + - streamly-project-0.1.0.0 (exe:streamly-project) (configuration changed) + ... +ghci> +``` + +## Which version of `streamly` should you use? + +If you are new to Streamly, we recommend using the latest [stable release +of streamly][streamly-hackage] on Hackage. + +If you need access to cutting edge features (and do not mind the +occasional breakage), please use the [development version of +streamly][streamly-github] from Github. + +## Building for Performance + +If you wish to run benchmarks, please be sure to build your +application using the instructions in the [Build Guide](/docs/User/HowTo/Compiling.md). + +## Next Steps + +If you got this far successfully, congratulations! For an overview +of the `streamly` package, please read the [Learn By +Examples](/docs/User/Tutorials/learn-by-examples.md) page. + + + + [Streamly]: https://streamly.composewell.com/ + [streamly-hackage]: https://hackage.haskell.org/package/streamly + [streamly-github]: https://github.com/composewell/streamly + [streamly-packages]: https://github.com/composewell/streamly-packages diff --git a/docs/User/Tutorials/why-haskell-streamly.md b/docs/User/Tutorials/why-haskell-streamly.md --- a/docs/User/Tutorials/why-haskell-streamly.md +++ b/docs/User/Tutorials/why-haskell-streamly.md @@ -3,89 +3,150 @@ SPDX-License-Identifer: BSD-3-Clause --> -# Why Haskell Streamly? +# Why Haskell and Streamly? -A computer programmer is faced with different types of programming tasks. A -software project may involve programming tasks that have different -characteristics. Usually programmers are forced to choose different programming -tools for different tasks. +## Why Haskell? -For example, you may be writing shell or python scripts to automate system -administration or deployment tasks, or for managing cloud deployments, -configuration. For such tasks you may not be worried about the performance but -you may be worried about correctness and how quickly you can achieve what you -want to do, and maintainability of the programs. For such tasks you would -usually reach out for python, shell scripting or other such high level -scripting languages. +Haskell provides a rock-solid foundation for building reliable, +maintainable, and efficient systems. It combines the rigor of a strongly +typed, purely functional language with the practicality of modern +tooling. -On the other hand you may be writing a program that require very high -performance and optimal use of resources so that the task can be finished -faster and requires less resources to save cost. High level scripting languages -(e.g. python or shell) may be unsuitable for such tasks because they could be -10x-100x slower compared to lower level languages like `Rust`, `C`, `C++` or -`Java`. +### Interactive Development (GHCi) -If you would like to use the same language and tools for all your -programming tasks, be it a quick script or a high performance system, -or if you do not want to build different set of teams for programming -tasks of different nature then Haskell Streamly is just the programming -framework for you. +Haskell is compiled for performance, but it also ships with an +interpreter (GHCi). This gives you the convenience of interactive +exploration—like Python or Ruby—while still compiling to fast native +code when needed. Types are inferred automatically, so you often don’t +need to write them explicitly, but they are always there to guarantee +safety. -Whether you are writing scripts to manage your systems, or to automate mundane -tasks like organizing photos or files on your computer, or to write tests for -your software systems, or crawling the network to glean some information, or -writing a quick network server, or writing algorithmic trading systems, or -doing high performance intensive data processing, Haskell Streamly is just the -right tool for you. +### Fearless Refactoring -Haskell Streamly is a very high level programming framework, like Python or -Shell or Sed or AWK, in fact much higher level than those, but at the same time -provides high performance like C or Rust. The ability to compose programs using -high level combinators in Haskell is unmatched. Not just efficient programs but -you can write programs that scale on multiple CPUs with the same ease. Streamly -uses the full power of Haskell to make concurrency composable in declarative -style, so that you can use concurrent programming fearlessly with the same ease -as non-concurrent programming. +Large systems inevitably evolve, and in many languages refactoring +introduces new bugs. In Haskell, immutability and a strong static type +system keep programs consistent, while the compiler catches errors early. +This makes refactoring safe and reliable—a quality that experienced +Haskell developers consistently vouch for in production systems. -Although Haskell is a compiled programming language it comes with an -interpreter (GHCi) which allows you to run Haskell code interactively like an -interpreted language. Haskell has a strong static type system, yet in most -cases you do not have to annotate the types because it infers the types -automatically. +### Correctness by Design -You can keep systems written with Haskell Streamly extremely modular using -reusable building blocks, modularity is the fundamental characteristic and -a design goal of Streamly. At the same time Haskell allows you to do fearless -refactoring of your program to continuously evolve it without the fear of -introducing more bugs or breaking it every time you touch it. +Many common bugs in other languages—null pointer exceptions, data +races, accidental mutation—simply don’t exist in Haskell. This frees +you to focus on business logic instead of defensive programming. -The type safety and immutability by default in Haskell avoids a lot of bugs -that would otherwise find their way into your programs if you are using less -safe languages. You focus on your business logic rather than the correctness -issues imposed by the programming paradigm. +### Portability and Interoperability -Haskell is extensible, you can integrate C programs with Haskell very easily. -Programs written in Haskell work on `macOS`, `Windows`, `Linux` or any Unix -like system and even on the browser using the Java Script and Web assembly -backends. +Haskell is portable across Linux, macOS, Windows, and even the browser +(via JavaScript or WebAssembly). It can seamlessly interoperate with C, +Python, and many other languages, letting you reuse existing code and +libraries. -Haskell Streamly is a standard library for Haskell and supplements the Haskell -base package. It comes equipped with basic data structures and functions like -Streams, Arrays, Folds, Parsers, file system facilities like directory IO, file -IO, Unicode text processing, network processing using low level sockets or high -level operations. Concurrent programming facilities or time domain programming -facilities. +--- -The collection of high level building blocks provided by the Streamly ecosystem -allow you to write a variety of programs quickly. You can turn your shell or -python scripts into safe, highly modular and high performance programs using -`streamly-coreutils`. Moreover, you do not have to depend on any native OS -packages installed on the system. Or if you would like to use native -executables in your programs you can use `streamly-process` to invoke the -executables and connect the data streams generated like pipes in a seamless -manner. Or if you would like to use the shell to invoke and compose the -executables and integrate it seamless in your program you can do that too using -`streamly-shell`. If you would like to use statistical computation in your -programs try out `streamly-statistics`. Streamly ecosystem is evolving and -there are more useful packages in the works. In addition, you have thousands of -Haskell packages that are available on Hackage. +## Why Streamly? + +Streamly builds on Haskell’s strengths to provide a single framework +for everything from quick automation scripts to high-performance +servers. It combines **Python’s ease of use, C’s performance, +Rust’s safety, and Go’s concurrency model**—all in one framework, +and goes even further. + +### Performance Matching Low-Level Languages + +High-level scripting languages like Python or Bash can be **10x–100x +slower** than optimized low-level languages such as C, Rust, or +Java. For tasks where efficiency matters—data pipelines, servers, +or numerical processing—this overhead is unacceptable. + +Streamly leverages GHC’s advanced optimizations and stream fusion to +deliver performance on par with C, without sacrificing expressiveness. +It gives you the best of both worlds: the productivity of high-level +scripting languages like Python or Bash, with the performance of +low-level languages like C and Rust. + +### More Expressive than Scripting Languages + +For scripting, system management, data wrangling, or even spinning up +quick servers, Streamly offers high-level combinators that let you +compose programs declaratively. Its design philosophy emphasizes +**modularity**: a hierarchy of composable building blocks, where +higher-level constructs are built from lower-level ones. This degree +of modularity is possible in Haskell due to purity, which enables +the compiler to reason about and combine components safely, creating +higher-level functionality without compromising performance. The result +is much more power and expressiveness than Python or shell scripting— +while still compiling to efficient native code. + +### Fearless Concurrency + +Streamly is designed for concurrency, allowing you to write concurrent +code in a declarative style. Haskell’s purity lends itself +particularly well to concurrency, and Streamly leverages this unique +feature in Haskell. Its high-level abstractions free you from low-level +concerns such as threads, locks, and synchronization. There is little +distinction between concurrent and non-concurrent code—if your program +follows the streaming paradigm, it can be made concurrent effortlessly. + +### Standard Library for Real-World Needs + +The streaming model is the truest form of functional programming, +delivering the high composability that functional programming promises. +Streamly extends Haskell’s base library with unified, streaming-capable +APIs for everyday programming: + +- Streams, folds, and parsers for data processing +- Arrays for random-access storage with streaming APIs +- Binary serialization and deserialization +- Streaming file and directory I/O +- Streaming Unicode text processing +- Streaming network APIs +- Time-based streaming APIs for FRP +- Concurrency built into all APIs + +With these tools, you can move seamlessly from quick prototypes to +production-grade systems—without ever switching languages. + +### Streamly Ecosystem + +Beyond the core library, Streamly provides an ecosystem of packages: + +- **`streamly-process`**: Launch and compose executables, connect their + input and output streams, run shell commands, and integrate them + seamlessly into Haskell streaming pipelines. +- **`streamly-coreutils`**: Replace shell or Python scripts with safe, + modular, high-performance Haskell equivalents. +- **`streamly-statistics`**: Perform incremental statistical analysis on + sliding windows of data within streaming pipelines. +- **`streamly-fsevents`**: Watch files or directories for file system + events (inotify) and generate event streams. + +More packages are continually evolving. Combined with the thousands of +Haskell libraries on [Hackage](https://hackage.haskell.org), Streamly +gives you a complete toolkit for building powerful applications. + +--- + +## One Language for Everything + +Modern software projects demand many different kinds of programs: + +- Quick scripts for automation +- High-performance data processing +- Concurrent or parallel applications +- Network servers and distributed systems + +Traditionally, this forces programmers to juggle different tools: Python +or shell for scripting, C/C++/Rust for performance, Java/Go for servers, +and special frameworks for concurrency. This fragmentation leads to +duplicated effort, larger teams, and higher maintenance costs. + +**Haskell Streamly provides a single framework for all of these +tasks.** You can write concise, high-level programs that are safe, +scalable, and easy to reason about—yet still achieve performance +competitive with C. + +Haskell gives you correctness, safety, and interactive development. +Streamly adds performance, concurrency, modularity, and practical +libraries. Together, they remove the need to juggle multiple languages +for different tasks. diff --git a/docs/User/Tutorials/why-not-lists.md b/docs/User/Tutorials/why-not-lists.md new file mode 100644 --- /dev/null +++ b/docs/User/Tutorials/why-not-lists.md @@ -0,0 +1,224 @@ + + +# Why not lists? + +This document explains some problems that you might face when using +Haskell lists and why using streams is better in those cases. + +## Haskell Lazy Evaluation + +Haskell is fundamentally different from other languages. In most +languages, a variable name refers to some concrete data in memory; in +Haskell, a variable may refer to concrete data or it could refer to +a computation or expression which when evaluated would produce the +concrete data that the variable is referring to. When the value of the +variable is needed, the computation is evaluated and replaced by +the result. + +When a Haskell program starts, the entire program is an unevaluated +expression which is evaluated on-demand as needed. The top level +expression is forced to produce data when a result is demanded from it +for IO. Parts of the expression are reduced as needed, the reduction +process can be controlled by the programmer. + +## Unevaluated Expressions + +When we assign a value to a name, the name refers to the unevaluated +expression and not what it would produce when evaluated. For example: + +``` +>>> infiniteList = [1..] +``` + +The name `infiniteList` refers to an expression which when evaluated +would generate the list. `infiniteList` is not an actual physical list +but just an expression to generate the list `when needed`. Because we +are not storing the actual list in memory, we can represent an infinite +list without requiring infinite amount of memory. + +Let's try to get the length of this list: + +``` +>>> len = length infiniteList +``` + +Like before, the name `len` refers to an expression that when evaluated +would give us the length of the list. Till now Haskell has been saying +that I duly noted how to do what you want to do but I will do it only +when you need it. Let's ask it to do that now: + +``` +>>> len +...hangs forever +``` + +Now, Haskell has no choice but to start evaluating the expression but we +know it can never finish because the list is infinite. + +All expressions in Haskell are unevaluated by default. Haskell +evaluates the expressions only when it is absolutely required e.g. when +we have to print something, or write it to a file or to network. + +## On-demand Expression Evaluation + +Let us illustrate expression evaluation in Haskell with an example. Write +this little program in a file `example.hs`: + +```haskell unshared +main = + let largeList = [1..1000000::Int] + n = length largeList + in print n +``` + +The expression `largeList` is never evaluated to generate the entire +list at once. It is evaluated on-demand one element at a time by the +`length` function. The `length` function is in turn evaluated by the +`print` function when it evaluates its argument `n`. The `print` +function is evaluated by the top level program because it wants to print +`n` to the console. + +We can verify that the whole list is not stored in memory by looking at +the memory usage of this program. Let's compile and run it: + +``` +$ ghc -O example.hs +$ ./example +RTS -s +1000000 + 51,480 bytes allocated in the heap + 24 bytes copied during GC + 44,328 bytes maximum residency (1 sample(s)) +``` + +`largeList` is an expression representing a million element list, but +the program takes only 44K maximum memory. The `length` function +evaluates `largeList` one element at a time to count them, as soon as +an element is counted it can be garbage collected as there are no more +references to it in the entire program. + +## Expressions Holding up Heap Memory + +Let's try this program instead: + +```haskell unshared +{-# OPTIONS_GHC -Wno-x-partial #-} + +main = do + let largeList = [1..1000000::Int] + x1 = last largeList + x2 = head largeList + in print (x1, x2) +``` + +``` +$ ghc -O example.hs +$ ./example +RTS -s +(1000000,1) + 64,051,552 bytes allocated in the heap + 400 bytes copied during GC + 26,233,360 bytes maximum residency (4 sample(s)) +``` + +This program is showing 26MB maximum residency instead of 44K +earlier. Why is it so? To evaluate the first element of the tuple, `x1`, +we need to evaluate the entire list to get to the last element. However, +the head of the list is referenced by the element `x2` as well which +is yet to be evaluated and used. Therefore, we need to retain the head +until `x2` is printed and freed. But head of the list is referencing the +next element in the list which in turn is referring to the next element +and so on, therefore, the entire list is retained in memory between the +evaluation of `x1` and `x2`. + +If we change the print statement to `(x2, x1)` then we do not need to +retain the entire list between the two evaluations. + +When memory is unexpectedly retained in a program it is known as a +"space-leak" in the Haskell parlance. + +## Forcing Expression Evaluation + +Even if there is no explicit dependency in the program forcing +evaluation of an expression, the programmer can force the evaluation of +an expression using `seq`: + +```haskell unshared +{-# OPTIONS_GHC -Wno-x-partial #-} + +main = do + let largeList = [1..1000000::Int] + x1 = last largeList + x2 = head largeList + in print (x1 `seq` x2) +``` + +Similar to the example in previous section, this example also retains +the entire list in memory because `seq` forces `x1` to be evaluated +before `x2` and then returns `x2`, the evaluated list is held until `x2` is +returned. + +## Avoiding Unnecessary Memory Retention + +Memory retention can be avoided by changing the way we construct the +expression to process the data. We can use Streamly to avoid memory +retention in the above program. + +Let's first write it using streamly and reproduce the same problem: + +```haskell unshared +import Data.Functor.Identity (runIdentity) +import qualified Streamly.Data.Stream as Stream +import qualified Streamly.Data.Fold as Fold + +main = do + let largeList = Stream.fromList [1..1000000::Int] + x1 = runIdentity $ Stream.fold Fold.latest largeList + x2 = runIdentity $ Stream.fold Fold.one largeList + in print (x1, x2) +``` + +This program has the same behavior as the list based program, and for +the same reasons. + +``` +$ ghc -O2 example.hs +$ ./example +RTS -s +(Just 1000000,Just 1) + 64,052,520 bytes allocated in the heap + 400 bytes copied during GC + 26,233,360 bytes maximum residency (4 sample(s)) +``` + +However, we can compose the two folds using the `teeWith` combinator +such that we distribute a each element of the list to both the folds +simultaneously, thus avoiding the retainment of the entire list: + +```haskell unshared +import Data.Functor.Identity (runIdentity) +import qualified Streamly.Data.Stream as Stream +import qualified Streamly.Data.Fold as Fold + +main = do + let largeList = Stream.fromList [1..1000000::Int] + x = Fold.teeWith (,) Fold.latest Fold.one + in print $ runIdentity $ Stream.fold x largeList +``` + +``` +$ ghc -O2 example.hs +$ ./example +RTS -s +(Just 1000000,Just 1) + 64,052,736 bytes allocated in the heap + 280 bytes copied during GC + 44,328 bytes maximum residency (2 sample(s)) +``` + +This program uses constant small memory footprint (44K) irrespective of +the order of the elements in the tuple. When an element is generated by +the list it is supplied to both the folds before generating the next +element, therefore, it can be immediately freed. + +Streamly covers all the functionality of standard Haskell lists but in addition +provides powerful composition tools for better efficiency. diff --git a/docs/diagrams/module-diagram.hs b/docs/diagrams/module-diagram.hs new file mode 100644 --- /dev/null +++ b/docs/diagrams/module-diagram.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +import Diagrams.Prelude +import Diagrams.Backend.SVG.CmdLine +import Data.List (isPrefixOf) + +splitOn :: Eq a => [a] -> [a] -> [[a]] +splitOn delim str = go str + where + go [] = [[]] + go s + | delim `isPrefixOf` s = [] : go (drop (length delim) s) + | otherwise = + let (c:cs) = s + (x:xs) = go cs + in (c:x) : xs + +------------------------------------------------------------------------------- +-- Utilities +------------------------------------------------------------------------------- + +title1 t = + vsep 0.3 [ text line # fontSizeL 0.3 # bold | line <- splitOn "\n" t ] +title2 t = text t # fontSizeL 0.2 # bold + +textBox x y t = t <> strutX x <> strutY y + +item1 t = text t # fontSizeL 0.25 +enumerate items = vsep 0.3 [ textBox 2.0 0.4 (item1 i) | i <- items ] + +boxedXY :: Double -> Double -> Diagram B -> Diagram B +boxedXY w h content = content # centerXY <> rect w h # lw thin + +boxedEnum x y items = + let list = enumerate items + in boxedXY x y (list # centerXY) + +titleW = 2.0 +titleH = 0.5 + +boxedTitledEnum1 x y title items = + let ttext = textBox titleW titleH (title1 title) + list = enumerate items + in boxedXY x y (vsep 0 [ttext, boxedXY x (y - titleH) (list # centerXY)]) + +connect1 = connectOutside' (with & arrowHead .~ tri & headLength .~ global 0.2) + +coreOval :: String -> Diagram B +coreOval tag = + textBox 2.0 0.5 (title1 tag # centerXY) + <> ellipseXY 1.5 0.75 # fc lightblue # lw medium + +------------------------------------------------------------------------------- +-- streamly-core diagram +------------------------------------------------------------------------------- + +bigBoxW = 12 +bigBoxH = 4 +centerBoxW = bigBoxH +centerBoxH = bigBoxH + +box1 = boxedXY bigBoxW bigBoxH +box2 = boxedXY centerBoxW centerBoxH + +bigBoxSubContent = boxedTitledEnum1 (bigBoxW / 3) (bigBoxH - titleH) + +streamsBox :: Diagram B +streamsBox = + let prod = bigBoxSubContent "Generation" ["Stream", "StreamK", "Unfold"] + transf = bigBoxSubContent "Transformation" ["Scanl"] + cons = bigBoxSubContent "Consumption" ["Fold", "Parser", "ParserK"] + row = hsep 0 [prod, transf, cons] + title = textBox titleW titleH (title1 "Streams") + content = vsep 0 [title, row # centerXY] + in box1 (content # centerXY) + +arraysBox :: Diagram B +arraysBox = + let immut = bigBoxSubContent "Immutable" ["Array", "Array.Generic"] + mut = bigBoxSubContent "Mutable" ["MutArray", "MutArray.Generic", "RingArray"] + ser = bigBoxSubContent "Serialization" ["MutByteArray", "Unbox", "Serialize"] + row = hsep 0 [immut, mut, ser] + title = textBox titleW titleH (title1 "Arrays") + content= vsep 0 [title, row # centerXY] + in box1 (content # centerXY) + +fileSystemBox :: Diagram B +fileSystemBox = + let items = ["Console.Stdio", "FileIO", "DirIO", "Handle", "Path"] + content = boxedTitledEnum1 centerBoxW centerBoxH "File System" items + in box2 (content # centerXY) + +otherModulesBox :: Diagram B +otherModulesBox = + let unicode = boxedTitledEnum1 centerBoxW (centerBoxH * 2/3) "Unicode" ["Parser", "Stream", "String"] + resmgmt = boxedTitledEnum1 centerBoxW (centerBoxH * 1/3) "Resource Management" ["Control.Exception"] + content = vsep 0 [unicode, resmgmt] + in box2 (content # centerXY) + +streamlyCore :: Diagram B +streamlyCore = + let center = coreOval "streamly-core\n(types and modules)" # named "core" + topBox = streamsBox # named "streams" + bottomBox = arraysBox # named "arrays" + leftBox = fileSystemBox # named "fs" + rightBox = otherModulesBox # named "others" + + placed = position + [ (p2 (0,0), center) + , (p2 (0,4), topBox) + , (p2 (0,-4), bottomBox) + , (p2 (-4,0), leftBox) + , (p2 (4,0), rightBox) + ] + + arrows = applyAll + [ connect1 "core" "streams" + , connect1 "core" "arrays" + , connect1 "core" "fs" + , connect1 "core" "others" + ] + in arrows placed + +------------------------------------------------------------------------------- +-- streamly diagram +------------------------------------------------------------------------------- + +concurrentStreamsBox :: Diagram B +concurrentStreamsBox = + let prod = bigBoxSubContent "Generation" ["Stream.Prelude"] + transf = bigBoxSubContent "Transformation" ["Scanl.Prelude"] + cons = bigBoxSubContent "Consumption" ["Fold.Prelude"] + row = hsep 0 [prod, transf, cons] + title = textBox titleW titleH (title1 "Concurrent Streams") + content = vsep 0 [title, row # centerXY] + in box1 (content # centerXY) + +networkBox :: Diagram B +networkBox = + let items = ["Network.Socket", "Network.Inet.TCP"] + content = boxedTitledEnum1 centerBoxW centerBoxH "Network" items + in box2 (content # centerXY) + +streamly :: Diagram B +streamly = + let center = coreOval "streamly" # named "streamly" + topBox = concurrentStreamsBox # named "concurrent-streams" + bottomBox = networkBox # named "network" + + placed = position + [ (p2 (0,0), center) + , (p2 (0,4), topBox) + , (p2 (0,-4), bottomBox) + ] + + arrows = applyAll + [ connect1 "streamly" "concurrent-streams" + , connect1 "streamly" "network" + ] + in arrows placed + +main :: IO () +main = + mainWith + [ ("streamly-core", (streamlyCore # centerXY # pad 1.1)) + , ("streamly", (streamly # centerXY # pad 1.1)) + ] diff --git a/docs/streamly-docs.cabal b/docs/streamly-docs.cabal deleted file mode 100644 --- a/docs/streamly-docs.cabal +++ /dev/null @@ -1,48 +0,0 @@ -cabal-version: 2.2 --- Reasons for having a separate package for docs: --- * Leaner main package and better modularity --- * This package can be forked out as an independent package --- * We can have code examples in haddock with more dependencies --- * Documentation can be released independent of the library --- * We do not want too many doc modules in the main library -name: streamly-docs -version: 0.9.0 -synopsis: Documentation for Streamly -description: Documentation for Streamly -build-type: Simple - -------------------------------------------------------------------------------- --- Library -------------------------------------------------------------------------------- - -extra-doc-files: - User/*.md - User/Tutorials/*.md - User/Tutorials/*.link - User/HowTo/*.md - User/HowTo/*.link - User/Explanatory/*.md - User/Explanatory/streaming-pradigms.rst - User/ProjectRelated/*.md - User/ProjectRelated/*.link - User/ProjectRelated/ApiChangelogs/0.8.3.txt - User/ProjectRelated/ApiChangelogs/0.8.3-0.9.0.txt - Developer/*.png - Developer/*.md - Developer/*.link - Developer/*.rst - -library - default-language: Haskell2010 - ghc-options: -Wall - hs-source-dirs: . - exposed-modules: - User.Tutorials.Tutorial - User.Tutorials.ConcurrentStreams - User.Tutorials.ReactiveProgramming - - build-depends: - base >= 4.9 && < 4.18 - , transformers >= 0.4 && < 0.6 - , streamly - , streamly-core diff --git a/src/Streamly.hs b/src/Streamly.hs deleted file mode 100644 --- a/src/Streamly.hs +++ /dev/null @@ -1,624 +0,0 @@ -{-# OPTIONS_GHC -Wno-deprecations #-} - --- | --- Module : Streamly --- Copyright : (c) 2017 Composewell Technologies --- --- License : BSD3 --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- --- 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 ':'. --- --- @ --- > 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] --- @ --- --- Unlike lists, streams can be constructed from monadic effects: --- --- @ --- > S.'toList' $ 'getLine' \`consM` 'getLine' \`consM` S.'nil' --- hello --- world --- ["hello","world"] --- @ --- --- 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: --- --- @ --- > 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 NoMonomorphismRestriction #-} - -#include "inline.hs" - -module Streamly {-# DEPRECATED "Please use \"Streamly.Prelude\" instead." #-} - ( - -- -- * 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 - - -- ** Speculative Streams - -- $ahead - , AheadT - - -- ** Asynchronous Streams - -- $async - , AsyncT - , WAsyncT - , ParallelT - - -- ** Zipping Streams - -- $zipping - , ZipSerialM - , ZipAsyncM - - -- * Parallel Function Application - -- $application - , (IP.|$) - , (IP.|&) - , (IP.|$.) - , (IP.|&.) - , mkAsync - - -- * Merging Streams - -- $sum - , serial - , wSerial - , ahead - , async - , wAsync - , parallel - - -- * Concurrency Control - -- $concurrency - , maxThreads - , maxBuffer - - -- * Rate Limiting - , Rate (..) - , rate - , avgRate - , minRate - , maxRate - , constRate - - -- * Stream Type Adapters - -- $adapters - , IsStream () - - , serially - , wSerially - , asyncly - , aheadly - , wAsyncly - , parallely - , zipSerially - , zipAsyncly - , adapt - - -- * IO Streams - , Serial - , WSerial - , Ahead - , Async - , WAsync - , Parallel - , 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. - -- - , foldWith - , foldMapWith - , forEachWith - - -- * Re-exports - , Semigroup (..) - -- * Deprecated - , runStream - ) -where - -import Data.Semigroup (Semigroup(..)) -import Streamly.Internal.Control.Concurrent (MonadAsync) -import Streamly.Internal.Data.SVar (Rate(..)) -import Streamly.Internal.Data.Stream.Ahead -import Streamly.Internal.Data.Stream.Async -import Streamly.Internal.Data.Stream.IsStream.Combinators -import Streamly.Internal.Data.Stream.IsStream.Expand -import Streamly.Internal.Data.Stream.IsStream.Type - -import qualified Streamly.Prelude as P -import qualified Streamly.Internal.Data.Stream.IsStream as IP -import qualified Streamly.Internal.Data.Stream.IsStream.Transform as Transform - --- XXX provide good succinct examples of pipelining, merging, splitting etc. --- 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.Data.Array.Foreign.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.fold 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.Data.Array.Foreign") 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 ------------------------------------------------------------------------------- - --- | 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 "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 --} - --- XXX Deprecate it in 0.8.0 --- --- | Make a stream asynchronous, triggers the computation and returns a stream --- in the underlying monad representing the output generated by the original --- computation. The returned action is exhaustible and must be drained once. If --- not drained fully we may have a thread blocked forever and once exhausted it --- will always return 'empty'. --- --- @since 0.2.0 -{-# INLINABLE mkAsync #-} -mkAsync :: (IsStream t, MonadAsync m) => t m a -> m (t m a) -mkAsync = return . Transform.mkAsync - ------------------------------------------------------------------------------- --- Documentation ------------------------------------------------------------------------------- - --- $serial --- --- 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 --- --- /Scheduling and execution:/ In an asynchronous stream @a \`consM` b \`consM` --- c ...@, the actions @a@, @b@, and @c@ are executed concurrently with the --- consumer of the stream. The actions are /scheduled/ for execution in the --- same order as they are specified in the stream. Multiple scheduled actions --- may be /executed/ concurrently in parallel threads of execution. The --- actions may be executed out of order and they may complete at arbitrary --- times. Therefore, the /effects/ of the actions may be observed out of --- order. --- --- /Buffering:/ The /results/ from multiple threads of execution are queued in --- a buffer as soon as they become available. The consumer of the stream is --- served from this buffer. Therefore, the consumer may observe the results to --- be out of order. In other words, an asynchronous stream is an unordered --- stream i.e. order does not matter. --- --- /Concurrency control:/ Threads are suspended if the `maxBuffer` limit is --- reached, and resumed when the consumer makes space in the buffer. The --- maximum number of concurrent threads depends on `maxThreads`. Number of --- threads is increased or decreased based on the speed of the consumer. --- --- /Generation operations:/ Concurrent stream generation operations e.g. --- 'Streamly.Prelude.replicateM' when used in async style schedule and execute --- the stream generating actions in the manner described above. The generation --- actions run concurrently, effects and results of the actions as observed by --- the consumer of the stream may be out of order. --- --- /Transformation operations:/ Concurrent stream transformation operations --- e.g. 'Streamly.Prelude.mapM', when used in async style, schedule and --- execute transformation actions in the manner described above. Transformation --- actions run concurrently, effects and results of the actions may be --- observed by the consumer out of order. --- --- /Variants:/ There are two asynchronous stream types 'AsyncT' and 'WAsyncT'. --- They are identical with respect to single stream evaluation behavior. Their --- behaviors differ in how they combine multiple streams using 'Semigroup' or --- 'Monad' composition. Since the order of elements does not matter in --- asynchronous streams the 'Semigroup' operation is effectively commutative. - --- $zipping --- --- 'ZipSerialM' and 'ZipAsyncM', provide 'Applicative' instances for zipping the --- corresponding elements of two streams together. Note that these types are --- not monads. - --- $application --- --- Stream processing functions can be composed in a chain using function --- application with or without the '$' operator, or with reverse function --- application operator '&'. Streamly provides concurrent versions of these --- operators applying stream processing functions such that each stage of the --- stream can run in parallel. The operators start with a @|@; we can read '|$' --- as "@parallel dollar@" to remember that @|@ comes before '$'. --- --- Imports for the code snippets below: --- --- @ --- import Streamly --- import qualified Streamly.Prelude as S --- import Control.Concurrent --- @ - --- $sum --- The 'Semigroup' operation '<>' of each stream type combines two streams in a --- type specific manner. This section provides polymorphic versions of '<>' --- which can be used to combine two streams in a predetermined way irrespective --- of the type. - --- XXX An alternative design choice would be to let a control parameter affect --- the nearest SVar only and then it gets cleared. The benefit of the current --- choice is that it is simply just like global configuration, just like state --- behaves, so should be easy to comprehend. But it has the downside of leaking --- to undesired actions, that is we can forget to reset it. --- --- $concurrency --- --- These combinators can be used at any point in a stream composition to set --- 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 --- --- You may want to use different stream composition styles at different points --- in your program. Stream types can be freely converted or adapted from one --- type to another. The 'IsStream' type class facilitates type conversion of --- one stream type to another. It is not used directly, instead the type --- combinators provided below are used for conversions. --- --- To adapt from one monomorphic type (e.g. 'AsyncT') to another monomorphic --- type (e.g. 'SerialT') use the 'adapt' combinator. To give a polymorphic code --- a specific interpretation or to adapt a specific type to a polymorphic type --- use the type specific combinators e.g. 'fromAsync' or 'fromWSerial'. You --- cannot adapt polymorphic code to polymorphic code, as the compiler would not know --- 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. - --- | Same as 'Streamly.Prelude.concatFoldableWith' --- --- @since 0.1.0 -{-# DEPRECATED foldWith "Please use 'Streamly.Prelude.concatFoldableWith' instead." #-} -{-# INLINEABLE foldWith #-} -foldWith :: (IsStream t, Foldable f) => (t m a -> t m a -> t m a) -> f (t m a) -> t m a -foldWith = P.concatFoldableWith - --- | Same as 'Streamly.Prelude.concatMapFoldableWith' --- --- @since 0.1.0 -{-# DEPRECATED foldMapWith "Please use 'Streamly.Prelude.concatMapFoldableWith' instead." #-} -{-# INLINEABLE 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.concatMapFoldableWith - --- | Same as 'Streamly.Prelude.concatForFoldableWith' --- --- @since 0.1.0 -{-# DEPRECATED forEachWith "Please use 'Streamly.Prelude.concatForFoldableWith' instead." #-} -{-# INLINEABLE 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.concatForFoldableWith - -{-# DEPRECATED serially "Please use 'Streamly.Prelude.fromSerial' instead." #-} -serially :: IsStream t => SerialT m a -> t m a -serially = fromSerial - -{-# DEPRECATED wSerially "Please use 'Streamly.Prelude.fromWSerial' instead." #-} -wSerially :: IsStream t => WSerialT m a -> t m a -wSerially = fromWSerial - -{-# DEPRECATED asyncly "Please use 'Streamly.Prelude.fromAsync' instead." #-} -asyncly :: IsStream t => AsyncT m a -> t m a -asyncly = fromAsync - -{-# DEPRECATED aheadly "Please use 'Streamly.Prelude.fromAhead' instead." #-} -aheadly :: IsStream t => AheadT m a -> t m a -aheadly = fromAhead - -{-# DEPRECATED wAsyncly "Please use 'Streamly.Prelude.fromWAsync' instead." #-} -wAsyncly :: IsStream t => WAsyncT m a -> t m a -wAsyncly = fromWAsync - -{-# DEPRECATED parallely "Please use 'Streamly.Prelude.fromParallel' instead." #-} -parallely :: IsStream t => ParallelT m a -> t m a -parallely = fromParallel - -{-# DEPRECATED zipSerially "Please use 'Streamly.Prelude.fromZipSerial' instead." #-} -zipSerially :: IsStream t => ZipSerialM m a -> t m a -zipSerially = fromZipSerial - -{-# DEPRECATED zipAsyncly "Please use 'Streamly.Prelude.fromZipAsync' instead." #-} -zipAsyncly :: IsStream t => ZipAsyncM m a -> t m a -zipAsyncly = fromZipAsync diff --git a/src/Streamly/Data/Fold/Prelude.hs b/src/Streamly/Data/Fold/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Data/Fold/Prelude.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : Streamly.Data.Fold.Prelude +-- Copyright : (c) 2021 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : released +-- Portability : GHC +-- +-- All Fold related combinators including the streamly-core +-- "Streamly.Data.Fold" module, concurrency, unordered container operations. +-- +module Streamly.Data.Fold.Prelude + ( + -- * Setup + -- | To execute the code examples provided in this module in ghci, please + -- run the following commands first. + -- + -- $setup + + -- * "Streamly.Data.Fold" + -- | All "Streamly.Data.Fold" combinators are re-exported via this + -- module. For more pre-release combinators also see + -- "Streamly.Internal.Data.Fold" module. + module Streamly.Data.Fold + -- * Concurrent Operations + -- ** Configuration + , Config + , maxBuffer + , boundThreads + , inspect + + -- ** Combinators + , parBuffered + , parTee + , parDistribute + , parDistributeScan + , parPartition + , parDemuxScan + , parUnzip + + -- * Container Related + , toHashMapIO + + -- ** Deprecated + , parEval + ) +where + +import Control.Monad.IO.Class (MonadIO) +import Data.HashMap.Strict (HashMap) +import Data.Hashable (Hashable) +import Streamly.Data.Fold +import Streamly.Internal.Data.Fold (toContainerIO) +import Streamly.Internal.Data.Fold.Prelude +import Streamly.Internal.Data.IsMap.HashMap () + +#include "DocTestDataFold.hs" + +-- | Split the input stream based on a hashable component of the key field and +-- fold each split using the given fold. Useful for map/reduce, bucketizing +-- the input in different bins or for generating histograms. +-- +-- Consider a stream of key value pairs: +-- +-- >>> input = Stream.fromList [("k1",1),("k1",1.1),("k2",2), ("k2",2.2)] +-- +-- Classify each key to a different hash bin and fold the bins: +-- +-- >>> classify = Fold.toHashMapIO fst (Fold.lmap snd Fold.toList) +-- >>> sortOn fst . HM.toList <$> Stream.fold classify input :: IO [(String, [Double])] +-- [("k1",[1.0,1.1]),("k2",[2.0,2.2])] +-- +-- /Pre-release/ +-- +{-# INLINE toHashMapIO #-} +toHashMapIO :: (MonadIO m, Hashable k +#if __GLASGOW_HASKELL__ == 810 + , Eq k +#endif + ) => + (a -> k) -> Fold m a b -> Fold m a (HashMap k b) +toHashMapIO = toContainerIO diff --git a/src/Streamly/Data/Fold/Tee.hs b/src/Streamly/Data/Fold/Tee.hs --- a/src/Streamly/Data/Fold/Tee.hs +++ b/src/Streamly/Data/Fold/Tee.hs @@ -13,4 +13,4 @@ ) where -import Streamly.Internal.Data.Fold.Tee +import Streamly.Internal.Data.Fold diff --git a/src/Streamly/Data/Scanl/Prelude.hs b/src/Streamly/Data/Scanl/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Data/Scanl/Prelude.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : Streamly.Data.Scanl.Prelude +-- Copyright : (c) 2025 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : released +-- Portability : GHC +-- +-- All Scan related combinators including the streamly-core +-- "Streamly.Data.Scanl" module, concurrency, unordered container operations. +-- +module Streamly.Data.Scanl.Prelude + ( + -- * Setup + -- | To execute the code examples provided in this module in ghci, please + -- run the following commands first. + -- + -- $setup + + -- * "Streamly.Data.Scanl" + -- | All "Streamly.Data.Scanl" combinators are re-exported via this + -- module. For more pre-release combinators also see + -- "Streamly.Internal.Data.Scanl" module. + module Streamly.Data.Scanl + -- * Concurrent Operations + -- ** Configuration + , Config + , maxBuffer + , boundThreads + , inspect + + -- ** Combinators + , parTeeWith + , parDistributeScanM + , parDistributeScan + , parDemuxScanM + , parDemuxScan + ) +where + +import Streamly.Data.Scanl +import Streamly.Internal.Data.Scanl.Prelude + +#include "DocTestDataScanl.hs" diff --git a/src/Streamly/Data/Stream/Concurrent.hs b/src/Streamly/Data/Stream/Concurrent.hs deleted file mode 100644 --- a/src/Streamly/Data/Stream/Concurrent.hs +++ /dev/null @@ -1,191 +0,0 @@ --- | --- Module : Streamly.Data.Stream.Concurrent --- Copyright : (c) 2022 Composewell Technologies --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : released --- Portability : GHC --- --- This module provides concurrent streaming abstractions. --- --- == Programming Tips --- --- The names in this module do not conflict with other stream modules, --- therefore, you can import it in the same namespace: --- --- >>> import qualified Streamly.Data.Stream.Concurrent as Stream - -module Streamly.Data.Stream.Concurrent - ( - -- * Concurrency - -- $concurrency - MonadAsync - - -- ** Configuration - , Config - - -- *** Limits - , maxThreads - , maxBuffer - - -- *** Rate Control - , Rate(..) - , rate - , avgRate - , minRate - , maxRate - , constRate - - -- *** Stop behavior - , StopWhen (..) - , stopWhen - - -- *** Scheduling behavior - , eager - , ordered - , interleaved - - -- *** Diagnostics - , inspect - - -- ** Combinators - -- | Stream combinators using a concurrent channel. - - -- *** Evaluate - -- | Evaluates a serial stream asynchronously using a concurency channel. - - , parEval - - -- *** Generate - -- | Uses a concurrency channel to evaluate multiple actions concurrently. - , parRepeatM - , parReplicateM - , fromCallback - - -- *** Map - -- | Uses a concurrency channel to evaluate multiple mapped actions - -- concurrently. - - , parMapM - , parSequence - - -- *** Combine two - -- | Use a channel for each pair. - , parZipWithM - , parZipWith - , parMergeByM - , parMergeBy - - -- *** List of streams - -- | Shares a single channel across many streams. - - , parList - -- , zipWithM - -- , zipWith - - -- *** Stream of streams - -- **** Apply - - , parApply - - -- **** Concat - -- | Shares a single channel across many streams. - - , parConcat - , parConcatMap - - -- **** ConcatIterate - , parConcatIterate - - -- *** Observation - , tapCount - ) -where - -import Streamly.Internal.Data.Stream.Concurrent -import Prelude hiding (mapM, sequence, concat, concatMap, zipWith) - --- $concurrency --- --- == Concurrency Channels --- --- At a lower level, concurrency is implemented using channels that support --- concurrent evaluation of streams. We create a channel, and add one or more --- streams to it. The channel evaluates multiple streams concurrently and then --- generates a single output stream from the results. How the streams are --- combined depends on the configuration of the channel. --- --- == Concurrency Primitives --- --- There are only a few fundamental abstractions for concurrency, 'parEval', --- 'parConcatMap', and 'parConcatIterate', all concurrency combinators can be --- expressed in terms of these. --- --- 'parEval', evaluates a single stream asynchronously, a worker thread runs --- the stream and buffers the results, and the consumer of the stream runs in --- another thread consuming it from the buffer, thus decoupling the production --- and consumption of the stream. This can be used to run different stages of a --- pipeline concurrently. --- --- 'parConcatMap' is used to evaluate multiple streams concurrently and combine --- the results. A stream generator function is mapped to the input stream and --- all the generated streams are then evaluated concurrently, and the results --- are combined. --- --- 'parConcatIterate' is like 'parConcatMap' but iterates a stream generator --- function recursively over the stream. This can be used to traverse trees or --- graphs. --- --- == Concurrency Configuration --- --- Concurrent combinators take a 'Config' argument which controls the --- concurrent behavior. For example, maximum number of threads to be used --- ('maxThreads') or the maxmimum size of the buffer ('maxBuffer'), or how the --- streams are scheduled with respect to each other ('interleaved'), or how the --- results are consumed ('ordered'). --- --- Configuration is specified as @Config -> Config@ modifier functions that can --- be composed together using function composition. For example, to specify the --- maximum threads we can use @parConcatMap (maxThreads 10)@ if we also want to --- specify the maximum buffer we can compose the two options @parConcatMap --- (maxThreads 10 . maxBuffer 100)@. To use default configuration use 'id' as --- the config modifier e.g. @parConcatMap id@. --- --- See the @Configuration@ section and individual configuration options' --- documentation for the default behavior and default values of configuration --- parameters. --- --- == Scheduling behavior --- --- The most important configuration option is to control whether the output of --- the concurrent execution is consumed in the same order as the corresponding --- actions in the input stream or as soon as they arrive. The default is the --- latter, however, we can enforce the original order by using the 'ordered' --- option. --- --- Another important option controls whether the number of worker threads are --- automatically increased and decreased based on the consumption rate or --- threads are started as aggresively as possible until the 'maxThreads' or --- 'maxBuffer' limits are hit. The default is the former. However, the 'eager' --- option can be enabled to use the latter behavior. When 'eager' is on, even --- if the stream consumer thread blocks it does not make any impact on the --- scheduling of the available tasks. --- --- == Concurrent Combinators --- --- Using the few fundamental concurrency primitives we can implement all the --- usual streaming combinators with concurrent behavior. Combinators like --- 'unfoldrM', 'iterateM' that are inherently serial can be evaluated --- concurrently with respect to the consumer pipeline using 'parEval'. --- Combinators like 'zipWithM', 'mergeByM' can also use 'parEval' on the input --- streams to evaluate them concurrently before combining. --- --- Combinators like 'repeatM', 'replicateM', 'fromListM', 'sequence', 'mapM' in --- which all actions are independent of each other can be made concurrent using --- the 'parConcatMap' operation. --- --- A concurrent 'repeatM' repeats an action using multiple concurrent --- executions of the action. Similarly, a concurrent 'mapM' performs the mapped --- action in independent threads. --- --- Some common concurrent combinators are provided in this module. diff --git a/src/Streamly/Data/Stream/Exception.hs b/src/Streamly/Data/Stream/Exception.hs deleted file mode 100644 --- a/src/Streamly/Data/Stream/Exception.hs +++ /dev/null @@ -1,24 +0,0 @@ --- | --- Module : Streamly.Data.Stream.Exception --- Copyright : (c) 2022 Composewell Technologies --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : released --- Portability : GHC --- --- This module is designed such that it does not conflict with --- "Streamly.Data.Stream" module. --- --- >>> import qualified Streamly.Data.Stream.Exception as Stream --- -module Streamly.Data.Stream.Exception - ( - -- * Lifted Exceptions - after - , bracket - -- , bracket3 - , finally - ) -where - -import Streamly.Internal.Data.Stream.Exception.Lifted diff --git a/src/Streamly/Data/Stream/MkType.hs b/src/Streamly/Data/Stream/MkType.hs --- a/src/Streamly/Data/Stream/MkType.hs +++ b/src/Streamly/Data/Stream/MkType.hs @@ -7,7 +7,8 @@ -- Portability : GHC -- -- Template Haskell macros to create custom newtype wrappers for the 'Stream' --- type, deriving all the usual instances. +-- type. See the examples below to create the standard stream types that were +-- available in streamly versions before 0.9.0. -- -- To use this module, the following extensions must be enabled: -- @@ -23,32 +24,138 @@ -- >>> import Streamly.Data.Stream.MkType -- >>> import qualified Streamly.Data.Stream.Prelude as Stream -- --- Example, create an applicative type with zipping apply: +-- We are describing below many useful types that can be created using macros +-- in this module and the behavior of those types. These could be useful if you +-- like to program using the monad \"do notation\" instead of using concatMap +-- like operations. -- +-- == Parallel +-- +-- An unordered concurrent version of the serial 'Nested' type. Runs multiple +-- iterations of the nested loops concurrently, iterations may execute out of +-- order. More outer iterations are started only if the existing inner +-- iterations are not saturating the resources. +-- -- >>> :{ --- zipApply = Stream.zipWith ($) --- $(mkZipType "ZipStream" "zipApply" False) +-- bind = flip (Stream.parConcatMap id) +-- $(mkCrossType "Parallel" "bind" True) -- :} -- --- Example, create an applicative type with concurrent zipping apply: +-- This is a bounded concurrent, unordered list-transformer (ListT) monad. -- +-- WARNING! By design, monad bind of this type is not associative, because of +-- concurrency order of effects as well as results may be unpredictable. +-- +-- Same as the deprecated 'Streamly.Prelude.AsyncT' type. +-- +-- == FairParallel +-- +-- Like Parallel but strikes a balance between going deeper into existing +-- iterations of the loop and starting new iterations. +-- -- >>> :{ --- parApply = Stream.parApply id --- $(mkZipType "ParZipStream" "parApply" True) +-- bind = flip (Stream.parConcatMap (Stream.interleaved True)) +-- $(mkCrossType "FairParallel" "bind" True) -- :} -- --- Example, create a monad type with an eager concurrent cross product bind: +-- This is a bounded concurrent, fair logic programming (LogicT) monad. -- +-- WARNING! By design, monad bind of this type is not associative, because of +-- concurrency order of effects as well as results may be unpredictable. +-- +-- Same as the deprecated 'Streamly.Prelude.WAsyncT' type. +-- +-- == EagerParallel +-- +-- Like Parallel, but executes as many actions concurrently as possible. This +-- is useful if you want all actions to be scheduled at the same time so that +-- something does not get starved due to others. +-- -- >>> :{ -- parBind = flip (Stream.parConcatMap (Stream.eager True)) --- $(mkCrossType "ParEagerStream" "parBind" True) +-- $(mkCrossType "EagerParallel" "parBind" True) -- :} -- --- Instead of using these macros directly you could use the generated code as --- well. Use these macros in ghci to generate the required code and paste it in --- your package, you can customize the code as desired. See the docs of the --- macros below for examples about how to view the generated code. +-- This is an unbounded concurrent, unordered list transformer (ListT) monad. -- +-- WARNING! By design, monad bind of this type is not associative, because of +-- concurrency order of effects as well as results may be unpredictable. +-- +-- Same as the deprecated 'Streamly.Prelude.ParallelT' type. +-- +-- == OrderedParallel +-- +-- Like Parallel, runs many iterations concurrently, but stages the results +-- such that the results of iterations are presented in the same order as +-- specified in the code. This is closest to the serial Nested type in behavior +-- among all the concurrent types. +-- +-- >>> :{ +-- bind = flip (Stream.parConcatMap (Stream.ordered True)) +-- $(mkCrossType "OrderedParallel" "bind" True) +-- :} +-- +-- This is a bounded concurrent, ordered list transformer (ListT) monad. +-- +-- WARNING! Monad bind of this type is associative for values, but because of +-- concurrency, order of effects may be unpredictable. +-- +-- Same as the deprecated 'Streamly.Prelude.AheadT' type. +-- +-- == Zip +-- +-- An applicative type to zip two streams. +-- +-- >>> :{ +-- zipApply = Stream.zipWith ($) +-- $(mkZipType "Zip" "zipApply" False) +-- :} +-- +-- Same as the deprcated 'Streamly.Prelude.ZipSerialM' type. +-- +-- == ParZip +-- +-- Like Zip but evaluates the two streams concurrently. +-- +-- >>> :{ +-- parCrossApply = Stream.parCrossApply id +-- $(mkZipType "ParZip" "parCrossApply" True) +-- :} +-- +-- Same as the deprecated 'Streamly.Prelude.ZipAsync' type. +-- +-- == Avoiding Template Haskell +-- +-- Instead of using these macros directly you could copy and paste the +-- generated code as well. Use these macros in ghci to generate the required +-- code and paste it in your package, you can customize the code as desired. +-- See the docs of the macros below for examples about how to view the +-- generated code. For example: +-- +-- >>> bind = flip (Stream.parConcatMap id) +-- >>> expr <- runQ (mkCrossType "AsyncT" "bind" True) +-- +-- >> putStrLn $ pprint expr + +-- XXX TBD +-- +-- == Nested +-- +-- A serial cross monad type, same as 'Streamly.Data.StreamK.Nested' but with +-- mtl instances. +-- +-- == FairNested +-- +-- Like Nested but strikes a balance between going deeper into existing +-- iterations of the loop and starting new iterations. Same as +-- 'Streamly.Data.StreamK.FairNested' but additional with mtl instances. +-- +-- == InvertedParallel +-- +-- gives more priority to opening new iterations than to run existing +-- iterations. The interleaved options should be diagonal, and interleaved can +-- be for giving priority to iterations. + module Streamly.Data.Stream.MkType ( -- * Imports for Examples diff --git a/src/Streamly/Data/Stream/Prelude.hs b/src/Streamly/Data/Stream/Prelude.hs --- a/src/Streamly/Data/Stream/Prelude.hs +++ b/src/Streamly/Data/Stream/Prelude.hs @@ -6,25 +6,233 @@ -- Stability : experimental -- Portability : GHC -- --- This module re-exports the "Streamly.Data.Stream" module from the --- "streamly-core" package and additionally provides concurrency, time and --- lifted exception operations as well in a single module. --- --- Also see the following modules for more pre-release operations: +-- For upgrading to streamly-0.9.0+ please read the +-- . +-- Also, see the "Streamly.Data.Stream.MkType" module for direct replacement of +-- stream types that have been removed in 0.9.0. -- --- * "Streamly.Internal.Data.Stream.Concurrent" --- * "Streamly.Internal.Data.Stream.Time" --- * "Streamly.Internal.Data.Stream.Exception.Lifted" +-- All Stream related combinators including the streamly-core +-- "Streamly.Data.Stream" module, concurrency, time and lifted +-- exception operations. For more pre-release operations also see +-- "Streamly.Internal.Data.Stream.Prelude" module. -- module Streamly.Data.Stream.Prelude - ( module Streamly.Data.Stream - , module Streamly.Data.Stream.Concurrent - , module Streamly.Data.Stream.Time - , module Streamly.Data.Stream.Exception + ( + -- * "Streamly.Data.Stream" + -- | All "Streamly.Data.Stream" combinators are re-exported via this + -- module. For more pre-release combinators also see + -- "Streamly.Internal.Data.Stream" module. + module Streamly.Data.Stream + + -- * Concurrent Operations + -- $concurrency + + -- ** Types + , MonadAsync + + -- ** Configuration + , Config + + -- *** Limits + , maxThreads + , maxBuffer + + -- *** Rate Control + , Rate(..) + , rate + , avgRate + , minRate + , maxRate + , constRate + + -- *** Stop behavior + , StopWhen (..) + , stopWhen + + -- *** Scheduling behavior + , eager + , ordered + , interleaved + + -- *** Resource management + , useAcquire + , clearAcquire + + -- *** Diagnostics + , inspect + + -- ** Combinators + -- | Stream combinators using a concurrent channel. + + -- *** Evaluate + -- | Evaluate a stream as a whole concurrently with respect to the consumer + -- of the stream. + + , parBuffered + + -- *** Generate + -- | Generate a stream by evaluating multiple actions concurrently. + , parRepeatM + , parReplicateM + , fromCallback + + -- *** Map + -- | Map actions on a stream such that the mapped actions are evaluated + -- concurrently with each other. + + , parMapM + , parSequence + + -- *** Combine two + -- | Combine two streams such that each stream as a whole is evaluated + -- concurrently with respect to the other stream as well as the consumer of + -- the resulting stream. + , parZipWithM + , parZipWith + , parMergeByM + , parMergeBy + + -- *** List of streams + -- | Shares a single channel across many streams. + + , parList + -- , zipWithM + -- , zipWith + + -- *** Stream of streams + -- **** Apply + + , parCrossApply + + -- **** Concat + -- | Shares a single channel across many streams. + + , parConcat + , parConcatMap + + -- **** ConcatIterate + , parConcatIterate + + -- *** Observation + , parTapCount + + -- * Time Related + + -- ** Timers + , interject + + -- ** Trimming + , takeInterval + , dropInterval + + -- ** Chunking + , intervalsOf + + -- ** Sampling + , sampleIntervalEnd + , sampleIntervalStart + , sampleBurstEnd + , sampleBurstStart + + -- * Lifted Exceptions + , after + , bracket + -- , bracket3 + , finally + + -- ** Deprecated + , tapCount + , parEval + , parApply ) where import Streamly.Data.Stream -import Streamly.Data.Stream.Concurrent -import Streamly.Data.Stream.Exception -import Streamly.Data.Stream.Time +import Streamly.Internal.Data.Stream.Prelude + +-- $concurrency +-- +-- == Channels +-- +-- At a lower level, concurrency is implemented using channels that support +-- concurrent evaluation of streams. We create a channel, and add one or more +-- streams to it. The channel evaluates multiple streams concurrently and then +-- generates a single output stream from the results. How the streams are +-- combined depends on the configuration of the channel. +-- +-- == Primitives +-- +-- There are only a few fundamental abstractions for concurrency, 'parBuffered', +-- 'parConcatMap', and 'parConcatIterate', all concurrency combinators can be +-- expressed in terms of these. +-- +-- 'parBuffered' evaluates a stream as a whole asynchronously with respect to +-- the consumer of the stream. A worker thread evaluates multiple elements of +-- the stream ahead of time and buffers the results; the consumer of the stream +-- runs in another thread consuming the elements from the buffer, thus +-- decoupling the production and consumption of the stream. 'parBuffered' can be +-- used to run different stages of a pipeline concurrently. +-- +-- 'parConcatMap' is used to evaluate multiple actions in a stream concurrently +-- with respect to each other or to evaluate multiple streams concurrently and +-- combine the results. A stream generator function is mapped to the input +-- stream and all the generated streams are then evaluated concurrently, and +-- the results are combined. +-- +-- 'parConcatIterate' is like 'parConcatMap' but iterates a stream generator +-- function recursively over the stream. This can be used to traverse trees or +-- graphs. +-- +-- == Configuration +-- +-- Concurrent combinators take a 'Config' argument which controls the +-- concurrent behavior. For example, maximum number of threads to be used +-- ('maxThreads') or the maxmimum size of the buffer ('maxBuffer'), or how the +-- streams are scheduled with respect to each other ('interleaved'), or how the +-- results are consumed ('ordered'). +-- +-- Configuration is specified as @Config -> Config@ modifier functions that can +-- be composed together using function composition. For example, to specify the +-- maximum threads we can use @parConcatMap (maxThreads 10)@ if we also want to +-- specify the maximum buffer we can compose the two options @parConcatMap +-- (maxThreads 10 . maxBuffer 100)@. To use default configuration use 'id' as +-- the config modifier e.g. @parConcatMap id@. +-- +-- See the @Configuration@ section and individual configuration options' +-- documentation for the default behavior and default values of configuration +-- parameters. +-- +-- == Scheduling +-- +-- The most important configuration option is to control whether the output of +-- the concurrent execution is consumed in the same order as the corresponding +-- actions in the input stream or as soon as they arrive. The default is the +-- latter, however, we can enforce the original order by using the 'ordered' +-- option. +-- +-- Another important option controls whether the number of worker threads are +-- automatically increased and decreased based on the consumption rate or +-- threads are started as aggresively as possible until the 'maxThreads' or +-- 'maxBuffer' limits are hit. The default is the former. However, the 'eager' +-- option can be enabled to use the latter behavior. When 'eager' is on, even +-- if the stream consumer thread blocks it does not make any impact on the +-- scheduling of the available tasks. +-- +-- == Combinators +-- +-- Using the few fundamental concurrency primitives we can implement all the +-- usual streaming combinators with concurrent behavior. Combinators like +-- 'unfoldrM', 'iterateM' that are inherently serial can be evaluated +-- concurrently with respect to the consumer pipeline using 'parBuffered'. +-- Combinators like 'zipWithM', 'mergeByM' can also use 'parBuffered' on the input +-- streams to evaluate them concurrently before combining. +-- +-- Combinators like 'repeatM', 'replicateM', 'fromListM', 'sequence', 'mapM' in +-- which all actions are independent of each other can be made concurrent using +-- the 'parConcatMap' operation. +-- +-- A concurrent 'repeatM' repeats an action using multiple concurrent +-- executions of the action. Similarly, a concurrent 'mapM' performs the mapped +-- action in independent threads. +-- +-- Some common concurrent combinators are provided in this module. diff --git a/src/Streamly/Data/Stream/Time.hs b/src/Streamly/Data/Stream/Time.hs deleted file mode 100644 --- a/src/Streamly/Data/Stream/Time.hs +++ /dev/null @@ -1,37 +0,0 @@ --- | --- Module : Streamly.Data.Stream.Time --- Copyright : (c) 2022 Composewell Technologies --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : released --- Portability : GHC --- --- This module provides time related streaming abstractions. --- --- The names in this module do not conflict with other stream modules, --- therefore, you can import it in the same namespace: --- --- >>> import qualified Streamly.Data.Stream.Time as Stream --- -module Streamly.Data.Stream.Time - ( - -- * Time - -- ** Timers - interject - - -- ** Trimming - , takeInterval - , dropInterval - - -- ** Chunking - , intervalsOf - - -- ** Sampling - , sampleIntervalEnd - , sampleIntervalStart - , sampleBurstEnd - , sampleBurstStart - ) -where - -import Streamly.Internal.Data.Stream.Time diff --git a/src/Streamly/Data/Unicode/Stream.hs b/src/Streamly/Data/Unicode/Stream.hs deleted file mode 100644 --- a/src/Streamly/Data/Unicode/Stream.hs +++ /dev/null @@ -1,99 +0,0 @@ --- | --- 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.Data.Array.Foreign.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.Data.Array.Foreign.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.Data.Array.Foreign.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 --- --- @Stream 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.Memory.Unicode.Array". - --- XXX an unpinned array representation can be useful to store short and short --- lived strings in memory. --- -module Streamly.Data.Unicode.Stream - {-# DEPRECATED "Please use Streamly.Unicode.Stream module from the streamly-core package." #-} - ( - -- * Construction (Decoding) - decodeLatin1 - , decodeUtf8 - - -- * Elimination (Encoding) - , encodeLatin1 - , 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 - - -- * Deprecations - , decodeUtf8Lax - , encodeLatin1Lax - , encodeUtf8Lax - ) -where - -import Streamly.Internal.Unicode.Stream -import Prelude hiding (lines, words, unlines, unwords) diff --git a/src/Streamly/Internal/Control/ForkLifted.hs b/src/Streamly/Internal/Control/ForkLifted.hs --- a/src/Streamly/Internal/Control/ForkLifted.hs +++ b/src/Streamly/Internal/Control/ForkLifted.hs @@ -9,15 +9,17 @@ module Streamly.Internal.Control.ForkLifted ( doFork + , doForkWith , fork , forkManaged ) where -import Control.Concurrent (ThreadId, forkIO) +import Control.Concurrent (ThreadId, forkIO, forkOS) import Control.Exception (SomeException(..), catch, mask) import Data.Functor (void) -import Streamly.Internal.Control.Concurrent (MonadRunInIO, RunInIO(..), withRunInIO, withRunInIONoRestore) +import Streamly.Internal.Control.Concurrent + (MonadRunInIO, RunInIO(..), withRunInIO, withRunInIONoRestore) import Streamly.Internal.Control.ForkIO (rawForkIO, forkManagedWith) -- | Fork a thread to run the given computation, installing the provided @@ -32,11 +34,22 @@ -> RunInIO m -> (SomeException -> IO ()) -> m ThreadId -doFork action (RunInIO mrun) exHandler = +doFork = doForkWith False + +-- | Similar to 'doFork', but has a \"bound\" boolean parameter for specifying +-- whether 'forkOS' should be used instead of 'rawForkIO'. +{-# INLINE doForkWith #-} +doForkWith :: MonadRunInIO m + => Bool + -> m () + -> RunInIO m + -> (SomeException -> IO ()) + -> m ThreadId +doForkWith bound action (RunInIO mrun) exHandler = withRunInIO $ \run -> mask $ \restore -> do - tid <- rawForkIO $ catch (restore $ void $ mrun action) - exHandler + let frk = if bound then forkOS else rawForkIO + tid <- frk $ catch (restore $ void $ mrun action) exHandler run (return tid) -- | 'fork' lifted to any monad with 'MonadBaseControl IO m' capability. diff --git a/src/Streamly/Internal/Data/Array/ArrayMacros.h b/src/Streamly/Internal/Data/Array/ArrayMacros.h deleted file mode 100644 --- a/src/Streamly/Internal/Data/Array/ArrayMacros.h +++ /dev/null @@ -1,40 +0,0 @@ -------------------------------------------------------------------------------- --- Macros to access array pointers -------------------------------------------------------------------------------- - --- The Storable instance of () has size 0. We ensure that the size is non-zero --- to avoid a zero sized element and issues due to that. --- See https://mail.haskell.org/pipermail/libraries/2022-January/thread.html --- --- XXX Check the core to see if max can be statically eliminated. llvm can --- eliminate the comparison, but not sure if GHC NCG can. -#define SIZE_OF(a) max 1 (sizeOf (Proxy :: Proxy a)) -#define STORABLE_SIZE_OF(a) max 1 (sizeOf (undefined :: a)) - --- Move the pointer to ith element of specified type. Type is specified as the --- type variable in the signature of the function where this macro is used. -#define PTR_NEXT(ptr,a) ptr `plusPtr` STORABLE_SIZE_OF(a) -#define PTR_PREV(ptr,a) ptr `plusPtr` negate (STORABLE_SIZE_OF(a)) - -#define PTR_INDEX(ptr,i,a) ptr `plusPtr` (STORABLE_SIZE_OF(a) * i) -#define PTR_RINDEX(ptr,i,a) ptr `plusPtr` negate (STORABLE_SIZE_OF(a) * (i + 1)) - --- XXX If we know that the array is guaranteed to have size multiples of the --- element size then we can use a simpler check saying "ptr < end". Since we --- always allocate in multiples of elem we can use the simpler check and assert --- the rigorous check. -#define PTR_VALID(ptr,end,a) ptr `plusPtr` STORABLE_SIZE_OF(a) <= end -#define PTR_INVALID(ptr,end,a) ptr `plusPtr` STORABLE_SIZE_OF(a) > end - -------------------------------------------------------------------------------- --- Macros to access array indices -------------------------------------------------------------------------------- - -#define INDEX_NEXT(i,a) i + SIZE_OF(a) -#define INDEX_PREV(i,a) i - SIZE_OF(a) - -#define INDEX_OF(base,i,a) base + (SIZE_OF(a) * i) -#define RINDEX_OF(base,i,a) base - (SIZE_OF(a) * (i + 1)) - -#define INDEX_VALID(i,end,a) i + SIZE_OF(a) <= end -#define INDEX_INVALID(i,end,a) i + SIZE_OF(a) > end diff --git a/src/Streamly/Internal/Data/Channel.hs b/src/Streamly/Internal/Data/Channel.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Channel.hs @@ -0,0 +1,30 @@ +-- | +-- Module : Streamly.Internal.Data.Channel +-- Copyright : (c) 2017 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- This module contains operations that are common for Stream and Fold +-- channels. + +module Streamly.Internal.Data.Channel + ( + -- * Channel Config & Stats + module Streamly.Internal.Data.Channel.Types + -- * Worker Dispatcher + -- | Operations used by the consumer of the channel. + , module Streamly.Internal.Data.Channel.Dispatcher + -- * Channel Workers + -- | Operations used by the workers (producers) of the channel. These + -- operations are thread-safe, these can be called concurrently by workers + -- working in independent Haskell threads, the shared channel data + -- structures are read or updated atomically. + , module Streamly.Internal.Data.Channel.Worker + ) +where + +import Streamly.Internal.Data.Channel.Dispatcher +import Streamly.Internal.Data.Channel.Types +import Streamly.Internal.Data.Channel.Worker diff --git a/src/Streamly/Internal/Data/Channel/Dispatcher.hs b/src/Streamly/Internal/Data/Channel/Dispatcher.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Channel/Dispatcher.hs @@ -0,0 +1,324 @@ +-- | +-- Module : Streamly.Internal.Data.Channel.Dispatcher +-- Copyright : (c) 2017 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- +module Streamly.Internal.Data.Channel.Dispatcher + ( + -- ** Latency collection + minThreadDelay + , collectLatency + + -- ** Thread accounting + , addThread + , delThread + , modifyThread + , allThreadsDone + , recordMaxWorkers + + -- ** Diagnostics + , dumpSVarStats + ) +where + +import Data.Set (Set) +import Control.Concurrent (MVar, ThreadId) +import Control.Concurrent.MVar (tryPutMVar) +import Control.Exception (assert) +import Control.Monad (when, void) +import Control.Monad.IO.Class (MonadIO(liftIO)) +import Data.IORef (IORef, modifyIORef, readIORef, writeIORef) +import Streamly.Internal.Data.Atomics + (atomicModifyIORefCAS, writeBarrier, atomicModifyIORefCAS_) +import Streamly.Internal.Data.Time.Clock (Clock(Monotonic), getTime) +import Streamly.Internal.Data.Time.Units + ( AbsTime, NanoSecond64(..), diffAbsTime64, showNanoSecond64 + , showRelTime64) + +import qualified Data.Set as S + +import Streamly.Internal.Data.Channel.Types + +------------------------------------------------------------------------------- +-- Worker latency data processing +------------------------------------------------------------------------------- + +-- | 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 + +-- | 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 + -- This depends on the rate, if the rate is low, latencies are + -- small, by the time we poll it might be too late and we may have + -- yielded too many results. + -- cnt = max 1 $ minThreadDelay `div` latency + cnt = max 1 (latency `div` svarLatencyTarget yinfo) + period = min cnt (fromIntegral magicMaxBuffer) + + writeIORef periodRef (fromIntegral period) + +{-# INLINE recordMinMaxLatency #-} +recordMinMaxLatency :: SVarStats -> NanoSecond64 -> IO () +recordMinMaxLatency ss new = do + 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 :: SVarStats -> (Count, NanoSecond64) -> IO () +recordAvgLatency ss (count, time) = do + modifyIORef (avgWorkerLatency ss) $ + \(cnt, t) -> (cnt + count, t + time) + +-- | Add the 'workerPendingLatency' to 'workerCollectedLatency' and reset it to +-- zeroes. Return the added counts. +{-# INLINE collectWorkerPendingLatency #-} +collectWorkerPendingLatency + :: IORef (Count, Count, NanoSecond64) -- ^ 'workerPendingLatency' + -> IORef (Count, Count, NanoSecond64) -- ^ 'workerCollectedLatency' + -> IO (Count, Maybe (Count, NanoSecond64)) + -- ^ (total yield count, Maybe (total latency count, total latency time)). + -- Latency count and time are reported only when both are non-zero to avoid + -- arithemetic exceptions in calculations. +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) + +-- CAUTION! keep it in sync with getWorkerLatency + +-- | Always moves 'workerPendingLatency' to 'workerCollectedLatency': +-- +-- * 'workerCollectedLatency' always incremented by 'workerPendingLatency' +-- * 'workerPendingLatency' always reset to 0 +-- +-- Moves 'workerCollectedLatency' to 'svarAllTimeLatency' periodically, when +-- the collected batch size hits a limit, or time limit is over, or latency +-- changes beyond a limit. Updates done when the batch is collected: +-- +-- * 'svarAllTimeLatency' yield count updated +-- * 'workerMeasuredLatency' set to (new+prev)/2 +-- * 'workerPollingInterval' set using max of new/prev worker latency +-- * 'workerCollectedLatency' reset to 0 +-- +-- See also 'getWorkerLatency'. +-- +collectLatency :: + Bool -- ^ stat inspection mode + -> SVarStats -- ^ Channel stats + -> YieldRateInfo -- ^ Channel rate control info + -> Bool -- ^ Force batch collection + -> IO (Count, AbsTime, NanoSecond64) + -- ^ (channel yield count since beginning, beginning timestamp, 'workerMeasuredLatency') +collectLatency inspecting ss 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 inspecting $ recordMinMaxLatency ss 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 inspecting $ recordAvgLatency ss (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 :: Bool -> Maybe YieldRateInfo -> SVarStats -> IO String +dumpSVarStats inspecting rateInfo ss = do + case rateInfo of + Nothing -> return () + Just yinfo -> do + _ <- liftIO $ collectLatency inspecting ss 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 + stopTime <- readIORef (svarStopTime ss) + let stopReason = + case stopTime of + Nothing -> "stream abandoned" + Just _ -> "stream finished" + (svarCnt, svarGainLossCnt, svarLat, interval) <- case rateInfo of + Nothing -> return (0, 0, 0, 0) + Just yinfo -> do + (cnt, startTime) <- readIORef $ svarAllTimeLatency yinfo + interval <- + case stopTime of + Nothing -> do + now <- getTime Monotonic + return (diffAbsTime64 now startTime) + Just t -> do + return (diffAbsTime64 t startTime) + if cnt > 0 + then do + gl <- readIORef (svarGainedLostYields yinfo) + return (cnt, gl, interval `div` fromIntegral cnt, interval) + else return (0, 0, 0, interval) + + return $ concat + [ "stop reason = " <> stopReason + , if interval > 0 + then "\nlife time = " <> showRelTime64 interval + else "" + , "\ntotal dispatches = " <> show dispatches + , "\nmax workers = " <> show maxWrk + , "\nmax outQSize = " <> show maxOq + , 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 "\nchannel latency = " <> showRelTime64 svarLat + else "" + , if svarCnt > 0 + then "\nchannel yield count = " <> show svarCnt + else "" + , if svarGainLossCnt > 0 + then "\nchannel gain/loss yield count = " <> show svarGainLossCnt + else "" + ] + +------------------------------------------------------------------------------- +-- Thread accounting +------------------------------------------------------------------------------- + +-- 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 => IORef (Set ThreadId) -> ThreadId -> m () +addThread workerSet tid = + liftIO $ atomicModifyIORefCAS_ workerSet (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 => IORef (Set ThreadId) -> ThreadId -> m () +delThread workerSet tid = + liftIO $ atomicModifyIORefCAS_ workerSet (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 => IORef (Set ThreadId) -> MVar () -> ThreadId -> m () +modifyThread workerSet bell tid = do + changed <- liftIO $ atomicModifyIORefCAS workerSet $ \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 bell () + +-- | 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 => IORef (Set ThreadId) -> m Bool +allThreadsDone ref = liftIO $ S.null <$> readIORef ref + +------------------------------------------------------------------------------- +-- Dispatching workers +------------------------------------------------------------------------------- + +{-# NOINLINE recordMaxWorkers #-} +recordMaxWorkers :: MonadIO m => IORef Int -> SVarStats -> m () +recordMaxWorkers countRef ss = liftIO $ do + active <- readIORef countRef + maxWrk <- readIORef (maxWorkers ss) + when (active > maxWrk) $ writeIORef (maxWorkers ss) active + modifyIORef (totalDispatches ss) (+1) diff --git a/src/Streamly/Internal/Data/Channel/Types.hs b/src/Streamly/Internal/Data/Channel/Types.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Channel/Types.hs @@ -0,0 +1,458 @@ +-- | +-- Module : Streamly.Internal.Data.Channel.Types +-- Copyright : (c) 2017 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- A Channel is a place where streams join and new streams start. This module +-- defines low level data structures and functions to build channels. For +-- concrete Channels see the Channel modules of specific stream types. +-- +-- A Channel is a conduit to the output from multiple streams running +-- concurrently and asynchronously. A channel can be thought of as an +-- asynchronous IO handle. We can write any number of streams to a channel in a +-- non-blocking manner and then read them back at any time at any pace. The +-- channel would run the streams asynchronously and accumulate results. A +-- channel may not really execute the stream completely and accumulate all the +-- results. However, it ensures that the reader can read the results at +-- whatever pace it wants to read. The channel monitors and adapts to the +-- consumer's pace. +-- +-- A channel 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. An 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 channel by 'fromChannel' on demand if the output +-- produced is not keeping pace with the consumer. On bounded channels, 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. +-- +module Streamly.Internal.Data.Channel.Types + ( + -- ** Types + Count (..) + , Limit (..) + , ThreadAbort (..) + , ChildEvent (..) + + -- ** Stats + , SVarStats (..) + , newSVarStats + + -- ** Rate Control + , WorkerInfo (..) + , LatencyRange (..) + , YieldRateInfo (..) + + -- ** Output queue + , readOutputQRaw + , readOutputQBasic + , ringDoorBell + + -- ** Yield Limit + , decrementYieldLimit + , incrementYieldLimit + + -- ** Configuration + , Rate (..) + , StopWhen (..) + , magicMaxBuffer + + -- ** Diagnostics + , dumpCreator + , dumpOutputQ + , dumpDoorBell + , dumpNeedDoorBell + , dumpRunningThreads + , dumpWorkerCount + + , withDiagMVar + , printSVar + ) +where + +import Control.Concurrent (ThreadId, MVar, tryReadMVar) +import Control.Concurrent.MVar (tryPutMVar) +import Control.Exception + ( SomeException(..), Exception, catches, throwIO, Handler(..) + , BlockedIndefinitelyOnMVar(..), BlockedIndefinitelyOnSTM(..)) +import Control.Monad (void, when) +import Data.Int (Int64) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Streamly.Internal.Data.Atomics + (atomicModifyIORefCAS, atomicModifyIORefCAS_, storeLoadBarrier) +import Streamly.Internal.Data.Time.Units (AbsTime, NanoSecond64(..)) +import System.IO (hPutStrLn, stderr) + +------------------------------------------------------------------------------ +-- Common types +------------------------------------------------------------------------------ + +newtype Count = Count Int64 + deriving ( Eq + , Read + , Show + , Enum + , Bounded + , Num + , Real + , Integral + , Ord + ) + +-- XXX We can use maxBound for unlimited? + +-- 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 + +------------------------------------------------------------------------------ +-- Parent child thread communication type +------------------------------------------------------------------------------ + +-- | Channel driver throws this exception to all active workers to clean up +-- the channel. +data ThreadAbort = ThreadAbort deriving Show + +instance Exception ThreadAbort + +-- XXX Use a ChildSingle event to speed up mapM? +-- | Events that a child thread may send to a parent thread. +data ChildEvent a = + ChildYield a + | ChildStopChannel + | ChildStop ThreadId (Maybe SomeException) + +-- | 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 + { + -- | Yields allowed for this worker. 0 means unlimited. + workerYieldMax :: Count + -- | total number of yields by the worker till now + , workerYieldCount :: IORef Count + -- | (yield count at start of collection interval, collection start timestamp) + , workerLatencyStart :: IORef (Count, AbsTime) + } + +data LatencyRange = LatencyRange + { minLatency :: NanoSecond64 + , maxLatency :: NanoSecond64 + } deriving Show + +-- | Rate control. +data YieldRateInfo = YieldRateInfo + { svarLatencyTarget :: NanoSecond64 + , svarLatencyRange :: LatencyRange + + -- | Number of yields beyond which we will not try to recover the rate. + , svarRateBuffer :: Int + + -- | Yields that we have permanently gained or lost since the start of the + -- channel i.e. we do not want to adjust the rate to make up for this + -- deficit or gain. + -- + -- [LOCKING] Unlocked access. Modified by the consumer thread and snapshot + -- read by the worker threads + , svarGainedLostYields :: IORef Count + + -- XXX interval latency is enough, we can move this under diagnostics build + + -- | (channel yields from start till now, channel start timestamp) as + -- recorded by the consumer side of the channel. + -- + -- [LOCKING] Unlocked access. Modified by the consumer thread, snapshot + -- read by the worker threads. + , svarAllTimeLatency :: IORef (Count, AbsTime) + + -- | TODO. Not yet implemented. Worker latency specified by the user to be + -- used as a guide before the first actual measurement arrives. + , workerBootstrapLatency :: Maybe NanoSecond64 + + -- 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. + + -- | After how many yields the worker should update the latency + -- information. If the 'workerMeasuredLatency' is high, this count is kept + -- lower and vice-versa. + -- + -- [LOCKING] Unlocked access. Modified by the consumer thread and snapshot + -- read by the worker threads + , workerPollingInterval :: IORef Count + + -- | (total yields, measured yields, time taken by measured yields). + -- This is first level collection bucket which is continuously updated by + -- workers and periodically emptied and collected into + -- 'workerCollectedLatency' by the consumer thread. + -- + -- "Measured yields" are 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. Atomically 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. + , workerPendingLatency :: IORef (Count, Count, NanoSecond64) + + -- | 'workerPendingLatency' is periodically reset and aggregated into this + -- by the consumer thread. This itself is reset periodically and + -- 'svarAllTimeLatency', 'workerMeasuredLatency' are updated using it. + -- + -- [LOCKING] Unlocked access. Modified by the consumer thread and snapshot + -- read by the worker threads + , workerCollectedLatency :: IORef (Count, Count, NanoSecond64) + + -- | Weighted average of worker latencies in previous measurement periods. + -- + -- [LOCKING] Unlocked access. Modified by the consumer thread and snapshot + -- 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) +} + +------------------------------------------------------------------------------- +-- Config +------------------------------------------------------------------------------- + +-- | 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 yield count gap becomes more than 'rateBuffer' (specified as +-- a yield count) 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. +-- +data Rate = Rate + { rateLow :: Double -- ^ The lower rate limit (yields per sec) + , rateGoal :: Double -- ^ The target rate we want to achieve + , rateHigh :: Double -- ^ The upper rate limit + , rateBuffer :: Int -- ^ Maximum yield count slack from the goal + } + +-- | Specify when the 'Channel' should stop. +data StopWhen = + FirstStops -- ^ Stop when the first stream ends. + | AllStop -- ^ Stop when all the streams end. + | AnyStops -- ^ Stop when any one stream ends. + +-- | 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 + +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 + } + +------------------------------------------------------------------------------- +-- Channel yield count +------------------------------------------------------------------------------- + +-- 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 :: Maybe (IORef Count) -> IO Bool +decrementYieldLimit remaining = + case remaining of + Nothing -> return True + Just ref -> do + r <- atomicModifyIORefCAS ref $ \x -> (x - 1, x) + return $ r >= 1 + +{-# INLINE incrementYieldLimit #-} +incrementYieldLimit :: Maybe (IORef Count) -> IO () +incrementYieldLimit remaining = + case remaining of + Nothing -> return () + Just ref -> atomicModifyIORefCAS_ ref (+ 1) + +------------------------------------------------------------------------------- +-- Output queue +------------------------------------------------------------------------------- + +-- | Read the output queue of the channel. After reading set it to empty list +-- and 0 count. +{-# INLINE readOutputQBasic #-} +readOutputQBasic :: + IORef ([a], Int) -- ^ The channel output queue + -> IO ([a], Int) -- ^ (events, count) +readOutputQBasic q = atomicModifyIORefCAS q $ \x -> (([],0), x) + +-- | Same as 'readOutputQBasic' but additionally update the max output queue +-- size channel stat if the new size is more than current max. +{-# INLINE readOutputQRaw #-} +readOutputQRaw :: + IORef ([ChildEvent a], Int) -- ^ Channel output queue + -> Maybe SVarStats -- ^ Channel stats + -> IO ([ChildEvent a], Int) -- ^ (events, count) +readOutputQRaw q stats = do + (list, len) <- readOutputQBasic q + case stats of + Just ss -> do + let ref = maxOutQSize ss + oqLen <- readIORef ref + when (len > oqLen) $ writeIORef ref len + Nothing -> return () + return (list, len) + +-- | RingArray door bell. The IORef is read after adding a store-load barrier. If +-- the IORef was set to 'True' it is atomically reset to 'False'. +{-# INLINE ringDoorBell #-} +ringDoorBell :: + IORef Bool -- ^ If 'True' only then ring the door bell + -> MVar () -- ^ Door bell, put () to ring + -> IO () +ringDoorBell needBell bell = do + storeLoadBarrier + w <- readIORef needBell + 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_ needBell (const False) + void $ tryPutMVar bell () + +------------------------------------------------------------------------------- +-- Diagnostics +------------------------------------------------------------------------------- + +dumpCreator :: Show a => a -> String +dumpCreator tid = "Creator tid = " <> show tid + +dumpOutputQ :: (Foldable t, Show a1) => IORef (t a2, a1) -> IO String +dumpOutputQ q = do + (oqList, oqLen) <- readIORef q + return $ unlines + [ "outputQueue length computed = " <> show (length oqList) + , "outputQueue length maintained = " <> show oqLen + ] + +dumpDoorBell :: Show a => MVar a -> IO String +dumpDoorBell mvar = do + db <- tryReadMVar mvar + return $ "outputDoorBell = " <> show db + +dumpNeedDoorBell :: Show a => IORef a -> IO String +dumpNeedDoorBell ref = do + waiting <- readIORef ref + return $ "needDoorBell = " <> show waiting + +dumpRunningThreads :: Show a => IORef a -> IO String +dumpRunningThreads ref = do + rthread <- readIORef ref + return $ "running threads = " <> show rthread + +dumpWorkerCount :: Show a => IORef a -> IO String +dumpWorkerCount ref = do + workers <- readIORef ref + return $ "running thread count = " <> show workers + +{-# NOINLINE mvarExcHandler #-} +mvarExcHandler :: IO String -> String -> BlockedIndefinitelyOnMVar -> IO () +mvarExcHandler dump label e@BlockedIndefinitelyOnMVar = do + svInfo <- dump + hPutStrLn stderr $ label <> " " <> "BlockedIndefinitelyOnMVar\n" <> svInfo + throwIO e + +{-# NOINLINE stmExcHandler #-} +stmExcHandler :: IO String -> String -> BlockedIndefinitelyOnSTM -> IO () +stmExcHandler dump label e@BlockedIndefinitelyOnSTM = do + svInfo <- dump + hPutStrLn stderr $ label <> " " <> "BlockedIndefinitelyOnSTM\n" <> svInfo + throwIO e + +-- | MVar diagnostics has some overhead - around 5% on AsyncT 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. +withDiagMVar :: Bool -> IO String -> String -> IO () -> IO () +withDiagMVar inspecting dump label action = + if inspecting + then + action `catches` [ Handler (mvarExcHandler dump label) + , Handler (stmExcHandler dump label) + ] + else action + +printSVar :: IO String -> String -> IO () +printSVar dump how = do + svInfo <- dump + hPutStrLn stderr $ "\n" <> how <> "\n" <> svInfo diff --git a/src/Streamly/Internal/Data/Channel/Worker.hs b/src/Streamly/Internal/Data/Channel/Worker.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Channel/Worker.hs @@ -0,0 +1,442 @@ +-- | +-- Module : Streamly.Internal.Data.Channel.Worker +-- Copyright : (c) 2017 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- Collecting results from child workers in a streamed fashion + +module Streamly.Internal.Data.Channel.Worker + ( + -- ** Worker Rate Control + Work (..) + , estimateWorkers + , isBeyondMaxRate + , incrWorkerYieldCount + + -- ** Workers Sending Events + , sendEvent + , sendYield + , sendStop + , sendException + ) +where + +import Control.Concurrent (myThreadId) +import Control.Concurrent.MVar (MVar, tryPutMVar) +import Control.Exception (SomeException(..), assert) +import Control.Monad (when, void) +import Data.IORef (IORef, readIORef, writeIORef) +import Streamly.Internal.Data.Atomics + (atomicModifyIORefCAS, atomicModifyIORefCAS_, writeBarrier) +import Streamly.Internal.Data.Time.Clock (Clock(Monotonic), getTime) +import Streamly.Internal.Data.Time.Units + (AbsTime, NanoSecond64(..), diffAbsTime64, fromRelTime64) + +import Streamly.Internal.Data.Channel.Types + +------------------------------------------------------------------------------- +-- Yield control +------------------------------------------------------------------------------- + +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 + +------------------------------------------------------------------------------- +-- Sending results from worker +------------------------------------------------------------------------------- + +-- | Low level API to add an event on the channel's output queue. Atomically +-- adds the event to the queue and rings the doorbell if needed to wakeup the +-- consumer thread. +{-# INLINE sendEvent #-} +sendEvent :: + IORef ([a], Int) -- ^ Queue where the event is added + -> MVar () -- ^ Door bell to ring + -> a -- ^ The event to be added + -> IO Int -- ^ Length of the queue before adding this event +sendEvent q bell msg = do + -- XXX can the access to outputQueue be made faster somehow? + oldlen <- atomicModifyIORefCAS q $ \(es, n) -> + ((msg : es, n + 1), n) + when (oldlen <= 0) $ do + -- The wake up must happen only after the store has finished otherwise + -- 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 bell () + return oldlen + +------------------------------------------------------------------------------- +-- Collect and update worker latency +------------------------------------------------------------------------------- + +workerCollectLatency :: WorkerInfo -> IO (Maybe (Count, NanoSecond64)) +workerCollectLatency winfo = do + -- XXX make this unboxed IORef + (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 () + +------------------------------------------------------------------------------- +-- Worker rate control +------------------------------------------------------------------------------- + +-- | Describes how to pace the work based on current measurement estimates. If +-- the rate is higher than expected we may have to sleep for some time +-- ('BlockWait'), or send just one worker with limited yield count +-- ('PartialWorker') or send more than one workers with max yield count of each +-- limited to the total maximum target count. +data Work + = BlockWait NanoSecond64 -- ^ Sleep required before next dispatch + | PartialWorker Count -- ^ One worker is enough, total yields needed + | ManyWorkers Int Count -- ^ Worker count, total yields needed overall + deriving Show + +-- | 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 + +-- CAUTION! keep it in sync with collectLatency + +-- | Same as 'collectLatency' except that it does not update anything, this is +-- a readonly version of 'collectLatency'. +-- +getWorkerLatency :: + YieldRateInfo + -> IO (Count, AbsTime, NanoSecond64) + -- ^ (total yield count, base timestamp, 'workerMeasuredlatency') +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) + +-- XXX we can use phantom types to distinguish the duration/latency/expectedLat +-- XXX This should probably be inlined. +-- XXX Move this to the common Types module, since this is used by both +-- dispatcher and workers. + +-- | Estimate how many workers and yield count ('Work') is required to maintian +-- the target yield rate of the channel. +-- +-- This is used by the worker dispatcher to estimate how many workers to +-- dispatch. It is also used periodically by the workers to decide whether to +-- stop or continue working. +estimateWorkers + :: Limit -- ^ Channel's max worker limit + -> Count -- ^ Channel's yield count since start + -> Count -- ^ 'svarGainedLostYields' + -> NanoSecond64 -- ^ The up time of the channel + -> NanoSecond64 -- ^ Current 'workerMeasuredLatency' + -> NanoSecond64 -- ^ 'svarLatencyTarget' + -> LatencyRange -- ^ 'svarLatencyRange' + -> 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 achieve the required rate? + -- + -- When the workers are IO bound we can increase the throughput by + -- increasing the number of workers as long as the IO device has enough + -- 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 achieve. Design tests for CPU bound and IO bound cases. + + -- Calculate how many yields are we ahead or behind to match the exact + -- required rate. Based on that we increase or decrease the effective + -- 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) + +-- | Using the channel worker latency and channel yield count stats from the +-- current measurement interval, estimate how many workers are needed to +-- maintain the target rate and compare that with current number of workers. +-- Returns true if we have have more than required workers. +isBeyondMaxRate :: + Limit -- ^ Channel's max worker limit + -> IORef Int -- ^ Current worker count + -> YieldRateInfo -- ^ Channel's rate control info + -> IO Bool -- ^ True if we are exceeding the specified rate +isBeyondMaxRate workerLimit workerCount rateInfo = do + (count, tstamp, wLatency) <- getWorkerLatency rateInfo + now <- getTime Monotonic + let duration = fromRelTime64 $ diffAbsTime64 now tstamp + let targetLat = svarLatencyTarget rateInfo + gainLoss <- readIORef (svarGainedLostYields rateInfo) + let work = estimateWorkers workerLimit count gainLoss duration + wLatency targetLat (svarLatencyRange rateInfo) + cnt <- readIORef workerCount + 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 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. + +-- | Update the worker latency and check the channel yield rate. Updates and +-- checks only at specified multiples of yield count to keep the overhead low. +{-# NOINLINE updateLatencyAndCheckRate #-} +updateLatencyAndCheckRate :: + Limit + -> IORef Int + -> YieldRateInfo + -> WorkerInfo + -> Count + -> IO Bool +updateLatencyAndCheckRate workerLimit workerCount rateInfo workerInfo ycnt = do + -- XXX make this an unboxed IORef + i <- readIORef (workerPollingInterval rateInfo) + -- XXX use generation count to check if the interval has been updated + if i /= 0 && (ycnt `mod` i) == 0 + then do + workerUpdateLatency rateInfo workerInfo + -- XXX not required for parallel streams + isBeyondMaxRate workerLimit workerCount rateInfo + else return False + +-- | Update the local yield count of the worker and check if: +-- +-- * the channel yield rate is beyond max limit +-- * worker's yield count is beyond max limit +-- +{-# NOINLINE incrWorkerYieldCount #-} +incrWorkerYieldCount :: + Limit -- ^ Channel's max worker limit + -> IORef Int -- ^ Current worker count + -> YieldRateInfo -- ^ Channel's rate control info + -> WorkerInfo -- ^ Worker's yield count info + -> IO Bool -- ^ True means limits are ok and worker can continue +incrWorkerYieldCount workerLimit workerCount rateInfo workerInfo = do + cnt <- updateYieldCount workerInfo + beyondMaxRate <- + updateLatencyAndCheckRate workerLimit workerCount rateInfo workerInfo cnt + return $ not (isBeyondMaxYield cnt workerInfo || beyondMaxRate) + +------------------------------------------------------------------------------- +-- Send a yield event +------------------------------------------------------------------------------- + +-- 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. + +-- | Add a 'ChildYield' event to the channel's output queue. +-- +-- This is a wrapper over 'sendEvent', it does a few more things: +-- +-- * performs a buffer limit check, returns False if exceeded +-- +-- When rate control is enabled and 'WorkerInfo' is supplied:: +-- +-- * increments the worker yield count +-- * periodically pushes the worker latency stats to the channel +-- * performs a rate limit check, returns False if exceeded +{-# INLINE sendYield #-} +sendYield :: + Limit -- ^ Channel's max buffer limit + -> Limit -- ^ Channel's max worker limit + -> IORef Int -- ^ Current worker count + -> Maybe YieldRateInfo -- ^ Channel's rate control info + -> IORef ([ChildEvent a], Int) -- ^ Queue where the output is added + -> MVar () -- ^ Door bell to ring + -> Maybe WorkerInfo -- ^ Worker's yield count info + -> a -- ^ The output to be sent + -> IO Bool -- ^ True means worker is allowed to continue working +sendYield bufferLimit workerLimit workerCount rateInfo q bell workerInfo msg = + do + oldlen <- sendEvent q bell (ChildYield msg) + bufferSpaceOk <- + case bufferLimit of + Unlimited -> return True + Limited lim -> do + active <- readIORef workerCount + return $ (oldlen + 1) < (fromIntegral lim - active) + rateLimitOk <- + case workerInfo of + Just winfo -> + case rateInfo of + Nothing -> return True + Just yinfo -> + incrWorkerYieldCount workerLimit workerCount yinfo winfo + Nothing -> return True + return $ bufferSpaceOk && rateLimitOk + +------------------------------------------------------------------------------- +-- Send a Stop event +------------------------------------------------------------------------------- + +{-# INLINE workerStopUpdate #-} +workerStopUpdate :: WorkerInfo -> YieldRateInfo -> IO () +workerStopUpdate winfo info = do + i <- readIORef (workerPollingInterval info) + when (i /= 0) $ workerUpdateLatency info winfo + +-- | Add a 'ChildStop' event to the channel's output queue. When rate control +-- is enabled, it pushes the worker latency stats to the channel. +{-# INLINABLE sendStop #-} +sendStop :: + IORef Int -- ^ Channel's current worker count + -> Maybe YieldRateInfo -- ^ Channel's rate control info + -> IORef ([ChildEvent a], Int) -- ^ Queue where the stop event is added + -> MVar () -- ^ Door bell to ring + -> Maybe WorkerInfo -- ^ Worker's yield count info + -> IO () +sendStop workerCount rateInfo q bell workerInfo = do + atomicModifyIORefCAS_ workerCount $ \n -> n - 1 + case (workerInfo, rateInfo) of + (Just winfo, Just rinfo) -> + workerStopUpdate winfo rinfo + _ -> + return () + tid <- myThreadId + void $ sendEvent q bell (ChildStop tid Nothing) + +-- XXX Shouldn't we perform a workerStopUpdate even in this case? + +-- | Add a 'ChildStop' event with exception to the channel's output queue. +{-# NOINLINE sendException #-} +sendException :: + IORef Int -- ^ Channel's current worker count + -> IORef ([ChildEvent a], Int) -- ^ Queue where the event is added + -> MVar () -- ^ Door bell to ring + -> SomeException -- ^ The exception to send + -> IO () +sendException workerCount q bell e = do + atomicModifyIORefCAS_ workerCount $ \n -> n - 1 + tid <- myThreadId + void $ sendEvent q bell (ChildStop tid (Just e)) diff --git a/src/Streamly/Internal/Data/Fold/Async.hs b/src/Streamly/Internal/Data/Fold/Async.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Fold/Async.hs +++ /dev/null @@ -1,130 +0,0 @@ --- | --- Module : Streamly.Internal.Data.Fold.Async --- Copyright : (c) 2019 Composewell Technologies --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- -module Streamly.Internal.Data.Fold.Async - ( - -- * Trimming - takeInterval - - -- * Splitting - , intervalsOf - ) -where - -import Control.Concurrent (threadDelay, forkIO, killThread) -import Control.Concurrent.MVar (MVar, newMVar, swapMVar, readMVar) -import Control.Exception (SomeException(..), catch, mask) -import Control.Monad (void) -import Control.Monad.IO.Class (MonadIO(..)) -import Streamly.Data.Fold (many) -import Streamly.Internal.Data.Fold.Type (Fold(..), Step (..)) -import Streamly.Internal.Control.Concurrent (MonadAsync, withRunInIO) -import Streamly.Internal.Data.Tuple.Strict (Tuple3'(..)) - --- $setup --- >>> :m --- >>> :set -fno-warn-deprecations --- >>> :set -XFlexibleContexts --- >>> import qualified Streamly.Prelude as Stream --- >>> import qualified Streamly.Data.Fold as Fold --- >>> import qualified Streamly.Internal.Data.Fold.Async as Fold - --- XXX We can use asyncClock here. A parser can be used to return an input that --- arrives after the timeout. --- XXX If n is 0 return immediately in initial. --- XXX we should probably discard the input received after the timeout like --- takeEndBy_. - --- XXX The foldMany doctest is important for consistency with the "many" fold, --- and intervalsOf. We should put it in tests. - --- | @takeInterval n fold@ uses @fold@ to fold the input items arriving within --- a window of first @n@ seconds. --- --- >>> input = Stream.delay 0.2 $ Stream.fromList [1..10] --- >>> Stream.fold (Fold.takeInterval 1.0 Fold.toList) input --- [1,2,3,4,5,6] --- --- >>> f = Fold.takeInterval 0.5 Fold.toList --- >>> Stream.fold Fold.toList $ Stream.foldMany f input --- [[1,2,3,4],[5,6,7],[8,9,10]] --- --- Stops when @fold@ stops or when the timeout occurs. Note that the fold needs --- an input after the timeout to stop. For example, if no input is pushed to --- the fold until one hour after the timeout had occurred, then the fold will --- be done only after consuming that input. --- --- /Pre-release/ --- -{-# INLINE takeInterval #-} -takeInterval :: MonadAsync m => Double -> Fold m a b -> Fold m a b -takeInterval n (Fold step initial done) = Fold step' initial' done' - - where - - initial' = do - res <- initial - case res of - Partial s -> do - mv <- liftIO $ newMVar False - t <- - withRunInIO $ \run -> - mask $ \restore -> do - tid <- - forkIO - $ catch - (restore $ void $ run (timerThread mv)) - (handleChildException mv) - run (return tid) - return $ Partial $ Tuple3' s mv t - Done b -> return $ Done b - - step' (Tuple3' s mv t) a = do - val <- liftIO $ readMVar mv - if val - then do - res <- step s a - case res of - Partial sres -> Done <$> done sres - Done bres -> return $ Done bres - else do - res <- step s a - case res of - Partial fs -> return $ Partial $ Tuple3' fs mv t - Done b -> liftIO (killThread t) >> return (Done b) - - done' (Tuple3' s _ _) = done s - - timerThread mv = do - liftIO $ threadDelay (round $ n * 1000000) - -- Use IORef + CAS? instead of MVar since its a Bool? - liftIO $ void $ swapMVar mv True - - handleChildException :: MVar Bool -> SomeException -> IO () - handleChildException mv _ = void $ swapMVar mv True - --- 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. - --- XXX This needs to be fixed like intervalsOf in Data.Stream.Time. - --- | Group the input stream into windows of n second each using the first fold --- and then fold the resulting groups using the second fold. --- --- >>> intervals = Fold.intervalsOf 0.5 Fold.toList Fold.toList --- >>> Stream.fold intervals $ Stream.delay 0.2 $ Stream.fromList [1..10] --- [[1,2,3,4],[5,6,7],[8,9,10]] --- --- > intervalsOf n split = many (takeInterval n split) --- --- /Pre-release/ --- -{-# INLINE intervalsOf #-} -intervalsOf :: MonadAsync m => Double -> Fold m a b -> Fold m b c -> Fold m a c -intervalsOf n split = many (takeInterval n split) diff --git a/src/Streamly/Internal/Data/Fold/Channel.hs b/src/Streamly/Internal/Data/Fold/Channel.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Fold/Channel.hs @@ -0,0 +1,15 @@ +-- | +-- Module : Streamly.Internal.Data.Fold.Channel +-- Copyright : (c) 2022 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +module Streamly.Internal.Data.Fold.Channel + ( + module Streamly.Internal.Data.Fold.Channel.Type + ) +where + +import Streamly.Internal.Data.Fold.Channel.Type diff --git a/src/Streamly/Internal/Data/Fold/Channel/Type.hs b/src/Streamly/Internal/Data/Fold/Channel/Type.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Fold/Channel/Type.hs @@ -0,0 +1,652 @@ +-- | +-- Module : Streamly.Internal.Data.Fold.Channel.Type +-- Copyright : (c) 2017, 2022 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +module Streamly.Internal.Data.Fold.Channel.Type + ( + -- ** Type + Channel (..) + , OutEvent (..) + + -- ** Configuration + , Config + , defaultConfig + , maxBuffer + , boundThreads + , inspect + + -- ** Operations + , newChannelWith + , newChannelWithScan + , newChannel + , newScanChannel + , sendToWorker + , sendToWorker_ + , checkFoldStatus -- XXX collectFoldOutput + , dumpChannel + , cleanup + , finalize + ) +where + +#include "inline.hs" + +import Control.Concurrent (ThreadId, myThreadId, tryPutMVar) +import Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar) +import Control.Exception (SomeException(..)) +import Control.Monad (void, when) +import Control.Monad.Catch (throwM) +import Control.Monad.IO.Class (MonadIO(..)) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.List (intersperse) +import Streamly.Internal.Control.Concurrent + (MonadAsync, MonadRunInIO, askRunInIO) +import Streamly.Internal.Control.ForkLifted (doForkWith) +import Streamly.Internal.Data.Atomics (writeBarrier) +import Streamly.Internal.Data.Fold (Fold(..)) +import Streamly.Internal.Data.Scanl (Scanl(..)) +import Streamly.Internal.Data.Channel.Dispatcher (dumpSVarStats) +import Streamly.Internal.Data.Channel.Worker (sendEvent) +import Streamly.Internal.Data.Time.Clock (Clock(Monotonic), getTime) + +import qualified Streamly.Internal.Data.Fold as Fold +import qualified Streamly.Internal.Data.Stream as D + +import Streamly.Internal.Data.Channel.Types + +-- XXX We can make the fold evaluation concurrent by using a monoid for the +-- accumulator. It will then work in the same way as the stream evaluation, in +-- stream evaluation we dequeue the head and queue the tail, in folds we will +-- queue the accumulator and it will be picked by the next worker to accumulate +-- the next value. + +data OutEvent b = + FoldException ThreadId SomeException + | FoldPartial b + | FoldDone ThreadId b + | FoldEOF ThreadId + +-- | The fold driver thread queues the input of the fold in the 'inputQueue' +-- The driver rings the doorbell when the queue transitions from empty to +-- non-empty state. +-- +-- The fold consumer thread dequeues the input items from the 'inputQueue' and +-- supplies them to the fold. When the fold is done the output of the fold is +-- placed in 'inputQueue' and 'outputDoorBell' is rung. +-- +-- The fold driver thread keeps watching the 'outputQueue', if the fold has +-- terminated, it stops queueing the input to the 'inputQueue' +-- +-- If the fold driver runs out of input it stops and waits for the fold to +-- drain the buffered input. +-- +-- Driver thread ------>------Input Queue and Doorbell ----->-----Fold thread +-- +-- Driver thread ------<------Output Queue and Doorbell-----<-----Fold thread +-- +data Channel m a b = Channel + { + -- FORWARD FLOW: Flow of data from the driver to the consuming fold + + -- XXX Use a different type than ChildEvent. We can do with a simpler type + -- in folds. + + -- | Input queue (messages, length). + -- + -- [LOCKING] Frequent, locked access. Input is queued frequently by the + -- driver and infrequently dequeued in chunks by the fold. + -- + inputQueue :: IORef ([ChildEvent a], Int) + + -- | The maximum size of the inputQueue allowed. + , maxInputBuffer :: Limit + + -- | Doorbell is rung by the driver when 'inputQueue' transitions from + -- empty to non-empty. + -- + -- [LOCKING] Infrequent, MVar. + , inputItemDoorBell :: MVar () + , closedForInput :: IORef Bool + + -- | Doorbell to tell the driver that there is now space available in the + -- 'inputQueue' and more items can be queued. + , inputSpaceDoorBell :: MVar () + + , readInputQ :: m [ChildEvent a] + + -- | Final output and exceptions, if any, queued by the fold and read by + -- the fold driver. + -- + -- [LOCKING] atomicModifyIORef. Output is queued infrequently by the fold + -- and read frequently by the driver. + , outputQueue :: IORef ([OutEvent b], Int) + + -- | Doorbell for the 'outputQueue', rung by the fold when the queue + -- transitions from empty to non-empty. + -- + -- [LOCKING] Infrequent, MVar. + , outputDoorBell :: MVar () + + -- cleanup: to track garbage collection of SVar -- + , svarRef :: Maybe (IORef ()) + + -- Stats -- + , svarStats :: SVarStats + + -- Diagnostics -- + , svarInspectMode :: Bool + , svarCreator :: ThreadId + } + +------------------------------------------------------------------------------- +-- Config +------------------------------------------------------------------------------- + +-- | An abstract type for specifying the configuration parameters of a +-- 'Channel'. Use @Config -> Config@ modifier functions to modify the default +-- configuration. See the individual modifier documentation for default values. +-- +data Config = Config + { + _bufferHigh :: Limit + , _inspect :: Bool + , _bound :: Bool + } + +------------------------------------------------------------------------------- +-- State defaults and reset +------------------------------------------------------------------------------- + +defaultMaxBuffer :: Limit +defaultMaxBuffer = Limited magicMaxBuffer + +-- | The fields prefixed by an _ are not to be accessed or updated directly but +-- via smart accessor APIs. Use get/set routines instead of directly accessing +-- the Config fields +defaultConfig :: Config +defaultConfig = Config + { + _bufferHigh = defaultMaxBuffer + , _inspect = False + , _bound = False + } + +------------------------------------------------------------------------------- +-- Smart get/set routines for State +------------------------------------------------------------------------------- + +-- | Specify the maximum size of the buffer for storing the results from +-- concurrent computations. If the buffer becomes full we stop spawning more +-- concurrent tasks until there is space in the buffer. +-- A value of 0 resets the buffer size to default, a negative value means +-- there is no limit. The default value is 1500. +-- +-- CAUTION! using an unbounded 'maxBuffer' value (i.e. a negative value) +-- coupled with an unbounded 'maxThreads' value is a recipe for disaster in +-- presence of infinite streams, or very large streams. Especially, it must +-- not be used when 'pure' is used in 'ZipAsyncM' streams as 'pure' in +-- applicative zip streams generates an infinite stream causing unbounded +-- concurrent generation with no limit on the buffer or threads. +-- +maxBuffer :: Int -> Config -> Config +maxBuffer n st = + st { _bufferHigh = + if n < 0 + then Unlimited + else if n == 0 + then defaultMaxBuffer + else Limited (fromIntegral n) + } + +getMaxBuffer :: Config -> Limit +getMaxBuffer = _bufferHigh + +-- | Print debug information about the 'Channel' when the stream ends. When the +-- stream does not end normally, the channel debug information is printed when +-- the channel is garbage collected. If you are expecting but not seeing the +-- debug info try adding a 'performMajorGC' before the program ends. +-- +inspect :: Bool -> Config -> Config +inspect flag st = st { _inspect = flag } + +getInspectMode :: Config -> Bool +getInspectMode = _inspect + +-- | Spawn bound threads (i.e., spawn threads using 'forkOS' instead of +-- 'forkIO'). The default value is 'False'. +-- +-- Currently, this only takes effect only for concurrent folds. +boundThreads :: Bool -> Config -> Config +boundThreads flag st = st { _bound = flag } + +getBound :: Config -> Bool +getBound = _bound + +------------------------------------------------------------------------------- +-- Inspection +------------------------------------------------------------------------------- + +-- | Dump the channel stats for diagnostics. Used when 'inspect' option is +-- enabled. +{-# NOINLINE dumpChannel #-} +dumpChannel :: Channel m a b -> IO String +dumpChannel sv = do + xs <- sequence $ intersperse (return "\n") + [ return (dumpCreator (svarCreator sv)) + , return "---------CURRENT STATE-----------" + , dumpOutputQ (inputQueue sv) + -- XXX print the types of events in the outputQueue, first 5 + , dumpDoorBell (inputItemDoorBell sv) + , return "---------STATS-----------\n" + , dumpSVarStats (svarInspectMode sv) Nothing (svarStats sv) + ] + return $ concat xs + +------------------------------------------------------------------------------- +-- Support for running folds concurrently +------------------------------------------------------------------------------- + +-- $concurrentFolds +-- +-- To run folds concurrently, we need to decouple the fold execution from the +-- stream production. We use the SVar to do that, we have a single worker +-- pushing the stream elements to the SVar and on the consumer side a fold +-- driver pulls the values and folds them. +-- +-- @ +-- +-- Fold worker <------Channel<------Fold driver +-- | exceptions | +-- ---------------> +-- +-- @ +-- +-- We need a channel for pushing exceptions from the fold worker to the fold +-- driver. The stream may be pushed to multiple folds at the same time. For +-- that we need one Channel per fold: +-- +-- @ +-- +-- Fold worker <------Channel-- +-- | | +-- Fold worker <------Channel------Driver +-- | | +-- Fold worker <------Channel-- +-- +-- @ +-- +-- Note: If the stream pusher terminates due to an exception, we do not +-- actively terminate the fold. It gets cleaned up by the GC. + +------------------------------------------------------------------------------- +-- Process events received by a fold worker from a fold driver +------------------------------------------------------------------------------- + +sendToDriver :: Channel m a b -> OutEvent b -> IO Int +sendToDriver sv msg = do + -- In case the producer stream is blocked on pushing to the fold buffer + -- then wake it up so that it can check for the stop event or exception + -- being sent to it otherwise we will be deadlocked. + -- void $ tryPutMVar (pushBufferMVar sv) () + sendEvent (outputQueue sv) + (outputDoorBell sv) msg + +sendYieldToDriver :: MonadIO m => Channel m a b -> b -> m () +sendYieldToDriver sv res = liftIO $ do + tid <- myThreadId + void $ sendToDriver sv (FoldDone tid res) + +sendPartialToDriver :: MonadIO m => Channel m a b -> b -> m () +sendPartialToDriver sv res = liftIO $ do + void $ sendToDriver sv (FoldPartial res) + +sendEOFToDriver :: MonadIO m => Channel m a b -> m () +sendEOFToDriver sv = liftIO $ do + tid <- myThreadId + void $ sendToDriver sv (FoldEOF tid) + +{-# NOINLINE sendExceptionToDriver #-} +sendExceptionToDriver :: Channel m a b -> SomeException -> IO () +sendExceptionToDriver sv e = do + tid <- myThreadId + writeIORef (closedForInput sv) True + -- Should ring the doorbell after sending the message + void $ sendToDriver sv (FoldException tid e) + void $ tryPutMVar (inputSpaceDoorBell sv) () + +data FromSVarState m a b = + FromSVarRead (Channel m a b) + | FromSVarLoop (Channel m a b) [ChildEvent a] + +{-# INLINE_NORMAL fromInputQueue #-} +fromInputQueue :: MonadIO m => Channel m a b -> D.Stream m a +fromInputQueue svar = D.Stream step (FromSVarRead svar) + + where + + {-# INLINE_LATE step #-} + step _ (FromSVarRead sv) = do + list <- readInputQ sv + -- Reversing the output is important to guarantee that we process the + -- outputs in the same order as they were generated by the constituent + -- streams. + return $ D.Skip $ FromSVarLoop sv (Prelude.reverse list) + + step _ (FromSVarLoop sv []) = return $ D.Skip $ FromSVarRead sv + step _ (FromSVarLoop sv (ev : es)) = do + case ev of + -- XXX Separate input and output events. Input events cannot have + -- Stop event and output events cannot have ChildStopChannel + -- event. + ChildYield a -> return $ D.Yield a (FromSVarLoop sv es) + ChildStopChannel -> return D.Stop + _ -> undefined + +{-# INLINE readInputQChan #-} +readInputQChan :: Channel m a b -> IO ([ChildEvent a], Int) +readInputQChan chan = do + let ss = if svarInspectMode chan then Just (svarStats chan) else Nothing + r@(_, n) <- readOutputQRaw (inputQueue chan) ss + if n <= 0 + then do + liftIO + $ withDiagMVar + (svarInspectMode chan) + (dumpChannel chan) + "readInputQChan: nothing to do" + $ takeMVar (inputItemDoorBell chan) + readOutputQRaw (inputQueue chan) ss + else return r + +{-# INLINE readInputQWithDB #-} +readInputQWithDB :: Channel m a b -> IO ([ChildEvent a], Int) +readInputQWithDB chan = do + r <- readInputQChan chan + -- XXX We can do this only if needed, if someone sleeps because of buffer + -- then they can set a flag and we ring the doorbell only if the flag is + -- set. Like we do in sendWorkerWait for streams. + _ <- tryPutMVar (inputSpaceDoorBell chan) () + return r + +mkNewChannelWith :: forall m a b. MonadIO m => + IORef ([OutEvent b], Int) + -> MVar () + -> Config + -> IO (Channel m a b) +mkNewChannelWith outQRev outQMvRev cfg = do + outQ <- newIORef ([], 0) + outQMv <- newEmptyMVar + bufferMv <- newEmptyMVar + ref <- newIORef False + + stats <- newSVarStats + tid <- myThreadId + + let getSVar :: Channel m a b -> Channel m a b + getSVar sv = Channel + { inputQueue = outQ + , inputItemDoorBell = outQMv + , outputQueue = outQRev + , outputDoorBell = outQMvRev + , inputSpaceDoorBell = bufferMv + , closedForInput = ref + , maxInputBuffer = getMaxBuffer cfg + , readInputQ = liftIO $ fmap fst (readInputQWithDB sv) + , svarRef = Nothing + , svarInspectMode = getInspectMode cfg + , svarCreator = tid + , svarStats = stats + } + + let sv = getSVar sv in return sv + +{-# INLINABLE newChannelWith #-} +{-# SPECIALIZE newChannelWith :: + IORef ([OutEvent b], Int) + -> MVar () + -> (Config -> Config) + -> Fold IO a b + -> IO (Channel IO a b, ThreadId) #-} +newChannelWith :: (MonadRunInIO m) => + IORef ([OutEvent b], Int) + -> MVar () + -> (Config -> Config) + -> Fold m a b + -> m (Channel m a b, ThreadId) +newChannelWith outq outqDBell modifier f = do + let config = modifier defaultConfig + sv <- liftIO $ mkNewChannelWith outq outqDBell config + mrun <- askRunInIO + tid <- doForkWith + (getBound config) (work sv) mrun (sendExceptionToDriver sv) + return (sv, tid) + + where + + {-# NOINLINE work #-} + work chan = + let f1 = Fold.rmapM (void . sendYieldToDriver chan) f + in D.fold f1 $ fromInputQueue chan + +-- | Returns True if the fold terminated due to completion and False when due +-- to end-of-stream. +{-# INLINE scanToChannel #-} +scanToChannel :: MonadIO m => Channel m a b -> Scanl m a b -> Fold m a Bool +scanToChannel chan (Scanl step initial extract final) = + Fold step1 initial1 extract1 final1 + + where + + initial1 = do + r <- initial + case r of + Fold.Partial s -> do + b <- extract s + void $ sendPartialToDriver chan b + return $ Fold.Partial s + Fold.Done b -> do + sendYieldToDriver chan b + return $ Fold.Done True + + step1 st x = do + r <- step st x + case r of + Fold.Partial s -> do + b <- extract s + void $ sendPartialToDriver chan b + return $ Fold.Partial s + Fold.Done b -> do + sendYieldToDriver chan b + return $ Fold.Done True + + extract1 _ = error "extract: not supported by folds" + + -- XXX Should we not discard the result? + final1 st = do + void (final st) + return False + +{-# INLINABLE newChannelWithScan #-} +{-# SPECIALIZE newChannelWithScan :: + IORef ([OutEvent b], Int) + -> MVar () + -> (Config -> Config) + -> Scanl IO a b + -> IO (Channel IO a b, ThreadId) #-} +newChannelWithScan :: (MonadRunInIO m) => + IORef ([OutEvent b], Int) + -> MVar () + -> (Config -> Config) + -> Scanl m a b + -> m (Channel m a b, ThreadId) +newChannelWithScan outq outqDBell modifier f = do + let config = modifier defaultConfig + sv <- liftIO $ mkNewChannelWith outq outqDBell config + mrun <- askRunInIO + tid <- doForkWith + (getBound config) (work sv) mrun (sendExceptionToDriver sv) + return (sv, tid) + + where + + {-# NOINLINE work #-} + work chan = do + completed <- D.fold (scanToChannel chan f) (fromInputQueue chan) + -- We check for only one item in the outputqueue, for example in + -- parTeeWith, multiple messages can make that complicated. Therefore, + -- we first check if we already sent a FoldDone. + when (not completed) $ sendEOFToDriver chan + liftIO $ writeIORef (closedForInput chan) True + liftIO writeBarrier + void $ liftIO $ tryPutMVar (inputSpaceDoorBell chan) () + +{-# INLINABLE newChannel #-} +{-# SPECIALIZE newChannel :: + (Config -> Config) -> Fold IO a b -> IO (Channel IO a b) #-} +newChannel :: (MonadRunInIO m) => + (Config -> Config) -> Fold m a b -> m (Channel m a b) +newChannel modifier f = do + outQRev <- liftIO $ newIORef ([], 0) + outQMvRev <- liftIO newEmptyMVar + fmap fst (newChannelWith outQRev outQMvRev modifier f) + +{-# INLINABLE newScanChannel #-} +{-# SPECIALIZE newScanChannel :: + (Config -> Config) -> Scanl IO a b -> IO (Channel IO a b) #-} +newScanChannel :: (MonadRunInIO m) => + (Config -> Config) -> Scanl m a b -> m (Channel m a b) +newScanChannel modifier f = do + outQRev <- liftIO $ newIORef ([], 0) + outQMvRev <- liftIO newEmptyMVar + fmap fst (newChannelWithScan outQRev outQMvRev modifier f) + +------------------------------------------------------------------------------- +-- Process events received by the driver thread from the fold worker side +------------------------------------------------------------------------------- + +-- XXX currently only one event is sent by a fold consumer to the stream +-- producer. But we can potentially have multiple events e.g. the fold step can +-- generate exception more than once and the producer can ignore those +-- exceptions or handle them and still keep driving the fold. + +-- XXX In case of scan this could be a stream. + +-- | Poll for events sent by the fold worker to the fold driver. The fold +-- consumer can send a "Stop" event or an exception. When a "Stop" is received +-- this function returns 'True'. If an exception is recieved then it throws the +-- exception. +-- +{-# NOINLINE checkFoldStatus #-} +checkFoldStatus :: MonadAsync m => Channel m a b -> m (Maybe b) +checkFoldStatus sv = do + (list, _) <- liftIO $ readOutputQBasic (outputQueue sv) + -- Reversing the output is important to guarantee that we process the + -- outputs in the same order as they were generated by the constituent + -- streams. + processEvents $ reverse list + + where + + {-# INLINE processEvents #-} + processEvents [] = return Nothing + processEvents (ev : _) = do + case ev of + FoldException _ e -> throwM e + FoldDone _ b -> return (Just b) + FoldPartial _ -> + error "checkFoldStatus: FoldPartial can occur only for scans" + FoldEOF _ -> + error "checkFoldStatus: FoldEOF can occur only for scans" + +{-# INLINE isBufferAvailable #-} +isBufferAvailable :: MonadIO m => Channel m a b -> m Bool +isBufferAvailable sv = do + let limit = maxInputBuffer sv + case limit of + Unlimited -> return True + Limited lim -> do + (_, n) <- liftIO $ readIORef (inputQueue sv) + return $ fromIntegral lim > n + +-- | Push values from a driver to a fold worker via a Channel. Blocks if no +-- space is available in the buffer. Before pushing a value to the Channel it +-- polls for events received from the fold worker. If a stop event is received +-- then it returns 'True' otherwise false. Propagates exceptions received from +-- the fold worker. +-- +{-# INLINE sendToWorker #-} +sendToWorker :: MonadAsync m => Channel m a b -> a -> m (Maybe b) +sendToWorker chan a = go + + where + + -- Recursive function, should we use SPEC? + go = do + let qref = outputQueue chan + status <- do + (_, n) <- liftIO $ readIORef qref + if n > 0 + then checkFoldStatus chan + else return Nothing + case status of + Just _ -> return status + Nothing -> do + r <- isBufferAvailable chan + if r + then do + liftIO + $ void + $ sendEvent + (inputQueue chan) + (inputItemDoorBell chan) + (ChildYield a) + return Nothing + else do + () <- liftIO $ takeMVar (inputSpaceDoorBell chan) + go + +-- | Like sendToWorker but only sends, does not receive any events from the +-- fold. +{-# INLINE sendToWorker_ #-} +sendToWorker_ :: MonadAsync m => Channel m a b -> a -> m () +sendToWorker_ chan a = go + + where + + -- Recursive function, should we use SPEC? + go = do + r <- isBufferAvailable chan + if r + then do + liftIO + $ void + $ sendEvent + (inputQueue chan) + (inputItemDoorBell chan) + (ChildYield a) + else do + -- Block for space + () <- liftIO $ takeMVar (inputSpaceDoorBell chan) + closed <- liftIO $ readIORef (closedForInput chan) + when (not closed) go + +-- XXX Cleanup the fold if the stream is interrupted. Add a GC hook. + +cleanup :: MonadIO m => Channel m a b -> m () +cleanup chan = do + when (svarInspectMode chan) $ liftIO $ do + t <- getTime Monotonic + writeIORef (svarStopTime (svarStats chan)) (Just t) + printSVar (dumpChannel chan) "Scan channel done" + +finalize :: MonadIO m => Channel m a b -> m () +finalize chan = do + liftIO $ void + $ sendEvent + (inputQueue chan) + (inputItemDoorBell chan) + ChildStopChannel diff --git a/src/Streamly/Internal/Data/Fold/Concurrent.hs b/src/Streamly/Internal/Data/Fold/Concurrent.hs --- a/src/Streamly/Internal/Data/Fold/Concurrent.hs +++ b/src/Streamly/Internal/Data/Fold/Concurrent.hs @@ -6,64 +6,588 @@ -- Stability : experimental -- Portability : GHC -- --- Eval a fold asynchronously in a separate thread. +-- = Asynchronous Evaluation -- --- Use multiple worker folds to fold a stream and collect the results using --- another fold, combine using a monoid. The results can be collected --- out-of-order or in-order. +-- Using 'parBuffered' a fold can be decoupled from the driver and evaluated +-- concurrently with the driver. The driver just pushes an element to the +-- fold's buffer and waits for async evaluation to finish. -- +-- Stages in a fold pipeline can be made concurrent using 'parBuffered'. +-- +-- = Concurrent Fold Combinators +-- +-- The 'demux' combinator can be made concurrent by using 'parBuffered' on the fold +-- returned by the fold-generating function. Thus, we can fold values for each +-- key in the input stream concurrently. +-- +-- Similarly, we can use 'parBuffered' with other cobminators like 'toMap', +-- 'demuxToMap', 'classify', 'tee', 'distribute', 'partition' etc. Basically, +-- any combinator that composes multiple folds or multiple instances of a fold +-- is a good candidate for running folds concurrently. +-- +-- = Finalization +-- +-- Before a fold returns "done" it has to drain the child folds. For example, +-- consider a "take" operation on a `parBuffered` fold, the take should return as +-- soon as it has taken required number of elements but we have to ensure that +-- any asynchronous child folds finish before it returns. This is achieved by +-- calling the "final" operation of the fold. + +-- = TODO +-- +-- Use multiple worker folds to fold serial chunks of a stream and collect the +-- results using another fold, combine using a monoid. The results can be +-- collected out-of-order or in-order. This would be easier if each input +-- element is a streamable chunk and each fold consumes one chunk at a time. +-- This is like parConcatMap in streams. +-- -- Concurrent append: if one fold's buffer becomes full then use the next one -- Concurrent interleave/partition: Round robin to n folds. -- Concurrent distribute to multiple folds. module Streamly.Internal.Data.Fold.Concurrent ( - -- * Imports - -- $setup - - -- * Configuration - Config - , maxBuffer - , inspect - - -- * Combinators - -- | Stream combinators using Async channel + parBuffered + , parLmapM + , parTeeWith + , parTee + , parDistribute + , parPartition + , parUnzipWithM + , parUnzip + , parDistributeScan + , parDemuxScan - , eval + -- Deprecated , parEval ) where +#include "inline.hs" +#include "deprecation.h" + +import Control.Concurrent (newEmptyMVar, takeMVar, throwTo) +import Control.Monad.Catch (throwM) +import Control.Monad (void) +import Control.Monad.IO.Class (MonadIO(liftIO)) +import Data.IORef (newIORef, readIORef) +import Fusion.Plugin.Types (Fuse(..)) import Streamly.Internal.Control.Concurrent (MonadAsync) -import Streamly.Internal.Data.Fold (Fold) +import Streamly.Internal.Data.Channel.Worker (sendEvent) +import Streamly.Internal.Data.Fold (Fold(..), Step (..)) +import Streamly.Internal.Data.Stream (Stream(..), Step(..)) +import Streamly.Internal.Data.SVar.Type (adaptState) -import Streamly.Internal.Data.Fold.Concurrent.Channel +import qualified Data.Map.Strict as Map +import qualified Streamly.Internal.Data.Fold as Fold +import Streamly.Internal.Data.Fold.Channel.Type +import Streamly.Internal.Data.Channel.Types + -- $setup --- --- Imports for example snippets in this module. --- --- >>> :m --- >>> :set -XFlexibleContexts +-- >>> :set -fno-warn-deprecations -- >>> import Control.Concurrent (threadDelay) --- >>> import qualified Streamly.Data.Array as Array --- >>> import qualified Streamly.Data.Fold as Fold --- >>> import qualified Streamly.Data.Parser as Parser --- >>> import qualified Streamly.Data.Stream as Stream +-- >>> import qualified Streamly.Internal.Data.Stream as Stream +-- >>> import qualified Streamly.Internal.Data.Stream.Prelude as Stream +-- >>> import qualified Streamly.Internal.Data.Fold as Fold -- >>> import qualified Streamly.Internal.Data.Fold.Concurrent as Fold --- >>> import Prelude hiding (concatMap, concat) --- >>> :{ --- delay n = do --- threadDelay (n * 1000000) -- sleep for n seconds --- putStrLn (show n ++ " sec") -- print "n sec" --- return n -- IO Int --- :} --- | Evaluate a stream asynchronously using a channel and serve the consumer --- from the evaluation buffer. +------------------------------------------------------------------------------- +-- Evaluating a Fold +------------------------------------------------------------------------------- + +-- | 'parBuffered' introduces a concurrent stage at the input of the fold. The +-- inputs are asynchronously queued in a buffer and evaluated concurrently with +-- the evaluation of the source stream. On finalization, 'parBuffered' waits for +-- the asynchronous fold to complete before it returns. -- --- >>> eval = Fold.parEval id +-- In the following example both the stream and the fold have a 1 second delay, +-- but the delay is not compounded because both run concurrently. -- -{-# INLINE eval #-} -eval :: MonadAsync m => Fold m a b -> Fold m a b -eval = parEval id +-- >>> delay x = threadDelay 1000000 >> print x >> return x +-- +-- >>> src = Stream.delay 1 (Stream.enumerateFromTo 1 3) +-- >>> dst = Fold.parBuffered id (Fold.lmapM delay Fold.sum) +-- >>> Stream.fold dst src +-- ... +-- +-- Another example: +-- +-- >>> Stream.toList $ Stream.groupsOf 4 dst src +-- ... +-- +{-# INLINABLE parBuffered #-} +parBuffered, parEval + :: MonadAsync m => (Config -> Config) -> Fold m a b -> Fold m a b +parBuffered modifier f = + Fold step initial extract final + + where + + -- XXX Supply an output channel to the fold. The fold would send the result + -- from each step (i.e. scan result) to the channel. The Partial and Done + -- constructors are sent to the channel. We then draw the resulting stream + -- from that channel. Kind of concurrrent mapping on the stream but with a + -- fold/scan. + -- + -- There can also be a model where multiple folds pick input from the same + -- channel. + -- + -- We can also run parsers this way. So instead of sending output on each + -- step it can send once it is done. + initial = Partial <$> newChannel modifier f + + -- XXX This is not truly asynchronous. If the fold is done we only get to + -- know when we send the next input unless the stream ends. We could + -- potentially throw an async exception to the driver to inform it + -- asynchronously. Alternatively, the stream should not block forever, it + -- should keep polling the fold status. We can insert a timer tick in the + -- input stream to do that. + -- + -- A polled stream abstraction may be useful, it would consist of normal + -- events and tick events, latter are guaranteed to arrive. + -- + -- XXX We can use the config to indicate if the fold is a scanning type or + -- one-shot, or use a separate parBufferedScan for scanning. For a scanning + -- type fold the worker would always send the intermediate values back to + -- the driver. An intermediate value can be returned on an input, or the + -- driver can poll even without input, if we have the Skip input support. + -- When the buffer is full we can return "Skip" and then the next step + -- without input can wait for an output to arrive. Similarly, when "final" + -- is called it can return "Skip" to continue or "Done" to indicate + -- termination. + step chan a = do + status <- sendToWorker chan a + return $ case status of + Nothing -> Partial chan + Just b -> Done b + + extract _ = error "Concurrent folds do not support scanning" + + -- XXX depending on the use case we may want to either wait for the result + -- or cancel the ongoing work. We can use the config to control that? + -- Currently it waits for the work to complete. + final chan = do + liftIO $ void + $ sendEvent + (inputQueue chan) + (inputItemDoorBell chan) + ChildStopChannel + status <- checkFoldStatus chan + case status of + Nothing -> do + liftIO + $ withDiagMVar + (svarInspectMode chan) + (dumpChannel chan) + "parBuffered: waiting to drain" + $ takeMVar (outputDoorBell chan) + -- XXX remove recursion + final chan + Just b -> do + cleanup chan + return b +RENAME(parEval,parBuffered) + +-- XXX We can have a lconcatMap (unfoldMany) to expand the chunks in the input +-- to streams before folding. This will require an input Skip constructor. In +-- fact, parLmapM can be implemented in terms of this like in streams. + +-- | Evaluate the mapped actions concurrently with respect to each other. The +-- results may be unordered or ordered depending on the configuration. +-- +-- /Unimplemented/ +{-# INLINABLE parLmapM #-} +parLmapM :: -- MonadAsync m => + (Config -> Config) -> (a -> m b) -> Fold m b r -> Fold m a r +parLmapM = undefined + +-- | Execute both the folds in a tee concurrently. +-- +-- Definition: +-- +-- >>> parTeeWith cfg f c1 c2 = Fold.teeWith f (Fold.parBuffered cfg c1) (Fold.parBuffered cfg c2) +-- +-- Example: +-- +-- >>> delay x = threadDelay 1000000 >> print x >> return x +-- >>> c1 = Fold.lmapM delay Fold.sum +-- >>> c2 = Fold.lmapM delay Fold.length +-- >>> dst = Fold.parTeeWith id (,) c1 c2 +-- >>> Stream.fold dst src +-- ... +-- +{-# INLINABLE parTeeWith #-} +parTeeWith :: MonadAsync m => + (Config -> Config) + -> (a -> b -> c) + -> Fold m x a + -> Fold m x b + -> Fold m x c +parTeeWith cfg f c1 c2 = Fold.teeWith f (parBuffered cfg c1) (parBuffered cfg c2) + +-- | Execute both the folds in a tee concurrently. +-- +-- Definition: +-- +-- >>> parTee cfg c1 c2 = Fold.teeWith (,) (Fold.parBuffered cfg c1) (Fold.parBuffered cfg c2) +-- +-- Example: +-- +-- >>> delay x = threadDelay 1000000 >> print x >> return x +-- >>> c1 = Fold.lmapM delay Fold.sum +-- >>> c2 = Fold.lmapM delay Fold.length +-- >>> dst = Fold.parTee id c1 c2 +-- >>> Stream.fold dst src +-- ... +-- +{-# INLINABLE parTee #-} +parTee :: MonadAsync m => + (Config -> Config) + -> Fold m x a + -> Fold m x b + -> Fold m x (a, b) +parTee cfg c1 c2 = Fold.teeWith (,) (parBuffered cfg c1) (parBuffered cfg c2) + +-- | Distribute the input to all the folds in the supplied list concurrently. +-- +-- Definition: +-- +-- >>> parDistribute cfg = Fold.distribute . fmap (Fold.parBuffered cfg) +-- +-- Example: +-- +-- >>> delay x = threadDelay 1000000 >> print x >> return x +-- >>> c = Fold.lmapM delay Fold.sum +-- >>> dst = Fold.parDistribute id [c,c,c] +-- >>> Stream.fold dst src +-- ... +-- +{-# INLINABLE parDistribute #-} +parDistribute :: MonadAsync m => + (Config -> Config) -> [Fold m a b] -> Fold m a [b] +parDistribute cfg = Fold.distribute . fmap (parBuffered cfg) + +-- | Select first fold for Left input and second for Right input. Both folds +-- run concurrently. +-- +-- Definition +-- +-- >>> parPartition cfg c1 c2 = Fold.partition (Fold.parBuffered cfg c1) (Fold.parBuffered cfg c2) +-- +-- Example: +-- +-- >>> delay x = threadDelay 1000000 >> print x >> return x +-- >>> c1 = Fold.lmapM delay Fold.sum +-- >>> c2 = Fold.lmapM delay Fold.sum +-- >>> dst = Fold.parPartition id c1 c2 +-- >>> Stream.fold dst $ (fmap (\x -> if even x then Left x else Right x)) src +-- ... +-- +{-# INLINABLE parPartition #-} +parPartition :: MonadAsync m => + (Config -> Config) -> Fold m b x -> Fold m c y -> Fold m (Either b c) (x, y) +parPartition cfg c1 c2 = Fold.partition (parBuffered cfg c1) (parBuffered cfg c2) + +-- | Split and distribute the output to two different folds and then zip the +-- results. Both the consumer folds run concurrently. +-- +-- Definition +-- +-- >>> parUnzipWithM cfg f c1 c2 = Fold.unzipWithM f (Fold.parBuffered cfg c1) (Fold.parBuffered cfg c2) +-- +-- Example: +-- +-- >>> delay x = threadDelay 1000000 >> print x >> return x +-- >>> c1 = Fold.lmapM delay Fold.sum +-- >>> c2 = Fold.lmapM delay Fold.sum +-- >>> dst = Fold.parUnzipWithM id (pure . id) c1 c2 +-- >>> Stream.fold dst $ (fmap (\x -> (x, x* x))) src +-- ... +-- +{-# INLINABLE parUnzipWithM #-} +parUnzipWithM :: MonadAsync m + => (Config -> Config) -> (a -> m (b,c)) -> Fold m b x -> Fold m c y -> Fold m a (x,y) +parUnzipWithM cfg f c1 c2 = Fold.unzipWithM f (parBuffered cfg c1) (parBuffered cfg c2) + +-- | Split and distribute the output to two different folds and then zip the +-- results. Both the consumer folds run concurrently. +-- +-- Definition +-- +-- >>> parUnzip cfg c1 c2 = Fold.unzip (Fold.parBuffered cfg c1) (Fold.parBuffered cfg c2) +-- +-- Example: +-- +-- >>> delay x = threadDelay 1000000 >> print x >> return x +-- >>> c1 = Fold.lmapM delay Fold.sum +-- >>> c2 = Fold.lmapM delay Fold.sum +-- >>> dst = Fold.parUnzip id c1 c2 +-- >>> Stream.fold dst $ (fmap (\x -> (x, x * x))) src +-- ... +-- +{-# INLINABLE parUnzip #-} +parUnzip :: MonadAsync m + => (Config -> Config) -> Fold m b x -> Fold m c y -> Fold m (b,c) (x,y) +parUnzip cfg c1 c2 = Fold.unzip (parBuffered cfg c1) (parBuffered cfg c2) + +-- There are two ways to implement a concurrent scan. +-- +-- 1. Make the scan itself asynchronous, add the input to the queue, and then +-- extract the output. Extraction will have to be asynchronous, which will +-- require changes to the scan driver. This will require a different Scanl +-- type. +-- +-- 2. A monolithic implementation of concurrent Stream->Stream scan, using a +-- custom implementation of the scan and the driver. + +{-# ANN type ScanState Fuse #-} +data ScanState s q db f = + ScanInit + | ScanGo s q db [f] + | ScanDrain q db [f] + | ScanStop + +-- XXX return [b] or just b? +-- XXX We can use a one way mailbox type abstraction instead of using an IORef +-- for adding new folds dynamically. + +-- | Evaluate a stream and send its outputs to zero or more dynamically +-- generated folds. It checks for any new folds at each input generation step. +-- Any new fold is added to the list of folds which are currently running. If +-- there are no folds available, the input is discarded. If a fold completes +-- its output is emitted in the output of the scan. +-- +-- >>> import Data.IORef +-- >>> ref <- newIORef [Fold.take 2 Fold.sum, Fold.take 2 Fold.length :: Fold.Fold IO Int Int] +-- >>> gen = atomicModifyIORef ref (\xs -> ([], xs)) +-- >>> Stream.toList $ Fold.parDistributeScan id gen (Stream.enumerateFromTo 1 10) +-- ... +-- +{-# INLINE parDistributeScan #-} +parDistributeScan :: MonadAsync m => + (Config -> Config) -> m [Fold m a b] -> Stream m a -> Stream m [b] +parDistributeScan cfg getFolds (Stream sstep state) = + Stream step ScanInit + + where + + -- XXX can be written as a fold + processOutputs chans events done = do + case events of + [] -> return (chans, done) + (x:xs) -> + case x of + FoldException _tid ex -> do + -- XXX report the fold that threw the exception + liftIO $ mapM_ (`throwTo` ThreadAbort) (fmap snd chans) + mapM_ cleanup (fmap fst chans) + liftIO $ throwM ex + FoldDone tid b -> + let ch = filter (\(_, t) -> t /= tid) chans + in processOutputs ch xs (b:done) + FoldPartial _ -> + error "parDistributeScan: cannot occur for folds" + FoldEOF _ -> + error + "parDistributeScan: FoldEOF cannot occur for folds" + + collectOutputs qref chans = do + (_, n) <- liftIO $ readIORef qref + if n > 0 + then do + r <- fmap fst $ liftIO $ readOutputQBasic qref + processOutputs chans r [] + else return (chans, []) + + step _ ScanInit = do + q <- liftIO $ newIORef ([], 0) + db <- liftIO newEmptyMVar + return $ Skip (ScanGo state q db []) + + step gst (ScanGo st q db chans) = do + -- merge any new channels added since last input + fxs <- getFolds + newChans <- Prelude.mapM (newChannelWith q db cfg) fxs + let allChans = chans ++ newChans + + -- Collect outputs from running channels + (running, outputs) <- collectOutputs q allChans + + -- Send input to running folds + res <- sstep (adaptState gst) st + next <- case res of + Yield x s -> do + -- XXX We might block forever if some folds are already + -- done but we have not read the output queue yet. To + -- avoid that we have to either (1) precheck if space + -- is available in the input queues of all folds so + -- that this does not block, or (2) we have to use a + -- non-blocking read and track progress so that we can + -- restart from where we left. + -- + -- If there is no space available then we should block + -- on doorbell db or inputSpaceDoorBell of the relevant + -- channel. To avoid deadlock the output space can be + -- kept unlimited. However, the blocking will delay the + -- processing of outputs. We should yield the outputs + -- before blocking. + Prelude.mapM_ (`sendToWorker_` x) (fmap fst running) + return $ ScanGo s q db running + Skip s -> do + return $ ScanGo s q db running + Stop -> do + Prelude.mapM_ finalize (fmap fst running) + return $ ScanDrain q db running + if null outputs + then return $ Skip next + else return $ Yield outputs next + step _ (ScanDrain q db chans) = do + (running, outputs) <- collectOutputs q chans + case running of + [] -> return $ Yield outputs ScanStop + _ -> do + if null outputs + then do + liftIO $ takeMVar db + return $ Skip (ScanDrain q db running) + else return $ Yield outputs (ScanDrain q db running) + step _ ScanStop = return Stop + +{-# ANN type DemuxState Fuse #-} +data DemuxState s q db f = + DemuxInit + | DemuxGo s q db f + | DemuxDrain q db f + | DemuxStop + +-- XXX We need to either (1) remember a key when done so that we do not add the +-- fold again because some inputs would be lost in between, or (2) have a +-- FoldYield constructor to yield repeatedly so that we can restart the +-- existing fold itself when it is done. But in that case we cannot change the +-- fold once it is started. Also the Map would keep on increasing in size as we +-- never delete a key. Whatever we do we should keep the non-concurrent fold as +-- well consistent with that. + +-- | Evaluate a stream and send its outputs to the selected fold. The fold is +-- dynamically selected using a key at the time of the first input seen for +-- that key. Any new fold is added to the list of folds which are currently +-- running. If there are no folds available for a given key, the input is +-- discarded. If a fold completes its output is emitted in the output of the +-- scan. +-- +-- >>> import qualified Data.Map.Strict as Map +-- >>> import Data.Maybe (fromJust) +-- >>> f1 = ("even", Fold.take 2 Fold.sum) +-- >>> f2 = ("odd", Fold.take 2 Fold.sum) +-- >>> kv = Map.fromList [f1, f2] +-- >>> getFold k = return (fromJust $ Map.lookup k kv) +-- >>> getKey x = if even x then "even" else "odd" +-- >>> input = Stream.enumerateFromTo 1 10 +-- >>> Stream.toList $ Fold.parDemuxScan id getKey getFold input +-- ... +-- +{-# INLINE parDemuxScan #-} +parDemuxScan :: (MonadAsync m, Ord k) => + (Config -> Config) + -> (a -> k) + -> (k -> m (Fold m a b)) + -> Stream m a + -> Stream m [(k, b)] +parDemuxScan cfg getKey getFold (Stream sstep state) = + Stream step DemuxInit + + where + + -- XXX can be written as a fold + processOutputs keyToChan events done = do + case events of + [] -> return (keyToChan, done) + (x:xs) -> + case x of + FoldException _tid ex -> do + -- XXX report the fold that threw the exception + let chans = fmap snd $ Map.toList keyToChan + liftIO $ mapM_ (`throwTo` ThreadAbort) (fmap snd chans) + mapM_ cleanup (fmap fst chans) + liftIO $ throwM ex + FoldDone _tid o@(k, _) -> + let ch = Map.delete k keyToChan + in processOutputs ch xs (o:done) + FoldPartial _ -> + error "parDemuxScan: cannot occur for folds" + FoldEOF _ -> + error "parDemuxScan: FoldEOF cannot occur for folds" + + collectOutputs qref keyToChan = do + (_, n) <- liftIO $ readIORef qref + if n > 0 + then do + r <- fmap fst $ liftIO $ readOutputQBasic qref + processOutputs keyToChan r [] + else return (keyToChan, []) + + step _ DemuxInit = do + q <- liftIO $ newIORef ([], 0) + db <- liftIO newEmptyMVar + return $ Skip (DemuxGo state q db Map.empty) + + step gst (DemuxGo st q db keyToChan) = do + -- Collect outputs from running channels + (keyToChan1, outputs) <- collectOutputs q keyToChan + + -- Send input to the selected fold + res <- sstep (adaptState gst) st + + next <- case res of + Yield x s -> do + -- XXX If the fold for a particular key is done and we see that + -- key again. If we have not yet collected the done event we + -- cannot restart the fold because the previous key is already + -- installed. Thererfore, restarting the fold for the same key + -- fraught with races. + let k = getKey x + (keyToChan2, ch) <- + case Map.lookup k keyToChan1 of + Nothing -> do + fld <- getFold k + r@(chan, _) <- newChannelWith q db cfg (fmap (k,) fld) + return (Map.insert k r keyToChan1, chan) + Just (chan, _) -> return (keyToChan1, chan) + -- XXX We might block forever if some folds are already + -- done but we have not read the output queue yet. To + -- avoid that we have to either (1) precheck if space + -- is available in the input queues of all folds so + -- that this does not block, or (2) we have to use a + -- non-blocking read and track progress so that we can + -- restart from where we left. + -- + -- If there is no space available then we should block + -- on doorbell db or inputSpaceDoorBell of the relevant + -- channel. To avoid deadlock the output space can be + -- kept unlimited. However, the blocking will delay the + -- processing of outputs. We should yield the outputs + -- before blocking. + sendToWorker_ ch x + return $ DemuxGo s q db keyToChan2 + Skip s -> + return $ DemuxGo s q db keyToChan1 + Stop -> do + let chans = fmap (fst . snd) $ Map.toList keyToChan1 + Prelude.mapM_ finalize chans + return $ DemuxDrain q db keyToChan1 + if null outputs + then return $ Skip next + else return $ Yield outputs next + step _ (DemuxDrain q db keyToChan) = do + (keyToChan1, outputs) <- collectOutputs q keyToChan + if Map.null keyToChan1 + -- XXX null outputs case + then return $ Yield outputs DemuxStop + else do + if null outputs + then do + liftIO $ takeMVar db + return $ Skip (DemuxDrain q db keyToChan1) + else return $ Yield outputs (DemuxDrain q db keyToChan1) + step _ DemuxStop = return Stop diff --git a/src/Streamly/Internal/Data/Fold/Concurrent/Channel.hs b/src/Streamly/Internal/Data/Fold/Concurrent/Channel.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Fold/Concurrent/Channel.hs +++ /dev/null @@ -1,91 +0,0 @@ --- | --- Module : Streamly.Internal.Data.Fold.Concurrent.Channel --- Copyright : (c) 2022 Composewell Technologies --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC - -module Streamly.Internal.Data.Fold.Concurrent.Channel - ( - -- * Channel - Channel - - -- * Configuration - , Config - , maxBuffer - , inspect - - -- * Fold operations - , parEval - ) -where - -import Control.Concurrent (takeMVar) -import Control.Monad (void, when) -import Control.Monad.IO.Class (MonadIO(liftIO)) -import Data.IORef (writeIORef) -import Streamly.Internal.Control.Concurrent (MonadAsync) -import Streamly.Internal.Data.Fold (Fold(..), Step (..)) -import Streamly.Internal.Data.Stream.Channel.Worker (sendWithDoorBell) -import Streamly.Internal.Data.Time.Clock (Clock(Monotonic), getTime) - -import Streamly.Internal.Data.Fold.Concurrent.Channel.Type -import Streamly.Internal.Data.Stream.Channel.Types - -------------------------------------------------------------------------------- --- Evaluating a Fold -------------------------------------------------------------------------------- - --- XXX Cleanup the fold if the stream is interrupted. Add a GC hook. - --- | Evaluate the fold asynchronously in a worker thread separate from the --- driver thread. --- -{-# INLINABLE parEval #-} -parEval :: MonadAsync m => (Config -> Config) -> Fold m a b -> Fold m a b -parEval modifier f = - Fold step initial extract - - where - - initial = Partial <$> newChannel modifier f - - -- XXX This is not truly asynchronous. If the fold is done we only get to - -- know when we send the next input unless the stream ends. We could - -- potentially throw an async exception to the driver to inform it - -- asynchronously. Alternatively, the stream should not block forever, it - -- should keep polling the fold status. We can insert a timer tick in the - -- input stream to do that. - -- - -- A polled stream abstraction may be useful, it would consist of normal - -- events and tick events, latter are guaranteed to arrive. - step chan a = do - status <- sendToWorker chan a - return $ case status of - Nothing -> Partial chan - Just b -> Done b - - extract chan = do - liftIO $ void - $ sendWithDoorBell - (outputQueue chan) - (outputDoorBell chan) - ChildStopChannel - status <- checkFoldStatus chan - case status of - Nothing -> do - liftIO - $ withDiagMVar - (svarInspectMode chan) - (dumpSVar chan) - "parEval: waiting to drain" - $ takeMVar (outputDoorBellFromConsumer chan) - -- XXX remove recursion - extract chan - Just b -> do - when (svarInspectMode chan) $ liftIO $ do - t <- getTime Monotonic - writeIORef (svarStopTime (svarStats chan)) (Just t) - printSVar (dumpSVar chan) "SVar Done" - return b diff --git a/src/Streamly/Internal/Data/Fold/Concurrent/Channel/Type.hs b/src/Streamly/Internal/Data/Fold/Concurrent/Channel/Type.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Fold/Concurrent/Channel/Type.hs +++ /dev/null @@ -1,330 +0,0 @@ --- | --- Module : Streamly.Internal.Data.Fold.Concurrent.Channel.Type --- Copyright : (c) 2017, 2022 Composewell Technologies --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC - -module Streamly.Internal.Data.Fold.Concurrent.Channel.Type - ( Channel (..) - , newChannel - , Config - , sendToWorker - , checkFoldStatus - , dumpSVar - ) -where - -#include "inline.hs" - -import Control.Concurrent (ThreadId, myThreadId, tryPutMVar) -import Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar) -import Control.Exception (SomeException(..)) -import Control.Monad (void) -import Control.Monad.Catch (throwM) -import Control.Monad.IO.Class (MonadIO(..)) -import Data.IORef (IORef, newIORef, readIORef) -import Data.List (intersperse) -import Streamly.Internal.Control.Concurrent - (MonadAsync, MonadRunInIO, askRunInIO) -import Streamly.Internal.Control.ForkLifted (doFork) -import Streamly.Internal.Data.Fold (Fold(..)) -import Streamly.Internal.Data.Stream.Channel.Dispatcher (dumpSVarStats) -import Streamly.Internal.Data.Stream.Channel.Worker (sendWithDoorBell) - -import qualified Streamly.Internal.Data.Fold as Fold -import qualified Streamly.Internal.Data.Stream.StreamD.Type as D - -import Streamly.Internal.Data.Stream.Channel.Types - -data Channel m a b = Channel - { - -- FORWARD FLOW: Flow of data from the driver to the consuming fold - - -- XXX This is inputQueue instead. - - -- Shared output queue (events, length) - -- - -- [LOCKING] Frequent locked access. This is updated by the driver on each - -- yield and once in a while read by the consumer fold thread. - -- - -- XXX Use a different type than ChildEvent. We can do with a simpler type - -- in folds. - outputQueue :: IORef ([ChildEvent a], Int) - -- This is capped 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. - , maxBufferLimit :: Limit - - -- [LOCKING] Infrequent MVar. Used when the outputQ transitions from empty - -- to non-empty. - , outputDoorBell :: MVar () -- signal the consumer about output - , readOutputQ :: m [ChildEvent a] - - -- receive async events from the fold consumer to the driver. - , outputQueueFromConsumer :: IORef ([ChildEvent b], Int) - , outputDoorBellFromConsumer :: MVar () - , bufferSpaceDoorBell :: MVar () - - -- cleanup: to track garbage collection of SVar -- - , svarRef :: Maybe (IORef ()) - - -- Stats -- - , svarStats :: SVarStats - - -- Diagnostics -- - , svarInspectMode :: Bool - , svarCreator :: ThreadId - } - -{-# NOINLINE dumpSVar #-} -dumpSVar :: Channel m a b -> IO String -dumpSVar sv = do - xs <- sequence $ intersperse (return "\n") - [ return (dumpCreator (svarCreator sv)) - , return "---------CURRENT STATE-----------" - , dumpOutputQ (outputQueue sv) - -- XXX print the types of events in the outputQueue, first 5 - , dumpDoorBell (outputDoorBell sv) - , return "---------STATS-----------\n" - , dumpSVarStats (svarInspectMode sv) Nothing (svarStats sv) - ] - return $ concat xs - -------------------------------------------------------------------------------- --- Support for running folds concurrently -------------------------------------------------------------------------------- - --- $concurrentFolds --- --- To run folds concurrently, we need to decouple the fold execution from the --- stream production. We use the SVar to do that, we have a single worker --- pushing the stream elements to the SVar and on the consumer side a fold --- driver pulls the values and folds them. --- --- @ --- --- Fold worker <------Channel<------Fold driver --- | exceptions | --- ---------------> --- --- @ --- --- We need a channel for pushing exceptions from the fold worker to the fold --- driver. The stream may be pushed to multiple folds at the same time. For --- that we need one Channel per fold: --- --- @ --- --- Fold worker <------Channel-- --- | | --- Fold worker <------Channel------Driver --- | | --- Fold worker <------Channel-- --- --- @ --- --- Note: If the stream pusher terminates due to an exception, we do not --- actively terminate the fold. It gets cleaned up by the GC. - -------------------------------------------------------------------------------- --- Process events received by a fold worker from a fold driver -------------------------------------------------------------------------------- - -sendToDriver :: Channel m a b -> ChildEvent b -> IO Int -sendToDriver sv msg = do - -- In case the producer stream is blocked on pushing to the fold buffer - -- then wake it up so that it can check for the stop event or exception - -- being sent to it otherwise we will be deadlocked. - -- void $ tryPutMVar (pushBufferMVar sv) () - sendWithDoorBell (outputQueueFromConsumer sv) - (outputDoorBellFromConsumer sv) msg - -sendYieldToDriver :: MonadIO m => Channel m a b -> b -> m () -sendYieldToDriver sv res = liftIO $ do - void $ sendToDriver sv (ChildYield res) - -{-# NOINLINE sendExceptionToDriver #-} -sendExceptionToDriver :: Channel m a b -> SomeException -> IO () -sendExceptionToDriver sv e = do - tid <- myThreadId - void $ sendToDriver sv (ChildStop tid (Just e)) - -data FromSVarState m a b = - FromSVarRead (Channel m a b) - | FromSVarLoop (Channel m a b) [ChildEvent a] - -{-# INLINE_NORMAL fromProducerD #-} -fromProducerD :: MonadIO m => Channel m a b -> D.Stream m a -fromProducerD svar = D.Stream step (FromSVarRead svar) - - where - - {-# INLINE_LATE step #-} - step _ (FromSVarRead sv) = do - list <- readOutputQ sv - -- Reversing the output is important to guarantee that we process the - -- outputs in the same order as they were generated by the constituent - -- streams. - return $ D.Skip $ FromSVarLoop sv (Prelude.reverse list) - - step _ (FromSVarLoop sv []) = return $ D.Skip $ FromSVarRead sv - step _ (FromSVarLoop sv (ev : es)) = do - case ev of - ChildYield a -> return $ D.Yield a (FromSVarLoop sv es) - ChildStopChannel -> return D.Stop - _ -> undefined - -{-# INLINE readOutputQChan #-} -readOutputQChan :: Channel m a b -> IO ([ChildEvent a], Int) -readOutputQChan chan = do - let ss = if svarInspectMode chan then Just (svarStats chan) else Nothing - r@(_, n) <- readOutputQRaw (outputQueue chan) ss - if n <= 0 - then do - liftIO - $ withDiagMVar - (svarInspectMode chan) - (dumpSVar chan) - "readOutputQChan: nothing to do" - $ takeMVar (outputDoorBell chan) - readOutputQRaw (outputQueue chan) ss - else return r - -{-# INLINE readOutputQDB #-} -readOutputQDB :: Channel m a b -> IO ([ChildEvent a], Int) -readOutputQDB chan = do - r <- readOutputQChan chan - -- XXX We can do this only if needed, if someone sleeps because of buffer - -- then they can set a flag and we ring the doorbell only if the flag is - -- set. Like we do in sendWorkerWait for streams. - _ <- tryPutMVar (bufferSpaceDoorBell chan) () - return r - -mkNewChannel :: forall m a b. MonadIO m => Config -> IO (Channel m a b) -mkNewChannel cfg = do - outQ <- newIORef ([], 0) - outQMv <- newEmptyMVar - outQRev <- newIORef ([], 0) - outQMvRev <- newEmptyMVar - bufferMv <- newEmptyMVar - - stats <- newSVarStats - tid <- myThreadId - - let getSVar :: Channel m a b -> Channel m a b - getSVar sv = Channel - { outputQueue = outQ - , outputDoorBell = outQMv - , outputQueueFromConsumer = outQRev - , outputDoorBellFromConsumer = outQMvRev - , bufferSpaceDoorBell = bufferMv - , maxBufferLimit = getMaxBuffer cfg - , readOutputQ = liftIO $ fmap fst (readOutputQDB sv) - , svarRef = Nothing - , svarInspectMode = getInspectMode cfg - , svarCreator = tid - , svarStats = stats - } - - let sv = getSVar sv in return sv - -{-# INLINABLE newChannel #-} -{-# SPECIALIZE newChannel :: - (Config -> Config) -> Fold IO a b -> IO (Channel IO a b) #-} -newChannel :: (MonadRunInIO m) => - (Config -> Config) -> Fold m a b -> m (Channel m a b) -newChannel modifier f = do - sv <- liftIO $ mkNewChannel (modifier defaultConfig) - mrun <- askRunInIO - void $ doFork (work sv) mrun (sendExceptionToDriver sv) - return sv - - where - - {-# NOINLINE work #-} - work chan = - let f1 = Fold.rmapM (void . sendYieldToDriver chan) f - in D.fold f1 $ fromProducerD chan - -------------------------------------------------------------------------------- --- Process events received by the driver thread from the fold worker side -------------------------------------------------------------------------------- - --- XXX currently only one event is sent by a fold consumer to the stream --- producer. But we can potentially have multiple events e.g. the fold step can --- generate exception more than once and the producer can ignore those --- exceptions or handle them and still keep driving the fold. - --- XXX In case of scan this could be a stream. - --- | Poll for events sent by the fold worker to the fold driver. The fold --- consumer can send a "Stop" event or an exception. When a "Stop" is received --- this function returns 'True'. If an exception is recieved then it throws the --- exception. --- -{-# NOINLINE checkFoldStatus #-} -checkFoldStatus :: MonadAsync m => Channel m a b -> m (Maybe b) -checkFoldStatus sv = do - (list, _) <- liftIO $ readOutputQBasic (outputQueueFromConsumer sv) - -- Reversing the output is important to guarantee that we process the - -- outputs in the same order as they were generated by the constituent - -- streams. - processEvents $ reverse list - - where - - {-# INLINE processEvents #-} - processEvents [] = return Nothing - processEvents (ev : _) = do - case ev of - ChildStop _ e -> maybe undefined throwM e - ChildStopChannel -> undefined - ChildYield b -> return (Just b) - -{-# INLINE isBufferAvailable #-} -isBufferAvailable :: MonadIO m => Channel m a b -> m Bool -isBufferAvailable sv = do - let limit = maxBufferLimit sv - case limit of - Unlimited -> return True - Limited lim -> do - (_, n) <- liftIO $ readIORef (outputQueue sv) - return $ fromIntegral lim > n - --- | Push values from a driver to a fold worker via a Channel. Before pushing a --- value to the Channel it polls for events received from the fold worker. If a --- stop event is received then it returns 'True' otherwise false. Propagates --- exceptions received from the fold wroker. --- -{-# INLINE sendToWorker #-} -sendToWorker :: MonadAsync m => Channel m a b -> a -> m (Maybe b) -sendToWorker chan a = go - - where - - -- Recursive function, should we use SPEC? - go = do - let qref = outputQueueFromConsumer chan - status <- do - (_, n) <- liftIO $ readIORef qref - if n > 0 - then checkFoldStatus chan - else return Nothing - case status of - Just _ -> return status - Nothing -> do - r <- isBufferAvailable chan - if r - then do - liftIO - $ void - $ sendWithDoorBell - (outputQueue chan) - (outputDoorBell chan) - (ChildYield a) - return Nothing - else do - () <- liftIO $ takeMVar (bufferSpaceDoorBell chan) - go diff --git a/src/Streamly/Internal/Data/Fold/Prelude.hs b/src/Streamly/Internal/Data/Fold/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Fold/Prelude.hs @@ -0,0 +1,27 @@ +{-# OPTIONS_GHC -Wno-deprecations #-} + +-- | +-- Module : Streamly.Internal.Data.Fold.Prelude +-- Copyright : (c) 2022 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +module Streamly.Internal.Data.Fold.Prelude + ( + -- * Channel + module Streamly.Internal.Data.Fold.Channel + -- * Concurrency + , module Streamly.Internal.Data.Fold.Concurrent + -- * Time + , module Streamly.Internal.Data.Fold.Time + -- * Deprecated + , module Streamly.Internal.Data.Fold.SVar + ) +where + +import Streamly.Internal.Data.Fold.Channel +import Streamly.Internal.Data.Fold.Concurrent +import Streamly.Internal.Data.Fold.SVar +import Streamly.Internal.Data.Fold.Time diff --git a/src/Streamly/Internal/Data/Fold/SVar.hs b/src/Streamly/Internal/Data/Fold/SVar.hs --- a/src/Streamly/Internal/Data/Fold/SVar.hs +++ b/src/Streamly/Internal/Data/Fold/SVar.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-deprecations #-} -- | -- Module : Streamly.Internal.Data.Fold.SVar -- Copyright : (c) 2017 Composewell Technologies @@ -8,6 +9,7 @@ -- -- module Streamly.Internal.Data.Fold.SVar + {-# DEPRECATED "The functionality is moved to Fold.Concurrent" #-} ( write , writeLimited @@ -18,9 +20,9 @@ import Control.Monad (void) import Control.Monad.IO.Class (MonadIO(liftIO)) -import Streamly.Internal.Data.Fold.Type (Fold(..)) +import Streamly.Internal.Data.Fold (Fold(..)) -import qualified Streamly.Internal.Data.Fold.Type as FL (Step(Done, Partial)) +import qualified Streamly.Internal.Data.Fold as FL (Step(Done, Partial)) import Streamly.Internal.Data.SVar @@ -33,7 +35,7 @@ -- {-# INLINE write #-} write :: MonadIO m => SVar t m a -> Maybe WorkerInfo -> Fold m a () -write svar winfo = Fold step initial extract +write svar winfo = Fold step initial return final where @@ -47,14 +49,14 @@ void $ send svar (ChildYield x) return $ FL.Partial () - extract () = liftIO $ sendStop svar winfo + final () = liftIO $ sendStop svar winfo -- | Like write, but applies a yield limit. -- {-# INLINE writeLimited #-} writeLimited :: MonadIO m => SVar t m a -> Maybe WorkerInfo -> Fold m a () -writeLimited svar winfo = Fold step initial extract +writeLimited svar winfo = Fold step initial (const (return ())) final where @@ -74,5 +76,5 @@ return $ FL.Done () step False _ = return $ FL.Done () - extract True = liftIO $ sendStop svar winfo - extract False = return () + final True = liftIO $ sendStop svar winfo + final False = return () diff --git a/src/Streamly/Internal/Data/Fold/Time.hs b/src/Streamly/Internal/Data/Fold/Time.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Fold/Time.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : Streamly.Internal.Data.Fold.Time +-- Copyright : (c) 2019 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +module Streamly.Internal.Data.Fold.Time + ( + takeInterval + , intervalsOf + ) +where + +import Control.Concurrent (threadDelay, forkIO, killThread) +import Control.Concurrent.MVar (MVar, newMVar, swapMVar, readMVar) +import Control.Exception (SomeException(..), catch, mask) +import Control.Monad (void) +import Control.Monad.IO.Class (MonadIO(..)) +import Streamly.Data.Fold (many) +import Streamly.Internal.Data.Fold (Fold(..), Step (..)) +import Streamly.Internal.Control.Concurrent (MonadAsync, withRunInIO) +import Streamly.Internal.Data.Tuple.Strict (Tuple3'(..)) + +#include "DocTestDataFold.hs" + +-- XXX We can use asyncClock here. A parser can be used to return an input that +-- arrives after the timeout. +-- XXX If n is 0 return immediately in initial. +-- XXX we should probably discard the input received after the timeout like +-- takeEndBy_. + +-- XXX The foldMany doctest is important for consistency with the "many" fold, +-- and intervalsOf. We should put it in tests. + +-- | @takeInterval n fold@ uses @fold@ to fold the input items arriving within +-- a window of first @n@ seconds. +-- +-- >>> input = Stream.delay 0.2 $ Stream.fromList [1..10] +-- >>> Stream.fold (Fold.takeInterval 1.0 Fold.toList) input +-- [1,2,3,4,5,6] +-- +-- >>> f = Fold.takeInterval 0.5 Fold.toList +-- >>> Stream.fold Fold.toList $ Stream.foldMany f input +-- [[1,2,3,4],[5,6,7],[8,9,10]] +-- +-- Stops when @fold@ stops or when the timeout occurs. Note that the fold needs +-- an input after the timeout to stop. For example, if no input is pushed to +-- the fold until one hour after the timeout had occurred, then the fold will +-- be done only after consuming that input. +-- +-- /Pre-release/ +-- +{-# INLINE takeInterval #-} +takeInterval :: MonadAsync m => Double -> Fold m a b -> Fold m a b +takeInterval n (Fold step initial done final) = + Fold step' initial' done' final' + + where + + initial' = do + res <- initial + case res of + Partial s -> do + mv <- liftIO $ newMVar False + t <- + withRunInIO $ \run -> + mask $ \restore -> do + tid <- + forkIO + $ catch + (restore $ void $ run (timerThread mv)) + (handleChildException mv) + run (return tid) + return $ Partial $ Tuple3' s mv t + Done b -> return $ Done b + + step' (Tuple3' s mv t) a = do + val <- liftIO $ readMVar mv + if val + then do + res <- step s a + case res of + Partial sres -> Done <$> final sres + Done bres -> return $ Done bres + else do + res <- step s a + case res of + Partial fs -> return $ Partial $ Tuple3' fs mv t + Done b -> liftIO (killThread t) >> return (Done b) + + done' (Tuple3' s _ _) = done s + + final' (Tuple3' s _ _) = final s + + timerThread mv = do + liftIO $ threadDelay (round $ n * 1000000) + -- Use IORef + CAS? instead of MVar since its a Bool? + liftIO $ void $ swapMVar mv True + + handleChildException :: MVar Bool -> SomeException -> IO () + handleChildException mv _ = void $ swapMVar mv True + +-- 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. + +-- XXX This needs to be fixed like intervalsOf in Data.Stream.Time. + +-- | Group the input stream into windows of n second each using the first fold +-- and then fold the resulting groups using the second fold. +-- +-- >>> intervals = Fold.intervalsOf 0.5 Fold.toList Fold.toList +-- >>> Stream.fold intervals $ Stream.delay 0.2 $ Stream.fromList [1..10] +-- [[1,2,3,4],[5,6,7],[8,9,10]] +-- +-- > intervalsOf n split = many (takeInterval n split) +-- +-- /Pre-release/ +-- +{-# INLINE intervalsOf #-} +intervalsOf :: MonadAsync m => Double -> Fold m a b -> Fold m b c -> Fold m a c +intervalsOf n split = many (takeInterval n split) diff --git a/src/Streamly/Internal/Data/IsMap/HashMap.hs b/src/Streamly/Internal/Data/IsMap/HashMap.hs --- a/src/Streamly/Internal/Data/IsMap/HashMap.hs +++ b/src/Streamly/Internal/Data/IsMap/HashMap.hs @@ -1,3 +1,8 @@ +{-# LANGUAGE TypeFamilies #-} +-- Must come after TypeFamilies, otherwise it is re-enabled. +-- MonoLocalBinds enabled by TypeFamilies causes perf regressions in general. +{-# LANGUAGE NoMonoLocalBinds #-} + {-# OPTIONS_GHC -Wno-orphans #-} -- | @@ -20,7 +25,11 @@ import qualified Data.HashMap.Strict as HashMap +#if MIN_VERSION_hashable(1,4,0) +instance (Hashable k) => IsMap (HashMap.HashMap k) where +#else instance (Hashable k, Eq k) => IsMap (HashMap.HashMap k) where +#endif type Key (HashMap.HashMap k) = k mapEmpty = HashMap.empty @@ -30,3 +39,4 @@ mapDelete = HashMap.delete mapUnion = HashMap.union mapNull = HashMap.null + mapTraverseWithKey = HashMap.traverseWithKey diff --git a/src/Streamly/Internal/Data/SVar.hs b/src/Streamly/Internal/Data/SVar.hs --- a/src/Streamly/Internal/Data/SVar.hs +++ b/src/Streamly/Internal/Data/SVar.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-deprecations #-} + -- | -- Module : Streamly.Internal.Data.SVar -- Copyright : (c) 2017 Composewell Technologies @@ -8,6 +10,7 @@ -- -- module Streamly.Internal.Data.SVar + {-# DEPRECATED "SVar is replaced by Channel." #-} ( module Streamly.Internal.Data.SVar.Type , module Streamly.Internal.Data.SVar.Worker diff --git a/src/Streamly/Internal/Data/SVar/Dispatch.hs b/src/Streamly/Internal/Data/SVar/Dispatch.hs --- a/src/Streamly/Internal/Data/SVar/Dispatch.hs +++ b/src/Streamly/Internal/Data/SVar/Dispatch.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-deprecations #-} + -- | -- Module : Streamly.Internal.Data.SVar.Dispatch -- Copyright : (c) 2017 Composewell Technologies @@ -8,6 +10,7 @@ -- -- module Streamly.Internal.Data.SVar.Dispatch + {-# DEPRECATED "The functionality is moved to Channel.*" #-} ( -- * Latency collection collectLatency diff --git a/src/Streamly/Internal/Data/SVar/Pull.hs b/src/Streamly/Internal/Data/SVar/Pull.hs --- a/src/Streamly/Internal/Data/SVar/Pull.hs +++ b/src/Streamly/Internal/Data/SVar/Pull.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-deprecations #-} + -- | -- Module : Streamly.Internal.Data.SVar.Pull -- Copyright : (c) 2017 Composewell Technologies @@ -8,6 +10,7 @@ -- -- module Streamly.Internal.Data.SVar.Pull + {-# DEPRECATED "The functionality is moved to Channel.*" #-} ( -- * Read Output readOutputQBasic diff --git a/src/Streamly/Internal/Data/SVar/Worker.hs b/src/Streamly/Internal/Data/SVar/Worker.hs --- a/src/Streamly/Internal/Data/SVar/Worker.hs +++ b/src/Streamly/Internal/Data/SVar/Worker.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-deprecations #-} + -- | -- Module : Streamly.Internal.Data.SVar.Worker -- Copyright : (c) 2017 Composewell Technologies @@ -8,6 +10,7 @@ -- -- module Streamly.Internal.Data.SVar.Worker + {-# DEPRECATED "The functionality is moved to Channel.*" #-} ( -- * Adjusting Limits decrementYieldLimit diff --git a/src/Streamly/Internal/Data/Scanl/Concurrent.hs b/src/Streamly/Internal/Data/Scanl/Concurrent.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Scanl/Concurrent.hs @@ -0,0 +1,425 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : Streamly.Internal.Data.Scanl.Concurrent +-- Copyright : (c) 2024 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +module Streamly.Internal.Data.Scanl.Concurrent + ( + parTeeWith + , parDistributeScanM + , parDistributeScan + , parDemuxScanM + , parDemuxScan + ) +where + +#include "inline.hs" + +import Control.Concurrent (newEmptyMVar, takeMVar, throwTo) +import Control.Monad.Catch (throwM) +import Control.Monad.IO.Class (MonadIO(liftIO)) +import Data.IORef (newIORef, readIORef, atomicModifyIORef) +import Fusion.Plugin.Types (Fuse(..)) +import Streamly.Internal.Control.Concurrent (MonadAsync) +import Streamly.Internal.Data.Atomics (atomicModifyIORefCAS) +import Streamly.Internal.Data.Fold (Step (..)) +import Streamly.Internal.Data.Scanl (Scanl(..)) +import Streamly.Internal.Data.Stream (Stream(..), Step(..)) +import Streamly.Internal.Data.SVar.Type (adaptState) +import Streamly.Internal.Data.Tuple.Strict (Tuple3'(..)) + +import qualified Data.Map.Strict as Map +import qualified Streamly.Internal.Data.Stream as Stream + +import Streamly.Internal.Data.Fold.Channel.Type +import Streamly.Internal.Data.Channel.Types + +#include "DocTestDataScanl.hs" + +------------------------------------------------------------------------------- +-- Concurrent scans +------------------------------------------------------------------------------- + +-- | Execute both the scans in a tee concurrently. +-- +-- Example: +-- +-- >>> src = Stream.delay 1 (Stream.enumerateFromTo 1 3) +-- >>> delay x = threadDelay 1000000 >> print x >> return x +-- >>> c1 = Scanl.lmapM delay Scanl.sum +-- >>> c2 = Scanl.lmapM delay Scanl.length +-- >>> dst = Scanl.parTeeWith id (,) c1 c2 +-- >>> Stream.toList $ Stream.scanl dst src +-- ... +-- +{-# INLINABLE parTeeWith #-} +parTeeWith :: MonadAsync m => + (Config -> Config) + -> (a -> b -> c) + -> Scanl m x a + -> Scanl m x b + -> Scanl m x c +parTeeWith cfg f c1 c2 = Scanl step initial extract final + + where + + getResponse ch1 ch2 = do + -- NOTE: We do not need a queue and doorbell mechanism for this, a single + -- MVar should be enough. Also, there is only one writer and it writes + -- only once before we read it. + let db1 = outputDoorBell ch1 + let q1 = outputQueue ch1 + (xs1, _) <- liftIO $ atomicModifyIORefCAS q1 $ \x -> (([],0), x) + case xs1 of + [] -> do + liftIO $ takeMVar db1 + getResponse ch1 ch2 + x1 : [] -> do + case x1 of + FoldException _tid ex -> do + -- XXX + -- liftIO $ throwTo ch2Tid ThreadAbort + cleanup ch1 + cleanup ch2 + liftIO $ throwM ex + FoldDone _tid b -> return (Left b) + FoldPartial b -> return (Right b) + FoldEOF _ -> error "parTeeWith: FoldEOF cannot occur here" + _ -> error "parTeeWith: not expecting more than one msg in q" + + processResponses ch1 ch2 r1 r2 = + return $ case r1 of + Left b1 -> do + case r2 of + Left b2 -> Done (f b1 b2) + Right b2 -> Done (f b1 b2) + Right b1 -> do + case r2 of + Left b2 -> Done (f b1 b2) + Right b2 -> Partial $ Tuple3' ch1 ch2 (f b1 b2) + + initial = do + ch1 <- newScanChannel cfg c1 + ch2 <- newScanChannel cfg c2 + r1 <- getResponse ch1 ch2 + r2 <- getResponse ch2 ch1 + processResponses ch1 ch2 r1 r2 + + step (Tuple3' ch1 ch2 _) x = do + sendToWorker_ ch1 x + sendToWorker_ ch2 x + r1 <- getResponse ch1 ch2 + r2 <- getResponse ch2 ch1 + processResponses ch1 ch2 r1 r2 + + extract (Tuple3' _ _ x) = return x + + final (Tuple3' ch1 ch2 x) = do + finalize ch1 + finalize ch2 + -- XXX generate the final value? + return x + +-- There are two ways to implement a concurrent scan. +-- +-- 1. Make the scan itself asynchronous, add the input to the queue, and then +-- extract the output. Extraction will have to be asynchronous, which will +-- require changes to the scan driver. This will require a different Scanl +-- type. +-- +-- 2. A monolithic implementation of concurrent Stream->Stream scan, using a +-- custom implementation of the scan and the driver. + +{-# ANN type ScanState Fuse #-} +data ScanState s q db f = + ScanInit + | ScanGo s q db [f] + | ScanDrain q db [f] + | ScanStop + +-- XXX return [b] or just b? +-- XXX We can use a one way mailbox type abstraction instead of using an IORef +-- for adding new folds dynamically. + +-- | Evaluate a stream by distributing its inputs across zero or more +-- concurrently running scans. New scans can be generated dynamically. Use +-- 'parDistributeScan' for an eaiser to use interface, if you do not need the +-- power of 'parDistributeScanM'. +-- +-- Before processing each input element, the supplied action is executed to +-- produce additional scans. These scans are appended to the set of currently +-- active scans. If you do not want the same scan to be added repeatedly, +-- ensure that the action only generates it once (see the example below). +-- +-- If there are no scans currently active, the input element is discarded. +-- The results from all active scans are collected and lattened into the +-- the output stream. +-- +-- Concurrency and buffering: +-- +-- If the input buffer (see 'maxBuffer') is bounded, a scan may block until +-- space becomes available. If any scan is blocked on buffer, all scans are +-- blocked. Processing continues only when all scans have buffer space +-- available. +-- +-- Example: +-- +-- >>> import Data.IORef +-- >>> ref <- newIORef [Scanl.take 5 Scanl.sum, Scanl.take 5 Scanl.length :: Scanl.Scanl IO Int Int] +-- >>> gen = atomicModifyIORef ref (\xs -> ([], xs)) +-- >>> Stream.toList $ Scanl.parDistributeScanM id gen (Stream.enumerateFromTo 1 10) +-- ... +-- +{-# INLINE parDistributeScanM #-} +parDistributeScanM :: MonadAsync m => + (Config -> Config) -> m [Scanl m a b] -> Stream m a -> Stream m [b] +parDistributeScanM cfg getFolds (Stream sstep state) = + Stream step ScanInit + + where + + -- XXX can be written as a fold + processOutputs chans events done = do + case events of + [] -> return (chans, done) + (x:xs) -> + case x of + FoldException _tid ex -> do + -- XXX report the fold that threw the exception + liftIO $ mapM_ (`throwTo` ThreadAbort) (fmap snd chans) + mapM_ cleanup (fmap fst chans) + liftIO $ throwM ex + FoldDone tid b -> + let ch = filter (\(_, t) -> t /= tid) chans + in processOutputs ch xs (b:done) + FoldEOF tid -> do + let ch = filter (\(_, t) -> t /= tid) chans + in processOutputs ch xs done + FoldPartial b -> + processOutputs chans xs (b:done) + + collectOutputs qref chans = do + (_, n) <- liftIO $ readIORef qref + if n > 0 + then do + r <- fmap fst $ liftIO $ readOutputQBasic qref + processOutputs chans r [] + else return (chans, []) + + step _ ScanInit = do + q <- liftIO $ newIORef ([], 0) + db <- liftIO newEmptyMVar + return $ Skip (ScanGo state q db []) + + step gst (ScanGo st q db chans) = do + -- merge any new channels added since last input + fxs <- getFolds + newChans <- Prelude.mapM (newChannelWithScan q db cfg) fxs + let allChans = chans ++ newChans + + -- Collect outputs from running channels + (running, outputs) <- collectOutputs q allChans + + -- Send input to running folds + res <- sstep (adaptState gst) st + next <- case res of + Yield x s -> do + -- XXX The blocking will delay the processing of outputs. + -- Should we yield the outputs before blocking? + Prelude.mapM_ (`sendToWorker_` x) (fmap fst running) + return $ ScanGo s q db running + Skip s -> do + return $ ScanGo s q db running + Stop -> do + Prelude.mapM_ finalize (fmap fst running) + return $ ScanDrain q db running + if null outputs + then return $ Skip next + else return $ Yield outputs next + step _ (ScanDrain q db chans) = do + (running, outputs) <- collectOutputs q chans + case running of + [] -> return $ Yield outputs ScanStop + _ -> do + if null outputs + then do + liftIO $ takeMVar db + return $ Skip (ScanDrain q db running) + else return $ Yield outputs (ScanDrain q db running) + step _ ScanStop = return Stop + +-- | A pure variant of 'parDistributeScanM' that uses a fixed list of scans. +-- +-- The provided scans are started once and run concurrently for the duration +-- of the stream. Each input element is distributed to all active scans, and +-- their outputs are collected and emitted together. +-- +-- Example: +-- +-- >>> xs = [Scanl.take 5 Scanl.sum, Scanl.take 5 Scanl.length :: Scanl.Scanl IO Int Int] +-- >>> Stream.toList $ Scanl.parDistributeScan id xs (Stream.enumerateFromTo 1 10) +-- ... +{-# INLINE parDistributeScan #-} +parDistributeScan :: MonadAsync m => + (Config -> Config) -> [Scanl m a b] -> Stream m a -> Stream m [b] +parDistributeScan cfg getFolds stream = + Stream.concatEffect $ do + ref <- liftIO $ newIORef getFolds + let action = liftIO $ atomicModifyIORef ref (\xs -> ([], xs)) + return $ parDistributeScanM cfg action stream + +{-# ANN type DemuxState Fuse #-} +data DemuxState s q db f = + DemuxInit + | DemuxGo s q db f + | DemuxDrain q db f + | DemuxStop + +-- XXX We need to either (1) remember a key when done so that we do not add the +-- fold again because some inputs would be lost in between, or (2) have a +-- FoldYield constructor to yield repeatedly so that we can restart the +-- existing fold itself when it is done. But in that case we cannot change the +-- fold once it is started. Also the Map would keep on increasing in size as we +-- never delete a key. Whatever we do we should keep the non-concurrent fold as +-- well consistent with that. + +-- | Evaluate a stream by routing each input to a scan determined by a key. +-- +-- For each distinct key, the first input encountered triggers the creation +-- of a new scan (via the supplied key-to-scan function). This scan is then +-- added to the set of currently active scans. Subsequent inputs with the +-- same key are directed to the same scan. +-- +-- If no scan can be created for a key, the input element is discarded. +-- +-- When a constituent scan completes, its final output is emitted as part of +-- the composed output stream. The output of 'parDemuxScanM' is a stream of +-- key–value pairs, where each value is the output produced by the scan +-- corresponding to that key. +-- +-- For a simpler interface, use 'parDemuxScan' if you do not need the full +-- flexibility of 'parDemuxScanM'. +-- +-- Example: +-- +-- >>> import qualified Data.Map.Strict as Map +-- >>> import Data.Maybe (fromJust) +-- >>> f1 = ("even", Scanl.take 5 Scanl.sum) +-- >>> f2 = ("odd", Scanl.take 5 Scanl.sum) +-- >>> kv = Map.fromList [f1, f2] +-- >>> getScan k = return (fromJust $ Map.lookup k kv) +-- >>> getKey x = if even x then "even" else "odd" +-- >>> input = Stream.enumerateFromTo 1 10 +-- >>> Stream.toList $ Scanl.parDemuxScanM id getKey getScan input +-- ... +-- +{-# INLINE parDemuxScanM #-} +parDemuxScanM :: (MonadAsync m, Ord k) => + (Config -> Config) + -> (a -> k) + -> (k -> m (Scanl m a b)) + -> Stream m a + -> Stream m [(k, b)] +parDemuxScanM cfg getKey getFold (Stream sstep state) = + Stream step DemuxInit + + where + + -- XXX can be written as a fold + processOutputs keyToChan events done = do + case events of + [] -> return (keyToChan, done) + (x:xs) -> + case x of + FoldException _tid ex -> do + -- XXX report the fold that threw the exception + let chans = fmap snd $ Map.toList keyToChan + liftIO $ mapM_ (`throwTo` ThreadAbort) (fmap snd chans) + mapM_ cleanup (fmap fst chans) + liftIO $ throwM ex + FoldDone _tid o@(k, _) -> + let ch = Map.delete k keyToChan + in processOutputs ch xs (o:done) + FoldEOF tid -> + let chans = Map.toList keyToChan + ch = filter (\(_, (_, t)) -> t /= tid) chans + in processOutputs (Map.fromList ch) xs done + FoldPartial b -> + processOutputs keyToChan xs (b:done) + + collectOutputs qref keyToChan = do + (_, n) <- liftIO $ readIORef qref + if n > 0 + then do + r <- fmap fst $ liftIO $ readOutputQBasic qref + processOutputs keyToChan r [] + else return (keyToChan, []) + + step _ DemuxInit = do + q <- liftIO $ newIORef ([], 0) + db <- liftIO newEmptyMVar + return $ Skip (DemuxGo state q db Map.empty) + + step gst (DemuxGo st q db keyToChan) = do + -- Collect outputs from running channels + (keyToChan1, outputs) <- collectOutputs q keyToChan + + -- Send input to the selected fold + res <- sstep (adaptState gst) st + + next <- case res of + Yield x s -> do + -- XXX If the fold for a particular key is done and we see that + -- key again. If we have not yet collected the done event we + -- cannot restart the fold because the previous key is already + -- installed. Thererfore, restarting the fold for the same key + -- fraught with races. + let k = getKey x + (keyToChan2, ch) <- + case Map.lookup k keyToChan1 of + Nothing -> do + fld <- getFold k + r@(chan, _) <- newChannelWithScan q db cfg (fmap (k,) fld) + return (Map.insert k r keyToChan1, chan) + Just (chan, _) -> return (keyToChan1, chan) + sendToWorker_ ch x + return $ DemuxGo s q db keyToChan2 + Skip s -> + return $ DemuxGo s q db keyToChan1 + Stop -> do + let chans = fmap (fst . snd) $ Map.toList keyToChan1 + Prelude.mapM_ finalize chans + return $ DemuxDrain q db keyToChan1 + if null outputs + then return $ Skip next + else return $ Yield outputs next + step _ (DemuxDrain q db keyToChan) = do + (keyToChan1, outputs) <- collectOutputs q keyToChan + if Map.null keyToChan1 + -- XXX null outputs case + then return $ Yield outputs DemuxStop + else do + if null outputs + then do + liftIO $ takeMVar db + return $ Skip (DemuxDrain q db keyToChan1) + else return $ Yield outputs (DemuxDrain q db keyToChan1) + step _ DemuxStop = return Stop + +-- | A pure variant of 'parDemuxScanM' where the key-to-scan mapping is +-- static and does not require monadic effects. +-- +-- Each distinct key is deterministically mapped to a scan using the provided +-- function. The behavior is otherwise the same as 'parDemuxScanM'. +{-# INLINE parDemuxScan #-} +parDemuxScan :: (MonadAsync m, Ord k) => + (Config -> Config) + -> (a -> k) + -> (k -> Scanl m a b) + -> Stream m a + -> Stream m [(k, b)] +parDemuxScan cfg getKey getFold = parDemuxScanM cfg getKey (pure . getFold) diff --git a/src/Streamly/Internal/Data/Scanl/Prelude.hs b/src/Streamly/Internal/Data/Scanl/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Scanl/Prelude.hs @@ -0,0 +1,19 @@ +-- | +-- Module : Streamly.Internal.Data.Scanl.Prelude +-- Copyright : (c) 2022 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +module Streamly.Internal.Data.Scanl.Prelude + ( + -- * Channel + module Streamly.Internal.Data.Fold.Channel + -- * Concurrency + , module Streamly.Internal.Data.Scanl.Concurrent + ) +where + +import Streamly.Internal.Data.Fold.Channel +import Streamly.Internal.Data.Scanl.Concurrent diff --git a/src/Streamly/Internal/Data/SmallArray.hs b/src/Streamly/Internal/Data/SmallArray.hs --- a/src/Streamly/Internal/Data/SmallArray.hs +++ b/src/Streamly/Internal/Data/SmallArray.hs @@ -51,10 +51,10 @@ import Streamly.Data.Fold (Fold) import Streamly.Data.Stream (Stream) import Streamly.Internal.Data.Tuple.Strict (Tuple'(..)) -import Streamly.Internal.Data.Unfold.Type (Unfold(..)) +import Streamly.Internal.Data.Unfold (Unfold(..)) -import qualified Streamly.Internal.Data.Stream.StreamD as D -import qualified Streamly.Internal.Data.Fold.Type as FL +import qualified Streamly.Internal.Data.Stream as D +import qualified Streamly.Internal.Data.Fold as FL (Fold (..), Step (Done, Partial)) import Streamly.Internal.Data.SmallArray.Type @@ -106,7 +106,7 @@ -- of elements use an 'Array' from either "Streamly.Data.Array.Generic" or "Streamly.Data.Array.Foreign". {-# INLINE_NORMAL writeN #-} writeN :: MonadIO m => Int -> Fold m a (SmallArray a) -writeN len = FL.Fold step initial extract +writeN len = FL.Fold step initial extract extract where diff --git a/src/Streamly/Internal/Data/SmallArray/Type.hs b/src/Streamly/Internal/Data/SmallArray/Type.hs --- a/src/Streamly/Internal/Data/SmallArray/Type.hs +++ b/src/Streamly/Internal/Data/SmallArray/Type.hs @@ -1,4 +1,6 @@ {-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoMonoLocalBinds #-} -- | -- Module : Data.Primitive.SmallArray diff --git a/src/Streamly/Internal/Data/Stream/Ahead.hs b/src/Streamly/Internal/Data/Stream/Ahead.hs --- a/src/Streamly/Internal/Data/Stream/Ahead.hs +++ b/src/Streamly/Internal/Data/Stream/Ahead.hs @@ -1,5 +1,6 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- | -- Module : Streamly.Internal.Data.Stream.Ahead @@ -33,13 +34,17 @@ import Control.Concurrent.MVar (putMVar, takeMVar) import Control.Exception (assert) import Control.Monad (void, when) +#if !(MIN_VERSION_transformers(0,6,0)) import Control.Monad.Base (MonadBase(..), liftBaseDefault) +#endif import Control.Monad.Catch (MonadThrow, throwM) -- import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Reader.Class (MonadReader(..)) import Control.Monad.State.Class (MonadState(..)) +#if !(MIN_VERSION_transformers(0,6,0)) import Control.Monad.Trans.Class (MonadTrans(lift)) +#endif import Data.Heap (Heap, Entry(..)) import Data.IORef (IORef, readIORef, atomicModifyIORef, writeIORef) import Data.Maybe (fromJust) @@ -49,12 +54,12 @@ import Streamly.Internal.Control.Concurrent (MonadRunInIO, MonadAsync, askRunInIO, restoreM) -import Streamly.Internal.Data.Stream.StreamK.Type (Stream) +import Streamly.Internal.Data.StreamK (Stream) -import qualified Streamly.Internal.Data.Stream.StreamK.Type as K +import qualified Streamly.Internal.Data.StreamK as K (foldStreamShared, cons, mkStream, foldStream, fromEffect , nil, concatMapWith, fromPure, bindWith) -import qualified Streamly.Internal.Data.Stream.StreamD.Type as D +import qualified Streamly.Internal.Data.Stream as D (mapM, fromStreamK, toStreamK) import qualified Streamly.Internal.Data.Stream.Serial as Stream (toStreamK) @@ -692,9 +697,11 @@ -- @since 0.8.0 newtype AheadT m a = AheadT {getAheadT :: Stream m a} +#if !(MIN_VERSION_transformers(0,6,0)) instance MonadTrans AheadT where {-# INLINE lift #-} lift = AheadT . K.fromEffect +#endif -- | A serial IO stream of elements of type @a@ with concurrent lookahead. See -- 'AheadT' documentation for more details. @@ -760,5 +767,10 @@ ------------------------------------------------------------------------------ -- Other instances ------------------------------------------------------------------------------ + +#if !(MIN_VERSION_transformers(0,6,0)) +instance (MonadBase b m, Monad m, MonadAsync m) => MonadBase b (AheadT m) where + liftBase = liftBaseDefault +#endif MONAD_COMMON_INSTANCES(AheadT, MONADPARALLEL) diff --git a/src/Streamly/Internal/Data/Stream/Async.hs b/src/Streamly/Internal/Data/Stream/Async.hs --- a/src/Streamly/Internal/Data/Stream/Async.hs +++ b/src/Streamly/Internal/Data/Stream/Async.hs @@ -1,5 +1,6 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} #include "inline.hs" @@ -40,14 +41,18 @@ where import Control.Concurrent (myThreadId) +#if !(MIN_VERSION_transformers(0,6,0)) import Control.Monad.Base (MonadBase(..), liftBaseDefault) +#endif import Control.Monad.Catch (MonadThrow, throwM) import Control.Concurrent.MVar (newEmptyMVar) -- import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Reader.Class (MonadReader(..)) import Control.Monad.State.Class (MonadState(..)) +#if !(MIN_VERSION_transformers(0,6,0)) import Control.Monad.Trans.Class (MonadTrans(lift)) +#endif import Data.Concurrent.Queue.MichaelScott (LinkedQueue, newQ, nullQ, tryPopR, pushL) import Data.IORef (IORef, newIORef, readIORef) import Data.Maybe (fromJust) @@ -59,13 +64,13 @@ (MonadRunInIO, MonadAsync, askRunInIO, restoreM) import Streamly.Internal.Data.Atomics (atomicModifyIORefCAS, atomicModifyIORefCAS_) -import Streamly.Internal.Data.Stream.StreamK.Type (Stream) +import Streamly.Internal.Data.StreamK (Stream) import Streamly.Internal.Data.Stream.SVar.Generate (fromSVar, fromSVarD) -import qualified Streamly.Internal.Data.Stream.StreamK.Type as K +import qualified Streamly.Internal.Data.StreamK as K (foldStreamShared, mkStream, foldStream, fromEffect , nil, concatMapWith, fromPure, bindWith) -import qualified Streamly.Internal.Data.Stream.StreamD.Type as D +import qualified Streamly.Internal.Data.Stream as D (Stream(..), Step(..), mapM, toStreamK, fromStreamK) import qualified Streamly.Internal.Data.Stream.Serial as Stream (toStreamK) @@ -744,9 +749,11 @@ -- @since 0.8.0 newtype AsyncT m a = AsyncT {getAsyncT :: Stream m a} +#if !(MIN_VERSION_transformers(0,6,0)) instance MonadTrans AsyncT where {-# INLINE lift #-} lift = AsyncT . K.fromEffect +#endif -- | A demand driven left biased parallely composing IO stream of elements of -- type @a@. See 'AsyncT' documentation for more details. @@ -818,6 +825,11 @@ -- Other instances ------------------------------------------------------------------------------ +#if !(MIN_VERSION_transformers(0,6,0)) +instance (MonadBase b m, Monad m, MonadAsync m) => MonadBase b (AsyncT m) where + liftBase = liftBaseDefault +#endif + MONAD_COMMON_INSTANCES(AsyncT, MONADPARALLEL) ------------------------------------------------------------------------------ @@ -970,9 +982,11 @@ -- newtype WAsyncT m a = WAsyncT {getWAsyncT :: Stream m a} +#if !(MIN_VERSION_transformers(0,6,0)) instance MonadTrans WAsyncT where {-# INLINE lift #-} lift = WAsyncT . K.fromEffect +#endif -- | A round robin parallely composing IO stream of elements of type @a@. -- See 'WAsyncT' documentation for more details. @@ -1041,5 +1055,10 @@ ------------------------------------------------------------------------------ -- Other instances ------------------------------------------------------------------------------ + +#if !(MIN_VERSION_transformers(0,6,0)) +instance (MonadBase b m, Monad m, MonadAsync m) => MonadBase b (WAsyncT m) where + liftBase = liftBaseDefault +#endif MONAD_COMMON_INSTANCES(WAsyncT, MONADPARALLEL) diff --git a/src/Streamly/Internal/Data/Stream/Channel.hs b/src/Streamly/Internal/Data/Stream/Channel.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/Channel.hs @@ -0,0 +1,213 @@ +-- | +-- Module : Streamly.Internal.Data.Stream.Channel +-- Copyright : (c) 2017 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +module Streamly.Internal.Data.Stream.Channel + ( + module Streamly.Internal.Data.Stream.Channel.Type + + -- ** Allocation + , module Streamly.Internal.Data.Stream.Channel.Append + , module Streamly.Internal.Data.Stream.Channel.Interleave + , newChannel + + -- ** Event Processing Loop + , module Streamly.Internal.Data.Stream.Channel.Dispatcher + , module Streamly.Internal.Data.Stream.Channel.Consumer + , module Streamly.Internal.Data.Stream.Channel.Operations + , chanConcatMapK + + -- ** Evaluation + , withChannelK + , withChannel + -- quiesceChannel -- wait for running tasks but do not schedule any more. + ) +where + +import Streamly.Internal.Control.Concurrent (MonadAsync) +import Control.Monad.IO.Class (MonadIO(liftIO)) +import Streamly.Internal.Data.Stream (Stream) +import Streamly.Internal.Control.Concurrent (askRunInIO) +import Streamly.Internal.Data.SVar.Type (adaptState) + +import qualified Streamly.Internal.Data.StreamK as K + +import Streamly.Internal.Data.Channel.Types +import Streamly.Internal.Data.Stream.Channel.Type +import Streamly.Internal.Data.Stream.Channel.Operations +import Streamly.Internal.Data.Stream.Channel.Append +import Streamly.Internal.Data.Stream.Channel.Interleave +import Streamly.Internal.Data.Stream.Channel.Dispatcher +import Streamly.Internal.Data.Stream.Channel.Consumer + +------------------------------------------------------------------------------- +-- Channel allocation +------------------------------------------------------------------------------- + +-- | Create a new concurrent stream evaluation channel. The monad +-- state used to run the stream actions is captured from the call site of +-- newChannel. +{-# INLINE newChannel #-} +newChannel :: MonadAsync m => + (Config -> Config) -> m (Channel m a) +newChannel modifier = + let cfg = modifier defaultConfig + in if getInterleaved cfg + then newInterleaveChannel modifier + else newAppendChannel modifier + +-- | Allocate a channel and evaluate the stream concurrently using the channel +-- and the supplied evaluator function. The evaluator is run in a worker +-- thread. +{-# INLINE withChannelK #-} +withChannelK :: MonadAsync m => + (Config -> Config) -- ^ config modifier + -> K.StreamK m a -- ^ input stream + -> (Channel m b -> K.StreamK m a -> K.StreamK m b) -- ^ stream evaluator + -> K.StreamK m b -- ^ output stream +withChannelK modifier input evaluator = K.concatEffect action + + where + + action = do + chan <- newChannel modifier + toChannelK chan (evaluator chan input) + let cfg = modifier defaultConfig + return $ fromChannelK (getCleanup cfg) chan + +-- | A wrapper over 'withChannelK', converts 'Stream' to 'StreamK' and invokes +-- 'withChannelK'. +{-# INLINE withChannel #-} +withChannel :: MonadAsync m => + (Config -> Config) + -> Stream m a + -> (Channel m b -> Stream m a -> Stream m b) + -> Stream m b +withChannel modifier input evaluator = + let f chan stream = K.fromStream $ evaluator chan (K.toStream stream) + in K.toStream $ withChannelK modifier (K.fromStream input) f + +------------------------------------------------------------------------------- +-- Evaluator +------------------------------------------------------------------------------- + +-- | @concatMapHeadK consumeTail mapHead stream@, maps a stream generation +-- function on the head element and performs a side effect on the tail. +-- +-- Used for concurrent evaluation of streams using a Channel. A worker +-- evaluating the stream would queue the tail and go on to evaluate the head. +-- The tail is picked up by another worker which does the same. +{-# INLINE concatMapHeadK #-} +concatMapHeadK :: Monad m => + (K.StreamK m a -> m ()) -- ^ Queue the tail + -> (a -> K.StreamK m b) -- ^ Generate a stream from the head + -> K.StreamK m a + -> K.StreamK m b +concatMapHeadK consumeTail mapHead stream = + K.mkStream $ \st yld sng stp -> do + let foldShared = K.foldStreamShared st yld sng stp + single a = foldShared $ mapHead a + yieldk a r = consumeTail r >> single a + in K.foldStreamShared (adaptState st) yieldk single stp stream + +------------------------------------------------------------------------------- +-- concat streams +------------------------------------------------------------------------------- + +-- | 'mkEnqueue chan f returns a queuing function @enq@. @enq@ takes a +-- @stream@ and enqueues @f enq stream@ on the channel. One example of @f@ is +-- 'concatMapHeadK'. When the enqueued value with 'concatMapHeadK' as @f@ is +-- evaluated, it generates an output stream from the head and enqueues @f enq +-- tail@ on the channel. Thus whenever the enqueued stream is evaluated it +-- generates a stream from the head and queues the tail on the channel. +-- +-- Note that @enq@ and runner are mutually recursive, mkEnqueue ties the +-- knot between the two. +-- +{-# INLINE mkEnqueue #-} +mkEnqueue :: MonadAsync m => + Channel m b + -- | @divider enq stream@ + -> ((K.StreamK m a -> m ()) -> K.StreamK m a -> K.StreamK m b) + -- | Queuing function @enq@ + -> m (K.StreamK m a -> m ()) +mkEnqueue chan runner = do + runInIO <- askRunInIO + return + $ let f stream = do + liftIO $ enqueue chan (runInIO, runner f stream) + -- XXX In case of eager dispatch we can just directly dispatch + -- a worker with the tail stream here rather than first queuing + -- and then dispatching a worker which dequeues the work. The + -- older implementation did a direct dispatch here and its perf + -- characterstics looked much better. + eagerDispatch chan + in f + +{-# INLINE parConcatMapChanKAll #-} +parConcatMapChanKAll :: MonadAsync m => + Channel m b -> (a -> K.StreamK m b) -> K.StreamK m a -> K.StreamK m b +parConcatMapChanKAll chan f stream = + let run q = concatMapHeadK q f + in K.concatMapEffect (`run` stream) (mkEnqueue chan run) + -- K.parConcatMap (_appendWithChanK chan) f stream + +{-# INLINE parConcatMapChanKAny #-} +parConcatMapChanKAny :: MonadAsync m => + Channel m b -> (a -> K.StreamK m b) -> K.StreamK m a -> K.StreamK m b +parConcatMapChanKAny chan f stream = + let done = K.nilM (shutdown chan) + run q = concatMapHeadK q (\x -> K.append (f x) done) + in K.concatMapEffect (`run` stream) (mkEnqueue chan run) + +{-# INLINE parConcatMapChanKFirst #-} +parConcatMapChanKFirst :: MonadAsync m => + Channel m b -> (a -> K.StreamK m b) -> K.StreamK m a -> K.StreamK m b +parConcatMapChanKFirst chan f stream = + let done = K.nilM (shutdown chan) + run q = concatMapHeadK q f + in K.concatEffect $ do + res <- K.uncons stream + case res of + Nothing -> return K.nil + Just (h, t) -> do + q <- mkEnqueue chan run + q t + return $ K.append (f h) done + +-- | Make a concurrent stream evaluator from a stream, to be used in +-- 'withChannelK' or 'toChannelK'. Maps a stream generation function on each +-- element of the stream, the evaluation of the map on each element happens +-- concurrently. All the generated streams are merged together in the output of +-- the channel. The scheduling and termination behavior depends on the channel +-- settings. +-- +-- Note that if you queue a stream on the channel using 'toChannelK', it will +-- be picked up by a worker and the worker would evaluate the entire stream +-- serially and emit the results on the channel. However, if you transform the +-- stream using 'parConcatMapChanK' and queue it on the channel, it +-- parallelizes the function map on each element of the stream. The simplest +-- example is @parConcatMapChanK id id@ which is equivalent to evaluating each +-- element of the stream concurrently. +-- +-- A channel worker evaluating this function would enqueue the tail on the +-- channel's work queue and go on to evaluate the head generating an output +-- stream. The tail is picked up by another worker which does the same and so +-- on. +{-# INLINE chanConcatMapK #-} +chanConcatMapK :: MonadAsync m => + (Config -> Config) + -> Channel m b + -> (a -> K.StreamK m b) + -> K.StreamK m a + -> K.StreamK m b +chanConcatMapK modifier chan f stream = do + let cfg = modifier defaultConfig + case getStopWhen cfg of + AllStop -> parConcatMapChanKAll chan f stream + FirstStops -> parConcatMapChanKFirst chan f stream + AnyStops -> parConcatMapChanKAny chan f stream diff --git a/src/Streamly/Internal/Data/Stream/Channel/Append.hs b/src/Streamly/Internal/Data/Stream/Channel/Append.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/Channel/Append.hs @@ -0,0 +1,1102 @@ +-- | +-- Module : Streamly.Internal.Data.Stream.Channel.Append +-- Copyright : (c) 2017 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- The functions in this module are separated from the combinators using +-- these because of a GHC issue. We need to have newAppendChannel specialized but +-- not inlined. If we keep it in the same module as its users we cannot achieve +-- that and the code becomes bloated. But if it is in a separate module we can +-- use INLINABLE and SPECIALIZE on it which makes it specialized but it is not +-- actually inlined. + +module Streamly.Internal.Data.Stream.Channel.Append + ( + newAppendChannel + ) +where + +import Control.Concurrent (myThreadId) +import Control.Concurrent.MVar (newEmptyMVar, newMVar, putMVar, takeMVar) +import Control.Exception (assert) +import Control.Monad (when, void) +import Control.Monad.IO.Class (MonadIO(liftIO)) +import Data.Heap (Heap, Entry(..)) +import Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef, writeIORef) +import GHC.Exts (inline) +import Streamly.Internal.Control.Concurrent + (MonadRunInIO, RunInIO(..), askRunInIO, restoreM) +import Streamly.Internal.Data.Atomics + (atomicModifyIORefCAS, atomicModifyIORefCAS_) +import Streamly.Internal.Data.Channel.Dispatcher (modifyThread) + +import qualified Data.Heap as H +import qualified Data.Set as Set +import qualified Streamly.Internal.Data.StreamK as K + +import Streamly.Internal.Data.Channel.Types +import Streamly.Internal.Data.Channel.Worker +import Streamly.Internal.Data.Stream.Channel.Consumer +import Streamly.Internal.Data.Stream.Channel.Dispatcher +import Streamly.Internal.Data.Stream.Channel.Type + +------------------------------------------------------------------------------ +-- Concurrent streams with first-come-first serve results +------------------------------------------------------------------------------ + +{-# INLINE enqueueLIFO #-} +enqueueLIFO :: + Channel m a + -> IORef [(RunInIO m, K.StreamK m a)] + -> (RunInIO m, K.StreamK m a) + -> IO () +enqueueLIFO sv q m = do + atomicModifyIORefCAS_ q (m :) + ringDoorBell (doorBellOnWorkQ sv) (outputDoorBell sv) + +{-# INLINE dequeue #-} +dequeue :: MonadIO m => + IORef [(RunInIO m, K.StreamK m a)] + -> m (Maybe (RunInIO m, K.StreamK m a)) +dequeue qref = + liftIO + $ atomicModifyIORefCAS qref + $ \case + (x : xs) -> (xs, Just x) + x -> (x, Nothing) + +data WorkerStatus = Continue | Suspend + +{-# INLINE workLoopLIFO #-} +workLoopLIFO + :: MonadRunInIO m + => IORef [(RunInIO m, K.StreamK m a)] + -> Channel m a + -> Maybe WorkerInfo + -> m () +workLoopLIFO qref sv winfo = run + + where + + run = do + work <- dequeue qref + case work of + Nothing -> return () + Just (RunInIO runin, m) -> process runin m + + process runin m = do + -- XXX when we finish we need to send the monadic state back to + -- the parent so that the state can be merged back. We capture + -- and return the state in the stop continuation. + -- + -- Instead of using the run function we can just restore the + -- monad state here. That way it can work easily for + -- distributed case as well. + r <- liftIO $ runin $ + K.foldStreamShared + undefined + yieldk + single + (return Continue) + m + res <- restoreM r + case res of + Continue -> run + Suspend -> return () + + where + + single a = do + res <- liftIO $ yieldWith winfo sv a + return $ if res then Continue else Suspend + + yieldk a r = do + res <- liftIO $ yieldWith winfo sv a + if res + then K.foldStreamShared undefined yieldk single (return Continue) r + else do + runInIO <- askRunInIO + liftIO $ enqueueLIFO sv qref (runInIO, r) + return Suspend + +-- We duplicate workLoop for yield limit and no limit cases because it has +-- around 40% performance overhead in the worst case. +-- +-- XXX we can pass yinfo directly as an argument here so that we do not have to +-- make a check every time. +{-# INLINE workLoopLIFOLimited #-} +workLoopLIFOLimited + :: forall m a. MonadRunInIO m + => IORef [(RunInIO m, K.StreamK m a)] + -> Channel m a + -> Maybe WorkerInfo + -> m () +workLoopLIFOLimited qref sv winfo = run + + where + + incrContinue = + liftIO (incrementYieldLimit (remainingWork sv)) >> return Continue + + run = do + work <- dequeue qref + {- HLINT ignore "Use forM_" -} + case work of + Nothing -> return () + Just item -> process item + + process item@(RunInIO runin, m) = do + -- XXX This is just a best effort minimization of concurrency + -- to the yield limit. If the stream is made of concurrent + -- streams we do not reserve the yield limit in the constituent + -- streams before executing the action. This can be done + -- though, by sharing the yield limit ref with downstream + -- actions via state passing. Just a todo. + yieldLimitOk <- liftIO $ decrementYieldLimit (remainingWork sv) + if yieldLimitOk + then do + r <- liftIO $ runin $ + K.foldStreamShared + undefined + yieldk + single + incrContinue + m + res <- restoreM r + case res of + Continue -> run + Suspend -> return () + -- Avoid any side effects, undo the yield limit decrement if we + -- never yielded anything. + else liftIO $ do + enqueueLIFO sv qref item + incrementYieldLimit (remainingWork sv) + + where + + single a = do + res <- liftIO $ yieldWith winfo sv a + return $ if res then Continue else Suspend + + -- XXX can we pass on the yield limit downstream to limit the + -- concurrency of constituent streams. + yieldk a r = do + res <- liftIO $ yieldWith winfo sv a + yieldLimitOk <- liftIO $ decrementYieldLimit (remainingWork sv) + if res && yieldLimitOk + then K.foldStreamShared undefined yieldk single incrContinue r + else do + runInIO <- askRunInIO + liftIO $ incrementYieldLimit (remainingWork sv) + liftIO $ enqueueLIFO sv qref (runInIO, r) + return Suspend + +------------------------------------------------------------------------------- +-- Ahead Channel Data Structures +------------------------------------------------------------------------------- + +-- 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. +-- Therefore the queue never has more than one item in it. However, in case of +-- parIterateConcatMap the iteration may add more items at the end of the +-- queue. +-- +-- 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. +{-# ANN enqueueAhead "HLint: ignore" #-} +{-# INLINE enqueueAhead #-} +enqueueAhead :: + Channel m a + -> IORef ([K.StreamK m a], Int) + -> (RunInIO m, K.StreamK m a) + -> IO () +enqueueAhead sv q m = do + -- XXX The queue is LIFO. When parConcatIterate queues more than one items + -- to the queue it will perform a DFS style traversal. For BFS we will have + -- to use a FIFO data structure here. That would require another Config + -- option. + atomicModifyIORefCAS_ q $ \(xs, n) -> (snd m:xs, n) + ringDoorBell (doorBellOnWorkQ sv) (outputDoorBell 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 dequeueAhead #-} +dequeueAhead :: MonadIO m + => IORef ([K.StreamK m a], Int) -> m (Maybe (K.StreamK m a, Int)) +dequeueAhead q = liftIO $ + atomicModifyIORefCAS q $ \case + ([], n) -> (([], n), Nothing) + (x : xs, n) -> ((xs, n + 1), Just (x, n + 1)) + +-- Dequeue only if the seq number matches the expected seq number. +{-# INLINE dequeueAheadSeqCheck #-} +dequeueAheadSeqCheck :: MonadIO m + => IORef ([K.StreamK m a], Int) -> Int -> m (Maybe (K.StreamK m a)) +dequeueAheadSeqCheck q seqNo = liftIO $ + atomicModifyIORefCAS q $ \case + ([], n) -> (([], n), Nothing) + (x : xs, n) -> + if n + 1 == seqNo + then ((xs, n + 1), Just x) + else ((x : xs, n), Nothing) + +------------------------------------------------------------------------------- +-- 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 AheadHeapEntry m a = + AheadEntryNull -- ^ an empty result, required for sequencing + | AheadEntryPure a -- ^ a yielded value + -- ^ A stream with its head possibly evaluated, and tail unevaluated + | AheadEntryStream (RunInIO m, Maybe a, K.StreamK m a) + +data HeapDequeueResult m a = + -- | Not dequeued because someone is processing the heap. This is indicated + -- by the second component of the heap IORef tuple being set to 'Nothing'. + Clearing + -- | Not dequeued because the seq no. of the top entry is not the next one + -- expected in seqeunce, we have to wait. + | Waiting Int + -- | dequeued successfully, the seq no. of the top entry is the next one + -- expected in sequence. + | Ready (Entry Int (AheadHeapEntry m a)) + +-- | The heap is stored in an IORef along with a sequence number. When the +-- sequence number is set to 'Nothing' it means we are processing the heap. The +-- type of the dequeued entry would be 'Clearing' in this case. When the +-- sequence number in the IORef is set to 'Just' then it is the next expected +-- sequence number. If the dequeued entry matches with this expected sequence +-- number then it is 'Ready' and dequeued otherwise it is 'Waiting'. When we +-- return 'Clearing' or 'Waiting', the heap is not modified i.e. nothing is +-- dequeued. +-- +-- Note, when we have n streams each consisting of multiple items composed with +-- "ordered" execution then the entire stream is treated as one item with the +-- given sequence number and all of its elements are yielded serially. +{-# INLINE dequeueFromHeap #-} +dequeueFromHeap + :: IORef (Heap (Entry Int (AheadHeapEntry m a)), Maybe Int) + -- ^ (heap, Maybe sequence-no). + -> IO (HeapDequeueResult 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) + +-- | Called only when the heap is being processed to transfer entries to output +-- queue. Matches the sequence number of the dequeued entry with the supplied +-- sequence number to determine if the entry is 'Ready' or 'Waiting'. Heap is +-- not modified if we return 'Waiting' i.e. entry is not dequeued. +{-# INLINE dequeueFromHeapSeq #-} +dequeueFromHeapSeq + :: IORef (Heap (Entry Int (AheadHeapEntry m a)), Maybe Int) + -> Int + -> IO (HeapDequeueResult 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 m a)), Maybe Int) + -> Entry Int (AheadHeapEntry 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 m a)), Maybe Int) + -> Int + -> IO () +updateHeapSeq hpVar seqNo = + atomicModifyIORef_ hpVar $ \(hp, snum) -> + assert (heapIsSane snum seqNo) (hp, Just seqNo) + +------------------------------------------------------------------------------ +-- Ahead: Concurrent streams with ordered results +------------------------------------------------------------------------------ + +-- Lookahead streams can execute multiple tasks concurrently, ahead of time, +-- but always serve them in the same order as they appear in the stream. To +-- implement lookahead streams efficiently we assign a sequence number to each +-- task when the task is picked up for execution. When the task finishes, the +-- output is tagged with the same sequence number and we rearrange the outputs +-- in sequence based on that number. +-- +-- To explain the mechanism imagine that the current task at the head of the +-- stream has a "token" to yield to the outputQueue. The ownership of the token +-- is determined by the current sequence number is maintained in outputHeap. +-- Sequence number is assigned when a task is queued. When a thread dequeues a +-- task it picks up the sequence number as well and when the output is ready it +-- uses the sequence number to queue the output to the outputQueue. +-- +-- The thread with current sequence number sends the output directly to the +-- outputQueue. Other threads push the output to the outputHeap. When the task +-- being queued on the heap is a stream of many elements we evaluate only the +-- first element and keep the rest of the unevaluated computation in the heap. +-- When such a task gets the "token" for outputQueue it evaluates and directly +-- yields all the elements to the outputQueue without checking for the +-- "token". +-- +-- Note that no two outputs in the heap can have the same sequence numbers and +-- therefore we do not need a stable heap. We have also separated the buffer +-- for the current task (outputQueue) and the pending tasks (outputHeap) so +-- that the pending tasks cannot interfere with the current task. Note that for +-- a single task just the outputQueue is enough and for the case of many +-- threads just a heap is good enough. However we balance between these two +-- cases, so that both are efficient. +-- +-- For bigger streams it may make sense to have separate buffers for each +-- stream. However, for singleton streams this may become inefficient. However, +-- if we do not have separate buffers, then the streams that come later in +-- sequence may hog the buffer, hindering the streams that are ahead. For this +-- reason we have a single element buffer limitation for the streams being +-- executed in advance. +-- +-- This scheme works pretty efficiently with less than 40% extra overhead +-- compared to the Async streams where we do not have any kind of sequencing of +-- the outputs. It is especially devised so that we are most efficient when we +-- have short tasks and need just a single thread. Also when a thread yields +-- many items it can hold lockfree access to the outputQueue and do it +-- efficiently. +-- +-- XXX Maybe we can start the ahead threads at a lower cpu and IO priority so +-- that they do not hog the resources and hinder the progress of the threads in +-- front of them. + +-- Left associated ahead expressions are expensive. We start a new SVar for +-- each left associative expression. The queue is used only for right +-- associated expression, we queue the right expression and execute the left. +-- Thererefore the queue never has more than on item in it. +-- +-- XXX Also note that limiting concurrency for cases like "take 10" would not +-- work well with left associative expressions, because we have no visibility +-- about how much the left side of the expression would yield. +-- +-- XXX It may be a good idea to increment sequence numbers for each yield, +-- currently a stream on the left side of the expression may yield many +-- elements with the same sequene number. We can then use the seq number to +-- enforce yieldMax and yieldLImit as well. + +-- Invariants: +-- +-- * A worker should always ensure that it pushes all the consecutive items in +-- the heap to the outputQueue especially the items on behalf of the workers +-- that have already left when we were holding the token. This avoids deadlock +-- conditions when the later workers completion depends on the consumption of +-- earlier results. For more details see comments in the consumer pull side +-- code. + +{-# INLINE underMaxHeap #-} +underMaxHeap :: + Channel m a + -> Heap (Entry Int (AheadHeapEntry m a)) + -> IO Bool +underMaxHeap sv hp = do + (_, len) <- readIORef (outputQueue sv) + + -- XXX simplify this + let maxHeap = case maxBufferLimit sv of + Limited lim -> Limited $ + max 0 (lim - fromIntegral len) + Unlimited -> Unlimited + + case maxHeap of + Limited lim -> do + active <- readIORef (workerCount sv) + return $ H.size hp + active <= fromIntegral lim + Unlimited -> return True + +-- Return value: +-- True => stop +-- False => continue +preStopCheck :: + Channel m a + -> IORef (Heap (Entry Int (AheadHeapEntry m a)) , Maybe Int) + -> IO Bool +preStopCheck sv heap = + -- check the stop condition under a lock before actually + -- stopping so that the whole herd does not stop at once. + withIORef heap $ \(hp, _) -> do + heapOk <- underMaxHeap sv hp + takeMVar (workerStopMVar sv) + let stopping = do + putMVar (workerStopMVar sv) () + return True + continue = do + putMVar (workerStopMVar sv) () + return False + if heapOk + then + case yieldRateInfo sv of + Nothing -> continue + Just yinfo -> do + beyondRate <- + isBeyondMaxRate + (maxWorkerLimit sv) (workerCount sv) yinfo + if beyondRate then stopping else continue + else stopping + +-- XXX In absence of a "noyield" primitive (i.e. do not pre-empt inside a +-- critical section) from GHC RTS, we have a difficult problem. Assume we have +-- a 100,000 threads producing output and queuing it to the heap for +-- sequencing. The heap can be drained only by one thread at a time, any thread +-- that finds that heap can be drained now, takes a lock and starts draining +-- it, however the thread may get prempted in the middle of it holding the +-- lock. Since that thread is holding the lock, the other threads cannot pick +-- up the draining task, therefore they proceed to picking up the next task to +-- execute. If the draining thread could yield voluntarily at a point where it +-- has released the lock, then the next threads could pick up the draining +-- instead of executing more tasks. When there are 100,000 threads the drainer +-- gets a cpu share to run only 1:100000 of the time. This makes the heap +-- accumulate a lot of output when we the buffer size is large. +-- +-- The solutions to this problem are: +-- 1) make the other threads wait in a queue until the draining finishes +-- 2) make the other threads queue and go away if draining is in progress +-- +-- In both cases we give the drainer a chance to run more often. + +-- | Move entries from the heap to the channel's output queue. Only those +-- entries which are in correct order are transferred. Stop whenever a missing +-- sequence number is encountered. +-- +-- We enter this function only when we have verified that the sequence number +-- passed to it is the next expected sequence number. +processHeap + :: MonadRunInIO m + => IORef ([K.StreamK m a], Int) -- ^ work queue + -> IORef (Heap (Entry Int (AheadHeapEntry m a)), Maybe Int) -- ^ heap + -> Channel m a + -> Maybe WorkerInfo + -> AheadHeapEntry m a -- heap entry dequeued from top of heap + -> Int -- seq no. of the heap entry, this is the next correct seq no. + -> Bool -- True if we are draining the heap when we are finally stopping + -> m () +processHeap q heap sv winfo entry sno stopping = loopHeap sno entry + + where + + -- We do not stop the worker on buffer full here as we want to proceed to + -- nextHeap anyway so that we can clear any subsequent entries. We stop + -- only in yield continuation where we may have a remaining stream to be + -- pushed on the heap. + singleStreamFromHeap seqNo a = do + void $ liftIO $ yieldWith winfo sv a + nextHeap seqNo + + yieldStreamFromHeap seqNo a r = do + continue <- liftIO $ yieldWith winfo sv a + runStreamWithYieldLimit continue seqNo r + + -- XXX when we have an unfinished stream on the heap we cannot account all + -- the yields of that stream until it finishes, so if we have picked up + -- and executed more actions beyond that in the parent stream and put them + -- on the heap then they would eat up some yield limit which is not + -- correct, we will think that our yield limit is over even though we have + -- to yield items from unfinished stream before them. For this reason, if + -- there are pending items in the heap we drain them unconditionally + -- without considering the yield limit. + runStreamWithYieldLimit continue seqNo r = do + _ <- liftIO $ decrementYieldLimit (remainingWork sv) + if continue -- see comment above -- && yieldLimitOk + then do + let stopk = do + liftIO (incrementYieldLimit (remainingWork sv)) + nextHeap seqNo + K.foldStreamShared undefined + (yieldStreamFromHeap seqNo) + (singleStreamFromHeap seqNo) + stopk + r + else do + runIn <- askRunInIO + let ent = Entry seqNo (AheadEntryStream (runIn, Nothing, r)) + liftIO $ do + requeueOnHeapTop heap ent seqNo + incrementYieldLimit (remainingWork sv) + + processWorkQueue prevSeqNo = do + yieldLimitOk <- liftIO $ decrementYieldLimit (remainingWork sv) + if yieldLimitOk + then do + work <- dequeueAhead q + case work of + Nothing -> return () + Just (m, seqNo) -> do + if seqNo == prevSeqNo + 1 + then processWithToken q heap sv winfo m seqNo + else processWithoutToken q heap sv winfo m seqNo + else liftIO $ incrementYieldLimit (remainingWork sv) + + nextHeap prevSeqNo = do + res <- liftIO $ dequeueFromHeapSeq heap (prevSeqNo + 1) + case res of + Ready (Entry seqNo hent) -> loopHeap seqNo hent + Clearing -> return () + Waiting _ -> + if stopping + then do + r <- liftIO $ preStopCheck sv heap + if r + then return () + else processWorkQueue prevSeqNo + else inline processWorkQueue prevSeqNo + + -- The main loop processing the heap. The seqNo is correct in sequence, + -- this is the one we should be sending to output next. + loopHeap seqNo ent = + case ent of + AheadEntryNull -> nextHeap seqNo + AheadEntryPure a -> do + -- Use 'send' directly so that we do not account this in worker + -- latency as this will not be the real latency. + -- Don't stop the worker in this case as we are just + -- transferring available results from heap to outputQueue. + void + $ liftIO + $ sendEvent + (outputQueue sv) (outputDoorBell sv) (ChildYield a) + nextHeap seqNo + AheadEntryStream (RunInIO runin, Just a, r) -> do + let + action = do + -- XXX deduplicate this code with the same code above + void + $ liftIO + $ sendEvent + (outputQueue sv) (outputDoorBell sv) (ChildYield a) + runStreamWithYieldLimit True seqNo r + go = do + res <- liftIO $ runin action + restoreM res + if stopping + then do + stopIt <- liftIO $ preStopCheck sv heap + if stopIt + then liftIO $ do + -- put the entry back in the heap and stop + requeueOnHeapTop heap (Entry seqNo ent) seqNo + else go + else go + AheadEntryStream (RunInIO runin, Nothing, r) -> do + -- XXX deuplicate this code with the code above + let + action = runStreamWithYieldLimit True seqNo r + go = do + res <- liftIO $ runin action + restoreM res + if stopping + then do + stopIt <- liftIO $ preStopCheck sv heap + if stopIt + then liftIO $ do + -- put the entry back in the heap and stop + requeueOnHeapTop heap (Entry seqNo ent) seqNo + else go + else go + +{-# NOINLINE drainHeap #-} +drainHeap + :: MonadRunInIO m + => IORef ([K.StreamK m a], Int) + -> IORef (Heap (Entry Int (AheadHeapEntry m a)), Maybe Int) + -> Channel m a + -> Maybe WorkerInfo + -> m () +drainHeap q heap sv winfo = do + r <- liftIO $ dequeueFromHeap heap + case r of + Ready (Entry seqNo hent) -> + processHeap q heap sv winfo hent seqNo True + _ -> return () + +data HeapStatus = HContinue | HStop + +-- XXX Rename to processOutOfOrder + +-- | Without token means the worker is working on an item which not the next in +-- sequence, therefore, the output has to be placed on the heap rather than +-- sending it directly to the output queue. +-- +processWithoutToken + :: MonadRunInIO m + => IORef ([K.StreamK m a], Int) + -> IORef (Heap (Entry Int (AheadHeapEntry m a)), Maybe Int) + -> Channel m a + -> Maybe WorkerInfo + -> K.StreamK m a + -> Int + -> m () +processWithoutToken q heap sv winfo m seqNo = do + -- we have already decremented the yield limit for m + let stopk = do + liftIO (incrementYieldLimit (remainingWork sv)) + -- If the stream stops without yielding anything, and we do not put + -- anything on heap, but if heap was waiting for this seq number + -- then it will keep waiting forever, because we are never going to + -- put it on heap. So we have to put a null entry on heap even when + -- we stop. + toHeap AheadEntryNull + mrun = runInIO $ svarMrun sv + + -- XXX When StreamD streams are converted to StreamK, even for singleton + -- streams we have a yield and a stop. That can cause perf overhead in case + -- of concurrent workers. We should always create streams with a "single" + -- continuation. + r <- liftIO $ mrun $ + K.foldStreamShared undefined + (\a r -> do + runIn <- askRunInIO + toHeap $ AheadEntryStream (runIn, Just a, r)) + (toHeap . AheadEntryPure) + stopk + m + res <- restoreM r + case res of + Continue -> workLoopAhead q heap sv winfo + Suspend -> drainHeap q heap sv winfo + + where + + -- XXX to reduce contention each CPU can have its own heap + toHeap ent = do + -- Heap insertion is an expensive affair so we use a non CAS based + -- modification, otherwise contention and retries can make a thread + -- context switch and throw it behind other threads which come later in + -- sequence. + newHp <- liftIO $ atomicModifyIORef heap $ \(hp, snum) -> + let hp' = H.insert (Entry seqNo ent) hp + in assert (heapIsSane snum seqNo) ((hp', snum), hp') + + when (svarInspectMode sv) $ + liftIO $ do + maxHp <- readIORef (maxHeapSize $ svarStats sv) + when (H.size newHp > maxHp) $ + writeIORef (maxHeapSize $ svarStats sv) (H.size newHp) + + heapOk <- liftIO $ underMaxHeap sv newHp + + -- XXX Refactor to use join points + status <- + case yieldRateInfo sv of + Nothing -> return HContinue + Just yinfo -> + case winfo of + Just info -> do + rateOk <- + liftIO + $ incrWorkerYieldCount + (maxWorkerLimit sv) + (workerCount sv) + yinfo + info + if rateOk + then return HContinue + else return HStop + Nothing -> return HContinue + + if heapOk + then + case status of + HContinue -> return Continue + HStop -> return Suspend + else return Suspend + +data TokenWorkerStatus = TokenContinue Int | TokenSuspend + +-- XXX Rename to processInOrder + +-- | With token means this worker is working on an item which is the next in +-- sequence, therefore, it can be yielded directly to the output queue, +-- avoiding the heap. +-- +-- Before suspending the worker has the responsibility to transfer all the +-- in-sequence entries from the heap to the output queue. +processWithToken + :: MonadRunInIO m + => IORef ([K.StreamK m a], Int) + -> IORef (Heap (Entry Int (AheadHeapEntry m a)), Maybe Int) + -> Channel m a + -> Maybe WorkerInfo + -> K.StreamK m a + -> Int + -> m () +processWithToken q heap sv winfo action sno = do + -- Note, we enter this function with yield limit already decremented + -- XXX deduplicate stop in all invocations + let stopk = do + liftIO (incrementYieldLimit (remainingWork sv)) + return $ TokenContinue (sno + 1) + mrun = runInIO $ svarMrun sv + + r <- + liftIO + $ mrun + $ K.foldStreamShared + undefined (yieldOutput sno) (singleOutput sno) stopk action + + res <- restoreM r + case res of + TokenContinue seqNo -> loopWithToken seqNo + TokenSuspend -> drainHeap q heap sv winfo + + where + + singleOutput seqNo a = do + continue <- liftIO $ yieldWith winfo sv a + if continue + then return $ TokenContinue (seqNo + 1) + else do + liftIO $ updateHeapSeq heap (seqNo + 1) + return TokenSuspend + + -- XXX use a wrapper function around stop so that we never miss + -- incrementing the yield in a stop continuation. Essentiatlly all + -- "unstream" calls in this function must increment yield limit on stop. + yieldOutput seqNo a r = do + continue <- liftIO $ yieldWith winfo sv a + yieldLimitOk <- liftIO $ decrementYieldLimit (remainingWork sv) + if continue && yieldLimitOk + then do + let stopk = do + liftIO (incrementYieldLimit (remainingWork sv)) + return $ TokenContinue (seqNo + 1) + K.foldStreamShared undefined + (yieldOutput seqNo) + (singleOutput seqNo) + stopk + r + else do + runIn <- askRunInIO + let ent = Entry seqNo (AheadEntryStream (runIn, Nothing, r)) + liftIO $ requeueOnHeapTop heap ent seqNo + liftIO $ incrementYieldLimit (remainingWork sv) + return TokenSuspend + + loopWithToken nextSeqNo = do + let preExit = liftIO $ do + updateHeapSeq heap nextSeqNo + incrementYieldLimit (remainingWork sv) + yieldLimitOk <- liftIO $ decrementYieldLimit (remainingWork sv) + -- To avoid a race when another thread puts something + -- on the heap and goes away, the consumer will not get + -- a doorBell and we will not clear the heap before + -- executing the next action. If the consumer depends + -- on the output that is stuck in the heap then this + -- will result in a deadlock. So we always clear the + -- heap before executing the next action. + if yieldLimitOk + then do + -- XXX Instead of checking seqno inside dequeue we can dequeue + -- unconditionally and if the seqNo is not the same as nextSeqNo + -- then release the token and call processWithoutToken. Need + -- to check the performance though. + work <- dequeueAheadSeqCheck q nextSeqNo + case work of + Nothing -> preExit >> workLoopAhead q heap sv winfo + Just m -> do + let stopk = do + liftIO (incrementYieldLimit (remainingWork sv)) + return $ TokenContinue (nextSeqNo + 1) + mrun = runInIO $ svarMrun sv + r <- liftIO $ mrun $ + K.foldStreamShared undefined + (yieldOutput nextSeqNo) + (singleOutput nextSeqNo) + stopk + m + res <- restoreM r + case res of + TokenContinue seqNo -> loopWithToken seqNo + TokenSuspend -> drainHeap q heap sv winfo + else preExit >> drainHeap q heap sv winfo + +-- XXX the yield limit changes increased the performance overhead by 30-40%. +-- Just like AsyncT we can use an implementation without yeidlimit and even +-- without pacing code to keep the performance higher in the unlimited and +-- unpaced case. +-- +-- XXX The yieldLimit stuff is pretty invasive. We can instead do it by using +-- three hooks, a pre-execute hook, a yield hook and a stop hook. In fact these +-- hooks can be used for a more general implementation to even check predicates +-- and not just yield limit. + +workLoopAhead + :: MonadRunInIO m + => IORef ([K.StreamK m a], Int) + -> IORef (Heap (Entry Int (AheadHeapEntry m a)), Maybe Int) + -> Channel m a + -> Maybe WorkerInfo + -> m () +workLoopAhead q heap sv winfo = do + r <- liftIO $ dequeueFromHeap heap + case r of + Ready (Entry seqNo hent) -> + processHeap q heap sv winfo hent seqNo False + Clearing -> return () + Waiting _ -> do + -- Before we execute the next item from the work queue we check + -- if we are beyond the yield limit. It is better to check the + -- yield limit before we pick up the next item. Otherwise we + -- may have already started more tasks even though we may have + -- reached the yield limit. We can avoid this by taking active + -- workers into account, but that is not as reliable, because + -- workers may go away without picking up work and yielding a + -- value. + -- + -- Rate control can be done either based on actual yields in + -- the output queue or based on any yield either to the heap or + -- to the output queue. In both cases we may have one issue or + -- the other. We chose to do this based on actual yields to the + -- output queue because it makes the code common to both async + -- and ahead streams. + -- + yieldLimitOk <- liftIO $ decrementYieldLimit (remainingWork sv) + if yieldLimitOk + then do + work <- dequeueAhead q + case work of + Nothing -> return () + Just (m, seqNo) -> do + if seqNo == 0 + then processWithToken q heap sv winfo m seqNo + else processWithoutToken q heap sv winfo m seqNo + else liftIO $ incrementYieldLimit (remainingWork sv) + +------------------------------------------------------------------------------- +-- SVar creation +-- This code belongs in SVar.hs but is kept here for perf reasons +------------------------------------------------------------------------------- + +-- XXX we have this function in this file because passing runStreamLIFO as a +-- function argument to this function results in a perf degradation of more +-- than 10%. Need to investigate what the root cause is. +-- Interestingly, the same thing does not make any difference for Ahead. +-- {-# INLINABLE getLifoSVar #-} +getLifoSVar :: forall m a. MonadRunInIO m => + RunInIO m -> Config -> IO (Channel m a) +getLifoSVar mrun cfg = do + outQ <- newIORef ([], 0) + -- The second component of the heap IORef tuple is: + -- + -- * "Nothing" when we are in the process of clearing the heap i.e. when + -- we are procssing the heap and transferring entries from the heap to the + -- output queue + -- * "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 Set.empty + q <- newIORef ([] :: [(RunInIO m, K.StreamK m a)]) + -- Sequence number is incremented whenever something is de-queued, + -- therefore, first sequence number would be 0 + aheadQ <- newIORef ([], -1) + stopMVar <- newMVar () + yl <- + case getYieldLimit cfg of + Nothing -> return Nothing + Just x -> Just <$> newIORef x + stoppingRef <- newIORef False + stoppedMVar <- newMVar False + rateInfo <- newRateInfo cfg + + stats <- newSVarStats + tid <- myThreadId + + -- We are reading it without lock, the result would be reliable only if no + -- worker is pending. + let isWorkFinished _ = do + xs <- readIORef q + return (null xs) + + let isWorkFinishedLimited sv = do + yieldsDone <- + case remainingWork sv of + Just ref -> do + n <- readIORef ref + return (n <= 0) + Nothing -> return False + qEmpty <- isWorkFinished sv + return $ qEmpty || yieldsDone + + let eagerEval = getEagerDispatch cfg + inOrder = getOrdered cfg + + let getSVar :: Channel m a + -> (Channel m a -> m [ChildEvent a]) + -> (Channel m a -> m Bool) + -> (Channel m a -> IO Bool) + -> (IORef [(RunInIO m, K.StreamK m a)] + -> Channel m a + -> Maybe WorkerInfo + -> m()) + -> Channel m a + getSVar sv readOutput postProc workDone wloop = Channel + { outputQueue = outQ + , remainingWork = yl + , maxBufferLimit = getMaxBuffer cfg + , maxWorkerLimit = min (getMaxThreads cfg) (getMaxBuffer cfg) + , yieldRateInfo = rateInfo + , outputDoorBell = outQMv + , readOutputQ = readOutput sv + , postProcess = postProc sv + , workerThreads = running + + , workLoop = + if inOrder + then workLoopAhead aheadQ outH sv + else wloop q sv + , channelStopping = stoppingRef + , channelStopped = stoppedMVar + , enqueue = + if inOrder + then enqueueAhead sv aheadQ + else enqueueLIFO sv q + , eagerDispatch = when eagerEval $ void $ dispatchWorker 0 sv + , isWorkDone = + if inOrder + then isWorkDoneAhead sv aheadQ outH + else workDone sv + , isQueueDone = + if inOrder + then isQueueDoneAhead sv aheadQ + else workDone sv + + , doorBellOnWorkQ = wfw + , svarMrun = mrun + , workerCount = active + -- XXX We can use delThread or modThread based on eager flag. + , accountThread = modifyThread running outQMv + , workerStopMVar = stopMVar + , svarRef = Nothing + , svarInspectMode = getInspectMode cfg + , svarCreator = tid + , svarStats = stats + } + + let sv = + case getStreamRate cfg of + Nothing -> + case getYieldLimit cfg of + Nothing -> getSVar sv (readOutputQBounded eagerEval) + postProcessBounded + isWorkFinished + workLoopLIFO + Just _ -> getSVar sv (readOutputQBounded eagerEval) + postProcessBounded + isWorkFinishedLimited + workLoopLIFOLimited + Just _ -> + case getYieldLimit cfg of + Nothing -> getSVar sv readOutputQPaced + postProcessPaced + isWorkFinished + workLoopLIFO + Just _ -> getSVar sv readOutputQPaced + postProcessPaced + isWorkFinishedLimited + workLoopLIFOLimited + 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 + +-- | Create a new async style concurrent stream evaluation channel. The monad +-- state used to run the stream actions is taken from the call site of +-- newAppendChannel. +-- +-- This is a low level API, use newChannel instead. +{-# INLINABLE newAppendChannel #-} +{-# SPECIALIZE newAppendChannel :: (Config -> Config) -> IO (Channel IO a) #-} +newAppendChannel :: MonadRunInIO m => (Config -> Config) -> m (Channel m a) +newAppendChannel modifier = do + mrun <- askRunInIO + liftIO $ getLifoSVar mrun (modifier defaultConfig) diff --git a/src/Streamly/Internal/Data/Stream/Channel/Consumer.hs b/src/Streamly/Internal/Data/Stream/Channel/Consumer.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/Channel/Consumer.hs @@ -0,0 +1,143 @@ +-- | +-- Module : Streamly.Internal.Data.Stream.Channel.Consumer +-- Copyright : (c) 2017 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +module Streamly.Internal.Data.Stream.Channel.Consumer + ( + -- *** Reading Events + -- | Low level functions used to build 'fromChannelK'. + readOutputQBounded + , readOutputQPaced + , postProcessBounded + , postProcessPaced + ) +where + +import Control.Monad (when, void) +import Control.Monad.IO.Class (MonadIO(liftIO)) +import Data.IORef (readIORef) + +import Streamly.Internal.Data.Channel.Dispatcher +import Streamly.Internal.Data.Channel.Types +import Streamly.Internal.Data.Stream.Channel.Dispatcher +import Streamly.Internal.Data.Stream.Channel.Type + +------------------------------------------------------------------------------- +-- Reading from the workers' output queue/buffer +------------------------------------------------------------------------------- + +{-# INLINE readOutputQChan #-} +readOutputQChan :: Channel m a -> IO ([ChildEvent a], Int) +readOutputQChan sv = do + let ss = if svarInspectMode sv then Just (svarStats sv) else Nothing + in readOutputQRaw (outputQueue sv) ss + +-- | Read the channel's output queue. When there is no output dispatches +-- workers and waits for output (using 'sendWorkerWait'). Always ensures that +-- there is at least one outstanding worker. +-- +-- To be used as 'readOutputQ' function for the channel. +readOutputQBounded :: MonadIO m => Bool -> Channel m a -> m [ChildEvent a] +readOutputQBounded eagerEval sv = do + (list, len) <- liftIO $ readOutputQChan 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) (forkWorker 0 sv) + + {-# INLINE blockingRead #-} + blockingRead = do + dispatchAllWait eagerEval sendWorkerDelay (dispatchWorker 0) sv + liftIO (fst `fmap` readOutputQChan sv) + +-- | Same as 'readOutputQBounded' but uses 'dispatchWorkerPaced' to +-- dispatch workers with rate control. +-- +-- To be used as 'readOutputQ' function for the channel when rate control is +-- on. +readOutputQPaced :: MonadIO m => Channel m a -> m [ChildEvent a] +readOutputQPaced sv = do + (list, len) <- liftIO $ readOutputQChan 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 + dispatchAllWait False sendWorkerDelayPaced dispatchWorkerPaced sv + liftIO (fst `fmap` readOutputQChan sv) + +-- | If there is work to do dispatch as many workers as the target rate +-- requires. +-- +-- To be used as 'postProcess' function for the channel when rate control is +-- enabled. +postProcessPaced :: MonadIO m => Channel m a -> m Bool +postProcessPaced sv = do + workersDone <- allThreadsDone (workerThreads 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 (workerThreads sv) + when noWorker $ forkWorker 0 sv + return r + else return False + +-- | If there is work to do ensure that we have at least one worker disptached. +-- +-- To be used as 'postProcess' function for the channel. +postProcessBounded :: MonadIO m => Channel m a -> m Bool +postProcessBounded sv = do + workersDone <- allThreadsDone (workerThreads 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) (forkWorker 0 sv) + -- XXX do we need to dispatch many here? + -- void $ dispatchWorker sv + return r + else return False diff --git a/src/Streamly/Internal/Data/Stream/Channel/Dispatcher.hs b/src/Streamly/Internal/Data/Stream/Channel/Dispatcher.hs --- a/src/Streamly/Internal/Data/Stream/Channel/Dispatcher.hs +++ b/src/Streamly/Internal/Data/Stream/Channel/Dispatcher.hs @@ -9,286 +9,501 @@ -- module Streamly.Internal.Data.Stream.Channel.Dispatcher ( - -- * Latency collection - minThreadDelay - , collectLatency - - -- * Thread accounting - , addThread - , delThread - , modifyThread - , allThreadsDone - , recordMaxWorkers - - -- * Diagnostics - , dumpSVarStats + -- *** Worker Dispatching + -- | Low level functions used to build readOutputQ and postProcess + -- functions. + forkWorker + , dispatchWorker + , dispatchWorkerPaced + , dispatchAllWait + , sendWorkerDelay + , sendWorkerDelayPaced + , startChannel -- XXX bootstrap? ) where -import Data.Set (Set) -import Control.Concurrent (MVar, ThreadId) -import Control.Concurrent.MVar (tryPutMVar) -import Control.Exception (assert) +import Control.Concurrent (takeMVar, threadDelay, forkOS) +import Control.Exception (assert, catch, mask) import Control.Monad (when, void) import Control.Monad.IO.Class (MonadIO(liftIO)) -import Data.IORef (IORef, modifyIORef, readIORef, writeIORef) -import Streamly.Internal.Data.Atomics (atomicModifyIORefCAS, writeBarrier) +import Data.Maybe (fromJust, fromMaybe) +import Data.IORef (modifyIORef, newIORef, readIORef, writeIORef) +import Streamly.Internal.Control.Concurrent (RunInIO(..)) +import Streamly.Internal.Control.ForkIO (rawForkIO) +import Streamly.Internal.Data.Atomics + (atomicModifyIORefCAS_, storeLoadBarrier) import Streamly.Internal.Data.Time.Clock (Clock(Monotonic), getTime) import Streamly.Internal.Data.Time.Units - ( AbsTime, NanoSecond64(..), diffAbsTime64, showNanoSecond64 - , showRelTime64) - -import qualified Data.Set as S + (MicroSecond64(..), diffAbsTime64, fromRelTime64, toRelTime64) -import Streamly.Internal.Data.Stream.Channel.Types +import Streamly.Internal.Data.Channel.Dispatcher +import Streamly.Internal.Data.Channel.Types +import Streamly.Internal.Data.Channel.Worker +import Streamly.Internal.Data.Stream.Channel.Type ------------------------------------------------------------------------------- --- Worker latency data processing +-- Dispatching workers ------------------------------------------------------------------------------- --- | This is a magic number and it is overloaded, and used at several places to --- achieve batching: +-- XXX The old code passed the action and exception handler inside this and +-- only did a fork here. When we passed the channel and added the workerCount +-- update under the mask, many concurrent benchmarks regressed, some +-- drastically improved as well. We did an experiment to directly put this fork +-- code in forkWorker and just push the worker count update inside the mask and +-- that itself caused the entire regression. Also the memory consumption in +-- ConcurrentEager.toNullAp benchmark doubled from 300MB to 600 MB So something +-- fishy going on here which needs to be investigated. -- --- 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 +{-# INLINE doFork #-} +doFork :: Bool -> Channel m a -> Maybe WorkerInfo -> IO () +doFork bound chan winfo = + mask $ \restore -> do + liftIO $ atomicModifyIORefCAS_ (workerCount chan) $ \n -> n + 1 + when (svarInspectMode chan) + $ recordMaxWorkers (workerCount chan) (svarStats chan) + let frk = + if bound + then forkOS + else rawForkIO + (RunInIO mrun) = svarMrun chan + act = do + restore $ void $ mrun (workLoop chan winfo) + stopWith winfo chan + tid <- frk $ catch act (exceptionWith winfo chan) + -- In case of lazy dispatch we dispatch workers only from the + -- consumer thread. In that case it is ok to use addThread here as + -- it is guaranteed that the thread will be added to the workerSet + -- before the thread STOP event is processed, because we do both of + -- these actions in the same consumer thread. However, in case of + -- eager dispatch we may dispatch workers from workers, in which + -- case the thread Stop even may get processed before the addThread + -- occurs, so in that case we have to use modifyThread which + -- performs a toggle rather than adding or deleting. + -- + -- XXX We can use addThread or modThread based on eager flag. + -- XXX Update the dispatcher-to-worker threadId map for debugging + -- tid <- liftIO myThreadId + -- liftIO $ putStrLn $ "Dispatcher thread: " ++ show tid + modThread tid --- 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) + where - writeIORef periodRef (fromIntegral period) + modThread = modifyThread (workerThreads chan) (outputDoorBell chan) -{-# INLINE recordMinMaxLatency #-} -recordMinMaxLatency :: SVarStats -> NanoSecond64 -> IO () -recordMinMaxLatency ss new = do - minLat <- readIORef (minWorkerLatency ss) - when (new < minLat || minLat == 0) $ - writeIORef (minWorkerLatency ss) new +-- | Low level API to create a worker. Forks a thread which executes the +-- 'workLoop' of the channel. It does not fork only if the channel is stopped. +{-# NOINLINE forkWorker #-} +forkWorker :: MonadIO m => + Count -- ^ max yield limit for the worker + -> Channel m a + -> m () +forkWorker yieldMax sv = do + -- This allocation matters when significant number of workers are being + -- sent. We allocate it only when needed. + -- + -- XXX WorkerInfo is required for maxYields to work even if rate control is + -- not enabled. + 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 + } - maxLat <- readIORef (maxWorkerLatency ss) - when (new > maxLat) $ writeIORef (maxWorkerLatency ss) new + stopping <- liftIO $ readIORef (channelStopping sv) + when (not stopping) $ liftIO $ doFork False sv winfo -recordAvgLatency :: SVarStats -> (Count, NanoSecond64) -> IO () -recordAvgLatency ss (count, time) = do - modifyIORef (avgWorkerLatency ss) $ - \(cnt, t) -> (cnt + count, t + time) +-- | Determine the maximum number of workers required based on 'maxWorkerLimit' +-- and 'remainingWork'. +{-# INLINE getEffectiveWorkerLimit #-} +getEffectiveWorkerLimit :: MonadIO m => Channel m a -> m Limit +getEffectiveWorkerLimit sv = do + let workerLimit = maxWorkerLimit sv + 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) --- 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) +-- | Determine whether the active threads are more than the max threads we are +-- allowed to dispatch. +{-# INLINE checkMaxThreads #-} +checkMaxThreads :: MonadIO m => Int -> Channel m a -> m Bool +checkMaxThreads active sv = 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 <- getEffectiveWorkerLimit sv + return + $ case limit of + Unlimited -> True + -- 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 -> fromIntegral lim > active - (fcnt, cnt, t) <- readIORef col - let totalCount = fcnt + fcount - latCount = cnt + count - latTime = t + time - writeIORef col (totalCount, latCount, latTime) +-- | Determine whether we would exceed max buffer if we dispatch more workers +-- based on the current outputQueue size and active workers. +{-# INLINE checkMaxBuffer #-} +checkMaxBuffer :: MonadIO m => Int -> Channel m a -> m Bool +checkMaxBuffer active sv = do + let limit = maxBufferLimit sv + case limit of + Unlimited -> return True + Limited lim -> do + (_, n) <- liftIO $ readIORef (outputQueue sv) + return $ fromIntegral lim > n + active - assert (latCount == 0 || latTime /= 0) (return ()) - let latPair = - if latCount > 0 && latTime > 0 - then Just (latCount, latTime) - else Nothing - return (totalCount, latPair) +-- | Higher level API to dispatch a worker, it uses 'forkWorker' to create a +-- worker. +-- +-- Dispatches a worker only if all of the following are true: +-- +-- * the channel has work to do +-- * max thread count is not reached +-- * max buffer limit is not reached +-- +-- It is possible that no worker is dispatched even when there is no +-- outstanding worker - only if any of the following is true: +-- +-- * maxBuffer limit is 0 +-- * maxThreads limit is set to 0 +-- * there is output pending in the output buffer +-- +-- In all other cases a worker is guaranteed to be dispatched. +-- +dispatchWorker :: MonadIO m => + Count -- ^ max yield limit for the worker + -> Channel m a + -> m Bool -- ^ can dispatch more workers +dispatchWorker yieldCount sv = do + -- 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. + -- XXX Should we have a single abstraction for checking q and + -- work instead checking the two separately? + -- + -- Yield count check may not be reliable unless there are no workers + -- outsanding. If there are no outstanding workers, we are fine. But if + -- there are outstanding workers, it may return done even if we are not + -- done yet. But that is fine too as there are outstanding workers and we + -- cannot block forever in dispatchAllWait. + 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 be more until the sendStop events are processed. + active <- liftIO $ readIORef $ workerCount sv + when (active < 0) $ error "Bug: dispatchWorker active negative" + if not qDone + then do + -- 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. + r <- checkMaxThreads active sv + if r + then do + r1 <- checkMaxBuffer active sv + if r1 + then forkWorker yieldCount sv >> return True + else return False + else return False + else do + when (active <= 0) $ do + r <- liftIO $ isWorkDone sv + when (not r) $ forkWorker 0 sv + return False + else return False -{-# 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) +-- 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 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 :: - Bool - -> SVarStats - -> YieldRateInfo - -> Bool - -> IO (Count, AbsTime, NanoSecond64) -collectLatency inspecting ss yinfo drain = do - let cur = workerPendingLatency yinfo - col = workerCollectedLatency yinfo - longTerm = svarAllTimeLatency yinfo - measured = workerMeasuredLatency yinfo +-- | Like 'dispatchWorker' but with rate control. The number of workers to be +-- dispatched are decided based on the target rate. Uses 'dispatchWorker' to +-- actually dispatch when required. It may block wait until there is time to +-- dispatch. +-- +-- It guarantees that if there is no outstanding worker and there is work +-- pending then it dispatches a worker though it may block for some time before +-- it does that depending on the rate goal. +dispatchWorkerPaced :: MonadIO m => + Channel m a + -> m Bool -- ^ True means can dispatch more +dispatchWorkerPaced sv = do + let yinfo = fromJust $ yieldRateInfo sv + (svarYields, svarElapsed, wLatency) <- do + now <- liftIO $ getTime Monotonic + (yieldCount, baseTime, lat) <- + liftIO + $ collectLatency + (svarInspectMode sv) (svarStats sv) yinfo False + let elapsed = fromRelTime64 $ diffAbsTime64 now baseTime + let latency = + if lat == 0 + then fromMaybe lat (workerBootstrapLatency yinfo) + else lat - (newCount, newLatPair) <- collectWorkerPendingLatency cur col - (lcount, ltime) <- readIORef longTerm - prevLat <- readIORef measured + return (yieldCount, elapsed, latency) - let newLcount = lcount + newCount - retWith lat = return (newLcount, ltime, lat) + 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 - case newLatPair of - Nothing -> retWith prevLat - Just (count, time) -> do - let newLat = time `div` fromIntegral count - when inspecting $ recordMinMaxLatency ss 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 inspecting $ recordAvgLatency ss (count, time) - writeIORef col (0, 0, 0) - writeIORef measured ((prevLat + newLat) `div` 2) - modifyIORef longTerm $ \(_, t) -> (newLcount, t) - retWith newLat - else retWith prevLat + -- 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 and the + -- outputQueue is empty, otherwise we will delay reading the + -- pending output. Note we cannot use workerCount here as it is + -- not a reliable way to ensure the outputQueue is empty. When + -- workerCount is 0 we may still have a Stop event waiting in + -- the outputQueue. + done <- allThreadsDone (workerThreads 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 -------------------------------------------------------------------------------- --- Dumping the SVar for debug/diag -------------------------------------------------------------------------------- + done <- allThreadsDone (workerThreads sv) + when done $ void $ dispatchWorker yields sv + return False + ManyWorkers netWorkers yields -> do + assert (netWorkers >= 1) (return ()) + assert (yields >= 0) (return ()) + updateGainedLostYields yinfo yields -dumpSVarStats :: Bool -> Maybe YieldRateInfo -> SVarStats -> IO String -dumpSVarStats inspecting rateInfo ss = do - case rateInfo of - Nothing -> return () - Just yinfo -> do - _ <- liftIO $ collectLatency inspecting ss yinfo True - return () + -- XXX workerPollingInterval is also modified by the + -- collectLatency call above. Need to reconcile the two. + let periodRef = workerPollingInterval yinfo + ycnt = max 1 $ yields `div` fromIntegral netWorkers + period = min ycnt (fromIntegral magicMaxBuffer) - 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 rateInfo 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) + old <- liftIO $ readIORef periodRef + when (period < old) $ + liftIO $ writeIORef periodRef period - return $ unlines - [ "total dispatches = " <> show dispatches - , "max workers = " <> show maxWrk - , "max outQSize = " <> show maxOq - <> (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 "") - ] + 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 -------------------------------------------------------------------------------- --- Thread accounting -------------------------------------------------------------------------------- + where --- Thread tracking is needed for two reasons: + -- If the absolute value of yields required is more than the svarRateBuffer + -- then the amount beyond the rate buffer is added to the permanently lost + -- or gained yields. + 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 + +-- | Dispatches as many workers as it can until output is seen in the event +-- queue of the channel. If the dispatcher function returns 'False' then no +-- more dispatches can be done. If no more dispatches are possible blocks until +-- output arrives in the event queue. -- --- 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. +-- When this function returns we are sure that there is some output available. -- --- 2) To know when all threads are done and the stream has ended. +-- Before we call this function we must ensure that there is either a pending +-- worker or pending work, otherwise it might block forever. If there is +-- pending work and no pending worker the dispatcher function must ensure that +-- it dispatches a worker. +-- +{-# NOINLINE dispatchAllWait #-} +dispatchAllWait + :: MonadIO m + => Bool -- ^ 'eager' option is on + -> (Channel m a -> IO ()) -- ^ delay function + -> (Channel m a -> m Bool) -- ^ dispatcher function + -> Channel m a + -> m () +dispatchAllWait eagerEval delay dispatch sv = go -{-# NOINLINE addThread #-} -addThread :: MonadIO m => IORef (Set ThreadId) -> ThreadId -> m () -addThread workerSet tid = - liftIO $ modifyIORef workerSet (S.insert tid) + where --- 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 => IORef (Set ThreadId) -> ThreadId -> m () -delThread workerSet tid = - liftIO $ modifyIORef workerSet (S.delete tid) + go = do --- 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 => IORef (Set ThreadId) -> MVar () -> ThreadId -> m () -modifyThread workerSet bell tid = do - changed <- liftIO $ atomicModifyIORefCAS workerSet $ \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 bell () + -- 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. --- | 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 => IORef (Set ThreadId) -> m Bool -allThreadsDone ref = liftIO $ S.null <$> readIORef ref + liftIO $ delay sv + (_, n) <- liftIO $ readIORef (outputQueue sv) + when (n <= 0 || eagerEval) $ 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. -------------------------------------------------------------------------------- --- Dispatching workers -------------------------------------------------------------------------------- + -- 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. -{-# NOINLINE recordMaxWorkers #-} -recordMaxWorkers :: MonadIO m => IORef Int -> SVarStats -> m () -recordMaxWorkers countRef ss = liftIO $ do - active <- readIORef countRef - maxWrk <- readIORef (maxWorkers ss) - when (active > maxWrk) $ writeIORef (maxWorkers ss) active - modifyIORef (totalDispatches ss) (+1) + -- 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_ (doorBellOnWorkQ 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 go + else do + liftIO + $ withDiagMVar + (svarInspectMode sv) + (dumpChannel sv) + "dispatchAllWait: nothing to do" + $ takeMVar (outputDoorBell sv) + (_, len) <- liftIO $ readIORef (outputQueue sv) + if len <= 0 + then go + else + liftIO + $ atomicModifyIORefCAS_ (doorBellOnWorkQ sv) + $ const False + +-- | Start the evaluation of the channel's work queue by kicking off a worker. +-- Note: Work queue must not be empty otherwise the worker will exit without +-- doing anything. +startChannel :: MonadIO m => + Channel m a -> m () +startChannel chan = do + case yieldRateInfo chan of + Nothing -> forkWorker 0 chan + Just yinfo -> + if svarLatencyTarget yinfo == maxBound + then liftIO $ threadDelay maxBound + else forkWorker 1 chan + +-- | Noop as of now. +sendWorkerDelayPaced :: Channel m a -> IO () +sendWorkerDelayPaced _ = return () + +-- | Noop as of now. +sendWorkerDelay :: Channel 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 () diff --git a/src/Streamly/Internal/Data/Stream/Channel/Interleave.hs b/src/Streamly/Internal/Data/Stream/Channel/Interleave.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/Channel/Interleave.hs @@ -0,0 +1,257 @@ +-- | +-- Module : Streamly.Internal.Data.Stream.Channel.Interleave +-- Copyright : (c) 2017 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +module Streamly.Internal.Data.Stream.Channel.Interleave + ( + newInterleaveChannel + ) +where + +#include "inline.hs" + +import Control.Concurrent (myThreadId) +import Control.Concurrent.MVar (newEmptyMVar, newMVar) +import Control.Monad.IO.Class (MonadIO(liftIO)) +import Data.Concurrent.Queue.MichaelScott (LinkedQueue, newQ, nullQ, tryPopR, pushL) +import Data.IORef (newIORef, readIORef) +import Streamly.Internal.Control.Concurrent + (MonadRunInIO, MonadAsync, RunInIO(..), askRunInIO, restoreM) +import Streamly.Internal.Data.Channel.Dispatcher (delThread) + +import qualified Data.Set as Set +import qualified Streamly.Internal.Data.StreamK as K + +import Streamly.Internal.Data.Channel.Types +import Streamly.Internal.Data.Stream.Channel.Consumer +import Streamly.Internal.Data.Stream.Channel.Type + +------------------------------------------------------------------------------ +-- Creating a channel +------------------------------------------------------------------------------ + +data WorkerStatus = Continue | Suspend + +-- XXX This is not strictly round-robin as the streams that are faster may +-- yield more elements than the ones that are slower. Also, when streams +-- suspend due to buffer getting full they get added to the queue in a random +-- order. Document this under interleaved config option or fix it. + +{-# INLINE enqueueFIFO #-} +enqueueFIFO :: + Channel m a + -> LinkedQueue (RunInIO m, K.StreamK m a) + -> (RunInIO m, K.StreamK m a) + -> IO () +enqueueFIFO sv q m = do + pushL q m + ringDoorBell (doorBellOnWorkQ sv) (outputDoorBell sv) + +{-# INLINE workLoopFIFO #-} +workLoopFIFO + :: MonadRunInIO m + => LinkedQueue (RunInIO m, K.StreamK m a) + -> Channel m a + -> Maybe WorkerInfo + -> m () +workLoopFIFO q sv winfo = run + + where + + run = do + work <- liftIO $ tryPopR q + case work of + Nothing -> return () + Just (RunInIO runin, m) -> do + r <- liftIO + $ runin + $ K.foldStreamShared + undefined yieldk single (return Continue) m + res <- restoreM r + case res of + Continue -> run + Suspend -> return () + + single a = do + res <- liftIO $ yieldWith winfo sv a + return $ if res then Continue else Suspend + + -- XXX in general we would like to yield "n" elements from a single stream + -- before moving on to the next. Single element granularity could be too + -- expensive in certain cases. Similarly, we can use time limit for + -- yielding. + yieldk a r = do + res <- liftIO $ yieldWith winfo sv a + runInIO <- askRunInIO + -- XXX If the queue is empty we do not need to enqueue. We can just + -- continue evaluating the stream. + liftIO $ enqueueFIFO sv q (runInIO, r) + return $ if res then Continue else Suspend + +{-# INLINE workLoopFIFOLimited #-} +workLoopFIFOLimited + :: forall m a. MonadRunInIO m + => LinkedQueue (RunInIO m, K.StreamK m a) + -> Channel m a + -> Maybe WorkerInfo + -> m () +workLoopFIFOLimited q sv winfo = run + + where + + incrContinue = + liftIO (incrementYieldLimit (remainingWork sv)) >> return Continue + + run = do + work <- liftIO $ tryPopR q + case work of + Nothing -> return () + Just (RunInIO runin, m) -> do + yieldLimitOk <- liftIO $ decrementYieldLimit (remainingWork sv) + if yieldLimitOk + then do + r <- liftIO + $ runin + $ K.foldStreamShared + undefined yieldk single incrContinue m + res <- restoreM r + case res of + Continue -> run + Suspend -> return () + else liftIO $ do + enqueueFIFO sv q (RunInIO runin, m) + incrementYieldLimit (remainingWork sv) + + single a = do + res <- liftIO $ yieldWith winfo sv a + return $ if res then Continue else Suspend + + yieldk a r = do + res <- liftIO $ yieldWith winfo sv a + runInIO <- askRunInIO + liftIO $ enqueueFIFO sv q (runInIO, r) + yieldLimitOk <- liftIO $ decrementYieldLimit (remainingWork sv) + if res && yieldLimitOk + then return Continue + else liftIO $ do + incrementYieldLimit (remainingWork sv) + return Suspend + +------------------------------------------------------------------------------- +-- SVar creation +------------------------------------------------------------------------------- + +-- XXX we have this function in this file because passing runStreamLIFO as a +-- function argument to this function results in a perf degradation of more +-- than 10%. Need to investigate what the root cause is. +-- Interestingly, the same thing does not make any difference for Ahead. +getFifoSVar :: forall m a. MonadRunInIO m => + RunInIO m -> Config -> IO (Channel m a) +getFifoSVar mrun cfg = do + outQ <- newIORef ([], 0) + outQMv <- newEmptyMVar + active <- newIORef 0 + wfw <- newIORef False + running <- newIORef Set.empty + q <- newQ + yl <- case getYieldLimit cfg of + Nothing -> return Nothing + Just x -> Just <$> newIORef x + stoppingRef <- newIORef False + stoppedMVar <- newMVar False + rateInfo <- newRateInfo cfg + + stats <- newSVarStats + tid <- myThreadId + + let isWorkFinished _ = nullQ q + let isWorkFinishedLimited sv = do + yieldsDone <- + case remainingWork sv of + Just ref -> do + n <- readIORef ref + return (n <= 0) + Nothing -> return False + qEmpty <- nullQ q + return $ qEmpty || yieldsDone + + let getSVar :: Channel m a + -> (Channel m a -> m [ChildEvent a]) + -> (Channel m a -> m Bool) + -> (Channel m a -> IO Bool) + -> (LinkedQueue (RunInIO m, K.StreamK m a) + -> Channel m a + -> Maybe WorkerInfo + -> m()) + -> Channel m a + getSVar sv readOutput postProc workDone wloop = Channel + { outputQueue = outQ + , remainingWork = yl + , maxBufferLimit = getMaxBuffer cfg + , maxWorkerLimit = min (getMaxThreads cfg) (getMaxBuffer cfg) + , yieldRateInfo = rateInfo + , outputDoorBell = outQMv + , readOutputQ = readOutput sv + , postProcess = postProc sv + , workerThreads = running + , workLoop = wloop q sv + , channelStopping = stoppingRef + , channelStopped = stoppedMVar + , enqueue = enqueueFIFO sv q + , eagerDispatch = return () + , isWorkDone = workDone sv + , isQueueDone = workDone sv + , doorBellOnWorkQ = wfw + , svarMrun = mrun + , workerCount = active + , accountThread = delThread running + , workerStopMVar = undefined + , svarRef = Nothing + , svarInspectMode = getInspectMode cfg + , svarCreator = tid + , svarStats = stats + } + + let sv = + case getStreamRate cfg of + Nothing -> + case getYieldLimit cfg of + Nothing -> getSVar sv (readOutputQBounded False) + postProcessBounded + isWorkFinished + workLoopFIFO + Just _ -> getSVar sv (readOutputQBounded False) + postProcessBounded + isWorkFinishedLimited + workLoopFIFOLimited + Just _ -> + case getYieldLimit cfg of + Nothing -> getSVar sv readOutputQPaced + postProcessPaced + isWorkFinished + workLoopFIFO + Just _ -> getSVar sv readOutputQPaced + postProcessPaced + isWorkFinishedLimited + workLoopFIFOLimited + in return sv + +-- XXX GHC: If instead of MonadAsync we use (MonadIO m, MonadBaseControl IO m) +-- constraint we get a 2x perf regression. Need to look into that. + +-- | Create a new 'interleaved' style concurrent stream evaluation channel. The +-- monad state used to run the stream actions is taken from the call site of +-- newInterleaveChannel. +-- +-- This is a low level API, use newChannel instead. +{-# INLINABLE newInterleaveChannel #-} +{-# SPECIALIZE newInterleaveChannel :: (Config -> Config) -> IO (Channel IO a) #-} +newInterleaveChannel :: MonadAsync m => + (Config -> Config) -> m (Channel m a) +newInterleaveChannel modifier = do + mrun <- askRunInIO + liftIO $ getFifoSVar mrun (modifier defaultConfig) diff --git a/src/Streamly/Internal/Data/Stream/Channel/Operations.hs b/src/Streamly/Internal/Data/Stream/Channel/Operations.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/Channel/Operations.hs @@ -0,0 +1,335 @@ +#ifdef __HADDOCK_VERSION__ +#undef INSPECTION +#endif + +#ifdef INSPECTION +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-} +#endif + +-- | +-- Module : Streamly.Internal.Data.Stream.Channel.Operations +-- Copyright : (c) 2017 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +module Streamly.Internal.Data.Stream.Channel.Operations + ( + -- *** Reading Stream + fromChannelK + , fromChannel + + -- ** Enqueuing Work + , toChannelK + , toChannel + ) +where + +#include "inline.hs" + +import Control.Exception (fromException, displayException) +import Control.Monad (when) +import Control.Monad.Catch (throwM, MonadThrow) +import Control.Monad.IO.Class (MonadIO(liftIO)) +#if __GLASGOW_HASKELL__ >= 810 +import Data.Kind (Type) +#endif +import Data.IORef (newIORef, mkWeakIORef, writeIORef) +import Streamly.Internal.Control.Concurrent + (MonadAsync, MonadRunInIO, askRunInIO) +import Streamly.Internal.Data.Stream (Stream) +import Streamly.Internal.Data.Time.Clock (Clock(Monotonic), getTime) + +import qualified Streamly.Internal.Data.Stream as Stream +import qualified Streamly.Internal.Data.Stream as D +import qualified Streamly.Internal.Data.StreamK as K + +import Streamly.Internal.Data.Channel.Types +import Streamly.Internal.Data.Stream.Channel.Dispatcher +import Streamly.Internal.Data.Stream.Channel.Type hiding (inspect) + +import Prelude hiding (map, concat, concatMap) + +#ifdef INSPECTION +import Control.Exception (Exception) +import Control.Monad.Trans.Control (MonadBaseControl) +import Data.Typeable (Typeable) +import Test.Inspection (inspect, hasNoTypeClassesExcept) +#endif + +------------------------------------------------------------------------------ +-- Generating streams from a channel +------------------------------------------------------------------------------ + +-- $concurrentEval +-- +-- Usually a channel is used to concurrently evaluate multiple actions in a +-- stream using many worker threads that push the results to the channel and a +-- single puller that pulls them from channel generating the evaluated stream. +-- +-- @ +-- input stream +-- | +-- <-----------------|<--------worker +-- | exceptions | +-- output stream <---Channel<------worker +-- | +-- |<--------worker +-- +-- @ +-- +-- The puller itself schedules the worker threads based on demand. +-- Exceptions are propagated from the worker threads to the puller. + +------------------------------------------------------------------------------- +-- Write a stream to a channel +------------------------------------------------------------------------------- + +-- XXX Should be a Fold, singleton API could be called joinChannel, or the fold +-- can be called joinChannel. +-- XXX If we use toChannelK multiple times on a channel make sure the channel +-- does not go away before we use the subsequent ones. + +-- | High level function to enqueue a work item on the channel. The fundamental +-- unit of work is a stream. Each stream enqueued on the channel is picked up +-- and evaluated by a worker thread. The worker evaluates the stream it picked +-- up serially. When multiple streams are queued on the channel each stream can +-- be evaluated concurrently by different workers. +-- +-- Note that the items in each stream are not concurrently evaluated, streams +-- are fundamentally serial, therefore, elements in one particular stream will +-- be generated serially one after the other. Only two or more streams can be +-- run concurrently with each other. +-- +-- See 'chanConcatMapK' for concurrent evaluation of each element of a stream. +-- Alternatively, you can wrap each element of the original stream into a +-- stream generating action and queue all those streams on the channel. Then +-- all of them would be evaluated concurrently. However, that would not be +-- streaming in nature, it would require buffering space for the entire +-- original stream. Prefer 'chanConcatMapK' for larger streams. +-- +-- Items from each evaluated streams are queued to the same output queue of the +-- channel which can be read using 'fromChannelK'. 'toChannelK' can be called +-- multiple times to enqueue multiple streams on the channel. +-- +{-# INLINE toChannelK #-} +toChannelK :: MonadRunInIO m => Channel m a -> K.StreamK m a -> m () +toChannelK chan m = do + runIn <- askRunInIO + liftIO $ enqueue chan (runIn, m) + +-- INLINE for fromStreamK/toStreamK fusion + +-- | A wrapper over 'toChannelK' for 'Stream' type. +{-# INLINE toChannel #-} +toChannel :: MonadRunInIO m => Channel m a -> Stream m a -> m () +toChannel chan = toChannelK chan . Stream.toStreamK + +{- +-- | Send a stream of streams to a concurrent channel for evaluation. +{-# INLINE joinChannel #-} +joinChannel :: Channel m a -> Fold m (Stream m a) () +joinChannel = undefined +-} + +------------------------------------------------------------------------------- +-- Read a stream from a channel +------------------------------------------------------------------------------- + +-- | Pull a stream from an SVar. +{-# NOINLINE fromChannelRaw #-} +fromChannelRaw :: (MonadIO m, MonadThrow m) => Channel m a -> K.StreamK m a +fromChannelRaw sv = K.MkStream $ \st yld sng stp -> do + list <- readOutputQ sv + -- Reversing the output is important to guarantee that we process the + -- outputs in the same order as they were generated by the constituent + -- streams. + K.foldStream st yld sng stp $ processEvents $ reverse list + + where + + {-# INLINE processEvents #-} + processEvents [] = K.MkStream $ \st yld sng stp -> do + done <- postProcess sv + if done + then liftIO (channelDone sv "Channel done") >> stp + else K.foldStream st yld sng stp $ fromChannelRaw sv + + processEvents (ev : es) = K.MkStream $ \st yld sng stp -> do + let rest = processEvents es + case ev of + ChildYield a -> yld a rest + ChildStopChannel -> do + liftIO $ cleanupChan sv "ChildStopChannel" + stp + ChildStop tid e -> do + accountThread sv tid + case e of + Nothing -> K.foldStream st yld sng stp rest + Just ex -> + case fromException ex of + Just ThreadAbort -> + -- We terminate the loop after sending + -- ThreadAbort to workers so we should never + -- get it unless it is thrown from inside a + -- worker thread or by someone else to our + -- thread. + error $ "processEvents: got ThreadAbort for tid " ++ show tid + -- K.foldStream st yld sng stp rest + Nothing -> do + liftIO $ cleanupChan sv (displayException ex) + throwM ex + +#ifdef INSPECTION +-- Use of GHC constraint tuple (GHC.Classes.(%,,%)) in fromStreamVar leads to +-- space leak because the tuple gets allocated in every recursive call and each +-- allocation holds on to the previous allocation. This test is to make sure +-- that we do not use the constraint tuple type class. +-- +inspect $ hasNoTypeClassesExcept 'fromChannelRaw + [ ''Monad + , ''Applicative + , ''MonadThrow + , ''Exception + , ''MonadIO + , ''MonadBaseControl + , ''Typeable + , ''Functor + ] +#endif + +-- XXX Add a lock in the channel so that fromChannel cannot be called multiple +-- times. +-- +-- XXX Add an option to block the consumer rather than stopping the stream if +-- the work queue gets over. + +-- | Draw a stream from a concurrent channel. The stream consists of the +-- evaluated values from the input streams that were enqueued on the channel +-- using 'toChannelK'. +-- +-- This is the event processing loop for the channel which does two +-- things, (1) dispatch workers, (2) process the events sent by the workers. +-- Workers are dispatched based on the channel's configuration settings. +-- +-- The stream stops and the channel is shutdown if any of the following occurs: +-- +-- * the work queue becomes empty +-- * channel's max yield limit is reached +-- * an exception is thrown by a worker +-- * 'shutdown' is called on the channel +-- +-- Before the channel stops, all the workers are drained and no more workers +-- are dispatched. When the channel is garbage collected a 'ThreadAbort' +-- exception is thrown to all pending workers. If 'inspect' option is enabled +-- then channel's stats are printed on stdout when the channel stops. +-- +-- CAUTION! This API must not be called more than once on a channel. +{-# INLINE fromChannelK #-} +fromChannelK :: MonadAsync m => + Maybe (IO () -> IO ()) -> Channel m a -> K.StreamK m a +fromChannelK register chan = + -- Note: when an explicit cleanup handler registration is used, we still + -- install a GC based cleanup handler, in case the explicit cleanup handler + -- is not called by the user we will still clean it up when it is garbage + -- collected. + K.mkStream $ \st yld sng stp -> do + ref <- liftIO $ newIORef () + _ <- liftIO $ mkWeakIORef ref (cleanupChan chan "Channel cleanup via GC") + let msg = "Channel cleanup via explicit handler" + + -- Register the cleanup handler to be called at the end of a user + -- defined bracket. + -- + -- IMPORTANT: this hook should run before the resource cleanup hooks + -- registered by the worker threads themselves. If the auto release + -- hooks registered by the workers run first then we might release the + -- resources which are potentially in use by the workers, thus the + -- workers may misbehave. The correct sequence is to first abort and + -- drain all the workers then run any hooks registered by them. + + case register of + Nothing -> return () + Just f -> liftIO $ f (cleanupChan chan msg) + + startChannel chan + -- We pass a copy of chan to fromChannelRaw, with svarRef set to ref, + -- so that we know that it has no other references, when that copy gets + -- garbage collected "ref" will get garbage collected and our hook will + -- be called. + -- + -- XXX We should install cleanupChan as the exception handler for + -- ThreadAbort or any async exception while running fromChannelRaw. + K.foldStreamShared st yld sng stp $ + fromChannelRaw chan{svarRef = Just ref} + +-- | A wrapper over 'fromChannelK' for 'Stream' type. +{-# INLINE fromChannel #-} +fromChannel :: MonadAsync m => Channel m a -> Stream m a +-- XXX Pass the cleanup registration function to fromChannelK +fromChannel = Stream.fromStreamK . fromChannelK Nothing + +#if __GLASGOW_HASKELL__ >= 810 +type FromSVarState :: Type -> (Type -> Type) -> Type -> Type +#endif +data FromSVarState t m a = + FromSVarInit + | FromSVarRead (Channel m a) + | FromSVarLoop (Channel m a) [ChildEvent a] + | FromSVarDone (Channel m a) + +-- | Like 'fromSVar' but generates a StreamD style stream instead of CPS. +-- +{-# INLINE_NORMAL _fromChannelD #-} +_fromChannelD :: (MonadIO m, MonadThrow m) => Channel m a -> D.Stream m a +_fromChannelD svar = D.Stream step FromSVarInit + where + + {-# INLINE_LATE step #-} + step _ FromSVarInit = do + ref <- liftIO $ newIORef () + _ <- liftIO $ mkWeakIORef ref (cleanupChan svar "Channel cleanup via GC") + -- when this copy of svar gets garbage collected "ref" will get + -- garbage collected and our GC hook will be called. + let sv = svar{svarRef = Just ref} + return $ D.Skip (FromSVarRead sv) + + step _ (FromSVarRead sv) = do + list <- readOutputQ sv + -- Reversing the output is important to guarantee that we process the + -- outputs in the same order as they were generated by the constituent + -- streams. + return $ D.Skip $ FromSVarLoop sv (Prelude.reverse list) + + step _ (FromSVarLoop sv []) = do + done <- postProcess sv + return $ D.Skip $ if done + then FromSVarDone sv + else FromSVarRead sv + + step _ (FromSVarLoop sv (ev : es)) = do + case ev of + ChildYield a -> return $ D.Yield a (FromSVarLoop sv es) + ChildStopChannel -> do + liftIO $ cleanupChan sv "ChildStopChannel" + return $ D.Skip (FromSVarDone sv) + ChildStop tid e -> do + accountThread sv tid + case e of + Nothing -> return $ D.Skip (FromSVarLoop sv es) + Just ex -> + case fromException ex of + Just ThreadAbort -> + return $ D.Skip (FromSVarLoop sv es) + Nothing -> do + liftIO $ cleanupChan sv (displayException ex) + throwM ex + + step _ (FromSVarDone sv) = do + when (svarInspectMode sv) $ do + t <- liftIO $ getTime Monotonic + liftIO $ writeIORef (svarStopTime (svarStats sv)) (Just t) + liftIO $ printSVar (dumpChannel sv) "SVar Done" + return D.Stop diff --git a/src/Streamly/Internal/Data/Stream/Channel/Type.hs b/src/Streamly/Internal/Data/Stream/Channel/Type.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/Channel/Type.hs @@ -0,0 +1,887 @@ +-- | +-- Module : Streamly.Internal.Data.Stream.Channel.Type +-- Copyright : (c) 2017 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +module Streamly.Internal.Data.Stream.Channel.Type + ( + -- ** Type + Channel(..) + + -- ** Configuration + , Config + + -- *** Default config + , defaultConfig + + -- *** Limits + , maxThreads + , maxBuffer + , maxYields + + -- *** Rate Control + , Rate(..) + , newRateInfo + , rate + , avgRate + , minRate + , maxRate + , constRate + + -- *** Stop behavior + , StopWhen (..) + , stopWhen + + -- *** Scheduling behavior + , eager + , ordered + , interleaved + , boundThreads + + -- *** Diagnostics + , inspect + + -- *** Resource management + , useAcquire + , clearAcquire + + -- *** Get config + , getMaxBuffer + , getMaxThreads + , getYieldLimit + , getInspectMode + , getStreamRate + , getEagerDispatch + , getOrdered + , getStopWhen + , getInterleaved + , getCleanup + + -- ** Sending Worker Events + , yieldWith + , stopWith + , exceptionWith + , shutdown + + -- ** Cleanup + , channelDone + , cleanupChan + + -- ** Diagnostics + , dumpChannel + ) +where + +import Control.Concurrent (ThreadId, throwTo, takeMVar, putMVar) +import Control.Concurrent.MVar (MVar) +import Control.Exception (SomeException(..)) +import Control.Monad (void, when) +import Control.Monad.IO.Class (MonadIO(..)) +import Data.Int (Int64) +import Data.IORef (IORef, newIORef, readIORef, atomicWriteIORef, writeIORef) +import Data.List (intersperse) +import Data.Set (Set) +import Streamly.Internal.Control.Concurrent (RunInIO) +import Streamly.Internal.Data.Atomics (atomicModifyIORefCAS) +import Streamly.Internal.Data.Channel.Dispatcher (dumpSVarStats) +import Streamly.Internal.Data.Channel.Worker + (sendYield, sendStop, sendEvent, sendException) +import Streamly.Internal.Data.StreamK (StreamK) +import Streamly.Internal.Control.Exception + (AcquireIO(..), Priority(..), registerWith) +import Streamly.Internal.Data.Time.Clock (Clock(Monotonic), getTime) +import Streamly.Internal.Data.Time.Units (NanoSecond64(..)) +import System.Mem (performMajorGC) + +import qualified Data.Set as Set + +import Streamly.Internal.Data.Channel.Types + +-- 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). + +-- XXX Since we have stream specific channels now, we can remove functions like +-- enqueue, readOuputQ, postProcess, workLoop etc from this. + +-- XXX Add an option in channel for minthreads. +-- dispatch tail worker from the worker itself up to min threads or based on +-- pace data. min threads can be increased dynamically by the event loop. +-- for eager minthreads = maxthreads + +-- | A mutable channel to evaluate multiple streams concurrently and provide +-- the combined results as output stream. +-- +-- There are only two actors working on the channel data structure, the event +-- processing loop (single thread), and the workers (multiple threads). Locking +-- notes are provided below for concurrent access. +data Channel m a = Channel + { + -- XXX Do we need this? We store the runner in the work q, is that enough? + -- This seems to be used only by the 'ordered' stream as of now. + + -- | Runner for the monadic actions in the stream. Captures the monad + -- state at the point where the channel was created and uses the same + -- state to run all actions. + svarMrun :: RunInIO m + + --------------------------------------------------------------------------- + -- Output queue related + --------------------------------------------------------------------------- + + -- | Maximum size of the 'outputQueue'. The actual worst case buffer could + -- be double of this as the event loop may read the queue and the workers + -- may fill it up even before the event loop has started consuming. + , maxBufferLimit :: Limit + + -- 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. + -- + -- 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. + -- + -- XXX We can send a bundle of events of one type coaleseced together in an + -- unboxed structure. + + -- | (events, count): worker event queue of the channel. This is where the + -- workers queue the results and other events. + -- + -- [LOCKING] Frequently locked. This is locked and updated by workers on + -- each yield, and locked, updated by the event loop thread once in a while + -- for reading. Workers' locking contention may be high if there are a + -- large number of workers. + , outputQueue :: IORef ([ChildEvent a], Int) + + -- | Door bell for workers to wakeup the event loop. + -- + -- [LOCKING] Infrequently locked. Used only when the 'outputQueue' + -- transitions from empty to non-empty, or a work item is queued by a + -- worker to the work queue and 'doorBellOnWorkQ' is set by the event loop. + -- + -- We also use this for workerCount decrement, we wait on this during + -- cleanup. So any workerCount decrement must send a doorBell. + , outputDoorBell :: MVar () + + -- XXX Can we use IO instead of m here? + + -- | Function to read the output queue of the channel, depends on the rate + -- control option. + , readOutputQ :: m [ChildEvent a] + + -- | Function to invoke after all the events read in a batch are processed + -- i.e. before we go on to read the next batch, depends on the rate control + -- option. + , postProcess :: m Bool + + --------------------------------------------------------------------------- + -- Work and rate control + --------------------------------------------------------------------------- + + -- | Tracks how many yields are remaining before the channel stops, used + -- when 'maxYields' option is enabled. + -- + -- [LOCKING] Read only access by event loop 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) + + -- XXX We make this isChannelDone which should not include isQueueDone. + -- + -- | Determine if there is no more work to do. When 'maxYields' is set for + -- the channel we may be done even if the work queue still has work. + , isWorkDone :: IO Bool + + -- | Rate control information for the channel used when 'rate' control is + -- enabled, + , yieldRateInfo :: Maybe YieldRateInfo + + --------------------------------------------------------------------------- + -- Work queue related + --------------------------------------------------------------------------- + + -- | When set to True, ring 'outputDoorBell' when a work item is queued on + -- the work queue. This is set by the dispatcher before going to sleep. It + -- wants to be woken up whenever the work queue got more work to do so that + -- it can dispatch a worker. + , doorBellOnWorkQ :: IORef Bool + + -- XXX instead of this we should use a dispatcher setting. + + -- | This is a hook which is invoked whenever the tail of the stream is + -- re-enqueued on the work queue. Normally, this is set to a noop. When + -- 'eager' option is enabled this is set to an unconditional worker + -- dispatch function. This ensures that we eagerly send a worker as long + -- as there is work to do. + -- + -- NOTE that this is called from a worker context, therefore we should + -- consider appropriate locking semantics. + , eagerDispatch :: m () + + -- | Enqueue a stream for evaluation on the channel. The first element of + -- the tuple is the runner function which is used to run the stream actions + -- in a specific monadic context. + , enqueue :: (RunInIO m, StreamK m a) -> IO () + + -- | Determine if the work queue is empty, therefore, there is no more work + -- to do. + , isQueueDone :: IO Bool + + -- | Worker function. It is implicitly aware of the work queue. It dequeues + -- a work item from the queue and runs it. It keeps on doing this in a loop + -- until it determines that it needs to stop. + -- + -- Normally, the worker stops when the work queue becomes empty or the work + -- rate is higher than the target rate when rate control is enabled. It + -- stops by sending a 'ChildStop' event to the channel + -- + -- When rate control is enabled, the worker is dispatched with a + -- 'WorkerInfo' record which is used by the worker to maintain rate control + -- information and communicate it to the channel. + , workLoop :: Maybe WorkerInfo -> m () + + , channelStopping :: IORef Bool + , channelStopped :: MVar Bool + + --------------------------------------------------------------------------- + -- Worker thread accounting + --------------------------------------------------------------------------- + -- + -- | This is capped 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 + + -- | Tracks all active worker threads. An entry is added by the dispatcher + -- when a worker is dispatched, and removed whenever the event processing + -- loop receives a 'ChildStop' event. + -- + -- [LOCKING] Normally, this is updated only by the event loop thread, but + -- in case of eager dispatch (done in worker context) it is updated by a + -- worker. So reads from the event loop should be mindful of that. + -- Updates to this must be async signal safe because we rely on it for + -- cleanup and cleanup may leave unfinished threads if a thread is forked + -- but this is not updated. + , workerThreads :: IORef (Set ThreadId) + + -- | Total number of active worker threads. + -- + -- [LOCKING] Updated locked, by the event loop thread when dispatching a + -- worker and by a worker thread when the thread stops. This is read + -- without lock at several places where we want to rely on an approximate + -- value. Updates to this must be async signal safe because we rely on it + -- for cleanup and cleanup may hang and leave unfinished threads if this is + -- not correct. + , workerCount :: IORef Int + + -- XXX Can we use IO instead of m here? + , accountThread :: ThreadId -> m () + + -- | Used when 'ordered' is enabled. This is a lock to stop the workers one + -- at a time. Stopping one might affect whether the other should stop. + , workerStopMVar :: MVar () + + --------------------------------------------------------------------------- + -- Channel cleanup -- + --------------------------------------------------------------------------- + -- | A weak IORef to call a cleanup function when the channel is garbage + -- collected. + , svarRef :: Maybe (IORef ()) + + --------------------------------------------------------------------------- + -- Channel Stats -- + --------------------------------------------------------------------------- + -- | Stats collection. + , svarStats :: SVarStats + + --------------------------------------------------------------------------- + -- Diagnostics -- + --------------------------------------------------------------------------- + -- | When 'inspect' mode is enabled we report diagnostic data about the + -- channel at certain points. + , svarInspectMode :: Bool + -- | threadId of the thread that created the channel + , svarCreator :: ThreadId + + -- XXX Add a map of dispatcher thread to worker thread. + } + +------------------------------------------------------------------------------- +-- Channel Config +------------------------------------------------------------------------------- + +-- 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 + +-- | An abstract type for specifying the configuration parameters of a +-- 'Channel'. Use @Config -> Config@ modifier functions to modify the default +-- configuration. See the individual modifier documentation for default values. +-- +data Config = Config + { -- 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 + , _inspect :: Bool + , _eagerDispatch :: Bool + , _stopWhen :: StopWhen + , _ordered :: Bool + , _interleaved :: Bool + , _bound :: Bool + + -- XXX We can also use resource-t to release the channel. But that will + -- require a MonadResource constraint. It is a bigger change, we can plan + -- in future. With MonadResource, runResourceT will have to be called to + -- create a scope. Here we have an option to use prompt release or GC + -- release, but there are chances of missing a prompt release when the + -- option is provided to the programmer instead of always enforcing it. + -- + -- We could store Channel m a, here instead of a deallocation function, if + -- we make the Config type as "Config m a". That way we can also share + -- channels across multiple computations. + , _release :: Maybe (IO () -> IO ()) + } + +------------------------------------------------------------------------------- +-- State defaults and reset +------------------------------------------------------------------------------- + +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. Use get/set routines instead of directly accessing +-- the Config fields +defaultConfig :: Config +defaultConfig = Config + { -- streamVar = Nothing + _yieldLimit = Nothing + , _threadsHigh = defaultMaxThreads + , _bufferHigh = defaultMaxBuffer + , _maxStreamRate = Nothing + , _streamLatency = Nothing + , _inspect = False + -- XXX Set it to True when Rate is not set? + , _eagerDispatch = False + , _stopWhen = AllStop + , _ordered = False + , _interleaved = False + , _bound = False + , _release = Nothing + } + +------------------------------------------------------------------------------- +-- Smart get/set routines for State +------------------------------------------------------------------------------- + +-- | The maximum number of yields that this channel would produce. The Channel +-- automatically stops after that. This could be used to limit the speculative +-- execution beyond the limit. +-- +-- 'Nothing' means there is no limit. +-- +-- Keep in mind that checking this limit all the time has a performance +-- overhead. +-- +-- Known Bugs: currently this works only when rate is specified. +-- Known Bugs: for ordered streams sometimes the actual count is less than +-- expected. +maxYields :: Maybe Int64 -> Config -> Config +maxYields lim st = + st { _yieldLimit = + case lim of + Nothing -> Nothing + Just n -> + if n <= 0 + then Just 0 + else Just (fromIntegral n) + } + +getYieldLimit :: Config -> Maybe Count +getYieldLimit = _yieldLimit + +-- | Specify the maximum number of threads that can be spawned by the channel. +-- A value of 0 resets the thread limit to default, a negative value means +-- there is no limit. The default value is 1500. +-- +-- When the actions in a stream are IO bound, having blocking IO calls, this +-- option can be used to control the maximum number of in-flight IO requests. +-- When the actions are CPU bound this option can be used to control the amount +-- of CPU used by the stream. +-- +maxThreads :: Int -> Config -> Config +maxThreads n st = + st { _threadsHigh = + if n < 0 + then Unlimited + else if n == 0 + then defaultMaxThreads + else Limited (fromIntegral n) + } + +getMaxThreads :: Config -> Limit +getMaxThreads = _threadsHigh + +-- | Specify the maximum size of the buffer for storing the results from +-- concurrent computations. If the buffer becomes full we stop spawning more +-- concurrent tasks until there is space in the buffer. +-- A value of 0 resets the buffer size to default, a negative value means +-- there is no limit. The default value is 1500. +-- +-- CAUTION! using an unbounded 'maxBuffer' value (i.e. a negative value) +-- coupled with an unbounded 'maxThreads' value is a recipe for disaster in +-- presence of infinite streams, or very large streams. Especially, it must +-- not be used when 'pure' is used in 'ZipAsyncM' streams as 'pure' in +-- applicative zip streams generates an infinite stream causing unbounded +-- concurrent generation with no limit on the buffer or threads. +-- +maxBuffer :: Int -> Config -> Config +maxBuffer n st = + st { _bufferHigh = + if n < 0 + then Unlimited + else if n == 0 + then defaultMaxBuffer + else Limited (fromIntegral n) + } + +getMaxBuffer :: Config -> Limit +getMaxBuffer = _bufferHigh + +-- | Specify the stream evaluation rate of a channel. +-- +-- A 'Nothing' value means there is no smart rate control, concurrent execution +-- blocks only if 'maxThreads' or 'maxBuffer' is reached, or there are no more +-- concurrent tasks to execute. This is the default. +-- +-- When rate (throughput) is specified, concurrent production may be ramped +-- up or down automatically to achieve the specified stream throughput. The +-- specific behavior for different styles of 'Rate' specifications is +-- documented under 'Rate'. The effective maximum production rate achieved by +-- a channel is governed by: +-- +-- * The 'maxThreads' limit +-- * The 'maxBuffer' limit +-- * The maximum rate that the stream producer can achieve +-- * The maximum rate that the stream consumer can achieve +-- +-- Maximum production rate is given by: +-- +-- \(rate = \frac{maxThreads}{latency}\) +-- +-- If we know the average latency of the tasks we can set 'maxThreads' +-- accordingly. +-- +rate :: Maybe Rate -> Config -> Config +rate r st = st { _maxStreamRate = r } + +getStreamRate :: Config -> Maybe Rate +getStreamRate = _maxStreamRate + +_setStreamLatency :: Int -> Config -> Config +_setStreamLatency n st = + st { _streamLatency = + if n <= 0 + then Nothing + else Just (fromIntegral n) + } + +getStreamLatency :: Config -> Maybe NanoSecond64 +getStreamLatency = _streamLatency + +-- XXX Rename to "inspect" + +-- | Print debug information about the 'Channel' when the stream ends. When the +-- stream does not end normally, the channel debug information is printed when +-- the channel is garbage collected. If you are expecting but not seeing the +-- debug info try adding a 'performMajorGC' before the program ends. +-- +inspect :: Bool -> Config -> Config +inspect flag st = st { _inspect = flag } + +getInspectMode :: Config -> Bool +getInspectMode = _inspect + +-- | By default, processing of output from the worker threads is given priority +-- over dispatching new workers. More workers are dispatched only when there is +-- no output to process. When 'eager' is set to 'True', workers are dispatched +-- aggresively as long as there is more work to do irrespective of whether +-- there is output pending to be processed by the stream consumer. However, +-- dispatching may stop if 'maxThreads' or 'maxBuffer' is reached. +-- +-- /Note:/ This option has no effect when rate has been specified. +-- +-- /Note:/ Not supported with 'interleaved'. +-- +eager :: Bool -> Config -> Config +eager flag st = st { _eagerDispatch = flag } + +getEagerDispatch :: Config -> Bool +getEagerDispatch = _eagerDispatch + +-- | Specify when the 'Channel' should stop. +stopWhen :: StopWhen -> Config -> Config +stopWhen cond st = st { _stopWhen = cond } + +getStopWhen :: Config -> StopWhen +getStopWhen = _stopWhen + +-- | When enabled the streams may be evaluated cocnurrently but the results are +-- produced in the same sequence as a serial evaluation would produce. +-- +-- /Note:/ Not supported with 'interleaved'. +-- +ordered :: Bool -> Config -> Config +ordered flag st = st { _ordered = flag } + +getOrdered :: Config -> Bool +getOrdered = _ordered + +-- | Interleave the streams fairly instead of prioritizing the left stream. +-- This schedules all streams in a round robin fashion over limited number of +-- threads. +-- +-- /Note:/ Can only be used on finite number of streams. +-- +-- /Note:/ Not supported with 'ordered'. +-- +interleaved :: Bool -> Config -> Config +interleaved flag st = st { _interleaved = flag } + +getInterleaved :: Config -> Bool +getInterleaved = _interleaved + +-- | Spawn bound threads (i.e., spawn threads using 'forkOS' instead of +-- 'forkIO'). The default value is 'False'. +-- +-- /Unimplemented/ +boundThreads :: Bool -> Config -> Config +boundThreads flag st = st { _bound = flag } + +_getBound :: Config -> Bool +_getBound = _bound + +-- | A concurrent stream allocates worker threads to evaluates actions in the +-- stream concurrently. When an exception (sync or async) occurs in the code +-- outside the scope of the stream generation code, these workers need to be +-- stopped promptly. To enable that we can use an 'AcquireIO' bracket from the +-- surrounding scope. When 'AcquireIO' scope ends the channel is automatically +-- cleaned up. +-- +-- Here is an example: +-- +-- >>> import Control.Monad (when) +-- >>> import Control.Concurrent (threadDelay) +-- >>> import Data.Function ((&)) +-- >>> import System.IO (hClose, IOMode(..), openFile) +-- +-- >>> import qualified Streamly.Data.Fold as Fold +-- >>> import qualified Streamly.Data.Stream.Prelude as Stream +-- >>> import qualified Streamly.Control.Exception as Exception +-- +-- >>> :{ +-- close x h = do +-- putStrLn $ "closing: " ++ x +-- hClose h +-- :} +-- +-- >>> :{ +-- action ref = +-- Stream.fromList ["file1", "file2"] +-- & Stream.parMapM (Stream.useAcquire ref) +-- (\x -> do +-- (h, release) <- Exception.acquire ref (openFile x ReadMode) (close x) +-- -- use h here +-- threadDelay 1000000 +-- when (x == "file1") $ do +-- putStrLn $ "Manually releasing: " ++ x +-- release +-- return x +-- ) +-- & Stream.trace print +-- & Stream.fold Fold.drain +-- :} +-- +-- >>> run = Exception.withAcquireIO action +-- +useAcquire :: AcquireIO -> Config -> Config +useAcquire f cfg = cfg { _release = Just (registerWith Priority1 f) } + +-- | Clear the resource release registration function. +clearAcquire :: Config -> Config +clearAcquire cfg = cfg { _release = Nothing } + +getCleanup :: Config -> Maybe (IO () -> IO ()) +getCleanup = _release + +------------------------------------------------------------------------------- +-- Initialization +------------------------------------------------------------------------------- + +newRateInfo :: Config -> IO (Maybe YieldRateInfo) +newRateInfo 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 + } + +------------------------------------------------------------------------------- +-- Rate +------------------------------------------------------------------------------- + +-- | Same as @rate (Just $ Rate (r/2) r (2*r) maxBound)@ +-- +-- Specifies the average production rate of a stream in number of yields +-- per second (i.e. @Hertz@). Concurrent production is ramped up or down +-- automatically to achieve the specified average yield rate. The rate can +-- go down to half of the specified rate on the lower side and double of +-- the specified rate on the higher side. +-- +avgRate :: Double -> Config -> Config +avgRate r = rate (Just $ Rate (r/2) r (2*r) maxBound) + +-- | Same as @rate (Just $ Rate r r (2*r) maxBound)@ +-- +-- Specifies the minimum rate at which the stream should yield values. As +-- far as possible the yield rate would never be allowed to go below the +-- specified rate, even though it may possibly go above it at times, the +-- upper limit is double of the specified rate. +-- +minRate :: Double -> Config -> Config +minRate r = rate (Just $ Rate r r (2*r) maxBound) + +-- | Same as @rate (Just $ Rate (r/2) r r maxBound)@ +-- +-- Specifies the maximum rate at which the stream should yield values. As +-- far as possible the yield rate would never be allowed to go above the +-- specified rate, even though it may possibly go below it at times, the +-- lower limit is half of the specified rate. This can be useful in +-- applications where certain resource usage must not be allowed to go +-- beyond certain limits. +-- +maxRate :: Double -> Config -> Config +maxRate r = rate (Just $ Rate (r/2) r r maxBound) + +-- | Same as @rate (Just $ Rate r r r 0)@ +-- +-- Specifies a constant yield rate. If for some reason the actual rate +-- goes above or below the specified rate we do not try to recover it by +-- increasing or decreasing the rate in future. This can be useful in +-- applications like graphics frame refresh where we need to maintain a +-- constant refresh rate. +-- +constRate :: Double -> Config -> Config +constRate r = rate (Just $ Rate r r r 0) + +------------------------------------------------------------------------------- +-- Operations +------------------------------------------------------------------------------- + +-- | Used by workers to send a value to the channel's output stream. +-- +-- When a worker is dispatched, a 'WorkerInfo' record is supplied to it by the +-- dispatcher. This record contains the timestamp at the time of dispatch. +-- Whenever the worker yields a value, the yield count in the 'WorkerInfo' is +-- incremented. If the channel has rate control enabled, the yield count and +-- time duration is periodically (based on 'workerPollingInterval') pushed to +-- the channel's 'workerPendingLatency' stat. It is done only if the +-- 'workerPollingInterval' is non-zero. +-- +-- Queues the event but returns 'False' if: +-- +-- * the buffer limit is exceeding +-- * channel yield rate is exceeding (when rate control is enabled and +-- 'WorkerInfo' is available) +-- +-- This is a thread-safe API and can be called by anyone from anywhere. Even a +-- thread that is not registered as a worker with the channel can use it but +-- when rate control is enabled, it might confuse the rate control mechanism if +-- we use workers beyond the knowledge of dispatcher. +-- +{-# INLINE yieldWith #-} +yieldWith :: + Maybe WorkerInfo -- ^ Rate control info for the worker + -> Channel m a + -> a + -> IO Bool -- ^ True means the worker can continue otherwise stop. +yieldWith winfo chan = + sendYield + (maxBufferLimit chan) + (maxWorkerLimit chan) + (workerCount chan) + (yieldRateInfo chan) + (outputQueue chan) + (outputDoorBell chan) + winfo + +-- | Send a 'ChildStop' event to the channel, used when the worker stops +-- yielding and exits. The final update of the collected latency stats in +-- 'WorkerInfo' is pushed to the channel. Upon receiving the 'ChildStop' event +-- the channel would remove the worker from its set of registered workers. +-- +-- A worker that uses this API must have been registered on the Channel prior +-- to invoking this API. This is usually done by the dispatcher when the +-- worker is dispatched. +{-# INLINE stopWith #-} +stopWith :: Maybe WorkerInfo -> Channel m a -> IO () +stopWith winfo chan = + sendStop + (workerCount chan) + (yieldRateInfo chan) + (outputQueue chan) + (outputDoorBell chan) + winfo + +-- | Like 'stopWith' but marks the stop event with the specified exception. +{-# INLINE exceptionWith #-} +exceptionWith :: Maybe WorkerInfo -> Channel m a -> SomeException -> IO () +exceptionWith _winfo chan = + sendException + (workerCount chan) + (outputQueue chan) + (outputDoorBell chan) + +-- | Send a 'ChildStopChannel' event to shutdown the channel. Upon receiving +-- the event the event processing loop kills all the registered worker threads +-- and stops the channel. +{-# INLINABLE shutdown #-} +shutdown :: MonadIO m => Channel m a -> m () +shutdown chan = liftIO $ do + void + $ sendEvent + (outputQueue chan) + (outputDoorBell chan) + ChildStopChannel + +-- | Dump the channel stats for diagnostics. Used when 'inspect' option is +-- enabled. +{-# NOINLINE dumpChannel #-} +dumpChannel :: Channel m a -> IO String +dumpChannel sv = do + xs <- sequence $ intersperse (return "\n") + [ return (dumpCreator (svarCreator sv)) + , return "---------CURRENT STATE-----------" + , dumpOutputQ (outputQueue sv) + -- XXX print the types of events in the outputQueue, first 5 + , dumpDoorBell (outputDoorBell sv) + , dumpNeedDoorBell (doorBellOnWorkQ sv) + , dumpRunningThreads (workerThreads sv) + -- XXX print the status of first 5 threads + , dumpWorkerCount (workerCount sv) + , return "---------STATS-----------\n" + , dumpSVarStats (svarInspectMode sv) (yieldRateInfo sv) (svarStats sv) + ] + return $ concat xs + +------------------------------------------------------------------------------- +-- Cleanup +------------------------------------------------------------------------------- + +channelDone :: Channel m a -> String -> IO () +channelDone chan reason = do + when (svarInspectMode chan) $ do + t <- getTime Monotonic + writeIORef (svarStopTime (svarStats chan)) (Just t) + printSVar (dumpChannel chan) reason + -- If there are any other channels referenced by this channel a GC will + -- prompt them to be cleaned up quickly. + performMajorGC + +-- XXX Handle ThreadAbort while this is running? + +-- | Never called from a worker thread. This can be called multiple times and +-- only one will succeed others will block until it finishes. +-- +cleanupChan :: Channel m a -> String -> IO () +cleanupChan chan reason = do + stopped <- takeMVar (channelStopped chan) + when (not stopped) $ do + -- putStrLn "cleanupChan: START" + atomicWriteIORef (channelStopping chan) True + go + channelDone chan reason + putMVar (channelStopped chan) True + -- putStrLn "cleanupChan: DONE" + + where + + go = do + -- Empty the queue so that any new results put the doorbell MVar + _ <- readOutputQBasic (outputQueue chan) + cnt <- readIORef (workerCount chan) + -- Note that the workerSet may not have the threadIds of those workers + -- which are in the process of dispatch but not yet dispatched. To + -- ensure that we have aborted all the workers we need to wait until + -- the worker count drops down to zero, until then we need to watch the + -- workerset and send ThreadAbort if we find any ThreadId in it. As of + -- now, this can only happen in the eagerDispatch case as we can + -- dispatch workers from workers in that case. + workers <- + atomicModifyIORefCAS (workerThreads chan) (\x -> (Set.empty,x)) + -- self <- myThreadId + Prelude.mapM_ (`throwTo` ThreadAbort) + -- (Prelude.filter (/= self) $ Set.toList workers) + (Set.toList workers) + {- + let setSize = Set.size workers + putStrLn $ "cleanupChan: thread count: " ++ show cnt + ++ " workerSet size: " ++ show setSize + -} + when (cnt /= 0) $ do + {- + withDiagMVar + (svarInspectMode chan) + (dumpChannel chan) + "cleanupChan" + $ -} + takeMVar (outputDoorBell chan) + -- threadDelay 10000 + go diff --git a/src/Streamly/Internal/Data/Stream/Channel/Types.hs b/src/Streamly/Internal/Data/Stream/Channel/Types.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Stream/Channel/Types.hs +++ /dev/null @@ -1,827 +0,0 @@ --- | --- Module : Streamly.Internal.Data.Stream.Channel.Types --- Copyright : (c) 2017 Composewell Technologies --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- --- A Channel is a place where streams join and new streams start. This module --- defines low level data structures and functions to build channels. For --- concrete Channels see the Channel modules of specific stream types. --- --- A Channel is a conduit to the output from multiple streams running --- concurrently and asynchronously. A channel can be thought of as an --- asynchronous IO handle. We can write any number of streams to a channel in a --- non-blocking manner and then read them back at any time at any pace. The --- channel would run the streams asynchronously and accumulate results. A --- channel may not really execute the stream completely and accumulate all the --- results. However, it ensures that the reader can read the results at --- whatever pace it wants to read. The channel monitors and adapts to the --- consumer's pace. --- --- A channel 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. An 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 channel by 'fromChannel' on demand if the output --- produced is not keeping pace with the consumer. On bounded channels, 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. --- -module Streamly.Internal.Data.Stream.Channel.Types - ( - -- * Types - Count (..) - , Limit (..) - , ThreadAbort (..) - , ChildEvent (..) - - -- * Stats - , SVarStats (..) - , newSVarStats - - -- * Rate Control - , WorkerInfo (..) - , LatencyRange (..) - , YieldRateInfo (..) - , newRateInfo - - -- * Output queue - , readOutputQRaw - , readOutputQBasic - , ringDoorBell - - -- * Yield Limit - , decrementYieldLimit - , incrementYieldLimit - - -- * Configuration - , Rate (..) - , StopWhen (..) - , Config - - -- ** Default config - , magicMaxBuffer - , defaultConfig - - -- ** Set config - , maxThreads - , maxBuffer - , maxYields - , inspect - , eager - , stopWhen - , ordered - , interleaved - - , rate - , avgRate - , minRate - , maxRate - , constRate - - -- ** Get config - , getMaxThreads - , getMaxBuffer - , getStreamRate - , getStreamLatency - , setStreamLatency - , getYieldLimit - , getInspectMode - , getEagerDispatch - , getStopWhen - , getOrdered - , getInterleaved - - -- * Cleanup - , cleanupSVar - - -- * Diagnostics - , dumpCreator - , dumpOutputQ - , dumpDoorBell - , dumpNeedDoorBell - , dumpRunningThreads - , dumpWorkerCount - - , withDiagMVar - , printSVar - - , concatMapDivK - ) -where - -import Control.Concurrent (ThreadId, throwTo, MVar, tryReadMVar) -import Control.Concurrent.MVar (tryPutMVar) -import Control.Exception - ( SomeException(..), Exception, catches, throwIO, Handler(..) - , BlockedIndefinitelyOnMVar(..), BlockedIndefinitelyOnSTM(..)) -import Control.Monad (void, when) -import Data.Int (Int64) -import Data.IORef (IORef, newIORef, readIORef, writeIORef) -import Data.Set (Set) -import Streamly.Internal.Data.Atomics - (atomicModifyIORefCAS, atomicModifyIORefCAS_, storeLoadBarrier) -import Streamly.Internal.Data.SVar.Type (adaptState) -import Streamly.Internal.Data.Time.Clock (Clock(Monotonic), getTime) -import Streamly.Internal.Data.Time.Units (AbsTime, NanoSecond64(..)) -import System.IO (hPutStrLn, stderr) - -import qualified Data.Set as Set -import qualified Streamly.Internal.Data.Stream.StreamK.Type as K - ------------------------------------------------------------------------------- --- Common types ------------------------------------------------------------------------------- - -newtype Count = Count Int64 - deriving ( Eq - , Read - , Show - , Enum - , Bounded - , Num - , Real - , Integral - , Ord - ) - --- XXX We can use maxBound for unlimited? - --- 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 - ------------------------------------------------------------------------------- --- Parent child thread communication type ------------------------------------------------------------------------------- - --- | Channel driver throws this exception to all active workers to clean up --- the channel. -data ThreadAbort = ThreadAbort deriving Show - -instance Exception ThreadAbort - --- XXX Use a ChildSingle event to speed up mapM? --- | Events that a child thread may send to a parent thread. -data ChildEvent a = - ChildYield a - | ChildStopChannel - | ChildStop ThreadId (Maybe SomeException) - --- | 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 - { - -- | 0 means unlimited - workerYieldMax :: Count - -- | total number of yields by the worker till now - , workerYieldCount :: IORef Count - -- | yieldCount at start, timestamp - , workerLatencyStart :: IORef (Count, AbsTime) - } - -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) -} - -------------------------------------------------------------------------------- --- Config -------------------------------------------------------------------------------- - --- | 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. --- -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 - } - --- | Specify when the 'Channel' should stop. -data StopWhen = - FirstStops -- ^ Stop when the first stream ends. - | AllStop -- ^ Stop when all the streams end. - | AnyStops -- ^ Stop when any one stream ends. - --- 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 - --- | An abstract type for specifying the configuration parameters of a --- 'Channel'. Use @Config -> Config@ modifier functions to modify the default --- configuration. See the individual modifier documentation for default values. --- -data Config = Config - { -- 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 - , _inspect :: Bool - , _eagerDispatch :: Bool - , _stopWhen :: StopWhen - , _ordered :: Bool - , _interleaved :: 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. Use get/set routines instead of directly accessing --- the Config fields -defaultConfig :: Config -defaultConfig = Config - { -- streamVar = Nothing - _yieldLimit = Nothing - , _threadsHigh = defaultMaxThreads - , _bufferHigh = defaultMaxBuffer - , _maxStreamRate = Nothing - , _streamLatency = Nothing - , _inspect = False - -- XXX Set it to True when Rate is not set? - , _eagerDispatch = False - , _stopWhen = AllStop - , _ordered = False - , _interleaved = False - } - -------------------------------------------------------------------------------- --- Smart get/set routines for State -------------------------------------------------------------------------------- - -maxYields :: Maybe Int64 -> Config -> Config -maxYields lim st = - st { _yieldLimit = - case lim of - Nothing -> Nothing - Just n -> - if n <= 0 - then Just 0 - else Just (fromIntegral n) - } - -getYieldLimit :: Config -> Maybe Count -getYieldLimit = _yieldLimit - --- | Specify the maximum number of threads that can be spawned by the channel. --- A value of 0 resets the thread limit to default, a negative value means --- there is no limit. The default value is 1500. --- --- When the actions in a stream are IO bound, having blocking IO calls, this --- option can be used to control the maximum number of in-flight IO requests. --- When the actions are CPU bound this option can be used to control the amount --- of CPU used by the stream. --- -maxThreads :: Int -> Config -> Config -maxThreads n st = - st { _threadsHigh = - if n < 0 - then Unlimited - else if n == 0 - then defaultMaxThreads - else Limited (fromIntegral n) - } - -getMaxThreads :: Config -> Limit -getMaxThreads = _threadsHigh - --- | Specify the maximum size of the buffer for storing the results from --- concurrent computations. If the buffer becomes full we stop spawning more --- concurrent tasks until there is space in the buffer. --- A value of 0 resets the buffer size to default, a negative value means --- there is no limit. The default value is 1500. --- --- CAUTION! using an unbounded 'maxBuffer' value (i.e. a negative value) --- coupled with an unbounded 'maxThreads' value is a recipe for disaster in --- presence of infinite streams, or very large streams. Especially, it must --- not be used when 'pure' is used in 'ZipAsyncM' streams as 'pure' in --- applicative zip streams generates an infinite stream causing unbounded --- concurrent generation with no limit on the buffer or threads. --- -maxBuffer :: Int -> Config -> Config -maxBuffer n st = - st { _bufferHigh = - if n < 0 - then Unlimited - else if n == 0 - then defaultMaxBuffer - else Limited (fromIntegral n) - } - -getMaxBuffer :: Config -> Limit -getMaxBuffer = _bufferHigh - --- | Specify the stream evaluation rate of a channel. --- --- A 'Nothing' value means there is no smart rate control, concurrent execution --- blocks only if 'maxThreads' or 'maxBuffer' is reached, or there are no more --- concurrent tasks to execute. This is the default. --- --- When rate (throughput) is specified, concurrent production may be ramped --- up or down automatically to achieve the specified stream throughput. The --- specific behavior for different styles of 'Rate' specifications is --- documented under 'Rate'. The effective maximum production rate achieved by --- a channel is governed by: --- --- * The 'maxThreads' limit --- * The 'maxBuffer' limit --- * The maximum rate that the stream producer can achieve --- * The maximum rate that the stream consumer can achieve --- --- Maximum production rate is given by: --- --- \(rate = \frac{maxThreads}{latency}\) --- --- If we know the average latency of the tasks we can set 'maxThreads' --- accordingly. --- -rate :: Maybe Rate -> Config -> Config -rate r st = st { _maxStreamRate = r } - -getStreamRate :: Config -> Maybe Rate -getStreamRate = _maxStreamRate - -setStreamLatency :: Int -> Config -> Config -setStreamLatency n st = - st { _streamLatency = - if n <= 0 - then Nothing - else Just (fromIntegral n) - } - -getStreamLatency :: Config -> Maybe NanoSecond64 -getStreamLatency = _streamLatency - --- XXX Rename to "inspect" - --- | Print debug information about the 'Channel' when the stream ends. --- -inspect :: Bool -> Config -> Config -inspect flag st = st { _inspect = flag } - -getInspectMode :: Config -> Bool -getInspectMode = _inspect - --- | By default, processing of output from the worker threads is given priority --- over dispatching new workers. More workers are dispatched only when there is --- no output to process. With 'eager' on workers are dispatched aggresively as --- long as there is more work to do irrespective of whether there is output --- pending to be processed. However, dispatching may stop if 'maxThreads' or --- 'maxBuffer' is reached. --- --- /Note:/ This option has no effect when rate has been specified. --- --- /Note:/ Not supported with 'interleaved'. --- -eager :: Bool -> Config -> Config -eager flag st = st { _eagerDispatch = flag } - -getEagerDispatch :: Config -> Bool -getEagerDispatch = _eagerDispatch - --- | Specify when the 'Channel' should stop. -stopWhen :: StopWhen -> Config -> Config -stopWhen cond st = st { _stopWhen = cond } - -getStopWhen :: Config -> StopWhen -getStopWhen = _stopWhen - --- | When enabled the streams may be evaluated cocnurrently but the results are --- produced in the same sequence as a serial evaluation would produce. --- --- /Note:/ Not supported with 'interleaved'. --- -ordered :: Bool -> Config -> Config -ordered flag st = st { _ordered = flag } - -getOrdered :: Config -> Bool -getOrdered = _ordered - --- | Interleave the streams fairly instead of prioritizing the left stream. --- This schedules all streams in a round robin fashion over limited number of --- threads. --- --- /Note:/ Can only be used on finite number of streams. --- --- /Note:/ Not supported with 'ordered'. --- -interleaved :: Bool -> Config -> Config -interleaved flag st = st { _interleaved = flag } - -getInterleaved :: Config -> Bool -getInterleaved = _interleaved - -------------------------------------------------------------------------------- --- Initialization -------------------------------------------------------------------------------- - -newRateInfo :: Config -> IO (Maybe YieldRateInfo) -newRateInfo 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 - } - -------------------------------------------------------------------------------- --- Rate -------------------------------------------------------------------------------- - --- | Same as @rate (Just $ Rate (r/2) r (2*r) maxBound)@ --- --- Specifies the average production rate of a stream in number of yields --- per second (i.e. @Hertz@). Concurrent production is ramped up or down --- automatically to achieve the specified average yield rate. The rate can --- go down to half of the specified rate on the lower side and double of --- the specified rate on the higher side. --- -avgRate :: Double -> Config -> Config -avgRate r = rate (Just $ Rate (r/2) r (2*r) maxBound) - --- | Same as @rate (Just $ Rate r r (2*r) maxBound)@ --- --- Specifies the minimum rate at which the stream should yield values. As --- far as possible the yield rate would never be allowed to go below the --- specified rate, even though it may possibly go above it at times, the --- upper limit is double of the specified rate. --- -minRate :: Double -> Config -> Config -minRate r = rate (Just $ Rate r r (2*r) maxBound) - --- | Same as @rate (Just $ Rate (r/2) r r maxBound)@ --- --- Specifies the maximum rate at which the stream should yield values. As --- far as possible the yield rate would never be allowed to go above the --- specified rate, even though it may possibly go below it at times, the --- lower limit is half of the specified rate. This can be useful in --- applications where certain resource usage must not be allowed to go --- beyond certain limits. --- -maxRate :: Double -> Config -> Config -maxRate r = rate (Just $ Rate (r/2) r r maxBound) - --- | Same as @rate (Just $ Rate r r r 0)@ --- --- Specifies a constant yield rate. If for some reason the actual rate --- goes above or below the specified rate we do not try to recover it by --- increasing or decreasing the rate in future. This can be useful in --- applications like graphics frame refresh where we need to maintain a --- constant refresh rate. --- -constRate :: Double -> Config -> Config -constRate r = rate (Just $ Rate r r r 0) - -------------------------------------------------------------------------------- --- Channel yield count -------------------------------------------------------------------------------- - --- 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 :: Maybe (IORef Count) -> IO Bool -decrementYieldLimit remaining = - case remaining of - Nothing -> return True - Just ref -> do - r <- atomicModifyIORefCAS ref $ \x -> (x - 1, x) - return $ r >= 1 - -{-# INLINE incrementYieldLimit #-} -incrementYieldLimit :: Maybe (IORef Count) -> IO () -incrementYieldLimit remaining = - case remaining of - Nothing -> return () - Just ref -> atomicModifyIORefCAS_ ref (+ 1) - -------------------------------------------------------------------------------- --- Output queue -------------------------------------------------------------------------------- - -{-# INLINE readOutputQBasic #-} -readOutputQBasic :: IORef ([ChildEvent a], Int) -> IO ([ChildEvent a], Int) -readOutputQBasic q = atomicModifyIORefCAS q $ \x -> (([],0), x) - -{-# INLINE readOutputQRaw #-} -readOutputQRaw :: - IORef ([ChildEvent a], Int) -> Maybe SVarStats -> IO ([ChildEvent a], Int) -readOutputQRaw q stats = do - (list, len) <- readOutputQBasic q - case stats of - Just ss -> do - let ref = maxOutQSize ss - oqLen <- readIORef ref - when (len > oqLen) $ writeIORef ref len - Nothing -> return () - return (list, len) - -{-# INLINE ringDoorBell #-} -ringDoorBell :: IORef Bool -> MVar () -> IO () -ringDoorBell needBell bell = do - storeLoadBarrier - w <- readIORef needBell - 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_ needBell (const False) - void $ tryPutMVar bell () - -------------------------------------------------------------------------------- --- Diagnostics -------------------------------------------------------------------------------- - -dumpCreator :: Show a => a -> String -dumpCreator tid = "Creator tid = " <> show tid - -dumpOutputQ :: (Foldable t, Show a1) => IORef (t a2, a1) -> IO String -dumpOutputQ q = do - (oqList, oqLen) <- readIORef q - return $ unlines - [ "outputQueue length computed = " <> show (length oqList) - , "outputQueue length maintained = " <> show oqLen - ] - -dumpDoorBell :: Show a => MVar a -> IO String -dumpDoorBell mvar = do - db <- tryReadMVar mvar - return $ "outputDoorBell = " <> show db - -dumpNeedDoorBell :: Show a => IORef a -> IO String -dumpNeedDoorBell ref = do - waiting <- readIORef ref - return $ "needDoorBell = " <> show waiting - -dumpRunningThreads :: Show a => IORef a -> IO String -dumpRunningThreads ref = do - rthread <- readIORef ref - return $ "running threads = " <> show rthread - -dumpWorkerCount :: Show a => IORef a -> IO String -dumpWorkerCount ref = do - workers <- readIORef ref - return $ "running thread count = " <> show workers - -{-# NOINLINE mvarExcHandler #-} -mvarExcHandler :: IO String -> String -> BlockedIndefinitelyOnMVar -> IO () -mvarExcHandler dump label e@BlockedIndefinitelyOnMVar = do - svInfo <- dump - hPutStrLn stderr $ label <> " " <> "BlockedIndefinitelyOnMVar\n" <> svInfo - throwIO e - -{-# NOINLINE stmExcHandler #-} -stmExcHandler :: IO String -> String -> BlockedIndefinitelyOnSTM -> IO () -stmExcHandler dump label e@BlockedIndefinitelyOnSTM = do - svInfo <- dump - hPutStrLn stderr $ label <> " " <> "BlockedIndefinitelyOnSTM\n" <> svInfo - throwIO e - --- | MVar diagnostics has some overhead - around 5% on AsyncT 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. -withDiagMVar :: Bool -> IO String -> String -> IO () -> IO () -withDiagMVar inspecting dump label action = - if inspecting - then - action `catches` [ Handler (mvarExcHandler dump label) - , Handler (stmExcHandler dump label) - ] - else action - -printSVar :: IO String -> String -> IO () -printSVar dump how = do - svInfo <- dump - hPutStrLn stderr $ "\n" <> how <> "\n" <> svInfo - -------------------------------------------------------------------------------- --- Cleanup -------------------------------------------------------------------------------- - --- | Never called from a worker thread. -cleanupSVar :: IORef (Set ThreadId) -> IO () -cleanupSVar workerSet = do - workers <- readIORef workerSet - -- self <- myThreadId - Prelude.mapM_ (`throwTo` ThreadAbort) - -- (Prelude.filter (/= self) $ Set.toList workers) - (Set.toList workers) - -------------------------------------------------------------------------------- --- Evaluator -------------------------------------------------------------------------------- - --- | @concatMapDivK useTail useHead stream@, divides the stream in head and --- tail, maps a stream generator on the head and maps an action on the tail of --- a stream. Returns the stream generated by the head. --- --- Used for concurrent evaluation of streams using a Channel. -{-# INLINE concatMapDivK #-} -concatMapDivK :: Monad m => - (K.StreamK m a -> m ()) - -> (a -> K.StreamK m b) - -> K.StreamK m a - -> K.StreamK m b -concatMapDivK useTail useHead stream = - K.mkStream $ \st yld sng stp -> do - let foldShared = K.foldStreamShared st yld sng stp - single a = foldShared $ useHead a - yieldk a r = useTail r >> single a - in K.foldStreamShared (adaptState st) yieldk single stp stream diff --git a/src/Streamly/Internal/Data/Stream/Channel/Worker.hs b/src/Streamly/Internal/Data/Stream/Channel/Worker.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Stream/Channel/Worker.hs +++ /dev/null @@ -1,375 +0,0 @@ --- | --- Module : Streamly.Internal.Data.Stream.Concurrent.Channel.Worker --- Copyright : (c) 2017 Composewell Technologies --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- --- Collecting results from child workers in a streamed fashion - -module Streamly.Internal.Data.Stream.Channel.Worker - ( - Work (..) - , estimateWorkers - , isBeyondMaxRate - , workerRateControl - - -- * Send Events - , sendWithDoorBell - , sendYield - , sendStop - , handleChildException -- XXX rename to sendException - ) -where - -import Control.Concurrent (myThreadId) -import Control.Concurrent.MVar (MVar, tryPutMVar) -import Control.Exception (SomeException(..), assert) -import Control.Monad (when, void) -import Data.IORef (IORef, readIORef, writeIORef) -import Streamly.Internal.Data.Atomics - (atomicModifyIORefCAS, atomicModifyIORefCAS_, writeBarrier) -import Streamly.Internal.Data.Time.Clock (Clock(Monotonic), getTime) -import Streamly.Internal.Data.Time.Units - (AbsTime, NanoSecond64(..), diffAbsTime64, fromRelTime64) - -import Streamly.Internal.Data.Stream.Channel.Types - -------------------------------------------------------------------------------- --- Yield control -------------------------------------------------------------------------------- - -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 - -------------------------------------------------------------------------------- --- Sending results from worker -------------------------------------------------------------------------------- - -{-# INLINE sendWithDoorBell #-} -sendWithDoorBell :: - IORef ([ChildEvent a], Int) -> MVar () -> ChildEvent a -> IO Int -sendWithDoorBell q bell msg = do - -- XXX can the access to outputQueue be made faster somehow? - oldlen <- atomicModifyIORefCAS q $ \(es, n) -> - ((msg : es, n + 1), n) - when (oldlen <= 0) $ do - -- The wake up must happen only after the store has finished otherwise - -- 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 bell () - return oldlen - -------------------------------------------------------------------------------- --- Collect and update worker latency -------------------------------------------------------------------------------- - -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 () - -------------------------------------------------------------------------------- --- Worker rate control -------------------------------------------------------------------------------- - --- 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 - --- | 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 - --- | 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) - --- 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 achieve the required rate? - -- - -- When the workers are IO bound we can increase the throughput by - -- increasing the number of workers as long as the IO device has enough - -- 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 achieve. Design tests for CPU bound and IO bound cases. - - -- Calculate how many yields are we ahead or behind to match the exact - -- required rate. Based on that we increase or decrease the effective - -- 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) - -isBeyondMaxRate :: Limit -> IORef Int -> YieldRateInfo -> IO Bool -isBeyondMaxRate workerLimit workerCount rateInfo = do - (count, tstamp, wLatency) <- getWorkerLatency rateInfo - now <- getTime Monotonic - let duration = fromRelTime64 $ diffAbsTime64 now tstamp - let targetLat = svarLatencyTarget rateInfo - gainLoss <- readIORef (svarGainedLostYields rateInfo) - let work = estimateWorkers workerLimit count gainLoss duration - wLatency targetLat (svarLatencyRange rateInfo) - cnt <- readIORef workerCount - 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 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 :: - Limit - -> IORef Int - -> YieldRateInfo - -> WorkerInfo - -> Count - -> IO Bool -checkRatePeriodic workerLimit workerCount rateInfo workerInfo ycnt = do - i <- readIORef (workerPollingInterval rateInfo) - -- XXX use generation count to check if the interval has been updated - if i /= 0 && (ycnt `mod` i) == 0 - then do - workerUpdateLatency rateInfo workerInfo - -- XXX not required for parallel streams - isBeyondMaxRate workerLimit workerCount rateInfo - 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 :: Limit -> IORef Int -> YieldRateInfo -> WorkerInfo -> IO Bool -workerRateControl workerLimit workerCount rateInfo workerInfo = do - cnt <- updateYieldCount workerInfo - beyondMaxRate <- checkRatePeriodic workerLimit workerCount rateInfo workerInfo cnt - return $ not (isBeyondMaxYield cnt workerInfo || beyondMaxRate) - -------------------------------------------------------------------------------- --- Send a yield event -------------------------------------------------------------------------------- - --- 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 :: - Limit - -> Limit - -> IORef Int - -> Maybe WorkerInfo - -> Maybe YieldRateInfo - -> IORef ([ChildEvent a], Int) - -> MVar () - -> ChildEvent a - -> IO Bool -sendYield bufferLimit workerLimit workerCount workerInfo rateInfo q bell msg = - do - oldlen <- sendWithDoorBell q bell msg - bufferSpaceOk <- - case bufferLimit of - Unlimited -> return True - Limited lim -> do - active <- readIORef workerCount - return $ (oldlen + 1) < (fromIntegral lim - active) - rateLimitOk <- - case workerInfo of - Just winfo -> - case rateInfo of - Nothing -> return True - Just yinfo -> - workerRateControl workerLimit workerCount yinfo winfo - Nothing -> return True - return $ bufferSpaceOk && rateLimitOk - -------------------------------------------------------------------------------- --- Send a Stop event -------------------------------------------------------------------------------- - -{-# INLINE workerStopUpdate #-} -workerStopUpdate :: WorkerInfo -> YieldRateInfo -> IO () -workerStopUpdate winfo info = do - i <- readIORef (workerPollingInterval info) - when (i /= 0) $ workerUpdateLatency info winfo - -{-# INLINABLE sendStop #-} -sendStop :: - IORef Int - -> Maybe WorkerInfo - -> Maybe YieldRateInfo - -> IORef ([ChildEvent a], Int) - -> MVar () - -> IO () -sendStop workerCount workerInfo rateInfo q bell = do - atomicModifyIORefCAS_ workerCount $ \n -> n - 1 - case (workerInfo, rateInfo) of - (Just winfo, Just rinfo) -> - workerStopUpdate winfo rinfo - _ -> - return () - myThreadId >>= \tid -> - void $ sendWithDoorBell q bell (ChildStop tid Nothing) - -{-# NOINLINE handleChildException #-} -handleChildException :: - IORef ([ChildEvent a], Int) -> MVar () -> SomeException -> IO () -handleChildException q bell e = do - tid <- myThreadId - void $ sendWithDoorBell q bell (ChildStop tid (Just e)) diff --git a/src/Streamly/Internal/Data/Stream/Common.hs b/src/Streamly/Internal/Data/Stream/Common.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/Common.hs @@ -0,0 +1,105 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | +-- Module : Streamly.Internal.Data.Stream.Common +-- Copyright : (c) 2017 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- Low level functions using StreamK as the intermediate stream type. These +-- functions are used in other stream modules to implement their instances. +-- +module Streamly.Internal.Data.Stream.Common + ( + -- * Conversion operations + fromList + , toList + + -- * Fold operations + , foldr + , foldl' + , fold + + -- * Zip style operations + , eqBy + , cmpBy + ) +where + +#include "inline.hs" + +import Streamly.Data.Fold (Fold) + +import qualified Streamly.Data.StreamK as K +import qualified Streamly.Internal.Data.Stream as D + +import Prelude hiding (Foldable(..), repeat) + +------------------------------------------------------------------------------ +-- Conversions +------------------------------------------------------------------------------ + +-- | +-- @ +-- fromList = 'Prelude.foldr' 'K.cons' 'K.nil' +-- @ +-- +-- Construct a stream from a list of pure values. This is more efficient than +-- 'K.fromFoldable' for serial streams. +-- +{-# INLINE_EARLY fromList #-} +fromList :: Monad m => [a] -> K.StreamK m a +fromList = D.toStreamK . D.fromList +{-# RULES "fromList fallback to StreamK" [1] + forall a. D.toStreamK (D.fromList a) = K.fromFoldable a #-} + +-- | Convert a stream into a list in the underlying monad. +-- +{-# INLINE toList #-} +toList :: Monad m => K.StreamK m a -> m [a] +toList m = D.toList $ D.fromStreamK m + +------------------------------------------------------------------------------ +-- Folds +------------------------------------------------------------------------------ + +{-# INLINE foldrM #-} +foldrM :: Monad m => (a -> m b -> m b) -> m b -> K.StreamK m a -> m b +foldrM step acc m = D.foldrM step acc $ D.fromStreamK m + +{-# INLINE foldr #-} +foldr :: Monad m => (a -> b -> b) -> b -> K.StreamK m a -> m b +foldr f z = foldrM (\a b -> f a <$> b) (return z) + +-- | Strict left associative fold. +-- +{-# INLINE foldl' #-} +foldl' :: + Monad m => (b -> a -> b) -> b -> K.StreamK m a -> m b +foldl' step begin m = D.foldl' step begin $ D.fromStreamK m + + +{-# INLINE fold #-} +fold :: Monad m => Fold m a b -> K.StreamK m a -> m b +fold fld m = D.fold fld $ D.fromStreamK m + +------------------------------------------------------------------------------ +-- Comparison +------------------------------------------------------------------------------ + +-- | Compare two streams for equality +-- +{-# INLINE eqBy #-} +eqBy :: Monad m => + (a -> b -> Bool) -> K.StreamK m a -> K.StreamK m b -> m Bool +eqBy f m1 m2 = D.eqBy f (D.fromStreamK m1) (D.fromStreamK m2) + +-- | Compare two streams +-- +{-# INLINE cmpBy #-} +cmpBy + :: Monad m + => (a -> b -> Ordering) -> K.StreamK m a -> K.StreamK m b -> m Ordering +cmpBy f m1 m2 = D.cmpBy f (D.fromStreamK m1) (D.fromStreamK m2) diff --git a/src/Streamly/Internal/Data/Stream/Concurrent.hs b/src/Streamly/Internal/Data/Stream/Concurrent.hs --- a/src/Streamly/Internal/Data/Stream/Concurrent.hs +++ b/src/Streamly/Internal/Data/Stream/Concurrent.hs @@ -5,16 +5,9 @@ -- Maintainer : streamly@composewell.com -- Stability : experimental -- Portability : GHC --- --- Non-parallelizable stream combinators like unfoldrM, iterateM etc. can be --- evaluated concurrently with the stream consumer by using `eval`. --- Parallelizable combinators like repeatM, replicateM can generate the stream --- concurrently using 'concatMap'. -- Single effects related functionality can be moved to -- Data.Async/Control.Async. --- Common Channel functionality to Data.Channel. --- Stream channel to Data.Stream.Channel. module Streamly.Internal.Data.Stream.Concurrent ( @@ -22,32 +15,14 @@ -- $setup -- * Types - MonadAsync - - -- * Configuration - , Config - , maxThreads - , maxBuffer - , eager - , StopWhen (..) - , stopWhen - , ordered - , interleaved - -- maxYields - , Rate(..) - , rate - , avgRate - , minRate - , maxRate - , constRate - , inspect + MonadAsync -- XXX Move in channel? -- * Combinators -- | Stream combinators using a concurrent channel -- ** Evaluate -- | Evaluates a stream concurrently using a channel. - , parEval + , parBuffered -- Add unfoldrM/iterateM? -- ** Generate @@ -80,47 +55,51 @@ -- ** Stream of streams -- *** Apply - , parApply + , parCrossApply -- *** Concat -- | Shares a single channel across many streams. , parConcat , parConcatMap + , parMergeMap -- *** ConcatIterate , parConcatIterate + , parMergeIterate -- ** Reactive + , newStreamAndCallback + , parYieldWith , fromCallback - , tapCountD + , parTapCount , tapCount + + -- ** Deprecated + , parEval + , parApply ) where #include "inline.hs" +#include "deprecation.h" import Control.Concurrent (myThreadId, killThread) import Control.Monad (void, when) import Control.Monad.IO.Class (MonadIO(liftIO)) -import Streamly.Internal.Control.Concurrent (MonadAsync, askRunInIO) +import Streamly.Internal.Control.Concurrent (MonadAsync) import Streamly.Internal.Control.ForkLifted (forkManaged) -import Streamly.Internal.Data.Stream.Channel.Dispatcher (modifyThread) -import Streamly.Internal.Data.Stream.Channel.Types - ( ChildEvent(..) - , concatMapDivK - ) -import Streamly.Internal.Data.Stream.Channel.Worker (sendWithDoorBell) -import Streamly.Internal.Data.Stream.StreamD.Type (Stream) -import Streamly.Internal.Data.Stream.StreamD (Step(..)) +import Streamly.Internal.Data.Channel.Dispatcher (modifyThread) +import Streamly.Internal.Data.Channel.Worker (sendEvent) +import Streamly.Internal.Data.Stream (Stream, Step(..)) -import qualified Streamly.Internal.Data.IORef.Unboxed as Unboxed -import qualified Streamly.Internal.Data.Stream.StreamD as Stream -import qualified Streamly.Internal.Data.Stream.StreamD as D -import qualified Streamly.Internal.Data.Stream.StreamK as K -import qualified Streamly.Internal.Data.Stream.StreamK.Type as K +import qualified Streamly.Internal.Data.IORef as Unboxed +import qualified Streamly.Internal.Data.Stream as Stream +import qualified Streamly.Internal.Data.Stream as D +import qualified Streamly.Internal.Data.StreamK as K import Prelude hiding (mapM, sequence, concat, concatMap, zipWith) -import Streamly.Internal.Data.Stream.Concurrent.Channel +import Streamly.Internal.Data.Channel.Types +import Streamly.Internal.Data.Stream.Channel -- $setup -- @@ -132,8 +111,9 @@ -- >>> import qualified Streamly.Data.Array as Array -- >>> import qualified Streamly.Data.Fold as Fold -- >>> import qualified Streamly.Data.Parser as Parser --- >>> import qualified Streamly.Internal.Data.Stream as Stream hiding (append2) --- >>> import qualified Streamly.Internal.Data.Stream.Concurrent as Stream +-- >>> import qualified Streamly.Data.StreamK as StreamK +-- >>> import qualified Streamly.Internal.Data.Stream as Stream +-- >>> import qualified Streamly.Internal.Data.Stream.Prelude as Stream -- >>> import Prelude hiding (concatMap, concat, zipWith) -- >>> :{ -- delay n = do @@ -147,9 +127,9 @@ ------------------------------------------------------------------------------- {- -{-# INLINE_NORMAL parEvalD #-} -parEvalD :: MonadAsync m => (Config -> Config) -> D.Stream m a -> D.Stream m a -parEvalD modifier m = D.Stream step Nothing +{-# INLINE_NORMAL parBufferedD #-} +parBufferedD :: MonadAsync m => (Config -> Config) -> D.Stream m a -> D.Stream m a +parBufferedD modifier m = D.Stream step Nothing where step _ Nothing = do @@ -166,20 +146,34 @@ D.Stop -> D.Stop -} --- | Evaluate a stream asynchronously. In a serial stream, each element of the --- stream is generated as it is demanded by the consumer. `parEval` evaluates --- multiple elements of the stream ahead of time and serves the results from a --- buffer. +-- | 'parBuffered' evaluates a stream as a whole asynchronously with respect to +-- the consumer of the stream. A worker thread evaluates multiple elements of +-- the stream ahead of time and buffers the results; the consumer of the stream +-- runs in another thread consuming the elements from the buffer, thus +-- decoupling the production and consumption of the stream. 'parBuffered' can be +-- used to run different stages of a pipeline concurrently. -- --- Note that the evaluation requires only one thread as only one stream needs --- to be evaluated. Therefore, the concurrency options that are relevant to --- multiple streams won't apply here e.g. maxThreads, eager, interleaved, --- ordered, stopWhen options won't have any effect. +-- It is important to note that 'parBuffered' does not evaluate individual actions +-- in the stream concurrently with respect to each other, it merely evaluates +-- the stream serially but in a different thread than the consumer thread, +-- thus the consumer and producer can run concurrently. See 'parMapM' and +-- 'parSequence' to evaluate actions in the stream concurrently. -- -{-# INLINE parEval #-} -parEval :: MonadAsync m => (Config -> Config) -> Stream m a -> Stream m a -parEval modifier input = withChannel modifier input (const id) - -- Stream.fromStreamD $ parEvalD cfg $ Stream.toStreamD stream +-- The evaluation requires only one thread as only one stream needs to be +-- evaluated. Therefore, the concurrency options that are relevant to multiple +-- streams do not apply here e.g. maxThreads, eager, interleaved, ordered, +-- stopWhen options do not have any effect on 'parBuffered'. +-- +-- Useful idioms: +-- +-- >>> parUnfoldrM step = Stream.parBuffered id . Stream.unfoldrM step +-- >>> parIterateM step = Stream.parBuffered id . Stream.iterateM step +{-# INLINE parBuffered #-} +parBuffered, parEval + :: MonadAsync m => (Config -> Config) -> Stream m a -> Stream m a +parBuffered modifier input = withChannel modifier input (const id) + -- Stream.fromStreamD $ parBufferedD cfg $ Stream.toStreamD stream +RENAME(parEval,parBuffered) ------------------------------------------------------------------------------- -- combining two streams @@ -199,7 +193,7 @@ action = do chan <- newChan modifier let cfg = modifier defaultConfig - done = K.nilM (stopChannel chan) + done = K.nilM (shutdown chan) case getStopWhen cfg of AllStop -> do toChannelK chan stream2 @@ -272,85 +266,6 @@ $ appendWithK modifier (Stream.toStreamK stream1) (Stream.toStreamK stream2) -------------------------------------------------------------------------------- --- concat streams -------------------------------------------------------------------------------- - --- | A runner function takes a queuing function @q@ and a stream, it splits the --- input stream, queuing the tail and using the head to generate a stream. --- 'mkEnqueue' takes a runner function and generates the queuing function @q@. --- Note that @q@ and the runner are mutually recursive, mkEnqueue ties the knot --- between the two. -{-# INLINE mkEnqueue #-} -mkEnqueue :: MonadAsync m => - Channel m b - -> ((K.StreamK m a -> m ()) -> K.StreamK m a -> K.StreamK m b) - -> m (K.StreamK m a -> m ()) -mkEnqueue chan runner = do - runInIO <- askRunInIO - return - $ let q stream = do - -- Enqueue the outer loop - liftIO $ enqueue chan False (runInIO, runner q stream) - -- XXX In case of eager dispatch we can just directly dispatch - -- a worker with the tail stream here rather than first queuing - -- and then dispatching a worker which dequeues the work. The - -- older implementation did a direct dispatch here and its perf - -- characterstics looked much better. - eagerDispatch chan - in q - --- | Takes the head element of the input stream and queues the tail of the --- stream to the channel, then maps the supplied function on the head and --- evaluates the resulting stream. --- --- This function is designed to be used by worker threads on a channel to --- concurrently map and evaluate a stream. -{-# INLINE parConcatMapChanK #-} -parConcatMapChanK :: MonadAsync m => - Channel m b -> (a -> K.StreamK m b) -> K.StreamK m a -> K.StreamK m b -parConcatMapChanK chan f stream = - let run q = concatMapDivK q f - in K.concatMapEffect (`run` stream) (mkEnqueue chan run) - -- K.parConcatMap (_appendWithChanK chan) f stream - -{-# INLINE parConcatMapChanKAny #-} -parConcatMapChanKAny :: MonadAsync m => - Channel m b -> (a -> K.StreamK m b) -> K.StreamK m a -> K.StreamK m b -parConcatMapChanKAny chan f stream = - let done = K.nilM (stopChannel chan) - run q = concatMapDivK q (\x -> K.append (f x) done) - in K.concatMapEffect (`run` stream) (mkEnqueue chan run) - -{-# INLINE parConcatMapChanKFirst #-} -parConcatMapChanKFirst :: MonadAsync m => - Channel m b -> (a -> K.StreamK m b) -> K.StreamK m a -> K.StreamK m b -parConcatMapChanKFirst chan f stream = - let done = K.nilM (stopChannel chan) - run q = concatMapDivK q f - in K.concatEffect $ do - res <- K.uncons stream - case res of - Nothing -> return K.nil - Just (h, t) -> do - q <- mkEnqueue chan run - q t - return $ K.append (f h) done - -{-# INLINE parConcatMapChanKGeneric #-} -parConcatMapChanKGeneric :: MonadAsync m => - (Config -> Config) - -> Channel m b - -> (a -> K.StreamK m b) - -> K.StreamK m a - -> K.StreamK m b -parConcatMapChanKGeneric modifier chan f stream = do - let cfg = modifier defaultConfig - case getStopWhen cfg of - AllStop -> parConcatMapChanK chan f stream - FirstStops -> parConcatMapChanKFirst chan f stream - AnyStops -> parConcatMapChanKAny chan f stream - -- XXX Add a deep evaluation variant that evaluates individual elements in the -- generated streams in parallel. @@ -361,7 +276,7 @@ parConcatMapK :: MonadAsync m => (Config -> Config) -> (a -> K.StreamK m b) -> K.StreamK m a -> K.StreamK m b parConcatMapK modifier f input = - let g = parConcatMapChanKGeneric modifier + let g = chanConcatMapK modifier in withChannelK modifier input (`g` f) -- | Map each element of the input to a stream and then concurrently evaluate @@ -423,6 +338,15 @@ $ parConcatMapK modifier (Stream.toStreamK . f) (Stream.toStreamK stream) +-- | Same as 'mergeMapWith interleave' but concurrent. +-- +-- /Unimplemented/ +-- +{-# INLINE parMergeMap #-} +parMergeMap :: -- MonadAsync m => + (Config -> Config) -> (a -> Stream m b) -> Stream m a -> Stream m b +parMergeMap _modifier _f _stream = undefined + -- | Evaluate the streams in the input stream concurrently and combine them. -- -- >>> parConcat modifier = Stream.parConcatMap modifier id @@ -436,6 +360,8 @@ -- concat Lists ------------------------------------------------------------------------------- +-- XXX Rename to parListCat? + -- | Like 'parConcat' but works on a list of streams. -- -- >>> parList modifier = Stream.parConcat modifier . Stream.fromList @@ -501,18 +427,21 @@ -- Applicative ------------------------------------------------------------------------------- +-- XXX Rename to parStreamApply? + -- | Apply an argument stream to a function stream concurrently. Uses a -- shared channel for all individual applications within a stream application. -{-# INLINE parApply #-} -{-# SPECIALIZE parApply :: +{-# INLINE parCrossApply #-} +{-# SPECIALIZE parCrossApply :: (Config -> Config) -> Stream IO (a -> b) -> Stream IO a -> Stream IO b #-} -parApply :: MonadAsync m => +parCrossApply, parApply :: MonadAsync m => (Config -> Config) -> Stream m (a -> b) -> Stream m a -> Stream m b -parApply modifier stream1 stream2 = +parCrossApply modifier stream1 stream2 = parConcatMap modifier (\g -> parConcatMap modifier (Stream.fromPure . g) stream2) stream1 +RENAME(parApply,parCrossApply) ------------------------------------------------------------------------------- -- Map @@ -523,9 +452,9 @@ -- -- >>> parMapM modifier f = Stream.parConcatMap modifier (Stream.fromEffect . f) -- --- Example, the following example finishes in 1 second as all actions run in --- parallel. Even though results are available out of order they are ordered --- due to the config option:: +-- For example, the following finishes in 3 seconds (as opposed to 6 seconds) +-- because all actions run in parallel. Even though results are available out +-- of order they are ordered due to the config option: -- -- >>> f x = delay x >> return x -- >>> Stream.fold Fold.toList $ Stream.parMapM (Stream.ordered True) f $ Stream.fromList [3,2,1] @@ -539,9 +468,15 @@ (Config -> Config) -> (a -> m b) -> Stream m a -> Stream m b parMapM modifier f = parConcatMap modifier (Stream.fromEffect . f) --- | +-- | Definition: +-- -- >>> parSequence modifier = Stream.parMapM modifier id -- +-- Useful idioms: +-- +-- >>> parFromListM = Stream.parSequence id . Stream.fromList +-- >>> parFromFoldableM = Stream.parSequence id . StreamK.toStream . StreamK.fromFoldable +-- {-# INLINE parSequence #-} parSequence :: MonadAsync m => (Config -> Config) -> Stream m (m a) -> Stream m a @@ -550,13 +485,13 @@ -- | Evaluates the streams being zipped in separate threads than the consumer. -- The zip function is evaluated in the consumer thread. -- --- >>> parZipWithM cfg f m1 m2 = Stream.zipWithM f (Stream.parEval cfg m1) (Stream.parEval cfg m2) +-- >>> parZipWithM cfg f m1 m2 = Stream.zipWithM f (Stream.parBuffered cfg m1) (Stream.parBuffered cfg m2) -- -- Multi-stream concurrency options won't apply here, see the notes in --- 'parEval'. +-- 'parBuffered'. -- -- If you want to evaluate the zip function as well in a separate thread, you --- can use a 'parEval' on 'parZipWithM'. +-- can use a 'parBuffered' on 'parZipWithM'. -- {-# INLINE parZipWithM #-} parZipWithM :: MonadAsync m @@ -565,7 +500,8 @@ -> Stream m a -> Stream m b -> Stream m c -parZipWithM cfg f m1 m2 = Stream.zipWithM f (parEval cfg m1) (parEval cfg m2) +parZipWithM cfg f m1 m2 = + Stream.zipWithM f (parBuffered cfg m1) (parBuffered cfg m2) -- | -- >>> parZipWith cfg f = Stream.parZipWithM cfg (\a b -> return $ f a b) @@ -588,7 +524,7 @@ -- -- Definition: -- --- >>> parMergeByM cfg f m1 m2 = Stream.mergeByM f (Stream.parEval cfg m1) (Stream.parEval cfg m2) +-- >>> parMergeByM cfg f m1 m2 = Stream.mergeByM f (Stream.parBuffered cfg m1) (Stream.parBuffered cfg m2) -- {-# INLINE parMergeByM #-} parMergeByM :: MonadAsync m @@ -597,7 +533,8 @@ -> Stream m a -> Stream m a -> Stream m a -parMergeByM cfg f m1 m2 = Stream.mergeByM f (parEval cfg m1) (parEval cfg m2) +parMergeByM cfg f m1 m2 = + Stream.mergeByM f (parBuffered cfg m1) (parBuffered cfg m2) -- | Like 'mergeBy' but evaluates both the streams concurrently. -- @@ -633,13 +570,22 @@ where - iterateStream channel stream = - parConcatMapChanKGeneric modifier channel (generate channel) stream + iterateStream chan = chanConcatMapK modifier chan (generate chan) - generate channel x = - -- XXX The channel q should be FIFO for DFS, otherwise it is BFS - x `K.cons` iterateStream channel (Stream.toStreamK $ f x) + -- XXX The channel q should be FIFO for DFS, otherwise it is BFS + generate chan x = x `K.cons` iterateStream chan (Stream.toStreamK $ f x) +-- | Same as 'mergeIterateWith interleave' but concurrent. +-- +-- /Unimplemented/ +{-# INLINE parMergeIterate #-} +parMergeIterate :: -- MonadAsync m => + (Config -> Config) + -> (a -> Stream m a) + -> Stream m a + -> Stream m a +parMergeIterate _modifier _f _input = undefined + ------------------------------------------------------------------------------- -- Generate ------------------------------------------------------------------------------- @@ -675,54 +621,121 @@ ------------------------------------------------------------------------------- -- Note: we can use another API with two callbacks stop and yield if we want --- the callback to be able to indicate end of stream. +-- the callback to be able to indicate end of stream. Or we can use a Maybe +-- stream where Nothing indicates end of stream. + +-- XXX Rename to parNewCallback + +-- | Returns an entangled pair of a callback and a stream i.e. whenever the +-- callback is called a value appears in the stream. The stream is infinite, +-- there is no way for the callback to indicate that it is done now. -- --- | Generates a callback and a stream pair. The callback returned is used to --- queue values to the stream. The stream is infinite, there is no way for the --- callback to indicate that it is done now. +-- The callback queues a value to a concurrent channel associated with the +-- stream. The stream can be evaluated safely in any thread. -- -- /Pre-release/ -- -{-# INLINE_NORMAL newCallbackStream #-} -newCallbackStream :: MonadAsync m => m (a -> m (), Stream m a) -newCallbackStream = do +{-# INLINE_NORMAL newStreamAndCallback #-} +newStreamAndCallback :: MonadAsync m => m (a -> m (), Stream m a) +newStreamAndCallback = do chan <- newChannel (eager True) -- XXX Add our own thread-id to the SVar as we can not know the callback's -- thread-id and the callback is not run in a managed worker. We need to - -- handle this better. + -- handle this better. The caller thread might be killed by the Channel if + -- the stream evaluator dies. + -- liftIO myThreadId >>= modifyThread (workerThreads chan) (outputDoorBell chan) + -- XXX We can use a "Maybe a" here. Use Nothing to send a Stop event. let callback a = liftIO $ void - $ sendWithDoorBell + $ sendEvent (outputQueue chan) (outputDoorBell chan) (ChildYield a) -- XXX Use fromChannelD? return (callback, fromChannel chan) --- | Supplies a stream generating callback to a callback setter function. Each --- invocation of the callback results in a value being generated in the --- resulting stream. +-- XXX Take the Channel config as argument. What config can be set by user +-- here? + +-- | @fromCallback action@ runs @action@ with a callback which is used by +-- the action to send values that appear in the resulting stream. The action +-- must be run in a separate thread independent of the one in which the stream +-- is being evaluated. The action is supposed to be run forever in an infinite +-- loop. -- +-- Example: +-- +-- >> import Control.Concurrent (threadDelay, forkIO) +-- >> import Control.Monad (void, forever) +-- >> import qualified Streamly.Data.Fold as Fold +-- >> import qualified Streamly.Data.Stream.Prelude as Stream +-- >> +-- >> main = do +-- >> Stream.fold (Fold.drainMapM print) +-- >> $ Stream.fromCallback +-- >> $ \yield -> +-- >> void $ forkIO $ forever $ do +-- >> yield "x" >> threadDelay 1000000 +-- -- /Pre-release/ -- {-# INLINE fromCallback #-} fromCallback :: MonadAsync m => ((a -> m ()) -> m ()) -> Stream m a fromCallback setCallback = Stream.concatEffect $ do - (callback, stream) <- newCallbackStream + (callback, stream) <- newStreamAndCallback setCallback callback return stream -{-# INLINE_NORMAL tapCountD #-} -tapCountD +-- XXX What happens if an exception occurs when evaluating the stream? The +-- result of callback can be used to communicate that. But we can only know +-- about the exception on the next callback call. For better handling the user +-- can supply an exception sender function as argument to fromCallback. Or +-- maybe we should just forward all exceptions the parent stream. +-- +-- XXX Add a serial version of this i.e. yieldWith? +-- XXX For folds a parAwaitWith is possible. +-- XXX For pipes parYieldAwaitWith + +-- | An improved version of 'fromCallback'. +-- +-- * Takes a channel config modifier +-- * Evaluates the action in a parallel thread +-- * The action is supplied with a yield function to yield values to the stream +-- * Any exception generated is forwarded to the stream +-- * Sends a Stop event when the action is done. +-- +-- /Unimplemented/ +parYieldWith :: -- MonadAsync m => + (Config -> Config) -> ((a -> m b) -> m c) -> Stream m a +parYieldWith = undefined + +-- | @parTapCount predicate fold stream@ taps the count of those elements in +-- the stream that pass the @predicate@. The resulting count stream is sent to +-- a @fold@ running concurrently in another thread. +-- +-- For example, to print the count of elements processed every second: +-- +-- >>> rate = Stream.rollingMap2 (flip (-)) . Stream.delayPost 1 +-- >>> report = Stream.fold (Fold.drainMapM print) . rate +-- >>> tap = Stream.parTapCount (const True) report +-- >>> go = Stream.fold Fold.drain $ tap $ Stream.enumerateFrom 0 +-- +-- Note: This may not work correctly on 32-bit machines because of Int +-- overflow. +-- +-- /Pre-release/ +-- +{-# INLINE_NORMAL parTapCount #-} +parTapCount :: MonadAsync m => (a -> Bool) -> (D.Stream m Int -> m b) -> D.Stream m a -> D.Stream m a -tapCountD predicate fld (D.Stream step state) = D.Stream step' Nothing +parTapCount predicate fld (D.Stream step state) = D.Stream step' Nothing where {-# INLINE_LATE step' #-} @@ -733,7 +746,7 @@ countVar <- liftIO $ Unboxed.newIORef (0 :: Int) tid <- forkManaged $ void $ fld - $ Unboxed.toStreamD countVar + $ Unboxed.pollIORefInt countVar return $ Skip (Just (countVar, tid, state)) step' gst (Just (countVar, tid, st)) = do @@ -748,22 +761,8 @@ liftIO $ killThread tid return Stop --- | @tapCount predicate fold stream@ taps the count of those elements in the --- stream that pass the @predicate@. The resulting count stream is sent to --- another thread which folds it using @fold@. --- --- For example, to print the count of elements processed every second: --- --- >>> rate = Stream.rollingMap2 (flip (-)) . Stream.delayPost 1 --- >>> report = Stream.fold (Fold.drainMapM print) . rate --- >>> tap = Stream.tapCount (const True) report --- >>> go = Stream.fold Fold.drain $ tap $ Stream.enumerateFrom 0 --- --- Note: This may not work correctly on 32-bit machines because of Int --- overflow. --- --- /Pre-release/ --- +{-# DEPRECATED tapCount "Please use parTapCount instead." #-} +-- | Same as 'parTapCount'. Deprecated. {-# INLINE tapCount #-} tapCount :: (MonadAsync m) @@ -771,4 +770,88 @@ -> (Stream m Int -> m b) -> Stream m a -> Stream m a -tapCount = tapCountD +tapCount = parTapCount + +------------------------------------------------------------------------------- +-- Stream cloning +------------------------------------------------------------------------------- + +-- Clone a stream into n streams, perform some processing on them and then zip +-- or merge the results in different ways? +-- +-- For serial processing combining n scans into a single scan on the source +-- stream would be the most efficient way of doing this. But this has a +-- limitation that we process one element at a time through the combined scan. +-- This is a way to combine the states of different scans in a modular way. +-- This works well for cases where each scan consumes and produces one element +-- at a time. If different scans produce elements by consuming different number +-- of elements then this may become complicated, inconvenient to use. +-- +-- It does not make much sense to clone a stream to multiple free streams +-- unless we enforce processing those streams in independent threads. If +-- we are anyway running them in the same thread then there is not much point +-- of cloning, we can just map a function on the stream to do multiple tasks in +-- tandem. +-- +-- Cloning a stream to multiple free streams can provide independent buffering +-- and speed of evaluation to each cloned stream pipeline. For example, we can +-- parseBreak each stream independently using a different parser. The +-- evaluation would be push driven. The source stream would be evaluated in a +-- separate thread and we would push the generated elements to all the cloned +-- streams. +-- +-- 1. If the cloned streams have infinite buffers then this can lead to the +-- source stream getting evaluated faster than consumers and buffering the +-- entire source stream in cloned streams. +-- +-- 2. If the cloned streams have limited buffers, then they will all go at the +-- speed of the slowest stream if they are run concurrently. +-- +-- 3. If the cloned streams have limited buffers and are evaluated serially +-- then we may run into deadlock if we are deep evaluating one stream and the +-- source gets blocked because other stream's buffer are full. +-- +-- This is somewhat like list sharing. And it will have the same space leak +-- issues if used incorrectly. In fact, we can evaluate the source stream to +-- generate a lazy list using unsafePerformIO and share that lazy list among +-- multiple consumers. The evaluation of the list would drive the stream. And +-- the list would be naturally shared across consumers which can use different +-- buffering. This would be more like the lazy IO model. However, it may be +-- better to use streams instead of lists because streams use a monad and lists +-- are pure - pure lists can lead to the same issues as lazy IO when used in +-- pure functions. +-- +-- Therefore, for safety, it makes better sense to use consumers (Stream m a -> +-- m b) rather than generating free streams as results. Each such consumer can +-- be enforced to run in its own thread. We can also pass a result collector +-- callback in a ReaderT env to collect the results from all these consumers +-- into a single stream. +-- +-- parTap -- tap the stream to a single consumer +-- parDistribute -- a finite list of consumers is specified. all consumers +-- are guaranteed to get the entire stream from beginning. Run each consumer in +-- a separate thread. +-- parDistributeStream -- consumers can join the distribution channel +-- dynamically, they will get the source stream from now onwards. + +-- XXX We could use Stream or StreamK, what are the pros and cons? The StreamK +-- version can be used to implement parDistribute using foldr? +{- +{-# INLINE parTap #-} +parTap :: MonadAsync m => (Stream m a -> m b) -> Stream m a -> Stream m a +parTap f m = undefined + +-- Can we just use a parBuffered fold in tap? +-- We can easily convert the Fold to "Stream m a -> m b" form. Check if this +-- provides the same perf as above. +{-# INLINE parTap #-} +parTap :: MonadAsync m => Fold m a b -> Stream m a -> Stream m a +parTap f xs = undefined + +-- Can we just use a parallel distribute fold in tap? +-- Maybe better to use a custom impl of distribute? +{-# INLINE parDistribute #-} +parDistribute :: (Foldable f, , MonadAsync m) + => f (Stream m a -> m b) -> Stream m a -> Stream m a +parDistribute = flip (Prelude.foldr parTap) +-} diff --git a/src/Streamly/Internal/Data/Stream/Concurrent/Channel.hs b/src/Streamly/Internal/Data/Stream/Concurrent/Channel.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Stream/Concurrent/Channel.hs +++ /dev/null @@ -1,106 +0,0 @@ --- | --- Module : Streamly.Internal.Data.Stream.Concurrent.Channel --- Copyright : (c) 2017 Composewell Technologies --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC - -module Streamly.Internal.Data.Stream.Concurrent.Channel - ( - -- * Channel - Channel (..) - , newChannel - , withChannel - , withChannelK - , fromChannel - , toChannel - , toChannelK - , stopChannel - -- quiesceChannel -- wait for running tasks but do not schedule any more. - - -- * Configuration - , Config - , defaultConfig - - -- ** Limits - , maxThreads - , maxBuffer - - -- ** Rate Control - , Rate(..) - , rate - , avgRate - , minRate - , maxRate - , constRate - - -- ** Stop behavior - , StopWhen (..) - , stopWhen - , getStopWhen - - -- ** Scheduling behavior - , eager - , ordered - , interleaved - - -- ** Diagnostics - , inspect - ) -where - -import Streamly.Internal.Control.Concurrent (MonadAsync) -import Streamly.Internal.Data.Stream.StreamD (Stream) -import Streamly.Internal.Data.Stream.Concurrent.Channel.Operations - (fromChannel, fromChannelK, toChannel, toChannelK) - -import qualified Streamly.Internal.Data.Stream.Concurrent.Channel.Append - as Append -import qualified Streamly.Internal.Data.Stream.Concurrent.Channel.Interleave - as Interleave -import qualified Streamly.Internal.Data.Stream.StreamK as K - -import Streamly.Internal.Data.Stream.Concurrent.Channel.Type -import Streamly.Internal.Data.Stream.Channel.Types - --- | Create a new concurrent stream evaluation channel. The monad --- state used to run the stream actions is captured from the call site of --- newChannel. -{-# INLINE newChannel #-} -newChannel :: MonadAsync m => - (Config -> Config) -> m (Channel m a) -newChannel modifier = - let cfg = modifier defaultConfig - in if getInterleaved cfg - then Interleave.newChannel modifier - else Append.newChannel modifier - --- | Allocate a channel and evaluate the stream using the channel and the --- supplied evaluator function. The evaluator is run in a worker thread. -{-# INLINE withChannelK #-} -withChannelK :: MonadAsync m => - (Config -> Config) - -> K.StreamK m a - -> (Channel m b -> K.StreamK m a -> K.StreamK m b) - -> K.StreamK m b -withChannelK modifier input evaluator = K.concatEffect action - - where - - action = do - chan <- newChannel modifier - toChannelK chan (evaluator chan input) - return $ fromChannelK chan - --- | Allocate a channel and evaluate the stream using the channel and the --- supplied evaluator function. The evaluator is run in a worker thread. -{-# INLINE withChannel #-} -withChannel :: MonadAsync m => - (Config -> Config) - -> Stream m a - -> (Channel m b -> Stream m a -> Stream m b) - -> Stream m b -withChannel modifier input evaluator = - let f chan stream = K.fromStream $ evaluator chan (K.toStream stream) - in K.toStream $ withChannelK modifier (K.fromStream input) f diff --git a/src/Streamly/Internal/Data/Stream/Concurrent/Channel/Append.hs b/src/Streamly/Internal/Data/Stream/Concurrent/Channel/Append.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Stream/Concurrent/Channel/Append.hs +++ /dev/null @@ -1,1046 +0,0 @@ --- | --- Module : Streamly.Internal.Data.Stream.Concurrent.Channel.Append --- Copyright : (c) 2017 Composewell Technologies --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- --- The functions in this module are separated from the combinators using --- these because of a GHC issue. We need to have newChannel specialized but --- not inlined. If we keep it in the same module as its users we cannot achieve --- that and the code becomes bloated. But if it is in a separate module we can --- use INLINABLE and SPECIALIZE on it which makes it specialized but it is not --- actually inlined. - -module Streamly.Internal.Data.Stream.Concurrent.Channel.Append - ( - newChannel - ) -where - -import Control.Concurrent (myThreadId) -import Control.Concurrent.MVar (newEmptyMVar, newMVar, putMVar, takeMVar) -import Control.Exception (assert) -import Control.Monad (when, void) -import Control.Monad.IO.Class (MonadIO(liftIO)) -import Data.Heap (Heap, Entry(..)) -import Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef, writeIORef) -import Data.Kind (Type) -import GHC.Exts (inline) -import Streamly.Internal.Control.Concurrent - (MonadRunInIO, RunInIO(..), askRunInIO, restoreM) -import Streamly.Internal.Data.Atomics - (atomicModifyIORefCAS, atomicModifyIORefCAS_) -import Streamly.Internal.Data.Stream.Channel.Dispatcher (modifyThread) - -import qualified Data.Heap as H -import qualified Data.Set as Set -import qualified Streamly.Internal.Data.Stream.StreamK.Type as K - -import Streamly.Internal.Data.Stream.Concurrent.Channel.Consumer -import Streamly.Internal.Data.Stream.Concurrent.Channel.Dispatcher -import Streamly.Internal.Data.Stream.Concurrent.Channel.Type -import Streamly.Internal.Data.Stream.Channel.Types -import Streamly.Internal.Data.Stream.Channel.Worker - ------------------------------------------------------------------------------- --- Concurrent streams with first-come-first serve results ------------------------------------------------------------------------------- - --- 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 :: - Channel m a - -> IORef ([(RunInIO m, K.StreamK m a)], [(RunInIO m, K.StreamK m a)]) - -> Bool - -> (RunInIO m, K.StreamK m a) - -> IO () -enqueueLIFO sv q inner m = do - atomicModifyIORefCAS_ q $ \(xs, ys) -> - if inner then (xs, m : ys) else (m : xs, ys) - ringDoorBell (doorBellOnWorkQ sv) (outputDoorBell sv) - -data QResult a = QEmpty | QOuter a | QInner a - -{-# INLINE dequeue #-} -dequeue :: MonadIO m => - IORef ([(RunInIO m, K.StreamK m a)], [(RunInIO m, K.StreamK m a)]) - -> m (QResult (RunInIO m, K.StreamK m a)) -dequeue qref = - liftIO - $ atomicModifyIORefCAS qref - $ \case - (xs, y : ys) -> ((xs, ys), QInner y) - (x : xs, ys) -> ((xs, ys), QOuter x) - x -> (x, QEmpty) - -data WorkerStatus = Continue | Suspend - -{-# INLINE workLoopLIFO #-} -workLoopLIFO - :: MonadRunInIO m - => IORef ([(RunInIO m, K.StreamK m a)], [(RunInIO m, K.StreamK m a)]) - -> Channel m a - -> Maybe WorkerInfo - -> m () -workLoopLIFO qref sv winfo = run - - where - - run = do - work <- dequeue qref - case work of - QEmpty -> - liftIO $ stop sv winfo - QInner (RunInIO runin, m) -> - process runin m True - QOuter (RunInIO runin, m) -> - process runin m False - - process runin m inner = do - -- XXX when we finish we need to send the monadic state back to - -- the parent so that the state can be merged back. We capture - -- and return the state in the stop continuation. - -- - -- Instead of using the run function we can just restore the - -- monad state here. That way it can work easily for - -- distributed case as well. - r <- liftIO $ runin $ - K.foldStreamShared - undefined - yieldk - single - (return Continue) - m - res <- restoreM r - case res of - Continue -> run - Suspend -> liftIO $ stop sv winfo - - where - - single a = do - res <- liftIO $ yield sv winfo a - return $ if res then Continue else Suspend - - yieldk a r = do - res <- liftIO $ yield sv winfo a - if res - then K.foldStreamShared undefined yieldk single (return Continue) r - else do - runInIO <- askRunInIO - liftIO $ enqueueLIFO sv qref inner (runInIO, r) - return Suspend - --- We duplicate workLoop for yield limit and no limit cases because it has --- around 40% performance overhead in the worst case. --- --- XXX we can pass yinfo directly as an argument here so that we do not have to --- make a check every time. -{-# INLINE workLoopLIFOLimited #-} -workLoopLIFOLimited - :: forall m a. MonadRunInIO m - => IORef ([(RunInIO m, K.StreamK m a)], [(RunInIO m, K.StreamK m a)]) - -> Channel m a - -> Maybe WorkerInfo - -> m () -workLoopLIFOLimited qref sv winfo = run - - where - - incrContinue = - liftIO (incrementYieldLimit (remainingWork sv)) >> return Continue - - run = do - work <- dequeue qref - case work of - QEmpty -> - liftIO $ stop sv winfo - QInner item -> - process item True - QOuter item -> - process item False - - process item@(RunInIO runin, m) inner = do - -- XXX This is just a best effort minimization of concurrency - -- to the yield limit. If the stream is made of concurrent - -- streams we do not reserve the yield limit in the constituent - -- streams before executing the action. This can be done - -- though, by sharing the yield limit ref with downstream - -- actions via state passing. Just a todo. - yieldLimitOk <- liftIO $ decrementYieldLimit (remainingWork sv) - if yieldLimitOk - then do - r <- liftIO $ runin $ - K.foldStreamShared - undefined - yieldk - single - incrContinue - m - res <- restoreM r - case res of - Continue -> run - Suspend -> liftIO $ stop sv winfo - -- Avoid any side effects, undo the yield limit decrement if we - -- never yielded anything. - else liftIO $ do - enqueueLIFO sv qref inner item - incrementYieldLimit (remainingWork sv) - stop sv winfo - - where - - single a = do - res <- liftIO $ yield sv winfo a - return $ if res then Continue else Suspend - - -- XXX can we pass on the yield limit downstream to limit the - -- concurrency of constituent streams. - yieldk a r = do - res <- liftIO $ yield sv winfo a - yieldLimitOk <- liftIO $ decrementYieldLimit (remainingWork sv) - if res && yieldLimitOk - then K.foldStreamShared undefined yieldk single incrContinue r - else do - runInIO <- askRunInIO - liftIO $ incrementYieldLimit (remainingWork sv) - liftIO $ enqueueLIFO sv qref inner (runInIO, r) - return Suspend - -------------------------------------------------------------------------------- --- Ahead Channel Data Structures -------------------------------------------------------------------------------- - --- 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. --- Therefore the queue never has more than one item in it. However, in case of --- parIterateConcatMap the iteration may add more items at the end of the --- queue. --- --- 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. -{-# ANN enqueueAhead "HLint: ignore" #-} -{-# INLINE enqueueAhead #-} -enqueueAhead :: - Channel m a - -> IORef ([K.StreamK m a], Int) - -> (RunInIO m, K.StreamK m a) - -> IO () -enqueueAhead sv q m = do - -- XXX The queue is LIFO. When parConcatIterate queues more than one items - -- to the queue it will perform a DFS style traversal. For BFS we will have - -- to use a FIFO data structure here. That would require another Config - -- option. - atomicModifyIORefCAS_ q $ \(xs, n) -> (snd m:xs, n) - ringDoorBell (doorBellOnWorkQ sv) (outputDoorBell 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 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 : xs, n) -> ((xs, n + 1), Just (x, n + 1)) - --- Dequeue only if the seq number matches the expected seq number. -{-# INLINE dequeueAheadSeqCheck #-} -dequeueAheadSeqCheck :: MonadIO m - => IORef ([t m a], Int) -> Int -> m (Maybe (t m a)) -dequeueAheadSeqCheck q seqNo = liftIO $ - atomicModifyIORefCAS q $ \case - ([], n) -> (([], n), Nothing) - (x : xs, n) -> - if n + 1 == seqNo - then ((xs, n + 1), Just x) - else ((x : xs, n), Nothing) - -------------------------------------------------------------------------------- --- 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 AheadHeapEntry (t :: (Type -> Type) -> Type -> Type) m a = - AheadEntryNull - | AheadEntryPure a - | AheadEntryStream (RunInIO m, t m a) - -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) - ------------------------------------------------------------------------------- --- Ahead: Concurrent streams with ordered results ------------------------------------------------------------------------------- - --- Lookahead streams can execute multiple tasks concurrently, ahead of time, --- but always serve them in the same order as they appear in the stream. To --- implement lookahead streams efficiently we assign a sequence number to each --- task when the task is picked up for execution. When the task finishes, the --- output is tagged with the same sequence number and we rearrange the outputs --- in sequence based on that number. --- --- To explain the mechanism imagine that the current task at the head of the --- stream has a "token" to yield to the outputQueue. The ownership of the token --- is determined by the current sequence number is maintained in outputHeap. --- Sequence number is assigned when a task is queued. When a thread dequeues a --- task it picks up the sequence number as well and when the output is ready it --- uses the sequence number to queue the output to the outputQueue. --- --- The thread with current sequence number sends the output directly to the --- outputQueue. Other threads push the output to the outputHeap. When the task --- being queued on the heap is a stream of many elements we evaluate only the --- first element and keep the rest of the unevaluated computation in the heap. --- When such a task gets the "token" for outputQueue it evaluates and directly --- yields all the elements to the outputQueue without checking for the --- "token". --- --- Note that no two outputs in the heap can have the same sequence numbers and --- therefore we do not need a stable heap. We have also separated the buffer --- for the current task (outputQueue) and the pending tasks (outputHeap) so --- that the pending tasks cannot interfere with the current task. Note that for --- a single task just the outputQueue is enough and for the case of many --- threads just a heap is good enough. However we balance between these two --- cases, so that both are efficient. --- --- For bigger streams it may make sense to have separate buffers for each --- stream. However, for singleton streams this may become inefficient. However, --- if we do not have separate buffers, then the streams that come later in --- sequence may hog the buffer, hindering the streams that are ahead. For this --- reason we have a single element buffer limitation for the streams being --- executed in advance. --- --- This scheme works pretty efficiently with less than 40% extra overhead --- compared to the Async streams where we do not have any kind of sequencing of --- the outputs. It is especially devised so that we are most efficient when we --- have short tasks and need just a single thread. Also when a thread yields --- many items it can hold lockfree access to the outputQueue and do it --- efficiently. --- --- XXX Maybe we can start the ahead threads at a lower cpu and IO priority so --- that they do not hog the resources and hinder the progress of the threads in --- front of them. - --- Left associated ahead expressions are expensive. We start a new SVar for --- each left associative expression. The queue is used only for right --- associated expression, we queue the right expression and execute the left. --- Thererefore the queue never has more than on item in it. --- --- XXX Also note that limiting concurrency for cases like "take 10" would not --- work well with left associative expressions, because we have no visibility --- about how much the left side of the expression would yield. --- --- XXX It may be a good idea to increment sequence numbers for each yield, --- currently a stream on the left side of the expression may yield many --- elements with the same sequene number. We can then use the seq number to --- enforce yieldMax and yieldLImit as well. - --- Invariants: --- --- * A worker should always ensure that it pushes all the consecutive items in --- the heap to the outputQueue especially the items on behalf of the workers --- that have already left when we were holding the token. This avoids deadlock --- conditions when the later workers completion depends on the consumption of --- earlier results. For more details see comments in the consumer pull side --- code. - -{-# INLINE underMaxHeap #-} -underMaxHeap :: - Channel m a - -> Heap (Entry Int (AheadHeapEntry K.StreamK m a)) - -> IO Bool -underMaxHeap sv hp = do - (_, len) <- readIORef (outputQueue sv) - - -- XXX simplify this - let maxHeap = case maxBufferLimit sv of - Limited lim -> Limited $ - max 0 (lim - fromIntegral len) - Unlimited -> Unlimited - - case maxHeap of - Limited lim -> do - active <- readIORef (workerCount sv) - return $ H.size hp + active <= fromIntegral lim - Unlimited -> return True - --- Return value: --- True => stop --- False => continue -preStopCheck :: - Channel m a - -> IORef (Heap (Entry Int (AheadHeapEntry K.StreamK m a)) , Maybe Int) - -> IO Bool -preStopCheck sv heap = - -- check the stop condition under a lock before actually - -- stopping so that the whole herd does not stop at once. - withIORef heap $ \(hp, _) -> do - heapOk <- underMaxHeap sv hp - takeMVar (workerStopMVar sv) - let stopping = do - putMVar (workerStopMVar sv) () - return True - continue = do - putMVar (workerStopMVar sv) () - return False - if heapOk - then - case yieldRateInfo sv of - Nothing -> continue - Just yinfo -> do - rateOk <- - isBeyondMaxRate - (maxWorkerLimit sv) (workerCount sv) yinfo - if rateOk then continue else stopping - else stopping - -abortExecution :: Channel m a -> Maybe WorkerInfo -> IO () -abortExecution sv winfo = do - incrementYieldLimit (remainingWork sv) - stop sv winfo - --- XXX In absence of a "noyield" primitive (i.e. do not pre-empt inside a --- critical section) from GHC RTS, we have a difficult problem. Assume we have --- a 100,000 threads producing output and queuing it to the heap for --- sequencing. The heap can be drained only by one thread at a time, any thread --- that finds that heap can be drained now, takes a lock and starts draining --- it, however the thread may get prempted in the middle of it holding the --- lock. Since that thread is holding the lock, the other threads cannot pick --- up the draining task, therefore they proceed to picking up the next task to --- execute. If the draining thread could yield voluntarily at a point where it --- has released the lock, then the next threads could pick up the draining --- instead of executing more tasks. When there are 100,000 threads the drainer --- gets a cpu share to run only 1:100000 of the time. This makes the heap --- accumulate a lot of output when we the buffer size is large. --- --- The solutions to this problem are: --- 1) make the other threads wait in a queue until the draining finishes --- 2) make the other threads queue and go away if draining is in progress --- --- In both cases we give the drainer a chance to run more often. --- -processHeap - :: MonadRunInIO m - => IORef ([K.StreamK m a], Int) - -> IORef (Heap (Entry Int (AheadHeapEntry K.StreamK m a)), Maybe Int) - -> Channel m a - -> Maybe WorkerInfo - -> AheadHeapEntry K.StreamK m a - -> Int - -> Bool -- we are draining the heap before we stop - -> m () -processHeap q heap sv winfo entry sno stopping = loopHeap sno entry - - where - - stopIfNeeded ent seqNo r = do - stopIt <- liftIO $ preStopCheck sv heap - if stopIt - then liftIO $ do - -- put the entry back in the heap and stop - requeueOnHeapTop heap (Entry seqNo ent) seqNo - stop sv winfo - else runStreamWithYieldLimit True seqNo r - - loopHeap seqNo ent = - case ent of - AheadEntryNull -> nextHeap seqNo - AheadEntryPure a -> do - -- Use 'send' directly so that we do not account this in worker - -- latency as this will not be the real latency. - -- Don't stop the worker in this case as we are just - -- transferring available results from heap to outputQueue. - void - $ liftIO - $ sendWithDoorBell - (outputQueue sv) (outputDoorBell sv) (ChildYield a) - nextHeap seqNo - AheadEntryStream (RunInIO runin, r) -> do - if stopping - then stopIfNeeded ent seqNo r - else do - res <- liftIO $ runin (runStreamWithYieldLimit True seqNo r) - restoreM res - - nextHeap prevSeqNo = do - res <- liftIO $ dequeueFromHeapSeq heap (prevSeqNo + 1) - case res of - Ready (Entry seqNo hent) -> loopHeap seqNo hent - Clearing -> liftIO $ stop sv winfo - Waiting _ -> - if stopping - then do - r <- liftIO $ preStopCheck sv heap - if r - then liftIO $ stop sv winfo - else processWorkQueue prevSeqNo - else inline processWorkQueue prevSeqNo - - processWorkQueue prevSeqNo = do - yieldLimitOk <- liftIO $ decrementYieldLimit (remainingWork sv) - if yieldLimitOk - then do - work <- dequeueAhead q - case work of - Nothing -> liftIO $ stop sv winfo - Just (m, seqNo) -> do - if seqNo == prevSeqNo + 1 - then processWithToken q heap sv winfo m seqNo - else processWithoutToken q heap sv winfo m seqNo - else liftIO $ abortExecution sv winfo - - -- We do not stop the worker on buffer full here as we want to proceed to - -- nextHeap anyway so that we can clear any subsequent entries. We stop - -- only in yield continuation where we may have a remaining stream to be - -- pushed on the heap. - singleStreamFromHeap seqNo a = do - void $ liftIO $ yield sv winfo a - nextHeap seqNo - - -- XXX when we have an unfinished stream on the heap we cannot account all - -- the yields of that stream until it finishes, so if we have picked up - -- and executed more actions beyond that in the parent stream and put them - -- on the heap then they would eat up some yield limit which is not - -- correct, we will think that our yield limit is over even though we have - -- to yield items from unfinished stream before them. For this reason, if - -- there are pending items in the heap we drain them unconditionally - -- without considering the yield limit. - runStreamWithYieldLimit continue seqNo r = do - _ <- liftIO $ decrementYieldLimit (remainingWork sv) - if continue -- see comment above -- && yieldLimitOk - then do - let stopk = do - liftIO (incrementYieldLimit (remainingWork sv)) - nextHeap seqNo - K.foldStreamShared undefined - (yieldStreamFromHeap seqNo) - (singleStreamFromHeap seqNo) - stopk - r - else do - runIn <- askRunInIO - let ent = Entry seqNo (AheadEntryStream (runIn, r)) - liftIO $ do - requeueOnHeapTop heap ent seqNo - incrementYieldLimit (remainingWork sv) - stop sv winfo - - yieldStreamFromHeap seqNo a r = do - continue <- liftIO $ yield sv winfo a - runStreamWithYieldLimit continue seqNo r - -{-# NOINLINE drainHeap #-} -drainHeap - :: MonadRunInIO m - => IORef ([K.StreamK m a], Int) - -> IORef (Heap (Entry Int (AheadHeapEntry K.StreamK m a)), Maybe Int) - -> Channel m a - -> Maybe WorkerInfo - -> m () -drainHeap q heap sv winfo = do - r <- liftIO $ dequeueFromHeap heap - case r of - Ready (Entry seqNo hent) -> - processHeap q heap sv winfo hent seqNo True - _ -> liftIO $ stop sv winfo - -data HeapStatus = HContinue | HStop - -processWithoutToken - :: MonadRunInIO m - => IORef ([K.StreamK m a], Int) - -> IORef (Heap (Entry Int (AheadHeapEntry K.StreamK m a)), Maybe Int) - -> Channel m a - -> Maybe WorkerInfo - -> K.StreamK m a - -> Int - -> m () -processWithoutToken q heap sv winfo m seqNo = do - -- we have already decremented the yield limit for m - let stopk = do - liftIO (incrementYieldLimit (remainingWork sv)) - -- If the stream stops without yielding anything, and we do not put - -- anything on heap, but if heap was waiting for this seq number - -- then it will keep waiting forever, because we are never going to - -- put it on heap. So we have to put a null entry on heap even when - -- we stop. - toHeap AheadEntryNull - mrun = runInIO $ svarMrun sv - - r <- liftIO $ mrun $ - K.foldStreamShared undefined - (\a r -> do - runIn <- askRunInIO - toHeap $ AheadEntryStream (runIn, K.cons a r)) - (toHeap . AheadEntryPure) - stopk - m - res <- restoreM r - case res of - Continue -> workLoopAhead q heap sv winfo - Suspend -> drainHeap q heap sv winfo - - where - - -- XXX to reduce contention each CPU can have its own heap - toHeap ent = do - -- Heap insertion is an expensive affair so we use a non CAS based - -- modification, otherwise contention and retries can make a thread - -- context switch and throw it behind other threads which come later in - -- sequence. - newHp <- liftIO $ atomicModifyIORef heap $ \(hp, snum) -> - let hp' = H.insert (Entry seqNo ent) hp - in assert (heapIsSane snum seqNo) ((hp', snum), hp') - - when (svarInspectMode sv) $ - liftIO $ do - maxHp <- readIORef (maxHeapSize $ svarStats sv) - when (H.size newHp > maxHp) $ - writeIORef (maxHeapSize $ svarStats sv) (H.size newHp) - - heapOk <- liftIO $ underMaxHeap sv newHp - status <- - case yieldRateInfo sv of - Nothing -> return HContinue - Just yinfo -> - case winfo of - Just info -> do - rateOk <- - liftIO - $ workerRateControl - (maxWorkerLimit sv) - (workerCount sv) - yinfo - info - if rateOk - then return HContinue - else return HStop - Nothing -> return HContinue - - if heapOk - then - case status of - HContinue -> return Continue - HStop -> return Suspend - else return Suspend - -data TokenWorkerStatus = TokenContinue Int | TokenSuspend - -processWithToken - :: MonadRunInIO m - => IORef ([K.StreamK m a], Int) - -> IORef (Heap (Entry Int (AheadHeapEntry K.StreamK m a)), Maybe Int) - -> Channel m a - -> Maybe WorkerInfo - -> K.StreamK m a - -> Int - -> m () -processWithToken q heap sv winfo action sno = do - -- Note, we enter this function with yield limit already decremented - -- XXX deduplicate stop in all invocations - let stopk = do - liftIO (incrementYieldLimit (remainingWork sv)) - return $ TokenContinue (sno + 1) - mrun = runInIO $ svarMrun sv - - r <- - liftIO - $ mrun - $ K.foldStreamShared - undefined (yieldOutput sno) (singleOutput sno) stopk action - - res <- restoreM r - case res of - TokenContinue seqNo -> loopWithToken seqNo - TokenSuspend -> drainHeap q heap sv winfo - - where - - singleOutput seqNo a = do - continue <- liftIO $ yield sv winfo a - if continue - then return $ TokenContinue (seqNo + 1) - else do - liftIO $ updateHeapSeq heap (seqNo + 1) - return TokenSuspend - - -- XXX use a wrapper function around stop so that we never miss - -- incrementing the yield in a stop continuation. Essentiatlly all - -- "unstream" calls in this function must increment yield limit on stop. - yieldOutput seqNo a r = do - continue <- liftIO $ yield sv winfo a - yieldLimitOk <- liftIO $ decrementYieldLimit (remainingWork sv) - if continue && yieldLimitOk - then do - let stopk = do - liftIO (incrementYieldLimit (remainingWork sv)) - return $ TokenContinue (seqNo + 1) - K.foldStreamShared undefined - (yieldOutput seqNo) - (singleOutput seqNo) - stopk - r - else do - runIn <- askRunInIO - let ent = Entry seqNo (AheadEntryStream (runIn, r)) - liftIO $ requeueOnHeapTop heap ent seqNo - liftIO $ incrementYieldLimit (remainingWork sv) - return TokenSuspend - - loopWithToken nextSeqNo = do - let preExit = liftIO $ do - updateHeapSeq heap nextSeqNo - incrementYieldLimit (remainingWork sv) - yieldLimitOk <- liftIO $ decrementYieldLimit (remainingWork sv) - -- To avoid a race when another thread puts something - -- on the heap and goes away, the consumer will not get - -- a doorBell and we will not clear the heap before - -- executing the next action. If the consumer depends - -- on the output that is stuck in the heap then this - -- will result in a deadlock. So we always clear the - -- heap before executing the next action. - if yieldLimitOk - then do - -- XXX Instead of checking seqno inside dequeue we can dequeue - -- unconditionally and if the seqNo is not the same as nextSeqNo - -- then release the token and call processWithoutToken. Need - -- to check the performance though. - work <- dequeueAheadSeqCheck q nextSeqNo - case work of - Nothing -> preExit >> workLoopAhead q heap sv winfo - Just m -> do - let stopk = do - liftIO (incrementYieldLimit (remainingWork sv)) - return $ TokenContinue (nextSeqNo + 1) - mrun = runInIO $ svarMrun sv - r <- liftIO $ mrun $ - K.foldStreamShared undefined - (yieldOutput nextSeqNo) - (singleOutput nextSeqNo) - stopk - m - res <- restoreM r - case res of - TokenContinue seqNo -> loopWithToken seqNo - TokenSuspend -> drainHeap q heap sv winfo - else preExit >> drainHeap q heap sv winfo - --- XXX the yield limit changes increased the performance overhead by 30-40%. --- Just like AsyncT we can use an implementation without yeidlimit and even --- without pacing code to keep the performance higher in the unlimited and --- unpaced case. --- --- XXX The yieldLimit stuff is pretty invasive. We can instead do it by using --- three hooks, a pre-execute hook, a yield hook and a stop hook. In fact these --- hooks can be used for a more general implementation to even check predicates --- and not just yield limit. - -workLoopAhead - :: MonadRunInIO m - => IORef ([K.StreamK m a], Int) - -> IORef (Heap (Entry Int (AheadHeapEntry K.StreamK m a)), Maybe Int) - -> Channel m a - -> Maybe WorkerInfo - -> m () -workLoopAhead q heap sv winfo = do - r <- liftIO $ dequeueFromHeap heap - case r of - Ready (Entry seqNo hent) -> - processHeap q heap sv winfo hent seqNo False - Clearing -> liftIO $ stop sv winfo - Waiting _ -> do - -- Before we execute the next item from the work queue we check - -- if we are beyond the yield limit. It is better to check the - -- yield limit before we pick up the next item. Otherwise we - -- may have already started more tasks even though we may have - -- reached the yield limit. We can avoid this by taking active - -- workers into account, but that is not as reliable, because - -- workers may go away without picking up work and yielding a - -- value. - -- - -- Rate control can be done either based on actual yields in - -- the output queue or based on any yield either to the heap or - -- to the output queue. In both cases we may have one issue or - -- the other. We chose to do this based on actual yields to the - -- output queue because it makes the code common to both async - -- and ahead streams. - -- - yieldLimitOk <- liftIO $ decrementYieldLimit (remainingWork sv) - if yieldLimitOk - then do - work <- dequeueAhead q - case work of - Nothing -> liftIO $ stop sv winfo - Just (m, seqNo) -> do - if seqNo == 0 - then processWithToken q heap sv winfo m seqNo - else processWithoutToken q heap sv winfo m seqNo - else liftIO $ abortExecution sv winfo - -------------------------------------------------------------------------------- --- SVar creation --- This code belongs in SVar.hs but is kept here for perf reasons -------------------------------------------------------------------------------- - --- XXX we have this function in this file because passing runStreamLIFO as a --- function argument to this function results in a perf degradation of more --- than 10%. Need to investigate what the root cause is. --- Interestingly, the same thing does not make any difference for Ahead. --- {-# INLINABLE getLifoSVar #-} -getLifoSVar :: forall m a. MonadRunInIO m => - RunInIO m -> Config -> IO (Channel m a) -getLifoSVar mrun cfg = 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 Set.empty - q <- newIORef - ( [] :: [(RunInIO m, K.StreamK m a)] - , [] :: [(RunInIO m, K.StreamK m a)] - ) - -- Sequence number is incremented whenever something is de-queued, - -- therefore, first sequence number would be 0 - aheadQ <- newIORef ([], -1) - stopMVar <- newMVar () - yl <- - case getYieldLimit cfg of - Nothing -> return Nothing - Just x -> Just <$> newIORef x - rateInfo <- newRateInfo cfg - - stats <- newSVarStats - tid <- myThreadId - - -- We are reading it without lock, the result would be reliable only if no - -- worker is pending. - let isWorkFinished _ = do - (xs, ys) <- readIORef q - return (null xs && null ys) - - let isWorkFinishedLimited sv = do - yieldsDone <- - case remainingWork sv of - Just ref -> do - n <- readIORef ref - return (n <= 0) - Nothing -> return False - qEmpty <- isWorkFinished sv - return $ qEmpty || yieldsDone - - let eagerEval = getEagerDispatch cfg - inOrder = getOrdered cfg - - let getSVar :: Channel m a - -> (Channel m a -> m [ChildEvent a]) - -> (Channel m a -> m Bool) - -> (Channel m a -> IO Bool) - -> (IORef ([(RunInIO m, K.StreamK m a)], [(RunInIO m, K.StreamK m a)]) - -> Channel m a - -> Maybe WorkerInfo - -> m()) - -> Channel m a - getSVar sv readOutput postProc workDone wloop = Channel - { outputQueue = outQ - , remainingWork = yl - , maxBufferLimit = getMaxBuffer cfg - , maxWorkerLimit = min (getMaxThreads cfg) (getMaxBuffer cfg) - , yieldRateInfo = rateInfo - , outputDoorBell = outQMv - , readOutputQ = readOutput sv - , postProcess = postProc sv - , workerThreads = running - - , workLoop = - if inOrder - then workLoopAhead aheadQ outH sv - else wloop q sv - , enqueue = - \inner -> - if inOrder - then enqueueAhead sv aheadQ - else enqueueLIFO sv q inner - , eagerDispatch = when eagerEval $ void $ dispatchWorker 0 sv - , isWorkDone = - if inOrder - then isWorkDoneAhead sv aheadQ outH - else workDone sv - , isQueueDone = - if inOrder - then isQueueDoneAhead sv aheadQ - else workDone sv - - , doorBellOnWorkQ = wfw - , svarMrun = mrun - , workerCount = active - -- XXX We can use delThread or modThread based on eager flag. - , accountThread = modifyThread running outQMv - , workerStopMVar = stopMVar - , svarRef = Nothing - , svarInspectMode = getInspectMode cfg - , svarCreator = tid - , svarStats = stats - } - - let sv = - case getStreamRate cfg of - Nothing -> - case getYieldLimit cfg of - Nothing -> getSVar sv (readOutputQBounded eagerEval) - postProcessBounded - isWorkFinished - workLoopLIFO - Just _ -> getSVar sv (readOutputQBounded eagerEval) - postProcessBounded - isWorkFinishedLimited - workLoopLIFOLimited - Just _ -> - case getYieldLimit cfg of - Nothing -> getSVar sv readOutputQPaced - postProcessPaced - isWorkFinished - workLoopLIFO - Just _ -> getSVar sv readOutputQPaced - postProcessPaced - isWorkFinishedLimited - workLoopLIFOLimited - 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 - --- | Create a new async style concurrent stream evaluation channel. The monad --- state used to run the stream actions is taken from the call site of --- newChannel. -{-# INLINABLE newChannel #-} -{-# SPECIALIZE newChannel :: (Config -> Config) -> IO (Channel IO a) #-} -newChannel :: MonadRunInIO m => (Config -> Config) -> m (Channel m a) -newChannel modifier = do - mrun <- askRunInIO - liftIO $ getLifoSVar mrun (modifier defaultConfig) diff --git a/src/Streamly/Internal/Data/Stream/Concurrent/Channel/Consumer.hs b/src/Streamly/Internal/Data/Stream/Concurrent/Channel/Consumer.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Stream/Concurrent/Channel/Consumer.hs +++ /dev/null @@ -1,127 +0,0 @@ --- | --- Module : Streamly.Internal.Data.Stream.Concurrent.Channel.Consumer --- Copyright : (c) 2017 Composewell Technologies --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- -module Streamly.Internal.Data.Stream.Concurrent.Channel.Consumer - ( - -- * Read Output - readOutputQPaced - , readOutputQBounded - - -- * Postprocess Hook After Reading - , postProcessPaced - , postProcessBounded - ) -where - -import Control.Monad (when, void) -import Control.Monad.IO.Class (MonadIO(liftIO)) -import Data.IORef (readIORef) -import Streamly.Internal.Control.Concurrent (MonadRunInIO) - -import Streamly.Internal.Data.Stream.Concurrent.Channel.Dispatcher -import Streamly.Internal.Data.Stream.Concurrent.Channel.Type -import Streamly.Internal.Data.Stream.Channel.Dispatcher -import Streamly.Internal.Data.Stream.Channel.Types - -------------------------------------------------------------------------------- --- Reading from the workers' output queue/buffer -------------------------------------------------------------------------------- - -{-# INLINE readOutputQChan #-} -readOutputQChan :: Channel m a -> IO ([ChildEvent a], Int) -readOutputQChan sv = do - let ss = if svarInspectMode sv then Just (svarStats sv) else Nothing - in readOutputQRaw (outputQueue sv) ss - -readOutputQBounded :: MonadRunInIO m => Bool -> Channel m a -> m [ChildEvent a] -readOutputQBounded eagerEval sv = do - (list, len) <- liftIO $ readOutputQChan 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 eagerEval sendWorkerDelay (dispatchWorker 0) sv - liftIO (fst `fmap` readOutputQChan sv) - -readOutputQPaced :: MonadRunInIO m => Channel m a -> m [ChildEvent a] -readOutputQPaced sv = do - (list, len) <- liftIO $ readOutputQChan 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 False sendWorkerDelayPaced dispatchWorkerPaced sv - liftIO (fst `fmap` readOutputQChan sv) - -postProcessPaced :: MonadRunInIO m => Channel m a -> m Bool -postProcessPaced sv = do - workersDone <- allThreadsDone (workerThreads 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 (workerThreads sv) - when noWorker $ pushWorker 0 sv - return r - else return False - -postProcessBounded :: MonadRunInIO m => Channel m a -> m Bool -postProcessBounded sv = do - workersDone <- allThreadsDone (workerThreads 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 diff --git a/src/Streamly/Internal/Data/Stream/Concurrent/Channel/Dispatcher.hs b/src/Streamly/Internal/Data/Stream/Concurrent/Channel/Dispatcher.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Stream/Concurrent/Channel/Dispatcher.hs +++ /dev/null @@ -1,417 +0,0 @@ --- | --- Module : Streamly.Internal.Data.Stream.Concurrent.Channel.Dispatcher --- Copyright : (c) 2017 Composewell Technologies --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- --- -module Streamly.Internal.Data.Stream.Concurrent.Channel.Dispatcher - ( - -- * Dispatching - pushWorker - , dispatchWorker - , dispatchWorkerPaced - , sendWorkerWait - , startChannel - , sendWorkerDelay - , sendWorkerDelayPaced - ) -where - -import Control.Concurrent (takeMVar, threadDelay) -import Control.Exception (assert) -import Control.Monad (when, void) -import Control.Monad.IO.Class (MonadIO(liftIO)) -import Data.Maybe (fromJust, fromMaybe) -import Data.IORef (modifyIORef, newIORef, readIORef, writeIORef) -import Streamly.Internal.Control.Concurrent (MonadRunInIO) -import Streamly.Internal.Control.ForkLifted (doFork) -import Streamly.Internal.Data.Atomics (atomicModifyIORefCAS_, storeLoadBarrier) -import Streamly.Internal.Data.Time.Clock (Clock(Monotonic), getTime) -import Streamly.Internal.Data.Time.Units - (MicroSecond64(..), diffAbsTime64, fromRelTime64, toRelTime64) - -import Streamly.Internal.Data.Stream.Concurrent.Channel.Type -import Streamly.Internal.Data.Stream.Channel.Dispatcher -import Streamly.Internal.Data.Stream.Channel.Types -import Streamly.Internal.Data.Stream.Channel.Worker - -------------------------------------------------------------------------------- --- Dispatching workers -------------------------------------------------------------------------------- - -{-# NOINLINE pushWorker #-} -pushWorker :: MonadRunInIO m => Count -> Channel m a -> m () -pushWorker yieldMax sv = do - liftIO $ atomicModifyIORefCAS_ (workerCount sv) $ \n -> n + 1 - when (svarInspectMode sv) - $ recordMaxWorkers (workerCount sv) (svarStats 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 - } - -- In case of lazy dispatch we dispatch workers only from the consumer - -- thread. In that case it is ok to use addThread here as it is guaranteed - -- that the thread will be added to the workerSet before the thread STOP - -- event is processed, because we do both of these actions in the same - -- consumer thread. However, in case of eager dispatch we may dispatch - -- workers from workers, in which case the thread Stop even may get - -- processed before the addThread occurs, so in that case we have to use - -- modifyThread which performs a toggle rather than adding or deleting. - -- - -- XXX We can use addThread or modThread based on eager flag. - doFork (workLoop sv winfo) (svarMrun sv) exception >>= modThread - - where - - modThread = modifyThread (workerThreads sv) (outputDoorBell sv) - exception = handleChildException (outputQueue sv) (outputDoorBell sv) - --- | Determine the maximum number of workers required based on 'maxWorkerLimit' --- and 'remainingWork'. -{-# INLINE getEffectiveWorkerLimit #-} -getEffectiveWorkerLimit :: MonadIO m => Channel m a -> m Limit -getEffectiveWorkerLimit sv = do - let workerLimit = maxWorkerLimit sv - 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) - --- | Determine whether the active threads are more than the max threads we are --- allowed to dispatch. -{-# INLINE checkMaxThreads #-} -checkMaxThreads :: MonadIO m => Int -> Channel m a -> m Bool -checkMaxThreads active sv = 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 <- getEffectiveWorkerLimit sv - return - $ case limit of - Unlimited -> True - -- 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 -> fromIntegral lim > active - --- | Determine whether we would exceed max buffer if we dispatch more workers --- based on the current outputQueue size and active workers. -{-# INLINE checkMaxBuffer #-} -checkMaxBuffer :: MonadIO m => Int -> Channel m a -> m Bool -checkMaxBuffer active sv = do - let limit = maxBufferLimit sv - case limit of - Unlimited -> return True - Limited lim -> do - (_, n) <- liftIO $ readIORef (outputQueue sv) - return $ fromIntegral lim > n + active - -dispatchWorker :: MonadRunInIO m => - Count -> Channel m a -> m Bool -dispatchWorker yieldCount sv = do - -- 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. - -- XXX Should we have a single abstraction for checking q and - -- work instead checking the two separately? - 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 be more until the sendStop events are processed. - active <- liftIO $ readIORef $ workerCount sv - when (active < 0) $ error "dispatchWorker active negative" - if not qDone - then do - -- 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. - r <- checkMaxThreads active sv - if r - then do - r1 <- checkMaxBuffer active sv - if r1 - then pushWorker yieldCount sv >> return True - else return False - else return False - else do - when (active <= 0) $ do - r <- liftIO $ isWorkDone sv - when (not r) $ pushWorker 0 sv - return False - else return False - --- 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 :: MonadRunInIO m => - Channel 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 - (svarInspectMode sv) (svarStats sv) yinfo False - let elapsed = fromRelTime64 $ diffAbsTime64 now baseTime - let latency = - if lat == 0 - then fromMaybe lat (workerBootstrapLatency yinfo) - 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 (workerThreads 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 (workerThreads 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 - -{-# NOINLINE sendWorkerWait #-} -sendWorkerWait - :: MonadIO m - => Bool - -> (Channel m a -> IO ()) - -> (Channel m a -> m Bool) - -> Channel m a - -> m () -sendWorkerWait eagerEval delay dispatch sv = go - - where - - go = 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 || eagerEval) $ 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_ (doorBellOnWorkQ 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 go - else do - liftIO - $ withDiagMVar - (svarInspectMode sv) - (dumpSVar sv) - "sendWorkerWait: nothing to do" - $ takeMVar (outputDoorBell sv) - (_, len) <- liftIO $ readIORef (outputQueue sv) - if len <= 0 - then go - else - liftIO - $ atomicModifyIORefCAS_ (doorBellOnWorkQ sv) - $ const False - --- | Start the evaluation of the channel's work queue by kicking off a worker. --- Note: Work queue must not be empty otherwise the worker will exit without --- doing anything. -startChannel :: MonadRunInIO m => - Channel m a -> m () -startChannel chan = do - case yieldRateInfo chan of - Nothing -> pushWorker 0 chan - Just yinfo -> - if svarLatencyTarget yinfo == maxBound - then liftIO $ threadDelay maxBound - else pushWorker 1 chan - -sendWorkerDelayPaced :: Channel m a -> IO () -sendWorkerDelayPaced _ = return () - -sendWorkerDelay :: Channel 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 () diff --git a/src/Streamly/Internal/Data/Stream/Concurrent/Channel/Interleave.hs b/src/Streamly/Internal/Data/Stream/Concurrent/Channel/Interleave.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Stream/Concurrent/Channel/Interleave.hs +++ /dev/null @@ -1,250 +0,0 @@ --- | --- Module : Streamly.Internal.Data.Stream.Concurrent.Channel.Interleave --- Copyright : (c) 2017 Composewell Technologies --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC - -module Streamly.Internal.Data.Stream.Concurrent.Channel.Interleave - ( - newChannel - ) -where - -#include "inline.hs" - -import Control.Concurrent (myThreadId) -import Control.Concurrent.MVar (newEmptyMVar) -import Control.Monad.IO.Class (MonadIO(liftIO)) -import Data.Concurrent.Queue.MichaelScott (LinkedQueue, newQ, nullQ, tryPopR, pushL) -import Data.IORef (newIORef, readIORef) -import Streamly.Internal.Control.Concurrent - (MonadRunInIO, MonadAsync, RunInIO(..), askRunInIO, restoreM) -import Streamly.Internal.Data.Stream.Channel.Dispatcher (delThread) - -import qualified Data.Set as Set -import qualified Streamly.Internal.Data.Stream.StreamK.Type as K - -import Streamly.Internal.Data.Stream.Concurrent.Channel.Consumer -import Streamly.Internal.Data.Stream.Concurrent.Channel.Type -import Streamly.Internal.Data.Stream.Channel.Types - ------------------------------------------------------------------------------- --- Creating a channel ------------------------------------------------------------------------------- - -data WorkerStatus = Continue | Suspend - --- XXX This is not strictly round-robin as the streams that are faster may --- yield more elements than the ones that are slower. Also, when streams --- suspend due to buffer getting full they get added to the queue in a random --- order. - -{-# INLINE enqueueFIFO #-} -enqueueFIFO :: - Channel m a - -> LinkedQueue (RunInIO m, K.StreamK m a) - -> (RunInIO m, K.StreamK m a) - -> IO () -enqueueFIFO sv q m = do - pushL q m - ringDoorBell (doorBellOnWorkQ sv) (outputDoorBell sv) - -{-# INLINE workLoopFIFO #-} -workLoopFIFO - :: MonadRunInIO m - => LinkedQueue (RunInIO m, K.StreamK m a) - -> Channel m a - -> Maybe WorkerInfo - -> m () -workLoopFIFO q sv winfo = run - - where - - run = do - work <- liftIO $ tryPopR q - case work of - Nothing -> liftIO $ stop sv winfo - Just (RunInIO runin, m) -> do - r <- liftIO - $ runin - $ K.foldStreamShared - undefined yieldk single (return Continue) m - res <- restoreM r - case res of - Continue -> run - Suspend -> liftIO $ stop sv winfo - - single a = do - res <- liftIO $ yield sv winfo a - return $ if res then Continue else Suspend - - -- XXX in general we would like to yield "n" elements from a single stream - -- before moving on to the next. Single element granularity could be too - -- expensive in certain cases. Similarly, we can use time limit for - -- yielding. - yieldk a r = do - res <- liftIO $ yield sv winfo a - runInIO <- askRunInIO - liftIO $ enqueueFIFO sv q (runInIO, r) - return $ if res then Continue else Suspend - -{-# INLINE workLoopFIFOLimited #-} -workLoopFIFOLimited - :: forall m a. MonadRunInIO m - => LinkedQueue (RunInIO m, K.StreamK m a) - -> Channel m a - -> Maybe WorkerInfo - -> m () -workLoopFIFOLimited q sv winfo = run - - where - - incrContinue = - liftIO (incrementYieldLimit (remainingWork sv)) >> return Continue - - run = do - work <- liftIO $ tryPopR q - case work of - Nothing -> liftIO $ stop sv winfo - Just (RunInIO runin, m) -> do - yieldLimitOk <- liftIO $ decrementYieldLimit (remainingWork sv) - if yieldLimitOk - then do - r <- liftIO - $ runin - $ K.foldStreamShared - undefined yieldk single incrContinue m - res <- restoreM r - case res of - Continue -> run - Suspend -> liftIO $ stop sv winfo - else liftIO $ do - enqueueFIFO sv q (RunInIO runin, m) - incrementYieldLimit (remainingWork sv) - stop sv winfo - - single a = do - res <- liftIO $ yield sv winfo a - return $ if res then Continue else Suspend - - yieldk a r = do - res <- liftIO $ yield sv winfo a - runInIO <- askRunInIO - liftIO $ enqueueFIFO sv q (runInIO, r) - yieldLimitOk <- liftIO $ decrementYieldLimit (remainingWork sv) - if res && yieldLimitOk - then return Continue - else liftIO $ do - incrementYieldLimit (remainingWork sv) - return Suspend - -------------------------------------------------------------------------------- --- SVar creation -------------------------------------------------------------------------------- - --- XXX we have this function in this file because passing runStreamLIFO as a --- function argument to this function results in a perf degradation of more --- than 10%. Need to investigate what the root cause is. --- Interestingly, the same thing does not make any difference for Ahead. -getFifoSVar :: forall m a. MonadRunInIO m => - RunInIO m -> Config -> IO (Channel m a) -getFifoSVar mrun cfg = do - outQ <- newIORef ([], 0) - outQMv <- newEmptyMVar - active <- newIORef 0 - wfw <- newIORef False - running <- newIORef Set.empty - q <- newQ - yl <- case getYieldLimit cfg of - Nothing -> return Nothing - Just x -> Just <$> newIORef x - rateInfo <- newRateInfo cfg - - stats <- newSVarStats - tid <- myThreadId - - let isWorkFinished _ = nullQ q - let isWorkFinishedLimited sv = do - yieldsDone <- - case remainingWork sv of - Just ref -> do - n <- readIORef ref - return (n <= 0) - Nothing -> return False - qEmpty <- nullQ q - return $ qEmpty || yieldsDone - - let getSVar :: Channel m a - -> (Channel m a -> m [ChildEvent a]) - -> (Channel m a -> m Bool) - -> (Channel m a -> IO Bool) - -> (LinkedQueue (RunInIO m, K.StreamK m a) - -> Channel m a - -> Maybe WorkerInfo - -> m()) - -> Channel m a - getSVar sv readOutput postProc workDone wloop = Channel - { outputQueue = outQ - , remainingWork = yl - , maxBufferLimit = getMaxBuffer cfg - , maxWorkerLimit = min (getMaxThreads cfg) (getMaxBuffer cfg) - , yieldRateInfo = rateInfo - , outputDoorBell = outQMv - , readOutputQ = readOutput sv - , postProcess = postProc sv - , workerThreads = running - , workLoop = wloop q sv - , enqueue = \_ -> enqueueFIFO sv q - , eagerDispatch = return () - , isWorkDone = workDone sv - , isQueueDone = workDone sv - , doorBellOnWorkQ = wfw - , svarMrun = mrun - , workerCount = active - , accountThread = delThread running - , workerStopMVar = undefined - , svarRef = Nothing - , svarInspectMode = getInspectMode cfg - , svarCreator = tid - , svarStats = stats - } - - let sv = - case getStreamRate cfg of - Nothing -> - case getYieldLimit cfg of - Nothing -> getSVar sv (readOutputQBounded False) - postProcessBounded - isWorkFinished - workLoopFIFO - Just _ -> getSVar sv (readOutputQBounded False) - postProcessBounded - isWorkFinishedLimited - workLoopFIFOLimited - Just _ -> - case getYieldLimit cfg of - Nothing -> getSVar sv readOutputQPaced - postProcessPaced - isWorkFinished - workLoopFIFO - Just _ -> getSVar sv readOutputQPaced - postProcessPaced - isWorkFinishedLimited - workLoopFIFOLimited - in return sv - --- XXX GHC: If instead of MonadAsync we use (MonadIO m, MonadBaseControl IO m) --- constraint we get a 2x perf regression. Need to look into that. --- --- | Create a new async style concurrent stream evaluation channel. The monad --- state used to run the stream actions is taken from the call site of --- newChannel. -{-# INLINABLE newChannel #-} -{-# SPECIALIZE newChannel :: (Config -> Config) -> IO (Channel IO a) #-} -newChannel :: MonadAsync m => - (Config -> Config) -> m (Channel m a) -newChannel modifier = do - mrun <- askRunInIO - liftIO $ getFifoSVar mrun (modifier defaultConfig) diff --git a/src/Streamly/Internal/Data/Stream/Concurrent/Channel/Operations.hs b/src/Streamly/Internal/Data/Stream/Concurrent/Channel/Operations.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Stream/Concurrent/Channel/Operations.hs +++ /dev/null @@ -1,294 +0,0 @@ -#ifdef __HADDOCK_VERSION__ -#undef INSPECTION -#endif - -#ifdef INSPECTION -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-} -#endif - --- | --- Module : Streamly.Internal.Data.Stream.Concurrent.Channel.Operations --- Copyright : (c) 2017 Composewell Technologies --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC - -module Streamly.Internal.Data.Stream.Concurrent.Channel.Operations - ( - toChannel - , toChannelK - , fromChannel - , fromChannelK - ) -where - -#include "inline.hs" - -import Control.Exception (fromException) -import Control.Monad (when) -import Control.Monad.Catch (throwM, MonadThrow) -import Control.Monad.IO.Class (MonadIO(liftIO)) -import Data.IORef (newIORef, readIORef, mkWeakIORef, writeIORef) -import Data.Maybe (isNothing) -import Streamly.Internal.Control.Concurrent - (MonadAsync, MonadRunInIO, askRunInIO) -import Streamly.Internal.Data.Stream.StreamD.Type (Stream) -import Streamly.Internal.Data.Time.Clock (Clock(Monotonic), getTime) -import System.Mem (performMajorGC) - -import qualified Streamly.Internal.Data.Stream.StreamD as Stream -import qualified Streamly.Internal.Data.Stream.StreamD.Type as D -import qualified Streamly.Internal.Data.Stream.StreamK.Type as K - -import Streamly.Internal.Data.Stream.Concurrent.Channel.Dispatcher -import Streamly.Internal.Data.Stream.Concurrent.Channel.Type -import Streamly.Internal.Data.Stream.Channel.Types hiding (inspect) - -import Prelude hiding (map, concat, concatMap) - -#ifdef INSPECTION -import Control.Exception (Exception) -import Control.Monad.Trans.Control (MonadBaseControl) -import Data.Typeable (Typeable) -import Test.Inspection (inspect, hasNoTypeClassesExcept) -#endif - ------------------------------------------------------------------------------- --- Generating streams from a channel ------------------------------------------------------------------------------- - --- $concurrentEval --- --- Usually a channel is used to concurrently evaluate multiple actions in a --- stream using many worker threads that push the results to the channel and a --- single puller that pulls them from channel generating the evaluated stream. --- --- @ --- input stream --- | --- <-----------------|<--------worker --- | exceptions | --- output stream <---Channel<------worker --- | --- |<--------worker --- --- @ --- --- The puller itself schedules the worker threads based on demand. --- Exceptions are propagated from the worker threads to the puller. - -------------------------------------------------------------------------------- --- Write a stream to a channel -------------------------------------------------------------------------------- - --- XXX Should be a Fold, singleton API could be called joinChannel, or the fold --- can be called joinChannel. - --- | Write a stream to an 'SVar' in a non-blocking manner. The stream can then --- be read back from the SVar using 'fromSVar'. -{-# INLINE toChannelK #-} -toChannelK :: MonadRunInIO m => Channel m a -> K.StreamK m a -> m () -toChannelK sv m = do - runIn <- askRunInIO - liftIO $ enqueue sv False (runIn, m) - --- INLINE for fromStreamK/toStreamK fusion - --- | Send a stream to a given channel for concurrent evaluation. -{-# INLINE toChannel #-} -toChannel :: MonadRunInIO m => Channel m a -> Stream m a -> m () -toChannel chan = toChannelK chan . Stream.toStreamK - -{- --- | Send a stream of streams to a concurrent channel for evaluation. -{-# INLINE joinChannel #-} -joinChannel :: Channel m a -> Fold m (Stream m a) () -joinChannel = undefined --} - -------------------------------------------------------------------------------- --- Read a stream from a channel -------------------------------------------------------------------------------- - --- | Pull a stream from an SVar. -{-# NOINLINE fromChannelRaw #-} -fromChannelRaw :: (MonadIO m, MonadThrow m) => Channel m a -> K.StreamK m a -fromChannelRaw sv = K.MkStream $ \st yld sng stp -> do - list <- readOutputQ sv - -- Reversing the output is important to guarantee that we process the - -- outputs in the same order as they were generated by the constituent - -- streams. - K.foldStream st yld sng stp $ processEvents $ reverse list - - where - - cleanup = do - when (svarInspectMode sv) $ liftIO $ do - t <- getTime Monotonic - writeIORef (svarStopTime (svarStats sv)) (Just t) - printSVar (dumpSVar sv) "SVar Done" - - {-# INLINE processEvents #-} - processEvents [] = K.MkStream $ \st yld sng stp -> do - done <- postProcess sv - if done - then cleanup >> stp - else K.foldStream st yld sng stp $ fromChannelRaw sv - - processEvents (ev : es) = K.MkStream $ \st yld sng stp -> do - let rest = processEvents es - case ev of - ChildYield a -> yld a rest - ChildStopChannel -> do - liftIO (cleanupSVar (workerThreads sv)) - cleanup >> stp - ChildStop tid e -> do - accountThread sv tid - case e of - Nothing -> K.foldStream st yld sng stp rest - Just ex -> - case fromException ex of - Just ThreadAbort -> - -- We terminate the loop after sending - -- ThreadAbort to workers so we should never - -- get it unless it is thrown from inside a - -- worker thread or by someone else to our - -- thread. - error "processEvents: got ThreadAbort" - -- K.foldStream st yld sng stp rest - Nothing -> do - liftIO (cleanupSVar (workerThreads sv)) - cleanup >> throwM ex - -#ifdef INSPECTION --- Use of GHC constraint tuple (GHC.Classes.(%,,%)) in fromStreamVar leads to --- space leak because the tuple gets allocated in every recursive call and each --- allocation holds on to the previous allocation. This test is to make sure --- that we do not use the constraint tuple type class. --- -inspect $ hasNoTypeClassesExcept 'fromChannelRaw - [ ''Monad - , ''Applicative - , ''MonadThrow - , ''Exception - , ''MonadIO - , ''MonadBaseControl - , ''Typeable - , ''Functor - ] -#endif - --- XXX fromChannel Should not be called multiple times, we can add a --- safeguard for that. Or we can replicate the stream so that we can distribute --- it to multiple consumers. or should we use an explicit dupChannel for that? - -{-# INLINE fromChannelK #-} -fromChannelK :: MonadAsync m => Channel m a -> K.StreamK m a -fromChannelK sv = - K.mkStream $ \st yld sng stp -> do - ref <- liftIO $ newIORef () - _ <- liftIO $ mkWeakIORef ref hook - - startChannel sv - -- We pass a copy of sv to fromStreamVar, so that we know that it has - -- no other references, when that copy gets garbage collected "ref" - -- will get garbage collected and our hook will be called. - K.foldStreamShared st yld sng stp $ - fromChannelRaw sv{svarRef = Just ref} - where - - hook = do - when (svarInspectMode sv) $ do - r <- liftIO $ readIORef (svarStopTime (svarStats sv)) - when (isNothing r) $ - printSVar (dumpSVar sv) "SVar Garbage Collected" - cleanupSVar (workerThreads sv) - -- If there are any SVars referenced by this SVar a GC will prompt - -- them to be cleaned up quickly. - when (svarInspectMode sv) performMajorGC - --- | Generate a stream of results from concurrent evaluations from a channel. --- Evaluation of the channel does not start until this API is called. This API --- must not be called more than once on a channel. It kicks off evaluation of --- the channel by dispatching concurrent workers and ensures that as long there --- is work queued on the channel workers are dispatched proportional to the --- demand by the consumer. --- -{-# INLINE fromChannel #-} -fromChannel :: MonadAsync m => Channel m a -> Stream m a -fromChannel = Stream.fromStreamK . fromChannelK - -data FromSVarState t m a = - FromSVarInit - | FromSVarRead (Channel m a) - | FromSVarLoop (Channel m a) [ChildEvent a] - | FromSVarDone (Channel m a) - --- | Like 'fromSVar' but generates a StreamD style stream instead of CPS. --- -{-# INLINE_NORMAL _fromChannelD #-} -_fromChannelD :: (MonadIO m, MonadThrow m) => Channel m a -> D.Stream m a -_fromChannelD svar = D.Stream step FromSVarInit - where - - {-# INLINE_LATE step #-} - step _ FromSVarInit = do - ref <- liftIO $ newIORef () - _ <- liftIO $ mkWeakIORef ref hook - -- when this copy of svar gets garbage collected "ref" will get - -- garbage collected and our GC hook will be called. - let sv = svar{svarRef = Just ref} - return $ D.Skip (FromSVarRead sv) - - where - - {-# NOINLINE hook #-} - hook = do - when (svarInspectMode svar) $ do - r <- liftIO $ readIORef (svarStopTime (svarStats svar)) - when (isNothing r) $ - printSVar (dumpSVar svar) "SVar Garbage Collected" - cleanupSVar (workerThreads svar) - -- If there are any SVars referenced by this SVar a GC will prompt - -- them to be cleaned up quickly. - when (svarInspectMode svar) performMajorGC - - step _ (FromSVarRead sv) = do - list <- readOutputQ sv - -- Reversing the output is important to guarantee that we process the - -- outputs in the same order as they were generated by the constituent - -- streams. - return $ D.Skip $ FromSVarLoop sv (Prelude.reverse list) - - step _ (FromSVarLoop sv []) = do - done <- postProcess sv - return $ D.Skip $ if done - then FromSVarDone sv - else FromSVarRead sv - - step _ (FromSVarLoop sv (ev : es)) = do - case ev of - ChildYield a -> return $ D.Yield a (FromSVarLoop sv es) - ChildStopChannel -> do - liftIO (cleanupSVar (workerThreads sv)) - return $ D.Skip (FromSVarDone sv) - ChildStop tid e -> do - accountThread sv tid - case e of - Nothing -> return $ D.Skip (FromSVarLoop sv es) - Just ex -> - case fromException ex of - Just ThreadAbort -> - return $ D.Skip (FromSVarLoop sv es) - Nothing -> do - liftIO (cleanupSVar (workerThreads sv)) - throwM ex - - step _ (FromSVarDone sv) = do - when (svarInspectMode sv) $ do - t <- liftIO $ getTime Monotonic - liftIO $ writeIORef (svarStopTime (svarStats sv)) (Just t) - liftIO $ printSVar (dumpSVar sv) "SVar Done" - return D.Stop diff --git a/src/Streamly/Internal/Data/Stream/Concurrent/Channel/Type.hs b/src/Streamly/Internal/Data/Stream/Concurrent/Channel/Type.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Stream/Concurrent/Channel/Type.hs +++ /dev/null @@ -1,172 +0,0 @@ --- | --- Module : Streamly.Internal.Data.Stream.Concurrent.Channel.Type --- Copyright : (c) 2017 Composewell Technologies --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC - -module Streamly.Internal.Data.Stream.Concurrent.Channel.Type - ( - Channel(..) - , yield - , stop - , stopChannel - , dumpSVar - ) -where - -import Control.Concurrent (ThreadId) -import Control.Concurrent.MVar (MVar) -import Control.Monad (void) -import Control.Monad.IO.Class (MonadIO(..)) -import Data.IORef (IORef) -import Data.List (intersperse) -import Data.Set (Set) -import Streamly.Internal.Control.Concurrent (RunInIO) -import Streamly.Internal.Data.Atomics (atomicModifyIORefCAS_) -import Streamly.Internal.Data.Stream.Channel.Dispatcher (dumpSVarStats) -import Streamly.Internal.Data.Stream.Channel.Worker - (sendYield, sendStop, sendWithDoorBell) -import Streamly.Internal.Data.Stream.StreamK.Type (StreamK) - -import Streamly.Internal.Data.Stream.Channel.Types - --- 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). - --- XXX Since we have stream specific channels now, we can remove functions like --- enqueue, readOuputQ, postProcess, workLoop etc from this. - --- | A mutable channel to evaluate multiple streams concurrently and provide --- the combined results as output stream. -data Channel m a = Channel - { - svarMrun :: RunInIO m - -- FORWARD FLOW: Flow of data from the workers to the consumer - - -- 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. - -- XXX We can send a bundle of events of one type coaleseced together in an - -- unboxed structure. - , 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 - -- doorBellOnWorkQ is set by the consumer. - , outputDoorBell :: MVar () -- signal the consumer about output - -- XXX Can we use IO instead of m here? - , readOutputQ :: m [ChildEvent a] - , postProcess :: m Bool - - -- Scheduling -- - - -- Combined/aggregate parameters - -- This is capped 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 - - -- [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 - - , enqueue :: Bool -> (RunInIO m, StreamK m a) -> IO () - , eagerDispatch :: m () - , isWorkDone :: IO Bool - , isQueueDone :: IO Bool - , doorBellOnWorkQ :: IORef Bool -- ring outputDoorBell on enqueue so that a - -- sleeping consumer thread can wake up and send more workers. - , workLoop :: Maybe WorkerInfo -> m () - - -- Shared, thread tracking - -- [LOCKING] Updated unlocked, only by consumer thread. - , 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 - -- XXX Can we use IO instead of m here? - , accountThread :: ThreadId -> m () - , workerStopMVar :: MVar () -- Used only in ordered streams - - -- cleanup: to track garbage collection of SVar -- - , svarRef :: Maybe (IORef ()) - - -- Stats -- - , svarStats :: SVarStats - - -- Diagnostics -- - , svarInspectMode :: Bool - , svarCreator :: ThreadId - } - -{-# INLINE yield #-} -yield :: Channel m a -> Maybe WorkerInfo -> a -> IO Bool -yield sv winfo x = - sendYield - (maxBufferLimit sv) - (maxWorkerLimit sv) - (workerCount sv) - winfo - (yieldRateInfo sv) - (outputQueue sv) - (outputDoorBell sv) - (ChildYield x) - -{-# INLINE stop #-} -stop :: Channel m a -> Maybe WorkerInfo -> IO () -stop sv winfo = - sendStop - (workerCount sv) - winfo - (yieldRateInfo sv) - (outputQueue sv) - (outputDoorBell sv) - --- | Stop the channel. Kill all running worker threads. -{-# INLINABLE stopChannel #-} -stopChannel :: MonadIO m => Channel m a -> m () -stopChannel chan = liftIO $ do - atomicModifyIORefCAS_ (workerCount chan) $ \n -> n - 1 - void - $ sendWithDoorBell - (outputQueue chan) - (outputDoorBell chan) - ChildStopChannel - -{-# NOINLINE dumpSVar #-} -dumpSVar :: Channel m a -> IO String -dumpSVar sv = do - xs <- sequence $ intersperse (return "\n") - [ return (dumpCreator (svarCreator sv)) - , return "---------CURRENT STATE-----------" - , dumpOutputQ (outputQueue sv) - -- XXX print the types of events in the outputQueue, first 5 - , dumpDoorBell (outputDoorBell sv) - , dumpNeedDoorBell (doorBellOnWorkQ sv) - , dumpRunningThreads (workerThreads sv) - -- XXX print the status of first 5 threads - , dumpWorkerCount (workerCount sv) - , return "---------STATS-----------\n" - , dumpSVarStats (svarInspectMode sv) (yieldRateInfo sv) (svarStats sv) - ] - return $ concat xs diff --git a/src/Streamly/Internal/Data/Stream/Exception/Lifted.hs b/src/Streamly/Internal/Data/Stream/Exception/Lifted.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Stream/Exception/Lifted.hs +++ /dev/null @@ -1,331 +0,0 @@ --- | --- Module : Streamly.Internal.Data.Stream.Exception.Lifted --- Copyright : (c) 2019 Composewell Technologies --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC - -module Streamly.Internal.Data.Stream.Exception.Lifted - ( - after - , bracket - , bracket3 - , finally - , retry - - -- For IsStream module - , afterD - , bracket3D - , retryD - ) -where - -#include "inline.hs" - -import Control.Exception (Exception, SomeException, mask_) -import Control.Monad.Catch (MonadCatch) -#ifdef USE_UNLIFTIO -import Control.Monad.IO.Unlift (MonadUnliftIO) -#else -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Trans.Control (MonadBaseControl) -#endif -import Data.Map.Strict (Map) -import GHC.Exts (inline) -import Streamly.Internal.Control.Concurrent - (MonadRunInIO, MonadAsync, withRunInIO) -import Streamly.Internal.Data.Stream.StreamD.Type (Stream) -import Streamly.Internal.Data.IOFinalizer.Lifted - (newIOFinalizer, runIOFinalizer, clearingIOFinalizer) -import Streamly.Internal.Data.Stream.StreamD (Step(..)) - -import qualified Control.Monad.Catch as MC -import qualified Data.Map.Strict as Map -import qualified Streamly.Internal.Data.Stream.StreamD as D - --- $setup --- >>> :m --- >>> import qualified Streamly.Internal.Data.Stream.Exception.Lifted as Stream - --- XXX Implement in terms of the corresponding IO operation (gbracketIO). - -data GbracketIOState s1 s2 v wref - = GBracketIOInit - | GBracketIONormal s1 v wref - | GBracketIOException s2 - -{-# INLINE_NORMAL gbracket #-} -gbracket - :: MonadRunInIO m - => m c -- ^ before - -> (c -> m d1) -- ^ on normal stop - -> (c -> e -> D.Stream m b -> m (D.Stream m b)) -- ^ on exception - -> (c -> m d2) -- ^ on GC without normal stop or exception - -> (forall s. m s -> m (Either e s)) -- ^ try (exception handling) - -> (c -> D.Stream m b) -- ^ stream generator - -> D.Stream m b -gbracket bef aft onExc onGC ftry action = - D.Stream step GBracketIOInit - - where - - -- If the stream is never evaluated the "aft" action will never be - -- called. For that to occur we will need the user of this API to pass a - -- weak pointer to us. - {-# INLINE_LATE step #-} - step _ GBracketIOInit = do - -- We mask asynchronous exceptions to make the execution - -- of 'bef' and the registration of 'aft' atomic. - -- A similar thing is done in the resourcet package: https://git.io/JvKV3 - -- Tutorial: https://markkarpov.com/tutorial/exceptions.html - (r, ref) <- withRunInIO $ \run -> mask_ $ run $ do - r <- bef - ref <- newIOFinalizer (onGC r) - return (r, ref) - return $ Skip $ GBracketIONormal (action r) r ref - - step gst (GBracketIONormal (D.UnStream step1 st) v ref) = do - res <- ftry $ step1 gst st - case res of - Right r -> case r of - Yield x s -> - return $ Yield x (GBracketIONormal (D.Stream step1 s) v ref) - Skip s -> - return $ Skip (GBracketIONormal (D.Stream step1 s) v ref) - Stop -> - clearingIOFinalizer ref (aft v) >> return Stop - -- XXX Do not handle async exceptions, just rethrow them. - Left e -> do - -- Clearing of finalizer and running of exception handler must - -- be atomic wrt async exceptions. Otherwise if we have cleared - -- the finalizer and have not run the exception handler then we - -- may leak the resource. - stream <- - clearingIOFinalizer ref (onExc v e (D.UnStream step1 st)) - return $ Skip (GBracketIOException stream) - step gst (GBracketIOException (D.UnStream step1 st)) = do - res <- step1 gst st - case res of - Yield x s -> - return $ Yield x (GBracketIOException (D.Stream step1 s)) - Skip s -> return $ Skip (GBracketIOException (D.Stream step1 s)) - Stop -> return Stop - -{-# INLINE_NORMAL bracket3D #-} -bracket3D :: (MonadAsync m, MonadCatch m) => - m b - -> (b -> m c) - -> (b -> m d) - -> (b -> m e) - -> (b -> D.Stream m a) - -> D.Stream m a -bracket3D bef aft onExc onGC = - gbracket - bef - aft - (\a (e :: SomeException) _ -> onExc a >> return (D.nilM (MC.throwM e))) - onGC - (inline MC.try) - --- For a use case of this see the "streamly-process" package. It needs to kill --- the process in case of exception or garbage collection, but waits for the --- process to terminate in normal cases. - --- | Like 'bracket' but can use 3 separate cleanup actions depending on the --- mode of termination: --- --- 1. When the stream stops normally --- 2. When the stream is garbage collected --- 3. When the stream encounters an exception --- --- @bracket3 before onStop onGC onException action@ runs @action@ using the --- result of @before@. If the stream stops, @onStop@ action is executed, if the --- stream is abandoned @onGC@ is executed, if the stream encounters an --- exception @onException@ is executed. --- --- /Pre-release/ -{-# INLINE bracket3 #-} -bracket3 :: (MonadAsync m, MonadCatch m) - => m b - -> (b -> m c) - -> (b -> m d) - -> (b -> m e) - -> (b -> Stream m a) - -> Stream m a -bracket3 = bracket3D - --- | Run the alloc action @m b@ with async exceptions disabled but keeping --- blocking operations interruptible (see 'Control.Exception.mask'). Use the --- output @b@ as input to @b -> Stream m a@ to generate an output stream. --- --- @b@ is usually a resource under the state of monad @m@, e.g. a file --- handle, that requires a cleanup after use. The cleanup action @b -> m c@, --- runs whenever the stream ends normally, due to a sync or async exception or --- if it gets garbage collected after a partial lazy evaluation. --- --- 'bracket' only guarantees that the cleanup action runs, and it runs with --- async exceptions enabled. The action must ensure that it can successfully --- cleanup the resource in the face of sync or async exceptions. --- --- When the stream ends normally or on a sync exception, cleanup action runs --- immediately in the current thread context, whereas in other cases it runs in --- the GC context, therefore, cleanup may be delayed until the GC gets to run. --- --- /See also: 'bracket_'/ --- --- /Inhibits stream fusion/ --- -{-# INLINE bracket #-} -bracket :: (MonadAsync m, MonadCatch m) - => m b -> (b -> m c) -> (b -> Stream m a) -> Stream m a -bracket bef aft = bracket3 bef aft aft aft - --- | Run the action @m b@ whenever the stream @Stream m a@ stops normally, --- aborts due to an exception or if it is garbage collected after a partial --- lazy evaluation. --- --- The semantics of running the action @m b@ are similar to the cleanup action --- semantics described in 'bracket'. --- --- >>> finally action xs = Stream.bracket (return ()) (const action) (const xs) --- --- /See also 'finally_'/ --- --- /Inhibits stream fusion/ --- -{-# INLINE finally #-} -finally :: (MonadAsync m, MonadCatch m) => - m b -> Stream m a -> Stream m a -finally action xs = bracket (return ()) (const action) (const xs) - -{-# INLINE_NORMAL afterD #-} -afterD :: MonadRunInIO m - => m b -> D.Stream m a -> D.Stream m a -afterD action (D.Stream step state) = D.Stream step' Nothing - - where - - {-# INLINE_LATE step' #-} - step' _ Nothing = do - ref <- newIOFinalizer action - return $ Skip $ Just (state, ref) - step' gst (Just (st, ref)) = do - res <- step gst st - case res of - Yield x s -> return $ Yield x (Just (s, ref)) - Skip s -> return $ Skip (Just (s, ref)) - Stop -> do - runIOFinalizer ref - return Stop - --- | Run the action @m b@ whenever the stream @Stream m a@ stops normally, or --- if it is garbage collected after a partial lazy evaluation. --- --- The semantics of the action @m b@ are similar to the semantics of cleanup --- action in 'bracket'. --- --- /See also 'after_'/ --- -{-# INLINE after #-} -after :: -#ifdef USE_UNLIFTIO - MonadUnliftIO m -#else - (MonadIO m, MonadBaseControl IO m) -#endif - => m b -> Stream m a -> Stream m a -after = afterD - -data RetryState emap s1 s2 - = RetryWithMap emap s1 - | RetryDefault s2 - --- | See 'Streamly.Internal.Data.Stream.retry' --- -{-# INLINE_NORMAL retryD #-} -retryD - :: forall e m a. (Exception e, Ord e, MonadCatch m) - => Map e Int - -- ^ map from exception to retry count - -> (e -> D.Stream m a) - -- ^ default handler for those exceptions that are not in the map - -> D.Stream m a - -> D.Stream m a -retryD emap0 defaultHandler (D.Stream step0 state0) = D.Stream step state - - where - - state = RetryWithMap emap0 state0 - - {-# INLINE_LATE step #-} - step gst (RetryWithMap emap st) = do - eres <- MC.try $ step0 gst st - case eres of - Left e -> handler e emap st - Right res -> - return - $ case res of - Yield x st1 -> Yield x $ RetryWithMap emap st1 - Skip st1 -> Skip $ RetryWithMap emap st1 - Stop -> Stop - step gst (RetryDefault (D.UnStream step1 state1)) = do - res <- step1 gst state1 - return - $ case res of - Yield x st1 -> Yield x $ RetryDefault (D.Stream step1 st1) - Skip st1 -> Skip $ RetryDefault (D.Stream step1 st1) - Stop -> Stop - - {-# INLINE handler #-} - handler e emap st = - return - $ Skip - $ case Map.lookup e emap of - Just i - | i > 0 -> - let emap1 = Map.insert e (i - 1) emap - in RetryWithMap emap1 st - | otherwise -> RetryDefault $ defaultHandler e - Nothing -> RetryDefault $ defaultHandler e - --- | @retry@ takes 3 arguments --- --- 1. A map @m@ whose keys are exceptions and values are the number of times to --- retry the action given that the exception occurs. --- --- 2. A handler @han@ that decides how to handle an exception when the exception --- cannot be retried. --- --- 3. The stream itself that we want to run this mechanism on. --- --- When evaluating a stream if an exception occurs, --- --- 1. The stream evaluation aborts --- --- 2. The exception is looked up in @m@ --- --- a. If the exception exists and the mapped value is > 0 then, --- --- i. The value is decreased by 1. --- --- ii. The stream is resumed from where the exception was called, retrying --- the action. --- --- b. If the exception exists and the mapped value is == 0 then the stream --- evaluation stops. --- --- c. If the exception does not exist then we handle the exception using --- @han@. --- --- /Internal/ --- -{-# INLINE retry #-} -retry :: (MonadCatch m, Exception e, Ord e) - => Map e Int - -- ^ map from exception to retry count - -> (e -> Stream m a) - -- ^ default handler for those exceptions that are not in the map - -> Stream m a - -> Stream m a -retry = retryD diff --git a/src/Streamly/Internal/Data/Stream/Instances.hs b/src/Streamly/Internal/Data/Stream/Instances.hs --- a/src/Streamly/Internal/Data/Stream/Instances.hs +++ b/src/Streamly/Internal/Data/Stream/Instances.hs @@ -15,14 +15,11 @@ {-# INLINE (<$) #-}; \ (<$) = fmap . const }; \ \ -instance (MonadBase b m, Monad m CONSTRAINT) => MonadBase b (STREAM m) where {\ - liftBase = liftBaseDefault }; \ - \ instance (MonadIO m CONSTRAINT) => MonadIO (STREAM m) where { \ - liftIO = lift . liftIO }; \ + liftIO x = STREAM $ K.fromEffect $ liftIO x }; \ \ instance (MonadThrow m CONSTRAINT) => MonadThrow (STREAM m) where { \ - throwM = lift . throwM }; \ + throwM x = STREAM $ K.fromEffect $ throwM x }; \ \ {- \ instance (MonadError e m CONSTRAINT) => MonadError e (STREAM m) where { \ @@ -32,16 +29,16 @@ -} \ \ instance (MonadReader r m CONSTRAINT) => MonadReader r (STREAM m) where { \ - ask = lift ask; \ + ask = STREAM $ K.fromEffect ask; \ local f (STREAM m) = STREAM $ withLocal f m }; \ \ instance (MonadState s m CONSTRAINT) => MonadState s (STREAM m) where { \ {-# INLINE get #-}; \ - get = lift get; \ + get = STREAM $ K.fromEffect get; \ {-# INLINE put #-}; \ - put x = lift (put x); \ + put x = STREAM $ K.fromEffect $ put x; \ {-# INLINE state #-}; \ - state k = lift (state k) } + state k = STREAM $ K.fromEffect $ state k } ------------------------------------------------------------------------------ -- Lists diff --git a/src/Streamly/Internal/Data/Stream/IsStream.hs b/src/Streamly/Internal/Data/Stream/IsStream.hs --- a/src/Streamly/Internal/Data/Stream/IsStream.hs +++ b/src/Streamly/Internal/Data/Stream/IsStream.hs @@ -5,7 +5,7 @@ -- Copyright : (c) 2017 Composewell Technologies -- License : BSD-3-Clause -- Maintainer : streamly@composewell.com --- Stability : pre-release +-- Stability : experimental -- Portability : GHC -- -- This is an internal module which is a superset of the corresponding released @@ -22,6 +22,9 @@ , module Streamly.Internal.Data.Stream.IsStream.Exception , module Streamly.Internal.Data.Stream.IsStream.Lift , module Streamly.Internal.Data.Stream.IsStream.Top + , module Streamly.Internal.Data.Stream.IsStream.Combinators + , module Streamly.Internal.Data.Stream.IsStream.Common + , module Streamly.Internal.Data.Stream.IsStream.Enumeration , fromStream , toStream ) @@ -38,8 +41,11 @@ import Streamly.Internal.Data.Stream.IsStream.Type hiding (cmpBy, drain, eqBy, foldl', fold, toList, toStream , fromEffect, fromPure, repeat, fromStream) +import Streamly.Internal.Data.Stream.IsStream.Combinators +import Streamly.Internal.Data.Stream.IsStream.Common +import Streamly.Internal.Data.Stream.IsStream.Enumeration -import qualified Streamly.Internal.Data.Stream.StreamD as D +import qualified Streamly.Internal.Data.Stream as D {-# INLINE fromStream #-} fromStream :: (IsStream t, Monad m) => D.Stream m a -> t m a diff --git a/src/Streamly/Internal/Data/Stream/IsStream/Combinators.hs b/src/Streamly/Internal/Data/Stream/IsStream/Combinators.hs --- a/src/Streamly/Internal/Data/Stream/IsStream/Combinators.hs +++ b/src/Streamly/Internal/Data/Stream/IsStream/Combinators.hs @@ -31,7 +31,7 @@ import Streamly.Internal.Data.Stream.IsStream.Type (IsStream, mkStream, foldStreamShared) import Streamly.Internal.Data.Stream.Serial (SerialT) -import Streamly.Internal.Data.Stream.StreamK.Type (Stream) +import Streamly.Internal.Data.StreamK (Stream) import Streamly.Internal.Data.SVar diff --git a/src/Streamly/Internal/Data/Stream/IsStream/Common.hs b/src/Streamly/Internal/Data/Stream/IsStream/Common.hs --- a/src/Streamly/Internal/Data/Stream/IsStream/Common.hs +++ b/src/Streamly/Internal/Data/Stream/IsStream/Common.hs @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -Wno-deprecations #-} {-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- | -- Module : Streamly.Internal.Data.Stream.IsStream.Common @@ -71,23 +72,23 @@ import Control.Monad.IO.Class (MonadIO(..)) import Foreign.Storable (Storable) import Streamly.Internal.Control.Concurrent (MonadAsync) -import Streamly.Internal.Data.Array.Type (Array) -import Streamly.Internal.Data.Fold.Type (Fold (..)) +import Streamly.Internal.Data.Array (Array) +import Streamly.Internal.Data.Fold (Fold (..)) import Streamly.Internal.Data.Stream.IsStream.Combinators (maxYields) import Streamly.Internal.Data.Stream.IsStream.Type (IsStream(..), fromStreamD, toStreamD) import Streamly.Internal.Data.Stream.Serial (SerialT) import Streamly.Internal.Data.Time.Units (AbsTime, RelTime64, addToAbsTime64) import Streamly.Internal.System.IO (defaultChunkSize) -import Streamly.Internal.Data.Unboxed (Unbox) +import Streamly.Data.MutByteArray (Unbox) -import qualified Streamly.Internal.Data.Array.Type as A +import qualified Streamly.Internal.Data.Array as A import qualified Streamly.Internal.Data.Stream.Async as Async import qualified Streamly.Internal.Data.Stream.IsStream.Type as IsStream import qualified Streamly.Internal.Data.Stream.Parallel as Par -import qualified Streamly.Internal.Data.Stream.StreamK.Type as K +import qualified Streamly.Internal.Data.StreamK as K (fromPure, fromEffect, repeatMWith, reverse) -import qualified Streamly.Internal.Data.Stream.StreamD as D +import qualified Streamly.Internal.Data.Stream as D (repeatM, timesWith, foldAddLazy, map, scanlMAfter', postscanlMAfter' , postscanlM', take, takeWhile, takeEndBy, drop, findIndices , fromStreamK, toStreamK, concatMapM, concatMap, foldManyPost, splitOnSeq @@ -529,7 +530,7 @@ -- reverse' s = fromStreamD $ D.reverse' $ toStreamD s reverse' = fromStreamD - . A.flattenArraysRev -- unfoldMany A.readRev + . A.concatRev -- unfoldMany A.readerRev . D.fromStreamK . K.reverse . D.toStreamK @@ -661,7 +662,7 @@ -- ["h","e","l","l","o"] -- -- >>> splitOnSeq' "hello" "" --- [""] +-- [] -- -- >>> splitOnSeq' "hello" "hello" -- ["",""] diff --git a/src/Streamly/Internal/Data/Stream/IsStream/Eliminate.hs b/src/Streamly/Internal/Data/Stream/IsStream/Eliminate.hs --- a/src/Streamly/Internal/Data/Stream/IsStream/Eliminate.hs +++ b/src/Streamly/Internal/Data/Stream/IsStream/Eliminate.hs @@ -164,27 +164,27 @@ import Streamly.Internal.Data.Stream.IsStream.Type (IsStream, fromStreamD, toStreamD) import Streamly.Internal.Data.Stream.Serial (SerialT) -import Streamly.Internal.Data.Unboxed (Unbox) +import Streamly.Data.MutByteArray (Unbox) import qualified Streamly.Internal.Data.Array as A import qualified Streamly.Internal.Data.Stream.Serial as Stream import qualified Streamly.Internal.Data.Fold as FL -import qualified Streamly.Internal.Data.Parser.ParserD as PRD +import qualified Streamly.Internal.Data.Parser as PRD -- import qualified Streamly.Internal.Data.Parser.ParserK.Type as PRK import qualified Streamly.Internal.Data.Stream.IsStream.Type as IsStream -import qualified Streamly.Internal.Data.Stream.StreamD as D +import qualified Streamly.Internal.Data.Stream as D (foldr1, foldlT, foldlM', mapM_, null, head, headElse, last, elem , notElem, all, any, minimum, minimumBy, maximum, maximumBy, the, lookup , find, findM, toListRev, isPrefixOf, isSubsequenceOf, stripPrefix, (!!) , fromStreamK, foldrM, parseD) -import qualified Streamly.Internal.Data.Stream.StreamK.Type as K +import qualified Streamly.Internal.Data.StreamK as K (uncons, foldlS, tail, init) import qualified System.IO as IO import Prelude hiding - ( drop, take, takeWhile, foldr , foldl, mapM_, sequence, all, any, sum - , product, elem, notElem, maximum, minimum, head, last, tail, length - , null , reverse, init, and, or, lookup, foldr1, (!!) , splitAt, break + ( Foldable(..), drop, take, takeWhile, mapM_, sequence, all, any + , notElem, head, last, tail + , reverse, init, and, or, lookup, (!!), splitAt, break , mconcat) -- $setup diff --git a/src/Streamly/Internal/Data/Stream/IsStream/Enumeration.hs b/src/Streamly/Internal/Data/Stream/IsStream/Enumeration.hs --- a/src/Streamly/Internal/Data/Stream/IsStream/Enumeration.hs +++ b/src/Streamly/Internal/Data/Stream/IsStream/Enumeration.hs @@ -65,7 +65,7 @@ import Streamly.Internal.Data.Stream.IsStream.Type (IsStream(..), fromStreamD) import qualified Streamly.Internal.Data.Stream.IsStream.Type as IsStream -import qualified Streamly.Internal.Data.Stream.StreamD as D +import qualified Streamly.Internal.Data.Stream as D ( enumerateFromNum , enumerateFromThenNum , enumerateFromThenToIntegral diff --git a/src/Streamly/Internal/Data/Stream/IsStream/Exception.hs b/src/Streamly/Internal/Data/Stream/IsStream/Exception.hs --- a/src/Streamly/Internal/Data/Stream/IsStream/Exception.hs +++ b/src/Streamly/Internal/Data/Stream/IsStream/Exception.hs @@ -32,7 +32,7 @@ import Streamly.Internal.Data.Stream.IsStream.Type (IsStream(..), fromStreamD, toStreamD) -import qualified Streamly.Internal.Data.Stream.StreamD.Exception as D +import qualified Streamly.Internal.Data.Stream as D ( before , afterUnsafe , onException @@ -42,7 +42,7 @@ , handle ) -import qualified Streamly.Internal.Data.Stream.Exception.Lifted as D +import qualified Streamly.Internal.Data.Stream.Lifted as D ( afterD , bracket3D , retryD @@ -225,7 +225,7 @@ => (e -> t m a -> t m a) -> t m a -> t m a ghandle handler = fromStreamD - . D.ghandle (\e xs -> toStreamD $ handler e (fromStreamD xs)) + . D.ghandle (\e xs -> return $ toStreamD $ handler e (fromStreamD xs)) . toStreamD -- | When evaluating a stream if an exception occurs, stream evaluation aborts @@ -238,7 +238,7 @@ handle :: (IsStream t, MonadCatch m, Exception e) => (e -> t m a) -> t m a -> t m a handle handler xs = - fromStreamD $ D.handle (toStreamD . handler) $ toStreamD xs + fromStreamD $ D.handle (return . toStreamD . handler) $ toStreamD xs -- | @retry@ takes 3 arguments diff --git a/src/Streamly/Internal/Data/Stream/IsStream/Expand.hs b/src/Streamly/Internal/Data/Stream/IsStream/Expand.hs --- a/src/Streamly/Internal/Data/Stream/IsStream/Expand.hs +++ b/src/Streamly/Internal/Data/Stream/IsStream/Expand.hs @@ -1,3 +1,8 @@ +{-# LANGUAGE TypeFamilies #-} +-- Must come after TypeFamilies, otherwise it is re-enabled. +-- MonoLocalBinds enabled by TypeFamilies causes perf regressions in general. +{-# LANGUAGE NoMonoLocalBinds #-} + {-# OPTIONS_GHC -Wno-deprecations #-} -- | @@ -178,14 +183,13 @@ import qualified Streamly.Internal.Data.Stream.IsStream.Type as IsStream import qualified Streamly.Internal.Data.Stream.Parallel as Par import qualified Streamly.Internal.Data.Stream.Serial as Serial -import qualified Streamly.Internal.Data.Stream.StreamD as D +import qualified Streamly.Internal.Data.Stream as D (append, interleave, interleaveFstSuffix, interleaveFst, interleaveMin , roundRobin, mergeByM, unfoldMany, unfoldInterleave, intersperse , unfoldRoundRobin, interpose, interposeSuffix, gintercalate , gintercalateSuffix, intersperseMSuffix) -import qualified Streamly.Internal.Data.Stream.StreamK as K (mergeBy, mergeByM) -import qualified Streamly.Internal.Data.Stream.StreamK.Type as K - (interleave, append, mergeMapWith) +import qualified Streamly.Internal.Data.StreamK as K + (interleave, append, mergeMapWith, mergeBy, mergeByM) import qualified Streamly.Internal.Data.Stream.ZipAsync as ZipAsync import Prelude hiding (concat, concatMap, zipWith) @@ -193,6 +197,8 @@ -- $setup -- >>> :m -- >>> :set -fno-warn-deprecations +-- >>> :set -fno-warn-unrecognised-warning-flags +-- >>> :set -fno-warn-x-partial -- >>> import Control.Concurrent (threadDelay) -- >>> import Data.IORef -- >>> import Prelude hiding (zipWith, concatMap, concat) diff --git a/src/Streamly/Internal/Data/Stream/IsStream/Generate.hs b/src/Streamly/Internal/Data/Stream/IsStream/Generate.hs --- a/src/Streamly/Internal/Data/Stream/IsStream/Generate.hs +++ b/src/Streamly/Internal/Data/Stream/IsStream/Generate.hs @@ -92,7 +92,7 @@ import Control.Monad.IO.Class (MonadIO(..)) import Data.Void (Void) import Streamly.Internal.Control.Concurrent (MonadAsync) -import Streamly.Internal.Data.Unfold.Type (Unfold) +import Streamly.Internal.Data.Unfold (Unfold) import Streamly.Internal.Data.SVar (Rate (..)) import Streamly.Internal.Data.Stream.IsStream.Enumeration (Enumerable(..), enumerate, enumerateTo) @@ -103,18 +103,18 @@ (IsStream (..), fromSerial, consM, fromStreamD) import Streamly.Internal.Data.Stream.Serial (SerialT, WSerialT) import Streamly.Internal.Data.Time.Units (AbsTime , RelTime64, addToAbsTime64) -import Streamly.Internal.Data.Unboxed (Unbox) +import Streamly.Data.MutByteArray (Unbox) -import qualified Streamly.Internal.Data.IORef.Unboxed as Unboxed - (toStreamD, IORef) +import qualified Streamly.Internal.Data.MutArray as Unboxed + (pollIntIORef, IORef) import qualified Streamly.Internal.Data.Stream.IsStream.Type as IsStream import qualified Streamly.Internal.Data.Stream.Parallel as Par import qualified Streamly.Internal.Data.Stream.Serial as Serial -import qualified Streamly.Internal.Data.Stream.StreamD as D +import qualified Streamly.Internal.Data.Stream as D (unfold, unfoldr, toStreamK, unfoldr, repeat, replicate, replicateM , fromIndices, fromIndicesM, iterate, iterateM, toStreamK, fromListM , fromListM) -import qualified Streamly.Internal.Data.Stream.StreamK.Type as K +import qualified Streamly.Internal.Data.StreamK as K (unfoldr, unfoldrMWith, replicateMWith, fromIndicesMWith, iterateMWith , mfix, fromFoldable, fromFoldableM) import qualified Streamly.Internal.Data.Stream.Serial as Stream (fromStreamK) @@ -125,6 +125,8 @@ -- $setup -- >>> :m -- >>> :set -fno-warn-deprecations +-- >>> :set -fno-warn-unrecognised-warning-flags +-- >>> :set -fno-warn-x-partial -- >>> import Data.Function ((&)) -- >>> import Prelude hiding (iterate, replicate, repeat) -- >>> import qualified Streamly.Prelude as Stream @@ -637,4 +639,4 @@ -- {-# INLINE fromPrimIORef #-} fromPrimIORef :: (IsStream t, MonadIO m, Unbox a) => Unboxed.IORef a -> t m a -fromPrimIORef = fromStreamD . Unboxed.toStreamD +fromPrimIORef = fromStreamD . Unboxed.pollIntIORef diff --git a/src/Streamly/Internal/Data/Stream/IsStream/Lift.hs b/src/Streamly/Internal/Data/Stream/IsStream/Lift.hs --- a/src/Streamly/Internal/Data/Stream/IsStream/Lift.hs +++ b/src/Streamly/Internal/Data/Stream/IsStream/Lift.hs @@ -34,7 +34,7 @@ (IsStream(..), fromStreamD, toStreamD) import Streamly.Internal.Data.Stream.Serial (SerialT) -import qualified Streamly.Internal.Data.Stream.StreamD as D +import qualified Streamly.Internal.Data.Stream as D (morphInner, liftInner, runReaderT, evalStateT, runStateT) ------------------------------------------------------------------------------ diff --git a/src/Streamly/Internal/Data/Stream/IsStream/Reduce.hs b/src/Streamly/Internal/Data/Stream/IsStream/Reduce.hs --- a/src/Streamly/Internal/Data/Stream/IsStream/Reduce.hs +++ b/src/Streamly/Internal/Data/Stream/IsStream/Reduce.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wno-deprecations #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- | -- Module : Streamly.Internal.Data.Stream.IsStream.Reduce @@ -160,11 +161,11 @@ import Data.Proxy (Proxy(..)) import Foreign.Storable (Storable) import Streamly.Internal.Control.Concurrent (MonadAsync) -import Streamly.Internal.Data.Fold.Type (Fold (..)) +import Streamly.Internal.Data.Fold (Fold (..)) import Streamly.Internal.Data.IsMap (IsMap(..)) import Streamly.Internal.Data.Refold.Type (Refold (..)) import Streamly.Internal.Data.Parser (Parser (..), ParseError) -import Streamly.Internal.Data.Array.Type (Array) +import Streamly.Internal.Data.Array (Array) import Streamly.Internal.Data.Stream.IsStream.Common ( fold , interjectSuffix @@ -180,18 +181,18 @@ import Streamly.Internal.Data.Time.Units ( AbsTime, MilliSecond64(..), addToAbsTime, toRelTime , toAbsTime) -import Streamly.Internal.Data.Unboxed (Unbox) +import Streamly.Data.MutByteArray (Unbox) import qualified Data.Heap as H import qualified Streamly.Internal.Data.Unfold as Unfold -import qualified Streamly.Internal.Data.Array.Type as A +import qualified Streamly.Internal.Data.Array as A (chunksOf, read) import qualified Streamly.Internal.Data.Fold as FL (Fold, Step(..), takeEndBy_, takeEndBy, catMaybes, take) import qualified Streamly.Internal.Data.IsMap as IsMap -import qualified Streamly.Internal.Data.Parser.ParserD as PRD (Parser(..)) +import qualified Streamly.Internal.Data.Parser as PRD (Parser(..)) import qualified Streamly.Internal.Data.Stream.IsStream.Type as IsStream -import qualified Streamly.Internal.Data.Stream.StreamD as D +import qualified Streamly.Internal.Data.Stream as D ( foldMany , groupsOf , refoldMany @@ -1103,7 +1104,7 @@ :: (IsStream t, Monad m, Ord a, Unbox a) => Int -- window size -> Int -- window slide - -> Fold m (Ring a, Array a) b + -> Fold m (RingArray a, Array a) b -> t m a -> t m b slidingChunkBuffer = undefined @@ -1321,10 +1322,10 @@ -> t m (AbsTime, (Key f, a)) -- ^ timestamp, (session key, session data) -> t m (Key f, b) -- ^ session key, fold result classifySessionsByGeneric _ tick reset ejectPred tmout - (Fold step initial extract) input = + (Fold step initial extract final) input = Expand.unfoldMany (Unfold.lmap (toStreamK . sessionOutputStream) Unfold.fromStreamK) - $ scanlMAfter' sstep (return szero) (flush extract) + $ scanlMAfter' sstep (return szero) (flush final) $ interjectSuffix tick (return Nothing) $ map Just input @@ -1603,8 +1604,7 @@ -- -- /Pre-release/ {-# INLINE splitInnerBy #-} -splitInnerBy - :: (IsStream t, Monad m) +splitInnerBy :: forall t m (f :: Type -> Type) a. (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) @@ -1617,11 +1617,11 @@ -- -- /Pre-release/ {-# INLINE splitInnerBySuffix #-} -splitInnerBySuffix - :: (IsStream t, Monad m, Eq (f a), Monoid (f a)) +splitInnerBySuffix :: forall t m (f :: Type -> Type) a. + (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 = - fromStreamD $ D.splitInnerBySuffix splitter joiner $ toStreamD xs + fromStreamD $ D.splitInnerBySuffix (== mempty) splitter joiner $ toStreamD xs diff --git a/src/Streamly/Internal/Data/Stream/IsStream/Top.hs b/src/Streamly/Internal/Data/Stream/IsStream/Top.hs --- a/src/Streamly/Internal/Data/Stream/IsStream/Top.hs +++ b/src/Streamly/Internal/Data/Stream/IsStream/Top.hs @@ -72,8 +72,7 @@ -- import qualified Streamly.Internal.Data.Array.Generic as Array -- (fromStream, length, read) -- import qualified Streamly.Data.Array.Mut as MA -import qualified Streamly.Internal.Data.Fold as Fold (one, last) -import qualified Streamly.Internal.Data.Fold.Type as Fold +import qualified Streamly.Internal.Data.Fold as Fold import qualified Streamly.Internal.Data.Parser as Parser (groupByRollingEither) -- import qualified Streamly.Internal.Data.Stream.IsStream.Lift as Stream @@ -83,9 +82,9 @@ import qualified Streamly.Internal.Data.Stream.IsStream.Reduce as Stream import qualified Streamly.Internal.Data.Stream.IsStream.Transform as Stream import qualified Streamly.Internal.Data.Stream.IsStream.Type as IsStream -import qualified Streamly.Internal.Data.Stream.StreamD as StreamD +import qualified Streamly.Internal.Data.Stream as StreamD -import Prelude hiding (filter, zipWith, concatMap, concat) +import Prelude hiding (Foldable(..), filter, zipWith, concatMap, concat) -- $setup -- >>> :m @@ -650,7 +649,7 @@ (a -> a -> Ordering) -> t m a -> t m a -> t m a intersectBySorted eq s1 = IsStream.fromStreamD - . StreamD.intersectBySorted eq (IsStream.toStreamD s1) + . StreamD.sortedIntersectBy eq (IsStream.toStreamD s1) . IsStream.toStreamD -- Roughly joinLeft s1 s2 = s1 `difference` s2 + s1 `intersection` s2 diff --git a/src/Streamly/Internal/Data/Stream/IsStream/Transform.hs b/src/Streamly/Internal/Data/Stream/IsStream/Transform.hs --- a/src/Streamly/Internal/Data/Stream/IsStream/Transform.hs +++ b/src/Streamly/Internal/Data/Stream/IsStream/Transform.hs @@ -220,8 +220,8 @@ import Data.Either (isLeft, isRight, fromLeft, fromRight) import Data.Kind (Type) import Data.Maybe (isJust, fromJust) -import Streamly.Internal.Data.Fold.Type (Fold (..)) -import Streamly.Internal.Data.Pipe.Type (Pipe (..)) +import Streamly.Internal.Data.Fold (Fold (..)) +import Streamly.Internal.Data.Pipe (Pipe (..)) import Streamly.Internal.Data.Stream.IsStream.Combinators ( inspectMode, maxBuffer, maxThreads, rate, avgRate, minRate , maxRate, constRate) @@ -256,15 +256,15 @@ import qualified Streamly.Internal.Data.Stream.Concurrent as Concur import qualified Streamly.Internal.Data.Stream.Parallel as Par import qualified Streamly.Internal.Data.Stream.Serial as Serial -import qualified Streamly.Internal.Data.Stream.StreamD as D - (transform, foldrT, tap, tapOffsetEvery, mapM, scan +import qualified Streamly.Internal.Data.Stream as D + (pipe, foldrT, tap, tapOffsetEvery, mapM, scan , scanMany, postscan, scanlx', scanlM', scanl', postscanl', prescanl' , prescanlM', scanl1M', scanl1', filter, filterM, uniq, deleteBy, takeWhileM , dropWhile, dropWhileM, insertBy, intersperse , intersperseM_, intersperseMSuffix, intersperseMSuffix_ , intersperseMSuffixWith, indexed, indexedR, rollingMap, rollingMapM , rollingMap2, mapMaybe, mapMaybeM) -import qualified Streamly.Internal.Data.Stream.StreamK.Type as K +import qualified Streamly.Internal.Data.StreamK as K (foldrS, foldrSShared, mapMWith) import qualified Prelude @@ -298,7 +298,7 @@ -- {-# 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) +transform p xs = fromStreamD $ D.pipe p (toStreamD xs) ------------------------------------------------------------------------------ -- Transformation Folds @@ -583,7 +583,7 @@ -> t m a pollCounts predicate f xs = fromStreamD - $ Concur.tapCountD predicate (f . fromStreamD) + $ Concur.parTapCount predicate (f . fromStreamD) $ toStreamD xs -- | Apply a monadic function to each element flowing through the stream and diff --git a/src/Streamly/Internal/Data/Stream/IsStream/Type.hs b/src/Streamly/Internal/Data/Stream/IsStream/Type.hs --- a/src/Streamly/Internal/Data/Stream/IsStream/Type.hs +++ b/src/Streamly/Internal/Data/Stream/IsStream/Type.hs @@ -103,7 +103,7 @@ where import Streamly.Internal.Control.Concurrent (MonadAsync) -import Streamly.Internal.Data.Fold.Type (Fold (..)) +import Streamly.Internal.Data.Fold (Fold (..)) import Streamly.Internal.Data.Stream.Serial (SerialT, Serial, WSerialT(..), WSerial) import Streamly.Internal.Data.Stream.Async @@ -119,21 +119,22 @@ import qualified Streamly.Internal.Data.Stream.Async as Async import qualified Streamly.Internal.Data.Stream.Parallel as Parallel import qualified Streamly.Internal.Data.Stream.Serial as Serial -import qualified Streamly.Internal.Data.Stream.StreamD.Type as D +import qualified Streamly.Internal.Data.Stream as D (Stream(..), toStreamK, fromStreamK , drain, eqBy, cmpBy, fromList, toList, foldrMx, foldlMx' , foldlx', foldl', fold) -import qualified Streamly.Internal.Data.Stream.StreamK.Type as K +import qualified Streamly.Internal.Data.StreamK as K (StreamK(..), cons, fromEffect , nil, fromPure, bindWith, drain , fromFoldable, nilM, repeat) -import qualified Streamly.Internal.Data.Stream.StreamK as StreamK +import qualified Streamly.Internal.Data.StreamK as StreamK import qualified Streamly.Internal.Data.Stream.Serial as Stream (fromStreamK, toStreamK) import qualified Streamly.Internal.Data.Stream.Zip as Zip import qualified Streamly.Internal.Data.Stream.ZipAsync as ZipAsync -import Prelude hiding (foldr, repeat) +import Prelude hiding (Foldable(..), repeat) +import Data.Foldable (Foldable) #include "inline.hs" diff --git a/src/Streamly/Internal/Data/Stream/Lifted.hs b/src/Streamly/Internal/Data/Stream/Lifted.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/Lifted.hs @@ -0,0 +1,335 @@ +-- | +-- Module : Streamly.Internal.Data.Stream.Lifted +-- Copyright : (c) 2019 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +module Streamly.Internal.Data.Stream.Lifted + ( + after + , bracket + , bracket3 + , finally + , retry + + -- For IsStream module + , afterD + , bracket3D + , retryD + ) +where + +#include "inline.hs" + +import Control.Exception (Exception, SomeException, mask_) +import Control.Monad.Catch (MonadCatch) +#ifdef USE_UNLIFTIO +import Control.Monad.IO.Unlift (MonadUnliftIO) +#else +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Trans.Control (MonadBaseControl) +#endif +import Data.Map.Strict (Map) +import GHC.Exts (inline) +import Streamly.Internal.Control.Concurrent + (MonadRunInIO, MonadAsync, withRunInIO) +import Streamly.Internal.Data.Stream (Stream) +import Streamly.Internal.Data.IOFinalizer.Lifted + (newIOFinalizer, runIOFinalizer, clearingIOFinalizer) +import Streamly.Internal.Data.Stream (Step(..)) + +import qualified Control.Monad.Catch as MC +import qualified Data.Map.Strict as Map +import qualified Streamly.Internal.Data.Stream as D + +-- $setup +-- >>> :m +-- >>> import qualified Streamly.Internal.Data.Stream.Lifted as Stream + +-- XXX Implement in terms of the corresponding IO operation (gbracketIO). + +data GbracketIOState s1 s2 v wref + = GBracketIOInit + | GBracketIONormal s1 v wref + | GBracketIOException s2 + +{-# INLINE_NORMAL gbracket #-} +gbracket + :: MonadRunInIO m + => m c -- ^ before + -> (c -> m d1) -- ^ on normal stop + -> (c -> e -> D.Stream m b -> m (D.Stream m b)) -- ^ on exception + -> (c -> m d2) -- ^ on GC without normal stop or exception + -> (forall s. m s -> m (Either e s)) -- ^ try (exception handling) + -> (c -> D.Stream m b) -- ^ stream generator + -> D.Stream m b +gbracket bef aft onExc onGC ftry action = + D.Stream step GBracketIOInit + + where + + -- If the stream is never evaluated the "aft" action will never be + -- called. For that to occur we will need the user of this API to pass a + -- weak pointer to us. + {-# INLINE_LATE step #-} + step _ GBracketIOInit = do + -- We mask asynchronous exceptions to make the execution + -- of 'bef' and the registration of 'aft' atomic. + -- A similar thing is done in the resourcet package: https://git.io/JvKV3 + -- Tutorial: https://markkarpov.com/tutorial/exceptions.html + (r, ref) <- withRunInIO $ \run -> mask_ $ run $ do + r <- bef + ref <- newIOFinalizer (onGC r) + return (r, ref) + return $ Skip $ GBracketIONormal (action r) r ref + + step gst (GBracketIONormal (D.UnStream step1 st) v ref) = do + res <- ftry $ step1 gst st + case res of + Right r -> case r of + Yield x s -> + return $ Yield x (GBracketIONormal (D.Stream step1 s) v ref) + Skip s -> + return $ Skip (GBracketIONormal (D.Stream step1 s) v ref) + Stop -> + clearingIOFinalizer ref (aft v) >> return Stop + -- XXX Do not handle async exceptions, just rethrow them. + Left e -> do + -- Clearing of finalizer and running of exception handler must + -- be atomic wrt async exceptions. Otherwise if we have cleared + -- the finalizer and have not run the exception handler then we + -- may leak the resource. + stream <- + clearingIOFinalizer ref (onExc v e (D.UnStream step1 st)) + return $ Skip (GBracketIOException stream) + step gst (GBracketIOException (D.UnStream step1 st)) = do + res <- step1 gst st + case res of + Yield x s -> + return $ Yield x (GBracketIOException (D.Stream step1 s)) + Skip s -> return $ Skip (GBracketIOException (D.Stream step1 s)) + Stop -> return Stop + +{-# INLINE_NORMAL bracket3D #-} +bracket3D :: (MonadAsync m, MonadCatch m) => + m b + -> (b -> m c) + -> (b -> m d) + -> (b -> m e) + -> (b -> D.Stream m a) + -> D.Stream m a +bracket3D bef aft onExc onGC = + gbracket + bef + aft + (\a (e :: SomeException) _ -> onExc a >> MC.throwM e) + onGC + (inline MC.try) + +-- For a use case of this see the "streamly-process" package. It needs to kill +-- the process in case of exception or garbage collection, but waits for the +-- process to terminate in normal cases. + +-- | Like 'bracket' but can use 3 separate cleanup actions depending on the +-- mode of termination: +-- +-- 1. When the stream stops normally +-- 2. When the stream is garbage collected +-- 3. When the stream encounters an exception +-- +-- @bracket3 before onStop onGC onException action@ runs @action@ using the +-- result of @before@. If the stream stops, @onStop@ action is executed, if the +-- stream is abandoned @onGC@ is executed, if the stream encounters an +-- exception @onException@ is executed. +-- +-- The exception is not caught, it is rethrown. +-- +-- /Pre-release/ +{-# INLINE bracket3 #-} +bracket3 :: (MonadAsync m, MonadCatch m) + => m b + -> (b -> m c) + -> (b -> m d) + -> (b -> m e) + -> (b -> Stream m a) + -> Stream m a +bracket3 = bracket3D + +-- | Run the alloc action @IO b@ with async exceptions disabled but keeping +-- blocking operations interruptible (see 'Control.Exception.mask'). Use the +-- output @b@ of the IO action as input to the function @b -> Stream m a@ to +-- generate an output stream. +-- +-- @b@ is usually a resource under the IO monad, e.g. a file handle, that +-- requires a cleanup after use. The cleanup action @b -> m c@, runs whenever +-- (1) the stream ends normally, (2) due to a sync or async exception or, (3) +-- if it gets garbage collected after a partial lazy evaluation. The exception +-- is not caught, it is rethrown. +-- +-- 'bracket' only guarantees that the cleanup action runs, and it runs with +-- async exceptions enabled. The action must ensure that it can successfully +-- cleanup the resource in the face of sync or async exceptions. +-- +-- When the stream ends normally or on a sync exception, cleanup action runs +-- immediately in the current thread context, whereas in other cases it runs in +-- the GC context, therefore, cleanup may be delayed until the GC gets to run. +-- +-- /See also: 'bracket_'/ +-- +-- /Inhibits stream fusion/ +-- +{-# INLINE bracket #-} +bracket :: (MonadAsync m, MonadCatch m) + => m b -> (b -> m c) -> (b -> Stream m a) -> Stream m a +bracket bef aft = bracket3 bef aft aft aft + +-- | Run the action @m b@ whenever the stream @Stream m a@ stops normally, +-- aborts due to an exception or if it is garbage collected after a partial +-- lazy evaluation. +-- +-- The semantics of running the action @m b@ are similar to the cleanup action +-- semantics described in 'bracket'. +-- +-- >>> finally action xs = Stream.bracket (return ()) (const action) (const xs) +-- +-- /See also 'finally_'/ +-- +-- /Inhibits stream fusion/ +-- +{-# INLINE finally #-} +finally :: (MonadAsync m, MonadCatch m) => + m b -> Stream m a -> Stream m a +finally action xs = bracket (return ()) (const action) (const xs) + +{-# INLINE_NORMAL afterD #-} +afterD :: MonadRunInIO m + => m b -> D.Stream m a -> D.Stream m a +afterD action (D.Stream step state) = D.Stream step' Nothing + + where + + {-# INLINE_LATE step' #-} + step' _ Nothing = do + ref <- newIOFinalizer action + return $ Skip $ Just (state, ref) + step' gst (Just (st, ref)) = do + res <- step gst st + case res of + Yield x s -> return $ Yield x (Just (s, ref)) + Skip s -> return $ Skip (Just (s, ref)) + Stop -> do + runIOFinalizer ref + return Stop + +-- | Run the action @m b@ whenever the stream @Stream m a@ stops normally, or +-- if it is garbage collected after a partial lazy evaluation. +-- +-- The semantics of the action @m b@ are similar to the semantics of cleanup +-- action in 'bracket'. +-- +-- /See also 'after_'/ +-- +{-# INLINE after #-} +after :: +#ifdef USE_UNLIFTIO + MonadUnliftIO m +#else + (MonadIO m, MonadBaseControl IO m) +#endif + => m b -> Stream m a -> Stream m a +after = afterD + +data RetryState emap s1 s2 + = RetryWithMap emap s1 + | RetryDefault s2 + +-- | See 'Streamly.Internal.Data.Stream.retry' +-- +{-# INLINE_NORMAL retryD #-} +retryD + :: forall e m a. (Exception e, Ord e, MonadCatch m) + => Map e Int + -- ^ map from exception to retry count + -> (e -> D.Stream m a) + -- ^ default handler for those exceptions that are not in the map + -> D.Stream m a + -> D.Stream m a +retryD emap0 defaultHandler (D.Stream step0 state0) = D.Stream step state + + where + + state = RetryWithMap emap0 state0 + + {-# INLINE_LATE step #-} + step gst (RetryWithMap emap st) = do + eres <- MC.try $ step0 gst st + case eres of + Left e -> handler e emap st + Right res -> + return + $ case res of + Yield x st1 -> Yield x $ RetryWithMap emap st1 + Skip st1 -> Skip $ RetryWithMap emap st1 + Stop -> Stop + step gst (RetryDefault (D.UnStream step1 state1)) = do + res <- step1 gst state1 + return + $ case res of + Yield x st1 -> Yield x $ RetryDefault (D.Stream step1 st1) + Skip st1 -> Skip $ RetryDefault (D.Stream step1 st1) + Stop -> Stop + + {-# INLINE handler #-} + handler e emap st = + return + $ Skip + $ case Map.lookup e emap of + Just i + | i > 0 -> + let emap1 = Map.insert e (i - 1) emap + in RetryWithMap emap1 st + | otherwise -> RetryDefault $ defaultHandler e + Nothing -> RetryDefault $ defaultHandler e + +-- | @retry@ takes 3 arguments +-- +-- 1. A map @m@ whose keys are exceptions and values are the number of times to +-- retry the action given that the exception occurs. +-- +-- 2. A handler @han@ that decides how to handle an exception when the exception +-- cannot be retried. +-- +-- 3. The stream itself that we want to run this mechanism on. +-- +-- When evaluating a stream if an exception occurs, +-- +-- 1. The stream evaluation aborts +-- +-- 2. The exception is looked up in @m@ +-- +-- a. If the exception exists and the mapped value is > 0 then, +-- +-- i. The value is decreased by 1. +-- +-- ii. The stream is resumed from where the exception was called, retrying +-- the action. +-- +-- b. If the exception exists and the mapped value is == 0 then the stream +-- evaluation stops. +-- +-- c. If the exception does not exist then we handle the exception using +-- @han@. +-- +-- /Internal/ +-- +{-# INLINE retry #-} +retry :: (MonadCatch m, Exception e, Ord e) + => Map e Int + -- ^ map from exception to retry count + -> (e -> Stream m a) + -- ^ default handler for those exceptions that are not in the map + -> Stream m a + -> Stream m a +retry = retryD diff --git a/src/Streamly/Internal/Data/Stream/MkType.hs b/src/Streamly/Internal/Data/Stream/MkType.hs --- a/src/Streamly/Internal/Data/Stream/MkType.hs +++ b/src/Streamly/Internal/Data/Stream/MkType.hs @@ -334,10 +334,14 @@ [ clause [] (normalB - (infixE - (Just (varE _lift)) - (varE _dotOp) - (Just (varE _throwM)))) + (infixE + (Just (conE _Type)) + (varE _dotOp) + (Just + (infixE + (Just (varE (mkName "Stream.fromEffect"))) + (varE _dotOp) + (Just (varE _throwM)))))) [] ] ] @@ -504,7 +508,7 @@ -- >>> expr <- runQ (mkZipType "ZipStream" "zipApply" False) -- >>> putStrLn $ pprint expr -- newtype ZipStream m a --- = ZipStream (Stream.Stream m a) +-- = ZipStream (Stream.Stream m a) -- deriving Foldable -- mkZipStream :: Stream.Stream m a -> ZipStream m a -- mkZipStream = ZipStream @@ -516,19 +520,17 @@ -- deriving instance GHC.Classes.Eq a => Eq (ZipStream Identity a) -- deriving instance GHC.Classes.Ord a => Ord (ZipStream Identity a) -- instance Show a => Show (ZipStream Identity a) --- where {-# INLINE show #-} --- show (ZipStream strm) = show strm +-- where {{-# INLINE show #-}; show (ZipStream strm) = show strm} -- instance Read a => Read (ZipStream Identity a) --- where {-# INLINE readPrec #-} --- readPrec = fmap ZipStream readPrec +-- where {{-# INLINE readPrec #-}; readPrec = fmap ZipStream readPrec} -- instance Monad m => Functor (ZipStream m) --- where {-# INLINE fmap #-} --- fmap f (ZipStream strm) = ZipStream (fmap f strm) +-- where {{-# INLINE fmap #-}; +-- fmap f (ZipStream strm) = ZipStream (fmap f strm)} -- instance Monad m => Applicative (ZipStream m) --- where {-# INLINE pure #-} --- pure = ZipStream . Stream.repeat --- {-# INLINE (<*>) #-} --- (<*>) (ZipStream strm1) (ZipStream strm2) = ZipStream (zipApply strm1 strm2) +-- where {{-# INLINE pure #-}; +-- pure = ZipStream . Stream.repeat; +-- {-# INLINE (<*>) #-}; +-- (<*>) (ZipStream strm1) (ZipStream strm2) = ZipStream (zipApply strm1 strm2)} mkZipType :: String -- ^ Name of the type -> String -- ^ Function to use for (\<*\>) @@ -577,27 +579,25 @@ -- unParallel :: Parallel m a -> Stream.Stream m a -- unParallel (Parallel strm) = strm -- instance Monad m => Functor (Parallel m) --- where {-# INLINE fmap #-} --- fmap f (Parallel strm) = Parallel (fmap f strm) +-- where {{-# INLINE fmap #-}; +-- fmap f (Parallel strm) = Parallel (fmap f strm)} -- instance Stream.MonadAsync m => Monad (Parallel m) --- where {-# INLINE (>>=) #-} --- (>>=) (Parallel strm1) f = let f1 a = unParallel (f a) --- in Parallel (parBind strm1 f1) +-- where {{-# INLINE (>>=) #-}; +-- (>>=) (Parallel strm1) f = let f1 a = unParallel (f a) +-- in Parallel (parBind strm1 f1)} -- instance Stream.MonadAsync m => Applicative (Parallel m) --- where {-# INLINE pure #-} --- pure = Parallel . Stream.fromPure --- {-# INLINE (<*>) #-} --- (<*>) = ap +-- where {{-# INLINE pure #-}; +-- pure = Parallel . Stream.fromPure; +-- {-# INLINE (<*>) #-}; +-- (<*>) = ap} -- instance (Monad (Parallel m), MonadIO m) => MonadIO (Parallel m) --- where {-# INLINE liftIO #-} --- liftIO = Parallel . (Stream.fromEffect . liftIO) --- instance MonadTrans Parallel --- where {-# INLINE lift #-} --- lift = Parallel . Stream.fromEffect +-- where {{-# INLINE liftIO #-}; +-- liftIO = Parallel . (Stream.fromEffect . liftIO)} -- instance (Monad (Parallel m), -- MonadThrow m) => MonadThrow (Parallel m) --- where {-# INLINE throwM #-} --- throwM = lift . throwM +-- where {{-# INLINE throwM #-}; +-- throwM = Parallel . (Stream.fromEffect . throwM)} + mkCrossType :: String -- ^ Name of the type -> String -- ^ Function to use for (>>=) @@ -617,7 +617,7 @@ , readInstance _Type ] else [] - , sequence + , sequence $ [ functorInstance _Type , mkStreamMonad dtNameStr classConstraints bindOpStr , mkStreamApplicative @@ -627,10 +627,9 @@ "Stream.fromPure" "ap" , monadioInstance _Type - , monadtransInstance _Type , monadthrowInstance _Type -- , monadreaderInstance _Type - ] + ] ++ [monadtransInstance _Type | not isConcurrent] ] where diff --git a/src/Streamly/Internal/Data/Stream/Parallel.hs b/src/Streamly/Internal/Data/Stream/Parallel.hs --- a/src/Streamly/Internal/Data/Stream/Parallel.hs +++ b/src/Streamly/Internal/Data/Stream/Parallel.hs @@ -1,5 +1,6 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- | -- Module : Streamly.Internal.Data.Stream.Parallel @@ -48,26 +49,33 @@ import Control.Concurrent (myThreadId, takeMVar) import Control.Monad (when) +#if !(MIN_VERSION_transformers(0,6,0)) import Control.Monad.Base (MonadBase(..), liftBaseDefault) +#endif import Control.Monad.Catch (MonadThrow, throwM) -- import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Reader.Class (MonadReader(..)) import Control.Monad.State.Class (MonadState(..)) +#if !(MIN_VERSION_transformers(0,6,0)) import Control.Monad.Trans.Class (MonadTrans(lift)) +#endif import Data.Functor (void) +#if __GLASGOW_HASKELL__ >= 810 +import Data.Kind (Type) +#endif import Data.IORef (readIORef, writeIORef) import Data.Maybe (fromJust) import Streamly.Data.Fold (Fold) import Streamly.Internal.Control.Concurrent (MonadAsync) -import Streamly.Internal.Data.Stream.StreamD.Type (Step(..)) +import Streamly.Internal.Data.Stream (Step(..)) import qualified Data.Set as Set -import qualified Streamly.Internal.Data.Stream.StreamK.Type as K +import qualified Streamly.Internal.Data.StreamK as K (StreamK, foldStreamShared, mkStream, foldStream, fromEffect , nil, concatMapWith, fromPure, bindWith) -import qualified Streamly.Internal.Data.Stream.StreamD.Type as D +import qualified Streamly.Internal.Data.Stream as D (Stream(..), mapM, toStreamK, fromStreamK) import qualified Streamly.Internal.Data.Stream.SVar.Generate as SVar import qualified Streamly.Internal.Data.Stream.SVar.Eliminate as SVar @@ -357,6 +365,9 @@ K.foldStreamShared st yld sng stp $ Stream.toStreamK (SVar.teeToSVar sv $ Stream.fromStreamK m) +#if __GLASGOW_HASKELL__ >= 810 +type TapState :: Type -> Type -> Type -> Type +#endif data TapState fs st a = TapInit | Tapping !fs st | TapDone st -- | Like 'tapAsync' but uses a 'Fold' instead of a fold function. @@ -431,9 +442,11 @@ -- @since 0.8.0 newtype ParallelT m a = ParallelT {getParallelT :: K.StreamK m a} +#if !(MIN_VERSION_transformers(0,6,0)) instance MonadTrans ParallelT where {-# INLINE lift #-} lift = ParallelT . K.fromEffect +#endif -- | A parallely composing IO stream of elements of type @a@. -- See 'ParallelT' documentation for more details. @@ -502,6 +515,11 @@ ------------------------------------------------------------------------------ -- Other instances ------------------------------------------------------------------------------ + +#if !(MIN_VERSION_transformers(0,6,0)) +instance (MonadBase b m, Monad m, MonadAsync m) => MonadBase b (ParallelT m) where + liftBase = liftBaseDefault +#endif MONAD_COMMON_INSTANCES(ParallelT, MONADPARALLEL) diff --git a/src/Streamly/Internal/Data/Stream/Prelude.hs b/src/Streamly/Internal/Data/Stream/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/Prelude.hs @@ -0,0 +1,25 @@ +-- | +-- Module : Streamly.Internal.Data.Stream.Prelude +-- Copyright : (c) 2022 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +module Streamly.Internal.Data.Stream.Prelude + ( + -- * Concurrency Channels + module Streamly.Internal.Data.Stream.Channel + -- * Concurrent Streams + , module Streamly.Internal.Data.Stream.Concurrent + -- * Time + , module Streamly.Internal.Data.Stream.Time + -- * Lifted + , module Streamly.Internal.Data.Stream.Lifted + ) +where + +import Streamly.Internal.Data.Stream.Channel +import Streamly.Internal.Data.Stream.Concurrent +import Streamly.Internal.Data.Stream.Time +import Streamly.Internal.Data.Stream.Lifted diff --git a/src/Streamly/Internal/Data/Stream/SVar.hs b/src/Streamly/Internal/Data/Stream/SVar.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/SVar.hs @@ -0,0 +1,20 @@ +{-# OPTIONS_GHC -Wno-deprecations #-} + +-- | +-- Module : Streamly.Internal.Data.Stream.SVar +-- Copyright : (c) 2022 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +module Streamly.Internal.Data.Stream.SVar + {-# DEPRECATED "This module will be removed in future." #-} + ( + module Streamly.Internal.Data.Stream.SVar.Eliminate + , module Streamly.Internal.Data.Stream.SVar.Generate + ) +where + +import Streamly.Internal.Data.Stream.SVar.Eliminate +import Streamly.Internal.Data.Stream.SVar.Generate diff --git a/src/Streamly/Internal/Data/Stream/SVar/Eliminate.hs b/src/Streamly/Internal/Data/Stream/SVar/Eliminate.hs --- a/src/Streamly/Internal/Data/Stream/SVar/Eliminate.hs +++ b/src/Streamly/Internal/Data/Stream/SVar/Eliminate.hs @@ -10,6 +10,7 @@ -- Eliminate a stream by distributing it to multiple SVars concurrently. -- module Streamly.Internal.Data.Stream.SVar.Eliminate + {-# DEPRECATED "The functionality is moved to Channel.*" #-} ( -- * Concurrent Function Application toSVarParallel @@ -36,13 +37,13 @@ import Streamly.Internal.Control.ForkLifted (doFork) import Streamly.Internal.Data.Atomics (atomicModifyIORefCAS_) import Streamly.Internal.Data.Fold.SVar (write, writeLimited) -import Streamly.Internal.Data.Fold.Type (Fold(..)) +import Streamly.Internal.Data.Fold (Fold(..)) import Streamly.Internal.Data.Stream.Serial (SerialT) import Streamly.Internal.Data.Time.Clock (Clock(Monotonic), getTime) -import qualified Streamly.Internal.Data.Stream.StreamD.Type as D +import qualified Streamly.Internal.Data.Stream as D (Stream(..), Step(..), fold) -import qualified Streamly.Internal.Data.Stream.StreamK.Type as K +import qualified Streamly.Internal.Data.StreamK as K (Stream, mkStream, foldStream, foldStreamShared, nilM) import qualified Streamly.Internal.Data.Stream.Serial as Stream (fromStreamK, toStreamK) diff --git a/src/Streamly/Internal/Data/Stream/SVar/Generate.hs b/src/Streamly/Internal/Data/Stream/SVar/Generate.hs --- a/src/Streamly/Internal/Data/Stream/SVar/Generate.hs +++ b/src/Streamly/Internal/Data/Stream/SVar/Generate.hs @@ -18,6 +18,7 @@ -- -- module Streamly.Internal.Data.Stream.SVar.Generate + {-# DEPRECATED "SVar is replaced by Channel." #-} ( -- * Write to SVar toSVar @@ -43,9 +44,9 @@ import Streamly.Internal.Data.Time.Clock (Clock(Monotonic), getTime) import System.Mem (performMajorGC) -import qualified Streamly.Internal.Data.Stream.StreamD.Type as D +import qualified Streamly.Internal.Data.Stream as D (Stream(..), Step(..)) -import qualified Streamly.Internal.Data.Stream.StreamK.Type as K +import qualified Streamly.Internal.Data.StreamK as K (Stream, foldStreamShared, mkStream, foldStream) import qualified Streamly.Internal.Data.Stream.Serial as Stream (fromStreamK) @@ -112,7 +113,7 @@ -- | Pull a stream from an SVar. {-# NOINLINE fromStreamVar #-} -fromStreamVar :: MonadAsync m => SVar K.Stream m a -> K.Stream m a +fromStreamVar :: forall m a. MonadAsync m => SVar K.Stream m a -> K.Stream m a fromStreamVar sv = K.mkStream $ \st yld sng stp -> do list <- readOutputQ sv -- Reversing the output is important to guarantee that we process the @@ -122,6 +123,7 @@ where + allDone :: forall r. m r -> m r allDone stp = do when (svarInspectMode sv) $ do t <- liftIO $ getTime Monotonic @@ -162,6 +164,7 @@ return $ tid == sid #ifdef INSPECTION +#if __GLASGOW_HASKELL__ != 906 -- Use of GHC constraint tuple (GHC.Classes.(%,,%)) in fromStreamVar leads to -- space leak because the tuple gets allocated in every recursive call and each -- allocation holds on to the previous allocation. This test is to make sure @@ -177,6 +180,7 @@ , ''Typeable , ''Functor ] +#endif #endif -- | Generate a stream from an SVar. An unevaluated stream can be pushed to an diff --git a/src/Streamly/Internal/Data/Stream/Serial.hs b/src/Streamly/Internal/Data/Stream/Serial.hs --- a/src/Streamly/Internal/Data/Stream/Serial.hs +++ b/src/Streamly/Internal/Data/Stream/Serial.hs @@ -1,5 +1,12 @@ +{-# LANGUAGE TypeFamilies #-} +-- Must come after TypeFamilies, otherwise it is re-enabled. +-- MonoLocalBinds enabled by TypeFamilies causes perf regressions in general. +{-# LANGUAGE NoMonoLocalBinds #-} {-# LANGUAGE UndecidableInstances #-} + {-# OPTIONS_GHC -Wno-deprecations #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} -- | -- Module : Streamly.Internal.Data.Stream.Serial @@ -47,9 +54,13 @@ ) where +#if !(MIN_VERSION_base(4,18,0)) import Control.Applicative (liftA2) +#endif import Control.DeepSeq (NFData(..), NFData1(..)) +#if !(MIN_VERSION_transformers(0,6,0)) import Control.Monad.Base (MonadBase(..), liftBaseDefault) +#endif import Control.Monad.Catch (MonadThrow, throwM) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Reader.Class (MonadReader(..)) @@ -65,13 +76,11 @@ , readListPrecDefault) import Streamly.Internal.BaseCompat ((#.)) import Streamly.Internal.Data.Maybe.Strict (Maybe'(..), toMaybe) -import Streamly.Internal.Data.Stream.StreamK.Type (Stream) +import Streamly.Internal.Data.StreamK (Stream) import qualified Streamly.Internal.Data.Stream.Common as P -import qualified Streamly.Internal.Data.Stream.StreamD.Generate as D -import qualified Streamly.Internal.Data.Stream.StreamD.Transform as D -import qualified Streamly.Internal.Data.Stream.StreamD.Type as D -import qualified Streamly.Internal.Data.Stream.StreamK.Type as K +import qualified Streamly.Internal.Data.Stream as D +import qualified Streamly.Internal.Data.StreamK as K import Prelude hiding (map, mapM, repeat, filter) @@ -406,6 +415,11 @@ ------------------------------------------------------------------------------ -- Other instances ------------------------------------------------------------------------------ + +#if !(MIN_VERSION_transformers(0,6,0)) +instance (MonadBase b m, Monad m) => MonadBase b (SerialT m) where + liftBase = liftBaseDefault +#endif MONAD_COMMON_INSTANCES(WSerialT,) LIST_INSTANCES(WSerialT) diff --git a/src/Streamly/Internal/Data/Stream/Time.hs b/src/Streamly/Internal/Data/Stream/Time.hs --- a/src/Streamly/Internal/Data/Stream/Time.hs +++ b/src/Streamly/Internal/Data/Stream/Time.hs @@ -25,7 +25,10 @@ -- * Chunking , intervalsOf - , chunksOfTimeout + , boundedIntervalsOf + , timedGroupsOf + , timedChunksOf + , timedChunksOf' -- * Sampling , sampleIntervalEnd @@ -48,6 +51,9 @@ , bufferLatest , bufferLatestN , bufferOldestN + + -- * Deprecated + , groupsOfTimeout ) where @@ -60,9 +66,13 @@ import Data.Maybe (isNothing) import Data.Proxy (Proxy(..)) import Streamly.Data.Fold (Fold) -import Streamly.Internal.Data.Fold.Type (Fold (..)) +import Streamly.Data.Array (Unbox) +import Streamly.Internal.Data.Array (Array) +import Streamly.Internal.Data.Fold (Fold (..)) import Streamly.Internal.Data.IsMap (IsMap(..)) -import Streamly.Internal.Data.Stream.StreamD.Type (Stream) +import Streamly.Internal.Data.Channel.Types (Rate) +import Streamly.Internal.Data.Stream (Stream) +import Streamly.Internal.Data.Stream.Channel.Type (rate) import Streamly.Internal.Data.Time.Units ( AbsTime , MilliSecond64(..) @@ -73,12 +83,14 @@ import Streamly.Internal.Data.Time.Units (NanoSecond64(..), toRelTime64) import qualified Data.Heap as H +import qualified Streamly.Internal.Data.Array as Array import qualified Streamly.Data.Fold as Fold +import qualified Streamly.Data.Scanl as Scanl import qualified Streamly.Data.Stream as Stream import qualified Streamly.Data.Unfold as Unfold import qualified Streamly.Internal.Data.Fold as Fold (Step(..)) import qualified Streamly.Internal.Data.IsMap as IsMap -import qualified Streamly.Internal.Data.Stream.StreamD as Stream +import qualified Streamly.Internal.Data.Stream as Stream ( scanlMAfter' , timeIndexed , timestamped @@ -140,11 +152,11 @@ -- speed. -- -- >>> tickStream = Stream.repeatM (return ()) --- >>> ticksRate r = Stream.parEval (Stream.rate (Just r)) tickStream +-- >>> ticksRate r = Stream.parBuffered (Stream.rate (Just r)) tickStream -- {-# INLINE ticksRate #-} ticksRate :: MonadAsync m => Rate -> Stream m () -ticksRate r = parEval (rate (Just r)) $ Stream.repeatM (return ()) +ticksRate r = parBuffered (rate (Just r)) $ Stream.repeatM (return ()) -- XXX The case when the interval is 0, we should run only the stream being -- interjected. @@ -218,7 +230,14 @@ -- | Group the input stream into windows of @n@ second each and then fold each -- group using the provided fold function. -- --- >>> twoPerSec = Stream.parEval (Stream.constRate 2) $ Stream.enumerateFrom 1 +-- If the fold terminates before the interval is over, the next collection is +-- started, thus multiple collection can happen in the same interval. If the +-- fold does not terminate before the interval is over, the fold will be forced +-- to terminate at the interval end. +-- +-- Example: +-- +-- >>> twoPerSec = Stream.parBuffered (Stream.constRate 2) $ Stream.enumerateFrom 1 -- >>> intervals = Stream.intervalsOf 1 Fold.toList twoPerSec -- >>> Stream.fold Fold.toList $ Stream.take 2 intervals -- [...,...] @@ -230,28 +249,73 @@ (Fold.takeEndBy isNothing (Fold.catMaybes f)) (interject (return Nothing) n (fmap Just xs)) +-- | Like 'intervalsOf' but with an additional argument to limit the number of +-- collected items to a max limit. If the limit is reached, the fold output is +-- emitted and the next interval is started. +-- +-- An alternative behavior would be to emit multiple elements in the same +-- interval if the size is exceeded, keeping the intervals fixed. That can be +-- achieved by using 'intervalsOf' and using a fold that terminates on the +-- limit. +-- +-- /Unimplemented/ +{-# INLINE boundedIntervalsOf #-} +boundedIntervalsOf :: -- MonadAsync m => + Int -> Double -> Int -> Fold m a b -> Stream m a -> Stream m b +boundedIntervalsOf _len _time _f _xs = undefined + -- XXX This can be implemented more efficiently by sharing a Clock.Timer across -- parallel threads and resetting it whenever a span is emitted. --- | Like 'chunksOf' but if the chunk is not completed within the specified --- time interval then emit whatever we have collected till now. The chunk --- timeout is reset whenever a chunk is emitted. The granularity of the clock +-- | Like 'groupsOf' but if the group is not completed within the specified +-- time interval then emit whatever we have collected till now. The group +-- timeout is reset whenever a group is emitted. The granularity of the clock -- is 100 ms. -- +-- Note that it will not emit any output unless at least one item has been +-- collected in the group. The time interval is only for timing out the already +-- collected but not yet complete group. +-- -- >>> s = Stream.delayPost 0.3 $ Stream.fromList [1..1000] --- >>> f = Stream.fold (Fold.drainMapM print) $ Stream.chunksOfTimeout 5 1 Fold.toList s +-- >>> f = Stream.fold (Fold.drainMapM print) $ Stream.timedGroupsOf 1 5 Fold.toList s -- -- /Pre-release/ -{-# INLINE chunksOfTimeout #-} -chunksOfTimeout :: MonadAsync m - => Int -> Double -> Fold m a b -> Stream m a -> Stream m b -chunksOfTimeout n timeout f = +{-# INLINE timedGroupsOf #-} +timedGroupsOf :: MonadAsync m + => Double -> Int -> Fold m a b -> Stream m a -> Stream m b +timedGroupsOf timeout n f = fmap snd . classifySessionsBy 0.1 False (const (return False)) timeout (Fold.take n f) . Stream.timestamped . fmap ((),) +{-# Deprecated groupsOfTimeout "Please use timedGroupsOf instead." #-} +{-# INLINE groupsOfTimeout #-} +groupsOfTimeout :: MonadAsync m + => Int -> Double -> Fold m a b -> Stream m a -> Stream m b +groupsOfTimeout n timeout = timedGroupsOf timeout n + +-- Ideally this should be in an array module, but we do not have one in +-- streamly package. + +-- | Like 'chunksOf' from the Array module but emits the chunk after the +-- timeout even if we have not yet collected the requested size. +{-# INLINE timedChunksOf #-} +timedChunksOf :: (MonadAsync m, Unbox a) => + Double -> Int -> Stream m a -> Stream m (Array a) +timedChunksOf timeout n = timedGroupsOf timeout n (Array.unsafeCreateOf n) + +-- | Like 'timedChunksOf' but creates pinned arrays. If the chunks are smaller +-- than LARGE_OBJECT_THRESHOLD then this routine may be useful for better +-- performance if the arrays are to be sent for IO. This will avoid a copy for +-- pinning by the IO routines. +{-# INLINE timedChunksOf' #-} +timedChunksOf' :: (MonadAsync m, Unbox a) => + Double -> Int -> Stream m a -> Stream m (Array a) +timedChunksOf' timeout n = + timedGroupsOf timeout n (Array.unsafeCreateOf' n) + ------------------------------------------------------------------------------ -- Windowed classification ------------------------------------------------------------------------------ @@ -317,7 +381,7 @@ :: (IsStream t, Monad m, Ord a, Unboxed a) => Int -- window size -> Int -- window slide - -> Fold m (Ring a, Array a) b + -> Fold m (RingArray a, Array a) b -> t m a -> t m b slidingChunkBuffer = undefined @@ -536,9 +600,9 @@ -- data) -> Stream m (Key f, b) -- ^ session key, fold result classifySessionsByGeneric _ tick reset ejectPred tmout - (Fold step initial extract) input = - Stream.unfoldMany (Unfold.lmap sessionOutputStream Unfold.fromStream) - $ Stream.scanlMAfter' sstep (return szero) (flush extract) + (Fold step initial extract final) input = + Stream.unfoldEach (Unfold.lmap sessionOutputStream Unfold.fromStream) + $ Stream.scanlMAfter' sstep (return szero) (flush final) $ interject (return Nothing) tick $ fmap Just input @@ -833,7 +897,7 @@ -- but the tick stream should work well as long as the timer -- granularity is small enough compared to the gap. Stream.mapMaybe extract - $ Stream.scan (Fold.foldl' step BurstNone) + $ Stream.scanl (Scanl.mkScanl step BurstNone) $ Stream.timeIndexed $ interject (return Nothing) 0.01 (fmap Just xs) diff --git a/src/Streamly/Internal/Data/Stream/Zip.hs b/src/Streamly/Internal/Data/Stream/Zip.hs --- a/src/Streamly/Internal/Data/Stream/Zip.hs +++ b/src/Streamly/Internal/Data/Stream/Zip.hs @@ -1,5 +1,11 @@ +{-# LANGUAGE TypeFamilies #-} +-- Must come after TypeFamilies, otherwise it is re-enabled. +-- MonoLocalBinds enabled by TypeFamilies causes perf regressions in general. +{-# LANGUAGE NoMonoLocalBinds #-} {-# LANGUAGE UndecidableInstances #-} + {-# OPTIONS_GHC -Wno-deprecations #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} -- | -- Module : Streamly.Internal.Data.Stream.Zip @@ -13,8 +19,11 @@ -- To run examples in this module: -- -- >>> import qualified Streamly.Prelude as Stream +-- >>> import qualified Streamly.Internal.Data.Stream as D +-- >>> import qualified Streamly.Data.Fold as Fold -- module Streamly.Internal.Data.Stream.Zip + {-# DEPRECATED "Use \"Streamly.Data.Stream.MkType\" instead." #-} ( ZipSerialM (..) , ZipSerial @@ -22,12 +31,16 @@ , zipWithK , zipWithMK + , ZipConcurrent (..) + -- * Deprecated , ZipStream ) where +#if !MIN_VERSION_base(4,18,0) import Control.Applicative (liftA2) +#endif import Control.DeepSeq (NFData(..)) #if MIN_VERSION_deepseq(1,4,3) import Control.DeepSeq (NFData1(..)) @@ -46,11 +59,12 @@ import Streamly.Internal.BaseCompat ((#.)) import Streamly.Internal.Data.Maybe.Strict (Maybe'(..), toMaybe) import Streamly.Internal.Data.Stream.Serial (SerialT(..)) -import Streamly.Internal.Data.Stream.StreamK.Type (Stream) +import Streamly.Internal.Data.StreamK (Stream) +import Streamly.Internal.Data.Stream.Concurrent (MonadAsync, parZipWith) import qualified Streamly.Internal.Data.Stream.Common as P -import qualified Streamly.Internal.Data.Stream.StreamK.Type as K -import qualified Streamly.Internal.Data.Stream.StreamD as D +import qualified Streamly.Internal.Data.StreamK as K +import qualified Streamly.Internal.Data.Stream as D import qualified Streamly.Internal.Data.Stream.Serial as Serial import Prelude hiding (map, repeat, zipWith) @@ -59,6 +73,8 @@ -- $setup -- >>> import qualified Streamly.Prelude as Stream +-- >>> import qualified Streamly.Internal.Data.Stream as D +-- >>> import qualified Streamly.Data.Fold as Fold -- >>> import Control.Concurrent (threadDelay) -- >>> :{ -- delay n = do @@ -133,3 +149,27 @@ FOLDABLE_INSTANCE(ZipSerialM) TRAVERSABLE_INSTANCE(ZipSerialM) + +------------------------------------------------------------------------------- +-- ZipConcurrent +------------------------------------------------------------------------------- + +newtype ZipConcurrent m a = ZipConcurrent {getZipConcurrent :: D.Stream m a} + deriving (Functor) + +-- | An IO stream whose applicative instance zips streams concurrently. Note +-- that it uses the default concurrency options. +-- +-- >>> s = ZipConcurrent $ D.fromList [1, 2, 3] +-- >>> x = (,,) <$> s <*> s <*> s +-- >>> D.fold Fold.toList (getZipConcurrent x) +-- [(1,1,1),(2,2,2),(3,3,3)] +-- +-- @since 0.9.0 + +instance MonadAsync m => Applicative (ZipConcurrent m) where + pure = ZipConcurrent . D.repeat + + {-# INLINE (<*>) #-} + ZipConcurrent m1 <*> ZipConcurrent m2 = + ZipConcurrent $ parZipWith id id m1 m2 diff --git a/src/Streamly/Internal/Data/Stream/Zip/Concurrent.hs b/src/Streamly/Internal/Data/Stream/Zip/Concurrent.hs deleted file mode 100644 --- a/src/Streamly/Internal/Data/Stream/Zip/Concurrent.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} --- | --- Module : Streamly.Internal.Data.Stream.Concurrent --- Copyright : (c) 2017 Composewell Technologies --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- --- To run examples in this module: --- --- >>> import qualified Streamly.Internal.Data.Stream as Stream --- >>> import qualified Streamly.Data.Fold as Fold --- -module Streamly.Internal.Data.Stream.Zip.Concurrent - ( - ZipConcurrent (..) - ) -where - -import Streamly.Internal.Data.Stream.StreamD (Stream) -import Streamly.Internal.Data.Stream.Concurrent (MonadAsync, parZipWith) - -import qualified Streamly.Internal.Data.Stream.StreamD as Stream (repeat) -import Prelude hiding (map, repeat, zipWith) - --- $setup --- >>> import qualified Streamly.Internal.Data.Stream as Stream --- >>> import qualified Streamly.Data.Fold as Fold --- - -newtype ZipConcurrent m a = ZipConcurrent {getZipConcurrent :: Stream m a} - deriving (Functor) - --- | An IO stream whose applicative instance zips streams concurrently. Note --- that it uses the default concurrency options. --- --- >>> s = ZipConcurrent $ Stream.fromList [1, 2, 3] --- >>> x = (,,) <$> s <*> s <*> s --- >>> Stream.fold Fold.toList (getZipConcurrent x) --- [(1,1,1),(2,2,2),(3,3,3)] --- --- @since 0.9.0 - -instance MonadAsync m => Applicative (ZipConcurrent m) where - pure = ZipConcurrent . Stream.repeat - - {-# INLINE (<*>) #-} - ZipConcurrent m1 <*> ZipConcurrent m2 = - ZipConcurrent $ parZipWith id id m1 m2 diff --git a/src/Streamly/Internal/Data/Stream/ZipAsync.hs b/src/Streamly/Internal/Data/Stream/ZipAsync.hs --- a/src/Streamly/Internal/Data/Stream/ZipAsync.hs +++ b/src/Streamly/Internal/Data/Stream/ZipAsync.hs @@ -13,7 +13,8 @@ -- -- >>> import qualified Streamly.Prelude as Stream -- -module Streamly.Internal.Data.Stream.ZipAsync {-# DEPRECATED "Please use \"Streamly.Internal.Data.Stream.Zip.Concurrent\" instead." #-} +module Streamly.Internal.Data.Stream.ZipAsync + {-# DEPRECATED "Use \"Streamly.Data.Stream.MkType\" instead." #-} ( ZipAsyncM(..) , ZipAsync , consMZipAsync @@ -23,11 +24,11 @@ where import Streamly.Internal.Control.Concurrent (MonadAsync) -import Streamly.Internal.Data.Stream.StreamK.Type (Stream) +import Streamly.Internal.Data.StreamK (Stream) -import qualified Streamly.Internal.Data.Stream.StreamK as K +import qualified Streamly.Internal.Data.StreamK as K (mkStream, foldStream, zipWithM, consM) -import qualified Streamly.Internal.Data.Stream.StreamD as D (fromStreamK) +import qualified Streamly.Internal.Data.Stream as D (fromStreamK) import qualified Streamly.Internal.Data.Stream.Serial as Serial import qualified Streamly.Internal.Data.Stream.SVar.Eliminate as SVar import qualified Streamly.Internal.Data.Stream.SVar.Generate as SVar diff --git a/src/Streamly/Internal/Data/Unfold/Exception.hs b/src/Streamly/Internal/Data/Unfold/Exception.hs --- a/src/Streamly/Internal/Data/Unfold/Exception.hs +++ b/src/Streamly/Internal/Data/Unfold/Exception.hs @@ -25,11 +25,9 @@ (MonadRunInIO, MonadAsync, withRunInIO) import Streamly.Internal.Data.IOFinalizer.Lifted (newIOFinalizer, runIOFinalizer, clearingIOFinalizer) -import Streamly.Internal.Data.Stream.StreamD.Type (Step(..)) - import qualified Control.Monad.Catch as MC -import Streamly.Internal.Data.Unfold.Type +import Streamly.Internal.Data.Unfold -- | Run the alloc action @a -> m c@ with async exceptions disabled but keeping -- blocking operations interruptible (see 'Control.Exception.mask'). Use the diff --git a/src/Streamly/Internal/Data/Unfold/Prelude.hs b/src/Streamly/Internal/Data/Unfold/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Unfold/Prelude.hs @@ -0,0 +1,20 @@ +{-# OPTIONS_GHC -Wno-deprecations #-} + +-- | +-- Module : Streamly.Internal.Data.Unfold.Prelude +-- Copyright : (c) 2022 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +module Streamly.Internal.Data.Unfold.Prelude + ( + module Streamly.Internal.Data.Unfold.Exception + -- * Deprecated + , module Streamly.Internal.Data.Unfold.SVar + ) +where + +import Streamly.Internal.Data.Unfold.Exception +import Streamly.Internal.Data.Unfold.SVar diff --git a/src/Streamly/Internal/Data/Unfold/SVar.hs b/src/Streamly/Internal/Data/Unfold/SVar.hs --- a/src/Streamly/Internal/Data/Unfold/SVar.hs +++ b/src/Streamly/Internal/Data/Unfold/SVar.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-deprecations #-} -- | -- Module : Streamly.Internal.Data.Unfold.SVar -- Copyright : (c) 2019 Composewell Technologies @@ -7,6 +8,7 @@ -- Portability : GHC -- module Streamly.Internal.Data.Unfold.SVar + {-# DEPRECATED "The functionality is moved to Channel.*" #-} ( fromSVar , fromProducer @@ -21,10 +23,10 @@ import Data.IORef (newIORef, readIORef, mkWeakIORef, writeIORef) import Data.Maybe (isNothing) import Streamly.Internal.Control.Concurrent (MonadAsync) -import Streamly.Internal.Data.Stream.StreamD.Type (Step(..)) +import Streamly.Internal.Data.Stream (Step(..)) import Streamly.Internal.Data.Time.Clock (Clock(Monotonic), getTime) import Streamly.Internal.Data.SVar (printSVar, cleanupSVar, sendStopToProducer) -import Streamly.Internal.Data.Unfold.Type (Unfold(..)) +import Streamly.Internal.Data.Unfold (Unfold(..)) import System.Mem (performMajorGC) import qualified Control.Monad.Catch as MC diff --git a/src/Streamly/Internal/FileSystem/Event.hs b/src/Streamly/Internal/FileSystem/Event.hs --- a/src/Streamly/Internal/FileSystem/Event.hs +++ b/src/Streamly/Internal/FileSystem/Event.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-deprecations #-} + -- | -- Module : Streamly.FileSystem.Event -- Copyright : (c) 2020 Composewell Technologies @@ -20,7 +22,12 @@ -- * "Streamly.Internal.FileSystem.Event.Linux" -- * "Streamly.Internal.FileSystem.Event.Windows" +-- XXX Need to ensure that the signatures of the exported APIs are same on all +-- platforms. + + module Streamly.Internal.FileSystem.Event + {-# DEPRECATED "Use the streamly-fsevents package." #-} ( -- * Creating a Watch @@ -47,8 +54,8 @@ import Data.List.NonEmpty (NonEmpty) import Data.Word (Word8) -import Streamly.Internal.Data.Array (Array) -import Streamly.Internal.Data.Stream.StreamD (Stream) +import Streamly.Data.Array (Array) +import Streamly.Data.Stream (Stream) #if defined(CABAL_OS_DARWIN) import Streamly.Internal.FileSystem.Event.Darwin (Event) diff --git a/src/Streamly/Internal/FileSystem/Event/Darwin.c b/src/Streamly/Internal/FileSystem/Event/Darwin.c new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/FileSystem/Event/Darwin.c @@ -0,0 +1,287 @@ +/* + * Code adapted from the Haskell "hfsevents" package. + * + * Copyright (c) 2012, Luite Stegeman + * + */ + +#include + +#if HAVE_DECL_KFSEVENTSTREAMCREATEFLAGFILEEVENTS + +#include +#include +#include +#include + +/* + * For reference documentaion see: + * https://developer.apple.com/documentation/coreservices/file_system_events?language=objc + * https://developer.apple.com/library/archive/documentation/Darwin/Conceptual/FSEvents_ProgGuide/UsingtheFSEventsFramework/UsingtheFSEventsFramework.html + * + * An OS thread is started which runs the event loop. A pipe is created + * and the events are sent to the pipes. The receiver can read the pipe + * output end to get the events. + */ + +/****************************************************************************** + * Create Flags + *****************************************************************************/ + +UInt32 FSEventStreamCreateFlagNoDefer () { + return kFSEventStreamCreateFlagNoDefer; +} +UInt32 FSEventStreamCreateFlagWatchRoot () { + return kFSEventStreamCreateFlagWatchRoot; +} +UInt32 FSEventStreamCreateFlagFileEvents () { + return kFSEventStreamCreateFlagFileEvents; +} +UInt32 FSEventStreamCreateFlagIgnoreSelf () { + return kFSEventStreamCreateFlagIgnoreSelf; +} +#if 0 +UInt32 FSEventStreamCreateFlagFullHistory = kFSEventStreamCreateFlagFullHistory; +#endif + +/****************************************************************************** + * Event Flags + *****************************************************************************/ + +UInt32 FSEventStreamEventFlagEventIdsWrapped () { + return kFSEventStreamEventFlagEventIdsWrapped; +} +UInt32 FSEventStreamEventFlagMustScanSubDirs () { + return kFSEventStreamEventFlagMustScanSubDirs; +} +UInt32 FSEventStreamEventFlagKernelDropped () { + return kFSEventStreamEventFlagKernelDropped; +} +UInt32 FSEventStreamEventFlagUserDropped () { + return kFSEventStreamEventFlagUserDropped; +} +UInt32 FSEventStreamEventFlagHistoryDone () { + return kFSEventStreamEventFlagHistoryDone; +} +UInt32 FSEventStreamEventFlagRootChanged () { + return kFSEventStreamEventFlagRootChanged; +} +UInt32 FSEventStreamEventFlagMount () { + return kFSEventStreamEventFlagMount; +} +UInt32 FSEventStreamEventFlagUnmount () { + return kFSEventStreamEventFlagUnmount; +} +UInt32 FSEventStreamEventFlagItemChangeOwner () { + return kFSEventStreamEventFlagItemChangeOwner; +} +UInt32 FSEventStreamEventFlagItemInodeMetaMod () { + return kFSEventStreamEventFlagItemInodeMetaMod; +} +UInt32 FSEventStreamEventFlagItemFinderInfoMod () { + return kFSEventStreamEventFlagItemFinderInfoMod; +} +UInt32 FSEventStreamEventFlagItemXattrMod () { + return kFSEventStreamEventFlagItemXattrMod; +} +UInt32 FSEventStreamEventFlagItemCreated () { + return kFSEventStreamEventFlagItemCreated; +} +UInt32 FSEventStreamEventFlagItemRemoved () { + return kFSEventStreamEventFlagItemRemoved; +} +UInt32 FSEventStreamEventFlagItemRenamed () { + return kFSEventStreamEventFlagItemRenamed; +} +UInt32 FSEventStreamEventFlagItemModified () { + return kFSEventStreamEventFlagItemModified; +} +#if __MAC_OS_X_VERSION_MIN_REQUIRED >= 101300 +UInt32 FSEventStreamEventFlagItemCloned () { + return kFSEventStreamEventFlagItemCloned; +} +#endif +UInt32 FSEventStreamEventFlagItemIsDir () { + return kFSEventStreamEventFlagItemIsDir; +} +UInt32 FSEventStreamEventFlagItemIsFile () { + return kFSEventStreamEventFlagItemIsFile; +} +UInt32 FSEventStreamEventFlagItemIsSymlink () { + return kFSEventStreamEventFlagItemIsSymlink; +} +#if __MAC_OS_X_VERSION_MIN_REQUIRED >= 101000 +UInt32 FSEventStreamEventFlagItemIsHardlink () { + return kFSEventStreamEventFlagItemIsHardlink; +} +#endif +UInt32 FSEventStreamEventFlagItemIsLastHardlink () { + return kFSEventStreamEventFlagItemIsLastHardlink; +} + +/****************************************************************************** + * Event watch + *****************************************************************************/ + +/* Write an event to the pipe input fd */ +static void writeEvent(int fd, UInt64 eventId, UInt64 eventFlags, char* path) +{ + UInt64 buf[3]; + /* XXX Is the path string in UTF-8? */ + size_t len = strlen(path); + + buf[0] = eventId; + buf[1] = eventFlags; + buf[2] = (UInt64)len; + write(fd, buf, 3 * sizeof(UInt64)); + write(fd, path, len); +} + +struct watch +{ + FSEventStreamRef eventStream; + dispatch_queue_t queue; + int writefd; +}; + +/* Just writes the event to the pipe input fd */ +static void watchCallback + ( ConstFSEventStreamRef streamRef + , void *clientCallBackInfo + , size_t n + , void *eventPaths + , const FSEventStreamEventFlags eventFlags[] + , const FSEventStreamEventId eventIds[] + ) +{ + int i; + struct watch *w = clientCallBackInfo; + char **paths = eventPaths; + + for (i = 0; i < n; i++) { + writeEvent(w->writefd, eventIds[i], eventFlags[i], paths[i]); + } +} + +#define MAX_WATCH_PATHS 4096 + +static void free_cffolders(CFStringRef *cffolders, int n) { + int i; + for (i = 0; i < n; i++) { + CFRelease (cffolders[i]); + } + free(cffolders); +} + +int createWatch + ( struct pathName* folders + , int n /* number of entries in folders */ + , UInt32 createFlags + , UInt64 since + , double latency + , int* fd + , void** wp + ) +{ + if (n > MAX_WATCH_PATHS) { + return -1; + } + + int pfds[2]; + if (pipe (pfds)) { + return -1; + } + + /* + * XXX We can possibly use since == 0 to get all events since + * beginning of time + */ + if (!since) { + since = kFSEventStreamEventIdSinceNow; + } + + struct watch *w = malloc(sizeof(struct watch)); + if (!w) { + goto cleanup_pipe; + } + + /* Setup paths array */ + CFStringRef *cffolders = malloc(n * sizeof(CFStringRef)); + if (!cffolders) { + goto cleanup_watch; + } + + /* Create event stream using paths and context*/ + int i; + for(i = 0; i < n; i++) { + cffolders[i] = CFStringCreateWithBytes + ( NULL + , folders[i].pathBytes + , folders[i].pathLen + , kCFStringEncodingUTF8 + , false + ); + if (!cffolders[i]) { + free_cffolders(cffolders, i); + goto cleanup_watch; + } + } + CFArrayRef paths = CFArrayCreate(NULL, (const void **)cffolders, n, NULL); + if (!paths) { + free_cffolders(cffolders, n); + goto cleanup_watch; + } + + FSEventStreamContext ctx; + ctx.version = 0; + ctx.info = (void*)w; + ctx.retain = NULL; + ctx.release = NULL; + ctx.copyDescription = NULL; + + w->eventStream = FSEventStreamCreate + (NULL, &watchCallback, &ctx, paths, since, latency, createFlags); + free_cffolders(cffolders, n); + CFRelease(paths); + + if(w->eventStream == NULL) { + goto cleanup_watch; + } + + w->queue = dispatch_queue_create("com.composewell.streamly", NULL); + if (!w->queue) { + goto cleanup_es; + } + + w->writefd = pfds[1]; + *fd = pfds[0]; + *wp = w; + FSEventStreamSetDispatchQueue(w->eventStream, w->queue); + FSEventStreamStart(w->eventStream); + return 0; + +cleanup_es: + FSEventStreamRelease(w->eventStream); +cleanup_watch: + free(w); +cleanup_pipe: + close(pfds[0]); + close(pfds[1]); + return -1; +} + +/****************************************************************************** + * Stop a watch event loop + *****************************************************************************/ + +void destroyWatch(struct watch* w) { + /* Stop and invalidate the event stream */ + FSEventStreamFlushSync(w->eventStream); + FSEventStreamStop(w->eventStream); + FSEventStreamInvalidate(w->eventStream); + dispatch_release(w->queue); + FSEventStreamRelease(w->eventStream); + close(w->writefd); + free(w); +} +#endif diff --git a/src/Streamly/Internal/FileSystem/Event/Darwin.hs b/src/Streamly/Internal/FileSystem/Event/Darwin.hs --- a/src/Streamly/Internal/FileSystem/Event/Darwin.hs +++ b/src/Streamly/Internal/FileSystem/Event/Darwin.hs @@ -87,6 +87,7 @@ #if HAVE_DECL_KFSEVENTSTREAMCREATEFLAGFILEEVENTS module Streamly.Internal.FileSystem.Event.Darwin + {-# DEPRECATED "Use the streamly-fsevents package." #-} ( -- * Creating a Watch @@ -175,7 +176,7 @@ import Streamly.Internal.Data.Stream (Stream) import Streamly.Internal.Data.Cont (contListMap) import Streamly.Internal.Data.Parser (Parser) -import Streamly.Internal.Data.Array.Type (Array(..)) +import Streamly.Internal.Data.Array (Array(..)) import System.IO (Handle, hClose) import qualified Data.List.NonEmpty as NonEmpty @@ -451,8 +452,8 @@ withPathName :: Array Word8 -> (PathName -> IO a) -> IO a withPathName arr act = do - A.asPtrUnsafe arr $ \ptr -> - let pname = PathName (castPtr ptr) (fromIntegral (A.length arr)) + A.unsafePinnedAsPtr arr $ \ptr byteLen -> + let pname = PathName (castPtr ptr) (fromIntegral byteLen) in act pname withPathNames = contListMap withPathName withArray @@ -491,12 +492,12 @@ -- readOneEvent :: Parser Word8 IO Event readOneEvent = do - arr <- PR.takeEQ 24 (A.writeN 24) - let arr1 = A.castUnsafe arr :: Array Word64 - eid = A.unsafeIndex 0 arr1 - eflags = A.unsafeIndex 1 arr1 - pathLen = fromIntegral $ A.unsafeIndex 2 arr1 - path <- PR.takeEQ pathLen (A.writeN pathLen) + arr <- PR.takeEQ 24 (A.createOf 24) + let arr1 = A.unsafeCast arr :: Array Word64 + eid = A.unsafeGetIndex 0 arr1 + eflags = A.unsafeGetIndex 1 arr1 + pathLen = fromIntegral $ A.unsafeGetIndex 2 arr1 + path <- PR.takeEQ pathLen (A.createOf pathLen) return $ Event { eventId = eid , eventFlags = fromIntegral eflags @@ -1036,7 +1037,7 @@ -- | Convert an 'Event' record to a String representation. showEvent :: Event -> String showEvent ev@Event{..} = - let path = runIdentity $ S.fold FL.toList $ U.decodeUtf8' $ A.toStream eventAbsPath + let path = runIdentity $ S.fold FL.toList $ U.decodeUtf8' $ A.read eventAbsPath in "--------------------------" ++ "\nId = " ++ show eventId ++ "\nPath = " ++ show path diff --git a/src/Streamly/Internal/FileSystem/Event/Darwin.m b/src/Streamly/Internal/FileSystem/Event/Darwin.m deleted file mode 100644 --- a/src/Streamly/Internal/FileSystem/Event/Darwin.m +++ /dev/null @@ -1,294 +0,0 @@ -/* - * Code adapted from the Haskell "hfsevents" package. - * - * Copyright (c) 2012, Luite Stegeman - * - */ - -#include - -#if HAVE_DECL_KFSEVENTSTREAMCREATEFLAGFILEEVENTS - -#include -#include -#include -#include - -/* - * For reference documentaion see: - * https://developer.apple.com/documentation/coreservices/file_system_events?language=objc - * https://developer.apple.com/library/archive/documentation/Darwin/Conceptual/FSEvents_ProgGuide/UsingtheFSEventsFramework/UsingtheFSEventsFramework.html - * - * An OS thread is started which runs the event loop. A pipe is created - * and the events are sent to the pipes. The receiver can read the pipe - * output end to get the events. - */ - -/****************************************************************************** - * Create Flags - *****************************************************************************/ - -UInt32 FSEventStreamCreateFlagNoDefer () { - return kFSEventStreamCreateFlagNoDefer; -} -UInt32 FSEventStreamCreateFlagWatchRoot () { - return kFSEventStreamCreateFlagWatchRoot; -} -UInt32 FSEventStreamCreateFlagFileEvents () { - return kFSEventStreamCreateFlagFileEvents; -} -UInt32 FSEventStreamCreateFlagIgnoreSelf () { - return kFSEventStreamCreateFlagIgnoreSelf; -} -#if 0 -UInt32 FSEventStreamCreateFlagFullHistory = kFSEventStreamCreateFlagFullHistory; -#endif - -/****************************************************************************** - * Event Flags - *****************************************************************************/ - -UInt32 FSEventStreamEventFlagEventIdsWrapped () { - return kFSEventStreamEventFlagEventIdsWrapped; -} -UInt32 FSEventStreamEventFlagMustScanSubDirs () { - return kFSEventStreamEventFlagMustScanSubDirs; -} -UInt32 FSEventStreamEventFlagKernelDropped () { - return kFSEventStreamEventFlagKernelDropped; -} -UInt32 FSEventStreamEventFlagUserDropped () { - return kFSEventStreamEventFlagUserDropped; -} -UInt32 FSEventStreamEventFlagHistoryDone () { - return kFSEventStreamEventFlagHistoryDone; -} -UInt32 FSEventStreamEventFlagRootChanged () { - return kFSEventStreamEventFlagRootChanged; -} -UInt32 FSEventStreamEventFlagMount () { - return kFSEventStreamEventFlagMount; -} -UInt32 FSEventStreamEventFlagUnmount () { - return kFSEventStreamEventFlagUnmount; -} -UInt32 FSEventStreamEventFlagItemChangeOwner () { - return kFSEventStreamEventFlagItemChangeOwner; -} -UInt32 FSEventStreamEventFlagItemInodeMetaMod () { - return kFSEventStreamEventFlagItemInodeMetaMod; -} -UInt32 FSEventStreamEventFlagItemFinderInfoMod () { - return kFSEventStreamEventFlagItemFinderInfoMod; -} -UInt32 FSEventStreamEventFlagItemXattrMod () { - return kFSEventStreamEventFlagItemXattrMod; -} -UInt32 FSEventStreamEventFlagItemCreated () { - return kFSEventStreamEventFlagItemCreated; -} -UInt32 FSEventStreamEventFlagItemRemoved () { - return kFSEventStreamEventFlagItemRemoved; -} -UInt32 FSEventStreamEventFlagItemRenamed () { - return kFSEventStreamEventFlagItemRenamed; -} -UInt32 FSEventStreamEventFlagItemModified () { - return kFSEventStreamEventFlagItemModified; -} -#if __MAC_OS_X_VERSION_MIN_REQUIRED >= 101300 -UInt32 FSEventStreamEventFlagItemCloned () { - return kFSEventStreamEventFlagItemCloned; -} -#endif -UInt32 FSEventStreamEventFlagItemIsDir () { - return kFSEventStreamEventFlagItemIsDir; -} -UInt32 FSEventStreamEventFlagItemIsFile () { - return kFSEventStreamEventFlagItemIsFile; -} -UInt32 FSEventStreamEventFlagItemIsSymlink () { - return kFSEventStreamEventFlagItemIsSymlink; -} -#if __MAC_OS_X_VERSION_MIN_REQUIRED >= 101000 -UInt32 FSEventStreamEventFlagItemIsHardlink () { - return kFSEventStreamEventFlagItemIsHardlink; -} -#endif -UInt32 FSEventStreamEventFlagItemIsLastHardlink () { - return kFSEventStreamEventFlagItemIsLastHardlink; -} - -/****************************************************************************** - * Event watch - *****************************************************************************/ - -/* Write an event to the pipe input fd */ -static void writeEvent(int fd, UInt64 eventId, UInt64 eventFlags, char* path) -{ - UInt64 buf[3]; - buf[0] = eventId; - buf[1] = eventFlags; - /* XXX Is the path string in UTF-8? */ - buf[2] = (UInt64)strlen(path); - write(fd, buf, 3 * sizeof(UInt64)); - write(fd, path, strlen(path)); -} - -/* thread state */ -struct watch -{ - FSEventStreamRef eventStream; - CFRunLoopRef runLoop; - int writefd; - pthread_mutex_t mut; -}; - -/* Just writes the event to the pipe input fd */ -static void watchCallback - ( ConstFSEventStreamRef streamRef - , void *clientCallBackInfo - , size_t n - , void *eventPaths - , const FSEventStreamEventFlags eventFlags[] - , const FSEventStreamEventId eventIds[] - ) -{ - int i; - struct watch *w = clientCallBackInfo; - char **paths = eventPaths; - - for (i = 0; i < n; i++) { - writeEvent(w->writefd, eventIds[i], eventFlags[i], paths[i]); - } -} - -/****************************************************************************** - * Start a watch event loop - *****************************************************************************/ - -/* Event loop run in a pthread */ -static void *watchRunLoop(void *vw) -{ - struct watch* w = (struct watch*) vw; - CFRunLoopRef rl = CFRunLoopGetCurrent(); - CFRetain(rl); - w->runLoop = rl; - FSEventStreamScheduleWithRunLoop(w->eventStream, rl, kCFRunLoopDefaultMode); - FSEventStreamStart(w->eventStream); - pthread_mutex_unlock(&w->mut); - CFRunLoopRun(); - pthread_exit(NULL); -} - -#define MAX_WATCH_PATHS 4096 - -int createWatch - ( struct pathName* folders - , int n /* number of entries in folders */ - , UInt32 createFlags - , UInt64 since - , double latency - , int* fd - , void** wp - ) -{ - if (n > MAX_WATCH_PATHS) { - return -1; - } - - int pfds[2]; - if (pipe (pfds)) { - return -1; - } - - /* - * XXX We can possibly use since == 0 to get all events since - * beginning of time - */ - if (!since) { - since = kFSEventStreamEventIdSinceNow; - } - - /* Setup paths array */ - CFStringRef *cffolders = malloc(n * sizeof(CFStringRef)); - int i; - for(i = 0; i < n; i++) { - cffolders[i] = CFStringCreateWithBytes - ( NULL - , folders[i].pathBytes - , folders[i].pathLen - , kCFStringEncodingUTF8 - , false - ); - } - CFArrayRef paths = CFArrayCreate(NULL, (const void **)cffolders, n, NULL); - - /* Setup context */ - struct watch *w = malloc(sizeof(struct watch)); - FSEventStreamContext ctx; - ctx.version = 0; - ctx.info = (void*)w; - ctx.retain = NULL; - ctx.release = NULL; - ctx.copyDescription = NULL; - - /* Create watch using paths and context*/ - FSEventStreamRef es = FSEventStreamCreate - (NULL, &watchCallback, &ctx, paths, since, latency, createFlags); - - /* Run the event loop in a pthread */ - int retval; - if(es != NULL) { - /* Success */ - w->writefd = pfds[1]; - w->eventStream = es; - w->runLoop = NULL; - - /* Lock to prevent race against watch destroy */ - pthread_mutex_init(&w->mut, NULL); - pthread_mutex_lock(&w->mut); - pthread_t t; - pthread_create(&t, NULL, &watchRunLoop, (void*)w); - - /* return the out fd and the watch struct */ - *fd = pfds[0]; - *wp = w; - retval = 0; - } else { - /* Failure */ - close(pfds[0]); - close(pfds[1]); - free(w); - retval = -1; - } - - /* Cleanup */ - for (i = 0; i < n; i++) { - CFRelease (cffolders[i]); - } - free(cffolders); - CFRelease(paths); - return retval; -} - -/****************************************************************************** - * Stop a watch event loop - *****************************************************************************/ - -void destroyWatch(struct watch* w) { - /* Stop the loop so the thread will exit */ - pthread_mutex_lock(&w->mut); - FSEventStreamStop(w->eventStream); - FSEventStreamInvalidate(w->eventStream); - CFRunLoopStop(w->runLoop); - CFRelease(w->runLoop); - FSEventStreamRelease(w->eventStream); - close(w->writefd); - pthread_mutex_unlock(&w->mut); - - /* Cleanup */ - pthread_mutex_destroy(&w->mut); - free(w); -} -#endif diff --git a/src/Streamly/Internal/FileSystem/Event/Linux.hs b/src/Streamly/Internal/FileSystem/Event/Linux.hs --- a/src/Streamly/Internal/FileSystem/Event/Linux.hs +++ b/src/Streamly/Internal/FileSystem/Event/Linux.hs @@ -59,6 +59,7 @@ #if HAVE_DECL_IN_EXCL_UNLINK module Streamly.Internal.FileSystem.Event.Linux + {-# DEPRECATED "Use the streamly-fsevents package." #-} ( -- * Subscribing to events @@ -169,25 +170,34 @@ import Foreign.Ptr (Ptr) import Foreign.Storable (peek, peekByteOff, sizeOf) import GHC.IO.Device (IODeviceType(Stream)) -import GHC.IO.FD (fdFD, mkFD) +import GHC.IO.FD (fdFD, FD(..)) import GHC.IO.Handle.FD (mkHandleFromFD) -import Streamly.Internal.Data.Stream.StreamD (Stream) -import Streamly.Internal.Data.Parser (Parser) -import Streamly.Internal.Data.Array.Type (Array(..), byteLength) +import Streamly.Data.Stream (Stream) +import Streamly.Data.Parser (Parser) import System.Directory (doesDirectoryExist) import System.IO (Handle, hClose, IOMode(ReadMode)) import GHC.IO.Handle.FD (handleToFd) +import Streamly.Internal.Data.Array (Array(..), byteLength) +import Streamly.Internal.FileSystem.Path (Path) + import qualified Data.IntMap.Lazy as Map import qualified Data.List.NonEmpty as NonEmpty -import qualified Streamly.Internal.Data.Array as A import qualified Streamly.Data.Fold as FL +import qualified Streamly.Data.Array as A (fromList, createOf, getIndex) +import qualified Streamly.Data.Stream as S +import qualified Streamly.FileSystem.Handle as FH +import qualified Streamly.Unicode.Stream as U +import qualified Streamly.Internal.FileSystem.Path as Path + +import qualified Streamly.Internal.Data.Array as A + ( asCStringUnsafe, unsafePinnedAsPtr + , unsafeSliceOffLen, read + ) +import qualified Streamly.Internal.FileSystem.DirIO as Dir + (readDirs, followSymlinks) import qualified Streamly.Internal.Data.Parser as PR (takeEQ, fromEffect, fromFold) -import qualified Streamly.Internal.Data.Stream.StreamD as S -import qualified Streamly.Internal.FileSystem.Dir as Dir -import qualified Streamly.Internal.FileSystem.Handle as FH -import qualified Streamly.Internal.Unicode.Stream as U ------------------------------------------------------------------------------- -- Subscription to events @@ -569,6 +579,7 @@ newtype WD = WD CInt deriving Show +-- XXX Use inotify_init1? and IN_NONBLOCK? foreign import ccall unsafe "sys/inotify.h inotify_init" c_inotify_init :: IO CInt @@ -580,23 +591,34 @@ createWatch :: IO Watch createWatch = do rawfd <- throwErrnoIfMinus1 "createWatch" c_inotify_init - -- we could use fdToHandle but it cannot determine the fd type - -- automatically for the inotify fd - (fd, fdType) <- - mkFD - rawfd - ReadMode - (Just (Stream, 0, 0)) -- (IODeviceType, CDev, CIno) - False -- not a socket - False -- non-blocking is false - let fdString = "" + -- We could use fdToHandle but it cannot determine the fd type + -- automatically for the inotify fd because fdStat fails for Stream type + -- fd. + -- + -- Do not use mkFD as it locks a regular file causing "resource busy" error + -- in some test cases. + let fd = + FD + { fdFD = rawfd +#if !defined(mingw32_HOST_OS) + , fdIsNonBlocking = 0 +#else + , fdIsSocket_ = 0 +#endif + } + + -- XXX Do we need non-blocking IO? + -- With non-blocking IO it fails because GHC-9.10 uses fdStat in + -- FD.setNonBlockingMode to determine the fd type which fails for Stream + -- type fd. However, without non-blocking IO "select" has a limitation on + -- the number of FDs being watched (1024). h <- mkHandleFromFD fd - fdType - fdString + Stream + ("") ReadMode - True -- use non-blocking IO + False -- use non-blocking IO Nothing -- TextEncoding (binary) emptyMapRef <- newIORef Map.empty return $ Watch h emptyMapRef @@ -609,8 +631,8 @@ -- separated bytes. So these may fail or convert the path in an unexpected -- manner. We should ultimately remove all usage of these. -toUtf8 :: MonadIO m => String -> m (Array Word8) -toUtf8 = A.fromStream . U.encodeUtf8 . S.fromList +toUtf8 :: MonadIO m => Path -> m (Array Word8) +toUtf8 path = pure $ Path.toArray path utf8ToString :: Array Word8 -> String utf8ToString = runIdentity . S.fold FL.toList . U.decodeUtf8' . A.read @@ -643,7 +665,7 @@ Nothing -> error "removeTrailingSlash: Bug: Invalid index" Just x -> if x == fromIntegral (ord '/') - then A.getSliceUnsafe 0 n path + then A.unsafeSliceOffLen 0 n path else path else path @@ -710,12 +732,14 @@ -- -- XXX readDirs currently uses paths as String, we need to convert it -- to "/" separated by byte arrays. - pathIsDir <- doesDirectoryExist $ utf8ToString absPath + let p = Path.unsafeFromArray absPath + -- XXX Need a FileSystem.Stat module to remove this + pathIsDir <- doesDirectoryExist (Path.toString p) when (watchRec && pathIsDir) $ do let f = addToWatch cfg watch0 root . appendPaths path in S.fold (FL.drainMapM f) $ S.mapM toUtf8 - $ Dir.readDirs $ utf8ToString absPath + $ Dir.readDirs (Dir.followSymlinks True) p foreign import ccall unsafe "sys/inotify.h inotify_rm_watch" c_inotify_rm_watch @@ -802,8 +826,8 @@ readOneEvent :: Config -> Watch -> Parser Word8 IO Event readOneEvent cfg wt@(Watch _ wdMap) = do let headerLen = sizeOf (undefined :: CInt) + 12 - arr <- PR.takeEQ headerLen (A.writeN headerLen) - (ewd, eflags, cookie, pathLen) <- PR.fromEffect $ A.asPtrUnsafe arr readHeader + arr <- PR.takeEQ headerLen (A.createOf headerLen) + (ewd, eflags, cookie, pathLen) <- PR.fromEffect $ A.unsafePinnedAsPtr arr readHeader -- XXX need the "initial" in parsers to return a step type so that "take 0" -- can return without an input. otherwise if pathLen is 0 we will keep -- waiting to read one more char before we return this event. @@ -816,7 +840,7 @@ pth <- PR.fromFold $ FL.takeEndBy_ (== 0) - $ FL.take pathLen (A.writeN pathLen) + $ FL.take pathLen (A.createOf pathLen) let remaining = pathLen - byteLength pth - 1 when (remaining /= 0) $ PR.takeEQ remaining FL.drain return pth @@ -848,7 +872,7 @@ where - readHeader (ptr :: Ptr Word8) = do + readHeader (ptr :: Ptr Word8) _ = do let len = sizeOf (undefined :: CInt) ewd <- peek ptr eflags <- peekByteOff ptr len diff --git a/src/Streamly/Internal/FileSystem/Event/Windows.hs b/src/Streamly/Internal/FileSystem/Event/Windows.hs --- a/src/Streamly/Internal/FileSystem/Event/Windows.hs +++ b/src/Streamly/Internal/FileSystem/Event/Windows.hs @@ -43,6 +43,7 @@ -- * Minimum supported server: Windows Server 2003 [desktop apps | UWP apps module Streamly.Internal.FileSystem.Event.Windows + {-# DEPRECATED "Use the streamly-fsevents package." #-} ( -- * Subscribing to events @@ -98,8 +99,6 @@ import Foreign.Marshal.Alloc (alloca, allocaBytes) import Foreign.Storable (peekByteOff) import Foreign.Ptr (Ptr, FunPtr, castPtr, nullPtr, nullFunPtr, plusPtr) -import Streamly.Internal.Data.Stream (Stream) -import Streamly.Internal.Data.Stream.Concurrent (eager) import System.Win32.File ( FileNotificationFlag , LPOVERLAPPED @@ -118,14 +117,19 @@ , oPEN_EXISTING ) import System.Win32.Types (BOOL, DWORD, HANDLE, LPVOID, LPDWORD, failIfFalse_) + +import Streamly.Data.Array (Array) +import Streamly.Data.Stream (Stream) +import Streamly.Data.Stream.Prelude (eager) + import qualified Data.List.NonEmpty as NonEmpty +import qualified Streamly.Data.Array as A (fromList) import qualified Streamly.Data.Fold as Fold -import qualified Streamly.Internal.Data.Stream as S -import qualified Streamly.Internal.Data.Stream.Concurrent as S (parConcatMap) -import qualified Streamly.Internal.Unicode.Stream as U -import qualified Streamly.Internal.Unicode.Utf8 as UTF8 -import qualified Streamly.Internal.Data.Array as A -import Streamly.Internal.Data.Array (Array) +import qualified Streamly.Data.Stream as S +import qualified Streamly.Data.Stream.Prelude as S +import qualified Streamly.Unicode.Stream as U +import qualified Streamly.Internal.Unicode.Utf8 as UTF8 (pack, toArray) +import qualified Streamly.Internal.Data.Array as A (read) -- | Watch configuration, used to specify the events of interest and the -- behavior of the watch. diff --git a/src/Streamly/Internal/FileSystem/FD.hs b/src/Streamly/Internal/FileSystem/FD.hs --- a/src/Streamly/Internal/FileSystem/FD.hs +++ b/src/Streamly/Internal/FileSystem/FD.hs @@ -120,7 +120,6 @@ import Data.Word (Word8) -- import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) import Foreign.Ptr (castPtr) -import Streamly.Internal.Data.Unboxed (Unbox) -- import System.IO (Handle, hGetBufSome, hPutBuf) import System.IO (IOMode) import Prelude hiding (read) @@ -128,10 +127,12 @@ import qualified GHC.IO.FD as FD import qualified GHC.IO.Device as RawIO -import Streamly.Internal.Data.Array.Type - (Array(..), byteLength, unsafeFreeze, asPtrUnsafe) +import Streamly.Data.Array (Array, Unbox) +import Streamly.Data.Stream (Stream) + +import Streamly.Internal.Data.Array (byteLength, unsafeFreeze, unsafePinnedAsPtr) import Streamly.Internal.System.IO (defaultChunkSize) -import Streamly.Internal.Data.Stream.StreamD.Type (Stream) + #if !defined(mingw32_HOST_OS) {- import Streamly.Internal.Data.Stream.IsStream.Type (toStreamD) @@ -145,13 +146,13 @@ import qualified Streamly.Data.Array as A import qualified Streamly.Data.Fold as FL -import qualified Streamly.Internal.Data.Array.Mut as MArray - (MutArray(..), newPinnedBytes, asPtrUnsafe) -import qualified Streamly.Internal.Data.Stream.Chunked as AS -import qualified Streamly.Internal.Data.Stream.StreamD as S -import qualified Streamly.Internal.Data.Stream.StreamD.Type as D +import qualified Streamly.Internal.Data.MutArray as MArray + (MutArray(..), unsafePinnedAsPtr, pinnedNewBytes) +import qualified Streamly.Internal.Data.Array.Stream as AS +import qualified Streamly.Internal.Data.Stream as S +import qualified Streamly.Internal.Data.Stream as D (Stream(..), Step(..)) -import qualified Streamly.Internal.Data.Stream.StreamK.Type as K (mkStream) +import qualified Streamly.Internal.Data.StreamK as K (mkStream) ------------------------------------------------------------------------------- @@ -217,20 +218,17 @@ {-# INLINABLE readArrayUpto #-} readArrayUpto :: Int -> Handle -> IO (Array Word8) readArrayUpto size (Handle fd) = do - arr <- MArray.newPinnedBytes size - -- ptr <- mallocPlainForeignPtrAlignedBytes size (alignment (undefined :: Word8)) - MArray.asPtrUnsafe arr $ \p -> do - -- n <- hGetBufSome h p size + arr <- + MArray.unsafeCreateWithPtr' size $ \p -> + -- n <- hGetBufSome h p size #if MIN_VERSION_base(4,15,0) - n <- RawIO.read fd p 0 size + RawIO.read fd p 0 size #else - n <- RawIO.read fd p size + RawIO.read fd p size #endif - -- XXX shrink only if the diff is significant - -- Use unsafeFreezeWithShrink - return - $ unsafeFreeze - $ arr { MArray.arrEnd = n, MArray.arrBound = size } + -- XXX shrink only if the diff is significant + -- Use unsafeFreezeWithShrink + pure $ unsafeFreeze arr ------------------------------------------------------------------------------- -- Array IO (output) @@ -243,7 +241,7 @@ writeArray :: Unbox a => Handle -> Array a -> IO () writeArray _ arr | A.length arr == 0 = return () writeArray (Handle fd) arr = - asPtrUnsafe arr $ \p -> + unsafePinnedAsPtr arr $ \p -> -- RawIO.writeAll fd (castPtr p) aLen #if MIN_VERSION_base(4,15,0) RawIO.write fd (castPtr p) 0 aLen @@ -269,7 +267,7 @@ writeIOVec :: Handle -> Array RawIO.IOVec -> IO () writeIOVec _ iov | A.length iov == 0 = return () writeIOVec (Handle fd) iov = - asPtrUnsafe iov $ \p -> + unsafePinnedAsPtr iov $ \p -> RawIO.writevAll fd p (A.length iov) -} #endif diff --git a/src/Streamly/Internal/Network/Inet/TCP.hs b/src/Streamly/Internal/Network/Inet/TCP.hs --- a/src/Streamly/Internal/Network/Inet/TCP.hs +++ b/src/Streamly/Internal/Network/Inet/TCP.hs @@ -11,20 +11,25 @@ module Streamly.Internal.Network.Inet.TCP ( + -- * Setup + -- | To execute the code examples provided in this module in ghci, please + -- run the following commands first. + -- + -- $setup + -- * TCP Servers -- ** Streams - acceptOnAddr + accept + , acceptLocal + , acceptOnAddr , acceptOnAddrWith - , acceptOnPort - -- , acceptOnPortWith - , acceptOnPortLocal -- ** Unfolds + , acceptor + , acceptorLocal + , acceptorWith , acceptorOnAddr , acceptorOnAddrWith - , acceptorOnPort - , acceptorOnPortWith - , acceptorOnPortLocal -- * TCP clients -- | IP Address based operations. @@ -68,6 +73,7 @@ -- ** Transformation , pipeBytes + , pipeChunks {- -- ** Sink Servers @@ -89,6 +95,10 @@ , datagrams , datagramsOn -} + + -- * Deprecated + , acceptorOnPort + , acceptorOnPortLocal ) where @@ -106,13 +116,13 @@ import Streamly.Internal.Control.Concurrent (MonadAsync) import Streamly.Internal.Control.ForkLifted (fork) -import Streamly.Internal.Data.Array.Type (Array(..), writeNUnsafe) -import Streamly.Internal.Data.Fold.Type (Fold(..)) +import Streamly.Data.Array (Array) +import Streamly.Internal.Data.Fold ( Fold(..) ) import Streamly.Data.Stream (Stream) import Streamly.Internal.Data.Tuple.Strict (Tuple'(..)) -import Streamly.Internal.Data.Unboxed (Unbox) -import Streamly.Internal.Data.Unfold.Type (Unfold(..)) -import Streamly.Internal.Network.Socket (SockSpec(..), accept, acceptor) +import Streamly.Data.MutByteArray (Unbox) +import Streamly.Data.Unfold (Unfold) +import Streamly.Internal.Network.Socket (SockSpec(..)) import Streamly.Internal.System.IO (defaultChunkSize) import qualified Control.Monad.Catch as MC @@ -120,14 +130,22 @@ import qualified Streamly.Data.Array as A import qualified Streamly.Data.Fold as FL +import qualified Streamly.Data.Stream as S import qualified Streamly.Data.Unfold as UF -import qualified Streamly.Internal.Data.Array.Type as A -import qualified Streamly.Internal.Data.Unfold as UF (first, bracketIO) -import qualified Streamly.Internal.Data.Fold.Type as FL (Step(..), reduce) -import qualified Streamly.Internal.Data.Stream.StreamD as S -import qualified Streamly.Internal.Data.Stream.Exception.Lifted as S +import qualified Streamly.Internal.Data.Array as A + (chunksOf', unsafeCreateOf') +import qualified Streamly.Internal.Data.Unfold as UF (bracketIO) +import qualified Streamly.Internal.Data.Fold as FL (Step(..), reduce) + +import qualified Streamly.Internal.Data.Stream.Lifted as S (bracket) import qualified Streamly.Internal.Network.Socket as ISK +-- $setup +-- >>> :m +-- +-- >>> import qualified Streamly.Data.Unfold as Unfold +-- >>> import qualified Streamly.Network.Inet.TCP as TCP + ------------------------------------------------------------------------------- -- Accept (unfolds) ------------------------------------------------------------------------------- @@ -137,7 +155,7 @@ :: MonadIO m => [(SocketOption, Int)] -> Unfold m ((Word8, Word8, Word8, Word8), PortNumber) Socket -acceptorOnAddrWith opts = UF.lmap f acceptor +acceptorOnAddrWith opts = UF.lmap f ISK.acceptor where f (addr, port) = (maxListenQueue @@ -160,36 +178,50 @@ => Unfold m ((Word8, Word8, Word8, Word8), PortNumber) Socket acceptorOnAddr = acceptorOnAddrWith [] -{-# INLINE acceptorOnPortWith #-} -acceptorOnPortWith :: MonadIO m +{-# INLINE acceptorWith #-} +acceptorWith :: MonadIO m => [(SocketOption, Int)] -> Unfold m PortNumber Socket -acceptorOnPortWith opts = UF.first (0,0,0,0) (acceptorOnAddrWith opts) +acceptorWith opts = UF.first (0,0,0,0) (acceptorOnAddrWith opts) -- | Like 'acceptorOnAddr' 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. -- --- > acceptorOnPort = UF.first acceptorOnAddr (0,0,0,0) +-- >>> acceptor = Unfold.first (0,0,0,0) TCP.acceptorOnAddr -- +{-# INLINE acceptor #-} +acceptor :: MonadIO m => Unfold m PortNumber Socket +acceptor = UF.first (0,0,0,0) acceptorOnAddr + +{-# DEPRECATED acceptorOnPort "Use \"acceptor\" instead." #-} {-# INLINE acceptorOnPort #-} acceptorOnPort :: MonadIO m => Unfold m PortNumber Socket -acceptorOnPort = UF.first (0,0,0,0) acceptorOnAddr +acceptorOnPort = acceptor --- | Like 'acceptorOnAddr' 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. +-- | Like 'acceptor' 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. -- --- > acceptorOnPortLocal = UF.first acceptorOnAddr (127,0,0,1) +-- >>> acceptorLocal = Unfold.first (127,0,0,1) TCP.acceptorOnAddr -- +{-# INLINE acceptorLocal #-} +acceptorLocal :: MonadIO m => Unfold m PortNumber Socket +acceptorLocal = UF.first (127,0,0,1) acceptorOnAddr + +{-# DEPRECATED acceptorOnPortLocal "Use \"acceptorLocal\" instead." #-} {-# INLINE acceptorOnPortLocal #-} acceptorOnPortLocal :: MonadIO m => Unfold m PortNumber Socket -acceptorOnPortLocal = UF.first (127,0,0,1) acceptorOnAddr +acceptorOnPortLocal = acceptorLocal ------------------------------------------------------------------------------- -- Accept (streams) ------------------------------------------------------------------------------- +-- | Like 'acceptOnAddr' but with the ability to specify a list of socket +-- options. +-- +-- /Pre-release/ {-# INLINE acceptOnAddrWith #-} acceptOnAddrWith :: MonadIO m @@ -198,7 +230,7 @@ -> PortNumber -> Stream m Socket acceptOnAddrWith opts addr port = - accept maxListenQueue SockSpec + ISK.accept maxListenQueue SockSpec { sockFamily = AF_INET , sockType = Stream , sockProto = defaultProtocol @@ -206,9 +238,10 @@ } (SockAddrInet port (tupleToHostAddress addr)) --- | Like 'accept' but binds on the specified IPv4 address of the machine --- and listens for TCP connections on the specified port. +-- | Like 'accept' but binds on the specified IPv4 address. -- +-- >>> acceptOnAddr = TCP.acceptOnAddrWith [] +-- -- /Pre-release/ {-# INLINE acceptOnAddr #-} acceptOnAddr @@ -218,27 +251,27 @@ -> Stream m Socket acceptOnAddr = acceptOnAddrWith [] --- | Like 'accept' 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. +-- | Start a TCP stream server that binds on the IPV4 address @0.0.0.0@ and +-- listens for TCP connections from remote hosts on the specified server port. +-- The server generates a stream of connected sockets. -- --- > acceptOnPort = acceptOnAddr (0,0,0,0) +-- >>> accept = TCP.acceptOnAddr (0,0,0,0) -- -- /Pre-release/ -{-# INLINE acceptOnPort #-} -acceptOnPort :: MonadIO m => PortNumber -> Stream m Socket -acceptOnPort = acceptOnAddr (0,0,0,0) +{-# INLINE accept #-} +accept :: MonadIO m => PortNumber -> Stream m Socket +accept = acceptOnAddr (0,0,0,0) -- | Like 'accept' 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 = acceptOnAddr (127,0,0,1) +-- >>> acceptLocal = TCP.acceptOnAddr (127,0,0,1) -- -- /Pre-release/ -{-# INLINE acceptOnPortLocal #-} -acceptOnPortLocal :: MonadIO m => PortNumber -> Stream m Socket -acceptOnPortLocal = acceptOnAddr (127,0,0,1) +{-# INLINE acceptLocal #-} +acceptLocal :: MonadIO m => PortNumber -> Stream m Socket +acceptLocal = acceptOnAddr (127,0,0,1) ------------------------------------------------------------------------------- -- TCP Clients @@ -313,11 +346,11 @@ {-# INLINE reader #-} reader :: (MonadCatch m, MonadAsync m) => Unfold m ((Word8, Word8, Word8, Word8), PortNumber) Word8 -reader = UF.many A.reader (usingConnection ISK.chunkReader) +reader = UF.unfoldEach A.reader (usingConnection ISK.chunkReader) {-# INLINE concatChunks #-} concatChunks :: (Monad m, Unbox a) => Stream m (Array a) -> Stream m a -concatChunks = S.unfoldMany A.reader +concatChunks = S.unfoldEach A.reader -- | Read a stream from the supplied IPv4 host address and port number. -- @@ -355,7 +388,7 @@ => (Word8, Word8, Word8, Word8) -> PortNumber -> Fold m (Array Word8) () -writeChunks addr port = Fold step initial extract +writeChunks addr port = Fold step initial extract final where initial = do skt <- liftIO (connect addr port) @@ -365,12 +398,15 @@ step (Tuple' fld skt) x = do r <- FL.addOne x fld `MC.onException` liftIO (Net.close skt) return $ FL.Partial (Tuple' r skt) - extract (Tuple' (Fold _ initial1 extract1) skt) = do + + extract _ = return () + + final (Tuple' (Fold _ initial1 _ final1) skt) = do liftIO $ Net.close skt res <- initial1 case res of - FL.Partial fs -> extract1 fs - FL.Done fb -> return fb + FL.Partial fs -> final1 fs + FL.Done () -> return () -- | 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 @@ -385,7 +421,8 @@ -> PortNumber -> Stream m Word8 -> m () -putBytesWithBufferOf n addr port m = putChunks addr port $ A.chunksOf n m +putBytesWithBufferOf n addr port m = + putChunks addr port $ A.chunksOf' 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 @@ -399,7 +436,7 @@ -> PortNumber -> Fold m Word8 () writeWithBufferOf n addr port = - FL.groupsOf n (writeNUnsafe n) (writeChunks addr port) + FL.groupsOf n (A.unsafeCreateOf' n) (writeChunks addr port) -- | Write a stream to the supplied IPv4 host address and port number. -- @@ -425,19 +462,20 @@ :: (MonadCatch m, MonadAsync m) => (Word8, Word8, Word8, Word8) -> PortNumber - -> Stream m Word8 + -> Stream m a -> (Socket -> Stream m a) + -> (Socket -> Stream m a -> m ()) -> Stream m a -withInputConnect addr port input f = S.bracket pre post handler +withInputConnect addr port input fread fwrite = S.bracket pre post handler where pre = do sk <- liftIO $ connect addr port - tid <- fork (ISK.putBytes sk input) + tid <- fork (fwrite sk input) return (sk, tid) - handler (sk, _) = f sk + handler (sk, _) = fread sk -- XXX kill the thread immediately? post (sk, _) = liftIO $ Net.close sk @@ -455,4 +493,17 @@ -> PortNumber -> Stream m Word8 -> Stream m Word8 -pipeBytes addr port input = withInputConnect addr port input ISK.read +pipeBytes addr port input = withInputConnect addr port input ISK.read ISK.putBytes + +-- | This is similar to pipeBytes, but works on chunks of data. +-- +-- /Pre-release/ +-- +{-# INLINE pipeChunks #-} +pipeChunks + :: (MonadAsync m, MonadCatch m) + => (Word8, Word8, Word8, Word8) + -> PortNumber + -> Stream m (Array Word8) + -> Stream m (Array Word8) +pipeChunks addr port input = withInputConnect addr port input ISK.readChunks ISK.putChunks diff --git a/src/Streamly/Internal/Network/Socket.hs b/src/Streamly/Internal/Network/Socket.hs --- a/src/Streamly/Internal/Network/Socket.hs +++ b/src/Streamly/Internal/Network/Socket.hs @@ -11,7 +11,7 @@ -- module Streamly.Internal.Network.Socket ( - SockSpec (..) + SockSpec (..) -- * Use a socket , forSocketM , withSocket @@ -72,7 +72,7 @@ import Data.Maybe (isNothing, fromJust) import Data.Word (Word8) import Foreign.Ptr (plusPtr, Ptr, castPtr) -import Streamly.Internal.Data.Unboxed (Unbox) +import Streamly.Data.MutByteArray (Unbox) import Network.Socket (Socket, SocketOption(..), Family(..), SockAddr(..), ProtocolNumber, withSocketsDo, SocketType(..), socket, bind, @@ -86,26 +86,24 @@ import qualified Network.Socket as Net -import Streamly.Internal.Data.Array.Type (Array(..)) -import Streamly.Internal.Data.Stream.Chunked (lpackArraysChunksOf) -import Streamly.Internal.Data.Fold (Fold) -import Streamly.Internal.Data.Stream.StreamD.Type (Stream) -import Streamly.Internal.Data.Unfold.Type (Unfold(..)) +import Streamly.Internal.Data.Array (Array(..)) +import Streamly.Data.Fold (Fold) +import Streamly.Data.Stream (Stream) +import Streamly.Internal.Data.Unfold (Unfold(..)) -- import Streamly.String (encodeUtf8, decodeUtf8, foldLines) import Streamly.Internal.System.IO (defaultChunkSize) -import qualified Streamly.Data.Array as A (reader, length, writeN) +import qualified Streamly.Data.Array as A import qualified Streamly.Data.Fold as FL -import qualified Streamly.Internal.Data.Array.Type as A - (unsafeFreeze, asPtrUnsafe, byteLength, writeNUnsafe, chunksOf) -import qualified Streamly.Internal.Data.Array.Mut as MArray - (MutArray(..), newPinnedBytes, asPtrUnsafe) -import qualified Streamly.Internal.Data.Stream.StreamD as S -import qualified Streamly.Internal.Data.Stream.StreamD.Type as D - (Stream(..), Step(..)) +import qualified Streamly.Data.Stream as S import qualified Streamly.Data.Unfold as UF -import qualified Streamly.Internal.Data.Unfold as UF (first, map) -import qualified Streamly.Internal.Data.Stream.StreamK.Type as K (mkStream) +import qualified Streamly.Internal.Data.Array as A + ( unsafeFreeze, unsafePinnedAsPtr, chunksOf', + createOf', unsafeCreateOf, scanCompactMin ) +import qualified Streamly.Internal.Data.MutArray as MArray + (unsafeCreateWithPtr') +import qualified Streamly.Internal.Data.Stream as S (fromStreamK, Stream(..), Step(..)) +import qualified Streamly.Internal.Data.StreamK as K (mkStream) -- $setup -- >>> :m @@ -140,6 +138,9 @@ -- XXX Protocol specific socket options should be separated from socket level -- options. -- +-- NOTE: the socket config is specified as a record and not by composing +-- functions because all the fields are mandatory except the sockOpts field. + -- | Specify the socket protocol details. data SockSpec = SockSpec { @@ -173,7 +174,7 @@ step listener = do r <- liftIO (Net.accept listener `onException` Net.close listener) - return $ D.Yield r listener + return $ S.Yield r listener -- | Unfold a three tuple @(listenQLen, spec, addr)@ into a stream of connected -- protocol sockets corresponding to incoming connections. @listenQLen@ is the @@ -183,7 +184,7 @@ -- {-# INLINE acceptor #-} acceptor :: MonadIO m => Unfold m (Int, SockSpec, SockAddr) Socket -acceptor = UF.map fst listenTuples +acceptor = fmap fst listenTuples {-# INLINE connectCommon #-} connectCommon :: SockSpec -> Maybe SockAddr -> SockAddr -> IO Socket @@ -251,6 +252,8 @@ -- Array IO (Input) ------------------------------------------------------------------------------- +-- XXX add an API that compacts the arrays to an exact size. + {-# INLINABLE readArrayUptoWith #-} readArrayUptoWith :: (h -> Ptr Word8 -> Int -> IO Int) @@ -258,16 +261,10 @@ -> h -> IO (Array Word8) readArrayUptoWith f size h = do - arr <- MArray.newPinnedBytes size - -- ptr <- mallocPlainForeignPtrAlignedBytes size (alignment (undefined :: Word8)) - MArray.asPtrUnsafe arr $ \p -> do - n <- f h p size - let v = A.unsafeFreeze - $ arr { MArray.arrEnd = n, MArray.arrBound = size } - - -- XXX shrink only if the diff is significant - -- A.shrinkToFit v - return v + arr <- MArray.unsafeCreateWithPtr' size $ \p -> f h p size + -- XXX shrink only if the diff is significant + -- unsafeFreezeWithShrink + pure $ A.unsafeFreeze arr -- | Read a byte array from a file handle up to a maximum of the requested -- size. If no data is available on the handle it blocks until some data @@ -308,11 +305,8 @@ -> Array a -> IO () writeArrayWith _ _ arr | A.length arr == 0 = return () -writeArrayWith f h arr = A.asPtrUnsafe arr $ \ptr -> f h (castPtr ptr) aLen - - where - - aLen = A.byteLength arr +writeArrayWith f h arr = + A.unsafePinnedAsPtr arr $ \ptr byteLen -> f h (castPtr ptr) byteLen -- | Write an Array to a socket. -- @@ -344,15 +338,15 @@ {-# INLINE_NORMAL readChunksWith #-} readChunksWith :: MonadIO m => Int -> Socket -> Stream m (Array Word8) -- readChunksWith = _readChunksUptoWith readChunk -readChunksWith size h = D.Stream step () +readChunksWith size h = S.Stream step () where {-# INLINE_LATE step #-} step _ _ = do arr <- liftIO $ getChunk size h return $ case A.length arr of - 0 -> D.Stop - _ -> D.Yield arr () + 0 -> S.Stop + _ -> S.Yield arr () -- | Read a stream of byte arrays from a socket. The maximum size of a single -- array is limited to @defaultChunkSize@. @@ -378,8 +372,8 @@ arr <- liftIO $ getChunk size h return $ case A.length arr of - 0 -> D.Stop - _ -> D.Yield arr (size, h) + 0 -> S.Stop + _ -> S.Yield arr (size, h) -- | Same as 'chunkReaderWith' -- @@ -404,7 +398,7 @@ {-# INLINE concatChunks #-} concatChunks :: (Monad m, Unbox a) => Stream m (Array a) -> Stream m a -concatChunks = S.unfoldMany A.reader +concatChunks = S.unfoldEach A.reader -- | Generate a byte stream from a socket using a buffer of the given size. -- @@ -427,7 +421,7 @@ -- {-# INLINE readerWith #-} readerWith :: MonadIO m => Unfold m (Int, Socket) Word8 -readerWith = UF.many A.reader chunkReaderWith +readerWith = UF.unfoldEach A.reader chunkReaderWith -- | Same as 'readWith' -- @@ -471,7 +465,10 @@ {-# INLINE writeChunksWith #-} writeChunksWith :: (MonadIO m, Unbox a) => Int -> Socket -> Fold m (Array a) () -writeChunksWith n h = lpackArraysChunksOf n (writeChunks h) +-- writeChunksWith n h = A.lCompactBySizeGE n (writeChunks h) +writeChunksWith n h = + FL.postscanl (A.scanCompactMin n) + $ FL.catMaybes (writeChunks h) -- | Same as 'writeChunksWith' -- @@ -495,14 +492,14 @@ -- {-# INLINE putBytesWith #-} putBytesWith :: MonadIO m => Int -> Socket -> Stream m Word8 -> m () -putBytesWith n h m = putChunks h $ A.chunksOf n m +putBytesWith n h m = putChunks h $ A.chunksOf' n m -- | Write a byte stream to a socket. Accumulates the input in chunks of -- specified number of bytes before writing. -- {-# INLINE writeWith #-} writeWith :: MonadIO m => Int -> Socket -> Fold m Word8 () -writeWith n h = FL.groupsOf n (A.writeNUnsafe n) (writeChunks h) +writeWith n h = FL.groupsOf n (A.unsafeCreateOf n) (writeChunks h) -- | Same as 'writeWith' -- @@ -520,7 +517,7 @@ writeMaybesWith :: (MonadIO m ) => Int -> Socket -> Fold m (Maybe Word8) () writeMaybesWith n h = - let writeNJusts = FL.lmap fromJust $ A.writeN n + let writeNJusts = FL.lmap fromJust $ A.createOf' n writeOnNothing = FL.takeEndBy_ isNothing writeNJusts in FL.many writeOnNothing (writeChunks h) diff --git a/src/Streamly/Internal/System/IOVec.hs b/src/Streamly/Internal/System/IOVec.hs --- a/src/Streamly/Internal/System/IOVec.hs +++ b/src/Streamly/Internal/System/IOVec.hs @@ -30,13 +30,13 @@ import Control.Monad (when) import Control.Monad.IO.Class (MonadIO(..)) import Foreign.Ptr (castPtr) -import Streamly.Internal.Data.Array.Mut.Type (length) +import Streamly.Internal.Data.MutArray (length) import Streamly.Internal.Data.SVar.Type (adaptState) -import Streamly.Internal.Data.Array.Mut.Type (Array(..)) +import Streamly.Internal.Data.MutArray (Array(..)) -import qualified Streamly.Internal.Data.Array.Type as Array -import qualified Streamly.Internal.Data.Array.Mut.Type as MArray -import qualified Streamly.Internal.Data.Stream.StreamD as D +import qualified Streamly.Internal.Data.Array as Array +import qualified Streamly.Internal.Data.MutArray.Type as MArray +import qualified Streamly.Internal.Data.Stream as D -} #endif @@ -69,11 +69,11 @@ step' gst (GatherInitial st) = do when (n <= 0) $ -- XXX we can pass the module string from the higher level API - error $ "Streamly.Internal.Data.Array.Mut.Type.groupIOVecsOf: the size of " + error $ "Streamly.Internal.Data.MutArray.Type.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.Data.Array.Mut.Type.groupIOVecsOf: the number of " + error $ "Streamly.Internal.Data.MutArray.Type.groupIOVecsOf: the number of " ++ "IOVec entries [" ++ show n ++ "] must be a natural number" r <- step (adaptState gst) st case r of diff --git a/src/Streamly/Internal/Unicode/Char.hs b/src/Streamly/Internal/Unicode/Char.hs --- a/src/Streamly/Internal/Unicode/Char.hs +++ b/src/Streamly/Internal/Unicode/Char.hs @@ -7,6 +7,10 @@ -- Stability : experimental -- Portability : GHC +-- XXX We are using head/tail at one place +#if __GLASGOW_HASKELL__ >= 908 +{-# OPTIONS_GHC -Wno-x-partial #-} +#endif -- XXX This module should have the reader/writer unfold/refold and read/write -- stream/fold routines to convert a char to/from stream. -- @@ -35,9 +39,7 @@ import Data.Char (isAsciiUpper, isAsciiLower, chr, ord) import Unicode.Char (DecomposeMode(..)) -import Streamly.Internal.Data.Stream.StreamD (Stream(..), Step (..)) - -import qualified Streamly.Internal.Data.Stream.StreamD as Stream (Stream) +import Streamly.Internal.Data.Stream (Stream(..), Step (..)) import qualified Unicode.Char as Char @@ -225,13 +227,13 @@ Stop -> Skip $ YieldList rbuf ComposeStop {-# INLINE initHangul #-} - initHangul c st = ComposeJamo (Hangul c) st + initHangul c = ComposeJamo (Hangul c) {-# INLINE initJamo #-} - initJamo c st = ComposeJamo (Jamo c) st + initJamo c = ComposeJamo (Jamo c) {-# INLINE initReg #-} - initReg !c st = ComposeReg 0 [c] st + initReg !c = ComposeReg 0 [c] {-# INLINE composeNone #-} composeNone ch st @@ -321,6 +323,6 @@ normalize :: Monad m => NormalizationMode - -> Stream.Stream m Char - -> Stream.Stream m Char + -> Stream m Char + -> Stream m Char normalize = normalizeD diff --git a/src/Streamly/Memory/Array.hs b/src/Streamly/Memory/Array.hs deleted file mode 100644 --- a/src/Streamly/Memory/Array.hs +++ /dev/null @@ -1,74 +0,0 @@ -#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 be --- 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.Data.Array". - -module Streamly.Memory.Array - {-# DEPRECATED "Use Streamly.Data.Array.Foreign instead" #-} - ( - 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.Data.Array as A diff --git a/src/Streamly/Network/Inet/TCP.hs b/src/Streamly/Network/Inet/TCP.hs --- a/src/Streamly/Network/Inet/TCP.hs +++ b/src/Streamly/Network/Inet/TCP.hs @@ -7,18 +7,52 @@ -- Stability : released -- Portability : GHC -- --- Combinators to build Inet/TCP clients and servers. +-- Combinators to build Inet\/IPv4/TCP clients and servers. -- -- >>> import qualified Streamly.Network.Inet.TCP as TCP -- +-- = Examples +-- +-- Following is a short example of a concurrent echo server. +-- +-- >>> import Control.Monad.Catch (finally) +-- >>> import Data.Function ((&)) +-- >>> import Network.Socket (Socket) +-- >>> +-- >>> import qualified Network.Socket as Net +-- >>> import qualified Streamly.Data.Fold as Fold +-- >>> import qualified Streamly.Data.Stream.Prelude as Stream +-- >>> import qualified Streamly.Network.Inet.TCP as TCP +-- >>> import qualified Streamly.Network.Socket as Socket +-- >>> +-- >>> :{ +-- main :: IO () +-- main = +-- TCP.accept 8091 -- Stream IO Socket +-- & Stream.parMapM id (handleExceptions echo) -- Stream IO () +-- & Stream.fold Fold.drain -- IO () +-- where +-- echo :: Socket -> IO () +-- echo sk = +-- Socket.readChunksWith 32768 sk -- Stream IO (Array Word8) +-- & Stream.fold (Socket.writeChunks sk) -- IO () +-- handleExceptions :: (Socket -> IO ()) -> Socket -> IO () +-- handleExceptions f sk = finally (f sk) (Net.close sk) +-- :} module Streamly.Network.Inet.TCP ( -- * Accept Connections + -- ** Streams + accept + , acceptLocal + , acceptOnAddr + , acceptOnAddrWith + -- ** Unfolds - acceptorOnAddr - , acceptorOnPort - , acceptorOnPortLocal + , acceptor + , acceptorLocal + , acceptorOnAddr -- * Connect to Servers , connect @@ -48,34 +82,11 @@ , datagrams , datagramsOn -} + -- * Deprecated - , acceptOnAddr - , acceptOnPort - , acceptOnPortLocal + , acceptorOnPort + , acceptorOnPortLocal ) where -import Control.Monad.IO.Class (MonadIO(..)) -import Data.Word (Word8) -import Network.Socket (Socket, PortNumber) -import Streamly.Internal.Data.Unfold.Type (Unfold(..)) - import Streamly.Internal.Network.Inet.TCP - hiding (acceptOnAddr, acceptOnPort, acceptOnPortLocal) - -{-# DEPRECATED acceptOnAddr "Please use 'acceptorOnAddr' instead" #-} -{-# INLINE acceptOnAddr #-} -acceptOnAddr - :: MonadIO m - => Unfold m ((Word8, Word8, Word8, Word8), PortNumber) Socket -acceptOnAddr = acceptorOnAddr - -{-# DEPRECATED acceptOnPort "Please use 'acceptorOnPort' instead" #-} -{-# INLINE acceptOnPort #-} -acceptOnPort :: MonadIO m => Unfold m PortNumber Socket -acceptOnPort = acceptorOnPort - -{-# DEPRECATED acceptOnPortLocal "Please use 'acceptorOnPortLocal' instead" #-} -{-# INLINE acceptOnPortLocal #-} -acceptOnPortLocal :: MonadIO m => Unfold m PortNumber Socket -acceptOnPortLocal = acceptorOnPortLocal diff --git a/src/Streamly/Network/Socket.hs b/src/Streamly/Network/Socket.hs --- a/src/Streamly/Network/Socket.hs +++ b/src/Streamly/Network/Socket.hs @@ -10,13 +10,13 @@ -- This module provides socket based streaming APIs to to receive connections -- from remote hosts, and to read and write from and to network sockets. -- --- For basic socket types and operations please consult the @Network.Socket@ +-- For basic socket types and non-streaming operations please consult the @Network.Socket@ -- module of the package. -- -- = Examples -- --- To write a server, use the 'acceptor' unfold to start listening for --- connections from clients. 'acceptor' generates a stream of connected +-- To write a server, use the 'accept' stream to start listening for +-- connections from clients. 'accept' generates a stream of connected -- sockets. We can map an effectful action on this socket stream to handle the -- connections. The action would typically use socket reading and writing -- operations to communicate with the remote host. We can read/write a stream @@ -33,7 +33,6 @@ -- >>> import Streamly.Network.Socket (SockSpec(..)) -- >>> -- >>> import qualified Streamly.Data.Fold as Fold --- >>> import qualified Streamly.Data.Stream as Stream -- >>> import qualified Streamly.Data.Stream.Prelude as Stream -- >>> import qualified Streamly.Network.Socket as Socket -- >>> @@ -50,11 +49,11 @@ -- in server spec addr -- where -- server spec addr = --- Stream.unfold Socket.acceptor (maxListenQueue, spec, addr) +-- Socket.accept maxListenQueue spec addr -- & Stream.parMapM (Stream.eager True) (Socket.forSocketM echo) -- & Stream.fold Fold.drain -- echo sk = --- Stream.unfold Socket.chunkReader sk -- Stream IO (Array Word8) +-- Socket.readChunks sk -- Stream IO (Array Word8) -- & Stream.fold (Socket.writeChunks sk) -- IO () -- :} -- @@ -95,12 +94,19 @@ SockSpec(..) -- * Accept Connections + , accept , acceptor -- * Reads -- ** Singleton , getChunk + -- ** Streams + , read + , readWith + , readChunks + , readChunksWith + -- ** Unfolds , reader , readerWith @@ -121,33 +127,23 @@ , forSocketM -- * Deprecated - , accept , readChunk , writeChunk - , read , readWithBufferOf - , readChunks , readChunksWithBufferOf , writeWithBufferOf , writeChunksWithBufferOf ) where -import Control.Monad.IO.Class (MonadIO(..)) import Data.Word (Word8) -import Network.Socket (Socket, SockAddr) -import Streamly.Internal.Data.Unfold.Type (Unfold(..)) -import Streamly.Internal.Data.Array.Type (Array(..)) -import Streamly.Internal.Data.Unboxed (Unbox) +import Network.Socket (Socket) +import Streamly.Data.Array (Array) +import Streamly.Data.MutByteArray (Unbox) -import Streamly.Internal.Network.Socket hiding (accept, read, readChunks) +import Streamly.Internal.Network.Socket import Prelude hiding (read) -{-# DEPRECATED accept "Please use 'acceptor' instead" #-} -{-# INLINE accept #-} -accept :: MonadIO m => Unfold m (Int, SockSpec, SockAddr) Socket -accept = acceptor - {-# DEPRECATED readChunk "Please use 'getChunk' instead" #-} {-# INLINABLE readChunk #-} readChunk :: Int -> Socket -> IO (Array Word8) @@ -157,13 +153,3 @@ {-# INLINABLE writeChunk #-} writeChunk :: Unbox a => Socket -> Array a -> IO () writeChunk = putChunk - -{-# DEPRECATED read "Please use 'reader' instead" #-} -{-# INLINE read #-} -read :: MonadIO m => Unfold m Socket Word8 -read = reader - -{-# DEPRECATED readChunks "Please use 'chunkReader' instead" #-} -{-# INLINE readChunks #-} -readChunks :: MonadIO m => Unfold m Socket (Array Word8) -readChunks = chunkReader diff --git a/src/Streamly/Prelude.hs b/src/Streamly/Prelude.hs --- a/src/Streamly/Prelude.hs +++ b/src/Streamly/Prelude.hs @@ -943,10 +943,10 @@ import Streamly.Internal.Control.Concurrent (MonadAsync) 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, (!!), + hiding (Foldable(..), filter, drop, dropWhile, take, takeWhile, zipWith, + map, mapM, mapM_, sequence, all, any, + notElem, head, last, tail, + reverse, iterate, init, and, or, lookup, (!!), scanl, scanl1, repeat, replicate, concatMap, span) import Streamly.Internal.Data.Stream.IsStream diff --git a/src/config.h.in b/src/config.h.in --- a/src/config.h.in +++ b/src/config.h.in @@ -1,27 +1,27 @@ /* src/config.h.in. Generated from configure.ac by autoheader. */ -/* Define to 1 if you have the declaration of `IN_EXCL_UNLINK', and to 0 if +/* Define to 1 if you have the declaration of 'IN_EXCL_UNLINK', and to 0 if you don't. */ #undef HAVE_DECL_IN_EXCL_UNLINK -/* Define to 1 if you have the declaration of `IN_MASK_CREATE', and to 0 if +/* Define to 1 if you have the declaration of 'IN_MASK_CREATE', and to 0 if you don't. */ #undef HAVE_DECL_IN_MASK_CREATE /* Define to 1 if you have the declaration of - `kFSEventStreamCreateFlagFileEvents', and to 0 if you don't. */ + 'kFSEventStreamCreateFlagFileEvents', and to 0 if you don't. */ #undef HAVE_DECL_KFSEVENTSTREAMCREATEFLAGFILEEVENTS /* Define to 1 if you have the declaration of - `kFSEventStreamCreateFlagFullHistory', and to 0 if you don't. */ + 'kFSEventStreamCreateFlagFullHistory', and to 0 if you don't. */ #undef HAVE_DECL_KFSEVENTSTREAMCREATEFLAGFULLHISTORY /* Define to 1 if you have the declaration of - `kFSEventStreamEventFlagItemCloned', and to 0 if you don't. */ + 'kFSEventStreamEventFlagItemCloned', and to 0 if you don't. */ #undef HAVE_DECL_KFSEVENTSTREAMEVENTFLAGITEMCLONED /* Define to 1 if you have the declaration of - `kFSEventStreamEventFlagItemIsHardlink', and to 0 if you don't. */ + 'kFSEventStreamEventFlagItemIsHardlink', and to 0 if you don't. */ #undef HAVE_DECL_KFSEVENTSTREAMEVENTFLAGITEMISHARDLINK /* Define to the address where bug reports for this package should be sent. */ diff --git a/src/deprecation.h b/src/deprecation.h new file mode 100644 --- /dev/null +++ b/src/deprecation.h @@ -0,0 +1,9 @@ +#define RENAME(_old, _new) \ +{-# DEPRECATED _old "Please use _new instead." #-}; \ +{-# INLINE _old #-}; \ +_old = _new + +#define RENAME_PRIME(_old, _new) \ +{-# DEPRECATED _old "Please use _new' instead." #-}; \ +{-# INLINE _old #-}; \ +_old = _new' diff --git a/src/doctest/DocTestDataFold.hs b/src/doctest/DocTestDataFold.hs new file mode 100644 --- /dev/null +++ b/src/doctest/DocTestDataFold.hs @@ -0,0 +1,19 @@ +{- $setup +>>> :m +>>> :set -XFlexibleContexts +>>> import Control.Concurrent (threadDelay) +>>> import Data.List (sortOn) +>>> import Data.HashMap.Strict (HashMap) + +>>> import Streamly.Data.Fold (Fold) +>>> import Streamly.Data.Stream (Stream) + +>>> import qualified Data.HashMap.Strict as HM +>>> import qualified Streamly.Data.Fold.Prelude as Fold +>>> import qualified Streamly.Data.Stream.Prelude as Stream + +For APIs that have not been released yet. + +>>> import qualified Streamly.Internal.Data.Fold as Fold +>>> import qualified Streamly.Internal.Data.Fold.Prelude as Fold +-} diff --git a/src/doctest/DocTestDataScanl.hs b/src/doctest/DocTestDataScanl.hs new file mode 100644 --- /dev/null +++ b/src/doctest/DocTestDataScanl.hs @@ -0,0 +1,7 @@ +{- $setup +>>> :m +>>> :set -XFlexibleContexts +>>> import Control.Concurrent (threadDelay) +>>> import qualified Streamly.Data.Stream as Stream +>>> import qualified Streamly.Data.Scanl.Prelude as Scanl +-} diff --git a/streamly.cabal b/streamly.cabal --- a/streamly.cabal +++ b/streamly.cabal @@ -1,42 +1,45 @@ -cabal-version: 2.2 +cabal-version: 2.4 name: streamly -version: 0.9.0 -synopsis: Streaming, dataflow programming and declarative concurrency +version: 0.11.1 +synopsis: Streaming data pipelines with declarative concurrency description: - Streamly comprises two packages, the - package - provides functionality that depends only on boot libraries, and - the package - provides additional functionality like concurrency, time, lifted - exceptions, and networking. For unified documentation visit - . + For upgrading to streamly-0.9.0+ please read the + . . - Streamly provides unified, modular building blocks to build - high-performance, concurrent, scalable applications in Haskell. Stream - fusion optimizations in streamly enable exceptional modularity with - high performance comparable to C. Streamly complements the Haskell - package, supplying the - missing functionality to quickly build general-purpose applications - in Haskell. For high-level functionality built over streamly like - streaming system processes, shell programming, GNU coreutils, - statistics, and compression libraries please see the - . + Streamly is a high-performance, beginner-friendly standard library + for Haskell. It unifies streaming with list transformers and logic + programming; unifies streaming with concurrency and reactive + programming; unifies arrays with ring arrays, text, bytestring + and vector use cases; unifies arrays with builders and binary + serialization; generalizes parsers to any input type and unifies + attoparsec, parsec use cases with better performance; provides + streaming fileIO — all with a clean, consistent, well-integrated and + streaming enabled API. . - Performance with modularity: + Streams are designed to have a list like interface — no steep + learning curve, no complex types. Streamly is designed to build + general purpose applications in a truly functional manner, from + simple hello-world to advanced high-performance systems. The design + emphasizes simplicity, modularity, and code reuse with minimal + building blocks. Performance is on par with C, tuning is easy, and + it’s hard to get it wrong. . - * Performance on par with C () - * API close to standard Haskell lists () - * Declarative concurrency with automatic scaling - * Filesystem, fsnotify, network, and Unicode support included - * More functionality is provided via many () + Streamly is serial by default, with seamless declarative concurrency + that scales automatically when needed. It provides prompt and safe + resource management, works well with other streaming libraries as well + as core libraries like bytestring and text, and is backed by solid + documentation. . - Unified and powerful abstractions: + The @streamly@ package is built on top of the @streamly-core@ package + and offers high-level capabilities such as concurrency, reactive + programming, time-related combinators, lifted exceptions, and + networking. It provides streaming with concurrency, and is a more + powerful, higher-level and more expressive alternative to the @async@ + package. . - * Unifies streams, arrays, folds, and parsers - * Unifies @Data.List@, @list-t@, and @logict@ with streaming - * Unifies concurrency with standard streaming abstractions - * Unifies reactive, time-domain programming with streaming - * Interworks with other streaming libraries + Performant. Unified. Modular. Powerful. Simple. + . + Learn more at . homepage: https://streamly.composewell.com bug-reports: https://github.com/composewell/streamly/issues @@ -46,8 +49,13 @@ , GHC==8.8.4 , GHC==8.10.7 , GHC==9.0.2 - , GHC==9.2.7 - , GHC==9.4.4 + , GHC==9.2.8 + , GHC==9.4.7 + , GHC==9.6.3 + , GHC==9.8.1 + , GHC==9.10.3 + , GHC==9.12.4 + , GHC==9.14.1 author: Composewell Technologies maintainer: streamly@composewell.com copyright: 2017 Composewell Technologies @@ -59,21 +67,26 @@ build-type: Configure extra-source-files: + bench-test-lib/bench-test-lib.cabal + bench-test-lib/src/BenchTestLib/DirIO.hs benchmark/*.hs benchmark/bench-runner/Main.hs benchmark/bench-runner/bench-runner.cabal benchmark/Streamly/Benchmark/Data/*.hs + benchmark/Streamly/Benchmark/Data/Scanl/*.hs + benchmark/Streamly/Benchmark/Data/Fold/*.hs + benchmark/Streamly/Benchmark/Data/Serialize/*.hs benchmark/Streamly/Benchmark/Data/Array/Common.hs benchmark/Streamly/Benchmark/Data/Array/CommonImports.hs benchmark/Streamly/Benchmark/Data/Array/Generic.hs benchmark/Streamly/Benchmark/Data/Array/SmallArray.hs benchmark/Streamly/Benchmark/Data/Array.hs - benchmark/Streamly/Benchmark/Data/Ring/Unboxed.hs - benchmark/Streamly/Benchmark/Data/Array/Mut.hs + benchmark/Streamly/Benchmark/Data/RingArray.hs + benchmark/Streamly/Benchmark/Data/MutArray.hs benchmark/Streamly/Benchmark/Data/Array/Stream.hs benchmark/Streamly/Benchmark/Data/Fold/Window.hs - benchmark/Streamly/Benchmark/Data/Parser/*.hs benchmark/Streamly/Benchmark/Data/Stream/*.hs + benchmark/Streamly/Benchmark/Data/StreamK/*.hs benchmark/Streamly/Benchmark/FileSystem/*.hs benchmark/Streamly/Benchmark/FileSystem/Handle/*.hs benchmark/Streamly/Benchmark/Prelude/*.hs @@ -85,8 +98,7 @@ bin/mk-tags.sh configure configure.ac - docs/*.hs - docs/streamly-docs.cabal + src/doctest/*.hs targets/streamly-targets.cabal targets/Targets.hs test/test-runner/Main.hs @@ -94,42 +106,49 @@ -- This is duplicated src/Streamly/Internal/Data/Stream/Instances.hs - src/Streamly/Internal/Data/Array/ArrayMacros.h src/Streamly/Internal/FileSystem/Event/Darwin.h src/assert.hs src/config.h.in src/inline.hs + src/deprecation.h test/Streamly/Test/Data/*.hs test/Streamly/Test/Data/Array/CommonImports.hs test/Streamly/Test/Data/Array/Common.hs test/Streamly/Test/Data/Array/Generic.hs test/Streamly/Test/Data/Array.hs - test/Streamly/Test/Data/Array/Mut.hs - test/Streamly/Test/Data/Ring/Unboxed.hs + test/Streamly/Test/Data/MutArray.hs + test/Streamly/Test/Data/RingArray.hs test/Streamly/Test/Data/Array/Stream.hs - test/Streamly/Test/Data/Parser/ParserD.hs - test/Streamly/Test/Data/Stream/Concurrent.hs + test/Streamly/Test/Data/Parser.hs + test/Streamly/Test/Data/Parser/*.hs + test/Streamly/Test/Data/ParserK.hs + test/Streamly/Test/Data/Stream/*.hs test/Streamly/Test/FileSystem/Event.hs test/Streamly/Test/FileSystem/Event/Common.hs test/Streamly/Test/FileSystem/Event/Darwin.hs test/Streamly/Test/FileSystem/Event/Windows.hs test/Streamly/Test/FileSystem/Event/Linux.hs - test/Streamly/Test/FileSystem/Handle.hs + test/Streamly/Test/FileSystem/*.hs test/Streamly/Test/Network/Socket.hs test/Streamly/Test/Network/Inet/TCP.hs test/Streamly/Test/Prelude.hs test/Streamly/Test/Prelude/*.hs test/Streamly/Test/Unicode/*.hs test/Streamly/Test/Serialize/*.hs + test/Streamly/Test/Data/Scanl/*.hs test/Streamly/Test/Data/Fold/*.hs test/lib/Streamly/Test/Common.hs test/lib/Streamly/Test/Prelude/Common.hs + test/lib/Streamly/Test/Parser/Common.hs test/streamly-tests.cabal test/version-bounds.hs test/Streamly/Test/Unicode/ucd/NormalizationTest.txt test/Streamly/Test/Unicode/extra/NormalizationTest.txt test/Streamly/Test/Data/Unbox.hs + test/Streamly/Test/Data/Unbox/*.hs + test/Streamly/Test/Data/Serialize.hs + test/Streamly/Test/Data/Serialize/*.hs benchmark/Streamly/Benchmark/Unicode/data/AllChars.txt benchmark/Streamly/Benchmark/Unicode/data/Devanagari.txt benchmark/Streamly/Benchmark/Unicode/data/Japanese.txt @@ -143,29 +162,25 @@ CHANGELOG.md README.md benchmark/README.md - docs/Developer/Benchmarks.md - docs/Developer/*.png + docs/*.md + docs/diagrams/module-diagram.hs + docs/Developer/*.link docs/Developer/*.md - docs/Developer/*.rst docs/Developer/*.png - docs/Developer/*.md docs/Developer/*.rst - docs/Developer/*.link docs/User/*.md - docs/User/Tutorials/*.md - docs/User/Tutorials/*.link - docs/User/Tutorials/*.hs - docs/User/HowTo/*.md - docs/User/HowTo/*.link - docs/User/HowTo/*.svg docs/User/Explanatory/*.md docs/User/Explanatory/streaming-pradigms.rst - docs/User/ProjectRelated/*.md - docs/User/ProjectRelated/*.link - docs/User/ProjectRelated/ApiChangelogs/0.8.3-0.9.0.txt - docs/User/ProjectRelated/ApiChangelogs/0.8.3.txt + docs/User/HowTo/*.md + docs/User/HowTo/*.svg + docs/User/Project/*.link + docs/User/Project/*.md + docs/User/Project/ApiChangelogs/*.txt + docs/User/Tutorials/*.md + docs/User/Tutorials/*.link + docs/User/Tutorials/*.svg + docs/User/Tutorials/all-your-base.jpg test/README.md - docs/Developer/Tests.md extra-tmp-files: config.log @@ -192,8 +207,8 @@ manual: True default: False -flag dev - description: Development build +flag internal-dev + description: DO NOT USE, ONLY FOR INTERNAL USE. manual: True default: False @@ -212,8 +227,8 @@ manual: True default: False -flag use-unliftio - description: Use unliftio-core instead of monad-control +flag internal-use-unliftio + description: DO NOT USE, ONLY FOR INTERNAL USE. manual: True default: False @@ -222,8 +237,6 @@ ------------------------------------------------------------------------------- common compile-options - default-language: Haskell2010 - if os(darwin) cpp-options: -DCABAL_OS_DARWIN @@ -233,7 +246,7 @@ if os(windows) cpp-options: -DCABAL_OS_WINDOWS - if flag(dev) + if flag(internal-dev) cpp-options: -DDEVBUILD if flag(inspection) @@ -259,24 +272,45 @@ -Wno-redundant-bang-patterns -Wno-operator-whitespace + if impl(ghc >= 9.8) + ghc-options: + -Wno-missing-role-annotations + if flag(has-llvm) ghc-options: -fllvm - if flag(dev) + if flag(internal-dev) ghc-options: -Wmissed-specialisations -Wall-missed-specialisations if flag(limit-build-mem) ghc-options: +RTS -M1000M -RTS - if flag(use-unliftio) + if flag(internal-use-unliftio) cpp-options: -DUSE_UNLIFTIO common default-extensions + default-language: Haskell2010 + + -- GHC2024 may include more extensions than we are actually using, see the + -- full list below. We enable this to ensure that we are able to compile + -- with this i.e. there is no interference by other extensions. + + -- Don't enforce GHC2024 and GHC2021 but We can support the build with them. + + -- if impl(ghc >= 9.10) + -- default-language: GHC2024 + + -- if impl(ghc >= 9.2) && impl(ghc < 9.10) + -- default-language: GHC2021 + + if impl(ghc >= 8.10) + default-extensions: + StandaloneKindSignatures + + -- In GHC 2024 default-extensions: BangPatterns - CApiFFI - CPP ConstraintKinds DeriveDataTypeable DeriveGeneric @@ -288,26 +322,38 @@ InstanceSigs KindSignatures LambdaCase - MagicHash MultiParamTypeClasses - PatternSynonyms RankNTypes - RecordWildCards ScopedTypeVariables TupleSections TypeApplications - TypeFamilies TypeOperators - ViewPatterns - -- MonoLocalBinds, enabled by TypeFamilies, causes performance - -- regressions. Disable it. This must come after TypeFamilies, - -- otherwise TypeFamilies will enable it again. - NoMonoLocalBinds + -- Not in GHC2024 + default-extensions: + CApiFFI + CPP + MagicHash + RecordWildCards + -- TypeFamilies -- required by IsHashMap type class + + -- MonoLocalBinds, enabled by TypeFamilies and GHC2024, was + -- once found to cause runtime performance regressions which + -- does not seem to be the case anymore, but need more testing + -- to confirm. It is confirmed that it requires more memory + -- for compilation at least in some cases (Data.Fold.Window + -- benchmark on GHC-9.10.1 macOS). Disabling this must come + -- after TypeFamilies, otherwise TypeFamilies will enable it + -- again. + -- NoMonoLocalBinds + -- UndecidableInstances -- Does not show any perf impact -- UnboxedTuples -- interferes with (#.) + if impl(ghc >= 8.6) + default-extensions: QuantifiedConstraints + common optimization-options if flag(opt) ghc-options: -O2 @@ -316,8 +362,9 @@ -fmax-worker-args=16 -- For this to be effective it must come after the -O2 option - if flag(dev) || flag(debug) || !flag(opt) + if flag(internal-dev) || flag(debug) || !flag(opt) ghc-options: -fno-ignore-asserts + cpp-options: -DDEBUG common threading-options ghc-options: -threaded @@ -339,22 +386,19 @@ library import: lib-options - if impl(ghc >= 8.6) - default-extensions: QuantifiedConstraints - include-dirs: src + , src/doctest , src/Streamly/Internal/Data/Stream - , src/Streamly/Internal/Data/Array hs-source-dirs: src exposed-modules: -- Internal modules, listed roughly in bottom up -- dependency order To view dependency graph: -- graphmod | dot -Tps > deps.ps - Streamly.Internal.Data.IsMap.HashMap , Streamly.Internal.Data.Cont + , Streamly.Internal.Data.Channel , Streamly.Internal.Data.Stream.MkType -- streamly-concurrent @@ -362,27 +406,11 @@ , Streamly.Internal.Control.ForkLifted , Streamly.Internal.Data.Atomics , Streamly.Internal.Data.IOFinalizer.Lifted - , Streamly.Internal.Data.Stream.Channel.Types - , Streamly.Internal.Data.Stream.Channel.Dispatcher - , Streamly.Internal.Data.Stream.Channel.Worker - , Streamly.Internal.Data.Unfold.Exception - , Streamly.Internal.Data.Fold.Concurrent.Channel.Type - , Streamly.Internal.Data.Fold.Concurrent.Channel - , Streamly.Internal.Data.Fold.Concurrent - , Streamly.Data.Fold.Tee - - , Streamly.Internal.Data.Stream.Concurrent.Channel.Type - , Streamly.Internal.Data.Stream.Concurrent.Channel.Dispatcher - , Streamly.Internal.Data.Stream.Concurrent.Channel.Consumer - , Streamly.Internal.Data.Stream.Concurrent.Channel.Append - , Streamly.Internal.Data.Stream.Concurrent.Channel.Interleave - , Streamly.Internal.Data.Stream.Concurrent.Channel.Operations - , Streamly.Internal.Data.Stream.Concurrent.Channel - , Streamly.Internal.Data.Stream.Concurrent - , Streamly.Internal.Data.Stream.Zip.Concurrent - , Streamly.Internal.Data.Stream.Time - , Streamly.Internal.Data.Stream.Exception.Lifted + , Streamly.Internal.Data.Stream.Prelude + , Streamly.Internal.Data.Unfold.Prelude + , Streamly.Internal.Data.Fold.Prelude + , Streamly.Internal.Data.Scanl.Prelude -- streamly-unicode (depends on unicode-data) , Streamly.Internal.Unicode.Utf8 @@ -395,29 +423,21 @@ -- Exposed modules , Streamly.Data.Stream.MkType , Streamly.Data.Stream.Prelude + , Streamly.Data.Fold.Prelude + , Streamly.Data.Scanl.Prelude -- Network/IO , Streamly.Network.Socket , Streamly.Network.Inet.TCP -- Deprecated - , Streamly - , Streamly.Data.Unicode.Stream - , Streamly.Memory.Array , Streamly.Data.Array.Foreign + , Streamly.Data.Fold.Tee , Streamly.Prelude -- Deprecated Internal modules - , Streamly.Internal.Data.SVar.Worker - , Streamly.Internal.Data.SVar.Dispatch - , Streamly.Internal.Data.SVar.Pull , Streamly.Internal.Data.SVar - - , Streamly.Internal.Data.Unfold.SVar - , Streamly.Internal.Data.Fold.SVar - , Streamly.Internal.Data.Fold.Async - , Streamly.Internal.Data.Stream.SVar.Generate - , Streamly.Internal.Data.Stream.SVar.Eliminate + , Streamly.Internal.Data.Stream.SVar , Streamly.Internal.Data.Stream.Serial , Streamly.Internal.Data.Stream.Zip @@ -426,38 +446,28 @@ , Streamly.Internal.Data.Stream.Ahead , Streamly.Internal.Data.Stream.ZipAsync - , Streamly.Internal.Data.Stream.IsStream.Type - , Streamly.Internal.Data.Stream.IsStream.Combinators - , Streamly.Internal.Data.Stream.IsStream.Common - , Streamly.Internal.Data.Stream.IsStream.Enumeration - , Streamly.Internal.Data.Stream.IsStream.Generate - , Streamly.Internal.Data.Stream.IsStream.Eliminate - , Streamly.Internal.Data.Stream.IsStream.Transform - , Streamly.Internal.Data.Stream.IsStream.Expand - , Streamly.Internal.Data.Stream.IsStream.Reduce - , Streamly.Internal.Data.Stream.IsStream.Exception - , Streamly.Internal.Data.Stream.IsStream.Lift - , Streamly.Internal.Data.Stream.IsStream.Top , Streamly.Internal.Data.Stream.IsStream - if !impl(ghcjs) && flag(dev) - exposed-modules: + if !impl(ghcjs) && flag(internal-dev) + other-modules: Streamly.Internal.System.IOVec.Type , Streamly.Internal.System.IOVec , Streamly.Internal.FileSystem.FDIO , Streamly.Internal.FileSystem.FD - if flag(dev) - exposed-modules: Streamly.Data.SmallArray - , Streamly.Internal.Data.SmallArray - , Streamly.Internal.Data.SmallArray.Type + if flag(internal-dev) + exposed-modules: Streamly.Internal.Data.SmallArray + -- Exposed modules show up on hackage irrespective of the flag, so keep + -- it hidden. + other-modules: Streamly.Data.SmallArray + , Streamly.Internal.Data.SmallArray.Type if os(windows) exposed-modules: Streamly.Internal.FileSystem.Event.Windows if os(darwin) include-dirs: src/Streamly/Internal - c-sources: src/Streamly/Internal/FileSystem/Event/Darwin.m + c-sources: src/Streamly/Internal/FileSystem/Event/Darwin.c exposed-modules: Streamly.Internal.FileSystem.Event.Darwin if os(linux) @@ -467,10 +477,54 @@ exposed-modules: Streamly.Internal.FileSystem.Event other-modules: - Streamly.Data.Stream.Exception - , Streamly.Data.Stream.Concurrent - , Streamly.Data.Stream.Time + Streamly.Internal.Data.Channel.Types + , Streamly.Internal.Data.Channel.Dispatcher + , Streamly.Internal.Data.Channel.Worker + , Streamly.Internal.Data.Stream.Channel.Type + , Streamly.Internal.Data.Stream.Channel.Dispatcher + , Streamly.Internal.Data.Stream.Channel.Consumer + , Streamly.Internal.Data.Stream.Channel.Append + , Streamly.Internal.Data.Stream.Channel.Interleave + , Streamly.Internal.Data.Stream.Channel.Operations + , Streamly.Internal.Data.Stream.Channel + , Streamly.Internal.Data.Stream.Concurrent + , Streamly.Internal.Data.Stream.Time + , Streamly.Internal.Data.Stream.Lifted + + , Streamly.Internal.Data.Fold.Time + , Streamly.Internal.Data.Fold.Channel.Type + , Streamly.Internal.Data.Fold.Channel + , Streamly.Internal.Data.Fold.Concurrent + , Streamly.Internal.Data.Scanl.Concurrent + + , Streamly.Internal.Data.Unfold.Exception + , Streamly.Internal.Data.Unfold.SVar + + -- Deprecated + , Streamly.Internal.Data.Stream.Common + , Streamly.Internal.Data.Stream.IsStream.Type + , Streamly.Internal.Data.Stream.IsStream.Generate + , Streamly.Internal.Data.Stream.IsStream.Eliminate + , Streamly.Internal.Data.Stream.IsStream.Transform + , Streamly.Internal.Data.Stream.IsStream.Expand + , Streamly.Internal.Data.Stream.IsStream.Reduce + , Streamly.Internal.Data.Stream.IsStream.Exception + , Streamly.Internal.Data.Stream.IsStream.Lift + , Streamly.Internal.Data.Stream.IsStream.Top + , Streamly.Internal.Data.Stream.IsStream.Combinators + , Streamly.Internal.Data.Stream.IsStream.Common + , Streamly.Internal.Data.Stream.IsStream.Enumeration + + , Streamly.Internal.Data.Stream.SVar.Generate + , Streamly.Internal.Data.Stream.SVar.Eliminate + + , Streamly.Internal.Data.Fold.SVar + + , Streamly.Internal.Data.SVar.Worker + , Streamly.Internal.Data.SVar.Dispatch + , Streamly.Internal.Data.SVar.Pull + build-depends: -- Core libraries shipped with ghc, the min and max -- constraints of these libraries should match with @@ -478,56 +532,63 @@ -- packages depending on the "ghc" package (packages -- depending on doctest is a common example) can -- depend on streamly. - base >= 4.12 && < 4.19 - , containers >= 0.6.0 && < 0.7 - , deepseq >= 1.4.4 && < 1.5 + base >= 4.12 && < 4.23 + , fusion-plugin-types >= 0.1 && < 0.2 + , containers >= 0.6.0 && < 0.9 + , deepseq >= 1.4.4 && < 1.6 , exceptions >= 0.8.0 && < 0.11 , mtl >= 2.2.2 && < 2.4 , transformers >= 0.5.5 && < 0.7 - , template-haskell >= 2.14 && < 2.20 + , template-haskell >= 2.14 && < 2.25 -- The core streamly package - , streamly-core == 0.1.0 + , streamly-core >= 0.3.0 && < 0.3.2 - , hashable >= 1.3 && < 1.5 + , hashable >= 1.3 && < 1.6 , unordered-containers >= 0.2 && < 0.3 - - -- XXX to be removed - , transformers-base >= 0.4 && < 0.5 , heaps >= 0.3 && < 0.5 -- concurrency - , atomic-primops >= 0.8 && < 0.9 , lockfree-queue >= 0.2.4 && < 0.3 - , unicode-data >= 0.1 && < 0.5 + , unicode-data >= 0.1 && < 0.9 -- Network - , network >= 2.6 && < 3.2 + -- network version 3.2.8 is broken on windows + , network >= 2.6 && < 3.3 - if flag(use-unliftio) + + if impl(ghc < 9.10) + build-depends: atomic-primops >= 0.8 && < 0.9 + else + build-depends: atomic-primops >= 0.8.8 && < 0.9 + + if impl(ghc < 9.6) + build-depends: transformers-base >= 0.4 && < 0.5 + + if flag(internal-use-unliftio) build-depends: unliftio-core >= 0.2 && < 0.3 else build-depends: monad-control >= 1.0 && < 1.1 - if flag(dev) - build-depends: primitive >= 0.5.4 && < 0.9 + if flag(internal-dev) + build-depends: primitive >= 0.5.4 && < 0.10 -- For FileSystem.Event module if os(linux) build-depends: directory >= 1.2.2 && < 1.4 if os(windows) - build-depends: Win32 >= 2.6 && < 2.14 + build-depends: Win32 >= 2.6 && < 2.15 if os(darwin) build-depends: directory >= 1.2.2 && < 1.4 frameworks: Cocoa if flag(inspection) - build-depends: inspection-testing >= 0.4 && < 0.6 + build-depends: inspection-testing >= 0.4 && < 0.7 -- Array uses a Storable constraint in dev build making several inspection -- tests fail - if flag(dev) && flag(inspection) + if flag(internal-dev) && flag(inspection) build-depends: inspection-and-dev-flags-cannot-be-used-together diff --git a/targets/Targets.hs b/targets/Targets.hs --- a/targets/Targets.hs +++ b/targets/Targets.hs @@ -1,85 +1,257 @@ +{-# LANGUAGE CPP #-} + module Targets ( targets ) where --- Special tags --- noTest --- noBench --- testDevOnly +-- Special tags: +-- *_grp groups +-- *_cmp comparison groups +-- noTest not available in tests +-- noBench not available in bench +-- testDevOnly dev only test targets :: [(String, [String])] targets = - [ -- Base streams - ("Data.Stream.StreamD", - [ "base_stream_grp" - , "base_stream_cmp" + [ + ------------------------------------------------------------------------- + -- Alphabetical order + ------------------------------------------------------------------------- + + ("Data.Array", + [ "array_grp" + , "array_cmp" + ] + ) + , ("Data.Array.Generic", + [ "array_grp" + , "array_cmp" + ] + ) + , ("Data.Array.Stream", + [ "infinite_grp" + , "serial_stream_grp" + ] + ) + , ("Data.Binary", + [ "noBench" + ] + ) + , ("Data.Fold", + [ "infinite_grp" + , "fold_parser_grp" + ] + ) + , ("Data.Fold.Window", + [ "infinite_grp" + , "fold_parser_grp" + ] + ) + , ("Data.List", + [ "list_grp" + , "noBench" + , "testDevOnly" + ] + ) + , ("Data.List.Base", + [ "list_grp" + , "noBench" + ] + ) + , ("Data.MutArray", + [ "array_grp" + , "array_cmp" + ] + ) + , ("Data.Parser", + [ "infinite_grp" + , "fold_parser_grp" + , "parser_cmp" + ] + ) + , ("Data.ParserK", + [ "infinite_grp" + , "fold_parser_grp" + , "parser_cmp" + ] + ) + , ("Data.ParserK.Chunked", + [ "infinite_grp" + , "fold_parser_grp" + , "parser_cmp" , "noTest" ] ) - , ("Data.Stream.StreamK", - [ "base_stream_grp" - , "base_stream_cmp" + , ("Data.ParserK.Chunked.Generic", + [ "infinite_grp" + , "fold_parser_grp" + , "parser_cmp" , "noTest" ] ) - -{- - -- XXX Need devOnly flag support in BenchRunner - , ("Data.Stream.ToStreamK", - [ "noTest" - , "devOnly" + , ("Data.RingArray", + [ "array_grp" ] ) --} - - -- Streams - , ("Data.Stream", - [ "prelude_serial_grp" - , "infinite_grp" - , "serial_wserial_cmp" - , "serial_async_cmp" + , ("Data.Scanl", + [ "infinite_grp" + , "fold_parser_grp" , "noTest" ] ) - , ("Data.Stream.StreamDK", - [ "prelude_serial_grp" - , "infinite_grp" + , ("Data.Scanl.Window", + [ "infinite_grp" + , "fold_parser_grp" , "noTest" ] ) + , ("Data.Serialize", + [ "mut_bytearray_grp" + ] + ) + , ("Data.Serialize.Derive.TH", + [ "mut_bytearray_grp" + , "noBench" + ] + ) + , ("Data.Serialize.ENABLE_constructorTagAsString", + [ "mut_bytearray_grp" + , "noBench" + ] + ) + , ("Data.SmallArray", + [ "noBench" + , "testDevOnly" + ] + ) + , ("Data.Stream", + [ "infinite_grp" + , "serial_stream_grp" + , "serial_stream_cmp" + , "serial_concurrent_cmp" + ] + ) + , ("Data.Stream.Adaptive", + [ "concurrent_stream_grp" + , "noTest" + ] + ) + -- XXX Concurrent and rate benchmarks take a long time with --long, perhaps + -- need to use smaller stream sizes for these when using --long , ("Data.Stream.Concurrent", - [ "prelude_concurrent_grp" - , "infinite_grp" - , "concurrent_cmp" - , "serial_async_cmp" + [ "infinite_grp" + , "concurrent_stream_grp" + , "concurrent_stream_cmp" + , "serial_concurrent_cmp" ] ) , ("Data.Stream.ConcurrentEager", - [ "prelude_concurrent_grp" - , "infinite_grp" - , "concurrent_cmp" + [ "infinite_grp" + , "concurrent_stream_grp" + , "concurrent_stream_cmp" , "noTest" ] ) + , ("Data.Stream.ConcurrentInterleaved", + [ "infinite_grp" + , "concurrent_stream_grp" + , "concurrent_stream_cmp" + , "noTest" + ] + ) , ("Data.Stream.ConcurrentOrdered", - [ "prelude_concurrent_grp" - , "infinite_grp" - , "concurrent_cmp" + [ "infinite_grp" + , "concurrent_stream_grp" + , "concurrent_stream_cmp" , "noTest" ] ) - , ("Data.Stream.ConcurrentInterleaved", - [ "prelude_concurrent_grp" - , "infinite_grp" - , "concurrent_cmp" + , ("Data.Stream.ConcurrentThreadHeavy", + [ "concurrent_stream_grp" , "noTest" ] ) - , ("Data.Array.Stream", - [ "prelude_serial_grp" - , "infinite_grp" + , ("Data.Stream.Rate", + [ "infinite_grp" + , "concurrent_stream_grp" + , "testDevOnly" ] ) + , ("Data.StreamK", + [ "infinite_grp" + , "serial_stream_grp" + , "serial_stream_cmp" + , "noTest" + ] + ) +{- + -- XXX Need devOnly flag support in BenchRunner + , ("Data.StreamK.FromStream", + [ "infinite_grp" + , "serial_stream_grp" + , "noTest" + , "devOnly" + ] + ) +-} + , ("Data.Unbox", + [ "noTest" + ] + ) + , ("Data.Unbox.Derive.Generic", + [ "noBench" + ] + ) + , ("Data.Unbox.Derive.TH", + [] + ) + , ("Data.Unbox.TH", + [ "noBench" + ] + ) + , ("Data.Unfold", + [ "infinite_grp" + , "serial_stream_grp" + ] + ) + , ("FileSystem.Event", + [ "noBench" + ] + ) +#if defined(darwin_HOST_OS) + , ("FileSystem.Event.Darwin", + [ "noBench" + ] + ) +#endif +#if defined(linux_HOST_OS) + , ("FileSystem.Event.Linux", + [ "noBench" + , "testDevOnly" + ] + ) +#endif +#if defined(mingw32_HOST_OS) + , ("FileSystem.Event.Windows", + [ "noBench" + ] + ) +#endif + , ("FileSystem.Handle", []) + , ("FileSystem.DirIO", []) + , ("Network.Inet.TCP", ["noBench"]) + , ("Network.Socket", ["noBench"]) + , ("Unicode.Char", ["testDevOnly"]) + , ("Unicode.Parser", []) + , ("Unicode.Stream", []) + , ("Unicode.Utf8", ["noTest"]) + , ("version-bounds", ["noBench"]) + + ---- DEPRECATED ---- + + -- test only, no benchmarks + -- , ("Prelude", ["prelude_other_grp", "noBench"]) + -- , ("Prelude.Fold", ["prelude_other_grp", "noBench"]) -- Enabled only when use-prelude flag is set -- , ("Prelude.Serial", -- [ "prelude_serial_grp" @@ -153,55 +325,4 @@ -- , "noTest" -- ] -- ) - - -- Arrays - , ("Data.Array.Generic", - [ "array_grp" - , "array_cmp" - ] - ) - , ("Data.Array", - [ "array_grp" - , "array_cmp" - , "pinned_array_cmp" - ] - ) - , ("Data.Array.Mut", - [ "array_grp" - , "array_cmp" - ] - ) - - -- Ring - , ("Data.Ring.Unboxed", []) - - -- Parsers - , ("Data.Parser.ParserK", - [ "base_parser_grp" - , "base_parser_cmp" - , "infinite_grp" - , "noTest" - ] - ) - , ("Data.Fold", [ "parser_grp", "infinite_grp" ]) - , ("Data.Fold.Window", [ "parser_grp", "infinite_grp" ]) - , ("Data.Parser", [ "parser_grp", "infinite_grp" ]) - - , ("Data.Unbox", ["noBench"]) - , ("Data.Unfold", ["infinite_grp"]) - , ("FileSystem.Handle", []) - , ("Unicode.Stream", []) - , ("Unicode.Utf8", ["noTest"]) - , ("Unicode.Char", ["testDevOnly"]) - - -- test only, no benchmarks - -- , ("Prelude", ["prelude_other_grp", "noBench"]) - -- , ("Prelude.Fold", ["prelude_other_grp", "noBench"]) - , ("FileSystem.Event", ["noBench"]) - , ("Network.Socket", ["noBench"]) - , ("Network.Inet.TCP", ["noBench"]) - , ("version-bounds", ["noBench"]) - - , ("Data.List", ["list_grp", "noBench", "testDevOnly"]) - , ("Data.List.Base", ["list_grp", "noBench"]) ] diff --git a/test/Streamly/Test/Data/Array.hs b/test/Streamly/Test/Data/Array.hs --- a/test/Streamly/Test/Data/Array.hs +++ b/test/Streamly/Test/Data/Array.hs @@ -11,16 +11,18 @@ import Data.Char (isLower) import Data.List (sort) import Data.Proxy (Proxy(..)) -import Data.Word(Word8) +import Data.Word(Word8, Word16) import Foreign.Storable (peek) -import GHC.Ptr (plusPtr) -import Streamly.Internal.Data.Unboxed (Unbox, sizeOf) -import Streamly.Internal.Data.Array.Mut.Type (MutArray) +import Foreign.ForeignPtr (newForeignPtr_, withForeignPtr) +import GHC.Ptr (plusPtr, Ptr(..)) +import Streamly.Internal.Data.MutByteArray (Unbox, sizeOf) +import Streamly.Internal.Data.MutArray (MutArray) import Test.QuickCheck (chooseInt, listOf) +import System.Mem (performMajorGC) +import Streamly.Test.Common (performGCSweep) import qualified Streamly.Internal.Data.Array as A -import qualified Streamly.Internal.Data.Array.Type as A -import qualified Streamly.Internal.Data.Array.Mut.Type as MA +import qualified Streamly.Internal.Data.MutArray as MA #include "Streamly/Test/Data/Array/CommonImports.hs" @@ -36,7 +38,7 @@ testFoldUnfold :: Property testFoldUnfold = - genericTestFromTo (const (S.fold A.write)) (S.unfold A.reader) (==) + genericTestFromTo (const (S.fold A.create)) (S.unfold A.reader) (==) testFromList :: Property testFromList = @@ -53,8 +55,8 @@ unsafeWriteIndex :: [Int] -> Int -> Int -> IO Bool unsafeWriteIndex xs i x = do arr <- MA.fromList xs - MA.putIndexUnsafe i arr x - x1 <- MA.getIndexUnsafe i arr + MA.unsafePutIndex i arr x + x1 <- MA.unsafeGetIndex i arr return $ x1 == x lastN :: Int -> [a] -> [a] @@ -68,63 +70,63 @@ monadicIO $ do xs <- run $ fmap A.toList - $ S.fold (A.writeLastN n) + $ S.fold (A.createOfLast n) $ S.fromList list assert (xs == lastN n list) testLastN_LN :: Int -> Int -> IO Bool testLastN_LN len n = do let list = [1..len] - l1 <- fmap A.toList $ S.fold (A.writeLastN n) $ S.fromList list + l1 <- fmap A.toList $ S.fold (A.createOfLast n) $ S.fromList list let l2 = lastN n list return $ l1 == l2 testStrip :: IO Bool testStrip = do dt <- MA.fromList "abcDEFgeh" - dt' <- MA.strip isLower dt + dt' <- MA.dropAround isLower dt x <- MA.toList dt' return $ x == "DEF" testStripLeft :: IO Bool testStripLeft = do dt <- MA.fromList "abcDEF" - dt' <- MA.strip isLower dt + dt' <- MA.dropAround isLower dt x <- MA.toList dt' return $ x == "DEF" testStripRight :: IO Bool testStripRight = do dt <- MA.fromList "DEFgeh" - dt' <- MA.strip isLower dt + dt' <- MA.dropAround isLower dt x <- MA.toList dt' return $ x == "DEF" testStripZero :: IO Bool testStripZero = do dt <- MA.fromList "DEF" - dt' <- MA.strip isLower dt + dt' <- MA.dropAround isLower dt x <- MA.toList dt' return $ x == "DEF" testStripEmpty :: IO Bool testStripEmpty = do dt <- MA.fromList "abc" - dt' <- MA.strip isLower dt + dt' <- MA.dropAround isLower dt x <- MA.toList dt' return $ x == "" testStripNull :: IO Bool testStripNull = do dt <- MA.fromList "" - dt' <- MA.strip isLower dt + dt' <- MA.dropAround isLower dt x <- MA.toList dt' return $ x == "" unsafeSlice :: Int -> Int -> [Int] -> Bool unsafeSlice i n list = let lst = take n $ drop i list - arr = A.toList $ A.getSliceUnsafe i n $ A.fromList list + arr = A.toList $ A.unsafeSliceOffLen i n $ A.fromList list in arr == lst testBubbleWith :: Bool -> Property @@ -150,7 +152,7 @@ else MA.bubble (flip compare) arr return arr ) - (MA.newPinned $ length ls) + (MA.emptyOf' $ length ls) testBubbleAsc :: Property testBubbleAsc = testBubbleWith True @@ -160,19 +162,19 @@ testByteLengthWithMA :: forall a. Unbox a => a -> IO () testByteLengthWithMA _ = do - arrA <- MA.newPinned 100 :: IO (MutArray a) - let arrW8 = MA.castUnsafe arrA :: MutArray Word8 + arrA <- MA.emptyOf' 100 :: IO (MutArray a) + let arrW8 = MA.unsafeCast arrA :: MutArray Word8 MA.byteLength arrA `shouldBe` MA.length arrW8 testBreakOn :: [Word8] -> Word8 -> [Word8] -> Maybe [Word8] -> IO () testBreakOn inp sep bef aft = do - (bef_, aft_) <- A.breakOn sep (A.fromList inp) + (bef_, aft_) <- A.breakEndByWord8_ sep (A.fromList inp) bef_ `shouldBe` A.fromList bef aft_ `shouldBe` fmap A.fromList aft testWrite :: [Char] -> IO () testWrite inp = do - arr <- S.fold A.write (S.fromList inp) + arr <- S.fold A.create (S.fromList inp) A.toList arr `shouldBe` inp testFromToList :: [Char] -> IO () @@ -181,12 +183,12 @@ testUnsafeIndxedFromList :: [Char] -> IO () testUnsafeIndxedFromList inp = let arr = A.fromList inp - in fmap (`A.unsafeIndex` arr) [0 .. (length inp - 1)] `shouldBe` inp + in fmap (`A.unsafeGetIndex` arr) [0 .. (length inp - 1)] `shouldBe` inp -testAsPtrUnsafeMA :: IO () -testAsPtrUnsafeMA = do - arr <- MA.fromList ([0 .. 99] :: [Int]) - MA.asPtrUnsafe arr (getList (0 :: Int)) `shouldReturn` [0 .. 99] +getIntList :: Ptr Int -> Int -> IO [Int] +getIntList ptr byteLen = do + performMajorGC + getList ptr (ptr `plusPtr` byteLen) where @@ -194,13 +196,70 @@ -- We need to be careful here. We assume Unboxed and Storable are compatible -- with each other. For Int, they are compatible. - getList i _ - | i >= 100 = return [] - getList i p = do + getList p limitP + | p >= limitP = return [] + getList p limitP = do val <- peek p - rest <- getList (i + 1) (p `plusPtr` sizeOfInt) + rest <- getList (p `plusPtr` sizeOfInt) limitP return $ val : rest +testAsPtrUnsafeMA :: IO () +testAsPtrUnsafeMA = do + arr <- MA.fromList ([0 .. 99] :: [Int]) + arr1 <- MA.pin arr + MA.unsafeAsPtr arr1 getIntList `shouldReturn` [0 .. 99] + +testUnsafePinnedAsPtr :: IO () +testUnsafePinnedAsPtr = do + arr <- MA.unsafeSliceOffLen 10 50 <$> MA.fromList ([0 .. 99] :: [Int]) + let arr1 = A.unsafeFreeze arr + A.unsafePinnedAsPtr arr1 getIntList `shouldReturn` [10 .. 59] + +testUnsafeAsForeignPtr :: IO () +testUnsafeAsForeignPtr = do + arr <- MA.unsafeSliceOffLen 10 50 <$> MA.fromList ([0 .. 99] :: [Int]) + let arr1 = A.unsafeFreeze arr + A.unsafeAsForeignPtr arr1 getIntList1 `shouldReturn` [10 .. 59] + where + getIntList1 fp blen = withForeignPtr fp $ \p -> getIntList p blen + +testForeignPtrConversionId :: IO () +testForeignPtrConversionId = do + arr0 <- MA.unsafeSliceOffLen 10 50 <$> MA.fromList ([0 .. 99] :: [Word8]) + let arr = A.unsafeFreeze arr0 + A.unsafeAsForeignPtr arr $ \a b -> do + res <- A.unsafeFromForeignPtr a b + performGCSweep 4 100000 + res `shouldBe` arr + + +testUnsafeFromForeignPtr :: IO () +testUnsafeFromForeignPtr = do + arr0 <- MA.unsafeSliceOffLen 10 50 <$> MA.fromList ([0 .. 99] :: [Word8]) + let arr = A.unsafeFreeze arr0 + A.unsafePinnedAsPtr arr $ \ptr len -> do + fptr <- newForeignPtr_ ptr + performMajorGC + A.unsafeFromForeignPtr fptr len `shouldReturn` arr + +testFromCString# :: IO () +testFromCString# = do + arr0 <- MA.unsafeSliceOffLen 10 50 <$> MA.fromList ([0 .. 99] :: [Word8]) + let arr = A.unsafeFreeze arr0 + A.unsafePinnedAsPtr (arr <> A.fromList [0]) $ \(Ptr addr#) _ -> do + arr1 <- A.fromCString# addr# + performGCSweep 4 100000 + arr1 `shouldBe` arr + +testFromW16CString# :: IO () +testFromW16CString# = do + arr0 <- MA.unsafeSliceOffLen 10 50 <$> MA.fromList ([0 .. 99] :: [Word16]) + let arr = A.unsafeFreeze arr0 + A.unsafePinnedAsPtr (arr <> A.fromList [0]) $ \(Ptr addr#) _ -> do + arr1 <- A.fromW16CString# addr# + performGCSweep 4 100000 + arr1 `shouldBe` arr + reallocMA :: Property reallocMA = let len = 10000 @@ -208,7 +267,7 @@ in forAll (vectorOf len (arbitrary :: Gen Char)) $ \vec -> forAll (chooseInt (bSize - 2000, bSize + 2000)) $ \newBLen -> do arr <- MA.fromList vec - arr1 <- MA.realloc newBLen arr + arr1 <- MA.reallocBytes newBLen arr lst <- MA.toList arr lst1 <- MA.toList arr1 lst `shouldBe` lst1 @@ -230,7 +289,14 @@ prop "read . write === id" testFoldUnfold prop "fromList" testFromList prop "foldMany with writeNUnsafe concats to original" - (foldManyWith (\n -> Fold.take n (A.writeNUnsafe n))) + (foldManyWith (\n -> Fold.take n (A.unsafeCreateOf n))) + describe "AsPtr" $ do + it "testUnsafePinnedAsPtr" testUnsafePinnedAsPtr + it "testUnsafeAsForeignPtr" testUnsafeAsForeignPtr + it "testForeignPtrConversionId" testForeignPtrConversionId + it "testUnsafeFromForeignPtr" testUnsafeFromForeignPtr + it "testFromCString#" testFromCString# + it "testFromW16CString#" testFromW16CString# describe "unsafeSlice" $ do it "partial" $ unsafeSlice 2 4 [1..10] it "none" $ unsafeSlice 10 0 [1..10] @@ -240,12 +306,12 @@ it "middle" (unsafeWriteIndex [1..10] 5 0 `shouldReturn` True) it "last" (unsafeWriteIndex [1..10] 9 0 `shouldReturn` True) describe "Fold" $ do - prop "writeLastN : 0 <= n <= len" testLastN - describe "writeLastN boundary conditions" $ do - it "writeLastN -1" (testLastN_LN 10 (-1) `shouldReturn` True) - it "writeLastN 0" (testLastN_LN 10 0 `shouldReturn` True) - it "writeLastN length" (testLastN_LN 10 10 `shouldReturn` True) - it "writeLastN (length + 1)" (testLastN_LN 10 11 `shouldReturn` True) + prop "createOfLast : 0 <= n <= len" testLastN + describe "createOfLast boundary conditions" $ do + it "createOfLast -1" (testLastN_LN 10 (-1) `shouldReturn` True) + it "createOfLast 0" (testLastN_LN 10 0 `shouldReturn` True) + it "createOfLast length" (testLastN_LN 10 10 `shouldReturn` True) + it "createOfLast (length + 1)" (testLastN_LN 10 11 `shouldReturn` True) describe "Strip" $ do it "strip" (testStrip `shouldReturn` True) it "stripLeft" (testStripLeft `shouldReturn` True) @@ -268,7 +334,7 @@ describe "toList . fromList" $ do it "testFromToList abc" (testFromToList "abc") it "testFromToList \\22407" (testFromToList "\22407") - describe "unsafeIndex . fromList" $ do + describe "unsafeGetIndex . fromList" $ do it "testUnsafeIndxedFromList abc" (testUnsafeIndxedFromList "abc") it "testUnsafeIndxedFromList \\22407" (testUnsafeIndxedFromList "\22407") diff --git a/test/Streamly/Test/Data/Array/Common.hs b/test/Streamly/Test/Data/Array/Common.hs --- a/test/Streamly/Test/Data/Array/Common.hs +++ b/test/Streamly/Test/Data/Array/Common.hs @@ -23,7 +23,7 @@ assert (A.length arr == len) testLength :: Property -testLength = genericTestFrom (S.fold . A.writeN) +testLength = genericTestFrom (S.fold . A.createOf) testLengthFromStreamN :: Property testLengthFromStreamN = genericTestFrom A.fromStreamN @@ -44,16 +44,16 @@ testFoldNUnfold :: Property testFoldNUnfold = - genericTestFromTo (S.fold . A.writeN) (S.unfold A.reader) (==) + genericTestFromTo (S.fold . A.createOf) (S.unfold A.reader) (==) testFoldNToStream :: Property testFoldNToStream = - genericTestFromTo (S.fold . A.writeN) A.read (==) + genericTestFromTo (S.fold . A.createOf) A.read (==) testFoldNToStreamRev :: Property testFoldNToStreamRev = genericTestFromTo - (S.fold . A.writeN) + (S.fold . A.createOf) A.readRev (\xs list -> xs == reverse list) @@ -81,7 +81,7 @@ monadicIO $ do xs <- run $ S.fold Fold.toList - $ S.unfoldMany A.reader + $ S.unfoldEach A.reader $ S.foldMany (f 240) $ S.fromList list assert (xs == list) @@ -98,4 +98,4 @@ prop "toStream . fromStreamN === id" testFromStreamNToStream prop "fromListN" testFromListN prop "foldMany with writeN concats to original" - (foldManyWith A.writeN) + (foldManyWith A.createOf) diff --git a/test/Streamly/Test/Data/Array/Generic.hs b/test/Streamly/Test/Data/Array/Generic.hs --- a/test/Streamly/Test/Data/Array/Generic.hs +++ b/test/Streamly/Test/Data/Array/Generic.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -Wno-deprecations #-} -- | -- Module : Streamly.Test.Data.Array.Generic @@ -27,7 +26,7 @@ testFoldUnfold :: Property testFoldUnfold = - genericTestFromTo (const (S.fold A.write)) (S.unfold A.reader) (==) + genericTestFromTo (const (S.fold A.create)) (S.unfold A.reader) (==) testFromList :: Property testFromList = diff --git a/test/Streamly/Test/Data/Array/Mut.hs b/test/Streamly/Test/Data/Array/Mut.hs deleted file mode 100644 --- a/test/Streamly/Test/Data/Array/Mut.hs +++ /dev/null @@ -1,152 +0,0 @@ -module Streamly.Test.Data.Array.Mut (main) where - -import Test.QuickCheck (listOf) - -import Control.Monad (void) -import Data.Complex (Complex) -import Data.Functor.Const (Const) -import Data.Functor.Identity (Identity) -import Foreign.Ptr (IntPtr, WordPtr) -import GHC.Exts -import GHC.Fingerprint.Type (Fingerprint(..)) -import GHC.Int (Int16(..), Int32(..), Int64(..), Int8(..)) -import GHC.Real (Ratio(..)) -import GHC.Stable (StablePtr(..)) -import GHC.Word (Word16(..), Word32(..), Word64(..), Word8(..)) -import Streamly.Internal.Data.Unboxed (Unbox) -import Streamly.Test.Common (chooseInt) -import Test.Hspec (hspec, describe, it) -import Test.Hspec.QuickCheck -import Test.QuickCheck (forAll, Property) -import Test.QuickCheck.Monadic (monadicIO, assert) -#if MIN_VERSION_base(4,15,0) -import GHC.RTS.Flags (IoSubSystem(..)) -#endif - -import qualified Streamly.Internal.Data.Array.Mut as MArray -import qualified Streamly.Internal.Data.Stream as Stream -import qualified Test.Hspec as Hspec - -maxTestCount :: Int -maxTestCount = 100 - -moduleName :: String -moduleName = "Data.Array.Mut" - -testAppend :: Property -testAppend = - forAll (listOf (chooseInt (-50, 100))) $ \ls0 -> - monadicIO $ action ls0 - - where - - action ls = do - x <- Stream.fold - (MArray.writeAppend (MArray.newPinned 0)) - (Stream.fromList (ls::[Int])) - lst <- MArray.toList x - assert (ls == lst) - -#define TEST_IE(_type) it "_type" $ testIE ([] :: [_type]) - --- XXX This should be in test/Data.Unbox --- C-ish foreign types are platfor specific. The platform needs to be taken into --- consideration when making instances. -testUnboxInstanceExistance :: Hspec.SpecWith () -testUnboxInstanceExistance = do - describe "Unbox instances" $ do - -- TEST_IE(CBool) - -- TEST_IE(CChar) - -- TEST_IE(CClock) - -- TEST_IE(CDouble) - -- TEST_IE(CFloat) - -- TEST_IE(CInt) - -- TEST_IE(CIntMax) - -- TEST_IE(CIntPtr) - -- TEST_IE(CLLong) - -- TEST_IE(CLong) - -- TEST_IE(CPtrdiff) - -- TEST_IE(CSChar) - -- TEST_IE(CSUSeconds) - -- TEST_IE(CShort) - -- TEST_IE(CSigAtomic) - -- TEST_IE(CSize) - -- TEST_IE(CTime) - -- TEST_IE(CUChar) - -- TEST_IE(CUInt) - -- TEST_IE(CUIntMax) - -- TEST_IE(CUIntPtr) - -- TEST_IE(CULLong) - -- TEST_IE(CULong) - -- TEST_IE(CUSeconds) - -- TEST_IE(CUShort) - -- TEST_IE(CWchar) - TEST_IE(IntPtr) - TEST_IE(WordPtr) - TEST_IE(Fingerprint) - TEST_IE(Int16) - TEST_IE(Int32) - TEST_IE(Int64) - TEST_IE(Int8) -#if MIN_VERSION_base(4,15,0) - TEST_IE(IoSubSystem) -#endif - TEST_IE(Word16) - TEST_IE(Word32) - TEST_IE(Word64) - TEST_IE(Word8) - -- TEST_IE(CBlkCnt) - -- TEST_IE(CBlkSize) - -- TEST_IE(CCc) - -- TEST_IE(CClockId) - -- TEST_IE(CDev) - -- TEST_IE(CFsBlkCnt) - -- TEST_IE(CFsFilCnt) - -- TEST_IE(CGid) - -- TEST_IE(CId) - -- TEST_IE(CIno) - -- TEST_IE(CKey) - -- TEST_IE(CMode) - -- TEST_IE(CNfds) - -- TEST_IE(CNlink) - -- TEST_IE(COff) - -- TEST_IE(CPid) - -- TEST_IE(CRLim) - -- TEST_IE(CSocklen) - -- TEST_IE(CSpeed) - -- TEST_IE(CSsize) - -- TEST_IE(CTcflag) - -- TEST_IE(CTimer) - -- TEST_IE(CUid) - -- TEST_IE(Fd) - TEST_IE(()) - TEST_IE(Bool) - TEST_IE(Char) - TEST_IE(Double) - TEST_IE(Float) - TEST_IE(Int) - TEST_IE(Word) - TEST_IE(Complex Int) - TEST_IE(Identity Int) -#if MIN_VERSION_base(4,14,0) - TEST_IE(Down Int) -#endif - TEST_IE(FunPtr Int) - TEST_IE(Ptr Int) - TEST_IE(Ratio Int) - TEST_IE(StablePtr Int) - TEST_IE(Const Int Int) - where - - testIE :: Unbox a => [a] -> IO () - testIE lst = void $ MArray.fromList lst - -main :: IO () -main = - hspec $ - Hspec.parallel $ - modifyMaxSuccess (const maxTestCount) $ do - describe moduleName $ do - describe "Stream Append" $ do - prop "testAppend" testAppend - testUnboxInstanceExistance diff --git a/test/Streamly/Test/Data/Array/Stream.hs b/test/Streamly/Test/Data/Array/Stream.hs --- a/test/Streamly/Test/Data/Array/Stream.hs +++ b/test/Streamly/Test/Data/Array/Stream.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -Wno-deprecations #-} module Main (main) where @@ -10,7 +9,6 @@ import Test.QuickCheck.Monadic (assert, monadicIO, run) import qualified Streamly.Internal.Data.Array as Array -import qualified Streamly.Internal.Data.Stream.Chunked as ArrayStream import qualified Streamly.Internal.Data.Fold as Fold import qualified Streamly.Internal.Data.Parser as Parser import qualified Streamly.Internal.Data.Stream as Stream @@ -57,10 +55,10 @@ let input = Stream.toStreamK $ chunksOf - clen (Array.writeN clen) (Stream.fromList ls) + clen (Array.createOf clen) (Stream.fromList ls) parser = Parser.fromFold (Fold.take tlen Fold.toList) - in run $ ArrayStream.parseBreak parser input - ls2 <- run $ Stream.fold Fold.toList (ArrayStream.concat $ Stream.fromStreamK str) + in run $ Array.parseBreak (Array.toParserK parser) input + ls2 <- run $ Stream.fold Fold.toList (Array.concat $ Stream.fromStreamK str) case ls1 of Right x -> listEquals (==) (x ++ ls2) ls Left _ -> assert False @@ -69,8 +67,8 @@ splitOnSuffix sep inp out = do res <- Stream.fold Fold.toList - $ ArrayStream.splitOnSuffix sep - $ chunksOf 2 (Array.writeN 2) $ Stream.fromList inp + $ Array.compactEndByByte_ sep + $ chunksOf 2 (Array.createOf 2) $ Stream.fromList inp fmap Array.toList res `shouldBe` out ------------------------------------------------------------------------------- @@ -88,7 +86,7 @@ forAll (vectorOf 10000 (arbitrary :: Gen Word8)) $ \w8List -> do let w8ArrList = Array.fromList . (: []) <$> w8List - f2 <- Stream.fold Fold.toList $ ArrayStream.concat $ Stream.fromList w8ArrList + f2 <- Stream.fold Fold.toList $ Array.concat $ Stream.fromList w8ArrList w8List `shouldBe` f2 diff --git a/test/Streamly/Test/Data/Fold.hs b/test/Streamly/Test/Data/Fold.hs --- a/test/Streamly/Test/Data/Fold.hs +++ b/test/Streamly/Test/Data/Fold.hs @@ -2,7 +2,8 @@ module Main (main) where -import Data.List (sort) +import Data.List (sort, sortBy) +import Data.Ord (comparing, Down(..)) import Data.Semigroup (Sum(..), getSum) import Streamly.Test.Common (checkListEqual, listEquals) import Test.QuickCheck @@ -23,9 +24,8 @@ import qualified Data.Map import qualified Prelude -import qualified Streamly.Internal.Data.Array.Mut as MArray +import qualified Streamly.Internal.Data.MutArray as MArray import qualified Streamly.Internal.Data.Fold as Fold -import qualified Streamly.Internal.Data.Fold.Container as Fold import qualified Streamly.Internal.Data.Stream as Stream import Prelude hiding @@ -413,7 +413,7 @@ where action ls = do - let f = \x -> if odd x then return (Left x) else return (Right x) + let f x = if odd x then return (Left x) else return (Right x) v1 <- run $ Stream.fold (Fold.partitionByM f Fold.length Fold.length) @@ -430,7 +430,7 @@ where action _ = do - let f = \x -> if odd x then return (Left x) else return (Right x) + let f x = if odd x then return (Left x) else return (Right x) v1 <- run $ Stream.fold @@ -448,7 +448,7 @@ where action _ = do - let f = \x -> if odd x then return (Left x) else return (Right x) + let f x = if odd x then return (Left x) else return (Right x) v1 <- run $ Stream.fold @@ -466,7 +466,7 @@ where action _ = do - let f = \x -> if odd x then return (Left x) else return (Right x) + let f x = if odd x then return (Left x) else return (Right x) v1 <- run $ Stream.fold @@ -596,9 +596,9 @@ demux :: Expectation demux = - let table "SUM" = return Fold.sum - table "PRODUCT" = return Fold.product - table _ = return Fold.length + let table "SUM" = return $ Just Fold.sum + table "PRODUCT" = return $ Just Fold.product + table _ = return $ Just Fold.length input = Stream.fromList ( [ ("SUM", 1) , ("abc", 1) @@ -691,7 +691,7 @@ if isTop then do lst <- Stream.fold (Fold.top n) (Stream.fromList ls) >>= MArray.toList - assert ((Prelude.take n . Prelude.reverse . sort) ls == lst) + assert ((Prelude.take n . sortBy (comparing Down)) ls == lst) else do lst <- Stream.fold (Fold.bottom n) (Stream.fromList ls) >>= MArray.toList assert ((Prelude.take n . sort) ls == lst) diff --git a/test/Streamly/Test/Data/Fold/Window.hs b/test/Streamly/Test/Data/Fold/Window.hs --- a/test/Streamly/Test/Data/Fold/Window.hs +++ b/test/Streamly/Test/Data/Fold/Window.hs @@ -1,10 +1,11 @@ module Streamly.Test.Data.Fold.Window (main) where -import Streamly.Internal.Data.Fold.Window import Test.Hspec (hspec, describe, it, runIO) -import qualified Streamly.Internal.Data.Ring.Unboxed as Ring -import qualified Streamly.Internal.Data.Stream as S +import Streamly.Internal.Data.Scanl (Incr(..)) import qualified Streamly.Internal.Data.Fold as Fold +import qualified Streamly.Internal.Data.RingArray as RingArray +import qualified Streamly.Internal.Data.Scanl as Scanl +import qualified Streamly.Internal.Data.Stream as S import Prelude hiding (sum, maximum, minimum) @@ -20,17 +21,20 @@ 9007199254740992, 1, 1, 1, 9007199254740992] testCase = take numElem $ cycle testCaseChunk deviationLimit = 1 + testFunc f = do let c = S.fromList testCase - a <- runIO $ S.fold (Ring.slidingWindow winSize f) c - b <- runIO $ S.fold f $ S.drop (numElem - winSize) - $ fmap (, Nothing) c + f1 = Fold.fromScanl $ Scanl.incrScan winSize f + f2 = Fold.fromScanl f + a <- runIO $ S.fold f1 c + b <- runIO $ S.fold f2 $ S.drop (numElem - winSize) + $ fmap Insert c let c1 = a - b it ("should not deviate more than " ++ show deviationLimit) $ c1 >= -1 * deviationLimit && c1 <= deviationLimit - describe "Sum" $ testFunc sum - describe "mean" $ testFunc mean + describe "Sum" $ testFunc Scanl.incrSum + describe "mean" $ testFunc Scanl.incrMean describe "Correctness" $ do let winSize = 3 @@ -41,28 +45,45 @@ testFunc tc f sI sW = do let c = S.fromList tc - a <- runIO $ S.fold Fold.toList $ S.postscan f $ fmap (, Nothing) c - b <- runIO $ S.fold Fold.toList $ S.postscan - (Ring.slidingWindow winSize f) c + a <- runIO $ S.fold Fold.toList $ S.postscanl f $ fmap Insert c + b <- runIO $ S.fold Fold.toList $ S.postscanl + (Scanl.incrScan winSize f) c it "Infinite" $ a == sI it ("Finite " ++ show winSize) $ b == sW testFunc2 tc expec f = do let c = S.fromList tc - a <- runIO $ S.fold (f winSize) c + a <- runIO $ S.toList $ S.postscanl (f winSize) c + runIO $ print a it (show tc) $ a == expec + describe "toList" $ do + testFunc2 testCase1 + [[1.0],[1.0,4.0],[1.0,4.0,3.0],[4.0,3.0,2.1],[3.0,2.1,-5.1] + ,[2.1,-5.1,-2.0],[-5.1,-2.0,7.0],[-2.0,7.0,3.0],[7.0,3.0,-2.5] + ] + (RingArray.scanFoldRingsBy Fold.toList) describe "minimum" $ do - testFunc2 testCase1 (Just (-2.5)) minimum + testFunc2 testCase1 + [Just 1.0,Just 1.0,Just 1.0,Just 2.1,Just (-5.1),Just (-5.1) + ,Just (-5.1),Just (-2.0),Just (-2.5)] + (RingArray.scanFoldRingsBy Fold.minimum) describe "maximum" $ do - testFunc2 testCase1 (Just 7.0) maximum + testFunc2 testCase1 + [Just 1.0,Just 4.0,Just 4.0,Just 4.0,Just 3.0,Just 2.1 + ,Just 7.0,Just 7.0,Just 7.0] + (RingArray.scanFoldRingsBy Fold.maximum) describe "range" $ do - testFunc2 testCase1 (Just (-2.5, 7.0)) range + testFunc2 testCase1 + [Just (1.0,1.0),Just (1.0,4.0),Just (1.0,4.0),Just (2.1,4.0) + ,Just (-5.1,3.0),Just (-5.1,2.1),Just (-5.1,7.0) + ,Just (-2.0,7.0),Just (-2.5,7.0)] + (RingArray.scanFoldRingsBy Fold.range) describe "sum" $ do let scanInf = [1, 2, 3, 4, 5, 12] :: [Double] scanWin = [1, 2, 3, 3, 3, 9] :: [Double] - testFunc testCase2 sum scanInf scanWin + testFunc testCase2 Scanl.incrSum scanInf scanWin describe "mean" $ do let scanInf = [1, 1, 1, 1, 1, 2] :: [Double] scanWin = [1, 1, 1, 1, 1, 3] :: [Double] - testFunc testCase2 mean scanInf scanWin + testFunc testCase2 Scanl.incrMean scanInf scanWin diff --git a/test/Streamly/Test/Data/MutArray.hs b/test/Streamly/Test/Data/MutArray.hs new file mode 100644 --- /dev/null +++ b/test/Streamly/Test/Data/MutArray.hs @@ -0,0 +1,153 @@ +module Streamly.Test.Data.MutArray (main) where + +import Test.QuickCheck (listOf) + +import Control.Monad (void) +import Data.Complex (Complex) +import Data.Functor.Const (Const) +import Data.Functor.Identity (Identity) +import Foreign.Ptr (IntPtr, WordPtr) +import GHC.Exts +import GHC.Fingerprint.Type (Fingerprint(..)) +import GHC.Int (Int16(..), Int32(..), Int64(..), Int8(..)) +import GHC.Real (Ratio(..)) +import GHC.Stable (StablePtr(..)) +import GHC.Word (Word16(..), Word32(..), Word64(..), Word8(..)) +import Streamly.Internal.Data.MutByteArray (Unbox) +import Streamly.Test.Common (chooseInt) +import Test.Hspec (hspec, describe, it) +import Test.Hspec.QuickCheck +import Test.QuickCheck (forAll, Property) +import Test.QuickCheck.Monadic (monadicIO, assert) +#if MIN_VERSION_base(4,15,0) +import GHC.IO.SubSystem (IoSubSystem (..)) +#endif + +import qualified Streamly.Internal.Data.MutArray as MArray +import qualified Streamly.Internal.Data.Stream as Stream +import qualified Test.Hspec as Hspec + +maxTestCount :: Int +maxTestCount = 100 + +moduleName :: String +moduleName = "Data.MutArray" + +testAppend :: Property +testAppend = + forAll (listOf (chooseInt (-50, 100))) $ \ls0 -> + monadicIO $ action ls0 + + where + + action ls = do + arr0 <- MArray.emptyOf' 0 + x <- Stream.fold + (MArray.append2 arr0) + (Stream.fromList (ls::[Int])) + lst <- MArray.toList x + assert (ls == lst) + +#define TEST_IE(_type) it "_type" $ testIE ([] :: [_type]) + +-- XXX This should be in test/Data.Unbox +-- C-ish foreign types are platfor specific. The platform needs to be taken into +-- consideration when making instances. +testUnboxInstanceExistance :: Hspec.SpecWith () +testUnboxInstanceExistance = do + describe "Unbox instances" $ do + -- TEST_IE(CBool) + -- TEST_IE(CChar) + -- TEST_IE(CClock) + -- TEST_IE(CDouble) + -- TEST_IE(CFloat) + -- TEST_IE(CInt) + -- TEST_IE(CIntMax) + -- TEST_IE(CIntPtr) + -- TEST_IE(CLLong) + -- TEST_IE(CLong) + -- TEST_IE(CPtrdiff) + -- TEST_IE(CSChar) + -- TEST_IE(CSUSeconds) + -- TEST_IE(CShort) + -- TEST_IE(CSigAtomic) + -- TEST_IE(CSize) + -- TEST_IE(CTime) + -- TEST_IE(CUChar) + -- TEST_IE(CUInt) + -- TEST_IE(CUIntMax) + -- TEST_IE(CUIntPtr) + -- TEST_IE(CULLong) + -- TEST_IE(CULong) + -- TEST_IE(CUSeconds) + -- TEST_IE(CUShort) + -- TEST_IE(CWchar) + TEST_IE(IntPtr) + TEST_IE(WordPtr) + TEST_IE(Fingerprint) + TEST_IE(Int16) + TEST_IE(Int32) + TEST_IE(Int64) + TEST_IE(Int8) +#if MIN_VERSION_base(4,15,0) + TEST_IE(IoSubSystem) +#endif + TEST_IE(Word16) + TEST_IE(Word32) + TEST_IE(Word64) + TEST_IE(Word8) + -- TEST_IE(CBlkCnt) + -- TEST_IE(CBlkSize) + -- TEST_IE(CCc) + -- TEST_IE(CClockId) + -- TEST_IE(CDev) + -- TEST_IE(CFsBlkCnt) + -- TEST_IE(CFsFilCnt) + -- TEST_IE(CGid) + -- TEST_IE(CId) + -- TEST_IE(CIno) + -- TEST_IE(CKey) + -- TEST_IE(CMode) + -- TEST_IE(CNfds) + -- TEST_IE(CNlink) + -- TEST_IE(COff) + -- TEST_IE(CPid) + -- TEST_IE(CRLim) + -- TEST_IE(CSocklen) + -- TEST_IE(CSpeed) + -- TEST_IE(CSsize) + -- TEST_IE(CTcflag) + -- TEST_IE(CTimer) + -- TEST_IE(CUid) + -- TEST_IE(Fd) + TEST_IE(()) + TEST_IE(Bool) + TEST_IE(Char) + TEST_IE(Double) + TEST_IE(Float) + TEST_IE(Int) + TEST_IE(Word) + TEST_IE(Complex Int) + TEST_IE(Identity Int) +#if MIN_VERSION_base(4,14,0) + TEST_IE(Down Int) +#endif + TEST_IE(FunPtr Int) + TEST_IE(Ptr Int) + TEST_IE(Ratio Int) + TEST_IE(StablePtr Int) + TEST_IE(Const Int Int) + where + + testIE :: Unbox a => [a] -> IO () + testIE lst = void $ MArray.fromList lst + +main :: IO () +main = + hspec $ + Hspec.parallel $ + modifyMaxSuccess (const maxTestCount) $ do + describe moduleName $ do + describe "Stream Append" $ do + prop "testAppend" testAppend + testUnboxInstanceExistance diff --git a/test/Streamly/Test/Data/Parser.hs b/test/Streamly/Test/Data/Parser.hs --- a/test/Streamly/Test/Data/Parser.hs +++ b/test/Streamly/Test/Data/Parser.hs @@ -1,1230 +1,470 @@ -module Main (main) where - -import Control.Exception (displayException) -import Data.Foldable (for_) -import Data.Word (Word8, Word32, Word64) -import Streamly.Test.Common (listEquals, checkListEqual, chooseInt) -import Test.Hspec (Spec, hspec, describe) -import Test.Hspec.QuickCheck -import Test.QuickCheck - (arbitrary, forAll, elements, Property, property, listOf, - vectorOf, Gen) -import Test.QuickCheck.Monadic (monadicIO, assert, run) - -import Prelude hiding (sequence) - -import qualified Control.Monad.Fail as Fail -import qualified Data.List as List -import qualified Prelude -import qualified Streamly.Internal.Data.Array as A -import qualified Streamly.Internal.Data.Fold as FL -import qualified Streamly.Internal.Data.Parser as P -import qualified Streamly.Internal.Data.Stream as S -import qualified Test.Hspec as H - -#if MIN_VERSION_QuickCheck(2,14,0) - -import Test.QuickCheck (chooseAny) -import Control.Monad.Identity (Identity(runIdentity, Identity)) -import Streamly.Internal.Data.Parser.ParserD (ParseError(..)) - -#else - -import System.Random (Random(random)) -import Test.QuickCheck.Gen (Gen(MkGen)) - --- | Generates a random element over the natural range of `a`. -chooseAny :: Random a => Gen a -chooseAny = MkGen (\r _ -> let (x,_) = random r in x) - -#endif - -maxTestCount :: Int -maxTestCount = 100 - -min_value :: Int -min_value = 0 - -mid_value :: Int -mid_value = 5000 - -max_value :: Int -max_value = 10000 - -max_length :: Int -max_length = 1000 - --- Accumulator Tests - -fromFold :: Property -fromFold = - forAll (listOf $ chooseInt (min_value, max_value)) $ \ls -> - monadicIO $ do - s1 <- S.parse (P.fromFold FL.sum) (S.fromList ls) - o2 <- S.fold FL.sum (S.fromList ls) - return $ - case s1 of - Right o1 -> o1 == o2 - Left _ -> False - -fromPure :: Property -fromPure = - forAll (chooseInt (min_value, max_value)) $ \x -> - case runIdentity $ S.parse (P.fromPure x) (S.fromList [1 :: Int]) of - Right r -> r == x - Left _ -> False - -fromEffect :: Property -fromEffect = - forAll (chooseInt (min_value, max_value)) $ \x -> - case runIdentity $ S.parse (P.fromEffect $ return x) (S.fromList [1 :: Int]) of - Right r -> r == x - Left _ -> False - -die :: Property -die = - property $ - case runIdentity $ S.parse (P.die "die test") (S.fromList [0 :: Int]) of - Right _ -> False - Left _ -> True - -dieM :: Property -dieM = - property $ - case runIdentity $ S.parse (P.dieM (Identity "die test")) (S.fromList [0 :: Int]) of - Right _ -> False - Left _ -> True - -parserFail :: Property -parserFail = - property $ - case runIdentity $ S.parse (Fail.fail err) (S.fromList [0 :: Int]) of - Right _ -> False - Left (ParseError e) -> err == e - where - err = "Testing MonadFail.fail." - --- Element Parser Tests - -peekPass :: Property -peekPass = - forAll (chooseInt (1, max_length)) $ \list_length -> - forAll (vectorOf list_length (chooseInt (min_value, max_value))) $ \ls -> - case runIdentity $ S.parse P.peek (S.fromList ls) of - Right head_value -> case ls of - head_ls : _ -> head_value == head_ls - _ -> False - Left _ -> False - -peekFail :: Property -peekFail = - property (case runIdentity $ S.parse P.peek (S.fromList []) of - Right _ -> False - Left _ -> True) - -eofPass :: Property -eofPass = - property (case runIdentity $ S.parse P.eof (S.fromList []) of - Right _ -> True - Left _ -> False) - -eofFail :: Property -eofFail = - forAll (chooseInt (1, max_length)) $ \list_length -> - forAll (vectorOf list_length (chooseInt (min_value, max_value))) $ \ls -> - case runIdentity $ S.parse P.eof (S.fromList ls) of - Right _ -> False - Left _ -> True - -satisfyPass :: Property -satisfyPass = - forAll (chooseInt (mid_value, max_value)) $ \first_element -> - forAll (listOf (chooseInt (min_value, max_value))) $ \ls_tail -> - let - ls = first_element : ls_tail - predicate = (>= mid_value) - in - case runIdentity $ S.parse (P.satisfy predicate) (S.fromList ls) of - Right r -> r == first_element - Left _ -> False - -satisfy :: Property -satisfy = - forAll (listOf (chooseInt (min_value, max_value))) $ \ls -> - case runIdentity $ S.parse (P.satisfy predicate) (S.fromList ls) of - Right r -> case ls of - [] -> False - (x : _) -> predicate x && (r == x) - Left _ -> case ls of - [] -> True - (x : _) -> not $ predicate x - where - predicate = (>= mid_value) - -onePass :: Property -onePass = - forAll (chooseInt (1, max_value)) $ \int -> - property (case runIdentity $ S.parse P.one (S.fromList [int]) of - Right i -> i == int - Left _ -> False) - -one :: Property -one = - property $ - case runIdentity $ S.parse P.one (S.fromList []) of - Left _ -> True - Right _ -> False - --- Sequence Parsers Tests -takeBetweenPass :: Property -takeBetweenPass = - forAll (chooseInt (min_value, max_value)) $ \m -> - forAll (chooseInt (m, max_value)) $ \n -> - forAll (chooseInt (m, max_value)) $ \list_length -> - forAll (vectorOf list_length (chooseInt (min_value, max_value))) - $ \ls -> - case runIdentity $ S.parse (P.takeBetween m n FL.toList) - (S.fromList ls) of - Right parsed_list -> - let lpl = Prelude.length parsed_list - in checkListEqual parsed_list - $ Prelude.take lpl ls - Left _ -> property False - -takeBetween :: Property -takeBetween = - forAll (chooseInt (min_value, max_value)) $ \m -> - forAll (chooseInt (min_value, max_value)) $ \n -> - forAll (listOf (chooseInt (min_value, max_value))) $ \ls -> - go m n ls - - where - - go m n ls = - let inputLen = Prelude.length ls - in do - let p = P.takeBetween m n FL.toList - case runIdentity $ S.parse p (S.fromList ls) of - Right xs -> - let parsedLen = Prelude.length xs - in if inputLen >= m && parsedLen >= m && parsedLen <= n - then checkListEqual xs $ Prelude.take parsedLen ls - else property False - Left _ -> - property ((m >= 0 && n >= 0 && m > n) || inputLen < m) - - -takeEQPass :: Property -takeEQPass = - forAll (chooseInt (min_value, max_value)) $ \n -> - forAll (chooseInt (n, max_value)) $ \list_length -> - forAll (vectorOf list_length - (chooseInt (min_value, max_value))) $ \ls -> - case runIdentity $ S.parse (P.takeEQ n FL.toList) (S.fromList ls) of - Right parsed_list -> - checkListEqual parsed_list (Prelude.take n ls) - Left _ -> property False - -takeEQ :: Property -takeEQ = - forAll (chooseInt (min_value, max_value)) $ \n -> - forAll (listOf (chooseInt (min_value, max_value))) $ \ls -> - let - list_length = Prelude.length ls - in - case runIdentity $ S.parse (P.takeEQ n FL.toList) (S.fromList ls) of - Right parsed_list -> - if n <= list_length - then checkListEqual parsed_list (Prelude.take n ls) - else property False - Left _ -> property (n > list_length) - -takeGEPass :: Property -takeGEPass = - forAll (chooseInt (min_value, max_value)) $ \n -> - forAll (chooseInt (n, max_value)) $ \list_length -> - forAll (vectorOf list_length (chooseInt (min_value, max_value))) - $ \ls -> - case runIdentity $ S.parse (P.takeGE n FL.toList) (S.fromList ls) of - Right parsed_list -> checkListEqual parsed_list ls - Left _ -> property False - -takeGE :: Property -takeGE = - forAll (chooseInt (min_value, max_value)) $ \n -> - forAll (listOf (chooseInt (min_value, max_value))) $ \ls -> - let - list_length = Prelude.length ls - in - case runIdentity $ S.parse (P.takeGE n FL.toList) (S.fromList ls) of - Right parsed_list -> - if n <= list_length - then checkListEqual parsed_list ls - else property False - Left _ -> property (n > list_length) - - -nLessThanEqual0 :: - ( Int - -> FL.Fold Identity Int [Int] - -> P.Parser Int Identity [Int] - ) - -> (Int -> [Int] -> [Int]) - -> Property -nLessThanEqual0 tk ltk = - forAll (elements [0, (-1)]) $ \n -> - forAll (listOf arbitrary) $ \ls -> - case runIdentity $ S.parse (tk n FL.toList) (S.fromList ls) of - Right parsed_list -> checkListEqual parsed_list (ltk n ls) - Left _ -> property False - -takeProperties :: Spec -takeProperties = - describe "take combinators when n <= 0/" $ do - prop "takeEQ n FL.toList = []" $ - nLessThanEqual0 P.takeEQ (\_ -> const []) - prop "takeGE n FL.toList xs = xs" $ - nLessThanEqual0 P.takeGE (\_ -> id) - --- lookAheadPass :: Property --- lookAheadPass = --- forAll (chooseInt (min_value + 1, max_value)) $ \n -> --- let --- takeWithoutConsume = P.lookAhead $ P.take n FL.toList --- parseTwice = do --- parsed_list_1 <- takeWithoutConsume --- parsed_list_2 <- takeWithoutConsume --- return (parsed_list_1, parsed_list_2) --- in --- forAll (chooseInt (n, max_value)) $ \list_length -> --- forAll (vectorOf list_length (chooseInt (min_value, max_value))) $ \ls -> --- case S.parse parseTwice (S.fromList ls) of --- Right (ls_1, ls_2) -> checkListEqual ls_1 ls_2 .&&. checkListEqual ls_1 (Prelude.take n ls) --- Left _ -> property $ False - --- lookAheadFail :: Property --- lookAheadFail = --- forAll (chooseInt (min_value + 1, max_value)) $ \n -> --- let --- takeWithoutConsume = P.lookAhead $ P.take n FL.toList --- parseTwice = do --- parsed_list_1 <- takeWithoutConsume --- parsed_list_2 <- takeWithoutConsume --- return (parsed_list_1, parsed_list_2) --- in --- forAll (chooseInt (min_value, n - 1)) $ \list_length -> --- forAll (vectorOf list_length (chooseInt (min_value, max_value))) $ \ls -> --- case S.parse parseTwice (S.fromList ls) of --- Right _ -> False --- Left _ -> True - --- lookAhead :: Property --- lookAhead = --- forAll (chooseInt (min_value, max_value)) $ \n -> --- let --- takeWithoutConsume = P.lookAhead $ P.take n FL.toList --- parseTwice = do --- parsed_list_1 <- takeWithoutConsume --- parsed_list_2 <- takeWithoutConsume --- return (parsed_list_1, parsed_list_2) --- in --- forAll (listOf (chooseInt (min_value, max_value))) $ \ls -> --- case S.parse parseTwice (S.fromList ls) of --- Right (ls_1, ls_2) -> checkListEqual ls_1 ls_2 .&&. checkListEqual ls_1 (Prelude.take n ls) --- Left _ -> property ((list_length < n) || (list_length == n && n == 0)) --- where --- list_length = Prelude.length ls - -takeEndBy_ :: Property -takeEndBy_ = - forAll (listOf (chooseInt (min_value, max_value ))) $ \ls -> - case runIdentity $ S.parse (P.takeEndBy_ predicate prsr) (S.fromList ls) of - Right parsed_list -> - checkListEqual parsed_list (tkwhl ls) - Left _ -> property False - where - predicate = (>= 100) - prsr = P.many (P.satisfy (const True)) FL.toList - tkwhl ls = Prelude.takeWhile (not . predicate) ls - -takeStartBy :: Property -takeStartBy = - forAll (listOf (chooseInt (min_value, max_value))) $ \ls -> - let ls1 = 1:ls - in - case runIdentity $ S.parse parser (S.fromList ls1) of - Right parsed_list -> - if not $ Prelude.null ls1 - then - let tls = Prelude.takeWhile (not . predicate) (tail ls1) - in checkListEqual parsed_list $ - if predicate (head ls1) - then head ls1 : tls - else Prelude.takeWhile (not . predicate) ls1 - else property $ Prelude.null parsed_list - Left _ -> property False - where - predicate = odd - parser = P.takeStartBy predicate FL.toList - -takeWhile :: Property -takeWhile = - forAll (listOf (chooseInt (0, 1))) $ \ ls -> - case runIdentity $ S.parse (P.takeWhile predicate FL.toList) (S.fromList ls) of - Right parsed_list -> - checkListEqual parsed_list (Prelude.takeWhile predicate ls) - Left _ -> property False - where - predicate = (== 0) - -takeP :: Property -takeP = - forAll - ((,) <$> chooseInt (min_value, max_value) - <*> listOf (chooseInt (0, 1))) - $ \(takeNum, ls) -> - case runIdentity $ S.parse - (P.takeP takeNum (P.fromFold FL.toList)) - (S.fromList ls) of - Right parsed_list -> - checkListEqual parsed_list (Prelude.take takeNum ls) - Left _ -> property False - -takeWhile1 :: Property -takeWhile1 = - forAll (listOf (chooseInt (0, 1))) $ \ ls -> - case runIdentity $ S.parse (P.takeWhile1 predicate FL.toList) (S.fromList ls) of - Right parsed_list -> case ls of - [] -> property False - (x : _) -> - if predicate x - then - checkListEqual parsed_list - $ Prelude.takeWhile predicate ls - else - property False - Left _ -> case ls of - [] -> property True - (x : _) -> property (not $ predicate x) - where - predicate = (== 0) - -takeWhileP :: Property -takeWhileP = - forAll (listOf (chooseInt (0, 1))) $ \ls -> - forAll (chooseInt (min_value, max_value)) $ \n -> - let - predicate = (== 1) - - prsr = - P.takeWhileP predicate - $ P.fromFold (FL.take n FL.toList) - - takeWhileTillLen maxLen prd list = - Prelude.take maxLen $ Prelude.takeWhile prd list - in - case runIdentity $ S.parse prsr (S.fromList ls) of - Right parsed_list -> - checkListEqual - parsed_list - (takeWhileTillLen n predicate ls) - Left _ -> property False - -{- -choice :: Property -choice = - forAll - ((,,) <$> chooseInt (min_value, max_value) - <*> chooseInt (min_value, max_value) - <*> listOf (chooseInt (0, 1))) - $ \(i, j, ls) -> - case S.parse (P.choice [parser i, parser j]) (S.fromList ls) of - Right parsed_list -> - checkListEqual parsed_list $ take (min i j) ls - Left _ -> property False - - where - - parser i = P.fromFold (FL.take i FL.toList) --} - -groupBy :: Property -groupBy = - forAll (listOf (chooseInt (0, 1))) - $ \ls -> - case runIdentity $ S.parse parser (S.fromList ls) of - Right parsed -> checkListEqual parsed (groupByLF ls) - Left _ -> property False - - where - - cmp = (==) - parser = P.groupBy cmp FL.toList - groupByLF lst - | null lst = [] - | otherwise = head $ List.groupBy cmp lst - -wordBy :: Property -wordBy = - forAll (listOf (elements [' ', 's'])) - $ \ls -> - case runIdentity $ S.parse parser (S.fromList ls) of - Right parsed -> checkListEqual parsed (words' ls) - Left _ -> property False - - where - - predicate = (== ' ') - parser = P.many (P.wordBy predicate FL.toList) FL.toList - words' lst = - let wrds = words lst - in if wrds == [] && length lst > 0 then [""] else wrds - -parseManyWordQuotedBy :: H.SpecWith () -parseManyWordQuotedBy = - describe "parseMany wordQuotedBy" - $ for_ testCases - $ \c@(kQ, isQ, input, expected) -> do - let inpStrm = S.fromList input - - esc = '\\' - - spc ' ' = True - spc _ = False - - tr _ _ = Nothing - - parser = P.wordWithQuotes kQ tr esc isQ spc FL.toList - result <- H.runIO $ S.fold FL.toList $ S.catRights $ S.parseMany parser inpStrm - H.it (showCase c) $ result `H.shouldBe` expected - - where - - showCase (kQ, _, input, expected) = - show kQ ++ ", " ++ input ++ " -> " ++ show expected - - testCases = - [ ( True - , \x -> if x == '\'' then Just '\'' else Nothing - , "The quick brown fox" - , ["The", "quick", "brown", "fox"]) - , ( True - , \x -> if x == '\'' then Just '\'' else Nothing - , "The' quick brown' fox" - , ["The' quick brown'", "fox"]) - , ( False - , \x -> if x == '\'' then Just '\'' else Nothing - , "The' quick brown' fox" - , ["The quick brown", "fox"]) - , ( True - , \x -> if x == '[' then Just ']' else Nothing - , "The[ quick brown] fox" - , ["The[ quick brown]", "fox"]) - , ( True - , \x -> if x == '[' then Just ']' else Nothing - , "The[ qui[ck] brown] \\ f[ ox]" - , ["The[ qui[ck] brown]", " f[ ox]"]) - , ( False - , \x -> if x == '[' then Just ']' else Nothing - , "The[ qui[ck] brown] fox" - , ["The qui[ck] brown", "fox"]) - ] - - --- splitWithPass :: Property --- splitWithPass = --- forAll (listOf (chooseInt (0, 1))) $ \ls -> --- case S.parse (P.splitWith (,) (P.satisfy (== 0)) (P.satisfy (== 1))) (S.fromList ls) of --- Right (result_first, result_second) -> case ls of --- 0 : 1 : _ -> (result_first == 0) && (result_second == 1) --- _ -> False --- Left _ -> case ls of --- 0 : 1 : _ -> False --- _ -> True - --- splitWithFailLeft :: Property --- splitWithFailLeft = --- property (case S.parse (P.splitWith (,) (P.die "die") (P.fromPure (1 :: Int))) (S.fromList [1 :: Int]) of --- Right _ -> False --- Left _ -> True) - --- splitWithFailRight :: Property --- splitWithFailRight = --- property (case S.parse (P.splitWith (,) (P.fromPure (1 :: Int)) (P.die "die")) (S.fromList [1 :: Int]) of --- Right _ -> False --- Left _ -> True) - --- splitWithFailBoth :: Property --- splitWithFailBoth = --- property (case S.parse (P.splitWith (,) (P.die "die") (P.die "die")) (S.fromList [1 :: Int]) of --- Right _ -> False --- Left _ -> True) - --- teeWithPass :: Property --- teeWithPass = --- forAll (chooseInt (0, 10000)) $ \n -> --- forAll (listOf (chooseInt (0, 1))) $ \ls -> --- let --- prsr = P.take n FL.toList --- in --- case S.parse (P.teeWith (,) prsr prsr) (S.fromList ls) of --- Right (ls_1, ls_2) -> checkListEqual (Prelude.take n ls) ls_1 .&&. checkListEqual ls_1 ls_2 --- Left _ -> property False - --- teeWithFailLeft :: Property --- teeWithFailLeft = --- property (case S.parse (P.teeWith (,) (P.die "die") (P.fromPure (1 :: Int))) (S.fromList [1 :: Int]) of --- Right _ -> False --- Left _ -> True) - --- teeWithFailRight :: Property --- teeWithFailRight = --- property (case S.parse (P.teeWith (,) (P.fromPure (1 :: Int)) (P.die "die")) (S.fromList [1 :: Int]) of --- Right _ -> False --- Left _ -> True) - --- teeWithFailBoth :: Property --- teeWithFailBoth = --- property (case S.parse (P.teeWith (,) (P.die "die") (P.die "die")) (S.fromList [1 :: Int]) of --- Right _ -> False --- Left _ -> True) - -{- -deintercalate :: Property -deintercalate = - forAll (listOf (chooseAny :: Gen Int)) $ \ls -> - case runIdentity $ S.parse p (S.fromList ls) of - Right evenOdd -> evenOdd == List.partition even ls - Left _ -> False - - where - p1 = P.takeWhile even FL.toList - p2 = P.takeWhile odd FL.toList - partition = - FL.tee (fmap concat $ FL.catLefts FL.toList) - (fmap concat $ FL.catRights FL.toList) - p = P.deintercalate p1 p2 partition --} - --- shortestPass :: Property --- shortestPass = --- forAll (listOf (chooseInt(min_value, max_value))) $ \ls -> --- let --- prsr_1 = P.takeWhile (<= (mid_value `Prelude.div` 2)) FL.toList --- prsr_2 = P.takeWhile (<= mid_value) FL.toList --- prsr_shortest = P.shortest prsr_1 prsr_2 --- in --- case S.parse prsr_shortest (S.fromList ls) of --- Right short_list -> checkListEqual short_list (Prelude.takeWhile (<= 2500) ls) --- Left _ -> property False - --- shortestFailLeft :: Property --- shortestFailLeft = --- property (case S.parse (P.shortest (P.die "die") (P.fromPure (1 :: Int))) (S.fromList [1 :: Int]) of --- Right r -> r == 1 --- Left _ -> False) - --- shortestFailRight :: Property --- shortestFailRight = --- property (case S.parse (P.shortest (P.fromPure (1 :: Int)) (P.die "die")) (S.fromList [1 :: Int]) of --- Right r -> r == 1 --- Left _ -> False) - --- shortestFailBoth :: Property --- shortestFailBoth = --- property (case S.parse (P.shortest (P.die "die") (P.die "die")) (S.fromList [1 :: Int]) of --- Right _ -> False --- Left _ -> True) - -many :: Property -many = - forAll (listOf (chooseInt (0, 1))) $ \ls -> - let fldstp conL currL = return $ FL.Partial $ conL ++ currL - concatFold = FL.Fold fldstp (return (FL.Partial [])) return - prsr = - flip P.many concatFold $ P.fromFold $ FL.takeEndBy_ (== 1) FL.toList - in - case runIdentity $ S.parse prsr (S.fromList ls) of - Right res_list -> checkListEqual res_list - $ Prelude.filter (== 0) ls - Left _ -> property False - --- many_empty :: Property --- many_empty = --- property (case S.parse (P.many FL.toList (P.die "die")) (S.fromList [1 :: Int]) of --- Right res_list -> checkListEqual res_list ([] :: [Int]) --- Left _ -> property False) - -some :: Property -some = - forAll (listOf (chooseInt (0, 1))) $ \genLs -> - let - ls = 0 : genLs - fldstp conL currL = return $ FL.Partial $ conL ++ currL - concatFold = FL.Fold fldstp (return (FL.Partial [])) return - prsr = - flip P.some concatFold $ P.fromFold $ FL.takeEndBy_ (== 1) FL.toList - in - case runIdentity $ S.parse prsr (S.fromList ls) of - Right res_list -> res_list == Prelude.filter (== 0) ls - Left _ -> False - --- someFail :: Property --- someFail = --- property (case S.parse (P.some FL.toList (P.die "die")) (S.fromList [1 :: Int]) of --- Right _ -> False --- Left _ -> True) - -------------------------------------------------------------------------------- --- Instances -------------------------------------------------------------------------------- - -applicative :: Property -applicative = - forAll (listOf (chooseAny :: Gen Int)) $ \ list1 -> - forAll (listOf (chooseAny :: Gen Int)) $ \ list2 -> - let parser = - (,) - <$> P.fromFold (FL.take (length list1) FL.toList) - <*> P.fromFold (FL.take (length list2) FL.toList) - in monadicIO $ do - s <- S.parse parser (S.fromList $ list1 ++ list2) - return $ - case s of - Right (olist1, olist2) -> olist1 == list1 && olist2 == list2 - Left _ -> False - -sequence :: Property -sequence = - forAll (vectorOf 11 (listOf (chooseAny :: Gen Int))) $ \ ins -> - let p xs = P.fromFold (FL.take (length xs) FL.toList) - in monadicIO $ do - outs <- run $ - S.parse - (Prelude.sequence $ fmap p ins) - (S.fromList $ concat ins) - return $ - case outs of - Right ls -> ls == ins - Left _ -> False - -monad :: Property -monad = - forAll (listOf (chooseAny :: Gen Int)) $ \ list1 -> - forAll (listOf (chooseAny :: Gen Int)) $ \ list2 -> - let parser = do - olist1 <- P.fromFold (FL.take (length list1) FL.toList) - olist2 <- P.fromFold (FL.take (length list2) FL.toList) - return (olist1, olist2) - in monadicIO $ do - s <- S.parse parser (S.fromList $ list1 ++ list2) - return $ - case s of - Right (olist1, olist2) -> olist1 == list1 && olist2 == list2 - Left _ -> False - -------------------------------------------------------------------------------- --- Stream parsing -------------------------------------------------------------------------------- - -parseMany :: Property -parseMany = - forAll (chooseInt (1,100)) $ \len -> - forAll (listOf (vectorOf len (chooseAny :: Gen Int))) $ \ ins -> - monadicIO $ do - outs <- do - let p = P.fromFold $ FL.take len FL.toList - run - $ S.fold FL.toList - $ S.catRights - $ S.parseMany p (S.fromList $ concat ins) - listEquals (==) outs ins - -------------------------------------------------------------------------------- --- Test for a particular case hit during fs events testing -------------------------------------------------------------------------------- - -evId :: [Word8] -evId = [96,238,17,9,0,0,0,0] - -evFlags :: [Word8] -evFlags = [0,4,1,0,0,0,0,0] - -evPathLen :: [Word8] -evPathLen = [71,0,0,0,0,0,0,0] - -evPath :: [Word8] -evPath = - [47,85,115,101,114,115,47,118,111,108,47,118,101,109,98,97,47,99,111,109 - ,112,111,115,101,119,101 ,108,108,45,116,101,99,104,47,69,110,103,47,112 - ,114,111,106,101,99,116,115,47,115,116,114,101,97,109,108,121,47,115,116 - ,114,101,97,109,108,121,47,116,109,112,47,122,122 - ] - -event :: [Word8] -event = evId ++ evFlags ++ evPathLen ++ evPath - -data Event = Event - { eventId :: Word64 - , eventFlags :: Word32 - , eventAbsPath :: A.Array Word8 - } deriving (Show, Ord, Eq) - -readOneEvent :: P.Parser Word8 IO Event -readOneEvent = do - arr <- P.takeEQ 24 (A.writeN 24) - let arr1 = A.castUnsafe arr :: A.Array Word64 - eid = A.unsafeIndex 0 arr1 - eflags = A.unsafeIndex 1 arr1 - pathLen = fromIntegral $ A.unsafeIndex 2 arr1 - -- XXX handle if pathLen is 0 - path <- P.takeEQ pathLen (A.writeN pathLen) - return $ Event - { eventId = eid - , eventFlags = fromIntegral eflags - , eventAbsPath = path - } - -parseMany2Events :: Property -parseMany2Events = - monadicIO $ do - xs <- - ( run - $ S.fold FL.toList - $ S.catRights - $ S.parseMany readOneEvent - $ S.fromList (concat (replicate 2 event)) - ) - assert (length xs == 2) - -- XXX assuming little endian machine - let ev = Event - { eventId = 152170080 - , eventFlags = 66560 - , eventAbsPath = A.fromList evPath - } - in listEquals (==) xs (replicate 2 ev) - -manyEqParseMany :: Property -manyEqParseMany = - forAll (listOf (chooseInt (0, 100))) $ \lst -> - forAll (chooseInt (1, 100)) $ \i -> - monadicIO $ do - let strm = S.fromList lst - r1 <- run $ S.parse (P.many (split i) FL.toList) strm - r2 <- run $ S.fold FL.toList $ S.catRights $ S.parseMany (split i) strm - return $ - case r1 of - Right o1 -> o1 == r2 - Left _ -> False - - where - - split i = P.fromFold (FL.take i FL.toList) - - -takeEndBy1 :: Property -takeEndBy1 = - forAll (listOf (chooseInt (0, 1))) $ \ls -> - case runIdentity $ S.parse (P.takeEndBy predicate prsr) (S.fromList ls) of - Right parsed_list -> - checkListEqual - parsed_list - (takeWhileAndFirstFail (not . predicate) ls) - Left _ -> property False - where - prsr = P.many (P.satisfy (const True)) FL.toList - - predicate = (== 1) - - takeWhileAndFirstFail prd (x : xs) = - if prd x - then x : takeWhileAndFirstFail prd xs - else [x] - takeWhileAndFirstFail _ [] = [] - -splitWithSuffix - :: Monad m - => (a -> Bool) -> FL.Fold m a b -> S.Stream m a -> S.Stream m b -splitWithSuffix predicate f = S.foldMany (FL.takeEndBy predicate f) - -takeEndBy2 :: Property -takeEndBy2 = - forAll (listOf (chooseInt (0, 1))) $ \ls -> - let - strm = S.fromList ls - - predicate = (==0) - - eitherParsedList = - S.fold FL.toList - $ S.catRights - $ S.parseMany (P.takeEndBy predicate prsr) strm - - where - - prsr = P.many (P.satisfy (const True)) FL.toList - - eitherSplitList = - case ls of - [] -> return [] - _ -> - if last ls == 0 - then S.fold FL.toList $ S.append strm1 (S.fromList []) - else S.fold FL.toList strm1 - - where - - strm1 = splitWithSuffix predicate FL.toList strm - in - case eitherParsedList of - Left _ -> property False - Right parsedList -> - case eitherSplitList of - Left _ -> property False - Right splitList -> checkListEqual parsedList splitList - -takeEndByEsc :: Property -takeEndByEsc = - forAll (listOf (chooseInt (min_value, max_value))) $ \ls -> - let - msg = "takeEndByEsc: trailing escape" - - isSep = even - - isEsc x = x `mod` 6 == 0 - - prsr = P.takeEndByEsc isEsc isSep prsr0 - - where - - prsr0 = P.many (P.satisfy (const True)) FL.toList - - escapeSep maybePrevEsc [] = - case maybePrevEsc of - Nothing -> [] - Just prevEsc -> [prevEsc] - escapeSep maybePrevEsc (x : xs) = - case maybePrevEsc of - Nothing -> - if isEsc x - then escapeSep (Just x) xs - else - if isSep x - then [x] - else x : escapeSep Nothing xs - Just _ -> - x : escapeSep Nothing xs - in - case runIdentity $ S.parse prsr (S.fromList ls) of - Right parsed_list -> checkListEqual parsed_list $ escapeSep Nothing ls - Left err -> property (displayException err == msg) - -takeFramedByEsc_ :: Property -takeFramedByEsc_ = - forAll (listOf (chooseInt (min_value, max_value))) $ \ls -> - let - isBegin = (== 0) - - isEnd = (== 1) - - isEsc = (== 2) - - prsr = P.takeFramedByEsc_ isEsc isBegin isEnd FL.toList - - checkPass (x : xs) maybePrevEsc openMinusClose = - case maybePrevEsc of - Nothing -> - if isEsc x - then checkPass xs (Just x) openMinusClose - else - if isBegin x - then checkPass xs Nothing (openMinusClose + 1) - else - if isEnd x - then - case openMinusClose of - 0 -> False - 1 -> True - _ -> - checkPass - xs - Nothing - (openMinusClose - 1) - else - checkPass xs Nothing openMinusClose - Just _ -> checkPass xs Nothing openMinusClose - checkPass [] _ _ = False - - checkPassBeg [] = False - checkPassBeg xxs@(x:_) - | isBegin x = checkPass xxs Nothing (0 :: Int) - | otherwise = False - - escapeFrame begin end escape l = - let - helper (x : xs) maybePrevEsc openMinusClose = - case maybePrevEsc of - Nothing -> - if escape x - then helper xs (Just x) openMinusClose - else - if begin x - then helper xs Nothing (openMinusClose + 1) - else - if end x - then - if openMinusClose - 1 == 0 - then [] - else - helper - xs - Nothing - (openMinusClose - 1) - else - x : helper xs Nothing openMinusClose - Just prevEsc -> - if escape x || begin x || end x - then x : helper xs Nothing openMinusClose - else - prevEsc : x : helper xs Nothing openMinusClose - helper [] _ _ = error "Cannot Reach Here" - in - helper l Nothing (0 :: Int) - in - case runIdentity $ S.parse prsr (S.fromList ls) of - Right parsed_list -> - if checkPassBeg ls - then checkListEqual parsed_list $ - escapeFrame isBegin isEnd isEsc ls - else property False - Left _ -> - if checkPassBeg ls - then property False - else property True - -takeFramedByEsc_Pass :: Property -takeFramedByEsc_Pass = - forAll (listOf (chooseInt (min_value, max_value))) $ \list -> - let - ls = (0 : list) ++ (Prelude.replicate (Prelude.length list + 1) 1) - - isBegin = (== 0) - - isEnd = (== 1) - - isEsc = (== 2) - - prsr = P.takeFramedByEsc_ isEsc isBegin isEnd FL.toList - - escapeFrame begin end escape l = - let - helper (x : xs) maybePrevEsc openMinusClose = - case maybePrevEsc of - Nothing -> - if escape x - then helper xs (Just x) openMinusClose - else - if begin x - then - if openMinusClose == 0 - then helper xs Nothing (openMinusClose + 1) - else x : helper xs Nothing (openMinusClose + 1) - else - if end x - then - if openMinusClose - 1 == 0 - then [] - else - x : - helper - xs - Nothing - (openMinusClose - 1) - else - x : helper xs Nothing openMinusClose - Just _ -> - x : helper xs Nothing openMinusClose - helper [] _ _ = error "Cannot Reach Here" - in - helper l Nothing (0 :: Int) - in - case runIdentity $ S.parse prsr (S.fromList ls) of - Right parsed_list -> checkListEqual parsed_list $ escapeFrame isBegin isEnd isEsc ls - _ -> property False - -takeFramedByEsc_Fail1 :: Property -takeFramedByEsc_Fail1 = - let - msg = "takeFramedByEsc_: missing frame end" - - isBegin = (== 0) - - isEnd = (== 0) - - isEsc = (== 2) - - prsr = P.takeFramedByEsc_ isEsc isBegin isEnd FL.toList - - ls = [0 :: Int] - in - case runIdentity $ S.parse prsr (S.fromList ls) of - Right _ -> property False - Left err -> property (displayException err == msg) - -takeFramedByEsc_Fail2 :: Property -takeFramedByEsc_Fail2 = - let - msg = "takeFramedByEsc_: missing frame start" - - isBegin = (== 0) - - isEnd = (== 1) - - isEsc = (== 1) - - prsr = P.takeFramedByEsc_ isEsc isBegin isEnd FL.toList - - ls = [1 :: Int] - in - case runIdentity $ S.parse prsr (S.fromList ls) of - Right _ -> property False - Left err -> property (displayException err == msg) - -takeFramedByEsc_Fail3 :: Property -takeFramedByEsc_Fail3 = - let - msg = "takeFramedByEsc_: missing frame end" - - isBegin = (== 2) - - isEnd = (== 1) - - isEsc = (== 2) - - prsr = P.takeFramedByEsc_ isEsc isBegin isEnd FL.toList - - ls = [2 :: Int] - in - case runIdentity $ S.parse prsr (S.fromList ls) of - Right _ -> property False - Left err -> property $ (displayException err == msg) - -takeStartBy_ :: Property -takeStartBy_ = - forAll (listOf (chooseInt (min_value, max_value))) $ \ls -> - let ls1 = 1:ls - msg = "takeFramedByGeneric: empty token" - in - case runIdentity $ S.parse parser (S.fromList ls1) of - Right parsed_list -> - if not $ Prelude.null ls1 - then - let tls = Prelude.takeWhile (not . predicate) (tail ls1) - in checkListEqual parsed_list $ - if predicate (head ls1) - then tls - else Prelude.takeWhile (not . predicate) ls1 - else property $ Prelude.null parsed_list - Left err -> property (displayException err == msg) - where - predicate = odd - parser = P.takeStartBy_ predicate FL.toList -------------------------------------------------------------------------------- --- Main -------------------------------------------------------------------------------- - -moduleName :: String -moduleName = "Data.Parser" - -main :: IO () -main = - hspec $ - H.parallel $ - modifyMaxSuccess (const maxTestCount) $ do - describe moduleName $ do - - describe "Instances" $ do - prop "applicative" applicative - prop "monad" monad - prop "sequence" sequence - describe "Stream parsing" $ do - prop "parseMany" parseMany - prop "parseMany2Events" parseMany2Events - - describe "test for accumulator" $ do - prop "P.fromFold FL.sum = FL.sum" fromFold - prop "fromPure value provided" fromPure - prop "fromPure monadic value provided" fromEffect - prop "fail err = Left (SomeException (ParseError err))" parserFail - prop "always fail" die - prop "always fail but monadic" dieM - - describe "test for element parser" $ do - prop "peek = head with list length > 0" peekPass - prop "peek fail on []" peekFail - prop "eof pass on []" eofPass - prop "eof fail on non-empty list" eofFail - prop "first element exists and >= mid_value" satisfyPass - prop "one pass on [Int]" onePass - prop "one fail on []" one - prop "check first element exists and satisfies predicate" satisfy - - describe "test for sequence parser" $ do - prop "P.takeBetween = Prelude.take when len >= m and len <= n" - takeBetweenPass - prop ("P.takeBetween = Prelude.take when len >= m and len <= n and fail" - ++ "otherwise fail") Main.takeBetween - - prop "P.takeEQ = Prelude.take when len >= n" takeEQPass - prop "P.takeEQ = Prelude.take when len >= n and fail otherwise" - Main.takeEQ - prop "P.takeGE n ls = ls when len >= n" takeGEPass - prop "P.takeGE n ls = ls when len >= n and fail otherwise" Main.takeGE - -- prop "lookAhead . take n >> lookAhead . take n = lookAhead . take n" lookAheadPass - -- prop "Fail when stream length exceeded" lookAheadFail - -- prop "lookAhead . take n >> lookAhead . take n = lookAhead . take n, else fail" lookAhead - prop "P.takeEndBy_ test" Main.takeEndBy_ - prop ("P.takeStartBy pred = head : Prelude.takeWhile (not . pred)" - ++ " tail") takeStartBy - prop "P.takeWhile = Prelude.takeWhile" Main.takeWhile - prop ("P.takeWhile1 = Prelude.takeWhile if taken something," - ++ " else check why failed") takeWhile1 - prop "takeWhileP prd P.take = takeWhileMaxLen prd" takeWhileP - prop ("P.takeP = Prelude.take") takeP - prop "P.groupBy = Prelude.head . Prelude.groupBy" groupBy - prop "many (P.wordBy ' ') = words'" wordBy - parseManyWordQuotedBy - -- prop "choice" choice - -- prop "" splitWithPass - -- prop "" splitWithFailLeft - -- prop "" splitWithFailRight - -- prop "" splitWithFailBoth - -- prop "" teeWithPass - -- prop "" teeWithFailLeft - -- prop "" teeWithFailRight - -- prop "" teeWithFailBoth - -- prop "deintercalate" deintercalate - -- prop "" shortestPass - -- prop "" shortestFailLeft - -- prop "" shortestFailRight - -- prop "" shortestFailBoth - prop ("P.many concatFold $ P.takeEndBy_ (== 1) FL.toList =" - ++ "Prelude.filter (== 0)") many - -- prop "[] due to parser being die" many_empty - prop ("P.some concatFold $ P.takeEndBy_ (== 1) FL.toList =" - ++ "Prelude.filter (== 0)") some - -- prop "fail due to parser being die" someFail - prop "P.many == S.parseMany" manyEqParseMany - - prop "takeEndBy_" takeEndBy_ - prop "takeEndBy1" takeEndBy1 - prop "takeEndBy2" takeEndBy2 - prop "takeEndByEsc" takeEndByEsc - prop "takeFramedByEsc_" takeFramedByEsc_ - prop "takeFramedByEsc_Pass" takeFramedByEsc_Pass - prop "takeFramedByEsc_Fail1" takeFramedByEsc_Fail1 - prop "takeFramedByEsc_Fail2" takeFramedByEsc_Fail2 - prop "takeFramedByEsc_Fail3" takeFramedByEsc_Fail3 - prop "takeStartBy_" takeStartBy_ - - takeProperties +{-# Language NoMonoLocalBinds #-} +-- XXX We are using head/tail at one place +#if __GLASGOW_HASKELL__ >= 908 +{-# OPTIONS_GHC -Wno-x-partial #-} +#endif +module Main (main) where + +import Control.Applicative ((<|>)) +import Control.Exception (displayException) +import Control.Monad.IO.Class (MonadIO(..)) +import Data.Char (isSpace) +import Data.Foldable (for_) +import Data.Word (Word8, Word32, Word64) +import Streamly.Internal.Data.Fold (Fold(..)) +import Streamly.Internal.Data.Parser (Parser(..), Step(..), Initial(..), Final(..)) +import Streamly.Test.Common (listEquals, checkListEqual, chooseInt) +import Streamly.Internal.Data.Parser (ParseError(..)) +import Test.QuickCheck (forAll, Property, property, listOf, vectorOf, Gen) +import Test.QuickCheck.Monadic (monadicIO, assert, run) + +import Prelude hiding (sequence) + +import qualified Streamly.Test.Data.Parser.Common as Common +import qualified Streamly.Data.Stream as S +import qualified Streamly.Internal.Data.Array as A +import qualified Streamly.Internal.Data.Fold as FL +import qualified Streamly.Internal.Data.Parser as P +import qualified Streamly.Internal.Data.ParserK as PK +import qualified Streamly.Internal.Data.Producer as Producer +import qualified Streamly.Internal.Data.Unfold as Unfold +import qualified Streamly.Internal.Data.Stream as SI +import qualified Streamly.Internal.Data.StreamK as K +import qualified Test.Hspec as H + +import Test.Hspec +import Test.Hspec.QuickCheck +import Streamly.Test.Parser.Common + +#if MIN_VERSION_QuickCheck(2,14,0) + +import Test.QuickCheck (chooseAny) + +#else + +import System.Random (Random(random)) +import Test.QuickCheck.Gen (Gen(MkGen)) + +-- | Generates a random element over the natural range of `a`. +chooseAny :: Random a => Gen a +chooseAny = MkGen (\r _ -> let (x,_) = random r in x) + +#endif + +maxTestCount :: Int +maxTestCount = 100 + +------------------------------------------------------------------------------- +-- Stream parsing +------------------------------------------------------------------------------- + +parseManyWordQuotedBy :: H.SpecWith () +parseManyWordQuotedBy = + describe "parseMany wordQuotedBy" + $ for_ testCases + $ \c@(kQ, isQ, input, expected) -> do + let inpStrm = S.fromList input + + esc = '\\' + + spc ' ' = True + spc _ = False + + tr _ _ = Nothing + + parser = P.wordWithQuotes kQ tr esc isQ spc FL.toList + result <- H.runIO $ S.fold FL.toList $ S.catRights $ S.parseMany parser inpStrm + H.it (showCase c) $ result `H.shouldBe` expected + + where + + showCase (kQ, _, input, expected) = + show kQ ++ ", " ++ input ++ " -> " ++ show expected + + testCases = + [ ( True + , \x -> if x == '\'' then Just '\'' else Nothing + , "The quick brown fox" + , ["The", "quick", "brown", "fox"]) + , ( True + , \x -> if x == '\'' then Just '\'' else Nothing + , "The' quick brown' fox" + , ["The' quick brown'", "fox"]) + , ( False + , \x -> if x == '\'' then Just '\'' else Nothing + , "The' quick brown' fox" + , ["The quick brown", "fox"]) + , ( True + , \x -> if x == '[' then Just ']' else Nothing + , "The[ quick brown] fox" + , ["The[ quick brown]", "fox"]) + , ( True + , \x -> if x == '[' then Just ']' else Nothing + , "The[ qui[ck] brown] \\ f[ ox]" + , ["The[ qui[ck] brown]", " f[ ox]"]) + , ( False + , \x -> if x == '[' then Just ']' else Nothing + , "The[ qui[ck] brown] fox" + , ["The qui[ck] brown", "fox"]) + ] + +parseMany :: Property +parseMany = + forAll (chooseInt (1,100)) $ \len -> + forAll (listOf (vectorOf len (chooseAny :: Gen Int))) $ \ ins -> + monadicIO $ do + outs <- do + let p = P.fromFold $ FL.take len FL.toList + run + $ S.fold FL.toList + $ S.catRights + $ S.parseMany p (S.fromList $ concat ins) + listEquals (==) outs ins + + +-- basic sanity test for parsing from arrays +parseUnfold :: Property +parseUnfold = do + let len = 200 + -- ls = input list (stream) + -- clen = chunk size + -- tlen = parser take size + forAll + ((,,) + <$> vectorOf len (chooseAny :: Gen Int) + <*> chooseInt (1, len) + <*> chooseInt (1, len)) $ \(ls, clen, tlen) -> + monadicIO $ do + arrays <- S.toList $ A.chunksOf clen (S.fromList ls) + let src = Producer.source (Just (Producer.OuterLoop arrays)) + let parser = P.fromFold (FL.take tlen FL.toList) + let readSrc = + Producer.producer + $ Producer.concat Producer.fromList A.producer + let streamParser = + Producer.simplify (Producer.parseManyD parser readSrc) + xs <- run + $ S.toList + $ S.unfoldEach Unfold.fromList + $ S.catRights + $ S.unfold streamParser src + + listEquals (==) xs ls + +parserSequence :: Property +parserSequence = + forAll (vectorOf 11 (listOf (chooseAny :: Gen Int))) $ \ins -> + monadicIO $ do + let parsers = S.fromList + $ fmap (\xs -> P.fromFold $ FL.take (length xs) FL.sum) ins + let sequencedParser = P.sequence parsers FL.sum + outs <- + S.parse sequencedParser $ S.concatMap S.fromList (S.fromList ins) + return $ + case outs of + Right x -> x == sum (map sum ins) + Left _ -> False + +------------------------------------------------------------------------------- +-- Test for a particular case hit during fs events testing +------------------------------------------------------------------------------- + +evId :: [Word8] +evId = [96,238,17,9,0,0,0,0] + +evFlags :: [Word8] +evFlags = [0,4,1,0,0,0,0,0] + +evPathLen :: [Word8] +evPathLen = [71,0,0,0,0,0,0,0] + +evPath :: [Word8] +evPath = + [47,85,115,101,114,115,47,118,111,108,47,118,101,109,98,97,47,99,111,109 + ,112,111,115,101,119,101 ,108,108,45,116,101,99,104,47,69,110,103,47,112 + ,114,111,106,101,99,116,115,47,115,116,114,101,97,109,108,121,47,115,116 + ,114,101,97,109,108,121,47,116,109,112,47,122,122 + ] + +event :: [Word8] +event = evId ++ evFlags ++ evPathLen ++ evPath + +data Event = Event + { eventId :: Word64 + , eventFlags :: Word32 + , eventAbsPath :: A.Array Word8 + } deriving (Show, Ord, Eq) + +readOneEvent :: P.Parser Word8 IO Event +readOneEvent = do + arr <- P.takeEQ 24 (A.createOf 24) + let arr1 = A.unsafeCast arr :: A.Array Word64 + eid = A.unsafeGetIndex 0 arr1 + eflags = A.unsafeGetIndex 1 arr1 + pathLen = fromIntegral $ A.unsafeGetIndex 2 arr1 + -- XXX handle if pathLen is 0 + path <- P.takeEQ pathLen (A.createOf pathLen) + return $ Event + { eventId = eid + , eventFlags = fromIntegral eflags + , eventAbsPath = path + } + +parseMany2Events :: Property +parseMany2Events = + monadicIO $ do + xs <- + ( run + $ S.fold FL.toList + $ S.catRights + $ S.parseMany readOneEvent + $ S.fromList (concat (replicate 2 event)) + ) + assert (length xs == 2) + -- XXX assuming little endian machine + let ev = Event + { eventId = 152170080 + , eventFlags = 66560 + , eventAbsPath = A.fromList evPath + } + in listEquals (==) xs (replicate 2 ev) + +-------------------------------------------------------------------------------- +-- Parser sequence tests +-------------------------------------------------------------------------------- + +manyEqParseMany :: Property +manyEqParseMany = + forAll (listOf (chooseInt (0, 100))) $ \lst -> + forAll (chooseInt (1, 100)) $ \i -> + monadicIO $ do + let strm = S.fromList lst + r1 <- run $ S.parse (P.many (split i) FL.toList) strm + r2 <- run $ S.fold FL.toList $ S.catRights $ S.parseMany (split i) strm + return $ + case r1 of + Right o1 -> o1 == r2 + Left _ -> False + + where + + split i = P.fromFold (FL.take i FL.toList) + +splitWithSuffix + :: Monad m + => (a -> Bool) -> FL.Fold m a b -> S.Stream m a -> S.Stream m b +splitWithSuffix predicate f = S.foldMany (FL.takeEndBy predicate f) + +takeEndBy2 :: Property +takeEndBy2 = + forAll (listOf (chooseInt (0, 1))) $ \ls -> + let + strm = S.fromList ls + + predicate = (==0) + + eitherParsedList = + S.fold FL.toList + $ S.catRights + $ S.parseMany (P.takeEndBy predicate prsr) strm + + where + + prsr = P.many (P.satisfy (const True)) FL.toList + + eitherSplitList = + case ls of + [] -> return [] + _ -> + if last ls == 0 + then S.fold FL.toList $ S.append strm1 (S.fromList []) + else S.fold FL.toList strm1 + + where + + strm1 = splitWithSuffix predicate FL.toList strm + in + case eitherParsedList of + Left _ -> property False + Right parsedList -> + case eitherSplitList of + Left _ -> property False + Right splitList -> checkListEqual parsedList splitList + + +-------------------------------------------------------------------------------- +-- Parser quoted word tests +-------------------------------------------------------------------------------- + +quotedWordTest :: String -> [String] -> IO () +quotedWordTest inp expected = do + res <- + S.fold FL.toList + $ catRightsErr + $ S.parseMany quotedWord $ S.fromList inp + res `shouldBe` expected + where + catRightsErr = fmap (either (error . displayException) id) + quotedWord = + let toRQuote x = + case x of + '"' -> Just x + '\'' -> Just x + _ -> Nothing + -- Inside ", + -- * \\ is translated to \ + -- * \" is translated to " + trEsc '"' x = + case x of + '\\' -> Just '\\' + '"' -> Just '"' + _ -> Nothing + trEsc _ _ = Nothing + in P.wordWithQuotes False trEsc '\\' toRQuote isSpace FL.toList + +-------------------------------------------------------------------------------- +-- Parser sanity tests +-------------------------------------------------------------------------------- + +{- +TODO: +Add sanity tests for +- Producer.parse +- Producer.parseMany +-} + +sanityParseBreak :: [Move] -> SpecWith () +sanityParseBreak jumps = it (show jumps) $ do + (val, rest) <- SI.parseBreakPos (jumpParser jumps) $ S.fromList tape + lst <- S.toList rest + (val, lst) `shouldBe` (expectedResult jumps tape) + +sanityParseDBreak :: [Move] -> SpecWith () +sanityParseDBreak jumps = it (show jumps) $ do + (val, rest) <- K.parseBreakPos (PK.toParserK (jumpParser jumps)) $ K.fromList tape + lst <- K.toList rest + (val, lst) `shouldBe` (expectedResult jumps tape) + +{- +sanityParseBreakChunksK :: [Move] -> SpecWith () +sanityParseBreakChunksK jumps = it (show jumps) $ do + (val, rest) <- + A.parseBreakChunksK (jumpParser jumps) + $ K.fromList $ Prelude.map A.fromList chunkedTape + lst <- Prelude.map A.toList <$> K.toList rest + (val, concat lst) `shouldBe` (expectedResult jumps tape) +-} + +sanityParseMany :: [Move] -> SpecWith () +sanityParseMany jumps = it (show jumps) $ do + res <- S.toList $ SI.parseManyPos (jumpParser jumps) $ S.fromList tape + res `shouldBe` (expectedResultMany jumps tape) + +sanityParseIterate :: [Move] -> SpecWith () +sanityParseIterate jumps = it (show jumps) $ do + res <- + S.toList + $ SI.parseIteratePos (const (jumpParser jumps)) [] $ S.fromList tape + res `shouldBe` (expectedResultMany jumps tape) + +------------------------------------------------------------------------------- +-- Instances +------------------------------------------------------------------------------- + +{-# INLINE takeWhileFailD #-} +takeWhileFailD :: Monad m => (a -> Bool) -> Fold m a b -> Parser a m b +takeWhileFailD predicate (Fold fstep finitial _ ffinal) = + Parser step initial extract + + where + + initial = do + res <- finitial + return $ case res of + FL.Partial s -> IPartial s + FL.Done b -> IDone b + + step s a = + if predicate a + then do + fres <- fstep s a + return + $ case fres of + FL.Partial s1 -> SContinue 1 s1 + FL.Done b -> SDone 1 b + else return $ SError "fail" + + extract s = fmap (FDone 0) (ffinal s) + +{-# INLINE takeWhileFail #-} +takeWhileFail :: MonadIO m => + (a -> Bool) -> Fold m a b -> PK.ParserK a m b +takeWhileFail p f = PK.toParserK (takeWhileFailD p f) + +{-# INLINE takeWhileK #-} +takeWhileK :: MonadIO m => (a -> Bool) -> PK.ParserK a m [a] +takeWhileK p = PK.toParserK $ P.takeWhile p FL.toList + +{-# INLINE alt2 #-} +alt2 :: MonadIO m => K.StreamK m Int -> m (Either ParseError [Int]) +alt2 = + K.parse + ( takeWhileFail (<= 5) FL.toList + <|> takeWhileK (<= 7) + ) + +{-# INLINE altD #-} +altD :: MonadIO m => S.Stream m Int -> m (Either P.ParseError [Int]) +altD = + S.parse + ( takeWhileFailD (<= 5) FL.toList + <|> P.takeWhile (<= 7) FL.toList + ) + +altTests :: Spec +altTests = + describe "alt" $ do + it "alt2 [1..20]" $ alt2 (K.fromList [1..20]) `shouldReturn` Right [1..7] + it "altD [1..20]" $ altD (S.fromList [1..20]) `shouldReturn` Right [1..7] + +------------------------------------------------------------------------------- +-- Main +------------------------------------------------------------------------------- + +moduleName :: String +moduleName = "Data.Parser" + +main :: IO () +main = do + hspec $ + H.parallel $ + modifyMaxSuccess (const maxTestCount) $ do + describe moduleName $ do + parserSanityTests "Stream.parseBreak" sanityParseBreak + parserSanityTests "StreamK.parseDBreak" sanityParseDBreak + -- parserSanityTests "A.sanityParseBreakChunksK" sanityParseBreakChunksK + parserSanityTests "Stream.parseMany" sanityParseMany + parserSanityTests "Stream.parseIterate" sanityParseIterate + describe "Stream parsing" $ do + prop "parseMany" parseMany + prop "parseMany2Events" parseMany2Events + prop "parseUnfold" parseUnfold + prop "parserSequence" parserSequence + + describe "test for sequence parser" $ do + parseManyWordQuotedBy + prop "P.many == S.parseMany" manyEqParseMany + prop "takeEndBy2" takeEndBy2 + + describe "quotedWordTest" $ do + it "Single quote test" $ do + quotedWordTest "'hello\\\\\"world'" ["hello\\\\\"world"] + quotedWordTest "'hello\\'" ["hello\\"] + it "Double quote test" $ do + quotedWordTest + "\"hello\\\"\\\\w\\'orld\"" + ["hello\"\\w\\'orld"] + + + altTests + Common.main diff --git a/test/Streamly/Test/Data/Parser/Common.hs b/test/Streamly/Test/Data/Parser/Common.hs new file mode 100644 --- /dev/null +++ b/test/Streamly/Test/Data/Parser/Common.hs @@ -0,0 +1,1241 @@ +{-# Language NoMonoLocalBinds #-} +-- XXX We are using head/tail at one place +#if __GLASGOW_HASKELL__ >= 908 +{-# OPTIONS_GHC -Wno-x-partial #-} +#endif +module Streamly.Test.Data.Parser.Common (main) where + +import Control.Applicative ((<|>)) +import Control.Exception (displayException, try, evaluate, SomeException) +import Data.List (isSuffixOf) +import Streamly.Internal.Data.MutByteArray (Unbox) +import Streamly.Test.Common (listEquals, checkListEqual, chooseInt) +import Streamly.Internal.Data.Parser (ParseErrorPos(..)) +import Test.QuickCheck + (arbitrary, forAll, elements, Property, property, listOf, + vectorOf, Gen, (.&&.), ioProperty) +import Test.QuickCheck.Monadic (monadicIO, assert, run, PropertyM) + +import Prelude hiding (sequence) + +import qualified Control.Monad.Fail as Fail +import qualified Data.List as List +import qualified Prelude +import qualified Streamly.Internal.Data.Stream as S +import qualified Streamly.Internal.Data.Array as A +import qualified Streamly.Internal.Data.Array.Generic as GA +import qualified Streamly.Internal.Data.Fold as FL +import qualified Streamly.Internal.Data.Parser as P +import qualified Streamly.Internal.Data.ParserK as PK +import qualified Streamly.Internal.Data.StreamK as K + +import Test.Hspec +import Test.Hspec.QuickCheck + +#if MIN_VERSION_QuickCheck(2,14,0) + +import Test.QuickCheck (chooseAny) +import Control.Monad.Identity (Identity(runIdentity, Identity)) + +#else + +import System.Random (Random(random)) +import Test.QuickCheck.Gen (Gen(MkGen)) + +-- | Generates a random element over the natural range of `a`. +chooseAny :: Random a => Gen a +chooseAny = MkGen (\r _ -> let (x,_) = random r in x) + +#endif + +min_value :: Int +min_value = 0 + +mid_value :: Int +mid_value = 5000 + +max_value :: Int +max_value = 10000 + +max_length :: Int +max_length = 1000 + +-- Accumulator Tests + +-- TODO: Replace ParserTestCase_Temp with ParserTestCase in all the test cases. + +type ParserTestCase a m b c = + (P.Parser a m b -> [a] -> m (Either ParseErrorPos b, [a])) -> c + +type ParserTestCase_Temp a m b c = + forall t. ([a] -> t) + -> (P.Parser a m b -> t -> m (Either ParseErrorPos b)) + -> c + +fromFold :: ParserTestCase Int IO Int Property +fromFold consumer = + forAll (listOf $ chooseInt (min_value, max_value)) $ \ls -> + ioProperty $ do + (s1, rest) <- consumer (P.fromFold FL.sum) ls + o2 <- S.fold FL.sum (S.fromList ls) + pure $ rest == [] && + case s1 of + Right o1 -> o1 == o2 + Left _ -> False + +fromPure :: ParserTestCase Int Identity Int Property +fromPure consumer = + forAll (chooseInt (min_value, max_value)) $ \x -> + case runIdentity $ consumer (P.fromPure x) [1 :: Int] of + (Right r, rest) -> r == x && rest == [1 :: Int] + (Left _, _) -> False + +fromEffect :: ParserTestCase Int Identity Int Property +fromEffect consumer = + forAll (chooseInt (min_value, max_value)) $ \x -> + case runIdentity $ consumer (P.fromEffect $ return x) [1 :: Int] of + (Right r, rest) -> r == x && rest == [1 :: Int] + (Left _, _) -> False + +die :: ParserTestCase Int Identity Int Property +die consumer = + property $ + case runIdentity $ consumer (P.die "die test") [0 :: Int] of + (Right _, _) -> False + (Left _, rest) -> rest == [0 :: Int] + +dieM :: ParserTestCase Int Identity Int Property +dieM consumer = + property $ + case runIdentity $ consumer (P.dieM (Identity "die test")) [0 :: Int] of + (Right _, _) -> False + (Left _, rest) -> rest == [0 :: Int] + +parserFail :: ParserTestCase Int Identity Int Property +parserFail consumer = + property $ + case runIdentity $ consumer (Fail.fail err) [0 :: Int] of + (Right _, _) -> False + (Left (ParseErrorPos _ e), rest) -> err == e && rest == [0 :: Int] + where + err = "Testing MonadFail.fail." + +-- Element Parser Tests + +peekPass :: ParserTestCase Int Identity Int Property +peekPass consumer = + forAll (chooseInt (1, max_length)) $ \list_length -> + forAll (vectorOf list_length (chooseInt (min_value, max_value))) $ \ls -> + case runIdentity $ consumer P.peek ls of + (Right head_value, rest) -> case ls of + head_ls : _ -> head_value == head_ls && rest == ls + _ -> False + (Left _, _) -> False + +peekFail :: ParserTestCase Int Identity Int Property +peekFail consumer = + property (case runIdentity $ consumer P.peek [] of + (Right _, _) -> False + (Left _, rest) -> rest == []) + +eofPass :: ParserTestCase_Temp Int Identity () Property +eofPass producer consumer = + property (case runIdentity $ consumer P.eof (producer []) of + Right _ -> True + Left _ -> False) + +eofFail :: ParserTestCase_Temp Int Identity () Property +eofFail producer consumer = + forAll (chooseInt (1, max_length)) $ \list_length -> + forAll (vectorOf list_length (chooseInt (min_value, max_value))) $ \ls -> + case runIdentity $ consumer P.eof (producer ls) of + Right _ -> False + Left _ -> True + +satisfyPass :: ParserTestCase_Temp Int Identity Int Property +satisfyPass producer consumer = + forAll (chooseInt (mid_value, max_value)) $ \first_element -> + forAll (listOf (chooseInt (min_value, max_value))) $ \ls_tail -> + let + ls = first_element : ls_tail + predicate = (>= mid_value) + in + case runIdentity $ consumer (P.satisfy predicate) (producer ls) of + Right r -> r == first_element + Left _ -> False + +satisfy :: ParserTestCase_Temp Int Identity Int Property +satisfy producer consumer = + forAll (listOf (chooseInt (min_value, max_value))) $ \ls -> + case runIdentity $ consumer (P.satisfy predicate) (producer ls) of + Right r -> case ls of + [] -> False + (x : _) -> predicate x && (r == x) + Left _ -> case ls of + [] -> True + (x : _) -> not $ predicate x + where + predicate = (>= mid_value) + +onePass :: ParserTestCase_Temp Int Identity Int Property +onePass producer consumer = + forAll (chooseInt (1, max_value)) $ \int -> + property (case runIdentity $ consumer P.one (producer [int]) of + Right i -> i == int + Left _ -> False) + +one :: ParserTestCase_Temp Int Identity Int Property +one producer consumer = + property $ + case runIdentity $ consumer P.one (producer []) of + Left _ -> True + Right _ -> False + +-- Sequence Parsers Tests +takeBetweenPass :: ParserTestCase_Temp Int Identity [Int] Property +takeBetweenPass producer consumer = + forAll (chooseInt (min_value, max_value)) $ \m -> + forAll (chooseInt (m, max_value)) $ \n -> + forAll (chooseInt (m, max_value)) $ \list_length -> + forAll (vectorOf list_length (chooseInt (min_value, max_value))) + $ \ls -> + case runIdentity $ consumer (P.takeBetween m n FL.toList) + (producer ls) of + Right parsed_list -> + let lpl = Prelude.length parsed_list + in checkListEqual parsed_list + $ Prelude.take lpl ls + Left _ -> property False + +takeBetween :: ParserTestCase_Temp Int Identity [Int] Property +takeBetween producer consumer = + forAll (chooseInt (min_value, max_value)) $ \m -> + forAll (chooseInt (min_value, max_value)) $ \n -> + forAll (listOf (chooseInt (min_value, max_value))) $ \ls -> + ioProperty $ go m n ls + + where + + go m n ls = do + let inputLen = Prelude.length ls + let p = P.takeBetween m n FL.toList + eres <- try $ evaluate $ runIdentity $ consumer p (producer ls) + pure $ case eres of + Left (_ :: SomeException) -> m >= 0 && n >= 0 && m > n + Right (Right xs) -> + let parsedLen = Prelude.length xs + in (inputLen >= m && parsedLen >= m && parsedLen <= n) + && (xs == Prelude.take parsedLen ls) + Right (Left _) -> inputLen < m + + +take :: ParserTestCase_Temp Int Identity [Int] Property +take producer consumer = + forAll (chooseInt (min_value, max_value)) $ \n -> + forAll (listOf (chooseInt (min_value, max_value))) $ \ls -> + case runIdentity $ consumer (P.fromFold $ FL.take n FL.toList) (producer ls) of + Right parsed_list -> checkListEqual parsed_list (Prelude.take n ls) + Left _ -> property False + +takeEQPass :: ParserTestCase_Temp Int Identity [Int] Property +takeEQPass producer consumer = + forAll (chooseInt (min_value, max_value)) $ \n -> + forAll (chooseInt (n, max_value)) $ \list_length -> + forAll (vectorOf list_length + (chooseInt (min_value, max_value))) $ \ls -> + case runIdentity $ consumer (P.takeEQ n FL.toList) (producer ls) of + Right parsed_list -> + checkListEqual parsed_list (Prelude.take n ls) + Left _ -> property False + +takeEQ :: ParserTestCase_Temp Int Identity [Int] Property +takeEQ producer consumer = + forAll (chooseInt (min_value, max_value)) $ \n -> + forAll (listOf (chooseInt (min_value, max_value))) $ \ls -> + let + list_length = Prelude.length ls + in + case runIdentity $ consumer (P.takeEQ n FL.toList) (producer ls) of + Right parsed_list -> + if n <= list_length + then checkListEqual parsed_list (Prelude.take n ls) + else property False + Left _ -> property (n > list_length) + +takeGEPass :: ParserTestCase_Temp Int Identity [Int] Property +takeGEPass producer consumer = + forAll (chooseInt (min_value, max_value)) $ \n -> + forAll (chooseInt (n, max_value)) $ \list_length -> + forAll (vectorOf list_length (chooseInt (min_value, max_value))) + $ \ls -> + case runIdentity $ consumer (P.takeGE n FL.toList) (producer ls) of + Right parsed_list -> checkListEqual parsed_list ls + Left _ -> property False + +takeGE :: ParserTestCase_Temp Int Identity [Int] Property +takeGE producer consumer = + forAll (chooseInt (min_value, max_value)) $ \n -> + forAll (listOf (chooseInt (min_value, max_value))) $ \ls -> + let + list_length = Prelude.length ls + in + case runIdentity $ consumer (P.takeGE n FL.toList) (producer ls) of + Right parsed_list -> + if n <= list_length + then checkListEqual parsed_list ls + else property False + Left _ -> property (n > list_length) + +nLessThanEqual0 :: + ( Int + -> FL.Fold Identity Int [Int] + -> P.Parser Int Identity [Int] + ) + -> (Int -> [Int] -> [Int]) + -> ParserTestCase_Temp Int Identity [Int] Property +nLessThanEqual0 tk ltk producer consumer = + forAll (elements [0, (-1)]) $ \n -> + forAll (listOf arbitrary) $ \ls -> + case runIdentity $ consumer (tk n FL.toList) (producer ls) of + Right parsed_list -> checkListEqual parsed_list (ltk n ls) + Left _ -> property False + +takeProperties :: ParserTestCase_Temp Int Identity [Int] Spec +takeProperties producer consumer = + describe "take combinators when n <= 0/" $ do + prop "takeEQ n FL.toList = []" $ + nLessThanEqual0 P.takeEQ (\_ -> const []) producer consumer + prop "takeGE n FL.toList xs = xs" $ + nLessThanEqual0 P.takeGE (\_ -> id) producer consumer + +-- XXX lookAhead can't deal with EOF which in this case means when +-- n==list_length, this test will fail. So excluding that case for now. +lookAheadPass :: ParserTestCase_Temp Int Identity ([Int], [Int]) Property +lookAheadPass producer consumer = + forAll (chooseInt (min_value, max_value)) $ \n -> + let + takeWithoutConsume = P.lookAhead $ P.fromFold $ FL.take n FL.toList + parseTwice = do + parsed_list_1 <- takeWithoutConsume + parsed_list_2 <- takeWithoutConsume + return (parsed_list_1, parsed_list_2) + in + forAll (chooseInt (n+1, max_value)) $ \list_length -> + forAll (vectorOf list_length (chooseInt (min_value, max_value))) $ \ls -> + case runIdentity $ consumer parseTwice (producer ls) of + Right (ls_1, ls_2) -> checkListEqual ls_1 ls_2 .&&. checkListEqual ls_1 (Prelude.take n ls) + Left _ -> property $ False + +-- lookAheadFail :: ParserTestCase_Temp Int Identity Int Property +-- lookAheadFail producer consumer = +-- forAll (chooseInt (min_value + 1, max_value)) $ \n -> +-- let +-- takeWithoutConsume = P.lookAhead $ P.take n FL.toList +-- parseTwice = do +-- parsed_list_1 <- takeWithoutConsume +-- parsed_list_2 <- takeWithoutConsume +-- return (parsed_list_1, parsed_list_2) +-- in +-- forAll (chooseInt (min_value, n - 1)) $ \list_length -> +-- forAll (vectorOf list_length (chooseInt (min_value, max_value))) $ \ls -> +-- case consumer parseTwice (producer ls) of +-- Right _ -> False +-- Left _ -> True + +lookAhead :: ParserTestCase_Temp Int Identity ([Int], [Int]) Property +lookAhead producer consumer = + forAll (chooseInt (min_value, max_value)) $ \n -> + let + takeWithoutConsume = P.lookAhead $ P.fromFold $ FL.take n FL.toList + parseTwice = do + parsed_list_1 <- takeWithoutConsume + parsed_list_2 <- takeWithoutConsume + return (parsed_list_1, parsed_list_2) + in + forAll (listOf (chooseInt (min_value, max_value))) $ \ls -> + case runIdentity $ consumer parseTwice (producer ls) of + Right (ls_1, ls_2) -> checkListEqual ls_1 ls_2 .&&. checkListEqual ls_1 (Prelude.take n ls) + Left _ -> property ((list_length < n) || (list_length == n && n == 0)) + where + list_length = Prelude.length ls + +listTakeEndBy_ :: (a -> Bool) -> [a] -> ([a], [a]) +listTakeEndBy_ predicate ls = + case break predicate ls of + (a, []) -> (a, []) + (a, b) -> (a, tail b) + +takeEndBy_ :: ParserTestCase Int Identity [Int] Property +takeEndBy_ consumer = + forAll (listOf (chooseInt (min_value, max_value ))) $ \ls -> + case runIdentity $ consumer (P.takeEndBy_ predicate prsr) ls of + (Right parsed_list, rest) -> monadicIO $ do + let (ls1, ls2) = listTakeEndBy_ predicate ls + listEquals (==) parsed_list ls1 + listEquals (==) rest ls2 + _ -> property False + where + predicate = (>= 100) + prsr = P.many (P.satisfy (const True)) FL.toList + +takeEndByOrMax_ :: ParserTestCase Int Identity [Int] Property +takeEndByOrMax_ consumer = + forAll (chooseInt (min_value, max_value)) $ \n -> + forAll (listOf (chooseInt (0, 1))) $ \ls -> + case runIdentity $ consumer (P.fromFold $ FL.takeEndBy_ predicate (FL.take n FL.toList)) ls of + (Right parsed_list, rest) -> monadicIO $ do + let (lsa, lsb) = listTakeEndBy_ predicate ls + (ls1, ls2) = Prelude.splitAt n ls + if length lsa < length ls1 + then do + listEquals (==) parsed_list lsa + listEquals (==) rest lsb + else do + listEquals (==) parsed_list ls1 + listEquals (==) rest ls2 + _ -> property False + where + predicate = (== 1) + +takeStartBy :: ParserTestCase Int Identity [Int] Property +takeStartBy consumer = + forAll (listOf (chooseInt (min_value, max_value))) $ \ls -> + let ls1 = 1:ls + in + case runIdentity $ consumer parser ls1 of + (Right parsed_list, rest) -> + if not $ Prelude.null ls1 + then + let (rls1, rls2) = Prelude.break predicate (tail ls1) + in monadicIO $ do + listEquals (==) parsed_list (head ls1 : rls1) + listEquals (==) rest rls2 + else property $ Prelude.null parsed_list && Prelude.null rest + _ -> property False + where + predicate = odd + parser = P.takeBeginBy predicate FL.toList + +takeWhile :: ParserTestCase Int Identity [Int] Property +takeWhile consumer = + forAll (listOf (chooseInt (0, 1))) $ \ ls -> + case runIdentity $ consumer (P.takeWhile predicate FL.toList) ls of + (Right parsed_list, rest) -> monadicIO $ do + let (ls1, ls2) = Prelude.span predicate ls + listEquals (==) parsed_list ls1 + listEquals (==) rest ls2 + _ -> property False + where + predicate = (== 0) + +takeP :: ParserTestCase Int Identity [Int] Property +takeP consumer = + forAll + ((,) <$> chooseInt (min_value, max_value) + <*> listOf (chooseInt (0, 1))) + $ \(takeNum, ls) -> + case runIdentity $ consumer + (P.takeP takeNum (P.fromFold FL.toList)) ls of + (Right parsed_list, rest) -> monadicIO $ do + let (ls1, ls2) = Prelude.splitAt takeNum ls + listEquals (==) parsed_list ls1 + listEquals (==) rest ls2 + _ -> property False + +takeWhile1 :: ParserTestCase Int Identity [Int] Property +takeWhile1 consumer = + forAll (listOf (chooseInt (0, 1))) $ \ ls -> + case runIdentity $ consumer (P.takeWhile1 predicate FL.toList) ls of + (Right parsed_list, rest) -> case ls of + [] -> property False + (x : _) -> + if predicate x + then monadicIO $ do + let (ls1, ls2) = span predicate ls + listEquals (==) parsed_list ls1 + listEquals (==) rest ls2 + else + property False + (Left _, rest) -> monadicIO $ do + listEquals (==) rest ls + case ls of + [] -> assert True + (x : _) -> assert (not $ predicate x) + where + predicate = (== 0) + +takeWhileP :: ParserTestCase Int Identity [Int] Property +takeWhileP consumer = + forAll (listOf (chooseInt (0, 1))) $ \ls -> + forAll (chooseInt (min_value, max_value)) $ \n -> + let + predicate = (== 1) + + prsr = + P.takeWhileP predicate + $ P.fromFold (FL.take n FL.toList) + + takeWhileTillLen maxLen prd list = + Prelude.take maxLen $ Prelude.takeWhile prd list + in + case runIdentity $ consumer prsr ls of + (Right parsed_list, rest) -> monadicIO $ do + let ls1 = takeWhileTillLen n predicate ls + ls2 = drop (length ls1) ls + listEquals (==) parsed_list ls1 + listEquals (==) rest ls2 + _ -> property False + +{- +choice :: ParserTestCase_Temp Int Identity Int Property +choice producer consumer = + forAll + ((,,) <$> chooseInt (min_value, max_value) + <*> chooseInt (min_value, max_value) + <*> listOf (chooseInt (0, 1))) + $ \(i, j, ls) -> + case consumer (P.choice [parser i, parser j]) (producer ls) of + Right parsed_list -> + checkListEqual parsed_list $ take (min i j) ls + Left _ -> property False + + where + + parser i = P.fromFold (FL.take i FL.toList) +-} + +groupBy :: ParserTestCase_Temp Int Identity [Int] Property +groupBy producer consumer = + forAll (listOf (chooseInt (0, 1))) + $ \ls -> + case runIdentity $ consumer parser (producer ls) of + Right parsed -> checkListEqual parsed (groupByLF ls) + Left _ -> property False + + where + + cmp = (==) + parser = P.groupBy cmp FL.toList + groupByLF lst + | null lst = [] + | otherwise = head $ List.groupBy cmp lst + +groupByRolling :: ParserTestCase_Temp Int Identity [Int] Property +groupByRolling producer consumer = + forAll (listOf (chooseInt (0, 1))) + $ \ls -> + case runIdentity $ consumer parser (producer ls) of + Right parsed -> checkListEqual parsed (groupByLF Nothing ls) + Left _ -> property False + + where + + cmp = (==) + parser = P.groupBy cmp FL.toList + groupByLF _ [] = [] + groupByLF Nothing (x:xs) = x : groupByLF (Just x) xs + groupByLF (Just y) (x:xs) = + if cmp y x + then x : groupByLF (Just x) xs + else [] + +wordBy :: ParserTestCase_Temp Char Identity [String] Property +wordBy producer consumer = + forAll (listOf (elements [' ', 's'])) + $ \ls -> + case runIdentity $ consumer parser (producer ls) of + Right parsed -> checkListEqual parsed (words' ls) + Left _ -> property False + + where + + predicate = (== ' ') + parser = P.many (P.wordBy predicate FL.toList) FL.toList + words' lst = + let wrds = words lst + in if wrds == [] && length lst > 0 then [""] else wrds + +splitWith :: ParserTestCase_Temp Int Identity (Int, Int) Property +splitWith producer consumer = + forAll (listOf (chooseInt (0, 1))) $ \ls -> + case runIdentity $ consumer (P.splitWith (,) (P.satisfy (== 0)) (P.satisfy (== 1))) (producer ls) of + Right (result_first, result_second) -> case ls of + 0 : 1 : _ -> (result_first == 0) && (result_second == 1) + _ -> False + Left _ -> case ls of + 0 : 1 : _ -> False + _ -> True + +splitWithFailLeft :: ParserTestCase_Temp Int Identity (Int, Int) Property +splitWithFailLeft producer consumer = + property (case runIdentity $ consumer (P.splitWith (,) (P.die "die") (P.fromPure (1 :: Int))) (producer [1 :: Int]) of + Right _ -> False + Left _ -> True) + +splitWithFailRight :: ParserTestCase_Temp Int Identity (Int, Int) Property +splitWithFailRight producer consumer = + property (case runIdentity $ consumer (P.splitWith (,) (P.fromPure (1 :: Int)) (P.die "die")) (producer [1 :: Int]) of + Right _ -> False + Left _ -> True) + +splitWithFailBoth :: ParserTestCase_Temp Int Identity (Int, Int) Property +splitWithFailBoth producer consumer = + property (case runIdentity $ consumer (P.splitWith (,) (P.die "die") (P.die "die")) (producer [1 :: Int]) of + Right _ -> False + Left _ -> True) + +-- teeWithPass :: ParserTestCase_Temp Int Identity Int Property +-- teeWithPass producer consumer = +-- forAll (chooseInt (min_value, max_value)) $ \n -> +-- forAll (listOf (chooseInt (0, 1))) $ \ls -> +-- let +-- prsr = P.fromFold $ FL.take n FL.toList +-- in +-- case consumer (P.teeWith (,) prsr prsr) (producer ls) of +-- Right (ls_1, ls_2) -> checkListEqual (Prelude.take n ls) ls_1 .&&. checkListEqual ls_1 ls_2 +-- Left _ -> property False + +-- teeWithFailLeft :: ParserTestCase_Temp Int Identity Int Property +-- teeWithFailLeft producer consumer = +-- property (case consumer (P.teeWith (,) (P.die "die") (P.fromPure (1 :: Int))) (producer [1 :: Int]) of +-- Right _ -> False +-- Left _ -> True) + +-- teeWithFailRight :: ParserTestCase_Temp Int Identity Int Property +-- teeWithFailRight producer consumer = +-- property (case consumer (P.teeWith (,) (P.fromPure (1 :: Int)) (P.die "die")) (producer [1 :: Int]) of +-- Right _ -> False +-- Left _ -> True) + +-- teeWithFailBoth :: ParserTestCase_Temp Int Identity Int Property +-- teeWithFailBoth producer consumer = +-- property (case consumer (P.teeWith (,) (P.die "die") (P.die "die")) (producer [1 :: Int]) of +-- Right _ -> False +-- Left _ -> True) + +{- +deintercalate :: ParserTestCase_Temp Int Identity Int Property +deintercalate producer consumer = + forAll (listOf (chooseAny :: Gen Int)) $ \ls -> + case runIdentity $ consumer p (producer ls) of + Right evenOdd -> evenOdd == List.partition even ls + Left _ -> False + + where + p1 = P.takeWhile even FL.toList + p2 = P.takeWhile odd FL.toList + partition = + FL.tee (fmap concat $ FL.catLefts FL.toList) + (fmap concat $ FL.catRights FL.toList) + p = P.deintercalate p1 p2 partition +-} + +-- shortestPass :: ParserTestCase_Temp Int Identity Int Property +-- shortestPass producer consumer = +-- forAll (listOf (chooseInt(min_value, max_value))) $ \ls -> +-- let +-- half_mid_value = mid_value `Prelude.div` 2 +-- prsr_1 = P.takeWhile (<= half_mid_value) FL.toList +-- prsr_2 = P.takeWhile (<= mid_value) FL.toList +-- prsr_shortest = P.shortest prsr_1 prsr_2 +-- in +-- case consumer prsr_shortest (producer ls) of +-- Right short_list -> checkListEqual short_list (Prelude.takeWhile (<= half_mid_value) ls) +-- Left _ -> property False + +-- shortestPassLeft :: ParserTestCase_Temp Int Identity Int Property +-- shortestPassLeft producer consumer = +-- property (case consumer (P.shortest (P.die "die") (P.fromPure (1 :: Int))) (producer [1 :: Int]) of +-- Right r -> r == 1 +-- Left _ -> False) +-- +-- shortestPassRight :: ParserTestCase_Temp Int Identity Int Property +-- shortestPassRight producer consumer = +-- property (case consumer (P.shortest (P.fromPure (1 :: Int)) (P.die "die")) (producer [1 :: Int]) of +-- Right r -> r == 1 +-- Left _ -> False) + +-- shortestFailBoth :: ParserTestCase_Temp Int Identity Int Property +-- shortestFailBoth producer consumer = +-- property +-- (case consumer +-- (P.shortest (P.die "die") (P.die "die")) +-- (producer [1 :: Int]) of +-- Right _ -> False +-- Left _ -> True) +-- +-- longestPass :: ParserTestCase_Temp Int Identity Int Property +-- longestPass producer consumer = +-- forAll (listOf (chooseInt(min_value, max_value))) $ \ls -> +-- let +-- half_mid_value = mid_value `Prelude.div` 2 +-- prsr_1 = P.takeWhile (<= half_mid_value) FL.toList +-- prsr_2 = P.takeWhile (<= mid_value) FL.toList +-- prsr_longest = P.longest prsr_1 prsr_2 +-- in +-- case consumer prsr_longest (producer ls) of +-- Right long_list -> long_list == Prelude.takeWhile (<= mid_value) ls +-- Left _ -> False +-- +-- longestPassLeft :: ParserTestCase_Temp Int Identity Int Property +-- longestPassLeft producer consumer = +-- property (case consumer (P.shortest (P.die "die") (P.fromPure (1 :: Int))) (producer [1 :: Int]) of +-- Right r -> r == 1 +-- Left _ -> False) +-- +-- longestPassRight :: ParserTestCase_Temp Int Identity Int Property +-- longestPassRight producer consumer = +-- property (case consumer (P.shortest (P.fromPure (1 :: Int)) (P.die "die")) (producer [1 :: Int]) of +-- Right r -> r == 1 +-- Left _ -> False) +-- +-- longestFailBoth :: ParserTestCase_Temp Int Identity Int Property +-- longestFailBoth producer consumer = +-- property +-- (case consumer (P.shortest (P.die "die") (P.die "die")) (producer [1 :: Int]) of +-- Right _ -> False +-- Left _ -> True) + +many :: ParserTestCase_Temp Int Identity [Int] Property +many producer consumer = + forAll (listOf (chooseInt (0, 1))) $ \ls -> + let fldstp conL currL = return $ FL.Partial (conL ++ currL) + concatFold = FL.Fold fldstp (return (FL.Partial [])) return return + prsr = + flip P.many concatFold + $ P.fromFold $ FL.takeEndBy_ (== 1) FL.toList + in case runIdentity $ consumer prsr (producer ls) of + Right res_list -> + checkListEqual res_list (Prelude.filter (== 0) ls) + Left _ -> property False + +many_empty :: ParserTestCase_Temp Int Identity [Int] Property +many_empty producer consumer = + property (case runIdentity $ consumer (flip P.many FL.toList (P.die "die")) (producer [1 :: Int]) of + Right res_list -> checkListEqual res_list ([] :: [Int]) + Left _ -> property False) + +some :: ParserTestCase_Temp Int Identity [Int] Property +some producer consumer = + forAll (listOf (chooseInt (0, 1))) $ \genLs -> + let + ls = 0 : genLs + fldstp conL currL = return $ FL.Partial $ conL ++ currL + concatFold = FL.Fold fldstp (return (FL.Partial [])) return return + prsr = + flip P.some concatFold + $ P.fromFold $ FL.takeEndBy_ (== 1) FL.toList + in case runIdentity $ consumer prsr (producer ls) of + Right res_list -> res_list == Prelude.filter (== 0) ls + Left _ -> False + +someFail :: ParserTestCase_Temp Int Identity [Int] Property +someFail producer consumer = + property (case runIdentity $ consumer (P.some (P.die "die") FL.toList) (producer [1 :: Int]) of + Right _ -> False + Left _ -> True) + +------------------------------------------------------------------------------- +-- Instances +------------------------------------------------------------------------------- + +applicative :: ParserTestCase_Temp Int Identity ([Int], [Int]) Property +applicative producer consumer = + forAll (listOf (chooseAny :: Gen Int)) $ \ list1 -> + forAll (listOf (chooseAny :: Gen Int)) $ \ list2 -> + let parser = + (,) + <$> P.fromFold (FL.take (length list1) FL.toList) + <*> P.fromFold (FL.take (length list2) FL.toList) + in + case runIdentity $ consumer parser (producer $ list1 ++ list2) of + Right (olist1, olist2) -> olist1 == list1 && olist2 == list2 + Left _ -> False + +sequence :: ParserTestCase_Temp Int IO [[Int]] Property +sequence producer consumer = + forAll (vectorOf 11 (listOf (chooseAny :: Gen Int))) $ \ ins -> + let p xs = P.fromFold (FL.take (length xs) FL.toList) + in monadicIO $ do + outs <- run $ + consumer + (Prelude.sequence $ fmap p ins) + (producer $ concat ins) + return $ + case outs of + Right ls -> ls == ins + Left _ -> False + +altEOF1 :: ParserTestCase_Temp Int (PropertyM IO) Int Property +altEOF1 producer consumer = + monadicIO $ do + s1 <- consumer + (P.satisfy (> 0) <|> return 66) + (producer ([]::[Int])) + return $ + case s1 of + Right x -> x == 66 + Left _ -> False + +altEOF2 :: ParserTestCase_Temp Int (PropertyM IO) [Int] Property +altEOF2 producer consumer = + monadicIO $ do + s1 <- consumer + ((P.takeEQ 2 FL.toList) <|> (P.takeEQ 1 FL.toList)) + (producer ([51]::[Int])) + return $ + case s1 of + Right x -> x == [51] + Left _ -> False + +monad :: ParserTestCase_Temp Int (PropertyM IO) ([Int], [Int]) Property +monad producer consumer = + forAll (listOf (chooseAny :: Gen Int)) $ \ list1 -> + forAll (listOf (chooseAny :: Gen Int)) $ \ list2 -> + let parser = do + olist1 <- P.fromFold (FL.take (length list1) FL.toList) + olist2 <- P.fromFold (FL.take (length list2) FL.toList) + return (olist1, olist2) + in monadicIO $ do + s <- consumer parser (producer $ list1 ++ list2) + return $ + case s of + Right (olist1, olist2) -> olist1 == list1 && olist2 == list2 + Left _ -> False + +takeEndBy1 :: ParserTestCase_Temp Int Identity [Int] Property +takeEndBy1 producer consumer = + forAll (listOf (chooseInt (0, 1))) $ \ls -> + case runIdentity $ consumer (P.takeEndBy predicate prsr) (producer ls) of + Right parsed_list -> + checkListEqual + parsed_list + (takeWhileAndFirstFail (not . predicate) ls) + Left _ -> property False + where + prsr = P.many (P.satisfy (const True)) FL.toList + + predicate = (== 1) + + takeWhileAndFirstFail prd (x : xs) = + if prd x + then x : takeWhileAndFirstFail prd xs + else [x] + takeWhileAndFirstFail _ [] = [] + +takeEndByEsc :: ParserTestCase_Temp Int Identity [Int] Property +takeEndByEsc producer consumer = + forAll (listOf (chooseInt (min_value, max_value))) $ \ls -> + let + msg = "takeEndByEsc: trailing escape" + + isSep = even + + isEsc x = x `mod` 6 == 0 + + prsr = P.takeEndByEsc isEsc isSep prsr0 + + where + + prsr0 = P.many (P.satisfy (const True)) FL.toList + + escapeSep maybePrevEsc [] = + case maybePrevEsc of + Nothing -> [] + Just prevEsc -> [prevEsc] + escapeSep maybePrevEsc (x : xs) = + case maybePrevEsc of + Nothing -> + if isEsc x + then escapeSep (Just x) xs + else + if isSep x + then [x] + else x : escapeSep Nothing xs + Just _ -> + x : escapeSep Nothing xs + in + case runIdentity $ consumer prsr (producer ls) of + Right parsed_list -> checkListEqual parsed_list $ escapeSep Nothing ls + Left err -> property (msg `isSuffixOf` displayException err) + +takeFramedByEsc_ :: ParserTestCase_Temp Int Identity [Int] Property +takeFramedByEsc_ producer consumer = + forAll (listOf (chooseInt (min_value, max_value))) $ \ls -> + let + isBegin = (== 0) + + isEnd = (== 1) + + isEsc = (== 2) + + prsr = P.takeFramedByEsc_ isEsc isBegin isEnd FL.toList + + checkPass (x : xs) maybePrevEsc openMinusClose = + case maybePrevEsc of + Nothing -> + if isEsc x + then checkPass xs (Just x) openMinusClose + else + if isBegin x + then checkPass xs Nothing (openMinusClose + 1) + else + if isEnd x + then + case openMinusClose of + 0 -> False + 1 -> True + _ -> + checkPass + xs + Nothing + (openMinusClose - 1) + else + checkPass xs Nothing openMinusClose + Just _ -> checkPass xs Nothing openMinusClose + checkPass [] _ _ = False + + checkPassBeg [] = False + checkPassBeg xxs@(x:_) + | isBegin x = checkPass xxs Nothing (0 :: Int) + | otherwise = False + + escapeFrame begin end escape l = + let + helper (x : xs) maybePrevEsc openMinusClose = + case maybePrevEsc of + Nothing -> + if escape x + then helper xs (Just x) openMinusClose + else + if begin x + then helper xs Nothing (openMinusClose + 1) + else + if end x + then + if openMinusClose - 1 == 0 + then [] + else + helper + xs + Nothing + (openMinusClose - 1) + else + x : helper xs Nothing openMinusClose + Just prevEsc -> + if escape x || begin x || end x + then x : helper xs Nothing openMinusClose + else + prevEsc : x : helper xs Nothing openMinusClose + helper [] _ _ = error "Cannot Reach Here" + in + helper l Nothing (0 :: Int) + in + case runIdentity $ consumer prsr (producer ls) of + Right parsed_list -> + if checkPassBeg ls + then checkListEqual parsed_list $ + escapeFrame isBegin isEnd isEsc ls + else property False + Left _ -> + if checkPassBeg ls + then property False + else property True + +takeFramedByEsc_Pass :: ParserTestCase_Temp Int Identity [Int] Property +takeFramedByEsc_Pass producer consumer = + forAll (listOf (chooseInt (min_value, max_value))) $ \list -> + let + ls = (0 : list) ++ (Prelude.replicate (Prelude.length list + 1) 1) + + isBegin = (== 0) + + isEnd = (== 1) + + isEsc = (== 2) + + prsr = P.takeFramedByEsc_ isEsc isBegin isEnd FL.toList + + escapeFrame begin end escape l = + let + helper (x : xs) maybePrevEsc openMinusClose = + case maybePrevEsc of + Nothing -> + if escape x + then helper xs (Just x) openMinusClose + else + if begin x + then + if openMinusClose == 0 + then helper xs Nothing (openMinusClose + 1) + else x : helper xs Nothing (openMinusClose + 1) + else + if end x + then + if openMinusClose - 1 == 0 + then [] + else + x : + helper + xs + Nothing + (openMinusClose - 1) + else + x : helper xs Nothing openMinusClose + Just _ -> + x : helper xs Nothing openMinusClose + helper [] _ _ = error "Cannot Reach Here" + in + helper l Nothing (0 :: Int) + in + case runIdentity $ consumer prsr (producer ls) of + Right parsed_list -> checkListEqual parsed_list $ escapeFrame isBegin isEnd isEsc ls + _ -> property False + +takeFramedByEsc_Fail1 :: ParserTestCase_Temp Int Identity [Int] Property +takeFramedByEsc_Fail1 producer consumer = + let + msg = "takeFramedByEsc_: missing frame end" + + isBegin = (== 0) + + isEnd = (== 0) + + isEsc = (== 2) + + prsr = P.takeFramedByEsc_ isEsc isBegin isEnd FL.toList + + ls = [0 :: Int] + in + case runIdentity $ consumer prsr (producer ls) of + Right _ -> property False + Left err -> property (msg `isSuffixOf` displayException err) + +takeFramedByEsc_Fail2 :: ParserTestCase_Temp Int Identity [Int] Property +takeFramedByEsc_Fail2 producer consumer = + let + msg = "takeFramedByEsc_: missing frame start" + + isBegin = (== 0) + + isEnd = (== 1) + + isEsc = (== 1) + + prsr = P.takeFramedByEsc_ isEsc isBegin isEnd FL.toList + + ls = [1 :: Int] + in + case runIdentity $ consumer prsr (producer ls) of + Right _ -> property False + Left err -> property (msg `isSuffixOf` displayException err) + +takeFramedByEsc_Fail3 :: ParserTestCase_Temp Int Identity [Int] Property +takeFramedByEsc_Fail3 producer consumer = + let + msg = "takeFramedByEsc_: missing frame end" + + isBegin = (== 2) + + isEnd = (== 1) + + isEsc = (== 2) + + prsr = P.takeFramedByEsc_ isEsc isBegin isEnd FL.toList + + ls = [2 :: Int] + in + case runIdentity $ consumer prsr (producer ls) of + Right _ -> property False + Left err -> property (msg `isSuffixOf` displayException err) + +takeStartBy_ :: ParserTestCase_Temp Int Identity [Int] Property +takeStartBy_ producer consumer = + forAll (listOf (chooseInt (min_value, max_value))) $ \ls -> + let ls1 = 1:ls + msg = "takeFramedByGeneric: empty token" + in + case runIdentity $ consumer parser (producer ls1) of + Right parsed_list -> + if not $ Prelude.null ls1 + then + let tls = Prelude.takeWhile (not . predicate) (tail ls1) + in checkListEqual parsed_list $ + if predicate (head ls1) + then tls + else Prelude.takeWhile (not . predicate) ls1 + else property $ Prelude.null parsed_list + Left err -> property (msg `isSuffixOf` displayException err) + where + predicate = odd + parser = P.takeBeginBy_ predicate FL.toList + +------------------------------------------------------------------------------- +-- Main +------------------------------------------------------------------------------- + +data TestMode + = TMParserStream + | TMParserKStreamK + | TMParserKStreamKChunks + | TMParserKStreamKChunksGeneric + deriving (Show) + +runParserTC :: (Unbox a, Monad m) => TestMode -> ParserTestCase a m b c -> c +runParserTC tm runner = + case tm of + TMParserStream -> + runner $ \p -> mapMTup S.toList . S.parseBreakPos p . S.fromList + TMParserKStreamK -> + runner $ \p -> + mapMTup K.toList . K.parseBreakPos (PK.toParserK p) . K.fromList + TMParserKStreamKChunks -> + runner $ \p -> + mapMTup + (fmap (concatMap A.toList) . K.toList) + . A.parseBreakPos (A.toParserK p) + . producerChunks A.fromList + TMParserKStreamKChunksGeneric -> + runner $ \p -> + mapMTup + (fmap (concatMap GA.toList) . K.toList) + . GA.parseBreakPos (GA.toParserK p) + . producerChunks GA.fromList + + where + mapMTup f tupM = do + (t, a) <- tupM + (t,) <$> f a + + cSize = 50 + -- Not using A.createOf here because of the MonadIO constraint + producerChunks fl = + K.fromStream + . S.groupsOf cSize (fl <$> FL.toList) + . S.fromList + +runParserTC_temp :: (Unbox a, Monad m) => TestMode -> ParserTestCase_Temp a m b c -> c +runParserTC_temp tm runner = + case tm of + TMParserStream -> runner S.fromList S.parsePos + TMParserKStreamK -> runner K.fromList (K.parsePos . PK.toParserK) + TMParserKStreamKChunks -> + runner (producerChunks A.fromList) (A.parsePos . A.toParserK) + TMParserKStreamKChunksGeneric -> + runner + (producerChunks GA.fromList) + (GA.parsePos . GA.toParserK) + + where + cSize = 50 + -- Not using A.createOf here because of the MonadIO constraint + producerChunks fl = + K.fromStream + . S.groupsOf cSize (fl <$> FL.toList) + . S.fromList + +{-# NOINLINE mainCommon #-} +mainCommon :: TestMode -> Spec +mainCommon ptt = do + describe (show ptt) $ do + describe "Instances" $ do + prop "applicative" $ runParserTC_temp ptt applicative + prop "Alternative: end of input 1" $ runParserTC_temp ptt altEOF1 + prop "Alternative: end of input 2" $ runParserTC_temp ptt altEOF2 + prop "monad" $ runParserTC_temp ptt monad + prop "sequence" $ runParserTC_temp ptt sequence + + describe "test for accumulator" $ do + prop "P.fromFold FL.sum = FL.sum" $ runParserTC ptt fromFold + prop "fromPure value provided" $ runParserTC ptt fromPure + prop "fromPure monadic value provided" $ runParserTC ptt fromEffect + prop "fail err = Left (SomeException (ParseError err))" $ runParserTC ptt parserFail + prop "always fail" $ runParserTC ptt die + prop "always fail but monadic" $ runParserTC ptt dieM + + describe "test for element parser" $ do + prop "peek = head with list length > 0" $ runParserTC ptt peekPass + prop "peek fail on []" $ runParserTC ptt peekFail + prop "eof pass on []" $ runParserTC_temp ptt eofPass + prop "eof fail on non-empty list" $ runParserTC_temp ptt eofFail + prop "first element exists and >= mid_value" $ runParserTC_temp ptt satisfyPass + prop "one pass on [Int]" $ runParserTC_temp ptt onePass + prop "one fail on []" $ runParserTC_temp ptt one + prop "check first element exists and satisfies predicate" $ runParserTC_temp ptt satisfy + describe "test for sequence parser" $ do + prop "P.takeBetween = Prelude.take when len >= m and len <= n" + $ runParserTC_temp ptt takeBetweenPass + prop ("P.takeBetween = Prelude.take when len >= m and len <= n and fail" + ++ "otherwise fail") $ runParserTC_temp ptt takeBetween + prop "P.take = Prelude.take" $ runParserTC_temp ptt Streamly.Test.Data.Parser.Common.take + prop "P.takeEQ = Prelude.take when len >= n" $ runParserTC_temp ptt takeEQPass + prop "P.takeEQ = Prelude.take when len >= n and fail otherwise" + $ runParserTC_temp ptt Streamly.Test.Data.Parser.Common.takeEQ + prop "P.takeGE n ls = ls when len >= n" $ runParserTC_temp ptt takeGEPass + prop "P.takeGE n ls = ls when len >= n and fail otherwise" $ runParserTC_temp ptt Streamly.Test.Data.Parser.Common.takeGE + prop "lookAhead . take n >> lookAhead . take n = lookAhead . take n" $ runParserTC_temp ptt lookAheadPass + -- prop "Fail when stream length exceeded" lookAheadFail + prop "lookAhead . take n >> lookAhead . take n = lookAhead . take n, else fail" $ runParserTC_temp ptt lookAhead + prop ("P.takeStartBy pred = head : Prelude.takeWhile (not . pred)" + ++ " tail") $ runParserTC ptt takeStartBy + prop "P.takeWhile = Prelude.takeWhile" $ runParserTC ptt Streamly.Test.Data.Parser.Common.takeWhile + prop ("P.takeWhile1 = Prelude.takeWhile if taken something," + ++ " else check why failed") $ runParserTC ptt takeWhile1 + prop "takeWhileP prd P.take = takeWhileMaxLen prd" $ runParserTC ptt takeWhileP + prop ("P.takeP = Prelude.take") $ runParserTC ptt takeP + prop "P.groupBy = Prelude.head . Prelude.groupBy" $ runParserTC_temp ptt groupBy + prop "groupByRolling" $ runParserTC_temp ptt groupByRolling + prop "many (P.wordBy ' ') = words'" $ runParserTC_temp ptt wordBy + -- prop "choice" choice + prop "parse 0, then 1, else fail" $ runParserTC_temp ptt splitWith + prop "fail due to die as left parser" $ runParserTC_temp ptt splitWithFailLeft + prop "fail due to die as right parser" $ runParserTC_temp ptt splitWithFailRight + prop "fail due to die as both parsers" $ runParserTC_temp ptt splitWithFailBoth + -- prop "" teeWithPass + -- prop "" teeWithFailLeft + -- prop "" teeWithFailRight + -- prop "" teeWithFailBoth + -- prop "deintercalate" deintercalate + -- prop "" shortestPass + -- prop "" shortestFailLeft + -- prop "" shortestFailRight + -- prop "" shortestFailBoth + prop ("P.many concatFold $ P.takeEndBy_ (== 1) FL.toList =" + ++ "Prelude.filter (== 0)") $ runParserTC_temp ptt many + prop "[] due to parser being die" $ runParserTC_temp ptt many_empty + prop ("P.some concatFold $ P.takeEndBy_ (== 1) FL.toList =" + ++ "Prelude.filter (== 0)") $ runParserTC_temp ptt some + prop "fail due to parser being die" $ runParserTC_temp ptt someFail + prop "takeEndBy_" $ runParserTC ptt takeEndBy_ + prop "takeEndByOrMax_" $ runParserTC ptt takeEndByOrMax_ + prop "takeEndBy1" $ runParserTC_temp ptt takeEndBy1 + prop "takeEndByEsc" $ runParserTC_temp ptt takeEndByEsc + prop "takeFramedByEsc_" $ runParserTC_temp ptt takeFramedByEsc_ + prop "takeFramedByEsc_Pass" $ runParserTC_temp ptt takeFramedByEsc_Pass + prop "takeFramedByEsc_Fail1" $ runParserTC_temp ptt takeFramedByEsc_Fail1 + prop "takeFramedByEsc_Fail2" $ runParserTC_temp ptt takeFramedByEsc_Fail2 + prop "takeFramedByEsc_Fail3" $ runParserTC_temp ptt takeFramedByEsc_Fail3 + prop "takeStartBy_" $ runParserTC_temp ptt takeStartBy_ + + runParserTC_temp ptt takeProperties + +main :: Spec +main = do + -- We keep Parser and ParserK tests in the same (Parser) executable for 2 + -- reasons: + -- 1. We almost always write Parser tests hence we prioritize Parser over + -- ParserK + -- 2. This results in minimal compilation overhead compared to duplicating + -- or keeping the common part in the library. + -- 2.1. Duplication will result in compilation of this code twice + -- 2.2. Keeping the common part in the library will compile the Parser + -- code even when it's not necessary. For example, if we are running + -- non-parser test suites. + -- + -- One problem is that this module becomes very big for compilation. We can + -- break this further and keep them as a part of "other-modules" in + -- Test.Parser test-suite. + mainCommon TMParserStream + mainCommon TMParserKStreamKChunks + mainCommon TMParserKStreamK + mainCommon TMParserKStreamKChunksGeneric diff --git a/test/Streamly/Test/Data/Parser/ParserD.hs b/test/Streamly/Test/Data/Parser/ParserD.hs deleted file mode 100644 --- a/test/Streamly/Test/Data/Parser/ParserD.hs +++ /dev/null @@ -1,837 +0,0 @@ -module Main (main) where - -import Control.Applicative ((<|>)) -import Control.Exception (SomeException(..), try) -import Data.Word (Word8, Word32, Word64) -import Streamly.Test.Common (listEquals, checkListEqual, chooseInt) -import Test.Hspec (Spec, hspec, describe) -import Test.Hspec.QuickCheck -import Test.QuickCheck - (arbitrary, forAll, elements, Property, - property, listOf, vectorOf, (.&&.), Gen) -import Test.QuickCheck.Monadic (monadicIO, assert, run) - -import qualified Data.List as List -import qualified Prelude -import qualified Streamly.Data.Stream as S -import qualified Streamly.Internal.Data.Array as A -import qualified Streamly.Internal.Data.Fold as FL -import qualified Streamly.Internal.Data.Parser.ParserD as P -import qualified Streamly.Internal.Data.Producer.Source as Source -import qualified Streamly.Internal.Data.Producer as Producer -import qualified Streamly.Internal.Data.Stream as S -import qualified Streamly.Internal.Data.Stream.StreamD as D -import qualified Streamly.Internal.Data.Unfold as Unfold -import qualified Test.Hspec as H - -import Prelude hiding (sequence) - -#if MIN_VERSION_QuickCheck(2,14,0) - -import Test.QuickCheck (chooseAny) -import Control.Monad.Identity (runIdentity, Identity (Identity)) - -#else - -import System.Random (Random(random)) -import Test.QuickCheck.Gen (Gen(MkGen)) - --- | Generates a random element over the natural range of `a`. -chooseAny :: Random a => Gen a -chooseAny = MkGen (\r _ -> let (x,_) = random r in x) - -#endif - -maxTestCount :: Int -maxTestCount = 100 - -min_value :: Int -min_value = 0 - -mid_value :: Int -mid_value = 5000 - -max_value :: Int -max_value = 10000 - -max_length :: Int -max_length = 1000 - -toList :: Monad m => S.Stream m a -> m [a] -toList = S.fold FL.toList - --- Accumulator Tests - -fromFold :: Property -fromFold = - forAll (listOf $ chooseInt (min_value, max_value)) - $ \ls -> - case (==) <$> runIdentity (S.parseD (P.fromFold FL.sum) (S.fromList ls)) - <*> (S.fold FL.sum (S.fromList ls)) of - Right is_equal -> is_equal - Left _ -> False - -fromPure :: Property -fromPure = - forAll (chooseInt (min_value, max_value)) $ \x -> - case runIdentity $ S.parseD (P.fromPure x) (S.fromList [1 :: Int]) of - Right r -> r == x - Left _ -> False - -fromEffect :: Property -fromEffect = - forAll (chooseInt (min_value, max_value)) $ \x -> - case runIdentity $ S.parseD (P.fromEffect $ return x) (S.fromList [1 :: Int]) of - Right r -> r == x - Left _ -> False - -die :: Property -die = - property $ - case runIdentity (S.parseD (P.die "die test") (S.fromList [0 :: Int])) of - Right _ -> False - Left _ -> True - -dieM :: Property -dieM = - property $ - case runIdentity (S.parseD (P.dieM (Identity "die test")) (S.fromList [0 :: Int])) of - Right _ -> False - Left _ -> True - --- Element Parser Tests - -peekPass :: Property -peekPass = - forAll (chooseInt (1, max_length)) $ \list_length -> - forAll (vectorOf list_length (chooseInt (min_value, max_value))) $ \ls -> - case runIdentity $ S.parseD P.peek (S.fromList ls) of - Right head_value -> case ls of - head_ls : _ -> head_value == head_ls - _ -> False - Left _ -> False - -peekFail :: Property -peekFail = - property (case runIdentity $ S.parseD P.peek (S.fromList []) of - Right _ -> False - Left _ -> True) - -eofPass :: Property -eofPass = - property (case S.parseD P.eof (S.fromList []) of - Right _ -> True - Left _ -> False) - -eofFail :: Property -eofFail = - forAll (chooseInt (1, max_length)) $ \list_length -> - forAll (vectorOf list_length (chooseInt (min_value, max_value))) $ \ls -> - case runIdentity $ S.parseD P.eof (S.fromList ls) of - Right _ -> False - Left _ -> True - -satisfyPass :: Property -satisfyPass = - forAll (chooseInt (mid_value, max_value)) $ \first_element -> - forAll (listOf (chooseInt (min_value, max_value))) $ \ls_tail -> - let - ls = first_element : ls_tail - predicate = (>= mid_value) - in - case runIdentity $ S.parseD (P.satisfy predicate) (S.fromList ls) of - Right r -> r == first_element - Left _ -> False - -satisfy :: Property -satisfy = - forAll (listOf (chooseInt (min_value, max_value))) $ \ls -> - case runIdentity $ S.parseD (P.satisfy predicate) (S.fromList ls) of - Right r -> case ls of - [] -> False - (x : _) -> predicate x && (r == x) - Left _ -> case ls of - [] -> True - (x : _) -> not $ predicate x - where - predicate = (>= mid_value) - --- Sequence Parsers Tests -takeBetweenPass :: Property -takeBetweenPass = - forAll (chooseInt (min_value, max_value)) $ \m -> - forAll (chooseInt (m, max_value)) $ \n -> - forAll (chooseInt (m, max_value)) $ \list_length -> - forAll (vectorOf list_length (chooseInt (min_value, max_value))) $ \ls -> - case runIdentity $ S.parseD (P.takeBetween m n FL.toList) (S.fromList ls) of - Right parsed_list -> - let lpl = Prelude.length parsed_list - in checkListEqual parsed_list (Prelude.take lpl ls) - Left _ -> property False - - -takeBetween :: Property -takeBetween = - forAll (chooseInt (min_value, max_value)) $ \m -> - forAll (chooseInt (min_value, max_value)) $ \n -> - forAll (listOf (chooseInt (min_value, max_value))) $ \ls -> - let - list_length = Prelude.length ls - in monadicIO $ do - let p = P.takeBetween m n FL.toList - r <- run $ try $ S.parseD p (S.fromList ls) - return $ case r of - Right x -> case x of - Right parsed_list -> - if m <= list_length && n >= m - then - let len = Prelude.length parsed_list - in checkListEqual - parsed_list (Prelude.take len ls) - else property False - Left _ -> - property (m > n || list_length < m) - Left (_ :: SomeException) -> - property (m > n || list_length < m) - -take :: Property -take = - forAll (chooseInt (min_value, max_value)) $ \n -> - forAll (listOf (chooseInt (min_value, max_value))) $ \ls -> - case runIdentity $ S.parseD (P.fromFold $ FL.take n FL.toList) (S.fromList ls) of - Right parsed_list -> checkListEqual parsed_list (Prelude.take n ls) - Left _ -> property False - -takeEQPass :: Property -takeEQPass = - forAll (chooseInt (min_value, max_value)) $ \n -> - forAll (chooseInt (n, max_value)) $ \list_length -> - forAll (vectorOf list_length (chooseInt (min_value, max_value))) $ \ls -> - case runIdentity $ S.parseD (P.takeEQ n FL.toList) (S.fromList ls) of - Right parsed_list -> checkListEqual parsed_list (Prelude.take n ls) - Left _ -> property False - -takeEQ :: Property -takeEQ = - forAll (chooseInt (min_value, max_value)) $ \n -> - forAll (listOf (chooseInt (min_value, max_value))) $ \ls -> - let - list_length = Prelude.length ls - in - case runIdentity $ S.parseD (P.takeEQ n FL.toList) (S.fromList ls) of - Right parsed_list -> - if (n <= list_length) then - checkListEqual parsed_list (Prelude.take n ls) - else - property False - Left _ -> property (n > list_length) - -takeGEPass :: Property -takeGEPass = - forAll (chooseInt (min_value, max_value)) $ \n -> - forAll (chooseInt (n, max_value)) $ \list_length -> - forAll (vectorOf list_length (chooseInt (min_value, max_value))) $ \ls -> - case runIdentity $ S.parseD (P.takeGE n FL.toList) (S.fromList ls) of - Right parsed_list -> checkListEqual parsed_list ls - Left _ -> property False - -takeGE :: Property -takeGE = - forAll (chooseInt (min_value, max_value)) $ \n -> - forAll (listOf (chooseInt (min_value, max_value))) $ \ls -> - let - list_length = Prelude.length ls - in - case runIdentity $ S.parseD (P.takeGE n FL.toList) (S.fromList ls) of - Right parsed_list -> - if (n <= list_length) then - checkListEqual parsed_list ls - else - property False - Left _ -> property (n > list_length) - -nLessThanEqual0 :: - ( Int - -> FL.Fold Identity Int [Int] - -> P.Parser Int Identity [Int] - ) - -> (Int -> [Int] -> [Int]) - -> Property -nLessThanEqual0 tk ltk = - forAll (elements [0, (-1)]) $ \n -> - forAll (listOf arbitrary) $ \ls -> - case runIdentity $ S.parseD (tk n FL.toList) (S.fromList ls) of - Right parsed_list -> checkListEqual parsed_list (ltk n ls) - Left _ -> property False - -takeProperties :: Spec -takeProperties = - describe "take combinators when n <= 0/" $ do - prop "takeEQ n FL.toList = []" $ - nLessThanEqual0 P.takeEQ (\_ -> const []) - prop "takeGE n FL.toList xs = xs" $ - nLessThanEqual0 P.takeGE (\_ -> id) - - --- XXX lookAhead can't deal with EOF which in this case means when --- n==list_length, this test will fail. So excluding that case for now. -lookAheadPass :: Property -lookAheadPass = - forAll (chooseInt (min_value, max_value)) $ \n -> - let - takeWithoutConsume = P.lookAhead $ P.fromFold $ FL.take n FL.toList - parseTwice = do - parsed_list_1 <- takeWithoutConsume - parsed_list_2 <- takeWithoutConsume - return (parsed_list_1, parsed_list_2) - in - forAll (chooseInt (n+1, max_value)) $ \list_length -> - forAll (vectorOf list_length (chooseInt (min_value, max_value))) $ \ls -> - case runIdentity $ S.parseD parseTwice (S.fromList ls) of - Right (ls_1, ls_2) -> checkListEqual ls_1 ls_2 .&&. checkListEqual ls_1 (Prelude.take n ls) - Left _ -> property $ False - -lookAhead :: Property -lookAhead = - forAll (chooseInt (min_value, max_value)) $ \n -> - let - takeWithoutConsume = P.lookAhead $ P.fromFold $ FL.take n FL.toList - parseTwice = do - parsed_list_1 <- takeWithoutConsume - parsed_list_2 <- takeWithoutConsume - return (parsed_list_1, parsed_list_2) - in - forAll (listOf (chooseInt (min_value, max_value))) $ \ls -> - case runIdentity $ S.parseD parseTwice (S.fromList ls) of - Right (ls_1, ls_2) -> checkListEqual ls_1 ls_2 .&&. checkListEqual ls_1 (Prelude.take n ls) - Left _ -> property ((list_length < n) || (list_length == n && n == 0)) - where - list_length = Prelude.length ls - -takeWhile :: Property -takeWhile = - forAll (listOf (chooseInt (0, 1))) $ \ ls -> - case runIdentity $ S.parseD (P.takeWhile predicate FL.toList) (S.fromList ls) of - Right parsed_list -> checkListEqual parsed_list (Prelude.takeWhile predicate ls) - Left _ -> property False - where - predicate = (== 0) - -takeWhile1 :: Property -takeWhile1 = - forAll (listOf (chooseInt (0, 1))) $ \ ls -> - case runIdentity $ S.parseD (P.takeWhile1 predicate FL.toList) (S.fromList ls) of - Right parsed_list -> case ls of - [] -> property False - (x : _) -> - if predicate x then - checkListEqual parsed_list (Prelude.takeWhile predicate ls) - else - property False - Left _ -> case ls of - [] -> property True - (x : _) -> property (not $ predicate x) - where - predicate = (== 0) - -groupBy :: Property -groupBy = - forAll (listOf (chooseInt (0, 1))) - $ \ls -> - case runIdentity $ S.parseD parser (S.fromList ls) of - Right parsed -> checkListEqual parsed (groupByLF ls) - Left _ -> property False - - where - - cmp = (==) - parser = P.groupBy cmp FL.toList - groupByLF lst - | null lst = [] - | otherwise = head $ List.groupBy cmp lst - -groupByRolling :: Property -groupByRolling = - forAll (listOf (chooseInt (0, 1))) - $ \ls -> - case runIdentity $ S.parseD parser (S.fromList ls) of - Right parsed -> checkListEqual parsed (groupByLF Nothing ls) - Left _ -> property False - - where - - cmp = (==) - parser = P.groupBy cmp FL.toList - groupByLF _ [] = [] - groupByLF Nothing (x:xs) = x : groupByLF (Just x) xs - groupByLF (Just y) (x:xs) = - if cmp y x - then x : groupByLF (Just x) xs - else [] - -takeEndByOrMax :: Property -takeEndByOrMax = - forAll (chooseInt (min_value, max_value)) $ \n -> - forAll (listOf (chooseInt (0, 1))) $ \ls -> - case runIdentity $ S.parseD (P.fromFold $ FL.takeEndBy_ predicate (FL.take n FL.toList)) (S.fromList ls) of - Right parsed_list -> checkListEqual parsed_list (Prelude.take n (Prelude.takeWhile (not . predicate) ls)) - Left _ -> property False - where - predicate = (== 1) - -wordBy :: Property -wordBy = - forAll (listOf (elements [' ', 's'])) - $ \ls -> - case runIdentity $ S.parseD parser (S.fromList ls) of - Right parsed -> checkListEqual parsed (words' ls) - Left _ -> property False - - where - - predicate = (== ' ') - parser = P.many (P.wordBy predicate FL.toList) FL.toList - words' lst = - let wrds = words lst - in if wrds == [] && length lst > 0 then [""] else wrds - - -splitWith :: Property -splitWith = - forAll (listOf (chooseInt (0, 1))) $ \ls -> - case runIdentity $ S.parseD (P.splitWith (,) (P.satisfy (== 0)) (P.satisfy (== 1))) (S.fromList ls) of - Right (result_first, result_second) -> case ls of - 0 : 1 : _ -> (result_first == 0) && (result_second == 1) - _ -> False - Left _ -> case ls of - 0 : 1 : _ -> False - _ -> True - -splitWithFailLeft :: Property -splitWithFailLeft = - property (case runIdentity $ S.parseD (P.splitWith (,) (P.die "die") (P.fromPure (1 :: Int))) (S.fromList [1 :: Int]) of - Right _ -> False - Left _ -> True) - -splitWithFailRight :: Property -splitWithFailRight = - property (case runIdentity $ S.parseD (P.splitWith (,) (P.fromPure (1 :: Int)) (P.die "die")) (S.fromList [1 :: Int]) of - Right _ -> False - Left _ -> True) - -splitWithFailBoth :: Property -splitWithFailBoth = - property (case runIdentity $ S.parseD (P.splitWith (,) (P.die "die") (P.die "die")) (S.fromList [1 :: Int]) of - Right _ -> False - Left _ -> True) - -{- -teeWithPass :: Property -teeWithPass = - forAll (chooseInt (min_value, max_value)) $ \n -> - forAll (listOf (chooseInt (0, 1))) $ \ls -> - let - prsr = P.fromFold $ FL.take n FL.toList - in - case S.parseD (P.teeWith (,) prsr prsr) (S.fromList ls) of - Right (ls_1, ls_2) -> checkListEqual (Prelude.take n ls) ls_1 .&&. checkListEqual ls_1 ls_2 - Left _ -> property False - -teeWithFailLeft :: Property -teeWithFailLeft = - property (case S.parseD (P.teeWith (,) (P.die "die") (P.fromPure (1 :: Int))) (S.fromList [1 :: Int]) of - Right _ -> False - Left _ -> True) - -teeWithFailRight :: Property -teeWithFailRight = - property (case S.parseD (P.teeWith (,) (P.fromPure (1 :: Int)) (P.die "die")) (S.fromList [1 :: Int]) of - Right _ -> False - Left _ -> True) - -teeWithFailBoth :: Property -teeWithFailBoth = - property (case S.parseD (P.teeWith (,) (P.die "die") (P.die "die")) (S.fromList [1 :: Int]) of - Right _ -> False - Left _ -> True) - -shortestPass :: Property -shortestPass = - forAll (listOf (chooseInt(min_value, max_value))) $ \ls -> - let - half_mid_value = mid_value `Prelude.div` 2 - prsr_1 = P.takeWhile (<= half_mid_value) FL.toList - prsr_2 = P.takeWhile (<= mid_value) FL.toList - prsr_shortest = P.shortest prsr_1 prsr_2 - in - case S.parseD prsr_shortest (S.fromList ls) of - Right short_list -> checkListEqual short_list (Prelude.takeWhile (<= half_mid_value) ls) - Left _ -> property False - -shortestPassLeft :: Property -shortestPassLeft = - property (case S.parseD (P.shortest (P.die "die") (P.fromPure (1 :: Int))) (S.fromList [1 :: Int]) of - Right r -> r == 1 - Left _ -> False) - -shortestPassRight :: Property -shortestPassRight = - property (case S.parseD (P.shortest (P.fromPure (1 :: Int)) (P.die "die")) (S.fromList [1 :: Int]) of - Right r -> r == 1 - Left _ -> False) - -shortestFailBoth :: Property -shortestFailBoth = - property - (case S.parseD - (P.shortest (P.die "die") (P.die "die")) - (S.fromList [1 :: Int]) of - Right _ -> False - Left _ -> True) - -longestPass :: Property -longestPass = - forAll (listOf (chooseInt(min_value, max_value))) $ \ls -> - let - half_mid_value = mid_value `Prelude.div` 2 - prsr_1 = P.takeWhile (<= half_mid_value) FL.toList - prsr_2 = P.takeWhile (<= mid_value) FL.toList - prsr_longest = P.longest prsr_1 prsr_2 - in - case S.parseD prsr_longest (S.fromList ls) of - Right long_list -> long_list == Prelude.takeWhile (<= mid_value) ls - Left _ -> False - -longestPassLeft :: Property -longestPassLeft = - property (case S.parseD (P.shortest (P.die "die") (P.fromPure (1 :: Int))) (S.fromList [1 :: Int]) of - Right r -> r == 1 - Left _ -> False) - -longestPassRight :: Property -longestPassRight = - property (case S.parseD (P.shortest (P.fromPure (1 :: Int)) (P.die "die")) (S.fromList [1 :: Int]) of - Right r -> r == 1 - Left _ -> False) - -longestFailBoth :: Property -longestFailBoth = - property - (case S.parseD (P.shortest (P.die "die") (P.die "die")) (S.fromList [1 :: Int]) of - Right _ -> False - Left _ -> True) --} - -many :: Property -many = - forAll (listOf (chooseInt (0, 1))) - $ \ls -> - let fldstp conL currL = return $ FL.Partial (conL ++ currL) - concatFold = - FL.Fold fldstp (return (FL.Partial [])) return - prsr = - flip P.many concatFold - $ P.fromFold $ FL.takeEndBy_ (== 1) FL.toList - in case runIdentity $ S.parseD prsr (S.fromList ls) of - Right res_list -> - checkListEqual res_list (Prelude.filter (== 0) ls) - Left _ -> property False - -many_empty :: Property -many_empty = - property (case runIdentity $ S.parseD (flip P.many FL.toList (P.die "die")) (S.fromList [1 :: Int]) of - Right res_list -> checkListEqual res_list ([] :: [Int]) - Left _ -> property False) - -some :: Property -some = - forAll (listOf (chooseInt (0, 1))) - $ \ls -> - let fldstp conL currL = return $ FL.Partial $ conL ++ currL - concatFold = FL.Fold fldstp (return (FL.Partial [])) return - prsr = - flip P.some concatFold - $ P.fromFold $ FL.takeEndBy_ (== 1) FL.toList - in case runIdentity $ S.parseD prsr (S.fromList ls) of - Right res_list -> res_list == Prelude.filter (== 0) ls - Left _ -> False - -someFail :: Property -someFail = - property (case runIdentity $ S.parseD (P.some (P.die "die") FL.toList) (S.fromList [1 :: Int]) of - Right _ -> False - Left _ -> True) - -------------------------------------------------------------------------------- --- Instances -------------------------------------------------------------------------------- - -applicative :: Property -applicative = - forAll (listOf (chooseAny :: Gen Int)) $ \ list1 -> - forAll (listOf (chooseAny :: Gen Int)) $ \ list2 -> - monadicIO $ do - let parser = - (,) - <$> P.fromFold (FL.take (length list1) FL.toList) - <*> P.fromFold (FL.take (length list2) FL.toList) - - return $ - case runIdentity $ S.parseD parser (S.fromList $ list1 ++ list2) of - Right (olist1, olist2) -> olist1 == list1 && olist2 == list2 - Left _ -> False - -sequence :: Property -sequence = - forAll (vectorOf 11 (listOf (chooseAny :: Gen Int))) $ \ ins -> - monadicIO $ do - let parsers = fmap (\xs -> P.fromFold $ FL.take (length xs) FL.toList) ins - outs <- S.parseD - (Prelude.sequence parsers) - (S.fromList $ concat ins) - return $ - case outs of - Right x -> x == ins - Left _ -> False - -altEOF1 :: Property -altEOF1 = - monadicIO $ do - s1 <- S.parseD - (P.satisfy (> 0) <|> return 66) - (S.fromList ([]::[Int])) - return $ - case s1 of - Right x -> x == 66 - Left _ -> False - -altEOF2 :: Property -altEOF2 = - monadicIO $ do - s1 <- S.parseD - ((P.takeEQ 2 FL.toList) <|> (P.takeEQ 1 FL.toList)) - (S.fromList ([51]::[Int])) - return $ - case s1 of - Right x -> x == [51] - Left _ -> False - -monad :: Property -monad = - forAll (listOf (chooseAny :: Gen Int)) $ \ list1 -> - forAll (listOf (chooseAny :: Gen Int)) $ \ list2 -> - monadicIO $ do - let parser = do - olist1 <- P.fromFold (FL.take (length list1) FL.toList) - olist2 <- P.fromFold (FL.take (length list2) FL.toList) - return (olist1, olist2) - s1 <- S.parseD parser (S.fromList $ list1 ++ list2) - return $ - case s1 of - Right (olist1, olist2) -> olist1 == list1 && olist2 == list2 - Left _ -> False - -------------------------------------------------------------------------------- --- Stream parsing -------------------------------------------------------------------------------- - -parseMany :: Property -parseMany = - forAll (chooseInt (1,100)) $ \len -> - forAll (listOf (vectorOf len (chooseAny :: Gen Int))) $ \ ins -> - monadicIO $ do - outs <- - (toList $ S.catRights $ S.parseManyD - (P.fromFold $ FL.take len FL.toList) (S.fromList $ concat ins) - ) - return $ outs == ins - --- basic sanity test for parsing from arrays -parseUnfold :: Property -parseUnfold = do - let len = 200 - -- ls = input list (stream) - -- clen = chunk size - -- tlen = parser take size - forAll - ((,,) - <$> vectorOf len (chooseAny :: Gen Int) - <*> chooseInt (1, len) - <*> chooseInt (1, len)) $ \(ls, clen, tlen) -> - monadicIO $ do - arrays <- toList $ S.chunksOf clen (S.fromList ls) - let src = Source.source (Just (Producer.OuterLoop arrays)) - let parser = P.fromFold (FL.take tlen FL.toList) - let readSrc = - Source.producer - $ Producer.concat Producer.fromList A.producer - let streamParser = - Producer.simplify (Source.parseManyD parser readSrc) - xs <- run - $ toList - $ S.unfoldMany Unfold.fromList - $ S.catRights - $ S.unfold streamParser src - - listEquals (==) xs ls - -parserSequence :: Property -parserSequence = - forAll (vectorOf 11 (listOf (chooseAny :: Gen Int))) $ \ins -> - monadicIO $ do - let parsers = D.fromList - $ fmap (\xs -> P.fromFold $ FL.take (length xs) FL.sum) ins - let sequencedParser = P.sequence parsers FL.sum - outs <- - S.parseD sequencedParser $ S.concatMap S.fromList (S.fromList ins) - return $ - case outs of - Right x -> x == sum (map sum ins) - Left _ -> False - -------------------------------------------------------------------------------- --- Test for a particular case hit during fs events testing -------------------------------------------------------------------------------- - -evId :: [Word8] -evId = [96,238,17,9,0,0,0,0] - -evFlags :: [Word8] -evFlags = [0,4,1,0,0,0,0,0] - -evPathLen :: [Word8] -evPathLen = [71,0,0,0,0,0,0,0] - -evPath :: [Word8] -evPath = - [47,85,115,101,114,115,47,118,111,108,47,118,101,109,98,97,47,99,111,109 - ,112,111,115,101,119,101 ,108,108,45,116,101,99,104,47,69,110,103,47,112 - ,114,111,106,101,99,116,115,47,115,116,114,101,97,109,108,121,47,115,116 - ,114,101,97,109,108,121,47,116,109,112,47,122,122 - ] - -event :: [Word8] -event = evId ++ evFlags ++ evPathLen ++ evPath - -data Event = Event - { eventId :: Word64 - , eventFlags :: Word32 - , eventAbsPath :: A.Array Word8 - } deriving (Show, Ord, Eq) - -readOneEvent :: P.Parser Word8 IO Event -readOneEvent = do - arr <- P.takeEQ 24 (A.writeN 24) - let arr1 = A.castUnsafe arr :: A.Array Word64 - eid = A.unsafeIndex 0 arr1 - eflags = A.unsafeIndex 1 arr1 - pathLen = fromIntegral $ A.unsafeIndex 2 arr1 - path <- P.takeEQ pathLen (A.writeN pathLen) - return $ Event - { eventId = eid - , eventFlags = fromIntegral eflags - , eventAbsPath = path - } - -parseMany2Events :: Property -parseMany2Events = - monadicIO $ do - xs <- - ( run - $ toList - $ S.catRights - $ S.parseManyD readOneEvent - $ S.fromList (concat (replicate 2 event)) - ) - assert (length xs == 2) - -- XXX assuming little endian machine - let ev = Event - { eventId = 152170080 - , eventFlags = 66560 - , eventAbsPath = A.fromList evPath - } - in listEquals (==) xs (replicate 2 ev) - -------------------------------------------------------------------------------- --- Main -------------------------------------------------------------------------------- - -moduleName :: String -moduleName = "Data.Parser.ParserD" - -main :: IO () -main = - hspec $ - H.parallel $ - modifyMaxSuccess (const maxTestCount) $ do - describe moduleName $ do - - describe "Instances" $ do - prop "applicative" applicative - prop "Alternative: end of input 1" altEOF1 - prop "Alternative: end of input 2" altEOF2 - prop "monad" monad - prop "sequence" sequence - - describe "Stream parsing" $ do - prop "parseMany" parseMany - prop "parseMany2Events" parseMany2Events - prop "parseUnfold" parseUnfold - prop "parserSequence" parserSequence - - describe "test for accumulator" $ do - prop "P.fromFold FL.sum = FL.sum" fromFold - prop "fromPure value provided" fromPure - prop "fromPure monadic value provided" fromEffect - prop "always fail" die - prop "always fail but monadic" dieM - - describe "test for element parser" $ do - prop "peek = head with list length > 0" peekPass - prop "peek fail on []" peekFail - prop "eof pass on []" eofPass - prop "eof fail on non-empty list" eofFail - prop "first element exists and >= mid_value" satisfyPass - prop "check first element exists and satisfies predicate" satisfy - - describe "test for sequence parser" $ do - prop "P.takeBetween m n = Prelude.take when len >= m and len <= n" - takeBetweenPass - prop ("P.takeBetween m n = Prelude.take when len >= m and len <= n and" - ++ " fail otherwise") takeBetween - prop "P.take = Prelude.take" Main.take - prop "P.takeEQ = Prelude.take when len >= n" takeEQPass - prop "P.takeEQ = Prelude.take when len >= n and fail otherwise" Main.takeEQ - prop "P.takeGE n ls = ls when len >= n" takeGEPass - prop "P.takeGE n ls = ls when len >= n and fail otherwise" Main.takeGE - prop "lookAhead . take n >> lookAhead . take n = lookAhead . take n" lookAheadPass - prop "lookAhead . take n >> lookAhead . take n = lookAhead . take n, else fail" lookAhead - prop "P.takeWhile = Prelude.takeWhile" Main.takeWhile - prop "P.takeWhile1 = Prelude.takeWhile if taken something, else check why failed" takeWhile1 - prop "P.groupBy = Prelude.head . Prelude.groupBy" groupBy - prop "groupByRolling" groupByRolling - prop "P.takeEndByOrMax = Prelude.take n (Prelude.takeWhile (not . predicate)" takeEndByOrMax - prop "many (P.wordBy ' ') = words'" wordBy - prop "parse 0, then 1, else fail" splitWith - prop "fail due to die as left parser" splitWithFailLeft - prop "fail due to die as right parser" splitWithFailRight - prop "fail due to die as both parsers" splitWithFailBoth - {- - prop "parsed two lists should be equal" teeWithPass - prop "fail due to die as left parser" teeWithFailLeft - prop "fail due to die as right parser" teeWithFailRight - prop "fail due to die as both parsers" teeWithFailBoth - prop "P.takeWhile (<= half_mid_value) = Prelude.takeWhile half_mid_value" shortestPass - prop "pass even if die is left parser" shortestPassLeft - prop "pass even if die is right parser" shortestPassRight - prop "fail due to die as both parsers" shortestFailBoth - prop "P.takeWhile (<= mid_value) = Prelude.takeWhile (<= mid_value)" longestPass - prop "pass even if die is left parser" longestPassLeft - prop "pass even if die is right parser" longestPassRight - prop "fail due to die as both parsers" longestFailBoth - -} - prop "P.many concatFold $ P.takeEndBy_ (== 1) FL.toList = Prelude.filter (== 0)" many - prop "[] due to parser being die" many_empty - prop "P.some concatFold $ P.takeEndBy_ (== 1) FL.toList = Prelude.filter (== 0)" some - prop "fail due to parser being die" someFail - takeProperties diff --git a/test/Streamly/Test/Data/ParserK.hs b/test/Streamly/Test/Data/ParserK.hs new file mode 100644 --- /dev/null +++ b/test/Streamly/Test/Data/ParserK.hs @@ -0,0 +1,146 @@ +-- XXX We are using head/tail at one place +#if __GLASGOW_HASKELL__ >= 908 +{-# OPTIONS_GHC -Wno-x-partial #-} +#endif + +module Main (main) where + +import Data.Either (fromRight) +import Test.Hspec (Spec, hspec, describe, it, expectationFailure, shouldBe) +import Test.Hspec.QuickCheck + +import qualified Streamly.Internal.Data.Array as A +import qualified Streamly.Internal.Data.Array.Generic as AG +import qualified Streamly.Internal.Data.Fold as FL +import qualified Streamly.Internal.Data.Parser as Parser +import qualified Streamly.Internal.Data.ParserK as ParserK +import qualified Streamly.Internal.Data.Stream as Stream +import qualified Streamly.Internal.Data.StreamK as StreamK +import qualified Test.Hspec as H + +import Streamly.Test.Parser.Common + +import Prelude hiding (sequence) + +maxTestCount :: Int +maxTestCount = 100 + +toParser :: Spec +toParser = do + let p = ParserK.toParser (ParserK.toParserK Parser.one) + runP xs = Stream.parsePos p (Stream.fromList xs) + describe "toParser . toParserK" $ do + it "empty stream" $ do + r1 <- runP ([] :: [Int]) + case r1 of + Left e -> print e + Right x -> + expectationFailure $ "Expecting failure, got: " ++ show x + it "exact stream" $ do + r2 <- runP [0::Int] + fromRight undefined r2 `shouldBe` 0 + it "longer stream" $ do + r3 <- runP [0,1::Int] + fromRight undefined r3 `shouldBe` 0 + + let p1 = ParserK.toParserK $ ParserK.toParser (ParserK.toParserK Parser.one) + runP1 xs = StreamK.parsePos p1 (StreamK.fromStream $ Stream.fromList xs) + describe "toParserK . toParser . toParserK" $ do + it "empty stream" $ do + r1 <- runP1 ([] :: [Int]) + case r1 of + Left e -> print e + Right x -> + expectationFailure $ "Expecting failure, got: " ++ show x + it "exact stream" $ do + r2 <- runP1 [0::Int] + fromRight undefined r2 `shouldBe` 0 + it "longer stream" $ do + r3 <- runP1 [0,1::Int] + fromRight undefined r3 `shouldBe` 0 + + -- NOTE: Without fusionBreaker this test would pass even if toParser has + -- incorrect implementation because of fusion rules. + let p2 = Parser.takeWhile (<= 3) FL.toList + runP2 xs = Stream.parseBreakPos p2 (Stream.fromList xs) + + p3 = ParserK.toParserK (Parser.takeWhile (<= 3) FL.toList) + runP3 xs = StreamK.parseBreakPos p3 (StreamK.fromList xs) + + p4 = + ParserK.toParser + $ fusionBreaker + $ ParserK.toParserK (Parser.takeWhile (<= 3) FL.toList) + runP4 xs = Stream.parseBreakPos p4 (Stream.fromList xs) + describe "toParser . toParserK" $ do + it "(<= 3) for [1, 2, 3, 4, 5]" $ do + (a, b) <- runP2 ([1, 2, 3, 4, 5] :: [Int]) + fromRight undefined a `shouldBe` [1, 2, 3] + rest <- Stream.toList b + rest `shouldBe` [4, 5] + it "(<= 3) for [1, 2, 3, 4, 5]" $ do + (a, b) <- runP3 ([1, 2, 3, 4, 5] :: [Int]) + fromRight undefined a `shouldBe` [1, 2, 3] + rest <- StreamK.toList b + rest `shouldBe` [4, 5] + it "(<= 3) for [1, 2, 3, 4, 5]" $ do + (a, b) <- runP4 ([1, 2, 3, 4, 5] :: [Int]) + fromRight undefined a `shouldBe` [1,2,3] + rest <- Stream.toList b + rest `shouldBe` [4, 5] + it "(<= 3) for [1, 2, 3]" $ do + (a, b) <- runP4 ([1, 2, 3] :: [Int]) + fromRight undefined a `shouldBe` [1, 2, 3] + rest <- Stream.toList b + rest `shouldBe` [] + +{-# NOINLINE fusionBreaker #-} +fusionBreaker :: a -> a +fusionBreaker = id + +------------------------------------------------------------------------------- +-- Parser driver sanity tests +------------------------------------------------------------------------------- + +sanityParseBreak :: [Move] -> H.SpecWith () +sanityParseBreak jumps = it (show jumps) $ do + (val, rest) <- + StreamK.parseBreakPos (ParserK.toParserK (jumpParser jumps)) + $ StreamK.fromList tape + lst <- StreamK.toList rest + (val, lst) `shouldBe` (expectedResult jumps tape) + +sanityParseBreakChunks :: [Move] -> H.SpecWith () +sanityParseBreakChunks jumps = it (show jumps) $ do + (val, rest) <- + A.parseBreakPos (A.toParserK (jumpParser jumps)) + $ StreamK.fromList $ Prelude.map A.fromList chunkedTape + lst <- Prelude.map A.toList <$> StreamK.toList rest + (val, concat lst) `shouldBe` (expectedResult jumps tape) + +sanityParseBreakChunksGeneric :: [Move] -> H.SpecWith () +sanityParseBreakChunksGeneric jumps = it (show jumps) $ do + (val, rest) <- + AG.parseBreakPos (AG.toParserK (jumpParser jumps)) + $ StreamK.fromList $ Prelude.map AG.fromList chunkedTape + lst <- Prelude.map AG.toList <$> StreamK.toList rest + (val, concat lst) `shouldBe` (expectedResult jumps tape) + +------------------------------------------------------------------------------- +-- Main +------------------------------------------------------------------------------- + +moduleName :: String +moduleName = "Data.ParserK" + +-- Many ParserK tests are tested in Test.Parser module +main :: IO () +main = + hspec $ + H.parallel $ + modifyMaxSuccess (const maxTestCount) $ do + describe moduleName $ do + parserSanityTests "StreamK.parseBreak" sanityParseBreak + parserSanityTests "StreamK.parseBreakChunks" sanityParseBreakChunks + parserSanityTests "StreamK.parseBreakChunksGeneric" sanityParseBreakChunksGeneric + toParser diff --git a/test/Streamly/Test/Data/Ring/Unboxed.hs b/test/Streamly/Test/Data/Ring/Unboxed.hs deleted file mode 100644 --- a/test/Streamly/Test/Data/Ring/Unboxed.hs +++ /dev/null @@ -1,53 +0,0 @@ --- | --- Module : Streamly.Test.Data.Ring.Unboxed --- Copyright : (c) 2022 Composewell Technologies --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC - -module Streamly.Test.Data.Ring.Unboxed (main) where - -import Control.Monad (void) - -import qualified Streamly.Internal.Data.Array.Type as Array -import qualified Streamly.Internal.Data.Ring.Unboxed as Ring - -import Prelude as P -import qualified Data.Foldable as P - -import Test.Hspec as H - -unsafeEqArrayN :: [Int] -> [Int] -> Int -> Int -> Bool -> IO () -unsafeEqArrayN lstArr lstRing startR nelem expected = do - let arr = Array.fromList lstArr - (ring, rh) <- Ring.new (length lstRing) - void $ P.foldlM (Ring.unsafeInsert ring) rh lstRing - Ring.unsafeEqArrayN ring (Ring.moveBy startR ring rh) arr nelem - `shouldBe` expected - -unsafeEqArray :: [Int] -> [Int] -> Int -> Bool -> IO () -unsafeEqArray lstArr lstRing startR expected = do - let arr = Array.fromList lstArr - (ring, rh) <- Ring.new (length lstRing) - void $ P.foldlM (Ring.unsafeInsert ring) rh lstRing - Ring.unsafeEqArray ring (Ring.moveBy startR ring rh) arr - `shouldBe` expected - -moduleName :: String -moduleName = "Data.Ring.Unboxed" - -main :: IO () -main = hspec $ do - describe moduleName $ do - describe "Eq" $ do - let lstArr = [0..99] - lstRing = [50..99] ++ [0..49] - it "unsafeEqArrayN True (n < len)" - $ unsafeEqArrayN lstArr lstRing 50 75 True - it "unsafeEqArrayN True (n > len)" - $ unsafeEqArrayN lstArr lstRing 50 200 True - it "unsafeEqArrayN False" - $ unsafeEqArrayN lstArr lstRing 10 75 False - it "unsafeEqArray True" $ unsafeEqArray lstArr lstRing 50 True - it "unsafeEqArray False" $ unsafeEqArray lstArr lstRing 20 False diff --git a/test/Streamly/Test/Data/RingArray.hs b/test/Streamly/Test/Data/RingArray.hs new file mode 100644 --- /dev/null +++ b/test/Streamly/Test/Data/RingArray.hs @@ -0,0 +1,56 @@ +-- | +-- Module : Streamly.Test.Data.RingArray +-- Copyright : (c) 2022 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +module Streamly.Test.Data.RingArray (main) where + +import Streamly.Test.Common (performGCSweep) + +import qualified Streamly.Internal.Data.MutArray as MutArray +import qualified Streamly.Internal.Data.Array as Array +import qualified Streamly.Internal.Data.RingArray as RingArray + +import Prelude as P +import Test.Hspec as H + +eqArrayN :: [Int] -> [Int] -> Int -> Int -> Bool -> IO () +eqArrayN lstArr lstRing startR nBytes expected = do + let arr = Array.fromList lstArr + marr <- MutArray.fromList lstRing + let ring = + maybe (error "cast failed") id $ RingArray.castMutArrayWith startR marr + performGCSweep 4 100000 + res <- RingArray.eqArrayN ring arr nBytes + res `shouldBe` expected + +eqArray :: [Int] -> [Int] -> Int -> Bool -> IO () +eqArray lstArr lstRing startR expected = do + let arr = Array.fromList lstArr + marr <- MutArray.fromList lstRing + let ring = + maybe (error "cast failed") id $ RingArray.castMutArrayWith startR marr + performGCSweep 4 100000 + res <- RingArray.eqArray ring arr + res `shouldBe` expected + +moduleName :: String +moduleName = "Data.RingArray" + +main :: IO () +main = hspec $ do + describe moduleName $ do + describe "Eq" $ do + let lstArr = [0..99] + lstRing = [50..99] ++ [0..49] + it "eqArrayN True (n < len)" + $ eqArrayN lstArr lstRing 50 75 True + it "eqArrayN True (n > len)" + $ eqArrayN lstArr lstRing 50 200 True + it "eqArrayN False" + $ eqArrayN lstArr lstRing 10 75 False + it "eqArray True" $ eqArray lstArr lstRing 50 True + it "eqArray False" $ eqArray lstArr lstRing 20 False diff --git a/test/Streamly/Test/Data/Scanl/Concurrent.hs b/test/Streamly/Test/Data/Scanl/Concurrent.hs new file mode 100644 --- /dev/null +++ b/test/Streamly/Test/Data/Scanl/Concurrent.hs @@ -0,0 +1,154 @@ +-- | +-- Module : Streamly.Test.Data.Scanl.Concurrent +-- Copyright : (c) 2020 Composewell Technologies +-- +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +module Streamly.Test.Data.Scanl.Concurrent (main) where + +import Control.Concurrent (threadDelay) +import Control.Exception (ErrorCall(..), try) +import Data.Function ( (&) ) +import Data.IORef (newIORef, atomicModifyIORef') +import Data.List (sort) +import Streamly.Data.Scanl (Scanl) +import Test.Hspec as H + +import qualified Streamly.Data.Fold as Fold +import qualified Streamly.Data.Stream as Stream +import qualified Streamly.Internal.Data.Scanl as Scanl +import qualified Streamly.Internal.Data.Scanl.Prelude as Scanl + +moduleName :: String +moduleName = "Data.Scanl.Concurrent" + +--------------------------------------------------------------------------- +-- Main +--------------------------------------------------------------------------- + +evenScan :: Scanl IO Int (Maybe Int) +evenScan = + Scanl.filtering even + & Scanl.lmapM (\x -> threadDelay 100 >> pure x) + +oddScan :: Scanl IO Int (Maybe Int) +oddScan = + Scanl.filtering odd + & Scanl.lmapM (\x -> threadDelay 100 >> pure x) + +parDistributeScan_ScanEnd :: (Scanl.Config -> Scanl.Config) -> IO () +parDistributeScan_ScanEnd concOpts = do + let streamLen = 10000 + evenLen = 100 + ref <- newIORef [Scanl.take evenLen evenScan, oddScan] + let gen = atomicModifyIORef' ref (\xs -> ([], xs)) + inpList = [1..streamLen] + inpStream = Stream.fromList inpList + res1 <- + Scanl.parDistributeScanM concOpts gen inpStream + & Stream.concatMap Stream.fromList + & Stream.catMaybes + & Stream.fold Fold.toList + sort res1 `shouldBe` [1..evenLen] ++ filter odd [(evenLen+1)..streamLen] + +parDemuxScan_ScanEnd :: (Scanl.Config -> Scanl.Config) -> IO () +parDemuxScan_ScanEnd concOpts = do + let streamLen = 10000 + evenLen = 100 + demuxer i = even (i :: Int) + ref <- newIORef (Scanl.take evenLen $ Scanl.mkScanl1 (\_ x -> x)) + let gen True = + atomicModifyIORef' ref (\xs -> (fmap (const Nothing) Scanl.drain, xs)) + gen False = pure $ Scanl.mkScanl1 (\_ x -> x) + inpList = [1..streamLen] + inpStream = Stream.fromList inpList + res <- + Scanl.parDemuxScanM concOpts demuxer gen inpStream + & Stream.concatMap Stream.fromList + & fmap (\x -> (fst x,) <$> snd x) + & Stream.catMaybes + & Stream.fold Fold.toList + map snd (filter fst res) `shouldBe` take evenLen [2, 4 ..] + map snd (filter (not . fst) res) `shouldBe` filter odd [1..streamLen] + +parDistributeScan_StreamEnd :: (Scanl.Config -> Scanl.Config) -> IO () +parDistributeScan_StreamEnd concOpts = do + let streamLen = 10000 + ref <- newIORef [evenScan, oddScan] + let gen = atomicModifyIORef' ref (\xs -> ([], xs)) + inpList = [1..streamLen] + inpStream = Stream.fromList inpList + res1 <- + Scanl.parDistributeScanM concOpts gen inpStream + & Stream.concatMap Stream.fromList + & Stream.catMaybes + & Stream.fold Fold.toList + sort res1 `shouldBe` inpList + +parDemuxScan_StreamEnd :: (Scanl.Config -> Scanl.Config) -> IO () +parDemuxScan_StreamEnd concOpts = do + let streamLen = 10000 + demuxer i = even (i :: Int) + gen _ = pure $ Scanl.mkScanl1 (\_ x -> x) + inpList = [1..streamLen] + inpStream = Stream.fromList inpList + res <- + Scanl.parDemuxScanM concOpts demuxer gen inpStream + & Stream.concatMap Stream.fromList + & fmap (\x -> (fst x,) <$> snd x) + & Stream.catMaybes + & Stream.fold Fold.toList + map snd (filter fst res) `shouldBe` filter even [1..streamLen] + map snd (filter (not . fst) res) `shouldBe` filter odd [1..streamLen] + +parDemuxScan_WorkerException :: (Scanl.Config -> Scanl.Config) -> IO () +parDemuxScan_WorkerException concOpts = do + let throwAfter = 3 + -- All items go to the same key so the driver stays in sendToWorker_ + -- for a single worker channel, maximizing the chance of blocking on a + -- full buffer. + demuxer _ = (0 :: Int) + gen _ = pure + $ Scanl.lmapM + (\x -> do + -- Slow the worker down so the buffer fills up and the + -- driver blocks in sendToWorker_ waiting for space. + threadDelay 50000 + if (x :: Int) > throwAfter + then error "worker exception" + else pure x) + $ Scanl.mkScanl1 (\_ x -> x) + -- Send enough items to fill the buffer (maxBuffer 1) and block + inpList = [1..100] + inpStream = Stream.fromList inpList + res <- try + $ Scanl.parDemuxScanM concOpts demuxer gen inpStream + & Stream.concatMap Stream.fromList + & fmap (\x -> (fst x,) <$> snd x) + & Stream.catMaybes + & Stream.fold Fold.toList + case res of + Left (ErrorCall msg) -> msg `shouldBe` "worker exception" + Right _ -> expectationFailure + "Expected ErrorCall exception but stream completed successfully" + +main :: IO () +main = hspec + $ H.parallel +#ifdef COVERAGE_BUILD + $ modifyMaxSuccess (const 10) +#endif + $ describe moduleName $ do + it "parDistributeScanM (stream end) (maxBuffer 1)" + $ parDistributeScan_StreamEnd (Scanl.maxBuffer 1) + it "parDistributeScanM (scan end) (maxBuffer 1)" + $ parDistributeScan_ScanEnd (Scanl.maxBuffer 1) + it "parDemuxScanM (stream end) (maxBuffer 1)" + $ parDemuxScan_StreamEnd (Scanl.maxBuffer 1) + it "parDemuxScanM (scan end) (maxBuffer 1)" + $ parDemuxScan_ScanEnd (Scanl.maxBuffer 1) + it "parDemuxScanM (worker exception) (maxBuffer 1)" + $ parDemuxScan_WorkerException (Scanl.maxBuffer 1) diff --git a/test/Streamly/Test/Data/Serialize.hs b/test/Streamly/Test/Data/Serialize.hs new file mode 100644 --- /dev/null +++ b/test/Streamly/Test/Data/Serialize.hs @@ -0,0 +1,308 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} + +-- Required for Eq instance declaration of HigherOrderType +{-# LANGUAGE UndecidableInstances #-} + +-- We are generating an orphan instance of Serialize for Identity. +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- Module : Streamly.Test.Data.Serialize +-- Copyright : (c) 2022 Composewell technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +module Streamly.Test.Data.Serialize (main) where + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +import Data.Foldable (forM_) +import Data.Word (Word8) +import System.Random (randomRIO) +import Streamly.Internal.Data.MutByteArray (MutByteArray) +import GHC.Generics (Generic) +import Streamly.Data.MutByteArray (Serialize) +import Streamly.Test.Data.Serialize.TH (genDatatype) + +import Data.Functor.Identity (Identity (..)) + +import qualified Streamly.Internal.Data.Array as Array +import qualified Streamly.Internal.Data.MutArray as MutArray +import qualified Streamly.Internal.Data.MutByteArray as Serialize + +import qualified Streamly.Test.Data.Serialize.CompatV0 as CompatV0 +import qualified Streamly.Test.Data.Serialize.CompatV1 as CompatV1 + +import Test.Hspec.QuickCheck +import Test.QuickCheck +import Test.Hspec as H + +-------------------------------------------------------------------------------- +-- Serialize configuration +-------------------------------------------------------------------------------- + +#ifdef ENABLE_constructorTagAsString +#define CONF_NAME "ENABLE_constructorTagAsString" +#define CONF (Serialize.encodeConstrNames True) +#else +#define CONF_NAME "DEFAULT" +#define CONF id +#endif + +-------------------------------------------------------------------------------- +-- Edge case types +-------------------------------------------------------------------------------- + +data Unit = + Unit + deriving (Eq, Show) +$(Serialize.deriveSerializeWith CONF [d|instance Serialize Unit|]) + +data The = + The Unit Int Char + deriving (Eq, Show) +$(Serialize.deriveSerializeWith CONF [d|instance Serialize The|]) + +-------------------------------------------------------------------------------- +-- Generated types +-------------------------------------------------------------------------------- + +$(genDatatype "CustomDatatype" 15) +$(Serialize.deriveSerializeWith CONF [d|instance Serialize CustomDatatype|]) + +-------------------------------------------------------------------------------- +-- Types with functional parameters +-------------------------------------------------------------------------------- + +data HigherOrderType f = + HigherOrderType + { field0 :: f Int + , field1 :: f Char + } + +instance (Eq (f Int), Eq (f Char)) => Eq (HigherOrderType f) where + (==) a b = (field0 a == field0 b) && (field1 a == field1 b) + +instance (Show (f Int), Show (f Char)) => Show (HigherOrderType f) where + show a = "HigherOrderType " ++ show (field0 a) ++ " " ++ show (field1 a) + +$(Serialize.deriveSerializeWith CONF + [d|instance Serialize a => Serialize (Identity a)|]) +$(Serialize.deriveSerializeWith CONF + [d|instance Serialize (HigherOrderType Identity)|]) + +-------------------------------------------------------------------------------- +-- Recursive type +-------------------------------------------------------------------------------- + +-- Recursive ADT +data BinTree a + = Tree (BinTree a) (BinTree a) + | Leaf a + deriving (Show, Read, Eq, Generic) + +$(Serialize.deriveSerializeWith + CONF + [d|instance Serialize a => Serialize (BinTree a)|]) + +-- XXX This may not terminate, or could become really large. +instance Arbitrary a => Arbitrary (BinTree a) where + arbitrary = oneof [Leaf <$> arbitrary, Tree <$> arbitrary <*> arbitrary] + +-- Make a balanced tree of given level +mkBinTree :: (Arbitrary a) => Int -> IO (BinTree a) +mkBinTree = go (generate arbitrary) + + where + + go r 0 = Leaf <$> r + go r n = Tree <$> go r (n - 1) <*> go r (n - 1) + +-------------------------------------------------------------------------------- +-- Record syntax type +-------------------------------------------------------------------------------- + +upgradeRec :: (a -> b) -> CompatV0.Rec a -> CompatV1.Rec b +upgradeRec f val = + CompatV1.Rec + { CompatV1.initialField = CompatV0.initialField val + , CompatV1.otherField = f (CompatV0.otherField val) + , CompatV1.theLastField = CompatV0.theLastField val + , CompatV1.aNewField = Nothing + } + +upgradeRiver :: CompatV0.River -> CompatV1.River +upgradeRiver = read . show + +downgradeRec :: (a -> b) -> CompatV1.Rec a -> CompatV0.Rec b +downgradeRec f val = + CompatV0.Rec + { CompatV0.initialField = CompatV1.initialField val + , CompatV0.otherField = f (CompatV1.otherField val) + , CompatV0.theLastField = CompatV1.theLastField val + } + +downgradeRiver :: CompatV1.River -> CompatV0.River +downgradeRiver = read . show + +testCompatibility :: + CompatV0.Rec (CompatV0.Rec CompatV0.River) + -> CompatV1.Rec (CompatV1.Rec CompatV1.River) + -> IO () +testCompatibility v0 v1 = do + let upgradedV0 = upgradeRec (upgradeRec upgradeRiver) v0 + downgradedV1 = downgradeRec (downgradeRec downgradeRiver) v1 + + res <- poke v0 + peekAndVerify res upgradedV0 + + res1 <- poke v1 + peekAndVerify res1 downgradedV1 + +-------------------------------------------------------------------------------- +-- Test helpers +-------------------------------------------------------------------------------- + +poke :: + forall a. Serialize.Serialize a + => a + -> IO (MutByteArray, Int, Int) +poke val = do + let sz = Serialize.addSizeTo 0 val + + let excessSize = 100 + randomOff <- randomRIO (10, excessSize) + -- Use a proper slice to test instead of the array directly. This will catch + -- any hardcoded 0 offsets + let arrSize = sz + excessSize + serStartOff = randomOff + serEndOff = randomOff + sz + arr <- Serialize.new arrSize + arr2 <- Serialize.new arrSize + -- Re-initialize the array with random value + forM_ [0..(arrSize - 1)] $ \i -> Serialize.pokeAt i arr2 (8 :: Word8) + + off1 <- Serialize.serializeAt serStartOff arr val + off2 <- Serialize.serializeAt 0 arr2 val + + let slice1 = Array.Array arr serStartOff off1 :: Array.Array Word8 + slice2 = Array.Array arr2 0 off2 :: Array.Array Word8 + -- The serialized representation should be the same + slice1 `shouldBe` slice2 + + off1 `shouldBe` serEndOff + pure (arr, serStartOff, serEndOff) + +peekAndVerify :: + forall a. (Eq a, Show a, Serialize.Serialize a) + => (MutByteArray, Int, Int) + -> a + -> IO () +peekAndVerify (arr, serStartOff, serEndOff) val = do + (off2, val2) <- Serialize.deserializeAt serStartOff arr serEndOff + val2 `shouldBe` val + off2 `shouldBe` serEndOff + let slice = Array.Array arr serStartOff serEndOff + val `shouldBe` fst (Array.deserialize slice) + clonedSlice <- + fmap Array.unsafeFreeze $ MutArray.clone $ Array.unsafeThaw slice + val `shouldBe` fst (Array.deserialize clonedSlice) + +roundtrip + :: forall a. (Eq a, Show a, Serialize.Serialize a) + => a + -> IO () +roundtrip val = do + + -- For debugging large size generated by arbitrary + -- let sz = Serialize.addSizeTo 0 val + -- putStrLn $ "Size is: " ++ show sz + + val `shouldBe` fst (Array.deserialize (Array.serialize' val)) + + res <- poke val + peekAndVerify res val + +testSerializeList + :: forall a. (Eq a, Show a, Serialize.Serialize a) + => Int + -> a + -> IO () +testSerializeList sizeOfA val = do + + let sz = Serialize.addSizeTo 0 val + + sz `shouldBe` sizeOfA + + roundtrip val + +-------------------------------------------------------------------------------- +-- Tests +-------------------------------------------------------------------------------- + +testCases :: Spec +testCases = do + + it "Serialize [Int]" + $ testSerializeList (8 + 4 * 8) ([1, 2, 3, 4] :: [Int]) + it "Serialize [[Int]]" + $ testSerializeList + (8 + 3 * 8 + 6 * 8) + ([[1], [1, 2], [1, 2, 3]] :: [[Int]]) + + describe "Edge Cases" $ do + it "Unit" $ roundtrip Unit + it "The" $ roundtrip $ The Unit 1 'a' + + it "HigherOrderType" + $ roundtrip $ HigherOrderType (Identity 5) (Identity 'e') + + prop "Integer" + $ \(x :: Integer) -> roundtrip x + + prop "([Integer], [Int])" + $ \(x :: ([Integer], [Int])) -> roundtrip x + + prop "Array Int" + $ \(x :: [Int]) -> roundtrip (Array.fromList x) + + prop "Compatible Record" + $ \(a :: CompatV1.Rec (CompatV0.Rec CompatV1.River)) -> roundtrip a + + prop "Compatibility" + $ \a b -> testCompatibility a b + + limitQC + $ prop "CustomDatatype" + $ \(x :: CustomDatatype) -> roundtrip x + + limitQC + $ prop "[CustomDatatype]" + $ \(x :: [CustomDatatype]) -> roundtrip x + + limitQC + $ prop "BinTree" + $ forAll (elements [1..15]) + (\(x :: Int) -> do + (r :: BinTree Int) <- mkBinTree x + roundtrip r + ) + + where + + limitQC = modifyMaxSize (const 50) + +-------------------------------------------------------------------------------- +-- Main function +-------------------------------------------------------------------------------- + +moduleName :: String +moduleName = "Data.Serialize." ++ CONF_NAME + +main :: IO () +main = hspec $ H.parallel $ describe moduleName testCases diff --git a/test/Streamly/Test/Data/Serialize/CompatV0.hs b/test/Streamly/Test/Data/Serialize/CompatV0.hs new file mode 100644 --- /dev/null +++ b/test/Streamly/Test/Data/Serialize/CompatV0.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Streamly.Test.Data.Serialize.CompatV0 + ( Rec(..) + , River(..) + ) where + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +import Test.QuickCheck (Arbitrary, arbitrary, elements) +import Streamly.Internal.Data.MutByteArray (Serialize) +import qualified Streamly.Internal.Data.MutByteArray as Serialize + +-------------------------------------------------------------------------------- +-- Types +-------------------------------------------------------------------------------- + +data Rec a = + Rec + { initialField :: Int + , otherField :: a + , theLastField :: Maybe String + } + deriving (Eq, Show) + +instance Arbitrary a => Arbitrary (Rec a) where + arbitrary = Rec <$> arbitrary <*> arbitrary <*> arbitrary + +$(Serialize.deriveSerializeWith + (Serialize.encodeRecordFields True) + [d|instance Serialize a => Serialize (Rec a)|]) + +data River + = Ganga + | Yamuna + | Godavari + deriving (Eq, Show, Read) + +instance Arbitrary River where + arbitrary = elements [Ganga, Yamuna, Godavari] + +$(Serialize.deriveSerializeWith + (Serialize.encodeConstrNames True) + [d|instance Serialize River|]) diff --git a/test/Streamly/Test/Data/Serialize/CompatV1.hs b/test/Streamly/Test/Data/Serialize/CompatV1.hs new file mode 100644 --- /dev/null +++ b/test/Streamly/Test/Data/Serialize/CompatV1.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Streamly.Test.Data.Serialize.CompatV1 + ( Rec(..) + , River(..) + ) where + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +import Test.QuickCheck (Arbitrary, arbitrary, elements) +import Streamly.Internal.Data.MutByteArray (Serialize) +import qualified Streamly.Internal.Data.MutByteArray as Serialize + +-------------------------------------------------------------------------------- +-- Types +-------------------------------------------------------------------------------- + +data Rec a = + Rec + { initialField :: Int + , otherField :: a + , theLastField :: Maybe String + , aNewField :: Maybe Char + } + deriving (Eq, Show) + +instance Arbitrary a => Arbitrary (Rec a) where + arbitrary = Rec <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + +$(Serialize.deriveSerializeWith + (Serialize.encodeRecordFields True) + [d|instance Serialize a => Serialize (Rec a)|]) + +data River + = Yamuna + | Krishna + | Godavari + | Ganga + deriving (Eq, Show, Read) + +instance Arbitrary River where + arbitrary = elements [Ganga, Yamuna, Godavari] + +$(Serialize.deriveSerializeWith + (Serialize.encodeConstrNames True) + [d|instance Serialize River|]) diff --git a/test/Streamly/Test/Data/Serialize/TH.hs b/test/Streamly/Test/Data/Serialize/TH.hs new file mode 100644 --- /dev/null +++ b/test/Streamly/Test/Data/Serialize/TH.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Module : Streamly.Test.Data.Serialize.TH +-- Copyright : (c) 2022 Composewell technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +module Streamly.Test.Data.Serialize.TH (genDatatype) where + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +import Language.Haskell.TH + +import Test.QuickCheck.Arbitrary (Arbitrary(..)) +import Test.QuickCheck.Gen (oneof) + +-------------------------------------------------------------------------------- +-- Generated types +-------------------------------------------------------------------------------- + +genDatatype :: String -> Int -> Q [Dec] +genDatatype tyName numCons = + sequence + [ dataD + (pure []) + (mkName tyName) + [] + Nothing + (mkCon <$> [0 .. (numCons - 1)]) + [derivClause Nothing [conT ''Eq, conT ''Show]] + , instanceD + (pure []) + (appT (conT ''Arbitrary) (conT (mkName tyName))) + [ funD + 'arbitrary + [ clause + [] + (normalB + (appE + (varE 'oneof) + (listE + (mkArbitraryExp <$> + [0 .. (numCons - 1)])))) + [] + ] + ] + ] + + where + + fieldTypeChoices = + [ conT ''Int + , conT ''Char + , conT ''String + , appT listT (conT ''Int) + , appT listT (conT ''String) + , appT listT (appT listT (conT ''Int)) + , appT listT (appT listT (conT ''String)) + ] + + chooseCycle i xs = xs !! (i `mod` length xs) + + mkArbitraryExp i = + foldl + (\b a -> [|$(b) <*> $(a)|]) + [|pure $(conE (mkName ("Constructor" ++ show i)))|] + (replicate i (varE 'arbitrary)) + + mkCon i = + normalC + (mkName ("Constructor" ++ show i)) + (mkField <$> [0..(i - 1)]) + + mkField i = + bangType + (bang noSourceUnpackedness noSourceStrictness) + (chooseCycle i fieldTypeChoices) diff --git a/test/Streamly/Test/Data/Stream.hs b/test/Streamly/Test/Data/Stream.hs new file mode 100644 --- /dev/null +++ b/test/Streamly/Test/Data/Stream.hs @@ -0,0 +1,867 @@ +-- XXX We are using head/tail at one place +{-# OPTIONS_GHC -Wno-missing-signatures #-} +#if __GLASGOW_HASKELL__ >= 908 +{-# OPTIONS_GHC -Wno-x-partial #-} +#endif + +-- | +-- Module : Streamly.Test.Data.Stream +-- Copyright : (c) 2019 Composewell technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +module Streamly.Test.Data.Stream (main) where + +import Control.Monad ( forM_ ) +import Control.Monad.IO.Class (MonadIO) +import Data.List (sort, group, intercalate) +import Data.Semigroup (Sum(..), getSum) +import Data.Word (Word8) +import Streamly.Internal.Data.Array (Array) +import Streamly.Internal.Data.Fold (Fold) +import Streamly.Internal.Data.MutByteArray (Unbox) +import Streamly.Internal.Data.Stream (Stream) +import Test.QuickCheck + ( Gen + , Property + , Arbitrary(..) + , choose + , forAll + , frequency + , listOf + , listOf1 + , suchThat + , vectorOf + , withMaxSuccess + ) +import Test.QuickCheck.Monadic (assert, monadicIO, pick, run) + +import qualified Streamly.Internal.Data.Array as Array +import qualified Streamly.Internal.Data.Fold as Fold +import qualified Streamly.Internal.Data.Stream as Stream +import qualified Streamly.Internal.Data.Unfold as Unfold +import qualified Streamly.Internal.Data.StreamK as StreamK +import qualified Streamly.Internal.Data.Parser as Parser + +import Test.Hspec as H +import Test.Hspec.QuickCheck + +import Streamly.Test.Common +-- import Streamly.Test.Prelude.Common + +toList :: Monad m => Stream m a -> m [a] +toList = Stream.toList + +-- XXX There are takeEndBy_ tests in Data.Fold module as well, need to +-- deduplicate. +-- XXX Where are the tests for "takeEndBy"? +splitOn :: Monad m => + (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b +splitOn predicate f = Stream.foldManyPost (Fold.takeEndBy_ predicate f) + +splitOnSuffix :: Monad m => + (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b +splitOnSuffix predicate f = Stream.foldMany (Fold.takeEndBy_ predicate f) + +-- XXX Where are the tests for "takeEndBySeq"? +splitOnSeqFold :: (MonadIO m, Unbox a, Enum a, Eq a) => + Array.Array a -> Fold m a b -> Stream m a -> Stream m b +splitOnSeqFold patt f = Stream.foldManyPost (Fold.takeEndBySeq_ patt f) + +splitOnSeqStream :: (MonadIO m, Unbox a, Enum a, Eq a) => + Array.Array a -> Fold m a b -> Stream m a -> Stream m b +splitOnSeqStream = Stream.splitSepBySeq_ + +splitOnSuffixSeqFold :: (MonadIO m, Unbox a, Enum a, Eq a) => + Array.Array a -> Fold m a b -> Stream m a -> Stream m b +splitOnSuffixSeqFold patt f = Stream.foldMany (Fold.takeEndBySeq_ patt f) + +-- XXX Where are the tests for Stream.splitOnSuffixSeq True ? +splitOnSuffixSeqStream :: (MonadIO m, Unbox a, Enum a, Eq a) => + Array.Array a -> Fold m a b -> Stream m a -> Stream m b +splitOnSuffixSeqStream = Stream.splitOnSuffixSeq False + +groupsBy :: Monad m => + (a -> a -> Bool) -> Fold m a b -> Stream m a -> Stream m b +groupsBy cmp f m = Stream.catRights $ Stream.parseMany (Parser.groupBy cmp f) m + +groupsByRolling :: Monad m => + (a -> a -> Bool) -> Fold m a b -> Stream m a -> Stream m b +groupsByRolling cmp f m = + Stream.catRights $ Stream.parseMany (Parser.groupByRolling cmp f) m + +{- +drainWhile :: Monad m => (a -> Bool) -> Stream m a -> m () +drainWhile p m = Stream.fold Fold.drain $ Stream.takeWhile p m +-} + +splitOnSeq :: + (Array Char -> Fold IO a [a] -> Stream IO Char -> Stream IO String) + -> Spec +splitOnSeq op = do + describe "Tests for splitOnSeq" $ do + -- Empty pattern case + it "splitOnSeq_ \"\" \"\" = []" + $ splitOnSeq_ "" "" `shouldReturn` [] + + -- Single element pattern cases + it "splitOnSeq_ \"x\" \"\" = []" + $ splitOnSeq_ "x" "" `shouldReturn` [] + it "splitOnSeq_ \"x\" \"hello\" = [\"hello\"]" + $ splitOnSeq_ "x" "hello" `shouldReturn` ["hello"] + it "splitOnSeq_ \"h\" \"hello\" = [\"\", \"ello\"]" + $ splitOnSeq_ "h" "hello" `shouldReturn` ["", "ello"] + it "splitOnSeq_ \"e\" \"hello\" = [\"h\", \"llo\"]" + $ splitOnSeq_ "e" "hello" `shouldReturn` ["h", "llo"] + it "splitOnSeq_ \"l\" \"hello\" = [\"he\", \"\", \"o\"]" + $ splitOnSeq_ "l" "hello" `shouldReturn` ["he", "", "o"] + it "splitOnSeq_ \"o\" \"hello\" = [\"hell\", \"\"]" + $ splitOnSeq_ "o" "hello" `shouldReturn` ["hell", ""] + + -- multi-element pattern fitting in a Word + it "splitOnSeq_ \"he\" \"\" = []" + $ splitOnSeq_ "he" "" `shouldReturn` [] + it "splitOnSeq_ \"he\" \"hello\" = [\"\", \"llo\"]" + $ splitOnSeq_ "he" "hello" `shouldReturn` ["", "llo"] + it "splitOnSeq_ \"ll\" \"hello\" = [\"he\", \"o\"]" + $ splitOnSeq_ "ll" "hello" `shouldReturn` ["he", "o"] + it "splitOnSeq_ \"lo\" \"hello\" = [\"hel\", \"\"]" + $ splitOnSeq_ "lo" "hello" `shouldReturn` ["hel", ""] + + -- multi-element pattern - Rabin-Karp cases + it "splitOnSeq_ \"hello\" \"\" = []" + $ splitOnSeq_ "hello" "" `shouldReturn` [] + it "splitOnSeq_ \"hel\" \"hello\" = [\"\", \"lo\"]" + $ splitOnSeq_ "hel" "hello" `shouldReturn` ["", "lo"] + it "splitOnSeq_ \"ell\" \"hello\" = [\"h\", \"o\"]" + $ splitOnSeq_ "ell" "hello" `shouldReturn` ["h", "o"] + it "splitOnSeq_ \"llo\" \"hello\" = [\"he\", \"\"]" + $ splitOnSeq_ "llo" "hello" `shouldReturn` ["he", ""] + it "splitOnSeq_ \"hello\" \"hello\" = [\"\", \"\"]" + $ splitOnSeq_ "hello" "hello" `shouldReturn` ["", ""] + + where + + splitOnSeq_ pat xs = toList $ + op (Array.fromList pat) Fold.toList (Stream.fromList xs) + +splitOnSuffixSeq :: + (Array Char -> Fold IO a [a] -> Stream IO Char -> Stream IO String) + -> Spec +splitOnSuffixSeq op = do + describe "Tests for splitOnSuffixSeq" $ do + -- Empty pattern case + + -- Single element pattern cases + it "splitSuffixOn_ \".\" \"\" []" + $ splitSuffixOn_ "." "" `shouldReturn` [] + it "splitSuffixOn_ \".\" \".\" [\"\"]" + $ splitSuffixOn_ "." "." `shouldReturn` [""] + it "splitSuffixOn_ \".\" \"a\" [\"a\"]" + $ splitSuffixOn_ "." "a" `shouldReturn` ["a"] + it "splitSuffixOn_ \".\" \".a\" [\"\",\"a\"]" + $ splitSuffixOn_ "." ".a" `shouldReturn` ["", "a"] + it "splitSuffixOn_ \".\" \"a.\" [\"a\"]" + $ splitSuffixOn_ "." "a." `shouldReturn` ["a"] + it "splitSuffixOn_ \".\" \"a.b\" [\"a\",\"b\"]" + $ splitSuffixOn_ "." "a.b" `shouldReturn` ["a", "b"] + it "splitSuffixOn_ \".\" \"a.b.\" [\"a\",\"b\"]" + $ splitSuffixOn_ "." "a.b." `shouldReturn` ["a", "b"] + it "splitSuffixOn_ \".\" \"a..b..\" [\"a\",\"\",\"b\",\"\"]" + $ splitSuffixOn_ "." "a..b.." `shouldReturn` ["a", "", "b", ""] + + -- multi-element pattern fitting in a Word + it "splitSuffixOn_ \"he\" \"hello\" = [\"\", \"llo\"]" + $ splitSuffixOn_ "he" "hello" `shouldReturn` ["", "llo"] + it "splitSuffixOn_ \"el\" \"hello\" = [\"h\", \"lo\"]" + $ splitSuffixOn_ "el" "hello" `shouldReturn` ["h", "lo"] + it "splitSuffixOn_ \"lo\" \"hello\" = [\"hel\"]" + $ splitSuffixOn_ "lo" "hello" `shouldReturn` ["hel"] + + -- multi-element pattern - Rabin-Karp cases + it "splitSuffixOn_ \"hello\" \"\" = []" + $ splitSuffixOn_ "hello" "" `shouldReturn` [] + it "splitSuffixOn_ \"hel\" \"hello\" = [\"\", \"lo\"]" + $ splitSuffixOn_ "hel" "hello" `shouldReturn` ["", "lo"] + it "splitSuffixOn_ \"ell\" \"hello\" = [\"h\", \"o\"]" + $ splitSuffixOn_ "ell" "hello" `shouldReturn` ["h", "o"] + it "splitSuffixOn_ \"llo\" \"hello\" = [\"he\"]" + $ splitSuffixOn_ "llo" "hello" `shouldReturn` ["he"] + it "splitSuffixOn_ \"hello\" \"hello\" = [\"\", \"\"]" + $ splitSuffixOn_ "hello" "hello" `shouldReturn` [""] + + where + + splitSuffixOn_ pat xs = toList $ + op (Array.fromList pat) Fold.toList (Stream.fromList xs) + +intercalateSuffix xs yss = intercalate xs yss ++ xs + +nonSepElem :: (Arbitrary a, Eq a) => a -> Gen a +nonSepElem sep = suchThat arbitrary (/= sep) + +listWithSep :: Arbitrary a => a -> Gen [a] +listWithSep sep = listOf $ frequency [(3, arbitrary), (1, return sep)] + +listWithoutSep :: (Arbitrary a, Eq a) => a -> Gen [a] +listWithoutSep sep = vectorOf 4 (nonSepElem sep) + +listsWithoutSep :: (Arbitrary a, Eq a) => a -> Gen [[a]] +listsWithoutSep sep = listOf (listWithoutSep sep) + +listsWithoutSep1 :: (Arbitrary a, Eq a) => a -> Gen [[a]] +listsWithoutSep1 sep = listOf1 (listWithoutSep sep) + +intercalateSplitEqId sep splitter lIntercalater sIntercalater i = + let name = + "intercalater . splitter == id (" + <> show i <> " element separator)" + in prop name + $ forAll (listWithSep sep) + $ \xs -> withMaxSuccess maxTestCount $ monadicIO $ testCase xs + + where + + testCase xs = do + ys <- splitter xs (replicate i sep) + szs <- + toList + $ sIntercalater (replicate i sep) Unfold.fromList + $ Stream.fromList ys + let lzs = lIntercalater (replicate i sep) ys + listEquals (==) szs xs + listEquals (==) lzs xs + +intercalateSplitEqIdNoSepEnd sep splitter lIntercalater sIntercalater i = + let name = + "intercalater . splitter . (++ [x \\= sep]) == id (" + <> show i <> " element separator)" + in prop name + $ forAll ((,) <$> listWithSep sep <*> nonSepElem sep) + $ \(xs_, nonSep) -> do + let xs = xs_ ++ [nonSep] + withMaxSuccess maxTestCount $ monadicIO $ testCase xs + + where + + testCase xs = do + ys <- splitter xs (replicate i sep) + szs <- + toList + $ sIntercalater (replicate i sep) Unfold.fromList + $ Stream.fromList ys + let lzs = lIntercalater (replicate i sep) ys + listEquals (==) szs xs + listEquals (==) lzs xs + +concatSplitIntercalateEqConcat sep splitter lIntercalater sIntercalater i = + let name = + "concat . splitter .Stream.intercalater == " + <> "concat (" + <> show i <> " element separator/possibly empty list)" + in prop name + $ forAll (listsWithoutSep sep) + $ \xss -> withMaxSuccess maxTestCount $ monadicIO $ testCase xss + + where + + testCase xss = do + let lxs = lIntercalater (replicate i sep) xss + lys <- splitter lxs (replicate i sep) + sxs <- + toList + $ sIntercalater (replicate i sep) Unfold.fromList + $ Stream.fromList xss + sys <- splitter sxs (replicate i sep) + listEquals (==) (concat lys) (concat xss) + listEquals (==) (concat sys) (concat xss) + +splitIntercalateEqId sep splitter lIntercalater sIntercalater = + let name = + "splitter . intercalater == id" + <> " (exclusive separator/non-empty list)" + in prop name + $ forAll (listsWithoutSep1 sep) + $ \xss -> do + withMaxSuccess maxTestCount $ monadicIO $ testCase xss + + where + + testCase xss = do + let lxs = lIntercalater [sep] xss + lys <- splitter lxs [sep] + sxs <- toList + $ sIntercalater [sep] Unfold.fromList + $ Stream.fromList xss + sys <- splitter sxs [sep] + listEquals (==) lys xss + listEquals (==) sys xss + +splitterProperties :: + forall a. (Arbitrary a, Eq a, Show a) + => a + -> String + -> Spec +splitterProperties sep desc = do + describe (desc <> " splitOn") + $ do + + intercalateSplitEqId + sep splitOn_ intercalate Stream.unfoldEachSepBySeq 1 + + concatSplitIntercalateEqConcat + sep splitOn_ intercalate Stream.unfoldEachSepBySeq 1 + + -- Exclusive case + splitIntercalateEqId + sep splitOn_ intercalate Stream.unfoldEachSepBySeq + + describe (desc <> " splitOnSuffix") + $ do + + intercalateSplitEqIdNoSepEnd + sep splitOnSuffix_ intercalate Stream.unfoldEachSepBySeq 1 + + concatSplitIntercalateEqConcat + sep splitOnSuffix_ intercalateSuffix Stream.unfoldEachEndBySeq 1 + + -- Exclusive case + splitIntercalateEqId + sep splitOnSuffix_ intercalateSuffix Stream.unfoldEachEndBySeq + + where + + splitOn_ xs pat = + toList $ splitOn (== head pat) Fold.toList (Stream.fromList xs) + + splitOnSuffix_ xs pat = + toList $ splitOnSuffix (== head pat) Fold.toList (Stream.fromList xs) + +seqSplitterProperties :: + forall a. (Arbitrary a, Eq a, Show a, Unbox a, Enum a) + => a + -> String + -> Spec +seqSplitterProperties sep desc = do + describe (desc <> " splitOnSeq fold") (splitOnSeqWith splitOnSeq_) + describe (desc <> " splitOnSeq stream") (splitOnSeqWith splitOnSeqStream_) + describe (desc <> " splitOnSuffixSeq fold") + (splitOnSuffixSeqWith splitOnSuffixSeq_) + describe (desc <> " splitOnSuffixSeq stream") + (splitOnSuffixSeqWith splitOnSuffixSeqStream_) + + where + + splitOnSeq_ xs pat = + toList $ splitOnSeqFold (Array.fromList pat) Fold.toList (Stream.fromList xs) + + splitOnSeqStream_ xs pat = + toList $ splitOnSeqStream (Array.fromList pat) Fold.toList (Stream.fromList xs) + + splitOnSuffixSeq_ xs pat = + toList $ splitOnSuffixSeqFold (Array.fromList pat) Fold.toList (Stream.fromList xs) + + splitOnSuffixSeqStream_ xs pat = + toList $ splitOnSuffixSeqStream (Array.fromList pat) Fold.toList (Stream.fromList xs) + + splitOnSeqWith op = do + forM_ [0, 1, 2, 4] + $ intercalateSplitEqId sep op intercalate Stream.unfoldEachSepBySeq + + forM_ [0, 1, 2, 4] + $ concatSplitIntercalateEqConcat + sep op intercalate Stream.unfoldEachSepBySeq + + -- Exclusive case + splitIntercalateEqId sep op intercalate Stream.unfoldEachSepBySeq + + splitOnSuffixSeqWith op = do + forM_ [0, 1, 2, 4] + $ intercalateSplitEqIdNoSepEnd + sep op intercalate Stream.unfoldEachSepBySeq + + forM_ [0, 1, 2, 4] + $ concatSplitIntercalateEqConcat + sep op intercalateSuffix Stream.unfoldEachEndBySeq + + -- Exclusive case + splitIntercalateEqId + sep op intercalateSuffix Stream.unfoldEachEndBySeq + +intercalateSplitOnId :: + forall a. (Arbitrary a, Eq a, Show a, Num a) => + a -> String -> Spec +intercalateSplitOnId x desc = + prop (desc <> " intercalate [x] . splitOn (== x) == id") $ + forAll listWithZeroes $ \xs -> do + withMaxSuccess maxTestCount $ + monadicIO $ do + ys <- toList $ splitOn (== x) Fold.toList (Stream.fromList xs) + listEquals (==) (intercalate [x] ys) xs + + where + + listWithZeroes :: Gen [a] + listWithZeroes = listOf $ frequency [(3, arbitrary), (1, return 0)] + +groupSplitOps :: String -> Spec +groupSplitOps desc = do + -- splitting + + -- The foldManyPost implementation on an empty stream produces a single + -- value. The behaviour of foldManyPost implementation and the direct stream + -- implementation is not different. + -- splitOnSeq splitOnSeqFold + + splitOnSeq splitOnSeqStream + splitOnSuffixSeq splitOnSuffixSeqFold + + -- XXX there are no tests for withSep = True option + splitOnSuffixSeq splitOnSuffixSeqStream + -- Some ad-hoc tests + it "splitEndBySeq word hash cases" $ do + let f sep input result = + Stream.toList + ( Stream.splitEndBySeq (Array.fromList sep) Fold.toList + $ Stream.fromList input + ) `shouldReturn` result + + f "ab" "a" ["a"] + f "ab" "ab" ["ab"] + f "ab" "aba" ["ab","a"] + f "ab" "abab" ["ab","ab"] + f "ab" "abc" ["ab","c"] + f "ab" "xab" ["xab"] + f "" "" [] + f "." "" [] + f ".." "" [] + f "..." "" [] + f "" "a...b" ["a",".",".",".","b"] + f "." "a...b" ["a.",".",".","b"] + f ".." "a...b" ["a..",".b"] + f "..." "a...b" ["a...","b"] + f "." "abc" ["abc"] + f ".." "abc" ["abc"] + f "..." "abc" ["abc"] + f "." "." ["."] + f ".." ".." [".."] + f "..." "..." ["..."] + f "." ".a" [".","a"] + f "." "a." ["a."] + + it "splitEndBySeq_ word hash cases" $ do + let f sep input result = + Stream.toList + ( Stream.splitEndBySeq_ (Array.fromList sep) Fold.toList + $ Stream.fromList input + ) `shouldReturn` result + f "" "" [] + f "." "" [] + f ".." "" [] + f "..." "" [] + f "" "a...b" ["a",".",".",".","b"] + f "." "a...b" ["a","","","b"] + f ".." "a...b" ["a",".b"] + f "..." "a...b" ["a","b"] + f "." "abc" ["abc"] + f ".." "abc" ["abc"] + f "..." "abc" ["abc"] + f "." "." [""] + f ".." ".." [""] + f "..." "..." [""] + f "." ".a" ["","a"] + f "." "a." ["a"] + + it "splitSepBySeq_ word hash cases" $ do + let f sep input result = + Stream.toList + ( Stream.splitSepBySeq_ (Array.fromList sep) Fold.toList + $ Stream.fromList input + ) `shouldReturn` result + f "" "" [] + f "." "" [] + f ".." "" [] + f "..." "" [] + f "" "a...b" ["a",".",".",".","b"] + f "." "a...b" ["a","","","b"] + f ".." "a...b" ["a",".b"] + f "..." "a...b" ["a","b"] + f "." "abc" ["abc"] + f ".." "abc" ["abc"] + f "..." "abc" ["abc"] + f "." "." ["",""] + f ".." ".." ["",""] + f "..." "..." ["",""] + f "." ".a" ["","a"] + f "." "a." ["a",""] + + let takeEndBySeq pat input result = + Stream.toList + ( Stream.takeEndBySeq (Array.fromList pat) + $ Stream.fromList input + ) `shouldReturn` result + it "takeEndBySeq empty pattern" $ do + let f = takeEndBySeq "" + f "" "" + f "abcd" "" + it "takeEndBySeq single element pattern" $ do + let f = takeEndBySeq "a" + f "" "" + f "a" "a" + f "ab" "a" + f "xa" "xa" + f "xab" "xa" + it "takeEndBySeq word hash cases" $ do + let f = takeEndBySeq "ab" + f "" "" + f "a" "a" + f "ab" "ab" + f "abc" "ab" + f "aba" "ab" + f "abab" "ab" + f "x" "x" + f "xa" "xa" + f "xab" "xab" + f "xabc" "xab" + it "takeEndBySeq karp-rabin cases" $ do + let f = takeEndBySeq "abc" + f "" "" + f "a" "a" + f "ab" "ab" + f "abc" "abc" + f "abcd" "abc" + f "abca" "abc" + f "abcabc" "abc" + f "x" "x" + f "xa" "xa" + f "xab" "xab" + f "xabc" "xabc" + f "xabcd" "xabc" + + -- splitting properties + splitterProperties (0 :: Int) desc + splitterProperties (0 :: Word8) desc + + seqSplitterProperties (0 :: Int) desc + seqSplitterProperties (0 :: Word8) desc + + intercalateSplitOnId (0 :: Int) desc + intercalateSplitOnId (0 :: Word8) desc + +-- | +-- After grouping (and folding) Int stream using @<@ operation, +-- the first @Int@ of every @[Int]@ in the @[Int]@ stream should be the minimum. +testGroupsBy :: Property +testGroupsBy = + forAll (choose (0, maxStreamLen)) $ \len -> + forAll (vectorOf len (arbitrary :: Gen Int)) $ \vec -> monadicIO $ do + r <- run $ Stream.fold (Fold.all (\ls -> + case ls of + [] -> True + (x:_) -> x == minimum ls)) + $ groupsBy (<) Fold.toList + $ Stream.fromList vec + assert r + +testGroups :: Property +testGroups = + forAll (choose (0, maxStreamLen)) $ \len -> + forAll (vectorOf len (arbitrary :: Gen Int)) $ \vec -> monadicIO $ do + r <- toList $ groupsBy (==) Fold.toList $ Stream.fromList vec + assert $ r == group vec + +testGroupsByRolling :: Property +testGroupsByRolling = + forAll (choose (0, maxStreamLen)) $ \len -> + forAll (vectorOf len (arbitrary :: Gen Int)) $ \vec -> monadicIO $ do + r <- toList $ groupsByRolling (==) Fold.toList $ Stream.fromList vec + assert $ r == group vec + +-- | +-- If the list is empty, returns Nothing, +-- else wraps the minimum value of the list in Just. +maybeMinimum :: [Int] -> Maybe Int +maybeMinimum [] = Nothing +maybeMinimum ls = Just $ minimum ls + +-- | +-- Checks if the @[Int]@ is non-increasing. +decreasing :: [Maybe Int] -> Bool +decreasing [] = True +decreasing xs = and $ zipWith (<=) (tail xs) xs + +-- | +-- To check if the minimum elements (after grouping on @<@) +-- are non-increasing (either decrease or remain the same). +-- Had an element been strictly greater, it would have been grouped +-- with that element only. +testGroupsBySep :: Property +testGroupsBySep = + forAll (choose (0, maxStreamLen)) $ \len -> + forAll (vectorOf len (arbitrary :: Gen Int)) $ \vec -> monadicIO $ do + a <- toList + $ fmap maybeMinimum + $ groupsBy (<) Fold.toList + $ Stream.fromList vec + assert $ decreasing a + +testgroupsOf :: Expectation +testgroupsOf = + Stream.toList + (Stream.groupsOf 2 Fold.sum (Stream.enumerateFromTo 1 10)) + `shouldReturn` [3::Int, 7, 11, 15, 19] + +groupingOps :: Spec +groupingOps = do + prop "groupsBy" testGroupsBy + prop "Stream.groups = groups" testGroups + prop "Stream.groupsByRolling = groups" testGroupsByRolling + prop "testGroupsBySep" testGroupsBySep + prop "testgroupsOf" testgroupsOf + +{- +-- XXX to be fixed +associativityCheck + :: String + -> (Stream IO Int -> Stream IO Int) + -> Spec +associativityCheck desc t = prop desc assocCheckProp + where + assocCheckProp :: [Int] -> [Int] -> [Int] -> Property + assocCheckProp xs ys zs = + monadicIO $ do + let xStream = Stream.fromList xs + yStream = Stream.fromList ys + zStream = Stream.fromList zs + infixAssocstream <- + run $ Stream.toList $ t $ xStream `Stream.append` yStream `Stream.append` zStream + assocStream <- run $ Stream.toList $ t $ xStream <> yStream <> zStream + listEquals (==) infixAssocstream assocStream +-} + +max_length :: Int +max_length = 1000 + +unfold :: Property +unfold = monadicIO $ do + a <- pick $ choose (0, max_length `div` 2) + b <- pick $ choose (0, max_length) + let unf = Unfold.second b Unfold.enumerateFromToIntegral + ls <- toList $ Stream.unfold unf a + return $ ls == [a..b] + +foldIterateM :: Property +foldIterateM = + forAll (listOf (chooseInt (0, max_length))) $ \lst -> monadicIO $ do + let s1 = Prelude.sum lst + strm =Stream.fromList lst + ms2 <- + Stream.fold Fold.latest + $ fmap getSum + $ Stream.foldIterateM + (return . Fold.take 1 . Fold.sconcat) + (return (Sum 0)) + $ fmap Sum strm + case ms2 of + Nothing -> assert $ s1 == 0 + Just s2 -> assert $ s1 == s2 + +sortBy :: Property +sortBy = + forAll (listOf (chooseInt (0, max_length))) + $ \lst -> monadicIO $ do + let s1 = sort lst + s2 <- toList + $ StreamK.toStream + ( StreamK.sortBy compare + $ StreamK.fromStream + $ Stream.fromList lst + ) + assert $ s1 == s2 + +------------------------------------------------------------------------------ + +maxStreamLen :: Int +maxStreamLen = 1000 + +-- Coverage build takes too long with default number of tests +maxTestCount :: Int +#ifdef DEVBUILD +maxTestCount = 100 +#else +maxTestCount = 10 +#endif + +moduleName :: String +moduleName = "Data.Stream" + +main :: IO () +main = hspec + $ H.parallel +#ifdef COVERAGE_BUILD + $ modifyMaxSuccess (const 10) +#endif + $ describe moduleName $ do + describe "Runners" $ do + -- XXX use an IORef to store and check the side effects + it "simple serially" $ + Stream.fold Fold.drain + (Stream.fromPure (0 :: Int)) `shouldReturn` () + it "simple serially with IO" $ + Stream.fold Fold.drain + (Stream.fromEffect $ putStrLn "hello") `shouldReturn` () + + describe "Construction" $ do + {- + -- XXX To be fixed. Copied from old stream Prelude tests. + -- Add all the construction tests for all stream types. + serialOps $ prop "serially repeat" . constructWithRepeat + serialOps $ prop "serially repeatM" . constructWithRepeatM + serialOps $ prop "serially replicate" . constructWithReplicate + serialOps $ prop "serially replicateM" . constructWithReplicateM + serialOps $ prop "serially intFromThenTo" . + constructWithIntFromThenTo + serialOps $ prop "serially DoubleFromThenTo" . + constructWithDoubleFromThenTo + serialOps $ prop "serially iterate" . constructWithIterate + -- XXX test for all types of streams + serialOps $ prop "serially iterateM" . constructWithIterateM + serialOps $ prop "serially enumerate" . constructWithEnumerate id + serialOps $ prop "serially enumerateTo" . constructWithEnumerateTo id + serialOps $ prop "serially fromIndices" . constructWithFromIndices + serialOps $ prop "serially fromIndicesM" . constructWithFromIndicesM + serialOps $ prop "serially fromList" . constructWithFromList id + serialOps $ prop "serially fromListM" . constructWithFromListM id + serialOps $ prop "serially unfoldr" . constructWithUnfoldr id + serialOps $ prop "serially fromPure" . constructWithFromPure id + serialOps $ prop "serially fromEffect" . constructWithFromEffect id + serialOps $ prop "serially cons" . constructWithCons Stream.cons + serialOps $ prop "serially consM" . constructWithConsM Stream.consM id + -} + + describe "From Generators" $ do + prop "unfold" unfold + + {- + describe "Simple Operations" $ serialOps simpleOps + + describe "Functor operations" $ do + serialOps $ functorOps (Stream.fromFoldable) "serially" (==) + serialOps $ functorOps folded "serially folded" (==) + + describe "Monoid operations" $ do + serialOps $ monoidOps "serially" mempty (==) + + describe "Serial loops" $ loops fromSerial id reverse + + describe "Bind and Monoidal composition combinations" $ do + -- XXX Taking a long time when serialOps is used. + bindAndComposeSimpleOps "Serial" sortEq fromSerial + bindAndComposeHierarchyOps "Serial" fromSerial + serialOps $ nestTwoStreams "Serial" id id + serialOps $ nestTwoStreamsApp "Serial" id id + composeAndComposeSimpleSerially "Serial <> " (repeat [1..9]) fromSerial + composeAndComposeSimpleAheadly "Serial <> " (repeat [1 .. 9]) fromSerial + composeAndComposeSimpleWSerially + "Serial <> " + [[1..9], [1..9], [1,3,2,4,6,5,7,9,8], [1,3,2,4,6,5,7,9,8]] + fromSerial + + describe "Semigroup operations" $ do + serialOps $ semigroupOps "serially" (==) + serialOps $ associativityCheck "serial == <>" + + describe "Applicative operations" $ do + -- The tests using sorted equality are weaker tests + -- We need to have stronger unit tests for all those + -- XXX applicative with three arguments + serialOps $ applicativeOps (Stream.fromFoldable) "serially" (==) + serialOps $ applicativeOps folded "serially folded" (==) + serialOps $ applicativeOps1 (Stream.fromFoldable) "serially" (==) + serialOps $ applicativeOps1 (Stream.fromFoldable) "serially folded" (==) + + -- XXX add tests for indexed/indexedR + describe "Zip operations" $ do + -- We test only the serial zip with serial streams and the parallel + -- stream, because the rate setting in these streams can slow down + -- zipAsync. + serialOps $ prop "zip monadic serially" . zipMonadic (Stream.fromFoldable) (==) + serialOps $ prop "zip monadic serially folded" . zipMonadic folded (==) + + -- XXX add merge tests like zip tests + -- for mergeBy, we can split a list randomly into two lists and + -- then merge them, it should result in original list + -- describe "Merge operations" $ do + + describe "Monad operations" $ do + serialOps $ prop "serially monad then" . monadThen (Stream.fromFoldable) (==) + serialOps $ prop "serially monad then folded" . monadThen folded (==) + serialOps $ prop "serially monad bind" . monadBind (Stream.fromFoldable) (==) + serialOps $ prop "serially monad bind folded" . monadBind folded (==) + + describe "Stream transform and combine operations" $ do + serialOps $ transformCombineOpsCommon (Stream.fromFoldable) "serially" (==) + serialOps $ transformCombineOpsCommon folded "serially" (==) + serialOps $ transformCombineOpsOrdered (Stream.fromFoldable) "serially" (==) + serialOps $ transformCombineOpsOrdered folded "serially" (==) + -} + + -- Just some basic sanity tests for now + let input = [[1,1] :: [Int],[2,2],[3,3],[4,4],[5,5],[6,6],[7,7],[8,8]] + mustBe g inp out = + Stream.toList (StreamK.toStream (StreamK.mergeMapWith g StreamK.fromList (StreamK.fromList inp))) + `shouldReturn` out + in do + it "concatPairsWith serial" + $ mustBe StreamK.append input [1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8] + it "concatPairsWith wSerial" + $ mustBe StreamK.interleave input [1,5,3,7,2,6,4,8,1,5,3,7,2,6,4,8] + it "concatPairsWith mergeBy sorted" + $ mustBe + (StreamK.mergeBy compare) input [1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8] + it "concatPairsWith mergeBy reversed" + $ mustBe + (StreamK.mergeBy compare) + (reverse input) + [1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8] + prop "sortBy" sortBy + + describe "Stream group and split operations" $ do + groupSplitOps "serially" + + {- + describe "Stream elimination operations" $ do + serialOps $ eliminationOps (Stream.fromFoldable) "serially" + serialOps $ eliminationOps folded "serially folded" + serialOps $ eliminationOpsWord8 (Stream.fromFoldable) "serially" + serialOps $ eliminationOpsWord8 folded "serially folded" + serialOps $ \t -> + prop "drainWhile (> 0)" $ \n -> + withMaxSuccess maxTestCount $ + monadicIO $ do + let xs = [1..n] + ioRef <- run $ newIORef ([] :: [Int]) + run $ + drainWhile (> 0) . t $ + Stream.mapM (\a -> modifyIORef' ioRef (a :) >> return a) $ + Stream.fromList xs + strm <- run $ readIORef ioRef + listEquals (==) (reverse strm) (takeWhile (> 0) xs) + + -- XXX Add a test where we chain all transformation APIs and make sure that + -- the state is being passed through all of them. + describe "Stream serial elimination operations" $ do + serialOps $ eliminationOpsOrdered (Stream.fromFoldable) "serially" + serialOps $ eliminationOpsOrdered folded "serially folded" + -} + + describe "Tests for Stream.groupsBy" groupingOps + + -- describe "Tests for exceptions" $ serialOps $ exceptionOps "serially" + + -- describe "Composed MonadThrow serially" $ composeWithMonadThrow fromSerial + + describe "Nesting" $ do + prop "foldIterateM" foldIterateM diff --git a/test/Streamly/Test/Data/Stream/Concurrent.hs b/test/Streamly/Test/Data/Stream/Concurrent.hs --- a/test/Streamly/Test/Data/Stream/Concurrent.hs +++ b/test/Streamly/Test/Data/Stream/Concurrent.hs @@ -9,13 +9,14 @@ module Streamly.Test.Data.Stream.Concurrent (main) where -#ifdef DEVBUILD import Control.Concurrent (threadDelay) -#endif import Control.Exception (Exception, try) import Control.Monad (replicateM) import Control.Monad.Catch (throwM) +import Data.Function ( (&) ) +import Data.IORef ( newIORef, readIORef, writeIORef) import Data.List (sort) +import Data.Maybe ( isJust, fromJust ) import Data.Word (Word8) import Streamly.Data.Stream (Stream) import Test.Hspec.QuickCheck @@ -24,8 +25,9 @@ import Test.Hspec as H import qualified Streamly.Data.Fold as Fold -import qualified Streamly.Data.Stream as Stream -import qualified Streamly.Internal.Data.Stream.Concurrent as Async +import qualified Streamly.Internal.Data.Stream as Stream +import qualified Streamly.Internal.Data.Stream.Prelude as Stream +import qualified Streamly.Internal.Data.Stream.Prelude as Async import Streamly.Test.Common (listEquals) @@ -39,10 +41,10 @@ sortEq :: Ord a => [a] -> [a] -> Bool sortEq a b = sort a == sort b -cmp :: Stream IO Int -> ([Int] -> [Int] -> Bool) -> [Int] -> Property -cmp s eq list = +cmp :: (Show a, Ord a) => ([a] -> [a] -> Bool) -> [a] -> Stream IO a -> Property +cmp eq list s = monadicIO $ do - stream <- run $ Stream.fold Fold.toList s + stream <- run $ sort <$> Stream.fold Fold.toList s listEquals eq stream list prop1 :: Testable prop => String -> prop -> SpecWith () @@ -217,6 +219,37 @@ list = flip replicateM (return 1 :: IO Int) stream = Async.parSequence cfg . flip Stream.replicate (return 1 :: IO Int) +drainMapM :: Monad m => (a -> m b) -> Stream m a -> m () +drainMapM f = Stream.fold (Fold.drainMapM f) + +testFromCallback :: IO Int +testFromCallback = do + ref <- newIORef Nothing + let stream = + Stream.parList (Stream.eager True) + [ fmap Just (Stream.fromCallback (setCallback ref)) + , runCallback ref + ] + Stream.fold Fold.sum $ fmap fromJust $ Stream.takeWhile isJust stream + + where + + setCallback ref cb = do + writeIORef ref (Just cb) + + runCallback ref = Stream.fromEffect $ do + cb <- + Stream.repeatM (readIORef ref) + & Stream.delayPost 0.1 + & Stream.mapMaybe id + & Stream.fold Fold.one + + Stream.fromList [1..100] + & Stream.delayPost 0.001 + & drainMapM (fromJust cb) + threadDelay 100000 + return Nothing + main :: IO () main = hspec $ H.parallel @@ -226,94 +259,138 @@ $ describe moduleName $ do let transform = transformCombineFromList Stream.fromList sortEq - prop "eval" $ + prop "parBuffered" $ transform (fmap (+2)) - (fmap (+1) . Async.parEval id . fmap (+1)) + (fmap (+1) . Async.parBuffered id . fmap (+1)) asyncSpec $ prop "parSequence" . sequenceReplicate - -- XXX Need to use asyncSpec in all tests - prop "mapM (+1)" $ - transform (fmap (+1)) (Async.parMapM id (\x -> return (x + 1))) + asyncSpec $ + prop "parMapM (+1)" + . transform (fmap (+1)) + . (`Async.parMapM` (\x -> return (x + 1))) + -- XXX Need to use eq instead of sortEq for ahead oeprations -- Binary append - prop1 "append [] []" - $ cmp (Async.parList id [Stream.nil, Stream.nil]) sortEq [] - prop1 "append [] [1]" - $ cmp (Async.parList id [Stream.nil, Stream.fromPure 1]) sortEq [1] - prop1 "append [1] []" - $ cmp (Async.parList id [Stream.fromPure 1, Stream.nil]) sortEq [1] - prop1 "append [0] [1]" - $ let stream = Async.parList id [Stream.fromPure 0, Stream.fromPure 1] - in cmp stream sortEq [0, 1] + asyncSpec $ + let appWith cfg = Async.parList cfg [Stream.nil, Stream.nil] + in prop1 "parList [] []" . cmp sortEq ([] :: [Int]) . appWith - prop1 "append [0] [] [1]" - $ let stream = - Async.parList id - [Stream.fromPure 0, Stream.nil, Stream.fromPure 1] - in cmp stream sortEq [0, 1] + asyncSpec $ + let appWith cfg = Async.parList cfg [Stream.nil, Stream.fromPure 1] + in prop1 "parList [] [1]" . cmp sortEq [1 :: Int] . appWith - let async = Async.parTwo id - prop1 "append2 left associated" - $ let stream = - Stream.fromPure 0 - `async` Stream.fromPure 1 - `async` Stream.fromPure 2 - `async` Stream.fromPure 3 - in cmp stream sortEq [0, 1, 2, 3] + asyncSpec $ + let appWith cfg = Async.parList cfg [Stream.fromPure 1, Stream.nil] + in prop1 "parList [1] []" . cmp sortEq [1 :: Int] . appWith - prop1 "append right associated" - $ let stream = - Stream.fromPure 0 - `async` (Stream.fromPure 1 - `async` (Stream.fromPure 2 - `async` Stream.fromPure 3)) - in cmp stream sortEq [0, 1, 2, 3] + asyncSpec $ + let appWith cfg = + Async.parList cfg [Stream.fromPure 0, Stream.fromPure 1] + in prop1 "parList [0] [1]" . cmp sortEq [0, 1 :: Int] . appWith - prop1 "append balanced" - $ let leaf x y = Stream.fromPure x `async` Stream.fromPure y - leaf11 = leaf 0 1 `async` leaf 2 (3 :: Int) - leaf12 = leaf 4 5 `async` leaf 6 7 - stream = leaf11 `async` leaf12 - in cmp stream sortEq [0, 1, 2, 3, 4, 5, 6,7] + asyncSpec $ + let appWith cfg = + Async.parList + cfg [Stream.fromPure 0, Stream.nil, Stream.fromPure 1] + in prop1 "parList [0] [] [1]" . cmp sortEq [0, 1 :: Int] . appWith - prop1 "combineWith (maxThreads 1)" - $ let stream = - Async.parTwo (Async.maxThreads 1) - (Stream.fromList [1,2,3,4,5]) + asyncSpec $ + let appWith cfg = + Async.parTwo cfg + (Async.parTwo cfg + (Async.parTwo cfg + (Stream.fromPure 0) (Stream.fromPure 1)) + (Stream.fromPure 2)) + (Stream.fromPure 3) + in prop1 "parTwo left associated" + . cmp sortEq [0, 1, 2, 3 :: Int] . appWith + + asyncSpec $ + let appWith cfg = + Async.parTwo cfg + (Stream.fromPure 0) + (Async.parTwo cfg + (Stream.fromPure 1) + (Async.parTwo cfg + (Stream.fromPure 2) (Stream.fromPure 3)) + ) + in prop1 "parTwo right associated" + . cmp sortEq [0, 1, 2, 3 :: Int] . appWith + + asyncSpec $ + let leaf x y cfg = + Async.parTwo cfg (Stream.fromPure x) + (Stream.fromPure y) + leaf11 cfg = + Async.parTwo cfg (leaf 0 1 cfg) $ leaf 2 (3 :: Int) cfg + leaf12 cfg = + Async.parTwo cfg (leaf 4 5 cfg) $ leaf 6 7 cfg + appWith cfg = + Async.parTwo cfg (leaf11 cfg) (leaf12 cfg) + in prop1 "parTwo balanced" + . cmp sortEq [0, 1, 2, 3, 4, 5, 6,7] . appWith + + asyncSpec $ + let appWith cfg = + Async.parTwo cfg + (Stream.fromList [1,2,3,4,5 :: Int]) (Stream.fromList [6,7,8,9,10]) - in cmp stream (==) [1,2,3,4,5,6,7,8,9,10] + in prop1 "parTwo" . cmp (==) [1,2,3,4,5,6,7,8,9,10] . appWith - prop1 "apply (async arg1)" - $ let s1 = Async.parApply id (Stream.fromPure (,)) (Stream.fromPure 1 `async` Stream.fromPure 2) - s2 = Async.parApply id s1 (Stream.fromPure 3) :: Stream IO (Int, Int) - xs = Stream.fold Fold.toList s2 - in sort <$> xs `shouldReturn` [(1, 3), (2, 3)] + asyncSpec $ + let par2 cfg = + Async.parTwo + cfg + (Stream.fromPure 1) + (Stream.fromPure 2) + s1 cfg = + Async.parCrossApply + cfg + (Stream.fromPure (,)) + (par2 cfg) + s2 cfg = + Async.parCrossApply + cfg + (s1 cfg) + (Stream.fromPure 3) :: Stream IO (Int, Int) + in prop1 + "parCrossApply (async arg1)" . cmp (==) ( [(1, 3), (2, 3)]) . s2 - prop1 "apply (async arg2)" - $ let s1 = Stream.fromPure (1,) - s2 = Async.parApply id s1 (Stream.fromPure 2 `async` Stream.fromPure 3) - xs = Stream.fold Fold.toList s2 :: IO [(Int, Int)] - in sort <$> xs `shouldReturn` [(1, 2), (1, 3)] + asyncSpec $ + let par2 cfg = + Async.parTwo + cfg + (Stream.fromPure (2 :: Int)) + (Stream.fromPure 3) + s1 = Stream.fromPure (1 :: Int,) + s2 cfg = Async.parCrossApply cfg s1 (par2 cfg) + in prop1 "apply (async arg2)" . cmp (==) ([(1, 2), (1, 3)]) . s2 -- concat - prop1 "concat" - $ let stream = - Async.parConcat id + asyncSpec $ + let stream cfg = + Async.parConcat cfg $ fmap Stream.fromPure - $ Stream.fromList [1..100] - in cmp stream sortEq [1..100] + $ Stream.fromList [1..100 :: Int] + in prop1 "parConcat" . cmp sortEq [1..100] . stream - prop "concatMap" $ - forAll (choose (0, 100)) $ \n -> - transform - (concatMap (const [1..n])) - (Async.parConcatMap id (const (Stream.fromList [1..n]))) + asyncSpec $ + let f cfg = + forAll (choose (0, 100)) $ \n -> + transform + (concatMap (const [1..n])) + (Async.parConcatMap + cfg (const (Stream.fromList [1..n])) + ) + in prop "parConcatMap" . f #ifdef DEVBUILD describe "Time ordering" $ timeOrdering (Async.parList id) #endif + let async = Async.parTwo id describe "Exception propagation" $ exceptionPropagation async -- Ad-hoc tests it "takes n from stream of streams" $ takeCombined 2 + it "fromCallback" $ testFromCallback `shouldReturn` (50*101) diff --git a/test/Streamly/Test/Data/Stream/Exception.hs b/test/Streamly/Test/Data/Stream/Exception.hs new file mode 100644 --- /dev/null +++ b/test/Streamly/Test/Data/Stream/Exception.hs @@ -0,0 +1,204 @@ +module Streamly.Test.Data.Stream.Exception (main) + +where + +import Control.Concurrent (threadDelay) +import Control.Exception (SomeException, throw, catch, finally, bracket_) +import Control.Monad (when) +import Data.Foldable (sequenceA_) +import Data.Function ((&)) +import Data.IORef (IORef, newIORef, atomicModifyIORef', readIORef) +import Streamly.Internal.Control.Exception (AcquireIO, acquire) +import Streamly.Internal.Data.Stream (Stream) +import Streamly.Internal.Data.Stream.Prelude (Config) +import System.Mem (performMajorGC) + +import qualified Streamly.Internal.Control.Exception as Exception +import qualified Streamly.Internal.Data.Stream.Prelude as Stream +import qualified Streamly.Internal.Data.Stream as Stream +import qualified Streamly.Data.Fold as Fold + +-- IMPORTANT: do not use a blocking operation inside it, otherwise the tests +-- might fail because the operation will become interruptible.. +incr :: Num a => IORef a -> IO () +incr ref = do + -- tid <- myThreadId + -- putStrLn $ "Incrementing the counter: " ++ show tid + atomicModifyIORef' ref (\x -> (x + 1, ())) + +-- IMPORTANT: do not use a blocking operation inside it, otherwise the tests +-- might fail because the operation will become interruptible.. +decr :: Num a => IORef a -> IO () +decr ref = do + atomicModifyIORef' ref (\x -> (x - 1, ())) + -- tid <- myThreadId + -- putStrLn $ "Decremented the counter: " ++ show tid + +handler :: SomeException -> IO b +handler (e :: SomeException) = do + -- tid <- myThreadId + -- putStrLn $ "Child: " ++ show tid ++ " " ++ show e + -- Rethrowing the exception is important, otherwise the thread will not + -- exit. + throw e + +run :: Num a => IORef a -> IO c -> IO c +run ref x = bracket_ (incr ref) (decr ref) (x `catch` handler) + +timeout :: Int +timeout = 1000000 + +takeCount :: Int +takeCount = 1 + +stream :: IORef Int -> (Config -> Config) -> Stream.Stream IO () +stream ref modifier = + Stream.enumerateFrom (1 :: Int) + & Stream.parMapM modifier + ( \x -> + -- somehow if all of them have same timeout then the chances of + -- failure are more. + run ref $ threadDelay (if x == 1 then 1000000 else timeout) + ) + & Stream.take takeCount + +streamRelease :: + AcquireIO -> IORef Int -> IORef Int -> (Config -> Config) -> Stream IO () +streamRelease aref ref1 ref2 modifier = + Stream.enumerateFrom (1 :: Int) + & Stream.parMapM modifier + ( \x -> do + if x <= 10 + then do + -- IMPORTANT: do not put interruptile operations in the + -- release function, otherwise the tests might fail, + -- because the operation will become interruptible. + ((), release) <- + acquire aref (incr ref1) (\() -> decr ref1) + -- 1000 makes a particular bug surface, not less, not more + threadDelay 1000 + -- putStrLn $ "release: " ++ show x + release + else do + run ref2 $ threadDelay timeout + ) + & Stream.take 10 + +finalAction :: Bool -> IORef Int -> Int -> IO () +finalAction gc ref t = do + -- When cleanup happens via GC, ghc creates a thread for the finalizer to + -- run, actual cleanup time depends on when that thread is scheduled. The + -- thread may outlive one or more GCs. So we have to give it some time to + -- finish. But it cannot be deterministic. + -- threadDelay 1000000 + when gc $ do + performMajorGC + threadDelay t + performMajorGC + threadDelay t + r <- readIORef ref + putStrLn $ "Pending computations: " ++ show r + -- Delay for letting any gc based cleanup threads drain and print output + -- for debugging + -- when gc $ threadDelay 1000000 + when (r /= 0) $ error "Failed" + +testStream :: Int -> (Config -> Config) -> IO () +testStream t cfg = do + ref <- newIORef (0 :: Int) + (Stream.withAcquireIO (\aref -> stream ref (cfg . Stream.useAcquire aref)) + -- XXX enable this when stream finalization is implemented + -- & Stream.take 1 + & Stream.fold Fold.drain) `finally` finalAction False ref t + +testStreamRelease :: Int -> (Config -> Config) -> IO () +testStreamRelease count cfg = do + ref1 <- newIORef (0 :: Int) + ref2 <- newIORef (0 :: Int) + (Stream.withAcquireIO (\aref -> do + let cfg1 = cfg . Stream.useAcquire aref + streamRelease aref ref1 ref2 cfg1) + -- XXX enable this when stream finalization is implemented + -- & Stream.take 1 + & Stream.fold Fold.drain + ) + `finally` do + putStrLn "Checking MANUALLY released resources..." + finalAction False ref1 count + putStrLn "Checking AUTO released resources..." + finalAction False ref2 count + +testEffect :: Int -> (Config -> Config) -> IO () +testEffect t cfg = do + ref <- newIORef (0 :: Int) + Exception.withAcquireIO (\aref -> + stream ref (cfg . Stream.useAcquire aref) + & Stream.take 1 + & Stream.fold Fold.drain + ) `finally` finalAction False ref t + +testEffectRelease :: Int -> (Config -> Config) -> IO () +testEffectRelease count cfg = do + ref1 <- newIORef (0 :: Int) + ref2 <- newIORef (0 :: Int) + Exception.withAcquireIO (\aref -> do + let cfg1 = cfg . Stream.useAcquire aref + streamRelease aref ref1 ref2 cfg1 + & Stream.take 1 + & Stream.fold Fold.drain + ) `finally` do + putStrLn "Checking MANUALLY released resources..." + finalAction False ref1 count + putStrLn "Checking AUTO released resources..." + finalAction False ref2 count + +finallyGC :: Int -> (Stream.Config -> Stream.Config) -> IO () +finallyGC t cfg = do + ref <- newIORef (0 :: Int) + Stream.finallyIO (finalAction True ref t) (stream ref cfg) + & Stream.fold Fold.drain + +-- XXX Include rate as well +limits :: [(String, Stream.Config -> Stream.Config)] +limits = + [ ("default", id) + , ("maxBuffer 10", Stream.maxBuffer 10) + , ("maxThreads 10", Stream.maxThreads 10) + ] + +sched :: [(String, Stream.Config -> Stream.Config)] +sched = + [ ("default", id) + , ("eager", Stream.eager True) + , ("ordered", Stream.ordered True) + , ("interleaved", Stream.interleaved True) + ] + +funcs :: [(String, Int -> (Stream.Config -> Stream.Config) -> IO ())] +funcs = + [ ("Stream.withAcquireIO", testStream) + , ("Exception.withAcquireIO", testEffect) + , ("Stream.withAcquireIO release", testStreamRelease) + , ("Exception.withAcquireIO release", testEffectRelease) + , ("finallyGC", finallyGC) + ] + +main :: IO () +main = do + let cfg = id -- Stream.inspect True + + -- TODO: Interrupt test + -- Run the main test in a separate thread. Keep the thread-id in a global + -- variable which will be used to interrupt the thread. Once one thread is + -- over then the next test will keep it's threadId in the global var. + -- Run another thread which sleeps for random intervals and sends + -- UserInterrupt exception to the current test thread-id stored in the + -- glbal variable in a loop. + -- TODO: test for non-concurrent use cases as well + sequenceA_ + [ putStrLn ("Running: " ++ fst f ++ " " ++ fst x1 ++ " " ++ fst x2) + >> snd f + (if fst x1 == "default" then 500000 else 100000) + (snd x1 . snd x2 . cfg) + | f <- funcs, x1 <- limits, x2 <- sched + ] diff --git a/test/Streamly/Test/Data/Stream/Rate.hs b/test/Streamly/Test/Data/Stream/Rate.hs new file mode 100644 --- /dev/null +++ b/test/Streamly/Test/Data/Stream/Rate.hs @@ -0,0 +1,287 @@ +-- | +-- Module : Streamly.Test.Data.Stream.Rate +-- Copyright : (c) 2018 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +module Streamly.Test.Data.Stream.Rate (main) where + +import Data.Int (Int64) +import Streamly.Data.Stream.Prelude (Config) +import Streamly.Internal.Data.Time.Clock (getTime, Clock(..)) +import Streamly.Internal.Data.Time.Units + (NanoSecond64, diffAbsTime64, fromRelTime64) +import System.Mem (performMajorGC) + +import qualified Streamly.Data.Fold as Fold +import qualified Streamly.Data.Stream as Stream +import qualified Streamly.Internal.Data.Stream.Prelude as Stream + +import Control.Concurrent +import Control.Monad +import System.Random +import Test.Hspec + +durationShouldBe :: (Double, Double) -> IO () -> Expectation +durationShouldBe d@(tMin, tMax) action = do + t0 <- getTime Monotonic + action + t1 <- getTime Monotonic + let diff = fromRelTime64 (diffAbsTime64 t1 t0) :: NanoSecond64 + let t = fromIntegral diff / 1e9 + putStrLn $ "Expected: " <> show d <> " Took: " <> show t + (t <= tMax && t >= tMin) `shouldBe` True + +toMicroSecs :: Num a => a -> a +toMicroSecs x = x * 10^(6 :: Int) + +measureRate' :: + String + -> (Config -> Config) + -> Int -- buffers + -> Int -- threads + -> Either Double Int -- either rate or count of actions + -> Int + -> (Double, Double) + -> (Double, Double) + -> Spec +measureRate' + desc modifier buffers threads rval consumerDelay producerDelay expectedRange = do + it (desc <> rateDesc + <> " buffers: " <> show buffers + <> " threads: " <> show threads + <> ", consumer latency: " <> show consumerDelay + <> ", producer latency: " <> show producerDelay) + runTest + + where + + -- Keep a minimum of 2 for the very low rate cases, otherwise the + -- timing would be 0 because we will finish as soon as the first result + -- arrives. + yieldCount :: Int + yieldCount = case rval of + Left r -> max 2 (round (10 * r)) + Right n -> max 2 n + + rateDesc = (case rval of + Left r -> ", rate: " <> show r <> ", count: " <> show yieldCount + Right n -> ", count: " <> show n) <> "," + + cfg (_n :: Maybe Int64) = + modifier + . Stream.maxBuffer buffers + -- . Stream.inspect True + . Stream.maxThreads threads + . case rval of + Left r -> Stream.avgRate r + Right _ -> Stream.rate Nothing + -- XXX it comes out less than expected for ordered streams at high + -- rates, need to fix. + -- . Stream.maxYields (Just (fromIntegral yieldCount)) + + threadAction f = + case rval of + Left _ -> + Stream.take yieldCount + $ Stream.parMapM (cfg (Just (fromIntegral yieldCount))) f + $ Stream.enumerateFrom (1 :: Int) + Right _ -> + Stream.parReplicateM + (cfg (Just (fromIntegral yieldCount))) yieldCount (f 1) + + runTest = do + durationShouldBe expectedRange $ do + res <- Stream.fold Fold.length + $ (if consumerDelay > 0 + then Stream.mapM $ \x -> + threadDelay (toMicroSecs consumerDelay) >> return x + else id) + $ threadAction $ \_idx -> do + let (t1, t2) = producerDelay + r <- if t1 == t2 + then return $ round $ toMicroSecs t1 + else randomRIO ( round $ toMicroSecs t1 + , round $ toMicroSecs t2) + when (r > 0) $ -- do + -- t1 <- getTime Monotonic + threadDelay r + -- t2 <- getTime Monotonic + -- let delta = fromIntegral (toNanoSecs (t2 - t1)) / 1000000000 + -- putStrLn $ "delay took: " <> show delta + -- when (delta > 2) $ do + -- putStrLn $ "delay took high: " <> show delta + -- putStrLn $ "Done: " ++ show idx + return (1 :: Int) + when (res /= yieldCount) $ + error $ "expected yield count: " ++ show yieldCount + ++ " actual: " ++ show res + + -- To ensure that when we use "inspect" option on the channel, GC + -- occurs and cleans up the channel to print the debug info. + performMajorGC + +measureRateVariable :: + String + -> (Config -> Config) + -> Double + -> Int + -> (Double, Double) + -> (Double, Double) + -> Spec +measureRateVariable desc modifier rval = + measureRate' desc modifier (-1) (-1) (Left rval) + +measureRate :: + String + -> (Config -> Config) + -> Double + -> Int + -> Int + -> (Double, Double) + -> Spec +measureRate desc modifier rval consumerDelay producerDelay dur = + let d = fromIntegral producerDelay + in measureRateVariable desc modifier rval consumerDelay (d, d) dur + +measureThreads :: + String + -> (Config -> Config) + -> Int -- threads + -> Int -- count of actions + -> Spec +measureThreads desc modifier threads count = do + let expectedTime = + if threads < 0 + then 1.0 + else fromIntegral count / fromIntegral threads + duration = (expectedTime * 0.9, expectedTime * 1.1) + measureRate' desc modifier (-1) threads (Right count) 0 (1,1) duration + +measureBuffers :: + String + -> (Config -> Config) + -> Int -- buffers + -> Int -- count of actions + -> Spec +measureBuffers desc modifier buffers count = do + let expectedTime = + if buffers < 0 + then 1.0 + else fromIntegral count / fromIntegral buffers + duration = (expectedTime * 0.9, expectedTime * 1.1) + measureRate' desc modifier buffers (-1) (Right count) 0 (1,1) duration + +moduleName :: String +moduleName = "Data.Stream.Rate" + +main :: IO () +main = hspec $ do + describe moduleName $ do + + describe "maxBuffers" $ do + measureBuffers "async" id (-1) 5 + -- XXX this test fails due to a known issue + -- measureBuffers "maxBuffers" id 1 5 + measureBuffers "async" id 5 5 + + describe "maxThreads" $ do + measureThreads "async" id (-1) 5 + measureThreads "async" id 1 5 + measureThreads "async" id 5 5 + + measureThreads "ordered" (Stream.ordered True) (-1) 5 + measureThreads "ordered" (Stream.ordered True) 1 5 + measureThreads "ordered" (Stream.ordered True) 5 5 + + measureThreads "interleaved" (Stream.interleaved True) (-1) 5 + measureThreads "interleaved" (Stream.interleaved True) 1 5 + measureThreads "interleaved" (Stream.interleaved True) 5 5 + + describe "max rate possible (count / time)" $ do + measureRate "async" (Stream.rate Nothing) 1000000 0 0 (0, 1e9) + + let range = (8,12) + + -- Note that because after the last yield we don't wait, the last period + -- will be effectively shorter. This becomes significant when the rates are + -- lower (1 or lower). For rate 1 we lose 1 second in the end and for rate + -- 10 0.1 second. + let rates = [0.1, 1, 10, 100, 1000, 10000 +#ifndef __GHCJS__ + , 100000, 1000000 +#endif + ] + in describe "async no consumer delay no producer delay" $ + forM_ rates (\r -> measureRate "async" id r 0 0 range) + + -- XXX try staggering the dispatches to achieve higher rates + -- Producer delay causes a lot of threads to be created, consuming large + -- amounts of memory at higher rates. + let rates = [0.1, 1, 10, 100 +#if !defined(__GHCJS__) && defined USE_LARGE_MEMORY + 1000, 10000, 25000 +#endif + ] + in describe "async no consumer delay and 1 sec producer delay" $ + forM_ rates (\r -> measureRate "async" id r 0 1 range) + + -- At lower rates (1/10) this is likely to vary quite a bit depending on + -- the spread of random producer latencies generated. + let rates = [1, 10, 100 +#if !defined(__GHCJS__) && defined USE_LARGE_MEMORY + , 1000, 10000, 25000 +#endif + ] + in describe "async, no consumer delay and variable producer delay" $ + forM_ rates $ \r -> + measureRateVariable "async" id r 0 (0.1, 3) range + + let rates = [0.1, 1, 10, 100, 1000, 10000 +#ifndef __GHCJS__ + , 100000, 1000000 +#endif + ] + in describe "interleaved, no consumer delay no producer delay" $ + forM_ rates (\r -> measureRate "interleaved" (Stream.interleaved True) r 0 0 range) + + let rates = [0.1, 1, 10, 100, 1000 +#if !defined(__GHCJS__) && defined USE_LARGE_MEMORY + , 10000, 25000 +#endif + ] + in describe "interleaved, no consumer delay and 1 sec producer delay" $ + forM_ rates (\r -> measureRate "interleaved" (Stream.interleaved True) r 0 1 range) + + let rates = [0.1, 1, 10, 100, 1000, 10000 +#ifndef __GHCJS__ + , 100000, 1000000 +#endif + ] + in describe "ordered, no consumer delay no producer delay" $ + forM_ rates (\r -> measureRate "ordered" (Stream.ordered True) r 0 0 range) + + -- XXX after the change to stop workers when the heap is clearing + -- thi does not work well at a 25000 ops per second, need to fix. + let rates = [0.1, 1, 10, 100, 1000 +#if !defined(__GHCJS__) && defined USE_LARGE_MEMORY + , 10000, 12500 +#endif + ] + in describe "ordered, no consumer delay and 1 sec producer delay" $ + forM_ rates (\r -> measureRate "ordered" (Stream.ordered True) r 0 1 range) + + describe "async, some consumer delay and 1 sec producer delay" $ do + -- ideally it should take 10 x 1 + 1 seconds + forM_ [1] (\r -> measureRate "async" id r 1 1 (11, 16)) + -- ideally it should take 10 x 2 + 1 seconds + forM_ [1] (\r -> measureRate "async" id r 2 1 (21, 23)) + -- ideally it should take 10 x 3 + 1 seconds + forM_ [1] (\r -> measureRate "async" id r 3 1 (31, 33)) + + describe "ordered, some consumer delay and 1 sec producer delay" $ do + forM_ [1] (\r -> measureRate "ordered" (Stream.ordered True) r 1 1 (11, 16)) + forM_ [1] (\r -> measureRate "ordered" (Stream.ordered True) r 2 1 (21, 23)) + forM_ [1] (\r -> measureRate "ordered" (Stream.ordered True) r 3 1 (31, 33)) diff --git a/test/Streamly/Test/Data/Stream/Time.hs b/test/Streamly/Test/Data/Stream/Time.hs new file mode 100644 --- /dev/null +++ b/test/Streamly/Test/Data/Stream/Time.hs @@ -0,0 +1,95 @@ +-- XXX We are using head/tail at one place +#if __GLASGOW_HASKELL__ >= 908 +{-# OPTIONS_GHC -Wno-x-partial #-} +#endif + +-- | +-- Module : Streamly.Test.Data.Stream +-- Copyright : (c) 2019 Composewell technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +module Streamly.Test.Data.Stream.Time (main) where + +#ifdef DEVBUILD +import Control.Concurrent ( threadDelay ) +import Control.Monad ( when) +import Data.Int (Int64) +import Streamly.Internal.Data.Time.Clock (Clock(Monotonic), getTime) +import Streamly.Internal.Data.Time.Units + (AbsTime, NanoSecond64(..), toRelTime64, diffAbsTime64) + +import qualified Streamly.Internal.Data.Fold as Fold +import qualified Streamly.Internal.Data.Stream as Stream +import qualified Streamly.Internal.Data.Stream.Prelude as Stream + +#endif + +import Test.Hspec as H + +#ifdef DEVBUILD +tenPow8 :: Int64 +tenPow8 = 10^(8 :: Int) + +tenPow7 :: Int64 +tenPow7 = 10^(7 :: Int) + +takeDropTime :: NanoSecond64 +takeDropTime = NanoSecond64 $ 5 * tenPow8 + +checkTakeDropTime :: (Maybe AbsTime, Maybe AbsTime) -> IO Bool +checkTakeDropTime (mt0, mt1) = do + let graceTime = NanoSecond64 $ 8 * tenPow7 + case mt0 of + Nothing -> return True + Just t0 -> + case mt1 of + Nothing -> return True + Just t1 -> do + let tMax = toRelTime64 (takeDropTime + graceTime) + let tMin = toRelTime64 (takeDropTime - graceTime) + let t = diffAbsTime64 t1 t0 + let r = t >= tMin && t <= tMax + when (not r) $ putStrLn $ + "t = " ++ show t ++ + " tMin = " ++ show tMin ++ + " tMax = " ++ show tMax + return r + +testTakeInterval :: IO Bool +testTakeInterval = do + r <- + Stream.fold (Fold.tee Fold.one Fold.latest) + $ Stream.takeInterval (fromIntegral takeDropTime * 10**(-9)) + $ Stream.repeatM (threadDelay 1000 >> getTime Monotonic) + checkTakeDropTime r + +testDropInterval :: IO Bool +testDropInterval = do + t0 <- getTime Monotonic + mt1 <- + Stream.fold Fold.one + $ Stream.dropInterval (fromIntegral takeDropTime * 10**(-9)) + $ Stream.repeatM (threadDelay 1000 >> getTime Monotonic) + checkTakeDropTime (Just t0, mt1) +#endif + +moduleName :: String +moduleName = "Data.Stream.Time" + +main :: IO () +main = hspec + $ H.parallel +#ifdef COVERAGE_BUILD + $ modifyMaxSuccess (const 10) +#endif + $ describe moduleName $ do +#ifdef DEVBUILD + describe "Filtering" $ do + it "takeInterval" (testTakeInterval `shouldReturn` True) + it "dropInterval" (testDropInterval `shouldReturn` True) +#endif + it "dummy" (return () `shouldReturn` ()) + diff --git a/test/Streamly/Test/Data/Unbox.hs b/test/Streamly/Test/Data/Unbox.hs --- a/test/Streamly/Test/Data/Unbox.hs +++ b/test/Streamly/Test/Data/Unbox.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE StandaloneDeriving, DeriveAnyClass #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeApplications #-} -{-# HLINT ignore "Use newtype instead of data" #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE TemplateHaskell #-} + +-- This module has a lot of orphan instances as we are deriving it here. We can +-- ignore this warning. {-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} -- | -- Module : Streamly.Test.Data.Unbox @@ -20,106 +20,223 @@ -- Imports -------------------------------------------------------------------------------- +#ifdef USE_SERIALIZE +import Data.Foldable (forM_) +import Data.Word (Word8) +import qualified Streamly.Internal.Data.Array as Array +#endif + +import GHC.Fingerprint (Fingerprint(..)) + import Data.Complex (Complex ((:+))) import Data.Functor.Const (Const (..)) import Data.Functor.Identity (Identity (..)) import Data.Proxy (Proxy(..)) -import GHC.Generics (Generic, Rep(..)) +import GHC.Generics (Generic, Rep) import GHC.Real (Ratio(..)) -import Streamly.Internal.Data.Unboxed - ( PeekRep(..) - , PokeRep(..) - , SizeOfRep(..) - , Unbox(..) - , genericPeekByteIndex - , genericPokeByteIndex - , genericSizeOf - , newUnpinnedBytes - , pokeByteIndex - ) +import Streamly.Internal.Data.MutByteArray +import qualified Streamly.Internal.Data.MutByteArray as MBA + import Test.Hspec as H -------------------------------------------------------------------------------- -- Types -------------------------------------------------------------------------------- +#ifdef USE_SERIALIZE + +#define MODULE_NAME "Data.Serialize.Deriving.TH" +#define DERIVE_UNBOX(typ) $(deriveSerialize [d|instance Serialize typ|]) +#define PEEK(i, arr, sz) (deserializeAt i arr sz) +#define POKE(i, arr, val) (serializeAt i arr val) +#define TYPE_CLASS Serialize + +#else + +#define PEEK(i, arr, sz) peekAtWithNextOff i arr +#define POKE(i, arr, val) pokeAtWithNextOff i arr val +#define TYPE_CLASS Unbox + +#ifdef USE_TH + +#define MODULE_NAME "Data.Unbox.Deriving.TH" +#define DERIVE_UNBOX(typ) $(deriveUnbox [d|instance Unbox typ|]) + +#else + +#define MODULE_NAME "Data.Unbox.Deriving.Generic" +#define DERIVE_UNBOX(typ) deriving instance Unbox (typ) + +#endif + +#endif + +-------------------------------------------------------------------------------- +-- Helpers +-------------------------------------------------------------------------------- + +#ifndef USE_SERIALIZE + +peekAtWithNextOff :: + forall a. Unbox a + => Int + -> MutByteArray + -> IO (Int, a) +peekAtWithNextOff i arr = do + val <- peekAt i arr + pure (i + sizeOf (Proxy :: Proxy a), val) + +pokeAtWithNextOff :: + forall a. Unbox a + => Int + -> MutByteArray + -> a + -> IO Int +pokeAtWithNextOff i arr val = do + pokeAt i arr val + pure $ i + sizeOf (Proxy :: Proxy a) + +#endif + +-------------------------------------------------------------------------------- +-- Types +-------------------------------------------------------------------------------- + -- Unit instance uses a hack, so test all cases data Unit = Unit - deriving (Unbox, Show, Generic, Eq) + deriving (Show, Generic, Eq) +DERIVE_UNBOX(Unit) data UnarySum = Sum1 | Sum2 - deriving (Unbox, Show, Generic, Eq) + deriving (Show, Generic, Eq) +DERIVE_UNBOX(UnarySum) data UnarySum2 = UnitSum1 Unit | UnitSum2 Unit - deriving (Generic, Unbox, Eq, Show) + deriving (Generic, Eq, Show) +DERIVE_UNBOX(UnarySum2) data Unit1 = Unit1 Unit - deriving (Generic, Unbox, Eq, Show) + deriving (Generic, Eq, Show) +DERIVE_UNBOX(Unit1) data Unit2 = Unit2 Unit Unit - deriving (Generic, Unbox, Eq, Show) + deriving (Generic, Eq, Show) +DERIVE_UNBOX(Unit2) data Unit3 = Unit3 Int Unit Int - deriving (Generic, Unbox, Eq, Show) + deriving (Generic, Eq, Show) +DERIVE_UNBOX(Unit3) data Unit4 = Unit4 Int Unit1 Int - deriving (Generic, Unbox, Eq, Show) + deriving (Generic, Eq, Show) +DERIVE_UNBOX(Unit4) {-# ANN Single "HLint: ignore" #-} data Single = Single Int - deriving (Unbox, Show, Generic, Eq) + deriving (Show, Generic, Eq) +DERIVE_UNBOX(Single) data Product2 = Product2 Int Char - deriving (Unbox, Show, Generic, Eq) + deriving (Show, Generic, Eq) +DERIVE_UNBOX(Product2) data SumOfProducts = SOP0 | SOP1 Int | SOP2 Int Char | SOP3 Int Int Int - deriving (Unbox, Show, Generic, Eq) + deriving (Show, Generic, Eq) +DERIVE_UNBOX(SumOfProducts) data NestedSOP = NSOP0 SumOfProducts | NSOP1 SumOfProducts - deriving (Unbox, Show, Generic, Eq) + deriving (Show, Generic, Eq) +DERIVE_UNBOX(NestedSOP) -------------------------------------------------------------------------------- -- Standalone derivations -------------------------------------------------------------------------------- --- Ratio does not have a Generic instance by default +-- The following types don't have a Generic instance by default deriving instance Generic (Ratio Int) +#if !MIN_VERSION_base(4,15,0) +deriving instance Generic (Fingerprint) +#endif +#if defined(USE_SERIALIZE) +$(deriveSerialize + [d|instance Serialize a => Serialize (Complex a)|]) +$(deriveSerialize + [d|instance Serialize a => Serialize (Ratio a)|]) +$(deriveSerialize + [d|instance Serialize a => Serialize (Const a b)|]) +$(deriveSerialize + [d|instance Serialize a => Serialize (Identity a)|]) +#endif + -------------------------------------------------------------------------------- -- Test helpers -------------------------------------------------------------------------------- +#ifdef USE_SERIALIZE +variableSizeOf :: + forall a. Serialize a + => a + -> Int +variableSizeOf = addSizeTo 0 +#endif + testSerialization :: - forall a. (Eq a, Show a, Unbox a) + forall a. (Eq a, Show a, TYPE_CLASS a) => a -> IO () testSerialization val = do - arr <- newUnpinnedBytes (sizeOf (Proxy :: Proxy a)) - pokeByteIndex 0 arr val - peekByteIndex 0 arr `shouldReturn` val + let len = +#ifdef USE_SERIALIZE + (variableSizeOf val) +#else + (sizeOf (Proxy :: Proxy a)) +#endif + arr <- MBA.new len + nextOff <- POKE(0, arr, val) +#ifdef USE_SERIALIZE + arr2 <- MBA.new len + -- Re-initialize the array with random value + forM_ [0..(len - 1)] $ \i -> POKE(i, arr2, (8 :: Word8)) + _ <- POKE(0, arr2, val) + let slice1 = Array.Array arr 0 len :: Array.Array Word8 + slice2 = Array.Array arr2 0 len :: Array.Array Word8 + -- The serialized representation should be the same + slice1 `shouldBe` slice2 + -- The serialized representation is not the same for "Unbox" as the Array + -- might not be fully utilized in case of "Unbox". This is because different + -- constructors might have different lengths. +#endif + (nextOff1, val1) <- PEEK(0, arr, len) + val1 `shouldBe` val + nextOff1 `shouldBe` len + nextOff `shouldBe` len testGenericConsistency :: forall a. ( Eq a , Show a +#ifdef USE_SERIALIZE + , Serialize a +#endif , Unbox a , Generic a , SizeOfRep (Rep a) @@ -131,21 +248,35 @@ testGenericConsistency val = do -- Test the generic sizeOf - sizeOf (Proxy :: Proxy a) `shouldBe` genericSizeOf (Proxy :: Proxy a) + let len = +#ifdef USE_SERIALIZE + variableSizeOf val +#else + sizeOf (Proxy :: Proxy a) +#endif + len `shouldBe` genericSizeOf (Proxy :: Proxy a) -- Test the serialization and deserialization - arr <- newUnpinnedBytes (sizeOf (Proxy :: Proxy a)) + arr <- MBA.new (sizeOf (Proxy :: Proxy a)) - pokeByteIndex 0 arr val + nextOff <- POKE(0, arr, val) genericPeekByteIndex arr 0 `shouldReturn` val genericPokeByteIndex arr 0 val - peekByteIndex 0 arr `shouldReturn` val + (nextOff1, val1) <- PEEK(0, arr, len) + val1 `shouldBe` val + nextOff1 `shouldBe` len + nextOff `shouldBe` len + + +#ifndef USE_SERIALIZE -- Size is also implicitly tested while serializing and deserializing. checkSizeOf :: forall a. Unbox a => Proxy a -> Int -> IO () -checkSizeOf _ size = sizeOf (Proxy :: Proxy a) `shouldBe` size +checkSizeOf _ sz = sizeOf (Proxy :: Proxy a) `shouldBe` sz +#endif + -------------------------------------------------------------------------------- -- CPP helpers -------------------------------------------------------------------------------- @@ -175,6 +306,7 @@ it "SumOfProducts SOP2" $ testSerialization (SOP2 1 'a') it "SumOfProducts SOP3" $ testSerialization (SOP3 1 2 3) +#ifndef USE_SERIALIZE CHECK_SIZE(Unit, 1) CHECK_SIZE(Unit1, 1) CHECK_SIZE(Unit2, 2) @@ -186,6 +318,7 @@ CHECK_SIZE(Product2, 12) CHECK_SIZE(SumOfProducts, 25) CHECK_SIZE(NestedSOP, 26) +#endif it "Bool" $ testSerialization True it "Complex Int" $ testSerialization (5 :+ 3 :: Complex Int) @@ -203,17 +336,16 @@ it "GenericConsistency (Identity Int)" $ testGenericConsistency (Identity 56760 :: Identity Int) - -- Fingerprint does not work for GHC 8.6.5 - -- it "Fingerprint" $ testSerialization (Fingerprint 123456 876588) - -- it "GenericConsistency Fingerprint" - -- $ testGenericConsistency (Fingerprint 123456 876588) + it "Fingerprint" $ testSerialization (Fingerprint 123456 876588) + it "GenericConsistency Fingerprint" + $ testGenericConsistency (Fingerprint 123456 876588) -------------------------------------------------------------------------------- -- Main function -------------------------------------------------------------------------------- moduleName :: String -moduleName = "Data.Unboxed" +moduleName = MODULE_NAME main :: IO () main = hspec $ H.parallel $ describe moduleName testCases diff --git a/test/Streamly/Test/Data/Unbox/TH.hs b/test/Streamly/Test/Data/Unbox/TH.hs new file mode 100644 --- /dev/null +++ b/test/Streamly/Test/Data/Unbox/TH.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Module : Streamly.Test.Data.Unbox.TH +-- Copyright : (c) 2022 Composewell technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +module Streamly.Test.Data.Unbox.TH (main) where + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +import Data.Proxy (Proxy(..)) +import Streamly.Internal.Data.MutByteArray +import qualified Streamly.Internal.Data.MutByteArray as MBA + +import Test.Hspec as H + +-------------------------------------------------------------------------------- +-- Test helpers +-------------------------------------------------------------------------------- + +testSerialization :: + forall a. (Eq a, Show a, Unbox a) + => a + -> IO () +testSerialization val = do + arr <- MBA.new (sizeOf (Proxy :: Proxy a)) + pokeAt 0 arr val + peekAt 0 arr `shouldReturn` val + +-- Size is also implicitly tested while serializing and deserializing. +checkSizeOf :: forall a. Unbox a => Proxy a -> Int -> IO () +checkSizeOf _ sz = sizeOf (Proxy :: Proxy a) `shouldBe` sz + +checkSizeOfNew :: forall a. Unbox a => String -> Proxy a -> Int -> Spec +checkSizeOfNew tag proxy expectation = + it ("checkSizeOf " ++ tag) $ checkSizeOf proxy expectation + +data CustomDataType1 = + CustomDataType1 + deriving (Show, Eq) + +data CustomDataType2 + = CDT2Constructor1 + | CDT2Constructor2 + | CDT2Constructor3 + deriving (Show, Eq) + +data CustomDataType3 a b c + = CDT3Constructor1 a + | CDT3Constructor2 a b + | CDT3Constructor3 a b c + deriving (Show, Eq) + +data CustomDataType4 a b + = CDT4Constructor1 + | CDT4Constructor2 Bool + | CDT4Constructor3 Bool b + deriving (Show, Eq) + +$(deriveUnbox [d|instance Unbox CustomDataType1|]) +$(deriveUnbox [d|instance Unbox CustomDataType2|]) +$(deriveUnbox + [d|instance (Unbox a, Unbox b, Unbox c) => Unbox (CustomDataType3 a b c)|]) +$(deriveUnbox [d|instance Unbox b => Unbox (CustomDataType4 a b)|]) + +-------------------------------------------------------------------------------- +-- CPP helpers +-------------------------------------------------------------------------------- + +#define CHECK_SIZE(type, expectation) \ + it "checkSizeOf type" $ checkSizeOf (Proxy :: Proxy type) expectation + +-------------------------------------------------------------------------------- +-- Tests +-------------------------------------------------------------------------------- + +testCustomDatatype1TH :: Spec +testCustomDatatype1TH = do + it "CustomDataType1" $ testSerialization CustomDataType1 + + CHECK_SIZE(CustomDataType1, 1) + +testCustomDatatype2TH :: Spec +testCustomDatatype2TH = do + it "CustomDataType2 1" $ testSerialization CDT2Constructor1 + it "CustomDataType2 2" $ testSerialization CDT2Constructor2 + it "CustomDataType2 3" $ testSerialization CDT2Constructor3 + + CHECK_SIZE(CustomDataType2, 1) + +testCustomDatatype3TH :: Spec +testCustomDatatype3TH = do + it "CustomDataType3 1" + $ testSerialization + (CDT3Constructor1 3 :: CustomDataType3 Int Bool Double) + it "CustomDataType3 2" + $ testSerialization + (CDT3Constructor2 3 False :: CustomDataType3 Int Bool Double) + it "CustomDataType3 3" + $ testSerialization (CDT3Constructor3 (3 :: Int) False (5 :: Double)) + + checkSizeOfNew + "CustomDataType3" + (Proxy :: Proxy (CustomDataType3 Int Bool Double)) + (1 + sizeOf (Proxy :: Proxy Int) + + sizeOf (Proxy :: Proxy Bool) + + sizeOf (Proxy :: Proxy Double)) + +testCustomDatatype4TH :: Spec +testCustomDatatype4TH = do + it "CustomDataType4 1" + $ testSerialization (CDT4Constructor1 :: CustomDataType4 a Int) + it "CustomDataType4 2" + $ testSerialization + (CDT4Constructor2 True :: CustomDataType4 a Int) + it "CustomDataType4 3" + $ testSerialization (CDT4Constructor3 False (5 :: Int)) + + checkSizeOfNew + "CustomDataType4" + (Proxy :: Proxy (CustomDataType4 a Int)) + (1 + sizeOf (Proxy :: Proxy Bool) + sizeOf (Proxy :: Proxy Int)) + +testCases :: Spec +testCases = do + + testCustomDatatype1TH + testCustomDatatype2TH + testCustomDatatype3TH + testCustomDatatype4TH + +-------------------------------------------------------------------------------- +-- Main function +-------------------------------------------------------------------------------- + +moduleName :: String +moduleName = "Data.Unboxed.TH" + +main :: IO () +main = hspec $ H.parallel $ describe moduleName testCases diff --git a/test/Streamly/Test/Data/Unfold.hs b/test/Streamly/Test/Data/Unfold.hs --- a/test/Streamly/Test/Data/Unfold.hs +++ b/test/Streamly/Test/Data/Unfold.hs @@ -16,8 +16,8 @@ import qualified Streamly.Internal.Data.Fold as Fold import qualified Streamly.Internal.Data.Unfold as UF import qualified Streamly.Internal.Data.Stream as S -import qualified Streamly.Internal.Data.Stream.StreamD as D -import qualified Streamly.Internal.Data.Stream.StreamK as K +import qualified Streamly.Internal.Data.Stream as D +import qualified Streamly.Internal.Data.StreamK as K import Control.Monad.Trans.State.Strict import Data.Functor.Identity @@ -72,8 +72,8 @@ both :: Bool both = - let unf = UF.both 1 (UF.function id) - in testUnfold unf undefined ([1] :: [Int]) + let unf = UF.supply 1 (UF.function id) + in testUnfold unf () ([1] :: [Int]) first :: Bool first = @@ -468,8 +468,8 @@ property $ \f list -> let fA = applyFun2 f :: [Int] -> Int -> Int - fM x y = modify (+ 1) >> return (fA x y) - unf = UF.mapM2 fM UF.fromList + fM (x, y) = modify (+ 1) >> return (fA x y) + unf = UF.mapM fM (UF.carry UF.fromList) mList = Prelude.map (fA list) list in testUnfoldMD unf list 0 (length list) mList @@ -549,7 +549,7 @@ concat = let unfIn = UF.replicateM unfOut = UF.map ((10,) . return) UF.enumerateFromToIntegral - unf = UF.many unfIn unfOut + unf = UF.unfoldEach unfIn unfOut lst = Prelude.concat $ Prelude.map (Prelude.replicate 10) [1 .. 10] in testUnfoldD unf (1, 10) lst diff --git a/test/Streamly/Test/FileSystem/DirIO.hs b/test/Streamly/Test/FileSystem/DirIO.hs new file mode 100644 --- /dev/null +++ b/test/Streamly/Test/FileSystem/DirIO.hs @@ -0,0 +1,202 @@ +-- | +-- Module : Streamly.Test.FileSystem.DirIO +-- Copyright : (c) 2019 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +{-# LANGUAGE CPP #-} + +{-# OPTIONS_GHC -Wno-unrecognised-warning-flags #-} +{-# OPTIONS_GHC -Wno-x-partial #-} + +module Main (main) where + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +import Data.Word (Word8) +import GHC.IO.Encoding (setLocaleEncoding, utf8) +#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) +import Streamly.Data.Array (Array) +#endif +import System.Directory (createDirectoryLink) + +import qualified Streamly.Unicode.Stream as Unicode +import qualified Streamly.Internal.Unicode.Stream as Unicode (lines) +import qualified Streamly.Data.Stream.Prelude as Stream +import qualified Streamly.Data.Fold as Fold +import qualified Streamly.Data.StreamK as StreamK +import qualified Streamly.Internal.FileSystem.DirIO as Dir + +import Prelude hiding (last, length) +import BenchTestLib.DirIO + +import Test.Hspec as H + +-------------------------------------------------------------------------------- +-- Main +-------------------------------------------------------------------------------- + +moduleName :: String +moduleName = "FileSystem.DirIO" + +testCorrectness + :: [FilePath] -> Stream.Stream IO Word8 -> Expectation +testCorrectness expectation lister = do + reality <- + Stream.fold Fold.toList + $ StreamK.toStream + $ StreamK.sortBy compare + $ StreamK.fromStream + $ Unicode.lines Fold.toList + $ Unicode.decodeUtf8 lister + reality `shouldBe` expectation + +#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) +testCorrectnessByteChunked + :: [FilePath] -> Stream.Stream IO (Array Word8) -> Expectation +testCorrectnessByteChunked expectation lister = do + reality <- + Stream.fold Fold.toList + $ StreamK.toStream + $ StreamK.sortBy compare + $ StreamK.fromStream + $ Unicode.lines Fold.toList + $ Unicode.decodeUtf8Chunks lister + reality `shouldBe` expectation +#endif + +testSymLinkFollow :: Spec +testSymLinkFollow = do + let fp = "benchmark-tmp/dir-structure-small-sym" + -- We create and use a different directory tree here for these tests because + -- of convinence. + pathsUnsorted <- runIO $ createDirStucture fp 2 3 + paths <- + runIO + $ Stream.fold Fold.toList + $ StreamK.toStream + $ StreamK.sortBy compare + $ StreamK.fromStream $ Stream.fromList pathsUnsorted + runIO $ do + createDirectoryLink "./dir_1" (fp ++ "/sym-link-1") + createDirectoryLink "./dir_1/dir_2" (fp ++ "/sym-link-2") + createDirectoryLink "./broken_link" (fp ++ "/sym-link-3") + let answerFollowSym = + (fp ++ "/sym-link-1") + : (fp ++ "/sym-link-1/dir_1") + : (fp ++ "/sym-link-1/dir_2") + : (fp ++ "/sym-link-1/dir_3") + : (fp ++ "/sym-link-2") + : paths + answerNoFollowSym = + (fp ++ "/sym-link-1") + : (fp ++ "/sym-link-2") + : (fp ++ "/sym-link-3") + : paths + sortedAnswerFollowSym <- + Stream.fold Fold.toList + $ StreamK.toStream + $ StreamK.sortBy compare + $ StreamK.fromStream $ Stream.fromList answerFollowSym + sortedAnswerNoFollowSym <- + Stream.fold Fold.toList + $ StreamK.toStream + $ StreamK.sortBy compare + $ StreamK.fromStream $ Stream.fromList answerNoFollowSym + describe "Symlink" $ do + it "followSymlinks True" $ + testCorrectness + sortedAnswerFollowSym + (listDirUnfoldDfs + ( Dir.followSymlinks True + . Dir.ignoreMissing True + . Dir.ignoreInaccessible False + . Dir.ignoreSymlinkLoops False + ) + fp) + it "followSymlinks False" $ + testCorrectness + sortedAnswerNoFollowSym + (listDirUnfoldDfs + ( Dir.followSymlinks False + . Dir.ignoreMissing True + . Dir.ignoreInaccessible False + . Dir.ignoreSymlinkLoops False + ) + fp) + +-- | List the current directory recursively +main :: IO () +main = do + setLocaleEncoding utf8 + + let smallTree = "benchmark-tmp/dir-structure-small" + bigTree = "benchmark-tmp/dir-structure-big" + pathsSmallUnsorted <- createDirStucture smallTree 2 3 + pathsBigUnsorted <- createDirStucture bigTree 5 5 + + pathsSmall <- + Stream.fold Fold.toList + $ StreamK.toStream + $ StreamK.sortBy compare + $ StreamK.fromStream $ Stream.fromList pathsSmallUnsorted + pathsBig <- + Stream.fold Fold.toList + $ StreamK.toStream + $ StreamK.sortBy compare + $ StreamK.fromStream $ Stream.fromList pathsBigUnsorted + + hspec $ + describe moduleName $ do + describe "Sanity" $ do +#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) + it "listDirByteChunked" $ + testCorrectnessByteChunked + (tail pathsBig) (listDirByteChunked bigTree) +#endif + -- NOTE: The BFS traversal fails with: + -- openDirStream: resource exhausted (Too many open files) + -- if a bigger directory tree is used + it "listDirUnfoldDfs" $ + testCorrectness pathsBig (listDirUnfoldDfs id bigTree) + it "listDirUnfoldBfs" $ + testCorrectness pathsSmall (listDirUnfoldBfs id smallTree) + it "listDirUnfoldBfsRev" $ + testCorrectness pathsSmall (listDirUnfoldBfsRev id smallTree) + it "listDirConcatDfs" $ + testCorrectness pathsBig (listDirConcatDfs id bigTree) + it "listDirConcatBfs" $ + testCorrectness pathsSmall (listDirConcatBfs id smallTree) + it "listDirConcatBfsRev" $ + testCorrectness pathsSmall (listDirConcatBfsRev id smallTree) + it "listDirAppend" $ + testCorrectness pathsBig (listDirAppend id bigTree) + it "listDirInterleave" $ + testCorrectness pathsBig (listDirInterleave id bigTree) + it "listDirPar" $ + testCorrectness pathsBig (listDirPar id bigTree) + it "listDirParInterleaved" $ + testCorrectness pathsBig (listDirParInterleaved id bigTree) + it "listDirParOrdered" $ + testCorrectness pathsBig (listDirParOrdered id bigTree) + it "listDirChunkDfs" $ + testCorrectness pathsBig (listDirChunkDfs id bigTree) + it "listDirChunkBfs" $ + testCorrectness pathsSmall (listDirChunkBfs id smallTree) + it "listDirChunkBfsRev" $ + testCorrectness pathsSmall (listDirChunkBfsRev id smallTree) + it "listDirChunkAppend" $ + testCorrectness pathsBig (listDirChunkAppend id bigTree) + it "listDirChunkInterleave" $ + testCorrectness pathsBig (listDirChunkInterleave id bigTree) + it "listDirChunkPar" $ + testCorrectness pathsBig (listDirChunkPar id bigTree) + it "listDirChunkParInterleaved" $ + testCorrectness pathsBig (listDirChunkParInterleaved id bigTree) + it "listDirChunkParOrdered" $ + testCorrectness pathsBig (listDirChunkParOrdered id bigTree) + testSymLinkFollow diff --git a/test/Streamly/Test/FileSystem/Event.hs b/test/Streamly/Test/FileSystem/Event.hs --- a/test/Streamly/Test/FileSystem/Event.hs +++ b/test/Streamly/Test/FileSystem/Event.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-deprecations #-} + -- | -- Module : Streamly.Test.FileSystem.Event -- Copyright : (c) 2021 Composewell Technologies diff --git a/test/Streamly/Test/FileSystem/Event/Common.hs b/test/Streamly/Test/FileSystem/Event/Common.hs --- a/test/Streamly/Test/FileSystem/Event/Common.hs +++ b/test/Streamly/Test/FileSystem/Event/Common.hs @@ -53,6 +53,8 @@ ( createDirectory , createDirectoryIfMissing , createDirectoryLink + , doesDirectoryExist + , doesFileExist , removeFile , removePathForcibly , renameDirectory @@ -67,7 +69,7 @@ import qualified Data.List.NonEmpty as NonEmpty import qualified Streamly.Internal.Data.Array as Array import qualified Streamly.Internal.Data.Stream as Stream -import qualified Streamly.Internal.Data.Stream.Concurrent as Stream +import qualified Streamly.Internal.Data.Stream.Prelude as Stream import qualified Streamly.Unicode.Stream as Unicode #if defined(FILESYSTEM_EVENT_LINUX) @@ -173,11 +175,13 @@ openFile root WriteMode >>= hClose return root SymLinkResolvedPath -> do + -- root -> target let tgt = fp "watch-root-real" createDirectory tgt createDirectoryLink tgt root return tgt SymLinkOrigPath -> do + -- root -> target let tgt = fp "watch-root-real" createDirectory tgt createDirectoryLink tgt root @@ -189,7 +193,11 @@ startWatchAndCheck root target sync startWatchAndCheck root target sync = do + putStrLn ("Before pre op: root [" <> root + <> "] target [" <> target <> "]") pre root + putStrLn ("After pre op: root [" <> root + <> "] target [" <> target <> "]") -- XXX On macOS the events from pre ops also seem to be bundled -- with the events occurred after the watch is started. let check = checker root target sync expected @@ -202,9 +210,11 @@ -- not ensure that the event watcher has actually started. So we need a -- delay as well. Do we? takeMVar sync >> threadDelay 200000 + putStrLn ("Before fs ops: root [" <> fp) ops fp + putStrLn ("After fs ops: root [" <> fp) threadDelay 10000000 - error "Time out occurred before event watcher could terminate" + error $ fp <> ": Time out occurred before event watcher could terminate" ------------------------------------------------------------------------------- -- Test descriptions @@ -233,7 +243,7 @@ createParent :: FilePath -> FilePath -> IO () createParent file parent = do - createDirectoryIfMissing True (parent takeDirectory file) + createDirectoryIfMissing True (takeDirectory (parent file)) createDirWithParent :: FilePath -> FilePath -> IO () createDirWithParent dir parent = @@ -301,9 +311,25 @@ createFileWithParent :: FilePath -> FilePath -> IO () createFileWithParent file parent = do - when (not (null file)) $ - createDirectoryIfMissing True (parent takeDirectory file) - openFile (parent file) WriteMode >>= hClose + let filepath = parent file + let dir = takeDirectory filepath + putStrLn $ "createFileWithParent: file [" + ++ file ++ "] dir [" ++ dir ++ "]" + putStrLn $ "Ensuring dir: " ++ dir + createDirectoryIfMissing True dir + r <- doesDirectoryExist dir + if r + then do + putStrLn $ "Ensured dir: " ++ dir + when (not (null file)) $ do + exists <- doesFileExist filepath + if not exists + then do + putStrLn $ "Creating file: " ++ (parent file) + openFile (parent file) WriteMode >>= hClose + putStrLn $ "Created file: " ++ (parent file) + else error $ "File exists: " ++ filepath + else error $ "Could not create dir: " ++ dir createFile :: FilePath -> FilePath -> IO () createFile file parent = diff --git a/test/Streamly/Test/FileSystem/Event/Darwin.hs b/test/Streamly/Test/FileSystem/Event/Darwin.hs --- a/test/Streamly/Test/FileSystem/Event/Darwin.hs +++ b/test/Streamly/Test/FileSystem/Event/Darwin.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-deprecations #-} + -- | -- Module : Streamly.Test.FileSystem.Event.Darwin -- Copyright : (c) 2020 Composewell Technologies diff --git a/test/Streamly/Test/FileSystem/Event/Linux.hs b/test/Streamly/Test/FileSystem/Event/Linux.hs --- a/test/Streamly/Test/FileSystem/Event/Linux.hs +++ b/test/Streamly/Test/FileSystem/Event/Linux.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-deprecations #-} + -- | -- Module : Streamly.Test.FileSystem.Event.Linux -- Copyright : (c) 2020 Composewell Technologies @@ -9,10 +11,16 @@ module Streamly.Test.FileSystem.Event.Linux (main) where import Streamly.Internal.FileSystem.Event.Linux (Event) +-- #if __GLASGOW_HASKELL__ == 902 +#if 0 +import qualified Data.List as List +#endif import qualified Streamly.Internal.FileSystem.Event.Linux as Event import Streamly.Test.FileSystem.Event.Common +#define DEVBUILD + moduleName :: String moduleName = "FileSystem.Event.Linux" @@ -92,18 +100,39 @@ : regSymTests let symTests = - -- when root is a symlinked dir, it does not recv touch, isDeleted - -- or rootDeleted, rootUnwatched events. +#if 0 + -- No events occur when a symlink root is moved. when root is a + -- symlinked dir, it does not recv touch, isDeleted or + -- rootDeleted, rootUnwatched events. We are not seeing + -- isAttrModified event as well, so disabling this altogether. dirDelete "" (\dir -> [(dir, dirEvent Event.isAttrsModified)]) - -- No events occur when a symlink root is moved - : regSymTests + : +#endif + regSymTests let w = Event.watchWith (Event.setAllEvents True) run = runTests moduleName "non-recursive" w - run DirType regTests - run SymLinkOrigPath symTests +#if 0 + let failingTests = + [ "File deleted (file1)" + , "File modified (file1)" + , "File moved (file1 file2)" + ] +#endif + run DirType +#if 0 + $ filter (\(desc, _, _, _) -> desc `List.notElem` failingTests) +#endif + regTests + + run SymLinkOrigPath +#if 0 + $ filter (\(desc, _, _, _) -> desc `List.notElem` failingTests) +#endif + symTests + let fileRootTests = [ fileDelete "" (\path -> [ (path, Event.isAttrsModified) @@ -157,7 +186,25 @@ -- uncaught exception: IOException of type ResourceBusy -- /tmp/fsevent_dir-a5bd0df64c44ab27/watch-root/file: openFile: resource busy (file is locked) - runRec DirType recRegTests - runRec SymLinkOrigPath recSymTests +#if 0 + let failingRecTests = failingTests ++ + [ "File created (subdir/file)" + , "File deleted (subdir/file1)" + , "File modified (subdir/file1)" + , "File moved (subdir/file1 subdir/file2)" + ] +#endif + + runRec DirType +#if 0 + $ filter (\(desc, _, _, _) -> desc `List.notElem` failingRecTests) +#endif + recRegTests + + runRec SymLinkOrigPath +#if 0 + $ filter (\(desc, _, _, _) -> desc `List.notElem` failingRecTests) +#endif + recSymTests #endif runRec FileType fileRootTests diff --git a/test/Streamly/Test/FileSystem/Event/Windows.hs b/test/Streamly/Test/FileSystem/Event/Windows.hs --- a/test/Streamly/Test/FileSystem/Event/Windows.hs +++ b/test/Streamly/Test/FileSystem/Event/Windows.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-deprecations #-} + -- | -- Module : Streamly.Test.FileSystem.Event.Windows -- Copyright : (c) 2020 Composewell Technologies diff --git a/test/Streamly/Test/FileSystem/Handle.hs b/test/Streamly/Test/FileSystem/Handle.hs --- a/test/Streamly/Test/FileSystem/Handle.hs +++ b/test/Streamly/Test/FileSystem/Handle.hs @@ -20,21 +20,32 @@ , hClose , hFlush , hSeek - , openFile + , hPutStr ) import System.IO.Temp (withSystemTempDirectory) +#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) +import Streamly.Internal.FileSystem.Posix.File (openFile, withFile) +#else +import Streamly.Internal.FileSystem.Windows.File (openFile, withFile) +#endif import Test.QuickCheck (Property, forAll, Gen, vectorOf, choose) import Test.QuickCheck.Monadic (monadicIO, assert, run) +import Streamly.Internal.FileSystem.Path (Path) import qualified Streamly.Data.Fold as Fold import qualified Streamly.Internal.FileSystem.Handle as Handle import qualified Streamly.Internal.Data.Stream as Stream import qualified Streamly.Internal.Data.Array as Array import qualified Streamly.Internal.Unicode.Stream as Unicode +import qualified Streamly.Internal.FileSystem.Path as Path +import Prelude hiding (writeFile) import Test.Hspec as H import Test.Hspec.QuickCheck +writeFile :: Path -> String -> IO () +writeFile fpath val = withFile fpath WriteMode (`hPutStr` val) + maxArrLen :: Int maxArrLen = defaultChunkSize * 8 @@ -63,7 +74,7 @@ executor :: (Handle -> Stream IO Char) -> IO (Stream IO Char) executor f = withSystemTempDirectory "fs_handle" $ \fp -> do - let fpath = fp "tmp_read.txt" + fpath <- Path.fromString $ fp "tmp_read.txt" writeFile fpath testDataLarge h <- openFile fpath ReadMode return $ f h @@ -75,7 +86,7 @@ readWithBufferFromHandle :: IO (Stream IO Char) readWithBufferFromHandle = - let f1 = (\h -> (1024, h)) + let f1 h = (1024, h) f2 = Unicode.decodeUtf8 . Stream.unfold Handle.readerWith . f1 in executor f2 @@ -88,7 +99,7 @@ readChunksWithBuffer :: IO (Stream IO Char) readChunksWithBuffer = - let f1 = (\h -> (1024, h)) + let f1 h = (1024, h) f2 = Unicode.decodeUtf8 . Stream.concatMap Array.read @@ -115,7 +126,7 @@ go list = withSystemTempDirectory "fs_handle" $ \fp -> do - let fpathWrite = fp "tmp_write.txt" + fpathWrite <- Path.fromString $ fp "tmp_write.txt" writeFile fpathWrite "" h <- openFile fpathWrite ReadWriteMode hSeek h AbsoluteSeek 0 @@ -136,8 +147,8 @@ go = withSystemTempDirectory "fs_handle" $ \fp -> do - let fpathRead = fp "tmp_read.txt" - fpathWrite = fp "tmp_write.txt" + fpathRead <- Path.fromString $ fp "tmp_read.txt" + fpathWrite <- Path.fromString $ fp "tmp_write.txt" writeFile fpathRead testDataLarge writeFile fpathWrite "" hr <- openFile fpathRead ReadMode @@ -158,7 +169,7 @@ go = withSystemTempDirectory "fs_handle" $ \fp -> do - let fpathRead = fp "tmp_read.txt" + fpathRead <- Path.fromString $ fp "tmp_read.txt" writeFile fpathRead testBinData h <- openFile fpathRead ReadMode ls <- diff --git a/test/Streamly/Test/Network/Inet/TCP.hs b/test/Streamly/Test/Network/Inet/TCP.hs --- a/test/Streamly/Test/Network/Inet/TCP.hs +++ b/test/Streamly/Test/Network/Inet/TCP.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -Wno-deprecations #-} -- | -- Module : Streamly.Test.Network.Socket @@ -113,7 +112,7 @@ validateOnPort = monadicIO $ do res <- run $ do ls2 <- - execute TCP.acceptorOnPort basePort defaultChunkSize handlerRW + execute TCP.acceptor basePort defaultChunkSize handlerRW let dataChunk = take defaultChunkSize testDataSource Stream.eqBy (==) (Stream.fromList dataChunk) ls2 assert res @@ -123,7 +122,7 @@ res <- run $ do ls2 <- execute - TCP.acceptorOnPortLocal + TCP.acceptorLocal (basePort + 1) defaultChunkSize handlerRW diff --git a/test/Streamly/Test/Network/Socket.hs b/test/Streamly/Test/Network/Socket.hs --- a/test/Streamly/Test/Network/Socket.hs +++ b/test/Streamly/Test/Network/Socket.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -Wno-deprecations #-} -- | -- Module : Streamly.Test.Network.Socket @@ -87,7 +86,7 @@ server :: PortNumber -> MVar () -> (Socket -> IO ()) -> IO () server port sem handler = do putMVar sem () - Stream.unfold TCP.acceptorOnPort port + Stream.unfold TCP.acceptor port & Stream.mapM (Socket.forSocketM handler) & Stream.fold Fold.drain diff --git a/test/Streamly/Test/Prelude/Concurrent.hs b/test/Streamly/Test/Prelude/Concurrent.hs --- a/test/Streamly/Test/Prelude/Concurrent.hs +++ b/test/Streamly/Test/Prelude/Concurrent.hs @@ -490,10 +490,13 @@ replicate 2000 $ S.fromEffect $ threadDelay 1000000) `shouldReturn` () +-- Hanging on macOS CI +#ifdef DEVBUILD it "aheadly crosses thread limit (4000 threads)" $ S.drain (fromAhead $ fold $ replicate 4000 $ S.fromEffect $ threadDelay 1000000) `shouldReturn` () +#endif #ifdef DEVBUILD describe "restricts concurrency and cleans up extra tasks" $ do diff --git a/test/Streamly/Test/Prelude/Serial.hs b/test/Streamly/Test/Prelude/Serial.hs --- a/test/Streamly/Test/Prelude/Serial.hs +++ b/test/Streamly/Test/Prelude/Serial.hs @@ -1,5 +1,9 @@ {-# OPTIONS_GHC -Wno-deprecations #-} {-# Language TypeApplications #-} +-- XXX We are using head/tail at one place +#if __GLASGOW_HASKELL__ >= 908 +{-# OPTIONS_GHC -Wno-x-partial #-} +#endif -- | -- Module : Streamly.Test.Prelude.Serial @@ -21,8 +25,7 @@ import Data.Maybe ( isJust, fromJust ) import Data.Word (Word8) import Data.Semigroup (Sum(..), getSum) -import Foreign.Storable (Storable) -import Streamly.Internal.Data.Unboxed (Unbox) +import Streamly.Internal.Data.MutByteArray (Unbox) import Test.Hspec.QuickCheck import Test.QuickCheck ( Gen @@ -49,7 +52,7 @@ import qualified Streamly.Internal.Data.Fold as FL import qualified Streamly.Internal.Data.Unfold as UF import qualified Streamly.Internal.Data.Stream as IS -import qualified Streamly.Internal.Data.Stream.StreamK as K +import qualified Streamly.Internal.Data.StreamK as K import qualified Streamly.Data.Array as A import qualified Streamly.Internal.Data.Parser as Parser import qualified Streamly.Prelude as SP @@ -76,11 +79,11 @@ (a -> Bool) -> FL.Fold m a b -> S.Stream m a -> S.Stream m b splitOnSuffix predicate f = S.foldMany (FL.takeEndBy_ predicate f) -splitOnSeq' :: (MonadIO m, Unbox a, Storable a, Enum a, Eq a) => +splitOnSeq' :: (MonadIO m, Unbox a, Enum a, Eq a) => A.Array a -> FL.Fold m a b -> S.Stream m a -> S.Stream m b splitOnSeq' patt f m = IS.foldManyPost (FL.takeEndBySeq_ patt f) m -splitOnSuffixSeq' :: (MonadIO m, Unbox a, Storable a, Enum a, Eq a) => +splitOnSuffixSeq' :: (MonadIO m, Unbox a, Enum a, Eq a) => A.Array a -> FL.Fold m a b -> S.Stream m a -> S.Stream m b splitOnSuffixSeq' patt f m = S.foldMany (FL.takeEndBySeq_ patt f) m @@ -150,7 +153,7 @@ splitOnSuffixSeq' (A.fromList pat) FL.toList (S.fromList xs) splitterProperties :: - forall a. (Arbitrary a, Eq a, Show a, Storable a, Unbox a, Enum a) + forall a. (Arbitrary a, Eq a, Show a, Unbox a, Enum a) => a -> String -> Spec @@ -217,17 +220,17 @@ where - splitOnSeq_ xs ys = - toList $ splitOnSeq' (A.fromList ys) FL.toList (S.fromList xs) + splitOnSeq_ xs pat = + toList $ splitOnSeq' (A.fromList pat) FL.toList (S.fromList xs) - splitOnSuffixSeq_ xs ys = - toList $ splitOnSuffixSeq' (A.fromList ys) FL.toList (S.fromList xs) + splitOnSuffixSeq_ xs pat = + toList $ splitOnSuffixSeq' (A.fromList pat) FL.toList (S.fromList xs) - splitOn_ xs ys = - toList $ splitOn (== (head ys)) FL.toList (S.fromList xs) + splitOn_ xs pat = + toList $ splitOn (== (head pat)) FL.toList (S.fromList xs) - splitOnSuffix_ xs ys = - toList $ splitOnSuffix (== (head ys)) FL.toList (S.fromList xs) + splitOnSuffix_ xs pat = + toList $ splitOnSuffix (== (head pat)) FL.toList (S.fromList xs) intercalateSuffix xs yss = intercalate xs yss ++ xs @@ -474,7 +477,7 @@ testTakeInterval = do r <- S.fold (FL.tee FL.head FL.last) - $ S.takeInterval (toRelTime64 takeDropTime) + $ S.takeInterval (fromIntegral takeDropTime * 10**(-9)) $ S.repeatM (threadDelay 1000 >> getTime Monotonic) checkTakeDropTime r @@ -483,7 +486,7 @@ t0 <- getTime Monotonic mt1 <- S.fold FL.head - $ S.dropInterval (toRelTime64 takeDropTime) + $ S.dropInterval (fromIntegral takeDropTime * 10**(-9)) $ S.repeatM (threadDelay 1000 >> getTime Monotonic) checkTakeDropTime (Just t0, mt1) #endif diff --git a/test/Streamly/Test/Prelude/Top.hs b/test/Streamly/Test/Prelude/Top.hs --- a/test/Streamly/Test/Prelude/Top.hs +++ b/test/Streamly/Test/Prelude/Top.hs @@ -14,7 +14,7 @@ ) import Test.QuickCheck.Monadic (monadicIO, assert, run) import qualified Streamly.Prelude as S -import qualified Streamly.Internal.Data.Stream.IsStream.Top as Top +import qualified Streamly.Internal.Data.Stream.IsStream as Top import Prelude hiding (maximum, minimum, elem, notElem, null, product, sum, head, last, take) diff --git a/test/Streamly/Test/Prelude/WAsync.hs b/test/Streamly/Test/Prelude/WAsync.hs --- a/test/Streamly/Test/Prelude/WAsync.hs +++ b/test/Streamly/Test/Prelude/WAsync.hs @@ -145,7 +145,7 @@ describe "Stream transform and combine operations" $ do wAsyncOps $ transformCombineOpsCommon S.fromFoldable "wAsyncly" sortEq - wAsyncOps $ transformCombineOpsCommon folded "wAsyncly" sortEq + wAsyncOps $ transformCombineOpsCommon folded "wAsyncly folded" sortEq describe "Stream elimination operations" $ do wAsyncOps $ eliminationOps S.fromFoldable "wAsyncly" diff --git a/test/Streamly/Test/Serialize/Serializable.hs b/test/Streamly/Test/Serialize/Serializable.hs --- a/test/Streamly/Test/Serialize/Serializable.hs +++ b/test/Streamly/Test/Serialize/Serializable.hs @@ -10,8 +10,8 @@ ) import Test.QuickCheck.Monadic (monadicIO) -import qualified Streamly.Internal.Serialize.FromBytes as Decoder -import qualified Streamly.Internal.Serialize.ToBytes as Encoder +import qualified Streamly.Internal.Data.Binary.Parser as Decoder +import qualified Streamly.Internal.Data.Binary.Stream as Encoder import qualified Streamly.Data.Stream as Stream import Streamly.Internal.Data.Parser (Parser) diff --git a/test/Streamly/Test/Unicode/Char.hs b/test/Streamly/Test/Unicode/Char.hs --- a/test/Streamly/Test/Unicode/Char.hs +++ b/test/Streamly/Test/Unicode/Char.hs @@ -54,7 +54,7 @@ checkOp :: String -> NormalizationMode -> [(Text, Text)] -> IO Bool checkOp name op pairs = do res <- mapM (checkEqual name (normalize op)) pairs - return $ all (== True) res + return $ and res checkNFC :: (Text, Text, Text, Text, Text) -> IO Bool checkNFC (c1, c2, c3, c4, c5) = @@ -72,7 +72,7 @@ checkNFKD (c1, c2, c3, c4, c5) = checkOp "toNFKD" NFKD $ map (c5,) [c1, c2, c3, c4, c5] -splitOn predicate f = S.foldManyPost (FL.takeEndBy_ predicate f) +splitOn predicate f = S.foldMany1 (FL.takeEndBy_ predicate f) checkAllTestCases :: Int -> String -> IO () checkAllTestCases lineno line = do diff --git a/test/Streamly/Test/Unicode/Parser.hs b/test/Streamly/Test/Unicode/Parser.hs new file mode 100644 --- /dev/null +++ b/test/Streamly/Test/Unicode/Parser.hs @@ -0,0 +1,231 @@ +{-# OPTIONS_GHC -Wno-deprecations #-} + +module Streamly.Test.Unicode.Parser + (main) +where + +import Control.Monad.Identity (Identity(runIdentity)) +import Debug.Trace (trace) +import Streamly.Internal.Data.Parser (ParseError (..), Parser) +import Streamly.Test.Common (chooseDouble) +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck + (forAll, Property, property) +import Test.QuickCheck.Monadic (monadicIO, assert, run) + +import qualified Data.Scientific as Scientific +import qualified Streamly.Data.Stream as Stream +import qualified Streamly.Unicode.Parser as Unicode +import qualified Streamly.Internal.Unicode.Parser as Parser +import qualified Test.Hspec as H + +-- Scientific notation +scientificExpFP :: Property +scientificExpFP = + forAll (chooseDouble (-99.99e-12, 1234.4567e+234)) $ \ls -> + case runIdentity $ Stream.parse parser (Stream.fromList (show ls)) of + Right val -> val `H.shouldBe` read (show ls) + Left _ -> error "Parsing failed." + + where + + toScientific (c, m) = Scientific.scientific c m + parser = toScientific <$> Parser.number + +-- Standard decimal notation. +scientificFixFP :: Property +scientificFixFP = + forAll (chooseDouble (-0.00099, 123445.67998)) $ \ls -> + case runIdentity $ Stream.parse parser (Stream.fromList (show ls)) of + Right val -> val `H.shouldBe` read (show ls) + Left _ -> error "Parsing failed." + + where + + toScientific (c, m) = Scientific.scientific c m + parser = toScientific <$> Parser.number + +doubleExpFP :: Property +doubleExpFP = + forAll (chooseDouble (-99.99e-12, 1234.4567e+234)) $ \ls -> do + let sls = show ls + case runIdentity $ Stream.parse Parser.double (Stream.fromList sls) of + Right val -> if val == ls + then property (val == ls) + else trace + ("Read = "++ show (read sls :: Double) ++ " Expected = " ++ sls ++ " Got = " ++ show val) + property (val == ls) + Left _ -> property False + +-- Standard decimal notation. +doubleFixFP :: Property +doubleFixFP = + forAll (chooseDouble (-0.00099, 123445.67998)) $ \ls -> + case runIdentity $ Stream.parse Parser.double (Stream.fromList (show ls)) of + Right val -> if val == ls + then property (val == ls) + else trace + ("Expected = " ++ show ls ++ " Got = " ++ show val) + property (val == ls) + Left _ -> property False + +doubleParser :: String -> IO (Either ParseError Double) +doubleParser = Stream.parse Unicode.double . Stream.fromList + +double :: String -> Double -> Property +double s d = monadicIO $ do + x <- run $ doubleParser s + case x of + Right val -> if val == d + then assert (val == d) + else trace ("Expected = " ++ show d ++ " Got = "++ show val) (assert (val == d)) + Left (ParseError _) -> assert False + +numberP :: Monad m => Parser Char m Double +numberP = uncurry Parser.mkDouble <$> Parser.number + +numberParser :: String -> IO (Either ParseError Double) +numberParser = Stream.parse numberP . Stream.fromList + +number :: String -> Double -> Property +number s d = monadicIO $ do + x <- run $ numberParser s + case x of + Right val -> if val == d + then assert (val == d) + else trace ("Expected = " ++ show d ++ " Got = "++ show val) (assert (val == d)) + Left (ParseError _) -> assert False + +doubleErr :: (String -> IO (Either ParseError Double)) -> String -> String -> Property +doubleErr f s msg = monadicIO $ do + x <- run $ f s + case x of + Right _ -> assert False + Left (ParseError err) -> + if err == msg + then assert (err == msg) + else trace err (assert (err == msg)) + +remainingStreamDouble :: String -> [String] +remainingStreamDouble x = + let f = Stream.parseBreak Unicode.double . Stream.fromList + in concatMap (Stream.toList . snd) (f x) + +remainingStreamNumber :: String -> [String] +remainingStreamNumber x = + let f = Stream.parseBreak numberP . Stream.fromList + in concatMap (Stream.toList . snd) (f x) + +afterParse :: (String -> [String]) -> String -> String -> Property +afterParse f si so = monadicIO $ do + let x = f si + in assert (x == [so]) + +testParser :: String -> (String -> Double -> Property) -> H.SpecWith () +testParser desc f = do + -- XXX We can combine the parser tests and remaining stream tests in the + -- same test. + H.describe ("Unicode Parser " ++ desc) $ do + prop "double \"00.00\"" $ f "00.00" 0.0 + prop "double \"00.00e00\"" $ f "00.00e00" 0.0 + prop "double \"4\" 4.0" $ f "4" 4.0 + prop "double \"00.3\" 0.3" $ f "00.3" 0.3 + prop "double \"0.003\" 3.0e-3" $ f "0.003" 3.0e-3 + prop "double \"44.56.67\" 44.56" $ f "44.56.67" 44.56 + prop "double \"0.0.00\" 0.0" $ f "0.0.00" 0.0 + prop "double \"44.56-78\" 44.56" $ f "44.56-78" 44.56 + prop "double \"44-\" 44.0" $ f "44-" 44.0 + prop "double \"44-56\" 44.0" $ f "44-56" 44.0 + prop "double \"44+\" 44.0" $ f "44+" 44.0 + prop "double \"44+56\" 44.0" $ f "44+56" 44.0 + prop "double \"44u\" 44.0" $ f "44u" 44.0 + prop "double \"+123.345\" 123.345" $ f "+123.345" 123.345 + prop "double \"-123.345\" (-123.345)" $ f "-123.345" (-123.345) + prop "double \"1e\"" $ f "1e" 1.0 + prop "double \"1e+\"" $ f "1e+" 1.0 + prop "double \"1ex\"" $ f "1ex" 1.0 + prop "double \"1e+x\"" $ f "1e+x" 1.0 + prop "double \"1e+0\"" $ f "1e+0" 1.0 + prop "double \"1e-0\"" $ f "1e-0" 1.0 + prop "double \"1.0e-1\"" $ f "1.0e-1" 0.1 + prop "double \"1.0e+1\"" $ f "1.0e+1" 10.0 + prop "double \"1.0e1\"" $ f "1.0e1" 10.0 + prop "double \"1.0e+309\"" $ f "1.0e+309" 1.0e309 + prop "double \"1.0e-309\"" $ f "1.0e-309" 1.0e-309 + prop "double \"1.0e1.\"" $ f "1.0e1." 10.0 + prop "double \"1.0e1+\"" $ f "1.0e1+" 10.0 + prop "double \"1.0e1-\"" $ f "1.0e1-" 10.0 + prop "double \"1.0e1e\"" $ f "1.0e1e" 10.0 + prop "double \"1.0E+1\"" $ f "1.0E+1" 10.0 + prop "double \"9223372036854775806\"" $ f "9223372036854775806" 9.223372036854776e18 + -- maxBound :: Int + prop "double \"9223372036854775807\"" $ f "9223372036854775807" 9.223372036854776e18 + prop "double \"9223372036854775808\"" $ f "9223372036854775808" 9.223372036854776e18 + +testParseErr :: String -> (String -> IO (Either ParseError Double)) -> H.SpecWith () +testParseErr desc f = do + H.describe ("Unicode Parser Error " ++ desc) $ do + prop "double \"\" Error" + $ doubleErr f "" "number: expecting sign or decimal digit, got end of input" + prop "double \"a\" Error" + $ doubleErr f "a" "number: expecting sign or decimal digit, got 'a'" + prop "double \".4\" Error" + $ doubleErr f ".4" "number: expecting sign or decimal digit, got '.'" + prop "double \".\" Error" + $ doubleErr f "." "number: expecting sign or decimal digit, got '.'" + prop "double \"..\" Error" + $ doubleErr f ".." "number: expecting sign or decimal digit, got '.'" + prop "double \"-\" Error" + $ doubleErr f "-" "number: expecting decimal digit, got end of input" + prop "double \"+\" Error" + $ doubleErr f "+" "number: expecting decimal digit, got end of input" + prop "double \"++\" Error" + $ doubleErr f "++" "number: expecting decimal digit, got '+'" + +testLeftOver :: String -> (String -> [String]) -> H.SpecWith () +testLeftOver desc f = do + H.describe ("Unicode Parser leftover " ++ desc) $ do + prop "afterParse \"4.\" \".\"" $ afterParse f "4." "." + prop "afterParse \"4..\" \"..\"" $ afterParse f "4.." ".." + prop "afterParse \"4-\" \"-\"" $ afterParse f "4-" "-" + prop "afterParse \"4--\" \"--\"" $ afterParse f "4--" "--" + prop "afterParse \"4.9abc\" \"abc\"" $ afterParse f "4.9abc" "abc" + prop "afterParse \"4.9ex\"" $ afterParse f "4.9ex" "ex" + prop "afterParse \"4.9e+x\"" $ afterParse f "4.9e+x" "e+x" + prop "afterParse \"4.9\" \"\"" $ afterParse f "4.9" "" + prop "afterParse \"+4.9\" \"\"" $ afterParse f "+4.9" "" + prop "afterParse \"-4.9\" \"\"" $ afterParse f "-4.9" "" + prop "afterParse \"4.9.\" \".\"" $ afterParse f "4.9." "." + prop "afterParse \"4.9..\" \"..\"" $ afterParse f "4.9.." ".." + prop "afterParse \"4.9...\" \"...\"" $ afterParse f "4.9..." "..." + prop "afterParse \"4.9+\" \"+\"" $ afterParse f "4.9+" "+" + prop "afterParse \"4.9++\" \"++\"" $ afterParse f "4.9++" "++" + prop "afterParse \"4.9+++\" \"+++\"" $ afterParse f "4.9+++" "+++" + prop "afterParse \"4.9-\" \"-\"" $ afterParse f "4.9-" "-" + prop "afterParse \"4.9--\" \"--\"" $ afterParse f "4.9--" "--" + prop "afterParse \"4.9---\" \"---\"" $ afterParse f "4.9---" "---" + prop "afterParse \"\" \"\"" $ afterParse f "" "" + prop "afterParse \".\" \".\"" $ afterParse f "." "." + prop "afterParse \"..\" \"..\"" $ afterParse f ".." ".." + prop "afterParse \"+\" \"+\"" $ afterParse f "+" "+" + prop "afterParse \"++\" \"++\"" $ afterParse f "++" "++" + +moduleName :: String +moduleName = "Unicode.Parser" + +main :: IO () +main = do + H.hspec + $ H.describe moduleName $ do + testParser "double" double + testParser "number" number + testParseErr "double" doubleParser + testParseErr "number" numberParser + testLeftOver "double" remainingStreamDouble + testLeftOver "number" remainingStreamNumber + H.describe "Scientific parser property test" $ do + prop "Exponent format" scientificExpFP + prop "Decimal format" scientificFixFP + H.describe "double parser property test" $ do + prop "Exponent format" doubleExpFP + prop "Decimal format" doubleFixFP diff --git a/test/Streamly/Test/Unicode/Stream.hs b/test/Streamly/Test/Unicode/Stream.hs --- a/test/Streamly/Test/Unicode/Stream.hs +++ b/test/Streamly/Test/Unicode/Stream.hs @@ -2,8 +2,9 @@ module Streamly.Test.Unicode.Stream (main) where +import Control.Monad (when) import Data.Char (ord, chr) -import Data.Word (Word8) +import Data.Word (Word8, Word16) import Test.QuickCheck ( Property , forAll @@ -16,12 +17,14 @@ , vectorOf , choose ) -import Test.QuickCheck.Monadic (run, monadicIO, assert) +import Test.QuickCheck.Monadic (run, monadicIO, assert, PropertyM) +import Streamly.Data.Stream (Stream) import qualified Streamly.Data.Array as A +import qualified Streamly.Internal.Data.Array as Array import qualified Streamly.Data.Stream as Stream -import qualified Streamly.Internal.Data.Stream.Chunked as AS -import qualified Streamly.Internal.Data.Stream.StreamD as Stream +import qualified Streamly.Internal.Data.Array.Stream as AS +import qualified Streamly.Internal.Data.Stream as Stream import qualified Streamly.Unicode.Stream as SS import qualified Streamly.Internal.Unicode.Stream as IUS import qualified Streamly.Internal.Unicode.Array as IUA @@ -39,13 +42,23 @@ #endif -} +assertEq :: (Eq a, Show a) => a -> a -> PropertyM IO () +assertEq a b = do + when (a /= b) $ run $ do + putStrLn $ "A: " ++ show a + putStrLn $ "B: " ++ show b + assert (a == b) + -- Use quickcheck-unicode instead? genUnicode :: Gen String genUnicode = listOf arbitraryUnicodeChar -genWord8 :: Gen [Word8] -genWord8 = listOf arbitrary +genWord8List :: Gen [Word8] +genWord8List = listOf arbitrary +genListOfW8List :: Gen [[Word8]] +genListOfW8List = listOf (listOf arbitrary) + propDecodeEncodeId' :: Property propDecodeEncodeId' = forAll genUnicode $ \list -> @@ -54,6 +67,33 @@ chrs <- run $ Stream.toList $ SS.decodeUtf8' wrds assert (chrs == list) +propDecodeEncodeUtf16Id + :: (Stream IO Char -> Stream IO Word16) + -> (Stream IO Word16 -> Stream IO Char) + -> Property +propDecodeEncodeUtf16Id encoder decoder = + forAll genUnicode $ \list -> + monadicIO $ do + let wrds = encoder $ Stream.fromList list + chrs <- run $ Stream.toList $ decoder wrds + assertEq chrs list + +propMkEvenW8Chunks :: Property +propMkEvenW8Chunks = + forAll genListOfW8List $ \list -> + monadicIO $ do + list1 <- + run $ Stream.toList + $ fmap A.toList + $ IUS.mkEvenW8Chunks + $ fmap A.fromList $ Stream.fromList list + let concatedList = concat list + concatedList1 = concat list1 + assert (and (map (even . length) list1)) + if (odd (length concatedList)) + then assertEq concatedList1 (init concatedList) + else assertEq concatedList1 concatedList + -- XXX need to use invalid characters propDecodeEncodeId :: Property propDecodeEncodeId = @@ -61,15 +101,15 @@ monadicIO $ do let wrds = SS.encodeUtf8 $ Stream.fromList list chrs <- Stream.toList $ SS.decodeUtf8 wrds - assert (chrs == list) + assertEq chrs list propDecodeEncodeIdArrays :: Property propDecodeEncodeIdArrays = forAll genUnicode $ \list -> monadicIO $ do - let wrds = Stream.chunksOf 8 $ SS.encodeUtf8' $ Stream.fromList list + let wrds = Array.chunksOf 8 $ SS.encodeUtf8' $ Stream.fromList list chrs <- Stream.toList $ IUS.decodeUtf8Chunks wrds - assert (chrs == list) + assertEq chrs list unicodeTestData :: [Char] unicodeTestData = "z\72150\83468;L$Wz| ?_i/J ." @@ -86,7 +126,7 @@ $ SS.encodeLatin1 $ Stream.fromList list lst <- run $ Stream.toList wrds - assert (list == lst) + assertEq list lst propUnicodeToLatin1 :: Property propUnicodeToLatin1 = @@ -96,7 +136,7 @@ $ SS.encodeLatin1 $ Stream.fromList unicodeTestData lst <- run $ Stream.toList wrds - assert (latin1TestData == lst) + assertEq latin1TestData lst propUnicodeToLatin1' :: Property propUnicodeToLatin1' = @@ -106,7 +146,7 @@ $ SS.encodeLatin1' $ Stream.fromList unicodeTestData lst <- run $ Stream.toList wrds - assert (latin1TestData == lst) + assertEq latin1TestData lst testLines :: Property testLines = @@ -116,17 +156,17 @@ $ fmap A.toList $ IUA.lines $ Stream.fromList list - assert (xs == lines list) + assertEq xs (lines list) testLinesArray :: Property testLinesArray = - forAll genWord8 $ \list -> + forAll genWord8List $ \list -> monadicIO $ do xs <- Stream.toList $ fmap A.toList $ AS.splitOnSuffix 10 $ Stream.fromPure (A.fromList list) - assert (xs == map (map (fromIntegral . ord)) + assertEq xs (map (map (fromIntegral . ord)) (lines (map (chr . fromIntegral) list))) testWords :: Property @@ -137,7 +177,7 @@ $ Stream.map A.toList $ IUA.words $ Stream.fromList list - assert (xs == words list) + assertEq xs (words list) testUnlines :: Property testUnlines = @@ -147,7 +187,7 @@ $ IUA.unlines $ IUA.lines $ Stream.fromList list - assert (xs == unlines (lines list)) + assertEq xs (unlines (lines list)) testUnwords :: Property testUnwords = @@ -158,7 +198,7 @@ $ IUA.unwords $ IUA.words $ Stream.fromList list - assert (xs == unwords (words list)) + assertEq xs (unwords (words list)) moduleName :: String moduleName = "Unicode.Stream" @@ -183,6 +223,13 @@ prop "Streamly.Data.String.unwords . Streamly.Data.String.words == unwords . words" testUnwords + + H.describe "UTF16 - Encoding / Decoding" $ do + prop "decodeUtf16le' . encodeUtf16le' == id" + (propDecodeEncodeUtf16Id IUS.encodeUtf16le' IUS.decodeUtf16le') + prop "decodeUtf16le . encodeUtf16le == id" + (propDecodeEncodeUtf16Id IUS.encodeUtf16le' IUS.decodeUtf16le) + prop "mkEvenW8Chunks" propMkEvenW8Chunks H.describe "Latin1 - Encoding / Decoding" $ do prop "ASCII to Latin1" propASCIIToLatin1 diff --git a/test/lib/Streamly/Test/Common.hs b/test/lib/Streamly/Test/Common.hs --- a/test/lib/Streamly/Test/Common.hs +++ b/test/lib/Streamly/Test/Common.hs @@ -12,14 +12,19 @@ , listEquals , checkListEqual , chooseInt + , chooseDouble + , performGCSweep ) where -import Control.Monad (when) +import Control.Monad (when, void, replicateM_) import Control.Monad.IO.Class (MonadIO(..)) import Data.List ((\\)) +import System.Mem (performMajorGC) import Test.QuickCheck (Property, Gen, choose, counterexample) import Test.QuickCheck.Monadic (PropertyM, assert, monitor, monadicIO) +import qualified Streamly.Internal.Data.MutArray as MA + equals :: (Show a, Monad m) => (a -> a -> Bool) -> a -> a -> PropertyM m () @@ -60,3 +65,13 @@ chooseInt :: (Int, Int) -> Gen Int chooseInt = choose + +chooseDouble :: (Double, Double) -> Gen Double +chooseDouble = choose + +-- XXX Move this to Streamly.Test.Array.Common? +performGCSweep :: Int -> Int -> IO () +performGCSweep i j = do + replicateM_ i $ do + performMajorGC + void $ MA.fromList ([0 .. j] :: [Int]) diff --git a/test/lib/Streamly/Test/Parser/Common.hs b/test/lib/Streamly/Test/Parser/Common.hs new file mode 100644 --- /dev/null +++ b/test/lib/Streamly/Test/Parser/Common.hs @@ -0,0 +1,178 @@ +module Streamly.Test.Parser.Common + ( Move(..) + , jumpParser + , chunkedTape + , tape + , tapeLen + , expectedResult + , expectedResultMany + , parserSanityTests + ) +where + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +import Streamly.Internal.Data.Parser (ParseErrorPos(..)) +import qualified Streamly.Internal.Data.Parser as P +import Test.Hspec + +-------------------------------------------------------------------------------- +-- Parser driver tests +-------------------------------------------------------------------------------- + +data Move + = Consume Int + | Custom (P.Step () ()) + deriving (Show) + +jumpParser :: Monad m => [Move] -> P.Parser Int m [Int] +jumpParser jumps = P.Parser step initial done + where + initial = pure $ P.IPartial (jumps, []) + + step ([], buf) _ = pure $ P.SDone 0 (reverse buf) + step (action:xs, buf) a = + case action of + Consume n + | n == 1 -> pure $ P.SContinue 1 (xs, a:buf) + | n > 0 -> pure $ P.SContinue 1 (Consume (n - 1) : xs, a:buf) + | otherwise -> error "Cannot consume <= 0" + Custom (P.SPartial i ()) -> pure $ P.SPartial i (xs, buf) + Custom (P.SContinue i ()) -> pure $ P.SContinue i (xs, buf) + Custom (P.SDone i ()) -> pure $ P.SDone i (reverse buf) + Custom (P.SError err) -> pure $ P.SError err + + done ([], buf) = pure $ P.FDone 0 (reverse buf) + done (action:xs, buf) = + case action of + Consume _ -> pure $ P.FError "INCOMPLETE" + Custom (P.SPartial i ()) -> pure $ P.FContinue i (xs, buf) + Custom (P.SContinue i ()) -> pure $ P.FContinue i (xs, buf) + Custom (P.SDone i ()) -> pure $ P.FDone i (reverse buf) + Custom (P.SError err) -> pure $ P.FError err + +chunkedTape :: [[Int]] +chunkedTape = Prelude.map (\x -> [x..(x+9)]) [1, 11 .. 91] + +tape :: [Int] +tape = concat chunkedTape + +tapeLen :: Int +tapeLen = length tape + +expectedResult :: [Move] -> [Int] -> (Either ParseErrorPos [Int], [Int]) +expectedResult moves inp = go 0 0 [] moves + where + inpLen = length inp + + slice off len = Prelude.take len . Prelude.drop off + slice_ = Prelude.drop + + -- i = Index of inp head + -- j = Minimum index of inp head + go i j ys [] = (Right ys, slice_ (max i j) inp) + go i j ys ((Consume n):xs) + | i + n > inpLen = (Left (ParseErrorPos inpLen "INCOMPLETE"), drop j inp) + | otherwise = + go (i + n) j (ys ++ slice i n inp) xs + go i j ys ((Custom step):xs) + | i > inpLen = error "i > inpLen" + | otherwise = + case step of + P.SPartial n () -> go (i + n) (max j (i + n)) ys xs + P.SContinue n () -> go (i + n) j ys xs + P.SDone n () -> (Right ys, slice_ (max (i + n) j) inp) + P.SError err -> (Left (ParseErrorPos (i + 1) err), slice_ j inp) + +expectedResultMany :: [Move] -> [Int] -> [Either ParseErrorPos [Int]] +expectedResultMany = go 0 + where + go _ _ [] = [] + go off moves inp = + let (res, rest) = expectedResult moves inp + consumed = length inp - length rest + in + case res of + Left (ParseErrorPos relOff err) -> + [Left (ParseErrorPos (off + relOff) err)] + Right val -> Right val : go (off + consumed) moves rest + +createPaths :: [a] -> [[a]] +createPaths xs = + Prelude.map (`Prelude.take` xs) [1..length xs] + +parserSanityTests :: String -> ([Move] -> SpecWith ()) -> SpecWith () +parserSanityTests desc testRunner = + describe desc $ do + Prelude.mapM_ testRunner $ + createPaths + [ Consume (tapeLen + 1) + ] + Prelude.mapM_ testRunner $ + createPaths + [ Custom (P.SError "Message0") + ] + Prelude.mapM_ testRunner $ + createPaths + [ Consume 10 + , Custom (P.SPartial 1 ()) + , Consume 10 + , Custom (P.SPartial 0 ()) + , Consume 10 + , Custom (P.SPartial (-10) ()) + , Consume 10 + , Custom (P.SContinue 1 ()) + , Consume 10 + , Custom (P.SContinue 0 ()) + , Consume 10 + , Custom (P.SContinue (-10) ()) + , Custom (P.SError "Message1") + ] + Prelude.mapM_ testRunner $ + createPaths + [ Consume 10 + , Custom (P.SContinue 1 ()) + , Consume 10 + , Custom (P.SContinue 0 ()) + , Consume 10 + , Custom (P.SContinue (-10) ()) + , Consume 10 + , Custom (P.SDone 1 ()) + ] + Prelude.mapM_ testRunner $ + createPaths + [ Consume 20 + , Custom (P.SContinue 1 ()) + , Custom (P.SContinue (-10) ()) + , Custom (P.SDone 0 ()) + ] + Prelude.mapM_ testRunner $ + createPaths + [ Consume 20 + , Custom (P.SContinue 1 ()) + , Custom (P.SContinue (-10) ()) + , Custom (P.SError "Message2") + ] + Prelude.mapM_ testRunner $ + createPaths + [ Consume 20 + , Custom (P.SContinue 1 ()) + , Custom (P.SContinue (-10) ()) + , Custom (P.SDone (-4) ()) + ] + Prelude.mapM_ testRunner $ + createPaths + [ Consume (tapeLen - 1) + , Custom (P.SContinue 1 ()) + , Custom (P.SContinue (-9) ()) + , Custom (P.SDone (-4) ()) + ] + Prelude.mapM_ testRunner $ + createPaths + [ Consume (tapeLen - 1) + , Custom (P.SContinue 1 ()) + , Custom (P.SContinue (-9) ()) + , Custom (P.SError "Message3") + ] diff --git a/test/lib/Streamly/Test/Prelude/Common.hs b/test/lib/Streamly/Test/Prelude/Common.hs --- a/test/lib/Streamly/Test/Prelude/Common.hs +++ b/test/lib/Streamly/Test/Prelude/Common.hs @@ -1,4 +1,9 @@ +{-# Language NoMonoLocalBinds #-} {-# OPTIONS_GHC -Wno-deprecations #-} +-- XXX We are using head/tail at one place +#if __GLASGOW_HASKELL__ >= 908 +{-# OPTIONS_GHC -Wno-x-partial #-} +#endif -- | -- Module : Streamly.Test.Prelude.Common @@ -85,7 +90,10 @@ , sortEq ) where -import Control.Applicative (ZipList(..), liftA2) +#if !MIN_VERSION_base(4,18,0) +import Control.Applicative (liftA2) +#endif +import Control.Applicative (ZipList(..)) import Control.Exception (Exception, try) import Control.Concurrent (threadDelay) import Control.Monad (replicateM) @@ -95,6 +103,8 @@ import Control.Monad.Catch (throwM, MonadThrow) import Data.IORef ( IORef, atomicModifyIORef', modifyIORef', newIORef , readIORef, writeIORef) +import Data.Foldable + (elem, foldl, foldMap, foldr, length, maximum, minimum, null, product, sum) import Data.List ( delete , deleteBy @@ -131,12 +141,13 @@ import qualified Streamly.Prelude as S import qualified Streamly.Data.Fold as FL import qualified Streamly.Internal.Data.Stream.IsStream as S -import qualified Streamly.Internal.Data.Stream.IsStream.Common as IS +import qualified Streamly.Internal.Data.Stream.IsStream as IS import qualified Streamly.Internal.Data.Unfold as UF import qualified Data.Map.Strict as Map import Streamly.Test.Common +import Prelude hiding (Foldable(..)) maxStreamLen :: Int maxStreamLen = 1000 diff --git a/test/streamly-tests.cabal b/test/streamly-tests.cabal --- a/test/streamly-tests.cabal +++ b/test/streamly-tests.cabal @@ -50,8 +50,6 @@ ------------------------------------------------------------------------------- common compile-options - default-language: Haskell2010 - if os(darwin) cpp-options: -DCABAL_OS_DARWIN @@ -92,10 +90,23 @@ cpp-options: -DINCLUDE_FLAKY_TESTS common default-extensions + default-language: Haskell2010 + + -- GHC2024 may include more extensions than we are actually using, see the + -- full list below. We enable this to ensure that we are able to compile + -- with this i.e. there is no interference by other extensions. + if impl(ghc >= 9.10) + default-language: GHC2024 + + if impl(ghc >= 9.2) && impl(ghc < 9.10) + default-language: GHC2021 + + if impl(ghc >= 8.10) + default-extensions: StandaloneKindSignatures + + -- In GHC 2024 default-extensions: BangPatterns - CApiFFI - CPP ConstraintKinds DeriveDataTypeable DeriveGeneric @@ -107,24 +118,18 @@ InstanceSigs KindSignatures LambdaCase - MagicHash MultiParamTypeClasses - PatternSynonyms RankNTypes - RecordWildCards ScopedTypeVariables TupleSections - TypeFamilies - ViewPatterns - -- MonoLocalBinds, enabled by TypeFamilies, causes performance - -- regressions. Disable it. This must come after TypeFamilies, - -- otherwise TypeFamilies will enable it again. + -- Not in GHC2024 + CPP + MagicHash + PatternSynonyms + RecordWildCards NoMonoLocalBinds - -- UndecidableInstances -- Does not show any perf impact - -- UnboxedTuples -- interferes with (#.) - common threading-options ghc-options: -threaded -with-rtsopts=-N @@ -145,19 +150,21 @@ common test-dependencies build-depends: streamly-core - , base >= 4.9 && < 4.18 - , containers >= 0.5 && < 0.7 + , base >= 4.9 && < 4.23 + , containers >= 0.5 && < 0.9 , exceptions >= 0.8 && < 0.11 , ghc - , hspec >= 2.0 && < 2.10 - , mtl >= 2.2 && < 2.3 - , random >= 1.0.0 && < 1.3 + , hspec >= 2.0 && < 2.12 + , mtl >= 2.2 && < 2.4 + , random >= 1.0.0 && < 1.4 , transformers >= 0.4 && < 0.7 - , QuickCheck >= 2.13 && < 2.15 - , directory >= 1.2.2 && < 1.4 - , filepath >= 1.4.1 && < 1.5 + , QuickCheck >= 2.13 && < 2.19 + , directory >= 1.2.2 && < 1.5 + , filepath >= 1.4.1 && < 1.6 , temporary >= 1.3 && < 1.4 - , network >= 3.1 && < 3.2 + , network >= 3.1 && < 3.3 + , scientific >= 0.0 && < 0.4 + , template-haskell >= 2.12 && < 2.25 if !flag(use-streamly-core) build-depends: streamly @@ -179,7 +186,9 @@ library import: lib-options, test-dependencies hs-source-dirs: lib - exposed-modules: Streamly.Test.Common + exposed-modules: + Streamly.Test.Common + Streamly.Test.Parser.Common if !flag(use-streamly-core) exposed-modules: Streamly.Test.Prelude.Common if flag(limit-build-mem) @@ -192,7 +201,10 @@ common test-options import: lib-options , threading-options - ghc-options: -rtsopts -fno-ignore-asserts + ghc-options: + -rtsopts + -with-rtsopts "-t" + -fno-ignore-asserts include-dirs: . build-depends: streamly-tests @@ -206,26 +218,20 @@ -fmax-worker-args=16 -fspec-constr-recursive=16 -rtsopts + -with-rtsopts "-t" -fno-ignore-asserts if flag(fusion-plugin) && !impl(ghcjs) && !impl(ghc < 8.6) ghc-options: -fplugin Fusion.Plugin ------------------------------------------------------------------------------- --- Test suites in sorted order +-- Test suites in alphabetical order ------------------------------------------------------------------------------- -test-suite Data.List - import: test-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Data/List.hs - cpp-options: -DUSE_STREAMLY_LIST - if !flag(dev) - buildable: False - -test-suite Data.List.Base +test-suite Data.Array import: test-options type: exitcode-stdio-1.0 - main-is: Streamly/Test/Data/List.hs + main-is: Streamly/Test/Data/Array.hs + ghc-options: -main-is Streamly.Test.Data.Array.main test-suite Data.Array.Generic import: test-options @@ -235,38 +241,17 @@ if flag(use-streamly-core) buildable: False -test-suite Data.Array - import: test-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Data/Array.hs - ghc-options: -main-is Streamly.Test.Data.Array.main - -test-suite Data.Array.Mut - import: test-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Data/Array/Mut.hs - ghc-options: -main-is Streamly.Test.Data.Array.Mut.main - -test-suite Data.Ring.Unboxed +test-suite Data.Array.Stream import: test-options type: exitcode-stdio-1.0 - main-is: Streamly/Test/Data/Ring/Unboxed.hs - ghc-options: -main-is Streamly.Test.Data.Ring.Unboxed.main + main-is: Streamly/Test/Data/Array/Stream.hs if flag(use-streamly-core) buildable: False -test-suite Data.Unbox - import: test-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Data/Unbox.hs - ghc-options: -main-is Streamly.Test.Data.Unbox.main - -test-suite Data.Array.Stream +test-suite Data.Binary import: test-options type: exitcode-stdio-1.0 - main-is: Streamly/Test/Data/Array/Stream.hs - if flag(use-streamly-core) - buildable: False + main-is: Streamly/Test/Serialize/Serializable.hs test-suite Data.Fold import: test-options @@ -279,20 +264,89 @@ main-is: Streamly/Test/Data/Fold/Window.hs ghc-options: -main-is Streamly.Test.Data.Fold.Window.main +-- The Streamly.Data.List needs to be fixed to enable this +-- test-suite Data.List +-- import: test-options +-- type: exitcode-stdio-1.0 +-- main-is: Streamly/Test/Data/List.hs +-- cpp-options: -DUSE_STREAMLY_LIST +-- if !flag(dev) +-- buildable: False + +test-suite Data.List.Base + import: test-options + type: exitcode-stdio-1.0 + main-is: Streamly/Test/Data/List.hs + +test-suite Data.MutArray + import: test-options + type: exitcode-stdio-1.0 + main-is: Streamly/Test/Data/MutArray.hs + ghc-options: -main-is Streamly.Test.Data.MutArray.main + test-suite Data.Parser import: test-options type: exitcode-stdio-1.0 main-is: Streamly/Test/Data/Parser.hs + hs-source-dirs: . + other-modules: Streamly.Test.Data.Parser.Common if flag(limit-build-mem) - ghc-options: +RTS -M4000M -RTS + ghc-options: +RTS -M2000M -RTS -test-suite Data.Parser.ParserD +test-suite Data.ParserK import: test-options type: exitcode-stdio-1.0 - main-is: Streamly/Test/Data/Parser/ParserD.hs + main-is: Streamly/Test/Data/ParserK.hs if flag(limit-build-mem) ghc-options: +RTS -M1500M -RTS +test-suite Data.RingArray + import: test-options + type: exitcode-stdio-1.0 + main-is: Streamly/Test/Data/RingArray.hs + ghc-options: -main-is Streamly.Test.Data.RingArray.main + +test-suite Data.Scanl.Concurrent + import: test-options + type: exitcode-stdio-1.0 + main-is: Streamly/Test/Data/Scanl/Concurrent.hs + ghc-options: -main-is Streamly.Test.Data.Scanl.Concurrent.main + if flag(use-streamly-core) + buildable: False + +-- XXX Rename to MutByteArray +test-suite Data.Serialize + import: test-options + type: exitcode-stdio-1.0 + main-is: Streamly/Test/Data/Serialize.hs + other-modules: + Streamly.Test.Data.Serialize.TH + Streamly.Test.Data.Serialize.CompatV0 + Streamly.Test.Data.Serialize.CompatV1 + ghc-options: -main-is Streamly.Test.Data.Serialize.main + if flag(limit-build-mem) + ghc-options: +RTS -M1500M -RTS + +test-suite Data.Serialize.Derive.TH + import: test-options + type: exitcode-stdio-1.0 + cpp-options: -DUSE_SERIALIZE + main-is: Streamly/Test/Data/Unbox.hs + ghc-options: -main-is Streamly.Test.Data.Unbox.main + +test-suite Data.Serialize.ENABLE_constructorTagAsString + import: test-options + type: exitcode-stdio-1.0 + main-is: Streamly/Test/Data/Serialize.hs + other-modules: + Streamly.Test.Data.Serialize.TH + Streamly.Test.Data.Serialize.CompatV0 + Streamly.Test.Data.Serialize.CompatV1 + cpp-options: -DENABLE_constructorTagAsString + ghc-options: -main-is Streamly.Test.Data.Serialize.main + if flag(limit-build-mem) + ghc-options: +RTS -M1500M -RTS + test-suite Data.SmallArray import: test-options type: exitcode-stdio-1.0 @@ -301,6 +355,68 @@ if !flag(dev) || flag(use-streamly-core) buildable: False +test-suite Data.Stream + import: test-options + type: exitcode-stdio-1.0 + main-is: Streamly/Test/Data/Stream.hs + ghc-options: -main-is Streamly.Test.Data.Stream.main + if flag(limit-build-mem) + ghc-options: +RTS -M1500M -RTS + +test-suite Data.Stream.Concurrent + import: test-options + type: exitcode-stdio-1.0 + main-is: Streamly/Test/Data/Stream/Concurrent.hs + ghc-options: -main-is Streamly.Test.Data.Stream.Concurrent.main + if flag(use-streamly-core) + buildable: False + +test-suite Data.Stream.Exception + import: test-options + type: exitcode-stdio-1.0 + main-is: Streamly/Test/Data/Stream/Exception.hs + ghc-options: -main-is Streamly.Test.Data.Stream.Exception.main + +test-suite Data.Stream.Time + import: test-options + type: exitcode-stdio-1.0 + main-is: Streamly/Test/Data/Stream/Time.hs + ghc-options: -main-is Streamly.Test.Data.Stream.Time.main + if flag(use-streamly-core) + buildable: False + +test-suite Data.Stream.Rate + import:always-optimized + type: exitcode-stdio-1.0 + main-is: Streamly/Test/Data/Stream/Rate.hs + ghc-options: -main-is Streamly.Test.Data.Stream.Rate.main + if flag(dev) + buildable: True + else + buildable: False + if flag(use-streamly-core) + buildable: False + +-- XXX Rename to MutByteArray.Unbox +test-suite Data.Unbox.Derive.Generic + import: test-options + type: exitcode-stdio-1.0 + main-is: Streamly/Test/Data/Unbox.hs + ghc-options: -main-is Streamly.Test.Data.Unbox.main + +test-suite Data.Unbox.Derive.TH + import: test-options + type: exitcode-stdio-1.0 + cpp-options: -DUSE_TH + main-is: Streamly/Test/Data/Unbox.hs + ghc-options: -main-is Streamly.Test.Data.Unbox.main + +test-suite Data.Unbox.TH + import: test-options + type: exitcode-stdio-1.0 + main-is: Streamly/Test/Data/Unbox/TH.hs + ghc-options: -main-is Streamly.Test.Data.Unbox.TH.main + test-suite Data.Unfold import: test-options type: exitcode-stdio-1.0 @@ -312,7 +428,7 @@ ghc-options: -main-is Streamly.Test.FileSystem.Event main-is: Streamly/Test/FileSystem/Event.hs other-modules: Streamly.Test.FileSystem.Event.Common - if flag(use-streamly-core) + if !((os(linux) && impl(ghc >= 9.4)) || os(darwin) || os(windows)) || flag(use-streamly-core) buildable: False test-suite FileSystem.Event.Darwin @@ -322,9 +438,7 @@ other-modules: Streamly.Test.FileSystem.Event.Common cpp-options: -DFILESYSTEM_EVENT_DARWIN ghc-options: -main-is Streamly.Test.FileSystem.Event.Darwin - if !os(darwin) - buildable: False - if flag(use-streamly-core) + if !os(darwin) || flag(use-streamly-core) buildable: False test-suite FileSystem.Event.Linux @@ -334,9 +448,7 @@ other-modules: Streamly.Test.FileSystem.Event.Common cpp-options: -DFILESYSTEM_EVENT_LINUX ghc-options: -main-is Streamly.Test.FileSystem.Event.Linux - if !os(linux) - buildable: False - if flag(use-streamly-core) + if impl(ghc < 9.4) || !os(linux) || flag(use-streamly-core) buildable: False test-suite FileSystem.Event.Windows @@ -346,9 +458,7 @@ other-modules: Streamly.Test.FileSystem.Event.Common cpp-options: -DFILESYSTEM_EVENT_WINDOWS ghc-options: -main-is Streamly.Test.FileSystem.Event.Windows - if !os(windows) - buildable: False - if flag(use-streamly-core) + if !os(windows) || flag(use-streamly-core) buildable: False test-suite FileSystem.Handle @@ -359,30 +469,77 @@ if flag(use-streamly-core) buildable: False -test-suite Network.Inet.TCP +test-suite FileSystem.DirIO import: test-options type: exitcode-stdio-1.0 - main-is: Streamly/Test/Network/Inet/TCP.hs + main-is: Streamly/Test/FileSystem/DirIO.hs if flag(use-streamly-core) buildable: False - -- XXX on Windows these test cases are hanging for ever - -- need to be investigated. - -- https://github.com/composewell/streamly/issues/2315 + build-depends: + bench-test-lib + -- Fix this test-suite for Windows if os(windows) buildable: False +test-suite Network.Inet.TCP + import: lib-options + type: exitcode-stdio-1.0 + main-is: Streamly/Test/Network/Inet/TCP.hs + ghc-options: -rtsopts -fno-ignore-asserts + include-dirs: . + build-depends: streamly-tests + -- Cannot killThread in listen/accept on Windows threaded runtime + if !os(windows) + ghc-options: -threaded -with-rtsopts=-N + if flag(use-streamly-core) + buildable: False + test-suite Network.Socket - import: test-options + import: lib-options type: exitcode-stdio-1.0 main-is: Streamly/Test/Network/Socket.hs + ghc-options: -rtsopts -fno-ignore-asserts + include-dirs: . + build-depends: streamly-tests + -- Cannot killThread in listen/accept on Windows threaded runtime + if !os(windows) + ghc-options: -threaded -with-rtsopts=-N if flag(use-streamly-core) buildable: False - -- XXX on Windows these test cases are hanging for ever - -- need to be investigated. - -- https://github.com/composewell/streamly/issues/2315 - if os(windows) + +test-suite Unicode.Char + import: test-options + type: exitcode-stdio-1.0 + main-is: Streamly/Test/Unicode/Char.hs + ghc-options: -main-is Streamly.Test.Unicode.Char.main + if flag(use-streamly-core) || !flag(dev) buildable: False +test-suite Unicode.Parser + import: test-options + type: exitcode-stdio-1.0 + main-is: Streamly/Test/Unicode/Parser.hs + ghc-options: -main-is Streamly.Test.Unicode.Parser.main + if flag(use-streamly-core) + buildable: False + +test-suite Unicode.Stream + import: test-options + type: exitcode-stdio-1.0 + main-is: Streamly/Test/Unicode/Stream.hs + ghc-options: -main-is Streamly.Test.Unicode.Stream.main + if flag(use-streamly-core) + buildable: False + +test-suite version-bounds + import: test-options + type: exitcode-stdio-1.0 + main-is: version-bounds.hs + +------------------------------------------------------------------------------- +-- Deprecated +------------------------------------------------------------------------------- + test-suite Prelude import: test-options type: exitcode-stdio-1.0 @@ -407,14 +564,6 @@ if flag(use-streamly-core) buildable: False -test-suite Data.Stream.Concurrent - import: test-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Data/Stream/Concurrent.hs - ghc-options: -main-is Streamly.Test.Data.Stream.Concurrent.main - if flag(use-streamly-core) - buildable: False - test-suite Prelude.Concurrent import: test-options type: exitcode-stdio-1.0 @@ -503,29 +652,3 @@ ghc-options: -main-is Streamly.Test.Prelude.ZipSerial.main if flag(use-streamly-core) buildable: False - -test-suite Unicode.Stream - import: test-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Unicode/Stream.hs - ghc-options: -main-is Streamly.Test.Unicode.Stream.main - if flag(use-streamly-core) - buildable: False - -test-suite Unicode.Char - import: test-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Unicode/Char.hs - ghc-options: -main-is Streamly.Test.Unicode.Char.main - if flag(use-streamly-core) || !flag(dev) - buildable: False - -test-suite Serialize.Serializable - import: test-options - type: exitcode-stdio-1.0 - main-is: Streamly/Test/Serialize/Serializable.hs - -test-suite version-bounds - import: test-options - type: exitcode-stdio-1.0 - main-is: version-bounds.hs diff --git a/test/test-runner/Main.hs b/test/test-runner/Main.hs --- a/test/test-runner/Main.hs +++ b/test/test-runner/Main.hs @@ -10,23 +10,28 @@ import Targets (targets) rtsOpts :: Bool -> String -> String -> String -rtsOpts relaxMem exeName target = +rtsOpts relaxMem exeName target = mkOpts <> " -t" - if relaxMem - then "-K16M -M1024M" - else "-K8M -M64M " <> targetSpecific where + mkOpts = + if relaxMem + then "-K16M -M1024M" + else "-K8M -M64M " <> targetSpecific + targetSpecific = case target of -- XXX Data.Array.* heap requirement increased for GHC-8.10 - "Data.Array.Unboxed" -> "-M128M" + "Data.Array" -> "-M128M" "Data.Array.Generic" -> "-M128M" + "Data.Stream.Rate" -> "-M512M" + "Data.Serialize" -> "-M128M" + "Data.Serialize.ENABLE_constructorTagAsString" -> "-M128M" "Prelude.Rate" -> "-M512M" -- For -O0 case writeChunks test fails, maybe we should have a -- separate flag for O0 case? - "FileSystem.Handle" -> "-K16M" + "FileSystem.Handle" -> "-K16M -M128M" _ -> "" main :: IO ()