{-# LANGUAGE TemplateHaskell #-}
module Test.QuickCheck.TH.Generators.Internal.BuildArbitrary where
import Language.Haskell.TH
import Safe
buildArbAny :: Int -> Q [Dec]
buildArbAny l
| l < 1 = return []
| otherwise = do
let buildArbName = mkName ("buildArb" ++ show l)
arbParameterNames <- mapM newName $ (("a" ++) . show) <$> [0..(l-1)]
let mFirstArbParameterName = headMay arbParameterNames
mRestArbParameterNames = tailMay arbParameterNames
bName <- newName "b"
fName <- newName "f"
mArbitraryTypeName <- lookupTypeName "Arbitrary"
mGenTypeName <- lookupTypeName "Gen"
mFmapName <- lookupValueName "<$>"
mApName <- lookupValueName "<*>"
mArbitraryValue <- lookupValueName "arbitrary"
case (,,,,,,) <$> mFirstArbParameterName <*> mRestArbParameterNames <*> mArbitraryTypeName <*> mGenTypeName <*> mFmapName <*> mApName <*> mArbitraryValue of
Nothing -> return []
Just (firstArbParameterName,restArbParameterNames,arbitraryTypeName,genTypeName,fmapName,apName,arbitraryValue) -> do
let plainTVs = PlainTV <$> (arbParameterNames ++ [bName])
typeClassRequirements = (AppT (ConT arbitraryTypeName) ) <$> (VarT <$> arbParameterNames)
genB = AppT (ConT genTypeName) (VarT bName)
aToGenB = (AppT
(AppT
ArrowT
(VarT firstArbParameterName))
(VarT bName))
buildFunctionArgument old new = (AppT
(AppT
ArrowT
(VarT new))
old)
preFunctionArgument = AppT ArrowT $ foldl buildFunctionArgument
aToGenB
restArbParameterNames
functionArgument = AppT preFunctionArgument genB
fFmapArbitrary = (InfixE (Just (VarE fName)) (VarE fmapName) (Just (VarE arbitraryValue)))
arbRs = replicate (length arbParameterNames - 1) arbitraryValue
preFunctionBody = foldl (\old new -> InfixE (Just old) (VarE apName) (Just (VarE new)))
fFmapArbitrary
arbRs
functionBody = FunD buildArbName [Clause [VarP fName] (NormalB preFunctionBody) []]
return
[SigD
buildArbName
(ForallT
plainTVs
typeClassRequirements
functionArgument
)
, functionBody
]