{-# LANGUAGE DataKinds #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module Data.Registry.Internal.TH where
import Control.Monad.Fail (fail)
import Data.Registry.Internal.Hedgehog
import Data.Text (splitOn, toLower)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Prelude (last)
import Protolude hiding (Type)
makeSelectGenerator :: Name -> [Con] -> ExpQ
makeSelectGenerator name constructors = do
chooserParam <- [p| (chooser :: GenIO Chooser) |]
otherParams <- traverse (parameterFor name) constructors
untaggedGenerators <- traverse untagGenerator constructors
expression <- appE (appE (varE (mkName "chooseOne")) (varE (mkName "chooser"))) (pure $ ListE untaggedGenerators)
pure $ LamE (chooserParam : otherParams) expression
where
parameterFor :: Name -> Con -> Q Pat
parameterFor typeName constructor = do
constructorTag <- tagName constructor
sigP (varP constructorTag) (appT (conT (mkName "GenIO")) (appT (appT (conT (mkName "Tag")) (litT (strTyLit (show constructorTag)))) (conT typeName)))
makeConstructorGenerator :: Con -> ExpQ
makeConstructorGenerator constructor = do
constructorTag <- tagName constructor
constructorName <- nameOf constructor
appE (appTypeE (varE (mkName "tag")) (litT (strTyLit (show constructorTag)))) (conE constructorName)
untagGenerator :: Con -> ExpQ
untagGenerator constructor = do
constructorTag <- tagName constructor
appE (appE (varE (mkName "fmap")) (varE (mkName "unTag"))) (varE constructorTag)
tagName :: Con -> Q Name
tagName constructor = do
n <- nameOf constructor
pure $ mkName $ toS . last . splitOn "." . toLower $ show n
nameOf :: Con -> Q Name
nameOf (NormalC n _) = pure n
nameOf (RecC n _) = pure n
nameOf other = do
qReport True ("we can only create generators for normal constructors and records, got: " <> show other)
fail "generators creation failed"
typesOf :: Con -> Q [Type]
typesOf (NormalC _ types) = pure (snd <$> types)
typesOf (RecC _ types) = pure $ (\(_,_,t) -> t) <$> types
typesOf other = do
qReport True ("we can only create generators for normal constructors and records, got: " <> show other)
fail "generators creation failed"
assembleGeneratorsToRegistry :: Exp -> [Exp] -> ExpQ
assembleGeneratorsToRegistry _ [] =
fail "generators creation failed"
assembleGeneratorsToRegistry selectorGenerator [g] =
let r = appendExpressions (genFunOf (pure g)) (funOf (pure selectorGenerator))
in appendExpressions r (genFunOf (varE (mkName "choiceChooser")))
assembleGeneratorsToRegistry selectorGenerator (g:gs) =
appendExpressions (genFunOf (pure g)) (assembleGeneratorsToRegistry selectorGenerator gs)
appendExpressions :: ExpQ -> ExpQ -> ExpQ
appendExpressions e1 e2 =
infixE (Just e1) (varE (mkName "<:")) (Just e2)
genFunOf :: ExpQ -> ExpQ
genFunOf = appE (varE (mkName "genFun"))
funOf :: ExpQ -> ExpQ
funOf = appE (varE (mkName "fun"))