genvalidity 0.5.1.0 → 0.6.1.0

raw patch · 6 files changed

+537/−82 lines, 6 filesdep +hspec-coredep ~validityPVP ok

version bump matches the API change (PVP)

Dependencies added: hspec-core

Dependency ranges changed: validity

API changes (from Hackage documentation)

Files

• genvalidity.cabal +6/−3
• src/Data/GenValidity.hs +224/−39
• test/Data/GenValidity/GenericSpec.hs +107/−0
• test/Data/GenValidity/ShrinkGenericSpec.hs +77/−0
• test/Data/GenValiditySpec.hs +43/−4
• test/Data/InstanceSpec.hs +80/−36

@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 75f45c202b686df17dfa4b7d2a4c2d401bb0c8e9a9437f40d008cef1de3ef380+-- hash: 9a0fdf5334fa38718d2c186fdefbe256697468190ad9f948af82c99a6acefb9a  name:           genvalidity-version:        0.5.1.0+version:        0.6.1.0 synopsis:       Testing utilities for the validity library description:    Note: There are companion instance packages for this library:                 .@@ -55,7 +55,7 @@   build-depends:       QuickCheck >=2.7     , base >=4.7 && <5-    , validity >=0.5+    , validity >=0.8   if impl(ghc >=8.0.0)     ghc-options: -Wno-redundant-constraints   default-language: Haskell2010@@ -64,6 +64,8 @@   type: exitcode-stdio-1.0   main-is: Spec.hs   other-modules:+      Data.GenValidity.GenericSpec+      Data.GenValidity.ShrinkGenericSpec       Data.GenValiditySpec       Data.InstanceSpec       Paths_genvalidity@@ -75,4 +77,5 @@     , base     , genvalidity     , hspec+    , hspec-core   default-language: Haskell2010

