module Control.Monad.Fail
       ( -- * Intro
         -- $intro

         -- * Failing monad
         FailT(..)
       , runFailC
       , runFailI
       , mapFailTBase
       , mapFailTFail
        -- * Helper functions
       , mfail
       , mwarn
       ) where

import Control.Applicative
import Control.Applicative.Fail
import Control.Monad
import Control.Monad.Base
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Writer
import Data.Bifunctor
import Data.Foldable
import Data.Functor.Compose
import Data.Functor.Identity
import Data.Monoid
import Data.Traversable
import Data.Tuple
import Data.Typeable
import GHC.Generics

#if MIN_VERSION_mtl(2,2,1)
import Control.Monad.Except
#else
import Control.Monad.Error
#endif

{- $intro

Failing monad transformer, which behaves in general like
'EitherT' but it also supports warnings. In short, it behaves like
combination of 'EitherT' and 'WriterT' transformers and built on
'Fail' applicative functor.

>>> runFailT $ do {a <- return 10; b <- return 20; return (a, b)}
Success (10,20)

>>> runFailT $ (,) <$> pure 10 <*> pure 20
Success (10,20)

>>> fmap runDLFail $ runFailT $ do {a <- mfail 10 ; b <- mfail 20; return (a, b)}
([10],Nothing)

>>> fmap runDLFail $ runFailT $ (,) <$> mfail 10 <*> mfail 20
([10],Nothing)

Note, that Applicative instance behaves just like Monad: it fails
immediately. 'FailT' also supports warning like 'Fail' does:

>>> fmap runDLFail $ runFailT $ do {a <- mwarn 10 *> return 15; b <- return 20; return (a, b)}
([10],Just (15,20))

>>> fmap runDLFail $ runFailT $ (,) <$> (mwarn 10 *> return 15) <*> return 20
([10],Just (15,20))

You can also combine 'FailT' with 'Fail' using 'Compose' like that:

>>> let check10 = do {liftBase $ print "checking 10"; return 10}
>>> let check20 = do {liftBase $ print "checking 20"; mwarn "oups"; return 20}
>>> fmap runDLFail $ getCompose $ (,) <$> runFailC check10 <*> runFailC check20
"checking 10"
"checking 20"
(["oups"],Just (10,20))

Note how 'Compose' functor is used here.

>>> let fail10 = do {liftBase $ print "failing 10"; mfail "10 is failed"}
>>> fmap runDLFail $ getCompose $ (,) <$> runFailC fail10 <*> runFailC check20
"failing 10"
"checking 20"
(["10 is failed","oups"],Nothing)

Note how second checker was runned even after first checker failed
(got "oups" message). This is because internal (monadic) checkers
unrolled back to __IO (Fail e a)__ and wrapped to 'Compose' so infered
type of __runFailC fail10__ is __Compose IO (Fail (DList String)) a__

Example from "Control.Applicative.Fail" can be also rewritten more convenient:

>>> :{
data Animal = Animal
    { species :: String
    , weight  :: Double
    , age     :: Int
    } deriving (Show)
:}

>>> let spc = "Parastratiosphecomyia stratiosphecomyioides"
>>> let w = 100
>>> let a = 27234
>>> :{
let animal :: Fail [String] Animal
    animal = Animal
             <$> (runFailI $ do
                          when (length spc > 20) $ mwarn "Name is too long"
                          when (spc == "") $ mfail "Name can not be empty"
                          return spc)
             <*> (runFailI $ do
                          when (w < 0) $ mfail "Weight can not be negative"
                          return w)
             <*> (runFailI $ do
                          when (a < 0) $ mfail "Age can not be negative"
                          return a)
:}

>>> animal
Fail ["Name is too long"] (Just (Animal {species = "Parastratiosphecomyia stratiosphecomyioides", weight = 100.0, age = 27234}))

Monadic interface is much more comfortable here
-}


newtype FailT e m a = FailT
    { runFailT :: m (Fail e a)
    } deriving ( Functor, Foldable, Traversable
               , Typeable, Generic )

