{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
#if __GLASGOW_HASKELL__ < 710
{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE IncoherentInstances #-}
#endif
module Generic.Random.Internal.Generic where
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative (Applicative(..))
#endif
import Control.Applicative (Alternative(..), liftA2)
import Data.Coerce (coerce)
#if __GLASGOW_HASKELL__ >= 800
import Data.Kind (Type)
#endif
import Data.Proxy (Proxy(..))
#if __GLASGOW_HASKELL__ >= 800
import GHC.Generics hiding (S, prec)
#else
import GHC.Generics hiding (S, Arity, prec)
#endif
import GHC.TypeLits (KnownNat, Nat, Symbol, type (+), natVal)
import Test.QuickCheck (Arbitrary(..), Gen, choose, scale, sized, vectorOf)
#if __GLASGOW_HASKELL__ < 800
#define Type *
#endif
genericArbitrary
:: (GArbitrary UnsizedOpts a)
=> Weights a
-> Gen a
genericArbitrary :: Weights a -> Gen a
genericArbitrary = UnsizedOpts -> Weights a -> Gen a
forall opts a. GArbitrary opts a => opts -> Weights a -> Gen a
genericArbitraryWith UnsizedOpts
unsizedOpts
genericArbitraryU
:: (GArbitrary UnsizedOpts a, GUniformWeight a)
=> Gen a
genericArbitraryU :: Gen a
genericArbitraryU = Weights a -> Gen a
forall a. GArbitrary UnsizedOpts a => Weights a -> Gen a
genericArbitrary Weights a
forall a. UniformWeight_ (Rep a) => Weights a
uniform
genericArbitrarySingle
:: (GArbitrary UnsizedOpts a, Weights_ (Rep a) ~ L c0)
=> Gen a
genericArbitrarySingle :: Gen a
genericArbitrarySingle = Gen a
forall a. (GArbitrary UnsizedOpts a, GUniformWeight a) => Gen a
genericArbitraryU
genericArbitraryRec
:: (GArbitrary SizedOptsDef a)
=> Weights a
-> Gen a
genericArbitraryRec :: Weights a -> Gen a
genericArbitraryRec = SizedOptsDef -> Weights a -> Gen a
forall opts a. GArbitrary opts a => opts -> Weights a -> Gen a
genericArbitraryWith SizedOptsDef
sizedOptsDef
genericArbitraryG
:: (GArbitrary (SetGens genList UnsizedOpts) a)
=> genList
-> Weights a
-> Gen a
genericArbitraryG :: genList -> Weights a -> Gen a
genericArbitraryG gs :: genList
gs = Options 'Unsized genList -> Weights a -> Gen a
forall opts a. GArbitrary opts a => opts -> Weights a -> Gen a
genericArbitraryWith Options 'Unsized genList
opts
where
opts :: Options 'Unsized genList
opts = genList -> UnsizedOpts -> Options 'Unsized genList
forall genList (s :: Sizing) g0.
genList -> Options s g0 -> Options s genList
setGenerators genList
gs UnsizedOpts
unsizedOpts
genericArbitraryUG
:: (GArbitrary (SetGens genList UnsizedOpts) a, GUniformWeight a)
=> genList
-> Gen a
genericArbitraryUG :: genList -> Gen a
genericArbitraryUG gs :: genList
gs = genList -> Weights a -> Gen a
forall genList a.
GArbitrary (SetGens genList UnsizedOpts) a =>
genList -> Weights a -> Gen a
genericArbitraryG genList
gs Weights a
forall a. UniformWeight_ (Rep a) => Weights a
uniform
genericArbitrarySingleG
:: (GArbitrary (SetGens genList UnsizedOpts) a, Weights_ (Rep a) ~ L c0)
=> genList
-> Gen a
genericArbitrarySingleG :: genList -> Gen a
genericArbitrarySingleG = genList -> Gen a
forall genList a.
(GArbitrary (SetGens genList UnsizedOpts) a, GUniformWeight a) =>
genList -> Gen a
genericArbitraryUG
genericArbitraryRecG
:: (GArbitrary (SetGens genList SizedOpts) a)
=> genList
-> Weights a
-> Gen a
genericArbitraryRecG :: genList -> Weights a -> Gen a
genericArbitraryRecG gs :: genList
gs = Options 'Sized genList -> Weights a -> Gen a
forall opts a. GArbitrary opts a => opts -> Weights a -> Gen a
genericArbitraryWith Options 'Sized genList
opts
where
opts :: Options 'Sized genList
opts = genList -> Options 'Sized () -> Options 'Sized genList
forall genList (s :: Sizing) g0.
genList -> Options s g0 -> Options s genList
setGenerators genList
gs Options 'Sized ()
sizedOpts
genericArbitraryWith
:: (GArbitrary opts a)
=> opts -> Weights a -> Gen a
genericArbitraryWith :: opts -> Weights a -> Gen a
genericArbitraryWith opts :: opts
opts (Weights w :: Weights_ (Rep a)
w n :: Int
n) =
(Rep a Any -> a) -> Gen (Rep a Any) -> Gen a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Rep a Any -> a
forall a x. Generic a => Rep a x -> a
to (opts -> Weights_ (Rep a) -> Int -> Gen (Rep a Any)
forall opts (f :: * -> *) p.
GA opts f =>
opts -> Weights_ f -> Int -> Gen (f p)
ga opts
opts Weights_ (Rep a)
w Int
n)
type family Weights_ (f :: Type -> Type) :: Type where
Weights_ (f :+: g) = Weights_ f :| Weights_ g
Weights_ (M1 D _c f) = Weights_ f
#if __GLASGOW_HASKELL__ >= 800
Weights_ (M1 C ('MetaCons c _i _j) _f) = L c
#else
Weights_ (M1 C _c _f) = L ""
#endif
data a :| b = N a Int b
data L (c :: Symbol) = L
data Weights a = Weights (Weights_ (Rep a)) Int
newtype W (c :: Symbol) = W Int deriving Integer -> W c
W c -> W c
W c -> W c -> W c
(W c -> W c -> W c)
-> (W c -> W c -> W c)
-> (W c -> W c -> W c)
-> (W c -> W c)
-> (W c -> W c)
-> (W c -> W c)
-> (Integer -> W c)
-> Num (W c)
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
forall (c :: Symbol). Integer -> W c
forall (c :: Symbol). W c -> W c
forall (c :: Symbol). W c -> W c -> W c
fromInteger :: Integer -> W c
$cfromInteger :: forall (c :: Symbol). Integer -> W c
signum :: W c -> W c
$csignum :: forall (c :: Symbol). W c -> W c
abs :: W c -> W c
$cabs :: forall (c :: Symbol). W c -> W c
negate :: W c -> W c
$cnegate :: forall (c :: Symbol). W c -> W c
* :: W c -> W c -> W c
$c* :: forall (c :: Symbol). W c -> W c -> W c
- :: W c -> W c -> W c
$c- :: forall (c :: Symbol). W c -> W c -> W c
+ :: W c -> W c -> W c
$c+ :: forall (c :: Symbol). W c -> W c -> W c
Num
weights :: (Weights_ (Rep a), Int, ()) -> Weights a
weights :: (Weights_ (Rep a), Int, ()) -> Weights a
weights (w :: Weights_ (Rep a)
w, n :: Int
n, ()) = Weights_ (Rep a) -> Int -> Weights a
forall a. Weights_ (Rep a) -> Int -> Weights a
Weights Weights_ (Rep a)
w Int
n
uniform :: UniformWeight_ (Rep a) => Weights a
uniform :: Weights a
uniform =
let (w :: Weights_ (Rep a)
w, n :: Int
n) = (Weights_ (Rep a), Int)
forall a. UniformWeight a => (a, Int)
uniformWeight
in Weights_ (Rep a) -> Int -> Weights a
forall a. Weights_ (Rep a) -> Int -> Weights a
Weights Weights_ (Rep a)
w Int
n
type family First a :: Symbol where
First (a :| _b) = First a
First (L c) = c
type family First' w where
First' (Weights a) = First (Weights_ (Rep a))
First' (a, Int, r) = First a
type family Prec' w where
Prec' (Weights a) = Prec (Weights_ (Rep a)) ()
Prec' (a, Int, r) = Prec a r
#if __GLASGOW_HASKELL__ >= 800
class (a ~ b) => a ~. b
instance (a ~ b) => a ~. b
#else
class a ~. b
instance a ~. b
#endif
class WeightBuilder' w where
(%) :: (c ~. First' w) => W c -> Prec' w -> w
instance WeightBuilder (Weights_ (Rep a)) => WeightBuilder' (Weights a) where
w :: W c
w % :: W c -> Prec' (Weights a) -> Weights a
% prec :: Prec' (Weights a)
prec = (Weights_ (Rep a), Int, ()) -> Weights a
forall a. (Weights_ (Rep a), Int, ()) -> Weights a
weights (W c
w W c -> Prec (Weights_ (Rep a)) () -> (Weights_ (Rep a), Int, ())
forall a (c :: Symbol) r.
(WeightBuilder a, c ~. First a) =>
W c -> Prec a r -> (a, Int, r)
%. Prec (Weights_ (Rep a)) ()
Prec' (Weights a)
prec)
instance WeightBuilder a => WeightBuilder' (a, Int, r) where
% :: W c -> Prec' (a, Int, r) -> (a, Int, r)
(%) = W c -> Prec' (a, Int, r) -> (a, Int, r)
forall a (c :: Symbol) r.
(WeightBuilder a, c ~. First a) =>
W c -> Prec a r -> (a, Int, r)
(%.)
class WeightBuilder a where
type Prec a r
(%.) :: (c ~. First a) => W c -> Prec a r -> (a, Int, r)
infixr 1 %
instance WeightBuilder a => WeightBuilder (a :| b) where
type Prec (a :| b) r = Prec a (b, Int, r)
m :: W c
m %. :: W c -> Prec (a :| b) r -> (a :| b, Int, r)
%. prec :: Prec (a :| b) r
prec =
let (a :: a
a, n :: Int
n, (b :: b
b, p :: Int
p, r :: r
r)) = W c
m W c -> Prec' (a, Int, (b, Int, r)) -> (a, Int, (b, Int, r))
forall w (c :: Symbol).
(WeightBuilder' w, c ~. First' w) =>
W c -> Prec' w -> w
% Prec (a :| b) r
Prec' (a, Int, (b, Int, r))
prec
in (a -> Int -> b -> a :| b
forall a b. a -> Int -> b -> a :| b
N a
a Int
n b
b, Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
p, r
r)
instance WeightBuilder (L c) where
type Prec (L c) r = r
W m :: Int
m %. :: W c -> Prec (L c) r -> (L c, Int, r)
%. prec :: Prec (L c) r
prec = (L c
forall (c :: Symbol). L c
L, Int
m, r
Prec (L c) r
prec)
instance WeightBuilder () where
type Prec () r = r
W m :: Int
m %. :: W c -> Prec () r -> ((), Int, r)
%. prec :: Prec () r
prec = ((), Int
m, r
Prec () r
prec)
class UniformWeight a where
uniformWeight :: (a, Int)
instance (UniformWeight a, UniformWeight b) => UniformWeight (a :| b) where
uniformWeight :: (a :| b, Int)
uniformWeight =
let
(a :: a
a, m :: Int
m) = (a, Int)
forall a. UniformWeight a => (a, Int)
uniformWeight
(b :: b
b, n :: Int
n) = (b, Int)
forall a. UniformWeight a => (a, Int)
uniformWeight
in
(a -> Int -> b -> a :| b
forall a b. a -> Int -> b -> a :| b
N a
a Int
m b
b, Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n)
instance UniformWeight (L c) where
uniformWeight :: (L c, Int)
uniformWeight = (L c
forall (c :: Symbol). L c
L, 1)
instance UniformWeight () where
uniformWeight :: ((), Int)
uniformWeight = ((), 1)
class UniformWeight (Weights_ f) => UniformWeight_ f
instance UniformWeight (Weights_ f) => UniformWeight_ f
class UniformWeight_ (Rep a) => GUniformWeight a
instance UniformWeight_ (Rep a) => GUniformWeight a
newtype Options (s :: Sizing) (genList :: Type) = Options
{ Options s genList -> genList
_generators :: genList
}
unsizedOpts :: UnsizedOpts
unsizedOpts :: UnsizedOpts
unsizedOpts = () -> UnsizedOpts
forall (s :: Sizing) genList. genList -> Options s genList
Options ()
sizedOpts :: SizedOpts
sizedOpts :: Options 'Sized ()
sizedOpts = () -> Options 'Sized ()
forall (s :: Sizing) genList. genList -> Options s genList
Options ()
sizedOptsDef :: SizedOptsDef
sizedOptsDef :: SizedOptsDef
sizedOptsDef = (Gen1 [] :+ ()) -> SizedOptsDef
forall (s :: Sizing) genList. genList -> Options s genList
Options ((forall a. Gen a -> Gen [a]) -> Gen1 []
forall (f :: * -> *). (forall a. Gen a -> Gen (f a)) -> Gen1 f
Gen1 forall a. Gen a -> Gen [a]
listOf' Gen1 [] -> () -> Gen1 [] :+ ()
forall a b. a -> b -> a :+ b
:+ ())
data Sizing = Sized | Unsized
type UnsizedOpts = Options 'Unsized ()
type SizedOpts = Options 'Sized ()
type SizedOptsDef = Options 'Sized (Gen1 [] :+ ())
type family SizingOf opts :: Sizing
type instance SizingOf (Options s _g) = s
setSized :: Options s g -> Options 'Sized g
setSized :: Options s g -> Options 'Sized g
setSized = Options s g -> Options 'Sized g
forall a b. Coercible a b => a -> b
coerce
setUnsized :: Options s g -> Options 'Unsized g
setUnsized :: Options s g -> Options 'Unsized g
setUnsized = Options s g -> Options 'Unsized g
forall a b. Coercible a b => a -> b
coerce
data a :+ b = a :+ b
infixr 1 :+
type family GeneratorsOf opts :: Type
type instance GeneratorsOf (Options _s g) = g
class HasGenerators opts where
generators :: opts -> GeneratorsOf opts
instance HasGenerators (Options s g) where
generators :: Options s g -> GeneratorsOf (Options s g)
generators = Options s g -> GeneratorsOf (Options s g)
forall (s :: Sizing) genList. Options s genList -> genList
_generators
setGenerators :: genList -> Options s g0 -> Options s genList
setGenerators :: genList -> Options s g0 -> Options s genList
setGenerators gens :: genList
gens (Options _) = genList -> Options s genList
forall (s :: Sizing) genList. genList -> Options s genList
Options genList
gens
type family SetGens (g :: Type) opts
type instance SetGens g (Options s _g) = Options s g
#if __GLASGOW_HASKELL__ >= 800
newtype FieldGen (s :: Symbol) a = FieldGen { FieldGen s a -> Gen a
unFieldGen :: Gen a }
fieldGen :: proxy s -> Gen a -> FieldGen s a
fieldGen :: proxy s -> Gen a -> FieldGen s a
fieldGen _ = Gen a -> FieldGen s a
forall (s :: Symbol) a. Gen a -> FieldGen s a
FieldGen
newtype ConstrGen (c :: Symbol) (i :: Nat) a = ConstrGen { ConstrGen c i a -> Gen a
unConstrGen :: Gen a }
constrGen :: proxy '(c, i) -> Gen a -> ConstrGen c i a
constrGen :: proxy '(c, i) -> Gen a -> ConstrGen c i a
constrGen _ = Gen a -> ConstrGen c i a
forall (c :: Symbol) (i :: Nat) a. Gen a -> ConstrGen c i a
ConstrGen
#endif
newtype Gen1 f = Gen1 { Gen1 f -> forall a. Gen a -> Gen (f a)
unGen1 :: forall a. Gen a -> Gen (f a) }
newtype Gen1_ f = Gen1_ { Gen1_ f -> forall (a :: k). Gen (f a)
unGen1_ :: forall a. Gen (f a) }
vectorOf' :: Int -> Gen a -> Gen [a]
vectorOf' :: Int -> Gen a -> Gen [a]
vectorOf' 0 = \_ -> [a] -> Gen [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
vectorOf' i :: Int
i = (Int -> Int) -> Gen [a] -> Gen [a]
forall a. (Int -> Int) -> Gen a -> Gen a
scale (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
i) (Gen [a] -> Gen [a]) -> (Gen a -> Gen [a]) -> Gen a -> Gen [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Gen a -> Gen [a]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
i
listOf' :: Gen a -> Gen [a]
listOf' :: Gen a -> Gen [a]
listOf' g :: Gen a
g = (Int -> Gen [a]) -> Gen [a]
forall a. (Int -> Gen a) -> Gen a
sized ((Int -> Gen [a]) -> Gen [a]) -> (Int -> Gen [a]) -> Gen [a]
forall a b. (a -> b) -> a -> b
$ \n :: Int
n -> do
Int
i <- Int -> Gen Int
geom Int
n
Int -> Gen a -> Gen [a]
forall a. Int -> Gen a -> Gen [a]
vectorOf' Int
i Gen a
g
listOf1' :: Gen a -> Gen [a]
listOf1' :: Gen a -> Gen [a]
listOf1' g :: Gen a
g = (a -> [a] -> [a]) -> Gen a -> Gen [a] -> Gen [a]
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (:) Gen a
g (Gen a -> Gen [a]
forall a. Gen a -> Gen [a]
listOf' Gen a
g)
geom :: Int -> Gen Int
geom :: Int -> Gen Int
geom 0 = Int -> Gen Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure 0
geom n :: Int
n = Int -> Gen Int
go 0 where
n' :: Double
n' = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n
p :: Double
p = 1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Double -> Double
forall a. Floating a => a -> a
sqrt Double
n' Double -> Double -> Double
forall a. Num a => a -> a -> a
+ 1) :: Double
go :: Int -> Gen Int
go r :: Int
r = do
Double
x <- (Double, Double) -> Gen Double
forall a. Random a => (a, a) -> Gen a
choose (0, 1)
if Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
p then
Int -> Gen Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
r
else
Int -> Gen Int
go (Int -> Gen Int) -> Int -> Gen Int
forall a b. (a -> b) -> a -> b
$! (Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)
class GA opts f where
ga :: opts -> Weights_ f -> Int -> Gen (f p)
class (Generic a, GA opts (Rep a)) => GArbitrary opts a
instance (Generic a, GA opts (Rep a)) => GArbitrary opts a
instance GA opts f => GA opts (M1 D c f) where
ga :: opts -> Weights_ (M1 D c f) -> Int -> Gen (M1 D c f p)
ga z :: opts
z w :: Weights_ (M1 D c f)
w n :: Int
n = (f p -> M1 D c f p) -> Gen (f p) -> Gen (M1 D c f p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f p -> M1 D c f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (opts -> Weights_ f -> Int -> Gen (f p)
forall opts (f :: * -> *) p.
GA opts f =>
opts -> Weights_ f -> Int -> Gen (f p)
ga opts
z Weights_ f
Weights_ (M1 D c f)
w Int
n)
{-# INLINE ga #-}
instance (GASum opts f, GASum opts g) => GA opts (f :+: g) where
ga :: opts -> Weights_ (f :+: g) -> Int -> Gen ((:+:) f g p)
ga = opts -> Weights_ (f :+: g) -> Int -> Gen ((:+:) f g p)
forall opts (f :: * -> *) p.
GASum opts f =>
opts -> Weights_ f -> Int -> Gen (f p)
gaSum'
{-# INLINE ga #-}
instance GAProduct (SizingOf opts) (Name c) opts f => GA opts (M1 C c f) where
ga :: opts -> Weights_ (M1 C c f) -> Int -> Gen (M1 C c f p)
ga z :: opts
z _ _ = (f p -> M1 C c f p) -> Gen (f p) -> Gen (M1 C c f p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f p -> M1 C c f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Proxy '(SizingOf opts, Name c) -> opts -> Gen (f p)
forall k (s :: Sizing) (c :: Maybe Symbol) opts (f :: k -> *)
(proxys :: (Sizing, Maybe Symbol) -> *) (p :: k).
GAProduct s c opts f =>
proxys '(s, c) -> opts -> Gen (f p)
gaProduct (Proxy '(SizingOf opts, Name c)
forall k (t :: k). Proxy t
Proxy :: Proxy '(SizingOf opts, Name c)) opts
z)
{-# INLINE ga #-}
gaSum' :: GASum opts f => opts -> Weights_ f -> Int -> Gen (f p)
gaSum' :: opts -> Weights_ f -> Int -> Gen (f p)
gaSum' z :: opts
z w :: Weights_ f
w n :: Int
n = do
Int
i <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (0, Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-1)
opts -> Int -> Weights_ f -> Gen (f p)
forall opts (f :: * -> *) p.
GASum opts f =>
opts -> Int -> Weights_ f -> Gen (f p)
gaSum opts
z Int
i Weights_ f
w
{-# INLINE gaSum' #-}
class GASum opts f where
gaSum :: opts -> Int -> Weights_ f -> Gen (f p)
instance (GASum opts f, GASum opts g) => GASum opts (f :+: g) where
gaSum :: opts -> Int -> Weights_ (f :+: g) -> Gen ((:+:) f g p)
gaSum z :: opts
z i :: Int
i (N a n b)
| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n = (f p -> (:+:) f g p) -> Gen (f p) -> Gen ((:+:) f g p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f p -> (:+:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (opts -> Int -> Weights_ f -> Gen (f p)
forall opts (f :: * -> *) p.
GASum opts f =>
opts -> Int -> Weights_ f -> Gen (f p)
gaSum opts
z Int
i Weights_ f
a)
| Bool
otherwise = (g p -> (:+:) f g p) -> Gen (g p) -> Gen ((:+:) f g p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap g p -> (:+:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (opts -> Int -> Weights_ g -> Gen (g p)
forall opts (f :: * -> *) p.
GASum opts f =>
opts -> Int -> Weights_ f -> Gen (f p)
gaSum opts
z (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n) Weights_ g
b)
{-# INLINE gaSum #-}
instance GAProduct (SizingOf opts) (Name c) opts f => GASum opts (M1 C c f) where
gaSum :: opts -> Int -> Weights_ (M1 C c f) -> Gen (M1 C c f p)
gaSum z :: opts
z _ _ = (f p -> M1 C c f p) -> Gen (f p) -> Gen (M1 C c f p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f p -> M1 C c f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Proxy '(SizingOf opts, Name c) -> opts -> Gen (f p)
forall k (s :: Sizing) (c :: Maybe Symbol) opts (f :: k -> *)
(proxys :: (Sizing, Maybe Symbol) -> *) (p :: k).
GAProduct s c opts f =>
proxys '(s, c) -> opts -> Gen (f p)
gaProduct (Proxy '(SizingOf opts, Name c)
forall k (t :: k). Proxy t
Proxy :: Proxy '(SizingOf opts, Name c)) opts
z)
{-# INLINE gaSum #-}
class GAProduct (s :: Sizing) (c :: Maybe Symbol) opts f where
gaProduct :: proxys '(s, c) -> opts -> Gen (f p)
instance GAProduct' c 0 opts f => GAProduct 'Unsized c opts f where
gaProduct :: proxys '( 'Unsized, c) -> opts -> Gen (f p)
gaProduct _ = Proxy '(c, 0) -> opts -> Gen (f p)
forall k (c :: Maybe Symbol) (i :: Nat) opts (f :: k -> *)
(proxy :: (Maybe Symbol, Nat) -> *) (p :: k).
GAProduct' c i opts f =>
proxy '(c, i) -> opts -> Gen (f p)
gaProduct' (Proxy '(c, 0)
forall k (t :: k). Proxy t
Proxy :: Proxy '(c, 0))
{-# INLINE gaProduct #-}
instance {-# OVERLAPPING #-} GAProduct' c 0 opts (S1 d f)
=> GAProduct 'Sized c opts (S1 d f) where
gaProduct :: proxys '( 'Sized, c) -> opts -> Gen (S1 d f p)
gaProduct _ = (Int -> Int) -> Gen (S1 d f p) -> Gen (S1 d f p)
forall a. (Int -> Int) -> Gen a -> Gen a
scale (\n :: Int
n -> Int -> Int -> Int
forall a. Ord a => a -> a -> a
max 0 (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-1)) (Gen (S1 d f p) -> Gen (S1 d f p))
-> (opts -> Gen (S1 d f p)) -> opts -> Gen (S1 d f p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy '(c, 0) -> opts -> Gen (S1 d f p)
forall k (c :: Maybe Symbol) (i :: Nat) opts (f :: k -> *)
(proxy :: (Maybe Symbol, Nat) -> *) (p :: k).
GAProduct' c i opts f =>
proxy '(c, i) -> opts -> Gen (f p)
gaProduct' (Proxy '(c, 0)
forall k (t :: k). Proxy t
Proxy :: Proxy '(c, 0))
instance (GAProduct' c 0 opts f, KnownNat (Arity f)) => GAProduct 'Sized c opts f where
gaProduct :: proxys '( 'Sized, c) -> opts -> Gen (f p)
gaProduct _ = (Int -> Int) -> Gen (f p) -> Gen (f p)
forall a. (Int -> Int) -> Gen a -> Gen a
scale (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
arity) (Gen (f p) -> Gen (f p))
-> (opts -> Gen (f p)) -> opts -> Gen (f p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy '(c, 0) -> opts -> Gen (f p)
forall k (c :: Maybe Symbol) (i :: Nat) opts (f :: k -> *)
(proxy :: (Maybe Symbol, Nat) -> *) (p :: k).
GAProduct' c i opts f =>
proxy '(c, i) -> opts -> Gen (f p)
gaProduct' (Proxy '(c, 0)
forall k (t :: k). Proxy t
Proxy :: Proxy '(c, 0))
where
arity :: Int
arity = Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Proxy (Arity f) -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (Proxy (Arity f)
forall k (t :: k). Proxy t
Proxy :: Proxy (Arity f)))
{-# INLINE gaProduct #-}
instance {-# OVERLAPPING #-} GAProduct 'Sized c opts U1 where
gaProduct :: proxys '( 'Sized, c) -> opts -> Gen (U1 p)
gaProduct _ _ = U1 p -> Gen (U1 p)
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 p
forall k (p :: k). U1 p
U1
{-# INLINE gaProduct #-}
class GAProduct' (c :: Maybe Symbol) (i :: Nat) opts f where
gaProduct' :: proxy '(c, i) -> opts -> Gen (f p)
instance GAProduct' c i opts U1 where
gaProduct' :: proxy '(c, i) -> opts -> Gen (U1 p)
gaProduct' _ _ = U1 p -> Gen (U1 p)
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 p
forall k (p :: k). U1 p
U1
{-# INLINE gaProduct' #-}
instance
( HasGenerators opts
, ArbitraryOr gs () gs '(c, i, Name d) a
, gs ~ GeneratorsOf opts )
=> GAProduct' c i opts (S1 d (K1 _k a)) where
gaProduct' :: proxy '(c, i) -> opts -> Gen (S1 d (K1 _k a) p)
gaProduct' _ opts :: opts
opts = (a -> S1 d (K1 _k a) p) -> Gen a -> Gen (S1 d (K1 _k a) p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (K1 _k a p -> S1 d (K1 _k a) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (K1 _k a p -> S1 d (K1 _k a) p)
-> (a -> K1 _k a p) -> a -> S1 d (K1 _k a) p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> K1 _k a p
forall k i c (p :: k). c -> K1 i c p
K1) (Proxy '(c, i, Name d) -> gs -> () -> gs -> Gen a
forall fullGenList g gs (sel :: (Maybe Symbol, Nat, Maybe Symbol))
a (proxy :: (Maybe Symbol, Nat, Maybe Symbol) -> *).
ArbitraryOr fullGenList g gs sel a =>
proxy sel -> fullGenList -> g -> gs -> Gen a
arbitraryOr Proxy '(c, i, Name d)
sel gs
GeneratorsOf opts
gs () gs
GeneratorsOf opts
gs)
where
sel :: Proxy '(c, i, Name d)
sel = Proxy '(c, i, Name d)
forall k (t :: k). Proxy t
Proxy :: Proxy '(c, i, Name d)
gs :: GeneratorsOf opts
gs = opts -> GeneratorsOf opts
forall opts. HasGenerators opts => opts -> GeneratorsOf opts
generators opts
opts
{-# INLINE gaProduct' #-}
instance (GAProduct' c i opts f, GAProduct' c (i + Arity f) opts g) => GAProduct' c i opts (f :*: g) where
gaProduct' :: proxy '(c, i) -> opts -> Gen ((:*:) f g p)
gaProduct' px :: proxy '(c, i)
px = ((Gen (f p) -> Gen (g p) -> Gen ((:*:) f g p))
-> (opts -> Gen (f p))
-> (opts -> Gen (g p))
-> opts
-> Gen ((:*:) f g p)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 ((Gen (f p) -> Gen (g p) -> Gen ((:*:) f g p))
-> (opts -> Gen (f p))
-> (opts -> Gen (g p))
-> opts
-> Gen ((:*:) f g p))
-> ((f p -> g p -> (:*:) f g p)
-> Gen (f p) -> Gen (g p) -> Gen ((:*:) f g p))
-> (f p -> g p -> (:*:) f g p)
-> (opts -> Gen (f p))
-> (opts -> Gen (g p))
-> opts
-> Gen ((:*:) f g p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f p -> g p -> (:*:) f g p)
-> Gen (f p) -> Gen (g p) -> Gen ((:*:) f g p)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2) f p -> g p -> (:*:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:)
(proxy '(c, i) -> opts -> Gen (f p)
forall k (c :: Maybe Symbol) (i :: Nat) opts (f :: k -> *)
(proxy :: (Maybe Symbol, Nat) -> *) (p :: k).
GAProduct' c i opts f =>
proxy '(c, i) -> opts -> Gen (f p)
gaProduct' proxy '(c, i)
px)
(Proxy '(c, i + Arity f) -> opts -> Gen (g p)
forall k (c :: Maybe Symbol) (i :: Nat) opts (f :: k -> *)
(proxy :: (Maybe Symbol, Nat) -> *) (p :: k).
GAProduct' c i opts f =>
proxy '(c, i) -> opts -> Gen (f p)
gaProduct' (Proxy '(c, i + Arity f)
forall k (t :: k). Proxy t
Proxy :: Proxy '(c, i + Arity f)))
{-# INLINE gaProduct' #-}
type family Arity f :: Nat where
Arity (f :*: g) = Arity f + Arity g
Arity (M1 _i _c _f) = 1
class ArbitraryOr (fullGenList :: Type) (g :: Type) (gs :: Type)
(sel :: (Maybe Symbol, Nat, Maybe Symbol)) a where
arbitraryOr :: proxy sel -> fullGenList -> g -> gs -> Gen a
instance Arbitrary a => ArbitraryOr fg () () sel a where
arbitraryOr :: proxy sel -> fg -> () -> () -> Gen a
arbitraryOr _ _ _ _ = Gen a
forall a. Arbitrary a => Gen a
arbitrary
{-# INLINE arbitraryOr #-}
instance ArbitraryOr fg b g sel a => ArbitraryOr fg () (b :+ g) sel a where
arbitraryOr :: proxy sel -> fg -> () -> (b :+ g) -> Gen a
arbitraryOr sel :: proxy sel
sel fg :: fg
fg () (b :: b
b :+ gens :: g
gens) = proxy sel -> fg -> b -> g -> Gen a
forall fullGenList g gs (sel :: (Maybe Symbol, Nat, Maybe Symbol))
a (proxy :: (Maybe Symbol, Nat, Maybe Symbol) -> *).
ArbitraryOr fullGenList g gs sel a =>
proxy sel -> fullGenList -> g -> gs -> Gen a
arbitraryOr proxy sel
sel fg
fg b
b g
gens
{-# INLINE arbitraryOr #-}
instance {-# OVERLAPS #-} ArbitraryOr fg g () sel a => ArbitraryOr fg () g sel a where
arbitraryOr :: proxy sel -> fg -> () -> g -> Gen a
arbitraryOr sel :: proxy sel
sel fg :: fg
fg () g :: g
g = proxy sel -> fg -> g -> () -> Gen a
forall fullGenList g gs (sel :: (Maybe Symbol, Nat, Maybe Symbol))
a (proxy :: (Maybe Symbol, Nat, Maybe Symbol) -> *).
ArbitraryOr fullGenList g gs sel a =>
proxy sel -> fullGenList -> g -> gs -> Gen a
arbitraryOr proxy sel
sel fg
fg g
g ()
instance ArbitraryOr fg g (h :+ gs) sel a => ArbitraryOr fg (g :+ h) gs sel a where
arbitraryOr :: proxy sel -> fg -> (g :+ h) -> gs -> Gen a
arbitraryOr sel :: proxy sel
sel fg :: fg
fg (g :: g
g :+ h :: h
h) gs :: gs
gs = proxy sel -> fg -> g -> (h :+ gs) -> Gen a
forall fullGenList g gs (sel :: (Maybe Symbol, Nat, Maybe Symbol))
a (proxy :: (Maybe Symbol, Nat, Maybe Symbol) -> *).
ArbitraryOr fullGenList g gs sel a =>
proxy sel -> fullGenList -> g -> gs -> Gen a
arbitraryOr proxy sel
sel fg
fg g
g (h
h h -> gs -> h :+ gs
forall a b. a -> b -> a :+ b
:+ gs
gs)
instance {-# OVERLAPPABLE #-} ArbitraryOr fg () gs sel a => ArbitraryOr fg g gs sel a where
arbitraryOr :: proxy sel -> fg -> g -> gs -> Gen a
arbitraryOr sel :: proxy sel
sel fg :: fg
fg _ = proxy sel -> fg -> () -> gs -> Gen a
forall fullGenList g gs (sel :: (Maybe Symbol, Nat, Maybe Symbol))
a (proxy :: (Maybe Symbol, Nat, Maybe Symbol) -> *).
ArbitraryOr fullGenList g gs sel a =>
proxy sel -> fullGenList -> g -> gs -> Gen a
arbitraryOr proxy sel
sel fg
fg ()
instance {-# INCOHERENT #-} ArbitraryOr fg (Gen a) g sel a where
arbitraryOr :: proxy sel -> fg -> Gen a -> g -> Gen a
arbitraryOr _ _ gen :: Gen a
gen _ = Gen a
gen
{-# INLINE arbitraryOr #-}
#if __GLASGOW_HASKELL__ >= 800
instance {-# INCOHERENT #-} (a ~ a') => ArbitraryOr fg (FieldGen s a) g '(con, i, 'Just s) a' where
arbitraryOr :: proxy '(con, i, 'Just s) -> fg -> FieldGen s a -> g -> Gen a'
arbitraryOr _ _ (FieldGen gen :: Gen a
gen) _ = Gen a
Gen a'
gen
{-# INLINE arbitraryOr #-}
instance {-# INCOHERENT #-} (a ~ a') => ArbitraryOr fg (ConstrGen c i a) g '( 'Just c, i, s) a' where
arbitraryOr :: proxy '( 'Just c, i, s) -> fg -> ConstrGen c i a -> g -> Gen a'
arbitraryOr _ _ (ConstrGen gen :: Gen a
gen) _ = Gen a
Gen a'
gen
{-# INLINE arbitraryOr #-}
type family Name (d :: Meta) :: Maybe Symbol
type instance Name ('MetaSel mn su ss ds) = mn
type instance Name ('MetaCons n _f _s) = 'Just n
#else
type Name d = (Nothing :: Maybe Symbol)
#endif
instance {-# INCOHERENT #-} ArbitraryOr fg (Gen1_ f) g sel (f a) where
arbitraryOr :: proxy sel -> fg -> Gen1_ f -> g -> Gen (f a)
arbitraryOr _ _ (Gen1_ gen :: forall (a :: k). Gen (f a)
gen) _ = Gen (f a)
forall (a :: k). Gen (f a)
gen
instance {-# INCOHERENT #-} ArbitraryOr fg () fg '( 'Nothing, 0, 'Nothing) a
=> ArbitraryOr fg (Gen1 f) g sel (f a) where
arbitraryOr :: proxy sel -> fg -> Gen1 f -> g -> Gen (f a)
arbitraryOr _ fg :: fg
fg (Gen1 gen :: forall a. Gen a -> Gen (f a)
gen) _ = Gen a -> Gen (f a)
forall a. Gen a -> Gen (f a)
gen (Proxy '( 'Nothing, 0, 'Nothing) -> fg -> () -> fg -> Gen a
forall fullGenList g gs (sel :: (Maybe Symbol, Nat, Maybe Symbol))
a (proxy :: (Maybe Symbol, Nat, Maybe Symbol) -> *).
ArbitraryOr fullGenList g gs sel a =>
proxy sel -> fullGenList -> g -> gs -> Gen a
arbitraryOr Proxy '( 'Nothing, 0, 'Nothing)
forall a a. Proxy '( 'Nothing, 0, 'Nothing)
noSel fg
fg () fg
fg)
where noSel :: Proxy '( 'Nothing, 0, 'Nothing)
noSel = forall k (t :: k). Proxy t
forall a a. Proxy '( 'Nothing, 0, 'Nothing)
Proxy :: Proxy '( 'Nothing, 0, 'Nothing)
newtype Weighted a = Weighted (Maybe (Int -> Gen a, Int))
deriving a -> Weighted b -> Weighted a
(a -> b) -> Weighted a -> Weighted b
(forall a b. (a -> b) -> Weighted a -> Weighted b)
-> (forall a b. a -> Weighted b -> Weighted a) -> Functor Weighted
forall a b. a -> Weighted b -> Weighted a
forall a b. (a -> b) -> Weighted a -> Weighted b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Weighted b -> Weighted a
$c<$ :: forall a b. a -> Weighted b -> Weighted a
fmap :: (a -> b) -> Weighted a -> Weighted b
$cfmap :: forall a b. (a -> b) -> Weighted a -> Weighted b
Functor
instance Applicative Weighted where
pure :: a -> Weighted a
pure a :: a
a = Maybe (Int -> Gen a, Int) -> Weighted a
forall a. Maybe (Int -> Gen a, Int) -> Weighted a
Weighted ((Int -> Gen a, Int) -> Maybe (Int -> Gen a, Int)
forall a. a -> Maybe a
Just ((Gen a -> Int -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Gen a -> Int -> Gen a) -> (a -> Gen a) -> a -> Int -> Gen a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure) a
a, 1))
Weighted f :: Maybe (Int -> Gen (a -> b), Int)
f <*> :: Weighted (a -> b) -> Weighted a -> Weighted b
<*> Weighted a :: Maybe (Int -> Gen a, Int)
a = Maybe (Int -> Gen b, Int) -> Weighted b
forall a. Maybe (Int -> Gen a, Int) -> Weighted a
Weighted (Maybe (Int -> Gen b, Int) -> Weighted b)
-> Maybe (Int -> Gen b, Int) -> Weighted b
forall a b. (a -> b) -> a -> b
$ ((Int -> Gen (a -> b), Int)
-> (Int -> Gen a, Int) -> (Int -> Gen b, Int))
-> Maybe (Int -> Gen (a -> b), Int)
-> Maybe (Int -> Gen a, Int)
-> Maybe (Int -> Gen b, Int)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (Int -> Gen (a -> b), Int)
-> (Int -> Gen a, Int) -> (Int -> Gen b, Int)
forall b (f :: * -> *) a b.
(Integral b, Applicative f) =>
(b -> f (a -> b), b) -> (b -> f a, b) -> (b -> f b, b)
g Maybe (Int -> Gen (a -> b), Int)
f Maybe (Int -> Gen a, Int)
a
where
g :: (b -> f (a -> b), b) -> (b -> f a, b) -> (b -> f b, b)
g (f1 :: b -> f (a -> b)
f1, m :: b
m) (a1 :: b -> f a
a1, n :: b
n) =
( \i :: b
i ->
let (j :: b
j, k :: b
k) = b
i b -> b -> (b, b)
forall a. Integral a => a -> a -> (a, a)
`divMod` b
m
in b -> f (a -> b)
f1 b
j f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> b -> f a
a1 b
k
, b
m b -> b -> b
forall a. Num a => a -> a -> a
* b
n )
instance Alternative Weighted where
empty :: Weighted a
empty = Maybe (Int -> Gen a, Int) -> Weighted a
forall a. Maybe (Int -> Gen a, Int) -> Weighted a
Weighted Maybe (Int -> Gen a, Int)
forall a. Maybe a
Nothing
a :: Weighted a
a <|> :: Weighted a -> Weighted a -> Weighted a
<|> Weighted Nothing = Weighted a
a
Weighted Nothing <|> b :: Weighted a
b = Weighted a
b
Weighted (Just (a :: Int -> Gen a
a, m :: Int
m)) <|> Weighted (Just (b :: Int -> Gen a
b, n :: Int
n)) = Maybe (Int -> Gen a, Int) -> Weighted a
forall a. Maybe (Int -> Gen a, Int) -> Weighted a
Weighted (Maybe (Int -> Gen a, Int) -> Weighted a)
-> ((Int -> Gen a, Int) -> Maybe (Int -> Gen a, Int))
-> (Int -> Gen a, Int)
-> Weighted a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Gen a, Int) -> Maybe (Int -> Gen a, Int)
forall a. a -> Maybe a
Just ((Int -> Gen a, Int) -> Weighted a)
-> (Int -> Gen a, Int) -> Weighted a
forall a b. (a -> b) -> a -> b
$
( \i :: Int
i ->
if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
m then
Int -> Gen a
a Int
i
else
Int -> Gen a
b (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
m)
, Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n )
liftGen :: Gen a -> Weighted a
liftGen :: Gen a -> Weighted a
liftGen g :: Gen a
g = Maybe (Int -> Gen a, Int) -> Weighted a
forall a. Maybe (Int -> Gen a, Int) -> Weighted a
Weighted ((Int -> Gen a, Int) -> Maybe (Int -> Gen a, Int)
forall a. a -> Maybe a
Just (\_ -> Gen a
g, 1))