{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Data.Morpheus.Server.TH.Declare.Type
( declareType,
)
where
import Data.Morpheus.Internal.TH
( declareTypeRef,
m',
mkFieldName,
mkTypeName,
nameSpaceField,
nameSpaceType,
tyConArgs,
)
import Data.Morpheus.Server.Internal.TH.Types (ServerTypeDefinition (..))
import Data.Morpheus.Types.Internal.AST
( ArgumentsDefinition (..),
ConsD (..),
FieldContent (..),
FieldDefinition (..),
FieldName,
TRUE,
TypeKind (..),
TypeName,
isOutput,
isOutputObject,
isSubscription,
)
import GHC.Generics (Generic)
import Language.Haskell.TH
declareType :: Bool -> ServerTypeDefinition cat -> [Dec]
declareType _ ServerTypeDefinition {tKind = KindScalar} = []
declareType namespace ServerTypeDefinition {tName, tCons, tKind, tNamespace} =
[ DataD
[]
(mkNamespace tNamespace tName)
tVars
Nothing
cons
(derive tKind)
]
where
tVars = declareTyVar (tyConArgs tKind)
where
declareTyVar = map (PlainTV . mkTypeName)
cons = declareCons namespace tKind (tNamespace, tName) tCons
derive :: TypeKind -> [DerivClause]
derive tKind = [deriveClasses (''Generic : derivingList)]
where
derivingList
| isOutput tKind = []
| otherwise = [''Show]
deriveClasses :: [Name] -> DerivClause
deriveClasses classNames = DerivClause Nothing (map ConT classNames)
mkNamespace :: [FieldName] -> TypeName -> Name
mkNamespace tNamespace = mkTypeName . nameSpaceType tNamespace
declareCons ::
Bool ->
TypeKind ->
([FieldName], TypeName) ->
[ConsD cat] ->
[Con]
declareCons namespace tKind (tNamespace, tName) = map consR
where
consR ConsD {cName, cFields} =
RecC
(mkNamespace tNamespace cName)
(map (declareField namespace tKind tName) cFields)
declareField ::
Bool ->
TypeKind ->
TypeName ->
FieldDefinition cat ->
(Name, Bang, Type)
declareField namespace tKind tName field@FieldDefinition {fieldName} =
( fieldTypeName namespace tName fieldName,
Bang NoSourceUnpackedness NoSourceStrictness,
renderFieldType tKind field
)
renderFieldType ::
TypeKind ->
FieldDefinition cat ->
Type
renderFieldType tKind FieldDefinition {fieldContent, fieldType} =
genFieldT
(declareTypeRef (isSubscription tKind) fieldType)
tKind
fieldContent
fieldTypeName :: Bool -> TypeName -> FieldName -> Name
fieldTypeName namespace tName fieldName
| namespace = mkFieldName (nameSpaceField tName fieldName)
| otherwise = mkFieldName fieldName
genFieldT :: Type -> TypeKind -> Maybe (FieldContent TRUE cat) -> Type
genFieldT result _ (Just (FieldArgs ArgumentsDefinition {argumentsTypename = Just argsTypename})) =
AppT
(AppT arrowType argType)
(AppT m' result)
where
argType = ConT $ mkTypeName argsTypename
arrowType = ConT ''Arrow
genFieldT result kind _
| isOutputObject kind = AppT m' result
| otherwise = result
type Arrow = (->)