diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,173 @@ +4.3.16 + +* Fix example code for `every` +* Improved documentation for `ListT` + +4.3.15 + +* Build against `ghc-9.0` + +4.3.14 + +* Add `mapMaybe` and `wither`, and more laws for `filter` and `filterM`. + +4.3.13 + +* Add `MonadFail` instance for `Proxy` + +4.3.12 + +* Fix space leak introduced in version 4.3.10 + * This leak primarily affects the use of `forever` + +4.3.11 + +* Fix documentation for `scanM` + +4.3.10 + +* Relax `Monad` constraints to `Functor` +* Support GHC 8.8 + +4.3.9 + +* Increase upper bound on `exceptions` + +4.3.8 + +* Increase upper bound on `exceptions` + +4.3.7 + +* Documentation fix + +4.3.6 + +* Fix implementation of `pass` in `MonadWriter` instance for `Proxy` + +4.3.5 + +* Support `Semigroup` being a super-class of `Monoid` + +4.3.4 + +* Increase upper bound on `mmorph` + +4.3.3 + +* Make `X` a synonym for `Data.Void.Void` + +4.3.2 + +* BUG FIX: Fix `MMonad` instance for `ListT` + * The old instance was an infinite loop + +4.3.1 + +* Support building against `ghc-7.4` + +4.3.0 + +* BREAKING CHANGE: Remove `Alternative`/`MonadPlus` instances for `Proxy` + * See commit 08e7302f43dbf2a40bd367c5ee73ee3367e17768 which explains why +* Add `Traversable` instance for `ListT` +* New `MonadThrow`/`MonadCatch`/`MMonad`/`Semigroup`/`MonadZip` instances for + `ListT` +* New `MonadThrow`/`MonadCatch` instances for `Proxy` +* Fix lower bound on `mtl` +* Increase upper bound on `optparse-applicative` + +4.2.0 + +* BREAKING CHANGE: Switch from `ErrorT` to `ExceptT` +* Add `Foldable` instance for `ListT` +* Fix all warnings +* Enable foldr/build fusion for `toList` + +4.1.9 + +* Increase lower bound on `criterion` +* Increase upper bound on `transformers` for tests/benchmarks +* Optimize code by delaying `INLINABLE` annotations + +4.1.8 + +* Increase upper bound on `transformers` +* Prepare for MRP (Monad of no Return Proposal) + +4.1.7 + +* Increase lower bound on `deepseq` +* Add `unfoldr` +* Add `loop` +* Add `toListM'` +* Improve efficiency of `drop` +* License tutorial under Creative Commons license + +4.1.6 + +* Increase lower bound on `base` +* Add diagrams to `Pipes.Core` documentation +* Add `mapM_` +* Add `takeWhile'` +* Add `seq` +* Improve efficiency of `toListM` + +4.1.5 + +* Increase upper bound on `criterion` + +4.1.4 + +* Increase upper bound on `criterion` +* Add `Monoid` instance for `Proxy` + +4.1.3 + +* Increase lower bound on `mtl` +* Re-export `void` +* Add `fold'` +* Add `foldM'` + +4.1.2 + +* Increase upper bounds on `transformers` and `mtl` + +4.1.1 + +* Add `runListT` +* Add `MMonad` instance for `Proxy` +* Add `repeatM` +* Add laws to documentation of `Pipes.Prelude` utilities + +4.1.0 + +* Remove Haskell98 support +* Use internal `X` type instead of `Data.Void` +* Document `Pipes.Lift` module:w +* Add `drain` +* Add `sequence` + +4.0.2 + +* Improve performance of `each` +* Add tutorial appendix explaining how to work around quadratic time complexity + +4.0.1 + +* Remove `WriterT` and `RWST` benchmarks +* Add `Enumerable` instance for `ErrorT` +* Add cabal flag for Haskell98 compilation +* Add several rewrite rules +* Add `mtl` instances for `ListT` +* Fix implementation of `pass`, which did not satisfy `Writer` laws +* Implement `fail` for `ListT` +* Add type synonym table to tutorial appendix +* Add QuickCheck tests for `pipes` laws +* Add `mapFoldable` +* Add `Monoid` instance for `ListT` +* Add manual proofs of `pipes` laws in `laws.md` + +4.0.0 + +Major upgrade of `pipes` to no longer use `Proxy` type class diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2012, 2013 Gabriel Gonzalez +Copyright (c) 2012-2016 Gabriel Gonzalez All rights reserved. Redistribution and use in source and binary forms, with or without modification, diff --git a/benchmarks/Common.hs b/benchmarks/Common.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Common.hs @@ -0,0 +1,20 @@ +module Common (commonMain) where + +import Criterion.Main (Benchmark, runMode) +import Criterion.Main.Options as Criterion +import Data.Maybe (fromMaybe) +import Data.Monoid +import Options.Applicative + +commonMain :: Int -- ^ default maximum data size + -> (Int -> [Benchmark]) -- ^ the benchmarks to run + -> IO () +commonMain mdMax bench = do + (maybeNewMax, critMode) <- execParser $ info (helper <*> options) mempty + runMode critMode $ bench (fromMaybe mdMax maybeNewMax) + +options :: Parser (Maybe Int, Criterion.Mode) +options = + (,) <$> optional (option auto (help "benchmark maximum data size" + <> metavar "N" <> short 'i' <> long "imax")) + <*> Criterion.parseWith Criterion.defaultConfig diff --git a/benchmarks/LiftBench.hs b/benchmarks/LiftBench.hs --- a/benchmarks/LiftBench.hs +++ b/benchmarks/LiftBench.hs @@ -2,7 +2,6 @@ module Main (main) where import Common (commonMain) -import Control.DeepSeq import Control.Monad.Identity import qualified Control.Monad.Trans.Reader as R import qualified Control.Monad.Trans.State.Strict as S @@ -13,8 +12,6 @@ defaultMax :: Int defaultMax = 10000 - -instance NFData a => NFData (Sum a) main :: IO () main = commonMain defaultMax liftBenchmarks diff --git a/pipes.cabal b/pipes.cabal --- a/pipes.cabal +++ b/pipes.cabal @@ -1,10 +1,11 @@ Name: pipes -Version: 4.0.2 +Version: 4.3.16 Cabal-Version: >= 1.10 Build-Type: Simple +Tested-With: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.1 License: BSD3 License-File: LICENSE -Copyright: 2012, 2013 Gabriel Gonzalez +Copyright: 2012-2016 Gabriel Gonzalez Author: Gabriel Gonzalez Maintainer: Gabriel439@gmail.com Bug-Reports: https://github.com/Gabriel439/Haskell-Pipes-Library/issues @@ -17,7 +18,7 @@ . * /Concise API/: Use simple commands like 'for', ('>->'), 'await', and 'yield' . - * /Blazing fast/: Implementation tuned for speed + * /Blazing fast/: Implementation tuned for speed, including shortcut fusion . * /Lightweight Dependency/: @pipes@ is small and compiles very rapidly, including dependencies @@ -34,26 +35,28 @@ . Read "Pipes.Tutorial" for an extensive tutorial. Category: Control, Pipes +Extra-Source-Files: + CHANGELOG.md Source-Repository head Type: git Location: https://github.com/Gabriel439/Haskell-Pipes-Library Library - if !flag(haskell98) - Default-Language: Haskell2010 - else - Default-Language: Haskell98 + Default-Language: Haskell2010 HS-Source-Dirs: src Build-Depends: - base >= 4 && < 5 , - transformers >= 0.2.0.0 && < 0.4, - void < 0.7 + base >= 4.8 && < 5 , + transformers >= 0.2.0.0 && < 0.6 , + exceptions >= 0.4 && < 0.11, + mmorph >= 1.0.4 && < 1.2 , + mtl >= 2.2.1 && < 2.3 , + void >= 0.4 && < 0.8 - if !flag(haskell98) - Build-Depends: - mmorph >= 1.0.0 && < 1.1, - mtl >= 2.0.1.0 && < 2.2 + if impl(ghc < 8.0) + Build-depends: + fail == 4.9.* , + semigroups >= 0.17 && < 0.20 Exposed-Modules: Pipes, @@ -64,54 +67,49 @@ Pipes.Tutorial GHC-Options: -O2 -Wall - if flag(haskell98) - CPP-Options: -Dhaskell98 - - Benchmark prelude-benchmarks Default-Language: Haskell2010 Type: exitcode-stdio-1.0 HS-Source-Dirs: benchmarks Main-Is: PreludeBench.hs + Other-Modules: Common GHC-Options: -O2 -Wall -rtsopts -fno-warn-unused-do-bind Build-Depends: - base >= 4 && < 5 , - criterion >= 0.6.2.1 && < 0.9, - mtl >= 2.0.1.0 && < 2.2, - pipes >= 4.0.0 && < 4.1 + base >= 4.4 && < 5 , + criterion >= 1.1.1.0 && < 1.6, + optparse-applicative >= 0.12 && < 0.17, + mtl >= 2.1 && < 2.3, + pipes test-suite tests Default-Language: Haskell2010 Type: exitcode-stdio-1.0 HS-Source-Dirs: tests Main-Is: Main.hs - GHC-Options: -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-missing-signatures + GHC-Options: -Wall -rtsopts -fno-warn-missing-signatures -fno-enable-rewrite-rules Build-Depends: - base >= 4 && < 5 , - pipes >= 4.0.0 && < 4.1 , + base >= 4.4 && < 5 , + pipes , QuickCheck >= 2.4 && < 3 , - mtl >= 2.0.1 && < 2.2 , + mtl >= 2.1 && < 2.3 , test-framework >= 0.4 && < 1 , test-framework-quickcheck2 >= 0.2.0 && < 0.4 , - transformers >= 0.2.0.0 && < 0.4 + transformers >= 0.2.0.0 && < 0.6 Benchmark lift-benchmarks Default-Language: Haskell2010 Type: exitcode-stdio-1.0 HS-Source-Dirs: benchmarks Main-Is: LiftBench.hs + Other-Modules: Common GHC-Options: -O2 -Wall -rtsopts -fno-warn-unused-do-bind Build-Depends: - base >= 4 && < 5 , - criterion >= 0.6.2.1 && < 0.9, - deepseq , - mtl >= 2.0.1.0 && < 2.2, - pipes >= 4.0.0 && < 4.1, - transformers >= 0.2.0.0 && < 0.4 - -Flag haskell98 - Description: Haskell98 compliant subset of pipes. - Default: False + base >= 4.4 && < 5 , + criterion >= 1.1.1.0 && < 1.6 , + optparse-applicative >= 0.12 && < 0.17, + mtl >= 2.1 && < 2.3 , + pipes , + transformers >= 0.2.0.0 && < 0.6 diff --git a/src/Pipes.hs b/src/Pipes.hs --- a/src/Pipes.hs +++ b/src/Pipes.hs @@ -1,25 +1,20 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE Trustworthy #-} + {-| This module is the recommended entry point to the @pipes@ library. Read "Pipes.Tutorial" if you want a tutorial explaining how to use this library. -} -{-# LANGUAGE - RankNTypes - , CPP - , FlexibleInstances - , MultiParamTypeClasses - , UndecidableInstances - #-} - --- The rewrite RULES require the 'TrustWorthy' annotation -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Trustworthy #-} -#endif - module Pipes ( -- * The Proxy Monad Transformer Proxy + , X , Effect , Effect' , runEffect @@ -50,6 +45,7 @@ -- * ListT , ListT(..) + , runListT , Enumerable(..) -- * Utilities @@ -60,40 +56,41 @@ -- * Re-exports -- $reexports + , module Control.Monad , module Control.Monad.IO.Class , module Control.Monad.Trans.Class -#ifndef haskell98 , module Control.Monad.Morph -#endif - , module Data.Foldable - , module Data.Void + , Foldable ) where -import Control.Applicative (Applicative(pure, (<*>)), Alternative(empty, (<|>))) -import Control.Monad (MonadPlus(mzero, mplus)) +import Control.Monad (void, MonadPlus(mzero, mplus)) +import Control.Monad.Catch (MonadThrow(..), MonadCatch(..)) +import Control.Monad.Except (MonadError(..)) +import Control.Monad.Fail (MonadFail(..)) import Control.Monad.IO.Class (MonadIO(liftIO)) +import Control.Monad.Reader (MonadReader(..)) +import Control.Monad.State (MonadState(..)) import Control.Monad.Trans.Class (MonadTrans(lift)) -import Control.Monad.Trans.Error (ErrorT(runErrorT)) +import Control.Monad.Trans.Except (ExceptT, runExceptT) import Control.Monad.Trans.Identity (IdentityT(runIdentityT)) import Control.Monad.Trans.Maybe (MaybeT(runMaybeT)) -import Data.Foldable (Foldable) -import qualified Data.Foldable as F -import Data.Monoid (Monoid(..)) -import Data.Void (Void) -import qualified Data.Void as V -import Pipes.Internal (Proxy(..)) -import Pipes.Core -#ifndef haskell98 -import Control.Monad.Error (MonadError(..)) -import Control.Monad.Reader (MonadReader(..)) -import Control.Monad.State (MonadState(..)) import Control.Monad.Writer (MonadWriter(..)) +import Control.Monad.Zip (MonadZip(..)) +import Pipes.Core +import Pipes.Internal (Proxy(..)) +import qualified Data.Foldable as F + +#if MIN_VERSION_base(4,8,0) +import Control.Applicative (Alternative(..)) +#else +import Control.Applicative +import Data.Foldable (Foldable) +import Data.Traversable (Traversable(..)) #endif +import Data.Semigroup -- Re-exports -#ifndef haskell98 -import Control.Monad.Morph (MFunctor(hoist)) -#endif +import Control.Monad.Morph (MFunctor(hoist), MMonad(embed)) infixl 4 <~ infixr 4 ~> @@ -137,30 +134,52 @@ {-| Produce a value @ -'yield' :: 'Monad' m => a -> 'Pipe' x a m () +'yield' :: 'Monad' m => a -> 'Producer' a m () +'yield' :: 'Monad' m => a -> 'Pipe' x a m () @ -} -yield :: (Monad m) => a -> Producer' a m () +yield :: Functor m => a -> Proxy x' x () a m () yield = respond -{-# INLINABLE yield #-} +{-# INLINABLE [1] yield #-} {-| @(for p body)@ loops over @p@ replacing each 'yield' with @body@. @ -'for' :: 'Monad' m => 'Producer' b m r -> (b -> 'Effect' m ()) -> 'Effect' m r -'for' :: 'Monad' m => 'Producer' b m r -> (b -> 'Producer' c m ()) -> 'Producer' c m r -'for' :: 'Monad' m => 'Pipe' x b m r -> (b -> 'Consumer' x m ()) -> 'Consumer' x m r -'for' :: 'Monad' m => 'Pipe' x b m r -> (b -> 'Pipe' x c m ()) -> 'Pipe' x c m r +'for' :: 'Functor' m => 'Producer' b m r -> (b -> 'Effect' m ()) -> 'Effect' m r +'for' :: 'Functor' m => 'Producer' b m r -> (b -> 'Producer' c m ()) -> 'Producer' c m r +'for' :: 'Functor' m => 'Pipe' x b m r -> (b -> 'Consumer' x m ()) -> 'Consumer' x m r +'for' :: 'Functor' m => 'Pipe' x b m r -> (b -> 'Pipe' x c m ()) -> 'Pipe' x c m r @ + + The following diagrams show the flow of information: + +@ + .---> b + / | + +-----------+ / +-----|-----+ +---------------+ + | | / | v | | | + | | / | | | | +x ==> p ==> b ---' x ==> body ==> c = x ==> 'for' p body ==> c + | | | | | | + | | | | | | | | | + +-----|-----+ +-----|-----+ +-------|-------+ + v v v + r () r +@ + + For a more complete diagram including bidirectional flow, see "Pipes.Core#respond-diagram". -} -for :: (Monad m) +for :: Functor m => Proxy x' x b' b m a' -- ^ -> (b -> Proxy x' x c' c m b') -- ^ -> Proxy x' x c' c m a' for = (//>) -{-# INLINABLE for #-} +-- There are a number of useful rewrites which can be performed on various uses +-- of this combinator; to ensure that they fire we defer inlining until quite +-- late. +{-# INLINABLE [0] for #-} {-# RULES "for (for p f) g" forall p f g . for (for p f) g = for p (\a -> for (f a) g) @@ -190,19 +209,45 @@ yield x go in go + + ; "p1 >-> (p2 >-> p3)" forall p1 p2 p3 . + p1 >-> (p2 >-> p3) = (p1 >-> p2) >-> p3 + + ; "p >-> cat" forall p . p >-> cat = p + + ; "cat >-> p" forall p . cat >-> p = p + #-} {-| Compose loop bodies @ -('~>') :: 'Monad' m => (a -> 'Producer' b m r) -> (b -> 'Effect' m ()) -> (a -> 'Effect' m r) -('~>') :: 'Monad' m => (a -> 'Producer' b m r) -> (b -> 'Producer' c m ()) -> (a -> 'Producer' c m r) -('~>') :: 'Monad' m => (a -> 'Pipe' x b m r) -> (b -> 'Consumer' x m ()) -> (a -> 'Consumer' x m r) -('~>') :: 'Monad' m => (a -> 'Pipe' x b m r) -> (b -> 'Pipe' x c m ()) -> (a -> 'Pipe' x c m r) +('~>') :: 'Functor' m => (a -> 'Producer' b m r) -> (b -> 'Effect' m ()) -> (a -> 'Effect' m r) +('~>') :: 'Functor' m => (a -> 'Producer' b m r) -> (b -> 'Producer' c m ()) -> (a -> 'Producer' c m r) +('~>') :: 'Functor' m => (a -> 'Pipe' x b m r) -> (b -> 'Consumer' x m ()) -> (a -> 'Consumer' x m r) +('~>') :: 'Functor' m => (a -> 'Pipe' x b m r) -> (b -> 'Pipe' x c m ()) -> (a -> 'Pipe' x c m r) @ + + The following diagrams show the flow of information: + +@ + a .---> b a + | / | | + +-----|-----+ / +-----|-----+ +------|------+ + | v | / | v | | v | + | | / | | | | +x ==> f ==> b ---' x ==> g ==> c = x ==> f '~>' g ==> c + | | | | | | + | | | | | | | | | + +-----|-----+ +-----|-----+ +------|------+ + v v v + r () r +@ + + For a more complete diagram including bidirectional flow, see "Pipes.Core#respond-diagram". -} (~>) - :: (Monad m) + :: Functor m => (a -> Proxy x' x b' b m a') -- ^ -> (b -> Proxy x' x c' c m b') @@ -213,7 +258,7 @@ -- | ('~>') with the arguments flipped (<~) - :: (Monad m) + :: Functor m => (b -> Proxy x' x c' c m b') -- ^ -> (a -> Proxy x' x b' b m a') @@ -243,35 +288,51 @@ {-| Consume a value @ -'await' :: 'Monad' m => 'Pipe' a y m a +'await' :: 'Functor' m => 'Pipe' a y m a @ -} -await :: (Monad m) => Consumer' a m a +await :: Functor m => Consumer' a m a await = request () -{-# INLINABLE await #-} +{-# INLINABLE [1] await #-} {-| @(draw >~ p)@ loops over @p@ replacing each 'await' with @draw@ @ -('>~') :: 'Monad' m => 'Effect' m b -> 'Consumer' b m c -> 'Effect' m c -('>~') :: 'Monad' m => 'Consumer' a m b -> 'Consumer' b m c -> 'Consumer' a m c -('>~') :: 'Monad' m => 'Producer' y m b -> 'Pipe' b y m c -> 'Producer' y m c -('>~') :: 'Monad' m => 'Pipe' a y m b -> 'Pipe' b y m c -> 'Pipe' a y m c +('>~') :: 'Functor' m => 'Effect' m b -> 'Consumer' b m c -> 'Effect' m c +('>~') :: 'Functor' m => 'Consumer' a m b -> 'Consumer' b m c -> 'Consumer' a m c +('>~') :: 'Functor' m => 'Producer' y m b -> 'Pipe' b y m c -> 'Producer' y m c +('>~') :: 'Functor' m => 'Pipe' a y m b -> 'Pipe' b y m c -> 'Pipe' a y m c @ + + The following diagrams show the flow of information: + +@ + +-----------+ +-----------+ +-------------+ + | | | | | | + | | | | | | +a ==> f ==> y .---> b ==> g ==> y = a ==> f '>~' g ==> y + | | / | | | | + | | | / | | | | | | + +-----|-----+ / +-----|-----+ +------|------+ + v / v v + b ----' c c +@ + + For a more complete diagram including bidirectional flow, see "Pipes.Core#request-diagram". -} (>~) - :: (Monad m) + :: Functor m => Proxy a' a y' y m b -- ^ -> Proxy () b y' y m c -- ^ -> Proxy a' a y' y m c p1 >~ p2 = (\() -> p1) >\\ p2 -{-# INLINABLE (>~) #-} +{-# INLINABLE [1] (>~) #-} -- | ('>~') with the arguments flipped (~<) - :: (Monad m) + :: Functor m => Proxy () b y' y m c -- ^ -> Proxy a' a y' y m b @@ -299,53 +360,129 @@ -} -- | The identity 'Pipe', analogous to the Unix @cat@ program -cat :: (Monad m) => Pipe a a m r +cat :: Functor m => Pipe a a m r cat = pull () -{-# INLINABLE cat #-} +{-# INLINABLE [1] cat #-} {-| 'Pipe' composition, analogous to the Unix pipe operator @ -('>->') :: 'Monad' m => 'Producer' b m r -> 'Consumer' b m r -> 'Effect' m r -('>->') :: 'Monad' m => 'Producer' b m r -> 'Pipe' b c m r -> 'Producer' c m r -('>->') :: 'Monad' m => 'Pipe' a b m r -> 'Consumer' b m r -> 'Consumer' a m r -('>->') :: 'Monad' m => 'Pipe' a b m r -> 'Pipe' b c m r -> 'Pipe' a c m r +('>->') :: 'Functor' m => 'Producer' b m r -> 'Consumer' b m r -> 'Effect' m r +('>->') :: 'Functor' m => 'Producer' b m r -> 'Pipe' b c m r -> 'Producer' c m r +('>->') :: 'Functor' m => 'Pipe' a b m r -> 'Consumer' b m r -> 'Consumer' a m r +('>->') :: 'Functor' m => 'Pipe' a b m r -> 'Pipe' b c m r -> 'Pipe' a c m r @ + + The following diagrams show the flow of information: + +@ + +-----------+ +-----------+ +-------------+ + | | | | | | + | | | | | | +a ==> f ==> b ==> g ==> c = a ==> f '>->' g ==> c + | | | | | | + | | | | | | | | | + +-----|-----+ +-----|-----+ +------|------+ + v v v + r r r +@ + + For a more complete diagram including bidirectional flow, see "Pipes.Core#pull-diagram". -} (>->) - :: (Monad m) + :: Functor m => Proxy a' a () b m r -- ^ -> Proxy () b c' c m r -- ^ -> Proxy a' a c' c m r p1 >-> p2 = (\() -> p1) +>> p2 -{-# INLINABLE (>->) #-} +{-# INLINABLE [1] (>->) #-} {-| The list monad transformer, which extends a monad with non-determinism - 'return' corresponds to 'yield', yielding a single value + The type variables signify: - ('>>=') corresponds to 'for', calling the second computation once for each - time the first computation 'yield's. + * @m@ - The base monad + * @a@ - The values that the computation 'yield's throughout its execution + + For basic construction and composition of 'ListT' computations, much can be + accomplished using common typeclass methods. + + * 'return' corresponds to 'yield', yielding a single value. + * ('>>=') corresponds to 'for', calling the second computation once + for each time the first computation 'yield's. + * 'mempty' neither 'yield's any values nor produces any effects in the + base monad. + * ('<>') sequences two computations, 'yield'ing all the values of the + first followed by all the values of the second. + * 'lift' converts an action in the base monad into a ListT computation + which performs the action and 'yield's a single value. + + 'ListT' is a newtype wrapper for 'Producer'. You will likely need to use + 'Select' and 'enumerate' to convert back and forth between these two types + to take advantage of all the 'Producer'-related utilities that + "Pipes.Prelude" has to offer. + + * To lift a plain list into a 'ListT' computation, first apply 'each' + to turn the list into a 'Producer'. Then apply the 'Select' + constructor to convert from 'Producer' to 'ListT'. + * For other ways to construct 'ListT' computations, see the + “Producers” section in "Pipes.Prelude" to build 'Producer's. + These can then be converted to 'ListT' using 'Select'. + * To aggregate the values from a 'ListT' computation (for example, + to compute the sum of a 'ListT' of numbers), first apply + 'enumerate' to obtain a 'Producer'. Then see the “Folds” + section in "Pipes.Prelude" to proceed. -} newtype ListT m a = Select { enumerate :: Producer a m () } -instance (Monad m) => Functor (ListT m) where +instance Functor m => Functor (ListT m) where fmap f p = Select (for (enumerate p) (\a -> yield (f a))) + {-# INLINE fmap #-} -instance (Monad m) => Applicative (ListT m) where +instance Functor m => Applicative (ListT m) where pure a = Select (yield a) + {-# INLINE pure #-} mf <*> mx = Select ( for (enumerate mf) (\f -> for (enumerate mx) (\x -> yield (f x) ) ) ) -instance (Monad m) => Monad (ListT m) where - return a = Select (yield a) +instance Monad m => Monad (ListT m) where + return = pure + {-# INLINE return #-} m >>= f = Select (for (enumerate m) (\a -> enumerate (f a))) + {-# INLINE (>>=) #-} +#if !MIN_VERSION_base(4,13,0) fail _ = mzero + {-# INLINE fail #-} +#endif +instance Monad m => MonadFail (ListT m) where + fail _ = mzero + {-# INLINE fail #-} + +instance Foldable m => Foldable (ListT m) where + foldMap f = go . enumerate + where + go p = case p of + Request v _ -> closed v + Respond a fu -> f a `mappend` go (fu ()) + M m -> F.foldMap go m + Pure _ -> mempty + {-# INLINE foldMap #-} + +instance (Functor m, Traversable m) => Traversable (ListT m) where + traverse k (Select p) = fmap Select (traverse_ p) + where + traverse_ (Request v _ ) = closed v + traverse_ (Respond a fu) = _Respond <$> k a <*> traverse_ (fu ()) + where + _Respond a_ a' = Respond a_ (\_ -> a') + traverse_ (M m ) = fmap M (traverse traverse_ m) + traverse_ (Pure r ) = pure (Pure r) + instance MonadTrans ListT where lift m = Select (do a <- lift m @@ -353,42 +490,62 @@ instance (MonadIO m) => MonadIO (ListT m) where liftIO m = lift (liftIO m) + {-# INLINE liftIO #-} -instance (Monad m) => Alternative (ListT m) where +instance (Functor m) => Alternative (ListT m) where empty = Select (return ()) + {-# INLINE empty #-} p1 <|> p2 = Select (do enumerate p1 enumerate p2 ) instance (Monad m) => MonadPlus (ListT m) where mzero = empty + {-# INLINE mzero #-} mplus = (<|>) + {-# INLINE mplus #-} -#ifndef haskell98 instance MFunctor ListT where hoist morph = Select . hoist morph . enumerate -#endif + {-# INLINE hoist #-} -instance (Monad m) => Monoid (ListT m a) where +instance MMonad ListT where + embed f (Select p0) = Select (loop p0) + where + loop (Request a' fa ) = Request a' (\a -> loop (fa a )) + loop (Respond b fb') = Respond b (\b' -> loop (fb' b')) + loop (M m ) = for (enumerate (fmap loop (f m))) id + loop (Pure r ) = Pure r + {-# INLINE embed #-} + +instance (Functor m) => Semigroup (ListT m a) where + (<>) = (<|>) + {-# INLINE (<>) #-} + +instance (Functor m) => Monoid (ListT m a) where mempty = empty + {-# INLINE mempty #-} +#if !(MIN_VERSION_base(4,11,0)) mappend = (<|>) + {-# INLINE mappend #-} +#endif -#ifndef haskell98 instance (MonadState s m) => MonadState s (ListT m) where get = lift get + {-# INLINE get #-} put s = lift (put s) + {-# INLINE put #-} -#if MIN_VERSION_mtl(2,1,0) state f = lift (state f) -#endif + {-# INLINE state #-} instance (MonadWriter w m) => MonadWriter w (ListT m) where -#if MIN_VERSION_mtl(2,1,0) writer = lift . writer -#endif + {-# INLINE writer #-} tell w = lift (tell w) + {-# INLINE tell #-} listen l = Select (go (enumerate l) mempty) where @@ -409,28 +566,67 @@ M m -> M (do (p', w') <- listen m return (go p' $! mappend w w') ) - Pure r -> Pure r + Pure r -> Pure r instance (MonadReader i m) => MonadReader i (ListT m) where ask = lift ask + {-# INLINE ask #-} local f l = Select (local f (enumerate l)) + {-# INLINE local #-} -#if MIN_VERSION_mtl(2,1,0) reader f = lift (reader f) -#endif + {-# INLINE reader #-} instance (MonadError e m) => MonadError e (ListT m) where throwError e = lift (throwError e) + {-# INLINE throwError #-} catchError l k = Select (catchError (enumerate l) (\e -> enumerate (k e))) -#endif + {-# INLINE catchError #-} +instance MonadThrow m => MonadThrow (ListT m) where + throwM = Select . throwM + {-# INLINE throwM #-} + +instance MonadCatch m => MonadCatch (ListT m) where + catch l k = Select (Control.Monad.Catch.catch (enumerate l) (\e -> enumerate (k e))) + {-# INLINE catch #-} + +instance Monad m => MonadZip (ListT m) where + mzipWith f = go + where + go xs ys = Select $ do + xres <- lift $ next (enumerate xs) + case xres of + Left r -> return r + Right (x, xnext) -> do + yres <- lift $ next (enumerate ys) + case yres of + Left r -> return r + Right (y, ynext) -> do + yield (f x y) + enumerate (go (Select xnext) (Select ynext)) + +-- | Run a self-contained `ListT` computation +runListT :: Monad m => ListT m a -> m () +runListT l = runEffect (enumerate (l >> mzero)) +{-# INLINABLE runListT #-} + {-| 'Enumerable' generalizes 'Data.Foldable.Foldable', converting effectful containers to 'ListT's. + + Instances of 'Enumerable' must satisfy these two laws: + +> toListT (return r) = return r +> +> toListT $ do x <- m = do x <- toListT m +> f x toListT (f x) + + In other words, 'toListT' is monad morphism. -} class Enumerable t where - toListT :: (Monad m) => t m a -> ListT m a + toListT :: Monad m => t m a -> ListT m a instance Enumerable ListT where toListT = id @@ -447,9 +643,9 @@ Nothing -> return () Just a -> yield a -instance Enumerable (ErrorT e) where +instance Enumerable (ExceptT e) where toListT m = Select $ do - x <- lift $ runErrorT m + x <- lift $ runExceptT m case x of Left _ -> return () Right a -> yield a @@ -459,18 +655,23 @@ 'next' either fails with a 'Left' if the 'Producer' terminates or succeeds with a 'Right' providing the next value and the remainder of the 'Producer'. -} -next :: (Monad m) => Producer a m r -> m (Either r (a, Producer a m r)) +next :: Monad m => Producer a m r -> m (Either r (a, Producer a m r)) next = go where go p = case p of - Request v _ -> V.absurd v + Request v _ -> closed v Respond a fu -> return (Right (a, fu ())) M m -> m >>= go Pure r -> return (Left r) {-# INLINABLE next #-} --- | Convert a 'F.Foldable' to a 'Producer' -each :: (Monad m, Foldable f) => f a -> Producer' a m () +{-| Convert a 'F.Foldable' to a 'Producer' + +@ +'each' :: ('Functor' m, 'Foldable' f) => f a -> 'Producer' a m () +@ +-} +each :: (Functor m, Foldable f) => f a -> Proxy x' x () a m () each = F.foldr (\a p -> yield a >> p) (return ()) {-# INLINABLE each #-} {- The above code is the same as: @@ -481,19 +682,24 @@ build/foldr fusion -} --- | Convert an 'Enumerable' to a 'Producer' -every :: (Monad m, Enumerable t) => t m a -> Producer' a m () +{-| Convert an 'Enumerable' to a 'Producer' + +@ +'every' :: ('Monad' m, 'Enumerable' t) => t m a -> 'Producer' a m () +@ +-} +every :: (Monad m, Enumerable t) => t m a -> Proxy x' x () a m () every it = discard >\\ enumerate (toListT it) {-# INLINABLE every #-} -- | Discards a value -discard :: (Monad m) => a -> m () +discard :: Monad m => a -> m () discard _ = return () {-# INLINABLE discard #-} -- | ('>->') with the arguments flipped (<-<) - :: (Monad m) + :: Functor m => Proxy () b c' c m r -- ^ -> Proxy a' a () b m r @@ -503,15 +709,13 @@ {-# INLINABLE (<-<) #-} {- $reexports + "Control.Monad" re-exports 'void' + "Control.Monad.IO.Class" re-exports 'MonadIO'. "Control.Monad.Trans.Class" re-exports 'MonadTrans'. -#ifndef haskell98 "Control.Monad.Morph" re-exports 'MFunctor'. -#endif - "Data.Foldable" re-exports 'Foldable' (the class name only) - - "Data.Void" re-exports 'Void' + "Data.Foldable" re-exports 'Foldable' (the class name only). -} diff --git a/src/Pipes/Core.hs b/src/Pipes/Core.hs --- a/src/Pipes/Core.hs +++ b/src/Pipes/Core.hs @@ -13,12 +13,7 @@ * push-based 'Pipe's. -} -{-# LANGUAGE CPP, RankNTypes #-} - --- The rewrite RULES require the 'TrustWorthy' annotation -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Trustworthy #-} -#endif +{-# LANGUAGE RankNTypes, Trustworthy #-} module Pipes.Core ( -- * Proxy Monad Transformer @@ -58,6 +53,7 @@ , reflect -- * Concrete Type Synonyms + , X , Effect , Producer , Pipe @@ -83,12 +79,10 @@ , (<<+) -- * Re-exports - , module Data.Void + , closed ) where -import Data.Void (Void) -import qualified Data.Void as V -import Pipes.Internal (Proxy(..)) +import Pipes.Internal (Proxy(..), X, closed) {- $proxy Diagrammatically, you can think of a 'Proxy' as having the following shape: @@ -121,12 +115,12 @@ -} -- | Run a self-contained 'Effect', converting it back to the base monad -runEffect :: (Monad m) => Effect m r -> m r +runEffect :: Monad m => Effect m r -> m r runEffect = go where go p = case p of - Request v _ -> V.absurd v - Respond v _ -> V.absurd v + Request v _ -> closed v + Respond v _ -> closed v M m -> m >>= go Pure r -> return r {-# INLINABLE runEffect #-} @@ -222,10 +216,12 @@ (f '/>/' g) '/>/' h = f '/>/' (g '/>/' h) @ +#respond-diagram# + The following diagrams show the flow of information: @ -'respond' :: ('Monad' m) +'respond' :: 'Functor' m => a -> 'Proxy' x' x a' a m a' \ a @@ -237,13 +233,13 @@ x ==> / \\===> a | | | +----|----+ - v + v a' -('/>/') :: ('Monad' m) +('/>/') :: 'Functor' m => (a -> 'Proxy' x' x b' b m a') -> (b -> 'Proxy' x' x c' c m b') - -> (a -> 'Proxy' x' x b' b m a') + -> (a -> 'Proxy' x' x c' c m a') \ a /===> b a | / | | @@ -251,6 +247,23 @@ | v | / | v | | v | x' <== <== b' <==\\ / x'<== <== c' x' <== <== c' | f | X | g | = | f '/>/' g | + x ==> ==> b ===/ \\ x ==> ==> c x ==> ==> c + | | | \\ | | | | | | + +----|----+ \\ +----|----+ +----|----+ + v \\ v v + a' \\==== b' a' + +('//>') :: 'Functor' m + => 'Proxy' x' x b' b m a' + -> (b -> 'Proxy' x' x c' c m b') + -> 'Proxy' x' x c' c m a' + +\ /===> b + / | + +---------+ / +----|----+ +---------+ + | | / | v | | | + x' <== <== b' <==\\ / x'<== <== c' x' <== <== c' + | f | X | g | = | f '//>' g | x ==> ==> b ===/ \\ x ==> ==> c x ==> ==> c' | | | \\ | | | | | | +----|----+ \\ +----|----+ +----|----+ @@ -265,9 +278,9 @@ 'respond' is the identity of the respond category. -} -respond :: (Monad m) => a -> Proxy x' x a' a m a' +respond :: Functor m => a -> Proxy x' x a' a m a' respond a = Respond a Pure -{-# INLINABLE respond #-} +{-# INLINABLE [1] respond #-} {-| Compose two unfolds, creating a new unfold @@ -278,7 +291,7 @@ ('/>/') is the composition operator of the respond category. -} (/>/) - :: (Monad m) + :: Functor m => (a -> Proxy x' x b' b m a') -- ^ -> (b -> Proxy x' x c' c m b') @@ -293,7 +306,7 @@ Point-ful version of ('/>/') -} (//>) - :: (Monad m) + :: Functor m => Proxy x' x b' b m a' -- ^ -> (b -> Proxy x' x c' c m b') @@ -305,9 +318,9 @@ go p = case p of Request x' fx -> Request x' (\x -> go (fx x)) Respond b fb' -> fb b >>= \b' -> go (fb' b') - M m -> M (m >>= \p' -> return (go p')) + M m -> M (go <$> m) Pure a -> Pure a -{-# INLINABLE (//>) #-} +{-# INLINE [1] (//>) #-} {-# RULES "(Request x' fx ) //> fb" forall x' fx fb . @@ -315,7 +328,7 @@ "(Respond b fb') //> fb" forall b fb' fb . (Respond b fb') //> fb = fb b >>= \b' -> fb' b' //> fb; "(M m ) //> fb" forall m fb . - (M m ) //> fb = M (m >>= \p' -> return (p' //> fb)); + (M m ) //> fb = M ((\p' -> p' //> fb) <$> m); "(Pure a ) //> fb" forall a fb . (Pure a ) //> fb = Pure a; #-} @@ -337,10 +350,12 @@ (f '\>\' g) '\>\' h = f '\>\' (g '\>\' h) @ +#request-diagram# + The following diagrams show the flow of information: @ -'request' :: ('Monad' m) +'request' :: 'Functor' m => a' -> 'Proxy' a' a y' y m a \ a' @@ -355,7 +370,7 @@ v a -('\>\') :: ('Monad' m) +('\>\') :: 'Functor' m => (b' -> 'Proxy' a' a y' y m b) -> (c' -> 'Proxy' b' b y' y m c) -> (c' -> 'Proxy' a' a y' y m c) @@ -371,6 +386,23 @@ +----|----+ / +----|----+ +----|----+ v / v v b ======/ c c + +('>\\') :: Functor m + => (b' -> Proxy a' a y' y m b) + -> Proxy b' b y' y m c + -> Proxy a' a y' y m c + +\ b'<=====\\ + | \\ + +----|----+ \\ +---------+ +---------+ + | v | \\ | | | | + a' <== <== y' \\== b' <== <== y' a' <== <== y' + | f | | g | = | f '>\\' g | + a ==> ==> y /=> b ==> ==> y a ==> ==> y + | | | / | | | | | | + +----|----+ / +----|----+ +----|----+ + v / v v + b ======/ c c @ -} @@ -378,9 +410,9 @@ 'request' is the identity of the request category. -} -request :: (Monad m) => a' -> Proxy a' a y' y m a +request :: Functor m => a' -> Proxy a' a y' y m a request a' = Request a' Pure -{-# INLINABLE request #-} +{-# INLINABLE [1] request #-} {-| Compose two folds, creating a new fold @@ -391,7 +423,7 @@ ('\>\') is the composition operator of the request category. -} (\>\) - :: (Monad m) + :: Functor m => (b' -> Proxy a' a y' y m b) -- ^ -> (c' -> Proxy b' b y' y m c) @@ -406,7 +438,7 @@ Point-ful version of ('\>\') -} (>\\) - :: (Monad m) + :: Functor m => (b' -> Proxy a' a y' y m b) -- ^ -> Proxy b' b y' y m c @@ -418,9 +450,9 @@ go p = case p of Request b' fb -> fb' b' >>= \b -> go (fb b) Respond x fx' -> Respond x (\x' -> go (fx' x')) - M m -> M (m >>= \p' -> return (go p')) + M m -> M (go <$> m) Pure a -> Pure a -{-# INLINABLE (>\\) #-} +{-# INLINE [1] (>\\) #-} {-# RULES "fb' >\\ (Request b' fb )" forall fb' b' fb . @@ -428,7 +460,7 @@ "fb' >\\ (Respond x fx')" forall fb' x fx' . fb' >\\ (Respond x fx') = Respond x (\x' -> fb' >\\ fx' x'); "fb' >\\ (M m )" forall fb' m . - fb' >\\ (M m ) = M (m >>= \p' -> return (fb' >\\ p')); + fb' >\\ (M m ) = M ((\p' -> fb' >\\ p') <$> m); "fb' >\\ (Pure a )" forall fb' a . fb' >\\ (Pure a ) = Pure a; #-} @@ -453,7 +485,7 @@ The following diagram shows the flow of information: @ -'push' :: ('Monad' m) +'push' :: 'Functor' m => a -> 'Proxy' a' a a' a m r \ a @@ -468,7 +500,7 @@ v r -('>~>') :: ('Monad' m) +('>~>') :: 'Functor' m => (a -> 'Proxy' a' a b' b m r) -> (b -> 'Proxy' b' b c' c m r) -> (a -> 'Proxy' a' a c' c m r) @@ -496,11 +528,11 @@ 'push' is the identity of the push category. -} -push :: (Monad m) => a -> Proxy a' a a' a m r +push :: Functor m => a -> Proxy a' a a' a m r push = go where go a = Respond a (\a' -> Request a' go) -{-# INLINABLE push #-} +{-# INLINABLE [1] push #-} {-| Compose two proxies blocked while 'request'ing data, creating a new proxy blocked while 'request'ing data @@ -512,7 +544,7 @@ ('>~>') is the composition operator of the push category. -} (>~>) - :: (Monad m) + :: Functor m => (_a -> Proxy a' a b' b m r) -- ^ -> ( b -> Proxy b' b c' c m r) @@ -522,12 +554,12 @@ (fa >~> fb) a = fa a >>~ fb {-# INLINABLE (>~>) #-} -{-| @(p >>~ f)@ pairs each 'respond' in @p@ with an 'request' in @f@. +{-| @(p >>~ f)@ pairs each 'respond' in @p@ with a 'request' in @f@. Point-ful version of ('>~>') -} (>>~) - :: (Monad m) + :: Functor m => Proxy a' a b' b m r -- ^ -> (b -> Proxy b' b c' c m r) @@ -537,9 +569,9 @@ p >>~ fb = case p of Request a' fa -> Request a' (\a -> fa a >>~ fb) Respond b fb' -> fb' +>> fb b - M m -> M (m >>= \p' -> return (p' >>~ fb)) + M m -> M ((\p' -> p' >>~ fb) <$> m) Pure r -> Pure r -{-# INLINABLE (>>~) #-} +{-# INLINE [1] (>>~) #-} {- $pull The 'pull' category closely corresponds to pull-based Unix pipes. @@ -558,10 +590,12 @@ (f '>+>' g) '>+>' h = f '>+>' (g '>+>' h) @ +#pull-diagram# + The following diagrams show the flow of information: @ -'pull' :: ('Monad' m) +'pull' :: 'Functor' m => a' -> 'Proxy' a' a a' a m r \ a' @@ -576,7 +610,7 @@ v r -('>+>') :: ('Monad' m) +('>+>') :: 'Functor' m -> (b' -> 'Proxy' a' a b' b m r) -> (c' -> 'Proxy' b' b c' c m r) -> (c' -> 'Proxy' a' a c' c m r) @@ -604,11 +638,11 @@ 'pull' is the identity of the pull category. -} -pull :: (Monad m) => a' -> Proxy a' a a' a m r +pull :: Functor m => a' -> Proxy a' a a' a m r pull = go where go a' = Request a' (\a -> Respond a go) -{-# INLINABLE pull #-} +{-# INLINABLE [1] pull #-} {-| Compose two proxies blocked in the middle of 'respond'ing, creating a new proxy blocked in the middle of 'respond'ing @@ -620,7 +654,7 @@ ('>+>') is the composition operator of the pull category. -} (>+>) - :: (Monad m) + :: Functor m => ( b' -> Proxy a' a b' b m r) -- ^ -> (_c' -> Proxy b' b c' c m r) @@ -635,7 +669,7 @@ Point-ful version of ('>+>') -} (+>>) - :: (Monad m) + :: Functor m => (b' -> Proxy a' a b' b m r) -- ^ -> Proxy b' b c' c m r @@ -645,9 +679,9 @@ fb' +>> p = case p of Request b' fb -> fb' b' >>~ fb Respond c fc' -> Respond c (\c' -> fb' +>> fc' c') - M m -> M (m >>= \p' -> return (fb' +>> p')) + M m -> M ((\p' -> fb' +>> p') <$> m) Pure r -> Pure r -{-# INLINABLE (+>>) #-} +{-# INLINABLE [1] (+>>) #-} {- $reflect @(reflect .)@ transforms each streaming category into its dual: @@ -682,13 +716,13 @@ -} -- | Switch the upstream and downstream ends -reflect :: (Monad m) => Proxy a' a b' b m r -> Proxy b b' a a' m r +reflect :: Functor m => Proxy a' a b' b m r -> Proxy b b' a a' m r reflect = go where go p = case p of Request a' fa -> Respond a' (\a -> go (fa a )) Respond b fb' -> Request b (\b' -> go (fb' b')) - M m -> M (m >>= \p' -> return (go p')) + M m -> M (go <$> m) Pure r -> Pure r {-# INLINABLE reflect #-} @@ -696,30 +730,30 @@ 'Effect's neither 'Pipes.await' nor 'Pipes.yield' -} -type Effect = Proxy Void () () Void +type Effect = Proxy X () () X -- | 'Producer's can only 'Pipes.yield' -type Producer b = Proxy Void () () b +type Producer b = Proxy X () () b -- | 'Pipe's can both 'Pipes.await' and 'Pipes.yield' type Pipe a b = Proxy () a () b -- | 'Consumer's can only 'Pipes.await' -type Consumer a = Proxy () a () Void +type Consumer a = Proxy () a () X {-| @Client a' a@ sends requests of type @a'@ and receives responses of type @a@. 'Client's only 'request' and never 'respond'. -} -type Client a' a = Proxy a' a () Void +type Client a' a = Proxy a' a () X {-| @Server b' b@ receives requests of type @b'@ and sends responses of type @b@. 'Server's only 'respond' and never 'request'. -} -type Server b' b = Proxy Void () b' b +type Server b' b = Proxy X () b' b -- | Like 'Effect', but with a polymorphic type type Effect' m r = forall x' x y' y . Proxy x' x y' y m r @@ -738,7 +772,7 @@ -- | Equivalent to ('/>/') with the arguments flipped (\<\) - :: (Monad m) + :: Functor m => (b -> Proxy x' x c' c m b') -- ^ -> (a -> Proxy x' x b' b m a') @@ -750,7 +784,7 @@ -- | Equivalent to ('\>\') with the arguments flipped (/ (c' -> Proxy b' b x' x m c) -- ^ -> (b' -> Proxy a' a x' x m b) @@ -762,7 +796,7 @@ -- | Equivalent to ('>~>') with the arguments flipped (<~<) - :: (Monad m) + :: Functor m => (b -> Proxy b' b c' c m r) -- ^ -> (a -> Proxy a' a b' b m r) @@ -774,7 +808,7 @@ -- | Equivalent to ('>+>') with the arguments flipped (<+<) - :: (Monad m) + :: Functor m => (c' -> Proxy b' b c' c m r) -- ^ -> (b' -> Proxy a' a b' b m r) @@ -786,7 +820,7 @@ -- | Equivalent to ('//>') with the arguments flipped (<\\) - :: (Monad m) + :: Functor m => (b -> Proxy x' x c' c m b') -- ^ -> Proxy x' x b' b m a' @@ -798,7 +832,7 @@ -- | Equivalent to ('>\\') with the arguments flipped (//<) - :: (Monad m) + :: Functor m => Proxy b' b y' y m c -- ^ -> (b' -> Proxy a' a y' y m b) @@ -810,7 +844,7 @@ -- | Equivalent to ('>>~') with the arguments flipped (~<<) - :: (Monad m) + :: Functor m => (b -> Proxy b' b c' c m r) -- ^ -> Proxy a' a b' b m r @@ -822,7 +856,7 @@ -- | Equivalent to ('+>>') with the arguments flipped (<<+) - :: (Monad m) + :: Functor m => Proxy b' b c' c m r -- ^ -> (b' -> Proxy a' a b' b m r) @@ -833,20 +867,28 @@ {-# INLINABLE (<<+) #-} {-# RULES - "(p //> f) //> g" forall p f g . (p //> f) //> g = p //> (\a -> f a //> g) + "(p //> f) //> g" forall p f g . (p //> f) //> g = p //> (\x -> f x //> g) ; "p //> respond" forall p . p //> respond = p ; "respond x //> f" forall x f . respond x //> f = f x - ; "f >\\ (g >\\ p)" forall f g p . f >\\ (g >\\ p) = (\a -> f >\\ g a) >\\ p + ; "f >\\ (g >\\ p)" forall f g p . f >\\ (g >\\ p) = (\x -> f >\\ g x) >\\ p ; "request >\\ p" forall p . request >\\ p = p ; "f >\\ request x" forall f x . f >\\ request x = f x - #-} + ; "(p >>~ f) >>~ g" forall p f g . (p >>~ f) >>~ g = p >>~ (\x -> f x >>~ g) -{- $reexports - @Data.Void@ re-exports the 'Void' type --} + ; "p >>~ push" forall p . p >>~ push = p + + ; "push x >>~ f" forall x f . push x >>~ f = f x + + ; "f +>> (g +>> p)" forall f g p . f +>> (g +>> p) = (\x -> f +>> g x) +>> p + + ; "pull +>> p" forall p . pull +>> p = p + + ; "f +>> pull x" forall f x . f +>> pull x = f x + + #-} diff --git a/src/Pipes/Internal.hs b/src/Pipes/Internal.hs --- a/src/Pipes/Internal.hs +++ b/src/Pipes/Internal.hs @@ -18,39 +18,42 @@ any functions which can violate the monad transformer laws. -} -{-# LANGUAGE - FlexibleInstances - , MultiParamTypeClasses - , RankNTypes - , UndecidableInstances - , CPP - #-} - --- The rewrite RULES require the 'TrustWorthy' annotation -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Trustworthy #-} -#endif +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE Trustworthy #-} module Pipes.Internal ( -- * Internal Proxy(..) , unsafeHoist - , observe, + , observe + , X + , closed ) where -import Control.Applicative (Applicative(pure, (<*>)), Alternative(empty, (<|>))) -import Control.Monad (MonadPlus(..)) +import qualified Control.Monad.Fail as F (MonadFail(fail)) import Control.Monad.IO.Class (MonadIO(liftIO)) import Control.Monad.Trans.Class (MonadTrans(lift)) -#ifndef haskell98 -import Control.Monad.Morph (MFunctor(hoist)) -import Control.Monad.Error (MonadError(..)) +import Control.Monad.Morph (MFunctor(hoist), MMonad(embed)) +import Control.Monad.Except (MonadError(..)) +import Control.Monad.Catch (MonadThrow(..), MonadCatch(..)) import Control.Monad.Reader (MonadReader(..)) import Control.Monad.State (MonadState(..)) -import Control.Monad.Writer (MonadWriter(..)) -import Data.Monoid (mempty,mappend) +import Control.Monad.Writer (MonadWriter(..), censor) +import Data.Void (Void) + +#if MIN_VERSION_base(4,8,0) +import Control.Applicative (Alternative(..)) +#else +import Control.Applicative #endif +import Data.Semigroup +import qualified Data.Void + {-| A 'Proxy' is a monad transformer that receives and sends information on both an upstream and downstream interface. @@ -72,29 +75,35 @@ | M (m (Proxy a' a b' b m r)) | Pure r -instance (Monad m) => Functor (Proxy a' a b' b m) where +instance Functor m => Functor (Proxy a' a b' b m) where fmap f p0 = go p0 where go p = case p of Request a' fa -> Request a' (\a -> go (fa a )) Respond b fb' -> Respond b (\b' -> go (fb' b')) - M m -> M (m >>= \p' -> return (go p')) + M m -> M (go <$> m) Pure r -> Pure (f r) -instance (Monad m) => Applicative (Proxy a' a b' b m) where +instance Functor m => Applicative (Proxy a' a b' b m) where pure = Pure pf <*> px = go pf where go p = case p of Request a' fa -> Request a' (\a -> go (fa a )) Respond b fb' -> Respond b (\b' -> go (fb' b')) - M m -> M (m >>= \p' -> return (go p')) - Pure f -> fmap f px + M m -> M (go <$> m) + Pure f -> fmap f px + l *> r = go l where + go p = case p of + Request a' fa -> Request a' (\a -> go (fa a )) + Respond b fb' -> Respond b (\b' -> go (fb' b')) + M m -> M (go <$> m) + Pure _ -> r -instance (Monad m) => Monad (Proxy a' a b' b m) where - return = Pure +instance Functor m => Monad (Proxy a' a b' b m) where + return = pure (>>=) = _bind _bind - :: (Monad m) + :: Functor m => Proxy a' a b' b m r -> (r -> Proxy a' a b' b m r') -> Proxy a' a b' b m r' @@ -102,8 +111,9 @@ go p = case p of Request a' fa -> Request a' (\a -> go (fa a )) Respond b fb' -> Respond b (\b' -> go (fb' b')) - M m -> M (m >>= \p' -> return (go p')) - Pure r -> f r + M m -> M (go <$> m) + Pure r -> f r +{-# NOINLINE[1] _bind #-} {-# RULES "_bind (Request a' k) f" forall a' k f . @@ -111,13 +121,27 @@ "_bind (Respond b k) f" forall b k f . _bind (Respond b k) f = Respond b (\b' -> _bind (k b') f); "_bind (M m) f" forall m f . - _bind (M m) f = M (m >>= \p -> return (_bind p f)); + _bind (M m) f = M ((\p -> _bind p f) <$> m); "_bind (Pure r ) f" forall r f . _bind (Pure r ) f = f r; #-} +instance (Functor m, Semigroup r) => Semigroup (Proxy a' a b' b m r) where + p1 <> p2 = go p1 where + go p = case p of + Request a' fa -> Request a' (\a -> go (fa a )) + Respond b fb' -> Respond b (\b' -> go (fb' b')) + M m -> M (go <$> m) + Pure r1 -> fmap (r1 <>) p2 + +instance (Functor m, Monoid r, Semigroup r) => Monoid (Proxy a' a b' b m r) where + mempty = Pure mempty +#if !(MIN_VERSION_base(4,11,0)) + mappend = (<>) +#endif + instance MonadTrans (Proxy a' a b' b) where - lift m = M (m >>= \r -> return (Pure r)) + lift m = M (Pure <$> m) {-| 'unsafeHoist' is like 'hoist', but faster. @@ -126,32 +150,42 @@ safe if you pass a monad morphism as the first argument. -} unsafeHoist - :: (Monad m) + :: Functor m => (forall x . m x -> n x) -> Proxy a' a b' b m r -> Proxy a' a b' b n r unsafeHoist nat = go where go p = case p of Request a' fa -> Request a' (\a -> go (fa a )) Respond b fb' -> Respond b (\b' -> go (fb' b')) - M m -> M (nat (m >>= \p' -> return (go p'))) - Pure r -> Pure r + M m -> M (nat (go <$> m)) + Pure r -> Pure r {-# INLINABLE unsafeHoist #-} -#ifndef haskell98 instance MFunctor (Proxy a' a b' b) where - hoist nat p0 = go (observe p0) where + hoist nat p0 = go (observe p0) + where go p = case p of Request a' fa -> Request a' (\a -> go (fa a )) Respond b fb' -> Respond b (\b' -> go (fb' b')) - M m -> M (nat (m >>= \p' -> return (go p'))) - Pure r -> Pure r -#endif + M m -> M (nat (go <$> m)) + Pure r -> Pure r -instance (MonadIO m) => MonadIO (Proxy a' a b' b m) where - liftIO m = M (liftIO (m >>= \r -> return (Pure r))) +instance MMonad (Proxy a' a b' b) where + embed f = go + where + go p = case p of + Request a' fa -> Request a' (\a -> go (fa a )) + Respond b fb' -> Respond b (\b' -> go (fb' b')) + M m -> f m >>= go + Pure r -> Pure r -#ifndef haskell98 -instance (MonadReader r m) => MonadReader r (Proxy a' a b' b m) where +instance F.MonadFail m => F.MonadFail (Proxy a' a b' b m) where + fail = lift . F.fail + +instance MonadIO m => MonadIO (Proxy a' a b' b m) where + liftIO m = M (liftIO (Pure <$> m)) + +instance MonadReader r m => MonadReader r (Proxy a' a b' b m) where ask = lift ask local f = go where @@ -159,22 +193,16 @@ Request a' fa -> Request a' (\a -> go (fa a )) Respond b fb' -> Respond b (\b' -> go (fb' b')) Pure r -> Pure r - M m -> M (local f m >>= \r -> return (go r)) -#if MIN_VERSION_mtl(2,1,0) + M m -> M (go <$> local f m) reader = lift . reader -#endif -instance (MonadState s m) => MonadState s (Proxy a' a b' b m) where +instance MonadState s m => MonadState s (Proxy a' a b' b m) where get = lift get put = lift . put -#if MIN_VERSION_mtl(2,1,0) state = lift . state -#endif -instance (MonadWriter w m) => MonadWriter w (Proxy a' a b' b m) where -#if MIN_VERSION_mtl(2,1,0) +instance MonadWriter w m => MonadWriter w (Proxy a' a b' b m) where writer = lift . writer -#endif tell = lift . tell listen p0 = go p0 mempty where @@ -192,11 +220,11 @@ Request a' fa -> Request a' (\a -> go (fa a ) w) Respond b fb' -> Respond b (\b' -> go (fb' b') w) M m -> M (do - (p', w') <- listen m + (p', w') <- censor (const mempty) (listen m) return (go p' $! mappend w w') ) - Pure (r, f) -> M (pass (return (Pure r, \_ -> f w))) + Pure (r, f) -> M (pass (return (Pure r, \_ -> f w))) -instance (MonadError e m) => MonadError e (Proxy a' a b' b m) where +instance MonadError e m => MonadError e (Proxy a' a b' b m) where throwError = lift . throwError catchError p0 f = go p0 where @@ -207,15 +235,13 @@ M m -> M ((do p' <- m return (go p') ) `catchError` (\e -> return (f e)) ) -#endif -instance (MonadPlus m) => Alternative (Proxy a' a b' b m) where - empty = mzero - (<|>) = mplus +instance MonadThrow m => MonadThrow (Proxy a' a b' b m) where + throwM = lift . throwM + {-# INLINE throwM #-} -instance (MonadPlus m) => MonadPlus (Proxy a' a b' b m) where - mzero = lift mzero - mplus p0 p1 = go p0 +instance MonadCatch m => MonadCatch (Proxy a' a b' b m) where + catch p0 f = go p0 where go p = case p of Request a' fa -> Request a' (\a -> go (fa a )) @@ -223,7 +249,7 @@ Pure r -> Pure r M m -> M ((do p' <- m - return (go p') ) `mplus` return p1 ) + return (go p') ) `Control.Monad.Catch.catch` (\e -> return (f e)) ) {-| The monad transformer laws are correct when viewed through the 'observe' function: @@ -240,7 +266,7 @@ This function is a convenience for low-level @pipes@ implementers. You do not need to use 'observe' if you stick to the safe API. -} -observe :: (Monad m) => Proxy a' a b' b m r -> Proxy a' a b' b m r +observe :: Monad m => Proxy a' a b' b m r -> Proxy a' a b' b m r observe p0 = M (go p0) where go p = case p of Request a' fa -> return (Request a' (\a -> observe (fa a ))) @@ -248,3 +274,11 @@ M m' -> m' >>= go Pure r -> return (Pure r) {-# INLINABLE observe #-} + +-- | The empty type, used to close output ends +type X = Void + +-- | Use 'closed' to \"handle\" impossible outputs +closed :: X -> a +closed = Data.Void.absurd +{-# INLINABLE closed #-} diff --git a/src/Pipes/Lift.hs b/src/Pipes/Lift.hs --- a/src/Pipes/Lift.hs +++ b/src/Pipes/Lift.hs @@ -1,109 +1,120 @@ +{-# LANGUAGE CPP #-} + {-| Many actions in base monad transformers cannot be automatically 'Control.Monad.Trans.Class.lift'ed. These functions lift these remaining actions so that they work in the 'Proxy' monad transformer. --} -{-# LANGUAGE CPP #-} + See the mini-tutorial at the bottom of this module for example code and + typical use cases where this module will come in handy. +-} module Pipes.Lift ( - -- * ErrorT - errorP -#ifndef haskell98 - , runErrorP + -- * Utilities + distribute + + -- * ExceptT + , exceptP + , runExceptP , catchError -#endif , liftCatchError -- * MaybeT , maybeP -#ifndef haskell98 , runMaybeP -#endif -- * ReaderT , readerP -#ifndef haskell98 , runReaderP -#endif -- * StateT , stateP -#ifndef haskell98 , runStateP , evalStateP , execStateP -#endif -- * WriterT -- $writert , writerP -#ifndef haskell98 , runWriterP , execWriterP -#endif -- * RWST , rwsP -#ifndef haskell98 , runRWSP , evalRWSP , execRWSP - -- * Utilities - , distribute -#endif - + -- * Tutorial + -- $tutorial ) where import Control.Monad.Trans.Class (lift, MonadTrans(..)) -import qualified Control.Monad.Trans.Error as E +import qualified Control.Monad.Trans.Except as E import qualified Control.Monad.Trans.Maybe as M import qualified Control.Monad.Trans.Reader as R import qualified Control.Monad.Trans.State.Strict as S import qualified Control.Monad.Trans.Writer.Strict as W import qualified Control.Monad.Trans.RWS.Strict as RWS -import Data.Monoid (Monoid) import Pipes.Internal (Proxy(..), unsafeHoist) -#ifndef haskell98 import Control.Monad.Morph (hoist, MFunctor(..)) import Pipes.Core (runEffect, request, respond, (//>), (>\\)) + +#if MIN_VERSION_base(4,8,0) +#else +import Data.Monoid #endif --- | Wrap the base monad in 'E.ErrorT' -errorP - :: (Monad m, E.Error e) +-- | Distribute 'Proxy' over a monad transformer +distribute + :: ( Monad m + , MonadTrans t + , MFunctor t + , Monad (t m) + , Monad (t (Proxy a' a b' b m)) + ) + => Proxy a' a b' b (t m) r + -- ^ + -> t (Proxy a' a b' b m) r + -- ^ +distribute p = runEffect $ request' >\\ unsafeHoist (hoist lift) p //> respond' + where + request' = lift . lift . request + respond' = lift . lift . respond +{-# INLINABLE distribute #-} + +-- | Wrap the base monad in 'E.ExceptT' +exceptP + :: Monad m => Proxy a' a b' b m (Either e r) - -> Proxy a' a b' b (E.ErrorT e m) r -errorP p = do + -> Proxy a' a b' b (E.ExceptT e m) r +exceptP p = do x <- unsafeHoist lift p - lift $ E.ErrorT (return x) -{-# INLINABLE errorP #-} + lift $ E.ExceptT (return x) +{-# INLINABLE exceptP #-} -#ifndef haskell98 --- | Run 'E.ErrorT' in the base monad -runErrorP - :: (Monad m, E.Error e) - => Proxy a' a b' b (E.ErrorT e m) r +-- | Run 'E.ExceptT' in the base monad +runExceptP + :: Monad m + => Proxy a' a b' b (E.ExceptT e m) r -> Proxy a' a b' b m (Either e r) -runErrorP = E.runErrorT . distribute -{-# INLINABLE runErrorP #-} +runExceptP = E.runExceptT . distribute +{-# INLINABLE runExceptP #-} -- | Catch an error in the base monad catchError - :: (Monad m, E.Error e) - => Proxy a' a b' b (E.ErrorT e m) r + :: Monad m + => Proxy a' a b' b (E.ExceptT e m) r -- ^ - -> (e -> Proxy a' a b' b (E.ErrorT e m) r) + -> (e -> Proxy a' a b' b (E.ExceptT e m) r) -- ^ - -> Proxy a' a b' b (E.ErrorT e m) r -catchError e h = errorP . E.runErrorT $ - E.catchError (distribute e) (distribute . h) + -> Proxy a' a b' b (E.ExceptT e m) r +catchError e h = exceptP . E.runExceptT $ + E.catchE (distribute e) (distribute . h) {-# INLINABLE catchError #-} -#endif -- | Catch an error using a catch function for the base monad liftCatchError - :: (Monad m) + :: Monad m => ( m (Proxy a' a b' b m r) -> (e -> m (Proxy a' a b' b m r)) -> m (Proxy a' a b' b m r) ) @@ -125,46 +136,42 @@ -- | Wrap the base monad in 'M.MaybeT' maybeP - :: (Monad m) + :: Monad m => Proxy a' a b' b m (Maybe r) -> Proxy a' a b' b (M.MaybeT m) r maybeP p = do x <- unsafeHoist lift p lift $ M.MaybeT (return x) {-# INLINABLE maybeP #-} -#ifndef haskell98 -- | Run 'M.MaybeT' in the base monad runMaybeP - :: (Monad m) + :: Monad m => Proxy a' a b' b (M.MaybeT m) r -> Proxy a' a b' b m (Maybe r) runMaybeP p = M.runMaybeT $ distribute p {-# INLINABLE runMaybeP #-} -#endif -- | Wrap the base monad in 'R.ReaderT' readerP - :: (Monad m) + :: Monad m => (i -> Proxy a' a b' b m r) -> Proxy a' a b' b (R.ReaderT i m) r readerP k = do i <- lift R.ask unsafeHoist lift (k i) {-# INLINABLE readerP #-} -#ifndef haskell98 -- | Run 'R.ReaderT' in the base monad runReaderP - :: (Monad m) + :: Monad m => i -> Proxy a' a b' b (R.ReaderT i m) r -> Proxy a' a b' b m r runReaderP r p = (`R.runReaderT` r) $ distribute p {-# INLINABLE runReaderP #-} -#endif -- | Wrap the base monad in 'S.StateT' stateP - :: (Monad m) + :: Monad m => (s -> Proxy a' a b' b m (r, s)) -> Proxy a' a b' b (S.StateT s m) r stateP k = do s <- lift S.get @@ -173,10 +180,9 @@ return r {-# INLINABLE stateP #-} -#ifndef haskell98 -- | Run 'S.StateT' in the base monad runStateP - :: (Monad m) + :: Monad m => s -> Proxy a' a b' b (S.StateT s m) r -> Proxy a' a b' b m (r, s) @@ -185,7 +191,7 @@ -- | Evaluate 'S.StateT' in the base monad evalStateP - :: (Monad m) + :: Monad m => s -> Proxy a' a b' b (S.StateT s m) r -> Proxy a' a b' b m r @@ -194,13 +200,12 @@ -- | Execute 'S.StateT' in the base monad execStateP - :: (Monad m) + :: Monad m => s -> Proxy a' a b' b (S.StateT s m) r -> Proxy a' a b' b m s execStateP s p = fmap snd $ runStateP s p {-# INLINABLE execStateP #-} -#endif {- $writert Note that 'runWriterP' and 'execWriterP' will keep the accumulator in @@ -223,10 +228,9 @@ return r {-# INLINABLE writerP #-} -#ifndef haskell98 -- | Run 'W.WriterT' in the base monad runWriterP - :: (Monad m, Data.Monoid.Monoid w) + :: (Monad m, Monoid w) => Proxy a' a b' b (W.WriterT w m) r -> Proxy a' a b' b m (r, w) runWriterP p = W.runWriterT $ distribute p @@ -234,12 +238,11 @@ -- | Execute 'W.WriterT' in the base monad execWriterP - :: (Monad m, Data.Monoid.Monoid w) + :: (Monad m, Monoid w) => Proxy a' a b' b (W.WriterT w m) r -> Proxy a' a b' b m w execWriterP p = fmap snd $ runWriterP p {-# INLINABLE execWriterP #-} -#endif -- | Wrap the base monad in 'RWS.RWST' rwsP @@ -256,7 +259,6 @@ return r {-# INLINABLE rwsP #-} -#ifndef haskell98 -- | Run 'RWS.RWST' in the base monad runRWSP :: (Monad m, Monoid w) @@ -291,21 +293,94 @@ f x = let (_, s', w) = x in (s', w) {-# INLINABLE execRWSP #-} --- | Distribute 'Proxy' over a monad transformer -distribute - :: ( Monad m - , MonadTrans t - , MFunctor t - , Monad (t m) - , Monad (t (Proxy a' a b' b m)) - ) - => Proxy a' a b' b (t m) r - -- ^ - -> t (Proxy a' a b' b m) r - -- ^ -distribute p = runEffect $ request' >\\ unsafeHoist (hoist lift) p //> respond' - where - request' = lift . lift . request - respond' = lift . lift . respond -{-# INLINABLE distribute #-} -#endif +{- $tutorial + Probably the most useful functionality in this module is lifted error + handling. Suppose that you have a 'Pipes.Pipe' whose base monad can fail + using 'E.ExceptT': + +> import Control.Monad.Trans.Error +> import Pipes +> +> example :: Monad m => Pipe Int Int (ExceptT String m) r +> example = for cat $ \n -> +> if n == 0 +> then lift $ throwError "Zero is forbidden" +> else yield n + + Without the tools in this module you cannot recover from any potential error + until after you compose and run the pipeline: + +>>> import qualified Pipes.Prelude as P +>>> runExceptT $ runEffect $ P.readLn >-> example >-> P.print +42 +42 +1 +1 +0 +Zero is forbidden +>>> + + This module provides `catchError`, which lets you catch and recover from + errors inside the 'Pipe': + +> import qualified Pipes.Lift as Lift +> +> caught :: Pipe Int Int (ExceptT String IO) r +> caught = example `Lift.catchError` \str -> do +> liftIO (putStrLn str) +> caught + + This lets you resume streaming in the face of errors raised within the base + monad: + +>>> runExceptT $ runEffect $ P.readLn >-> caught >-> P.print +0 +Zero is forbidden +42 +42 +0 +Zero is forbidden +1 +1 +... + + Another common use case is running a base monad before running the pipeline. + For example, the following contrived 'Producer' uses 'S.StateT' gratuitously + to increment numbers: + +> import Control.Monad (forever) +> import Control.Monad.Trans.State.Strict +> import Pipes +> +> numbers :: Monad m => Producer Int (StateT Int m) r +> numbers = forever $ do +> n <- lift get +> yield n +> lift $ put $! n + 1 + + You can run the 'StateT' monad by supplying an initial state, before you + ever compose the 'Producer': + +> import Pipes.Lift +> +> naturals :: Monad m => Producer Int m r +> naturals = evalStateP 0 numbers + + This deletes 'StateT' from the base monad entirely, give you a completely + pure 'Pipes.Producer': + +>>> Pipes.Prelude.toList naturals +[0,1,2,3,4,5,6...] + + Note that the convention for the 'S.StateT' run functions is backwards from + @transformers@ for convenience: the initial state is the first argument. + + All of these functions internally use 'distribute', which can pull out most + monad transformers from the base monad. For example, 'evalStateP' is + defined in terms of 'distribute': + +> evalStateP s p = evalStateT (distribute p) s + + Therefore you can use 'distribute' to run other monad transformers, too, as + long as they implement the 'MFunctor' type class from the @mmorph@ library. +-} diff --git a/src/Pipes/Prelude.hs b/src/Pipes/Prelude.hs --- a/src/Pipes/Prelude.hs +++ b/src/Pipes/Prelude.hs @@ -16,37 +16,41 @@ newlines. -} -{-# LANGUAGE RankNTypes, CPP #-} +{-# LANGUAGE RankNTypes, Trustworthy #-} {-# OPTIONS_GHC -fno-warn-unused-do-bind #-} --- The rewrite RULES require the 'TrustWorthy' annotation -#if __GLASGOW_HASKELL__ >= 702 -{-# LANGUAGE Trustworthy #-} -#endif - module Pipes.Prelude ( -- * Producers -- $producers stdinLn , readLn , fromHandle + , repeatM , replicateM + , unfoldr -- * Consumers -- $consumers , stdoutLn + , stdoutLn' + , mapM_ , print , toHandle + , drain -- * Pipes -- $pipes , map , mapM + , sequence , mapFoldable , filter + , mapMaybe , filterM + , wither , take , takeWhile + , takeWhile' , drop , dropWhile , concat @@ -57,11 +61,17 @@ , chain , read , show + , seq + -- *ListT + , loop + -- * Folds -- $folds , fold + , fold' , foldM + , foldM' , all , any , and @@ -81,31 +91,29 @@ , product , toList , toListM + , toListM' -- * Zips , zip , zipWith -#ifndef haskell98 + -- * Utilities , tee , generalize -#endif ) where import Control.Exception (throwIO, try) -import Control.Monad (liftM, replicateM_, when, unless) +import Control.Monad (liftM, when, unless, (>=>)) +import Control.Monad.Trans.State.Strict (get, put) import Data.Functor.Identity (Identity, runIdentity) -import Data.Void (absurd) import Foreign.C.Error (Errno(Errno), ePIPE) -import qualified GHC.IO.Exception as G +import GHC.Exts (build) import Pipes import Pipes.Core import Pipes.Internal -import qualified System.IO as IO -#ifndef haskell98 -import Control.Monad.Trans.State.Strict (get, put) import Pipes.Lift (evalStateP) -#endif +import qualified GHC.IO.Exception as G +import qualified System.IO as IO import qualified Prelude import Prelude hiding ( all @@ -121,6 +129,7 @@ , length , map , mapM + , mapM_ , maximum , minimum , notElem @@ -130,7 +139,9 @@ , product , read , readLn + , sequence , show + , seq , sum , take , takeWhile @@ -161,20 +172,24 @@ Terminates on end of input -} -stdinLn :: (MonadIO m) => Producer' String m () +stdinLn :: MonadIO m => Producer' String m () stdinLn = fromHandle IO.stdin {-# INLINABLE stdinLn #-} -- | 'read' values from 'IO.stdin', ignoring failed parses -readLn :: (MonadIO m) => (Read a) => Producer' a m () +readLn :: (MonadIO m, Read a) => Producer' a m () readLn = stdinLn >-> read {-# INLINABLE readLn #-} {-| Read 'String's from a 'IO.Handle' using 'IO.hGetLine' Terminates on end of input + +@ +'fromHandle' :: 'MonadIO' m => 'IO.Handle' -> 'Producer' 'String' m () +@ -} -fromHandle :: (MonadIO m) => IO.Handle -> Producer' String m () +fromHandle :: MonadIO m => IO.Handle -> Proxy x' x () String m () fromHandle h = go where go = do @@ -185,8 +200,29 @@ go {-# INLINABLE fromHandle #-} --- | Repeat a monadic action a fixed number of times, 'yield'ing each result -replicateM :: (Monad m) => Int -> m a -> Producer a m () +{-| Repeat a monadic action indefinitely, 'yield'ing each result + +'repeatM' :: 'Monad' m => m a -> 'Producer' a m r +-} +repeatM :: Monad m => m a -> Proxy x' x () a m r +repeatM m = lift m >~ cat +{-# INLINABLE [1] repeatM #-} + +{-# RULES + "repeatM m >-> p" forall m p . repeatM m >-> p = lift m >~ p + #-} + +{-| Repeat a monadic action a fixed number of times, 'yield'ing each result + +> replicateM 0 x = return () +> +> replicateM (m + n) x = replicateM m x >> replicateM n x -- 0 <= {m,n} + +@ +'replicateM' :: 'Monad' m => Int -> m a -> 'Producer' a m () +@ +-} +replicateM :: Monad m => Int -> m a -> Proxy x' x () a m () replicateM n m = lift m >~ take n {-# INLINABLE replicateM #-} @@ -206,7 +242,7 @@ Unlike 'toHandle', 'stdoutLn' gracefully terminates on a broken output pipe -} -stdoutLn :: (MonadIO m) => Consumer' String m () +stdoutLn :: MonadIO m => Consumer' String m () stdoutLn = go where go = do @@ -221,10 +257,34 @@ Right () -> go {-# INLINABLE stdoutLn #-} +{-| Write 'String's to 'IO.stdout' using 'putStrLn' + + This does not handle a broken output pipe, but has a polymorphic return + value +-} +stdoutLn' :: MonadIO m => Consumer' String m r +stdoutLn' = for cat (\str -> liftIO (putStrLn str)) +{-# INLINABLE [1] stdoutLn' #-} + +{-# RULES + "p >-> stdoutLn'" forall p . + p >-> stdoutLn' = for p (\str -> liftIO (putStrLn str)) + #-} + +-- | Consume all values using a monadic function +mapM_ :: Monad m => (a -> m ()) -> Consumer' a m r +mapM_ f = for cat (\a -> lift (f a)) +{-# INLINABLE [1] mapM_ #-} + +{-# RULES + "p >-> mapM_ f" forall p f . + p >-> mapM_ f = for p (\a -> lift (f a)) + #-} + -- | 'print' values to 'IO.stdout' print :: (MonadIO m, Show a) => Consumer' a m r print = for cat (\a -> liftIO (Prelude.print a)) -{-# INLINABLE print #-} +{-# INLINABLE [1] print #-} {-# RULES "p >-> print" forall p . @@ -232,15 +292,25 @@ #-} -- | Write 'String's to a 'IO.Handle' using 'IO.hPutStrLn' -toHandle :: (MonadIO m) => IO.Handle -> Consumer' String m r +toHandle :: MonadIO m => IO.Handle -> Consumer' String m r toHandle handle = for cat (\str -> liftIO (IO.hPutStrLn handle str)) -{-# INLINABLE toHandle #-} +{-# INLINABLE [1] toHandle #-} {-# RULES "p >-> toHandle handle" forall p handle . p >-> toHandle handle = for p (\str -> liftIO (IO.hPutStrLn handle str)) #-} +-- | 'discard' all incoming values +drain :: Functor m => Consumer' a m r +drain = for cat discard +{-# INLINABLE [1] drain #-} + +{-# RULES + "p >-> drain" forall p . + p >-> drain = for p discard + #-} + {- $pipes Use ('>->') to connect 'Producer's, 'Pipe's, and 'Consumer's: @@ -254,10 +324,15 @@ -} --- | Apply a function to all values flowing downstream -map :: (Monad m) => (a -> b) -> Pipe a b m r +{-| Apply a function to all values flowing downstream + +> map id = cat +> +> map (g . f) = map f >-> map g +-} +map :: Functor m => (a -> b) -> Pipe a b m r map f = for cat (\a -> yield (f a)) -{-# INLINABLE map #-} +{-# INLINABLE [1] map #-} {-# RULES "p >-> map f" forall p f . p >-> map f = for p (\a -> yield (f a)) @@ -267,12 +342,17 @@ return (f a) ) >~ p #-} --- | Apply a monadic function to all values flowing downstream -mapM :: (Monad m) => (a -> m b) -> Pipe a b m r +{-| Apply a monadic function to all values flowing downstream + +> mapM return = cat +> +> mapM (f >=> g) = mapM f >-> mapM g +-} +mapM :: Monad m => (a -> m b) -> Pipe a b m r mapM f = for cat $ \a -> do b <- lift (f a) yield b -{-# INLINABLE mapM #-} +{-# INLINABLE [1] mapM #-} {-# RULES "p >-> mapM f" forall p f . p >-> mapM f = for p (\a -> do @@ -285,36 +365,77 @@ return b ) >~ p #-} +-- | Convert a stream of actions to a stream of values +sequence :: Monad m => Pipe (m a) a m r +sequence = mapM id +{-# INLINABLE sequence #-} + {- | Apply a function to all values flowing downstream, and forward each element of the result. -} -mapFoldable :: (Monad m, Foldable t) => (a -> t b) -> Pipe a b m r +mapFoldable :: (Functor m, Foldable t) => (a -> t b) -> Pipe a b m r mapFoldable f = for cat (\a -> each (f a)) -{-# INLINABLE mapFoldable #-} +{-# INLINABLE [1] mapFoldable #-} {-# RULES "p >-> mapFoldable f" forall p f . p >-> mapFoldable f = for p (\a -> each (f a)) #-} --- | @(filter predicate)@ only forwards values that satisfy the predicate. -filter :: (Monad m) => (a -> Bool) -> Pipe a a m r +{-| @(filter predicate)@ only forwards values that satisfy the predicate. + +> filter (pure True) = cat +> +> filter (liftA2 (&&) p1 p2) = filter p1 >-> filter p2 +> +> filter f = mapMaybe (\a -> a <$ guard (f a)) +-} +filter :: Functor m => (a -> Bool) -> Pipe a a m r filter predicate = for cat $ \a -> when (predicate a) (yield a) -{-# INLINABLE filter #-} +{-# INLINABLE [1] filter #-} {-# RULES "p >-> filter predicate" forall p predicate. p >-> filter predicate = for p (\a -> when (predicate a) (yield a)) #-} +{-| @(mapMaybe f)@ yields 'Just' results of 'f'. + +Basic laws: + +> mapMaybe (f >=> g) = mapMaybe f >-> mapMaybe g +> +> mapMaybe (pure @Maybe . f) = mapMaybe (Just . f) = map f +> +> mapMaybe (const Nothing) = drain + +As a result of the second law, + +> mapMaybe return = mapMaybe Just = cat +-} +mapMaybe :: Functor m => (a -> Maybe b) -> Pipe a b m r +mapMaybe f = for cat $ maybe (pure ()) yield . f +{-# INLINABLE [1] mapMaybe #-} + +{-# RULES + "p >-> mapMaybe f" forall p f. + p >-> mapMaybe f = for p $ maybe (pure ()) yield . f + #-} + {-| @(filterM predicate)@ only forwards values that satisfy the monadic predicate + +> filterM (pure (pure True)) = cat +> +> filterM (liftA2 (liftA2 (&&)) p1 p2) = filterM p1 >-> filterM p2 +> +> filterM f = wither (\a -> (\b -> a <$ guard b) <$> f a) -} -filterM :: (Monad m) => (a -> m Bool) -> Pipe a a m r +filterM :: Monad m => (a -> m Bool) -> Pipe a a m r filterM predicate = for cat $ \a -> do b <- lift (predicate a) when b (yield a) -{-# INLINABLE filterM #-} +{-# INLINABLE [1] filterM #-} {-# RULES "p >-> filterM predicate" forall p predicate . @@ -323,17 +444,62 @@ when b (yield a) ) #-} --- | @(take n)@ only allows @n@ values to pass through -take :: (Monad m) => Int -> Pipe a a m () -take n = replicateM_ n $ do - a <- await - yield a +{-| @(wither f)@ forwards 'Just' values produced by the + monadic action. + +Basic laws: + +> wither (runMaybeT . (MaybeT . f >=> MaybeT . g)) = wither f >-> wither g +> +> wither (runMaybeT . lift . f) = wither (fmap Just . f) = mapM f +> +> wither (pure . f) = mapMaybe f + +As a result of the second law, + +> wither (runMaybeT . return) = cat + +As a result of the third law, + +> wither (pure . const Nothing) = wither (const (pure Nothing)) = drain +-} +wither :: Monad m => (a -> m (Maybe b)) -> Pipe a b m r +wither f = for cat $ lift . f >=> maybe (pure ()) yield +{-# INLINABLE [1] wither #-} + +{-# RULES + "p >-> wither f" forall p f . + p >-> wither f = for p $ lift . f >=> maybe (pure ()) yield + #-} + +{-| @(take n)@ only allows @n@ values to pass through + +> take 0 = return () +> +> take (m + n) = take m >> take n + +> take = cat +> +> take (min m n) = take m >-> take n +-} +take :: Functor m => Int -> Pipe a a m () +take = go + where + go 0 = return () + go n = do + a <- await + yield a + go (n-1) {-# INLINABLE take #-} {-| @(takeWhile p)@ allows values to pass downstream so long as they satisfy the predicate @p@. + +> takeWhile (pure True) = cat +> +> takeWhile (liftA2 (&&) p1 p2) = takeWhile p1 >-> takeWhile p2 -} -takeWhile :: (Monad m) => (a -> Bool) -> Pipe a a m () +takeWhile :: Functor m => (a -> Bool) -> Pipe a a m () takeWhile predicate = go where go = do @@ -345,17 +511,48 @@ else return () {-# INLINABLE takeWhile #-} --- | @(drop n)@ discards @n@ values going downstream -drop :: (Monad m) => Int -> Pipe a a m r -drop n = do - replicateM_ n await - cat +{-| @(takeWhile' p)@ is a version of takeWhile that returns the value failing + the predicate. + +> takeWhile' (pure True) = cat +> +> takeWhile' (liftA2 (&&) p1 p2) = takeWhile' p1 >-> takeWhile' p2 +-} +takeWhile' :: Functor m => (a -> Bool) -> Pipe a a m a +takeWhile' predicate = go + where + go = do + a <- await + if (predicate a) + then do + yield a + go + else return a +{-# INLINABLE takeWhile' #-} + +{-| @(drop n)@ discards @n@ values going downstream + +> drop 0 = cat +> +> drop (m + n) = drop m >-> drop n +-} +drop :: Functor m => Int -> Pipe a a m r +drop = go + where + go 0 = cat + go n = do + await + go (n-1) {-# INLINABLE drop #-} {-| @(dropWhile p)@ discards values going downstream until one violates the predicate @p@. + +> dropWhile (pure False) = cat +> +> dropWhile (liftA2 (||) p1 p2) = dropWhile p1 >-> dropWhile p2 -} -dropWhile :: (Monad m) => (a -> Bool) -> Pipe a a m r +dropWhile :: Functor m => (a -> Bool) -> Pipe a a m r dropWhile predicate = go where go = do @@ -368,60 +565,71 @@ {-# INLINABLE dropWhile #-} -- | Flatten all 'Foldable' elements flowing downstream -concat :: (Monad m, Foldable f) => Pipe (f a) a m r +concat :: (Functor m, Foldable f) => Pipe (f a) a m r concat = for cat each -{-# INLINABLE concat #-} +{-# INLINABLE [1] concat #-} {-# RULES "p >-> concat" forall p . p >-> concat = for p each #-} -- | Outputs the indices of all elements that match the given element -elemIndices :: (Monad m, Eq a) => a -> Pipe a Int m r +elemIndices :: (Functor m, Eq a) => a -> Pipe a Int m r elemIndices a = findIndices (a ==) {-# INLINABLE elemIndices #-} -- | Outputs the indices of all elements that satisfied the predicate -findIndices :: (Monad m) => (a -> Bool) -> Pipe a Int m r -findIndices predicate = loop 0 +findIndices :: Functor m => (a -> Bool) -> Pipe a Int m r +findIndices predicate = go 0 where - loop n = do + go n = do a <- await when (predicate a) (yield n) - loop $! n + 1 + go $! n + 1 {-# INLINABLE findIndices #-} --- | Strict left scan -scan :: (Monad m) => (x -> a -> x) -> x -> (x -> b) -> Pipe a b m r -scan step begin done = loop begin +{-| Strict left scan + +> Control.Foldl.purely scan :: Monad m => Fold a b -> Pipe a b m r +-} +scan :: Functor m => (x -> a -> x) -> x -> (x -> b) -> Pipe a b m r +scan step begin done = go begin where - loop x = do + go x = do yield (done x) a <- await let x' = step x a - loop $! x' + go $! x' {-# INLINABLE scan #-} --- | Strict, monadic left scan -scanM :: (Monad m) => (x -> a -> m x) -> m x -> (x -> m b) -> Pipe a b m r +{-| Strict, monadic left scan + +> Control.Foldl.impurely scanM :: Monad m => FoldM m a b -> Pipe a b m r +-} +scanM :: Monad m => (x -> a -> m x) -> m x -> (x -> m b) -> Pipe a b m r scanM step begin done = do x <- lift begin - loop x + go x where - loop x = do + go x = do b <- lift (done x) yield b a <- await x' <- lift (step x a) - loop $! x' + go $! x' {-# INLINABLE scanM #-} --- | Apply an action to all values flowing downstream -chain :: (Monad m) => (a -> m ()) -> Pipe a a m r +{-| Apply an action to all values flowing downstream + +> chain (pure (return ())) = cat +> +> chain (liftA2 (>>) m1 m2) = chain m1 >-> chain m2 +-} +chain :: Monad m => (a -> m ()) -> Pipe a a m r chain f = for cat $ \a -> do lift (f a) yield a -{-# INLINABLE chain #-} +{-# INLINABLE [1] chain #-} {-# RULES "p >-> chain f" forall p f . @@ -436,11 +644,11 @@ #-} -- | Parse 'Read'able values, only forwarding the value if the parse succeeds -read :: (Monad m, Read a) => Pipe String a m r +read :: (Functor m, Read a) => Pipe String a m r read = for cat $ \str -> case (reads str) of [(a, "")] -> yield a _ -> return () -{-# INLINABLE read #-} +{-# INLINABLE [1] read #-} {-# RULES "p >-> read" forall p . @@ -450,15 +658,30 @@ #-} -- | Convert 'Show'able values to 'String's -show :: (Monad m, Show a) => Pipe a String m r +show :: (Functor m, Show a) => Pipe a String m r show = map Prelude.show {-# INLINABLE show #-} +-- | Evaluate all values flowing downstream to WHNF +seq :: Functor m => Pipe a a m r +seq = for cat $ \a -> yield $! a +{-# INLINABLE seq #-} + +{-| Create a `Pipe` from a `ListT` transformation + +> loop (k1 >=> k2) = loop k1 >-> loop k2 +> +> loop return = cat +-} +loop :: Monad m => (a -> ListT m b) -> Pipe a b m r +loop k = for cat (every . k) +{-# INLINABLE loop #-} + {- $folds Use these to fold the output of a 'Producer'. Many of these folds will stop drawing elements if they can compute their result early, like 'any': ->>> P.any null P.stdinLn +>>> P.any Prelude.null P.stdinLn Test ABC @@ -467,55 +690,97 @@ -} --- | Strict fold of the elements of a 'Producer' -fold :: (Monad m) => (x -> a -> x) -> x -> (x -> b) -> Producer a m () -> m b -fold step begin done p0 = loop p0 begin +{-| Strict fold of the elements of a 'Producer' + +> Control.Foldl.purely fold :: Monad m => Fold a b -> Producer a m () -> m b +-} +fold :: Monad m => (x -> a -> x) -> x -> (x -> b) -> Producer a m () -> m b +fold step begin done p0 = go p0 begin where - loop p x = case p of - Request v _ -> absurd v - Respond a fu -> loop (fu ()) $! step x a - M m -> m >>= \p' -> loop p' x + go p x = case p of + Request v _ -> closed v + Respond a fu -> go (fu ()) $! step x a + M m -> m >>= \p' -> go p' x Pure _ -> return (done x) {-# INLINABLE fold #-} --- | Strict, monadic fold of the elements of a 'Producer' +{-| Strict fold of the elements of a 'Producer' that preserves the return value + +> Control.Foldl.purely fold' :: Monad m => Fold a b -> Producer a m r -> m (b, r) +-} +fold' :: Monad m => (x -> a -> x) -> x -> (x -> b) -> Producer a m r -> m (b, r) +fold' step begin done p0 = go p0 begin + where + go p x = case p of + Request v _ -> closed v + Respond a fu -> go (fu ()) $! step x a + M m -> m >>= \p' -> go p' x + Pure r -> return (done x, r) +{-# INLINABLE fold' #-} + +{-| Strict, monadic fold of the elements of a 'Producer' + +> Control.Foldl.impurely foldM :: Monad m => FoldM a b -> Producer a m () -> m b +-} foldM - :: (Monad m) + :: Monad m => (x -> a -> m x) -> m x -> (x -> m b) -> Producer a m () -> m b foldM step begin done p0 = do x0 <- begin - loop p0 x0 + go p0 x0 where - loop p x = case p of - Request v _ -> absurd v + go p x = case p of + Request v _ -> closed v Respond a fu -> do x' <- step x a - loop (fu ()) $! x' - M m -> m >>= \p' -> loop p' x + go (fu ()) $! x' + M m -> m >>= \p' -> go p' x Pure _ -> done x {-# INLINABLE foldM #-} +{-| Strict, monadic fold of the elements of a 'Producer' + +> Control.Foldl.impurely foldM' :: Monad m => FoldM a b -> Producer a m r -> m (b, r) +-} +foldM' + :: Monad m + => (x -> a -> m x) -> m x -> (x -> m b) -> Producer a m r -> m (b, r) +foldM' step begin done p0 = do + x0 <- begin + go p0 x0 + where + go p x = case p of + Request v _ -> closed v + Respond a fu -> do + x' <- step x a + go (fu ()) $! x' + M m -> m >>= \p' -> go p' x + Pure r -> do + b <- done x + return (b, r) +{-# INLINABLE foldM' #-} + {-| @(all predicate p)@ determines whether all the elements of @p@ satisfy the predicate. -} -all :: (Monad m) => (a -> Bool) -> Producer a m () -> m Bool +all :: Monad m => (a -> Bool) -> Producer a m () -> m Bool all predicate p = null $ p >-> filter (\a -> not (predicate a)) {-# INLINABLE all #-} {-| @(any predicate p)@ determines whether any element of @p@ satisfies the predicate. -} -any :: (Monad m) => (a -> Bool) -> Producer a m () -> m Bool +any :: Monad m => (a -> Bool) -> Producer a m () -> m Bool any predicate p = liftM not $ null (p >-> filter predicate) {-# INLINABLE any #-} -- | Determines whether all elements are 'True' -and :: (Monad m) => Producer Bool m () -> m Bool +and :: Monad m => Producer Bool m () -> m Bool and = all id {-# INLINABLE and #-} -- | Determines whether any element is 'True' -or :: (Monad m) => Producer Bool m () -> m Bool +or :: Monad m => Producer Bool m () -> m Bool or = any id {-# INLINABLE or #-} @@ -534,19 +799,19 @@ {-# INLINABLE notElem #-} -- | Find the first element of a 'Producer' that satisfies the predicate -find :: (Monad m) => (a -> Bool) -> Producer a m () -> m (Maybe a) +find :: Monad m => (a -> Bool) -> Producer a m () -> m (Maybe a) find predicate p = head (p >-> filter predicate) {-# INLINABLE find #-} {-| Find the index of the first element of a 'Producer' that satisfies the predicate -} -findIndex :: (Monad m) => (a -> Bool) -> Producer a m () -> m (Maybe Int) +findIndex :: Monad m => (a -> Bool) -> Producer a m () -> m (Maybe Int) findIndex predicate p = head (p >-> findIndices predicate) {-# INLINABLE findIndex #-} -- | Retrieve the first element from a 'Producer' -head :: (Monad m) => Producer a m () -> m (Maybe a) +head :: Monad m => Producer a m () -> m (Maybe a) head p = do x <- next p return $ case x of @@ -555,27 +820,27 @@ {-# INLINABLE head #-} -- | Index into a 'Producer' -index :: (Monad m) => Int -> Producer a m () -> m (Maybe a) +index :: Monad m => Int -> Producer a m () -> m (Maybe a) index n p = head (p >-> drop n) {-# INLINABLE index #-} -- | Retrieve the last element from a 'Producer' -last :: (Monad m) => Producer a m () -> m (Maybe a) +last :: Monad m => Producer a m () -> m (Maybe a) last p0 = do x <- next p0 case x of Left _ -> return Nothing - Right (a, p') -> loop a p' + Right (a, p') -> go a p' where - loop a p = do + go a p = do x <- next p case x of Left _ -> return (Just a) - Right (a', p') -> loop a' p' + Right (a', p') -> go a' p' {-# INLINABLE last #-} -- | Count the number of elements in a 'Producer' -length :: (Monad m) => Producer a m () -> m Int +length :: Monad m => Producer a m () -> m Int length = fold (\n _ -> n + 1) 0 id {-# INLINABLE length #-} @@ -598,7 +863,7 @@ {-# INLINABLE minimum #-} -- | Determine if a 'Producer' is empty -null :: (Monad m) => Producer a m () -> m Bool +null :: Monad m => Producer a m () -> m Bool null p = do x <- next p return $ case x of @@ -618,14 +883,15 @@ -- | Convert a pure 'Producer' into a list toList :: Producer a Identity () -> [a] -toList = loop +toList prod0 = build (go prod0) where - loop p = case p of - Request v _ -> absurd v - Respond a fu -> a:loop (fu ()) - M m -> loop (runIdentity m) - Pure _ -> [] -{-# INLINABLE toList #-} + go prod cons nil = + case prod of + Request v _ -> closed v + Respond a fu -> cons a (go (fu ()) cons nil) + M m -> go (runIdentity m) cons nil + Pure _ -> nil +{-# INLINE toList #-} {-| Convert an effectful 'Producer' into a list @@ -634,32 +900,43 @@ immediately as they are generated instead of loading all elements into memory. -} -toListM :: (Monad m) => Producer a m () -> m [a] -toListM = loop +toListM :: Monad m => Producer a m () -> m [a] +toListM = fold step begin done where - loop p = case p of - Request v _ -> absurd v - Respond a fu -> do - as <- loop (fu ()) - return (a:as) - M m -> m >>= loop - Pure _ -> return [] + step x a = x . (a:) + begin = id + done x = x [] {-# INLINABLE toListM #-} +{-| Convert an effectful 'Producer' into a list alongside the return value + + Note: 'toListM'' is not an idiomatic use of @pipes@, but I provide it for + simple testing purposes. Idiomatic @pipes@ style consumes the elements + immediately as they are generated instead of loading all elements into + memory. +-} +toListM' :: Monad m => Producer a m r -> m ([a], r) +toListM' = fold' step begin done + where + step x a = x . (a:) + begin = id + done x = x [] +{-# INLINABLE toListM' #-} + -- | Zip two 'Producer's -zip :: (Monad m) - => (Producer a m r) - -> (Producer b m r) - -> (Producer' (a, b) m r) +zip :: Monad m + => (Producer a m r) + -> (Producer b m r) + -> (Proxy x' x () (a, b) m r) zip = zipWith (,) {-# INLINABLE zip #-} -- | Zip two 'Producer's using the provided combining function -zipWith :: (Monad m) +zipWith :: Monad m => (a -> b -> c) -> (Producer a m r) -> (Producer b m r) - -> (Producer' c m r) + -> (Proxy x' x () c m r) zipWith f = go where go p1 p2 = do @@ -675,11 +952,10 @@ go p1' p2' {-# INLINABLE zipWith #-} -#ifndef haskell98 {-| Transform a 'Consumer' to a 'Pipe' that reforwards all values further downstream -} -tee :: (Monad m) => Consumer a m r -> Pipe a a m r +tee :: Monad m => Consumer a m r -> Pipe a a m r tee p = evalStateP Nothing $ do r <- up >\\ (hoist lift p //> dn) ma <- lift get @@ -696,7 +972,7 @@ a <- await lift $ put (Just a) return a - dn v = absurd v + dn v = closed v {-# INLINABLE tee #-} {-| Transform a unidirectional 'Pipe' to a bidirectional 'Proxy' @@ -705,7 +981,7 @@ > > generalize cat = pull -} -generalize :: (Monad m) => Pipe a b m r -> x -> Proxy x a x b m r +generalize :: Monad m => Pipe a b m r -> x -> Proxy x a x b m r generalize p x0 = evalStateP x0 $ up >\\ hoist lift p //> dn where up () = do @@ -715,4 +991,19 @@ x <- respond a lift $ put x {-# INLINABLE generalize #-} -#endif + +{-| The natural unfold into a 'Producer' with a step function and a seed + +> unfoldr next = id +-} +unfoldr :: Monad m + => (s -> m (Either r (a, s))) -> s -> Producer a m r +unfoldr step = go where + go s0 = do + e <- lift (step s0) + case e of + Left r -> return r + Right (a,s) -> do + yield a + go s +{-# INLINABLE unfoldr #-} diff --git a/src/Pipes/Tutorial.hs b/src/Pipes/Tutorial.hs --- a/src/Pipes/Tutorial.hs +++ b/src/Pipes/Tutorial.hs @@ -41,6 +41,8 @@ learn about by reading either: * the paper \"Monad Transformers - Step by Step\", + + * part III \"Monads in the Real World\" of the tutorial \"All About Monads\", * chapter 18 of \"Real World Haskell\" on monad transformers, or: @@ -83,14 +85,14 @@ -- * Appendix: Time Complexity -- $timecomplexity + + -- * Copyright + -- $copyright ) where import Control.Category import Control.Monad -import Control.Monad.Trans.Error -import Control.Monad.Trans.Writer.Strict import Pipes -import Pipes.Lift import qualified Pipes.Prelude as P import Prelude hiding ((.), id) @@ -241,22 +243,22 @@ also an 'Effect': @ - data 'Void' -- The uninhabited type + data 'X' -- The uninhabited type -\ type 'Effect' m r = 'Producer' 'Void' m r +\ type 'Effect' m r = 'Producer' 'X' m r @ This is why 'for' permits two different type signatures. The first type signature is just a special case of the second one: @ - 'for' :: 'Monad' m => 'Producer' a m r -> (a -> 'Producer' b m ()) -> 'Producer' b m r + 'for' :: 'Monad' m => 'Producer' a m r -> (a -> 'Producer' b m ()) -> 'Producer' b m r -\ -- Specialize \'b\' to \'Void\' - 'for' :: 'Monad' m => 'Producer' a m r -> (a -> 'Producer' 'Void' m ()) -> 'Producer' 'Void' m r +\ -- Specialize \'b\' to \'X\' + 'for' :: 'Monad' m => 'Producer' a m r -> (a -> 'Producer' 'X' m ()) -> 'Producer' 'X' m r -\ -- Producer Void = Effect - 'for' :: 'Monad' m => 'Producer' a m r -> (a -> 'Effect' m ()) -> 'Effect' m r +\ -- Producer X = Effect + 'for' :: 'Monad' m => 'Producer' a m r -> (a -> 'Effect' m ()) -> 'Effect' m r @ This is the same trick that all @pipes@ functions use to work with various @@ -344,7 +346,7 @@ You can also use 'for' to loop over lists, too. To do so, convert the list to a 'Producer' using 'each', which is exported by default from "Pipes": -> each :: (Monad m) => [a] -> Producer a m () +> each :: Monad m => [a] -> Producer a m () > each as = mapM_ yield as Combine 'for' and 'each' to iterate over lists using a \"foreach\" loop: @@ -370,47 +372,51 @@ {- $composability You might wonder why the body of a 'for' loop can be a 'Producer'. Let's - test out this feature by defining a new loop body that @duplicate@s every - value: + test out this feature by defining a new loop body that creates three copies + of every value: > -- nested.hs > > import Pipes > import qualified Pipes.Prelude as P -- Pipes.Prelude already has 'stdinLn' > -> duplicate :: (Monad m) => a -> Producer a m () -> duplicate x = do +> triple :: Monad m => a -> Producer a m () +> triple x = do > yield x > yield x +> yield x > > loop :: Producer String IO () -> loop = for P.stdinLn duplicate +> loop = for P.stdinLn triple > > -- This is the exact same as: > -- > -- loop = for P.stdinLn $ \x -> do > -- yield x > -- yield x +> -- yield x This time our @loop@ is a 'Producer' that outputs 'String's, specifically - two copies of each line that we read from standard input. Since @loop@ is a - 'Producer' we cannot run it because there is still unhandled output. - However, we can use yet another 'for' to handle this new duplicated stream: + three copies of each line that we read from standard input. Since @loop@ is + a 'Producer' we cannot run it because there is still unhandled output. + However, we can use yet another 'for' to handle this new repeated stream: > -- nested.hs > > main = runEffect $ for loop (lift . putStrLn) This creates a program which echoes every line from standard input to - standard output twice: + standard output three times: > $ ./nested > Test > Test > Test +> Test > ABC > ABC > ABC +> ABC > > $ @@ -419,16 +425,16 @@ > main = runEffect $ > for P.stdinLn $ \str1 -> -> for (duplicate str1) $ \str2 -> +> for (triple str1) $ \str2 -> > lift $ putStrLn str2 Yes, we could have! In fact, this is a special case of the following equality, which always holds no matter what: @ - \-\- s :: (Monad m) => 'Producer' a m () -- i.e. \'P.stdinLn\' - \-\- f :: (Monad m) => a -> 'Producer' b m () -- i.e. \'duplicate\' - \-\- g :: (Monad m) => b -> 'Producer' c m () -- i.e. \'(lift . putStrLn)\' + \-\- s :: Monad m => 'Producer' a m () -- i.e. \'P.stdinLn\' + \-\- f :: Monad m => a -> 'Producer' b m () -- i.e. \'triple\' + \-\- g :: Monad m => b -> 'Producer' c m () -- i.e. \'(lift . putStrLn)\' \ for (for s f) g = for s (\\x -> for (f x) g) @ @@ -437,10 +443,10 @@ following operator that is the point-free counterpart to 'for': @ - (~>) :: (Monad m) - => (a -> 'Producer' b m r) - -> (b -> 'Producer' c m r) - -> (a -> 'Producer' c m r) + (~>) :: Monad m + => (a -> 'Producer' b m ()) + -> (b -> 'Producer' c m ()) + -> (a -> 'Producer' c m ()) (f ~> g) x = for (f x) g @ @@ -448,9 +454,9 @@ into the following more symmetric equation: @ - f :: (Monad m) => a -> 'Producer' b m r - g :: (Monad m) => b -> 'Producer' c m r - h :: (Monad m) => c -> 'Producer' d m r + f :: Monad m => a -> 'Producer' b m () + g :: Monad m => b -> 'Producer' c m () + h :: Monad m => c -> 'Producer' d m () \ \-\- Associativity (f ~> g) ~> h = f ~> (g ~> h) @@ -498,7 +504,7 @@ our original code into the following more succinct form that composes two transformations: -> main = runEffect $ for P.stdinLn (duplicate ~> lift . putStrLn) +> main = runEffect $ for P.stdinLn (triple ~> lift . putStrLn) This means that we can also choose to program in a more functional style and think of stream processing in terms of composing transformations using @@ -568,7 +574,7 @@ @ One way to feed a 'Consumer' is to repeatedly feed the same input using - using ('>~') (pronounced \"feed\"): + ('>~') (pronounced \"feed\"): @ \-\- +- Feed +- Consumer to +- Returns new @@ -608,7 +614,7 @@ following intermediate 'Consumer' that requests two 'String's and returns them concatenated: -> doubleUp :: (Monad m) => Consumer String m String +> doubleUp :: Monad m => Consumer String m String > doubleUp = do > str1 <- await > str2 <- await @@ -744,7 +750,7 @@ A 'Pipe' is a monad transformer that is a mix between a 'Producer' and 'Consumer', because a 'Pipe' can both 'await' and 'yield'. The following - example 'Pipe' is analagous to the Prelude's 'take', only allowing a fixed + example 'Pipe' is analogous to the Prelude's 'take', only allowing a fixed number of values to flow through: > -- take.hs @@ -812,7 +818,7 @@ quirks. In fact, we can continue the analogy to Unix by defining 'cat' (named after the Unix @cat@ utility), which reforwards elements endlessly: -> cat :: (Monad m) => Pipe a a m r +> cat :: Monad m => Pipe a a m r > cat = forever $ do > x <- await > yield x @@ -838,10 +844,10 @@ > import qualified Pipes.Prelude as P -- Pipes.Prelude provides 'take', too > import Prelude hiding (head) > -> head :: (Monad m) => Int -> Pipe a a m () +> head :: Monad m => Int -> Pipe a a m () > head = P.take > -> yes :: (Monad m) => Producer String m r +> yes :: Monad m => Producer String m r > yes = forever $ yield "y" > > main = runEffect $ yes >-> head 3 >-> P.stdoutLn @@ -964,6 +970,104 @@ Notice how this streams out values immediately as they are generated, rather than building up a large intermediate result and then printing all the values in one batch at the end. + + `ListT` computations can be combined in more ways than `Pipe`s, so try to + program in `ListT` as much as possible and defer converting it to a `Pipe` + as late as possible using `P.loop`. + + You can combine `ListT` computations even if their inputs and outputs are + completely different: + +> data In +> = InA A +> | InB B +> | InC C +> +> data Out +> = OutD D +> | OutE E +> | OutF F +> +> -- Independent computations +> +> example1 :: A -> ListT IO D +> example2 :: B -> ListT IO E +> example3 :: C -> ListT IO F +> +> -- Combined computation +> +> total :: In -> ListT IO Out +> total input = case input of +> InA a -> fmap OutD (example1 a) +> InB b -> fmap OutE (example2 b) +> InC c -> fmap OutF (example3 c) + + Sometimes you have multiple computations that handle different inputs but + the same output, in which case you don't need to unify their outputs: + +> -- Overlapping outputs +> +> example1 :: A -> ListT IO Out +> example2 :: B -> ListT IO Out +> example3 :: C -> ListT IO Out +> +> -- Combined computation +> +> total :: In -> ListT IO Out +> total input = case input of +> InA a -> example1 a +> InB b -> example2 b +> InC c -> example3 c + + Other times you have multiple computations that handle the same input but + produce different outputs. You can unify their outputs using the `Monoid` + and `Functor` instances for `ListT`: + +> -- Overlapping inputs +> +> example1 :: In -> ListT IO D +> example2 :: In -> ListT IO E +> example3 :: In -> ListT IO F +> +> -- Combined computation +> +> total :: In -> ListT IO Out +> total input = +> fmap OutD (example1 input) +> <> fmap OutE (example2 input) +> <> fmap OutF (example3 input) + + You can also chain `ListT` computations, feeding the output of the first + computation as the input to the next computation: + +> -- End-to-end +> +> aToB :: A -> ListT IO B +> bToC :: B -> ListT IO C +> +> -- Combined computation +> +> aToC :: A -> LIstT IO C +> aToC = aToB >=> bToC + + ... or you can just use @do@ notation if you prefer. + + However, the `Pipe` type is more general than `ListT` and can represent + things like termination. Therefore you should consider mixing `Pipe`s with + `ListT` when you need to take advantage of these extra features: + +> -- Mix ListT with Pipes +> +> example :: In -> ListT IO Out +> +> pipe :: Pipe In Out IO () +> pipe = Pipes.takeWhile (not . isC) >-> loop example +> where +> isC (InC _) = True +> isC _ = False + + So promote your `ListT` logic to a `Pipe` when you need to take advantage of + these `Pipe`-specific features. -} {- $tricks @@ -976,7 +1080,7 @@ For example, you can loop over the output of a 'Pipe' using 'for', which is how 'P.map' is defined: -> map :: (Monad m) => (a -> b) -> Pipe a b m r +> map :: Monad m => (a -> b) -> Pipe a b m r > map f = for cat $ \x -> yield (f x) > > -- Read this as: For all values flowing downstream, apply 'f' @@ -990,7 +1094,7 @@ You can also feed a 'Pipe' input using ('>~'). This means we could have instead defined the @yes@ pipe like this: -> yes :: (Monad m) => Producer String m r +> yes :: Monad m => Producer String m r > yes = return "y" >~ cat > > -- Read this as: Keep feeding "y" downstream @@ -1002,7 +1106,7 @@ You can also sequence two 'Pipe's together. This is how 'P.drop' is defined: -> drop :: (Monad m) => Int -> Pipe a a m r +> drop :: Monad m => Int -> Pipe a a m r > drop n = do > replicateM_ n await > cat @@ -1019,7 +1123,7 @@ > customerService :: Producer String IO () > customerService = do -> each [ "Hello, how can I help you?" -- Begin with a script +> each [ "Hello, how can I help you?" -- Begin with a script > , "Hold for one second." > ] > P.stdinLn >-> P.takeWhile (/= "Goodbye!") -- Now continue with a human @@ -1036,7 +1140,7 @@ Another neat thing to know is that 'every' has a more general type: @ - 'every' :: ('Enumerable' t) => t m a -> 'Producer' a m () + 'every' :: ('Monad' m, 'Enumerable' t) => t m a -> 'Producer' a m () @ 'Enumerable' generalizes 'Foldable' and if you have an effectful container @@ -1044,15 +1148,16 @@ container implement the 'toListT' method of the 'Enumerable' class: > class Enumerable t where -> toListT :: (Monad m) => t m a -> ListT m a +> toListT :: Monad m => t m a -> ListT m a You can even use 'Enumerable' to traverse effectful types that are not even proper containers, like 'Control.Monad.Trans.Maybe.MaybeT': -> input :: MaybeT IO Int +> input :: MaybeT IO String > input = do > str <- lift getLine > guard (str /= "Fail") +> return str >>> runEffect $ every input >-> P.stdoutLn Test @@ -1075,12 +1180,16 @@ * @pipes-safe@: Resource management and exception safety for @pipes@ + * @pipes-group@: Grouping streams in constant space + These libraries provide functionality specialized to common streaming domains. Additionally, there are several libraries on Hackage that provide even higher-level functionality, which you can find by searching under the \"Pipes\" category or by looking for packages with a @pipes-@ prefix in their name. Current examples include: + * @pipes-extras@: Miscellaneous utilities + * @pipes-network@/@pipes-network-tls@: Networking * @pipes-zlib@: Compression and decompression @@ -1112,7 +1221,7 @@ {- $types @pipes@ uses parametric polymorphism (i.e. generics) to overload all - operations. You've probably noticed this overloading already:: + operations. You've probably noticed this overloading already: * 'yield' works within both 'Producer's and 'Pipe's @@ -1156,49 +1265,49 @@ * Polymorphic type synonyms that don't explicitly close unused inputs or outputs - The concrete type synonyms use @()@ to close unused inputs and 'Void' (the + The concrete type synonyms use @()@ to close unused inputs and 'X' (the uninhabited type) to close unused outputs: * 'Effect': explicitly closes both ends, forbidding 'await's and 'yield's -> type Effect = Proxy Void () () Void +> type Effect = Proxy X () () X > -> Upstream | Downstream -> +---------+ -> | | -> Void <== <== () -> | | -> () ==> ==> Void -> | | | -> +----|----+ -> v -> r +> Upstream | Downstream +> +---------+ +> | | +> X <== <== () +> | | +> () ==> ==> X +> | | | +> +----|----+ +> v +> r * 'Producer': explicitly closes the upstream end, forbidding 'await's -> type Producer b = Proxy Void () () b +> type Producer b = Proxy X () () b > -> Upstream | Downstream -> +---------+ -> | | -> Void <== <== () -> | | -> () ==> ==> b -> | | | -> +----|----+ -> v -> r +> Upstream | Downstream +> +---------+ +> | | +> X <== <== () +> | | +> () ==> ==> b +> | | | +> +----|----+ +> v +> r * 'Consumer': explicitly closes the downstream end, forbidding 'yield's -> type Consumer a = Proxy () a () Void +> type Consumer a = Proxy () a () X > > Upstream | Downstream > +---------+ > | | > () <== <== () > | | -> a ==> ==> Void +> a ==> ==> X > | | | > +----|----+ > v @@ -1224,30 +1333,30 @@ 'Producer', 'Pipe', and a 'Consumer', you can think of information flowing like this: -> Producer Pipe Consumer -> +-----------+ +----------+ +------------+ -> | | | | | | -> Void <== <== () <== <== () <== <== () -> | stdinLn | | take 3 | | stdoutLn | -> () ==> ==> String ==> ==> String ==> ==> Void -> | | | | | | | | | -> +-----|-----+ +----|-----+ +------|-----+ -> v v v -> () () () +> Producer Pipe Consumer +> +-----------+ +----------+ +------------+ +> | | | | | | +> X <== <== () <== <== () <== <== () +> | stdinLn | | take 3 | | stdoutLn | +> () ==> ==> String ==> ==> String ==> ==> X +> | | | | | | | | | +> +-----|-----+ +----|-----+ +------|-----+ +> v v v +> () () () Composition fuses away the intermediate interfaces, leaving behind an 'Effect': -> Effect -> +-----------------------------------+ -> | | -> Void <== <== () -> | stdinLn >-> take 3 >-> stdoutLn | -> () ==> ==> Void -> | | -> +----------------|------------------+ -> v -> () +> Effect +> +-----------------------------------+ +> | | +> X <== <== () +> | stdinLn >-> take 3 >-> stdoutLn | +> () ==> ==> X +> | | +> +----------------|------------------+ +> v +> () @pipes@ also provides polymorphic type synonyms with apostrophes at the end of their names. These use universal quantification to leave open any unused @@ -1387,7 +1496,7 @@ 'Pipes.Prelude.fromHandle' function from "Pipes.Prelude" requires @RankNTypes@ to compile correctly on @ghc-7.6.3@: -> fromHandle :: (MonadIO m) => Handle -> Producer' String m () +> fromHandle :: MonadIO m => Handle -> Producer' String m () * You can't use polymorphic type synonyms inside other type constructors without the @ImpredicativeTypes@ extension: @@ -1417,26 +1526,26 @@ >>> runEffect P.stdinLn :4:5: - Couldn't match expected type `Void' with actual type `String' + Couldn't match expected type `X' with actual type `String' Expected type: Effect m0 r0 - Actual type: Proxy Void () () String IO () + Actual type: Proxy X () () String IO () In the first argument of `runEffect', namely `P.stdinLn' In the expression: runEffect P.stdinLn 'runEffect' expects an 'Effect', which is equivalent to the following type: -> Effect IO () = Proxy Void () () Void IO () +> Effect IO () = Proxy X () () X IO () ... but 'P.stdinLn' type-checks as a 'Producer', which has the following type: -> Producer String IO () = Proxy Void () () String IO () +> Producer String IO () = Proxy X () () String IO () The fourth type variable (the output) does not match. For an 'Effect' this - type variable should be closed (i.e. 'Void'), but 'P.stdinLn' has a 'String' + type variable should be closed (i.e. 'X'), but 'P.stdinLn' has a 'String' output, thus the type error: -> Couldn't match expected type `Void' with actual type `String' +> Couldn't match expected type `X' with actual type `String' Any time you get type errors like these you can work through them by expanding out the type synonyms and seeing which type variables do not @@ -1445,13 +1554,13 @@ You may also consult this table of type synonyms to more easily compare them: -> type Effect = Proxy Void () () Void -> type Producer b = Proxy Void () () b -> type Consumer a = Proxy () a () Void -> type Pipe a b = Proxy () a () b +> type Effect = Proxy X () () X +> type Producer b = Proxy X () () b +> type Consumer a = Proxy () a () X +> type Pipe a b = Proxy () a () b > -> type Server b' b = Proxy Void () b' b -> type Client a' a = Proxy a' a () Void +> type Server b' b = Proxy X () b' b +> type Client a' a = Proxy a' a () X > > type Effect' m r = forall x' x y' y . Proxy x' x y' y m r > type Producer' b m r = forall x' x . Proxy x' x () b m r @@ -1501,8 +1610,13 @@ > import Control.Monad.Codensity (lowerCodensity) > -> linear :: (Monad m) => Int -> Consumer a m [a] +> linear :: Monad m => Int -> Consumer a m [a] > linear n = lowerCodensity $ replicateM n $ lift await This will produce the exact same result, but in linear time. +-} + +{- $copyright + This tutorial is licensed under a + -}