{-# LANGUAGE CPP                  #-}
{-# LANGUAGE ConstraintKinds      #-}
{-# LANGUAGE DataKinds            #-}
{-# LANGUAGE LambdaCase           #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE TypeOperators        #-}
{-# LANGUAGE UndecidableInstances #-}

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

'Validation' is a monoidal sibling to 'Either' but 'Validation' doesn't have a
'Monad' instance. '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.

Instances of different standard typeclasses provide various semantics:

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

module Relude.Extra.Validation
       ( -- * How to use
         -- $use
         Validation(..)
       , validationToEither
       , eitherToValidation
       ) where

import GHC.TypeLits (ErrorMessage (..), TypeError)

import Relude

-- >>> $setup
-- >>> import Relude

{- $use

Take for example a type @Computer@ that needs to be validated:

>>> :{
data Computer = Computer
    { computerRam  :: !Int  -- ^ Ram in Gigabytes
    , computerCpus :: !Int
    } deriving (Eq, Show)
:}

You can validate that the computer has a minimum of 16GB of RAM:

>>> :{
validateRam :: Int -> Validation [Text] Int
validateRam ram
    | ram >= 16 = Success ram
    | otherwise = Failure ["Not enough RAM"]
:}

and that the processor has at least two CPUs:

>>> :{
validateCpus :: Int -> Validation [Text] Int
validateCpus cpus
    | cpus >= 2 = Success cpus
    | otherwise = Failure ["Not enough CPUs"]
:}

You can use these functions with the 'Applicative' instance of the 'Validation'
type to construct a validated @Computer@. You will get either (pun intended) a
valid @Computer@ or the errors that prevent it from being considered valid.

Like so:

>>> :{
mkComputer :: Int -> Int -> Validation [Text] Computer
mkComputer ram cpus = Computer
    <$> validateRam ram
    <*> validateCpus cpus
:}

Using @mkComputer@ we get a @Success Computer@ or a list with all possible errors:

>>> mkComputer 16 2
Success (Computer {computerRam = 16, computerCpus = 2})

>>> mkComputer 16 1
Failure ["Not enough CPUs"]

>>> mkComputer 15 2
Failure ["Not enough RAM"]

>>> mkComputer 15 1
Failure ["Not enough RAM","Not enough CPUs"]
-}

-- | 'Validation' is 'Either' with a 'Left' that is a 'Semigroup'.
data Validation e a
    = Failure e
    | Success a
    deriving (Validation e a -> Validation e a -> Bool
(Validation e a -> Validation e a -> Bool)
-> (Validation e a -> Validation e a -> Bool)
-> Eq (Validation e a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall e a.
(Eq e, Eq a) =>
Validation e a -> Validation e a -> Bool
/= :: Validation e a -> Validation e a -> Bool
$c/= :: forall e a.
(Eq e, Eq a) =>
Validation e a -> Validation e a -> Bool
== :: Validation e a -> Validation e a -> Bool
$c== :: forall e a.
(Eq e, Eq a) =>
Validation e a -> Validation e a -> Bool
Eq, Eq (Validation e a)
Eq (Validation e a) =>
(Validation e a -> Validation e a -> Ordering)
-> (Validation e a -> Validation e a -> Bool)
-> (Validation e a -> Validation e a -> Bool)
-> (Validation e a -> Validation e a -> Bool)
-> (Validation e a -> Validation e a -> Bool)
-> (Validation e a -> Validation e a -> Validation e a)
-> (Validation e a -> Validation e a -> Validation e a)
-> Ord (Validation e a)
Validation e a -> Validation e a -> Bool
Validation e a -> Validation e a -> Ordering
Validation e a -> Validation e a -> Validation e a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall e a. (Ord e, Ord a) => Eq (Validation e a)
forall e a.
(Ord e, Ord a) =>
Validation e a -> Validation e a -> Bool
forall e a.
(Ord e, Ord a) =>
Validation e a -> Validation e a -> Ordering
forall e a.
(Ord e, Ord a) =>
Validation e a -> Validation e a -> Validation e a
min :: Validation e a -> Validation e a -> Validation e a
$cmin :: forall e a.
(Ord e, Ord a) =>
Validation e a -> Validation e a -> Validation e a
max :: Validation e a -> Validation e a -> Validation e a
$cmax :: forall e a.
(Ord e, Ord a) =>
Validation e a -> Validation e a -> Validation e a
>= :: Validation e a -> Validation e a -> Bool
$c>= :: forall e a.
(Ord e, Ord a) =>
Validation e a -> Validation e a -> Bool
> :: Validation e a -> Validation e a -> Bool
$c> :: forall e a.
(Ord e, Ord a) =>
Validation e a -> Validation e a -> Bool
<= :: Validation e a -> Validation e a -> Bool
$c<= :: forall e a.
(Ord e, Ord a) =>
Validation e a -> Validation e a -> Bool
< :: Validation e a -> Validation e a -> Bool
$c< :: forall e a.
(Ord e, Ord a) =>
Validation e a -> Validation e a -> Bool
compare :: Validation e a -> Validation e a -> Ordering
$ccompare :: forall e a.
(Ord e, Ord a) =>
Validation e a -> Validation e a -> Ordering
$cp1Ord :: forall e a. (Ord e, Ord a) => Eq (Validation e a)
Ord, Int -> Validation e a -> ShowS
[Validation e a] -> ShowS
Validation e a -> String
(Int -> Validation e a -> ShowS)
-> (Validation e a -> String)
-> ([Validation e a] -> ShowS)
-> Show (Validation e a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall e a. (Show e, Show a) => Int -> Validation e a -> ShowS
forall e a. (Show e, Show a) => [Validation e a] -> ShowS
forall e a. (Show e, Show a) => Validation e a -> String
showList :: [Validation e a] -> ShowS
$cshowList :: forall e a. (Show e, Show a) => [Validation e a] -> ShowS
show :: Validation e a -> String
$cshow :: forall e a. (Show e, Show a) => Validation e a -> String
showsPrec :: Int -> Validation e a -> ShowS
$cshowsPrec :: forall e a. (Show e, Show a) => Int -> Validation e a -> ShowS
Show)

instance Functor (Validation e) where
    fmap :: (a -> b) -> Validation e a -> Validation e b
    fmap :: (a -> b) -> Validation e a -> Validation e b
fmap _ (Failure e :: e
e) = e -> Validation e b
forall e a. e -> Validation e a
Failure e
e
    fmap f :: a -> b
f (Success a :: a
a) = b -> Validation e b
forall e a. a -> Validation e a
Success (a -> b
f a
a)
    {-# INLINE fmap #-}

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

{- | This instances covers the following cases:

1. Both 'Success': combine values inside 'Success' with '<>'.
2. Both 'Failure': combine values inside 'Failure' with '<>'.
3. One 'Success', one 'Failure': return 'Failure'.

__Examples__

>>> success1 = Success [42] :: Validation [Text] [Int]
>>> success2 = Success [69] :: Validation [Text] [Int]
>>> failure1 = Failure ["WRONG"] :: Validation [Text] [Int]
>>> failure2 = Failure ["FAIL"]  :: Validation [Text] [Int]

>>> success1 <> success2
Success [42,69]

>>> failure1 <> failure2
Failure ["WRONG","FAIL"]

>>> success1 <> failure1
Failure ["WRONG"]

@since 0.6.0.0
-}
instance (Semigroup e, Semigroup a) => Semigroup (Validation e a) where
    (<>) :: Validation e a -> Validation e a -> Validation e a
    <> :: Validation e a -> Validation e a -> Validation e a
(<>) = (a -> a -> a) -> Validation e a -> Validation e a -> Validation e a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. Semigroup a => a -> a -> a
(<>)
    {-# INLINE (<>) #-}

{- | 'mempty' is @'Success' 'mempty'@.

@since 0.6.0.0
-}
instance (Semigroup e, Monoid a) => Monoid (Validation e a) where
    mempty :: Validation e a
    mempty :: Validation e a
mempty = a -> Validation e a
forall e a. a -> Validation e a
Success a
forall a. Monoid a => a
mempty
    {-# INLINE mempty #-}

{- | 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 42 :: Validation [Text] Int
>>> success2 = Success 69 :: Validation [Text] Int
>>> successF = Success (* 2) :: Validation [Text] (Int -> Int)
>>> failure1 = Failure ["WRONG"] :: Validation [Text] Int
>>> failure2 = Failure ["FAIL"]  :: Validation [Text] Int

>>> successF <*> success1
Success 84

>>> successF <*> failure1
Failure ["WRONG"]

>>> (+) <$> success1 <*> success2
Success 111

>>> (+) <$> 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.

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

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

    (<*>) :: Validation e (a -> b) -> Validation e a -> Validation e b
    Failure e :: e
e <*> :: Validation e (a -> b) -> Validation e a -> Validation e b
<*> b :: Validation e a
b = e -> Validation e b
forall e a. e -> Validation e a
Failure (e -> Validation e b) -> e -> Validation e b
forall a b. (a -> b) -> a -> b
$ case Validation e a
b of
        Failure e' :: e
e' -> e
e e -> e -> e
forall a. Semigroup a => a -> a -> a
<> e
e'
        Success _  -> e
e
    Success _ <*> Failure e :: e
e  = e -> Validation e b
forall e a. e -> Validation e a
Failure e
e
    Success f :: a -> b
f <*> Success a :: a
a = b -> Validation e b
forall e a. a -> Validation e a
Success (a -> b
f a
a)
    {-# INLINE (<*>) #-}

    (*>) :: Validation e a -> Validation e b -> Validation e b
    Failure e :: e
e *> :: Validation e a -> Validation e b -> Validation e b
*> b :: Validation e b
b = e -> Validation e b
forall e a. e -> Validation e a
Failure (e -> Validation e b) -> e -> Validation e b
forall a b. (a -> b) -> a -> b
$ case Validation e b
b of
        Failure e' :: e
e' -> e
e e -> e -> e
forall a. Semigroup a => a -> a -> a
<> e
e'
        Success _  -> e
e
    Success _ *> Failure e :: e
e  = e -> Validation e b
forall e a. e -> Validation e a
Failure e
e
    Success _ *> Success b :: b
b  = b -> Validation e b
forall e a. a -> Validation e a
Success b
b
    {-# INLINE (*>) #-}

    (<*) :: Validation e a -> Validation e b -> Validation e a
    Failure e :: e
e <* :: Validation e a -> Validation e b -> Validation e a
<* b :: Validation e b
b = e -> Validation e a
forall e a. e -> Validation e a
Failure (e -> Validation e a) -> e -> Validation e a
forall a b. (a -> b) -> a -> b
$ case Validation e b
b of
        Failure e' :: e
e' -> e
e e -> e -> e
forall a. Semigroup a => a -> a -> a
<> e
e'
        Success _  -> e
e
    Success _ <* Failure e :: e
e  = e -> Validation e a
forall e a. e -> Validation e a
Failure e
e
    Success a :: a
a <* Success _  = a -> Validation e a
forall e a. a -> Validation e a
Success a
a
    {-# INLINE (<*) #-}


{- | This instance implements the following behavior for the binary operator:

1. Both 'Failure': combine values inside 'Failure' using '<>'.
2. At least is 'Success': return the left 'Success' (the earliest 'Success').
3. 'empty' is @'Failure' 'mempty'@.

__Examples__

>>> success1 = Success [42] :: Validation [Text] [Int]
>>> success2 = Success [69] :: Validation [Text] [Int]
>>> failure1 = Failure ["WRONG"] :: Validation [Text] [Int]
>>> failure2 = Failure ["FAIL"]  :: Validation [Text] [Int]

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

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

instance Foldable (Validation e) where
    fold :: Monoid m => Validation e m -> m
    fold :: Validation e m -> m
fold (Success a :: m
a) = m
a
    fold (Failure _) = m
forall a. Monoid a => a
mempty
    {-# INLINE fold #-}

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

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

instance Traversable (Validation e) where
    traverse :: Applicative f => (a -> f b) -> Validation e a -> f (Validation e b)
    traverse :: (a -> f b) -> Validation e a -> f (Validation e b)
traverse f :: a -> f b
f (Success a :: a
a) = b -> Validation e b
forall e a. a -> Validation e a
Success (b -> Validation e b) -> f b -> f (Validation e b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
a
    traverse _ (Failure e :: e
e) = Validation e b -> f (Validation e b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (e -> Validation e b
forall e a. e -> Validation e a
Failure e
e)
    {-# INLINE traverse #-}

    sequenceA :: Applicative f => Validation e (f a) -> f (Validation e a)
    sequenceA :: Validation e (f a) -> f (Validation e a)
sequenceA = (f a -> f a) -> Validation e (f a) -> f (Validation e a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse f a -> f a
forall a. a -> a
id
    {-# INLINE sequenceA #-}

instance Bifunctor Validation where
    bimap :: (e -> d) -> (a -> b) -> Validation e a -> Validation d b
    bimap :: (e -> d) -> (a -> b) -> Validation e a -> Validation d b
bimap f :: e -> d
f _ (Failure e :: e
e) = d -> Validation d b
forall e a. e -> Validation e a
Failure (e -> d
f e
e)
    bimap _ g :: a -> b
g (Success a :: a
a) = b -> Validation d b
forall e a. a -> Validation e a
Success (a -> b
g a
a)
    {-# INLINE bimap #-}

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

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

#if MIN_VERSION_base(4,10,0)
instance Bifoldable Validation where
    bifoldMap :: Monoid m => (e -> m) -> (a -> m) -> Validation e a -> m
    bifoldMap :: (e -> m) -> (a -> m) -> Validation e a -> m
bifoldMap f :: e -> m
f _ (Failure e :: e
e) = e -> m
f e
e
    bifoldMap _ g :: a -> m
g (Success a :: a
a) = a -> m
g a
a
    {-# INLINE bifoldMap #-}

instance Bitraversable Validation where
    bitraverse :: Applicative f
               => (e -> f d) -> (a -> f b) -> Validation e a -> f (Validation d b)
    bitraverse :: (e -> f d) -> (a -> f b) -> Validation e a -> f (Validation d b)
bitraverse f :: e -> f d
f _ (Failure e :: e
e) = d -> Validation d b
forall e a. e -> Validation e a
Failure (d -> Validation d b) -> f d -> f (Validation d b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> e -> f d
f e
e
    bitraverse _ g :: a -> f b
g (Success a :: a
a) = b -> Validation d b
forall e a. a -> Validation e a
Success (b -> Validation d b) -> f b -> f (Validation d b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
g a
a
    {-# INLINE bitraverse #-}
#endif

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

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

>>> validationToEither (Failure "nahh")
Left "nahh"
-}
validationToEither :: Validation e a -> Either e a
validationToEither :: Validation e a -> Either e a
validationToEither = \case
    Failure e :: e
e -> e -> Either e a
forall a b. a -> Either a b
Left e
e
    Success a :: a
a -> a -> Either e a
forall a b. b -> Either a b
Right a
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 :: Either e a -> Validation e a
eitherToValidation = \case
    Left e :: e
e  -> e -> Validation e a
forall e a. e -> Validation e a
Failure e
e
    Right a :: a
a -> a -> Validation e a
forall e a. a -> Validation e a
Success a
a
{-# INLINE eitherToValidation #-}

----------------------------------------------------------------------------
-- 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'.
...

@since 0.6.0.0
-}
instance (NoValidationMonadError, Semigroup e) => Monad (Validation e) where
    return :: a -> Validation e a
return = Text -> a -> Validation e a
forall a t. (HasCallStack, IsText t) => t -> a
error "Unreachable Validation instance of Monad"
    >>= :: Validation e a -> (a -> Validation e b) -> Validation e b
(>>=)  = Text -> Validation e a -> (a -> Validation e b) -> Validation e b
forall a t. (HasCallStack, IsText t) => t -> a
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'."
        )