validation 0.5.5 → 1.2.2
raw patch · 9 files changed
Files
- LICENCE +30/−0
- LICENSE +0/−29
- Setup.hs +0/−2
- changelog +80/−1
- src/Data/Validation.hs +1048/−941
- test/doctest_tests.hs +17/−0
- test/doctests.hs +0/−32
- test/hedgehog_tests.hs +453/−0
- validation.cabal +80/−68
+ LICENCE view
@@ -0,0 +1,30 @@+Copyright (C) 2010-2013 Tony Morris, Nick Partridge+Copyright (C) 2014,2015 NICTA Limited+Copyright (c) 2016-2019 Commonwealth Scientific and Industrial Research Organisation (CSIRO) ABN 41 687 119 230+Copyright (c) 2019-2026 Tony Morris++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.
− LICENSE
@@ -1,29 +0,0 @@-Copyright 2010-2013 Tony Morris, Nick Partridge-Copyright 2014,2015 NICTA Limited-Copyright 2016,2017, Commonwealth Scientific and Industrial Research Organisation (CSIRO) ABN 41 687 119 230.--All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions-are met:-1. Redistributions of source code must retain the above copyright- notice, this list of conditions and the following disclaimer.-2. Redistributions in binary form must reproduce the above copyright- notice, this list of conditions and the following disclaimer in the- documentation and/or other materials provided with the distribution.-3. Neither the name of the author nor the names of his contributors- may be used to endorse or promote products derived from this software- without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND-ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE-IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE-ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE-FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL-DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS-OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)-HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT-LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY-OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF-SUCH DAMAGE.
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
changelog view
@@ -1,3 +1,83 @@+1.2.2++* Implement Either instances for ReviewFailure, AsFailure, ReviewSuccess,+ and AsSuccess+* Add hedgehog property tests for Either optic instances++1.2.1++* Updates to documentation.++1.2.0++* Add Validator e p x a profunctor transformer newtype with instances+ for Functor, Apply, Applicative, Alt, Selective, Profunctor, Strong,+ Choice, Semigroupoid, Category, Arrow, ArrowChoice, ArrowApply, and+ Wrapped/Rewrapped+* Add classy optics for Validator (GetValidator, HasValidator,+ ReviewValidator, AsValidator)+* Add profunctor newtypes Iso'' and Prism'' for wrapping monomorphic+ optics as two-parameter profunctors+* Add unitValidator, taggedValidator, and swapValidator isomorphisms+* Add nonEmptyList example validators using Iso'' and Prism''+* Add tagged package dependency+* Expand hedgehog property tests from 4 to 35 covering semigroup,+ monoid, functor, applicative, apply, alt, bifunctor, foldValidation,+ iso/prism roundtrips, swap, and all Validator instances+* Replace HUnit tests with doctest suite (187 examples)+* Add tests: True to cabal.project+* Update examples for current API (remove Validate class, use either iso)+* Hide Prelude.either to avoid ambiguity with Data.Validation.either++1.1.5++* Update version bounds++1.1.4++* Remove nix build+* Add `Selective` instance++1.1.3++* Fix CI for older GHC++1.1.2++* Drop support for GHC-7.8.*, GHC-7.6.*, GHC-7.4.*, and GHC-7.2.*+* Adjust lower bounds of most dependencies to be inline with the lowest supported GHC version of 7.10.3++1.1.1++* Add `Data.Bifunctor.Swap.Swap` instance from `swap`+* Support `lens ^>= 5`++1.1++* Generalise types of `validate` and `ensure` functions to use `Maybe` instead of `Bool`++1++* Rename `AccValidation` to `Validation`++0.6.3++* Add `Generic` and `NFData` instances+* Make AccValidation Apply and Applicative lazier++0.6.2++* Add `bindValidation` and `validationed`++0.6.1++* Add validate, validationnel, fromEither, liftError, validation, toEither, orElse, valueOr, ensure, codiagonal, revalidate++0.6.0++* Delete `Validation`, `ValidationB`, `ValidationT`, `Validation'`+* Remove `_Validation` member from `Validate` class+ 0.5.5 * Raise upper bounds on base.@@ -72,4 +152,3 @@ 0.3.4 Loosen the type of the Isos for polymorphic update.-
src/Data/Validation.hs view
@@ -1,941 +1,1048 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE TypeFamilies #-}---- | Data types similar to @Data.Either@ that are explicit about failure and success.-module Data.Validation-(- -- * Data types- AccValidation(..)-, Validation(..)-, ValidationT(..)-, ValidationB(..)-, Validation'- -- * Prisms-, _Failure-, _Success- -- * Isomorphisms-, 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, runIdentity))-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)---- $setup--- >>> import Prelude(Num(..))--- >>> import Data.Eq(Eq(..))--- >>> import Data.String(String)--- >>> import Data.Int(Int)--- >>> import Test.QuickCheck--- >>> import Data.Either(either)--- >>> instance (Arbitrary err, Arbitrary a) => Arbitrary (AccValidation err a) where arbitrary = fmap (either (_Failure #) (_Success #)) arbitrary--- >>> instance (Arbitrary err, Arbitrary a) => Arbitrary (Validation err a) where arbitrary = fmap (either (_Failure #) (_Success #)) arbitrary--- >>> instance (Applicative m, Arbitrary err, Arbitrary a) => Arbitrary (ValidationT err m a) where arbitrary = fmap (ValidationT . pure) arbitrary--- >>> instance (Applicative m, Arbitrary err, Arbitrary a) => Arbitrary (ValidationB m err a) where arbitrary = fmap (ValidationB . pure) arbitrary---- | A value of the type @err@ or @a@, however, the @Applicative@ instance--- accumulates values. This is witnessed by the @Semigroup@ context on the instance.--- /Note that there is no Monad such that ap = (<*>)./------ >>> _Success # (+1) <*> _Success # 7 :: AccValidation String Int--- AccSuccess 8------ >>> _Failure # ["f1"] <*> _Success # 7 :: AccValidation [String] Int--- AccFailure ["f1"]------ >>> _Success # (+1) <*> _Failure # ["f2"] :: AccValidation [String] Int--- AccFailure ["f2"]------ >>> _Failure # ["f1"] <*> _Failure # ["f2"] :: AccValidation [String] Int--- AccFailure ["f1","f2"]-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)-{-# INLINE fmapAccValidation #-}--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)-{-# INLINE apAccValidation #-}--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-{-# INLINE altAccValidation #-}--instance 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-{-# INLINE foldrAccValidation #-}--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)-{-# INLINE traverseAccValidation #-}--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)-{-# INLINE bimapAccValidation #-}--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-{-# INLINE bifoldrAccValidation #-}--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-{-# INLINE bitraverseAccValidation #-}--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-{-# INLINE appsAccValidation #-}---- |------ prop> ((x <> y) <> z) == (x <> (y <> z :: AccValidation [String] Int))-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-{-# INLINE appmAccValidation #-}--emptyAccValidation ::- Monoid err =>- AccValidation err a-emptyAccValidation =- AccFailure mempty-{-# INLINE emptyAccValidation #-}---- |------ prop> ((x `mappend` y) `mappend` z) == (x `mappend` (y `mappend` z :: AccValidation [String] Int))------ prop> mempty `mappend` x == (x :: AccValidation [String] Int)------ prop> x `mappend` mempty == (x :: AccValidation [String] Int)-instance Monoid e => Monoid (AccValidation e a) where- mappend =- appmAccValidation- mempty =- emptyAccValidation---- | A value of the type @err@ or @a@ and isomorphic to @Data.Either@.------ >>> _Success # (+1) <*> _Success # 7 :: Validation String Int--- Success 8------ >>> _Failure # ["f1"] <*> _Success # 7 :: Validation [String] Int--- Failure ["f1"]------ >>> _Success # (+1) <*> _Failure # ["f2"] :: Validation [String] Int--- Failure ["f2"]------ >>> _Failure # ["f1"] <*> _Failure # ["f2"] :: Validation [String] Int--- Failure ["f1"]-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)-{-# INLINE fmapValidation #-}--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)-{-# INLINE apValidation #-}--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-{-# INLINE altValidation #-}--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-{-# INLINE foldrValidation #-}--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)-{-# INLINE traverseValidation #-}--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)-{-# INLINE bimapValidation #-}--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-{-# INLINE bifoldrValidation #-}--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-{-# INLINE bitraverseValidation #-}--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-{-# INLINE bindValidation #-}--instance Bind (Validation err) where- (>>-) =- bindValidation--instance Monad (Validation err) where- return =- Success- (>>=) =- bindValidation---- | The transformer version of @Validation@.-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)-{-# INLINE fmapValidationT #-}--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)-{-# INLINE apValidationT #-}--instance Apply m => Apply (ValidationT err m) where- (<.>) =- apValidationT--pureValidationT ::- Applicative f =>- a- -> ValidationT err f a-pureValidationT =- ValidationT . pure . pure-{-# INLINE pureValidationT #-}--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)-{-# INLINE aplValidationT #-}--instance Applicative m => Applicative (ValidationT err m) where- pure =- pureValidationT- (<*>) =- aplValidationT--altValidationT ::- 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))-{-# INLINE altValidationT #-}--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-{-# INLINE foldrValidationT #-}--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-{-# INLINE traverseValidationT #-}--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))-{-# INLINE bindValidationT #-}--instance (Apply m, Monad m) => Bind (ValidationT err m) where- (>>-) =- bindValidationT--returnValidationT ::- Monad f =>- a- -> ValidationT err f a-returnValidationT =- ValidationT . return . pure-{-# INLINE returnValidationT #-}--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-{-# INLINE liftValidationT #-}---- | The bifunctor version of ValidationT-data ValidationB m err a =- ValidationB {- runValidationB :: m (Validation err a)- }--fmapValidationB ::- Functor f =>- (a -> b)- -> ValidationB f err a- -> ValidationB f err b-fmapValidationB f (ValidationB k) =- ValidationB (fmap (fmap f) k)-{-# INLINE fmapValidationB #-}--instance Functor m => Functor (ValidationB m err) where- fmap =- fmapValidationB--apValidationB ::- Apply f =>- ValidationB f err (a -> b)- -> ValidationB f err a- -> ValidationB f err b-ValidationB f `apValidationB` ValidationB a =- ValidationB (liftF2 (<.>) f a)-{-# INLINE apValidationB #-}--instance Apply m => Apply (ValidationB m err) where- (<.>) =- apValidationB--pureValidationB ::- Applicative f =>- a- -> ValidationB f err a-pureValidationB =- ValidationB . pure . pure-{-# INLINE pureValidationB #-}--aplValidationB ::- Applicative f =>- ValidationB f err (a -> b)- -> ValidationB f err a- -> ValidationB f err b-ValidationB f `aplValidationB` ValidationB a =- ValidationB (liftA2 (<*>) f a)-{-# INLINE aplValidationB #-}--instance Applicative m => Applicative (ValidationB m err) where- pure =- pureValidationB- (<*>) =- aplValidationB--altValidationB ::- Monad m =>- ValidationB m err a- -> ValidationB m err a- -> ValidationB m err a-ValidationB x `altValidationB` ValidationB y =- ValidationB (x >>= \q -> case q of- Failure _ -> y- Success a -> return (Success a))-{-# INLINE altValidationB #-}--instance (Functor m, Monad m) => Alt (ValidationB m err) where- (<!>) =- altValidationB--foldrValidationB ::- Foldable f =>- (a -> b -> b)- -> b- -> ValidationB f err a- -> b-foldrValidationB f z (ValidationB x) =- foldr (flip (foldr f)) z x-{-# INLINE foldrValidationB #-}--instance Foldable m => Foldable (ValidationB m err) where- foldr =- foldrValidationB--traverseValidationB ::- (Traversable g, Applicative f) =>- (a -> f b)- -> ValidationB g err a- -> f (ValidationB g err b)-traverseValidationB f (ValidationB x) =- ValidationB <$> traverse (traverse f) x-{-# INLINE traverseValidationB #-}--instance Traversable m => Traversable (ValidationB m err) where- traverse =- traverseValidationB--bimapValidationB ::- Functor f =>- (err -> frr)- -> (a -> b)- -> ValidationB f err a- -> ValidationB f frr b-bimapValidationB f g (ValidationB x) =- ValidationB (fmap (bimap f g) x)-{-# INLINE bimapValidationB #-}--instance Functor m => Bifunctor (ValidationB m) where- bimap =- bimapValidationB--bifoldrValidationB ::- Foldable f =>- (err -> b -> b)- -> (a -> b -> b)- -> b- -> ValidationB f err a- -> b-bifoldrValidationB f g z (ValidationB x) =- foldr (flip (bifoldr f g)) z x-{-# INLINE bifoldrValidationB #-}--instance Foldable m => Bifoldable (ValidationB m) where- bifoldr =- bifoldrValidationB--bitraverseValidationB ::- (Traversable g, Applicative f) =>- (err -> f frr)- -> (a -> f b)- -> ValidationB g err a- -> f (ValidationB g frr b)-bitraverseValidationB f g (ValidationB x) =- ValidationB <$> traverse (bitraverse f g) x-{-# INLINE bitraverseValidationB #-}--instance Traversable m => Bitraversable (ValidationB m) where- bitraverse =- bitraverseValidationB--bindValidationB ::- Monad f =>- ValidationB f err a- -> (a -> ValidationB f err b)- -> ValidationB f err b-ValidationB v `bindValidationB` f =- ValidationB (v >>= \w -> case w of- Failure e -> return (Failure e)- Success a -> runValidationB (f a))-{-# INLINE bindValidationB #-}-instance (Apply m, Monad m) => Bind (ValidationB m err) where- (>>-) =- bindValidationB--returnValidationB ::- Monad f =>- a- -> ValidationB f err a-returnValidationB =- ValidationB . return . pure-{-# INLINE returnValidationB #-}--instance Monad m => Monad (ValidationB m err) where- return =- returnValidationB- (>>=) =- bindValidationB--_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)-{-# INLINE _ValidationV' #-}--_ValidationTx ::- Iso (ValidationT e m a) (ValidationT e' m' a') (ValidationB m e a) (ValidationB m' e' a')-_ValidationTx =- iso- (\(ValidationT x) -> ValidationB x)- (\(ValidationB 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)-{-# INLINE _AccValidationV #-}--_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)-{-# INLINE _EitherV #-}--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)-{-# INLINE _AccValidationValidationIso #-}--_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)-{-# INLINE _AccValidationEitherIso #-}--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)-{-# INLINE _EitherValidationIso #-}--_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)-{-# INLINE _EitherAccValidationIso #-}--instance Validate Either where- _Validation =- _EitherValidationIso- _AccValidation =- _EitherAccValidationIso- _Either =- id--instance (m ~ Identity) => Validate (ValidationB m) where- _Validation =- iso- (\(ValidationB x) -> runIdentity x)- (ValidationB . Identity)--_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))-{-# INLINE _Failure #-}--_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)-{-# INLINE _Success #-}--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)-{-# INLINE swappedAccValidation #-}--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)-{-# INLINE swappedValidation #-}--swappedValidationB ::- Functor k =>- Iso (ValidationB k e a) (ValidationB k f b) (ValidationB k a e) (ValidationB k b f)-swappedValidationB =- iso- (\(ValidationB x) -> ValidationB (fmap (swapped # ) x))- (\(ValidationB x) -> ValidationB (fmap (swapped # ) x))-{-# INLINE swappedValidationB #-}--instance Swapped AccValidation where- swapped =- swappedAccValidation--instance Swapped Validation where- swapped =- swappedValidation--instance Functor f => Swapped (ValidationB f) where- swapped =- swappedValidationB+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -Wall #-}++-- \$setup+-- >>> import Prelude hiding (either, id, (.))+-- >>> import Data.List.NonEmpty(NonEmpty(..))+-- >>> import Data.Semigroup(Semigroup((<>)))+-- >>> import Control.Lens((^?), (#), review, view, from, _Wrapped')+-- >>> import Data.Functor.Alt(Alt((<!>)))+-- >>> import Data.Functor.Apply(Apply((<.>)))+-- >>> import Control.DeepSeq(rnf)+-- >>> import Control.Category(id, (.))+-- >>> import Data.Semigroupoid(Semigroupoid(o))+-- >>> import Data.Profunctor(Profunctor(dimap), Strong(first'), Choice(left'))+-- >>> import Control.Arrow(Arrow(arr, first), ArrowApply(app), ArrowChoice(left))+-- >>> import Control.Selective(Selective(select))+-- >>> import Data.Bifunctor(Bifunctor(bimap))+-- >>> import Data.Bifoldable(Bifoldable(bifoldr))+-- >>> import Data.Bitraversable(Bitraversable(bitraverse))+-- >>> import Data.Bifunctor.Swap(Swap(swap))+-- >>> import Data.Tagged(Tagged(..))+-- >>> :set -XNoMonomorphismRestriction -w++-- | A data type similar to @Data.Either@ that accumulates failures.+module Data.Validation+ ( -- * Data type+ Validation (..),++ -- * Catamorphism+ foldValidation,++ -- * Optics++ -- ** Classy lenses (as generated by @makeClassy@)+ GetValidation (..),+ HasValidation (..),++ -- ** Classy prisms (as generated by @makeClassyPrisms@)+ ReviewValidation (..),+ AsValidation (..),+ GetFailure (..),+ HasFailure (..),+ ReviewFailure (..),+ AsFailure (..),+ GetSuccess (..),+ HasSuccess (..),+ ReviewSuccess (..),+ AsSuccess (..),++ -- ** Prisms+ __Failure,+ __Success,++ -- ** Isomorphisms+ Data.Validation.either,+ codiagonal,++ -- * Validator+ Validator (..),+ Validator',++ -- ** Classy lenses+ GetValidator (..),+ HasValidator (..),++ -- ** Classy prisms+ ReviewValidator (..),+ AsValidator (..),++ -- ** Isomorphisms+ unitValidator,+ taggedValidator,+ swapValidator,++ -- ** Profunctor newtypes+ Iso'' (..),+ Prism'' (..),++ -- ** Example validators+ nonEmptyListIsoValidator',+ nonEmptyListIsoValidator,+ nonEmptyListPrismValidator',+ nonEmptyListPrismValidator,+ )+where++import Control.Arrow (Arrow (arr, first), ArrowApply (app), ArrowChoice (left, right))+import Control.Category (Category (..), (>>>))+import Control.DeepSeq (NFData (rnf))+import Control.Lens (Getter, Lens', Prism, Prism', Review, Rewrapped, Wrapped (_Wrapped', type Unwrapped), prism, prism')+import Control.Lens.Iso (Iso, iso+#if !MIN_VERSION_lens(4,20,0)+ , Swapped(..))+#else+ )+#endif+import Control.Selective (Selective (..))+import Data.Bifoldable (Bifoldable (bifoldr))+import Data.Bifunctor (Bifunctor (bimap))+import Data.Bifunctor.Swap (Swap (..))+import Data.Bitraversable (Bitraversable (bitraverse))+import Data.Bool (bool)+import Data.Data (Data)+import qualified Data.Either as Either+import Data.Functor.Alt (Alt ((<!>)))+import Data.Functor.Apply (Apply ((<.>)))+import Data.List.NonEmpty (NonEmpty (..), toList)+import Data.Profunctor (Choice (left', right'), Profunctor (dimap, lmap, rmap), Strong (first', second'))+import Data.Semigroupoid (Semigroupoid (o))+import Data.Tagged (Tagged (..))+import Data.Typeable (Typeable)+import Data.Void (Void, absurd)+import GHC.Generics (Generic)+import Prelude hiding (either, id, (.))++-- | A @Validation@ is either a value of the type @err@ or @a@, similar to 'Either'. However,+-- the 'Applicative' instance for @Validation@ /accumulates/ errors using a 'Semigroup' on @err@.+-- In contrast, the @Applicative@ for @Either@ returns only the first error.+--+-- A consequence of this is that @Validation@ has no 'Data.Functor.Bind.Bind' or 'Control.Monad.Monad' instance. This is because+-- such an instance would violate the law that a Monad's 'Control.Monad.ap' must equal the+-- @Applicative@'s 'Control.Applicative.<*>'+--+-- An example of typical usage can be found <https://github.com/qfpl/validation/blob/master/examples/src/Email.hs here>.+data Validation err a+ = Failure err+ | Success a+ deriving (Data, Eq, Generic, Ord, Show, Typeable)++-- |+-- >>> fmap (+1) (Success 2 :: Validation String Int)+-- Success 3+--+-- >>> fmap (+1) (Failure "err" :: Validation String Int)+-- Failure "err"+instance Functor (Validation err) where+ fmap _ (Failure e) =+ Failure e+ fmap f (Success a) =+ Success (f a)+ {-# INLINE fmap #-}++-- | Accumulates errors on the left using 'Semigroup'.+--+-- >>> import Data.Functor.Apply(Apply((<.>)))+-- >>> Success (+1) <.> Success 2 :: Validation [String] Int+-- Success 3+--+-- >>> Failure ["e1"] <.> Success 2 :: Validation [String] Int+-- Failure ["e1"]+--+-- >>> Success (+1) <.> Failure ["e2"] :: Validation [String] Int+-- Failure ["e2"]+--+-- >>> Failure ["e1"] <.> Failure ["e2"] :: Validation [String] Int+-- Failure ["e1","e2"]+instance (Semigroup err) => Apply (Validation err) where+ Failure e1 <.> b = Failure $ case b of+ Failure e2 -> e1 <> e2+ Success _ -> e1+ Success _ <.> Failure e2 =+ Failure e2+ Success f <.> Success a =+ Success (f a)+ {-# INLINE (<.>) #-}++-- | Delegates to the 'Apply' instance, accumulating errors with '<>'.+--+-- >>> pure (+1) <*> pure 2 :: Validation [String] Int+-- Success 3+--+-- >>> Failure ["e1"] <*> Failure ["e2"] :: Validation [String] Int+-- Failure ["e1","e2"]+instance (Semigroup err) => Applicative (Validation err) where+ pure =+ Success+ {-# INLINE pure #-}+ (<*>) =+ (<.>)+ {-# INLINE (<*>) #-}++-- | Tries the left, then the right, accumulating errors on two failures.+--+-- >>> import Data.Functor.Alt(Alt((<!>)))+-- >>> Success 1 <!> Success 2 :: Validation [String] Int+-- Success 1+--+-- >>> Failure ["e1"] <!> Success 2 :: Validation [String] Int+-- Success 2+--+-- >>> Success 1 <!> Failure ["e2"] :: Validation [String] Int+-- Success 1+--+-- >>> Failure ["e1"] <!> Failure ["e2"] :: Validation [String] Int+-- Failure ["e1","e2"]+instance (Semigroup err) => Alt (Validation err) where+ Failure e1 <!> Failure e2 =+ Failure (e1 <> e2)+ Failure _ <!> Success a =+ Success a+ Success a <!> _ =+ Success a+ {-# INLINE (<!>) #-}++-- | Skips the second effect on 'Failure'.+--+-- >>> import Control.Selective(Selective(select))+-- >>> select (Success (Right 1)) (Success (+1)) :: Validation [String] Int+-- Success 1+--+-- >>> select (Success (Left 1)) (Success (+1)) :: Validation [String] Int+-- Success 2+--+-- >>> select (Failure ["e1"]) (Success (+1)) :: Validation [String] Int+-- Failure ["e1"]+--+-- >>> select (Failure ["e1"]) (Failure ["e2"]) :: Validation [String] Int+-- Failure ["e1"]+instance (Semigroup err) => Selective (Validation err) where+ select (Failure e) _ = Failure e+ select (Success x) f = Either.either (\a -> ($ a) <$> f) Success x+ {-# INLINE select #-}++-- |+-- >>> foldr (:) [] (Success 1 :: Validation String Int)+-- [1]+--+-- >>> foldr (:) [] (Failure "err" :: Validation String Int)+-- []+instance Foldable (Validation err) where+ foldr f x (Success a) =+ f a x+ foldr _ x (Failure _) =+ x+ {-# INLINE foldr #-}++-- |+-- >>> traverse (\x -> [x, x+1]) (Success 1 :: Validation String Int)+-- [Success 1,Success 2]+--+-- >>> traverse (\x -> [x, x+1]) (Failure "err" :: Validation String Int)+-- [Failure "err"]+instance Traversable (Validation err) where+ traverse f (Success a) =+ Success <$> f a+ traverse _ (Failure e) =+ pure (Failure e)+ {-# INLINE traverse #-}++-- |+-- >>> import Data.Bifunctor(Bifunctor(bimap))+-- >>> bimap show (+1) (Failure 1 :: Validation Int Int)+-- Failure "1"+--+-- >>> bimap show (+1) (Success 1 :: Validation Int Int)+-- Success 2+instance Bifunctor Validation where+ bimap f _ (Failure e) =+ Failure (f e)+ bimap _ g (Success a) =+ Success (g a)+ {-# INLINE bimap #-}++-- |+-- >>> import Data.Bifoldable(Bifoldable(bifoldr))+-- >>> bifoldr (\e r -> show e ++ r) (\a r -> show a ++ r) "" (Failure 1 :: Validation Int Int)+-- "1"+--+-- >>> bifoldr (\e r -> show e ++ r) (\a r -> show a ++ r) "" (Success 2 :: Validation Int Int)+-- "2"+instance Bifoldable Validation where+ bifoldr _ g x (Success a) =+ g a x+ bifoldr f _ x (Failure e) =+ f e x+ {-# INLINE bifoldr #-}++-- |+-- >>> import Data.Bitraversable(Bitraversable(bitraverse))+-- >>> bitraverse (\e -> [e, e+1]) (\a -> [a, a*2]) (Failure 1 :: Validation Int Int)+-- [Failure 1,Failure 2]+--+-- >>> bitraverse (\e -> [e, e+1]) (\a -> [a, a*2]) (Success 3 :: Validation Int Int)+-- [Success 3,Success 6]+instance Bitraversable Validation where+ bitraverse _ g (Success a) =+ Success <$> g a+ bitraverse f _ (Failure e) =+ Failure <$> f e+ {-# INLINE bitraverse #-}++-- | First 'Success' wins; two 'Failure's are combined with '<>'.+--+-- >>> Failure ["e1"] <> Failure ["e2"] :: Validation [String] Int+-- Failure ["e1","e2"]+--+-- >>> Failure ["e1"] <> Success 2 :: Validation [String] Int+-- Success 2+--+-- >>> Success 1 <> Failure ["e2"] :: Validation [String] Int+-- Success 1+--+-- >>> Success 1 <> Success 2 :: Validation [String] Int+-- Success 1+instance (Semigroup e) => Semigroup (Validation e a) where+ Failure e1 <> Failure e2 = Failure (e1 <> e2)+ Failure _ <> Success a = Success a+ Success a <> _ = Success a+ {-# INLINE (<>) #-}++-- |+-- >>> mempty :: Validation [String] Int+-- Failure []+instance (Monoid e) => Monoid (Validation e a) where+ mempty =+ Failure mempty+ {-# INLINE mempty #-}++#if !MIN_VERSION_lens(4,20,0)+instance Swapped Validation where+ swapped = iso swap swap+ {-# INLINE swapped #-}+#endif++-- |+-- >>> import Data.Bifunctor.Swap(Swap(swap))+-- >>> swap (Failure "err" :: Validation String Int)+-- Success "err"+--+-- >>> swap (Success 1 :: Validation String Int)+-- Failure 1+instance Swap Validation where+ swap v =+ case v of+ Failure e -> Success e+ Success a -> Failure a+ {-# INLINE swap #-}++-- |+-- >>> import Control.DeepSeq(rnf)+-- >>> rnf (Success 1 :: Validation String Int)+-- ()+--+-- >>> rnf (Failure "err" :: Validation String Int)+-- ()+instance (NFData e, NFData a) => NFData (Validation e a) where+ rnf v =+ case v of+ Failure e -> rnf e+ Success a -> rnf a+ {-# INLINE rnf #-}++-- | Catamorphism for 'Validation'.+--+-- >>> foldValidation show show (Failure 1 :: Validation Int Int)+-- "1"+--+-- >>> foldValidation show show (Success 2 :: Validation Int Int)+-- "2"+foldValidation :: (a -> x) -> (b -> x) -> Validation a b -> x+foldValidation f _ (Failure a) = f a+foldValidation _ s (Success b) = s b+{-# INLINE foldValidation #-}++-- | Polymorphic 'Prism' targeting the 'Failure' constructor.+--+-- >>> import Control.Lens((^?), review)+-- >>> review __Failure "err" :: Validation String Int+-- Failure "err"+--+-- >>> (Failure "err" :: Validation String Int) ^? __Failure+-- Just "err"+--+-- >>> (Success 1 :: Validation String Int) ^? __Failure+-- Nothing+__Failure :: Prism (Validation a b) (Validation a' b) a a'+__Failure =+ prism+ Failure+ ( \case+ Failure a -> Right a+ Success b -> Left (Success b)+ )+{-# INLINE __Failure #-}++-- | Polymorphic 'Prism' targeting the 'Success' constructor.+--+-- >>> import Control.Lens((^?), review)+-- >>> review __Success 1 :: Validation String Int+-- Success 1+--+-- >>> (Success 1 :: Validation String Int) ^? __Success+-- Just 1+--+-- >>> (Failure "err" :: Validation String Int) ^? __Success+-- Nothing+__Success :: Prism (Validation a b) (Validation a b') b b'+__Success =+ prism+ Success+ ( \case+ Failure a -> Left (Failure a)+ Success b -> Right b+ )+{-# INLINE __Success #-}++-- | Isomorphism between 'Validation' and 'Either'.+--+-- >>> import Control.Lens(view)+-- >>> view either (Failure "err" :: Validation String Int)+-- Left "err"+--+-- >>> view either (Success 1 :: Validation String Int)+-- Right 1+either :: Iso (Validation a b) (Validation a' b') (Either a b) (Either a' b')+either =+ iso+ (foldValidation Left Right)+ (Either.either Failure Success)+{-# INLINE either #-}++-- | Isomorphism between @Validation a a@ and @(Bool, a)@, where 'False' corresponds to 'Failure'.+--+-- >>> import Control.Lens(view)+-- >>> view codiagonal (Failure "x" :: Validation String String)+-- (False,"x")+--+-- >>> view codiagonal (Success "x" :: Validation String String)+-- (True,"x")+codiagonal :: Iso (Validation a a) (Validation a' a') (Bool, a) (Bool, a')+codiagonal =+ iso+ (foldValidation (False,) (True,))+ (\(p, a) -> bool (Failure a) (Success a) p)+{-# INLINE codiagonal #-}++-- | Class for types that have a 'Getter' to a 'Validation'.+class GetValidation s err a | s -> err a where+ getValidation :: Getter s (Validation err a)++instance GetValidation (Validation err a) err a where+ getValidation = id+ {-# INLINE getValidation #-}++-- | Class for types that have a 'Lens'' to a 'Validation' (as generated by @makeClassy@).+class (GetValidation s err a) => HasValidation s err a | s -> err a where+ validation :: Lens' s (Validation err a)++instance HasValidation (Validation err a) err a where+ validation = id+ {-# INLINE validation #-}++-- | Class for types that have a 'Review' to a 'Validation'.+class ReviewValidation s err a | s -> err a where+ reviewValidation :: Review s (Validation err a)++instance ReviewValidation (Validation err a) err a where+ reviewValidation = id+ {-# INLINE reviewValidation #-}++-- | Class for types that have a 'Prism'' to a 'Validation' (as generated by @makeClassyPrisms@).+class (ReviewValidation s err a) => AsValidation s err a | s -> err a where+ _Validation :: Prism' s (Validation err a)++instance AsValidation (Validation err a) err a where+ _Validation = id+ {-# INLINE _Validation #-}++-- | Class for types that have a 'Getter' to an @err@.+class GetFailure s err a | s -> err a where+ getFailure :: Getter s err++-- | Class for types that have a 'Lens'' to an @err@.+class HasFailure s err a | s -> err a where+ failure :: Lens' s err++-- | Class for types that have a 'Review' to construct from an @err@.+class ReviewFailure s err a | s -> err a where+ reviewFailure :: Review s err++-- |+-- >>> import Control.Lens((#))+-- >>> reviewFailure # "err" :: Validation String Int+-- Failure "err"+instance ReviewFailure (Validation err a) err a where+ reviewFailure = __Failure+ {-# INLINE reviewFailure #-}++-- |+-- >>> import Control.Lens((#))+-- >>> reviewFailure # "err" :: Either String Int+-- Left "err"+instance ReviewFailure (Either a b) a b where+ reviewFailure =+ prism'+ Left+ ( \case+ Left a -> Just a+ Right _ -> Nothing+ )+ {-# INLINE reviewFailure #-}++-- | Class for types that have a 'Prism'' to an @err@ (as generated by @makeClassyPrisms@).+class (ReviewFailure s err a) => AsFailure s err a | s -> err a where+ _Failure :: Prism' s err++-- |+-- >>> import Control.Lens((^?), (#))+-- >>> _Failure # "err" :: Validation String Int+-- Failure "err"+--+-- >>> (Failure "err" :: Validation String Int) ^? _Failure+-- Just "err"+--+-- >>> (Success 1 :: Validation String Int) ^? _Failure+-- Nothing+instance AsFailure (Validation err a) err a where+ _Failure = __Failure+ {-# INLINE _Failure #-}++-- |+-- >>> import Control.Lens((^?), (#))+-- >>> _Failure # "err" :: Either String Int+-- Left "err"+--+-- >>> (Left "err" :: Either String Int) ^? _Failure+-- Just "err"+--+-- >>> (Right 1 :: Either String Int) ^? _Failure+-- Nothing+instance AsFailure (Either a b) a b where+ _Failure =+ prism'+ Left+ ( \case+ Left a -> Just a+ Right _ -> Nothing+ )+ {-# INLINE _Failure #-}++-- | Class for types that have a 'Getter' to an @a@.+class GetSuccess s err a | s -> err a where+ getSuccess :: Getter s a++-- | Class for types that have a 'Lens'' to an @a@.+class HasSuccess s err a | s -> err a where+ success :: Lens' s a++-- | Class for types that have a 'Review' to construct from an @a@.+class ReviewSuccess s err a | s -> err a where+ reviewSuccess :: Review s a++-- |+-- >>> import Control.Lens((#))+-- >>> reviewSuccess # 1 :: Either String Int+-- Right 1+instance ReviewSuccess (Either a b) a b where+ reviewSuccess =+ prism'+ Right+ ( \case+ Right a -> Just a+ Left _ -> Nothing+ )+ {-# INLINE reviewSuccess #-}++-- |+-- >>> import Control.Lens((#))+-- >>> reviewSuccess # 1 :: Validation String Int+-- Success 1+instance ReviewSuccess (Validation err a) err a where+ reviewSuccess = __Success+ {-# INLINE reviewSuccess #-}++-- | Class for types that have a 'Prism'' to an @a@ (as generated by @makeClassyPrisms@).+class (ReviewSuccess s err a) => AsSuccess s err a | s -> err a where+ _Success :: Prism' s a++-- |+-- >>> import Control.Lens((^?), (#))+-- >>> _Success # 1 :: Either String Int+-- Right 1+--+-- >>> (Right 1 :: Either String Int) ^? _Success+-- Just 1+--+-- >>> (Left "err" :: Either String Int) ^? _Success+-- Nothing+instance AsSuccess (Either a b) a b where+ _Success =+ prism'+ Right+ ( \case+ Right a -> Just a+ Left _ -> Nothing+ )+ {-# INLINE _Success #-}++-- |+-- >>> import Control.Lens((^?), (#))+-- >>> _Success # 1 :: Validation String Int+-- Success 1+--+-- >>> (Success 1 :: Validation String Int) ^? _Success+-- Just 1+--+-- >>> (Failure "err" :: Validation String Int) ^? _Success+-- Nothing+instance AsSuccess (Validation err a) err a where+ _Success = __Success+ {-# INLINE _Success #-}++-- | A @Validator@ is a profunctor transformer that wraps the output of @p@ in a 'Validation'.+-- @Validator e (->) x a@ is isomorphic to @x -> Validation e a@.+--+-- The 'Semigroupoid' and 'Category' instances compose by short-circuiting on 'Failure'+-- (like monadic bind, not accumulating). Use the 'Applicative' instance to accumulate+-- errors in parallel.+newtype Validator e p x a = Validator (p x (Validation e a))++-- | @Validator@ specialised to @(->)@.+type Validator' e x a = Validator e (->) x a++-- |+-- >>> import Control.Lens(view, _Wrapped')+-- >>> view _Wrapped' (fmap (+1) (Validator (Success . (*2)) :: Validator' String Int Int)) 3+-- Success 7+--+-- >>> view _Wrapped' (fmap (+1) (Validator (\_ -> Failure "err") :: Validator' String Int Int)) 3+-- Failure "err"+instance (Profunctor p) => Functor (Validator e p x) where+ fmap f (Validator p) = Validator (rmap (fmap f) p)+ {-# INLINE fmap #-}++-- | Applies the accumulating 'Validation' '<.>' to both outputs, using 'Arrow' to fan out.+--+-- >>> import Control.Lens(view, _Wrapped')+-- >>> import Data.Functor.Apply(Apply((<.>)))+-- >>> let f = Validator (Success . (+1)) :: Validator' [String] Int Int+-- >>> let g = Validator (Success . (*2)) :: Validator' [String] Int Int+-- >>> view _Wrapped' (fmap (*) f <.> g) 3+-- Success 24+--+-- >>> let f = Validator (\_ -> Failure ["e1"]) :: Validator' [String] Int Int+-- >>> let g = Validator (\_ -> Failure ["e2"]) :: Validator' [String] Int Int+-- >>> view _Wrapped' (fmap (*) f <.> g) 3+-- Failure ["e1","e2"]+instance (Profunctor p, Arrow p, Semigroup e) => Apply (Validator e p x) where+ Validator f <.> Validator g = Validator (arr (uncurry (<.>)) . (f &&& g))+ where+ (&&&) a b = arr (\x -> (x, x)) >>> first a >>> arr (\(a', x) -> (a', x)) >>> swapFirst b+ swapFirst h = arr (\(c, x) -> (x, c)) >>> first h >>> arr (\(b', c) -> (c, b'))+ {-# INLINE (<.>) #-}++-- | 'pure' lifts a value into a successful 'Validator'. '<*>' accumulates errors.+--+-- >>> import Control.Lens(view, _Wrapped')+-- >>> view _Wrapped' (pure 1 :: Validator' String Int Int) 99+-- Success 1+--+-- >>> let f = Validator (Success . (+1)) :: Validator' [String] Int Int+-- >>> let g = Validator (Success . (*2)) :: Validator' [String] Int Int+-- >>> view _Wrapped' ((*) <$> f <*> g) 3+-- Success 24+--+-- >>> let f = Validator (\_ -> Failure ["e1"]) :: Validator' [String] Int Int+-- >>> let g = Validator (\_ -> Failure ["e2"]) :: Validator' [String] Int Int+-- >>> view _Wrapped' ((*) <$> f <*> g) 3+-- Failure ["e1","e2"]+instance (Profunctor p, Arrow p, Semigroup e) => Applicative (Validator e p x) where+ pure a = Validator (arr (\_ -> Success a))+ {-# INLINE pure #-}+ (<*>) = (<.>)+ {-# INLINE (<*>) #-}++-- | Tries the left, then the right, accumulating errors on two failures.+--+-- >>> import Control.Lens(view, _Wrapped')+-- >>> import Data.Functor.Alt(Alt((<!>)))+-- >>> let f = Validator (\_ -> Failure ["e1"]) :: Validator' [String] Int Int+-- >>> let g = Validator (Success . (*2)) :: Validator' [String] Int Int+-- >>> view _Wrapped' (f <!> g) 3+-- Success 6+--+-- >>> let f = Validator (\_ -> Failure ["e1"]) :: Validator' [String] Int Int+-- >>> let g = Validator (\_ -> Failure ["e2"]) :: Validator' [String] Int Int+-- >>> view _Wrapped' (f <!> g) 3+-- Failure ["e1","e2"]+--+-- >>> let f = Validator (Success . (+1)) :: Validator' [String] Int Int+-- >>> let g = Validator (Success . (*2)) :: Validator' [String] Int Int+-- >>> view _Wrapped' (f <!> g) 3+-- Success 4+instance (Profunctor p, Arrow p, Semigroup e) => Alt (Validator e p x) where+ Validator f <!> Validator g = Validator (arr (uncurry (<!>)) . (f &&& g))+ where+ (&&&) a b = arr (\x -> (x, x)) >>> first a >>> arr (\(a', x) -> (a', x)) >>> swapFirst b+ swapFirst h = arr (\(c, x) -> (x, c)) >>> first h >>> arr (\(b', c) -> (c, b'))+ {-# INLINE (<!>) #-}++-- | Skips the second effect on 'Failure'.+--+-- >>> import Control.Lens(view, _Wrapped')+-- >>> import Control.Selective(Selective(select))+-- >>> let v = Validator (\x -> Success (if even x then Right x else Left x)) :: Validator' [String] Int (Either Int Int)+-- >>> let f = Validator (\_ -> Success (+10)) :: Validator' [String] Int (Int -> Int)+-- >>> view _Wrapped' (select v f) 4+-- Success 4+--+-- >>> view _Wrapped' (select v f) 3+-- Success 13+instance (Profunctor p, Arrow p, Semigroup e) => Selective (Validator e p x) where+ select (Validator c) (Validator f) = Validator (arr go . (c &&& f))+ where+ go (vc, vf) = case vc of+ Failure e -> Failure e+ Success x -> Either.either (\a -> fmap ($ a) vf) Success x+ (&&&) a b = arr (\x -> (x, x)) >>> first a >>> arr (\(a', x) -> (a', x)) >>> swapFirst b+ swapFirst h = arr (\(c', x) -> (x, c')) >>> first h >>> arr (\(b', c') -> (c', b'))+ {-# INLINE select #-}++-- |+-- >>> import Control.Lens(view, _Wrapped')+-- >>> import Data.Profunctor(Profunctor(dimap))+-- >>> view _Wrapped' (dimap (+1) (*2) (Validator (Success . (+10)) :: Validator' String Int Int)) 3+-- Success 28+instance (Profunctor p) => Profunctor (Validator e p) where+ dimap f g (Validator p) = Validator (dimap f (fmap g) p)+ {-# INLINE dimap #-}+ lmap f (Validator p) = Validator (lmap f p)+ {-# INLINE lmap #-}+ rmap f (Validator p) = Validator (rmap (fmap f) p)+ {-# INLINE rmap #-}++-- |+-- >>> import Control.Lens(view, _Wrapped')+-- >>> import Data.Profunctor(Strong(first'))+-- >>> view _Wrapped' (first' (Validator (Success . (+1)) :: Validator' String Int Int)) (3, "x")+-- Success (4,"x")+--+-- >>> view _Wrapped' (first' (Validator (\_ -> Failure "err") :: Validator' String Int Int)) (3, "x")+-- Failure "err"+instance (Strong p) => Strong (Validator e p) where+ first' (Validator p) = Validator (rmap (\(v, c) -> fmap (,c) v) (first' p))+ {-# INLINE first' #-}+ second' (Validator p) = Validator (rmap (\(c, v) -> fmap (c,) v) (second' p))+ {-# INLINE second' #-}++-- |+-- >>> import Control.Lens(view, _Wrapped')+-- >>> import Data.Profunctor(Choice(left'))+-- >>> view _Wrapped' (left' (Validator (Success . (+1)) :: Validator' String Int Int)) (Left 3)+-- Success (Left 4)+--+-- >>> view _Wrapped' (left' (Validator (Success . (+1)) :: Validator' String Int Int)) (Right "x")+-- Success (Right "x")+--+-- >>> view _Wrapped' (left' (Validator (\_ -> Failure "err") :: Validator' String Int Int)) (Left 3)+-- Failure "err"+instance (Choice p) => Choice (Validator e p) where+ left' (Validator p) = Validator (rmap (Either.either (fmap Left) (Success . Right)) (left' p))+ {-# INLINE left' #-}+ right' (Validator p) = Validator (rmap (Either.either (Success . Left) (fmap Right)) (right' p))+ {-# INLINE right' #-}++-- | Composes by short-circuiting on 'Failure' (does not accumulate errors).+--+-- >>> import Control.Lens(view, _Wrapped')+-- >>> import Data.Semigroupoid(Semigroupoid(o))+-- >>> let f = Validator (Success . (+1)) :: Validator' String Int Int+-- >>> let g = Validator (Success . (*2)) :: Validator' String Int Int+-- >>> view _Wrapped' (g `o` f) 3+-- Success 8+--+-- >>> let f = Validator (\_ -> Failure "e1") :: Validator' String Int Int+-- >>> let g = Validator (Success . (*2)) :: Validator' String Int Int+-- >>> view _Wrapped' (g `o` f) 3+-- Failure "e1"+instance (Choice p, Semigroupoid p) => Semigroupoid (Validator e p) where+ Validator g `o` Validator f =+ Validator (rmap (Either.either Failure id) (right' g `o` rmap (foldValidation Left Right) f))+ {-# INLINE o #-}++-- |+-- >>> import Prelude hiding (id)+-- >>> import Control.Lens(view, _Wrapped')+-- >>> import Control.Category(id)+-- >>> view _Wrapped' (id :: Validator' String Int Int) 3+-- Success 3+instance (Choice p, Category p) => Category (Validator e p) where+ id = Validator (rmap Success id)+ {-# INLINE id #-}+ Validator g . Validator f =+ Validator (rmap (Either.either Failure id) (right' g . rmap (foldValidation Left Right) f))+ {-# INLINE (.) #-}++-- |+-- >>> import Control.Lens(view, _Wrapped')+-- >>> import Control.Arrow(Arrow(arr, first))+-- >>> view _Wrapped' (arr (+1) :: Validator' String Int Int) 3+-- Success 4+--+-- >>> view _Wrapped' (first (Validator (Success . (+1)) :: Validator' String Int Int)) (3, "x")+-- Success (4,"x")+instance (ArrowChoice p, Choice p) => Arrow (Validator e p) where+ arr f = Validator (arr (Success . f))+ {-# INLINE arr #-}+ first (Validator f) = Validator (arr (\(v, c) -> fmap (,c) v) . first f)+ {-# INLINE first #-}++-- |+-- >>> import Control.Lens(view, _Wrapped')+-- >>> import Control.Arrow(ArrowApply(app))+-- >>> view _Wrapped' (app :: Validator' String (Validator' String Int Int, Int) Int) (Validator (Success . (+1)), 3)+-- Success 4+instance (ArrowApply p, ArrowChoice p, Choice p) => ArrowApply (Validator e p) where+ app = Validator (arr (\(Validator f, x) -> (f, x)) >>> app)+ {-# INLINE app #-}++-- |+-- >>> import Control.Lens(view, _Wrapped')+-- >>> import Control.Arrow(ArrowChoice(left))+-- >>> view _Wrapped' (left (Validator (Success . (+1)) :: Validator' String Int Int)) (Left 3 :: Either Int String)+-- Success (Left 4)+--+-- >>> view _Wrapped' (left (Validator (Success . (+1)) :: Validator' String Int Int)) (Right "x" :: Either Int String)+-- Success (Right "x")+--+-- >>> view _Wrapped' (left (Validator (\_ -> Failure "err") :: Validator' String Int Int)) (Left 3 :: Either Int String)+-- Failure "err"+instance (ArrowChoice p, Choice p) => ArrowChoice (Validator e p) where+ left (Validator f) = Validator (arr (Either.either (fmap Left) (Success . Right)) . left f)+ {-# INLINE left #-}+ right (Validator f) = Validator (arr (Either.either (Success . Left) (fmap Right)) . right f)+ {-# INLINE right #-}++-- |+-- >>> import Control.Lens(view, from, _Wrapped')+-- >>> view _Wrapped' (Validator Success :: Validator' String Int Int) 1+-- Success 1+--+-- >>> view _Wrapped' (view (from _Wrapped') (Success . (+1)) :: Validator' String Int Int) 3+-- Success 4+instance Wrapped (Validator e p x a) where+ type Unwrapped (Validator e p x a) = p x (Validation e a)+ _Wrapped' = iso (\(Validator p) -> p) Validator+ {-# INLINE _Wrapped' #-}++instance Rewrapped (Validator e p x a) (Validator e' p' x' a')++-- | Class for types that have a 'Getter' to a 'Validator'.+class GetValidator s e p x a | s -> e p x a where+ getValidator :: Getter s (Validator e p x a)++instance GetValidator (Validator e p x a) e p x a where+ getValidator = id+ {-# INLINE getValidator #-}++-- | Class for types that have a 'Lens'' to a 'Validator' (as generated by @makeClassy@).+class (GetValidator s e p x a) => HasValidator s e p x a | s -> e p x a where+ validator :: Lens' s (Validator e p x a)++instance HasValidator (Validator e p x a) e p x a where+ validator = id+ {-# INLINE validator #-}++-- | Class for types that have a 'Review' to a 'Validator'.+class ReviewValidator s e p x a | s -> e p x a where+ reviewValidator :: Review s (Validator e p x a)++instance ReviewValidator (Validator e p x a) e p x a where+ reviewValidator = id+ {-# INLINE reviewValidator #-}++-- | Class for types that have a 'Prism'' to a 'Validator' (as generated by @makeClassyPrisms@).+class (ReviewValidator s e p x a) => AsValidator s e p x a | s -> e p x a where+ _Validator :: Prism' s (Validator e p x a)++instance AsValidator (Validator e p x a) e p x a where+ _Validator = id+ {-# INLINE _Validator #-}++-- | Isomorphism between @Validator' e () a@ and @Validation e a@, unwrapping by applying to @()@.+--+-- >>> import Control.Lens(view, from, _Wrapped')+-- >>> view unitValidator (Validator (\() -> Success 1) :: Validator' String () Int)+-- Success 1+--+-- >>> view _Wrapped' (view (from unitValidator) (Failure "err" :: Validation String Int)) ()+-- Failure "err"+unitValidator :: Iso (Validator' e () a) (Validator' e' () a') (Validation e a) (Validation e' a')+unitValidator =+ iso+ (\(Validator k) -> k ())+ (Validator . pure)+{-# INLINE unitValidator #-}++-- | Isomorphism between @Validator e Tagged x a@ and @Validation e a@, unwrapping via 'Tagged'.+--+-- >>> import Control.Lens(view)+-- >>> import Data.Tagged(Tagged(..))+-- >>> view taggedValidator (Validator (Tagged (Success 1)) :: Validator String Tagged Int Int)+-- Success 1+--+-- >>> view taggedValidator (Validator (Tagged (Failure "err")) :: Validator String Tagged Int Int)+-- Failure "err"+taggedValidator :: Iso (Validator e Tagged x a) (Validator e' Tagged x a') (Validation e a) (Validation e' a')+taggedValidator =+ iso+ (\(Validator k) -> unTagged k)+ (Validator . Tagged)+{-# INLINE taggedValidator #-}++-- | Isomorphism that swaps the error and success types of a 'Validator' by 'swap'-ping the inner 'Validation'.+--+-- >>> import Control.Lens(view, _Wrapped')+-- >>> let v = Validator (Success . (+1)) :: Validator' String Int Int+-- >>> view _Wrapped' (view swapValidator v) 3+-- Failure 4+--+-- >>> let w = Validator (\_ -> Failure "err") :: Validator' String Int Int+-- >>> view _Wrapped' (view swapValidator w) 3+-- Success "err"+swapValidator :: (Profunctor p, Profunctor p') => Iso (Validator e p x a) (Validator e' p' x' a') (Validator a p x e) (Validator a' p' x' e')+swapValidator =+ iso+ (\(Validator p) -> Validator (rmap swap p))+ (\(Validator p) -> Validator (rmap swap p))+{-# INLINE swapValidator #-}++-- | A newtype wrapping a monomorphic 'Iso' as a two-parameter profunctor.+-- This allows 'Iso'' to be used as the @p@ parameter in 'Validator'.+newtype Iso'' a b = Iso'' (Iso a a b b)++-- | An 'Iso' between a list and a @Validation () (NonEmpty a)@.+-- The empty list maps to @Failure ()@ and a non-empty list maps to @Success@.+--+-- >>> import Control.Lens(view, review)+-- >>> import Data.List.NonEmpty(NonEmpty(..))+-- >>> view nonEmptyListIsoValidator' [1, 2, 3 :: Int]+-- Success (1 :| [2,3])+--+-- >>> view nonEmptyListIsoValidator' ([] :: [Int])+-- Failure ()+--+-- >>> review nonEmptyListIsoValidator' (Success (1 :| [2, 3]))+-- [1,2,3]+--+-- >>> review nonEmptyListIsoValidator' (Failure ())+-- []+nonEmptyListIsoValidator' ::+ Iso+ [a]+ [a']+ (Validation () (NonEmpty a))+ (Validation () (NonEmpty a'))+nonEmptyListIsoValidator' =+ iso+ ( \case+ [] -> Failure ()+ h : t -> Success (h :| t)+ )+ (foldValidation (\() -> []) toList)+{-# INLINE nonEmptyListIsoValidator' #-}++-- | A 'Validator' using 'Iso''' that validates a list is non-empty.+-- The empty list maps to @Failure ()@.+--+-- >>> import Control.Lens(view, review)+-- >>> import Data.List.NonEmpty(NonEmpty(..))+-- >>> let Validator (Iso'' i) = nonEmptyListIsoValidator+-- >>> view i [1, 2, 3 :: Int]+-- Success (1 :| [2,3])+--+-- >>> let Validator (Iso'' i) = nonEmptyListIsoValidator+-- >>> view i ([] :: [Int])+-- Failure ()+--+-- >>> let Validator (Iso'' i) = nonEmptyListIsoValidator+-- >>> review i (Success (1 :| [2, 3]))+-- [1,2,3]+--+-- >>> let Validator (Iso'' i) = nonEmptyListIsoValidator+-- >>> review i (Failure ())+-- []+nonEmptyListIsoValidator :: Validator () Iso'' [a] (NonEmpty a)+nonEmptyListIsoValidator =+ Validator+ ( Iso''+ nonEmptyListIsoValidator'+ )++-- | A newtype wrapping a monomorphic 'Prism' as a two-parameter profunctor.+-- This allows 'Prism''' to be used as the @p@ parameter in 'Validator'.+newtype Prism'' a b = Prism'' (Prism a a b b)++-- | A 'Prism' from a list to a @Validation Void (NonEmpty a)@.+-- The empty list does not match (yields 'Nothing'); a non-empty list matches as @Success@.+--+-- >>> import Control.Lens((^?), review)+-- >>> import Data.List.NonEmpty(NonEmpty(..))+-- >>> [1, 2, 3 :: Int] ^? nonEmptyListPrismValidator'+-- Just (Success (1 :| [2,3]))+--+-- >>> ([] :: [Int]) ^? nonEmptyListPrismValidator'+-- Nothing+--+-- >>> review nonEmptyListPrismValidator' (Success (1 :| [2, 3]))+-- [1,2,3]+nonEmptyListPrismValidator' :: Prism [a] [a] (Validation err (NonEmpty a)) (Validation Void (NonEmpty a))+nonEmptyListPrismValidator' =+ prism'+ (foldValidation absurd toList)+ ( \case+ [] -> Nothing+ h : t -> Just (Success (h :| t))+ )+{-# INLINE nonEmptyListPrismValidator' #-}++-- | A 'Validator' using 'Prism''' that validates a list is non-empty.+-- Uses 'Void' as the error type since the 'Prism' encodes partiality via 'Nothing'.+--+-- >>> import Control.Lens((^?), review)+-- >>> import Data.List.NonEmpty(NonEmpty(..))+-- >>> let Validator (Prism'' p) = nonEmptyListPrismValidator+-- >>> [1, 2, 3 :: Int] ^? p+-- Just (Success (1 :| [2,3]))+--+-- >>> let Validator (Prism'' p) = nonEmptyListPrismValidator+-- >>> ([] :: [Int]) ^? p+-- Nothing+--+-- >>> let Validator (Prism'' p) = nonEmptyListPrismValidator+-- >>> review p (Success (1 :| [2, 3]))+-- [1,2,3]+nonEmptyListPrismValidator :: Validator Void Prism'' [a] (NonEmpty a)+nonEmptyListPrismValidator =+ Validator+ (Prism'' nonEmptyListPrismValidator')
+ test/doctest_tests.hs view
@@ -0,0 +1,17 @@+import System.Exit (ExitCode (..), exitFailure)+import System.Process (rawSystem)++main :: IO ()+main = do+ exit <-+ rawSystem+ "cabal"+ [ "exec",+ "--",+ "doctest",+ "-isrc",+ "src/Data/Validation.hs"+ ]+ case exit of+ ExitSuccess -> pure ()+ ExitFailure _ -> exitFailure
− test/doctests.hs
@@ -1,32 +0,0 @@-module Main where--import Build_doctests (deps)-import Control.Applicative-import Control.Monad-import Data.List-import System.Directory-import System.FilePath-import Test.DocTest--main ::- IO ()-main =- getSources >>= \sources -> doctest $- "-isrc"- : "-idist/build/autogen"- : "-optP-include"- : "-optPdist/build/autogen/cabal_macros.h"- : "-hide-all-packages"- : map ("-package="++) deps ++ sources--getSources :: IO [FilePath]-getSources = filter (isSuffixOf ".hs") <$> go "src"- where- go dir = do- (dirs, files) <- getFilesAndDirectories dir- (files ++) . concat <$> mapM go dirs--getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])-getFilesAndDirectories dir = do- c <- map (dir </>) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir- (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c
+ test/hedgehog_tests.hs view
@@ -0,0 +1,453 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++import Control.Applicative (liftA3)+import Control.Category (id, (.))+import Control.Lens (Wrapped (_Wrapped'), from, review, view, (#), (^.), (^?))+import Control.Monad (join, unless)+import Data.Bifunctor (bimap)+import Data.Bifunctor.Swap (swap)+import Data.Functor.Alt (Alt ((<!>)))+import Data.Functor.Apply (Apply ((<.>)))+import Data.Semigroupoid (Semigroupoid (o))+import Data.Validation+import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import System.Exit (exitFailure)+import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)+import Prelude hiding (either, id, (.))+import qualified Prelude++main :: IO ()+main = do+ hSetBuffering stdout LineBuffering+ hSetBuffering stderr LineBuffering++ result <-+ checkParallel $+ Group+ "Validation"+ [ ("prop_semigroup_assoc", prop_semigroup_assoc),+ ("prop_monoid_assoc", prop_monoid_assoc),+ ("prop_monoid_left_id", prop_monoid_left_id),+ ("prop_monoid_right_id", prop_monoid_right_id),+ ("prop_functor_id", prop_functor_id),+ ("prop_functor_compose", prop_functor_compose),+ ("prop_applicative_id", prop_applicative_id),+ ("prop_applicative_homomorphism", prop_applicative_homomorphism),+ ("prop_apply_compose", prop_apply_compose),+ ("prop_alt_assoc", prop_alt_assoc),+ ("prop_alt_left_catch", prop_alt_left_catch),+ ("prop_bifunctor_id", prop_bifunctor_id),+ ("prop_bifunctor_compose", prop_bifunctor_compose),+ ("prop_foldValidation_failure", prop_foldValidation_failure),+ ("prop_foldValidation_success", prop_foldValidation_success),+ ("prop_either_roundtrip", prop_either_roundtrip),+ ("prop_either_roundtrip_inv", prop_either_roundtrip_inv),+ ("prop_codiagonal_roundtrip", prop_codiagonal_roundtrip),+ ("prop_failure_prism_review_preview", prop_failure_prism_review_preview),+ ("prop_success_prism_review_preview", prop_success_prism_review_preview),+ ("prop_failure_prism_miss", prop_failure_prism_miss),+ ("prop_success_prism_miss", prop_success_prism_miss),+ ("prop_poly_failure_prism", prop_poly_failure_prism),+ ("prop_poly_success_prism", prop_poly_success_prism),+ ("prop_swap_failure", prop_swap_failure),+ ("prop_swap_success", prop_swap_success),+ ("prop_swap_involution", prop_swap_involution),+ ("prop_validator_functor_id", prop_validator_functor_id),+ ("prop_validator_category_left_id", prop_validator_category_left_id),+ ("prop_validator_category_right_id", prop_validator_category_right_id),+ ("prop_validator_category_assoc", prop_validator_category_assoc),+ ("prop_validator_semigroupoid_assoc", prop_validator_semigroupoid_assoc),+ ("prop_validator_apply_accumulates", prop_validator_apply_accumulates),+ ("prop_validator_alt_accumulates", prop_validator_alt_accumulates),+ ("prop_validator_alt_left_success", prop_validator_alt_left_success),+ ("prop_either_reviewFailure", prop_either_reviewFailure),+ ("prop_either_asFailure_hit", prop_either_asFailure_hit),+ ("prop_either_asFailure_miss", prop_either_asFailure_miss),+ ("prop_either_reviewSuccess", prop_either_reviewSuccess),+ ("prop_either_asSuccess_hit", prop_either_asSuccess_hit),+ ("prop_either_asSuccess_miss", prop_either_asSuccess_miss),+ ("prop_either_failure_roundtrip", prop_either_failure_roundtrip),+ ("prop_either_success_roundtrip", prop_either_success_roundtrip)+ ]++ unless result exitFailure++-- Generators++genValidation :: Gen e -> Gen a -> Gen (Validation e a)+genValidation e a = Gen.choice [fmap Failure e, fmap Success a]++genInt :: Gen Int+genInt = Gen.int (Range.linear (-100) 100)++genString :: Gen String+genString = Gen.string (Range.linear 0 50) Gen.unicode++genStrings :: Gen [String]+genStrings = Gen.list (Range.linear 1 10) genString++testGen :: Gen (Validation [String] Int)+testGen = genValidation genStrings genInt++runV :: Validator' e x a -> x -> Validation e a+runV = view _Wrapped'++validators :: [Validator' [String] Int Int]+validators =+ [ Validator (Success . (+ 1)),+ Validator (Success . (* 2)),+ Validator (Success . negate),+ Validator (\_ -> Failure ["e1"]),+ Validator (\_ -> Failure ["e2"])+ ]++genValidatorIdx :: Gen Int+genValidatorIdx = Gen.int (Range.constant 0 (length validators - 1))++pickValidator :: Int -> Validator' [String] Int Int+pickValidator i = validators !! i++-- Semigroup / Monoid++mkAssoc :: (Validation [String] Int -> Validation [String] Int -> Validation [String] Int) -> Property+mkAssoc f =+ let g = forAll testGen+ assoc x y z = ((x `f` y) `f` z) === (x `f` (y `f` z))+ in property $ join (liftA3 assoc g g g)++prop_semigroup_assoc :: Property+prop_semigroup_assoc = mkAssoc (<>)++prop_monoid_assoc :: Property+prop_monoid_assoc = mkAssoc mappend++prop_monoid_left_id :: Property+prop_monoid_left_id =+ property $ do+ x <- forAll testGen+ (mempty `mappend` x) === x++prop_monoid_right_id :: Property+prop_monoid_right_id =+ property $ do+ x <- forAll testGen+ (x `mappend` mempty) === x++-- Functor++prop_functor_id :: Property+prop_functor_id =+ property $ do+ x <- forAll testGen+ fmap Prelude.id x === x++prop_functor_compose :: Property+prop_functor_compose =+ property $ do+ x <- forAll testGen+ let f = (+ 1)+ g = (* 2)+ fmap (f Prelude.. g) x === fmap f (fmap g x)++-- Applicative / Apply++prop_applicative_id :: Property+prop_applicative_id =+ property $ do+ x <- forAll testGen+ (pure Prelude.id <*> x) === x++prop_applicative_homomorphism :: Property+prop_applicative_homomorphism =+ property $ do+ x <- forAll genInt+ let f = (+ 1)+ (pure f <*> pure x :: Validation [String] Int) === pure (f x)++prop_apply_compose :: Property+prop_apply_compose =+ property $ do+ w <- forAll testGen+ let u = Success (+ 1) :: Validation [String] (Int -> Int)+ v = Success (* 2) :: Validation [String] (Int -> Int)+ (fmap (Prelude..) u <.> v <.> w) === (u <.> (v <.> w))++-- Alt++prop_alt_assoc :: Property+prop_alt_assoc =+ property $ do+ x <- forAll testGen+ y <- forAll testGen+ z <- forAll testGen+ ((x <!> y) <!> z) === (x <!> (y <!> z))++prop_alt_left_catch :: Property+prop_alt_left_catch =+ property $ do+ x <- forAll genInt+ y <- forAll testGen+ (Success x <!> y) === (Success x :: Validation [String] Int)++-- Bifunctor++prop_bifunctor_id :: Property+prop_bifunctor_id =+ property $ do+ x <- forAll testGen+ bimap Prelude.id Prelude.id x === x++prop_bifunctor_compose :: Property+prop_bifunctor_compose =+ property $ do+ x <- forAll testGen+ let f = (++ ["x"])+ g = (+ 1)+ h = (++ ["y"])+ k = (* 2)+ bimap (f Prelude.. h) (g Prelude.. k) x === bimap f g (bimap h k x)++-- foldValidation++prop_foldValidation_failure :: Property+prop_foldValidation_failure =+ property $ do+ e <- forAll genStrings+ foldValidation length (const 0) (Failure e :: Validation [String] Int) === length e++prop_foldValidation_success :: Property+prop_foldValidation_success =+ property $ do+ a <- forAll genInt+ foldValidation (const 0) (+ 1) (Success a :: Validation [String] Int) === (a + 1)++-- Iso: either++prop_either_roundtrip :: Property+prop_either_roundtrip =+ property $ do+ x <- forAll testGen+ (x ^. either ^. from either) === x++prop_either_roundtrip_inv :: Property+prop_either_roundtrip_inv =+ property $ do+ x <- forAll testGen+ let e = x ^. either :: Prelude.Either [String] Int+ (e ^. from either) === x++-- Iso: codiagonal++prop_codiagonal_roundtrip :: Property+prop_codiagonal_roundtrip =+ property $ do+ x <- forAll (genValidation genInt genInt)+ (x ^. codiagonal ^. from codiagonal) === x++-- Prisms++prop_failure_prism_review_preview :: Property+prop_failure_prism_review_preview =+ property $ do+ e <- forAll genStrings+ let v = review _Failure e :: Validation [String] Int+ v ^? _Failure === Just e++prop_success_prism_review_preview :: Property+prop_success_prism_review_preview =+ property $ do+ a <- forAll genInt+ let v = review _Success a :: Validation [String] Int+ v ^? _Success === Just a++prop_failure_prism_miss :: Property+prop_failure_prism_miss =+ property $ do+ a <- forAll genInt+ (Success a :: Validation [String] Int) ^? _Failure === Nothing++prop_success_prism_miss :: Property+prop_success_prism_miss =+ property $ do+ e <- forAll genStrings+ (Failure e :: Validation [String] Int) ^? _Success === Nothing++-- Polymorphic prisms++prop_poly_failure_prism :: Property+prop_poly_failure_prism =+ property $ do+ e <- forAll genStrings+ let v = __Failure # e :: Validation [String] Int+ v ^? __Failure === Just e++prop_poly_success_prism :: Property+prop_poly_success_prism =+ property $ do+ a <- forAll genInt+ let v = __Success # a :: Validation [String] Int+ v ^? __Success === Just a++-- Swap++prop_swap_failure :: Property+prop_swap_failure =+ property $ do+ e <- forAll genString+ let v = Failure e :: Validation String Int+ swap v === (Success e :: Validation Int String)++prop_swap_success :: Property+prop_swap_success =+ property $ do+ a <- forAll genInt+ let v = Success a :: Validation String Int+ swap v === (Failure a :: Validation Int String)++prop_swap_involution :: Property+prop_swap_involution =+ property $ do+ x <- forAll testGen+ (swap (swap x)) === x++-- Validator: Functor++prop_validator_functor_id :: Property+prop_validator_functor_id =+ property $ do+ x <- forAll genInt+ i <- forAll genValidatorIdx+ let v = pickValidator i+ runV (fmap Prelude.id v) x === runV v x++-- Validator: Category++prop_validator_category_left_id :: Property+prop_validator_category_left_id =+ property $ do+ x <- forAll genInt+ i <- forAll genValidatorIdx+ let v = pickValidator i+ runV (id . v) x === runV v x++prop_validator_category_right_id :: Property+prop_validator_category_right_id =+ property $ do+ x <- forAll genInt+ i <- forAll genValidatorIdx+ let v = pickValidator i+ runV (v . id) x === runV v x++prop_validator_category_assoc :: Property+prop_validator_category_assoc =+ property $ do+ x <- forAll genInt+ fi <- forAll genValidatorIdx+ gi <- forAll genValidatorIdx+ hi <- forAll genValidatorIdx+ let f = pickValidator fi+ g = pickValidator gi+ h = pickValidator hi+ runV ((f . g) . h) x === runV (f . (g . h)) x++-- Validator: Semigroupoid++prop_validator_semigroupoid_assoc :: Property+prop_validator_semigroupoid_assoc =+ property $ do+ x <- forAll genInt+ fi <- forAll genValidatorIdx+ gi <- forAll genValidatorIdx+ hi <- forAll genValidatorIdx+ let f = pickValidator fi+ g = pickValidator gi+ h = pickValidator hi+ runV ((f `o` g) `o` h) x === runV (f `o` (g `o` h)) x++-- Validator: Apply / Alt accumulate errors++prop_validator_apply_accumulates :: Property+prop_validator_apply_accumulates =+ property $ do+ x <- forAll genInt+ let f = Validator (\_ -> Failure ["e1"]) :: Validator' [String] Int Int+ g = Validator (\_ -> Failure ["e2"]) :: Validator' [String] Int Int+ runV (fmap const f <.> g) x === Failure ["e1", "e2"]++prop_validator_alt_accumulates :: Property+prop_validator_alt_accumulates =+ property $ do+ x <- forAll genInt+ let f = Validator (\_ -> Failure ["e1"]) :: Validator' [String] Int Int+ g = Validator (\_ -> Failure ["e2"]) :: Validator' [String] Int Int+ runV (f <!> g) x === Failure ["e1", "e2"]++prop_validator_alt_left_success :: Property+prop_validator_alt_left_success =+ property $ do+ x <- forAll genInt+ let f = Validator (Success . (+ 1)) :: Validator' [String] Int Int+ g = Validator (\_ -> Failure ["e2"]) :: Validator' [String] Int Int+ runV (f <!> g) x === Success (x + 1)++-- Either instances: ReviewFailure, AsFailure, ReviewSuccess, AsSuccess++genEither :: Gen a -> Gen b -> Gen (Prelude.Either a b)+genEither ga gb = Gen.choice [fmap Left ga, fmap Right gb]++prop_either_reviewFailure :: Property+prop_either_reviewFailure =+ property $ do+ e <- forAll genStrings+ (reviewFailure # e :: Prelude.Either [String] Int) === Left e++prop_either_asFailure_hit :: Property+prop_either_asFailure_hit =+ property $ do+ e <- forAll genStrings+ (Left e :: Prelude.Either [String] Int) ^? _Failure === Just e++prop_either_asFailure_miss :: Property+prop_either_asFailure_miss =+ property $ do+ a <- forAll genInt+ (Right a :: Prelude.Either [String] Int) ^? _Failure === Nothing++prop_either_reviewSuccess :: Property+prop_either_reviewSuccess =+ property $ do+ a <- forAll genInt+ (reviewSuccess # a :: Prelude.Either [String] Int) === Right a++prop_either_asSuccess_hit :: Property+prop_either_asSuccess_hit =+ property $ do+ a <- forAll genInt+ (Right a :: Prelude.Either [String] Int) ^? _Success === Just a++prop_either_asSuccess_miss :: Property+prop_either_asSuccess_miss =+ property $ do+ e <- forAll genStrings+ (Left e :: Prelude.Either [String] Int) ^? _Success === Nothing++prop_either_failure_roundtrip :: Property+prop_either_failure_roundtrip =+ property $ do+ x <- forAll (genEither genStrings genInt)+ let reviewed = x ^? _Failure+ case x of+ Left e -> reviewed === Just e+ Right _ -> reviewed === Nothing++prop_either_success_roundtrip :: Property+prop_either_success_roundtrip =+ property $ do+ x <- forAll (genEither genStrings genInt)+ let reviewed = x ^? _Success+ case x of+ Right a -> reviewed === Just a+ Left _ -> reviewed === Nothing
validation.cabal view
@@ -1,124 +1,136 @@ name: validation-version: 0.5.5+version: 1.2.2 license: BSD3-license-file: LICENSE+license-file: LICENCE author: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> <dibblego>, Nick Partridge <nkpart>-maintainer: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> <dibblego>, Nick Partridge <nkpart>, Queensland Functional Programming Lab <oᴉ˙ldɟb@llǝʞsɐɥ>+maintainer: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> <dibblego>, Nick Partridge <nkpart> copyright: Copyright (C) 2010-2013 Tony Morris, Nick Partridge-copyright: Copyright (C) 2014,2015 NICTA Limited-copyright: Copyright (c) 2016,2017, Commonwealth Scientific and Industrial Research Organisation (CSIRO) ABN 41 687 119 230.+ Copyright (C) 2014,2015 NICTA Limited+ Copyright (c) 2016-2019 Commonwealth Scientific and Industrial Research Organisation (CSIRO) ABN 41 687 119 230+ Copyright (c) 2019-2026 Tony Morris synopsis: A data-type like Either but with an accumulating Applicative category: Data description:- <<http://i.imgur.com/uZnp9ke.png>>- .- Several data-types like Either but with differing properties and type-class- instances.+ <<https://logo.systemf.com.au/systemf-450x450.png>> .- Library support is provided for those different representations, include- `lens`-related functions for converting between each and abstracting over their- similarities.+ A data type like @Either@ but with an accumulating @Applicative@ instance. .- * `AccValidation`+ == @Validation@ .- The `AccValidation` data type is isomorphic to `Either`, but has an instance- of `Applicative` that accumulates on the error side. That is to say, if two- (or more) errors are encountered, they are appended using a `Semigroup`+ The @Validation@ data type is isomorphic to @Either@, but has an instance+ of @Applicative@ that accumulates on the error side. That is to say, if two+ (or more) errors are encountered, they are appended using a @Semigroup@ operation. .- As a consequence of this `Applicative` instance, there is no corresponding- `Bind` or `Monad` instance. `AccValidation` is an example of, "An applicative+ As a consequence of this @Applicative@ instance, there is no corresponding+ @Bind@ or @Monad@ instance. @Validation@ is an example of, "An applicative functor that is not a monad." .- * `Validation`+ The library provides: .- The `Validation` data type is isomorphic to `Either` and has a `Monad`- instance that does the same as `Either`. The only difference to `Either` is- the constructor names and surrounding library support.+ * Classy optics (@GetValidation@, @HasValidation@, @ReviewValidation@,+ @AsValidation@, and corresponding classes for @Failure@ and @Success@)+ following the conventions of @makeClassy@ and @makeClassyPrisms@ from @lens@.+ * Polymorphic prisms (@__Failure@, @__Success@) for type-changing operations.+ * Isomorphisms to @Either@ and @(Bool, a)@. .- * `ValidationT`+ == @Validator@ .- The `ValidationT` data type is the monad transformer for `Validation`. An- instance of `MonadTrans` is provided for `(ValidationT err)`. Due to the- arrangement of the `ValidationT` type constructor, which permits a `MonadTrans- instance, there is no possible `Bifunctor` instance. Consequently, the- `ValidationB` data type provides a `Bifunctor` instance (but not a- `MonadTrans` instance). Library support is provided to exploit the isomorphism- to `ValidationB`.+ The @Validator@ newtype is a profunctor transformer: .- Note that since `AccValidation` is not a monad, there is also no corresponding- monad transformer for this data type.+ @newtype Validator e p x a = Validator (p x (Validation e a))@ .- * `ValidationB`+ @Validator e (->) x a@ is isomorphic to @x -> Validation e a@. The profunctor+ parameter @p@ generalises this to other optic-like contexts such as @Tagged@,+ @Iso@, and @Prism@. .- The `ValidationB` data type is similar to the monad transformer for- `Validation` (`ValidationT`), however, due to the arrangement of the- `ValidationB` type constructor, which permits a `Bifunctor` instance, there is- no possible `MonadTrans` instance. Consequently, the `ValidationT` data type- provides a `MonadTrans` instance (but not a `Bifunctor` instance). Library- support is provided to exploit the isomorphism to `ValidationT`.+ Instances include @Functor@, @Apply@, @Applicative@, @Alt@, @Selective@,+ @Profunctor@, @Strong@, @Choice@, @Semigroupoid@, @Category@, @Arrow@,+ @ArrowApply@, @ArrowChoice@, and @Wrapped@. .- * `Validation'`+ The @Applicative@ instance accumulates errors in parallel (using @Semigroup@),+ while @Category@ composition short-circuits on @Failure@ (like monadic bind). .- The `Validation' err a` type-alias is equivalent to- `ValidationT err Identity a` and so is isomorphic to `Either` and others.- Libraries are supplied accordingly.+ The library also provides profunctor newtype wrappers (@Iso''@, @Prism''@) that+ allow @Validator@ to be parameterised over monomorphic isos and prisms. -homepage: https://github.com/qfpl/validation-bug-reports: https://github.com/qfpl/validation/issues+homepage: https://github.com/system-f/validation+bug-reports: https://github.com/system-f/validation/issues cabal-version: >= 1.10-build-type: Custom+build-type: Simple extra-source-files: changelog+tested-with: GHC == 9.10.3, GHC == 9.8.4, GHC == 9.6.7, GHC==9.0.1, GHC==8.10.4, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4 source-repository head type: git- location: git@github.com:qfpl/validation.git--flag small_base- description: Choose the new, split-up base package.+ location: git@github.com:system-f/validation.git library default-language: Haskell2010 build-depends:- base >= 3 && < 5- , mtl >= 2.0 && < 2.3- , semigroups >= 0.8- , semigroupoids >= 4.0- , bifunctors >= 3.0- , lens >= 4.0 && < 5- , transformers >= 0.3 && < 0.6+ base >= 4.11 && < 5+ , assoc >= 1 && < 2+ , deepseq >= 1.4.3 && < 2+ , selective >= 0.6 && < 1+ , semigroups >= 0.18.2 && < 1+ , semigroupoids >= 5.2.2 && < 7+ , bifunctors >= 5.5 && < 6+ , lens >= 4.0.5 && < 6+ , profunctors >= 5 && < 6+ , tagged >= 0.8 && < 1 ghc-options: -Wall - default-extensions:- NoImplicitPrelude- hs-source-dirs: src exposed-modules: Data.Validation -test-suite doctests+test-suite hedgehog type: exitcode-stdio-1.0 main-is:- doctests.hs+ hedgehog_tests.hs default-language: Haskell2010 build-depends:- base < 5 && >= 3- , doctest >= 0.9.7- , filepath >= 1.3- , directory >= 1.1- , QuickCheck >= 2.0- , template-haskell >= 2.8+ base >= 4.11 && < 5+ , assoc >= 1 && < 2+ , bifunctors >= 5.5 && < 6+ , hedgehog >= 0.5 && < 2+ , lens >= 4.0.5 && < 6+ , semigroupoids >= 5.2.2 && < 7+ , semigroups >= 0.18.2 && < 1+ , validation++ ghc-options:+ -Wall+ -threaded++ hs-source-dirs:+ test++test-suite doctest+ type:+ exitcode-stdio-1.0++ main-is:+ doctest_tests.hs++ default-language:+ Haskell2010++ build-depends:+ base >= 4.11 && < 5+ , process >= 1.6 && < 2+ , validation ghc-options: -Wall