{-- |
Module      : Control.Monad.Trans.StringErrorT
Description : A variant of MaybeT transformer that returns an error string in case of failure
Copyright   : (c) Mihai Giurgeanu, 2017
License     : GPL-3
Maintainer  : mihai.giurgeanu@gmail.com
Stability   : experimental
Portability : Portable
--}

module Control.Monad.Trans.StringError where

import Control.Monad.Trans.Class (MonadTrans (lift))
import Control.Monad.IO.Class
import Control.Monad (MonadPlus(mzero, mplus))

import Control.Applicative
import Data.Foldable (Foldable(foldMap))
import Data.Traversable (Traversable(traverse))

import qualified Control.Monad.Fail as Fail

newtype StringErrorT m a = StringErrorT {runStringErrorT :: m (Either String a) }

-- | Transform the computation inside a @StringErrorT@.
--
-- * @'runStringErrorT' ('mapStringErrorT' f m) = f ('runStringErrorT' m)@
mapStringErrorT :: (m (Either String a) -> n (Either String b)) -> StringErrorT m a -> StringErrorT n b
mapStringErrorT f = StringErrorT . f . runStringErrorT
{-# INLINE mapStringErrorT #-}


instance MonadTrans StringErrorT where
  lift m = StringErrorT  $ m >>= (\ x -> return $ Right x)

instance (Functor m) => Functor (StringErrorT m) where
    fmap f = mapStringErrorT (fmap (fmap f))
    {-# INLINE fmap #-}

instance (Foldable f) => Foldable (StringErrorT f) where
    foldMap f (StringErrorT a) = foldMap (foldMap f) a
    {-# INLINE foldMap #-}

instance (Traversable f) => Traversable (StringErrorT f) where
    traverse f (StringErrorT a) = StringErrorT <$> traverse (traverse f) a
    {-# INLINE traverse #-}

instance (Functor m, Monad m) => Applicative (StringErrorT m) where
    pure = StringErrorT . return . Right
    {-# INLINE pure #-}
    mf <*> mx = StringErrorT $ do
        mb_f <- runStringErrorT mf
        case mb_f of
            Left s  -> return (Left s)
            Right f -> do
                mb_x <- runStringErrorT mx
                case mb_x of
                    Left s  -> return (Left s)
                    Right x -> return (Right (f x))
    {-# INLINE (<*>) #-}
    m *> k = m >>= \_ -> k
    {-# INLINE (*>) #-}

instance (Functor m, Monad m) => Alternative (StringErrorT m) where
    empty = StringErrorT (return $ Left "")
    {-# INLINE empty #-}
    x <|> y = StringErrorT $ do
        v <- runStringErrorT x
        case v of
            Left _  -> runStringErrorT y
            Right _ -> return v
    {-# INLINE (<|>) #-}



instance (Monad m) => Monad (StringErrorT m) where
  return = StringErrorT . return . Right
  {-# INLINE return #-}

  (>>=) x f = StringErrorT $ do
    v <- runStringErrorT x
    case v of
      Left s  -> return (Left s)
      Right y -> runStringErrorT (f y)
  {-# INLINE (>>=) #-}

  fail s = StringErrorT (return $ Left s)
  {-# INLINE fail #-}


instance (Monad m) => Fail.MonadFail (StringErrorT m) where
  fail s = StringErrorT (return $ Left s)
  {-# INLINE fail #-}

instance (MonadIO m) => MonadIO (StringErrorT m) where
  liftIO = lift . liftIO
  {-# INLINE liftIO #-}

instance (Monad m) => MonadPlus (StringErrorT m) where
  mzero = StringErrorT (return $ Left "")
  {-# INLINE mzero #-}
  mplus x y = StringErrorT $ do
    v <- runStringErrorT x
    case v of
      Left _  -> runStringErrorT y
      Right _ -> return v
  {-# INLINE mplus #-}