{-# LANGUAGE TemplateHaskell #-}
module Test.QuickCheck.TH.Generators.Internal (makeArbitrary) where
import Data.Monoid ((<>))
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Test.QuickCheck
import Test.QuickCheck.TH.Generators.Internal.BuildArbitrary
$(buildArbAny 1)
$(buildArbAny 2)
$(buildArbAny 3)
$(buildArbAny 4)
$(buildArbAny 5)
$(buildArbAny 6)
$(buildArbAny 7)
$(buildArbAny 8)
$(buildArbAny 9)
$(buildArbAny 10)
$(buildArbAny 11)
$(buildArbAny 12)
$(buildArbAny 13)
$(buildArbAny 14)
$(buildArbAny 15)
$(buildArbAny 16)
$(buildArbAny 17)
$(buildArbAny 18)
$(buildArbAny 19)
$(buildArbAny 20)
withType :: Name
-> ([TyVarBndr] -> [Con] -> Q a)
-> Q a
withType :: Name -> ([TyVarBndr] -> [Con] -> Q a) -> Q a
withType Name
name [TyVarBndr] -> [Con] -> Q a
f = do
Info
info <- Name -> Q Info
reify Name
name
case Info
info of
TyConI Dec
dec ->
case Dec
dec of
DataD Cxt
_ Name
_ [TyVarBndr]
tvbs Maybe Kind
_ [Con]
cons' [DerivClause]
_ -> [TyVarBndr] -> [Con] -> Q a
f [TyVarBndr]
tvbs [Con]
cons'
NewtypeD Cxt
_ Name
_ [TyVarBndr]
tvbs Maybe Kind
_ Con
con [DerivClause]
_ -> [TyVarBndr] -> [Con] -> Q a
f [TyVarBndr]
tvbs [Con
con]
Dec
other -> [Char] -> Q a
forall a. HasCallStack => [Char] -> a
error ([Char] -> Q a) -> [Char] -> Q a
forall a b. (a -> b) -> a -> b
$ [Char]
"Example.TH.withType: Unsupported type: "
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Dec -> [Char]
forall a. Show a => a -> [Char]
show Dec
other
Info
_ -> [Char] -> Q a
forall a. HasCallStack => [Char] -> a
error [Char]
"Example.TH.withType: I need the name of a type."
makeArbitrary :: Name -> Q [Dec]
makeArbitrary :: Name -> Q [Dec]
makeArbitrary Name
n = Name -> ([TyVarBndr] -> [Con] -> Q [Dec]) -> Q [Dec]
forall a. Name -> ([TyVarBndr] -> [Con] -> Q a) -> Q a
withType Name
n [TyVarBndr] -> [Con] -> Q [Dec]
forall p. p -> [Con] -> Q [Dec]
runConstructionApp
where
runConstructionApp :: p -> [Con] -> Q [Dec]
runConstructionApp p
_ [Con]
con = do
[Dec]
dec <- Name -> [Con] -> Q [Dec]
applyCon Name
n [Con]
con
[Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec]
dec
applyCon :: Name -> [Con] -> DecsQ
applyCon :: Name -> [Con] -> Q [Dec]
applyCon Name
n [Con]
cons' = [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q Dec
signature,Q Dec
value]
where
signature :: Q Dec
signature = Name -> TypeQ -> Q Dec
sigD Name
finalFunctionName (TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT ''Gen) (Name -> TypeQ
conT Name
n))
value :: Q Dec
value = PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP Name
finalFunctionName) (ExpQ -> BodyQ
normalB ([Con] -> ExpQ
makeArbList [Con]
cons')) []
finalFunctionName :: Name
finalFunctionName = [Char] -> Name
mkName ([Char]
"arbitrary" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Name -> [Char]
nameBase Name
n)
makeArbList :: [Con] -> Q Exp
makeArbList :: [Con] -> ExpQ
makeArbList [Con]
cons' = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'oneof)
([ExpQ] -> ExpQ
listE ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ ((Name, [StrictType]) -> ExpQ) -> [Con] -> [ExpQ]
forall a. ((Name, [StrictType]) -> a) -> [Con] -> [a]
asNormalOrRecC (Name, [StrictType]) -> ExpQ
applyConExp [Con]
cons' )
asNormalOrRecC :: ((Name, [StrictType]) -> a) -> [Con] -> [a]
asNormalOrRecC :: ((Name, [StrictType]) -> a) -> [Con] -> [a]
asNormalOrRecC (Name, [StrictType]) -> a
f [Con]
cons' = (Con -> [a] -> [a]) -> [a] -> [Con] -> [a]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Con -> [a] -> [a]
decodeC [] [Con]
cons'
where
decodeC :: Con -> [a] -> [a]
decodeC (RecC Name
n [VarBangType]
l) [a]
lst = ((Name, [StrictType]) -> a
f (Name
n, VarBangType -> StrictType
forall a a b. (a, a, b) -> (a, b)
varStrictToStrict (VarBangType -> StrictType) -> [VarBangType] -> [StrictType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [VarBangType]
l)) a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
lst
decodeC (NormalC Name
n [StrictType]
l) [a]
lst = ((Name, [StrictType]) -> a
f (Name
n, [StrictType]
l)) a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
lst
decodeC Con
_ [a]
lst = [a]
lst
varStrictToStrict :: (a, a, b) -> (a, b)
varStrictToStrict (a
_ , a
s,b
t) = (a
s,b
t)
applyConExp :: (Name, [StrictType]) -> ExpQ
applyConExp :: (Name, [StrictType]) -> ExpQ
applyConExp (Name, [StrictType])
deconstructedConstructor = Integer -> ExpQ
runMapAndApp Integer
argCount
where
conName :: Name
conName = (Name, [StrictType]) -> Name
forall a b. (a, b) -> a
fst (Name, [StrictType])
deconstructedConstructor
argCount :: Integer
argCount = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer)
-> ((Name, [StrictType]) -> Int) -> (Name, [StrictType]) -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [StrictType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([StrictType] -> Int)
-> ((Name, [StrictType]) -> [StrictType])
-> (Name, [StrictType])
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, [StrictType]) -> [StrictType]
forall a b. (a, b) -> b
snd ((Name, [StrictType]) -> Integer)
-> (Name, [StrictType]) -> Integer
forall a b. (a -> b) -> a -> b
$ (Name, [StrictType])
deconstructedConstructor :: Integer
runMapAndApp :: Integer -> ExpQ
runMapAndApp :: Integer -> ExpQ
runMapAndApp Integer
0 = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'arbReturn ) (Name -> ExpQ
conE Name
conName)
runMapAndApp Integer
1 = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'buildArb1 ) (Name -> ExpQ
conE Name
conName)
runMapAndApp Integer
2 = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'buildArb2 ) (Name -> ExpQ
conE Name
conName)
runMapAndApp Integer
3 = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'buildArb3 ) (Name -> ExpQ
conE Name
conName)
runMapAndApp Integer
4 = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'buildArb4 ) (Name -> ExpQ
conE Name
conName)
runMapAndApp Integer
5 = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'buildArb5 ) (Name -> ExpQ
conE Name
conName)
runMapAndApp Integer
6 = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'buildArb6 ) (Name -> ExpQ
conE Name
conName)
runMapAndApp Integer
7 = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'buildArb7 ) (Name -> ExpQ
conE Name
conName)
runMapAndApp Integer
8 = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'buildArb8 ) (Name -> ExpQ
conE Name
conName)
runMapAndApp Integer
9 = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'buildArb9 ) (Name -> ExpQ
conE Name
conName)
runMapAndApp Integer
10 = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'buildArb10 ) (Name -> ExpQ
conE Name
conName)
runMapAndApp Integer
11 = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'buildArb11 ) (Name -> ExpQ
conE Name
conName)
runMapAndApp Integer
12 = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'buildArb12 ) (Name -> ExpQ
conE Name
conName)
runMapAndApp Integer
13 = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'buildArb13 ) (Name -> ExpQ
conE Name
conName)
runMapAndApp Integer
14 = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'buildArb14 ) (Name -> ExpQ
conE Name
conName)
runMapAndApp Integer
15 = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'buildArb15 ) (Name -> ExpQ
conE Name
conName)
runMapAndApp Integer
16 = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'buildArb16 ) (Name -> ExpQ
conE Name
conName)
runMapAndApp Integer
17 = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'buildArb17 ) (Name -> ExpQ
conE Name
conName)
runMapAndApp Integer
18 = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'buildArb18 ) (Name -> ExpQ
conE Name
conName)
runMapAndApp Integer
19 = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'buildArb19 ) (Name -> ExpQ
conE Name
conName)
runMapAndApp Integer
20 = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'buildArb20 ) (Name -> ExpQ
conE Name
conName)
runMapAndApp Integer
_ = [Char] -> ExpQ
forall a. HasCallStack => [Char] -> a
error [Char]
"Arbitrary TypeConstructors only defined for 0 to 20 parameters"
arbReturn :: a -> Gen a
arbReturn :: a -> Gen a
arbReturn = a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return