{-# LANGUAGE
RankNTypes
, FlexibleInstances
, MultiParamTypeClasses
, UndecidableInstances
, Trustworthy
#-}
module Pipes (
Proxy
, X
, Effect
, Effect'
, runEffect
, Producer
, Producer'
, yield
, for
, (~>)
, (<~)
, Consumer
, Consumer'
, await
, (>~)
, (~<)
, Pipe
, cat
, (>->)
, (<-<)
, ListT(..)
, runListT
, Enumerable(..)
, next
, each
, every
, discard
, module Control.Monad.IO.Class
, module Control.Monad.Trans.Class
, module Control.Monad.Morph
, module Data.Foldable
) where
import Control.Applicative (Applicative(pure, (<*>)), Alternative(empty, (<|>)))
import Control.Monad.Error (MonadError(..))
import Control.Monad.IO.Class (MonadIO(liftIO))
import Control.Monad (MonadPlus(mzero, mplus))
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.Identity (IdentityT(runIdentityT))
import Control.Monad.Trans.Maybe (MaybeT(runMaybeT))
import Control.Monad.Writer (MonadWriter(..))
import Data.Foldable (Foldable)
import Data.Monoid (Monoid(..))
import Pipes.Core
import Pipes.Internal (Proxy(..))
import qualified Data.Foldable as F
import Control.Monad.Morph (MFunctor(hoist))
infixl 4 <~
infixr 4 ~>
infixl 5 ~<
infixr 5 >~
infixl 7 >->
infixr 7 <-<
yield :: Monad m => a -> Producer' a m ()
yield = respond
for :: Monad m
=> Proxy x' x b' b m a'
-> (b -> Proxy x' x c' c m b')
-> Proxy x' x c' c m a'
for = (//>)
{-# RULES
"for (for p f) g" forall p f g . for (for p f) g = for p (\a -> for (f a) g)
; "for p yield" forall p . for p yield = p
; "for (yield x) f" forall x f . for (yield x) f = f x
; "for cat f" forall f .
for cat f =
let go = do
x <- await
f x
go
in go
; "f >~ (g >~ p)" forall f g p . f >~ (g >~ p) = (f >~ g) >~ p
; "await >~ p" forall p . await >~ p = p
; "p >~ await" forall p . p >~ await = p
; "m >~ cat" forall m .
m >~ cat =
let go = do
x <- m
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
#-}
(~>)
:: Monad m
=> (a -> Proxy x' x b' b m a')
-> (b -> Proxy x' x c' c m b')
-> (a -> Proxy x' x c' c m a')
(~>) = (/>/)
(<~)
:: Monad m
=> (b -> Proxy x' x c' c m b')
-> (a -> Proxy x' x b' b m a')
-> (a -> Proxy x' x c' c m a')
g <~ f = f ~> g
await :: Monad m => Consumer' a m a
await = request ()
(>~)
:: Monad 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
(~<)
:: Monad m
=> Proxy () b y' y m c
-> Proxy a' a y' y m b
-> Proxy a' a y' y m c
p2 ~< p1 = p1 >~ p2
cat :: Monad m => Pipe a a m r
cat = pull ()
(>->)
:: Monad m
=> Proxy a' a () b m r
-> Proxy () b c' c m r
-> Proxy a' a c' c m r
p1 >-> p2 = (\() -> p1) +>> p2
newtype ListT m a = Select { enumerate :: Producer a m () }
instance (Monad m) => Functor (ListT m) where
fmap f p = Select (for (enumerate p) (\a -> yield (f a)))
instance (Monad m) => Applicative (ListT m) where
pure a = Select (yield a)
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)
m >>= f = Select (for (enumerate m) (\a -> enumerate (f a)))
fail _ = mzero
instance MonadTrans ListT where
lift m = Select (do
a <- lift m
yield a )
instance (MonadIO m) => MonadIO (ListT m) where
liftIO m = lift (liftIO m)
instance (Monad m) => Alternative (ListT m) where
empty = Select (return ())
p1 <|> p2 = Select (do
enumerate p1
enumerate p2 )
instance (Monad m) => MonadPlus (ListT m) where
mzero = empty
mplus = (<|>)
instance MFunctor ListT where
hoist morph = Select . hoist morph . enumerate
instance (Monad m) => Monoid (ListT m a) where
mempty = empty
mappend = (<|>)
instance (MonadState s m) => MonadState s (ListT m) where
get = lift get
put s = lift (put s)
state f = lift (state f)
instance (MonadWriter w m) => MonadWriter w (ListT m) where
writer = lift . writer
tell w = lift (tell w)
listen l = Select (go (enumerate l) mempty)
where
go p w = case p of
Request a' fa -> Request a' (\a -> go (fa a ) w)
Respond b fb' -> Respond (b, w) (\b' -> go (fb' b') w)
M m -> M (do
(p', w') <- listen m
return (go p' $! mappend w w') )
Pure r -> Pure r
pass l = Select (go (enumerate l) mempty)
where
go p w = case p of
Request a' fa -> Request a' (\a -> go (fa a ) w)
Respond (b, f) fb' -> M (pass (return
(Respond b (\b' -> go (fb' b') (f w)), \_ -> f w) ))
M m -> M (do
(p', w') <- listen m
return (go p' $! mappend w w') )
Pure r -> Pure r
instance (MonadReader i m) => MonadReader i (ListT m) where
ask = lift ask
local f l = Select (local f (enumerate l))
reader f = lift (reader f)
instance (MonadError e m) => MonadError e (ListT m) where
throwError e = lift (throwError e)
catchError l k = Select (catchError (enumerate l) (\e -> enumerate (k e)))
runListT :: Monad m => ListT m X -> m ()
runListT l = runEffect (enumerate l)
class Enumerable t where
toListT :: Monad m => t m a -> ListT m a
instance Enumerable ListT where
toListT = id
instance Enumerable IdentityT where
toListT m = Select $ do
a <- lift $ runIdentityT m
yield a
instance Enumerable MaybeT where
toListT m = Select $ do
x <- lift $ runMaybeT m
case x of
Nothing -> return ()
Just a -> yield a
instance Enumerable (ErrorT e) where
toListT m = Select $ do
x <- lift $ runErrorT m
case x of
Left _ -> return ()
Right a -> yield a
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 _ -> closed v
Respond a fu -> return (Right (a, fu ()))
M m -> m >>= go
Pure r -> return (Left r)
each :: (Monad m, Foldable f) => f a -> Producer' a m ()
each = F.foldr (\a p -> yield a >> p) (return ())
every :: (Monad m, Enumerable t) => t m a -> Producer' a m ()
every it = discard >\\ enumerate (toListT it)
discard :: Monad m => a -> m ()
discard _ = return ()
(<-<)
:: Monad m
=> Proxy () b c' c m r
-> Proxy a' a () b m r
-> Proxy a' a c' c m r
p2 <-< p1 = p1 >-> p2