{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeFamilies #-}
module Data.Morpheus.Server.TH.Declare
( declare,
)
where
import Data.Morpheus.Server.Internal.TH.Types
( ServerTypeDefinition (..),
)
import Data.Morpheus.Server.TH.Declare.Decode
( deriveDecode,
)
import Data.Morpheus.Server.TH.Declare.Encode
( deriveEncode,
)
import Data.Morpheus.Server.TH.Declare.GQLType
( deriveGQLType,
)
import Data.Morpheus.Server.TH.Declare.Introspect
( deriveObjectRep,
instanceIntrospect,
)
import Data.Morpheus.Server.TH.Declare.Type
( declareType,
)
import Data.Morpheus.Server.TH.Transform
import Data.Morpheus.Types.Internal.AST
( IN,
isInput,
isObject,
)
import Data.Semigroup ((<>))
import Language.Haskell.TH
class Declare a where
type DeclareCtx a :: *
declare :: DeclareCtx a -> a -> Q [Dec]
instance Declare a => Declare [a] where
type DeclareCtx [a] = DeclareCtx a
declare namespace = fmap concat . traverse (declare namespace)
instance Declare TypeDec where
type DeclareCtx TypeDec = Bool
declare namespace (InputType typeD) = declare namespace typeD
declare namespace (OutputType typeD) = declare namespace typeD
instance Declare (ServerTypeDefinition cat) where
type DeclareCtx (ServerTypeDefinition cat) = Bool
declare namespace typeD@ServerTypeDefinition {tKind, typeArgD, typeOriginal} =
do
let mainType = declareType namespace typeD
argTypes <- declareArgTypes namespace typeArgD
gqlInstances <- deriveGQLInstances
typeClasses <- deriveGQLType typeD
introspectEnum <- instanceIntrospect typeOriginal
pure $ mainType <> typeClasses <> argTypes <> gqlInstances <> introspectEnum
where
deriveGQLInstances = concat <$> sequence gqlInstances
where
gqlInstances
| isObject tKind && isInput tKind =
[deriveObjectRep typeD, deriveDecode typeD]
| isObject tKind =
[deriveObjectRep typeD, deriveEncode typeD]
| otherwise =
[]
declareArgTypes :: Bool -> [ServerTypeDefinition IN] -> Q [Dec]
declareArgTypes namespace types = do
introspectArgs <- concat <$> traverse deriveObjectRep types
decodeArgs <- concat <$> traverse deriveDecode types
return $ argsTypeDecs <> decodeArgs <> introspectArgs
where
argsTypeDecs = concatMap (declareType namespace) types