{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

-- |
--
--    @GenValid@ exists to make tests involving @Validity@ types easier and
--    speed up the generation of data for them.
--
--    To implement tests for this datatype, we would have to be able to
--    generate both primes. We could do this with a generator like this one:
--
--    > (Prime <$> 'arbitrary') `suchThat` isValid
--
--    However, this is tedious and inefficient, as well as quite
--    naive (because 'arbitrary' tends to use very naive generators).
--
--    The @GenValid@ type class allows you to specify how to (efficiently)
--    generate valid data of the given type to allow for easier and quicker testing.
--    The default implementation of `GenValid` already gives you a generator and shrinking function
--    for free:
--
--    > instance GenValid Prime
--
--    For example, to generate primes, we don't have to consider even numbers other
--    than 2. A more efficient implementation could then look as follows:
--
--    > instance GenValid Prime where
--    >     genValid = Prime <$>
--    >        (oneof
--    >          [ pure 2
--    >          , ((\y -> 2 * abs y + 1) <$> arbitrary) `suchThat` isPrime)
--    >          ])
--
--
--    Typical examples of tests involving validity could look as follows:
--
--    > it "succeeds when given valid input" $ do
--    >     forAllValid $ \input ->
--    >         myFunction input `shouldSatisfy` isRight
--
--    > it "produces valid output when it succeeds" $ do
--    >     forAllValid $ \input ->
--    >         case myFunction input of
--    >             Nothing -> return () -- Can happen
--    >             Just output -> output `shouldSatisfy` isValid
--
--    Definitely also look at the companion packages for more info on how to use this package.
module Data.GenValidity
  ( GenValid (..),

    -- * Helper functions
    genValidStructurally,
    genValidStructurallyWithoutExtraChecking,
    shrinkValidStructurally,
    shrinkValidStructurallyWithoutExtraFiltering,
    module Data.GenValidity.Utils,

    -- ** Helper functions for specific types

    -- *** Char
    genUtf16SurrogateCodePoint,
    genLineSeparator,
    genNonLineSeparator,

    -- *** String
    genSingleLineString,

    -- * Re-exports
    module Data.Validity,

    -- * The Generics magic
    GGenValid (..),
    GValidRecursivelyShrink (..),
    structurallyValidSubterms,
    GValidSubterms (..),
    GValidSubtermsIncl (..),
  )
where

import Control.Monad (guard)
import Data.Char (chr)
import Data.Fixed (Fixed (..), HasResolution)
import Data.GenValidity.Utils
import Data.Int (Int16, Int32, Int64, Int8)
import Data.List.NonEmpty (NonEmpty)
import Data.Ratio ((%))
import Data.Validity
import Data.Word (Word16, Word32, Word64, Word8)
import GHC.Generics
import GHC.Real (Ratio (..))
import Numeric.Natural
import Test.QuickCheck hiding (Fixed)

{-# ANN module "HLint: ignore Reduce duplication" #-}

-- | A class of types for which valid values can be generated to be valid.
--
-- === How to instantiate 'GenValid'
--
-- __Step 1__: Try to instantiate 'GenValid' without overriding any functions.
--             It is possible that, if few values are valid or if validity
--             checking is expensive, the resulting generator is too slow.
--             In that case, go to Step 2.
--
-- __Step 2__: Consider using 'genValidStructurallyWithoutExtraChecking' and
--             'shrinkValidStructurallyWithoutExtraFiltering' to speed up generation.
--             This only works if your type has a derived or trivial 'Validity'
--             instance.
--
-- __Step 3__: If that still is not fast enough, consider writing your own
--             generator and shrinking function.
--             Make sure to generate any possible valid value, but only valid values.
--
-- === A note about 'Arbitrary'
--
-- If you also write @Arbitrary@ instances for @GenValid@ types, it may be
-- best to simply use
--
-- > instance Arbitrary A where
-- >   arbitrary = genValid
-- >   shrink = shrinkValid
class Validity a => GenValid a where
  -- | Generate a valid datum, this should cover all possible valid values in
  -- the type
  --
  -- The default implementation is as follows:
  --
  -- >  genValid = genValidStructurally
  --
  -- To speed up testing, it may be a good idea to implement this yourself.
  -- If you do, make sure that it is possible to generate all possible valid
  -- data, otherwise your testing may not cover all cases.
  genValid :: Gen a
  default genValid :: (Generic a, GGenValid (Rep a)) => Gen a
  genValid = forall a. (Validity a, Generic a, GGenValid (Rep a)) => Gen a
genValidStructurally

  -- | Shrink a valid value.
  --
  -- The default implementation is as follows:
  --
  -- >  shrinkValid = shrinkValidStructurally
  --
  -- 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]
  default shrinkValid :: (Generic a, GValidRecursivelyShrink (Rep a), GValidSubterms (Rep a) a) => a -> [a]
  shrinkValid = forall a.
