{-# LANGUAGE DataKinds #-}
module Data.Registry.Hedgehog.TH where
import Control.Monad.Fail (fail)
import Data.Registry
import Data.Registry.Internal.TH
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Protolude
makeGenerators :: Name -> ExpQ
makeGenerators :: Name -> ExpQ
makeGenerators Name
genType = do
Info
info <- Name -> Q Info
reify Name
genType
case Info
info of
TyConI (DataD Cxt
_context Name
name [TyVarBndr]
_typeVars Maybe Kind
_kind [Con]
constructors [DerivClause]
_deriving) -> do
Exp
selector <- Name -> [Con] -> ExpQ
makeSelectGenerator Name
name [Con]
constructors
[Exp]
generators <- (Con -> ExpQ) -> [Con] -> Q [Exp]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Con -> ExpQ
makeConstructorGenerator [Con]
constructors
Exp -> [Exp] -> ExpQ
assembleGeneratorsToRegistry Exp
selector [Exp]
generators
Info
other -> do
Bool -> String -> Q ()
forall (m :: * -> *). Quasi m => Bool -> String -> m ()
qReport Bool
True (String
"can only create generators for an ADT, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Info -> String
forall a b. (Show a, ConvertText String b) => a -> b
show Info
other)
String -> ExpQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"generators creation failed"
emptyRegistry :: Registry '[] '[]
emptyRegistry :: Registry '[] '[]
emptyRegistry = Registry '[] '[]
forall a. Monoid a => a
mempty