{-# 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 f = do
info <- reify name
case info of
TyConI dec ->
case dec of
DataD _ _ tvbs _ cons' _ -> f tvbs cons'
NewtypeD _ _ tvbs _ con _ -> f tvbs [con]
other -> error $ "Example.TH.withType: Unsupported type: "
++ show other
_ -> error "Example.TH.withType: I need the name of a type."
makeArbitrary :: Name -> Q [Dec]
makeArbitrary n = withType n runConstructionApp
where
runConstructionApp _ con = do
dec <- applyCon n con
return dec
applyCon :: Name -> [Con] -> DecsQ
applyCon n cons' = sequence [signature,value]
where
signature = sigD finalFunctionName (appT (conT ''Gen) (conT n))
value = valD (varP finalFunctionName) (normalB (makeArbList cons')) []
finalFunctionName = mkName ("arbitrary" <> nameBase n)
makeArbList :: [Con] -> Q Exp
makeArbList cons' = appE (varE 'oneof)
(listE $ asNormalOrRecC applyConExp cons' )
asNormalOrRecC :: ((Name, [StrictType]) -> a) -> [Con] -> [a]
asNormalOrRecC f cons' = foldr decodeC [] cons'
where
decodeC (RecC n l) lst = (f (n, varStrictToStrict <$> l)) : lst
decodeC (NormalC n l) lst = (f (n, l)) : lst
decodeC _ lst = lst
varStrictToStrict (_ , s,t) = (s,t)
applyConExp :: (Name, [StrictType]) -> ExpQ
applyConExp deconstructedConstructor = runMapAndApp argCount
where
conName = fst deconstructedConstructor
argCount = fromIntegral . length . snd $ deconstructedConstructor :: Integer
runMapAndApp :: Integer -> ExpQ
runMapAndApp 0 = appE (varE 'arbReturn ) (conE conName)
runMapAndApp 1 = appE (varE 'buildArb1 ) (conE conName)
runMapAndApp 2 = appE (varE 'buildArb2 ) (conE conName)
runMapAndApp 3 = appE (varE 'buildArb3 ) (conE conName)
runMapAndApp 4 = appE (varE 'buildArb4 ) (conE conName)
runMapAndApp 5 = appE (varE 'buildArb5 ) (conE conName)
runMapAndApp 6 = appE (varE 'buildArb6 ) (conE conName)
runMapAndApp 7 = appE (varE 'buildArb7 ) (conE conName)
runMapAndApp 8 = appE (varE 'buildArb8 ) (conE conName)
runMapAndApp 9 = appE (varE 'buildArb9 ) (conE conName)
runMapAndApp 10 = appE (varE 'buildArb10 ) (conE conName)
runMapAndApp 11 = appE (varE 'buildArb11 ) (conE conName)
runMapAndApp 12 = appE (varE 'buildArb12 ) (conE conName)
runMapAndApp 13 = appE (varE 'buildArb13 ) (conE conName)
runMapAndApp 14 = appE (varE 'buildArb14 ) (conE conName)
runMapAndApp 15 = appE (varE 'buildArb15 ) (conE conName)
runMapAndApp 16 = appE (varE 'buildArb16 ) (conE conName)
runMapAndApp 17 = appE (varE 'buildArb17 ) (conE conName)
runMapAndApp 18 = appE (varE 'buildArb18 ) (conE conName)
runMapAndApp 19 = appE (varE 'buildArb19 ) (conE conName)
runMapAndApp 20 = appE (varE 'buildArb20 ) (conE conName)
runMapAndApp _ = error "Arbitrary TypeConstructors only defined for 0 to 20 parameters"
arbReturn :: a -> Gen a
arbReturn = return