@@ -68,6 +68,7 @@ import Data.Fixed (Fixed(..), HasResolution) #if MIN_VERSION_base(4,9,0) import Data.List.NonEmpty (NonEmpty((:|)))+import qualified Data.List.NonEmpty as NE #endif #if MIN_VERSION_base(4,8,0) import Data.Word (Word8, Word16, Word32, Word64)@@ -81,6 +82,11 @@  import Test.QuickCheck hiding (Fixed) +#if !MIN_VERSION_QuickCheck(2,8,0)+import Data.List (sortBy)+import Data.Ord (comparing)+#endif+ #if MIN_VERSION_base(4,8,0) import GHC.Natural import Control.Monad (forM)@@ -115,13 +121,13 @@     genUnchecked :: Gen a     default genUnchecked :: (Generic a, GGenUnchecked (Rep a)) =>         Gen a-    genUnchecked = to <$> gGenUnchecked+    genUnchecked = genericGenUnchecked      shrinkUnchecked :: a -> [a]     default shrinkUnchecked ::         (Generic a, GUncheckedRecursivelyShrink (Rep a), GUncheckedSubterms (Rep a) a) =>         a -> [a]-    shrinkUnchecked = gShrinkUnchecked+    shrinkUnchecked = genericShrinkUnchecked  -- | A class of types for which valid values can be generated. --@@ -142,6 +148,12 @@     -- data, otherwise your testing may not cover all cases.     genValid = genUnchecked `suchThat` isValid +    -- | Shrink a valid value.+    --+    -- It is important that this shrinking function only shrinks values to valid values.+    -- If `shrinkValid` ever shrinks a value to an invalid value, the test that is being shrunk for+    -- might fail for a different reason than for the reason that it originally failed.+    -- This would lead to very confusing error messages.     shrinkValid :: a -> [a]     shrinkValid = filter isValid . shrinkUnchecked @@ -169,6 +181,9 @@             a <- resize r genUnchecked             b <- resize s genUnchecked             return (a, b)+    shrinkUnchecked (a, b) = ((,) <$> shrinkUnchecked a <*> shrinkUnchecked b)+      ++ [ (a', b) | a' <- shrinkUnchecked a ]+      ++ [ (a, b') | b' <- shrinkUnchecked b ]  instance (GenValid a, GenValid b) => GenValid (a, b) where     genValid =@@ -177,6 +192,9 @@             a <- resize r genValid             b <- resize s genValid             return (a, b)+    shrinkValid (a, b) = ((,) <$> shrinkValid a <*> shrinkValid b)+      ++ [ (a', b) | a' <- shrinkValid a ]+      ++ [ (a, b') | b' <- shrinkValid b ]  instance (GenInvalid a, GenInvalid b) => GenInvalid (a, b) where     genInvalid =@@ -193,9 +211,13 @@  instance (GenUnchecked a, GenUnchecked b) => GenUnchecked (Either a b) where     genUnchecked = oneof [Left <$> genUnchecked, Right <$> genUnchecked]+    shrinkUnchecked (Left a) = Left <$> shrinkUnchecked a+    shrinkUnchecked (Right b) = Right <$> shrinkUnchecked b  instance (GenValid a, GenValid b) => GenValid (Either a b) where     genValid = oneof [Left <$> genValid, Right <$> genValid]+    shrinkValid (Left a) = Left <$> shrinkValid a+    shrinkValid (Right b) = Right <$> shrinkValid b  -- | This instance ensures that the generated tupse contains at least one invalid element. The other element is unchecked. instance (GenInvalid a, GenInvalid b) => GenInvalid (Either a b) where@@ -210,6 +232,10 @@             b <- resize s genUnchecked             c <- resize t genUnchecked             return (a, b, c)+    shrinkUnchecked (a, b, c) =+        [ (a', b', c')+        | (a', (b', c')) <- shrinkUnchecked (a, (b, c))+        ]  instance (GenValid a, GenValid b, GenValid c) => GenValid (a, b, c) where     genValid =@@ -219,6 +245,10 @@             b <- resize s genValid             c <- resize t genValid             return (a, b, c)+    shrinkValid (a, b, c) =+        [ (a', b', c')+        | (a', (b', c')) <- shrinkValid (a, (b, c))+        ]  -- | This instance ensures that the generated triple contains at least one invalid element. The other two are unchecked. instance (GenInvalid a, GenInvalid b, GenInvalid c) =>@@ -251,6 +281,10 @@             c <- resize t genUnchecked             d <- resize u genUnchecked             return (a, b, c, d)+    shrinkUnchecked (a, b, c, d) =+        [ (a', b', c', d')+        | (a', (b', (c', d'))) <- shrinkUnchecked (a, (b, (c, d)))+        ]  instance (GenValid a, GenValid b, GenValid c, GenValid d) =>          GenValid (a, b, c, d) where@@ -262,6 +296,10 @@             c <- resize t genValid             d <- resize u genValid             return (a, b, c, d)+    shrinkValid (a, b, c, d) =+        [ (a', b', c', d')+        | (a', (b', (c', d'))) <- shrinkValid (a, (b, (c, d)))+        ]  -- | This instance ensures that the generated triple contains at least one invalid element. The other two are unchecked. instance (GenInvalid a, GenInvalid b, GenInvalid c, GenInvalid d) =>@@ -303,6 +341,10 @@             d <- resize u genUnchecked             e <- resize v genUnchecked             return (a, b, c, d, e)+    shrinkUnchecked (a, b, c, d, e) =+        [ (a', b', c', d', e')+        | (a', (b', (c', (d', e')))) <- shrinkUnchecked (a, (b, (c, (d, e))))+        ]  instance (GenValid a, GenValid b, GenValid c, GenValid d, GenValid e) =>          GenValid (a, b, c, d, e) where@@ -315,6 +357,10 @@             d <- resize u genValid             e <- resize v genValid             return (a, b, c, d, e)+    shrinkValid (a, b, c, d, e) =+        [ (a', b', c', d', e')+        | (a', (b', (c', (d', e')))) <- shrinkValid (a, (b, (c, (d, e))))+        ]  -- | This instance ensures that the generated triple contains at least one invalid element. The other two are unchecked. instance (GenInvalid a, GenInvalid b, GenInvalid c, GenInvalid d, GenInvalid e) =>@@ -357,38 +403,52 @@  instance GenUnchecked a => GenUnchecked (Maybe a) where     genUnchecked = oneof [pure Nothing, Just <$> genUnchecked]+    shrinkUnchecked Nothing = []+    shrinkUnchecked (Just a) = Nothing : (Just <$> shrinkUnchecked a) + instance GenValid a => GenValid (Maybe a) where     genValid = oneof [pure Nothing, Just <$> genValid]+    shrinkValid Nothing = []+    shrinkValid (Just a) = Nothing : (Just <$> shrinkValid a)  instance GenInvalid a => GenInvalid (Maybe a) where     genInvalid = Just <$> genInvalid -instance GenUnchecked a => GenUnchecked [a] where-    genUnchecked = genListOf genUnchecked-    shrinkUnchecked = shrinkList shrinkUnchecked- #if MIN_VERSION_base(4,9,0) instance GenUnchecked a => GenUnchecked (NonEmpty a) where-    genUnchecked = (:|) <$> genUnchecked <*> genUnchecked+    genUnchecked = do+      l <- genUnchecked+      case NE.nonEmpty l of+        Nothing -> scale (+1) genUnchecked+        Just ne -> pure ne     shrinkUnchecked (v :| vs) = [ e :| es | (e, es) <- shrinkUnchecked (v, vs)]  instance GenValid a => GenValid (NonEmpty a) where-    genValid = (:|) <$> genValid <*> genValid+    genValid = do+      l <- genValid+      case NE.nonEmpty l of+        Nothing -> scale (+1) genValid+        Just ne -> pure ne+    shrinkValid (v :| vs) = [ e :| es | (e, es) <- shrinkValid (v, vs)]  instance GenInvalid a => GenInvalid (NonEmpty a) where-    genInvalid = sized $ \n -> do-      (a, b) <- genSplit n-      oneof-        [ (:|) <$> resize a genUnchecked <*> resize b genInvalid-        , (:|) <$> resize a genInvalid <*> resize b genUnchecked-        ]+    genInvalid = do+      l <- genInvalid+      case NE.nonEmpty l of+        Nothing -> scale (+1) genInvalid+        Just ne -> pure ne #endif +instance GenUnchecked a => GenUnchecked [a] where+    genUnchecked = genListOf genUnchecked+    shrinkUnchecked = shrinkList shrinkUnchecked+ -- | If we can generate values of a certain type, we can also generate lists of -- them. instance GenValid a => GenValid [a] where     genValid = genListOf genValid+    shrinkValid = shrinkList shrinkValid  -- | This instance ensures that the generated list contains at least one element -- that satisfies 'isInvalid'. The rest is unchecked.@@ -499,21 +559,22 @@  -- | Either 'NaN' or 'Infinity'. instance GenInvalid Float where-    genInvalid = elements [read "NaN", read "Infinity", read "-Infinity", read "-0"]+    genInvalid = elements [read "NaN", read "Infinity", read "-Infinity"]  instance GenUnchecked Double where-    genUnchecked = arbitrary+    genUnchecked = frequency [(9, genValid), (1, genInvalid)] #if MIN_VERSION_QuickCheck(2,9,2)     shrinkUnchecked = shrink #else     shrinkUnchecked _ = [] #endif -instance GenValid Double+instance GenValid Double where+    genValid = arbitrary  -- | Either 'NaN' or 'Infinity'. instance GenInvalid Double where-    genInvalid = elements [read "NaN", read "Infinity", read "-Infinity", read "-0"]+    genInvalid = elements [read "NaN", read "Infinity", read "-Infinity"]  instance GenUnchecked Integer where     genUnchecked = arbitrary@@ -532,17 +593,11 @@ #endif  instance (Integral a, GenUnchecked a) => GenUnchecked (Ratio a) where-    genUnchecked = do-        n <- genUnchecked-        d <- genUnchecked-        pure $ n :% d+    genUnchecked = (:%) <$> genUnchecked <*> genUnchecked     shrinkUnchecked (n :% d) = [n' :% d' | (n', d') <- shrinkUnchecked (n, d)]  instance (Integral a, Num a, Ord a, GenValid a) => GenValid (Ratio a) where-    genValid = do-      n <- genValid-      d <- genValid `suchThat` (> 0)-      pure $ n % d+    genValid = (%) <$> genValid <*> (genValid `suchThat` (> 0))     shrinkValid (n :% d) = [n' % d' | (n', d') <- shrinkValid (n, d), d' > 0]  instance (Integral a, Num a, Ord a, GenValid a) => GenInvalid (Ratio a)@@ -610,13 +665,23 @@  -- | 'arbPartition n' generates a list 'ls' such that 'sum ls' equals 'n'. arbPartition :: Int -> Gen [Int]-arbPartition k-    | k <= 0 = pure []-    | otherwise = do-        first <- choose (1, k)-        rest <- arbPartition $ k - first-        return $ first : rest+arbPartition i = go i >>= shuffle+  where+    go k+      | k <= 0 = pure []+      | otherwise = do+          first <- choose (1, k)+          rest <- arbPartition $ k - first+          return $ first : rest +#if !MIN_VERSION_QuickCheck(2,8,0)+-- | Generates a random permutation of the given list.+shuffle :: [a] -> Gen [a]+shuffle xs = do+  ns <- vectorOf (length xs) (choose (minBound :: Int, maxBound))+  return (map snd (sortBy (comparing fst) (zip ns xs)))+#endif+ -- | A version of @listOf@ that takes size into account more accurately. genListOf :: Gen a -> Gen [a] genListOf func =@@ -625,6 +690,9 @@         pars <- arbPartition size         forM pars $ \i -> resize i func +genericGenUnchecked :: (Generic a, GGenUnchecked (Rep a)) => Gen a+genericGenUnchecked = to <$> gGenUnchecked+ class GGenUnchecked f where     gGenUnchecked :: Gen (f a) @@ -632,10 +700,7 @@     gGenUnchecked = pure U1  instance (GGenUnchecked a, GGenUnchecked b) => GGenUnchecked (a :*: b) where-    gGenUnchecked = do-        g1 <- gGenUnchecked-        g2 <- gGenUnchecked-        pure $ g1 :*: g2+    gGenUnchecked = (:*:) <$> gGenUnchecked <*> gGenUnchecked  instance (GGenUnchecked a, GGenUnchecked b) => GGenUnchecked (a :+: b) where     gGenUnchecked = oneof [L1 <$> gGenUnchecked, R1 <$> gGenUnchecked]@@ -649,8 +714,8 @@  -- | Shrink a term to any of its immediate subterms, -- and also recursively shrink all subterms.-gShrinkUnchecked :: (Generic a, GUncheckedRecursivelyShrink (Rep a), GUncheckedSubterms (Rep a) a) => a -> [a]-gShrinkUnchecked x = uncheckedSubterms x ++ uncheckedRecursivelyShrink x+genericShrinkUnchecked :: (Generic a, GUncheckedRecursivelyShrink (Rep a), GUncheckedSubterms (Rep a) a) => a -> [a]+genericShrinkUnchecked x = uncheckedSubterms x ++ uncheckedRecursivelyShrink x  -- | Recursively shrink all immediate uncheckedSubterms. uncheckedRecursivelyShrink :: (Generic a, GUncheckedRecursivelyShrink (Rep a)) => a -> [a]@@ -661,7 +726,9 @@  instance (GUncheckedRecursivelyShrink f, GUncheckedRecursivelyShrink g) => GUncheckedRecursivelyShrink (f :*: g) where   gUncheckedRecursivelyShrink (x :*: y) =-      [x' :*: y' | x' <- gUncheckedRecursivelyShrink x, y' <- gUncheckedRecursivelyShrink y]+    ((:*:) <$> gUncheckedRecursivelyShrink x <*> gUncheckedRecursivelyShrink y)+      ++ [ x' :*: y | x' <- gUncheckedRecursivelyShrink x ]+      ++ [ x :*: y' | y' <- gUncheckedRecursivelyShrink y ]  instance (GUncheckedRecursivelyShrink f, GUncheckedRecursivelyShrink g) => GUncheckedRecursivelyShrink (f :+: g) where   gUncheckedRecursivelyShrink (L1 x) = map L1 (gUncheckedRecursivelyShrink x)@@ -735,3 +802,121 @@ instance OVERLAPPING_ GUncheckedSubtermsIncl (K1 i a) b where   gUncheckedSubtermsIncl (K1 _) = [] ++genValidStructurally :: (Validity a, Generic a, GGenValid (Rep a)) => Gen a+genValidStructurally = genValidStructurallyWithoutExtraChecking `suchThat` isValid++genValidStructurallyWithoutExtraChecking :: (Generic a, GGenValid (Rep a)) => Gen a+genValidStructurallyWithoutExtraChecking = to <$> gGenValid++class GGenValid f where+    gGenValid :: Gen (f a)++instance GGenValid U1 where+    gGenValid = pure U1++instance (GGenValid a, GGenValid b) => GGenValid (a :*: b) where+    gGenValid = (:*:) <$> gGenValid <*> gGenValid++instance (GGenValid a, GGenValid b) => GGenValid (a :+: b) where+    gGenValid = oneof [L1 <$> gGenValid, R1 <$> gGenValid]++instance (GGenValid a) => GGenValid (M1 i c a) where+    gGenValid = M1 <$> gGenValid++instance (GenValid a) => GGenValid (K1 i a) where+    gGenValid = K1 <$> genValid+++-- | Shrink a term to any of its immediate valid subterms,+-- and also recursively shrink all subterms.+shrinkValidStructurally :: (Validity a, Generic a, GValidRecursivelyShrink (Rep a), GValidSubterms (Rep a) a) => a -> [a]+shrinkValidStructurally = filter isValid . shrinkValidStructurallyWithoutExtraFiltering++shrinkValidStructurallyWithoutExtraFiltering :: (Generic a, GValidRecursivelyShrink (Rep a), GValidSubterms (Rep a) a) => a -> [a]+shrinkValidStructurallyWithoutExtraFiltering x = structurallyValidSubterms x ++ structurallyValidRecursivelyShrink x++-- | Recursively shrink all immediate structurally valid subterms.+structurallyValidRecursivelyShrink :: (Generic a, GValidRecursivelyShrink (Rep a)) => a -> [a]+structurallyValidRecursivelyShrink = map to . gValidRecursivelyShrink . from++class GValidRecursivelyShrink f where+  gValidRecursivelyShrink :: f a -> [f a]++instance (GValidRecursivelyShrink f, GValidRecursivelyShrink g) => GValidRecursivelyShrink (f :*: g) where+  gValidRecursivelyShrink (x :*: y) =+    ((:*:) <$> gValidRecursivelyShrink x <*> gValidRecursivelyShrink y)+      ++ [ x' :*: y | x' <- gValidRecursivelyShrink x ]+      ++ [ x :*: y' | y' <- gValidRecursivelyShrink y ]++instance (GValidRecursivelyShrink f, GValidRecursivelyShrink g) => GValidRecursivelyShrink (f :+: g) where+  gValidRecursivelyShrink (L1 x) = map L1 (gValidRecursivelyShrink x)+  gValidRecursivelyShrink (R1 x) = map R1 (gValidRecursivelyShrink x)++instance GValidRecursivelyShrink f => GValidRecursivelyShrink (M1 i c f) where+  gValidRecursivelyShrink (M1 x) = map M1 (gValidRecursivelyShrink x)++instance GenValid a => GValidRecursivelyShrink (K1 i a) where+  gValidRecursivelyShrink (K1 x) = map K1 (shrinkValid x)++instance GValidRecursivelyShrink U1 where+  gValidRecursivelyShrink U1 = []++instance GValidRecursivelyShrink V1 where+  -- The empty type can't be shrunk to anything.+  gValidRecursivelyShrink _ = []+++-- | All immediate validSubterms of a term.+structurallyValidSubterms :: (Generic a, GValidSubterms (Rep a) a) => a -> [a]+structurallyValidSubterms = gValidSubterms . from+++class GValidSubterms f a where+  gValidSubterms :: f a -> [a]++instance GValidSubterms V1 a where+  gValidSubterms _ = []++instance GValidSubterms U1 a where+  gValidSubterms U1 = []++instance (GValidSubtermsIncl f a, GValidSubtermsIncl g a) => GValidSubterms (f :*: g) a where+  gValidSubterms (l :*: r) = gValidSubtermsIncl l ++ gValidSubtermsIncl r++instance (GValidSubtermsIncl f a, GValidSubtermsIncl g a) => GValidSubterms (f :+: g) a where+  gValidSubterms (L1 x) = gValidSubtermsIncl x+  gValidSubterms (R1 x) = gValidSubtermsIncl x++instance GValidSubterms f a => GValidSubterms (M1 i c f) a where+  gValidSubterms (M1 x) = gValidSubterms x++instance GValidSubterms (K1 i a) b where+  gValidSubterms (K1 _) = []+++class GValidSubtermsIncl f a where+  gValidSubtermsIncl :: f a -> [a]++instance GValidSubtermsIncl V1 a where+  gValidSubtermsIncl _ = []++instance GValidSubtermsIncl U1 a where+  gValidSubtermsIncl U1 = []++instance (GValidSubtermsIncl f a, GValidSubtermsIncl g a) => GValidSubtermsIncl (f :*: g) a where+  gValidSubtermsIncl (l :*: r) = gValidSubtermsIncl l ++ gValidSubtermsIncl r++instance (GValidSubtermsIncl f a, GValidSubtermsIncl g a) => GValidSubtermsIncl (f :+: g) a where+  gValidSubtermsIncl (L1 x) = gValidSubtermsIncl x+  gValidSubtermsIncl (R1 x) = gValidSubtermsIncl x++instance GValidSubtermsIncl f a => GValidSubtermsIncl (M1 i c f) a where+  gValidSubtermsIncl (M1 x) = gValidSubtermsIncl x++-- This is the important case: We've found a term of the same type.+instance OVERLAPPING_ GValidSubtermsIncl (K1 i a) a where+  gValidSubtermsIncl (K1 x) = [x]++instance OVERLAPPING_ GValidSubtermsIncl (K1 i a) b where+  gValidSubtermsIncl (K1 _) = []

