{-# 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.Monoid (Monoid(mappend, mempty))
import Data.Profunctor
import Data.Semigroup (Semigroup((<>)))
import Data.Traversable (Traversable(traverse))
import Prelude hiding (foldr)

-- | '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
  x@Success{} `mappend` _ = x
  _ `mappend` x@Success{} = x
  Failure e1 `mappend` Failure e2 = Failure (e1 `mappend` e2)

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 #-}