(Validity a, Generic a, GValidRecursivelyShrink (Rep a),
 GValidSubterms (Rep a) a) =>
a -> [a]
shrinkValidStructurally

instance (GenValid a, GenValid b) => GenValid (a, b) where
  genValid :: Gen (a, b)
genValid =
    forall a. (Int -> Gen a) -> Gen a
sized forall a b. (a -> b) -> a -> b
$ \Int
n -> do
      (Int
r, Int
s) <- Int -> Gen (Int, Int)
genSplit Int
n
      a
a <- forall a. Int -> Gen a -> Gen a
resize Int
r forall a. GenValid a => Gen a
genValid
      b
b <- forall a. Int -> Gen a -> Gen a
resize Int
s forall a. GenValid a => Gen a
genValid
      forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, b
b)
  shrinkValid :: (a, b) -> [(a, b)]
shrinkValid = forall a b. (a -> [a]) -> (b -> [b]) -> (a, b) -> [(a, b)]
shrinkTuple forall a. GenValid a => a -> [a]
shrinkValid forall a. GenValid a => a -> [a]
shrinkValid

instance (GenValid a, GenValid b) => GenValid (Either a b) where
  genValid :: Gen (Either a b)
genValid = forall a. [Gen a] -> Gen a
oneof [forall a b. a -> Either a b
Left forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. GenValid a => Gen a
genValid, forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. GenValid a => Gen a
genValid]
  shrinkValid :: Either a b -> [Either a b]
shrinkValid (Left a
a) = forall a b. a -> Either a b
Left forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. GenValid a => a -> [a]
shrinkValid a
a
  shrinkValid (Right b
b) = forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. GenValid a => a -> [a]
shrinkValid b
b

instance (GenValid a, GenValid b, GenValid c) => GenValid (a, b, c) where
  genValid :: Gen (a, b, c)
genValid =
    forall a. (Int -> Gen a) -> Gen a
sized forall a b. (a -> b) -> a -> b
$ \Int
n -> do
      (Int
r, Int
s, Int
t) <- Int -> Gen (Int, Int, Int)
genSplit3 Int
n
      a
a <- forall a. Int -> Gen a -> Gen a
resize Int
r forall a. GenValid a => Gen a
genValid
      b
b <- forall a. Int -> Gen a -> Gen a
resize Int
s forall a. GenValid a => Gen a
genValid
      c
c <- forall a. Int -> Gen a -> Gen a
resize Int
t forall a. GenValid a => Gen a
genValid
      forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, b
b, c
c)
  shrinkValid :: (a, b, c) -> [(a, b, c)]
shrinkValid = forall a b c.
(a -> [a]) -> (b -> [b]) -> (c -> [c]) -> (a, b, c) -> [(a, b, c)]
shrinkTriple forall a. GenValid a => a -> [a]
shrinkValid forall a. GenValid a => a -> [a]
shrinkValid forall a. GenValid a => a -> [a]
shrinkValid

instance
  (GenValid a, GenValid b, GenValid c, GenValid d) =>
  GenValid (a, b, c, d)
  where
  genValid :: Gen (a, b, c, d)
genValid =
    forall a. (Int -> Gen a) -> Gen a
sized forall a b. (a -> b) -> a -> b
$ \Int
n -> do
      (Int
r, Int
s, Int
t, Int
u) <- Int -> Gen (Int, Int, Int, Int)
genSplit4 Int
n
      a
