{-# OPTIONS_GHC -Wall -O2 #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE UnboxedSums #-}
{-# LANGUAGE UnboxedTuples #-}
module Data.Validation.Unpacked
(
Validation(Validation, Failure, Success)
, failure
, success
, validate
, fromEither
, liftError
, validation
, toEither
, orElse
, valueOr
, ensure
, codiagonal
, bindValidation
, fromBaseValidation
, toBaseValidation
) where
import Prelude
()
import Control.Applicative (Applicative((<*>), pure))
import Control.DeepSeq (NFData(rnf))
import Control.Monad (return)
import Data.Bifoldable (Bifoldable(bifoldr))
import Data.Bifunctor (Bifunctor(bimap))
import Data.Bitraversable (Bitraversable(bitraverse))
import Data.Bool (Bool(False))
import Data.Either.Unpacked (Either(Left, Right), either)
import Data.Eq (Eq((==)))
import Data.Foldable (Foldable(foldr))
import Data.Function ((.), id)
import Data.Functor (Functor(fmap), (<$>))
import Data.Monoid (Monoid(mempty,mappend))
import Data.Ord (Ord(compare, (>=)), Ordering(GT, LT))
import Data.Semigroup (Semigroup((<>)))
import Data.Traversable (Traversable(traverse))
import qualified Data.Validation as BaseValidation
import GHC.Read (Read(readPrec, readList), expectP)
import GHC.Show (Show(showsPrec, showList), showString, showParen, showList__)
import Text.Read (parens, Lexeme(Ident), (+++), readListPrec, readListDefault, readListPrecDefault)
import Text.ParserCombinators.ReadPrec
(prec, step)
data Validation err a = Validation (# err | a #)
pattern Failure :: err -> Validation err a
pattern Failure err = Validation (# err | #)
pattern Success :: a -> Validation err a
pattern Success a = Validation (# | a #)
{-# COMPLETE Failure, Success #-}
failure :: err -> Validation err a
{-# INLINE failure #-}
failure err = Validation (# err | #)
success :: a -> Validation err a
{-# INLINE success #-}
success a = Validation (# | a #)
appValidation :: (err -> err -> err)
-> Validation err a
-> Validation err a
-> Validation err a
{-# INLINE appValidation #-}
appValidation m (Failure e1) (Failure e2) = Failure (e1 `m` e2)
appValidation _ (Failure _) (Success a2) = Success a2
appValidation _ (Success a1) (Failure _) = Success a1
appValidation _ (Success a1) (Success _) = Success a1
validate :: err -> (a -> Bool) -> a -> Validation err a
{-# INLINE validate #-}
validate e p a = if p a
then Success a
else Failure e
validation :: (e -> c) -> (a -> c) -> Validation e a -> c
{-# INLINE validation #-}
validation ec _ (Failure e) = ec e
validation _ ac (Success a) = ac a
liftError :: (b -> e) -> Either b a -> Validation e a
{-# INLINE liftError #-}
liftError f = either (Failure . f) Success
fromEither :: Either e a -> Validation e a
{-# INLINE fromEither #-}
fromEither = liftError id
toEither :: Validation e a -> Either e a
{-# INLINE toEither #-}
toEither = validation Left Right
orElse :: Validation e a -> a -> a
{-# INLINE orElse #-}
orElse v a = validation (\_ -> a) id v
valueOr :: (e -> a) -> Validation e a -> a
{-# INLINE valueOr #-}
valueOr ea (Failure e) = ea e
valueOr _ (Success a) = a
codiagonal :: Validation a a -> a
{-# INLINE codiagonal #-}
codiagonal = valueOr id
ensure :: e -> (a -> Bool) -> Validation e a -> Validation e a
{-# INLINE ensure #-}
ensure _ _ (Failure x) = Failure x
ensure e p (Success a) = validate e p a
bindValidation :: Validation e a -> (a -> Validation e b) -> Validation e b
bindValidation (Failure e) _ = Failure e
bindValidation (Success a) f = f a
fromBaseValidation :: BaseValidation.Validation a b -> Validation a b
fromBaseValidation (BaseValidation.Failure a) = failure a
fromBaseValidation (BaseValidation.Success b) = success b
toBaseValidation :: Validation a b -> BaseValidation.Validation a b
toBaseValidation (Failure a) = BaseValidation.Failure a
toBaseValidation (Success b) = BaseValidation.Success b
instance (Eq a, Eq b) => Eq (Validation a b) where
Failure a == Failure b = a == b
Success a == Success b = a == b
_ == _ = False
{-# INLINE (==) #-}
instance (Ord a, Ord b) => Ord (Validation a b) where
compare x y
= case x of
Failure a -> case y of
Failure b -> compare a b
_ -> LT
Success a -> case y of
Success b -> compare a b
_ -> GT
{-# INLINE compare #-}
instance (Read a, Read b) => Read (Validation a b) where
readPrec
= parens (prec 10
(do expectP (Ident "Failure")
a <- step readPrec
return (Failure a))
+++
prec
10
(do expectP (Ident "Success")
b <- step readPrec
return (Success b)))
readList = readListDefault
readListPrec = readListPrecDefault
instance (Show b, Show a) => Show (Validation a b) where
showsPrec i (Failure a)
= showParen
(i >= 11)
((.)
(showString "Failure ") (showsPrec 11 a))
showsPrec i (Success b)
= showParen
(i >= 11)
((.)
(showString "Success ") (showsPrec 11 b))
showList = showList__ (showsPrec 0)
instance Functor (Validation err) where
fmap _ (Failure e) = Failure e
fmap f (Success a) = Success (f a)
{-# INLINE fmap #-}
instance Semigroup err => Applicative (Validation err) where
pure = Success
{-# INLINE pure #-}
Failure e1 <*> Failure e2 = Failure (e1 <> e2)
Failure e1 <*> Success _ = Failure e1
Success _ <*> Failure e2 = Failure e2
Success f <*> Success a = Success (f a)
{-# INLINE (<*>) #-}
instance Foldable (Validation err) where
foldr f x (Success a) = f a x
foldr _ x (Failure _) = x
{-# INLINE foldr #-}
instance Traversable (Validation err) where
traverse f (Success a) = Success <$> f a
traverse _ (Failure e) = pure (Failure e)
{-# INLINE traverse #-}
instance Bifunctor Validation where
bimap f _ (Failure e) = Failure (f e)
bimap _ g (Success a) = Success (g a)
{-# INLINE bimap #-}
instance Bifoldable Validation where
bifoldr _ g x (Success a) = g a x
bifoldr f _ x (Failure e) = f e x
{-# INLINE bifoldr #-}
instance Bitraversable Validation where
bitraverse _ g (Success a) = Success <$> g a
bitraverse f _ (Failure e) = Failure <$> f e
{-# INLINE bitraverse #-}
instance Semigroup e => Semigroup (Validation e a) where
(<>) = appValidation (<>)
{-# INLINE (<>) #-}
instance Monoid e => Monoid (Validation e a) where
mappend = appValidation mappend
{-# INLINE mappend #-}
mempty = Failure mempty
{-# INLINE mempty #-}
instance (NFData e, NFData a) => NFData (Validation e a) where
rnf (Failure e) = rnf e
rnf (Success a) = rnf a
{-# INLINE rnf #-}