@@ -0,0 +1,107 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Data.GenValidity.GenericSpec+    ( spec+    ) where++import GHC.Generics (Generic, Rep)++import Control.Monad++import Test.Hspec+import Test.QuickCheck++import Data.Proxy+import Data.Typeable++import Data.GenValidity++spec :: Spec+spec = do+    describe "genValidStructurally" $ do+        genValidstructurallySpec (Proxy :: Proxy Bool)+        genValidstructurallySpec (Proxy :: Proxy Ordering)+        genValidstructurallySpec (Proxy :: Proxy (Maybe Double))+        genValidstructurallySpec (Proxy :: Proxy (Either Double Rational))+        genValidstructurallySpec (Proxy :: Proxy MyType)+    describe "shrinkValidStructurally" $ do+        shrinkValidstructurallySpec (Proxy :: Proxy Bool)+        shrinkValidstructurallySpec (Proxy :: Proxy Ordering)+        shrinkValidstructurallySpec (Proxy :: Proxy (Maybe Double))+        shrinkValidstructurallySpec (Proxy :: Proxy (Either Double Rational))+        shrinkValidstructurallySpec (Proxy :: Proxy MyType)++genValidstructurallySpec ::+       forall a.+       (Validity a, Show a, Eq a, Typeable a, Generic a, GGenValid (Rep a))+    => Proxy a+    -> Spec+genValidstructurallySpec proxy =+    it (unwords ["only generates valid", "\"" ++ nameOf proxy ++ "\"s"]) $+    forAll (genValidStructurally :: Gen a) $ \a ->+        case prettyValidation a of+            Right _ -> return ()+            Left err ->+                expectationFailure $+                unlines+                    [ "'validate' reported this value to be invalid: "+                    , show a+                    , "with explanation"+                    , err+                    , ""+                    ]++shrinkValidstructurallySpec ::+       forall a.+       ( Validity a+       , Show a+       , Eq a+       , Typeable a+       , Generic a+       , GenValid a+       , GValidRecursivelyShrink (Rep a)+       , GValidSubterms (Rep a) a+       )+    => Proxy a+    -> Spec+shrinkValidstructurallySpec proxy = do+    it (unwords ["only shrinks to valid", "\"" ++ nameOf proxy ++ "\"s"]) $+        forAll (genValid :: Gen a) $ \a ->+            forM_ (shrinkValidStructurally a) $ \subA ->+                case prettyValidation subA of+                    Right _ -> return ()+                    Left err ->+                        expectationFailure $+                        unlines+                            [ "'validate' reported this value to be invalid: "+                            , show subA+                            , "with explanation"+                            , err+                            , "but it should have been valid from shrinking"+                            ]+    it (unwords+            ["never shrinks to itself for valid", "\"" ++ nameOf proxy ++ "\"s"]) $+        forAll (genValid :: Gen a) $ \a ->+            forM_ (shrinkValidStructurally a) $ \subA ->+                when (subA == a) $+                expectationFailure $ unlines [show a, "was shrunk to itself."]++nameOf ::+       forall a. Typeable a+    => Proxy a+    -> String+nameOf = show . typeRep++data MyType =+    MyType Double+           Rational+    deriving (Show, Eq, Generic, Typeable)++instance Validity MyType++instance GenUnchecked MyType++instance GenValid MyType

