validation 1.3.2 → 1.3.3

raw patch · 6 files changed

+315/−4 lines, 6 filesdep +either-nPVP ok

version bump matches the API change (PVP)

Dependencies added: either-n

API changes (from Hackage documentation)

Files

• changelog +13/−0
• src/Data/Validation/Validation.hs +40/−0
• src/Data/Validation/ValidationMonad.hs +33/−0
• src/Data/Validation/Validator.hs +116/−2
• test/hedgehog_tests.hs +110/−1
• validation.cabal +3/−1

@@ -1,3 +1,16 @@+1.3.3++* Add unmatch, constructing a prism from a review and any validator. It is+  an inverse of match: unmatch p (match p) is p, and match (unmatch r v)+  is v+* Add (<--), an operator for unmatch (infixr 2, binding more loosely than+  (.), (-->), <$> and <!>)+* Depend on either-n+* Add Injection1 and Injection2 instances (from either-n) for Validation,+  where _I1 is the Failure constructor and _I2 is the Success constructor+* Add Injection1 and Injection2 instances for ValidationMonad, the+  Validation inside Identity+ 1.3.2  * Change the Extend instances for all four validators to keep failures,

@@ -56,6 +56,7 @@ import Data.Functor.Classes (Eq1 (liftEq), Eq2 (liftEq2), Ord1 (liftCompare), Ord2 (liftCompare2), Show1 (liftShowsPrec), Show2 (liftShowsPrec2), showsUnaryWith) import Data.Functor.Extend (Extend (extended)) import Data.Functor.Plus (Plus (zero))+import Data.Lens.Injection (Injection1 (_I1), Injection2 (_I2)) import Data.Semigroup.Traversable.Class (Bitraversable1 (bitraverse1)) import Data.Typeable (Typeable) import GHC.Generics (Generic, Generic1)@@ -73,6 +74,7 @@ >>> import Data.Bifoldable(Bifoldable(bifoldr)) >>> import Data.Bitraversable(Bitraversable(bitraverse)) >>> import Data.Bifunctor.Swap(Swap(swap))+>>> import Data.Lens.Injection(Injection1(_I1), Injection2(_I2)) >>> :set -XNoMonomorphismRestriction -w -} @@ -443,6 +445,44 @@         Success b -> Right b     ) {-# INLINE __Success #-}++{- | The first constructor, 'Failure'. The same as '__Failure'.++>>> import Control.Lens((^?), (#), over)+>>> (Failure "err" :: Validation String Int) ^? _I1+Just "err"++>>> (Success 1 :: Validation String Int) ^? _I1+Nothing++>>> _I1 # "err" :: Validation String Int+Failure "err"++>>> over _I1 length (Failure "err" :: Validation String Int)+Failure 3+-}+instance Injection1 (Validation a b) (Validation a' b) a a' where+  _I1 = __Failure+  {-# INLINE _I1 #-}++{- | The second constructor, 'Success'. The same as '__Success'.++>>> import Control.Lens((^?), (#), over)+>>> (Success 1 :: Validation String Int) ^? _I2+Just 1++>>> (Failure "err" :: Validation String Int) ^? _I2+Nothing++>>> _I2 # 1 :: Validation String Int+Success 1++>>> over _I2 show (Success 1 :: Validation String Int)+Success "1"+-}+instance Injection2 (Validation a b) (Validation a b') b b' where+  _I2 = __Success+  {-# INLINE _I2 #-}  {- | Isomorphism between 'Validation' and 'Either'. 

@@ -53,6 +53,7 @@ import Data.Functor.Extend (Extend (extended)) import Data.Functor.Identity (Identity (..)) import Data.Functor.Plus (Plus (zero))+import Data.Lens.Injection (Injection1 (_I1), Injection2 (_I2)) import Data.Validation.Validation (AsValidation (..), GetValidation (..), HasValidation (..), ReviewValidation (..), Validation (..), foldValidation) import qualified Data.Validation.Validation as Validation import GHC.Generics (Generic)@@ -449,6 +450,38 @@ validationMonad :: Iso (Validation err a) (Validation err' a') (ValidationMonad err a) (ValidationMonad err' a') validationMonad = iso (ValidationMonadT . pure) (\(ValidationMonadT (Identity v)) -> v) {-# INLINE validationMonad #-}++{- | The first constructor, 'Failure', of the 'Validation' inside 'Identity'.++>>> import Control.Lens((^?), (#))+>>> (ValidationMonadT (Identity (Failure "err")) :: ValidationMonad String Int) ^? _I1+Just "err"++>>> (ValidationMonadT (Identity (Success 1)) :: ValidationMonad String Int) ^? _I1+Nothing++>>> _I1 # "err" :: ValidationMonad String Int+ValidationMonadT (Identity (Failure "err"))+-}+instance Injection1 (ValidationMonad err a) (ValidationMonad err' a) err err' where+  _I1 = from validationMonad . _I1+  {-# INLINE _I1 #-}++{- | The second constructor, 'Success', of the 'Validation' inside 'Identity'.++>>> import Control.Lens((^?), (#))+>>> (ValidationMonadT (Identity (Success 1)) :: ValidationMonad String Int) ^? _I2+Just 1++>>> (ValidationMonadT (Identity (Failure "err")) :: ValidationMonad String Int) ^? _I2+Nothing++>>> _I2 # 1 :: ValidationMonad String Int+ValidationMonadT (Identity (Success 1))+-}+instance Injection2 (ValidationMonad err a) (ValidationMonad err a') a a' where+  _I2 = from validationMonad . _I2+  {-# INLINE _I2 #-}  -- Isomorphism between @Either err a@ and @ValidationMonad err a@. eitherValidationMonad :: Iso' (Either err a) (ValidationMonad err a)

@@ -70,13 +70,17 @@   matchValidatorProfunctor,   matchValidatorMonad,   matchValidatorMonadProfunctor,++  -- * Constructing prisms from validators+  (<--),+  unmatch, ) where  import Control.Applicative (Alternative (empty, (<|>))) import Control.Arrow (Arrow (arr, first), ArrowApply (app), ArrowChoice (left, right), ArrowPlus ((<+>)), ArrowZero (zeroArrow)) import Control.Category (Category (..))-import Control.Lens (APrism, Getter, Lens', Prism', Review, Rewrapped, Wrapped (_Wrapped', type Unwrapped), from, matching, review, unto, view)-import Control.Lens.Iso (Iso', iso)+import Control.Lens (APrism, AReview, Getter, Lens', Prism, Prism', Review, Rewrapped, Wrapped (_Wrapped', type Unwrapped), from, matching, prism, review, unto, view)+import Control.Lens.Iso (Iso', iso, mapping) import Control.Monad (MonadPlus, ap, (>=>)) import Control.Monad.Cont.Class (MonadCont (callCC)) import Control.Monad.Error.Class (MonadError (catchError, throwError))@@ -1945,3 +1949,113 @@ matchValidatorMonadProfunctor :: APrism s t a b -> ValidatorMonadProfunctor t s a matchValidatorMonadProfunctor = match {-# INLINE matchValidatorMonadProfunctor #-}++-- ==================================+-- Constructing prisms from validators+-- ==================================++{- | Construct a prism from a review and a validator. The prism matches+when the validator succeeds, and otherwise returns the failure, retyped to+@t@ (see 'Control.Lens.matching'). It is built with the review.++'unmatch' is an inverse of 'match'. For a prism @p@, @'unmatch' p ('match' p)@+is @p@, and for a validator @v@, @'match' ('unmatch' r v)@ is @v@. The prism+is lawful when the validator succeeds with @b@ on @'review' r b@, and fails+with its input otherwise.++The result is a 'Prism', so it can be used directly with 'Control.Lens.^?',+'review' and other optics, and the review can be any 'AReview', including a+'Prism' or an 'Control.Lens.Iso'.++The validator can be any validator with a 'GetValidator' instance.++>>> import Control.Lens(Prism, matching, withPrism)+>>> let positive = Validator (\n -> if n > 0 then Success n else Failure n) :: Validator Int Int Int+>>> let p = unmatch id positive+>>> matching p 5+Right 5++>>> matching p (-5)+Left (-5)++>>> 5 ^? p+Just 5++>>> review p 7+7++A type-changing prism.++>>> let p = unmatch _Left (matchValidator _Left) :: Prism (Either Int String) (Either Bool String) Int Bool+>>> matching p (Left 1)+Right 1++>>> matching p (Right "x")+Left (Right "x")++>>> withPrism p (\build _ -> build True)+Left True++'match' recovers the validator.++>>> runV (matchValidator (unmatch _Just (matchValidator _Just))) (Just 3)+Success 3++>>> runV (matchValidator (unmatch _Just (matchValidator _Just))) (Nothing :: Maybe Int)+Failure Nothing++The other validators are written the same way.++>>> let p = unmatch _Right (matchValidatorProfunctor _Right) :: Prism (Either String Int) (Either String Int) Int Int+>>> matching p (Left "x")+Left (Left "x")++>>> let p = unmatch _Just (matchValidatorMonad _Just >>= \n -> if n > (0 :: Int) then pure n else throwError (Just n))+>>> matching p (Just 3)+Right 3++>>> matching p (Just (-3))+Left (Just (-3))++>>> let p = unmatch _Just (matchValidatorMonadProfunctor _Just)+>>> matching p (Nothing :: Maybe Int)+Left Nothing+-}+unmatch :: (GetValidator v s t a) => AReview t b -> v -> Prism s t a b+unmatch r v =+  prism (review r) (view (getValidator . _Wrapped' . mapping Validation.either) v)+{-# INLINE unmatch #-}+{-# SPECIALIZE unmatch :: AReview t b -> Validator s t a -> Prism s t a b #-}+{-# SPECIALIZE unmatch :: AReview t b -> ValidatorProfunctor t s a -> Prism s t a b #-}+{-# SPECIALIZE unmatch :: AReview t b -> ValidatorMonad s t a -> Prism s t a b #-}+{-# SPECIALIZE unmatch :: AReview t b -> ValidatorMonadProfunctor t s a -> Prism s t a b #-}++{- | An operator for 'unmatch'. @r '<--' v@ is @'unmatch' r v@.++'<--' is @infixr 2@. It binds more loosely than '.', '-->', '<$>' and+'<!>', so the review and the validator can each be written without+parentheses.++>>> import Control.Lens(Prism, matching)+>>> let p = _Right . _Just <-- length <$> matchValidator _Left <!> matchValidator (_Right . _Just) :: Prism (Either String (Maybe Int)) (Either String (Maybe Int)) Int Int+>>> matching p (Left "abc")+Right 3++>>> matching p (Right (Just 5))+Right 5++>>> matching p (Right Nothing)+Left (Right Nothing)++>>> review p 7+Right (Just 7)+-}+(<--) :: (GetValidator v s t a) => AReview t b -> v -> Prism s t a b+(<--) = unmatch+{-# INLINE (<--) #-}+{-# SPECIALIZE (<--) :: AReview t b -> Validator s t a -> Prism s t a b #-}+{-# SPECIALIZE (<--) :: AReview t b -> ValidatorProfunctor t s a -> Prism s t a b #-}+{-# SPECIALIZE (<--) :: AReview t b -> ValidatorMonad s t a -> Prism s t a b #-}+{-# SPECIALIZE (<--) :: AReview t b -> ValidatorMonadProfunctor t s a -> Prism s t a b #-}++infixr 2 <--

@@ -2,13 +2,14 @@ {-# LANGUAGE ScopedTypeVariables #-}  import Control.Applicative (liftA3)-import Control.Lens (from, review, (#), (^.), (^?), _Just, _Left, _Right)+import Control.Lens (APrism', clonePrism, from, matching, review, (#), (^.), (^?), _Just, _Left, _Right) import Control.Monad (join, unless) import Data.Bifunctor (bimap) import Data.Bifunctor.Swap (swap) import Data.Functor.Alt (Alt ((<!>))) import Data.Functor.Apply (Apply ((<.>))) import Data.Functor.Identity (Identity (..))+import Data.Lens.Injection (_I1, _I2) import Data.Validation import Hedgehog import qualified Hedgehog.Gen as Gen@@ -51,6 +52,16 @@         , ("prop_success_prism_miss", prop_success_prism_miss)         , ("prop_poly_failure_prism", prop_poly_failure_prism)         , ("prop_poly_success_prism", prop_poly_success_prism)+        , ("prop_injection1_review_preview", prop_prism_review_preview (_I1 :: APrism' (Validation [String] Int) [String]) genStrings)+        , ("prop_injection1_matching_review", prop_prism_matching_review _I1 testGen)+        , ("prop_injection2_review_preview", prop_prism_review_preview (_I2 :: APrism' (Validation [String] Int) Int) genInt)+        , ("prop_injection2_matching_review", prop_prism_matching_review _I2 testGen)+        , ("prop_validationMonad_injection1_review_preview", prop_prism_review_preview (_I1 :: APrism' (ValidationMonad [String] Int) [String]) genStrings)+        , ("prop_validationMonad_injection1_matching_review", prop_prism_matching_review _I1 testGenMonad)+        , ("prop_validationMonad_injection2_review_preview", prop_prism_review_preview (_I2 :: APrism' (ValidationMonad [String] Int) Int) genInt)+        , ("prop_validationMonad_injection2_matching_review", prop_prism_matching_review _I2 testGenMonad)+        , ("prop_validationMonad_injection1_validation", prop_validationMonad_injection1_validation)+        , ("prop_validationMonad_injection2_validation", prop_validationMonad_injection2_validation)         , ("prop_swap_failure", prop_swap_failure)         , ("prop_swap_success", prop_swap_success)         , ("prop_swap_involution", prop_swap_involution)@@ -78,6 +89,14 @@         , ("prop_arrow_validatorProfunctor_alt", prop_arrow_validatorProfunctor_alt)         , ("prop_arrow_validatorMonad_alt", prop_arrow_validatorMonad_alt)         , ("prop_arrow_validatorMonadProfunctor_alt", prop_arrow_validatorMonadProfunctor_alt)+        , ("prop_unmatch_match_matching", prop_unmatch_match_matching)+        , ("prop_unmatch_match_review", prop_unmatch_match_review)+        , ("prop_match_unmatch", prop_match_unmatch)+        , ("prop_unmatch_validatorProfunctor", prop_unmatch_validatorProfunctor)+        , ("prop_unmatch_validatorMonad", prop_unmatch_validatorMonad)+        , ("prop_unmatch_validatorMonadProfunctor", prop_unmatch_validatorMonadProfunctor)+        , ("prop_unmatch_arrow", prop_unmatch_arrow)+        , ("prop_unmatch_arrow_alt", prop_unmatch_arrow_alt)         ]    unless result exitFailure@@ -99,6 +118,9 @@ testGen :: Gen (Validation [String] Int) testGen = genValidation genStrings genInt +testGenMonad :: Gen (ValidationMonad [String] Int)+testGenMonad = fmap (^. validationMonad) testGen+ -- Semigroup / Monoid  mkAssoc :: (Validation [String] Int -> Validation [String] Int -> Validation [String] Int) -> Property@@ -280,6 +302,34 @@     let v = __Success # a :: Validation [String] Int     v ^? __Success === Just a +-- Injections++-- | Prism law: previewing a reviewed value gives that value back.+prop_prism_review_preview :: (Eq a, Show a) => APrism' s a -> Gen a -> Property+prop_prism_review_preview p ga =+  property $ do+    a <- forAll ga+    (clonePrism p # a) ^? clonePrism p === Just a++-- | Prism law: reviewing a matched value gives the original back, and a miss is unchanged.+prop_prism_matching_review :: (Eq s, Show s) => APrism' s a -> Gen s -> Property+prop_prism_matching_review p gs =+  property $ do+    s <- forAll gs+    Prelude.either Prelude.id (review (clonePrism p)) (matching p s) === s++prop_validationMonad_injection1_validation :: Property+prop_validationMonad_injection1_validation =+  property $ do+    v <- forAll testGen+    (v ^. validationMonad) ^? _I1 === v ^? _I1++prop_validationMonad_injection2_validation :: Property+prop_validationMonad_injection2_validation =+  property $ do+    v <- forAll testGen+    (v ^. validationMonad) ^? _I2 === v ^? _I2+ -- Swap  prop_swap_failure :: Property@@ -500,3 +550,62 @@     let ValidatorMonadProfunctorT f = _Left --> Prelude.id <!> _Right Prelude.. _Just --> show :: ValidatorMonadProfunctor Input Input String         ValidationMonadT (Identity r) = f i     r === expected i++-- unmatch and (<--): construct a prism from a review and a validator++-- | A validator that succeeds on a positive number, and fails with its input otherwise.+positive :: Validator Int Int Int+positive = Validator (\n -> if n > 0 then Success n else Failure n)++-- | The expected match of positive.+expectedPositive :: Int -> Prelude.Either Int Int+expectedPositive n = if n > 0 then Right n else Left n++prop_unmatch_match_matching :: Property+prop_unmatch_match_matching =+  property $ do+    x <- forAll (genEither genStrings genInt)+    matching (unmatch _Right matchRight) x === matching _Right x++prop_unmatch_match_review :: Property+prop_unmatch_match_review =+  property $ do+    a <- forAll genInt+    review (unmatch _Right matchRight) a === (review _Right a :: Prelude.Either [String] Int)++prop_match_unmatch :: Property+prop_match_unmatch =+  property $ do+    n <- forAll genInt+    runValidator (matchValidator (unmatch Prelude.id positive)) n === runValidator positive n++prop_unmatch_validatorProfunctor :: Property+prop_unmatch_validatorProfunctor =+  property $ do+    n <- forAll genInt+    matching (unmatch Prelude.id (positive ^. validatorProfunctor)) n === expectedPositive n++prop_unmatch_validatorMonad :: Property+prop_unmatch_validatorMonad =+  property $ do+    n <- forAll genInt+    matching (unmatch Prelude.id (positive ^. validatorMonadT)) n === expectedPositive n++prop_unmatch_validatorMonadProfunctor :: Property+prop_unmatch_validatorMonadProfunctor =+  property $ do+    n <- forAll genInt+    matching (unmatch Prelude.id (positive ^. validatorMonadProfunctorT)) n === expectedPositive n++prop_unmatch_arrow :: Property+prop_unmatch_arrow =+  property $ do+    n <- forAll genInt+    matching (Prelude.id <-- positive) n === matching (unmatch Prelude.id positive) n++prop_unmatch_arrow_alt :: Property+prop_unmatch_arrow_alt =+  property $ do+    i <- forAll genInput+    let p = _Left <-- matchValidator _Left <!> show <$> matchValidator (_Right Prelude.. _Just)+    matching p i === expected i ^. either

@@ -1,5 +1,5 @@ name:               validation-version:            1.3.2+version:            1.3.3 license:            BSD3 license-file:       LICENCE author:             Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> <dibblego>, Nick Partridge <nkpart>@@ -77,6 +77,7 @@                       base          >= 4.18    && < 5                     , assoc         >= 1.1     && < 2                     , deepseq       >= 1.4.8.1 && < 2+                    , either-n      >= 0.1     && < 0.2                     , selective     >= 0.7     && < 1                     , semigroupoids >= 6.0.0.1 && < 7                     , bifunctors    >= 5.6     && < 6@@ -111,6 +112,7 @@                       base          >= 4.18    && < 5                     , assoc         >= 1.1     && < 2                     , bifunctors    >= 5.6     && < 6+                    , either-n      >= 0.1     && < 0.2                     , hedgehog      >= 1.2     && < 2                     , lens          >= 5.2.1   && < 6                     , semigroupoids >= 6.0.0.1 && < 7