#if __GLASGOW_HASKELL__ < 710
#endif
module Generic.Random.Internal.Generic where
import Control.Applicative
import Data.Proxy
#if __GLASGOW_HASKELL__ >= 800
import GHC.Generics hiding (S)
#else
import GHC.Generics hiding (S, Arity)
#endif
import GHC.TypeLits
import Test.QuickCheck
genericArbitrary
:: (Generic a, GA Unsized (Rep a))
=> Weights a
-> Gen a
genericArbitrary (Weights w n) = fmap to (ga (Proxy :: Proxy Unsized) w n)
genericArbitraryU
:: (Generic a, GA Unsized (Rep a), UniformWeight_ (Rep a))
=> Gen a
genericArbitraryU = genericArbitrary uniform
genericArbitrarySingle
:: (Generic a, GA Unsized (Rep a), Weights_ (Rep a) ~ L c0)
=> Gen a
genericArbitrarySingle = genericArbitraryU
genericArbitraryRec
:: forall a
. (Generic a, GA Sized (Rep a))
=> Weights a
-> Gen a
genericArbitraryRec (Weights w n) =
fmap to (ga (Proxy :: Proxy Sized) w n :: Gen (Rep a p))
type family Weights_ (f :: * -> *) :: * 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
class WeightBuilder' w where
(%) :: W (First' w) -> 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
(%.) :: W (First a) -> 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
data Sized
data Unsized
class GA sized f where
ga :: proxy sized -> Weights_ f -> Int -> Gen (f p)
instance GA sized f => GA sized (M1 D c f) where
ga z w n = fmap M1 (ga z w n)
instance (GASum sized f, GASum sized g) => GA sized (f :+: g) where
ga = gaSum'
instance GAProduct sized f => GA sized (M1 C c f) where
ga z _ _ = fmap M1 (gaProduct z)
#if __GLASGOW_HASKELL__ >= 800
instance
TypeError
( 'Text "Unrecognized Rep: "
':<>: 'ShowType f
':$$: 'Text "Possible cause: missing Generic instance"
)
=> GA sized f where
ga = error "Type error"
#endif
gaSum' :: GASum sized f => proxy sized -> Weights_ f -> Int -> Gen (f p)
gaSum' z w n = do
i <- choose (0, n1)
gaSum z i w
class GASum sized f where
gaSum :: proxy sized -> Int -> Weights_ f -> Gen (f p)
instance (GASum sized f, GASum sized g) => GASum sized (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)
instance GAProduct sized f => GASum sized (M1 i c f) where
gaSum z _ _ = fmap M1 (gaProduct z)
class GAProduct sized f where
gaProduct :: proxy sized -> Gen (f p)
instance GAProduct' f => GAProduct Unsized f where
gaProduct _ = gaProduct'
instance (GAProduct' f, KnownNat (Arity f)) => GAProduct Sized f where
gaProduct _ = sized $ \n -> resize (n `div` arity) gaProduct'
where
arity = fromInteger (natVal (Proxy :: Proxy (Arity f)))
instance GAProduct Sized U1 where
gaProduct _ = pure U1
class GAProduct' f where
gaProduct' :: Gen (f p)
instance GAProduct' U1 where
gaProduct' = pure U1
instance Arbitrary c => GAProduct' (K1 i c) where
gaProduct' = fmap K1 arbitrary
instance (GAProduct' f, GAProduct' g) => GAProduct' (f :*: g) where
gaProduct' = liftA2 (:*:) gaProduct' gaProduct'
instance GAProduct' f => GAProduct' (M1 i c f) where
gaProduct' = fmap M1 gaProduct'
type family Arity f :: Nat where
Arity (f :*: g) = Arity f + Arity g
Arity (M1 _i _c _f) = 1
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 (f, m) (a, n) =
( \i ->
let (j, k) = i `divMod` m
in f j <*> a 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))