{-# LANGUAGE DataKinds #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Data.Morpheus.Server.TH.Declare.Encode
( deriveEncode,
)
where
import Data.Morpheus.Internal.TH
( applyT,
destructRecord,
instanceHeadMultiT,
mkTypeName,
nameStringE,
nameVarE,
nameVarP,
nameVarT,
typeT,
)
import Data.Morpheus.Server.Deriving.Encode
( Encode (..),
ExploreResolvers (..),
)
import Data.Morpheus.Server.Internal.TH.Types (ServerTypeDefinition (..))
import Data.Morpheus.Server.Types.GQLType (TRUE)
import Data.Morpheus.Types.Internal.AST
( ConsD (..),
FieldDefinition (..),
QUERY,
SUBSCRIPTION,
TypeName (..),
isSubscription,
)
import Data.Morpheus.Types.Internal.Resolving
( LiftOperation,
MapStrategy (..),
ObjectResModel (..),
ResModel (..),
Resolver,
)
import Data.Semigroup ((<>))
import Data.Typeable (Typeable)
import Language.Haskell.TH
m_ :: TypeName
m_ = "m"
fo_ :: TypeName
fo_ = "fieldOperationKind"
po_ :: TypeName
po_ = "parentOparation"
e_ :: TypeName
e_ = "encodeEvent"
encodeVars :: [TypeName]
encodeVars = [e_, m_]
encodeVarsT :: [TypeQ]
encodeVarsT = map nameVarT encodeVars
deriveEncode :: ServerTypeDefinition cat -> Q [Dec]
deriveEncode ServerTypeDefinition {tName, tCons = [ConsD {cFields}], tKind} =
pure <$> instanceD (cxt constrains) appHead methods
where
subARgs = conT ''SUBSCRIPTION : encodeVarsT
instanceArgs
| isSubscription tKind = subARgs
| otherwise = map nameVarT (po_ : encodeVars)
mainType = applyT (mkTypeName tName) [mainTypeArg]
where
mainTypeArg
| isSubscription tKind = applyT ''Resolver subARgs
| otherwise = typeT ''Resolver (fo_ : encodeVars)
typeables
| isSubscription tKind =
[applyT ''MapStrategy $ map conT [''QUERY, ''SUBSCRIPTION]]
| otherwise =
[ iLiftOp po_,
iLiftOp fo_,
typeT ''MapStrategy [fo_, po_],
iTypeable fo_,
iTypeable po_
]
iLiftOp op = applyT ''LiftOperation [nameVarT op]
iTypeable name = typeT ''Typeable [name]
constrains =
typeables
<> [ typeT ''Monad [m_],
applyT ''Encode (mainType : instanceArgs),
iTypeable e_,
iTypeable m_
]
appHead =
instanceHeadMultiT
''ExploreResolvers
(conT ''TRUE)
(mainType : instanceArgs)
methods = [funD 'exploreResolvers [clause argsE (normalB body) []]]
where
argsE = [nameVarP "_", destructRecord tName varNames]
body =
appE (varE 'pure)
$ appE
(conE 'ResObject)
$ appE
( appE
(conE 'ObjectResModel)
(nameStringE tName)
)
(listE $ map decodeVar varNames)
decodeVar name = [|(name, encode $(varName))|]
where
varName = nameVarE name
varNames = map fieldName cFields
deriveEncode _ = pure []