module MonadLib.Compose
(
mid
, ComposeM(..)
, (<<<)
, (>>>)
, derive_mcompose
, derive_mapply
)
where
import Data.Monoid
import MonadLib
import MonadLib.Derive
import MonadLib.Monads
mid :: ReaderM m s => m s
mid = ask
class (Monad m, Monad n) => ComposeM m n s t | m -> s, n -> t, n s -> m where
mcompose :: m a -> n s -> n a
mcompose m n = mapply m =<< n
mapply :: m a -> s -> n a
mapply m s = mcompose m (return s)
(<<<) :: ComposeM m n s t => m a -> n s -> n a
(<<<) = mcompose
infixr 1 <<<
(>>>) :: ComposeM m n s t => n s -> m a -> n a
(>>>) = flip mcompose
infixl 1 >>>
derive_mcompose :: ComposeM m n s t => Iso m o -> Iso n p -> o a -> p s -> p a
derive_mcompose (Iso _ openM) (Iso closeN openN) m n = closeN $ mcompose (openM m) (openN n)
derive_mapply :: ComposeM m n s t => Iso m o -> Iso n p -> o a -> s -> p a
derive_mapply (Iso _ openM) (Iso closeN _) m s = closeN $ mapply (openM m) s
instance ComposeM ((->) s) ((->) t) s t where
mcompose = (.)
instance Monad m => ComposeM (ReaderT s m) (ReaderT t m) s t where
mapply m s = lift (runReaderT s m)
instance ComposeM (Reader s) (Reader t) s t where
mcompose m n = asks $ flip runReader m . flip runReader n
x_mapply :: (MonadT xt, ComposeM 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
instance ComposeM m n s t => ComposeM (IdT m) (IdT n) s t where
mapply = x_mapply return runIdT
instance (ComposeM m n s t, Monoid w) => ComposeM (WriterT w m) (WriterT w n) s t where
mapply = x_mapply puts runWriterT
instance ComposeM m n s t => ComposeM (ExceptionT e m) (ExceptionT e n) s t where
mapply = x_mapply raises runExceptionT
instance ComposeM m n s t => ComposeM (StateT i m) (StateT i n) s t where
mapply m s = do
i <- get
(u, i') <- lift $ mapply (runStateT i m) s
set i'
return u
instance ComposeM m n s t => ComposeM (ChoiceT m) (ChoiceT n) s t where
mapply m s = do
u <- lift $ mapply (runChoiceT m) s
case u of
Nothing -> mzero
Just (a, m') -> return a `mplus` (mapply m' s)