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

import Prelude hiding (fail);

import Control.Applicative;
import Control.Category.Unicode;
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 Applicative m => Applicative (FailureT f m) where {
  pure = FailureT ∘ pure ∘ Right;
  FailureT f <*> FailureT x = let {
    go (Right φ) (Right χ) = Right (φ χ);
    go (Right _) (Left  e) = Left e;
    go (Left  e)  _        = Left e;
  } in FailureT (liftA2 go f x);
};

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);
};