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