{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances #-} {- | Copyright : 2010 Aristid Breitkreuz License : BSD3 Stability : experimental Portability : portable This module provides Arrow-like monad composition for transformers. To be more precise, it is "Category-like", i.e. the parallels are to 'Control.Category.Category'. /This version has been adapted from monadLib-compose, to work with the transformers package./ 'Control.Category.Category' generalises '.' and 'id' to arrows and categories. One such arrow is 'Kleisli', which represents functions returning monadic values. Incidentally, that's equivalent to 'ReaderT'! So it turns out that it is possible to generalise '.' and 'id' to 'ReaderT' ('id' is just 'ask'), as well as to many monad transformer stacks that embed a 'ReaderT' inside. -} module Control.Monad.Compose.Class ( MonadCompose(..) , (<<<) , (>>>) ) where import Control.Monad.Trans.Class import Control.Monad.Trans.Error import Control.Monad.Trans.Identity import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader import Data.Monoid import qualified Control.Monad.Trans.RWS.Lazy as LazyRWS import qualified Control.Monad.Trans.RWS.Strict as StrictRWS import qualified Control.Monad.Trans.State.Lazy as Lazy import qualified Control.Monad.Trans.State.Strict as Strict import qualified Control.Monad.Trans.Writer.Lazy as Lazy import qualified Control.Monad.Trans.Writer.Strict as Strict --import Control.Monad.Logic (LogicT(..), runLogicT) -- | Composable monads. Compare with 'Control.Category.Category'. -- Note that there are two different monad types involved in each instance. class (Monad m, Monad n) => MonadCompose m n s t | m -> s, n -> t, n s -> m where -- | Compose two monadic values from right to left. @mcompose f g@ is -- comparable to @f . g@ but for monadic values. Compare with 'Control.Category..'. mcompose :: m a -> n s -> n a mcompose m n = mapply m =<< n -- | Apply a constant value to a composable monad. mapply :: m a -> s -> n a mapply m s = mcompose m (return s) -- | Compose two monadic values from right to left. Compare with 'Control.Category.<<<'. -- @f <<< g@ is equivalent to @mcompose f g@. (<<<) :: MonadCompose m n s t => m a -> n s -> n a (<<<) = mcompose infixr 1 <<< -- | Compose two monadic values from left to right. Compare with 'Control.Category.>>>'. -- @g >>> f@ is equivalent to @mcompose f g@. (>>>) :: MonadCompose m n s t => n s -> m a -> n a (>>>) = flip mcompose infixl 1 >>> instance MonadCompose ((->) s) ((->) t) s t where mcompose = (.) instance Monad m => MonadCompose (ReaderT s m) (ReaderT t m) s t where mapply m a = ReaderT $ \_ -> runReaderT m a x_mapply :: (MonadTrans xt, MonadCompose m n s t, Monad (xt n)) => (a -> xt n b) -> (xt m c -> m a) -> xt m c -> s -> xt n b x_mapply close open m s = lift (open m `mapply` s) >>= close x_mapply' :: (MonadTrans xt, MonadCompose m n s t, Monad (xt n)) => (n a -> xt n b) -> (xt m c -> m a) -> xt m c -> s -> xt n b x_mapply' close' open = x_mapply (close' . return) open instance MonadCompose m n s t => MonadCompose (IdentityT m) (IdentityT n) s t where mapply = x_mapply return runIdentityT instance MonadCompose m n s t => MonadCompose (MaybeT m) (MaybeT n) s t where mapply = x_mapply' MaybeT runMaybeT instance (MonadCompose m n s t, Error e) => MonadCompose (ErrorT e m) (ErrorT e n) s t where mapply = x_mapply' ErrorT runErrorT instance MonadCompose m n s t => MonadCompose (Lazy.StateT i m) (Lazy.StateT i n) s t where mapply m a = Lazy.StateT $ \i -> mapply (Lazy.runStateT m i) a instance MonadCompose m n s t => MonadCompose (Strict.StateT i m) (Strict.StateT i n) s t where mapply m a = Strict.StateT $ \i -> mapply (Strict.runStateT m i) a instance (MonadCompose m n s t, Monoid w) => MonadCompose (Lazy.WriterT w m) (Lazy.WriterT w n) s t where mapply = x_mapply' Lazy.WriterT Lazy.runWriterT instance (MonadCompose m n s t, Monoid w) => MonadCompose (Strict.WriterT w m) (Strict.WriterT w n) s t where mapply = x_mapply' Strict.WriterT Strict.runWriterT instance (Monad m, Monoid w) => MonadCompose (LazyRWS.RWST s w i m) (LazyRWS.RWST t w i m) s t where mapply m a = LazyRWS.RWST $ \_ i -> LazyRWS.runRWST m a i instance (Monad m, Monoid w) => MonadCompose (StrictRWS.RWST s w i m) (StrictRWS.RWST t w i m) s t where mapply m a = StrictRWS.RWST $ \_ i -> StrictRWS.runRWST m a i {- instance MonadCompose m n s t => MonadCompose (LogicT m) (LogicT n) s t where mcompose m n = LogicT $ \sk fk -> runLogicT (mcompose m n) sk fk -}