-- | Unwraps 'FailT' and wraps result into 'Compose' functor. Usable
-- for convenient composition of 'Fail' where 'FailT' works inside.
runFailC :: FailT e m a -> Compose m (Fail e) a
runFailC = Compose . runFailT
{-# INLINEABLE runFailC #-}

runFailI :: FailT e Identity a -> Fail e a
runFailI = runIdentity . runFailT
{-# INLINEABLE runFailI #-}

mapFailTBase :: (forall x. m x -> n x) -> FailT e m a -> FailT e n a
mapFailTBase f (FailT ma) = FailT $ f ma
{-# INLINEABLE mapFailTBase #-}

-- | Like 'first' from 'Bifunctor' maps error type
mapFailTFail :: (Functor m) => (e -> e') -> FailT e m a -> FailT e' m a
mapFailTFail f (FailT ma) = FailT $ fmap (first f) ma
{-# INLINEABLE mapFailTFail #-}

deriving instance Eq (m (Fail e a)) => Eq (FailT e m a)
deriving instance Ord (m (Fail e a)) => Ord (FailT e m a)
deriving instance Show (m (Fail e a)) => Show (FailT e m a)

instance (Applicative m, Monoid a, Monoid e) => Monoid (FailT e m a) where
    mempty = FailT $ pure $ mempty
    {-# INLINEABLE mempty #-}
    mappend (FailT a) (FailT b) = FailT $ mappend <$> a <*> b
    {-# INLINEABLE mappend #-}

-- | NOTE: This instance behaves not like 'Applicative' for
-- 'Fail'. This applicative does not try to collect all posible fails,
-- it returns fast like 'EitherT' to match the 'Monad' isntance
-- behaviour.
instance (Monoid e, Functor m, Monad m) => Applicative (FailT e m) where
    pure a = return a
    {-# INLINEABLE pure #-}
    mf <*> ma = mf >>= \f -> fmap f ma
    {-# INLINEABLE (<*>) #-}

instance (Monoid e, Monad m) => Monad (FailT e m) where
    return a = FailT $ return $ pure a
    {-# INLINEABLE return #-}

    x >>= f = FailT $ runFailT x >>= \case
        Success a -> runFailT $ f a
        Fail e (Just a) -> runFailT (f a) >>= \case
            Success b -> return $ Fail e (Just b)
            Fail e' mb -> return $ Fail (e <> e') mb
        Fail e Nothing -> return $ Fail e Nothing
    {-# INLINEABLE (>>=) #-}

instance MonadTrans (FailT e) where
    lift ma = FailT $ liftM Success ma
    {-# INLINEABLE lift #-}

instance (Monoid e, MonadBase b m) => MonadBase b (FailT e m) where
    liftBase = lift . liftBase
    {-# INLINEABLE liftBase #-}

instance (MonadReader r m, Monoid e) => MonadReader r (FailT e m) where
    ask = lift ask
    {-# INLINEABLE ask #-}
    local f action = FailT $ do
        local f (runFailT action)
    {-# INLINEABLE local #-}
    reader = lift . reader
    {-# INLINEABLE reader #-}

instance (MonadState s m, Monoid e) => MonadState s (FailT e m) where
    get = lift get
    {-# INLINEABLE get #-}
    put = lift . put
    {-# INLINEABLE put #-}
    state = lift . state
    {-# INLINEABLE state #-}

instance (MonadWriter w m, Monoid e) => MonadWriter w (FailT e m) where
    writer = lift . writer
    {-# INLINEABLE writer #-}
    tell = lift . tell
    {-# INLINEABLE tell #-}
    listen action = FailT $ do
        (f, w) <- listen (runFailT action)
        return $ fmap (,w) f
    {-# INLINEABLE listen #-}
    pass action = FailT $ do
        a <- runFailT action
        let x = sequenceA $ fmap swap a
        pass $ return $ swap x
    {-# INLINEABLE pass #-}

instance (Monad m, Monoid e) => MonadError e (FailT e m) where
    throwError e = FailT $ return $ Fail e Nothing
    catchError ma handler = FailT $ runFailT ma >>= \case
        res@(Success _) -> return res
        (Fail e _)      -> runFailT $ handler e


mfail :: (Applicative f, Applicative m) => e -> FailT (f e) m a
mfail e = FailT $ pure $ afail e
{-# INLINEABLE mfail #-}

mwarn :: (Applicative f, Applicative m) => e -> FailT (f e) m ()
mwarn e = FailT $ pure $ awarn e ()
{-# INLINEABLE mwarn #-}