validation 1 → 1.2.2
raw patch · 8 files changed
Files
- LICENCE +4/−3
- Setup.hs +0/−2
- changelog +58/−1
- src/Data/Validation.hs +1046/−371
- test/doctest_tests.hs +17/−0
- test/hedgehog_tests.hs +412/−21
- test/hunit_tests.hs +0/−131
- validation.cabal +65/−37
LICENCE view
@@ -1,6 +1,7 @@-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.+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.
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
changelog view
@@ -1,3 +1,61 @@+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`@@ -94,4 +152,3 @@ 0.3.4 Loosen the type of the Isos for polymorphic update.-
src/Data/Validation.hs view
@@ -1,373 +1,1048 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE TypeFamilies #-}--#if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE DeriveGeneric #-}-#endif---- | A data type similar to @Data.Either@ that accumulates failures.-module Data.Validation-(- -- * Data type- Validation(..)- -- * Constructing validations-, validate-, validationNel-, fromEither-, liftError- -- * Functions on validations-, validation-, toEither-, orElse-, valueOr-, ensure-, codiagonal-, validationed-, bindValidation- -- * Prisms- -- | These prisms are useful for writing code which is polymorphic in its- -- choice of Either or Validation. This choice can then be made later by a- -- user, depending on their needs.- --- -- An example of this style of usage can be found- -- <https://github.com/qfpl/validation/blob/master/examples/src/PolymorphicEmail.hs here>-, _Failure-, _Success- -- * Isomorphisms-, Validate(..)-, revalidate-) where--import Control.Applicative(Applicative((<*>), pure), (<$>))-import Control.DeepSeq (NFData (rnf))-import Control.Lens (over, under)-import Control.Lens.Getter((^.))-import Control.Lens.Iso(Swapped(..), Iso, iso, from)-import Control.Lens.Prism(Prism, prism)-import Control.Lens.Review(( # ))-import Data.Bifoldable(Bifoldable(bifoldr))-import Data.Bifunctor(Bifunctor(bimap))-import Data.Bitraversable(Bitraversable(bitraverse))-import Data.Bool (Bool)-import Data.Data(Data)-import Data.Either(Either(Left, Right), either)-import Data.Eq(Eq)-import Data.Foldable(Foldable(foldr))-import Data.Function((.), ($), id)-import Data.Functor(Functor(fmap))-import Data.Functor.Alt(Alt((<!>)))-import Data.Functor.Apply(Apply((<.>)))-import Data.List.NonEmpty (NonEmpty)-import Data.Monoid(Monoid(mappend, mempty))-import Data.Ord(Ord)-import Data.Semigroup(Semigroup((<>)))-import Data.Traversable(Traversable(traverse))-import Data.Typeable(Typeable)-#if __GLASGOW_HASKELL__ >= 702-import GHC.Generics (Generic)-#endif-import Prelude(Show)----- | An @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 (- Eq, Ord, Show, Data, Typeable-#if __GLASGOW_HASKELL__ >= 702- , Generic-#endif- )--instance Functor (Validation err) where- fmap _ (Failure e) =- Failure e- fmap f (Success a) =- Success (f a)- {-# INLINE fmap #-}--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 (<.>) #-}--instance Semigroup err => Applicative (Validation err) where- pure =- Success- (<*>) =- (<.>)--instance Alt (Validation err) where- Failure _ <!> x =- x- Success a <!> _ =- Success a- {-# INLINE (<!>) #-}--instance Foldable (Validation err) where- foldr f x (Success a) =- f a x- foldr _ x (Failure _) =- x- {-# INLINE foldr #-}--instance Traversable (Validation err) where- traverse f (Success a) =- Success <$> f a- traverse _ (Failure e) =- pure (Failure e)- {-# INLINE traverse #-}--instance Bifunctor Validation where- bimap f _ (Failure e) =- Failure (f e)- bimap _ g (Success a) =- Success (g a)- {-# INLINE bimap #-}---instance Bifoldable Validation where- bifoldr _ g x (Success a) =- g a x- bifoldr f _ x (Failure e) =- f e x- {-# INLINE bifoldr #-}--instance Bitraversable Validation where- bitraverse _ g (Success a) =- Success <$> g a- bitraverse f _ (Failure e) =- Failure <$> f e- {-# INLINE bitraverse #-}--appValidation ::- (err -> err -> err)- -> Validation err a- -> Validation err a- -> Validation err a-appValidation m (Failure e1) (Failure e2) =- Failure (e1 `m` e2)-appValidation _ (Failure _) (Success a2) =- Success a2-appValidation _ (Success a1) (Failure _) =- Success a1-appValidation _ (Success a1) (Success _) =- Success a1-{-# INLINE appValidation #-}--instance Semigroup e => Semigroup (Validation e a) where- (<>) =- appValidation (<>)- {-# INLINE (<>) #-}--instance Monoid e => Monoid (Validation e a) where- mappend =- appValidation mappend- {-# INLINE mappend #-}- mempty =- Failure mempty- {-# INLINE mempty #-}--instance Swapped Validation where- swapped =- 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 swapped #-}--instance (NFData e, NFData a) => NFData (Validation e a) where- rnf v =- case v of- Failure e -> rnf e- Success a -> rnf a---- | 'validate's the @a@ with the given predicate, returning @e@ if the predicate does not hold.------ This can be thought of as having the less general type:------ @--- validate :: e -> (a -> Bool) -> a -> Validation e a--- @-validate :: Validate v => e -> (a -> Bool) -> a -> v e a-validate e p a =- if p a then _Success # a else _Failure # e---- | 'validationNel' is 'liftError' specialised to 'NonEmpty' lists, since--- they are a common semigroup to use.-validationNel :: Either e a -> Validation (NonEmpty e) a-validationNel = liftError pure---- | Converts from 'Either' to 'Validation'.-fromEither :: Either e a -> Validation e a-fromEither = liftError id---- | 'liftError' is useful for converting an 'Either' to an 'Validation'--- when the @Left@ of the 'Either' needs to be lifted into a 'Semigroup'.-liftError :: (b -> e) -> Either b a -> Validation e a-liftError f = either (Failure . f) Success---- | 'validation' is the catamorphism for @Validation@.-validation :: (e -> c) -> (a -> c) -> Validation e a -> c-validation ec ac v = case v of- Failure e -> ec e- Success a -> ac a---- | Converts from 'Validation' to 'Either'.-toEither :: Validation e a -> Either e a-toEither = validation Left Right---- | @v 'orElse' a@ returns @a@ when @v@ is Failure, and the @a@ in @Success a@.------ This can be thought of as having the less general type:------ @--- orElse :: Validation e a -> a -> a--- @-orElse :: Validate v => v e a -> a -> a-orElse v a = case v ^. _Validation of- Failure _ -> a- Success x -> x---- | Return the @a@ or run the given function over the @e@.------ This can be thought of as having the less general type:------ @--- valueOr :: (e -> a) -> Validation e a -> a--- @-valueOr :: Validate v => (e -> a) -> v e a -> a-valueOr ea v = case v ^. _Validation of- Failure e -> ea e- Success a -> a---- | 'codiagonal' gets the value out of either side.-codiagonal :: Validation a a -> a-codiagonal = valueOr id---- | 'ensure' leaves the validation unchanged when the predicate holds, or--- fails with @e@ otherwise.------ This can be thought of as having the less general type:------ @--- ensure :: e -> (a -> Bool) -> Validation e a -> Validation e a--- @-ensure :: Validate v => e -> (a -> Bool) -> v e a -> v e a-ensure e p =- over _Validation $ \v -> case v of- Failure x -> Failure x- Success a -> validate e p a---- | Run a function on anything with a Validate instance (usually Either)--- as if it were a function on Validation------ This can be thought of as having the type------ @(Either e a -> Either e' a') -> Validation e a -> Validation e' a'@-validationed :: Validate v => (v e a -> v e' a') -> Validation e a -> Validation e' a'-validationed f = under _Validation f---- | @bindValidation@ binds through an Validation, which is useful for--- composing Validations sequentially. Note that despite having a bind--- function of the correct type, Validation is not a monad.--- The reason is, this bind does not accumulate errors, so it does not--- agree with the Applicative instance.------ There is nothing wrong with using this function, it just does not make a--- valid @Monad@ instance.-bindValidation :: Validation e a -> (a -> Validation e b) -> Validation e b-bindValidation v f = case v of- Failure e -> Failure e- Success a -> f a---- | The @Validate@ class carries around witnesses that the type @f@ is isomorphic--- to Validation, and hence isomorphic to Either.-class Validate f where- _Validation ::- Iso (f e a) (f g b) (Validation e a) (Validation g b)-- _Either ::- Iso (f e a) (f g b) (Either e a) (Either g b)- _Either =- 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 _Either #-}--instance Validate Validation where- _Validation =- id- {-# INLINE _Validation #-}- _Either =- iso- (\x -> case x of- Failure e -> Left e- Success a -> Right a)- (\x -> case x of- Left e -> Failure e- Right a -> Success a)- {-# INLINE _Either #-}--instance Validate Either where- _Validation =- iso- fromEither- toEither- {-# INLINE _Validation #-}- _Either =- id- {-# INLINE _Either #-}---- | This prism generalises 'Control.Lens.Prism._Left'. It targets the failure case of either 'Either' or 'Validation'.-_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 #-}---- | This prism generalises 'Control.Lens.Prism._Right'. It targets the success case of either 'Either' or 'Validation'.-_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 #-}---- | 'revalidate' converts between any two instances of 'Validate'.-revalidate :: (Validate f, Validate g) => Iso (f e1 s) (f e2 t) (g e1 s) (g e2 t)-revalidate = _Validation . from _Validation-+{-# 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/hedgehog_tests.hs view
@@ -1,49 +1,125 @@ {-# 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.Semigroup ((<>))+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.IO (BufferMode(..), hSetBuffering, stdout, stderr) import System.Exit (exitFailure)--import Data.Validation (Validation (Success, Failure))+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", prop_semigroup)- , ("prop_monoid_assoc", prop_monoid_assoc)- , ("prop_monoid_left_id", prop_monoid_left_id)- , ("prop_monoid_right_id", prop_monoid_right_id)- ]+ 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+ 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 =- let range = Range.linear 1 50- string = Gen.string range Gen.unicode- strings = Gen.list range string- in genValidation strings Gen.enumBounded+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)+ assoc x y z = ((x `f` y) `f` z) === (x `f` (y `f` z))+ in property $ join (liftA3 assoc g g g) -prop_semigroup :: Property-prop_semigroup = mkAssoc (<>)+prop_semigroup_assoc :: Property+prop_semigroup_assoc = mkAssoc (<>) prop_monoid_assoc :: Property prop_monoid_assoc = mkAssoc mappend@@ -60,3 +136,318 @@ 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
− test/hunit_tests.hs
@@ -1,131 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--module Main (main) where--import Test.HUnit--import Prelude hiding (length)-import Control.Lens ((#))-import Control.Monad (when)-import Data.Foldable (length)-import Data.Proxy (Proxy (Proxy))-import Data.Validation (Validation (Success, Failure), Validate, _Failure, _Success, ensure,- orElse, validate, validation, validationNel)-import System.Exit (exitFailure)--seven :: Int-seven = 7--three :: Int-three = 3--testYY :: Test-testYY =- let subject = _Success # (+1) <*> _Success # seven :: Validation String Int- expected = Success 8- in TestCase (assertEqual "Success <*> Success" subject expected)--testNY :: Test-testNY =- let subject = _Failure # ["f1"] <*> _Success # seven :: Validation [String] Int- expected = Failure ["f1"]- in TestCase (assertEqual "Failure <*> Success" subject expected)--testYN :: Test-testYN =- let subject = _Success # (+1) <*> _Failure # ["f2"] :: Validation [String] Int- expected = Failure ["f2"]- in TestCase (assertEqual "Success <*> Failure" subject expected)--testNN :: Test-testNN =- let subject = _Failure # ["f1"] <*> _Failure # ["f2"] :: Validation [String] Int- expected = Failure ["f1","f2"]- in TestCase (assertEqual "Failure <*> Failure" subject expected)--testValidationNel :: Test-testValidationNel =- let subject = validation length (const 0) $ validationNel (Left ())- in TestCase (assertEqual "validationNel makes lists of length 1" subject 1)--testEnsureLeftFalse, testEnsureLeftTrue, testEnsureRightFalse, testEnsureRightTrue,- testOrElseRight, testOrElseLeft- :: forall v. (Validate v, Eq (v Int Int), Show (v Int Int)) => Proxy v -> Test--testEnsureLeftFalse _ =- let subject :: v Int Int- subject = ensure three (const False) (_Failure # seven)- in TestCase (assertEqual "ensure Left False" subject (_Failure # seven))--testEnsureLeftTrue _ =- let subject :: v Int Int- subject = ensure three (const True) (_Failure # seven)- in TestCase (assertEqual "ensure Left True" subject (_Failure # seven))--testEnsureRightFalse _ =- let subject :: v Int Int- subject = ensure three (const False) (_Success # seven)- in TestCase (assertEqual "ensure Right False" subject (_Failure # three))--testEnsureRightTrue _ =- let subject :: v Int Int- subject = ensure three (const True ) (_Success # seven)- in TestCase (assertEqual "ensure Right True" subject (_Success # seven))--testOrElseRight _ =- let v :: v Int Int- v = _Success # seven- subject = v `orElse` three- in TestCase (assertEqual "orElseRight" subject seven)--testOrElseLeft _ =- let v :: v Int Int- v = _Failure # seven- subject = v `orElse` three- in TestCase (assertEqual "orElseLeft" subject three)--testValidateTrue :: Test-testValidateTrue =- let subject = validate three (const True) seven- expected = Success seven- in TestCase (assertEqual "testValidateTrue" subject expected)--testValidateFalse :: Test-testValidateFalse =- let subject = validate three (const False) seven- expected = Failure three- in TestCase (assertEqual "testValidateFalse" subject expected)--tests :: Test-tests =- let eitherP :: Proxy Either- eitherP = Proxy- validationP :: Proxy Validation- validationP = Proxy- generals :: forall v. (Validate v, Eq (v Int Int), Show (v Int Int)) => [Proxy v -> Test]- generals =- [ testEnsureLeftFalse- , testEnsureLeftTrue- , testEnsureRightFalse- , testEnsureRightTrue- , testOrElseLeft- , testOrElseRight- ]- eithers = fmap ($ eitherP) generals- validations = fmap ($ validationP) generals- in TestList $ [- testYY- , testYN- , testNY- , testNN- , testValidationNel- , testValidateFalse- , testValidateTrue- ] ++ eithers ++ validations- where--main :: IO ()-main = do- c <- runTestTT tests- when (errors c > 0 || failures c > 0) exitFailure-
validation.cabal view
@@ -1,59 +1,85 @@ name: validation-version: 1+version: 1.2.2 license: BSD3 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 (C) 2014,2015 NICTA Limited- Copyright (c) 2016,2017, Commonwealth Scientific and Industrial Research Organisation (CSIRO) ABN 41 687 119 230.+ 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>>- .- A data-type like Either but with differing properties and type-class- instances.+ <<https://logo.systemf.com.au/systemf-450x450.png>> .- Library support is provided for this different representation, include- `lens`-related functions for converting between each and abstracting over their- similarities.+ A data type like @Either@ but with an accumulating @Applicative@ instance. .- * `Validation`+ == @Validation@ .- 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`+ 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. `Validation` 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."+ .+ The library provides:+ .+ * 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)@.+ .+ == @Validator@+ .+ The @Validator@ newtype is a profunctor transformer:+ .+ @newtype Validator e p x a = Validator (p x (Validation e a))@+ .+ @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@.+ .+ Instances include @Functor@, @Apply@, @Applicative@, @Alt@, @Selective@,+ @Profunctor@, @Strong@, @Choice@, @Semigroupoid@, @Category@, @Arrow@,+ @ArrowApply@, @ArrowChoice@, and @Wrapped@.+ .+ The @Applicative@ instance accumulates errors in parallel (using @Semigroup@),+ while @Category@ composition short-circuits on @Failure@ (like monadic bind).+ .+ 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: Simple extra-source-files: changelog-tested-with: GHC==8.4.1, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2+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+ location: git@github.com:system-f/validation.git library default-language: Haskell2010 build-depends:- base >= 4.5 && < 5- , deepseq >= 1.2 && < 1.5- , semigroups >= 0.8 && < 1- , semigroupoids >= 5 && < 6- , bifunctors >= 5.1 && < 6- , lens >= 4 && < 5- if impl(ghc>=7.2) && impl(ghc<7.5)- build-depends: ghc-prim == 0.2.0.0+ 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@@ -75,9 +101,13 @@ Haskell2010 build-depends:- base >= 3 && < 5- , hedgehog >= 0.5 && < 0.6- , semigroups >= 0.8 && < 1+ 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:@@ -87,21 +117,19 @@ hs-source-dirs: test -test-suite hunit+test-suite doctest type: exitcode-stdio-1.0 main-is:- hunit_tests.hs+ doctest_tests.hs default-language: Haskell2010 build-depends:- base >= 3 && < 5- , HUnit >= 1.5 && < 1.7- , lens >= 4 && < 5- , semigroups >= 0.8 && < 1+ base >= 4.11 && < 5+ , process >= 1.6 && < 2 , validation ghc-options: