validation 1.2.2 → 1.3.3

raw patch · 8 files changed

Files

• changelog +77/−0
• src/Data/Validation.hs +11/−1048
• src/Data/Validation/Validation.hs +620/−0
• src/Data/Validation/ValidationMonad.hs +609/−0
• src/Data/Validation/Validator.hs +2061/−0
• test/doctest_tests.hs +17/−11
• test/hedgehog_tests.hs +301/−143
• validation.cabal +44/−36

@@ -1,3 +1,80 @@+1.3.3++* Add unmatch, constructing a prism from a review and any validator. It is+  an inverse of match: unmatch p (match p) is p, and match (unmatch r v)+  is v+* Add (<--), an operator for unmatch (infixr 2, binding more loosely than+  (.), (-->), <$> and <!>)+* Depend on either-n+* Add Injection1 and Injection2 instances (from either-n) for Validation,+  where _I1 is the Failure constructor and _I2 is the Success constructor+* Add Injection1 and Injection2 instances for ValidationMonad, the+  Validation inside Identity++1.3.2++* Change the Extend instances for all four validators to keep failures,+  like Validation: for each input, extended fails where the validator+  fails, rather than always succeeding. The constraint on the monadic+  validators is relaxed to Functor+* Generalise the ReviewValidation instance for ValidationMonad to+  ValidationMonadT over any Applicative+* Relax constraints: Choice for ValidatorProfunctor no longer requires+  Semigroup, Sieve for ValidatorMonadProfunctorT requires only Functor,+  and the MonadFail instances no longer require a redundant Monad++1.3.1++* Change the Alt instance for Validator to be like Either: the first+  Success wins, otherwise the second Failure is returned. The Semigroup+  constraint is removed+* Remove the Plus and Alternative instances for Validator+* Add (-->), constructing any validator from a prism and a function on+  its focus, so that validators can be written one case per constructor+  (infixl 6, binding tighter than <!>)+* Add match, constructing any validator from a prism, and its+  specialisations matchValidator, matchValidatorProfunctor,+  matchValidatorMonad and matchValidatorMonadProfunctor+* Add the missing cross-type optics instances between Validator and+  ValidatorMonadProfunctorT, and between ValidatorProfunctor and+  ValidatorMonadT+* Generalise the ReviewValidator and ReviewValidatorProfunctor instances+  for ValidatorMonadT and ValidatorMonadProfunctorT from Identity to any+  Applicative+* Add hedgehog property tests for match and its specialisations+* Raise dependency lower bounds to the oldest versions that build on+  GHC 9.6 (base >= 4.18, lens >= 5.2.1, semigroupoids >= 6.0.0.1, ...),+  and check them in CI with lower-bounds.project+* Remove GHC 9.0.1 from CI, and build with GHC 9.6.7, 9.8.4 and 9.10.3+* Add bin/lint.sh, running hlint and fourmolu, and check it in CI++1.3.0++* Replace ormolu with fourmolu+* Remove CPP, raise lens lower bound to >= 4.20+* Move Data.Validation to Data.Validation.Validation, re-export from+  Data.Validation+* Add ValidationMonadT monad transformer with short-circuiting+  Applicative, Bind, Monad, MonadError, MonadTrans, and related instances+* Add Eq1, Eq2, Ord1, Ord2, Show1, Show2 instances for Validation+* Add Generic1, Plus, Alternative, Bifoldable1, Bitraversable1, Assoc,+  Extend instances for Validation+* Add four validator newtypes with different parameter orders:+  - Validator x err a (Bifunctor, accumulating Applicative)+  - ValidatorProfunctor err x a (Profunctor, accumulating Applicative)+  - ValidatorMonadT x err f a (Monad, MonadTrans, BindTrans)+  - ValidatorMonadProfunctorT err f x a (Profunctor, Monad, Category, Arrow)+* Add cross-type optics instances between all four validator newtypes+* Add classy optics (Get/Has/Review/As) for all new types+* Add Wrapped/Rewrapped instances for all new types+* Add validationMonad isomorphism between Validation and ValidationMonad+* Remove Validator profunctor transformer (replaced by above newtypes)+* Remove ReifiedIso', ReifiedPrism' profunctor wrappers+* Remove examples/ subdirectory+* Drop support for GHC < 9.6+* Add 728 doctests across all modules+* Remove unused profunctors and tagged dependencies from test suite+ 1.2.2  * Implement Either instances for ReviewFailure, AsFailure, ReviewSuccess,

