module Data.Component.Mock.TH.Gadt
( make
) where
import Relude
import qualified Relude.Unsafe as Unsafe
import qualified Language.Haskell.TH as Meta
import qualified Language.Haskell.TH.Syntax as Meta
import Data.Component.Mock.TH.Common
make :: [Meta.VarBangType] -> Meta.DecsQ
make fields = do
constructors <- traverse constructorFromField fields
let gadtDefinition = defaultDefinition constructors
pure (gadtDefinition : derivedInstances)
constructorFromField :: Meta.VarBangType -> Meta.Q Meta.Con
constructorFromField (fieldName, _, type') =
case functionTypeToList type' of
result : [] -> do
resultType <- substituteReturnContext result
let name = titleizeName fieldName
pure $ Meta.GadtC [name] [] resultType
othersAndResult -> do
let resultType = Unsafe.last othersAndResult
let inputType = Unsafe.init othersAndResult
resultType <- substituteReturnContext resultType
let name = titleizeName fieldName
pure $ Meta.GadtC [name] (toList $ fmap (noBang,) inputType) resultType
derivedInstances :: [Meta.Dec]
derivedInstances =
fmap deriveInstanceFor ["Eq", "Show"]
where
deriveInstanceFor classStr =
Meta.StandaloneDerivD
Nothing
[]
(Meta.AppT
(Meta.ConT $ Meta.mkName classStr)
(Meta.AppT
(Meta.ConT actionName)
(Meta.VarT $ Meta.mkName "r")))
substituteReturnContext :: Meta.Type -> Meta.Q Meta.Type
substituteReturnContext resultType =
case resultType of
Meta.AppT (Meta.VarT _) res ->
pure $ Meta.AppT (Meta.ConT actionName) res
other -> do
fail
$ "Data.Component.Mock only works with records that return values in a context, but got:\n"
<> " - " <> Meta.pprint other
noBang :: Meta.Bang
noBang = Meta.Bang Meta.NoSourceUnpackedness Meta.NoSourceStrictness
defaultDefinition :: [Meta.Con] -> Meta.Dec
defaultDefinition constructors =
Meta.DataD context actionName typeVars kind constructors derivingClauses
where
context =
[]
typeVars =
[Meta.PlainTV $ Meta.mkName "a"]
kind =
Nothing
derivingClauses =
[]