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

         -- * Fail
         Fail(..)
       , runFail
       , runDLFail
       , afail
       , awarn
       , fNull
       , getFail
       , getSucc
         -- * Combinators
       , failEither
       , joinFail
       ) where

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

import qualified Data.DList as DL

{- $intro

Assume you have some type

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

And you would like to produce this value from some data (e.g. query
parameters). There can be some warnigns or value can not be produced
at all. It would be great to have some simple tool to notify about
warnings and/or fail computation.

Like that:

>>> let spc = "Parastratiosphecomyia stratiosphecomyioides"
>>> let w = 100
>>> let a = 27234
>>> :{
let animal :: Fail [String] Animal
    animal = Animal
             <$> (if length spc > 20
                  then awarn "Name is too long" spc
                  else if spc == ""
                       then afail "Name can not be empty"
                       else pure spc)
             <*> (if w < 0
                  then afail "Weight can not be negative"
                  else pure w)
             <*> (if a < 0
                  then afail "Age can not be negative"
                  else pure a)
:}

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

>>> getSucc animal
Just (Animal {species = "Parastratiosphecomyia stratiosphecomyioides", weight = 100.0, age = 27234})

>>> getFail animal
Just ["Name is too long"]

Now you can build your own parser-like things

-}


{- | 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

-}

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

-- | Unwraps 'Fail' to tuple of error and value. If pattern is
-- 'Success' then return 'mempty' in error part.
runFail :: (Monoid e) => Fail e a -> (e, Maybe a)
runFail (Success a) = (mempty, Just a)
runFail (Fail e a)  = (e, a)

-- | Unwraps 'Fail' and constrain error container to 'DList' for type
-- inference
runDLFail :: Fail (DList e) a -> ([e], Maybe a)
runDLFail = first DL.toList . runFail

-- | Return True if pattern does not contain not success value nor
-- fails, i.e. (Fail mempty Nothing)
fNull :: (Eq e, Monoid e) => Fail e a -> Bool
fNull (Fail ((== mempty) -> True) Nothing) = True
fNull _                                    = False

afail :: Applicative f => e -> Fail (f e) a
afail e = Fail (pure e) Nothing

awarn :: Applicative f => e -> a -> Fail (f e) a
awarn e a = Fail (pure e) (Just a)

-- | Return 'Right' if there is value (including pattern '(Fail e
-- (Just a))'). If there is no value return 'Left'
failEither :: Fail e a -> Either e a
failEither (Success a)       = Right a
failEither (Fail _ (Just a)) = Right a
failEither (Fail e Nothing)  = Left e

-- | Return fail part if exists
getFail :: Fail e a -> Maybe e
getFail (Fail e _) = Just e
getFail _ = Nothing

-- | Return success part if exists
getSucc :: Fail e a -> Maybe a
getSucc (Success a) = Just a
getSucc (Fail _ a) = a

-- | Join two fails like monad does. This function still match to 'Applicative'
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