{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 710
#define OVERLAPPING_ {-# OVERLAPPING #-}
#else
{-# LANGUAGE OverlappingInstances #-}
#define OVERLAPPING_
#endif
#if MIN_VERSION_base(4,9,0)
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
#endif
module Data.GenValidity
( module Data.Validity
, module Data.GenValidity
) where
import Data.Validity
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)
#else
import Data.Word (Word, Word8, Word16, Word32, Word64)
#endif
import Data.Int (Int8, Int16, Int32, Int64)
import Data.Ratio ((%))
import GHC.Generics
import GHC.Real (Ratio(..))
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)
#else
import Control.Applicative ((<*>), (<$>), pure)
import Control.Monad (forM)
#endif
{-# ANN module "HLint: ignore Reduce duplication" #-}
class GenUnchecked a where
genUnchecked :: Gen a
default genUnchecked :: (Generic a, GGenUnchecked (Rep a)) =>
Gen a
genUnchecked = genericGenUnchecked
shrinkUnchecked :: a -> [a]
default shrinkUnchecked ::
(Generic a, GUncheckedRecursivelyShrink (Rep a), GUncheckedSubterms (Rep a) a) =>
a -> [a]
shrinkUnchecked = genericShrinkUnchecked
class (Validity a, GenUnchecked a) =>
GenValid a where
genValid :: Gen a
genValid = genUnchecked `suchThat` isValid
shrinkValid :: a -> [a]
shrinkValid = filter isValid . shrinkUnchecked
class (Validity a, GenUnchecked a) =>
GenInvalid a where
genInvalid :: Gen a
genInvalid = genUnchecked `suchThat` isInvalid
shrinkInvalid :: a -> [a]
shrinkInvalid = filter isInvalid . shrinkUnchecked
instance (GenUnchecked a, GenUnchecked b) => GenUnchecked (a, b) where
genUnchecked =
sized $ \n -> do
(r, s) <- genSplit n
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 =
sized $ \n -> do
(r, s) <- genSplit n
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 =
sized $ \n -> do
(r, s) <- genSplit n
oneof
[ do a <- resize r genUnchecked
b <- resize s genInvalid
return (a, b)
, do a <- resize r genInvalid
b <- resize s genUnchecked
return (a, b)
]
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
instance (GenInvalid a, GenInvalid b) => GenInvalid (Either a b) where
genInvalid = oneof [Left <$> genInvalid, Right <$> genInvalid]
instance (GenUnchecked a, GenUnchecked b, GenUnchecked c) =>
GenUnchecked (a, b, c) where
genUnchecked =
sized $ \n -> do
(r, s, t) <- genSplit3 n
a <- resize r genUnchecked
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 =
sized $ \n -> do
(r, s, t) <- genSplit3 n
a <- resize r genValid
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))
]
instance (GenInvalid a, GenInvalid b, GenInvalid c) =>
GenInvalid (a, b, c) where
genInvalid =
sized $ \n -> do
(r, s, t) <- genSplit3 n
oneof
[ do a <- resize r genInvalid
b <- resize s genUnchecked
c <- resize t genUnchecked
return (a, b, c)
, do a <- resize r genUnchecked
b <- resize s genInvalid
c <- resize t genUnchecked
return (a, b, c)
, do a <- resize r genUnchecked
b <- resize s genUnchecked
c <- resize t genInvalid
return (a, b, c)
]
instance (GenUnchecked a, GenUnchecked b, GenUnchecked c, GenUnchecked d) =>
GenUnchecked (a, b, c, d) where
genUnchecked =
sized $ \n -> do
(r, s, t, u) <- genSplit4 n
a <- resize r genUnchecked
b <- resize s genUnchecked
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
genValid =
sized $ \n -> do
(r, s, t, u) <- genSplit4 n
a <- resize r genValid
b <- resize s genValid
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)))
]
instance (GenInvalid a, GenInvalid b, GenInvalid c, GenInvalid d) =>
GenInvalid (a, b, c, d) where
genInvalid =
sized $ \n -> do
(r, s, t, u) <- genSplit4 n
oneof
[ do a <- resize r genInvalid
b <- resize s genUnchecked
c <- resize t genUnchecked
d <- resize u genUnchecked
return (a, b, c, d)
, do a <- resize r genUnchecked
b <- resize s genInvalid
c <- resize t genUnchecked
d <- resize u genUnchecked
return (a, b, c, d)
, do a <- resize r genUnchecked
b <- resize s genUnchecked
c <- resize t genInvalid
d <- resize u genUnchecked
return (a, b, c, d)
, do a <- resize r genUnchecked
b <- resize s genUnchecked
c <- resize t genUnchecked
d <- resize u genInvalid
return (a, b, c, d)
]
instance (GenUnchecked a, GenUnchecked b, GenUnchecked c, GenUnchecked d, GenUnchecked e) =>
GenUnchecked (a, b, c, d, e) where
genUnchecked =
sized $ \n -> do
(r, s, t, u, v) <- genSplit5 n
a <- resize r genUnchecked
b <- resize s genUnchecked
c <- resize t genUnchecked
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
genValid =
sized $ \n -> do
(r, s, t, u, v) <- genSplit5 n
a <- resize r genValid
b <- resize s genValid
c <- resize t genValid
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))))
]
instance (GenInvalid a, GenInvalid b, GenInvalid c, GenInvalid d, GenInvalid e) =>
GenInvalid (a, b, c, d, e) where
genInvalid =
sized $ \n -> do
(r, s, t, u, v) <- genSplit5 n
oneof
[ do a <- resize r genInvalid
b <- resize s genUnchecked
c <- resize t genUnchecked
d <- resize u genUnchecked
e <- resize v genUnchecked
return (a, b, c, d, e)
, do a <- resize r genUnchecked
b <- resize s genInvalid
c <- resize t genUnchecked
d <- resize u genUnchecked
e <- resize v genUnchecked
return (a, b, c, d, e)
, do a <- resize r genUnchecked
b <- resize s genUnchecked
c <- resize t genInvalid
d <- resize u genUnchecked
e <- resize v genUnchecked
return (a, b, c, d, e)
, do a <- resize r genUnchecked
b <- resize s genUnchecked
c <- resize t genUnchecked
d <- resize u genInvalid
e <- resize v genUnchecked
return (a, b, c, d, e)
, do a <- resize r genUnchecked
b <- resize s genUnchecked
c <- resize t genUnchecked
d <- resize u genUnchecked
e <- resize v genInvalid
return (a, b, c, d, e)
]
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
#if MIN_VERSION_base(4,9,0)
instance GenUnchecked a => GenUnchecked (NonEmpty a) where
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 = 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 = 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
instance GenValid a => GenValid [a] where
genValid = genListOf genValid
shrinkValid = shrinkList shrinkValid
instance GenInvalid a => GenInvalid [a] where
genInvalid =
sized $ \n -> do
(x, y, z) <- genSplit3 n
before <- resize x $ genListOf genUnchecked
middle <- resize y genInvalid
after <- resize z $ genListOf genUnchecked
return $ before ++ [middle] ++ after
instance GenUnchecked () where
genUnchecked = arbitrary
shrinkUnchecked = shrink
instance GenValid ()
instance GenUnchecked Bool where
genUnchecked = arbitrary
shrinkUnchecked = shrink
instance GenValid Bool
instance GenUnchecked Ordering where
genUnchecked = arbitrary
shrinkUnchecked = shrink
instance GenValid Ordering
instance GenUnchecked Char where
genUnchecked = arbitrary
shrinkUnchecked = shrink
instance GenValid Char
instance GenUnchecked Int where
genUnchecked = arbitrary
shrinkUnchecked = shrink
instance GenValid Int
instance GenUnchecked Int8 where
genUnchecked = arbitrary
shrinkUnchecked = shrink
instance GenValid Int8
instance GenUnchecked Int16 where
genUnchecked = arbitrary
shrinkUnchecked = shrink
instance GenValid Int16
instance GenUnchecked Int32 where
genUnchecked = arbitrary
shrinkUnchecked = shrink
instance GenValid Int32
instance GenUnchecked Int64 where
genUnchecked = arbitrary
shrinkUnchecked = shrink
instance GenValid Int64 where
genValid = arbitrary
shrinkValid = shrink
instance GenUnchecked Word where
genUnchecked = arbitrary
shrinkUnchecked = shrink
instance GenValid Word
instance GenUnchecked Word8 where
genUnchecked = arbitrary
shrinkUnchecked = shrink
instance GenValid Word8
instance GenUnchecked Word16 where
genUnchecked = arbitrary
shrinkUnchecked = shrink
instance GenValid Word16
instance GenUnchecked Word32 where
genUnchecked = arbitrary
shrinkUnchecked = shrink
instance GenValid Word32
instance GenUnchecked Word64 where
genUnchecked = arbitrary
shrinkUnchecked = shrink
instance GenValid Word64
instance GenUnchecked Float where
genUnchecked = frequency [(9, arbitrary), (1, elements [read "NaN", read "Infinity", read "-Infinity", read "-0"])]
#if MIN_VERSION_QuickCheck(2,9,2)
shrinkUnchecked f = if
| isInfinite f -> []
| isNaN f -> []
| otherwise -> shrink f
#else
shrinkUnchecked _ = []
#endif
instance GenValid Float where
genValid = genUnchecked
shrinkValid = shrinkUnchecked
instance GenUnchecked Double where
genUnchecked = frequency [(9, arbitrary), (1, elements [read "NaN", read "Infinity", read "-Infinity", read "-0"])]
#if MIN_VERSION_QuickCheck(2,9,2)
shrinkUnchecked d = if
| isInfinite d -> []
| isNaN d -> []
| otherwise -> shrink d
#else
shrinkUnchecked _ = []
#endif
instance GenValid Double where
genValid = genUnchecked
shrinkValid = shrinkUnchecked
instance GenUnchecked Integer where
genUnchecked = arbitrary
shrinkUnchecked = shrink
instance GenValid Integer
#if MIN_VERSION_base(4,8,0)
instance GenUnchecked Natural where
genUnchecked = fromInteger . abs <$> genUnchecked
shrinkUnchecked 0 = []
shrinkUnchecked n = [0 .. n-1]
instance GenValid Natural where
genValid = fromInteger . abs <$> genValid
#endif
instance (Integral a, GenUnchecked a) => GenUnchecked (Ratio a) where
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 = (%) <$> 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)
instance HasResolution a => GenUnchecked (Fixed a) where
genUnchecked = MkFixed <$> genUnchecked
shrinkUnchecked (MkFixed i) = MkFixed <$> shrinkUnchecked i
instance HasResolution a => GenValid (Fixed a)
shrinkT2
:: (a -> [a])
-> (a, a) -> [(a, a)]
shrinkT2 s (a, b) = (,) <$> s a <*> s b
shrinkT3
:: (a -> [a])
-> (a, a, a) -> [(a, a, a)]
shrinkT3 s (a, b, c) = (,,) <$> s a <*> s b <*> s c
upTo :: Int -> Gen Int
upTo n
| n <= 0 = pure 0
| otherwise = choose (0, n)
genSplit :: Int -> Gen (Int, Int)
genSplit n
| n < 0 = pure (0, 0)
| otherwise = do
i <- choose (0, n)
let j = n - i
pure (i, j)
genSplit3 :: Int -> Gen (Int, Int, Int)
genSplit3 n
| n < 0 = pure (0, 0, 0)
| otherwise = do
(a, z) <- genSplit n
(b, c) <- genSplit z
return (a, b, c)
genSplit4 :: Int -> Gen (Int, Int, Int, Int)
genSplit4 n
| n < 0 = pure (0, 0, 0, 0)
| otherwise = do
(y, z) <- genSplit n
(a, b) <- genSplit y
(c, d) <- genSplit z
return (a, b, c, d)
genSplit5 :: Int -> Gen (Int, Int, Int, Int, Int)
genSplit5 n
| n < 0 = pure (0, 0, 0, 0, 0)
| otherwise = do
(y, z) <- genSplit n
(a, b, c) <- genSplit3 y
(d, e) <- genSplit z
return (a, b, c, d, e)
arbPartition :: Int -> Gen [Int]
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)
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
genListOf :: Gen a -> Gen [a]
genListOf func =
sized $ \n -> do
size <- upTo n
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)
instance GGenUnchecked U1 where
gGenUnchecked = pure U1
instance (GGenUnchecked a, GGenUnchecked b) => GGenUnchecked (a :*: b) where
gGenUnchecked = (:*:) <$> gGenUnchecked <*> gGenUnchecked
instance (GGenUnchecked a, GGenUnchecked b) => GGenUnchecked (a :+: b) where
gGenUnchecked = oneof [L1 <$> gGenUnchecked, R1 <$> gGenUnchecked]
instance (GGenUnchecked a) => GGenUnchecked (M1 i c a) where
gGenUnchecked = M1 <$> gGenUnchecked
instance (GenUnchecked a) => GGenUnchecked (K1 i a) where
gGenUnchecked = K1 <$> genUnchecked
genericShrinkUnchecked :: (Generic a, GUncheckedRecursivelyShrink (Rep a), GUncheckedSubterms (Rep a) a) => a -> [a]
genericShrinkUnchecked x = uncheckedSubterms x ++ uncheckedRecursivelyShrink x
uncheckedRecursivelyShrink :: (Generic a, GUncheckedRecursivelyShrink (Rep a)) => a -> [a]
uncheckedRecursivelyShrink = map to . gUncheckedRecursivelyShrink . from
class GUncheckedRecursivelyShrink f where
gUncheckedRecursivelyShrink :: f a -> [f a]
instance (GUncheckedRecursivelyShrink f, GUncheckedRecursivelyShrink g) => GUncheckedRecursivelyShrink (f :*: g) where
gUncheckedRecursivelyShrink (x :*: 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)
gUncheckedRecursivelyShrink (R1 x) = map R1 (gUncheckedRecursivelyShrink x)
instance GUncheckedRecursivelyShrink f => GUncheckedRecursivelyShrink (M1 i c f) where
gUncheckedRecursivelyShrink (M1 x) = map M1 (gUncheckedRecursivelyShrink x)
instance GenUnchecked a => GUncheckedRecursivelyShrink (K1 i a) where
gUncheckedRecursivelyShrink (K1 x) = map K1 (shrinkUnchecked x)
instance GUncheckedRecursivelyShrink U1 where
gUncheckedRecursivelyShrink U1 = []
instance GUncheckedRecursivelyShrink V1 where
gUncheckedRecursivelyShrink _ = []
uncheckedSubterms :: (Generic a, GUncheckedSubterms (Rep a) a) => a -> [a]
uncheckedSubterms = gUncheckedSubterms . from
class GUncheckedSubterms f a where
gUncheckedSubterms :: f a -> [a]
instance GUncheckedSubterms V1 a where
gUncheckedSubterms _ = []
instance GUncheckedSubterms U1 a where
gUncheckedSubterms U1 = []
instance (GUncheckedSubtermsIncl f a, GUncheckedSubtermsIncl g a) => GUncheckedSubterms (f :*: g) a where
gUncheckedSubterms (l :*: r) = gUncheckedSubtermsIncl l ++ gUncheckedSubtermsIncl r
instance (GUncheckedSubtermsIncl f a, GUncheckedSubtermsIncl g a) => GUncheckedSubterms (f :+: g) a where
gUncheckedSubterms (L1 x) = gUncheckedSubtermsIncl x
gUncheckedSubterms (R1 x) = gUncheckedSubtermsIncl x
instance GUncheckedSubterms f a => GUncheckedSubterms (M1 i c f) a where
gUncheckedSubterms (M1 x) = gUncheckedSubterms x
instance GUncheckedSubterms (K1 i a) b where
gUncheckedSubterms (K1 _) = []
class GUncheckedSubtermsIncl f a where
gUncheckedSubtermsIncl :: f a -> [a]
instance GUncheckedSubtermsIncl V1 a where
gUncheckedSubtermsIncl _ = []
instance GUncheckedSubtermsIncl U1 a where
gUncheckedSubtermsIncl U1 = []
instance (GUncheckedSubtermsIncl f a, GUncheckedSubtermsIncl g a) => GUncheckedSubtermsIncl (f :*: g) a where
gUncheckedSubtermsIncl (l :*: r) = gUncheckedSubtermsIncl l ++ gUncheckedSubtermsIncl r
instance (GUncheckedSubtermsIncl f a, GUncheckedSubtermsIncl g a) => GUncheckedSubtermsIncl (f :+: g) a where
gUncheckedSubtermsIncl (L1 x) = gUncheckedSubtermsIncl x
gUncheckedSubtermsIncl (R1 x) = gUncheckedSubtermsIncl x
instance GUncheckedSubtermsIncl f a => GUncheckedSubtermsIncl (M1 i c f) a where
gUncheckedSubtermsIncl (M1 x) = gUncheckedSubtermsIncl x
instance OVERLAPPING_ GUncheckedSubtermsIncl (K1 i a) a where
gUncheckedSubtermsIncl (K1 x) = [x]
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
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
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
gValidRecursivelyShrink _ = []
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
instance OVERLAPPING_ GValidSubtermsIncl (K1 i a) a where
gValidSubtermsIncl (K1 x) = [x]
instance OVERLAPPING_ GValidSubtermsIncl (K1 i a) b where
gValidSubtermsIncl (K1 _) = []