{-# LANGUAGE CPP #-}
{-# LANGUAGE Rank2Types #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Either.Validation
-- Copyright   :  (c) 2014 Chris Allen, Edward Kmett
-- License     :  BSD-style
--
-- Maintainer  :  ekmett@gmail.com
-- Stability   :  provisional
-- Portability :  portable
--
-- Monoidal 'Validation' sibling to 'Either'.
--
-----------------------------------------------------------------------------

module Data.Either.Validation
  ( Validation(..)
  , _Success
  , _Failure
  , eitherToValidation
  , validationToEither
  , _Validation
  , vap
  , ealt
  -- combinators that leak less, but require monoid constraints
  , vapm, apm
  ) where

import Control.Applicative
import Data.Bifoldable(Bifoldable(bifoldr))
import Data.Bifunctor(Bifunctor(bimap))
import Data.Bitraversable(Bitraversable(bitraverse))
import Data.Foldable (Foldable(foldr))
import Data.Functor.Alt (Alt((<!>)))
import Data.Functor.Apply (Apply ((<.>)))
import Data.Profunctor
import Prelude hiding (foldr)

#if !(MIN_VERSION_base(4,8,0))
import Data.Monoid (Monoid(mappend, mempty))
import Data.Traversable (Traversable(traverse))
#endif

#if !(MIN_VERSION_base(4,11,0))
import Data.Semigroup (Semigroup((<>)))
#endif

-- | 'Validation' is 'Either' with a Left that is a 'Monoid'
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
_ (Failure e
e) = e -> Validation e b
forall e a. e -> Validation e a
Failure e
e
   fmap a -> b
f (Success a
a) = b -> Validation e b
forall e a. a -> Validation e a
Success (a -> b
f a
a)

instance Semigroup e => Apply (Validation e) where
  Failure e
e1 <.> :: Validation e (a -> b) -> Validation e a -> Validation e 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
e2 -> e
e1 e -> e -> e
forall a. Semigroup a => a -> a -> a
<> e
e2
    Success a
_  -> e
e1
  Success a -> b
_  <.> Failure e
e  = e -> Validation e b
forall e a. e -> Validation e a
Failure  e
e
  Success a -> b
f  <.> Success a
x  = b -> Validation e b
forall e a. a -> Validation e a
Success (a -> b
f a
x)

instance Semigroup e => Applicative (Validation e) where
  pure :: a -> Validation e a
pure = a -> Validation e a
forall e a. a -> Validation e a
Success
  <*> :: Validation e (a -> b) -> Validation e a -> Validation e b
(<*>) = Validation e (a -> b) -> Validation e a -> Validation e b
forall (f :: * -> *) a b. Apply f => f (a -> b) -> f a -> f b
(<.>)

-- | For two errors, this instance reports both of them.
instance Semigroup e => Alt (Validation e) where
  s :: Validation e a
s@Success{} <!> :: Validation e a -> Validation e a -> Validation e a
<!> Validation e a
_ = Validation e a
s
  Validation e a
_ <!> s :: Validation e a
s@Success{} = Validation e a
s
  Failure e
m <!> Failure e
n = e -> Validation e a
forall e a. e -> Validation e a
Failure (e
m e -> e -> e
forall a. Semigroup a => a -> a -> a
<> e
n)

instance (Semigroup e, Monoid e) => Alternative (Validation e) where
  empty :: Validation e a
empty = e -> Validation e a
forall e a. e -> Validation e a
Failure e
forall a. Monoid a => a
mempty
  <|> :: Validation e a -> Validation e a -> Validation e a
(<|>) = Validation e a -> Validation e a -> Validation e a
forall (f :: * -> *) a. Alt f => f a -> f a -> f a
(<!>)

instance Foldable (Validation e) where
  foldr :: (a -> b -> b) -> b -> Validation e a -> b
foldr a -> b -> b
f b
x (Success a
a) = a -> b -> b
f a
a b
x
  foldr a -> b -> b
_ b
x (Failure e
_) = b
x

instance Traversable (Validation e) where
  traverse :: (a -> f b) -> Validation e a -> f (Validation e b)
traverse a -> f b
f (Success 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 a -> f b
_ (Failure 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)

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

instance Bifoldable Validation where
  bifoldr :: (a -> c -> c) -> (b -> c -> c) -> c -> Validation a b -> c
bifoldr a -> c -> c
_ b -> c -> c
g c
x (Success b
a) = b -> c -> c
g b
a c
x
  bifoldr a -> c -> c
f b -> c -> c
_ c
x (Failure a
e) = a -> c -> c
f a
e c
x

instance Bitraversable Validation where
  bitraverse :: (a -> f c) -> (b -> f d) -> Validation a b -> f (Validation c d)
bitraverse a -> f c
_ b -> f d
g (Success b
a) = d -> Validation c d
forall e a. a -> Validation e a
Success (d -> Validation c d) -> f d -> f (Validation c d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> b -> f d
g b
a
  bitraverse a -> f c
f b -> f d
_ (Failure a
e) = c -> Validation c d
forall e a. e -> Validation e a
Failure (c -> Validation c d) -> f c -> f (Validation c d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f c
f a
e

instance Semigroup e => Semigroup (Validation e a) where
  x :: Validation e a
x@Success{} <> :: Validation e a -> Validation e a -> Validation e a
<> Validation e a
_ = Validation e a
x
  Validation e a
_ <> x :: Validation e a
x@Success{} = Validation e a
x
  Failure e
e1 <> Failure e
e2 = e -> Validation e a
forall e a. e -> Validation e a
Failure (e
e1 e -> e -> e
forall a. Semigroup a => a -> a -> a
<> e
e2)

instance Monoid e => Monoid (Validation e a) where
  mempty :: Validation e a
mempty = e -> Validation e a
forall e a. e -> Validation e a
Failure e
forall a. Monoid a => a
mempty
#if !(MIN_VERSION_base(4,11,0))
  x@Success{} `mappend` _ = x
  _ `mappend` x@Success{} = x
  Failure e1 `mappend` Failure e2 = Failure (e1 `mappend` e2)
#endif

type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)

prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
prism b -> t
bt s -> Either t a
seta = (s -> Either t a)
-> (Either t (f b) -> f t)
-> p (Either t a) (Either t (f b))
-> p s (f t)
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap s -> Either t a
seta ((t -> f t) -> (f b -> f t) -> Either t (f b) -> f t
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either t -> f t
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((b -> t) -> f b -> f t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> t
bt)) (p (Either t a) (Either t (f b)) -> p s (f t))
-> (p a (f b) -> p (Either t a) (Either t (f b)))
-> p a (f b)
-> p s (f t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p a (f b) -> p (Either t a) (Either t (f b))
forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (Either c a) (Either c b)
right'
{-# INLINE prism #-}

_Failure :: Prism (Validation a c) (Validation b c) a b
_Failure :: p a (f b) -> p (Validation a c) (f (Validation b c))
_Failure = (b -> Validation b c)
-> (Validation a c -> Either (Validation b c) a)
-> Prism (Validation a c) (Validation b c) a b
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism
           (\ b
x -> b -> Validation b c
forall e a. e -> Validation e a
Failure b
x)
           (\ Validation a c
x
            -> case Validation a c
x of
              Failure a
y -> a -> Either (Validation b c) a
forall a b. b -> Either a b
Right a
y
              Success c
y -> Validation b c -> Either (Validation b c) a
forall a b. a -> Either a b
Left (c -> Validation b c
forall e a. a -> Validation e a
Success c
y))
{-# INLINE _Failure #-}

_Success :: Prism (Validation c a) (Validation c b) a b
_Success :: p a (f b) -> p (Validation c a) (f (Validation c b))
_Success = (b -> Validation c b)
-> (Validation c a -> Either (Validation c b) a)
-> Prism (Validation c a) (Validation c b) a b
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism
           (\ b
x -> b -> Validation c b
forall e a. a -> Validation e a
Success b
x)
           (\ Validation c a
x
            -> case Validation c a
x of
              Failure c
y -> Validation c b -> Either (Validation c b) a
forall a b. a -> Either a b
Left (c -> Validation c b
forall e a. e -> Validation e a
Failure c
y)
              Success a
y -> a -> Either (Validation c b) a
forall a b. b -> Either a b
Right a
y)
{-# INLINE _Success #-}

type Iso s t a b = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)

iso :: (s -> a) -> (b -> t) -> Iso s t a b
iso :: (s -> a) -> (b -> t) -> Iso s t a b
iso s -> a
sa b -> t
bt = (s -> a) -> (f b -> f t) -> p a (f b) -> p s (f t)
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap s -> a
sa ((b -> t) -> f b -> f t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> t
bt)
{-# INLINE iso #-}

validationToEither :: Validation e a -> Either e a
validationToEither :: Validation e a -> Either e a
validationToEither Validation e a
x = case Validation e a
x of
  Failure e
e -> e -> Either e a
forall a b. a -> Either a b
Left e
e
  Success a
a -> a -> Either e a
forall a b. b -> Either a b
Right a
a
{-# INLINE validationToEither #-}

eitherToValidation :: Either e a -> Validation e a
eitherToValidation :: Either e a -> Validation e a
eitherToValidation Either e a
x = case Either e a
x of
  Left e
e -> e -> Validation e a
forall e a. e -> Validation e a
Failure e
e
  Right a
a -> a -> Validation e a
forall e a. a -> Validation e a
Success a
a
{-# INLINE eitherToValidation #-}

-- | 'Validation' is isomorphic to 'Either'
_Validation :: Iso (Validation e a) (Validation g b) (Either e a) (Either g b)
_Validation :: p (Either e a) (f (Either g b))
-> p (Validation e a) (f (Validation g b))
_Validation = (Validation e a -> Either e a)
-> (Either g b -> Validation g b)
-> Iso (Validation e a) (Validation g b) (Either e a) (Either g b)
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso Validation e a -> Either e a
forall e a. Validation e a -> Either e a
validationToEither Either g b -> Validation g b
forall e a. Either e a -> Validation e a
eitherToValidation
{-# INLINE _Validation #-}

vap :: Semigroup m => Either m (a -> b) -> Either m a -> Either m b
vap :: Either m (a -> b) -> Either m a -> Either m b
vap (Left m
m) Either m a
b = m -> Either m b
forall a b. a -> Either a b
Left (m -> Either m b) -> m -> Either m b
forall a b. (a -> b) -> a -> b
$ case Either m a
b of
  Left m
n  -> m
m m -> m -> m
forall a. Semigroup a => a -> a -> a
<> m
n
  Right{} -> m
m
vap Right{} (Left m
n) = m -> Either m b
forall a b. a -> Either a b
Left m
n
vap (Right a -> b
f) (Right a
a) = b -> Either m b
forall a b. b -> Either a b
Right (a -> b
f a
a)
{-# INLINE vap #-}

apm :: Monoid m => Validation m (a -> b) -> Validation m a -> Validation m b
apm :: Validation m (a -> b) -> Validation m a -> Validation m b
apm (Failure m
m) Validation m a
b = m -> Validation m b
forall e a. e -> Validation e a
Failure (m -> Validation m b) -> m -> Validation m b
forall a b. (a -> b) -> a -> b
$ m
m m -> m -> m
forall a. Monoid a => a -> a -> a
`mappend` case Validation m a
b of
  Failure m
n  -> m
n
  Success{} -> m
forall a. Monoid a => a
mempty
apm Success{} (Failure m
n) = m -> Validation m b
forall e a. e -> Validation e a
Failure m
n
apm (Success a -> b
f) (Success a
a) = b -> Validation m b
forall e a. a -> Validation e a
Success (a -> b
f a
a)
{-# INLINE apm #-}

-- lazier version of vap that can leak less, but which requires a Monoid
vapm :: Monoid m => Either m (a -> b) -> Either m a -> Either m b
vapm :: Either m (a -> b) -> Either m a -> Either m b
vapm (Left m
m) Either m a
b = m -> Either m b
forall a b. a -> Either a b
Left (m -> Either m b) -> m -> Either m b
forall a b. (a -> b) -> a -> b
$ m
m m -> m -> m
forall a. Monoid a => a -> a -> a
`mappend` case Either m a
b of
  Left m
n  -> m
n
  Right{} -> m
forall a. Monoid a => a
mempty
vapm Right{} (Left m
n) = m -> Either m b
forall a b. a -> Either a b
Left m
n
vapm (Right a -> b
f) (Right a
a) = b -> Either m b
forall a b. b -> Either a b
Right (a -> b
f a
a)
{-# INLINE vapm #-}

ealt :: Validation e a -> Validation e a -> Validation e a
ealt :: Validation e a -> Validation e a -> Validation e a
ealt Failure{} Validation e a
r = Validation e a
r
ealt (Success a
a) Validation e a
_ = a -> Validation e a
forall e a. a -> Validation e a
Success a
a
{-# INLINE ealt #-}