Phased.hs

module Control.Monad.Trans.Phased where

import Control.Monad
import Control.Applicative
import Control.Monad.Trans.Class
import Control.Monad.IO.Class

newtype PhasedT m a = PhasedT { unPhasedT :: m (Either (PhasedT m a) a) }

instance Functor m => Functor (PhasedT m) where
  fmap f = PhasedT . fmap (either (Left . fmap f) (Right . f)) . unPhasedT

instance (Functor m, Monad m) => Applicative (PhasedT m) where
  pure = return
  (<*>) = ap

instance Monad m => Monad (PhasedT m) where
  k >>= f = PhasedT $ unPhasedT k >>= either (return . Left . (>>= f)) (unPhasedT . f)
  return = PhasedT . return . Right
  fail = PhasedT . fail

instance MonadTrans PhasedT where
  lift = PhasedT . liftM Right

runPhasedT :: Monad m => PhasedT m a -> m a
runPhasedT = either runPhasedT return <=< unPhasedT

instance MonadIO m => MonadIO (PhasedT m) where
  liftIO = PhasedT . liftM Right . liftIO

mapPhasedT :: Monad n => (m (Either (PhasedT m a) a) -> n (Either (PhasedT m a) b)) -> PhasedT m a -> PhasedT n b
mapPhasedT f (PhasedT x) = PhasedT $ return (either (Left . (mapPhasedT f)) Right) `ap` f x