{-# LANGUAGE UndecidableInstances #-}

-- | Default generators
--
-- 'GenDefault' (as well as t'Test.Falsify.GenDefault.Std.Std') are exported from
-- "Test.Falsify", so you will only need to import this module if you want to
-- make use of the deriving-via support.
--
-- Intended for unqualified import.
module Test.Falsify.GenDefault (
    GenDefault(..)
    -- * Deriving-via support
  , ViaTag(..)
  , ViaIntegral(..)
  , ViaEnum(..)
  , ViaList(..)
  , ViaString(..)
  , ViaGeneric(..)
  , GGenDefault -- opaque
  ) where

import Data.Bits (FiniteBits)
import Data.Proxy
import GHC.Exts (IsList (..), IsString (..))
import GHC.Generics
import GHC.TypeLits (KnownNat, natVal, Nat)

import qualified Control.Applicative as Ap

import Test.Falsify.Generator (Gen)
import qualified Test.Falsify.Generator as Gen
import qualified Test.Falsify.Range     as Range

-- | Default generators
--
-- 'GenDefault' is similar to QuickCheck's 'Test.QuickCheck.Arbitrary' class
-- along with some @deriving via@ helpers. Unlike @Arbitrary@, 'GenDefault'
-- allows one to choose between sets of default generators with user-defined
-- tags. See "Test.Falsify.GenDefault.Std" for the standard tag with a few
-- useful instances.
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
_ = (a -> ViaTag tag' a) -> Gen a -> Gen (ViaTag tag' a)
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> ViaTag tag' a
forall tag' a. a -> ViaTag tag' a
ViaTag (forall tag a. GenDefault tag a => Proxy tag -> Gen a
genDefault @tag' Proxy tag'
forall {k} (t :: k). Proxy t
Proxy)

{-------------------------------------------------------------------------------
  Deriving-via helpers for types of specific shape
-------------------------------------------------------------------------------}

-- | 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
_ = (a -> ViaIntegral a) -> Gen a -> Gen (ViaIntegral a)
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> ViaIntegral a
forall a. a -> ViaIntegral a
ViaIntegral (Range a -> Gen a
forall a. Range a -> Gen a
Gen.inRange Range a
forall a. (Integral a, FiniteBits a, Bounded a) => Range a
Range.uniform)

-- | 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
_ = (a -> ViaEnum a) -> Gen a -> Gen (ViaEnum a)
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> ViaEnum a
forall a. a -> ViaEnum a
ViaEnum (Range a -> Gen a
forall a. Range a -> Gen a
Gen.inRange ((a, a) -> Range a
forall a. Enum a => (a, a) -> Range a
Range.enum (a
forall a. Bounded a => a
minBound, a
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 = Integer -> Word
forall a. Num a => Integer -> a
fromInteger (Proxy mn -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall (t :: Nat). Proxy t
forall {k} (t :: k). Proxy t
Proxy @mn))
        bx :: Word
bx = Integer -> Word
forall a. Num a => Integer -> a
fromInteger (Proxy mx -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall (t :: Nat). Proxy t
forall {k} (t :: k). Proxy t
Proxy @mx))
    in ([Item l] -> ViaList l mn mx)
-> Gen [Item l] -> Gen (ViaList l mn mx)
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (l -> ViaList l mn mx
forall l (mn :: Nat) (mx :: Nat). l -> ViaList l mn mx
ViaList (l -> ViaList l mn mx)
-> ([Item l] -> l) -> [Item l] -> ViaList l mn mx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Item l] -> l
forall l. IsList l => [Item l] -> l
fromList) (Range Word -> Gen (Item l) -> Gen [Item l]
forall a. Range Word -> Gen a -> Gen [a]
Gen.list ((Word, Word) -> Range Word
forall a. (Integral a, FiniteBits a) => (a, a) -> Range a
Range.inclusive (Word
bn, Word
bx)) (Proxy tag -> Gen (Item l)
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 = Integer -> Word
forall a. Num a => Integer -> a
fromInteger (Proxy mn -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall (t :: Nat). Proxy t
forall {k} (t :: k). Proxy t
Proxy @mn))
        bx :: Word
bx = Integer -> Word
forall a. Num a => Integer -> a
fromInteger (Proxy mx -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall (t :: Nat). Proxy t
forall {k} (t :: k). Proxy t
Proxy @mx))
    in (String -> ViaString s mn mx)
-> Gen String -> Gen (ViaString s mn mx)
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (s -> ViaString s mn mx
forall s (mn :: Nat) (mx :: Nat). s -> ViaString s mn mx
ViaString (s -> ViaString s mn mx)
-> (String -> s) -> String -> ViaString s mn mx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> s
forall a. IsString a => String -> a
fromString) (Range Word -> Gen Char -> Gen String
forall a. Range Word -> Gen a -> Gen [a]
Gen.list ((Word, Word) -> Range Word
forall a. (Integral a, FiniteBits a) => (a, a) -> Range a
Range.inclusive (Word
bn, Word
bx)) (Proxy tag -> Gen Char
forall tag a. GenDefault tag a => Proxy tag -> Gen a
genDefault Proxy tag
p))

{-------------------------------------------------------------------------------
  Generics
-------------------------------------------------------------------------------}

-- | Generic generator construction
--
-- For use with t'ViaGeneric'.
class GGenDefault tag f where
  {-# MINIMAL #-}
  ggenDefault :: Proxy tag -> Gen (f a)
  ggenDefault Proxy tag
_ = String -> Gen (f a)
forall a. HasCallStack => String -> a
error String
"ggenDefault not implemented"

instance GGenDefault tag U1 where
  ggenDefault :: forall a. Proxy tag -> Gen (U1 a)
ggenDefault Proxy tag
_ = U1 a -> Gen (U1 a)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 a
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 = (a a -> M1 i c a a) -> Gen (a a) -> Gen (M1 i c a a)
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a a -> M1 i c a a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Gen (a a) -> Gen (M1 i c a a))
-> (Proxy tag -> Gen (a a)) -> Proxy tag -> Gen (M1 i c a a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy tag -> Gen (a a)
forall a. Proxy tag -> Gen (a a)
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 = (a a -> b a -> (:*:) a b a)
-> Gen (a a) -> Gen (b a) -> Gen ((:*:) a b a)
forall a b c. (a -> b -> c) -> Gen a -> Gen b -> Gen c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
Ap.liftA2 a a -> b a -> (:*:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (Proxy tag -> Gen (a a)
forall a. Proxy tag -> Gen (a a)
forall tag (f :: * -> *) a.
GGenDefault tag f =>
Proxy tag -> Gen (f a)
ggenDefault Proxy tag
p) (Proxy tag -> Gen (b a)
forall a. Proxy tag -> Gen (b a)
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 = Gen ((:+:) a b a) -> Gen ((:+:) a b a) -> Gen ((:+:) a b a)
forall a. Gen a -> Gen a -> Gen a
Gen.choose ((a a -> (:+:) a b a) -> Gen (a a) -> Gen ((:+:) a b a)
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a a -> (:+:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (Proxy tag -> Gen (a a)
forall a. Proxy tag -> Gen (a a)
forall tag (f :: * -> *) a.
GGenDefault tag f =>
Proxy tag -> Gen (f a)
ggenDefault Proxy tag
p)) ((b a -> (:+:) a b a) -> Gen (b a) -> Gen ((:+:) a b a)
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b a -> (:+:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (Proxy tag -> Gen (b a)
forall a. Proxy tag -> Gen (b a)
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 = (a -> K1 i a a) -> Gen a -> Gen (K1 i a a)
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> K1 i a a
forall k i c (p :: k). c -> K1 i c p
K1 (Gen a -> Gen (K1 i a a))
-> (Proxy tag -> Gen a) -> Proxy tag -> Gen (K1 i a a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy tag -> Gen a
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 = (Rep t Any -> ViaGeneric tag t)
-> Gen (Rep t Any) -> Gen (ViaGeneric tag t)
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (t -> ViaGeneric tag t
forall tag a. a -> ViaGeneric tag a
ViaGeneric (t -> ViaGeneric tag t)
-> (Rep t Any -> t) -> Rep t Any -> ViaGeneric tag t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rep t Any -> t
forall a x. Generic a => Rep a x -> a
forall x. Rep t x -> t
to) (Gen (Rep t Any) -> Gen (ViaGeneric tag t))
-> (Proxy tag -> Gen (Rep t Any))
-> Proxy tag
-> Gen (ViaGeneric tag t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy tag -> Gen (Rep t Any)
forall a. Proxy tag -> Gen (Rep t a)
forall tag (f :: * -> *) a.
GGenDefault tag f =>
Proxy tag -> Gen (f a)
ggenDefault