{-|
Module      : Data.Validation
Copyright   : (c) Marcin Mrotek, 2016
License     : BSD3
Maintainer  : marcin.jan.mrotek@gmail.com
Stability   : experimental

Accumulating Either-like type.
-}

{-# LANGUAGE 
    DeriveDataTypeable
  , DeriveFunctor
  , DeriveFoldable
  , DeriveGeneric 
  #-}

module Data.Validation (Validation(..)) where
  
import Control.Applicative
import Control.Lens
import Data.Bifunctor
import Data.Bifoldable
import Data.Bitraversable
import Data.Data
import Data.Functor.Alt
import Data.Semigroup
import GHC.Generics

data Validation e a = Success a | Failure e
  deriving (Show, Eq, Ord, Data, Functor, Foldable, Generic)

instance Semigroup e => Semigroup (Validation e a) where
  (<>) = app
    where
      app (Failure e1) (Failure e2) = Failure (e1 <> e2)
      app v@(Success _) _ = v
      app _ v@(Success _) = v
      
instance Monoid e => Monoid (Validation e a) where
  mempty = Failure mempty
  mappend = app
    where
      app (Failure e1) (Failure e2) = Failure (e1 `mappend` e2)
      app v@(Success _) _ = v
      app _ v@(Success _) = v
  
instance Semigroup e => Applicative (Validation e) where
  pure = Success
  (<*>) = app
    where
      app (Success f) (Success a) = Success (f a)
      app (Failure e) (Success _) = Failure e
      app (Success _) (Failure e) = Failure e
      app (Failure e1) (Failure e2) = Failure (e1 <> e2)
      
altValidation :: Validation e a -> Validation e a -> Validation e a
altValidation (Failure _) v = v
altValidation v@(Success _) _ = v

instance (Monoid e, Semigroup e) => Alternative (Validation e) where
  empty = Failure mempty
  (<|>) = altValidation
      
instance Semigroup e => Apply (Validation e) where
  (<.>) = (<*>)
  
instance Alt (Validation e) where
  (<!>) = altValidation

instance Traversable (Validation e) where
  traverse f v = 
    case v of
      Success a -> Success <$> f a
      Failure e -> pure $ Failure e
      
instance Swapped Validation where
  swapped = iso swap swap
    where
      swap (Success a) = Failure a
      swap (Failure e) = Success e
      
instance Bifunctor Validation where
  bimap f g v = 
    case v of
      Success a -> Success (g a)
      Failure e -> Failure (f e)
  first f v =
    case v of
      Success a -> Success a
      Failure e -> Failure (f e)
  second = fmap

instance Bifoldable Validation where
  bifoldMap f g v =
    case v of
      Success a -> g a
      Failure e -> f e
    
instance Bitraversable Validation where
  bitraverse f g v =
    case v of
      Success a -> Success <$> g a
      Failure e -> Failure <$> f e