a <- forall a. Int -> Gen a -> Gen a
resize Int
r forall a. GenValid a => Gen a
genValid
      b
b <- forall a. Int -> Gen a -> Gen a
resize Int
s forall a. GenValid a => Gen a
genValid
      c
c <- forall a. Int -> Gen a -> Gen a
resize Int
t forall a. GenValid a => Gen a
genValid
      d
d <- forall a. Int -> Gen a -> Gen a
resize Int
u forall a. GenValid a => Gen a
genValid
      forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, b
b, c
c, d
d)
  shrinkValid :: (a, b, c, d) -> [(a, b, c, d)]
shrinkValid = forall a b c d.
(a -> [a])
-> (b -> [b])
-> (c -> [c])
-> (d -> [d])
-> (a, b, c, d)
-> [(a, b, c, d)]
shrinkQuadruple forall a. GenValid a => a -> [a]
shrinkValid forall a. GenValid a => a -> [a]
shrinkValid forall a. GenValid a => a -> [a]
shrinkValid forall a. GenValid a => a -> [a]
shrinkValid

instance
  (GenValid a, GenValid b, GenValid c, GenValid d, GenValid e) =>
  GenValid (a, b, c, d, e)
  where
  genValid :: Gen (a, b, c, d, e)
genValid =
    forall a. (Int -> Gen a) -> Gen a
sized forall a b. (a -> b) -> a -> b
$ \Int
n -> do
      (Int
r, Int
s, Int
t, Int
u, Int
v) <- Int -> Gen (Int, Int, Int, Int, Int)
genSplit5 Int
n
      a
a <- forall a. Int -> Gen a -> Gen a
resize Int
r forall a. GenValid a => Gen a
genValid
      b
b <- forall a. Int -> Gen a -> Gen a
resize Int
s forall a. GenValid a => Gen a
genValid
      c
c <- forall a. Int -> Gen a -> Gen a
resize Int
t forall a. GenValid a => Gen a
genValid
      d
d <- forall a. Int -> Gen a -> Gen a
resize Int
u forall a. GenValid a => Gen a
genValid
      e
e <- forall a. Int -> Gen a -> Gen a
resize Int
v forall a. GenValid a => Gen a
genValid
      forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, b
b, c
c, d
d, e
e)
  shrinkValid :: (a, b, c, d, e) -> [(a, b, c, d, e)]
