content: {-# 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,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 (Eq, Ord, Show)
  
  instance Functor (Validation e) where
     fmap _ (Failure e) = Failure e
     fmap f (Success a) = Success (f a)
  
  instance Semigroup e => Apply (Validation e) where
    Failure e1 <.> b = Failure $ case b of
      Failure e2 -> e1 <> e2
      Success _  -> e1
    Success _  <.> Failure e  = Failure  e
    Success f  <.> Success x  = Success (f x)
  
  instance Semigroup e => Applicative (Validation e) where
    pure = Success
    (<*>) = (<.>)
  
  -- | For two errors, this instance reports both of them.
  instance Semigroup e => Alt (Validation e) where
    s@Success{} <!> _ = s
    _ <!> s@Success{} = s
    Failure m <!> Failure n = Failure (m <> n)
  
  instance (Semigroup e, Monoid e) => Alternative (Validation e) where
    empty = Failure mempty
    (<|>) = (<!>)
  
  instance Foldable (Validation e) where
    foldr f x (Success a) = f a x
    foldr _ x (Failure _) = x
  
  instance Traversable (Validation e) where
    traverse f (Success a) = Success <$> f a
    traverse _ (Failure e) = pure (Failure e)
  
  instance Bifunctor Validation where
    bimap f _ (Failure e) = Failure (f e)
    bimap _ g (Success a) = Success (g a)
  
  instance Bifoldable Validation where
    bifoldr _ g x (Success a) = g a x
    bifoldr f _ x (Failure e) = f e x
  
  instance Bitraversable Validation where
    bitraverse _ g (Success a) = Success <$> g a
    bitraverse f _ (Failure e) = Failure <$> f e
  
  instance Semigroup e => Semigroup (Validation e a) where
    x@Success{} <> _ = x
    _ <> x@Success{} = x
    Failure e1 <> Failure e2 = Failure (e1 <> e2)
  
  instance Monoid e => Monoid (Validation e a) where
    mempty = Failure 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 bt seta = dimap seta (either pure (fmap bt)) . right'
  {-# INLINE prism #-}
  
  _Failure :: Prism (Validation a c) (Validation b c) a b
  _Failure = prism
             (\ x -> Failure x)
             (\ x
              -> case x of
                Failure y -> Right y
                Success y -> Left (Success y))
  {-# INLINE _Failure #-}
  
  _Success :: Prism (Validation c a) (Validation c b) a b
  _Success = prism
             (\ x -> Success x)
             (\ x
              -> case x of
                Failure y -> Left (Failure y)
                Success y -> Right 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 sa bt = dimap sa (fmap bt)
  {-# INLINE iso #-}
  
  validationToEither :: Validation e a -> Either e a
  validationToEither x = case x of
    Failure e -> Left e
    Success a -> Right a
  {-# INLINE validationToEither #-}
  
  eitherToValidation :: Either e a -> Validation e a
  eitherToValidation x = case x of
    Left e -> Failure e
    Right a -> Success a
  {-# INLINE eitherToValidation #-}
  
  -- | 'Validation' is isomorphic to 'Either'
  _Validation :: Iso (Validation e a) (Validation g b) (Either e a) (Either g b)
  _Validation = iso validationToEither eitherToValidation
  {-# INLINE _Validation #-}
  
  vap :: Semigroup m => Either m (a -> b) -> Either m a -> Either m b
  vap (Left m) b = Left $ case b of
    Left n  -> m <> n
    Right{} -> m
  vap Right{} (Left n) = Left n
  vap (Right f) (Right a) = Right (f a)
  {-# INLINE vap #-}
  
  apm :: Monoid m => Validation m (a -> b) -> Validation m a -> Validation m b
  apm (Failure m) b = Failure $ m `mappend` case b of
    Failure n  -> n
    Success{} -> mempty
  apm Success{} (Failure n) = Failure n
  apm (Success f) (Success a) = Success (f 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 (Left m) b = Left $ m `mappend` case b of
    Left n  -> n
    Right{} -> mempty
  vapm Right{} (Left n) = Left n
  vapm (Right f) (Right a) = Right (f a)
  {-# INLINE vapm #-}
  
  ealt :: Validation e a -> Validation e a -> Validation e a
  ealt Failure{} r = r
  ealt (Success a) _ = Success a
  {-# INLINE ealt #-}
  