{-# LANGUAGE FlexibleContexts, KindSignatures #-}
module Control.Monad.Trans.Compose (
ComposeT(ComposeT, getComposeT),
) where
import Control.Applicative (
Applicative(pure, (<*>), (*>), (<*)), Alternative(empty, (<|>)) )
import Control.Monad (MonadPlus(mzero, mplus), liftM)
import Control.Monad.Morph (MFunctor(hoist))
import Control.Monad.Trans.Class (MonadTrans(lift))
import Control.Monad.IO.Class (MonadIO(liftIO))
import Data.Foldable (Foldable(fold, foldMap, foldr, foldl, foldr1, foldl1))
import Data.Traversable (Traversable(traverse, sequenceA, mapM, sequence))
import Prelude hiding (foldr, foldl, foldr1, foldl1, mapM, sequence)
newtype ComposeT (f :: (* -> *) -> * -> *) (g :: (* -> *) -> * -> *) m a
= ComposeT { getComposeT :: f (g m) a }
instance (MFunctor f, MonadTrans f, MonadTrans g) => MonadTrans (ComposeT f g)
where
lift = ComposeT . hoist lift . lift
instance Functor (f (g m)) => Functor (ComposeT f g m) where
fmap f (ComposeT m) = ComposeT (fmap f m)
instance Applicative (f (g m)) => Applicative (ComposeT f g m) where
pure a = ComposeT (pure a)
ComposeT f <*> ComposeT a = ComposeT (f <*> a)
ComposeT a *> ComposeT b = ComposeT (a *> b)
ComposeT a <* ComposeT b = ComposeT (a <* b)
instance Alternative (f (g m)) => Alternative (ComposeT f g m) where
empty = ComposeT empty
ComposeT a <|> ComposeT b = ComposeT (a <|> b)
instance Monad (f (g m)) => Monad (ComposeT f g m) where
return a = ComposeT (return a)
m >>= f = ComposeT (getComposeT m >>= \x -> getComposeT (f x))
fail e = ComposeT (fail e)
instance MonadPlus (f (g m)) => MonadPlus (ComposeT f g m) where
mzero = ComposeT mzero
ComposeT a `mplus` ComposeT b = ComposeT (a `mplus` b)
instance MonadIO (f (g m)) => MonadIO (ComposeT f g m) where
liftIO m = ComposeT (liftIO m)
instance Foldable (f (g m)) => Foldable (ComposeT f g m) where
fold (ComposeT m) = fold m
foldMap f (ComposeT m) = foldMap f m
foldr f a (ComposeT m) = foldr f a m
foldl f a (ComposeT m) = foldl f a m
foldr1 f (ComposeT m) = foldr1 f m
foldl1 f (ComposeT m) = foldl1 f m
instance Traversable (f (g m)) => Traversable (ComposeT f g m) where
traverse f (ComposeT m) = fmap ComposeT (traverse f m)
sequenceA (ComposeT m) = fmap ComposeT (sequenceA m)
mapM f (ComposeT m) = liftM ComposeT (mapM f m)
sequence (ComposeT m) = liftM ComposeT (sequence m)