module Control.Monad.Trans.Continue (
ContinueT (..)
, stop
, failure
, continue
, hoistContinue
, mapContinueT
, bimapContinueT
, firstContinueT
, secondContinueT
, mapFailure
, stopFromNothing
, hoistEither
, liftEitherT
, liftExceptT
, runToEitherT
, runToExceptT
) where
import Data.Continue (Continue (..))
import Control.Applicative (Applicative (..))
import Control.Monad (Monad (..))
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Trans.Class (MonadTrans (..), lift)
import Control.Monad.Trans.Except (ExceptT (..))
import qualified Control.Monad.Trans.Except as Except
import Data.Bifunctor (Bifunctor (..))
import Data.Either (Either (..))
import Data.Foldable (Foldable (..))
import Data.Function (($), (.), id)
import Data.Functor (Functor (..), (<$>))
import Data.Maybe (Maybe (..))
import Data.Traversable (Traversable (..))
newtype ContinueT x m a =
ContinueT {
runContinueT :: m (Continue x a)
} deriving (Functor, Foldable, Traversable)
instance (Applicative m, Monad m) => Applicative (ContinueT x m) where
(<*>) f fa =
ContinueT $ do
fab <- runContinueT f
a <- runContinueT fa
case a of
Stop ->
pure Stop
Failure e ->
pure $ Failure e
Continue ax ->
pure $ ($ ax) <$> fab
pure a =
ContinueT . pure $ pure a
instance Monad m => Monad (ContinueT x m) where
(>>=) ma f =
ContinueT $ do
a <- runContinueT ma
case a of
Stop ->
pure $ Stop
Failure x ->
pure $ Failure x
Continue ax ->
runContinueT $ f ax
return =
ContinueT . return . return
instance MonadIO m => MonadIO (ContinueT x m) where
liftIO =
lift . liftIO
instance MonadTrans (ContinueT x) where
lift =
ContinueT . fmap Continue
stop :: Applicative m => ContinueT x m a
stop =
ContinueT . pure $ Stop
failure :: Applicative m => x -> ContinueT x m a
failure =
ContinueT . pure . Failure
continue :: Applicative m => a -> ContinueT x m a
continue =
ContinueT . pure . Continue
hoistContinue :: Monad m => Continue x a -> ContinueT x m a
hoistContinue =
ContinueT . return
mapContinueT :: (m (Continue x a) -> n (Continue y b)) -> ContinueT x m a -> ContinueT y n b
mapContinueT f =
ContinueT . f . runContinueT
bimapContinueT :: Functor m => (x -> y) -> (a -> b) -> ContinueT x m a -> ContinueT y m b
bimapContinueT f g =
mapContinueT (fmap (bimap f g))
firstContinueT :: Functor m => (x -> y) -> ContinueT x m a -> ContinueT y m a
firstContinueT f =
bimapContinueT f id
secondContinueT :: Functor m => (a -> b) -> ContinueT x m a -> ContinueT x m b
secondContinueT f =
bimapContinueT id f
mapFailure :: Functor m => (x -> y) -> ContinueT x m a -> ContinueT y m a
mapFailure =
firstContinueT
stopFromNothing :: Applicative m => Maybe a -> ContinueT x m a
stopFromNothing m =
case m of
Nothing ->
stop
Just a ->
continue a
hoistEither :: Applicative m => Either x a -> ContinueT x m a
hoistEither e =
case e of
Left x ->
failure x
Right a ->
continue a
runToEitherT :: Monad m => ContinueT x m () -> ExceptT x m ()
runToEitherT =
runToExceptT
runToExceptT :: Monad m => ContinueT x m () -> ExceptT x m ()
runToExceptT c = do
r <- lift $ runContinueT c
case r of
Stop ->
pure ()
Failure x ->
Except.throwE x
Continue a ->
ExceptT . pure $ pure a
liftEitherT :: Monad m => ExceptT x m a -> ContinueT x m a
liftEitherT =
liftExceptT
liftExceptT :: Monad m => ExceptT x m a -> ContinueT x m a
liftExceptT e =
ContinueT $ do
r <- Except.runExceptT e
return $ case r of
Left x ->
Failure x
Right a ->
Continue a