{-# OPTIONS_HADDOCK not-home #-}

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Core implementation.
--
-- === Warning
--
-- This is an internal module: it is not subject to any versioning policy,
-- breaking changes can happen at any time.
--
-- If something here seems useful, please report it or create a pull request to
-- export it from an external module.

module Generic.Random.Internal.Generic where

import Control.Applicative (Alternative(..), liftA2)
import Data.Coerce (Coercible, coerce)
import Data.Kind (Type)

import Data.Proxy (Proxy(..))
import Data.Type.Bool (type (&&))
import Data.Type.Equality (type (==))

import GHC.Generics hiding (S, prec)
import GHC.TypeLits (KnownNat, Nat, Symbol, type (+), natVal)
import Test.QuickCheck (Arbitrary(..), Gen, choose, scale, sized, vectorOf)

-- * Random generators

-- | Pick a constructor with a given distribution, and fill its fields
-- with recursive calls to 'arbitrary'.
--
-- === Example
--
-- > genericArbitrary (2 % 3 % 5 % ()) :: Gen a
--
-- Picks the first constructor with probability @2/10@,
-- the second with probability @3/10@, the third with probability @5/10@.
genericArbitrary
  :: (GArbitrary UnsizedOpts a)
  => Weights a  -- ^ List of weights for every constructor
  -> 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

-- | Pick every constructor with equal probability.
-- Equivalent to @'genericArbitrary' 'uniform'@.
--
-- > genericArbitraryU :: Gen a
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

-- | 'arbitrary' for types with one constructor.
-- Equivalent to 'genericArbitraryU', with a stricter type.
--
-- > genericArbitrarySingle :: Gen a
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

-- | Decrease size at every recursive call, but don't do anything different
-- at size 0.
--
-- > genericArbitraryRec (7 % 11 % 13 % ()) :: Gen a
--
-- N.B.: This replaces the generator for fields of type @[t]@ with
-- @'listOf'' arbitrary@ instead of @'Test.QuickCheck.listOf' arbitrary@ (i.e., @arbitrary@ for
-- lists).
genericArbitraryRec
  :: (GArbitrary SizedOptsDef a)
  => Weights a  -- ^ List of weights for every constructor
  -> 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

-- | 'genericArbitrary' with explicit generators.
--
-- === Example
--
-- > genericArbitraryG customGens (17 % 19 % ())
--
-- where, the generators for 'String' and 'Int' fields are overridden as
-- follows, for example:
--
-- @
-- customGens :: Gen String ':+' Gen Int
-- customGens =
--   (filter (/= '\NUL') '<$>' arbitrary) ':+'
--   (getNonNegative '<$>' arbitrary)
-- @
--
-- === Note on multiple matches
--
-- Multiple generators may match a given field: the first will be chosen.
genericArbitraryG
  :: (GArbitrary (SetGens genList UnsizedOpts) a)
  => genList
  -> Weights a
  -> Gen a
genericArbitraryG :: genList -> Weights a -> Gen a
genericArbitraryG genList
gs = Options 'INCOHERENT 'Unsized genList -> Weights a -> Gen a
forall opts a. GArbitrary opts a => opts -> Weights a -> Gen a
genericArbitraryWith Options 'INCOHERENT 'Unsized genList
opts
  where
    opts :: Options 'INCOHERENT 'Unsized genList
opts = genList -> UnsizedOpts -> Options 'INCOHERENT 'Unsized genList
forall genList (c :: Coherence) (s :: Sizing) g0.
genList -> Options c s g0 -> Options c s genList
setGenerators genList
gs UnsizedOpts
unsizedOpts

-- | 'genericArbitraryU' with explicit generators.
-- See also 'genericArbitraryG'.
genericArbitraryUG
  :: (GArbitrary (SetGens genList UnsizedOpts) a, GUniformWeight a)
  => genList
  -> Gen a
genericArbitraryUG :: genList -> Gen a
genericArbitraryUG 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

-- | 'genericArbitrarySingle' with explicit generators.
-- See also 'genericArbitraryG'.
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

-- | 'genericArbitraryRec' with explicit generators.
-- See also 'genericArbitraryG'.
genericArbitraryRecG
  :: (GArbitrary (SetGens genList SizedOpts) a)
  => genList
  -> Weights a  -- ^ List of weights for every constructor
  -> Gen a
genericArbitraryRecG :: genList -> Weights a -> Gen a
genericArbitraryRecG genList
gs = Options 'INCOHERENT 'Sized genList -> Weights a -> Gen a
forall opts a. GArbitrary opts a => opts -> Weights a -> Gen a
genericArbitraryWith Options 'INCOHERENT 'Sized genList
opts
  where
    opts :: Options 'INCOHERENT 'Sized genList
opts = genList
-> Options 'INCOHERENT 'Sized ()
-> Options 'INCOHERENT 'Sized genList
forall genList (c :: Coherence) (s :: Sizing) g0.
genList -> Options c s g0 -> Options c s genList
setGenerators genList
gs Options 'INCOHERENT 'Sized ()
sizedOpts

-- | General generic generator with custom options.
genericArbitraryWith
  :: (GArbitrary opts a)
  => opts -> Weights a -> Gen a
