{-# LANGUAGE DataKinds            #-}
{-# LANGUAGE DeriveAnyClass       #-}
{-# LANGUAGE DeriveDataTypeable   #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE TypeOperators        #-}
{-# LANGUAGE UndecidableInstances #-}

{- |
Copyright:  (c) 2014 Chris Allen, Edward Kmett
            (c) 2018-2020 Kowainik
SPDX-License-Identifier: MPL-2.0
Maintainer: Kowainik <xrom.xkov@gmail.com>

Lightweight pure data validation based on 'Applicative' and 'Selective' functors.

'Validation' allows to accumulate all errors instead of
short-circuting on the first error so you can display all possible
errors at once.

Common use-cases include:

1. Validating each input of a form with multiple inputs.
2. Performing multiple validations of a single value.

'Validation' provides __modular__ and __composable__ interface which
means that you can implement validations for different pieces of your
data independently, and then combine smaller parts into the validation
of a bigger type. The below table illustrates main ways to combine two
'Validation's:

+---------------+-------------+---------------------------+---------------------------+---------------------------+---------------------------+
|   Typeclass   | Operation ○ | 'Failure' e ○ 'Failure' d | 'Success' a ○ 'Success' b | 'Failure' e ○ 'Success' a | 'Success' a ○ 'Failure' e |
+===============+=============+===========================+===========================+===========================+===========================+
| 'Semigroup'   | '<>'        | 'Failure' (e '<>' d)      | 'Success' (a '<>' b)      | 'Failure' e               | 'Failure' e               |
+---------------+-------------+---------------------------+---------------------------+---------------------------+---------------------------+
| 'Applicative' | '<*>'       | 'Failure' (e '<>' d)      | 'Success' (a b)           | 'Failure' e               | 'Failure' e               |
+---------------+-------------+---------------------------+---------------------------+---------------------------+---------------------------+
| 'Alternative' | '<|>'       | 'Failure' (e '<>' d)      | 'Success' a               | 'Success' a               | 'Success' a               |
+---------------+-------------+---------------------------+---------------------------+---------------------------+---------------------------+
| 'Selective'   | '<*?'       | 'Failure' e               | 'Selective' choice        | 'Failure' e               | 'Selective' choice        |
+---------------+-------------+---------------------------+---------------------------+---------------------------+---------------------------+

In other words, instances of different standard typeclasses provide
various semantics which can be useful in different use-cases:

1. 'Semigroup': accumulate both 'Failure' and 'Success' with '<>'.
2. 'Monoid': 'Success' that stores 'mempty'.
3. 'Functor': change the type inside 'Success'.
4. 'Bifunctor': change both 'Failure' and 'Success'.
5. 'Applicative': apply function to values inside 'Success' and accumulate
   errors inside 'Failure'.
6. 'Alternative': return the first 'Success' or accumulate all errors
   inside 'Failure'.
7. 'Selective': choose which validations to apply based on the value
   inside.
-}

module Validation
       ( -- * Type
         Validation (..)

         -- * How to use
         -- $use

         -- * Interface functions
       , isFailure
       , isSuccess
       , validation
       , failures
       , successes
       , partitionValidations
       , fromFailure
       , fromSuccess

         -- ** 'NonEmpty' combinators
         -- $nonEmptyCombinators
       , failure
       , failureIf
       , failureUnless

         -- ** 'Either' conversion
         -- $either
       , validationToEither
       , eitherToValidation
       ) where

import Control.Applicative (Alternative (..), Applicative (..))
import Control.DeepSeq (NFData, NFData1, NFData2 (..))
import Control.Selective (Selective (..))
import Data.Bifoldable (Bifoldable (..))
import Data.Bifunctor (Bifunctor (..))
import Data.Bitraversable (Bitraversable (..))
import Data.Data (Data)
import Data.Foldable (Foldable (..))
import Data.Kind (Constraint)
import Data.List.NonEmpty (NonEmpty (..))
import GHC.Generics (Generic, Generic1)
import GHC.TypeLits (ErrorMessage (..), TypeError)


-- $setup
-- >>> import Control.Applicative (liftA3)
-- >>> import Control.Selective (ifS)
-- >>> import Data.Char (isDigit)
-- >>> import Data.Maybe (listToMaybe)
-- >>> import Text.Read (readMaybe)

{- $use

This section contains the typical 'Validation' usage example. Let's say we
have a form with fields where you can input your login information.

>>> :{
data Form = Form
    { formUserName :: !String
    , formPassword :: !String
    }
:}


This @Form@ data type can represent values of some text fields on the
web page or inside the GUI application. Our goal is to create a value of
the custom @User@ data type from the @Form@ fields.

First, let's define our @User@ type and additional @newtype@s for more
type safety.

>>> :{
newtype UserName = UserName
    { unUserName :: String
    } deriving newtype (Show)
:}

>>> :{
newtype Password = Password
    { unPassword :: String
    } deriving newtype (Show)
:}

>>> :{
data User = User
    { userName     :: !UserName
    , userPassword :: !Password
    } deriving stock (Show)
:}

We can easily create a @User@ from the @Form@ in the /unsafe/ way by wrapping
each form field into the corresponding @newtype@:

>>> :{
unsafeUserFromForm :: Form -> User
unsafeUserFromForm Form{..} = User
    { userName     = UserName formUserName
    , userPassword = Password formPassword
    }
:}

However, this conversion is unsafe (as name suggests) since @Form@ can
contain /invalid/ data. So, before creating a @User@ we want to check
whether all @Form@ fields satisfy our preconditions. Specifically:

1. User name must not be empty.
2. Password should be at least 8 characters long.
3. Password should contain at least 1 digit.

'Validation' offers __modular__ and __composable__ way of defining and
outputting all validation failures which means:

1. __Modular__: define validation checks for different fields
independently.
2. __Composable__: combine smaller validations easily into a
validation of a bigger type.

Before implementing @Form@ validation, we need to introduce a type for
representing our validation errors. It is a good practice to define
all possible errors as a single sum type, so let's go ahead:

>>> :{
data FormValidationError
    = EmptyName
    | ShortPassword
    | NoDigitPassword
    deriving stock (Show)
:}

With 'Validation' we can define checks for individual fields
independently and compose them later. First, let's start with defining
validation for the name:

>>> :{
validateName :: String -> Validation (NonEmpty FormValidationError) UserName
validateName name = UserName name <$ failureIf (null name) EmptyName
:}

You can notice a few things about this function:

1. All errors are collected in 'NonEmpty', since we want to have
guarantees that in case of errors we have at least one failure.
2. It wraps the result into @UserName@ to tell that validation is
passed.

Let's see how this function works:

>>> validateName "John"
Success "John"
>>> validateName ""
Failure (EmptyName :| [])

Since 'Validation' provides __modular__ interface for defining checks,
we now can define all validation functions for the password
separately:

>>> :{
validateShortPassword :: String -> Validation (NonEmpty FormValidationError) Password
validateShortPassword password = Password password <$
    failureIf (length password < 8) ShortPassword
:}

>>> :{
validatePasswordDigit :: String -> Validation (NonEmpty FormValidationError) Password
validatePasswordDigit password = Password password <$
    failureUnless (any isDigit password) NoDigitPassword
:}

After we've implemented validations for different @Form@ fields, it's
time to combine them together! 'Validation' offers several ways to
compose different validations. These ways are provided via different
instances of common Haskell typeclasses, specifically:

* 'Semigroup'
* 'Alternative'
* 'Applicative'

'Semigroup' allows combining values inside both 'Failure' and
'Success' but this requires both values to implement the 'Semigroup'
instance. This doesn't fit our goal, since @Password@ can't have a
reasonble 'Semigroup' instance.

'Alternative' returns first 'Success' or combines all 'Failure's. We
can notice that 'Alternative' also doesn't work for us here.

In our case we are interested in collecting all possible errors and
returning 'Success' only when all checks are passed. Fortunately,
'Applicative' is exactly what we need here. So we can use the '*>'
operator to compose all checks for password:

>>> :{
validatePassword :: String -> Validation (NonEmpty FormValidationError) Password
validatePassword password =
    validateShortPassword password *> validatePasswordDigit password
:}

Let's see how it works:

>>> validatePassword "abcd"
Failure (ShortPassword :| [NoDigitPassword])
>>> validatePassword "abcd1"
Failure (ShortPassword :| [])
>>> validatePassword "abcd12345"
Success "abcd12345"

After we've implemented validations for all fields, we can compose
them together to produce validation for the whole @User@. As before,
we are going to use the 'Applicative' instance:

>>> :{
validateForm :: Form -> Validation (NonEmpty FormValidationError) User
validateForm Form{..} = User
    <$> validateName formUserName
    <*> validatePassword formPassword
:}

And it works like a charm:

>>> validateForm (Form "" "")
Failure (EmptyName :| [ShortPassword,NoDigitPassword])
>>> validateForm (Form "John" "abc")
Failure (ShortPassword :| [NoDigitPassword])
>>> validateForm (Form "Jonh" "qwertypassword")
Failure (NoDigitPassword :| [])
>>> validateForm (Form "Jonh" "qwertypassword123")
Success (User {userName = "Jonh", userPassword = "qwertypassword123"})
-}

{- | 'Validation' is a polymorphic sum type for storing either all
validation failures or validation success. Unlike 'Either', which
returns only the first error, 'Validation' accumulates all errors
using the 'Semigroup' typeclass.

Usually type variables in @'Validation' e a@ are used as follows:

* @e@: is a list or set of failure messages or values of some error data type.
* @a@: is some domain type denoting successful validation result.

Some typical use-cases:

* @'Validation' ['String'] User@

    * Either list of 'String' error messages or a validated value of a
      custom @User@ type.

* @'Validation' ('NonEmpty' UserValidationError) User@

    * Similar to previous example, but list of failures guaranteed to
      be non-empty in case of validation failure, and it stores values
      of some custom error type.
-}
data Validation e a
    = Failure e
    -- ^ Validation failure. The @e@ type is supposed to implement the 'Semigroup' instance.
    | Success a
    -- ^ Successful validation result of type @a@.
    deriving stock (Eq, Ord, Show, Generic, Generic1, Data)
    deriving anyclass (NFData, NFData1)

{- | Allows changing the value inside 'Success' with a given function.

__Examples__

>>> fmap (+1) (Success 9)
Success 10
>>> fmap (+1) (Failure ["wrong"])
Failure ["wrong"]
-}
instance Functor (Validation e) where
    fmap :: (a -> b) -> Validation e a -> Validation e b
    fmap _ (Failure e) = Failure e
    fmap f (Success a) = Success (f a)
    {-# INLINE fmap #-}

    (<$) :: a -> Validation e b -> Validation e a
    x <$ Success _ = Success x
    _ <$ Failure e = Failure e
    {-# INLINE (<$) #-}

{- | 'Semigroup' allows merging multiple 'Validation's into single one
by combining values inside both 'Failure' and 'Success'. The '<>'
operator merges two 'Validation's following the below rules:

1. If both values are 'Failure's, returns a new 'Failure' with
accumulated errors.
2. If both values are 'Success'ful, returns a new 'Success' with
combined success using 'Semigroup' for values inside 'Success'.
3. If one value is 'Failure' and another one is 'Success', then
'Failure' is returned.

__Examples__

>>> success1 = Success [9] :: Validation [String] [Int]
>>> success2 = Success [15] :: Validation [String] [Int]
>>> failure1 = Failure ["WRONG"] :: Validation [String] [Int]
>>> failure2 = Failure ["FAIL"]  :: Validation [String] [Int]

>>> success1 <> success2
Success [9,15]
>>> failure1 <> failure2
Failure ["WRONG","FAIL"]
>>> success1 <> failure1
Failure ["WRONG"]
>>> failure2 <> success1 <> success2 <> failure1
Failure ["FAIL","WRONG"]
-}
instance (Semigroup e, Semigroup a) => Semigroup (Validation e a) where
    (<>) :: Validation e a -> Validation e a -> Validation e a
    (<>) = liftA2 (<>)
    {-# INLINE (<>) #-}

{- | @'mempty' :: 'Validation' e a@ is @Success@ which stores
@'mempty' :: a@ to be consistent with the 'Semigroup' instance.

__Examples__

>>> mempty :: Validation String [Bool]
Success []
-}
instance (Semigroup e, Semigroup a, Monoid a) => Monoid (Validation e a) where
    mempty :: Validation e a
    mempty = Success mempty
    {-# INLINE mempty #-}

    mappend :: Validation e a -> Validation e a -> Validation e a
    mappend = (<>)
    {-# INLINE mappend #-}

{- | This instance if the most important instance for the 'Validation' data
type. It's responsible for the many implementations. And it allows to accumulate
errors while performing validation or combining the results in the applicative
style.

__Examples__

>>> success1 = Success 9 :: Validation [String] Int
>>> success2 = Success 15 :: Validation [String] Int
>>> successF = Success (* 2) :: Validation [String] (Int -> Int)
>>> failure1 = Failure ["WRONG"] :: Validation [String] Int
>>> failure2 = Failure ["FAIL"]  :: Validation [String] Int

>>> successF <*> success1
Success 18
>>> successF <*> failure1
Failure ["WRONG"]
>>> (+) <$> success1 <*> success2
Success 24
>>> (+) <$> failure1 <*> failure2
Failure ["WRONG","FAIL"]
>>> liftA2 (+) success1 failure1
Failure ["WRONG"]
>>> liftA3 (,,) failure1 success1 failure2
Failure ["WRONG","FAIL"]

Implementations of all functions are lazy and they correctly work if some
arguments are not fully evaluated.

>>> failure1 *> failure2
Failure ["WRONG","FAIL"]
>>> isFailure $ failure1 *> failure2
True
>>> epicFail = error "Impossible validation" :: Validation [String] Int
>>> isFailure $ failure1 *> epicFail
True
-}
instance Semigroup e => Applicative (Validation e) where
    pure :: a -> Validation e a
    pure = Success
    {-# INLINE pure #-}

    (<*>) :: Validation e (a -> b) -> Validation e a -> Validation e b
    Failure e1 <*> b = Failure $ case b of
        Failure e2 -> e1 <> e2
        Success _  -> e1
    Success _ <*> Failure e = Failure e
    Success f <*> Success a = Success (f a)
    {-# INLINE (<*>) #-}

    (*>) :: Validation e a -> Validation e b -> Validation e b
    Failure e1 *> b = Failure $ case b of
        Failure e2 -> e1 <> e2
        Success _  -> e1
    Success _ *> Failure e = Failure e
    Success _ *> Success b = Success b
    {-# INLINE (*>) #-}

    (<*) :: Validation e a -> Validation e b -> Validation e a
    Failure e1 <* b = Failure $ case b of
        Failure e2 -> e1 <> e2
        Success _  -> e1
    Success _ <* Failure e = Failure e
    Success a <* Success _ = Success a
    {-# INLINE (<*) #-}

    liftA2 :: (a -> b -> c) -> Validation e a -> Validation e b -> Validation e c
    liftA2 _ (Failure e1) b = Failure $ case b of
        Failure e2 -> e1 <> e2
        Success _  -> e1
    liftA2 _ (Success _) (Failure e) = Failure e
    liftA2 f (Success a) (Success b) = Success (f a b)
    {-# INLINE liftA2 #-}

{- | 'Selective' functors from the [selective](https://hackage.haskell.org/package/selective)
package. This instance allows choosing which validations to apply
based on value inside. 'Validation' can't have a lawful 'Monad'
instance but it's highly desirable to have the monadic behavior in cases
when you want future checks depend on previous values. 'Selective'
allows to circumvent this limitation by providing the desired
behavior.

==== __Examples__

To understand better, how 'Selective' can be helpful, let's consider a
typical usage example with validating passwords.

>>> :{
newtype Password = Password
    { unPassword :: String
    } deriving stock (Show)
:}

When user enters a password in some form, we want to check the
following conditions:

1. Password must not be empty.
2. Password must contain at least 8 characters.
3. Password must contain at least 1 digit.

As in the previous usage example with form validation, let's introduce
a custom data type to represent all possible errors.

>>> :{
data PasswordValidationError
    = EmptyPassword
    | ShortPassword
    | NoDigitPassword
    deriving stock (Show)
:}

And, again, we can implement independent functions to validate all these cases:

>>> type PasswordValidation = Validation (NonEmpty PasswordValidationError) Password

>>> :{
validateEmptyPassword :: String -> PasswordValidation
validateEmptyPassword password = Password password <$
    failureIf (null password) EmptyPassword
:}

>>> :{
validateShortPassword :: String -> PasswordValidation
validateShortPassword password = Password password <$
    failureIf (length password < 8) ShortPassword
:}

>>> :{
validatePasswordDigit :: String -> PasswordValidation
validatePasswordDigit password = Password password <$
    failureUnless (any isDigit password) NoDigitPassword
:}

And we can easily compose all these checks into single validation for
@Password@ using 'Applicative' instance:

>>> :{
validatePassword :: String -> PasswordValidation
validatePassword password =
    validateEmptyPassword password
    *> validateShortPassword password
    *> validatePasswordDigit password
:}

However, if we try using this function, we can notice a problem
immediately:

>>> validatePassword ""
Failure (EmptyPassword :| [ShortPassword,NoDigitPassword])

Due to the nature of the 'Applicative' instance for 'Validation', we
run all checks and combine all possible errors. But you can notice
that if password is empty, it doesn't make sense to run other
validations. The fact that the password is empty implies that password
is shorter than 8 characters.

You may say that check for empty password is redundant because empty
password is a special case of a short password. However, when using
'Validation', we want to display readable and friendly errors to
users, so they know how to fix errors and can act correspondingly.

This behaviour could be achieved easily if 'Validation' had the
'Monad' instance. But it can't have a lawful 'Monad'
instance. Fortunately, the 'Selective' instance for 'Validation' can
help with our problem. But to solve it, we need to write our password
validation in a slightly different way.

First, we need to write a function that checks whether the password is
empty:

>>> :{
checkEmptyPassword :: String -> Validation e Bool
checkEmptyPassword = Success . null
:}

Now we can use the @ifS@ function from the @selective@ package to
branch on the result of @checkEmptyPassword@:

>>> :{
validatePassword :: String -> PasswordValidation
validatePassword password = ifS
    (checkEmptyPassword password)
    (failure EmptyPassword)
    (validateShortPassword password *> validatePasswordDigit password)
:}

With this implementation we achieved our desired behavior:

>>> validatePassword ""
Failure (EmptyPassword :| [])
>>> validatePassword "abc"
Failure (ShortPassword :| [NoDigitPassword])
>>> validatePassword "abc123"
Failure (ShortPassword :| [])
>>> validatePassword "security567"
Success (Password {unPassword = "security567"})
-}
instance Semigroup e => Selective (Validation e) where
    select :: Validation e (Either a b) -> Validation e (a -> b) -> Validation e b
    select (Failure e)   _ = Failure e -- Skip effect after failed conditions
    select (Success eab) f = case eab of
        Left a  -> ($ a) <$> f  -- Apply second effect
        Right b -> Success b    -- Skip second effect
    {-# INLINE select #-}

{- | This instance implements the behaviour when the first 'Success'
is returned. Otherwise all 'Failure's are combined.

__Examples__

>>> success1 = Success [9] :: Validation [String] [Int]
>>> success2 = Success [15] :: Validation [String] [Int]
>>> failure1 = Failure ["WRONG"] :: Validation [String] [Int]
>>> failure2 = Failure ["FAIL"]  :: Validation [String] [Int]

>>> success1 <|> success2
Success [9]
>>> failure1 <|> failure2
Failure ["WRONG","FAIL"]
>>> failure2 <|> success2
Success [15]
-}
instance (Semigroup e, Monoid e) => Alternative (Validation e) where
    empty :: Validation e a
    empty = Failure mempty
    {-# INLINE empty #-}

    (<|>) :: Validation e a -> Validation e a -> Validation e a
    s@Success{} <|> _ = s
    _ <|> s@Success{} = s
    Failure e <|> Failure e' = Failure (e <> e')
    {-# INLINE (<|>) #-}

{- | 'Foldable' for 'Validation' allows folding values inside 'Success'.

__Examples__

>>> fold (Success [16])
[16]
>>> fold (Failure "WRONG!" :: Validation String [Int])
[]
-}
instance Foldable (Validation e) where
    fold :: Monoid m => Validation e m -> m
    fold = \case
        Failure _ -> mempty
        Success a -> a
    {-# INLINE fold #-}

    foldMap :: Monoid m => (a -> m) -> Validation e a -> m
    foldMap f = \case
        Failure _ -> mempty
        Success a -> f a
    {-# INLINE foldMap #-}

    foldr :: (a -> b -> b) -> b -> Validation e a -> b
    foldr f x = \case
        Failure _ -> x
        Success a -> f a x
    {-# INLINE foldr #-}

    foldr' :: (a -> b -> b) -> b -> Validation e a -> b
    foldr' = foldr
    {-# INLINE foldr' #-}

    foldl :: (b -> a -> b) -> b -> Validation e a -> b
    foldl f x = \case
        Failure _ -> x
        Success a -> f x a
    {-# INLINE foldl #-}

    foldl' :: (b -> a -> b) -> b -> Validation e a -> b
    foldl' = foldl
    {-# INLINE foldl' #-}

    toList :: Validation e a -> [a]
    toList = \case
        Failure _ -> []
        Success a -> [a]
    {-# INLINE toList #-}

    null :: Validation e a -> Bool
    null = \case
        Failure _ -> True
        Success _ -> False
    {-# INLINE null #-}

    length :: Validation e a -> Int
    length = \case
        Failure _ -> 0
        Success _ -> 1
    {-# INLINE length #-}

    elem :: Eq a => a -> Validation e a -> Bool
    elem x = \case
        Failure _ -> False
        Success a -> x == a
    {-# INLINE elem #-}

    sum :: Num a => Validation e a -> a
    sum = \case
        Failure _ -> 0
        Success a -> a
    {-# INLINE sum #-}

    product :: Num a => Validation e a -> a
    product = \case
        Failure _ -> 1
        Success a -> a
    {-# INLINE product #-}

    -- not-implemented because they are partial, so we're using the
    -- default implementations
    --
    -- foldr1  :: (a -> a -> a) -> Validation e a -> a
    -- foldl1  :: (a -> a -> a) -> Validation e a -> a
    -- maximum :: Ord a => Validation e a -> a
    -- minimum :: Ord a => Validation e a -> a

{- | Traverse values inside 'Success' with some effectful computation.

__Examples__

>>> parseInt = readMaybe :: String -> Maybe Int
>>> traverse parseInt (Success "42")
Just (Success 42)
>>> traverse parseInt (Success "int")
Nothing
>>> traverse parseInt (Failure ["42"])
Just (Failure ["42"])
-}
instance Traversable (Validation e) where
    traverse :: Applicative f => (a -> f b) -> Validation e a -> f (Validation e b)
    traverse f (Success a) = Success <$> f a
    traverse _ (Failure e) = pure (Failure e)
    {-# INLINE traverse #-}

    sequenceA :: Applicative f => Validation e (f a) -> f (Validation e a)
    sequenceA = \case
        Failure e -> pure (Failure e)
        Success f -> Success <$> f
    {-# INLINE sequenceA #-}

{- | Similar to 'Functor' but allows mapping of values inside both
'Failure' and 'Success'.

__Examples__

>>> bimap length show (Success 50)
Success "50"
>>> bimap length show (Failure ["15", "9"])
Failure 2
-}
instance Bifunctor Validation where
    bimap :: (e -> d) -> (a -> b) -> Validation e a -> Validation d b
    bimap f _ (Failure e) = Failure (f e)
    bimap _ g (Success a) = Success (g a)
    {-# INLINE bimap #-}

    first :: (e -> d) -> Validation e a -> Validation d a
    first f (Failure e) = Failure (f e)
    first _ (Success a) = Success a
    {-# INLINE first #-}

    second :: (a -> b) -> Validation e a -> Validation e b
    second _ (Failure e) = Failure e
    second g (Success a) = Success (g a)
    {-# INLINE second #-}

{- | Similar to 'Foldable' but allows folding both 'Failure' and
'Success' to the same monoidal value according to given functions.

__Examples__

>>> one x = [x]
>>> bifoldMap id (one . show) (Success 15)
["15"]
>>> bifoldMap id (one . show) (Failure ["Wrong", "Fail"])
["Wrong","Fail"]
-}
instance Bifoldable Validation where
--    bifoldMap :: (e -> m) -> (a -> m) -> Validation e a -> m
    bifoldMap f _ (Failure e) = f e
    bifoldMap _ g (Success a) = g a
    {-# INLINE bifoldMap #-}

{- | Similar to 'Traversable' but traverses both 'Failure' and
'Success' with given effectful computations.

__Examples__

>>> parseInt = readMaybe :: String -> Maybe Int
>>> bitraverse listToMaybe parseInt (Success "42")
Just (Success 42)
>>> bitraverse listToMaybe parseInt (Success "int")
Nothing
>>> bitraverse listToMaybe parseInt (Failure [15])
Just (Failure 15)
>>> bitraverse listToMaybe parseInt (Failure [])
Nothing
-}
instance Bitraversable Validation where
    bitraverse
        :: Applicative f
        => (e -> f d)
        -> (a -> f b)
        -> Validation e a
        -> f (Validation d b)
    bitraverse f _ (Failure e) = Failure <$> f e
    bitraverse _ g (Success a) = Success <$> g a
    {-# INLINE bitraverse #-}

instance NFData2 Validation where
    liftRnf2 :: (e -> ()) -> (a -> ()) -> Validation e a -> ()
    liftRnf2 f _s (Failure x) = f x
    liftRnf2 _f s (Success y) = s y

----------------------------------------------------------------------------
-- Custom errors
----------------------------------------------------------------------------

{- | ⚠️__CAUTION__⚠️ This instance is for custom error display only.

It's not possible to implement lawful 'Monad' instance for 'Validation'.

In case it is used by mistake, the user will see the following:

>>> Success 42 >>= \n -> if even n then Success n else Failure ["Not even"]
...
... Type 'Validation' doesn't have lawful 'Monad' instance
      which means that you can't use 'Monad' methods with 'Validation'.
...
-}
instance (NoValidationMonadError, Semigroup e) => Monad (Validation e) where
    return = error "Unreachable Validation instance of Monad"
    (>>=)  = error "Unreachable Validation instance of Monad"

-- | Helper type family to produce error messages
type family NoValidationMonadError :: Constraint where
    NoValidationMonadError = TypeError
        ( 'Text "Type 'Validation' doesn't have lawful 'Monad' instance"
        ':$$: 'Text "which means that you can't use 'Monad' methods with 'Validation'."
        )

----------------------------------------------------------------------------
-- Either
----------------------------------------------------------------------------

{- $either
'Validation' is usually compared to the 'Either' data type due to the similarity
in structure, nature and use case. Here is a quick table you can relate to, in
order to see the main properties and differences between these two data types:

+------------------------+---------------------------+---------------------------+
|                        | 'Either'                  | 'Validation'              |
+========================+===========================+===========================+
| Error result           | 'Left'                    | 'Failure'                 |
+------------------------+---------------------------+---------------------------+
| Successful result      | 'Right'                   | 'Success'                 |
+------------------------+---------------------------+---------------------------+
| 'Applicative' instance | Stops on the first 'Left' | Aggregates all 'Failure's |
+------------------------+---------------------------+---------------------------+
| 'Monad' instance       | Lawful instance           | __Cannot__ exist          |
+------------------------+---------------------------+---------------------------+

== Comparison in example

For the sake of better illustration of the difference between 'Either' and
'Validation', let's go through the example of how parsing is done with the usage of
these types.

Our goal is to parse two given 'String's and return their sum in case if both of
them are valid 'Int's. If any of the inputs is failing to be parsed we should
return the @ParseError@ which we are introducing right now:

>>> :{
newtype ParseError = ParseError
    { nonParsedString :: String
    } deriving stock (Show)
:}

Let's first implement the parsing of single input in the 'Either' context:

>>> :{
parseEither :: String -> Either ParseError Int
parseEither input = case readMaybe @Int input of
    Just x  -> Right x
    Nothing -> Left $ ParseError input
:}

And the final function for 'Either' looks like this:

>>> :{
parseSumEither :: String -> String -> Either ParseError Int
parseSumEither str1 str2 = do
    let x = parseEither str1
    let y = parseEither str2
    liftA2 (+) x y
:}

Let's now test it in action.

>>> parseSumEither "1" "2"
Right 3
>>> parseSumEither "NaN" "42"
Left (ParseError {nonParsedString = "NaN"})
>>> parseSumEither "15" "Infinity"
Left (ParseError {nonParsedString = "Infinity"})
>>> parseSumEither "NaN" "infinity"
Left (ParseError {nonParsedString = "NaN"})

__Note__ how in the case of both failed parsing we got only the first @NaN@.

To finish our comparison, let's implement the same functionality using
'Validation' properties.

>>> :{
parseValidation :: String -> Validation (NonEmpty ParseError) Int
parseValidation input = case readMaybe @Int input of
    Just x  -> Success x
    Nothing -> failure $ ParseError input
:}

>>> :{
parseSumValidation :: String -> String -> Validation (NonEmpty ParseError) Int
parseSumValidation str1 str2 = do
    let x = parseValidation str1
    let y = parseValidation str2
    liftA2 (+) x y
:}

It looks almost completely identical except for the resulting type —
@'Validation' ('NonEmpty' ParseError) 'Int'@. But let's see if they behave the
same way:

>>> parseSumValidation "1" "2"
Success 3
>>> parseSumValidation "NaN" "42"
Failure (ParseError {nonParsedString = "NaN"} :| [])
>>> parseSumValidation "15" "infinity"
Failure (ParseError {nonParsedString = "infinity"} :| [])
>>> parseSumValidation "NaN" "infinity"
Failure (ParseError {nonParsedString = "NaN"} :| [ParseError {nonParsedString = "infinity"}])

As expected, with 'Validation' we got __all__ parse 'Failure's we received on
the way.

== Combinators

We are providing several functions for better integration with the 'Either'
related code in this section.
-}

{- | Transform a 'Validation' into an 'Either'.

>>> validationToEither (Success "whoop")
Right "whoop"

>>> validationToEither (Failure "nahh")
Left "nahh"
-}
validationToEither :: Validation e a -> Either e a
validationToEither = \case
    Failure e -> Left e
    Success a -> Right a
{-# INLINE validationToEither #-}

{- | Transform an 'Either' into a 'Validation'.

>>> eitherToValidation (Right "whoop")
Success "whoop"

>>> eitherToValidation (Left "nahh")
Failure "nahh"
-}
eitherToValidation :: Either e a -> Validation e a
eitherToValidation = \case
    Left e  -> Failure e
    Right a -> Success a
{-# INLINE eitherToValidation #-}

----------------------------------------------------------------------------
-- Interface
----------------------------------------------------------------------------

{- | Predicate on if the given 'Validation' is 'Failure'.

>>> isFailure (Failure 'e')
True
>>> isFailure (Success 'a')
False
-}
isFailure :: Validation e a -> Bool
isFailure = \case
    Failure _ -> True
    Success _ -> False

{- | Predicate on if the given 'Validation' is 'Success'.

>>> isSuccess (Success 'a')
True
>>> isSuccess (Failure 'e')
False
-}
isSuccess :: Validation e a -> Bool
isSuccess = \case
    Success _ -> True
    Failure _ -> False

{- | Transforms the value of the given 'Validation' into @x@ using provided
functions that can transform 'Failure' and 'Success' value into the resulting
type respectively.

>>> let myValidation = validation (<> " world!") (show . (* 10))
>>> myValidation (Success 100)
"1000"
>>> myValidation (Failure "Hello")
"Hello world!"
-}
validation :: (e -> x) -> (a -> x) -> Validation e a -> x
validation fe fa = \case
    Success a -> fa a
    Failure e -> fe e

{- | Filters out all 'Failure' values into the new list of @e@s from the given
list of 'Validation's.

Note that the order is preserved.

>>> failures [Failure "Hello", Success 1, Failure "world", Success 2, Failure "!" ]
["Hello","world","!"]
-}
failures :: [Validation e a] -> [e]
failures v = [e | Failure e <- v]
{-# INLINE failures #-}

{- | Filters out all 'Success' values into the new list of @a@s from the given
list of 'Validation's.

Note that the order is preserved.

>>> successes [Failure "Hello", Success 1, Failure "world", Success 2, Failure "!" ]
[1,2]
-}
successes :: [Validation e a] -> [a]
successes v = [a | Success a <- v]
{-# INLINE successes #-}

{- | Redistributes the given list of 'Validation's into two lists of @e@s and
@e@s, where the first list contains all values of 'Failure's and the second
one — 'Success'es correspondingly.

Note that the order is preserved.

>>> partitionValidations [Failure "Hello", Success 1, Failure "world", Success 2, Failure "!" ]
(["Hello","world","!"],[1,2])
-}
partitionValidations :: [Validation e a] -> ([e], [a])
partitionValidations = go
  where
    go :: [Validation e a] -> ([e], [a])
    go []               = ([], [])
    go (Failure e:rest) = first  (e:) $ go rest
    go (Success a:rest) = second (a:) $ go rest

{- | Returns the contents of a 'Failure'-value or a default value otherwise.

>>> fromFailure "default" (Failure "failure")
"failure"
>>> fromFailure "default" (Success 1)
"default"
-}
fromFailure :: e -> Validation e a -> e
fromFailure _ (Failure e) = e
fromFailure e _           = e

{- | Returns the contents of a 'Success'-value or a default value otherwise.

>>> fromSuccess 42 (Success 1)
1
>>> fromSuccess 42 (Failure "failure")
42
-}
fromSuccess :: a -> Validation e a -> a
fromSuccess _ (Success a) = a
fromSuccess a _           = a

----------------------------------------------------------------------------
-- NonEmpty Combinators
----------------------------------------------------------------------------

{- $nonEmptyCombinators

When using 'Validation', we often work with the 'NonEmpty' list of errors, and
those lists will be concatenated later.

The following functions aim to help with writing more concise code.

For example, instead of (perfectly fine) code like:

>>> :{
validateNameVerbose :: String -> Validation (NonEmpty String) String
validateNameVerbose name
    | null name = Failure ("Empty Name" :| [])
    | otherwise = Success name
:}

one can write simply:

>>> :{
validateNameSimple :: String -> Validation (NonEmpty String) String
validateNameSimple name = name <$ failureIf (null name) "Empty Name"
:}

-}

{- | Create a 'Failure' of 'NonEmpty' list with a single given error.

>>> failure "I am a failure"
Failure ("I am a failure" :| [])
-}
failure :: e -> Validation (NonEmpty e) a
failure e = Failure (e :| [])
{-# INLINE failure #-}

{- | Returns a 'Failure' in case of the given predicate is 'True'.
Returns @'Success' '()'@ otherwise.

>>> let shouldFail = (==) "I am a failure"
>>> failureIf (shouldFail "I am a failure") "I told you so"
Failure ("I told you so" :| [])
>>> failureIf (shouldFail "I am NOT a failure") "okay"
Success ()
-}
failureIf :: Bool -> e -> Validation (NonEmpty e) ()
failureIf p e
    | p = failure e
    | otherwise = Success ()
{-# INLINE failureIf #-}

{- | Returns a 'Failure' unless the given predicate is 'True'.
Returns @'Success' '()'@ in case of the predicate is satisfied.

Similar to 'failureIf' with the reversed predicate.

@
'failureUnless' p ≡ 'failureIf' (not p)
@

>>> let shouldFail = (==) "I am a failure"
>>> failureUnless (shouldFail "I am a failure") "doesn't matter"
Success ()
>>> failureUnless (shouldFail "I am NOT a failure") "I told you so"
Failure ("I told you so" :| [])
-}
failureUnless :: Bool -> e -> Validation (NonEmpty e) ()
failureUnless p e
    | p = Success ()
    | otherwise = failure e
{-# INLINE failureUnless #-}