shrinkValid (a
a, b
b, c
c, d
d, e
e) =
    [ (a
a', b
b', c
c', d
d', e
e')
      | (a
a', (b
b', (c
c', (d
d', e
e')))) <- forall a. GenValid a => a -> [a]
shrinkValid (a
a, (b
b, (c
c, (d
d, e
e))))
    ]

instance GenValid a => GenValid (Maybe a) where
  genValid :: Gen (Maybe a)
genValid = forall a. Gen a -> Gen (Maybe a)
genMaybe forall a. GenValid a => Gen a
genValid
  shrinkValid :: Maybe a -> [Maybe a]
shrinkValid = forall a. (a -> [a]) -> Maybe a -> [Maybe a]
shrinkMaybe forall a. GenValid a => a -> [a]
shrinkValid

instance GenValid a => GenValid (NonEmpty a) where
  genValid :: Gen (NonEmpty a)
genValid = forall a. Gen a -> Gen (NonEmpty a)
genNonEmptyOf forall a. GenValid a => Gen a
genValid
  shrinkValid :: NonEmpty a -> [NonEmpty a]
shrinkValid = forall a. (a -> [a]) -> NonEmpty a -> [NonEmpty a]
shrinkNonEmpty forall a. GenValid a => a -> [a]
shrinkValid

instance GenValid a => GenValid [a] where
  genValid :: Gen [a]
genValid = forall a. Gen a -> Gen [a]
genListOf forall a. GenValid a => Gen a
genValid
  shrinkValid :: [a] -> [[a]]
shrinkValid = forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList forall a. GenValid a => a -> [a]
shrinkValid

instance GenValid () where
  genValid :: Gen ()
genValid = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  shrinkValid :: () -> [()]
shrinkValid () = []

instance GenValid Bool where
  genValid :: Gen Bool
genValid = forall a. Arbitrary a => Gen a
arbitrary
  shrinkValid :: Bool -> [Bool]
shrinkValid = forall a. Arbitrary a => a -> [a]
shrink

instance GenValid Ordering where
  genValid :: Gen Ordering
genValid = forall a. Arbitrary a => Gen a
arbitrary
  shrinkValid :: Ordering -> [Ordering]
shrinkValid = forall a. Arbitrary a => a -> [a]
shrink

instance GenValid Char where
  genValid :: Gen Char
genValid =
    forall a. [(Int, Gen a)] -> Gen a
frequency
      [ (Int
9, forall a. Random a => (a, a) -> Gen a
choose (forall a. Bounded a => a
minBound, forall a. Bounded a => a
maxBound)),
        (Int
1, Gen Char
genUtf16SurrogateCodePoint)
      ]
  shrinkValid :: Char -> [Char]
shrinkValid = forall a. Arbitrary a => a -> [a]
shrink

genUtf16SurrogateCodePoint :: Gen Char
genUtf16SurrogateCodePoint :: Gen Char
genUtf16SurrogateCodePoint = Int -> Char
chr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [Gen a] -> Gen a
oneof [forall a. Random a => (a, a) -> Gen a
choose (Int
0xD800, Int
0xDBFF), forall a. Random a => (a, a) -> Gen a
choose (Int
0xDC00, Int
0xDFFF)]

genLineSeparator :: Gen Char
genLineSeparator :: Gen Char
genLineSeparator = forall a. [a] -> Gen a
elements [Char
'\n', Char
'\r']

genNonLineSeparator :: Gen Char
genNonLineSeparator :: Gen Char
genNonLineSeparator = forall a. GenValid a => Gen a
genValid forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isLineSeparator)

genSingleLineString :: Gen String
genSingleLineString :: Gen [Char]
genSingleLineString = forall a. Gen a -> Gen [a]
genListOf Gen Char
genNonLineSeparator

instance GenValid Int where
  genValid :: Gen Int
genValid = forall a. (Integral a, Bounded a, Random a) => Gen a
genIntX
  shrinkValid :: Int -> [Int]
shrinkValid = forall a. Arbitrary a => a -> [a]
shrink

instance GenValid Int8 where
  genValid :: Gen Int8
genValid = forall a. (Integral a, Bounded a, Random a) => Gen a
genIntX
  shrinkValid :: Int8 -> [Int8]
shrinkValid = forall a. Arbitrary a => a -> [a]
shrink

instance GenValid Int16 where
  genValid :: Gen Int16
genValid = forall a. (Integral a, Bounded a, Random a) => Gen a
genIntX
  shrinkValid :: Int16 -> [Int16]
shrinkValid = forall a. Arbitrary a => a -> [a]
shrink

instance GenValid Int32 where
  genValid :: Gen Int32
genValid = forall a. (Integral a, Bounded a, Random a) => Gen a
genIntX
  shrinkValid :: Int32 -> [Int32]
shrinkValid = forall a. Arbitrary a => a -> [a]
shrink

instance GenValid Int64 where
  genValid :: Gen Int64
genValid = forall a. (Integral a, Bounded a, Random a) => Gen a
genIntX
  shrinkValid :: Int64 -> [Int64]
shrinkValid = forall a. Arbitrary a => a -> [a]
shrink

instance GenValid Word where
  genValid :: Gen Word
genValid = forall a. (Integral a, Bounded a, Random a) => Gen a
genWordX
  shrinkValid :: Word -> [Word]
shrinkValid = forall a. Arbitrary a => a -> [a]
shrink

instance GenValid Word8 where
  genValid :: Gen Word8
genValid = forall a. (Integral a, Bounded a, Random a) => Gen a
genWordX
  shrinkValid :: Word8 -> [Word8]
shrinkValid = forall a. Arbitrary a => a -> [a]
shrink

instance GenValid Word16 where
  genValid :: Gen Word16
genValid = forall a. (Integral a, Bounded a, Random a) => Gen a
genWordX
  shrinkValid :: Word16 -> [Word16]
shrinkValid = forall a. Arbitrary a => a -> [a]
shrink

instance GenValid Word32 where
  genValid :: Gen Word32
genValid = forall a. (Integral a, Bounded a, Random a) => Gen a
genWordX
  shrinkValid :: Word32 -> [Word32]
shrinkValid = forall a. Arbitrary a => a -> [a]
shrink

instance GenValid Word64 where
  genValid :: Gen Word64
genValid = forall a. (Integral a, Bounded a, Random a) => Gen a
genWordX
  shrinkValid :: Word64 -> [Word64]
shrinkValid = forall a. Arbitrary a => a -> [a]
shrink

instance GenValid Float where
  genValid :: Gen Float
genValid = Gen Float
genFloat
  shrinkValid :: Float -> [Float]
shrinkValid Float
f
    | forall a. RealFloat a => a -> Bool
isInfinite Float
f = []
    | forall a. RealFloat a => a -> Bool
isNaN Float
f = []
    | Bool
otherwise = forall a. Arbitrary a => a -> [a]
shrink Float
f

instance GenValid Double where
  genValid :: Gen Double
genValid = Gen Double
genDouble
  shrinkValid :: Double -> [Double]
shrinkValid Double
d
    | forall a. RealFloat a => a -> Bool
isInfinite Double
d = []
    | forall a. RealFloat a => a -> Bool
isNaN Double
d = []
    | Bool
otherwise = forall a. Arbitrary a => a -> [a]
shrink Double
d

instance GenValid Integer where
  genValid :: Gen Integer
genValid = Gen Integer
genInteger
  shrinkValid :: Integer -> [Integer]
shrinkValid = forall a. Arbitrary a => a -> [a]
shrink

instance GenValid Natural where
  genValid :: Gen Natural
genValid = forall a. Num a => Integer -> a
fromInteger forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a
abs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. GenValid a => Gen a
genValid
  shrinkValid :: Natural -> [Natural]
shrinkValid = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Num a => Integer -> a
fromInteger forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a
abs) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. GenValid a => a -> [a]
shrinkValid forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Integral a => a -> Integer
toInteger