@@ -0,0 +1,77 @@+{-# LANGUAGE DeriveGeneric #-}++module Data.GenValidity.ShrinkGenericSpec where++import GHC.Generics (Generic)++import Test.Hspec++import Data.GenValidity++spec :: Spec+spec = do+    describe "genericShrinkUnchecked" $ do+        it "shrinks tuples correctly" $+            genericShrinkUnchecked ((A2, B3)) `shouldBe`+            [(A1, B1), (A1, B2), (A1, B3), (A2, B1), (A2, B2)]+        it "figures out the right shrinking function for Ex" $+            genericShrinkUnchecked (Ex A2 B3) `shouldBe`+            [Ex A1 B1, Ex A1 B2, Ex A1 B3, Ex A2 B1, Ex A2 B2]+    describe "default shrinkValid" $ do+        it "figures out the right shrinking function for A" $+            shrinkValid A2 `shouldBe` [A1]+        it "figures out the right shrinking function for B" $+            shrinkValid B3 `shouldBe` [B1]+        it "shrinks tuples correctly" $+            shrinkValid ((A2, B3)) `shouldBe` [(A1, B1), (A1, B3), (A2, B1)]+        it "figures out the right shrinking function for Ex" $+            shrinkValid (Ex A2 B3) `shouldBe` [Ex A1 B1, Ex A1 B3, Ex A2 B1]+    describe "shrinkValidStructurally" $ do+        it "shrinks tuples correctly" $+            shrinkValidStructurally ((A2, B3)) `shouldBe`+            [(A1, B1), (A1, B3), (A2, B1)]+        it "figures out the right shrinking function for Ex" $+            shrinkValidStructurally (Ex A2 B3) `shouldBe`+            [Ex A1 B1, Ex A1 B3, Ex A2 B1]++data Ex =+    Ex A+       B+    deriving (Show, Eq, Generic)++instance Validity Ex++instance GenUnchecked Ex++instance GenValid Ex++data A+    = A1+    | A2+    deriving (Show, Eq, Generic)++instance Validity A++instance GenUnchecked A where+    shrinkUnchecked A1 = []+    shrinkUnchecked A2 = [A1]++instance GenValid A++data B+    = B1+    | B2+    | B3+    deriving (Show, Eq, Generic)++instance Validity B where+    validate B1 = valid+    validate B2 = invalid "for test"+    validate B3 = valid++instance GenUnchecked B where+    shrinkUnchecked B1 = []+    shrinkUnchecked B2 = [B1]+    shrinkUnchecked B3 = [B1, B2]++instance GenValid B

@@ -9,9 +9,12 @@  spec :: Spec spec = do-    describe "upTo" $+    describe "upTo" $ do         it "returns only positive integers" $-        forAll arbitrary $ \n -> forAll (upTo n) (`shouldSatisfy` (>= 0))+            forAll arbitrary $ \n -> forAll (upTo n) (`shouldSatisfy` (>= 0))+        it "returns only integers smaller than or equal to the given number" $+            forAll arbitrary $ \n ->+                forAll (upTo n) (`shouldSatisfy` (<= (max n 0)))     describe "genSplit" $ do         it "returns positive integers" $             forAll arbitrary $ \i ->@@ -19,8 +22,44 @@                     a `shouldSatisfy` (>= 0)                     b `shouldSatisfy` (>= 0)         it "returns two integers such that the sum is the original integer" $-            forAll (arbitrary `suchThat` (>= 0)) $ \i ->-                forAll (genSplit i) $ \(a, b) -> a + b `shouldBe` i+            forAll arbitrary $ \i ->+                forAll (genSplit i) $ \(a, b) -> a + b `shouldBe` max 0 i+    describe "genSplit3" $ do+        it "returns positive integers" $+            forAll arbitrary $ \i ->+                forAll (genSplit3 i) $ \(a, b, c) -> do+                    a `shouldSatisfy` (>= 0)+                    b `shouldSatisfy` (>= 0)+                    c `shouldSatisfy` (>= 0)+        it "returns three integers such that the sum is the original integer" $+            forAll arbitrary $ \i ->+                forAll (genSplit3 i) $ \(a, b, c) ->+                    a + b + c `shouldBe` max 0 i+    describe "genSplit4" $ do+        it "returns positive integers" $+            forAll arbitrary $ \i ->+                forAll (genSplit4 i) $ \(a, b, c, d) -> do+                    a `shouldSatisfy` (>= 0)+                    b `shouldSatisfy` (>= 0)+                    c `shouldSatisfy` (>= 0)+                    d `shouldSatisfy` (>= 0)+        it "returns four integers such that the sum is the original integer" $+            forAll arbitrary $ \i ->+                forAll (genSplit4 i) $ \(a, b, c, d) ->+                    a + b + c + d `shouldBe` max 0 i+    describe "genSplit5" $ do+        it "returns positive integers" $+            forAll arbitrary $ \i ->+                forAll (genSplit5 i) $ \(a, b, c, d, e) -> do+                    a `shouldSatisfy` (>= 0)+                    b `shouldSatisfy` (>= 0)+                    c `shouldSatisfy` (>= 0)+                    d `shouldSatisfy` (>= 0)+                    e `shouldSatisfy` (>= 0)+        it "returns four integers such that the sum is the original integer" $+            forAll arbitrary $ \i ->+                forAll (genSplit5 i) $ \(a, b, c, d, e) ->+                    a + b + c + d + e `shouldBe` max 0 i     describe "arbPartition" $ do         it "returns an empty list upon strictly negative input" $             forAll (arbitrary `suchThat` (< 0)) $ \n ->

@@ -20,6 +20,7 @@ import Control.Monad  import Test.Hspec+import Test.Hspec.Core.QuickCheck (modifyMaxSize, modifyMaxSuccess) import Test.QuickCheck #if MIN_VERSION_base(4,8,0) import GHC.Natural@@ -49,7 +50,8 @@     threeTupleTests (Proxy :: Proxy Double)     threeTests (Proxy :: Proxy Rational)     threeTupleTests (Proxy :: Proxy Rational)-    threeTests (Proxy :: Proxy (Either Double Double))+    modifyMaxSize (`quot` 2) $+        threeTests (Proxy :: Proxy (Either Double Double))     threeTests (Proxy :: Proxy (Maybe Double))     threeTests (Proxy :: Proxy (Maybe (Maybe Double)))     threeTests (Proxy :: Proxy [Double])@@ -74,38 +76,42 @@     twoTupleTests (Proxy :: Proxy Pico) #if MIN_VERSION_base(4,8,0)     twoTests (Proxy :: Proxy Natural)-    +     twoTupleTests (Proxy :: Proxy Natural)-    +     twoTests (Proxy :: Proxy (Ratio Integer))-    +     twoTupleTests (Proxy :: Proxy (Ratio Int)) #endif #if MIN_VERSION_base(4,9,0)     threeTests (Proxy :: Proxy (NonEmpty Double)) #endif twoTupleTests ::-       forall a. (Show a, Typeable a, GenValid a)+       forall a. (Show a, Eq a, Typeable a, GenValid a)     => Proxy a     -> Spec twoTupleTests proxy = do-    twoTests $ (,) <$> proxy <*> proxy-    twoTests $ (,,) <$> proxy <*> proxy <*> proxy-    twoTests $ (,,,) <$> proxy <*> proxy <*> proxy <*> proxy-    twoTests $ (,,,,) <$> proxy <*> proxy <*> proxy <*> proxy <*> proxy+    modifyMaxSize (`quot` 2) $ twoTests $ (,) <$> proxy <*> proxy+    modifyMaxSize (`quot` 3) $ twoTests $ (,,) <$> proxy <*> proxy <*> proxy+    modifyMaxSize (`quot` 4) $+        twoTests $ (,,,) <$> proxy <*> proxy <*> proxy <*> proxy+    modifyMaxSize (`quot` 5) $+        twoTests $ (,,,,) <$> proxy <*> proxy <*> proxy <*> proxy <*> proxy  threeTupleTests ::-       forall a. (Show a, Typeable a, GenValid a, GenInvalid a)+       forall a. (Show a, Eq a, Typeable a, GenValid a, GenInvalid a)     => Proxy a     -> Spec threeTupleTests proxy = do-    threeTests $ (,) <$> proxy <*> proxy-    threeTests $ (,,) <$> proxy <*> proxy <*> proxy-    threeTests $ (,,,) <$> proxy <*> proxy <*> proxy <*> proxy-    threeTests $ (,,,,) <$> proxy <*> proxy <*> proxy <*> proxy <*> proxy+    modifyMaxSize (`quot` 2) $ threeTests $ (,) <$> proxy <*> proxy+    modifyMaxSize (`quot` 3) $ threeTests $ (,,) <$> proxy <*> proxy <*> proxy+    modifyMaxSize (`quot` 4) $+        threeTests $ (,,,) <$> proxy <*> proxy <*> proxy <*> proxy+    modifyMaxSize (`quot` 5) $+        threeTests $ (,,,,) <$> proxy <*> proxy <*> proxy <*> proxy <*> proxy  twoTests ::-       forall a. (Show a, Typeable a, GenValid a)+       forall a. (Show a, Eq a, Typeable a, GenValid a)     => Proxy a     -> Spec twoTests proxy =@@ -114,7 +120,7 @@         genValidTest proxy  threeTests ::-       forall a. (Show a, Typeable a, GenValid a, GenInvalid a)+       forall a. (Show a, Eq a, Typeable a, GenValid a, GenInvalid a)     => Proxy a     -> Spec threeTests proxy =@@ -124,7 +130,7 @@         genInvalidTest proxy  genUncheckedTest ::-       forall a. (Show a, Typeable a, GenValid a)+       forall a. (Show a, Eq a, Typeable a, GenValid a)     => Proxy a     -> Spec genUncheckedTest proxy = do@@ -134,19 +140,33 @@             case prettyValidation (a :: a) of                 Right v -> seq v True                 Left err -> seq err True-    it (unwords-            [ "shrinkUnchecked of"-            , nameOf proxy-            , "only produces values that do not crash while validating"-            ]) $+    modifyMaxSuccess (`quot` 5) $+        it+            (unwords+                 [ "shrinkUnchecked of"+                 , nameOf proxy+                 , "only produces values that do not crash while validating"+                 ]) $         forAll genUnchecked $ \a ->             forM_ (shrinkUnchecked a) $ \v ->                 case prettyValidation (v :: a) of                     Right v_ -> seq v_ $ pure () :: IO ()                     Left err -> seq err $ pure ()+    modifyMaxSuccess (`quot` 5) $+        it+            (unwords+                 [ "shrinkUnchecked of"+                 , nameOf proxy+                 , "does not shrink to itself"+                 ]) $+        forAll genValid $ \a ->+            forM_ (shrinkUnchecked a) $ \a' ->+                unless (a /= a') $+                expectationFailure $+                unlines ["The value", show( a ::a), "was shrunk to itself"]  genValidTest ::-       forall a. (Show a, Typeable a, GenValid a)+       forall a. (Show a, Eq a, Typeable a, GenValid a)     => Proxy a     -> Spec genValidTest proxy = do@@ -162,7 +182,13 @@                         , err                         , ""                         ]-    it (unwords ["shrinkValid of", nameOf proxy, "shrinks to only valid values"]) $+    modifyMaxSuccess (`quot` 5) $+        it+            (unwords+                 [ "shrinkValid of"+                 , nameOf proxy+                 , "shrinks to only valid values"+                 ]) $         forAll genValid $ \a ->             forM_ (shrinkValid a) $ \v ->                 case prettyValidation (v :: a) of@@ -175,16 +201,27 @@                             , err                             , ""                             ]-    it (unwords-            [ "shrinkValid of"-            , nameOf proxy-            , "only produces values that do not crash while validating"-            ]) $+    modifyMaxSuccess (`quot` 5) $+        it+            (unwords+                 [ "shrinkValid of"+                 , nameOf proxy+                 , "only produces values that do not crash while validating"+                 ]) $         forAll genValid $ \a ->             forM_ (shrinkValid a) $ \v ->                 case prettyValidation (v :: a) of                     Right v_ -> seq v_ $ pure () :: IO ()                     Left err -> seq err $ pure ()+    modifyMaxSuccess (`quot` 5) $+        it+            (unwords+                 ["shrinkValid of", nameOf proxy, "does not shrink to itself"]) $+        forAll genValid $ \a ->+            forM_ (shrinkValid a) $ \a' ->+                unless (a /= a') $+                expectationFailure $+                unlines ["The value", show (a :: a), "was shrunk to itself"]  genInvalidTest ::        forall a. (Show a, Typeable a, GenInvalid a)@@ -199,8 +236,13 @@                     unlines                         ["'validate' reported this value to be valid: ", show a]                 Left e -> seq e $ pure ()-    it (unwords-            ["shrinkInvalid of", nameOf proxy, "shrinks to only invalid values"]) $+    modifyMaxSuccess (`quot` 5) $+        it+            (unwords+                 [ "shrinkInvalid of"+                 , nameOf proxy+                 , "shrinks to only invalid values"+                 ]) $         forAll genInvalid $ \a ->             forM_ (shrinkInvalid a) $ \v ->                 case prettyValidation (v :: a) of@@ -211,11 +253,13 @@                             , show v                             ]                     Left e -> seq e $ pure ()-    it (unwords-            [ "shrinkInvalid of"-            , nameOf proxy-            , "only produces values that do not crash while validating"-            ]) $+    modifyMaxSuccess (`quot` 5) $+        it+            (unwords+                 [ "shrinkInvalid of"+                 , nameOf proxy+                 , "only produces values that do not crash while validating"+                 ]) $         forAll genInvalid $ \a ->             forM_ (shrinkInvalid a) $ \v ->                 case prettyValidation (v :: a) of