{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Data.Morpheus.Server.TH.Declare.Type
( declareType,
)
where
import Control.Monad.Reader (asks)
import Data.Morpheus.Internal.TH
( declareTypeRef,
m',
nameSpaceField,
nameSpaceType,
toName,
tyConArgs,
)
import Data.Morpheus.Server.Internal.TH.Types
( ServerDec,
ServerDecContext (..),
ServerTypeDefinition (..),
)
import Data.Morpheus.Types.Internal.AST
( ArgumentsDefinition (..),
ConsD (..),
FieldContent (..),
FieldDefinition (..),
FieldName (..),
TRUE,
TypeKind (..),
TypeName (..),
isOutput,
isOutputObject,
isSubscription,
)
import Data.Morpheus.Types.Internal.Resolving
( SubscriptionField,
)
import GHC.Generics (Generic)
import Language.Haskell.TH
declareType :: ServerTypeDefinition cat s -> ServerDec [Dec]
declareType ServerTypeDefinition {tKind = KindScalar} = pure []
declareType
ServerTypeDefinition
{ tName,
tCons,
tKind
} =
do
cons <- declareCons tKind tName tCons
let vars = map (PlainTV . toName) (tyConArgs tKind)
pure
[ DataD
[]
(toName tName)
vars
Nothing
cons
(derive tKind)
]
derive :: TypeKind -> [DerivClause]
derive tKind = [deriveClasses (''Generic : derivingList)]
where
derivingList
| isOutput tKind = []
| otherwise = [''Show]
deriveClasses :: [Name] -> DerivClause
deriveClasses classNames = DerivClause Nothing (map ConT classNames)
declareCons ::
TypeKind ->
TypeName ->
[ConsD cat s] ->
ServerDec [Con]
declareCons tKind tName = traverse consR
where
consR ConsD {cName, cFields} =
RecC
<$> consName tKind tName cName
<*> traverse (declareField tKind tName) cFields
consName :: TypeKind -> TypeName -> TypeName -> ServerDec Name
consName KindEnum (TypeName name) conName = do
namespace' <- asks namespace
if namespace'
then pure $ toName $ nameSpaceType [FieldName name] conName
else pure (toName conName)
consName _ _ conName = pure (toName conName)
declareField ::
TypeKind ->
TypeName ->
FieldDefinition cat s ->
ServerDec (Name, Bang, Type)
declareField tKind tName field@FieldDefinition {fieldName} = do
namespace' <- asks namespace
pure
( fieldTypeName namespace' tName fieldName,
Bang NoSourceUnpackedness NoSourceStrictness,
renderFieldType tKind field
)
renderFieldType ::
TypeKind ->
FieldDefinition cat s ->
Type
renderFieldType tKind FieldDefinition {fieldContent, fieldType} =
withFieldWrappers tKind fieldContent (declareTypeRef fieldType)
fieldTypeName :: Bool -> TypeName -> FieldName -> Name
fieldTypeName namespace tName fieldName
| namespace = toName (nameSpaceField tName fieldName)
| otherwise = toName fieldName
withSubscriptionField :: TypeKind -> Type -> Type
withSubscriptionField kind x
| isSubscription kind = AppT (ConT ''SubscriptionField) x
| otherwise = x
withArgs :: TypeName -> Type -> Type
withArgs argsTypename = AppT (AppT arrowType argType)
where
argType = ConT $ toName argsTypename
arrowType = ConT ''Arrow
withMonad :: Type -> Type
withMonad = AppT m'
type Arrow = (->)
withFieldWrappers ::
TypeKind ->
Maybe (FieldContent TRUE cat s) ->
Type ->
Type
withFieldWrappers kind (Just (FieldArgs ArgumentsDefinition {argumentsTypename = Just argsTypename})) =
withArgs argsTypename
. withSubscriptionField kind
. withMonad
withFieldWrappers kind _
| isOutputObject kind =
withSubscriptionField kind
. withMonad
| otherwise = id