instance (Integral a, Num a, Ord a, GenValid a) => GenValid (Ratio a) where
  genValid :: Gen (Ratio a)
genValid =
    ( do
        a
n <- forall a. GenValid a => Gen a
genValid
        a
d <- (forall a. GenValid a => Gen a
genValid forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (forall a. Ord a => a -> a -> Bool
> a
0))
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ a
n forall a. a -> a -> Ratio a
:% a
d
    )
      forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` forall a. Validity a => a -> Bool
isValid
  shrinkValid :: Ratio a -> [Ratio a]
shrinkValid (a
n :% a
d) = do
    (a
n', a
d') <- forall a b. (a -> [a]) -> (b -> [b]) -> (a, b) -> [(a, b)]
shrinkTuple forall a. GenValid a => a -> [a]
shrinkValid (forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Ord a => a -> a -> Bool
> a
0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. GenValid a => a -> [a]
shrinkValid) (a
n, a
d)
    let candidate :: Ratio a
candidate = a
n' forall a. a -> a -> Ratio a
:% a
d'
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall a. Validity a => a -> Bool
isValid Ratio a
candidate
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ a
n' forall a. Integral a => a -> a -> Ratio a
% a
d'

instance HasResolution a => GenValid (Fixed a) where
  genValid :: Gen (Fixed a)
genValid = forall k (a :: k). Integer -> Fixed a
MkFixed forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. GenValid a => Gen a
genValid
  shrinkValid :: Fixed a -> [Fixed a]
shrinkValid (MkFixed Integer
i) = forall k (a :: k). Integer -> Fixed a
MkFixed forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. GenValid a => a -> [a]
shrinkValid Integer
i

-- | Generate a valid value by generating all the sub parts using the 'Generic' instance,
-- and trying that until a valid value has been generated
--
-- > genValidStructurally = genValidStructurallyWithoutExtraChecking `suchThat` isValid
--
-- This is probably the function that you are looking for.
-- If you do use this function to override `genValid`, you probably also want to use
-- 'shrinkValidStructurally' to override 'shrinkValid'.
genValidStructurally :: (Validity a, Generic a, GGenValid (Rep a)) => Gen a
genValidStructurally :: forall a. (Validity a, Generic a, GGenValid (Rep a)) => Gen a
genValidStructurally = forall a. (Generic a, GGenValid (Rep a)) => Gen a
genValidStructurallyWithoutExtraChecking forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` forall a. Validity a => a -> Bool
isValid

-- | Generate a valid value by generating all the sub parts using the 'Generic' instance,
--
-- This generator is _not_ guaranteed to generate a valid value.
--
-- This is probably _not_ the function that you are looking for when overriding
-- `genValid` _unless_ the type in question has no _extra_ validity constraints on top of
-- the validity of its sub parts.
genValidStructurallyWithoutExtraChecking :: (Generic a, GGenValid (Rep a)) => Gen a
genValidStructurallyWithoutExtraChecking :: forall a. (Generic a, GGenValid (Rep a)) => Gen a
genValidStructurallyWithoutExtraChecking = forall a x. Generic a => Rep a x -> a
to forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. GGenValid f => Gen (f a)
gGenValid

class GGenValid f where
  gGenValid :: Gen (f a)

instance GGenValid U1 where
  gGenValid :: forall a. Gen (U1 a)
gGenValid = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall k (p :: k). U1 p
U1

instance (GGenValid a, GGenValid b) => GGenValid (a :*: b) where
  gGenValid :: forall a. Gen ((:*:) a b a)
gGenValid = forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. GGenValid f => Gen (f a)
gGenValid forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. GGenValid f => Gen (f a)
gGenValid

instance (GGenValid a, GGenValid b) => GGenValid (a :+: b) where
  gGenValid :: forall a. Gen ((:+:) a b a)
gGenValid = forall a. [Gen a] -> Gen a
oneof [forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. GGenValid f => Gen (f a)
gGenValid, forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. GGenValid f => Gen (f a)
gGenValid]

instance (GGenValid a) => GGenValid (M1 i c a) where
  gGenValid :: forall a. Gen (M1 i c a a)
gGenValid = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. GGenValid f => Gen (f a)
gGenValid

instance (GenValid a) => GGenValid (K1 i a) where
  gGenValid :: forall a. Gen (K1 i a a)
gGenValid = forall k i c (p :: k). c -> K1 i c p
K1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. GenValid a => Gen a
genValid

-- | Shrink a term to any of its immediate valid subterms,
-- and also recursively shrink all subterms, and then filtering out the results that are not valid.
--
-- > shrinkValidStructurally = filter isValid . shrinkValidStructurallyWithoutExtraFiltering
--
-- This is probably the function that you are looking for.
shrinkValidStructurally :: (Validity a, Generic a, GValidRecursivelyShrink (Rep a), GValidSubterms (Rep a) a) => a -> [a]
shrinkValidStructurally :: forall a.
(Validity a, Generic a, GValidRecursivelyShrink (Rep a),
 GValidSubterms (Rep a) a) =>
a -> [a]
shrinkValidStructurally = forall a. (a -> Bool) -> [a] -> [a]
filter forall a. Validity a => a -> Bool
isValid forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
(Generic a, GValidRecursivelyShrink (Rep a),
 GValidSubterms (Rep a) a) =>
a -> [a]
shrinkValidStructurallyWithoutExtraFiltering

-- | Shrink a term to any of its immediate valid subterms,
-- and also recursively shrink all subterms.
--
-- This shrinking function is _not_ guaranteed to shrink to valid values.
--
-- This is probably _not_ the function that you are looking for when overriding
-- `shrinkValid` _unless_ the type in question has no _extra_ validity constraints on top of
-- the validity of its sub parts.
shrinkValidStructurallyWithoutExtraFiltering :: (Generic a, GValidRecursivelyShrink (Rep a), GValidSubterms (Rep a) a) => a -> [a]
shrinkValidStructurallyWithoutExtraFiltering :: forall a.
(Generic a, GValidRecursivelyShrink (Rep a),
 GValidSubterms (Rep a) a) =>
a -> [a]
shrinkValidStructurallyWithoutExtraFiltering a
x = forall a. (Generic a, GValidSubterms (Rep a) a) => a -> [a]
structurallyValidSubterms a
x forall a. [a] -> [a] -> [a]
++ forall a. (Generic a, GValidRecursivelyShrink (Rep a)) => a -> [a]
structurallyValidRecursivelyShrink a
x

