module Data.Validation
(
AccValidation(..)
, Validation(..)
, ValidationT(..)
, Validation'
, _Failure
, _Success
, Validate(..)
) where
import Control.Applicative(Applicative((<*>), pure), liftA2, (<$>))
import Control.Lens.Getter((^.))
import Control.Lens.Iso(Swapped(..), Iso, iso)
import Control.Lens.Prism(Prism, prism)
import Control.Lens.Review(( # ))
import Control.Monad(Monad((>>=), return), liftM)
import Control.Monad.Trans.Class(MonadTrans, lift)
import Data.Bifoldable(Bifoldable(bifoldr))
import Data.Bifunctor(Bifunctor(bimap))
import Data.Bitraversable(Bitraversable(bitraverse))
import Data.Data(Data)
import Data.Either(Either(Left, Right))
import Data.Eq(Eq)
import Data.Foldable(Foldable(foldr))
import Data.Function((.), id, flip)
import Data.Functor(Functor(fmap))
import Data.Functor.Alt(Alt((<!>)))
import Data.Functor.Apply(Apply((<.>)))
import Data.Functor.Bind(Bind((>>-)), liftF2)
import Data.Functor.Identity(Identity(Identity))
import Data.Monoid(Monoid(mappend, mempty))
import Data.Ord(Ord)
import Data.Semigroup(Semigroup((<>)))
import Data.Traversable(Traversable(traverse))
import Data.Typeable(Typeable)
import Prelude(Show)
data AccValidation err a =
AccFailure err
| AccSuccess a
deriving (Eq, Ord, Show, Data, Typeable)
fmapAccValidation ::
(a -> b)
-> AccValidation err a
-> AccValidation err b
fmapAccValidation _ (AccFailure e) =
AccFailure e
fmapAccValidation f (AccSuccess a) =
AccSuccess (f a)
instance Functor (AccValidation err) where
fmap =
fmapAccValidation
apAccValidation ::
Semigroup err =>
AccValidation err (a -> b)
-> AccValidation err a
-> AccValidation err b
AccFailure e1 `apAccValidation` AccFailure e2 =
AccFailure (e1 <> e2)
AccFailure e1 `apAccValidation` AccSuccess _ =
AccFailure e1
AccSuccess _ `apAccValidation` AccFailure e2 =
AccFailure e2
AccSuccess f `apAccValidation` AccSuccess a =
AccSuccess (f a)
instance Semigroup err => Apply (AccValidation err) where
(<.>) =
apAccValidation
instance Semigroup err => Applicative (AccValidation err) where
pure =
AccSuccess
(<*>) =
(<.>)
altAccValidation ::
AccValidation err a
-> AccValidation err a
-> AccValidation err a
AccFailure _ `altAccValidation` x =
x
AccSuccess a `altAccValidation` _ =
AccSuccess a
instance Semigroup err => Alt (AccValidation err) where
(<!>) =
altAccValidation
foldrAccValidation ::
(a -> b -> b)
-> b
-> AccValidation err a -> b
foldrAccValidation f x (AccSuccess a) =
f a x
foldrAccValidation _ x (AccFailure _) =
x
instance Foldable (AccValidation err) where
foldr =
foldrAccValidation
traverseAccValidation ::
Applicative f =>
(a -> f b)
-> AccValidation err a
-> f (AccValidation err b)
traverseAccValidation f (AccSuccess a) =
AccSuccess <$> f a
traverseAccValidation _ (AccFailure e) =
pure (AccFailure e)
instance Traversable (AccValidation err) where
traverse =
traverseAccValidation
bimapAccValidation ::
(err -> f)
-> (a -> b)
-> AccValidation err a
-> AccValidation f b
bimapAccValidation f _ (AccFailure e) =
AccFailure (f e)
bimapAccValidation _ g (AccSuccess a) =
AccSuccess (g a)
instance Bifunctor AccValidation where
bimap =
bimapAccValidation
bifoldrAccValidation ::
(x -> a -> b)
-> (y -> a -> b)
-> a
-> AccValidation x y
-> b
bifoldrAccValidation _ g x (AccSuccess a) =
g a x
bifoldrAccValidation f _ x (AccFailure e) =
f e x
instance Bifoldable AccValidation where
bifoldr =
bifoldrAccValidation
bitraverseAccValidation ::
Functor f =>
(x -> f err)
-> (y -> f a)
-> AccValidation x y
-> f (AccValidation err a)
bitraverseAccValidation _ g (AccSuccess a) =
AccSuccess <$> g a
bitraverseAccValidation f _ (AccFailure e) =
AccFailure <$> f e
instance Bitraversable AccValidation where
bitraverse =
bitraverseAccValidation
appsAccValidation ::
Semigroup err =>
AccValidation err a
-> AccValidation err a
-> AccValidation err a
AccFailure e1 `appsAccValidation` AccFailure e2 =
AccFailure (e1 <> e2)
AccFailure _ `appsAccValidation` AccSuccess a2 =
AccSuccess a2
AccSuccess a1 `appsAccValidation` AccFailure _ =
AccSuccess a1
AccSuccess a1 `appsAccValidation` AccSuccess _ =
AccSuccess a1
instance Semigroup e => Semigroup (AccValidation e a) where
(<>) =
appsAccValidation
appmAccValidation ::
Monoid err =>
AccValidation err a
-> AccValidation err a
-> AccValidation err a
AccFailure e1 `appmAccValidation` AccFailure e2 =
AccFailure (e1 `mappend` e2)
AccFailure _ `appmAccValidation` AccSuccess a2 =
AccSuccess a2
AccSuccess a1 `appmAccValidation` AccFailure _ =
AccSuccess a1
AccSuccess a1 `appmAccValidation` AccSuccess _ =
AccSuccess a1
emptyAccValidation ::
Monoid err =>
AccValidation err a
emptyAccValidation =
AccFailure mempty
instance Monoid e => Monoid (AccValidation e a) where
mappend =
appmAccValidation
mempty =
emptyAccValidation
data Validation err a =
Failure err
| Success a
deriving (Eq, Ord, Show, Data, Typeable)
fmapValidation ::
(a -> b)
-> Validation err a
-> Validation err b
fmapValidation _ (Failure e) =
Failure e
fmapValidation f (Success a) =
Success (f a)
instance Functor (Validation err) where
fmap =
fmapValidation
apValidation ::
Validation err (a -> b)
-> Validation err a
-> Validation err b
Failure e1 `apValidation` Failure _ =
Failure e1
Failure e1 `apValidation` Success _ =
Failure e1
Success _ `apValidation` Failure e2 =
Failure e2
Success f `apValidation` Success a =
Success (f a)
instance Apply (Validation err) where
(<.>) =
apValidation
instance Applicative (Validation err) where
pure =
Success
(<*>) =
apValidation
altValidation ::
Validation err a
-> Validation err a
-> Validation err a
Failure _ `altValidation` x =
x
Success a `altValidation` _ =
Success a
instance Alt (Validation err) where
(<!>) =
altValidation
foldrValidation ::
(a -> b -> b)
-> b
-> Validation err a
-> b
foldrValidation f x (Success a) =
f a x
foldrValidation _ x (Failure _) =
x
instance Foldable (Validation err) where
foldr =
foldrValidation
traverseValidation ::
Applicative f =>
(a -> f b)
-> Validation err a
-> f (Validation err b)
traverseValidation f (Success a) =
Success <$> f a
traverseValidation _ (Failure e) =
pure (Failure e)
instance Traversable (Validation err) where
traverse =
traverseValidation
bimapValidation ::
(err -> f)
-> (a -> b)
-> Validation err a
-> Validation f b
bimapValidation f _ (Failure e) =
Failure (f e)
bimapValidation _ g (Success a) =
Success (g a)
instance Bifunctor Validation where
bimap =
bimapValidation
bifoldrValidation ::
(x -> a -> b)
-> (y -> a -> b)
-> a
-> Validation x y
-> b
bifoldrValidation _ g x (Success a) =
g a x
bifoldrValidation f _ x (Failure e) =
f e x
instance Bifoldable Validation where
bifoldr =
bifoldrValidation
bitraverseValidation ::
Functor f =>
(x -> f err)
-> (y -> f a)
-> Validation x y
-> f (Validation err a)
bitraverseValidation _ g (Success a) =
Success <$> g a
bitraverseValidation f _ (Failure e) =
Failure <$> f e
instance Bitraversable Validation where
bitraverse =
bitraverseValidation
bindValidation ::
Validation err a
-> (a -> Validation err b)
-> Validation err b
Failure e `bindValidation` _ =
Failure e
Success a `bindValidation` f =
f a
instance Bind (Validation err) where
(>>-) =
bindValidation
instance Monad (Validation err) where
return =
Success
(>>=) =
bindValidation
data ValidationT err m a =
ValidationT {
runValidationT :: m (Validation err a)
}
type Validation' err a =
ValidationT err Identity a
fmapValidationT ::
Functor f =>
(a -> b)
-> ValidationT err f a
-> ValidationT err f b
fmapValidationT f (ValidationT k) =
ValidationT (fmap (fmap f) k)
instance Functor m => Functor (ValidationT err m) where
fmap =
fmapValidationT
apValidationT ::
Apply f =>
ValidationT err f (a -> b)
-> ValidationT err f a
-> ValidationT err f b
ValidationT f `apValidationT` ValidationT a =
ValidationT (liftF2 (<.>) f a)
instance Apply m => Apply (ValidationT err m) where
(<.>) =
apValidationT
pureValidationT ::
Applicative f =>
a
-> ValidationT err f a
pureValidationT =
ValidationT . pure . pure
aplValidationT ::
Applicative f =>
ValidationT err f (a -> b)
-> ValidationT err f a
-> ValidationT err f b
ValidationT f `aplValidationT` ValidationT a =
ValidationT (liftA2 (<*>) f a)
instance Applicative m => Applicative (ValidationT err m) where
pure =
pureValidationT
(<*>) =
aplValidationT
altValidationT ::
(Functor m, Monad m) =>
ValidationT err m a
-> ValidationT err m a
-> ValidationT err m a
ValidationT x `altValidationT` ValidationT y =
ValidationT (x >>= \q -> case q of
Failure _ -> y
Success a -> return (Success a))
instance (Functor m, Monad m) => Alt (ValidationT err m) where
(<!>) =
altValidationT
foldrValidationT ::
Foldable f =>
(a -> b -> b)
-> b
-> ValidationT err f a
-> b
foldrValidationT f z (ValidationT x) =
foldr (flip (foldr f)) z x
instance Foldable m => Foldable (ValidationT err m) where
foldr =
foldrValidationT
traverseValidationT ::
(Traversable g, Applicative f) =>
(a -> f b)
-> ValidationT err g a
-> f (ValidationT err g b)
traverseValidationT f (ValidationT x) =
ValidationT <$> traverse (traverse f) x
instance Traversable m => Traversable (ValidationT err m) where
traverse =
traverseValidationT
bindValidationT ::
Monad f =>
ValidationT err f a
-> (a -> ValidationT err f b)
-> ValidationT err f b
ValidationT v `bindValidationT` f =
ValidationT (v >>= \w -> case w of
Failure e -> return (Failure e)
Success a -> runValidationT (f a))
instance (Apply m, Monad m) => Bind (ValidationT err m) where
(>>-) =
bindValidationT
returnValidationT ::
Monad f =>
a
-> ValidationT err f a
returnValidationT =
ValidationT . return . pure
instance Monad m => Monad (ValidationT err m) where
return =
returnValidationT
(>>=) =
bindValidationT
instance MonadTrans (ValidationT err) where
lift = liftValidationT
liftValidationT ::
Monad m =>
m a
-> ValidationT e m a
liftValidationT =
ValidationT . liftM Success
data ValidationTB m err a =
ValidationTB {
runValidationTB :: m (Validation err a)
}
fmapValidationTB ::
Functor f =>
(a -> b)
-> ValidationTB f err a
-> ValidationTB f err b
fmapValidationTB f (ValidationTB k) =
ValidationTB (fmap (fmap f) k)
instance Functor m => Functor (ValidationTB m err) where
fmap =
fmapValidationTB
apValidationTB ::
Apply f =>
ValidationTB f err (a -> b)
-> ValidationTB f err a
-> ValidationTB f err b
ValidationTB f `apValidationTB` ValidationTB a =
ValidationTB (liftF2 (<.>) f a)
instance Apply m => Apply (ValidationTB m err) where
(<.>) =
apValidationTB
pureValidationTB ::
Applicative f =>
a
-> ValidationTB f err a
pureValidationTB =
ValidationTB . pure . pure
aplValidationTB ::
Applicative f =>
ValidationTB f err (a -> b)
-> ValidationTB f err a
-> ValidationTB f err b
ValidationTB f `aplValidationTB` ValidationTB a =
ValidationTB (liftA2 (<*>) f a)
instance Applicative m => Applicative (ValidationTB m err) where
pure =
pureValidationTB
(<*>) =
aplValidationTB
altValidationTB ::
(Functor m, Monad m) =>
ValidationTB m err a
-> ValidationTB m err a
-> ValidationTB m err a
ValidationTB x `altValidationTB` ValidationTB y =
ValidationTB (x >>= \q -> case q of
Failure _ -> y
Success a -> return (Success a))
instance (Functor m, Monad m) => Alt (ValidationTB m err) where
(<!>) =
altValidationTB
foldrValidationTB ::
Foldable f =>
(a -> b -> b)
-> b
-> ValidationTB f err a
-> b
foldrValidationTB f z (ValidationTB x) =
foldr (flip (foldr f)) z x
instance Foldable m => Foldable (ValidationTB m err) where
foldr =
foldrValidationTB
traverseValidationTB ::
(Traversable g, Applicative f) =>
(a -> f b)
-> ValidationTB g err a
-> f (ValidationTB g err b)
traverseValidationTB f (ValidationTB x) =
ValidationTB <$> traverse (traverse f) x
instance Traversable m => Traversable (ValidationTB m err) where
traverse =
traverseValidationTB
bimapValidationTB ::
Functor f =>
(err -> frr)
-> (a -> b)
-> ValidationTB f err a
-> ValidationTB f frr b
bimapValidationTB f g (ValidationTB x) =
ValidationTB (fmap (bimap f g) x)
instance Functor m => Bifunctor (ValidationTB m) where
bimap =
bimapValidationTB
bifoldrValidationTB ::
Foldable f =>
(err -> b -> b)
-> (a -> b -> b)
-> b
-> ValidationTB f err a
-> b
bifoldrValidationTB f g z (ValidationTB x) =
foldr (flip (bifoldr f g)) z x
instance Foldable m => Bifoldable (ValidationTB m) where
bifoldr =
bifoldrValidationTB
bitraverseValidationTB ::
(Traversable g, Applicative f) =>
(err -> f frr)
-> (a -> f b)
-> ValidationTB g err a
-> f (ValidationTB g frr b)
bitraverseValidationTB f g (ValidationTB x) =
ValidationTB <$> traverse (bitraverse f g) x
instance Traversable m => Bitraversable (ValidationTB m) where
bitraverse =
bitraverseValidationTB
bindValidationTB ::
Monad f =>
ValidationTB f err a
-> (a -> ValidationTB f err b)
-> ValidationTB f err b
ValidationTB v `bindValidationTB` f =
ValidationTB (v >>= \w -> case w of
Failure e -> return (Failure e)
Success a -> runValidationTB (f a))
instance (Apply m, Monad m) => Bind (ValidationTB m err) where
(>>-) =
bindValidationTB
returnValidationTB ::
Monad f =>
a
-> ValidationTB f err a
returnValidationTB =
ValidationTB . return . pure
instance Monad m => Monad (ValidationTB m err) where
return =
returnValidationTB
(>>=) =
bindValidationTB
_ValidationV' ::
Validate f =>
Iso (f e a) (f g b) (Validation' e a) (Validation' g b)
_ValidationV' =
iso
(\x -> ValidationT (Identity (x ^. _Validation)))
(\(ValidationT (Identity x)) -> _Validation # x)
_ValidationTx ::
Iso (ValidationT e m a) (ValidationT e' m' a') (ValidationTB m e a) (ValidationTB m' e' a')
_ValidationTx =
iso
(\(ValidationT x) -> ValidationTB x)
(\(ValidationTB x) -> ValidationT x)
_AccValidationV ::
Validate f =>
Iso (f e a) (f g b) (AccValidation e a) (AccValidation g b)
_AccValidationV =
iso
(\x -> case x ^. _Validation of
Failure e -> AccFailure e
Success a -> AccSuccess a)
(\x -> _Validation # case x of
AccFailure e -> Failure e
AccSuccess a -> Success a)
_EitherV ::
Validate f =>
Iso (f e a) (f g b) (Either e a) (Either g b)
_EitherV =
iso
(\x -> case x ^. _Validation of
Failure e -> Left e
Success a -> Right a)
(\x -> _Validation # case x of
Left e -> Failure e
Right a -> Success a)
class Validate f where
_Validation ::
Iso (f e a) (f g b) (Validation e a) (Validation g b)
_Validation' ::
Iso (f e a) (f g b) (Validation' e a) (Validation' g b)
_Validation' =
_ValidationV'
_AccValidation ::
Iso (f e a) (f g b) (AccValidation e a) (AccValidation g b)
_AccValidation =
_AccValidationV
_Either ::
Iso (f e a) (f g b) (Either e a) (Either g b)
_Either =
_EitherV
instance Validate Validation where
_Validation =
id
_AccValidationValidationIso ::
Iso (AccValidation e a) (AccValidation g b) (Validation e a) (Validation g b)
_AccValidationValidationIso =
iso
(\x -> case x of
AccFailure e -> Failure e
AccSuccess a -> Success a)
(\x -> case x of
Failure e -> AccFailure e
Success a -> AccSuccess a)
_AccValidationEitherIso ::
Iso (AccValidation e a) (AccValidation g b) (Either e a) (Either g b)
_AccValidationEitherIso =
iso
(\x -> case x of
AccFailure e -> Left e
AccSuccess a -> Right a)
(\x -> case x of
Left e -> AccFailure e
Right a -> AccSuccess a)
instance Validate AccValidation where
_Validation =
_AccValidationValidationIso
_AccValidation =
id
_Either =
_AccValidationEitherIso
_EitherValidationIso ::
Iso (Either e a) (Either g b) (Validation e a) (Validation g b)
_EitherValidationIso =
iso
(\x -> case x of
Left e -> Failure e
Right a -> Success a)
(\x -> case x of
Failure e -> Left e
Success a -> Right a)
_EitherAccValidationIso ::
Iso (Either e a) (Either g b) (AccValidation e a) (AccValidation g b)
_EitherAccValidationIso =
iso
(\x -> case x of
Left e -> AccFailure e
Right a -> AccSuccess a)
(\x -> case x of
AccFailure e -> Left e
AccSuccess a -> Right a)
instance Validate Either where
_Validation =
_EitherValidationIso
_AccValidation =
_EitherAccValidationIso
_Either =
id
_Failure ::
Validate f =>
Prism (f e1 a) (f e2 a) e1 e2
_Failure =
prism
(\x -> _Either # Left x)
(\x -> case x ^. _Either of
Left e -> Right e
Right a -> Left (_Either # Right a))
_Success ::
Validate f =>
Prism (f e a) (f e b) a b
_Success =
prism
(\x -> _Either # Right x)
(\x -> case x ^. _Either of
Left e -> Left (_Either # Left e)
Right a -> Right a)
swappedAccValidation ::
Iso (AccValidation e a) (AccValidation f b) (AccValidation a e) (AccValidation b f)
swappedAccValidation =
iso
(\v -> case v of
AccFailure e -> AccSuccess e
AccSuccess a -> AccFailure a)
(\v -> case v of
AccFailure a -> AccSuccess a
AccSuccess e -> AccFailure e)
swappedValidation ::
Iso (Validation e a) (Validation f b) (Validation a e) (Validation b f)
swappedValidation =
iso
(\v -> case v of
Failure e -> Success e
Success a -> Failure a)
(\v -> case v of
Failure a -> Success a
Success e -> Failure e)
swappedValidationTB ::
Functor k =>
Iso (ValidationTB k e a) (ValidationTB k f b) (ValidationTB k a e) (ValidationTB k b f)
swappedValidationTB =
iso
(\(ValidationTB x) -> ValidationTB (fmap (swapped # ) x))
(\(ValidationTB x) -> ValidationTB (fmap (swapped # ) x))
instance Swapped AccValidation where
swapped =
swappedAccValidation
instance Swapped Validation where
swapped =
swappedValidation
instance Functor f => Swapped (ValidationTB f) where
swapped =
swappedValidationTB