genericArbitraryWith :: opts -> Weights a -> Gen a
genericArbitraryWith opts
opts (Weights Weights_ (Rep a)
w 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)

-- * Internal

type family Weights_ (f :: Type -> Type) :: Type where
  Weights_ (f :+: g) = Weights_ f :| Weights_ g
  Weights_ (M1 D _c f) = Weights_ f
  Weights_ (M1 C ('MetaCons c _i _j) _f) = L c

data a :| b = N a Int b
data L (c :: Symbol) = L

-- | Trees of weights assigned to constructors of type @a@,
-- rescaled to obtain a probability distribution.
--
-- Two ways of constructing them.
--
-- @
-- (x1 '%' x2 '%' ... '%' xn '%' ()) :: 'Weights' a
-- 'uniform' :: 'Weights' a
-- @
--
-- Using @('%')@, there must be exactly as many weights as
-- there are constructors.
--
-- 'uniform' is equivalent to @(1 '%' ... '%' 1 '%' ())@
-- (automatically fills out the right number of 1s).
data Weights a = Weights (Weights_ (Rep a)) Int

-- | Type of a single weight, tagged with the name of the associated
-- constructor for additional compile-time checking.
--
-- @
-- ((9 :: 'W' \"Leaf\") '%' (8 :: 'W' \"Node\") '%' ())
-- @
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

-- | A smart constructor to specify a custom distribution.
-- It can be omitted for the '%' operator is overloaded to
-- insert it.
weights :: (Weights_ (Rep a), Int, ()) -> Weights a
weights :: (Weights_ (Rep a), Int, ()) -> Weights a
weights (Weights_ (Rep a)
w, Int
n, ()) = Weights_ (Rep a) -> Int -> Weights a
forall a. Weights_ (Rep a) -> Int -> Weights a
Weights Weights_ (Rep a)
w Int
n

-- | Uniform distribution.
uniform :: UniformWeight_ (Rep a) => Weights a
uniform :: Weights a
uniform =
  let (Weights_ (Rep a)
w, 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

class WeightBuilder' w where

  -- | A binary constructor for building up trees of weights.
  (%) :: (c ~ First' w) => W c -> Prec' w -> w

instance WeightBuilder (Weights_ (Rep a)) => WeightBuilder' (Weights a) where
  W c
w % :: W c -> Prec' (Weights a) -> Weights a
% 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)
  W c
m %. :: W c -> Prec (a :| b) r -> (a :| b, Int, r)
%. Prec (a :| b) r
prec =
    let (a
a, Int
n, (b
b, Int
p, 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 Int
m %. :: W c -> Prec (L c) r -> (L c, Int, r)
%. 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 Int
m %. :: W c -> Prec () r -> ((), Int, r)
%. 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, Int
m) = (a, Int)
forall a. UniformWeight a => (a, Int)
uniformWeight
      (b
b, 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, Int
1)

instance UniformWeight () where
  uniformWeight :: ((), Int)
uniformWeight = ((), Int
1)

class UniformWeight (Weights_ f) => UniformWeight_ f
instance UniformWeight (Weights_ f) => UniformWeight_ f

-- | Derived uniform distribution of constructors for @a@.
class UniformWeight_ (Rep a) => GUniformWeight a
instance UniformWeight_ (Rep a) => GUniformWeight a


-- | Type-level options for 'GArbitrary'.
--
-- Note: it is recommended to avoid referring to the 'Options' type
-- explicitly in code, as the set of options may change in the future.
-- Instead, use the provided synonyms ('UnsizedOpts', 'SizedOpts', 'SizedOptsDef')
-- and the setter 'SetOptions' (abbreviated as @('<+')@).
newtype Options (c :: Coherence) (s :: Sizing) (genList :: Type) = Options
  { Options c s genList -> genList
_generators :: genList
  }

-- | Setter for 'Options'.
--
-- This subsumes the other setters: 'SetSized', 'SetUnsized', 'SetGens'.
--
-- @since 1.4.0.0
type family SetOptions (x :: k) (o :: Type) :: Type
type instance SetOptions (s :: Sizing) (Options c _s g) = Options c s g
type instance SetOptions (c :: Coherence) (Options _c s g) = Options c s g
type instance SetOptions (g :: Type) (Options c s _g) = Options c s g

-- | Infix flipped synonym for 'Options'.
--
-- @since 1.4.0.0
type (<+) o x = SetOptions x o
infixl 1 <+


type UnsizedOpts = Options 'INCOHERENT 'Unsized ()
type SizedOpts = Options 'INCOHERENT 'Sized ()
type SizedOptsDef = Options 'INCOHERENT 'Sized (Gen1 [] :+ ())

-- | Like 'UnsizedOpts', but using coherent instances by default.
--
-- @since 1.4.0.0
type CohUnsizedOpts = Options 'COHERENT 'Unsized ()

-- | Like 'SizedOpts', but using coherent instances by default.
--
-- @since 1.4.0.0
type CohSizedOpts = Options 'COHERENT 'Sized ()

-- | Coerce an 'Options' value between types with the same representation.
--
-- @since 1.4.0.0
setOpts :: forall x o. (Coercible o (SetOptions x o)) => o -> SetOptions x o
setOpts :: o -> SetOptions x o
setOpts = o -> SetOptions x o
coerce

-- | Default options for unsized generators.
unsizedOpts :: UnsizedOpts
unsizedOpts :: UnsizedOpts
unsizedOpts = () -> UnsizedOpts
forall (c :: Coherence) (s :: Sizing) genList.
genList -> Options c s genList
Options ()

-- | Default options for sized generators.
sizedOpts :: SizedOpts
sizedOpts :: Options 'INCOHERENT 'Sized ()
sizedOpts = () -> Options 'INCOHERENT 'Sized ()
forall (c :: Coherence) (s :: Sizing) genList.
genList -> Options c s genList
Options ()

-- | Default options overriding the list generator using 'listOf''.
sizedOptsDef :: SizedOptsDef
sizedOptsDef :: SizedOptsDef
sizedOptsDef = (Gen1 [] :+ ()) -> SizedOptsDef
forall (c :: Coherence) (s :: Sizing) genList.
genList -> Options c 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
:+ ())

-- | Like 'unsizedOpts', but using coherent instances by default.
cohUnsizedOpts :: CohUnsizedOpts
cohUnsizedOpts :: CohUnsizedOpts
cohUnsizedOpts = () -> CohUnsizedOpts
forall (c :: Coherence) (s :: Sizing) genList.
genList -> Options c s genList
Options ()

-- | Like 'sizedOpts' but using coherent instances by default.
cohSizedOpts :: CohSizedOpts
cohSizedOpts :: CohSizedOpts
cohSizedOpts = () -> CohSizedOpts
forall (c :: Coherence) (s :: Sizing) genList.
genList -> Options c s genList
Options ()


-- | Whether to decrease the size parameter before generating fields.
--
-- The 'Sized' option makes the size parameter decrease in the following way:
-- - Constructors with one field decrease the size parameter by 1 to generate
--   that field.
-- - Constructors with more than one field split the size parameter among all
--   fields; the size parameter is rounded down to then be divided equally.
data Sizing
  = Sized     -- ^ Decrease the size parameter when running generators for fields
  | Unsized   -- ^ Don't touch the size parameter

type family SizingOf opts :: Sizing
type instance SizingOf (Options _c s _g) = s

type family SetSized (o :: Type) :: Type
type instance SetSized (Options c s g) = Options c 'Sized g

type family SetUnsized (o :: Type) :: Type
type instance SetUnsized (Options c s g) = Options c 'Unsized g

setSized :: Options c s g -> Options c 'Sized g
setSized :: Options c s g -> Options c 'Sized g
setSized = Options c s g -> Options c 'Sized g
coerce

setUnsized :: Options c s g -> Options c 'Unsized g
setUnsized :: Options c s g -> Options c 'Unsized g
setUnsized = Options c s g -> Options c 'Unsized g
coerce


-- | For custom generators to work with parameterized types, incoherent
-- instances must be used internally.
-- In practice, the resulting behavior is what users want 100% of the time,
-- so you should forget this option even exists.
--
-- === __Details__
--
-- The default configuration of generic-random does a decent job if
-- we trust GHC implements precisely the instance resolution algorithm as
-- described in the GHC manual:
--
-- - https://downloads.haskell.org/ghc/latest/docs/html/users_guide/glasgow_exts.html#overlapping-instances
--
-- While that assumption holds in practice, it is overly context-dependent
-- (to know the context leading to a particular choice, we must replay the
-- whole resolution algorithm).
-- In particular, this algorithm may find one solution, but it is not
-- guaranteed to be unique: the behavior of the program is dependent on
-- implementation details.
--
-- An notable property to consider of an implicit type system (such as type
-- classes) is coherence: the behavior of the program is stable under
-- specialization.
--
-- This sounds nice on paper, but actually leads to surprising behavior for
-- generic implementations with parameterized types, such as generic-random.
--
-- To address that, the coherence property can be relaxd by users, by
-- explicitly allowing some custom generators to be chosen incoherently. With
-- appropriate precautions, it is possible to ensure a weaker property which
-- nevertheless helps keep type inference predictable: when a solution is
-- found, it is unique.
-- (This is assuredly weaker, i.e., is not stable under specialization.)
--
-- @since 1.4.0.0
data Coherence
  = INCOHERENT  -- ^ Match custom generators incoherently.
  | COHERENT
    -- ^ Match custom generators coherently by default
    -- (can be manually bypassed with 'Incoherent').

type family CoherenceOf (o :: Type) :: Coherence
type instance CoherenceOf (Options c _s _g) = c

-- | Match this generator incoherently when the 'COHERENT' option is set.
newtype Incoherent g = Incoherent g


-- | Heterogeneous list of generators.
data a :+ b = a :+ b

infixr 1 :+


type family GeneratorsOf opts :: Type
type instance GeneratorsOf (Options _c _s g) = g

class HasGenerators opts where
  generators :: opts -> GeneratorsOf opts

instance HasGenerators (Options c s g) where
  generators :: Options c s g -> GeneratorsOf (Options c s g)
generators = Options c s g -> GeneratorsOf (Options c s g)
forall (c :: Coherence) (s :: Sizing) genList.
Options c s genList -> genList
_generators

-- | Define the set of custom generators.
--
-- Note: for recursive types which can recursively appear inside lists or other
-- containers, you may want to include a custom generator to decrease the size
-- when generating such containers.
--
-- See also the Note about lists in "Generic.Random.Tutorial#notelists".
setGenerators :: genList -> Options c s g0 -> Options c s genList
setGenerators :: genList -> Options c s g0 -> Options c s genList
setGenerators genList
gens (Options g0
_) = genList -> Options c s genList
forall (c :: Coherence) (s :: Sizing) genList.
genList -> Options c s genList
Options genList
gens

type family SetGens (g :: Type) opts
type instance SetGens g (Options c s _g) = Options c s g


-- | Custom generator for record fields named @s@.
--
-- If there is a field named @s@ with a different type,
-- this will result in a type error.
newtype FieldGen (s :: Symbol) a = FieldGen { FieldGen s a -> Gen a
unFieldGen :: Gen a }

-- | 'FieldGen' constructor with the field name given via a proxy.
fieldGen :: proxy s -> Gen a -> FieldGen s a
fieldGen :: proxy s -> Gen a -> FieldGen s a
fieldGen proxy s
_ = Gen a -> FieldGen s a
forall (s :: Symbol) a. Gen a -> FieldGen s a
FieldGen

-- | Custom generator for the @i@-th field of the constructor named @c@.
-- Fields are 0-indexed.
newtype ConstrGen (c :: Symbol) (i :: Nat) a = ConstrGen { ConstrGen c i a -> Gen a
unConstrGen :: Gen a }

-- | 'ConstrGen' constructor with the constructor name given via a proxy.
constrGen :: proxy '(c, i) -> Gen a -> ConstrGen c i a
constrGen :: proxy '(c, i) -> Gen a -> ConstrGen c i a
constrGen proxy '(c, i)
_ = Gen a -> ConstrGen c i a
forall (c :: Symbol) (i :: Nat) a. Gen a -> ConstrGen c i a
ConstrGen

-- | Custom generators for \"containers\" of kind @Type -> Type@, parameterized
-- by the generator for \"contained elements\".
--
-- A custom generator @'Gen1' f@ will be used for any field whose type has the
-- form @f x@, requiring a generator of @x@. The generator for @x@ will be
-- constructed using the list of custom generators if possible, otherwise
-- an instance @Arbitrary x@ will be required.
newtype Gen1 f = Gen1 { Gen1 f -> forall a. Gen a -> Gen (f a)
unGen1 :: forall a. Gen a -> Gen (f a) }

-- | Custom generators for unary type constructors that are not \"containers\",
-- i.e., which don't require a generator of @a@ to generate an @f a@.
--
-- A custom generator @'Gen1_' f@ will be used for any field whose type has the
-- form @f x@.
newtype Gen1_ f = Gen1_ { Gen1_ f -> forall (a :: k). Gen (f a)
unGen1_ :: forall a. Gen (f a) }


-- | An alternative to 'vectorOf' that divides the size parameter by the
-- length of the list.
vectorOf' :: Int -> Gen a -> Gen [a]
vectorOf' :: Int -> Gen a -> Gen [a]
vectorOf' Int
0 = \Gen a
_ -> [a] -> Gen [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
vectorOf' 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

-- | An alternative to 'Test.QuickCheck.listOf' that divides the size parameter
-- by the length of the list.
-- The length follows a geometric distribution of parameter
-- @1/(sqrt size + 1)@.
listOf' :: Gen a -> Gen [a]
listOf' :: Gen a -> Gen [a]
listOf' 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
$ \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

-- | An alternative to 'Test.QuickCheck.listOf1' (nonempty lists) that divides
-- the size parameter by the length of the list.
-- The length (minus one) follows a geometric distribution of parameter
-- @1/(sqrt size + 1)@.
listOf1' :: Gen a -> Gen [a]
listOf1' :: Gen a -> Gen [a]
listOf1' 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)

-- | Geometric distribution of parameter @1/(sqrt n + 1)@ (@n >= 0@).
geom :: Int -> Gen Int
geom :: Int -> Gen Int
geom Int
0 = Int -> Gen Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
0
geom Int
n = Int -> Gen Int
go Int
0 where
  n' :: Double
n' = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n
  p :: Double
p = Double
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
+ Double
1) :: Double
  go :: Int -> Gen Int
go Int
r = do
    Double
x <- (Double, Double) -> Gen Double
forall a. Random a => (a, a) -> Gen a
choose (Double
0, Double
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
+ Int
1)

---

-- | Generic Arbitrary
class GA opts f where
  ga :: opts -> Weights_ f -> Int -> Gen (f p)

-- | Generic Arbitrary
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 opts
z Weights_ (M1 D c f)
w 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 opts
z Weights_ (M1 C c f)
_ Int
_ = (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' opts
z Weights_ f
w Int
n = do
  Int
i <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
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 opts
z 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 opts
z Int
_ Weights_ (M1 C c f)
_ = (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 proxys '( 'Unsized, 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))
  {-# INLINE gaProduct #-}

-- Single-field constructors: decrease size by 1.
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 proxys '( 'Sized, c)
_ = (Int -> Int) -> Gen (S1 d f p) -> Gen (S1 d f p)
forall a. (Int -> Int) -> Gen a -> Gen a
scale (\Int
n -> Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
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 proxys '( 'Sized, c)
_ = (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 proxys '( 'Sized, c)
_ opts
_ = 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' proxy '(c, i)
_ opts
_ = 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
  , FindGen 'Shift ('S gs coh '(c, i, Name d)) () gs a
  , gs ~ GeneratorsOf opts
  , coh ~ CoherenceOf opts )
  => GAProduct' c i opts (S1 d (K1 _k a)) where
  gaProduct' :: proxy '(c, i) -> opts -> Gen (S1 d (K1 _k a) p)
gaProduct' proxy '(c, i)
_ 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 'Shift, Proxy ('S gs coh '(c, i, Name d)),
 FullGenListOf ('S gs coh '(c, i, Name d)))
-> () -> gs -> Gen a
forall (i :: AInstr) (s :: AStore) g gs a.
FindGen i s g gs a =>
(Proxy i, Proxy s, FullGenListOf s) -> g -> gs -> Gen a
findGen (Proxy 'Shift
is, Proxy ('S gs coh '(c, i, Name d))
s, FullGenListOf ('S gs coh '(c, i, Name d))
GeneratorsOf opts
gs) () gs
GeneratorsOf opts
gs)
    where
      is :: Proxy 'Shift
is = Proxy 'Shift
forall k (t :: k). Proxy t
Proxy :: Proxy 'Shift
      s :: Proxy ('S gs coh '(c, i, Name d))
s = Proxy ('S gs coh '(c, i, Name d))
forall k (t :: k). Proxy t
Proxy :: Proxy ('S gs coh '(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
  -- TODO: Why does this inline better than eta-reducing? (GHC-8.2)
  gaProduct' :: proxy '(c, i) -> opts -> Gen ((:*:) f g p)
gaProduct' 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

-- | Given a list of custom generators @g :+ gs@, find one that applies,
-- or use @Arbitrary a@ by default.
--
-- @g@ and @gs@ follow this little state machine:
--
-- >           g,      gs | result
-- > ---------------------+-----------------------------
-- >          (),      () | END
-- >          (), g :+ gs | g, gs
-- >          (),      g  | g, () when g is not (_ :+ _)
-- >      g :+ h,      gs | g, h :+ gs
-- >       Gen a,      gs | END if g matches, else ((), gs)
-- >  FieldGen a,      gs | idem
-- > ConstrGen a,      gs | idem
-- >      Gen1 a,      gs | idem
-- >     Gen1_ a,      gs | idem
class FindGen (i :: AInstr) (s :: AStore) (g :: Type) (gs :: Type) (a :: Type) where
  findGen :: (Proxy i, Proxy s, FullGenListOf s) -> g -> gs -> Gen a

data AInstr = Shift | Match Coherence | MatchCoh Bool
data AStore = S Type Coherence ASel

type ASel = (Maybe Symbol, Nat, Maybe Symbol)

iShift :: Proxy 'Shift
iShift :: Proxy 'Shift
iShift = Proxy 'Shift
forall k (t :: k). Proxy t
Proxy

type family FullGenListOf (s :: AStore) :: Type where
  FullGenListOf ('S fg _coh _sel) = fg

type family ACoherenceOf (s :: AStore) :: Coherence where
  ACoherenceOf ('S _fg coh _sel) = coh

type family ASelOf (s :: AStore) :: ASel where
  ASelOf ('S _fg _coh sel) = sel

-- | All candidates have been exhausted
instance Arbitrary a => FindGen 'Shift s () () a where
  findGen :: (Proxy 'Shift, Proxy s, FullGenListOf s) -> () -> () -> Gen a
findGen (Proxy 'Shift, Proxy s, FullGenListOf s)
_ ()
_ ()
_ = Gen a
forall a. Arbitrary a => Gen a
arbitrary
  {-# INLINEABLE findGen #-}

-- | Examine the next candidate
instance FindGen 'Shift s b g a => FindGen 'Shift s () (b :+ g) a where
  findGen :: (Proxy 'Shift, Proxy s, FullGenListOf s) -> () -> (b :+ g) -> Gen a
findGen (Proxy 'Shift, Proxy s, FullGenListOf s)
p () (b
b :+ g
gens) = (Proxy 'Shift, Proxy s, FullGenListOf s) -> b -> g -> Gen a
forall (i :: AInstr) (s :: AStore) g gs a.
FindGen i s g gs a =>
(Proxy i, Proxy s, FullGenListOf s) -> g -> gs -> Gen a
findGen (Proxy 'Shift, Proxy s, FullGenListOf s)
p b
b g
gens
  {-# INLINEABLE findGen #-}

-- | Examine the last candidate (@g@ is not of the form @_ :+ _@)
instance {-# OVERLAPS #-} FindGen 'Shift s g () a => FindGen 'Shift s () g a where
  findGen :: (Proxy 'Shift, Proxy s, FullGenListOf s) -> () -> g -> Gen a
findGen (Proxy 'Shift, Proxy s, FullGenListOf s)
p () g
g = (Proxy 'Shift, Proxy s, FullGenListOf s) -> g -> () -> Gen a
forall (i :: AInstr) (s :: AStore) g gs a.
FindGen i s g gs a =>
(Proxy i, Proxy s, FullGenListOf s) -> g -> gs -> Gen a
findGen (Proxy 'Shift, Proxy s, FullGenListOf s)
p g
g ()

-- | This can happen if the generators form a tree rather than a list, for whatever reason.
instance FindGen 'Shift s g (h :+ gs) a => FindGen 'Shift s (g :+ h) gs a where
  findGen :: (Proxy 'Shift, Proxy s, FullGenListOf s) -> (g :+ h) -> gs -> Gen a
findGen (Proxy 'Shift, Proxy s, FullGenListOf s)
p (g
g :+ h
h) gs
gs = (Proxy 'Shift, Proxy s, FullGenListOf s) -> g -> (h :+ gs) -> Gen a
forall (i :: AInstr) (s :: AStore) g gs a.
FindGen i s g gs a =>
(Proxy i, Proxy s, FullGenListOf s) -> g -> gs -> Gen a
findGen (Proxy 'Shift, Proxy s, FullGenListOf s)
p g
g (h
h h -> gs -> h :+ gs
forall a b. a -> b -> a :+ b
:+ gs
gs)

instance FindGen ('Match 'INCOHERENT) s g gs a => FindGen 'Shift s (Incoherent g) gs a where
  findGen :: (Proxy 'Shift, Proxy s, FullGenListOf s)
-> Incoherent g -> gs -> Gen a
findGen (Proxy 'Shift
_, Proxy s
s, FullGenListOf s
fg) (Incoherent g
g) = (Proxy ('Match 'INCOHERENT), Proxy s, FullGenListOf s)
-> g -> gs -> Gen a
forall (i :: AInstr) (s :: AStore) g gs a.
FindGen i s g gs a =>
(Proxy i, Proxy s, FullGenListOf s) -> g -> gs -> Gen a
findGen (Proxy ('Match 'INCOHERENT)
im, Proxy s
s, FullGenListOf s
fg) g
g where
    im :: Proxy ('Match 'INCOHERENT)
im = Proxy ('Match 'INCOHERENT)
forall k (t :: k). Proxy t
Proxy :: Proxy ('Match 'INCOHERENT)

-- | If none of the above matches, then @g@ should be a simple generator,
-- and we test whether it matches the type @a@.
instance {-# OVERLAPPABLE #-} FindGen ('Match (ACoherenceOf s)) s g gs a
  => FindGen 'Shift s g gs a where
  findGen :: (Proxy 'Shift, Proxy s, FullGenListOf s) -> g -> gs -> Gen a
findGen (Proxy 'Shift
_, Proxy s
s, FullGenListOf s
fg) = (Proxy ('Match (ACoherenceOf s)), Proxy s, FullGenListOf s)
-> g -> gs -> Gen a
forall (i :: AInstr) (s :: AStore) g gs a.
FindGen i s g gs a =>
(Proxy i, Proxy s, FullGenListOf s) -> g -> gs -> Gen a
findGen (Proxy ('Match (ACoherenceOf s))
im, Proxy s
s, FullGenListOf s
fg) where
    im :: Proxy ('Match (ACoherenceOf s))
im = Proxy ('Match (ACoherenceOf s))
forall k (t :: k). Proxy t
Proxy :: Proxy ('Match (ACoherenceOf s))

-- INCOHERENT

-- | None of the INCOHERENT instances match, discard the candidate @g@ and look
-- at the rest of the list @gs@.
instance FindGen 'Shift s () gs a
  => FindGen ('Match 'INCOHERENT) s _g gs a where
  findGen :: (Proxy ('Match 'INCOHERENT), Proxy s, FullGenListOf s)
-> _g -> gs -> Gen a
findGen (Proxy ('Match 'INCOHERENT)
_, Proxy s
s, FullGenListOf s
fg) _g
_ = (Proxy 'Shift, Proxy s, FullGenListOf s) -> () -> gs -> Gen a
forall (i :: AInstr) (s :: AStore) g gs a.
FindGen i s g gs a =>
(Proxy i, Proxy s, FullGenListOf s) -> g -> gs -> Gen a
findGen (Proxy 'Shift
iShift, Proxy s
s, FullGenListOf s
fg) () where

-- | Matching custom generator for @a@.
instance {-# INCOHERENT #-} FindGen ('Match 'INCOHERENT) s (Gen a) gs a where
  findGen :: (Proxy ('Match 'INCOHERENT), Proxy s, FullGenListOf s)
-> Gen a -> gs -> Gen a
findGen (Proxy ('Match 'INCOHERENT), Proxy s, FullGenListOf s)
_ Gen a
gen gs
_ = Gen a
gen
  {-# INLINEABLE findGen #-}

-- | Matching custom generator for non-container @f@.
instance {-# INCOHERENT #-} FindGen ('Match 'INCOHERENT) s (Gen1_ f) gs (f a) where
  findGen :: (Proxy ('Match 'INCOHERENT), Proxy s, FullGenListOf s)
-> Gen1_ f -> gs -> Gen (f a)
findGen (Proxy ('Match 'INCOHERENT), Proxy s, FullGenListOf s)
_ (Gen1_ forall (a :: k). Gen (f a)
gen) gs
_ = Gen (f a)
forall (a :: k). Gen (f a)
gen

-- | Matching custom generator for container @f@. Start the search for containee @a@,
-- discarding field information.
instance {-# INCOHERENT #-} FindGen 'Shift ('S fg coh DummySel) () fg a
  => FindGen ('Match 'INCOHERENT) ('S fg coh _sel) (Gen1 f) gs (f a) where
  findGen :: (Proxy ('Match 'INCOHERENT), Proxy ('S fg coh _sel),
 FullGenListOf ('S fg coh _sel))
-> Gen1 f -> gs -> Gen (f a)
findGen (Proxy ('Match 'INCOHERENT)
_, Proxy ('S fg coh _sel)
_, FullGenListOf ('S fg coh _sel)
fg) (Gen1 forall a. Gen a -> Gen (f a)
gen) gs
_ = Gen a -> Gen (f a)
forall a. Gen a -> Gen (f a)
gen ((Proxy 'Shift, Proxy ('S fg coh DummySel),
 FullGenListOf ('S fg coh DummySel))
-> () -> fg -> Gen a
forall (i :: AInstr) (s :: AStore) g gs a.
FindGen i s g gs a =>
(Proxy i, Proxy s, FullGenListOf s) -> g -> gs -> Gen a
findGen (Proxy 'Shift
iShift, Proxy ('S fg coh DummySel)
s, FullGenListOf ('S fg coh _sel)
FullGenListOf ('S fg coh DummySel)
fg) () fg
FullGenListOf ('S fg coh _sel)
fg) where
    s :: Proxy ('S fg coh DummySel)
s  = Proxy ('S fg coh DummySel)
forall k (t :: k). Proxy t
Proxy :: Proxy ('S fg coh DummySel)

type DummySel = '( 'Nothing, 0, 'Nothing)

-- | Matching custom generator for field @s@.
instance {-# INCOHERENT #-} (a ~ a')
  => FindGen ('Match 'INCOHERENT) ('S _fg _coh '(con, i, 'Just s)) (FieldGen s a) gs a' where
  findGen :: (Proxy ('Match 'INCOHERENT),
 Proxy ('S _fg _coh '(con, i, 'Just s)),
 FullGenListOf ('S _fg _coh '(con, i, 'Just s)))
-> FieldGen s a -> gs -> Gen a'
findGen (Proxy ('Match 'INCOHERENT),
 Proxy ('S _fg _coh '(con, i, 'Just s)),
 FullGenListOf ('S _fg _coh '(con, i, 'Just s)))
_ (FieldGen Gen a
gen) gs
_ = Gen a
Gen a'
gen
  {-# INLINEABLE findGen #-}

-- | Matching custom generator for @i@-th field of constructor @c@.
instance {-# INCOHERENT #-} (a ~ a')
  => FindGen ('Match 'INCOHERENT) ('S _fg _coh '( 'Just c, i, s)) (ConstrGen c i a) gs a' where
  findGen :: (Proxy ('Match 'INCOHERENT), Proxy ('S _fg _coh '( 'Just c, i, s)),
 FullGenListOf ('S _fg _coh '( 'Just c, i, s)))
-> ConstrGen c i a -> gs -> Gen a'
findGen (Proxy ('Match 'INCOHERENT), Proxy ('S _fg _coh '( 'Just c, i, s)),
 FullGenListOf ('S _fg _coh '( 'Just c, i, s)))
_ (ConstrGen Gen a
gen) gs
_ = Gen a
Gen a'
gen
  {-# INLINEABLE findGen #-}

-- | Get the name contained in a 'Meta' tag.
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

-- COHERENT

-- Use a type famaily to do the matching coherently.
instance FindGen ('MatchCoh (Matches (ASelOf s) g a)) s g gs a
  => FindGen ('Match 'COHERENT) s g gs a where
  findGen :: (Proxy ('Match 'COHERENT), Proxy s, FullGenListOf s)
-> g -> gs -> Gen a
findGen (Proxy ('Match 'COHERENT)
_, Proxy s
s, FullGenListOf s
fg) = (Proxy ('MatchCoh (Matches (ASelOf s) g a)), Proxy s,
 FullGenListOf s)
-> g -> gs -> Gen a
forall (i :: AInstr) (s :: AStore) g gs a.
FindGen i s g gs a =>
(Proxy i, Proxy s, FullGenListOf s) -> g -> gs -> Gen a
findGen (Proxy ('MatchCoh (Matches (ASelOf s) g a))
im, Proxy s
s, FullGenListOf s
fg) where
    im :: Proxy ('MatchCoh (Matches (ASelOf s) g a))
im = Proxy ('MatchCoh (Matches (ASelOf s) g a))
forall k (t :: k). Proxy t
Proxy :: Proxy ('MatchCoh (Matches (ASelOf s) g a))

type family Matches (s :: ASel) (g :: Type) (a :: Type) :: Bool where
  Matches _sel (Gen b) a = b == a
  Matches _sel (Gen1_ f) (f a) = 'True
  Matches _sel (Gen1_ f) a = 'False
  Matches _sel (Gen1 f) (f a) = 'True
  Matches _sel (Gen1 f) a = 'False
  Matches '(_c, i,  s) (FieldGen s1 b) a = s == 'Just s1 && b == a
  Matches '( c, i, _s) (ConstrGen c1 j b) a = c == 'Just c1 && i == j && b == a

-- If there is no match, skip and shift.
instance FindGen 'Shift s () gs a => FindGen ('MatchCoh 'False) s _g gs a where
  findGen :: (Proxy ('MatchCoh 'False), Proxy s, FullGenListOf s)
-> _g -> gs -> Gen a
findGen (Proxy ('MatchCoh 'False)
_, Proxy s
s, FullGenListOf s
fg) _g
_ = (Proxy 'Shift, Proxy s, FullGenListOf s) -> () -> gs -> Gen a
forall (i :: AInstr) (s :: AStore) g gs a.
FindGen i s g gs a =>
(Proxy i, Proxy s, FullGenListOf s) -> g -> gs -> Gen a
findGen (Proxy 'Shift
iShift, Proxy s
s, FullGenListOf s
fg) () where

-- If there is a match, the search terminates

instance (a ~ a') => FindGen ('MatchCoh 'True) s (Gen a) gs a' where
  findGen :: (Proxy ('MatchCoh 'True), Proxy s, FullGenListOf s)
-> Gen a -> gs -> Gen a'
findGen (Proxy ('MatchCoh 'True), Proxy s, FullGenListOf s)
_ Gen a
g gs
_ = Gen a
Gen a'
g

instance (f x ~ a') => FindGen ('MatchCoh 'True) s (Gen1_ f) gs a' where
  findGen :: (Proxy ('MatchCoh 'True), Proxy s, FullGenListOf s)
-> Gen1_ f -> gs -> Gen a'
findGen (Proxy ('MatchCoh 'True), Proxy s, FullGenListOf s)
_ (Gen1_ forall (a :: k). Gen (f a)
g) gs
_ = Gen a'
forall (a :: k). Gen (f a)
g

instance (f x ~ a', FindGen 'Shift ('S fg coh DummySel) () fg x)
  => FindGen ('MatchCoh 'True) ('S fg coh _sel) (Gen1 f) gs a' where
  findGen :: (Proxy ('MatchCoh 'True), Proxy ('S fg coh _sel),
 FullGenListOf ('S fg coh _sel))
-> Gen1 f -> gs -> Gen a'
findGen (Proxy ('MatchCoh 'True)
_, Proxy ('S fg coh _sel)
_, FullGenListOf ('S fg coh _sel)
fg) (Gen1 forall a. Gen a -> Gen (f a)
gen) gs
_ = Gen x -> Gen (f x)
forall a. Gen a -> Gen (f a)
gen ((Proxy 'Shift, Proxy ('S fg coh DummySel),
 FullGenListOf ('S fg coh DummySel))
-> () -> fg -> Gen x
forall (i :: AInstr) (s :: AStore) g gs a.
FindGen i s g gs a =>
(Proxy i, Proxy s, FullGenListOf s) -> g -> gs -> Gen a
findGen (Proxy 'Shift
iShift, Proxy ('S fg coh DummySel)
s, FullGenListOf ('S fg coh _sel)
FullGenListOf ('S fg coh DummySel)
fg) () fg
FullGenListOf ('S fg coh _sel)
fg) where
    s :: Proxy ('S fg coh DummySel)
s  = Proxy ('S fg coh DummySel)
forall k (t :: k). Proxy t
Proxy :: Proxy ('S fg coh DummySel)

-- | Matching custom generator for field @s@.
instance (a ~ a')
  => FindGen ('MatchCoh 'True) s (FieldGen sn a) gs a' where
  findGen :: (Proxy ('MatchCoh 'True), Proxy s, FullGenListOf s)
-> FieldGen sn a -> gs -> Gen a'
findGen (Proxy ('MatchCoh 'True), Proxy s, FullGenListOf s)
_ (FieldGen Gen a
gen) gs
_ = Gen a
Gen a'
gen

-- | Matching custom generator for @i@-th field of constructor @c@.
instance (a ~ a')
  => FindGen ('MatchCoh 'True) s (ConstrGen c i a) gs a' where
  findGen :: (Proxy ('MatchCoh 'True), Proxy s, FullGenListOf s)
-> ConstrGen c i a -> gs -> Gen a'
findGen (Proxy ('MatchCoh 'True), Proxy s, FullGenListOf s)
_ (ConstrGen Gen a
gen) gs
_ = Gen a
Gen a'
gen

--

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 = 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, Int
1))
  Weighted Maybe (Int -> Gen (a -> b), Int)
f <*> :: Weighted (a -> b) -> Weighted a -> Weighted b
<*> Weighted 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 (b -> f (a -> b)
f1, b
m) (b -> f a
a1, b
n) =
        ( \b
i ->
            let (b
j, 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
  Weighted a
a <|> :: Weighted a -> Weighted a -> Weighted a
<|> Weighted Maybe (Int -> Gen a, Int)
Nothing = Weighted a
a
  Weighted Maybe (Int -> Gen a, Int)
Nothing <|> Weighted a
b = Weighted a
b
  Weighted (Just (Int -> Gen a
a, Int
m)) <|> Weighted (Just (Int -> Gen a
b, 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
$
    ( \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 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 (\Int
_ -> Gen a
g, Int
1))