{-# 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 = genericArbitraryWith unsizedOpts
genericArbitraryU
:: (GArbitrary UnsizedOpts a, GUniformWeight a)
=> Gen a
genericArbitraryU = genericArbitrary uniform
genericArbitrarySingle
:: (GArbitrary UnsizedOpts a, Weights_ (Rep a) ~ L c0)
=> Gen a
genericArbitrarySingle = genericArbitraryU
genericArbitraryRec
:: (GArbitrary SizedOptsDef a)
=> Weights a
-> Gen a
genericArbitraryRec = genericArbitraryWith sizedOptsDef
genericArbitraryG
:: (GArbitrary (SetGens genList UnsizedOpts) a)
=> genList
-> Weights a
-> Gen a
genericArbitraryG gs = genericArbitraryWith opts
where
opts = setGenerators gs unsizedOpts
genericArbitraryUG
:: (GArbitrary (SetGens genList UnsizedOpts) a, GUniformWeight a)
=> genList
-> Gen a
genericArbitraryUG gs = genericArbitraryG gs uniform
genericArbitrarySingleG
:: (GArbitrary (SetGens genList UnsizedOpts) a, Weights_ (Rep a) ~ L c0)
=> genList
-> Gen a
genericArbitrarySingleG = genericArbitraryUG
genericArbitraryRecG
:: (GArbitrary (SetGens genList SizedOpts) a)
=> genList
-> Weights a
-> Gen a
genericArbitraryRecG gs = genericArbitraryWith opts
where
opts = setGenerators gs sizedOpts
genericArbitraryWith
:: (GArbitrary opts a)
=> opts -> Weights a -> Gen a
genericArbitraryWith opts (Weights w n) =
fmap to (ga opts w 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 Num
weights :: (Weights_ (Rep a), Int, ()) -> Weights a
weights (w, n, ()) = Weights w n
uniform :: UniformWeight_ (Rep a) => Weights a
uniform =
let (w, n) = uniformWeight
in Weights w 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 % prec = weights (w %. prec)
instance WeightBuilder a => WeightBuilder' (a, Int, r) where
(%) = (%.)
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 %. prec =
let (a, n, (b, p, r)) = m % prec
in (N a n b, n + p, r)
instance WeightBuilder (L c) where
type Prec (L c) r = r
W m %. prec = (L, m, prec)
instance WeightBuilder () where
type Prec () r = r
W m %. prec = ((), m, prec)
class UniformWeight a where
uniformWeight :: (a, Int)
instance (UniformWeight a, UniformWeight b) => UniformWeight (a :| b) where
uniformWeight =
let
(a, m) = uniformWeight
(b, n) = uniformWeight
in
(N a m b, m + n)
instance UniformWeight (L c) where
uniformWeight = (L, 1)
instance UniformWeight () where
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
{ _generators :: genList
}
unsizedOpts :: UnsizedOpts
unsizedOpts = Options ()
sizedOpts :: SizedOpts
sizedOpts = Options ()
sizedOptsDef :: SizedOptsDef
sizedOptsDef = Options (Gen1 listOf' :+ ())
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 = coerce
setUnsized :: Options s g -> Options 'Unsized g
setUnsized = 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 = _generators
setGenerators :: genList -> Options s g0 -> Options s genList
setGenerators gens (Options _) = Options 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 { unFieldGen :: Gen a }
fieldGen :: proxy s -> Gen a -> FieldGen s a
fieldGen _ = FieldGen
newtype ConstrGen (c :: Symbol) (i :: Nat) a = ConstrGen { unConstrGen :: Gen a }
constrGen :: proxy '(c, i) -> Gen a -> ConstrGen c i a
constrGen _ = ConstrGen
#endif
newtype Gen1 f = Gen1 { unGen1 :: forall a. Gen a -> Gen (f a) }
newtype Gen1_ f = Gen1_ { unGen1_ :: forall a. Gen (f a) }
vectorOf' :: Int -> Gen a -> Gen [a]
vectorOf' 0 = \_ -> pure []
vectorOf' i = scale (`div` i) . vectorOf i
listOf' :: Gen a -> Gen [a]
listOf' g = sized $ \n -> do
i <- geom n
vectorOf' i g
listOf1' :: Gen a -> Gen [a]
listOf1' g = liftA2 (:) g (listOf' g)
geom :: Int -> Gen Int
geom 0 = pure 0
geom n = go 0 where
n' = fromIntegral n
p = 1 / (sqrt n' + 1) :: Double
go r = do
x <- choose (0, 1)
if x < p then
pure r
else
go $! (r + 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 z w n = fmap M1 (ga z w n)
{-# INLINE ga #-}
instance (GASum opts f, GASum opts g) => GA opts (f :+: g) where
ga = gaSum'
{-# INLINE ga #-}
instance GAProduct (SizingOf opts) (Name c) opts f => GA opts (M1 C c f) where
ga z _ _ = fmap M1 (gaProduct (Proxy :: Proxy '(SizingOf opts, Name c)) z)
{-# INLINE ga #-}
gaSum' :: GASum opts f => opts -> Weights_ f -> Int -> Gen (f p)
gaSum' z w n = do
i <- choose (0, n-1)
gaSum z i 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 z i (N a n b)
| i < n = fmap L1 (gaSum z i a)
| otherwise = fmap R1 (gaSum z (i - n) b)
{-# INLINE gaSum #-}
instance GAProduct (SizingOf opts) (Name c) opts f => GASum opts (M1 C c f) where
gaSum z _ _ = fmap M1 (gaProduct (Proxy :: Proxy '(SizingOf opts, Name c)) 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 _ = gaProduct' (Proxy :: Proxy '(c, 0))
{-# INLINE gaProduct #-}
instance {-# OVERLAPPING #-} GAProduct' c 0 opts (S1 d f)
=> GAProduct 'Sized c opts (S1 d f) where
gaProduct _ = scale (\n -> max 0 (n-1)) . gaProduct' (Proxy :: Proxy '(c, 0))
instance (GAProduct' c 0 opts f, KnownNat (Arity f)) => GAProduct 'Sized c opts f where
gaProduct _ = scale (`div` arity) . gaProduct' (Proxy :: Proxy '(c, 0))
where
arity = fromInteger (natVal (Proxy :: Proxy (Arity f)))
{-# INLINE gaProduct #-}
instance {-# OVERLAPPING #-} GAProduct 'Sized c opts U1 where
gaProduct _ _ = pure 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' _ _ = pure 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' _ opts = fmap (M1 . K1) (arbitraryOr sel gs () gs)
where
sel = Proxy :: Proxy '(c, i, Name d)
gs = generators opts
{-# INLINE gaProduct' #-}
instance (GAProduct' c i opts f, GAProduct' c (i + Arity f) opts g) => GAProduct' c i opts (f :*: g) where
gaProduct' px = (liftA2 . liftA2) (:*:)
(gaProduct' px)
(gaProduct' (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 _ _ _ _ = arbitrary
{-# INLINE arbitraryOr #-}
instance ArbitraryOr fg b g sel a => ArbitraryOr fg () (b :+ g) sel a where
arbitraryOr sel fg () (b :+ gens) = arbitraryOr sel fg b gens
{-# INLINE arbitraryOr #-}
instance {-# OVERLAPS #-} ArbitraryOr fg g () sel a => ArbitraryOr fg () g sel a where
arbitraryOr sel fg () g = arbitraryOr sel fg g ()
instance ArbitraryOr fg g (h :+ gs) sel a => ArbitraryOr fg (g :+ h) gs sel a where
arbitraryOr sel fg (g :+ h) gs = arbitraryOr sel fg g (h :+ gs)
instance {-# OVERLAPPABLE #-} ArbitraryOr fg () gs sel a => ArbitraryOr fg g gs sel a where
arbitraryOr sel fg _ = arbitraryOr sel fg ()
instance {-# INCOHERENT #-} ArbitraryOr fg (Gen a) g sel a where
arbitraryOr _ _ gen _ = gen
{-# INLINE arbitraryOr #-}
#if __GLASGOW_HASKELL__ >= 800
instance {-# INCOHERENT #-} (a ~ a') => ArbitraryOr fg (FieldGen s a) g '(con, i, 'Just s) a' where
arbitraryOr _ _ (FieldGen gen) _ = gen
{-# INLINE arbitraryOr #-}
instance {-# INCOHERENT #-} (a ~ a') => ArbitraryOr fg (ConstrGen c i a) g '( 'Just c, i, s) a' where
arbitraryOr _ _ (ConstrGen gen) _ = 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 _ _ (Gen1_ gen) _ = gen
instance {-# INCOHERENT #-} ArbitraryOr fg () fg '( 'Nothing, 0, 'Nothing) a
=> ArbitraryOr fg (Gen1 f) g sel (f a) where
arbitraryOr _ fg (Gen1 gen) _ = gen (arbitraryOr noSel fg () fg)
where noSel = Proxy :: Proxy '( 'Nothing, 0, 'Nothing)
newtype Weighted a = Weighted (Maybe (Int -> Gen a, Int))
deriving Functor
instance Applicative Weighted where
pure a = Weighted (Just ((pure . pure) a, 1))
Weighted f <*> Weighted a = Weighted $ liftA2 g f a
where
g (f1, m) (a1, n) =
( \i ->
let (j, k) = i `divMod` m
in f1 j <*> a1 k
, m * n )
instance Alternative Weighted where
empty = Weighted Nothing
a <|> Weighted Nothing = a
Weighted Nothing <|> b = b
Weighted (Just (a, m)) <|> Weighted (Just (b, n)) = Weighted . Just $
( \i ->
if i < m then
a i
else
b (i - m)
, m + n )
liftGen :: Gen a -> Weighted a
liftGen g = Weighted (Just (\_ -> g, 1))