@@ -1,1048 +1,11 @@-{-# 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')+{-# OPTIONS_GHC -Wall #-}++module Data.Validation (+  module Data.Validation.Validation,+  module Data.Validation.ValidationMonad,+  module Data.Validation.Validator,+) where++import Data.Validation.Validation+import Data.Validation.ValidationMonad+import Data.Validation.Validator

@@ -0,0 +1,620 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -Wall #-}++-- | A data type similar to @Data.Either@ that accumulates failures.+module Data.Validation.Validation (+  -- * Data type+  Validation (..),++  -- * Catamorphism+  foldValidation,++  -- * Optics++  -- ** Classy lenses+  GetValidation (..),+  HasValidation (..),++  -- ** Classy prisms+  ReviewValidation (..),+  AsValidation (..),++  -- ** Prisms+  __Failure,+  __Success,++  -- ** Isomorphisms+  Data.Validation.Validation.either,+  codiagonal,+) where++import Control.Applicative (Alternative (empty, (<|>)))+import Control.Category (Category (..))+import Control.DeepSeq (NFData (rnf))+import Control.Lens (Getter, Lens', Prism, Prism', Review, from, prism, unto)+import Control.Lens.Iso (Iso, iso)+import Control.Selective (Selective (..))+import Data.Bifoldable (Bifoldable (bifoldr))+import Data.Bifoldable1 (Bifoldable1 (bifoldMap1))+import Data.Bifunctor (Bifunctor (bimap))+import Data.Bifunctor.Assoc (Assoc (assoc, unassoc))+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.Functor.Classes (Eq1 (liftEq), Eq2 (liftEq2), Ord1 (liftCompare), Ord2 (liftCompare2), Show1 (liftShowsPrec), Show2 (liftShowsPrec2), showsUnaryWith)+import Data.Functor.Extend (Extend (extended))+import Data.Functor.Plus (Plus (zero))+import Data.Lens.Injection (Injection1 (_I1), Injection2 (_I2))+import Data.Semigroup.Traversable.Class (Bitraversable1 (bitraverse1))+import Data.Typeable (Typeable)+import GHC.Generics (Generic, Generic1)+import Prelude hiding (either, id, (.))++{- $setup+>>> import Prelude hiding (either, id, (.))+>>> import Control.Lens((^?), (#), review, view, from, set)+>>> import Data.Functor.Alt(Alt((<!>)))+>>> import Data.Functor.Apply(Apply((<.>)))+>>> import Control.DeepSeq(rnf)+>>> import Control.Category(id, (.))+>>> 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.Lens.Injection(Injection1(_I1), Injection2(_I2))+>>> :set -XNoMonomorphismRestriction -w+-}++{- | 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.<*>'++See the <https://github.com/system-f/validation README> for usage examples.+-}+data Validation err a+  = Failure err+  | Success a+  deriving (Data, Eq, Generic, Generic1, Ord, Show, Typeable)++instance Eq2 Validation where+  liftEq2 f _ (Failure a) (Failure b) = f a b+  liftEq2 _ g (Success a) (Success b) = g a b+  liftEq2 _ _ _ _ = False+  {-# INLINE liftEq2 #-}++instance (Eq err) => Eq1 (Validation err) where+  liftEq = liftEq2 (==)+  {-# INLINE liftEq #-}++instance Ord2 Validation where+  liftCompare2 f _ (Failure a) (Failure b) = f a b+  liftCompare2 _ _ (Failure _) (Success _) = LT+  liftCompare2 _ _ (Success _) (Failure _) = GT+  liftCompare2 _ g (Success a) (Success b) = g a b+  {-# INLINE liftCompare2 #-}++instance (Ord err) => Ord1 (Validation err) where+  liftCompare = liftCompare2 compare+  {-# INLINE liftCompare #-}++instance Show2 Validation where+  liftShowsPrec2 sp1 _ _ _ d (Failure a) = showsUnaryWith sp1 "Failure" d a+  liftShowsPrec2 _ _ sp2 _ d (Success a) = showsUnaryWith sp2 "Success" d a+  {-# INLINE liftShowsPrec2 #-}++instance (Show err) => Show1 (Validation err) where+  liftShowsPrec = liftShowsPrec2 showsPrec showList+  {-# INLINE liftShowsPrec #-}++{- |+>>> 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 (<!>) #-}++instance (Monoid err) => Plus (Validation err) where+  zero = Failure mempty+  {-# INLINE zero #-}++instance (Monoid err) => Alternative (Validation err) where+  empty = zero+  {-# INLINE empty #-}+  (<|>) = (<!>)+  {-# 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 #-}++instance Bifoldable1 Validation where+  bifoldMap1 f _ (Failure e) = f e+  bifoldMap1 _ g (Success a) = g a+  {-# INLINE bifoldMap1 #-}++{- |+>>> 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 #-}++instance Bitraversable1 Validation where+  bitraverse1 f _ (Failure e) = Failure <$> f e+  bitraverse1 _ g (Success a) = Success <$> g a+  {-# INLINE bitraverse1 #-}++{- | 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 #-}++{- |+>>> 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 #-}++instance Assoc Validation where+  assoc (Failure (Failure a)) = Failure a+  assoc (Failure (Success b)) = Success (Failure b)+  assoc (Success c) = Success (Success c)+  {-# INLINE assoc #-}+  unassoc (Failure a) = Failure (Failure a)+  unassoc (Success (Failure b)) = Failure (Success b)+  unassoc (Success (Success c)) = Success c+  {-# INLINE unassoc #-}++{- |+>>> 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 #-}++instance Extend (Validation err) where+  extended _ (Failure e) = Failure e+  extended f w@(Success _) = Success (f w)+  {-# INLINE extended #-}++{- | 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 #-}++{- | The first constructor, 'Failure'. The same as '__Failure'.++>>> import Control.Lens((^?), (#), over)+>>> (Failure "err" :: Validation String Int) ^? _I1+Just "err"++>>> (Success 1 :: Validation String Int) ^? _I1+Nothing++>>> _I1 # "err" :: Validation String Int+Failure "err"++>>> over _I1 length (Failure "err" :: Validation String Int)+Failure 3+-}+instance Injection1 (Validation a b) (Validation a' b) a a' where+  _I1 = __Failure+  {-# INLINE _I1 #-}++{- | The second constructor, 'Success'. The same as '__Success'.++>>> import Control.Lens((^?), (#), over)+>>> (Success 1 :: Validation String Int) ^? _I2+Just 1++>>> (Failure "err" :: Validation String Int) ^? _I2+Nothing++>>> _I2 # 1 :: Validation String Int+Success 1++>>> over _I2 show (Success 1 :: Validation String Int)+Success "1"+-}+instance Injection2 (Validation a b) (Validation a b') b b' where+  _I2 = __Success+  {-# INLINE _I2 #-}++{- | 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 #-}++{- |+>>> import Control.Lens(view)+>>> view getValidation (Left "err" :: Either String Int)+Failure "err"++>>> view getValidation (Right 1 :: Either String Int)+Success 1+-}+instance GetValidation (Either err a) err a where+  getValidation = from Data.Validation.Validation.either+  {-# 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 #-}++{- |+>>> import Control.Lens(view, set)+>>> view validation (Left "err" :: Either String Int)+Failure "err"++>>> set validation (Success 2 :: Validation String Int) (Left "err" :: Either String Int)+Right 2+-}+instance HasValidation (Either err a) err a where+  validation = from Data.Validation.Validation.either+  {-# 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)+  reviewFailure :: Review s err+  reviewFailure = reviewValidation . reviewFailure+  {-# INLINE reviewFailure #-}+  reviewSuccess :: Review s a+  reviewSuccess = reviewValidation . reviewSuccess+  {-# INLINE reviewSuccess #-}++instance ReviewValidation (Validation err a) err a where+  reviewValidation = id+  {-# INLINE reviewValidation #-}+  reviewFailure = unto Failure+  {-# INLINE reviewFailure #-}+  reviewSuccess = unto Success+  {-# INLINE reviewSuccess #-}++{- |+>>> import Control.Lens((#))+>>> reviewValidation # (Failure "err" :: Validation String Int) :: Either String Int+Left "err"++>>> reviewValidation # (Success 1 :: Validation String Int) :: Either String Int+Right 1+-}+instance ReviewValidation (Either err a) err a where+  reviewValidation = from Data.Validation.Validation.either+  {-# 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)+  _Failure :: Prism' s err+  _Failure = _Validation . _Failure+  {-# INLINE _Failure #-}+  _Success :: Prism' s a+  _Success = _Validation . _Success+  {-# INLINE _Success #-}++instance AsValidation (Validation err a) err a where+  _Validation = id+  {-# INLINE _Validation #-}+  _Failure = __Failure+  {-# INLINE _Failure #-}+  _Success = __Success+  {-# INLINE _Success #-}++{- |+>>> import Control.Lens((^?), (#))+>>> _Validation # (Failure "err" :: Validation String Int) :: Either String Int+Left "err"++>>> (Left "err" :: Either String Int) ^? _Validation+Just (Failure "err")++>>> (Right 1 :: Either String Int) ^? _Validation+Just (Success 1)+-}+instance AsValidation (Either err a) err a where+  _Validation = from Data.Validation.Validation.either+  {-# INLINE _Validation #-}

@@ -0,0 +1,609 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wall #-}++{- | A monad transformer wrapping @m (Validation err a)@ with short-circuiting+'Applicative' and 'Monad' instances, unlike 'Validation' which accumulates errors.+-}+module Data.Validation.ValidationMonad (+  ValidationMonadT (..),+  ValidationMonad,+  liftValidationMonadT,++  -- * Isomorphisms+  validationMonad,++  -- * Optics++  -- ** Classy lenses+  GetValidationMonadT (..),+  HasValidationMonadT (..),++  -- ** Classy prisms+  ReviewValidationMonadT (..),+  AsValidationMonadT (..),+) where++import Control.Applicative (Alternative (empty, (<|>)))+import Control.DeepSeq (NFData (rnf))+import Control.Lens (Getter, Lens', Prism', Review, Rewrapped, Wrapped (_Wrapped', type Unwrapped), from, unto)+import Control.Lens.Iso (Iso, Iso', iso)+import Control.Monad (MonadPlus, ap)+import Control.Monad.Cont.Class (MonadCont (callCC))+import Control.Monad.Error.Class (MonadError (catchError, throwError))+import Control.Monad.IO.Class (MonadIO (liftIO))+import Control.Monad.RWS.Class (MonadRWS)+import Control.Monad.Reader.Class (MonadReader (ask, local, reader))+import Control.Monad.State.Class (MonadState (get, put, state))+import Control.Monad.Trans.Class (MonadTrans (lift))+import Control.Monad.Writer.Class (MonadWriter (listen, pass, tell, writer))+import Control.Selective (Selective (select), selectM)+import Data.Functor.Alt (Alt ((<!>)))+import Data.Functor.Apply (Apply ((<.>)))+import Data.Functor.Bind (Bind ((>>-)))+import Data.Functor.Bind.Trans (BindTrans (liftB))+import Data.Functor.Classes (Eq1 (liftEq), Ord1 (liftCompare), Show1 (liftShowList, liftShowsPrec))+import Data.Functor.Extend (Extend (extended))+import Data.Functor.Identity (Identity (..))+import Data.Functor.Plus (Plus (zero))+import Data.Lens.Injection (Injection1 (_I1), Injection2 (_I2))+import Data.Validation.Validation (AsValidation (..), GetValidation (..), HasValidation (..), ReviewValidation (..), Validation (..), foldValidation)+import qualified Data.Validation.Validation as Validation+import GHC.Generics (Generic)++{- $setup+>>> import Data.Functor.Identity(Identity(..))+>>> import Data.Validation.Validation(Validation(..))+>>> import Data.Validation.ValidationMonad+>>> import Control.Lens(view, _Wrapped', review, (#), (^?), from)+>>> import Data.Functor.Alt(Alt((<!>)))+>>> import Data.Functor.Apply(Apply((<.>)))+>>> import Data.Functor.Extend(Extend(extended))+>>> import Data.Functor.Classes(Eq1(liftEq), Ord1(liftCompare))+>>> import Control.Monad.Error.Class(MonadError(throwError, catchError))+>>> import Control.Monad.Trans.Class(MonadTrans(lift))+>>> import Control.DeepSeq(rnf)+>>> import Data.Functor.Plus(Plus(zero))+>>> :set -XNoMonomorphismRestriction -w+-}++{- | A monad transformer wrapping @m (Validation err a)@.++>>> ValidationMonadT (Identity (Success 1)) :: ValidationMonadT String Identity Int+ValidationMonadT (Identity (Success 1))++>>> ValidationMonadT (Identity (Failure "err")) :: ValidationMonadT String Identity Int+ValidationMonadT (Identity (Failure "err"))+-}+newtype ValidationMonadT err m a = ValidationMonadT (m (Validation err a))+  deriving (Generic)++-- | Type alias for @ValidationMonadT err Identity a@.+type ValidationMonad err a = ValidationMonadT err Identity a++{- |+>>> ValidationMonadT (Identity (Success 1)) == (ValidationMonadT (Identity (Success 1)) :: ValidationMonadT String Identity Int)+True++>>> ValidationMonadT (Identity (Success 1)) == (ValidationMonadT (Identity (Failure "err")) :: ValidationMonadT String Identity Int)+False+-}+deriving instance (Eq (m (Validation err a))) => Eq (ValidationMonadT err m a)++{- |+>>> compare (ValidationMonadT (Identity (Failure "a"))) (ValidationMonadT (Identity (Success 1)) :: ValidationMonadT String Identity Int)+LT+-}+deriving instance (Ord (m (Validation err a))) => Ord (ValidationMonadT err m a)++{- |+>>> show (ValidationMonadT (Identity (Success 1)) :: ValidationMonadT String Identity Int)+"ValidationMonadT (Identity (Success 1))"+-}+deriving instance (Show (m (Validation err a))) => Show (ValidationMonadT err m a)++{- |+>>> import Control.Lens(view, _Wrapped')+>>> view _Wrapped' (ValidationMonadT (Identity (Success 1)) :: ValidationMonadT String Identity Int)+Identity (Success 1)+-}+instance Wrapped (ValidationMonadT err m a) where+  type Unwrapped (ValidationMonadT err m a) = m (Validation err a)+  _Wrapped' = iso (\(ValidationMonadT m) -> m) ValidationMonadT+  {-# INLINE _Wrapped' #-}++instance Rewrapped (ValidationMonadT err m a) (ValidationMonadT err' m' b)++{- |+>>> liftEq (==) (ValidationMonadT (Identity (Success 1)) :: ValidationMonadT String Identity Int) (ValidationMonadT (Identity (Success 1)))+True++>>> liftEq (==) (ValidationMonadT (Identity (Success 1)) :: ValidationMonadT String Identity Int) (ValidationMonadT (Identity (Success 2)))+False+-}+instance (Eq1 m, Eq err) => Eq1 (ValidationMonadT err m) where+  liftEq f (ValidationMonadT ma) (ValidationMonadT mb) = liftEq (liftEq f) ma mb+  {-# INLINE liftEq #-}++{- |+>>> liftCompare compare (ValidationMonadT (Identity (Success 1)) :: ValidationMonadT String Identity Int) (ValidationMonadT (Identity (Success 2)))+LT+-}+instance (Ord1 m, Ord err) => Ord1 (ValidationMonadT err m) where+  liftCompare f (ValidationMonadT ma) (ValidationMonadT mb) = liftCompare (liftCompare f) ma mb+  {-# INLINE liftCompare #-}++instance (Show1 m, Show err) => Show1 (ValidationMonadT err m) where+  liftShowsPrec sp sl d (ValidationMonadT m) =+    showParen (d > 10) $+      showString "ValidationMonadT " . liftShowsPrec (liftShowsPrec sp sl) (liftShowList sp sl) 11 m+  {-# INLINE liftShowsPrec #-}++{- | Lift a value from the base functor into 'ValidationMonadT'.++>>> liftValidationMonadT (Identity 1) :: ValidationMonadT String Identity Int+ValidationMonadT (Identity (Success 1))+-}+liftValidationMonadT :: (Functor m) => m a -> ValidationMonadT err m a+liftValidationMonadT = ValidationMonadT . fmap Success+{-# INLINE liftValidationMonadT #-}++{- |+>>> fmap (+1) (ValidationMonadT (Identity (Success 2)) :: ValidationMonadT String Identity Int)+ValidationMonadT (Identity (Success 3))++>>> fmap (+1) (ValidationMonadT (Identity (Failure "err")) :: ValidationMonadT String Identity Int)+ValidationMonadT (Identity (Failure "err"))+-}+instance (Functor m) => Functor (ValidationMonadT err m) where+  fmap f (ValidationMonadT m) = ValidationMonadT (fmap (fmap f) m)+  {-# INLINE fmap #-}++{- | Short-circuiting: stops at the first 'Failure'.++>>> (ValidationMonadT (Identity (Success (+1))) :: ValidationMonadT String Identity (Int -> Int)) <.> ValidationMonadT (Identity (Success 2))+ValidationMonadT (Identity (Success 3))++>>> (ValidationMonadT (Identity (Failure "e1")) :: ValidationMonadT String Identity (Int -> Int)) <.> ValidationMonadT (Identity (Success 2))+ValidationMonadT (Identity (Failure "e1"))+-}+instance (Monad m) => Apply (ValidationMonadT err m) where+  (<.>) = ap+  {-# INLINE (<.>) #-}++{- | Short-circuiting: unlike 'Validation', does /not/ accumulate errors.++>>> pure 1 :: ValidationMonadT String Identity Int+ValidationMonadT (Identity (Success 1))++>>> (ValidationMonadT (Identity (Failure "e1")) :: ValidationMonadT String Identity (Int -> Int)) <*> (ValidationMonadT (Identity (Failure "e2")) :: ValidationMonadT String Identity Int)+ValidationMonadT (Identity (Failure "e1"))+-}+instance (Monad m) => Applicative (ValidationMonadT err m) where+  pure = ValidationMonadT . pure . Success+  {-# INLINE pure #-}+  ValidationMonadT mf <*> ValidationMonadT ma = ValidationMonadT $ do+    vf <- mf+    case vf of+      Failure e -> pure (Failure e)+      Success f -> fmap (fmap f) ma+  {-# INLINE (<*>) #-}++instance (Monad m) => Bind (ValidationMonadT err m) where+  (>>-) = (>>=)+  {-# INLINE (>>-) #-}++{- | Short-circuiting on the first 'Failure'.++>>> ValidationMonadT (Identity (Success 2)) >>= (\x -> ValidationMonadT (Identity (Success (x + 1)))) :: ValidationMonadT String Identity Int+ValidationMonadT (Identity (Success 3))++>>> (ValidationMonadT (Identity (Failure "err")) :: ValidationMonadT String Identity Int) >>= (\x -> ValidationMonadT (Identity (Success (x + 1))))+ValidationMonadT (Identity (Failure "err"))+-}+instance (Monad m) => Monad (ValidationMonadT err m) where+  ValidationMonadT m >>= k = ValidationMonadT $ do+    va <- m+    case va of+      Failure e -> pure (Failure e)+      Success a -> let ValidationMonadT n = k a in n+  {-# INLINE (>>=) #-}++instance (MonadFail m) => MonadFail (ValidationMonadT err m) where+  fail = liftValidationMonadT . fail+  {-# INLINE fail #-}++{- | First 'Success' wins; two 'Failure's accumulate errors.++>>> (ValidationMonadT (Identity (Success 1)) :: ValidationMonadT [String] Identity Int) <!> ValidationMonadT (Identity (Success 2))+ValidationMonadT (Identity (Success 1))++>>> (ValidationMonadT (Identity (Failure ["e1"])) :: ValidationMonadT [String] Identity Int) <!> ValidationMonadT (Identity (Success 2))+ValidationMonadT (Identity (Success 2))++>>> (ValidationMonadT (Identity (Failure ["e1"])) :: ValidationMonadT [String] Identity Int) <!> ValidationMonadT (Identity (Failure ["e2"]))+ValidationMonadT (Identity (Failure ["e1","e2"]))+-}+instance (Monad m, Semigroup err) => Alt (ValidationMonadT err m) where+  ValidationMonadT ma <!> ValidationMonadT mb = ValidationMonadT $ do+    va <- ma+    case va of+      Success a -> pure (Success a)+      Failure e1 -> fmap (foldValidation (Failure . (e1 <>)) Success) mb+  {-# INLINE (<!>) #-}++{- |+>>> zero :: ValidationMonadT [String] Identity Int+ValidationMonadT (Identity (Failure []))+-}+instance (Monad m, Monoid err) => Plus (ValidationMonadT err m) where+  zero = ValidationMonadT (pure (Failure mempty))+  {-# INLINE zero #-}++instance (Monad m, Monoid err) => Alternative (ValidationMonadT err m) where+  empty = zero+  {-# INLINE empty #-}+  (<|>) = (<!>)+  {-# INLINE (<|>) #-}++instance (Monad m, Monoid err) => MonadPlus (ValidationMonadT err m)++instance (Monad m) => Selective (ValidationMonadT err m) where+  select = selectM+  {-# INLINE select #-}++{- |+>>> foldr (:) [] (ValidationMonadT (Identity (Success 1)) :: ValidationMonadT String Identity Int)+[1]++>>> foldr (:) [] (ValidationMonadT (Identity (Failure "err")) :: ValidationMonadT String Identity Int)+[]+-}+instance (Foldable m) => Foldable (ValidationMonadT err m) where+  foldr f z (ValidationMonadT m) = foldr (flip (foldr f)) z m+  {-# INLINE foldr #-}++{- |+>>> traverse (\x -> [x, x+1]) (ValidationMonadT (Identity (Success 1)) :: ValidationMonadT String Identity Int)+[ValidationMonadT (Identity (Success 1)),ValidationMonadT (Identity (Success 2))]++>>> traverse (\x -> [x, x+1]) (ValidationMonadT (Identity (Failure "err")) :: ValidationMonadT String Identity Int)+[ValidationMonadT (Identity (Failure "err"))]+-}+instance (Traversable m) => Traversable (ValidationMonadT err m) where+  traverse f (ValidationMonadT m) = ValidationMonadT <$> traverse (traverse f) m+  {-# INLINE traverse #-}++{- |+>>> extended (\_ -> 42) (ValidationMonadT (Identity (Success 1)) :: ValidationMonadT String Identity Int) :: ValidationMonadT String Identity Int+ValidationMonadT (Identity (Success 42))++>>> extended (\_ -> 42) (ValidationMonadT (Identity (Failure "err")) :: ValidationMonadT String Identity Int) :: ValidationMonadT String Identity Int+ValidationMonadT (Identity (Failure "err"))+-}+instance (Functor m) => Extend (ValidationMonadT err m) where+  extended f w@(ValidationMonadT m) = ValidationMonadT (fmap (foldValidation Failure (const (Success (f w)))) m)+  {-# INLINE extended #-}++{- |+>>> (ValidationMonadT (Identity (Failure ["e1"])) :: ValidationMonadT [String] Identity Int) <> ValidationMonadT (Identity (Failure ["e2"]))+ValidationMonadT (Identity (Failure ["e1","e2"]))++>>> (ValidationMonadT (Identity (Failure ["e1"])) :: ValidationMonadT [String] Identity Int) <> ValidationMonadT (Identity (Success 2))+ValidationMonadT (Identity (Success 2))+-}+instance (Applicative m, Semigroup e) => Semigroup (ValidationMonadT e m a) where+  ValidationMonadT ma <> ValidationMonadT mb = ValidationMonadT (liftA2 (<>) ma mb)+  {-# INLINE (<>) #-}++{- |+>>> mempty :: ValidationMonadT [String] Identity Int+ValidationMonadT (Identity (Failure []))+-}+instance (Applicative m, Monoid e) => Monoid (ValidationMonadT e m a) where+  mempty = ValidationMonadT (pure mempty)+  {-# INLINE mempty #-}++{- |+>>> rnf (ValidationMonadT (Identity (Success 1)) :: ValidationMonadT String Identity Int)+()+-}+instance (NFData (m (Validation err a))) => NFData (ValidationMonadT err m a) where+  rnf (ValidationMonadT m) = rnf m+  {-# INLINE rnf #-}++{- |+>>> lift (Identity 1) :: ValidationMonadT String Identity Int+ValidationMonadT (Identity (Success 1))+-}+instance MonadTrans (ValidationMonadT err) where+  lift = liftValidationMonadT+  {-# INLINE lift #-}++instance BindTrans (ValidationMonadT err) where+  liftB = liftValidationMonadT+  {-# INLINE liftB #-}++{- |+>>> throwError "err" :: ValidationMonadT String Identity Int+ValidationMonadT (Identity (Failure "err"))++>>> catchError (throwError "err" :: ValidationMonadT String Identity Int) (\e -> pure (length e))+ValidationMonadT (Identity (Success 3))+-}+instance (Monad m) => MonadError err (ValidationMonadT err m) where+  throwError = ValidationMonadT . pure . Failure+  {-# INLINE throwError #-}+  catchError (ValidationMonadT m) h = ValidationMonadT $ do+    va <- m+    case va of+      Failure e -> let ValidationMonadT n = h e in n+      Success a -> pure (Success a)+  {-# INLINE catchError #-}++instance (MonadIO m) => MonadIO (ValidationMonadT err m) where+  liftIO = liftValidationMonadT . liftIO+  {-# INLINE liftIO #-}++instance (MonadReader r m) => MonadReader r (ValidationMonadT err m) where+  ask = liftValidationMonadT ask+  {-# INLINE ask #-}+  local f (ValidationMonadT m) = ValidationMonadT (local f m)+  {-# INLINE local #-}+  reader = liftValidationMonadT . reader+  {-# INLINE reader #-}++instance (MonadWriter w m) => MonadWriter w (ValidationMonadT err m) where+  writer = liftValidationMonadT . writer+  {-# INLINE writer #-}+  tell = liftValidationMonadT . tell+  {-# INLINE tell #-}+  listen (ValidationMonadT m) = ValidationMonadT $ do+    (va, w) <- listen m+    pure (fmap (,w) va)+  {-# INLINE listen #-}+  pass (ValidationMonadT m) = ValidationMonadT $ pass $ do+    va <- m+    pure $ case va of+      Failure e -> (Failure e, id)+      Success (a, f) -> (Success a, f)+  {-# INLINE pass #-}++instance (MonadState s m) => MonadState s (ValidationMonadT err m) where+  get = liftValidationMonadT get+  {-# INLINE get #-}+  put = liftValidationMonadT . put+  {-# INLINE put #-}+  state = liftValidationMonadT . state+  {-# INLINE state #-}++instance (MonadCont m) => MonadCont (ValidationMonadT err m) where+  callCC f = ValidationMonadT $ callCC $ \c ->+    let ValidationMonadT m = f (ValidationMonadT . c . Success) in m+  {-# INLINE callCC #-}++instance (MonadRWS r w s m) => MonadRWS r w s (ValidationMonadT err m)++{- | Class for types that have a 'Getter' to a 'ValidationMonadT'.++>>> import Control.Lens(view)+>>> view getValidationMonadT (ValidationMonadT (Identity (Success 1)) :: ValidationMonadT String Identity Int)+ValidationMonadT (Identity (Success 1))+-}+class GetValidationMonadT s err m a | s -> err m a where+  getValidationMonadT :: Getter s (ValidationMonadT err m a)++instance GetValidationMonadT (ValidationMonadT err m a) err m a where+  getValidationMonadT = id+  {-# INLINE getValidationMonadT #-}++{- | Class for types that have a 'Lens'' to a 'ValidationMonadT'.++>>> import Control.Lens(view)+>>> view validationMonadT (ValidationMonadT (Identity (Success 1)) :: ValidationMonadT String Identity Int)+ValidationMonadT (Identity (Success 1))+-}+class (GetValidationMonadT s err m a) => HasValidationMonadT s err m a | s -> err m a where+  validationMonadT :: Lens' s (ValidationMonadT err m a)++instance HasValidationMonadT (ValidationMonadT err m a) err m a where+  validationMonadT = id+  {-# INLINE validationMonadT #-}++{- | Class for types that have a 'Review' to a 'ValidationMonadT'.++>>> import Control.Lens(review)+>>> review reviewValidationMonadT (ValidationMonadT (Identity (Success 1))) :: ValidationMonadT String Identity Int+ValidationMonadT (Identity (Success 1))+-}+class ReviewValidationMonadT s err m a | s -> err m a where+  reviewValidationMonadT :: Review s (ValidationMonadT err m a)++instance ReviewValidationMonadT (ValidationMonadT err m a) err m a where+  reviewValidationMonadT = id+  {-# INLINE reviewValidationMonadT #-}++-- | Class for types that have a 'Prism'' to a 'ValidationMonadT'.+class (ReviewValidationMonadT s err m a) => AsValidationMonadT s err m a | s -> err m a where+  _ValidationMonadT :: Prism' s (ValidationMonadT err m a)++instance AsValidationMonadT (ValidationMonadT err m a) err m a where+  _ValidationMonadT = id+  {-# INLINE _ValidationMonadT #-}++{- | Isomorphism between @Validation err a@ and @ValidationMonadT err Identity a@.++>>> import Control.Lens(view, from)+>>> view validationMonad (Success 1 :: Validation String Int)+ValidationMonadT (Identity (Success 1))++>>> view (from validationMonad) (ValidationMonadT (Identity (Success 1)) :: ValidationMonadT String Identity Int)+Success 1+-}+validationMonad :: Iso (Validation err a) (Validation err' a') (ValidationMonad err a) (ValidationMonad err' a')+validationMonad = iso (ValidationMonadT . pure) (\(ValidationMonadT (Identity v)) -> v)+{-# INLINE validationMonad #-}++{- | The first constructor, 'Failure', of the 'Validation' inside 'Identity'.++>>> import Control.Lens((^?), (#))+>>> (ValidationMonadT (Identity (Failure "err")) :: ValidationMonad String Int) ^? _I1+Just "err"++>>> (ValidationMonadT (Identity (Success 1)) :: ValidationMonad String Int) ^? _I1+Nothing++>>> _I1 # "err" :: ValidationMonad String Int+ValidationMonadT (Identity (Failure "err"))+-}+instance Injection1 (ValidationMonad err a) (ValidationMonad err' a) err err' where+  _I1 = from validationMonad . _I1+  {-# INLINE _I1 #-}++{- | The second constructor, 'Success', of the 'Validation' inside 'Identity'.++>>> import Control.Lens((^?), (#))+>>> (ValidationMonadT (Identity (Success 1)) :: ValidationMonad String Int) ^? _I2+Just 1++>>> (ValidationMonadT (Identity (Failure "err")) :: ValidationMonad String Int) ^? _I2+Nothing++>>> _I2 # 1 :: ValidationMonad String Int+ValidationMonadT (Identity (Success 1))+-}+instance Injection2 (ValidationMonad err a) (ValidationMonad err a') a a' where+  _I2 = from validationMonad . _I2+  {-# INLINE _I2 #-}++-- Isomorphism between @Either err a@ and @ValidationMonad err a@.+eitherValidationMonad :: Iso' (Either err a) (ValidationMonad err a)+eitherValidationMonad = from Validation.either . validationMonad+{-# INLINE eitherValidationMonad #-}++{- |+>>> import Control.Lens(view)+>>> view getValidationMonadT (Success 1 :: Validation String Int)+ValidationMonadT (Identity (Success 1))+-}+instance GetValidationMonadT (Validation err a) err Identity a where+  getValidationMonadT = validationMonad+  {-# INLINE getValidationMonadT #-}++{- |+>>> import Control.Lens(view)+>>> view validationMonadT (Success 1 :: Validation String Int)+ValidationMonadT (Identity (Success 1))+-}+instance HasValidationMonadT (Validation err a) err Identity a where+  validationMonadT = validationMonad+  {-# INLINE validationMonadT #-}++{- |+>>> import Control.Lens(review)+>>> review reviewValidationMonadT (ValidationMonadT (Identity (Success 1))) :: Validation String Int+Success 1+-}+instance ReviewValidationMonadT (Validation err a) err Identity a where+  reviewValidationMonadT = validationMonad+  {-# INLINE reviewValidationMonadT #-}++{- |+>>> import Control.Lens((^?))+>>> (Success 1 :: Validation String Int) ^? _ValidationMonadT+Just (ValidationMonadT (Identity (Success 1)))+-}+instance AsValidationMonadT (Validation err a) err Identity a where+  _ValidationMonadT = validationMonad+  {-# INLINE _ValidationMonadT #-}++{- |+>>> import Control.Lens(view)+>>> view getValidation (ValidationMonadT (Identity (Success 1)) :: ValidationMonadT String Identity Int)+Success 1+-}+instance GetValidation (ValidationMonad err a) err a where+  getValidation = from validationMonad+  {-# INLINE getValidation #-}++{- |+>>> import Control.Lens(view)+>>> view validation (ValidationMonadT (Identity (Success 1)) :: ValidationMonadT String Identity Int)+Success 1+-}+instance HasValidation (ValidationMonad err a) err a where+  validation = from validationMonad+  {-# INLINE validation #-}++{- |+>>> import Control.Lens(review)+>>> review reviewValidation (Success 1 :: Validation String Int) :: ValidationMonadT String [] Int+ValidationMonadT [Success 1]+-}+instance (Applicative m) => ReviewValidation (ValidationMonadT err m a) err a where+  reviewValidation = unto (ValidationMonadT . pure)+  {-# INLINE reviewValidation #-}++{- |+>>> import Control.Lens((^?))+>>> (ValidationMonadT (Identity (Success 1)) :: ValidationMonadT String Identity Int) ^? _Validation+Just (Success 1)+-}+instance AsValidation (ValidationMonad err a) err a where+  _Validation = from validationMonad+  {-# INLINE _Validation #-}++{- |+>>> import Control.Lens(view)+>>> view getValidationMonadT (Left "err" :: Either String Int)+ValidationMonadT (Identity (Failure "err"))++>>> view getValidationMonadT (Right 1 :: Either String Int)+ValidationMonadT (Identity (Success 1))+-}+instance GetValidationMonadT (Either err a) err Identity a where+  getValidationMonadT = eitherValidationMonad+  {-# INLINE getValidationMonadT #-}++{- |+>>> import Control.Lens(view, set)+>>> view validationMonadT (Left "err" :: Either String Int)+ValidationMonadT (Identity (Failure "err"))++>>> set validationMonadT (ValidationMonadT (Identity (Success 2))) (Left "err" :: Either String Int)+Right 2+-}+instance HasValidationMonadT (Either err a) err Identity a where+  validationMonadT = eitherValidationMonad+  {-# INLINE validationMonadT #-}++{- |+>>> import Control.Lens(review)+>>> review reviewValidationMonadT (ValidationMonadT (Identity (Success 1))) :: Either String Int+Right 1++>>> review reviewValidationMonadT (ValidationMonadT (Identity (Failure "err"))) :: Either String Int+Left "err"+-}+instance ReviewValidationMonadT (Either err a) err Identity a where+  reviewValidationMonadT = eitherValidationMonad+  {-# INLINE reviewValidationMonadT #-}++{- |+>>> import Control.Lens((^?))+>>> (Left "err" :: Either String Int) ^? _ValidationMonadT+Just (ValidationMonadT (Identity (Failure "err")))++>>> (Right 1 :: Either String Int) ^? _ValidationMonadT+Just (ValidationMonadT (Identity (Success 1)))+-}+instance AsValidationMonadT (Either err a) err Identity a where+  _ValidationMonadT = eitherValidationMonad+  {-# INLINE _ValidationMonadT #-}

@@ -0,0 +1,2061 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wall #-}++module Data.Validation.Validator (+  -- * Accumulating, Bifunctor parameter order+  Validator (..),++  -- * Accumulating, Profunctor parameter order+  ValidatorProfunctor (..),++  -- * Short-circuiting monad, MonadTrans parameter order+  ValidatorMonadT (..),+  ValidatorMonad,++  -- * Short-circuiting monad, Profunctor parameter order+  ValidatorMonadProfunctorT (..),+  ValidatorMonadProfunctor,++  -- * Optics — Validator++  -- ** Classy lenses+  GetValidator (..),+  HasValidator (..),++  -- ** Classy prisms+  ReviewValidator (..),+  AsValidator (..),++  -- * Optics — ValidatorProfunctor++  -- ** Classy lenses+  GetValidatorProfunctor (..),+  HasValidatorProfunctor (..),++  -- ** Classy prisms+  ReviewValidatorProfunctor (..),+  AsValidatorProfunctor (..),++  -- * Optics — ValidatorMonadT++  -- ** Classy lenses+  GetValidatorMonadT (..),+  HasValidatorMonadT (..),++  -- ** Classy prisms+  ReviewValidatorMonadT (..),+  AsValidatorMonadT (..),++  -- * Optics — ValidatorMonadProfunctorT++  -- ** Classy lenses+  GetValidatorMonadProfunctorT (..),+  HasValidatorMonadProfunctorT (..),++  -- ** Classy prisms+  ReviewValidatorMonadProfunctorT (..),+  AsValidatorMonadProfunctorT (..),++  -- * Constructing validators from prisms+  (-->),+  match,+  matchValidator,+  matchValidatorProfunctor,+  matchValidatorMonad,+  matchValidatorMonadProfunctor,++  -- * Constructing prisms from validators+  (<--),+  unmatch,+) where++import Control.Applicative (Alternative (empty, (<|>)))+import Control.Arrow (Arrow (arr, first), ArrowApply (app), ArrowChoice (left, right), ArrowPlus ((<+>)), ArrowZero (zeroArrow))+import Control.Category (Category (..))+import Control.Lens (APrism, AReview, Getter, Lens', Prism, Prism', Review, Rewrapped, Wrapped (_Wrapped', type Unwrapped), from, matching, prism, review, unto, view)+import Control.Lens.Iso (Iso', iso, mapping)+import Control.Monad (MonadPlus, ap, (>=>))+import Control.Monad.Cont.Class (MonadCont (callCC))+import Control.Monad.Error.Class (MonadError (catchError, throwError))+import Control.Monad.IO.Class (MonadIO (liftIO))+import Control.Monad.RWS.Class (MonadRWS)+import Control.Monad.Reader.Class (MonadReader (ask, local, reader))+import Control.Monad.State.Class (MonadState (get, put, state))+import Control.Monad.Trans.Class (MonadTrans (lift))+import Control.Monad.Writer.Class (MonadWriter (listen, pass, tell, writer))+import Control.Selective (Selective (..), selectM)+import Data.Bifunctor (Bifunctor (bimap))+import Data.Bifunctor.Swap (Swap (..))+import Data.Functor.Alt (Alt ((<!>)))+import Data.Functor.Apply (Apply ((<.>)))+import Data.Functor.Bind (Bind ((>>-)))+import Data.Functor.Bind.Trans (BindTrans (liftB))+import Data.Functor.Extend (Extend (extended))+import Data.Functor.Identity (Identity (..))+import Data.Functor.Plus (Plus (zero))+import Data.Profunctor (Choice (left', right'), Profunctor (dimap, lmap, rmap), Strong (first', second'))+import Data.Profunctor.Sieve (Sieve (sieve))+import Data.Profunctor.Traversing (Traversing (traverse', wander))+import Data.Semigroupoid (Semigroupoid (o))+import Data.Validation.Validation (Validation (..))+import qualified Data.Validation.Validation as Validation+import Data.Validation.ValidationMonad (ValidationMonadT (..), liftValidationMonadT, validationMonad)+import GHC.Generics (Generic)+import Prelude hiding (id, (.))++{- $setup+>>> import Data.Validation.Validation(Validation(..))+>>> import Data.Validation.ValidationMonad(ValidationMonadT(..))+>>> import Data.Validation.Validator+>>> import Data.Functor.Identity(Identity(..))+>>> import Data.Functor.Alt(Alt((<!>)))+>>> import Data.Functor.Apply(Apply((<.>)))+>>> import Data.Functor.Bind(Bind((>>-)))+>>> import Data.Functor.Extend(Extend(extended))+>>> import Data.Functor.Plus(Plus(zero))+>>> import Data.Bifunctor(Bifunctor(bimap))+>>> import Data.Bifunctor.Swap(Swap(swap))+>>> import Data.Profunctor(Profunctor(dimap, lmap, rmap), Strong(first', second'), Choice(left', right'))+>>> import Data.Profunctor.Sieve(Sieve(sieve))+>>> import Data.Profunctor.Traversing(Traversing(traverse'))+>>> import Data.Semigroupoid(Semigroupoid(o))+>>> import Control.Category(id, (.))+>>> import Control.Arrow(Arrow(arr, first), ArrowApply(app), ArrowChoice(left, right), ArrowZero(zeroArrow), ArrowPlus((<+>)))+>>> import Control.Applicative(Alternative(empty))+>>> import Control.Selective(Selective(select))+>>> import Control.Monad.Error.Class(MonadError(throwError, catchError))+>>> import Control.Monad.Trans.Class(MonadTrans(lift))+>>> import Control.Lens(view, review, _Wrapped', (^?), _Just, _Left, _Right)+>>> import Prelude hiding (id, (.))+>>> :set -w+>>> let runV (Validator f) = f+>>> let runVM v x = let ValidatorMonadT f = v in let ValidationMonadT (Identity r) = f x in r+>>> let runVP (ValidatorProfunctor f) = f+>>> let vpOk x = ValidatorProfunctor (\_ -> Success x) :: ValidatorProfunctor [String] Int Int+>>> let vpErr e = ValidatorProfunctor (\_ -> Failure e) :: ValidatorProfunctor [String] Int Int+>>> let vpFromInput = ValidatorProfunctor (\x -> Success (x + 1)) :: ValidatorProfunctor [String] Int Int+>>> let runVMP v x = let ValidatorMonadProfunctorT f = v in let ValidationMonadT (Identity r) = f x in r+>>> let vmpOk a = ValidatorMonadProfunctorT (\x -> ValidationMonadT (Identity (Success (a x)))) :: ValidatorMonadProfunctorT [String] Identity Int Int+>>> let vmpSucc a = ValidatorMonadProfunctorT (\_ -> ValidationMonadT (Identity (Success a))) :: ValidatorMonadProfunctorT [String] Identity Int Int+>>> let vmpErr e = ValidatorMonadProfunctorT (\_ -> ValidationMonadT (Identity (Failure e))) :: ValidatorMonadProfunctorT [String] Identity Int Int+>>> let vmpFail = vmpErr ["fail"]+-}++-- ========================================+-- Validator (accumulating, Bifunctor order)+-- ========================================++{- | A validator that applies a function @x -> Validation err a@.+The 'Applicative' instance /accumulates/ errors using 'Semigroup', like 'Validation'.++Unlike 'Validation' and the other validators, the 'Alt' instance does /not/+accumulate errors: it behaves like 'Either', returning the first success, or+otherwise the second failure. As a consequence there are no 'Plus' or+'Alternative' instances, and '<>' (which accumulates) differs from '<!>'.++>>> let Validator f = Validator (\x -> if x > 0 then Success x else Failure ["not positive"]) :: Validator Int [String] Int+>>> f 5+Success 5++>>> f (-1)+Failure ["not positive"]+-}+newtype Validator x err a = Validator (x -> Validation err a)+  deriving (Generic)++{- |+>>> import Control.Lens(view, _Wrapped')+>>> let v = Validator (\x -> Success (x + 1)) :: Validator Int [String] Int+>>> (view _Wrapped' v) 10+Success 11+-}+instance Wrapped (Validator x err a) where+  type Unwrapped (Validator x err a) = x -> Validation err a+  _Wrapped' = iso (\(Validator f) -> f) Validator+  {-# INLINE _Wrapped' #-}++instance Rewrapped (Validator x err a) (Validator x' err' b)++{- |+>>> let Validator f = fmap (+1) (Validator Success :: Validator Int [String] Int)+>>> f 10+Success 11++>>> let Validator f = fmap (+1) (Validator (\_ -> Failure ["err"]) :: Validator Int [String] Int)+>>> f 10+Failure ["err"]+-}+instance Functor (Validator x err) where+  fmap f (Validator g) = Validator (fmap (fmap f) g)+  {-# INLINE fmap #-}++{- | Accumulates errors using 'Semigroup'.++>>> import Data.Functor.Apply(Apply((<.>)))+>>> let Validator f = Validator (\_ -> Success (+1)) <.> (Validator Success :: Validator Int [String] Int)+>>> f 10+Success 11++>>> let Validator f = (Validator (\_ -> Failure ["e1"]) :: Validator Int [String] (Int -> Int)) <.> (Validator (\_ -> Failure ["e2"]) :: Validator Int [String] Int)+>>> f 0+Failure ["e1","e2"]+-}+instance (Semigroup err) => Apply (Validator x err) where+  Validator f <.> Validator g = Validator (\x -> f x <.> g x)+  {-# INLINE (<.>) #-}++{- | Accumulates errors using 'Semigroup'.++>>> let Validator f = pure 42 :: Validator Int [String] Int+>>> f 0+Success 42++>>> let Validator f = pure (+) <*> (Validator (\_ -> Failure ["e1"]) :: Validator Int [String] Int) <*> (Validator (\_ -> Failure ["e2"]) :: Validator Int [String] Int)+>>> f 0+Failure ["e1","e2"]+-}+instance (Semigroup err) => Applicative (Validator x err) where+  pure a = Validator (\_ -> Success a)+  {-# INLINE pure #-}+  Validator f <*> Validator g = Validator (\x -> f x <.> g x)+  {-# INLINE (<*>) #-}++{- | First success wins, like 'Either'; if both fail, the second failure is returned.+Errors are not accumulated, so no 'Semigroup' constraint is required.++This differs from the 'Alt' instances for 'Validation', 'ValidatorProfunctor',+'ValidatorMonadT' and 'ValidatorMonadProfunctorT', which all accumulate errors+when both sides fail. Converting a 'Validator' to one of those types (for+example with 'validatorProfunctor') therefore changes the meaning of '<!>'.+Use '<>' to accumulate errors from two 'Validator's.++>>> import Data.Functor.Alt(Alt((<!>)))+>>> let Validator f = (Validator (\_ -> Success 1) :: Validator Int [String] Int) <!> Validator (\_ -> Success 2)+>>> f 0+Success 1++>>> let Validator f = (Validator (\_ -> Success 1) :: Validator Int [String] Int) <!> Validator (\_ -> Failure ["e2"])+>>> f 0+Success 1++>>> let Validator f = (Validator (\_ -> Failure ["e1"]) :: Validator Int [String] Int) <!> Validator (\_ -> Success 2)+>>> f 0+Success 2++>>> let Validator f = (Validator (\_ -> Failure ["e1"]) :: Validator Int [String] Int) <!> Validator (\_ -> Failure ["e2"])+>>> f 0+Failure ["e2"]++>>> let Validator f = (Validator (\_ -> Failure 1) :: Validator Int Int Int) <!> Validator (\_ -> Failure 2)+>>> f 0+Failure 2+-}+instance Alt (Validator x err) where+  Validator f <!> Validator g =+    Validator+      ( \x -> case f x of+          Failure _ -> g x+          s@(Success _) -> s+      )+  {-# INLINE (<!>) #-}++{- |+>>> import Control.Selective(Selective(select))+>>> let Validator f = select (Validator (\_ -> Success (Right 1)) :: Validator Int [String] (Either Int Int)) (pure (+1))+>>> f 0+Success 1++>>> let Validator f = select (Validator (\_ -> Success (Left 1)) :: Validator Int [String] (Either Int Int)) (pure (+1))+>>> f 0+Success 2+-}+instance (Semigroup err) => Selective (Validator x err) where+  select (Validator f) (Validator g) = Validator (\x -> select (f x) (g x))+  {-# INLINE select #-}++{- |+>>> import Data.Bifunctor(Bifunctor(bimap))+>>> let Validator f = bimap (map (++ "!")) (+1) (Validator Success :: Validator Int [String] Int)+>>> f 10+Success 11++>>> let Validator f = bimap (map (++ "!")) (+1) (Validator (\_ -> Failure ["err"]) :: Validator Int [String] Int)+>>> f 0+Failure ["err!"]+-}+instance Bifunctor (Validator x) where+  bimap f g (Validator h) = Validator (bimap f g . h)+  {-# INLINE bimap #-}++{- |+>>> import Data.Bifunctor.Swap(Swap(swap))+>>> let Validator f = swap (Validator (\_ -> Failure "err") :: Validator Int String Int)+>>> f 0+Success "err"++>>> let Validator f = swap (Validator (\_ -> Success 1) :: Validator Int String Int)+>>> f 0+Failure 1+-}+instance Swap (Validator x) where+  swap (Validator f) = Validator (swap . f)+  {-# INLINE swap #-}++{- | Like 'Validation', a failure is kept: for each input, the result fails+where the validator fails, and otherwise succeeds with @f@ applied to the validator.++>>> import Data.Functor.Extend(Extend(extended))+>>> let Validator f = extended (\_ -> 42) (Validator (\_ -> Success 1) :: Validator Int [String] Int)+>>> f 0+Success 42++>>> let Validator f = extended (\_ -> 42) (Validator (\x -> if x > 0 then Success x else Failure ["not positive"]) :: Validator Int [String] Int)+>>> f 5+Success 42++>>> f (-1)+Failure ["not positive"]+-}+instance Extend (Validator x err) where+  extended f w@(Validator g) = Validator (\x -> f w <$ g x)+  {-# INLINE extended #-}++{- | First success wins; two failures accumulate. Unlike '<!>' for 'Validator',+this requires 'Semigroup' on @err@.++>>> let Validator f = (Validator (\_ -> Failure ["e1"]) :: Validator Int [String] Int) <> Validator (\_ -> Failure ["e2"])+>>> f 0+Failure ["e1","e2"]++>>> let Validator f = (Validator (\_ -> Success 1) :: Validator Int [String] Int) <> Validator (\_ -> Failure ["e2"])+>>> f 0+Success 1+-}+instance (Semigroup err) => Semigroup (Validator x err a) where+  Validator f <> Validator g = Validator (\x -> f x <> g x)+  {-# INLINE (<>) #-}++{- |+>>> let Validator f = mempty :: Validator Int [String] Int+>>> f 0+Failure []+-}+instance (Monoid err) => Monoid (Validator x err a) where+  mempty = Validator (const mempty)+  {-# INLINE mempty #-}++{- | Class for types that have a 'Getter' to a 'Validator'.++>>> import Control.Lens(view)+>>> let Validator f = view getValidator (Validator (\_ -> Success 1) :: Validator Int [String] Int)+>>> f 0+Success 1+-}+class GetValidator s x err a | s -> x err a where+  getValidator :: Getter s (Validator x err a)++instance GetValidator (Validator x err a) x err a where+  getValidator = id+  {-# INLINE getValidator #-}++{- | Class for types that have a 'Lens'' to a 'Validator'.++>>> import Control.Lens(view)+>>> let Validator f = view validator (Validator (\_ -> Success 1) :: Validator Int [String] Int)+>>> f 0+Success 1+-}+class (GetValidator s x err a) => HasValidator s x err a | s -> x err a where+  validator :: Lens' s (Validator x err a)++instance HasValidator (Validator x err a) x err a where+  validator = id+  {-# INLINE validator #-}++-- | Class for types that have a 'Review' to a 'Validator'.+class ReviewValidator s x err a | s -> x err a where+  reviewValidator :: Review s (Validator x err a)++instance ReviewValidator (Validator x err a) x err a where+  reviewValidator = id+  {-# INLINE reviewValidator #-}++-- | Class for types that have a 'Prism'' to a 'Validator'.+class (ReviewValidator s x err a) => AsValidator s x err a | s -> x err a where+  _Validator :: Prism' s (Validator x err a)++instance AsValidator (Validator x err a) x err a where+  _Validator = id+  {-# INLINE _Validator #-}++-- =============================================+-- ValidatorProfunctor (accumulating, Profunctor order)+-- =============================================++{- | A validator function @x -> Validation err a@ with @err@ as the+outermost parameter, enabling 'Profunctor' and related instances.++>>> runVP (ValidatorProfunctor (\x -> Success (x * 2))) 5+Success 10++>>> runVP (ValidatorProfunctor (\_ -> Failure ["bad"])) 5+Failure ["bad"]+-}+newtype ValidatorProfunctor err x a = ValidatorProfunctor (x -> Validation err a)+  deriving (Generic)++{- |+>>> view _Wrapped' vpFromInput $ 3+Success 4+-}+instance Wrapped (ValidatorProfunctor err x a) where+  type Unwrapped (ValidatorProfunctor err x a) = x -> Validation err a+  _Wrapped' = iso (\(ValidatorProfunctor f) -> f) ValidatorProfunctor+  {-# INLINE _Wrapped' #-}++instance Rewrapped (ValidatorProfunctor err x a) (ValidatorProfunctor err' x' b)++{- |+>>> runVP (fmap (+10) vpFromInput) 3+Success 14++>>> runVP (fmap (+10) (vpErr ["e"])) 3+Failure ["e"]+-}+instance Functor (ValidatorProfunctor err x) where+  fmap f (ValidatorProfunctor g) = ValidatorProfunctor (fmap (fmap f) g)+  {-# INLINE fmap #-}++{- | Accumulates errors from both sides.++>>> runVP (ValidatorProfunctor (\_ -> Success (+1)) <.> vpOk 2 :: ValidatorProfunctor [String] Int Int) 0+Success 3++>>> runVP (ValidatorProfunctor (\_ -> Failure ["e1"]) <.> ValidatorProfunctor (\_ -> Failure ["e2"]) :: ValidatorProfunctor [String] Int Int) 0+Failure ["e1","e2"]++>>> runVP (ValidatorProfunctor (\_ -> Failure ["e1"]) <.> vpOk 2 :: ValidatorProfunctor [String] Int Int) 0+Failure ["e1"]++>>> runVP (ValidatorProfunctor (\_ -> Success (+1)) <.> vpErr ["e2"] :: ValidatorProfunctor [String] Int Int) 0+Failure ["e2"]+-}+instance (Semigroup err) => Apply (ValidatorProfunctor err x) where+  ValidatorProfunctor f <.> ValidatorProfunctor g = ValidatorProfunctor (\x -> f x <.> g x)+  {-# INLINE (<.>) #-}++{- | 'pure' ignores the input, '<*>' accumulates errors.++>>> runVP (pure 42 :: ValidatorProfunctor [String] Int Int) 0+Success 42++>>> runVP (pure (+1) <*> pure 2 :: ValidatorProfunctor [String] Int Int) 0+Success 3++>>> runVP (ValidatorProfunctor (\_ -> Failure ["e1"]) <*> ValidatorProfunctor (\_ -> Failure ["e2"]) :: ValidatorProfunctor [String] Int Int) 0+Failure ["e1","e2"]+-}+instance (Semigroup err) => Applicative (ValidatorProfunctor err x) where+  pure a = ValidatorProfunctor (\_ -> Success a)+  {-# INLINE pure #-}+  ValidatorProfunctor f <*> ValidatorProfunctor g = ValidatorProfunctor (\x -> f x <.> g x)+  {-# INLINE (<*>) #-}++{- | First success wins; two failures accumulate.++>>> runVP (vpOk 1 <!> vpOk 2) 0+Success 1++>>> runVP (vpErr ["e1"] <!> vpOk 2) 0+Success 2++>>> runVP (vpOk 1 <!> vpErr ["e2"]) 0+Success 1++>>> runVP (vpErr ["e1"] <!> vpErr ["e2"]) 0+Failure ["e1","e2"]+-}+instance (Semigroup err) => Alt (ValidatorProfunctor err x) where+  ValidatorProfunctor f <!> ValidatorProfunctor g = ValidatorProfunctor (\x -> f x <!> g x)+  {-# INLINE (<!>) #-}++{- |+>>> runVP (zero :: ValidatorProfunctor [String] Int Int) 0+Failure []+-}+instance (Monoid err) => Plus (ValidatorProfunctor err x) where+  zero = ValidatorProfunctor (\_ -> Failure mempty)+  {-# INLINE zero #-}++{- |+>>> runVP (empty :: ValidatorProfunctor [String] Int Int) 0+Failure []++>>> runVP (vpErr ["e1"] <|> vpOk 2) 0+Success 2+-}+instance (Monoid err) => Alternative (ValidatorProfunctor err x) where+  empty = zero+  {-# INLINE empty #-}+  (<|>) = (<!>)+  {-# INLINE (<|>) #-}++{- |+>>> runVP (select (pure (Right 1)) (pure (+1)) :: ValidatorProfunctor [String] Int Int) 0+Success 1++>>> runVP (select (pure (Left 1)) (pure (+1)) :: ValidatorProfunctor [String] Int Int) 0+Success 2++>>> runVP (select (ValidatorProfunctor (\_ -> Failure ["e1"])) (pure (+1)) :: ValidatorProfunctor [String] Int Int) 0+Failure ["e1"]+-}+instance (Semigroup err) => Selective (ValidatorProfunctor err x) where+  select (ValidatorProfunctor f) (ValidatorProfunctor g) = ValidatorProfunctor (\x -> select (f x) (g x))+  {-# INLINE select #-}++{- | Contravariant in @x@, covariant in @a@.++>>> runVP (dimap (*2) (+10) vpFromInput) 3+Success 17++>>> runVP (lmap (*2) vpFromInput) 3+Success 7++>>> runVP (rmap (+10) vpFromInput) 3+Success 14+-}+instance Profunctor (ValidatorProfunctor err) where+  dimap f g (ValidatorProfunctor h) = ValidatorProfunctor (fmap g . h . f)+  {-# INLINE dimap #-}+  lmap f (ValidatorProfunctor h) = ValidatorProfunctor (h . f)+  {-# INLINE lmap #-}+  rmap g (ValidatorProfunctor h) = ValidatorProfunctor (fmap g . h)+  {-# INLINE rmap #-}++{- |+>>> runVP (first' vpFromInput) (3, "tag")+Success (4,"tag")++>>> runVP (second' vpFromInput) ("tag", 3)+Success ("tag",4)+-}+instance Strong (ValidatorProfunctor err) where+  first' (ValidatorProfunctor f) = ValidatorProfunctor (\(a, c) -> fmap (,c) (f a))+  {-# INLINE first' #-}+  second' (ValidatorProfunctor f) = ValidatorProfunctor (\(c, a) -> fmap (c,) (f a))+  {-# INLINE second' #-}++{- |+>>> runVP (left' vpFromInput) (Left 3)+Success (Left 4)++>>> runVP (left' vpFromInput) (Right "x" :: Either Int String)+Success (Right "x")++>>> runVP (right' vpFromInput) (Right 3)+Success (Right 4)++>>> runVP (right' vpFromInput) (Left "x" :: Either String Int)+Success (Left "x")+-}+instance Choice (ValidatorProfunctor err) where+  left' (ValidatorProfunctor f) = ValidatorProfunctor (either (fmap Left . f) (Success . Right))+  {-# INLINE left' #-}+  right' (ValidatorProfunctor f) = ValidatorProfunctor (either (Success . Left) (fmap Right . f))+  {-# INLINE right' #-}++{- |+>>> runVP (traverse' vpFromInput) [1, 2, 3]+Success [2,3,4]+-}+instance (Semigroup err) => Traversing (ValidatorProfunctor err) where+  traverse' (ValidatorProfunctor f) = ValidatorProfunctor (traverse f)+  {-# INLINE traverse' #-}+  wander t (ValidatorProfunctor f) = ValidatorProfunctor (t f)+  {-# INLINE wander #-}++{- |+>>> sieve vpFromInput 3+Success 4++>>> sieve (vpErr ["e"]) 0+Failure ["e"]+-}+instance Sieve (ValidatorProfunctor err) (Validation err) where+  sieve (ValidatorProfunctor f) = f+  {-# INLINE sieve #-}++{- | Like 'Validation', a failure is kept: for each input, the result fails+where the validator fails, and otherwise succeeds with @f@ applied to the validator.++>>> runVP (extended (\_ -> 42) vpFromInput) 0+Success 42++>>> runVP (extended (\_ -> 42) (vpErr ["e"])) 0+Failure ["e"]+-}+instance Extend (ValidatorProfunctor err x) where+  extended f w@(ValidatorProfunctor g) = ValidatorProfunctor (\x -> f w <$ g x)+  {-# INLINE extended #-}++{- |+>>> runVP (vpOk 1 <> vpOk 2) 0+Success 1++>>> runVP (vpErr ["e1"] <> vpErr ["e2"]) 0+Failure ["e1","e2"]++>>> runVP (vpErr ["e1"] <> vpOk 2) 0+Success 2+-}+instance (Semigroup err) => Semigroup (ValidatorProfunctor err x a) where+  ValidatorProfunctor f <> ValidatorProfunctor g = ValidatorProfunctor (\x -> f x <> g x)+  {-# INLINE (<>) #-}++{- |+>>> runVP (mempty :: ValidatorProfunctor [String] Int Int) 0+Failure []+-}+instance (Monoid err) => Monoid (ValidatorProfunctor err x a) where+  mempty = ValidatorProfunctor (const mempty)+  {-# INLINE mempty #-}++{- |+>>> runVP (view getValidatorProfunctor vpFromInput) 3+Success 4+-}+class GetValidatorProfunctor s err x a | s -> err x a where+  getValidatorProfunctor :: Getter s (ValidatorProfunctor err x a)++instance GetValidatorProfunctor (ValidatorProfunctor err x a) err x a where+  getValidatorProfunctor = id+  {-# INLINE getValidatorProfunctor #-}++{- |+>>> runVP (view validatorProfunctor vpFromInput) 3+Success 4+-}+class (GetValidatorProfunctor s err x a) => HasValidatorProfunctor s err x a | s -> err x a where+  validatorProfunctor :: Lens' s (ValidatorProfunctor err x a)++instance HasValidatorProfunctor (ValidatorProfunctor err x a) err x a where+  validatorProfunctor = id+  {-# INLINE validatorProfunctor #-}++{- |+>>> runVP (review reviewValidatorProfunctor vpFromInput) 3+Success 4+-}+class ReviewValidatorProfunctor s err x a | s -> err x a where+  reviewValidatorProfunctor :: Review s (ValidatorProfunctor err x a)++instance ReviewValidatorProfunctor (ValidatorProfunctor err x a) err x a where+  reviewValidatorProfunctor = id+  {-# INLINE reviewValidatorProfunctor #-}++{- |+>>> let v = review _ValidatorProfunctor vpFromInput :: ValidatorProfunctor [String] Int Int+>>> runVP v 3+Success 4+-}+class (ReviewValidatorProfunctor s err x a) => AsValidatorProfunctor s err x a | s -> err x a where+  _ValidatorProfunctor :: Prism' s (ValidatorProfunctor err x a)++instance AsValidatorProfunctor (ValidatorProfunctor err x a) err x a where+  _ValidatorProfunctor = id+  {-# INLINE _ValidatorProfunctor #-}++-- ==============================================+-- ValidatorMonadT (short-circuiting, MonadTrans order)+-- ==============================================++{- | A validator with short-circuiting 'Monad' and 'MonadTrans' instances.+The parameter order @x err f a@ enables 'MonadTrans' on @ValidatorMonadT x err@.++>>> import Data.Functor.Identity (Identity(..))+>>> import Data.Validation.Validation (Validation(..))+>>> import Data.Validation.ValidationMonad (ValidationMonadT(..))+>>> let v = ValidatorMonadT (\x -> ValidationMonadT (Identity (if x > 0 then Success x else Failure ["non-positive"])))+>>> let ValidatorMonadT f = v in let ValidationMonadT (Identity r) = f 5 in r+Success 5++>>> let ValidatorMonadT f = v in let ValidationMonadT (Identity r) = f (-1) in r+Failure ["non-positive"]+-}+newtype ValidatorMonadT x err f a = ValidatorMonadT (x -> ValidationMonadT err f a)+  deriving (Generic)++-- | @ValidatorMonad x err a@ is @ValidatorMonadT x err Identity a@.+type ValidatorMonad x err a = ValidatorMonadT x err Identity a++{- |+>>> import Data.Functor.Identity (Identity(..))+>>> import Data.Validation.Validation (Validation(..))+>>> import Data.Validation.ValidationMonad (ValidationMonadT(..))+>>> import Control.Lens (view, _Wrapped')+>>> let v = ValidatorMonadT (\_ -> ValidationMonadT (Identity (Success 1))) :: ValidatorMonadT Int String Identity Int+>>> view _Wrapped' v $ 0+ValidationMonadT (Identity (Success 1))+-}+instance Wrapped (ValidatorMonadT x err f a) where+  type Unwrapped (ValidatorMonadT x err f a) = x -> ValidationMonadT err f a+  _Wrapped' = iso (\(ValidatorMonadT f) -> f) ValidatorMonadT+  {-# INLINE _Wrapped' #-}++instance Rewrapped (ValidatorMonadT x err f a) (ValidatorMonadT x' err' f' b)++{- |+>>> import Data.Functor.Identity (Identity(..))+>>> import Data.Validation.Validation (Validation(..))+>>> import Data.Validation.ValidationMonad (ValidationMonadT(..))+>>> let v = ValidatorMonadT (\_ -> ValidationMonadT (Identity (Success 1))) :: ValidatorMonadT Int [String] Identity Int+>>> let ValidatorMonadT f = fmap (+1) v in let ValidationMonadT (Identity r) = f 0 in r+Success 2+-}+instance (Functor f) => Functor (ValidatorMonadT x err f) where+  fmap f (ValidatorMonadT g) = ValidatorMonadT (fmap (fmap f) g)+  {-# INLINE fmap #-}++{- |+>>> import Data.Functor.Identity (Identity(..))+>>> import Data.Validation.Validation (Validation(..))+>>> import Data.Validation.ValidationMonad (ValidationMonadT(..))+>>> import Data.Functor.Apply ((<.>))+>>> let f = ValidatorMonadT (\_ -> ValidationMonadT (Identity (Success (+1)))) :: ValidatorMonadT Int [String] Identity (Int -> Int)+>>> let a = ValidatorMonadT (\_ -> ValidationMonadT (Identity (Success 2))) :: ValidatorMonadT Int [String] Identity Int+>>> let ValidatorMonadT g = f <.> a in let ValidationMonadT (Identity r) = g 0 in r+Success 3+-}+instance (Monad f) => Apply (ValidatorMonadT x err f) where+  (<.>) = ap+  {-# INLINE (<.>) #-}++{- | Short-circuits on first failure (unlike 'Validation' which accumulates).++>>> import Data.Functor.Identity (Identity(..))+>>> import Data.Validation.Validation (Validation(..))+>>> import Data.Validation.ValidationMonad (ValidationMonadT(..))+>>> let e1 = ValidatorMonadT (\_ -> ValidationMonadT (Identity (Failure ["e1"]))) :: ValidatorMonadT Int [String] Identity (Int -> Int)+>>> let e2 = ValidatorMonadT (\_ -> ValidationMonadT (Identity (Failure ["e2"]))) :: ValidatorMonadT Int [String] Identity Int+>>> let ValidatorMonadT f = e1 <*> e2 in let ValidationMonadT (Identity r) = f 0 in r+Failure ["e1"]+-}+instance (Monad f) => Applicative (ValidatorMonadT x err f) where+  pure a = ValidatorMonadT (\_ -> pure a)+  {-# INLINE pure #-}+  ValidatorMonadT f <*> ValidatorMonadT g = ValidatorMonadT (\x -> f x <*> g x)+  {-# INLINE (<*>) #-}++{- |+>>> import Data.Functor.Identity (Identity(..))+>>> import Data.Validation.Validation (Validation(..))+>>> import Data.Validation.ValidationMonad (ValidationMonadT(..))+>>> import Data.Functor.Bind ((>>-))+>>> let v = ValidatorMonadT (\_ -> ValidationMonadT (Identity (Success 1))) :: ValidatorMonadT Int [String] Identity Int+>>> let ValidatorMonadT f = v >>- \a -> ValidatorMonadT (\_ -> ValidationMonadT (Identity (Success (a + 1)))) in let ValidationMonadT (Identity r) = f 0 in r+Success 2+-}+instance (Monad f) => Bind (ValidatorMonadT x err f) where+  (>>-) = (>>=)+  {-# INLINE (>>-) #-}++{- | Short-circuits on 'Failure'.++>>> import Data.Functor.Identity (Identity(..))+>>> import Data.Validation.Validation (Validation(..))+>>> import Data.Validation.ValidationMonad (ValidationMonadT(..))+>>> let e1 = ValidatorMonadT (\_ -> ValidationMonadT (Identity (Failure ["e1"]))) :: ValidatorMonadT Int [String] Identity Int+>>> let e2 = ValidatorMonadT (\_ -> ValidationMonadT (Identity (Failure ["e2"]))) :: ValidatorMonadT Int [String] Identity Int+>>> let ValidatorMonadT f = e1 >> e2 in let ValidationMonadT (Identity r) = f 0 in r+Failure ["e1"]+-}+instance (Monad f) => Monad (ValidatorMonadT x err f) where+  ValidatorMonadT f >>= k = ValidatorMonadT (\x -> f x >>= \a -> let ValidatorMonadT g = k a in g x)+  {-# INLINE (>>=) #-}++instance (MonadFail f) => MonadFail (ValidatorMonadT x err f) where+  fail = ValidatorMonadT . const . liftValidationMonadT . Prelude.fail+  {-# INLINE fail #-}++{- | First success wins; two failures accumulate.++>>> import Data.Functor.Identity (Identity(..))+>>> import Data.Validation.Validation (Validation(..))+>>> import Data.Validation.ValidationMonad (ValidationMonadT(..))+>>> import Data.Functor.Alt ((<!>))+>>> let e1 = ValidatorMonadT (\_ -> ValidationMonadT (Identity (Failure ["e1"]))) :: ValidatorMonadT Int [String] Identity Int+>>> let ok = ValidatorMonadT (\_ -> ValidationMonadT (Identity (Success 2))) :: ValidatorMonadT Int [String] Identity Int+>>> let ValidatorMonadT f = e1 <!> ok in let ValidationMonadT (Identity r) = f 0 in r+Success 2+-}+instance (Monad f, Semigroup err) => Alt (ValidatorMonadT x err f) where+  ValidatorMonadT f <!> ValidatorMonadT g = ValidatorMonadT (\x -> f x <!> g x)+  {-# INLINE (<!>) #-}++{- |+>>> import Data.Functor.Identity (Identity(..))+>>> import Data.Validation.Validation (Validation(..))+>>> import Data.Validation.ValidationMonad (ValidationMonadT(..))+>>> import Data.Functor.Alt ((<!>))+>>> import Data.Functor.Plus (zero)+>>> let ok = ValidatorMonadT (\_ -> ValidationMonadT (Identity (Success 1))) :: ValidatorMonadT Int [String] Identity Int+>>> let ValidatorMonadT f = (zero :: ValidatorMonadT Int [String] Identity Int) <!> ok in let ValidationMonadT (Identity r) = f 0 in r+Success 1+-}+instance (Monad f, Monoid err) => Plus (ValidatorMonadT x err f) where+  zero = ValidatorMonadT (const zero)+  {-# INLINE zero #-}++{- |+>>> import Data.Functor.Identity (Identity(..))+>>> import Data.Validation.Validation (Validation(..))+>>> import Data.Validation.ValidationMonad (ValidationMonadT(..))+>>> let ok = ValidatorMonadT (\_ -> ValidationMonadT (Identity (Success 1))) :: ValidatorMonadT Int [String] Identity Int+>>> let ValidatorMonadT f = empty <|> ok in let ValidationMonadT (Identity r) = f 0 in r+Success 1+-}+instance (Monad f, Monoid err) => Alternative (ValidatorMonadT x err f) where+  empty = zero+  {-# INLINE empty #-}+  (<|>) = (<!>)+  {-# INLINE (<|>) #-}++instance (Monad f, Monoid err) => MonadPlus (ValidatorMonadT x err f)++{- |+>>> import Data.Functor.Identity (Identity(..))+>>> import Data.Validation.Validation (Validation(..))+>>> import Data.Validation.ValidationMonad (ValidationMonadT(..))+>>> import Control.Selective (select)+>>> let ok a = ValidatorMonadT (\_ -> ValidationMonadT (Identity (Success a)))+>>> let ValidatorMonadT f = select (ok (Left (1 :: Int))) (ok (+1)) :: ValidatorMonadT Int [String] Identity Int in let ValidationMonadT (Identity r) = f 0 in r+Success 2+-}+instance (Monad f) => Selective (ValidatorMonadT x err f) where+  select = selectM+  {-# INLINE select #-}++{- | Like 'Validation', a failure is kept: for each input, the result fails+where the validator fails, and otherwise succeeds with @f@ applied to the validator.+The effects of the validator are run.++>>> import Data.Functor.Identity (Identity(..))+>>> import Data.Validation.Validation (Validation(..))+>>> import Data.Validation.ValidationMonad (ValidationMonadT(..))+>>> import Data.Functor.Extend (extended)+>>> let v = ValidatorMonadT (\_ -> ValidationMonadT (Identity (Success 1))) :: ValidatorMonadT Int [String] Identity Int+>>> let ValidatorMonadT f = extended (\_ -> 42) v in let ValidationMonadT (Identity r) = f 0 in r+Success 42++>>> let e = ValidatorMonadT (\_ -> ValidationMonadT (Identity (Failure ["e"]))) :: ValidatorMonadT Int [String] Identity Int+>>> let ValidatorMonadT f = extended (\_ -> 42) e in let ValidationMonadT (Identity r) = f 0 in r+Failure ["e"]+-}+instance (Functor f) => Extend (ValidatorMonadT x err f) where+  extended f w@(ValidatorMonadT g) = ValidatorMonadT (\x -> f w <$ g x)+  {-# INLINE extended #-}++{- |+>>> import Data.Functor.Identity (Identity(..))+>>> import Data.Validation.Validation (Validation(..))+>>> import Data.Validation.ValidationMonad (ValidationMonadT(..))+>>> let e1 = ValidatorMonadT (\_ -> ValidationMonadT (Identity (Failure ["e1"]))) :: ValidatorMonadT Int [String] Identity Int+>>> let e2 = ValidatorMonadT (\_ -> ValidationMonadT (Identity (Failure ["e2"]))) :: ValidatorMonadT Int [String] Identity Int+>>> let ValidatorMonadT f = e1 <> e2 in let ValidationMonadT (Identity r) = f 0 in r+Failure ["e1","e2"]+-}+instance (Applicative f, Semigroup err) => Semigroup (ValidatorMonadT x err f a) where+  ValidatorMonadT f <> ValidatorMonadT g = ValidatorMonadT (\x -> f x <> g x)+  {-# INLINE (<>) #-}++{- |+>>> import Data.Functor.Identity (Identity(..))+>>> import Data.Validation.Validation (Validation(..))+>>> import Data.Validation.ValidationMonad (ValidationMonadT(..))+>>> let ValidatorMonadT f = mempty :: ValidatorMonadT Int [String] Identity Int in let ValidationMonadT (Identity r) = f 0 in r+Failure []+-}+instance (Applicative f, Monoid err) => Monoid (ValidatorMonadT x err f a) where+  mempty = ValidatorMonadT (const mempty)+  {-# INLINE mempty #-}++{- |+>>> import Data.Functor.Identity (Identity(..))+>>> import Data.Validation.Validation (Validation(..))+>>> import Data.Validation.ValidationMonad (ValidationMonadT(..))+>>> import Control.Monad.Trans.Class (lift)+>>> let ValidatorMonadT f = lift (Identity 42) :: ValidatorMonadT Int [String] Identity Int in let ValidationMonadT (Identity r) = f 0 in r+Success 42+-}+instance MonadTrans (ValidatorMonadT x err) where+  lift = ValidatorMonadT . const . liftValidationMonadT+  {-# INLINE lift #-}++instance BindTrans (ValidatorMonadT x err) where+  liftB = ValidatorMonadT . const . liftValidationMonadT+  {-# INLINE liftB #-}++{- |+>>> import Data.Functor.Identity (Identity(..))+>>> import Data.Validation.Validation (Validation(..))+>>> import Data.Validation.ValidationMonad (ValidationMonadT(..))+>>> import Control.Monad.Error.Class (throwError, catchError)+>>> let ValidatorMonadT f = throwError ["oops"] :: ValidatorMonadT Int [String] Identity Int in let ValidationMonadT (Identity r) = f 0 in r+Failure ["oops"]++>>> let e = ValidatorMonadT (\_ -> ValidationMonadT (Identity (Failure ["e"]))) :: ValidatorMonadT Int [String] Identity Int+>>> let ValidatorMonadT f = catchError e (\_ -> ValidatorMonadT (\_ -> ValidationMonadT (Identity (Success 99)))) in let ValidationMonadT (Identity r) = f 0 in r+Success 99+-}+instance (Monad f) => MonadError err (ValidatorMonadT x err f) where+  throwError e = ValidatorMonadT (\_ -> throwError e)+  {-# INLINE throwError #-}+  catchError (ValidatorMonadT f) h = ValidatorMonadT (\x -> catchError (f x) (\e -> let ValidatorMonadT g = h e in g x))+  {-# INLINE catchError #-}++instance (MonadIO f) => MonadIO (ValidatorMonadT x err f) where+  liftIO = ValidatorMonadT . const . liftValidationMonadT . liftIO+  {-# INLINE liftIO #-}++instance (MonadReader r f) => MonadReader r (ValidatorMonadT x err f) where+  ask = ValidatorMonadT (\_ -> liftValidationMonadT ask)+  {-# INLINE ask #-}+  local f (ValidatorMonadT g) = ValidatorMonadT (local f . g)+  {-# INLINE local #-}+  reader = ValidatorMonadT . const . liftValidationMonadT . reader+  {-# INLINE reader #-}++instance (MonadWriter w f) => MonadWriter w (ValidatorMonadT x err f) where+  writer = ValidatorMonadT . const . liftValidationMonadT . writer+  {-# INLINE writer #-}+  tell = ValidatorMonadT . const . liftValidationMonadT . tell+  {-# INLINE tell #-}+  listen (ValidatorMonadT f) = ValidatorMonadT (listen . f)+  {-# INLINE listen #-}+  pass (ValidatorMonadT f) = ValidatorMonadT (pass . f)+  {-# INLINE pass #-}++instance (MonadState s f) => MonadState s (ValidatorMonadT x err f) where+  get = ValidatorMonadT (\_ -> liftValidationMonadT get)+  {-# INLINE get #-}+  put = ValidatorMonadT . const . liftValidationMonadT . put+  {-# INLINE put #-}+  state = ValidatorMonadT . const . liftValidationMonadT . state+  {-# INLINE state #-}++instance (MonadCont f) => MonadCont (ValidatorMonadT x err f) where+  callCC f = ValidatorMonadT (\x -> callCC (\c -> let ValidatorMonadT g = f (\a -> ValidatorMonadT (\_ -> c a)) in g x))+  {-# INLINE callCC #-}++instance (MonadRWS r w s f) => MonadRWS r w s (ValidatorMonadT x err f)++{- |+>>> import Data.Functor.Identity (Identity(..))+>>> import Data.Validation.Validation (Validation(..))+>>> import Data.Validation.ValidationMonad (ValidationMonadT(..))+>>> import Control.Lens (view)+>>> let v = ValidatorMonadT (\_ -> ValidationMonadT (Identity (Success 1))) :: ValidatorMonadT Int String Identity Int+>>> let ValidatorMonadT f = view getValidatorMonadT v in let ValidationMonadT (Identity r) = f 0 in r+Success 1+-}+class GetValidatorMonadT s x err f a | s -> x err f a where+  getValidatorMonadT :: Getter s (ValidatorMonadT x err f a)++instance GetValidatorMonadT (ValidatorMonadT x err f a) x err f a where+  getValidatorMonadT = id+  {-# INLINE getValidatorMonadT #-}++{- |+>>> import Data.Functor.Identity (Identity(..))+>>> import Data.Validation.Validation (Validation(..))+>>> import Data.Validation.ValidationMonad (ValidationMonadT(..))+>>> import Control.Lens (view)+>>> let v = ValidatorMonadT (\_ -> ValidationMonadT (Identity (Success 1))) :: ValidatorMonadT Int String Identity Int+>>> let ValidatorMonadT f = view validatorMonadT v in let ValidationMonadT (Identity r) = f 0 in r+Success 1+-}+class (GetValidatorMonadT s x err f a) => HasValidatorMonadT s x err f a | s -> x err f a where+  validatorMonadT :: Lens' s (ValidatorMonadT x err f a)++instance HasValidatorMonadT (ValidatorMonadT x err f a) x err f a where+  validatorMonadT = id+  {-# INLINE validatorMonadT #-}++class ReviewValidatorMonadT s x err f a | s -> x err f a where+  reviewValidatorMonadT :: Review s (ValidatorMonadT x err f a)++instance ReviewValidatorMonadT (ValidatorMonadT x err f a) x err f a where+  reviewValidatorMonadT = id+  {-# INLINE reviewValidatorMonadT #-}++class (ReviewValidatorMonadT s x err f a) => AsValidatorMonadT s x err f a | s -> x err f a where+  _ValidatorMonadT :: Prism' s (ValidatorMonadT x err f a)++instance AsValidatorMonadT (ValidatorMonadT x err f a) x err f a where+  _ValidatorMonadT = id+  {-# INLINE _ValidatorMonadT #-}++-- =====================================================+-- ValidatorMonadProfunctorT (short-circuiting, Profunctor order)+-- =====================================================++{- | A profunctor validator with short-circuiting monadic semantics.++@ValidatorMonadProfunctorT err f x a@ wraps @x -> ValidationMonadT err f a@.+The @Applicative@ and @Monad@ instances short-circuit on the first 'Failure'.+@Category@ composition sequences validators, short-circuiting on the first failure.++>>> import Control.Lens(view, _Wrapped')+>>> let v = ValidatorMonadProfunctorT (\x -> ValidationMonadT (Identity (Success (x + 1)))) :: ValidatorMonadProfunctorT [String] Identity Int Int+>>> let ValidationMonadT (Identity r) = (view _Wrapped' v) 3+>>> r+Success 4+-}+newtype ValidatorMonadProfunctorT err f x a = ValidatorMonadProfunctorT (x -> ValidationMonadT err f a)+  deriving (Generic)++-- | @ValidatorMonadProfunctor@ is @ValidatorMonadProfunctorT@ specialised to 'Identity'.+type ValidatorMonadProfunctor err x a = ValidatorMonadProfunctorT err Identity x a++{- |+>>> import Control.Lens(view, _Wrapped')+>>> let v = ValidatorMonadProfunctorT (\x -> ValidationMonadT (Identity (Success (x + 1)))) :: ValidatorMonadProfunctorT [String] Identity Int Int+>>> view _Wrapped' v 3+ValidationMonadT (Identity (Success 4))+-}+instance Wrapped (ValidatorMonadProfunctorT err f x a) where+  type Unwrapped (ValidatorMonadProfunctorT err f x a) = x -> ValidationMonadT err f a+  _Wrapped' = iso (\(ValidatorMonadProfunctorT f) -> f) ValidatorMonadProfunctorT+  {-# INLINE _Wrapped' #-}++instance Rewrapped (ValidatorMonadProfunctorT err f x a) (ValidatorMonadProfunctorT err' f' x' b)++{- |+>>> import Control.Lens(view, _Wrapped')+>>> let v = ValidatorMonadProfunctorT (\x -> ValidationMonadT (Identity (Success (x + 1)))) :: ValidatorMonadProfunctorT [String] Identity Int Int+>>> let ValidationMonadT (Identity r) = (view _Wrapped' (fmap (*10) v)) 3+>>> r+Success 40+-}+instance (Functor f) => Functor (ValidatorMonadProfunctorT err f x) where+  fmap f (ValidatorMonadProfunctorT g) = ValidatorMonadProfunctorT (fmap (fmap f) g)+  {-# INLINE fmap #-}++{- | Short-circuiting: stops at the first 'Failure'.++>>> import Control.Lens(view, _Wrapped')+>>> import Data.Functor.Apply(Apply((<.>)))+>>> let f = ValidatorMonadProfunctorT (\x -> ValidationMonadT (Identity (Success (+ x)))) :: ValidatorMonadProfunctorT [String] Identity Int (Int -> Int)+>>> let g = ValidatorMonadProfunctorT (\x -> ValidationMonadT (Identity (Success (x * 2)))) :: ValidatorMonadProfunctorT [String] Identity Int Int+>>> let ValidationMonadT (Identity r) = (view _Wrapped' (f <.> g)) 3+>>> r+Success 9+-}+instance (Monad f) => Apply (ValidatorMonadProfunctorT err f x) where+  (<.>) = ap+  {-# INLINE (<.>) #-}++{- | Short-circuiting: unlike 'Validation', does /not/ accumulate errors.++>>> import Control.Lens(view, _Wrapped')+>>> let ValidationMonadT (Identity r) = view _Wrapped' (pure 42 :: ValidatorMonadProfunctorT [String] Identity Int Int) 0+>>> r+Success 42+-}+instance (Monad f) => Applicative (ValidatorMonadProfunctorT err f x) where+  pure a = ValidatorMonadProfunctorT (\_ -> pure a)+  {-# INLINE pure #-}+  ValidatorMonadProfunctorT f <*> ValidatorMonadProfunctorT g = ValidatorMonadProfunctorT (\x -> f x <*> g x)+  {-# INLINE (<*>) #-}++{- |+>>> import Control.Lens(view, _Wrapped')+>>> import Data.Functor.Bind(Bind((>>-)))+>>> let v = ValidatorMonadProfunctorT (\x -> ValidationMonadT (Identity (Success (x + 1)))) :: ValidatorMonadProfunctorT [String] Identity Int Int+>>> let ValidationMonadT (Identity r) = view _Wrapped' (v >>- \a -> pure (a * 10)) 3+>>> r+Success 40+-}+instance (Monad f) => Bind (ValidatorMonadProfunctorT err f x) where+  (>>-) = (>>=)+  {-# INLINE (>>-) #-}++{- |+>>> import Control.Lens(view, _Wrapped')+>>> let v = ValidatorMonadProfunctorT (\x -> ValidationMonadT (Identity (Success (x + 1)))) :: ValidatorMonadProfunctorT [String] Identity Int Int+>>> let ValidationMonadT (Identity r) = view _Wrapped' (v >>= \a -> pure (a * 10)) 3+>>> r+Success 40++>>> let f = ValidatorMonadProfunctorT (\_ -> ValidationMonadT (Identity (Failure ["e1"]))) :: ValidatorMonadProfunctorT [String] Identity Int Int+>>> let ValidationMonadT (Identity r) = view _Wrapped' (f >>= \a -> pure (a * 10)) 3+>>> r+Failure ["e1"]+-}+instance (Monad f) => Monad (ValidatorMonadProfunctorT err f x) where+  ValidatorMonadProfunctorT f >>= k = ValidatorMonadProfunctorT (\x -> f x >>= \a -> let ValidatorMonadProfunctorT g = k a in g x)+  {-# INLINE (>>=) #-}++{- |+>>> import Control.Lens(view, _Wrapped')+>>> import Data.Functor.Alt(Alt((<!>)))+>>> let v1 = ValidatorMonadProfunctorT (\_ -> ValidationMonadT (Identity (Failure ["e1"]))) :: ValidatorMonadProfunctorT [String] Identity Int Int+>>> let v2 = ValidatorMonadProfunctorT (\x -> ValidationMonadT (Identity (Success (x * 2)))) :: ValidatorMonadProfunctorT [String] Identity Int Int+>>> let ValidationMonadT (Identity r) = view _Wrapped' (v1 <!> v2) 3+>>> r+Success 6+-}+instance (Monad f, Semigroup err) => Alt (ValidatorMonadProfunctorT err f x) where+  ValidatorMonadProfunctorT f <!> ValidatorMonadProfunctorT g = ValidatorMonadProfunctorT (\x -> f x <!> g x)+  {-# INLINE (<!>) #-}++{- |+>>> import Control.Lens(view, _Wrapped')+>>> import Data.Functor.Plus(Plus(zero))+>>> let ValidationMonadT (Identity r) = view _Wrapped' (zero :: ValidatorMonadProfunctorT [String] Identity Int Int) 3+>>> r+Failure []+-}+instance (Monad f, Monoid err) => Plus (ValidatorMonadProfunctorT err f x) where+  zero = ValidatorMonadProfunctorT (const zero)+  {-# INLINE zero #-}++{- |+>>> import Control.Lens(view, _Wrapped')+>>> let ValidationMonadT (Identity r) = view _Wrapped' (empty :: ValidatorMonadProfunctorT [String] Identity Int Int) 3+>>> r+Failure []+-}+instance (Monad f, Monoid err) => Alternative (ValidatorMonadProfunctorT err f x) where+  empty = zero+  {-# INLINE empty #-}+  (<|>) = (<!>)+  {-# INLINE (<|>) #-}++instance (Monad f, Monoid err) => MonadPlus (ValidatorMonadProfunctorT err f x)++{- |+>>> import Control.Lens(view, _Wrapped')+>>> import Control.Selective(Selective(select))+>>> let v = fmap Right (pure 1) :: ValidatorMonadProfunctorT [String] Identity Int (Either Int Int)+>>> let ValidationMonadT (Identity r) = view _Wrapped' (select v (pure (+1))) 3+>>> r+Success 1+-}+instance (Monad f) => Selective (ValidatorMonadProfunctorT err f x) where+  select = selectM+  {-# INLINE select #-}++{- |+>>> import Control.Lens(view, _Wrapped')+>>> import Data.Profunctor(Profunctor(dimap, lmap, rmap))+>>> let v = ValidatorMonadProfunctorT (\x -> ValidationMonadT (Identity (Success (x + 1)))) :: ValidatorMonadProfunctorT [String] Identity Int Int+>>> let ValidationMonadT (Identity r) = view _Wrapped' (dimap (+10) (*2) v) 3+>>> r+Success 28++>>> let ValidationMonadT (Identity r) = view _Wrapped' (lmap (+10) v) 3+>>> r+Success 14++>>> let ValidationMonadT (Identity r) = view _Wrapped' (rmap (*2) v) 3+>>> r+Success 8+-}+instance (Functor f) => Profunctor (ValidatorMonadProfunctorT err f) where+  dimap f g (ValidatorMonadProfunctorT h) = ValidatorMonadProfunctorT (fmap g . h . f)+  {-# INLINE dimap #-}+  lmap f (ValidatorMonadProfunctorT h) = ValidatorMonadProfunctorT (h . f)+  {-# INLINE lmap #-}+  rmap g (ValidatorMonadProfunctorT h) = ValidatorMonadProfunctorT (fmap g . h)+  {-# INLINE rmap #-}++{- |+>>> import Control.Lens(view, _Wrapped')+>>> import Data.Profunctor(Strong(first'))+>>> let v = ValidatorMonadProfunctorT (\x -> ValidationMonadT (Identity (Success (x + 1)))) :: ValidatorMonadProfunctorT [String] Identity Int Int+>>> let ValidationMonadT (Identity r) = view _Wrapped' (first' v) (3, "tag")+>>> r+Success (4,"tag")+-}+instance (Functor f) => Strong (ValidatorMonadProfunctorT err f) where+  first' (ValidatorMonadProfunctorT f) = ValidatorMonadProfunctorT (\(a, c) -> fmap (,c) (f a))+  {-# INLINE first' #-}+  second' (ValidatorMonadProfunctorT f) = ValidatorMonadProfunctorT (\(c, a) -> fmap (c,) (f a))+  {-# INLINE second' #-}++{- |+>>> import Control.Lens(view, _Wrapped')+>>> import Data.Profunctor(Choice(left'))+>>> let v = ValidatorMonadProfunctorT (\x -> ValidationMonadT (Identity (Success (x + 1)))) :: ValidatorMonadProfunctorT [String] Identity Int Int+>>> let ValidationMonadT (Identity r) = view _Wrapped' (left' v) (Left 3 :: Either Int String)+>>> r+Success (Left 4)++>>> let ValidationMonadT (Identity r) = view _Wrapped' (left' v) (Right "x" :: Either Int String)+>>> r+Success (Right "x")+-}+instance (Monad f) => Choice (ValidatorMonadProfunctorT err f) where+  left' (ValidatorMonadProfunctorT f) = ValidatorMonadProfunctorT (either (fmap Left . f) (pure . Right))+  {-# INLINE left' #-}+  right' (ValidatorMonadProfunctorT f) = ValidatorMonadProfunctorT (either (pure . Left) (fmap Right . f))+  {-# INLINE right' #-}++{- |+>>> import Control.Lens(view, _Wrapped')+>>> let v = ValidatorMonadProfunctorT (\x -> ValidationMonadT (Identity (Success (x + 1)))) :: ValidatorMonadProfunctorT [String] Identity Int Int+>>> let ValidationMonadT (Identity r) = view _Wrapped' (traverse' v) [1, 2, 3]+>>> r+Success [2,3,4]+-}+instance (Monad f) => Traversing (ValidatorMonadProfunctorT err f) where+  traverse' (ValidatorMonadProfunctorT f) = ValidatorMonadProfunctorT (traverse f)+  {-# INLINE traverse' #-}+  wander t (ValidatorMonadProfunctorT f) = ValidatorMonadProfunctorT (t f)+  {-# INLINE wander #-}++{- |+>>> import Data.Profunctor.Sieve(Sieve(sieve))+>>> let v = ValidatorMonadProfunctorT (\x -> ValidationMonadT (Identity (Success (x + 1)))) :: ValidatorMonadProfunctorT [String] Identity Int Int+>>> let ValidationMonadT (Identity r) = sieve v 3+>>> r+Success 4+-}+instance (Functor f) => Sieve (ValidatorMonadProfunctorT err f) (ValidationMonadT err f) where+  sieve (ValidatorMonadProfunctorT f) = f+  {-# INLINE sieve #-}++{- | Kleisli-like composition, short-circuiting on failure.++>>> import Control.Lens(view, _Wrapped')+>>> import Data.Semigroupoid(Semigroupoid(o))+>>> let v1 = ValidatorMonadProfunctorT (\x -> ValidationMonadT (Identity (Success (x + 1)))) :: ValidatorMonadProfunctorT [String] Identity Int Int+>>> let v2 = ValidatorMonadProfunctorT (\x -> ValidationMonadT (Identity (Success (x * 2)))) :: ValidatorMonadProfunctorT [String] Identity Int Int+>>> let ValidationMonadT (Identity r) = view _Wrapped' (v2 `o` v1) 3+>>> r+Success 8+-}+instance (Monad f) => Semigroupoid (ValidatorMonadProfunctorT err f) where+  ValidatorMonadProfunctorT f `o` ValidatorMonadProfunctorT g = ValidatorMonadProfunctorT (g >=> f)+  {-# INLINE o #-}++{- |+>>> import Control.Lens(view, _Wrapped')+>>> import Control.Category(id, (.))+>>> import Prelude hiding (id, (.))+>>> let v1 = ValidatorMonadProfunctorT (\x -> ValidationMonadT (Identity (Success (x + 1)))) :: ValidatorMonadProfunctorT [String] Identity Int Int+>>> let v2 = ValidatorMonadProfunctorT (\x -> ValidationMonadT (Identity (Success (x * 2)))) :: ValidatorMonadProfunctorT [String] Identity Int Int+>>> let ValidationMonadT (Identity r) = view _Wrapped' (v2 . v1) 3+>>> r+Success 8+-}+instance (Monad f) => Category (ValidatorMonadProfunctorT err f) where+  id = ValidatorMonadProfunctorT pure+  {-# INLINE id #-}+  ValidatorMonadProfunctorT f . ValidatorMonadProfunctorT g = ValidatorMonadProfunctorT (g >=> f)+  {-# INLINE (.) #-}++{- |+>>> import Control.Lens(view, _Wrapped')+>>> import Control.Arrow(Arrow(arr))+>>> import Control.Category((.))+>>> import Prelude hiding ((.))+>>> let ValidationMonadT (Identity r) = view _Wrapped' (arr (+1) :: ValidatorMonadProfunctorT [String] Identity Int Int) 3+>>> r+Success 4+-}+instance (Monad f) => Arrow (ValidatorMonadProfunctorT err f) where+  arr f = ValidatorMonadProfunctorT (pure . f)+  {-# INLINE arr #-}+  first (ValidatorMonadProfunctorT f) = ValidatorMonadProfunctorT (\(a, c) -> fmap (,c) (f a))+  {-# INLINE first #-}++{- |+>>> import Control.Lens(view, _Wrapped')+>>> import Control.Arrow(ArrowApply(app))+>>> import Control.Category((.))+>>> import Prelude hiding ((.))+>>> let v = ValidatorMonadProfunctorT (\x -> ValidationMonadT (Identity (Success (x + 1)))) :: ValidatorMonadProfunctorT [String] Identity Int Int+>>> let ValidationMonadT (Identity r) = view _Wrapped' (app :: ValidatorMonadProfunctorT [String] Identity (ValidatorMonadProfunctorT [String] Identity Int Int, Int) Int) (v, 3)+>>> r+Success 4+-}+instance (Monad f) => ArrowApply (ValidatorMonadProfunctorT err f) where+  app = ValidatorMonadProfunctorT (\(ValidatorMonadProfunctorT f, x) -> f x)+  {-# INLINE app #-}++{- |+>>> import Control.Lens(view, _Wrapped')+>>> import Control.Arrow(ArrowChoice(left))+>>> import Control.Category((.))+>>> import Prelude hiding ((.))+>>> let v = ValidatorMonadProfunctorT (\x -> ValidationMonadT (Identity (Success (x + 1)))) :: ValidatorMonadProfunctorT [String] Identity Int Int+>>> let ValidationMonadT (Identity r) = view _Wrapped' (left v) (Left 3 :: Either Int String)+>>> r+Success (Left 4)+-}+instance (Monad f) => ArrowChoice (ValidatorMonadProfunctorT err f) where+  left (ValidatorMonadProfunctorT f) = ValidatorMonadProfunctorT (either (fmap Left . f) (pure . Right))+  {-# INLINE left #-}+  right (ValidatorMonadProfunctorT f) = ValidatorMonadProfunctorT (either (pure . Left) (fmap Right . f))+  {-# INLINE right #-}++{- |+>>> import Control.Lens(view, _Wrapped')+>>> import Control.Arrow(ArrowZero(zeroArrow))+>>> import Control.Category((.))+>>> import Prelude hiding ((.))+>>> let ValidationMonadT (Identity r) = view _Wrapped' (zeroArrow :: ValidatorMonadProfunctorT [String] Identity Int Int) 3+>>> r+Failure []+-}+instance (Monad f, Monoid err) => ArrowZero (ValidatorMonadProfunctorT err f) where+  zeroArrow = ValidatorMonadProfunctorT (const zero)+  {-# INLINE zeroArrow #-}++{- |+>>> import Control.Lens(view, _Wrapped')+>>> import Data.Functor.Alt(Alt((<!>)))+>>> import Control.Arrow(ArrowPlus((<+>)))+>>> import Control.Category((.))+>>> import Prelude hiding ((.))+>>> let v1 = ValidatorMonadProfunctorT (\_ -> ValidationMonadT (Identity (Failure ["e1"]))) :: ValidatorMonadProfunctorT [String] Identity Int Int+>>> let v2 = ValidatorMonadProfunctorT (\x -> ValidationMonadT (Identity (Success (x * 2)))) :: ValidatorMonadProfunctorT [String] Identity Int Int+>>> let ValidationMonadT (Identity r) = view _Wrapped' (v1 <+> v2) 3+>>> r+Success 6+-}+instance (Monad f, Monoid err) => ArrowPlus (ValidatorMonadProfunctorT err f) where+  ValidatorMonadProfunctorT f <+> ValidatorMonadProfunctorT g = ValidatorMonadProfunctorT (\x -> f x <!> g x)+  {-# INLINE (<+>) #-}++{- | Like 'Validation', a failure is kept: for each input, the result fails+where the validator fails, and otherwise succeeds with @f@ applied to the validator.+The effects of the validator are run.++>>> import Control.Lens(view, _Wrapped')+>>> import Data.Functor.Extend(Extend(extended))+>>> let v = ValidatorMonadProfunctorT (\x -> ValidationMonadT (Identity (Success (x + 1)))) :: ValidatorMonadProfunctorT [String] Identity Int Int+>>> let ValidationMonadT (Identity r) = view _Wrapped' (extended (\_ -> 99) v) 3+>>> r+Success 99++>>> let e = ValidatorMonadProfunctorT (\_ -> ValidationMonadT (Identity (Failure ["e"]))) :: ValidatorMonadProfunctorT [String] Identity Int Int+>>> let ValidationMonadT (Identity r) = view _Wrapped' (extended (\_ -> 99) e) 3+>>> r+Failure ["e"]+-}+instance (Functor f) => Extend (ValidatorMonadProfunctorT err f x) where+  extended f w@(ValidatorMonadProfunctorT g) = ValidatorMonadProfunctorT (\x -> f w <$ g x)+  {-# INLINE extended #-}++{- |+>>> import Control.Lens(view, _Wrapped')+>>> let v1 = ValidatorMonadProfunctorT (\_ -> ValidationMonadT (Identity (Success 1))) :: ValidatorMonadProfunctorT [String] Identity Int Int+>>> let v2 = ValidatorMonadProfunctorT (\_ -> ValidationMonadT (Identity (Success 2))) :: ValidatorMonadProfunctorT [String] Identity Int Int+>>> let ValidationMonadT (Identity r) = view _Wrapped' (v1 <> v2) 0+>>> r+Success 1+-}+instance (Applicative f, Semigroup err) => Semigroup (ValidatorMonadProfunctorT err f x a) where+  ValidatorMonadProfunctorT f <> ValidatorMonadProfunctorT g = ValidatorMonadProfunctorT (\x -> f x <> g x)+  {-# INLINE (<>) #-}++{- |+>>> import Control.Lens(view, _Wrapped')+>>> let ValidationMonadT (Identity r) = view _Wrapped' (mempty :: ValidatorMonadProfunctorT [String] Identity Int Int) 0+>>> r+Failure []+-}+instance (Applicative f, Monoid err) => Monoid (ValidatorMonadProfunctorT err f x a) where+  mempty = ValidatorMonadProfunctorT (const mempty)+  {-# INLINE mempty #-}++instance (MonadFail f) => MonadFail (ValidatorMonadProfunctorT err f x) where+  fail = ValidatorMonadProfunctorT . const . liftValidationMonadT . Prelude.fail+  {-# INLINE fail #-}++{- |+>>> import Control.Lens(view, _Wrapped')+>>> import Control.Monad.Error.Class(MonadError(throwError, catchError))+>>> let ValidationMonadT (Identity r) = view _Wrapped' (throwError ["oops"] :: ValidatorMonadProfunctorT [String] Identity Int Int) 3+>>> r+Failure ["oops"]++>>> let v = ValidatorMonadProfunctorT (\_ -> ValidationMonadT (Identity (Failure ["e1"]))) :: ValidatorMonadProfunctorT [String] Identity Int Int+>>> let h _ = ValidatorMonadProfunctorT (\x -> ValidationMonadT (Identity (Success (x * 2)))) :: ValidatorMonadProfunctorT [String] Identity Int Int+>>> let ValidationMonadT (Identity r) = view _Wrapped' (catchError v h) 3+>>> r+Success 6+-}+instance (Monad f) => MonadError err (ValidatorMonadProfunctorT err f x) where+  throwError e = ValidatorMonadProfunctorT (\_ -> throwError e)+  {-# INLINE throwError #-}+  catchError (ValidatorMonadProfunctorT f) h = ValidatorMonadProfunctorT (\x -> catchError (f x) (\e -> let ValidatorMonadProfunctorT g = h e in g x))+  {-# INLINE catchError #-}++instance (MonadIO f) => MonadIO (ValidatorMonadProfunctorT err f x) where+  liftIO = ValidatorMonadProfunctorT . const . liftValidationMonadT . liftIO+  {-# INLINE liftIO #-}++instance (MonadReader r f) => MonadReader r (ValidatorMonadProfunctorT err f x) where+  ask = ValidatorMonadProfunctorT (\_ -> liftValidationMonadT ask)+  {-# INLINE ask #-}+  local f (ValidatorMonadProfunctorT g) = ValidatorMonadProfunctorT (local f . g)+  {-# INLINE local #-}+  reader = ValidatorMonadProfunctorT . const . liftValidationMonadT . reader+  {-# INLINE reader #-}++instance (MonadWriter w f) => MonadWriter w (ValidatorMonadProfunctorT err f x) where+  writer = ValidatorMonadProfunctorT . const . liftValidationMonadT . writer+  {-# INLINE writer #-}+  tell = ValidatorMonadProfunctorT . const . liftValidationMonadT . tell+  {-# INLINE tell #-}+  listen (ValidatorMonadProfunctorT f) = ValidatorMonadProfunctorT (listen . f)+  {-# INLINE listen #-}+  pass (ValidatorMonadProfunctorT f) = ValidatorMonadProfunctorT (pass . f)+  {-# INLINE pass #-}++instance (MonadState s f) => MonadState s (ValidatorMonadProfunctorT err f x) where+  get = ValidatorMonadProfunctorT (\_ -> liftValidationMonadT get)+  {-# INLINE get #-}+  put = ValidatorMonadProfunctorT . const . liftValidationMonadT . put+  {-# INLINE put #-}+  state = ValidatorMonadProfunctorT . const . liftValidationMonadT . state+  {-# INLINE state #-}++instance (MonadCont f) => MonadCont (ValidatorMonadProfunctorT err f x) where+  callCC f = ValidatorMonadProfunctorT (\x -> callCC (\c -> let ValidatorMonadProfunctorT g = f (\a -> ValidatorMonadProfunctorT (\_ -> c a)) in g x))+  {-# INLINE callCC #-}++instance (MonadRWS r w s f) => MonadRWS r w s (ValidatorMonadProfunctorT err f x)++-- | Class for types that have a 'Getter' to a 'ValidatorMonadProfunctorT'.+class GetValidatorMonadProfunctorT s err f x a | s -> err f x a where+  getValidatorMonadProfunctorT :: Getter s (ValidatorMonadProfunctorT err f x a)++instance GetValidatorMonadProfunctorT (ValidatorMonadProfunctorT err f x a) err f x a where+  getValidatorMonadProfunctorT = id+  {-# INLINE getValidatorMonadProfunctorT #-}++-- | Class for types that have a 'Lens'' to a 'ValidatorMonadProfunctorT'.+class (GetValidatorMonadProfunctorT s err f x a) => HasValidatorMonadProfunctorT s err f x a | s -> err f x a where+  validatorMonadProfunctorT :: Lens' s (ValidatorMonadProfunctorT err f x a)++instance HasValidatorMonadProfunctorT (ValidatorMonadProfunctorT err f x a) err f x a where+  validatorMonadProfunctorT = id+  {-# INLINE validatorMonadProfunctorT #-}++-- | Class for types that have a 'Review' to a 'ValidatorMonadProfunctorT'.+class ReviewValidatorMonadProfunctorT s err f x a | s -> err f x a where+  reviewValidatorMonadProfunctorT :: Review s (ValidatorMonadProfunctorT err f x a)++instance ReviewValidatorMonadProfunctorT (ValidatorMonadProfunctorT err f x a) err f x a where+  reviewValidatorMonadProfunctorT = id+  {-# INLINE reviewValidatorMonadProfunctorT #-}++-- | Class for types that have a 'Prism'' to a 'ValidatorMonadProfunctorT'.+class (ReviewValidatorMonadProfunctorT s err f x a) => AsValidatorMonadProfunctorT s err f x a | s -> err f x a where+  _ValidatorMonadProfunctorT :: Prism' s (ValidatorMonadProfunctorT err f x a)++instance AsValidatorMonadProfunctorT (ValidatorMonadProfunctorT err f x a) err f x a where+  _ValidatorMonadProfunctorT = id+  {-# INLINE _ValidatorMonadProfunctorT #-}++-- =============================+-- Cross-type optics instances+-- =============================++-- Isomorphisms between the validator types, used by the cross-type instances.++validatorToProfunctor :: Iso' (Validator x err a) (ValidatorProfunctor err x a)+validatorToProfunctor = iso (\(Validator f) -> ValidatorProfunctor f) (\(ValidatorProfunctor f) -> Validator f)+{-# INLINE validatorToProfunctor #-}++monadToMonadProfunctor :: Iso' (ValidatorMonadT x err f a) (ValidatorMonadProfunctorT err f x a)+monadToMonadProfunctor = iso (\(ValidatorMonadT f) -> ValidatorMonadProfunctorT f) (\(ValidatorMonadProfunctorT f) -> ValidatorMonadT f)+{-# INLINE monadToMonadProfunctor #-}++validatorToMonad :: Iso' (Validator x err a) (ValidatorMonad x err a)+validatorToMonad = iso (\(Validator f) -> ValidatorMonadT (view validationMonad . f)) (\(ValidatorMonadT f) -> Validator (review validationMonad . f))+{-# INLINE validatorToMonad #-}++validatorToMonadProfunctor :: Iso' (Validator x err a) (ValidatorMonadProfunctor err x a)+validatorToMonadProfunctor = validatorToMonad . monadToMonadProfunctor+{-# INLINE validatorToMonadProfunctor #-}++profunctorToMonad :: Iso' (ValidatorProfunctor err x a) (ValidatorMonad x err a)+profunctorToMonad = from validatorToProfunctor . validatorToMonad+{-# INLINE profunctorToMonad #-}++profunctorToMonadProfunctor :: Iso' (ValidatorProfunctor err x a) (ValidatorMonadProfunctor err x a)+profunctorToMonadProfunctor = from validatorToProfunctor . validatorToMonadProfunctor+{-# INLINE profunctorToMonadProfunctor #-}++-- Cross-type optics: Validator <-> ValidatorProfunctor++instance GetValidator (ValidatorProfunctor err x a) x err a where+  getValidator = from validatorToProfunctor+  {-# INLINE getValidator #-}++instance HasValidator (ValidatorProfunctor err x a) x err a where+  validator = from validatorToProfunctor+  {-# INLINE validator #-}++instance ReviewValidator (ValidatorProfunctor err x a) x err a where+  reviewValidator = from validatorToProfunctor+  {-# INLINE reviewValidator #-}++instance AsValidator (ValidatorProfunctor err x a) x err a where+  _Validator = from validatorToProfunctor+  {-# INLINE _Validator #-}++instance GetValidatorProfunctor (Validator x err a) err x a where+  getValidatorProfunctor = validatorToProfunctor+  {-# INLINE getValidatorProfunctor #-}++instance HasValidatorProfunctor (Validator x err a) err x a where+  validatorProfunctor = validatorToProfunctor+  {-# INLINE validatorProfunctor #-}++instance ReviewValidatorProfunctor (Validator x err a) err x a where+  reviewValidatorProfunctor = validatorToProfunctor+  {-# INLINE reviewValidatorProfunctor #-}++instance AsValidatorProfunctor (Validator x err a) err x a where+  _ValidatorProfunctor = validatorToProfunctor+  {-# INLINE _ValidatorProfunctor #-}++-- Cross-type optics: ValidatorMonadT <-> ValidatorMonadProfunctorT++instance GetValidatorMonadT (ValidatorMonadProfunctorT err f x a) x err f a where+  getValidatorMonadT = from monadToMonadProfunctor+  {-# INLINE getValidatorMonadT #-}++instance HasValidatorMonadT (ValidatorMonadProfunctorT err f x a) x err f a where+  validatorMonadT = from monadToMonadProfunctor+  {-# INLINE validatorMonadT #-}++instance ReviewValidatorMonadT (ValidatorMonadProfunctorT err f x a) x err f a where+  reviewValidatorMonadT = from monadToMonadProfunctor+  {-# INLINE reviewValidatorMonadT #-}++instance AsValidatorMonadT (ValidatorMonadProfunctorT err f x a) x err f a where+  _ValidatorMonadT = from monadToMonadProfunctor+  {-# INLINE _ValidatorMonadT #-}++instance GetValidatorMonadProfunctorT (ValidatorMonadT x err f a) err f x a where+  getValidatorMonadProfunctorT = monadToMonadProfunctor+  {-# INLINE getValidatorMonadProfunctorT #-}++instance HasValidatorMonadProfunctorT (ValidatorMonadT x err f a) err f x a where+  validatorMonadProfunctorT = monadToMonadProfunctor+  {-# INLINE validatorMonadProfunctorT #-}++instance ReviewValidatorMonadProfunctorT (ValidatorMonadT x err f a) err f x a where+  reviewValidatorMonadProfunctorT = monadToMonadProfunctor+  {-# INLINE reviewValidatorMonadProfunctorT #-}++instance AsValidatorMonadProfunctorT (ValidatorMonadT x err f a) err f x a where+  _ValidatorMonadProfunctorT = monadToMonadProfunctor+  {-# INLINE _ValidatorMonadProfunctorT #-}++-- Cross-type optics: Validator <-> ValidatorMonadT (f ~ Identity)++instance GetValidator (ValidatorMonadT x err Identity a) x err a where+  getValidator = from validatorToMonad+  {-# INLINE getValidator #-}++instance HasValidator (ValidatorMonadT x err Identity a) x err a where+  validator = from validatorToMonad+  {-# INLINE validator #-}++instance (Applicative f) => ReviewValidator (ValidatorMonadT x err f a) x err a where+  reviewValidator = unto (\(Validator f) -> ValidatorMonadT (ValidationMonadT . pure . f))+  {-# INLINE reviewValidator #-}++instance AsValidator (ValidatorMonadT x err Identity a) x err a where+  _Validator = from validatorToMonad+  {-# INLINE _Validator #-}++instance GetValidatorMonadT (Validator x err a) x err Identity a where+  getValidatorMonadT = validatorToMonad+  {-# INLINE getValidatorMonadT #-}++instance HasValidatorMonadT (Validator x err a) x err Identity a where+  validatorMonadT = validatorToMonad+  {-# INLINE validatorMonadT #-}++instance ReviewValidatorMonadT (Validator x err a) x err Identity a where+  reviewValidatorMonadT = validatorToMonad+  {-# INLINE reviewValidatorMonadT #-}++instance AsValidatorMonadT (Validator x err a) x err Identity a where+  _ValidatorMonadT = validatorToMonad+  {-# INLINE _ValidatorMonadT #-}++-- Cross-type optics: ValidatorProfunctor <-> ValidatorMonadProfunctorT (f ~ Identity)++instance GetValidatorProfunctor (ValidatorMonadProfunctorT err Identity x a) err x a where+  getValidatorProfunctor = from profunctorToMonadProfunctor+  {-# INLINE getValidatorProfunctor #-}++instance HasValidatorProfunctor (ValidatorMonadProfunctorT err Identity x a) err x a where+  validatorProfunctor = from profunctorToMonadProfunctor+  {-# INLINE validatorProfunctor #-}++instance (Applicative f) => ReviewValidatorProfunctor (ValidatorMonadProfunctorT err f x a) err x a where+  reviewValidatorProfunctor = unto (\(ValidatorProfunctor f) -> ValidatorMonadProfunctorT (ValidationMonadT . pure . f))+  {-# INLINE reviewValidatorProfunctor #-}++instance AsValidatorProfunctor (ValidatorMonadProfunctorT err Identity x a) err x a where+  _ValidatorProfunctor = from profunctorToMonadProfunctor+  {-# INLINE _ValidatorProfunctor #-}++instance GetValidatorMonadProfunctorT (ValidatorProfunctor err x a) err Identity x a where+  getValidatorMonadProfunctorT = profunctorToMonadProfunctor+  {-# INLINE getValidatorMonadProfunctorT #-}++instance HasValidatorMonadProfunctorT (ValidatorProfunctor err x a) err Identity x a where+  validatorMonadProfunctorT = profunctorToMonadProfunctor+  {-# INLINE validatorMonadProfunctorT #-}++instance ReviewValidatorMonadProfunctorT (ValidatorProfunctor err x a) err Identity x a where+  reviewValidatorMonadProfunctorT = profunctorToMonadProfunctor+  {-# INLINE reviewValidatorMonadProfunctorT #-}++instance AsValidatorMonadProfunctorT (ValidatorProfunctor err x a) err Identity x a where+  _ValidatorMonadProfunctorT = profunctorToMonadProfunctor+  {-# INLINE _ValidatorMonadProfunctorT #-}++-- Cross-type optics: Validator <-> ValidatorMonadProfunctorT (f ~ Identity)++instance GetValidator (ValidatorMonadProfunctorT err Identity x a) x err a where+  getValidator = from validatorToMonadProfunctor+  {-# INLINE getValidator #-}++instance HasValidator (ValidatorMonadProfunctorT err Identity x a) x err a where+  validator = from validatorToMonadProfunctor+  {-# INLINE validator #-}++instance (Applicative f) => ReviewValidator (ValidatorMonadProfunctorT err f x a) x err a where+  reviewValidator = unto (\(Validator f) -> ValidatorMonadProfunctorT (ValidationMonadT . pure . f))+  {-# INLINE reviewValidator #-}++instance AsValidator (ValidatorMonadProfunctorT err Identity x a) x err a where+  _Validator = from validatorToMonadProfunctor+  {-# INLINE _Validator #-}++instance GetValidatorMonadProfunctorT (Validator x err a) err Identity x a where+  getValidatorMonadProfunctorT = validatorToMonadProfunctor+  {-# INLINE getValidatorMonadProfunctorT #-}++instance HasValidatorMonadProfunctorT (Validator x err a) err Identity x a where+  validatorMonadProfunctorT = validatorToMonadProfunctor+  {-# INLINE validatorMonadProfunctorT #-}++instance ReviewValidatorMonadProfunctorT (Validator x err a) err Identity x a where+  reviewValidatorMonadProfunctorT = validatorToMonadProfunctor+  {-# INLINE reviewValidatorMonadProfunctorT #-}++instance AsValidatorMonadProfunctorT (Validator x err a) err Identity x a where+  _ValidatorMonadProfunctorT = validatorToMonadProfunctor+  {-# INLINE _ValidatorMonadProfunctorT #-}++-- Cross-type optics: ValidatorProfunctor <-> ValidatorMonadT (f ~ Identity)++instance GetValidatorProfunctor (ValidatorMonadT x err Identity a) err x a where+  getValidatorProfunctor = from profunctorToMonad+  {-# INLINE getValidatorProfunctor #-}++instance HasValidatorProfunctor (ValidatorMonadT x err Identity a) err x a where+  validatorProfunctor = from profunctorToMonad+  {-# INLINE validatorProfunctor #-}++instance (Applicative f) => ReviewValidatorProfunctor (ValidatorMonadT x err f a) err x a where+  reviewValidatorProfunctor = unto (\(ValidatorProfunctor f) -> ValidatorMonadT (ValidationMonadT . pure . f))+  {-# INLINE reviewValidatorProfunctor #-}++instance AsValidatorProfunctor (ValidatorMonadT x err Identity a) err x a where+  _ValidatorProfunctor = from profunctorToMonad+  {-# INLINE _ValidatorProfunctor #-}++instance GetValidatorMonadT (ValidatorProfunctor err x a) x err Identity a where+  getValidatorMonadT = profunctorToMonad+  {-# INLINE getValidatorMonadT #-}++instance HasValidatorMonadT (ValidatorProfunctor err x a) x err Identity a where+  validatorMonadT = profunctorToMonad+  {-# INLINE validatorMonadT #-}++instance ReviewValidatorMonadT (ValidatorProfunctor err x a) x err Identity a where+  reviewValidatorMonadT = profunctorToMonad+  {-# INLINE reviewValidatorMonadT #-}++instance AsValidatorMonadT (ValidatorProfunctor err x a) x err Identity a where+  _ValidatorMonadT = profunctorToMonad+  {-# INLINE _ValidatorMonadT #-}++-- ==================================+-- Constructing validators from prisms+-- ==================================++{- | Construct a validator from a prism, mapping the focus with a function.+The validator succeeds with the function applied to the focus of the prism+when it matches, and otherwise fails with the input, retyped to @t@ (see+'Control.Lens.matching').++@p --> f@ is @f '<$>' 'match' p@, and @'match' p@ is @p --> 'id'@. As with+'match', the result can be any validator with a 'ReviewValidator' instance.++>>> runV (_Just --> (+ 1) :: Validator (Maybe Int) (Maybe Int) Int) (Just 1)+Success 2++>>> runV (_Just --> (+ 1) :: Validator (Maybe Int) (Maybe Int) Int) Nothing+Failure Nothing++'-->' is @infixl 6@. It binds more loosely than '.', so prisms compose+without parentheses, and more tightly than '<!>', so a validator can be+written as one case per constructor. The first case that matches wins, and+the input is returned as the failure if none match.++>>> let v = _Left --> length <!> _Right . _Just --> negate :: Validator (Either String (Maybe Int)) (Either String (Maybe Int)) Int+>>> runV v (Left "abc")+Success 3++>>> runV v (Right (Just 5))+Success (-5)++>>> runV v (Right Nothing)+Failure (Right Nothing)++The other validators are written the same way. Their '<!>' accumulates+errors, which requires the input type to be a 'Semigroup' (here 'Either').++>>> let v = _Left --> length <!> _Right . _Just --> negate :: ValidatorProfunctor (Either String (Maybe Int)) (Either String (Maybe Int)) Int+>>> runVP v (Right (Just 5))+Success (-5)++>>> runVP v (Right Nothing)+Failure (Right Nothing)++>>> let v = _Left --> length <!> _Right . _Just --> negate :: ValidatorMonad (Either String (Maybe Int)) (Either String (Maybe Int)) Int+>>> runVM v (Right (Just 5))+Success (-5)++>>> runVM v (Right Nothing)+Failure (Right Nothing)++>>> let v = _Left --> length <!> _Right . _Just --> negate :: ValidatorMonadProfunctor (Either String (Maybe Int)) (Either String (Maybe Int)) Int+>>> runVMP v (Right (Just 5))+Success (-5)++>>> runVMP v (Right Nothing)+Failure (Right Nothing)+-}+(-->) :: (ReviewValidator r s t a') => APrism s t a b -> (a -> a') -> r+(-->) p f = review reviewValidator (f <$> Validator (review Validation.either . matching p))+{-# INLINE (-->) #-}+{-# SPECIALIZE (-->) :: APrism s t a b -> (a -> a') -> Validator s t a' #-}+{-# SPECIALIZE (-->) :: APrism s t a b -> (a -> a') -> ValidatorProfunctor t s a' #-}+{-# SPECIALIZE (-->) :: APrism s t a b -> (a -> a') -> ValidatorMonad s t a' #-}+{-# SPECIALIZE (-->) :: APrism s t a b -> (a -> a') -> ValidatorMonadProfunctor t s a' #-}++infixl 6 -->++{- | Construct a validator from a prism. The validator succeeds with the+focus of the prism when it matches, and otherwise fails with the input,+retyped to @t@ (see 'Control.Lens.matching').++The result can be any validator with a 'ReviewValidator' instance, which+determines the validator type from the result type. @match p@ is+@p '-->' 'id'@.++>>> let Validator f = match _Just :: Validator (Maybe Int) (Maybe Int) Int+>>> f (Just 3)+Success 3++>>> f Nothing+Failure Nothing++A type-changing prism fails with the retyped input.++>>> let Validator f = match _Left :: Validator (Either Int String) (Either Bool String) Int+>>> f (Left 1)+Success 1++>>> f (Right "x")+Failure (Right "x")++Match each constructor with its own prism, and combine the validators with+'<!>'. The first prism that matches wins, and the input is returned as the+failure if none match. The result type annotation chooses the validator; the+specialisations 'matchValidator', 'matchValidatorProfunctor',+'matchValidatorMonad' and 'matchValidatorMonadProfunctor' avoid it.++>>> let v = match _Left <!> (show <$> match (_Right . _Just)) :: Validator (Either String (Maybe Int)) (Either String (Maybe Int)) String+>>> runV v (Left "abc")+Success "abc"++>>> runV v (Right (Just 5))+Success "5"++>>> runV v (Right Nothing)+Failure (Right Nothing)++'ValidatorProfunctor' and 'ValidatorMonadProfunctorT' take the error type first.++>>> let v = match _Left <!> (show <$> match (_Right . _Just)) :: ValidatorProfunctor (Either String (Maybe Int)) (Either String (Maybe Int)) String+>>> runVP v (Right (Just 5))+Success "5"++>>> runVP v (Right Nothing)+Failure (Right Nothing)++>>> let v = match _Left <!> (show <$> match (_Right . _Just)) :: ValidatorMonad (Either String (Maybe Int)) (Either String (Maybe Int)) String+>>> runVM v (Right (Just 5))+Success "5"++>>> runVM v (Right Nothing)+Failure (Right Nothing)++>>> let v = match _Left <!> (show <$> match (_Right . _Just)) :: ValidatorMonadProfunctor (Either String (Maybe Int)) (Either String (Maybe Int)) String+>>> runVMP v (Right (Just 5))+Success "5"++>>> runVMP v (Right Nothing)+Failure (Right Nothing)++The monadic validators work with any 'Applicative'.++>>> let ValidatorMonadT f = match _Just :: ValidatorMonadT (Maybe Int) (Maybe Int) [] Int+>>> let ValidationMonadT r = f (Just 3) in r+[Success 3]++>>> let ValidatorMonadProfunctorT f = match _Just :: ValidatorMonadProfunctorT (Maybe Int) Maybe (Maybe Int) Int+>>> let ValidationMonadT r = f Nothing in r+Just (Failure Nothing)+-}+match :: (ReviewValidator r s t a) => APrism s t a b -> r+match p = p --> id+{-# INLINE match #-}+{-# SPECIALIZE match :: APrism s t a b -> Validator s t a #-}+{-# SPECIALIZE match :: APrism s t a b -> ValidatorProfunctor t s a #-}+{-# SPECIALIZE match :: APrism s t a b -> ValidatorMonad s t a #-}+{-# SPECIALIZE match :: APrism s t a b -> ValidatorMonadProfunctor t s a #-}++{- | 'match' specialised to 'Validator', so no type annotation is needed.++Combine one prism per constructor with '<!>'. 'Validator' does not accumulate+errors, so the input type need not be a 'Semigroup'; if no prism matches, the+last failure is returned.++>>> let v = matchValidator _Left <!> (show <$> matchValidator (_Right . _Just))+>>> runV v (Left "abc")+Success "abc"++>>> runV v (Right (Just 5))+Success "5"++>>> runV v (Right (Nothing :: Maybe Int))+Failure (Right Nothing)++>>> runV (matchValidator _Just) (Nothing :: Maybe Int)+Failure Nothing+-}+matchValidator :: APrism s t a b -> Validator s t a+matchValidator = match+{-# INLINE matchValidator #-}++{- | 'match' specialised to 'ValidatorProfunctor', so no type annotation is needed.++The input type is also the error type, and '<!>' accumulates errors, so+combining with '<!>' requires the input type to be a 'Semigroup' (here+'Either').++>>> let v = matchValidatorProfunctor _Left <!> (show <$> matchValidatorProfunctor (_Right . _Just))+>>> runVP v (Left "abc")+Success "abc"++>>> runVP v (Right (Just 5))+Success "5"++>>> runVP v (Right (Nothing :: Maybe Int))+Failure (Right Nothing)++The input can be adapted with 'lmap'.++>>> runVP (lmap Just (matchValidatorProfunctor _Just)) (3 :: Int)+Success 3+-}+matchValidatorProfunctor :: APrism s t a b -> ValidatorProfunctor t s a+matchValidatorProfunctor = match+{-# INLINE matchValidatorProfunctor #-}++{- | 'match' specialised to 'ValidatorMonad', so no type annotation is needed.++Combining with '<!>' requires the input type to be a 'Semigroup' (here+'Either'). The 'Monad' instance short-circuits, so a match can decide the+next validator.++>>> let v = matchValidatorMonad _Left <!> (show <$> matchValidatorMonad (_Right . _Just))+>>> runVM v (Left "abc")+Success "abc"++>>> runVM v (Right (Just 5))+Success "5"++>>> runVM v (Right (Nothing :: Maybe Int))+Failure (Right Nothing)++>>> let w = matchValidatorMonad _Just >>= \n -> if n > (0 :: Int) then pure n else throwError (Just n)+>>> runVM w (Just 3)+Success 3++>>> runVM w (Just (-3))+Failure (Just (-3))++>>> runVM w Nothing+Failure Nothing+-}+matchValidatorMonad :: APrism s t a b -> ValidatorMonad s t a+matchValidatorMonad = match+{-# INLINE matchValidatorMonad #-}++{- | 'match' specialised to 'ValidatorMonadProfunctor', so no type annotation is needed.++Combining with '<!>' requires the input type to be a 'Semigroup' (here+'Either').++>>> let v = matchValidatorMonadProfunctor _Left <!> (show <$> matchValidatorMonadProfunctor (_Right . _Just))+>>> runVMP v (Left "abc")+Success "abc"++>>> runVMP v (Right (Just 5))+Success "5"++>>> runVMP v (Right (Nothing :: Maybe Int))+Failure (Right Nothing)+-}+matchValidatorMonadProfunctor :: APrism s t a b -> ValidatorMonadProfunctor t s a+matchValidatorMonadProfunctor = match+{-# INLINE matchValidatorMonadProfunctor #-}++-- ==================================+-- Constructing prisms from validators+-- ==================================++{- | Construct a prism from a review and a validator. The prism matches+when the validator succeeds, and otherwise returns the failure, retyped to+@t@ (see 'Control.Lens.matching'). It is built with the review.++'unmatch' is an inverse of 'match'. For a prism @p@, @'unmatch' p ('match' p)@+is @p@, and for a validator @v@, @'match' ('unmatch' r v)@ is @v@. The prism+is lawful when the validator succeeds with @b@ on @'review' r b@, and fails+with its input otherwise.++The result is a 'Prism', so it can be used directly with 'Control.Lens.^?',+'review' and other optics, and the review can be any 'AReview', including a+'Prism' or an 'Control.Lens.Iso'.++The validator can be any validator with a 'GetValidator' instance.++>>> import Control.Lens(Prism, matching, withPrism)+>>> let positive = Validator (\n -> if n > 0 then Success n else Failure n) :: Validator Int Int Int+>>> let p = unmatch id positive+>>> matching p 5+Right 5++>>> matching p (-5)+Left (-5)++>>> 5 ^? p+Just 5++>>> review p 7+7++A type-changing prism.++>>> let p = unmatch _Left (matchValidator _Left) :: Prism (Either Int String) (Either Bool String) Int Bool+>>> matching p (Left 1)+Right 1++>>> matching p (Right "x")+Left (Right "x")++>>> withPrism p (\build _ -> build True)+Left True++'match' recovers the validator.++>>> runV (matchValidator (unmatch _Just (matchValidator _Just))) (Just 3)+Success 3++>>> runV (matchValidator (unmatch _Just (matchValidator _Just))) (Nothing :: Maybe Int)+Failure Nothing++The other validators are written the same way.++>>> let p = unmatch _Right (matchValidatorProfunctor _Right) :: Prism (Either String Int) (Either String Int) Int Int+>>> matching p (Left "x")+Left (Left "x")++>>> let p = unmatch _Just (matchValidatorMonad _Just >>= \n -> if n > (0 :: Int) then pure n else throwError (Just n))+>>> matching p (Just 3)+Right 3++>>> matching p (Just (-3))+Left (Just (-3))++>>> let p = unmatch _Just (matchValidatorMonadProfunctor _Just)+>>> matching p (Nothing :: Maybe Int)+Left Nothing+-}+unmatch :: (GetValidator v s t a) => AReview t b -> v -> Prism s t a b+unmatch r v =+  prism (review r) (view (getValidator . _Wrapped' . mapping Validation.either) v)+{-# INLINE unmatch #-}+{-# SPECIALIZE unmatch :: AReview t b -> Validator s t a -> Prism s t a b #-}+{-# SPECIALIZE unmatch :: AReview t b -> ValidatorProfunctor t s a -> Prism s t a b #-}+{-# SPECIALIZE unmatch :: AReview t b -> ValidatorMonad s t a -> Prism s t a b #-}+{-# SPECIALIZE unmatch :: AReview t b -> ValidatorMonadProfunctor t s a -> Prism s t a b #-}++{- | An operator for 'unmatch'. @r '<--' v@ is @'unmatch' r v@.++'<--' is @infixr 2@. It binds more loosely than '.', '-->', '<$>' and+'<!>', so the review and the validator can each be written without+parentheses.++>>> import Control.Lens(Prism, matching)+>>> let p = _Right . _Just <-- length <$> matchValidator _Left <!> matchValidator (_Right . _Just) :: Prism (Either String (Maybe Int)) (Either String (Maybe Int)) Int Int+>>> matching p (Left "abc")+Right 3++>>> matching p (Right (Just 5))+Right 5++>>> matching p (Right Nothing)+Left (Right Nothing)++>>> review p 7+Right (Just 7)+-}+(<--) :: (GetValidator v s t a) => AReview t b -> v -> Prism s t a b+(<--) = unmatch+{-# INLINE (<--) #-}+{-# SPECIALIZE (<--) :: AReview t b -> Validator s t a -> Prism s t a b #-}+{-# SPECIALIZE (<--) :: AReview t b -> ValidatorProfunctor t s a -> Prism s t a b #-}+{-# SPECIALIZE (<--) :: AReview t b -> ValidatorMonad s t a -> Prism s t a b #-}+{-# SPECIALIZE (<--) :: AReview t b -> ValidatorMonadProfunctor t s a -> Prism s t a b #-}++infixr 2 <--

@@ -1,17 +1,23 @@+import Control.Monad (unless) import System.Exit (ExitCode (..), exitFailure) import System.Process (rawSystem)  main :: IO () main = do-  exit <--    rawSystem-      "cabal"-      [ "exec",-        "--",-        "doctest",-        "-isrc",-        "src/Data/Validation.hs"+  results <-+    mapM+      ( \f ->+          rawSystem+            "cabal"+            [ "exec"+            , "--"+            , "doctest"+            , "-isrc"+            , f+            ]+      )+      [ "src/Data/Validation/Validation.hs"+      , "src/Data/Validation/ValidationMonad.hs"+      , "src/Data/Validation/Validator.hs"       ]-  case exit of-    ExitSuccess -> pure ()-    ExitFailure _ -> exitFailure+  unless (all (== ExitSuccess) results) exitFailure

@@ -2,14 +2,14 @@ {-# LANGUAGE ScopedTypeVariables #-}  import Control.Applicative (liftA3)-import Control.Category (id, (.))-import Control.Lens (Wrapped (_Wrapped'), from, review, view, (#), (^.), (^?))+import Control.Lens (APrism', clonePrism, from, matching, review, (#), (^.), (^?), _Just, _Left, _Right) 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.Functor.Identity (Identity (..))+import Data.Lens.Injection (_I1, _I2) import Data.Validation import Hedgehog import qualified Hedgehog.Gen as Gen@@ -28,49 +28,75 @@     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)+        [ ("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_injection1_review_preview", prop_prism_review_preview (_I1 :: APrism' (Validation [String] Int) [String]) genStrings)+        , ("prop_injection1_matching_review", prop_prism_matching_review _I1 testGen)+        , ("prop_injection2_review_preview", prop_prism_review_preview (_I2 :: APrism' (Validation [String] Int) Int) genInt)+        , ("prop_injection2_matching_review", prop_prism_matching_review _I2 testGen)+        , ("prop_validationMonad_injection1_review_preview", prop_prism_review_preview (_I1 :: APrism' (ValidationMonad [String] Int) [String]) genStrings)+        , ("prop_validationMonad_injection1_matching_review", prop_prism_matching_review _I1 testGenMonad)+        , ("prop_validationMonad_injection2_review_preview", prop_prism_review_preview (_I2 :: APrism' (ValidationMonad [String] Int) Int) genInt)+        , ("prop_validationMonad_injection2_matching_review", prop_prism_matching_review _I2 testGenMonad)+        , ("prop_validationMonad_injection1_validation", prop_validationMonad_injection1_validation)+        , ("prop_validationMonad_injection2_validation", prop_validationMonad_injection2_validation)+        , ("prop_swap_failure", prop_swap_failure)+        , ("prop_swap_success", prop_swap_success)+        , ("prop_swap_involution", prop_swap_involution)+        , ("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)+        , ("prop_match_hit", prop_match_hit)+        , ("prop_match_miss", prop_match_miss)+        , ("prop_match_validatorProfunctor", prop_match_validatorProfunctor)+        , ("prop_match_validatorMonad", prop_match_validatorMonad)+        , ("prop_match_validatorMonadProfunctor", prop_match_validatorMonadProfunctor)+        , ("prop_match_alt", prop_match_alt)+        , ("prop_matchValidator_alt", prop_matchValidator_alt)+        , ("prop_matchValidatorProfunctor_alt", prop_matchValidatorProfunctor_alt)+        , ("prop_matchValidatorMonad_alt", prop_matchValidatorMonad_alt)+        , ("prop_matchValidatorMonadProfunctor_alt", prop_matchValidatorMonadProfunctor_alt)+        , ("prop_arrow_fmap_match", prop_arrow_fmap_match)+        , ("prop_arrow_id_match", prop_arrow_id_match)+        , ("prop_arrow_validator_alt", prop_arrow_validator_alt)+        , ("prop_arrow_validatorProfunctor_alt", prop_arrow_validatorProfunctor_alt)+        , ("prop_arrow_validatorMonad_alt", prop_arrow_validatorMonad_alt)+        , ("prop_arrow_validatorMonadProfunctor_alt", prop_arrow_validatorMonadProfunctor_alt)+        , ("prop_unmatch_match_matching", prop_unmatch_match_matching)+        , ("prop_unmatch_match_review", prop_unmatch_match_review)+        , ("prop_match_unmatch", prop_match_unmatch)+        , ("prop_unmatch_validatorProfunctor", prop_unmatch_validatorProfunctor)+        , ("prop_unmatch_validatorMonad", prop_unmatch_validatorMonad)+        , ("prop_unmatch_validatorMonadProfunctor", prop_unmatch_validatorMonadProfunctor)+        , ("prop_unmatch_arrow", prop_unmatch_arrow)+        , ("prop_unmatch_arrow_alt", prop_unmatch_arrow_alt)         ]    unless result exitFailure@@ -92,23 +118,8 @@ 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+testGenMonad :: Gen (ValidationMonad [String] Int)+testGenMonad = fmap (^. validationMonad) testGen  -- Semigroup / Monoid @@ -291,6 +302,34 @@     let v = __Success # a :: Validation [String] Int     v ^? __Success === Just a +-- Injections++-- | Prism law: previewing a reviewed value gives that value back.+prop_prism_review_preview :: (Eq a, Show a) => APrism' s a -> Gen a -> Property+prop_prism_review_preview p ga =+  property $ do+    a <- forAll ga+    (clonePrism p # a) ^? clonePrism p === Just a++-- | Prism law: reviewing a matched value gives the original back, and a miss is unchanged.+prop_prism_matching_review :: (Eq s, Show s) => APrism' s a -> Gen s -> Property+prop_prism_matching_review p gs =+  property $ do+    s <- forAll gs+    Prelude.either Prelude.id (review (clonePrism p)) (matching p s) === s++prop_validationMonad_injection1_validation :: Property+prop_validationMonad_injection1_validation =+  property $ do+    v <- forAll testGen+    (v ^. validationMonad) ^? _I1 === v ^? _I1++prop_validationMonad_injection2_validation :: Property+prop_validationMonad_injection2_validation =+  property $ do+    v <- forAll testGen+    (v ^. validationMonad) ^? _I2 === v ^? _I2+ -- Swap  prop_swap_failure :: Property@@ -313,86 +352,6 @@     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)@@ -451,3 +410,202 @@     case x of       Right a -> reviewed === Just a       Left _ -> reviewed === Nothing++-- match++matchRight :: Validator (Prelude.Either [String] Int) (Prelude.Either [String] Int) Int+matchRight = match _Right++runValidator :: Validator x err a -> x -> Validation err a+runValidator (Validator f) = f++prop_match_hit :: Property+prop_match_hit =+  property $ do+    a <- forAll genInt+    runValidator matchRight (Right a) === Success a++prop_match_miss :: Property+prop_match_miss =+  property $ do+    e <- forAll genStrings+    runValidator matchRight (Left e) === Failure (Left e)++prop_match_validatorProfunctor :: Property+prop_match_validatorProfunctor =+  property $ do+    x <- forAll (genEither genStrings genInt)+    let ValidatorProfunctor f = match _Right :: ValidatorProfunctor (Prelude.Either [String] Int) (Prelude.Either [String] Int) Int+    f x === runValidator matchRight x++prop_match_validatorMonad :: Property+prop_match_validatorMonad =+  property $ do+    x <- forAll (genEither genStrings genInt)+    let ValidatorMonadT f = match _Right :: ValidatorMonad (Prelude.Either [String] Int) (Prelude.Either [String] Int) Int+        ValidationMonadT (Identity r) = f x+    r === runValidator matchRight x++prop_match_validatorMonadProfunctor :: Property+prop_match_validatorMonadProfunctor =+  property $ do+    x <- forAll (genEither genStrings genInt)+    let ValidatorMonadProfunctorT f = match _Right :: ValidatorMonadProfunctor (Prelude.Either [String] Int) (Prelude.Either [String] Int) Int+        ValidationMonadT (Identity r) = f x+    r === runValidator matchRight x++-- match with (<!>): one prism per constructor, the first match wins++-- | The input used by the (<!>) properties: a Left, a Right Just, or a Right Nothing.+type Input = Prelude.Either String (Maybe Int)++genInput :: Gen Input+genInput = genEither genString (Gen.maybe genInt)++-- | The expected result: Left and Right Just match, Right Nothing matches neither prism.+expected :: Input -> Validation Input String+expected (Left s) = Success s+expected (Right (Just n)) = Success (show n)+expected i@(Right Nothing) = Failure i++prop_match_alt :: Property+prop_match_alt =+  property $ do+    i <- forAll genInput+    let v = match _Left <!> (show <$> match (_Right Prelude.. _Just)) :: Validator Input Input String+    runValidator v i === expected i++prop_matchValidator_alt :: Property+prop_matchValidator_alt =+  property $ do+    i <- forAll genInput+    let v = matchValidator _Left <!> (show <$> matchValidator (_Right Prelude.. _Just))+    runValidator v i === expected i++prop_matchValidatorProfunctor_alt :: Property+prop_matchValidatorProfunctor_alt =+  property $ do+    i <- forAll genInput+    let ValidatorProfunctor f = matchValidatorProfunctor _Left <!> (show <$> matchValidatorProfunctor (_Right Prelude.. _Just))+    f i === expected i++prop_matchValidatorMonad_alt :: Property+prop_matchValidatorMonad_alt =+  property $ do+    i <- forAll genInput+    let ValidatorMonadT f = matchValidatorMonad _Left <!> (show <$> matchValidatorMonad (_Right Prelude.. _Just))+        ValidationMonadT (Identity r) = f i+    r === expected i++prop_matchValidatorMonadProfunctor_alt :: Property+prop_matchValidatorMonadProfunctor_alt =+  property $ do+    i <- forAll genInput+    let ValidatorMonadProfunctorT f = matchValidatorMonadProfunctor _Left <!> (show <$> matchValidatorMonadProfunctor (_Right Prelude.. _Just))+        ValidationMonadT (Identity r) = f i+    r === expected i++-- (-->): match a prism and map its focus, one case per constructor++prop_arrow_fmap_match :: Property+prop_arrow_fmap_match =+  property $ do+    i <- forAll genInput+    let v = _Right Prelude.. _Just --> show :: Validator Input Input String+    runValidator v i === runValidator (show <$> matchValidator (_Right Prelude.. _Just)) i++prop_arrow_id_match :: Property+prop_arrow_id_match =+  property $ do+    i <- forAll genInput+    let v = _Left --> Prelude.id :: Validator Input Input String+    runValidator v i === runValidator (matchValidator _Left) i++prop_arrow_validator_alt :: Property+prop_arrow_validator_alt =+  property $ do+    i <- forAll genInput+    let v = _Left --> Prelude.id <!> _Right Prelude.. _Just --> show :: Validator Input Input String+    runValidator v i === expected i++prop_arrow_validatorProfunctor_alt :: Property+prop_arrow_validatorProfunctor_alt =+  property $ do+    i <- forAll genInput+    let ValidatorProfunctor f = _Left --> Prelude.id <!> _Right Prelude.. _Just --> show :: ValidatorProfunctor Input Input String+    f i === expected i++prop_arrow_validatorMonad_alt :: Property+prop_arrow_validatorMonad_alt =+  property $ do+    i <- forAll genInput+    let ValidatorMonadT f = _Left --> Prelude.id <!> _Right Prelude.. _Just --> show :: ValidatorMonad Input Input String+        ValidationMonadT (Identity r) = f i+    r === expected i++prop_arrow_validatorMonadProfunctor_alt :: Property+prop_arrow_validatorMonadProfunctor_alt =+  property $ do+    i <- forAll genInput+    let ValidatorMonadProfunctorT f = _Left --> Prelude.id <!> _Right Prelude.. _Just --> show :: ValidatorMonadProfunctor Input Input String+        ValidationMonadT (Identity r) = f i+    r === expected i++-- unmatch and (<--): construct a prism from a review and a validator++-- | A validator that succeeds on a positive number, and fails with its input otherwise.+positive :: Validator Int Int Int+positive = Validator (\n -> if n > 0 then Success n else Failure n)++-- | The expected match of positive.+expectedPositive :: Int -> Prelude.Either Int Int+expectedPositive n = if n > 0 then Right n else Left n++prop_unmatch_match_matching :: Property+prop_unmatch_match_matching =+  property $ do+    x <- forAll (genEither genStrings genInt)+    matching (unmatch _Right matchRight) x === matching _Right x++prop_unmatch_match_review :: Property+prop_unmatch_match_review =+  property $ do+    a <- forAll genInt+    review (unmatch _Right matchRight) a === (review _Right a :: Prelude.Either [String] Int)++prop_match_unmatch :: Property+prop_match_unmatch =+  property $ do+    n <- forAll genInt+    runValidator (matchValidator (unmatch Prelude.id positive)) n === runValidator positive n++prop_unmatch_validatorProfunctor :: Property+prop_unmatch_validatorProfunctor =+  property $ do+    n <- forAll genInt+    matching (unmatch Prelude.id (positive ^. validatorProfunctor)) n === expectedPositive n++prop_unmatch_validatorMonad :: Property+prop_unmatch_validatorMonad =+  property $ do+    n <- forAll genInt+    matching (unmatch Prelude.id (positive ^. validatorMonadT)) n === expectedPositive n++prop_unmatch_validatorMonadProfunctor :: Property+prop_unmatch_validatorMonadProfunctor =+  property $ do+    n <- forAll genInt+    matching (unmatch Prelude.id (positive ^. validatorMonadProfunctorT)) n === expectedPositive n++prop_unmatch_arrow :: Property+prop_unmatch_arrow =+  property $ do+    n <- forAll genInt+    matching (Prelude.id <-- positive) n === matching (unmatch Prelude.id positive) n++prop_unmatch_arrow_alt :: Property+prop_unmatch_arrow_alt =+  property $ do+    i <- forAll genInput+    let p = _Left <-- matchValidator _Left <!> show <$> matchValidator (_Right Prelude.. _Just)+    matching p i === expected i ^. either

@@ -1,5 +1,5 @@ name:               validation-version:            1.2.2+version:            1.3.3 license:            BSD3 license-file:       LICENCE author:             Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> <dibblego>, Nick Partridge <nkpart>@@ -29,37 +29,41 @@   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@.+    @AsValidation@) following the conventions of @makeClassy@ and+    @makeClassyPrisms@ from @lens@.   * Polymorphic prisms (@__Failure@, @__Success@) for type-changing operations.   * Isomorphisms to @Either@ and @(Bool, a)@.   .-  == @Validator@+  == @ValidationMonadT@   .-  The @Validator@ newtype is a profunctor transformer:+  @ValidationMonadT err m a@ is a monad transformer wrapping @m (Validation err a)@.+  Unlike @Validation@, it has short-circuiting @Applicative@, @Bind@, @Monad@,+  and @MonadError@ instances.   .-  @newtype Validator e p x a = Validator (p x (Validation e a))@+  == Validators   .-  @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@.+  Four validator newtypes wrap a validation function with different type+  parameter orders, enabling different class instances:   .-  Instances include @Functor@, @Apply@, @Applicative@, @Alt@, @Selective@,-  @Profunctor@, @Strong@, @Choice@, @Semigroupoid@, @Category@, @Arrow@,-  @ArrowApply@, @ArrowChoice@, and @Wrapped@.+  * @Validator x err a@ — @Bifunctor@, accumulating @Applicative@, @Either@-like @Alt@+  * @ValidatorProfunctor err x a@ — @Profunctor@, accumulating @Applicative@+  * @ValidatorMonadT x err f a@ — @Monad@, @MonadTrans@, @BindTrans@+  * @ValidatorMonadProfunctorT err f x a@ — @Profunctor@, @Monad@, @Category@, @Arrow@   .-  The @Applicative@ instance accumulates errors in parallel (using @Semigroup@),-  while @Category@ composition short-circuits on @Failure@ (like monadic bind).+  All four are isomorphic and have cross-type optics instances.   .-  The library also provides profunctor newtype wrappers (@Iso''@, @Prism''@) that-  allow @Validator@ to be parameterised over monomorphic isos and prisms.+  @Validator@ is the odd one out in its @Alt@ instance. For the other three+  validators, @\<!\>@ accumulates errors when both sides fail. For @Validator@,+  @\<!\>@ behaves like @Either@: the first success wins, otherwise the second+  failure is returned. @Validator@ has no @Plus@ or @Alternative@ instance, and+  its @\<\>@ still accumulates errors.  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 == 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+tested-with:        GHC == 9.10.3, GHC == 9.8.4, GHC == 9.6.7  source-repository   head   type:             git@@ -70,16 +74,17 @@                     Haskell2010    build-depends:-                      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+                      base          >= 4.18    && < 5+                    , assoc         >= 1.1     && < 2+                    , deepseq       >= 1.4.8.1 && < 2+                    , either-n      >= 0.1     && < 0.2+                    , selective     >= 0.7     && < 1+                    , semigroupoids >= 6.0.0.1 && < 7+                    , bifunctors    >= 5.6     && < 6+                    , lens          >= 5.2.1   && < 6+                    , mtl           >= 2.3.1   && < 2.4+                    , profunctors   >= 5.6.2   && < 6+                    , transformers  >= 0.6.1.0 && < 0.7    ghc-options:                     -Wall@@ -89,6 +94,9 @@    exposed-modules:                     Data.Validation+                    Data.Validation.Validation+                    Data.Validation.ValidationMonad+                    Data.Validation.Validator  test-suite hedgehog   type:@@ -101,13 +109,13 @@                     Haskell2010    build-depends:-                      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+                      base          >= 4.18    && < 5+                    , assoc         >= 1.1     && < 2+                    , bifunctors    >= 5.6     && < 6+                    , either-n      >= 0.1     && < 0.2+                    , hedgehog      >= 1.2     && < 2+                    , lens          >= 5.2.1   && < 6+                    , semigroupoids >= 6.0.0.1 && < 7                     , validation    ghc-options:@@ -128,8 +136,8 @@                     Haskell2010    build-depends:-                      base       >= 4.11   && < 5-                    , process    >= 1.6    && < 2+                      base    >= 4.18     && < 5+                    , process >= 1.6.19.0 && < 2                     , validation    ghc-options: