validation 1.2.2 → 1.3.0

raw patch · 8 files changed

+2820/−1226 lines, 8 filesdep +mtldep +transformersdep −semigroupsdep −taggeddep ~lensPVP ok

version bump matches the API change (PVP)

Dependencies added: mtl, transformers

Dependencies removed: semigroups, tagged

Dependency ranges changed: lens

API changes (from Hackage documentation)

Files

• changelog +27/−0
• src/Data/Validation.hs +11/−1048
• src/Data/Validation/Validation.hs +579/−0
• src/Data/Validation/ValidationMonad.hs +568/−0
• src/Data/Validation/Validator.hs +1559/−0
• test/doctest_tests.hs +17/−11
• test/hedgehog_tests.hs +36/−144
• validation.cabal +23/−23

@@ -1,3 +1,30 @@+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,579 @@+{-# 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 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))+-- >>> :set -XNoMonomorphismRestriction -w++-- | 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.Semigroup.Traversable.Class (Bitraversable1 (bitraverse1))+import Data.Typeable (Typeable)+import GHC.Generics (Generic, Generic1)+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.<*>'++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 #-}++{- | 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,568 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wall #-}++-- \$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)@ 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, prism', unto)+import Control.Lens.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 qualified Data.Either as Either+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.Validation.Validation (AsValidation (..), GetValidation (..), HasValidation (..), ReviewValidation (..), Validation (..), foldValidation)+import GHC.Generics (Generic)++{- | 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 (Monad m, 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 = unto 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 #-}++{- |+>>> 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 = unto (\(ValidationMonadT (Identity v)) -> v)+  {-# 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 =+    prism'+      (\(ValidationMonadT (Identity v)) -> v)+      (Just . ValidationMonadT . pure)+  {-# 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 #-}++instance ReviewValidation (ValidationMonad err a) err a where+  reviewValidation = unto (ValidationMonadT . Identity)+  {-# 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 = iso (ValidationMonadT . Identity . Either.either Failure Success) (\(ValidationMonadT (Identity v)) -> foldValidation Left Right v)+  {-# 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 = iso (ValidationMonadT . Identity . Either.either Failure Success) (\(ValidationMonadT (Identity v)) -> foldValidation Left Right v)+  {-# 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 = unto (\(ValidationMonadT (Identity v)) -> foldValidation Left Right v)+  {-# 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 = iso (ValidationMonadT . Identity . Either.either Failure Success) (\(ValidationMonadT (Identity v)) -> foldValidation Left Right v)+  {-# INLINE _ValidationMonadT #-}

@@ -0,0 +1,1559 @@+{-# 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 (..),+) 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 (Getter, Lens', Prism', Review, Rewrapped, Wrapped (_Wrapped', type Unwrapped), unto)+import Control.Lens.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 (..), 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 Data.Validation.ValidationMonad (ValidationMonadT (..), liftValidationMonadT)+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', (^?))+>>> import Prelude hiding (id, (.))+>>> :set -w+>>> 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'.++>>> 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; two failures accumulate.++>>> import Data.Functor.Alt(Alt((<!>)))+>>> 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 ["e1","e2"]+-}+instance (Semigroup err) => Alt (Validator x err) where+  Validator f <!> Validator g = Validator (\x -> f x <!> g x)+  {-# INLINE (<!>) #-}++{- |+>>> import Data.Functor.Alt(Alt((<!>)))+>>> import Data.Functor.Plus(Plus(zero))+>>> let Validator f = (zero :: Validator Int [String] Int) <!> Validator (\_ -> Success 1)+>>> f 0+Success 1+-}+instance (Monoid err) => Plus (Validator x err) where+  zero = Validator (\_ -> Failure mempty)+  {-# INLINE zero #-}++{- |+>>> let Validator f = (empty :: Validator Int [String] Int) <|> Validator (\_ -> Success 1)+>>> f 0+Success 1+-}+instance (Monoid err) => Alternative (Validator x err) where+  empty = zero+  {-# INLINE empty #-}+  (<|>) = (<!>)+  {-# 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 #-}++{- |+>>> import Data.Functor.Extend(Extend(extended))+>>> let Validator f = extended (\_ -> 42) (Validator (\_ -> Success 1) :: Validator Int [String] Int)+>>> f 0+Success 42+-}+instance Extend (Validator x err) where+  extended f w@(Validator _) = Validator (\_ -> Success (f w))+  {-# INLINE extended #-}++{- |+>>> 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 = unto 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 (Semigroup err) => Choice (ValidatorProfunctor err) where+  left' (ValidatorProfunctor f) = ValidatorProfunctor (either (fmap Left . f) (pure . Right))+  {-# INLINE left' #-}+  right' (ValidatorProfunctor f) = ValidatorProfunctor (either (pure . 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 #-}++{- |+>>> runVP (extended (\_ -> 42) vpFromInput) 0+Success 42+-}+instance Extend (ValidatorProfunctor err x) where+  extended f w@(ValidatorProfunctor _) = ValidatorProfunctor (\_ -> Success (f w))+  {-# 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 = unto 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 (Monad f, 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 #-}++{- |+>>> 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+-}+instance (Monad f) => Extend (ValidatorMonadT x err f) where+  extended f w@(ValidatorMonadT _) = ValidatorMonadT (\_ -> pure (f w))+  {-# 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 = unto 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 (Monad 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 (<+>) #-}++{- |+>>> 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+-}+instance (Monad f) => Extend (ValidatorMonadProfunctorT err f x) where+  extended f w@(ValidatorMonadProfunctorT _) = ValidatorMonadProfunctorT (\_ -> pure (f w))+  {-# 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 (Monad f, 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 = unto 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+-- =============================++-- Cross-type optics: Validator <-> ValidatorProfunctor++instance GetValidator (ValidatorProfunctor err x a) x err a where+  getValidator = iso (\(ValidatorProfunctor f) -> Validator f) (\(Validator f) -> ValidatorProfunctor f)+  {-# INLINE getValidator #-}++instance HasValidator (ValidatorProfunctor err x a) x err a where+  validator = iso (\(ValidatorProfunctor f) -> Validator f) (\(Validator f) -> ValidatorProfunctor f)+  {-# INLINE validator #-}++instance ReviewValidator (ValidatorProfunctor err x a) x err a where+  reviewValidator = unto (\(Validator f) -> ValidatorProfunctor f)+  {-# INLINE reviewValidator #-}++instance AsValidator (ValidatorProfunctor err x a) x err a where+  _Validator = iso (\(ValidatorProfunctor f) -> Validator f) (\(Validator f) -> ValidatorProfunctor f)+  {-# INLINE _Validator #-}++instance GetValidatorProfunctor (Validator x err a) err x a where+  getValidatorProfunctor = iso (\(Validator f) -> ValidatorProfunctor f) (\(ValidatorProfunctor f) -> Validator f)+  {-# INLINE getValidatorProfunctor #-}++instance HasValidatorProfunctor (Validator x err a) err x a where+  validatorProfunctor = iso (\(Validator f) -> ValidatorProfunctor f) (\(ValidatorProfunctor f) -> Validator f)+  {-# INLINE validatorProfunctor #-}++instance ReviewValidatorProfunctor (Validator x err a) err x a where+  reviewValidatorProfunctor = unto (\(ValidatorProfunctor f) -> Validator f)+  {-# INLINE reviewValidatorProfunctor #-}++instance AsValidatorProfunctor (Validator x err a) err x a where+  _ValidatorProfunctor = iso (\(Validator f) -> ValidatorProfunctor f) (\(ValidatorProfunctor f) -> Validator f)+  {-# INLINE _ValidatorProfunctor #-}++-- Cross-type optics: ValidatorMonadT <-> ValidatorMonadProfunctorT++instance GetValidatorMonadT (ValidatorMonadProfunctorT err f x a) x err f a where+  getValidatorMonadT = iso (\(ValidatorMonadProfunctorT f) -> ValidatorMonadT f) (\(ValidatorMonadT f) -> ValidatorMonadProfunctorT f)+  {-# INLINE getValidatorMonadT #-}++instance HasValidatorMonadT (ValidatorMonadProfunctorT err f x a) x err f a where+  validatorMonadT = iso (\(ValidatorMonadProfunctorT f) -> ValidatorMonadT f) (\(ValidatorMonadT f) -> ValidatorMonadProfunctorT f)+  {-# INLINE validatorMonadT #-}++instance ReviewValidatorMonadT (ValidatorMonadProfunctorT err f x a) x err f a where+  reviewValidatorMonadT = unto (\(ValidatorMonadT f) -> ValidatorMonadProfunctorT f)+  {-# INLINE reviewValidatorMonadT #-}++instance AsValidatorMonadT (ValidatorMonadProfunctorT err f x a) x err f a where+  _ValidatorMonadT = iso (\(ValidatorMonadProfunctorT f) -> ValidatorMonadT f) (\(ValidatorMonadT f) -> ValidatorMonadProfunctorT f)+  {-# INLINE _ValidatorMonadT #-}++instance GetValidatorMonadProfunctorT (ValidatorMonadT x err f a) err f x a where+  getValidatorMonadProfunctorT = iso (\(ValidatorMonadT f) -> ValidatorMonadProfunctorT f) (\(ValidatorMonadProfunctorT f) -> ValidatorMonadT f)+  {-# INLINE getValidatorMonadProfunctorT #-}++instance HasValidatorMonadProfunctorT (ValidatorMonadT x err f a) err f x a where+  validatorMonadProfunctorT = iso (\(ValidatorMonadT f) -> ValidatorMonadProfunctorT f) (\(ValidatorMonadProfunctorT f) -> ValidatorMonadT f)+  {-# INLINE validatorMonadProfunctorT #-}++instance ReviewValidatorMonadProfunctorT (ValidatorMonadT x err f a) err f x a where+  reviewValidatorMonadProfunctorT = unto (\(ValidatorMonadProfunctorT f) -> ValidatorMonadT f)+  {-# INLINE reviewValidatorMonadProfunctorT #-}++instance AsValidatorMonadProfunctorT (ValidatorMonadT x err f a) err f x a where+  _ValidatorMonadProfunctorT = iso (\(ValidatorMonadT f) -> ValidatorMonadProfunctorT f) (\(ValidatorMonadProfunctorT f) -> ValidatorMonadT f)+  {-# INLINE _ValidatorMonadProfunctorT #-}++-- Cross-type optics: Validator <-> ValidatorMonadT (f ~ Identity)++instance GetValidator (ValidatorMonadT x err Identity a) x err a where+  getValidator = iso (\(ValidatorMonadT f) -> Validator (runIdentity . (\(ValidationMonadT m) -> m) . f)) (\(Validator f) -> ValidatorMonadT (ValidationMonadT . Identity . f))+  {-# INLINE getValidator #-}++instance HasValidator (ValidatorMonadT x err Identity a) x err a where+  validator = iso (\(ValidatorMonadT f) -> Validator (runIdentity . (\(ValidationMonadT m) -> m) . f)) (\(Validator f) -> ValidatorMonadT (ValidationMonadT . Identity . f))+  {-# INLINE validator #-}++instance ReviewValidator (ValidatorMonadT x err Identity a) x err a where+  reviewValidator = unto (\(Validator f) -> ValidatorMonadT (ValidationMonadT . Identity . f))+  {-# INLINE reviewValidator #-}++instance AsValidator (ValidatorMonadT x err Identity a) x err a where+  _Validator = iso (\(ValidatorMonadT f) -> Validator (runIdentity . (\(ValidationMonadT m) -> m) . f)) (\(Validator f) -> ValidatorMonadT (ValidationMonadT . Identity . f))+  {-# INLINE _Validator #-}++instance GetValidatorMonadT (Validator x err a) x err Identity a where+  getValidatorMonadT = iso (\(Validator f) -> ValidatorMonadT (ValidationMonadT . Identity . f)) (\(ValidatorMonadT f) -> Validator (runIdentity . (\(ValidationMonadT m) -> m) . f))+  {-# INLINE getValidatorMonadT #-}++instance HasValidatorMonadT (Validator x err a) x err Identity a where+  validatorMonadT = iso (\(Validator f) -> ValidatorMonadT (ValidationMonadT . Identity . f)) (\(ValidatorMonadT f) -> Validator (runIdentity . (\(ValidationMonadT m) -> m) . f))+  {-# INLINE validatorMonadT #-}++instance ReviewValidatorMonadT (Validator x err a) x err Identity a where+  reviewValidatorMonadT = unto (\(ValidatorMonadT f) -> Validator (runIdentity . (\(ValidationMonadT m) -> m) . f))+  {-# INLINE reviewValidatorMonadT #-}++instance AsValidatorMonadT (Validator x err a) x err Identity a where+  _ValidatorMonadT = iso (\(Validator f) -> ValidatorMonadT (ValidationMonadT . Identity . f)) (\(ValidatorMonadT f) -> Validator (runIdentity . (\(ValidationMonadT m) -> m) . f))+  {-# INLINE _ValidatorMonadT #-}++-- Cross-type optics: ValidatorProfunctor <-> ValidatorMonadProfunctorT (f ~ Identity)++instance GetValidatorProfunctor (ValidatorMonadProfunctorT err Identity x a) err x a where+  getValidatorProfunctor = iso (\(ValidatorMonadProfunctorT f) -> ValidatorProfunctor (runIdentity . (\(ValidationMonadT m) -> m) . f)) (\(ValidatorProfunctor f) -> ValidatorMonadProfunctorT (ValidationMonadT . Identity . f))+  {-# INLINE getValidatorProfunctor #-}++instance HasValidatorProfunctor (ValidatorMonadProfunctorT err Identity x a) err x a where+  validatorProfunctor = iso (\(ValidatorMonadProfunctorT f) -> ValidatorProfunctor (runIdentity . (\(ValidationMonadT m) -> m) . f)) (\(ValidatorProfunctor f) -> ValidatorMonadProfunctorT (ValidationMonadT . Identity . f))+  {-# INLINE validatorProfunctor #-}++instance ReviewValidatorProfunctor (ValidatorMonadProfunctorT err Identity x a) err x a where+  reviewValidatorProfunctor = unto (\(ValidatorProfunctor f) -> ValidatorMonadProfunctorT (ValidationMonadT . Identity . f))+  {-# INLINE reviewValidatorProfunctor #-}++instance AsValidatorProfunctor (ValidatorMonadProfunctorT err Identity x a) err x a where+  _ValidatorProfunctor = iso (\(ValidatorMonadProfunctorT f) -> ValidatorProfunctor (runIdentity . (\(ValidationMonadT m) -> m) . f)) (\(ValidatorProfunctor f) -> ValidatorMonadProfunctorT (ValidationMonadT . Identity . f))+  {-# INLINE _ValidatorProfunctor #-}++instance GetValidatorMonadProfunctorT (ValidatorProfunctor err x a) err Identity x a where+  getValidatorMonadProfunctorT = iso (\(ValidatorProfunctor f) -> ValidatorMonadProfunctorT (ValidationMonadT . Identity . f)) (\(ValidatorMonadProfunctorT f) -> ValidatorProfunctor (runIdentity . (\(ValidationMonadT m) -> m) . f))+  {-# INLINE getValidatorMonadProfunctorT #-}++instance HasValidatorMonadProfunctorT (ValidatorProfunctor err x a) err Identity x a where+  validatorMonadProfunctorT = iso (\(ValidatorProfunctor f) -> ValidatorMonadProfunctorT (ValidationMonadT . Identity . f)) (\(ValidatorMonadProfunctorT f) -> ValidatorProfunctor (runIdentity . (\(ValidationMonadT m) -> m) . f))+  {-# INLINE validatorMonadProfunctorT #-}++instance ReviewValidatorMonadProfunctorT (ValidatorProfunctor err x a) err Identity x a where+  reviewValidatorMonadProfunctorT = unto (\(ValidatorMonadProfunctorT f) -> ValidatorProfunctor (runIdentity . (\(ValidationMonadT m) -> m) . f))+  {-# INLINE reviewValidatorMonadProfunctorT #-}++instance AsValidatorMonadProfunctorT (ValidatorProfunctor err x a) err Identity x a where+  _ValidatorMonadProfunctorT = iso (\(ValidatorProfunctor f) -> ValidatorMonadProfunctorT (ValidationMonadT . Identity . f)) (\(ValidatorMonadProfunctorT f) -> ValidatorProfunctor (runIdentity . (\(ValidationMonadT m) -> m) . f))+  {-# INLINE _ValidatorMonadProfunctorT #-}

@@ -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,12 @@ {-# LANGUAGE ScopedTypeVariables #-}  import Control.Applicative (liftA3)-import Control.Category (id, (.))-import Control.Lens (Wrapped (_Wrapped'), from, review, view, (#), (^.), (^?))+import Control.Lens (from, review, (#), (^.), (^?)) import Control.Monad (join, unless) import Data.Bifunctor (bimap) import Data.Bifunctor.Swap (swap) import Data.Functor.Alt (Alt ((<!>))) import Data.Functor.Apply (Apply ((<.>)))-import Data.Semigroupoid (Semigroupoid (o)) import Data.Validation import Hedgehog import qualified Hedgehog.Gen as Gen@@ -28,49 +26,41 @@     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_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)         ]    unless result exitFailure@@ -92,24 +82,6 @@ testGen :: Gen (Validation [String] Int) testGen = genValidation genStrings genInt -runV :: Validator' e x a -> x -> Validation e a-runV = view _Wrapped'--validators :: [Validator' [String] Int Int]-validators =-  [ Validator (Success . (+ 1)),-    Validator (Success . (* 2)),-    Validator (Success . negate),-    Validator (\_ -> Failure ["e1"]),-    Validator (\_ -> Failure ["e2"])-  ]--genValidatorIdx :: Gen Int-genValidatorIdx = Gen.int (Range.constant 0 (length validators - 1))--pickValidator :: Int -> Validator' [String] Int Int-pickValidator i = validators !! i- -- Semigroup / Monoid  mkAssoc :: (Validation [String] Int -> Validation [String] Int -> Validation [String] Int) -> Property@@ -312,86 +284,6 @@   property $ do     x <- forAll testGen     (swap (swap x)) === x---- Validator: Functor--prop_validator_functor_id :: Property-prop_validator_functor_id =-  property $ do-    x <- forAll genInt-    i <- forAll genValidatorIdx-    let v = pickValidator i-    runV (fmap Prelude.id v) x === runV v x---- Validator: Category--prop_validator_category_left_id :: Property-prop_validator_category_left_id =-  property $ do-    x <- forAll genInt-    i <- forAll genValidatorIdx-    let v = pickValidator i-    runV (id . v) x === runV v x--prop_validator_category_right_id :: Property-prop_validator_category_right_id =-  property $ do-    x <- forAll genInt-    i <- forAll genValidatorIdx-    let v = pickValidator i-    runV (v . id) x === runV v x--prop_validator_category_assoc :: Property-prop_validator_category_assoc =-  property $ do-    x <- forAll genInt-    fi <- forAll genValidatorIdx-    gi <- forAll genValidatorIdx-    hi <- forAll genValidatorIdx-    let f = pickValidator fi-        g = pickValidator gi-        h = pickValidator hi-    runV ((f . g) . h) x === runV (f . (g . h)) x---- Validator: Semigroupoid--prop_validator_semigroupoid_assoc :: Property-prop_validator_semigroupoid_assoc =-  property $ do-    x <- forAll genInt-    fi <- forAll genValidatorIdx-    gi <- forAll genValidatorIdx-    hi <- forAll genValidatorIdx-    let f = pickValidator fi-        g = pickValidator gi-        h = pickValidator hi-    runV ((f `o` g) `o` h) x === runV (f `o` (g `o` h)) x---- Validator: Apply / Alt accumulate errors--prop_validator_apply_accumulates :: Property-prop_validator_apply_accumulates =-  property $ do-    x <- forAll genInt-    let f = Validator (\_ -> Failure ["e1"]) :: Validator' [String] Int Int-        g = Validator (\_ -> Failure ["e2"]) :: Validator' [String] Int Int-    runV (fmap const f <.> g) x === Failure ["e1", "e2"]--prop_validator_alt_accumulates :: Property-prop_validator_alt_accumulates =-  property $ do-    x <- forAll genInt-    let f = Validator (\_ -> Failure ["e1"]) :: Validator' [String] Int Int-        g = Validator (\_ -> Failure ["e2"]) :: Validator' [String] Int Int-    runV (f <!> g) x === Failure ["e1", "e2"]--prop_validator_alt_left_success :: Property-prop_validator_alt_left_success =-  property $ do-    x <- forAll genInt-    let f = Validator (Success . (+ 1)) :: Validator' [String] Int Int-        g = Validator (\_ -> Failure ["e2"]) :: Validator' [String] Int Int-    runV (f <!> g) x === Success (x + 1)  -- Either instances: ReviewFailure, AsFailure, ReviewSuccess, AsSuccess 

@@ -1,5 +1,5 @@ name:               validation-version:            1.2.2+version:            1.3.0 license:            BSD3 license-file:       LICENCE author:             Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> <dibblego>, Nick Partridge <nkpart>@@ -29,37 +29,35 @@   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@-  .-  The @Validator@ newtype is a profunctor transformer:+  == @ValidationMonadT@   .-  @newtype Validator e p x a = Validator (p x (Validation e a))@+  @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.   .-  @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@.+  == Validators   .-  Instances include @Functor@, @Apply@, @Applicative@, @Alt@, @Selective@,-  @Profunctor@, @Strong@, @Choice@, @Semigroupoid@, @Category@, @Arrow@,-  @ArrowApply@, @ArrowChoice@, and @Wrapped@.+  Four validator newtypes wrap a validation function with different type+  parameter orders, enabling different class instances:   .-  The @Applicative@ instance accumulates errors in parallel (using @Semigroup@),-  while @Category@ composition short-circuits on @Failure@ (like monadic bind).+  * @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@   .-  The library also provides profunctor newtype wrappers (@Iso''@, @Prism''@) that-  allow @Validator@ to be parameterised over monomorphic isos and prisms.+  All four are isomorphic and have cross-type optics instances.  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@@ -74,12 +72,12 @@                     , 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+                    , lens          >= 4.20   && < 6+                    , mtl           >= 2.1    && < 2.4                     , profunctors   >= 5      && < 6-                    , tagged        >= 0.8    && < 1+                    , transformers  >= 0.5    && < 0.7    ghc-options:                     -Wall@@ -89,6 +87,9 @@    exposed-modules:                     Data.Validation+                    Data.Validation.Validation+                    Data.Validation.ValidationMonad+                    Data.Validation.Validator  test-suite hedgehog   type:@@ -105,9 +106,8 @@                     , assoc        >= 1      && < 2                     , bifunctors   >= 5.5    && < 6                     , hedgehog     >= 0.5    && < 2-                    , lens         >= 4.0.5  && < 6+                    , lens         >= 4.20   && < 6                     , semigroupoids >= 5.2.2 && < 7-                    , semigroups   >= 0.18.2 && < 1                     , validation    ghc-options: