{-# LANGUAGE UndecidableInstances #-}

-- | This module defines something similar to QuickCheck's Arbitrary class along with
-- some DerivingVia helpers. Our version, 'GenDefault', allows one to choose between
-- sets of default generators with a user-defined tag. See 'Test.Falsify.GenDefault.Std' for
-- the standard tag with a few useful instances.
module Test.Falsify.GenDefault
  ( GenDefault (..)
  , ViaTag (..)
  , ViaIntegral (..)
  , ViaEnum (..)
  , ViaList (..)
  , ViaString (..)
  , ViaGeneric (..)
  ) where

import Control.Applicative (liftA2)
import Data.Proxy (Proxy (..))
import GHC.Generics (Generic (..), K1 (..), M1 (..), U1 (..), (:+:) (..), (:*:) (..))
import Test.Falsify.Generator (Gen)
import qualified Test.Falsify.Generator as Gen
import qualified Test.Falsify.Range as Range
import Data.Bits (FiniteBits)
import GHC.Exts (IsList (..), IsString (..))
import GHC.TypeLits (KnownNat, natVal, Nat)

class GenDefault tag a where
  -- | Default generator for @a@
  --
  -- The type-level @tag@ allows types @a@ to have multiple defaults.
  genDefault :: Proxy tag -> Gen a

-- | DerivingVia wrapper for types with default instances under other tags
newtype ViaTag tag' a = ViaTag {forall tag' a. ViaTag tag' a -> a
unViaTag :: a}

instance GenDefault tag' a => GenDefault tag (ViaTag tag' a) where
  genDefault :: Proxy tag -> Gen (ViaTag tag' a)
genDefault Proxy tag
_ = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall tag' a. a -> ViaTag tag' a
ViaTag (forall tag a. GenDefault tag a => Proxy tag -> Gen a
genDefault @tag' forall {k} (t :: k). Proxy t
Proxy)

-- | DerivingVia wrapper for Integral types
newtype ViaIntegral a = ViaIntegral {forall a. ViaIntegral a -> a
unViaIntegral :: a}

instance (Integral a, FiniteBits a, Bounded a) => GenDefault tag (ViaIntegral a) where
  genDefault :: Proxy tag -> Gen (ViaIntegral a)
genDefault Proxy tag
_ = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> ViaIntegral a
ViaIntegral (forall a. Range a -> Gen a
Gen.inRange (forall a. (Integral a, FiniteBits a) => (a, a) -> Range a
Range.between (forall a. Bounded a => a
minBound, forall a. Bounded a => a
maxBound)))

-- | DerivingVia wrapper for Enum types
newtype ViaEnum a = ViaEnum {forall a. ViaEnum a -> a
unViaEnum :: a}

instance (Enum a, Bounded a) => GenDefault tag (ViaEnum a) where
  genDefault :: Proxy tag -> Gen (ViaEnum a)
genDefault Proxy tag
_ = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> ViaEnum a
ViaEnum (forall a. Range a -> Gen a
Gen.inRange (forall a. Enum a => (a, a) -> Range a
Range.enum (forall a. Bounded a => a
minBound, forall a. Bounded a => a
maxBound)))

-- | DerivingVia wrapper for FromList types
newtype ViaList l (mn :: Nat) (mx :: Nat) = ViaList {forall l (mn :: Nat) (mx :: Nat). ViaList l mn mx -> l
unViaList :: l}

instance (IsList l, GenDefault tag (Item l), KnownNat mn, KnownNat mx) => GenDefault tag (ViaList l mn mx) where
  genDefault :: Proxy tag -> Gen (ViaList l mn mx)
genDefault Proxy tag
p =
    let bn :: Word
bn = forall a. Num a => Integer -> a
fromInteger (forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall {k} (t :: k). Proxy t
Proxy @mn))
        bx :: Word
bx = forall a. Num a => Integer -> a
fromInteger (forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall {k} (t :: k). Proxy t
Proxy @mx))
    in forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall l (mn :: Nat) (mx :: Nat). l -> ViaList l mn mx