-- | Recursively shrink all immediate structurally valid subterms.
structurallyValidRecursivelyShrink :: (Generic a, GValidRecursivelyShrink (Rep a)) => a -> [a]
structurallyValidRecursivelyShrink :: forall a. (Generic a, GValidRecursivelyShrink (Rep a)) => a -> [a]
structurallyValidRecursivelyShrink = forall a b. (a -> b) -> [a] -> [b]
map forall a x. Generic a => Rep a x -> a
to forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. GValidRecursivelyShrink f => f a -> [f a]
gValidRecursivelyShrink forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. Generic a => a -> Rep a x
from

class GValidRecursivelyShrink f where
  gValidRecursivelyShrink :: f a -> [f a]

instance (GValidRecursivelyShrink f, GValidRecursivelyShrink g) => GValidRecursivelyShrink (f :*: g) where
  gValidRecursivelyShrink :: forall a. (:*:) f g a -> [(:*:) f g a]
gValidRecursivelyShrink (f a
x :*: g a
y) =
    (forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. GValidRecursivelyShrink f => f a -> [f a]
gValidRecursivelyShrink f a
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. GValidRecursivelyShrink f => f a -> [f a]
gValidRecursivelyShrink g a
y)
      forall a. [a] -> [a] -> [a]
++ [f a
x' forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: g a
y | f a
x' <- forall (f :: * -> *) a. GValidRecursivelyShrink f => f a -> [f a]
gValidRecursivelyShrink f a
x]
      forall a. [a] -> [a] -> [a]
++ [f a
x forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: g a
y' | g a
y' <- forall (f :: * -> *) a. GValidRecursivelyShrink f => f a -> [f a]
gValidRecursivelyShrink g a
y]

instance (GValidRecursivelyShrink f, GValidRecursivelyShrink g) => GValidRecursivelyShrink (f :+: g) where
  gValidRecursivelyShrink :: forall a. (:+:) f g a -> [(:+:) f g a]
gValidRecursivelyShrink (L1 f a
x) = forall a b. (a -> b) -> [a] -> [b]
map forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (forall (f :: * -> *) a. GValidRecursivelyShrink f => f a -> [f a]
gValidRecursivelyShrink f a
x)
  gValidRecursivelyShrink (R1 g a
x) = forall a b. (a -> b) -> [a] -> [b]
map forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (forall (f :: * -> *) a. GValidRecursivelyShrink f => f a -> [f a]
gValidRecursivelyShrink g a
x)

instance GValidRecursivelyShrink f => GValidRecursivelyShrink (M1 i c f) where
  gValidRecursivelyShrink :: forall a. M1 i c f a -> [M1 i c f a]
gValidRecursivelyShrink (M1 f a
x) = forall a b. (a -> b) -> [a] -> [b]
map forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (forall (f :: * -> *) a. GValidRecursivelyShrink f => f a -> [f a]
gValidRecursivelyShrink f a
x)

instance GenValid a => GValidRecursivelyShrink (K1 i a) where
  gValidRecursivelyShrink :: forall a. K1 i a a -> [K1 i a a]
gValidRecursivelyShrink (K1 a
x) = forall a b. (a -> b) -> [a] -> [b]
map forall k i c (p :: k). c -> K1 i c p
K1 (forall a. GenValid a => a -> [a]
shrinkValid a
x)

instance GValidRecursivelyShrink U1 where
  gValidRecursivelyShrink :: forall a. U1 a -> [U1 a]
gValidRecursivelyShrink U1 a
U1 = []

instance GValidRecursivelyShrink V1 where
  -- The empty type can't be shrunk to anything.
  gValidRecursivelyShrink :: forall a. V1 a -> [V1 a]
gValidRecursivelyShrink V1 a
_ = []

-- | All immediate validSubterms of a term.
structurallyValidSubterms :: (Generic a, GValidSubterms (Rep a) a) => a -> [a]
structurallyValidSubterms :: forall a. (Generic a, GValidSubterms (Rep a) a) => a -> [a]
structurallyValidSubterms = forall (f :: * -> *) a. GValidSubterms f a => f a -> [a]
gValidSubterms forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. Generic a => a -> Rep a x
from

