{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module Data.Morpheus.Server.TH.Declare.Introspect
( deriveObjectRep,
instanceIntrospect,
)
where
import Data.Morpheus.Internal.TH
( _',
_2',
apply,
applyVars,
cat',
funDSimple,
toCon,
toVarT,
tyConArgs,
)
import Data.Morpheus.Internal.Utils
( concatUpdates,
)
import Data.Morpheus.Server.Deriving.Introspect
( DeriveTypeContent (..),
Introspect (..),
ProxyRep (..),
deriveCustomInputObjectType,
)
import Data.Morpheus.Server.Internal.TH.Types
( ServerTypeDefinition (..),
)
import Data.Morpheus.Server.Internal.TH.Utils
( mkTypeableConstraints,
)
import Data.Morpheus.Server.Types.GQLType
( GQLType (__typeName, implements),
TypeUpdater,
)
import Data.Morpheus.Types.Internal.AST
( ArgumentsDefinition (..),
CONST,
ConsD (..),
FieldContent (..),
FieldDefinition (..),
IN,
LEAF,
OUT,
TRUE,
TypeContent (..),
TypeDefinition (..),
TypeKind (..),
TypeName,
TypeRef (..),
insertType,
unsafeFromFields,
)
import Data.Proxy (Proxy (..))
import Language.Haskell.TH
instanceIntrospect :: Maybe (TypeDefinition cat s) -> Q [Dec]
instanceIntrospect (Just typeDef@TypeDefinition {typeName, typeContent = DataEnum {}}) =
pure <$> instanceD (cxt []) iHead [defineIntrospect]
where
iHead = pure (apply ''Introspect [cat', toCon typeName])
defineIntrospect = funDSimple 'introspect [_'] [|insertType (typeDef :: TypeDefinition LEAF CONST)|]
instanceIntrospect _ = pure []
deriveObjectRep :: ServerTypeDefinition cat s -> Q [Dec]
deriveObjectRep
ServerTypeDefinition
{ tName,
tCons = [ConsD {cFields}],
tKind
} =
pure <$> instanceD constrains iHead methods
where
mainTypeName = applyVars tName typeArgs
typeArgs = tyConArgs tKind
constrains = mkTypeableConstraints typeArgs
iHead = apply ''DeriveTypeContent [instCat, conT ''TRUE, mainTypeName]
instCat
| tKind == KindInputObject =
conT ''IN
| otherwise = conT ''OUT
methods = [funDSimple 'deriveTypeContent [_', _2'] body]
where
body
| tKind == KindInputObject =
[|
deriveInputObject
$(buildFields cFields)
$(buildTypes instCat cFields)
|]
| otherwise =
[|
deriveOutputObject
$(proxy)
$(buildFields cFields)
$(buildTypes instCat cFields)
|]
proxy = [|(Proxy :: Proxy $(mainTypeName))|]
deriveObjectRep _ = pure []
deriveInputObject ::
[FieldDefinition IN s] ->
[TypeUpdater] ->
( TypeContent TRUE IN s,
[TypeUpdater]
)
deriveInputObject fields typeUpdates =
(DataInputObject (unsafeFromFields fields), typeUpdates)
deriveOutputObject ::
(GQLType a) =>
Proxy a ->
[FieldDefinition OUT s] ->
[TypeUpdater] ->
( TypeContent TRUE OUT s,
[TypeUpdater]
)
deriveOutputObject proxy fields typeUpdates =
( DataObject
(interfaceNames proxy)
(unsafeFromFields fields),
interfaceTypes proxy : typeUpdates
)
interfaceNames :: GQLType a => Proxy a -> [TypeName]
interfaceNames = map fst . implements
interfaceTypes :: GQLType a => Proxy a -> TypeUpdater
interfaceTypes = concatUpdates . map snd . implements
buildTypes :: TypeQ -> [FieldDefinition cat s] -> ExpQ
buildTypes cat = listE . concatMap (introspectField cat)
introspectField :: TypeQ -> FieldDefinition cat s -> [ExpQ]
introspectField cat FieldDefinition {fieldType, fieldContent} =
[|introspect $(proxyRepT cat fieldType)|] : inputTypes fieldContent
where
inputTypes :: Maybe (FieldContent TRUE cat s) -> [ExpQ]
inputTypes (Just (FieldArgs ArgumentsDefinition {argumentsTypename = Just argsTypeName}))
| argsTypeName /= "()" = [[|deriveCustomInputObjectType (argsTypeName, $(proxyT tAlias))|]]
where
tAlias = TypeRef {typeConName = argsTypeName, typeWrappers = [], typeArgs = Nothing}
inputTypes _ = []
proxyRepT :: TypeQ -> TypeRef -> Q Exp
proxyRepT cat TypeRef {typeConName, typeArgs} = [|(ProxyRep :: ProxyRep $(cat) $(genSig typeArgs))|]
where
genSig (Just m) = appT (toCon typeConName) (toVarT m)
genSig _ = toCon typeConName
proxyT :: TypeRef -> Q Exp
proxyT TypeRef {typeConName, typeArgs} = [|(Proxy :: Proxy $(genSig typeArgs))|]
where
genSig (Just m) = appT (toCon typeConName) (toVarT m)
genSig _ = toCon typeConName
buildFields :: [FieldDefinition cat s] -> ExpQ
buildFields = listE . map buildField
where
buildField f@FieldDefinition {fieldType} = [|f {fieldType = fieldType {typeConName = __typeName $(proxyT fieldType)}}|]