ViaList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. IsList l => [Item l] -> l
fromList) (forall a. Range Word -> Gen a -> Gen [a]
Gen.list (forall a. (Integral a, FiniteBits a) => (a, a) -> Range a
Range.between (Word
bn, Word
bx)) (forall tag a. GenDefault tag a => Proxy tag -> Gen a
genDefault Proxy tag
p))

-- | DerivingVia wrapper for FromString types
newtype ViaString s (mn :: Nat) (mx :: Nat) = ViaString {forall s (mn :: Nat) (mx :: Nat). ViaString s mn mx -> s
unViaString :: s}

instance (IsString s, GenDefault tag Char, KnownNat mn, KnownNat mx) => GenDefault tag (ViaString s mn mx) where
  genDefault :: Proxy tag -> Gen (ViaString s mn mx)
genDefault Proxy tag
p =
    let bn :: Word
bn = forall a. Num a => Integer -> a
fromInteger (forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall {k} (t :: k). Proxy t
Proxy @mn))
        bx :: Word
bx = forall a. Num a => Integer -> a
fromInteger (forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall {k} (t :: k). Proxy t
Proxy @mx))
    in forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall s (mn :: Nat) (mx :: Nat). s -> ViaString s mn mx
ViaString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString) (forall a. Range Word -> Gen a -> Gen [a]
Gen.list (forall a. (Integral a, FiniteBits a) => (a, a) -> Range a
Range.between (Word
bn, Word
bx)) (forall tag a. GenDefault tag a => Proxy tag -> Gen a
genDefault Proxy tag
p))

class GGenDefault tag f where
  ggenDefault :: Proxy tag -> Gen (f a)

instance GGenDefault tag U1 where
  ggenDefault :: forall a. Proxy tag -> Gen (U1 a)
ggenDefault Proxy tag
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall k (p :: k). U1 p
U1

instance GGenDefault tag a => GGenDefault tag (M1 i c a) where
  ggenDefault :: forall a. Proxy tag -> Gen (M1 i c a a)
ggenDefault = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall tag (f :: * -> *) a.
GGenDefault tag f =>
Proxy tag -> Gen (f a)
ggenDefault

instance (GGenDefault tag a, GGenDefault tag b) => GGenDefault tag (a :*: b) where
  ggenDefault :: forall a. Proxy tag -> Gen ((:*:) a b a)
ggenDefault Proxy tag
p = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (forall tag (f :: * -> *) a.
GGenDefault tag f =>
Proxy tag -> Gen (f a)
ggenDefault Proxy tag
p) (forall tag (f :: * -> *) a.
GGenDefault tag f =>
Proxy tag -> Gen (f a)
ggenDefault Proxy tag
p)

instance (GGenDefault tag a, GGenDefault tag b) => GGenDefault tag (a :+: b) where
  ggenDefault :: forall a. Proxy tag -> Gen ((:+:) a b a)
ggenDefault Proxy tag
p = forall a. Gen a -> Gen a -> Gen a
Gen.choose (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (forall tag (f :: * -> *) a.
GGenDefault tag f =>
Proxy tag -> Gen (f a)
ggenDefault Proxy tag
p)) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (forall tag (f :: * -> *) a.
GGenDefault tag f =>
Proxy tag -> Gen (f a)
ggenDefault Proxy tag
p))

instance GenDefault tag a => GGenDefault tag (K1 i a) where
  ggenDefault :: forall a. Proxy tag -> Gen (K1 i a a)
ggenDefault = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k i c (p :: k). c -> K1 i c p
K1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall tag a. GenDefault tag a => Proxy tag -> Gen a
genDefault

-- | DerivingVia wrapper for Generic types
newtype ViaGeneric tag a = ViaGeneric {forall tag a. ViaGeneric tag a -> a
unViaGeneric :: a}

instance (Generic t, GGenDefault tag (Rep t)) => GenDefault tag (ViaGeneric tag t) where
  genDefault :: Proxy tag -> Gen (ViaGeneric tag t)
genDefault = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall tag a. a -> ViaGeneric tag a
ViaGeneric forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. Generic a => Rep a x -> a
to) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall tag (f :: * -> *) a.
GGenDefault tag f =>
Proxy tag -> Gen (f a)
ggenDefault