module Control.Applicative.Fail
       ( Fail(..)
       , ffail
       , fwarn
       , fsucc
       , getFail
       , getSucc
         -- * Combinators
       , failEither
       , joinFail
       , bindFail
       , composeFail
       ) where

import Control.Applicative
import Data.Bifunctor
import Data.Foldable
import Data.Monoid
import Data.Traversable
import Data.Typeable
import GHC.Generics


{-| Applicative functor which collects all the fails instead of
immediate returning first fail like `Either`. It can not be a monad
because of differenct logic in Applicative.  Applicative instance of
Fail continue to fold fails even when 'Fail e Nothing' pattern is
met. Monad instance can not behave like that, so 'Fail' have no Monad
instance

Example usage:

>>> (,,) <$> Fail [10] (Just 10) <*> Success 10 <*> Success 20
Fail [10] (Just (10,10,20))
>>> (,) <$> Fail [1] Nothing <*> Success 10
Fail [1] Nothing
>>> (,) <$> Fail [1] (Just 10) <*> Fail [2] (Just 20)
Fail [1,2] (Just (10,20))

or like that:

>>> (,) <$> ffail "oups" <*> fsucc 10
Fail ["oups"] Nothing
>>> (,,) <$> fwarn "oups" 10 <*> fwarn "meh" 20 <*> fsucc 30
Fail ["oups","meh"] (Just (10,20,30))
>>> (,,) <$> ffail "oups" <*> ffail "meh" <*> fsucc 30
Fail ["oups","meh"] Nothing

This type is usefull for form parsing and returning your own type of
errors

-}

data Fail e a
    = Fail e (Maybe a) -- ^ (Just a) when checking may proceed in Applicative
    | Success a
    deriving ( Eq, Ord, Show, Read, Functor
             , Foldable, Traversable
             , Typeable, Generic )

instance Bifunctor Fail where
    bimap fe fa (Fail e a) = Fail (fe e) (fa <$> a)
    bimap _ fa (Success a) = Success (fa a)

instance (Monoid e) => Applicative (Fail e) where
    pure a = Success a
    (Success f) <*> a = fmap f a
    (Fail e1 f) <*> (Fail e2 a) = Fail (e1 <> e2) (f <*> a)
    (Fail e f) <*> (Success a) = Fail e (fmap ($ a) f)

instance (Monoid e, Monoid a) => Monoid (Fail e a) where
    mempty = Success mempty
    mappend (Success a) (Success b) = Success $ a <> b
    mappend (Fail e1 a) (Fail e2 b) = Fail (e1 <> e2) (mappend <$> a <*> b)
    mappend res@(Fail{}) (Success{}) = res -- fail always win
    mappend (Success{}) res@(Fail{}) = res

ffail :: e -> Fail [e] a
ffail e = Fail (pure e) Nothing

fwarn :: e -> a -> Fail [e] a
fwarn e a = Fail [e] (Just a)

fsucc :: a -> Fail e a
fsucc a = Success a

failEither :: Fail e a -> Either e a
failEither (Success a) = Right a
failEither (Fail e _)  = Left e

getFail :: Fail e a -> Maybe e
getFail (Fail e _) = Just e
getFail _ = Nothing

getSucc :: Fail e a -> Maybe a
getSucc (Success a) = Just a
getSucc (Fail _ a) = a

-- | Join two fails like monad does
joinFail :: (Monoid e)
         => Fail e (Fail e a)
         -> Fail e a
joinFail (Success a) = a
joinFail (Fail e a) =
    let ee = maybe e (e <>)
             (a >>= getFail)
        aa = a >>= getSucc
    in Fail ee aa


-- | This is a monadic-like bind. It breaks computation like
-- Maybe and does not correspond to Applicative instance
-- behaviour. So, instead of implementing Monad instance we
-- just implement separate 'bind' operator
bindFail :: (Monoid e)
         => Fail e a
         -> (a -> Fail e b)
         -> Fail e b
bindFail a f = joinFail $ fmap f a
infixl 1 `bindFail`

composeFail :: (Monoid e)
            => (a -> Fail e b)
            -> (b -> Fail e c)
            -> a
            -> Fail e c
composeFail l r a = bindFail (l a) r
infixl 1 `composeFail`