module Control.Proxy.ListT (
RespondT(..),
runRespondK,
ProduceT,
RequestT(..),
runRequestK,
CoProduceT,
ListT(..),
(\>\),
(/>/),
(/</),
(\<\),
(//<),
(<\\)
) where
import Control.Applicative (Applicative(pure, (<*>)), Alternative(empty, (<|>)))
import Control.Monad (MonadPlus(mzero, mplus))
import Control.Monad.IO.Class (MonadIO(liftIO))
import Control.Monad.Trans.Class (MonadTrans(lift))
import Control.Proxy.Class (Proxy(request, respond), return_P, (?>=), lift_P)
import Control.Proxy.Synonym (C)
import Data.Monoid (Monoid(mempty, mappend))
import Control.Monad ((>=>), (<=<))
newtype RespondT (p :: * -> * -> * -> * -> (* -> *) -> * -> *) a' a b' m b =
RespondT { runRespondT :: p a' a b' b m b' }
instance (Monad m, ListT p) => Functor (RespondT p a' a b' m) where
fmap f p = RespondT (runRespondT p //> \a -> respond (f a))
instance (Monad m, ListT p) => Applicative (RespondT p a' a b' m) where
pure a = RespondT (respond a)
mf <*> mx = RespondT (
runRespondT mf //> \f ->
runRespondT mx //> \x ->
respond (f x) )
instance (Monad m, ListT p) => Monad (RespondT p a' a b' m) where
return a = RespondT (respond a)
m >>= f = RespondT (runRespondT m //> \a -> runRespondT (f a))
instance (ListT p) => MonadTrans (RespondT p a' a b') where
lift m = RespondT (lift_P m ?>= \a -> respond a)
instance (MonadIO m, ListT p) => MonadIO (RespondT p a' a b' m) where
liftIO m = lift (liftIO m)
instance (Monad m, ListT p, Monoid b')
=> Alternative (RespondT p a' a b' m) where
empty = RespondT (return_P mempty)
p1 <|> p2 = RespondT (
runRespondT p1 ?>= \r1 ->
runRespondT p2 ?>= \r2 ->
return_P (mappend r1 r2) )
instance (Monad m, ListT p, Monoid b') => MonadPlus (RespondT p a' a b' m) where
mzero = empty
mplus = (<|>)
runRespondK :: (q -> RespondT p a' a b' m b) -> (q -> p a' a b' b m b')
runRespondK k q = runRespondT (k q)
type ProduceT p = RespondT p C () ()
newtype RequestT (p :: * -> * -> * -> * -> (* -> *) -> * -> *) a b' b m a' =
RequestT { runRequestT :: p a' a b' b m a }
instance (Monad m, ListT p) => Functor (RequestT p a b' b m) where
fmap f p = RequestT (runRequestT p //< \a -> request (f a))
instance (Monad m, ListT p) => Applicative (RequestT p a b' b m) where
pure a = RequestT (request a)
mf <*> mx = RequestT (
runRequestT mf //< \f ->
runRequestT mx //< \x ->
request (f x) )
instance (Monad m, ListT p) => Monad (RequestT p a b' b m) where
return a = RequestT (request a)
m >>= f = RequestT (runRequestT m //< \a -> runRequestT (f a))
instance (ListT p) => MonadTrans (RequestT p a' a b') where
lift m = RequestT (lift_P m ?>= \a -> request a)
instance (MonadIO m, ListT p) => MonadIO (RequestT p a b' b m) where
liftIO m = lift (liftIO m)
instance (Monad m, ListT p, Monoid a)
=> Alternative (RequestT p a b' b m) where
empty = RequestT (return_P mempty)
p1 <|> p2 = RequestT (
runRequestT p1 ?>= \r1 ->
runRequestT p2 ?>= \r2 ->
return_P (mappend r1 r2) )
instance (Monad m, ListT p, Monoid a) => MonadPlus (RequestT p a b' b m) where
mzero = empty
mplus = (<|>)
runRequestK :: (q -> RequestT p a b' b m a') -> (q -> p a' a b' b m a)
runRequestK k q = runRequestT (k q)
type CoProduceT p = RequestT p () () C
infixr 8 /</, >\\
infixl 8 \>\, //<
infixl 8 \<\, //>
infixr 8 />/, <\\
class (Proxy p) => ListT p where
(>\\)
:: (Monad m)
=> (b' -> p a' a x' x m b)
-> p b' b x' x m c
-> p a' a x' x m c
(//>)
:: (Monad m)
=> p x' x b' b m a'
-> (b -> p x' x c' c m b')
-> p x' x c' c m a'
(\>\)
:: (Monad m, ListT p)
=> ( b' -> p a' a x' x m b)
-> (_c' -> p b' b x' x m c)
-> (_c' -> p a' a x' x m c)
f \>\ g = \c' -> f >\\ g c'
(/>/)
:: (Monad m, ListT p)
=> (_a -> p x' x b' b m a')
-> ( b -> p x' x c' c m b')
-> (_a -> p x' x c' c m a')
f />/ g = \a -> f a //> g
(/</)
:: (Monad m, ListT p)
=> (_c' -> p b' b x' x m c)
-> ( b' -> p a' a x' x m b)
-> (_c' -> p a' a x' x m c)
p1 /</ p2 = p2 \>\ p1
(\<\)
:: (Monad m, ListT p)
=> ( b -> p x' x c' c m b')
-> (_a -> p x' x b' b m a')
-> (_a -> p x' x c' c m a')
p1 \<\ p2 = p2 />/ p1
(//<)
:: (Monad m, ListT p)
=> p b' b x' x m c
-> (b' -> p a' a x' x m b)
-> p a' a x' x m c
p //< f = f >\\ p
(<\\)
:: (Monad m, ListT p)
=> (b -> p x' x c' c m b')
-> p x' x b' b m a'
-> p x' x c' c m a'
f <\\ p = p //> f