class GValidSubterms f a where
  gValidSubterms :: f a -> [a]

instance GValidSubterms V1 a where
  gValidSubterms :: V1 a -> [a]
gValidSubterms V1 a
_ = []

instance GValidSubterms U1 a where
  gValidSubterms :: U1 a -> [a]
gValidSubterms U1 a
U1 = []

instance (GValidSubtermsIncl f a, GValidSubtermsIncl g a) => GValidSubterms (f :*: g) a where
  gValidSubterms :: (:*:) f g a -> [a]
gValidSubterms (f a
l :*: g a
r) = forall (f :: * -> *) a. GValidSubtermsIncl f a => f a -> [a]
gValidSubtermsIncl f a
l forall a. [a] -> [a] -> [a]
++ forall (f :: * -> *) a. GValidSubtermsIncl f a => f a -> [a]
gValidSubtermsIncl g a
r

instance (GValidSubtermsIncl f a, GValidSubtermsIncl g a) => GValidSubterms (f :+: g) a where
  gValidSubterms :: (:+:) f g a -> [a]
gValidSubterms (L1 f a
x) = forall (f :: * -> *) a. GValidSubtermsIncl f a => f a -> [a]
gValidSubtermsIncl f a
x
  gValidSubterms (R1 g a
x) = forall (f :: * -> *) a. GValidSubtermsIncl f a => f a -> [a]
gValidSubtermsIncl g a
x

instance GValidSubterms f a => GValidSubterms (M1 i c f) a where
  gValidSubterms :: M1 i c f a -> [a]
gValidSubterms (M1 f a
x) = forall (f :: * -> *) a. GValidSubterms f a => f a -> [a]
gValidSubterms f a
x

instance GValidSubterms (K1 i a) b where
  gValidSubterms :: K1 i a b -> [b]
gValidSubterms (K1 a
_) = []

class GValidSubtermsIncl f a where
  gValidSubtermsIncl :: f a -> [a]

instance GValidSubtermsIncl V1 a where
  gValidSubtermsIncl :: V1 a -> [a]
gValidSubtermsIncl V1 a
_ = []

instance GValidSubtermsIncl U1 a where
  gValidSubtermsIncl :: U1 a -> [a]
gValidSubtermsIncl U1 a
U1 = []

instance (GValidSubtermsIncl f a, GValidSubtermsIncl g a) => GValidSubtermsIncl (f :*: g) a where
  gValidSubtermsIncl :: (:*:) f g a -> [a]
gValidSubtermsIncl (f a
l :*: g a
r) = forall (f :: * -> *) a. GValidSubtermsIncl f a => f a -> [a]
gValidSubtermsIncl f a
l forall a. [a] -> [a] -> [a]
++ forall (f :: * -> *) a. GValidSubtermsIncl f a => f a -> [a]
gValidSubtermsIncl g a
r

instance (GValidSubtermsIncl f a, GValidSubtermsIncl g a) => GValidSubtermsIncl (f :+: g) a where
  gValidSubtermsIncl :: (:+:) f g a -> [a]
gValidSubtermsIncl (L1 f a
x) = forall (f :: * -> *) a. GValidSubtermsIncl f a => f a -> [a]
gValidSubtermsIncl f a
x
  gValidSubtermsIncl (R1 g a
x) = forall (f :: * -> *) a. GValidSubtermsIncl f a => f a -> [a]
gValidSubtermsIncl g a
x

instance GValidSubtermsIncl f a => GValidSubtermsIncl (M1 i c f) a where
  gValidSubtermsIncl :: M1 i c f a -> [a]
gValidSubtermsIncl (M1 f a
x) = forall (f :: * -> *) a. GValidSubtermsIncl f a => f a -> [a]
gValidSubtermsIncl f a
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 i a a -> [a]
gValidSubtermsIncl (K1 a
x) = [a
x]

instance {-# OVERLAPPING #-} GValidSubtermsIncl (K1 i a) b where
  gValidSubtermsIncl :: K1 i a b -> [b]
gValidSubtermsIncl (K1 a
_) = []