{-# 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

-- | Make a registry containing generators for an ADT
--   We  want to generate the following
--
--       fun genEmployeeStatus
--    <: genFun (tag @"permanent" Permanent)
--    <: genFun (tag @"temporary" Temporary)
--
-- genEmployeeStatus :: Gen Chooser -> Gen (Tag "permanent" EmployeeStatus) -> Gen (Tag "temporary" EmployeeStatus) -> Gen EmployeeStatus
-- genEmployeeStatus chooser g1 g2 = chooseOne chooser [fmap unTag1, fmap unTag g2]
makeGenerators :: Name -> ExpQ
makeGenerators :: Name -> ExpQ
makeGenerators Name
genType = do
  Info
info <- Name -> Q Info
reify Name
genType
  case Info
info of
    TyConI (NewtypeD Cxt
_context Name
_name [TyVarBndr]
_typeVars Maybe Kind
_kind Con
constructor [DerivClause]
_deriving) -> do
      Name
constructorType <- Con -> Q Name
nameOf Con
constructor
      ExpQ -> ExpQ -> ExpQ
app (ExpQ -> ExpQ
genFunOf (Name -> ExpQ
conE Name
constructorType)) (Name -> ExpQ
varE (String -> Name
mkName String
"emptyRegistry"))
    TyConI (DataD Cxt
_context Name
_name [TyVarBndr]
_typeVars Maybe Kind
_kind [Con
constructor] [DerivClause]
_deriving) -> do
      Name
constructorType <- Con -> Q Name
nameOf Con
constructor
      ExpQ -> ExpQ -> ExpQ
app (ExpQ -> ExpQ
genFunOf (Name -> ExpQ
conE Name
constructorType)) (Name -> ExpQ
varE (String -> Name
mkName String
"emptyRegistry"))
    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 not create generators for this kind of data type at the moment. Got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Info -> String
forall a b. (Show a, StringConv 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