module Control.Monad.Failure (module Control.Monad.Failure.Class, FailureT (..)) where

import Prelude hiding (fail);

import Control.Monad hiding (fail);
import Control.Monad.Fix;
import Control.Monad.Trans;
import Control.Monad.Failure.Class;
import Data.Traversable;

newtype FailureT f m a = FailureT { runFailureT :: m (Either f a) };

mapFailureT :: (m (Either f a) -> n (Either f b)) -> FailureT f m a -> FailureT f n b;
mapFailureT f = FailureT . f . runFailureT;

instance MonadTrans (FailureT f) where {
  lift = FailureT . liftM Right;
  tmap f _ = mapFailureT f;
};

instance Functor m => Functor (FailureT f m) where {
  fmap = mapFailureT . fmap . fmap;
};

instance Monad m => Monad (FailureT f m) where {
  return = lift . return;
  FailureT x >>= f = FailureT $ x >>= liftM join . either (liftM Left . return) (liftM Right . runFailureT . f);
};

instance MonadFix m => MonadFix (FailureT f m) where {
  mfix f = FailureT $ mfix (either (return . Left) (runFailureT . f));
};

instance (Monad m, MonadTrans xT, Monad (xT (FailureT f m))) => MonadFailure f (xT (FailureT f m)) where {
  fail = lift . fail;
};

instance Monad m => MonadFailure f (FailureT f m) where {
  fail = FailureT . return . Left;
};

instance Monad m => MonadSalvage f (FailureT f m) where {
  save f = mapFailureT (>>= runFailureT . either f return);
};