{-# LANGUAGE
FlexibleInstances
, MultiParamTypeClasses
, RankNTypes
, UndecidableInstances
, Trustworthy
#-}
module Pipes.Internal (
Proxy(..)
, unsafeHoist
, observe
, X
, closed
) where
import Control.Applicative (
Applicative(pure, (<*>), (*>)), Alternative(empty, (<|>)) )
import Control.Monad (MonadPlus(..))
import Control.Monad.IO.Class (MonadIO(liftIO))
import Control.Monad.Trans.Class (MonadTrans(lift))
import Control.Monad.Morph (MFunctor(hoist), MMonad(embed))
import Control.Monad.Error (MonadError(..))
import Control.Monad.Reader (MonadReader(..))
import Control.Monad.State (MonadState(..))
import Control.Monad.Writer (MonadWriter(..))
import Data.Monoid (mempty,mappend)
data Proxy a' a b' b m r
= Request a' (a -> Proxy a' a b' b m r )
| Respond b (b' -> Proxy a' a b' b m r )
| M (m (Proxy a' a b' b m r))
| Pure r
instance Monad 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'))
Pure r -> Pure (f r)
instance Monad 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
(*>) = (>>)
instance Monad m => Monad (Proxy a' a b' b m) where
return = Pure
(>>=) = _bind
_bind
:: Monad m
=> Proxy a' a b' b m r
-> (r -> Proxy a' a b' b m r')
-> Proxy a' a b' b m r'
p0 `_bind` f = 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'))
Pure r -> f r
{-# RULES
"_bind (Request a' k) f" forall a' k f .
_bind (Request a' k) f = Request a' (\a -> _bind (k a) f);
"_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 (Pure r ) f" forall r f .
_bind (Pure r ) f = f r;
#-}
instance MonadTrans (Proxy a' a b' b) where
lift m = M (m >>= \r -> return (Pure r))
unsafeHoist
:: Monad 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
instance MFunctor (Proxy a' a b' b) 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
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
instance MonadIO m => MonadIO (Proxy a' a b' b m) where
liftIO m = M (liftIO (m >>= \r -> return (Pure r)))
instance MonadReader r m => MonadReader r (Proxy a' a b' b m) where
ask = lift ask
local 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'))
Pure r -> Pure r
M m -> M (local f m >>= \r -> return (go r))
reader = lift . reader
instance MonadState s m => MonadState s (Proxy a' a b' b m) where
get = lift get
put = lift . put
state = lift . state
instance MonadWriter w m => MonadWriter w (Proxy a' a b' b m) where
writer = lift . writer
tell = lift . tell
listen p0 = go p0 mempty
where
go p w = case p of
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
return (go p' $! mappend w w') )
Pure r -> Pure (r, w)
pass p0 = go p0 mempty
where
go p w = case p of
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
return (go p' $! mappend w w') )
Pure (r, f) -> M (pass (return (Pure r, \_ -> f w)))
instance MonadError e m => MonadError e (Proxy a' a b' b m) where
throwError = lift . throwError
catchError p0 f = 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'))
Pure r -> Pure r
M m -> M ((do
p' <- m
return (go p') ) `catchError` (\e -> return (f e)) )
instance MonadPlus m => Alternative (Proxy a' a b' b m) where
empty = mzero
(<|>) = mplus
instance MonadPlus m => MonadPlus (Proxy a' a b' b m) where
mzero = lift mzero
mplus p0 p1 = 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'))
Pure r -> Pure r
M m -> M ((do
p' <- m
return (go p') ) `mplus` return p1 )
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 )))
Respond b fb' -> return (Respond b (\b' -> observe (fb' b')))
M m' -> m' >>= go
Pure r -> return (Pure r)
newtype X = X X
closed :: X -> a
closed (X x) = closed x