{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Data.Morpheus.CodeGen.Server.Interpreting.Transform
( parseServerTypeDefinitions,
)
where
import Data.ByteString.Lazy.Char8 (ByteString)
import Data.Morpheus.CodeGen.Internal.AST
( AssociatedType (..),
CodeGenConstructor (..),
CodeGenField (..),
CodeGenType (..),
CodeGenTypeName (CodeGenTypeName, typeParameters),
MethodArgument (..),
TypeClassInstance (..),
fromTypeName,
getFullName,
)
import Data.Morpheus.CodeGen.Server.Internal.AST
( CodeGenConfig (..),
DerivingClass (..),
FIELD_TYPE_WRAPPER (..),
GQLTypeDefinition (..),
InterfaceDefinition (..),
Kind (..),
ServerDeclaration (..),
ServerMethod (..),
)
import Data.Morpheus.CodeGen.Server.Interpreting.Directive
( getDefaultValueDir,
getDirectives,
getNamespaceDirs,
getRenameDir,
)
import Data.Morpheus.CodeGen.Server.Interpreting.Utils
( CodeGenM,
CodeGenMonad (printWarnings),
ServerCodeGenContext (..),
checkTypeExistence,
getEnumName,
getFieldName,
getFieldTypeName,
inType,
isParamResolverType,
isSubscription,
)
import Data.Morpheus.CodeGen.TH (ToName (..))
import Data.Morpheus.CodeGen.Utils
( Flag (..),
Flags,
camelCaseTypeName,
langExtension,
runCodeGenT,
toHaskellTypeName,
)
import Data.Morpheus.Core (parseDefinitions)
import Data.Morpheus.Error (renderGQLErrors)
import Data.Morpheus.Internal.Ext (Result (..))
import Data.Morpheus.Server.Types (Arg, DIRECTIVE_LOCATIONS, GQLDirective, GQLType (..), SubscriptionField)
import Data.Morpheus.Types.Internal.AST
( ANY,
ArgumentDefinition (..),
CONST,
DataEnumValue (..),
DirectiveDefinition (..),
FieldContent (..),
FieldDefinition (..),
FieldName,
FieldsDefinition,
IN,
OUT,
RawTypeDefinition (..),
TRUE,
TypeContent (..),
TypeDefinition (..),
TypeKind (..),
TypeName,
TypeRef (..),
UnionMember (..),
isNullable,
isPossibleInterfaceType,
isResolverType,
kindOf,
packName,
unpackName,
)
import Relude hiding (ByteString, get)
parseServerTypeDefinitions :: CodeGenMonad m => CodeGenConfig -> ByteString -> m ([ServerDeclaration], Flags)
parseServerTypeDefinitions :: forall (m :: * -> *).
CodeGenMonad m =>
CodeGenConfig -> ByteString -> m ([ServerDeclaration], Flags)
parseServerTypeDefinitions CodeGenConfig
ctx ByteString
txt =
case ByteString -> GQLResult [RawTypeDefinition]
parseDefinitions ByteString
txt of
Failure NonEmpty GQLError
errors -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail (NonEmpty GQLError -> String
renderGQLErrors NonEmpty GQLError
errors)
Success {[RawTypeDefinition]
result :: forall err a. Result err a -> a
result :: [RawTypeDefinition]
result, [GQLError]
warnings :: forall err a. Result err a -> [err]
warnings :: [GQLError]
warnings} -> forall (m :: * -> *). CodeGenMonad m => [GQLError] -> m ()
printWarnings [GQLError]
warnings forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *).
CodeGenMonad m =>
Bool -> [RawTypeDefinition] -> m ([ServerDeclaration], Flags)
toTHDefinitions (CodeGenConfig -> Bool
namespace CodeGenConfig
ctx) [RawTypeDefinition]
result
getExternals :: [ServerDeclaration] -> Flags
getExternals :: [ServerDeclaration] -> Flags
getExternals [ServerDeclaration]
xs =
[Text -> Flag
FlagExternal Text
scalarTypeName | ScalarType {Text
scalarTypeName :: ServerDeclaration -> Text
scalarTypeName :: Text
scalarTypeName} <- [ServerDeclaration]
xs]
forall a. Semigroup a => a -> a -> a
<> [Text -> Flag
FlagExternal (forall a (t :: NAME). NamePacking a => Name t -> a
unpackName forall a b. (a -> b) -> a -> b
$ CodeGenTypeName -> TypeName
getFullName forall a b. (a -> b) -> a -> b
$ forall body. TypeClassInstance body -> CodeGenTypeName
typeClassTarget TypeClassInstance ServerMethod
v) | GQLTypeInstance Kind
Scalar TypeClassInstance ServerMethod
v <- [ServerDeclaration]
xs]
toTHDefinitions ::
CodeGenMonad m =>
Bool ->
[RawTypeDefinition] ->
m ([ServerDeclaration], Flags)
toTHDefinitions :: forall (m :: * -> *).
CodeGenMonad m =>
Bool -> [RawTypeDefinition] -> m ([ServerDeclaration], Flags)
toTHDefinitions Bool
namespace [RawTypeDefinition]
defs = do
([ServerDeclaration]
types, Flags
flags) <- forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [(a, b)] -> ([a], [b])
unzip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *).
CodeGenMonad m =>
RawTypeDefinition -> m ([ServerDeclaration], Flags)
generateTypes [RawTypeDefinition]
defs
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ServerDeclaration]
types, Flags
flags forall a. Semigroup a => a -> a -> a
<> [ServerDeclaration] -> Flags
getExternals [ServerDeclaration]
types)
where
typeDefinitions :: [TypeDefinition ANY CONST]
typeDefinitions = [TypeDefinition ANY CONST
td | RawTypeDefinition TypeDefinition ANY CONST
td <- [RawTypeDefinition]
defs]
directiveDefinitions :: [DirectiveDefinition CONST]
directiveDefinitions = [DirectiveDefinition CONST
td | RawDirectiveDefinition DirectiveDefinition CONST
td <- [RawTypeDefinition]
defs]
generateTypes :: CodeGenMonad m => RawTypeDefinition -> m ([ServerDeclaration], Flags)
generateTypes :: forall (m :: * -> *).
CodeGenMonad m =>
RawTypeDefinition -> m ([ServerDeclaration], Flags)
generateTypes (RawTypeDefinition TypeDefinition ANY CONST
typeDef) =
forall (m :: * -> *) ctx a.
Monad m =>
CodeGenT ctx m a -> ctx -> m (a, Flags)
runCodeGenT
(forall (m :: * -> *).
CodeGenM m =>
TypeDefinition ANY CONST -> m [ServerDeclaration]
genTypeDefinition TypeDefinition ANY CONST
typeDef)
ServerCodeGenContext
{ toArgsTypeName :: FieldName -> TypeName
toArgsTypeName = Bool -> TypeName -> FieldName -> TypeName
mkArgsTypeName Bool
namespace (forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName TypeDefinition ANY CONST
typeDef),
[TypeDefinition ANY CONST]
typeDefinitions :: [TypeDefinition ANY CONST]
typeDefinitions :: [TypeDefinition ANY CONST]
typeDefinitions,
[DirectiveDefinition CONST]
directiveDefinitions :: [DirectiveDefinition CONST]
directiveDefinitions :: [DirectiveDefinition CONST]
directiveDefinitions,
currentTypeName :: Maybe TypeName
currentTypeName = forall a. a -> Maybe a
Just (forall a (t :: NAME). NamePacking a => a -> Name t
packName forall a b. (a -> b) -> a -> b
$ TypeName -> Text
toHaskellTypeName forall a b. (a -> b) -> a -> b
$ forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName TypeDefinition ANY CONST
typeDef),
currentKind :: Maybe TypeKind
currentKind = forall a. a -> Maybe a
Just (forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeKind
kindOf TypeDefinition ANY CONST
typeDef),
hasNamespace :: Bool
hasNamespace = Bool
namespace
}
generateTypes (RawDirectiveDefinition DirectiveDefinition {[DirectiveLocation]
Maybe Text
FieldName
ArgumentsDefinition CONST
directiveDefinitionName :: forall (s :: Stage). DirectiveDefinition s -> FieldName
directiveDefinitionDescription :: forall (s :: Stage). DirectiveDefinition s -> Maybe Text
directiveDefinitionArgs :: forall (s :: Stage). DirectiveDefinition s -> ArgumentsDefinition s
directiveDefinitionLocations :: forall (s :: Stage). DirectiveDefinition s -> [DirectiveLocation]
directiveDefinitionLocations :: [DirectiveLocation]
directiveDefinitionArgs :: ArgumentsDefinition CONST
directiveDefinitionDescription :: Maybe Text
directiveDefinitionName :: FieldName
..}) =
forall (m :: * -> *) ctx a.
Monad m =>
CodeGenT ctx m a -> ctx -> m (a, Flags)
runCodeGenT
( do
[CodeGenField]
fields <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *) (c :: TypeCategory).
CodeGenM m =>
FieldDefinition c CONST -> m CodeGenField
renderDataField (forall (s :: Stage). ArgumentDefinition s -> FieldDefinition IN s
argument forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a. Foldable t => t a -> [a]
toList ArgumentsDefinition CONST
directiveDefinitionArgs)
let typename :: TypeName
typename = coerce :: forall a b. Coercible a b => a -> b
coerce FieldName
directiveDefinitionName
[ServerDirectiveUsage]
namespaceDirs <- forall (m :: * -> *).
CodeGenM m =>
Text -> m [ServerDirectiveUsage]
getNamespaceDirs (forall a (t :: NAME). NamePacking a => Name t -> a
unpackName TypeName
typename)
let cgTypeName :: CodeGenTypeName
cgTypeName = TypeName -> CodeGenTypeName
fromTypeName TypeName
typename
forall (f :: * -> *) a. Applicative f => a -> f a
pure
[ CodeGenType -> ServerDeclaration
DataType
CodeGenType
{ CodeGenTypeName
cgTypeName :: CodeGenTypeName
cgTypeName :: CodeGenTypeName
cgTypeName,
cgConstructors :: [CodeGenConstructor]
cgConstructors = [CodeGenTypeName -> [CodeGenField] -> CodeGenConstructor
CodeGenConstructor (TypeName -> CodeGenTypeName
fromTypeName TypeName
typename) [CodeGenField]
fields],
cgDerivations :: [DerivingClass]
cgDerivations = [DerivingClass
SHOW, DerivingClass
GENERIC]
},
TypeClassInstance ServerMethod -> ServerDeclaration
GQLDirectiveInstance
TypeClassInstance
{ typeClassName :: Name
typeClassName = ''GQLDirective,
typeClassContext :: [(Name, Name)]
typeClassContext = [],
typeClassTarget :: CodeGenTypeName
typeClassTarget = CodeGenTypeName
cgTypeName,
assoc :: [(Name, AssociatedType)]
assoc = [(''DIRECTIVE_LOCATIONS, [DirectiveLocation] -> AssociatedType
AssociatedLocations [DirectiveLocation]
directiveDefinitionLocations)],
typeClassMethods :: [(Name, MethodArgument, ServerMethod)]
typeClassMethods = []
},
GQLTypeDefinition -> ServerDeclaration
gqlTypeToInstance
GQLTypeDefinition
{ gqlTarget :: CodeGenTypeName
gqlTarget = CodeGenTypeName
cgTypeName,
gqlKind :: Kind
gqlKind = Kind
Type,
gqlTypeDirectiveUses :: [ServerDirectiveUsage]
gqlTypeDirectiveUses = [ServerDirectiveUsage]
namespaceDirs
}
]
)
ServerCodeGenContext
{ toArgsTypeName :: FieldName -> TypeName
toArgsTypeName = coerce :: forall a b. Coercible a b => a -> b
coerce,
[TypeDefinition ANY CONST]
typeDefinitions :: [TypeDefinition ANY CONST]
typeDefinitions :: [TypeDefinition ANY CONST]
typeDefinitions,
currentTypeName :: Maybe TypeName
currentTypeName = forall a. a -> Maybe a
Just (coerce :: forall a b. Coercible a b => a -> b
coerce FieldName
directiveDefinitionName),
[DirectiveDefinition CONST]
directiveDefinitions :: [DirectiveDefinition CONST]
directiveDefinitions :: [DirectiveDefinition CONST]
directiveDefinitions,
currentKind :: Maybe TypeKind
currentKind = forall a. Maybe a
Nothing,
hasNamespace :: Bool
hasNamespace = Bool
namespace
}
generateTypes RawTypeDefinition
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Monoid a => a
mempty, forall a. Monoid a => a
mempty)
mkInterfaceName :: TypeName -> TypeName
mkInterfaceName :: TypeName -> TypeName
mkInterfaceName = (TypeName
"Interface" forall a. Semigroup a => a -> a -> a
<>)
mkPossibleTypesName :: TypeName -> TypeName
mkPossibleTypesName :: TypeName -> TypeName
mkPossibleTypesName = (TypeName
"PossibleTypes" forall a. Semigroup a => a -> a -> a
<>)
genTypeDefinition ::
CodeGenM m =>
TypeDefinition ANY CONST ->
m [ServerDeclaration]
genTypeDefinition :: forall (m :: * -> *).
CodeGenM m =>
TypeDefinition ANY CONST -> m [ServerDeclaration]
genTypeDefinition
typeDef :: TypeDefinition ANY CONST
typeDef@TypeDefinition {typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName = TypeName
originalTypeName, TypeContent TRUE ANY CONST
typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent :: TypeContent TRUE ANY CONST
typeContent} =
case TypeKind
tKind of
TypeKind
KIND_SCALAR -> do
ServerDeclaration
scalarGQLType <- m ServerDeclaration
deriveGQL
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Text -> ServerDeclaration
ScalarType (TypeName -> Text
toHaskellTypeName TypeName
typeName), ServerDeclaration
scalarGQLType]
TypeKind
_ -> forall (m :: * -> *).
CodeGenM m =>
TypeName -> TypeContent TRUE ANY CONST -> m BuildPlan
genTypeContent TypeName
originalTypeName TypeContent TRUE ANY CONST
typeContent forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BuildPlan -> m [ServerDeclaration]
withType
where
typeName :: TypeName
typeName
| TypeKind
tKind forall a. Eq a => a -> a -> Bool
== TypeKind
KIND_INTERFACE = TypeName -> TypeName
mkInterfaceName TypeName
originalTypeName
| Bool
otherwise = TypeName
originalTypeName
tKind :: TypeKind
tKind = forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeKind
kindOf TypeDefinition ANY CONST
typeDef
hsTypeName :: TypeName
hsTypeName = forall a (t :: NAME). NamePacking a => a -> Name t
packName forall a b. (a -> b) -> a -> b
$ TypeName -> Text
toHaskellTypeName TypeName
typeName
cgTypeName :: CodeGenTypeName
cgTypeName = [FieldName] -> [Text] -> TypeName -> CodeGenTypeName
CodeGenTypeName [] [Text
"m" | forall t. Strictness t => t -> Bool
isResolverType TypeKind
tKind] TypeName
hsTypeName
deriveGQL :: m ServerDeclaration
deriveGQL = do
[ServerDirectiveUsage]
defaultValueDirs <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *) (c :: TypeCategory).
CodeGenM m =>
FieldDefinition c CONST -> m [ServerDirectiveUsage]
getDefaultValueDir (forall (c :: TypeCategory) (s :: Stage).
TypeDefinition c s -> [FieldDefinition IN s]
getInputFields TypeDefinition ANY CONST
typeDef)
[ServerDirectiveUsage]
namespaceDirs <- forall (m :: * -> *).
CodeGenM m =>
Text -> m [ServerDirectiveUsage]
getNamespaceDirs (forall a (t :: NAME). NamePacking a => Name t -> a
unpackName TypeName
hsTypeName)
[ServerDirectiveUsage]
dirs <- forall (m :: * -> *) a.
(CodeGenM m, Meta a) =>
a -> m [ServerDirectiveUsage]
getDirectives TypeDefinition ANY CONST
typeDef
[ServerDirectiveUsage]
renameDir <- forall (m :: * -> *) (t :: NAME).
CodeGenM m =>
Name t -> Name t -> m [ServerDirectiveUsage]
getRenameDir TypeName
originalTypeName TypeName
hsTypeName
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
GQLTypeDefinition -> ServerDeclaration
gqlTypeToInstance
GQLTypeDefinition
{ gqlTarget :: CodeGenTypeName
gqlTarget = CodeGenTypeName
cgTypeName,
gqlTypeDirectiveUses :: [ServerDirectiveUsage]
gqlTypeDirectiveUses = [ServerDirectiveUsage]
renameDir forall a. Semigroup a => a -> a -> a
<> [ServerDirectiveUsage]
namespaceDirs forall a. Semigroup a => a -> a -> a
<> [ServerDirectiveUsage]
dirs forall a. Semigroup a => a -> a -> a
<> [ServerDirectiveUsage]
defaultValueDirs,
gqlKind :: Kind
gqlKind = TypeKind -> Kind
derivingKind TypeKind
tKind
}
cgDerivations :: [DerivingClass]
cgDerivations = Bool -> [DerivingClass]
derivesClasses (forall t. Strictness t => t -> Bool
isResolverType TypeKind
tKind)
withType :: BuildPlan -> m [ServerDeclaration]
withType (ConsIN [CodeGenConstructor]
cgConstructors) = do
ServerDeclaration
gqlType <- m ServerDeclaration
deriveGQL
forall (f :: * -> *) a. Applicative f => a -> f a
pure [CodeGenType -> ServerDeclaration
DataType CodeGenType {[DerivingClass]
[CodeGenConstructor]
CodeGenTypeName
cgConstructors :: [CodeGenConstructor]
cgDerivations :: [DerivingClass]
cgTypeName :: CodeGenTypeName
cgDerivations :: [DerivingClass]
cgConstructors :: [CodeGenConstructor]
cgTypeName :: CodeGenTypeName
..}, ServerDeclaration
gqlType]
withType (ConsOUT [ServerDeclaration]
others [CodeGenConstructor]
cgConstructors) = do
ServerDeclaration
gqlType <- m ServerDeclaration
deriveGQL
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CodeGenType -> ServerDeclaration
DataType CodeGenType {[DerivingClass]
[CodeGenConstructor]
CodeGenTypeName
cgConstructors :: [CodeGenConstructor]
cgDerivations :: [DerivingClass]
cgTypeName :: CodeGenTypeName
cgDerivations :: [DerivingClass]
cgConstructors :: [CodeGenConstructor]
cgTypeName :: CodeGenTypeName
..} forall a. a -> [a] -> [a]
: ServerDeclaration
gqlType forall a. a -> [a] -> [a]
: [ServerDeclaration]
others)
derivingKind :: TypeKind -> Kind
derivingKind :: TypeKind -> Kind
derivingKind TypeKind
KIND_SCALAR = Kind
Scalar
derivingKind TypeKind
_ = Kind
Type
derivesClasses :: Bool -> [DerivingClass]
derivesClasses :: Bool -> [DerivingClass]
derivesClasses Bool
isResolver = DerivingClass
GENERIC forall a. a -> [a] -> [a]
: [DerivingClass
SHOW | Bool -> Bool
not Bool
isResolver]
mkObjectCons :: TypeName -> [CodeGenField] -> [CodeGenConstructor]
mkObjectCons :: TypeName -> [CodeGenField] -> [CodeGenConstructor]
mkObjectCons TypeName
name = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. CodeGenTypeName -> [CodeGenField] -> CodeGenConstructor
CodeGenConstructor (TypeName -> CodeGenTypeName
fromTypeName TypeName
name)
mkArgsTypeName :: Bool -> TypeName -> FieldName -> TypeName
mkArgsTypeName :: Bool -> TypeName -> FieldName -> TypeName
mkArgsTypeName Bool
namespace TypeName
typeName FieldName
fieldName
| Bool
namespace = TypeName
typeName forall a. Semigroup a => a -> a -> a
<> TypeName
argTName
| Bool
otherwise = TypeName
argTName
where
argTName :: TypeName
argTName = forall (t :: NAME). [Name t] -> TypeName -> TypeName
camelCaseTypeName [FieldName
fieldName] TypeName
"Args"
mkObjectField ::
CodeGenM m =>
FieldDefinition OUT CONST ->
m CodeGenField
mkObjectField :: forall (m :: * -> *).
CodeGenM m =>
FieldDefinition OUT CONST -> m CodeGenField
mkObjectField
FieldDefinition
{ fieldName :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldName = FieldName
fName,
Maybe (FieldContent TRUE OUT CONST)
fieldContent :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Maybe (FieldContent TRUE cat s)
fieldContent :: Maybe (FieldContent TRUE OUT CONST)
fieldContent,
fieldType :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> TypeRef
fieldType = TypeRef {TypeName
typeConName :: TypeRef -> TypeName
typeConName :: TypeName
typeConName, TypeWrapper
typeWrappers :: TypeRef -> TypeWrapper
typeWrappers :: TypeWrapper
typeWrappers}
} = do
Bool
isParametrized <- forall (m :: * -> *). CodeGenM m => TypeName -> m Bool
isParamResolverType TypeName
typeConName
FieldName -> TypeName
genName <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ServerCodeGenContext -> FieldName -> TypeName
toArgsTypeName
Maybe TypeKind
kind <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ServerCodeGenContext -> Maybe TypeKind
currentKind
FieldName
fieldName <- forall (m :: * -> *). CodeGenM m => FieldName -> m FieldName
getFieldName FieldName
fName
[FIELD_TYPE_WRAPPER]
args <- forall (m :: * -> *) (s :: Stage).
CodeGenM m =>
FieldName
-> (FieldName -> TypeName)
-> [ArgumentDefinition s]
-> m [FIELD_TYPE_WRAPPER]
mkFieldArguments FieldName
fName FieldName -> TypeName
genName (forall (bool :: Bool) (cat :: TypeCategory) (s :: Stage).
Maybe (FieldContent bool cat s) -> [ArgumentDefinition s]
toArgList Maybe (FieldContent TRUE OUT CONST)
fieldContent)
TypeName
fieldType <- forall (m :: * -> *). CodeGenM m => TypeName -> m TypeName
getFieldTypeName TypeName
typeConName
forall (f :: * -> *) a. Applicative f => a -> f a
pure
CodeGenField
{ TypeName
fieldType :: TypeName
fieldType :: TypeName
fieldType,
fieldIsNullable :: Bool
fieldIsNullable = forall a. Nullable a => a -> Bool
isNullable TypeWrapper
typeWrappers,
wrappers :: [FIELD_TYPE_WRAPPER]
wrappers =
[FIELD_TYPE_WRAPPER]
args
forall a. Semigroup a => a -> a -> a
<> [Name -> FIELD_TYPE_WRAPPER
SUBSCRIPTION ''SubscriptionField | forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TypeKind -> Bool
isSubscription Maybe TypeKind
kind forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Bool
True]
forall a. Semigroup a => a -> a -> a
<> [FIELD_TYPE_WRAPPER
MONAD]
forall a. Semigroup a => a -> a -> a
<> [TypeWrapper -> FIELD_TYPE_WRAPPER
GQL_WRAPPER TypeWrapper
typeWrappers]
forall a. Semigroup a => a -> a -> a
<> [FIELD_TYPE_WRAPPER
PARAMETRIZED | Bool
isParametrized],
FieldName
fieldName :: FieldName
fieldName :: FieldName
..
}
mkFieldArguments :: CodeGenM m => FieldName -> (FieldName -> TypeName) -> [ArgumentDefinition s] -> m [FIELD_TYPE_WRAPPER]
mkFieldArguments :: forall (m :: * -> *) (s :: Stage).
CodeGenM m =>
FieldName
-> (FieldName -> TypeName)
-> [ArgumentDefinition s]
-> m [FIELD_TYPE_WRAPPER]
mkFieldArguments FieldName
_ FieldName -> TypeName
_ [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
mkFieldArguments
FieldName
_
FieldName -> TypeName
_
[ ArgumentDefinition FieldDefinition {FieldName
fieldName :: FieldName
fieldName :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldName, TypeRef
fieldType :: TypeRef
fieldType :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> TypeRef
fieldType}
] =
forall (m :: * -> *). CodeGenM m => TypeName -> m ()
checkTypeExistence (TypeRef -> TypeName
typeConName TypeRef
fieldType)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *). MonadState Flags m => Text -> m ()
langExtension Text
"DataKinds" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> [Name -> FieldName -> TypeRef -> FIELD_TYPE_WRAPPER
TAGGED_ARG ''Arg FieldName
fieldName TypeRef
fieldType]
mkFieldArguments FieldName
fName FieldName -> TypeName
genName [ArgumentDefinition s]
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure [TypeName -> FIELD_TYPE_WRAPPER
ARG (FieldName -> TypeName
genName FieldName
fName)]
toArgList :: Maybe (FieldContent bool cat s) -> [ArgumentDefinition s]
toArgList :: forall (bool :: Bool) (cat :: TypeCategory) (s :: Stage).
Maybe (FieldContent bool cat s) -> [ArgumentDefinition s]
toArgList (Just (FieldArgs ArgumentsDefinition s
args)) = forall (t :: * -> *) a. Foldable t => t a -> [a]
toList ArgumentsDefinition s
args
toArgList Maybe (FieldContent bool cat s)
_ = []
data BuildPlan
= ConsIN [CodeGenConstructor]
| ConsOUT [ServerDeclaration] [CodeGenConstructor]
gqlTypeToInstance :: GQLTypeDefinition -> ServerDeclaration
gqlTypeToInstance :: GQLTypeDefinition -> ServerDeclaration
gqlTypeToInstance GQLTypeDefinition {[ServerDirectiveUsage]
CodeGenTypeName
Kind
gqlTypeDirectiveUses :: [ServerDirectiveUsage]
gqlKind :: Kind
gqlTarget :: CodeGenTypeName
gqlTypeDirectiveUses :: GQLTypeDefinition -> [ServerDirectiveUsage]
gqlKind :: GQLTypeDefinition -> Kind
gqlTarget :: GQLTypeDefinition -> CodeGenTypeName
..} =
Kind -> TypeClassInstance ServerMethod -> ServerDeclaration
GQLTypeInstance
Kind
gqlKind
TypeClassInstance
{ typeClassName :: Name
typeClassName = ''GQLType,
typeClassContext :: [(Name, Name)]
typeClassContext = forall a b. (a -> b) -> [a] -> [b]
map ((''Typeable,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToName a => a -> Name
toName) (CodeGenTypeName -> [Text]
typeParameters CodeGenTypeName
gqlTarget),
typeClassTarget :: CodeGenTypeName
typeClassTarget = CodeGenTypeName
gqlTarget,
assoc :: [(Name, AssociatedType)]
assoc = [(''KIND, Name -> AssociatedType
AssociatedTypeName (forall a. ToName a => a -> Name
toName Kind
gqlKind))],
typeClassMethods :: [(Name, MethodArgument, ServerMethod)]
typeClassMethods =
[ ('directives, MethodArgument
ProxyArgument, [ServerDirectiveUsage] -> ServerMethod
ServerMethodDirectives [ServerDirectiveUsage]
gqlTypeDirectiveUses)
| Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ServerDirectiveUsage]
gqlTypeDirectiveUses)
]
}
genInterfaceUnion :: CodeGenM m => TypeName -> m [ServerDeclaration]
genInterfaceUnion :: forall (m :: * -> *).
CodeGenM m =>
TypeName -> m [ServerDeclaration]
genInterfaceUnion TypeName
interfaceName =
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ServerCodeGenContext -> [TypeDefinition ANY CONST]
typeDefinitions forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [TypeName] -> m [ServerDeclaration]
mkInterface forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall (c :: TypeCategory) (s :: Stage).
TypeName -> TypeDefinition c s -> Maybe (TypeDefinition c s)
isPossibleInterfaceType TypeName
interfaceName)
where
mkInterface :: [TypeName] -> m [ServerDeclaration]
mkInterface [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
mkInterface [TypeName
possibleTypeName] = forall (f :: * -> *) a. Applicative f => a -> f a
pure [TypeName -> ServerDeclaration
mkGuardWithPossibleType TypeName
possibleTypeName]
mkInterface [TypeName]
members = do
[CodeGenConstructor]
cgConstructors <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (m :: * -> *).
CodeGenM m =>
TypeName -> TypeName -> m CodeGenConstructor
mkUnionFieldDefinition TypeName
tName) [TypeName]
members
forall (f :: * -> *) a. Applicative f => a -> f a
pure
[ TypeName -> ServerDeclaration
mkGuardWithPossibleType TypeName
tName,
CodeGenType -> ServerDeclaration
DataType
CodeGenType
{ cgTypeName :: CodeGenTypeName
cgTypeName = CodeGenTypeName
possTypeName,
[CodeGenConstructor]
cgConstructors :: [CodeGenConstructor]
cgConstructors :: [CodeGenConstructor]
cgConstructors,
cgDerivations :: [DerivingClass]
cgDerivations = Bool -> [DerivingClass]
derivesClasses Bool
True
},
GQLTypeDefinition -> ServerDeclaration
gqlTypeToInstance
GQLTypeDefinition
{ gqlTarget :: CodeGenTypeName
gqlTarget = CodeGenTypeName
possTypeName,
gqlKind :: Kind
gqlKind = Kind
Type,
gqlTypeDirectiveUses :: [ServerDirectiveUsage]
gqlTypeDirectiveUses = forall (f :: * -> *) a. Alternative f => f a
empty
}
]
where
possTypeName :: CodeGenTypeName
possTypeName = [FieldName] -> [Text] -> TypeName -> CodeGenTypeName
CodeGenTypeName [] [Text
"m"] (forall a (t :: NAME). NamePacking a => a -> Name t
packName forall a b. (a -> b) -> a -> b
$ TypeName -> Text
toHaskellTypeName TypeName
tName)
mkGuardWithPossibleType :: TypeName -> ServerDeclaration
mkGuardWithPossibleType = InterfaceDefinition -> ServerDeclaration
InterfaceType forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeName -> TypeName -> TypeName -> InterfaceDefinition
InterfaceDefinition TypeName
interfaceName (TypeName -> TypeName
mkInterfaceName TypeName
interfaceName)
tName :: TypeName
tName = TypeName -> TypeName
mkPossibleTypesName TypeName
interfaceName
mkConsEnum :: CodeGenM m => DataEnumValue CONST -> m CodeGenConstructor
mkConsEnum :: forall (m :: * -> *).
CodeGenM m =>
DataEnumValue CONST -> m CodeGenConstructor
mkConsEnum DataEnumValue {TypeName
enumName :: forall (s :: Stage). DataEnumValue s -> TypeName
enumName :: TypeName
enumName} = do
CodeGenTypeName
constructorName <- forall (m :: * -> *).
MonadReader ServerCodeGenContext m =>
TypeName -> m CodeGenTypeName
getEnumName TypeName
enumName
forall (f :: * -> *) a. Applicative f => a -> f a
pure CodeGenConstructor {CodeGenTypeName
constructorName :: CodeGenTypeName
constructorName :: CodeGenTypeName
constructorName, constructorFields :: [CodeGenField]
constructorFields = []}
renderDataField :: CodeGenM m => FieldDefinition c CONST -> m CodeGenField
renderDataField :: forall (m :: * -> *) (c :: TypeCategory).
CodeGenM m =>
FieldDefinition c CONST -> m CodeGenField
renderDataField FieldDefinition {fieldType :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> TypeRef
fieldType = TypeRef {TypeName
typeConName :: TypeName
typeConName :: TypeRef -> TypeName
typeConName, TypeWrapper
typeWrappers :: TypeWrapper
typeWrappers :: TypeRef -> TypeWrapper
typeWrappers}, fieldName :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldName = FieldName
fName} = do
FieldName
fieldName <- forall (m :: * -> *). CodeGenM m => FieldName -> m FieldName
getFieldName FieldName
fName
let wrappers :: [FIELD_TYPE_WRAPPER]
wrappers = [TypeWrapper -> FIELD_TYPE_WRAPPER
GQL_WRAPPER TypeWrapper
typeWrappers]
TypeName
fieldType <- forall (m :: * -> *). CodeGenM m => TypeName -> m TypeName
getFieldTypeName TypeName
typeConName
let fieldIsNullable :: Bool
fieldIsNullable = forall a. Nullable a => a -> Bool
isNullable TypeWrapper
typeWrappers
forall (f :: * -> *) a. Applicative f => a -> f a
pure CodeGenField {Bool
[FIELD_TYPE_WRAPPER]
FieldName
TypeName
fieldIsNullable :: Bool
fieldType :: TypeName
wrappers :: [FIELD_TYPE_WRAPPER]
fieldName :: FieldName
fieldName :: FieldName
wrappers :: [FIELD_TYPE_WRAPPER]
fieldIsNullable :: Bool
fieldType :: TypeName
..}
genTypeContent :: CodeGenM m => TypeName -> TypeContent TRUE ANY CONST -> m BuildPlan
genTypeContent :: forall (m :: * -> *).
CodeGenM m =>
TypeName -> TypeContent TRUE ANY CONST -> m BuildPlan
genTypeContent TypeName
_ DataScalar {} = forall (f :: * -> *) a. Applicative f => a -> f a
pure ([CodeGenConstructor] -> BuildPlan
ConsIN [])
genTypeContent TypeName
_ (DataEnum DataEnum CONST
tags) = [CodeGenConstructor] -> BuildPlan
ConsIN forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *).
CodeGenM m =>
DataEnumValue CONST -> m CodeGenConstructor
mkConsEnum DataEnum CONST
tags
genTypeContent TypeName
typeName (DataInputObject FieldsDefinition IN CONST
fields) =
[CodeGenConstructor] -> BuildPlan
ConsIN forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeName -> [CodeGenField] -> [CodeGenConstructor]
mkObjectCons TypeName
typeName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *) (c :: TypeCategory).
CodeGenM m =>
FieldDefinition c CONST -> m CodeGenField
renderDataField (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList FieldsDefinition IN CONST
fields)
genTypeContent TypeName
_ DataInputUnion {} = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Input Unions not Supported"
genTypeContent TypeName
typeName DataInterface {FieldsDefinition OUT CONST
interfaceFields :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent IMPLEMENTABLE a s -> FieldsDefinition OUT s
interfaceFields :: FieldsDefinition OUT CONST
interfaceFields} =
[ServerDeclaration] -> [CodeGenConstructor] -> BuildPlan
ConsOUT
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Semigroup a => a -> a -> a
(<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
CodeGenM m =>
FieldsDefinition OUT CONST -> m [ServerDeclaration]
genArgumentTypes FieldsDefinition OUT CONST
interfaceFields forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *).
CodeGenM m =>
TypeName -> m [ServerDeclaration]
genInterfaceUnion TypeName
typeName)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ( do
let interfaceName :: TypeName
interfaceName = TypeName -> TypeName
mkInterfaceName TypeName
typeName
forall (m :: * -> *) a.
MonadReader ServerCodeGenContext m =>
Maybe TypeName -> m a -> m a
inType
(forall a. a -> Maybe a
Just TypeName
interfaceName)
( TypeName -> [CodeGenField] -> [CodeGenConstructor]
mkObjectCons TypeName
interfaceName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *).
CodeGenM m =>
FieldDefinition OUT CONST -> m CodeGenField
mkObjectField (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList FieldsDefinition OUT CONST
interfaceFields)
)
)
genTypeContent TypeName
typeName DataObject {FieldsDefinition OUT CONST
objectFields :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent OBJECT a s -> FieldsDefinition OUT s
objectFields :: FieldsDefinition OUT CONST
objectFields} =
[ServerDeclaration] -> [CodeGenConstructor] -> BuildPlan
ConsOUT
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
CodeGenM m =>
FieldsDefinition OUT CONST -> m [ServerDeclaration]
genArgumentTypes FieldsDefinition OUT CONST
objectFields
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ( TypeName -> [CodeGenField] -> [CodeGenConstructor]
mkObjectCons TypeName
typeName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *).
CodeGenM m =>
FieldDefinition OUT CONST -> m CodeGenField
mkObjectField (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList FieldsDefinition OUT CONST
objectFields)
)
genTypeContent TypeName
typeName (DataUnion UnionTypeDefinition OUT CONST
members) = do
[ServerDeclaration] -> [CodeGenConstructor] -> BuildPlan
ConsOUT [] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse UnionMember OUT CONST -> m CodeGenConstructor
unionCon (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList UnionTypeDefinition OUT CONST
members)
where
unionCon :: UnionMember OUT CONST -> m CodeGenConstructor
unionCon UnionMember {TypeName
memberName :: forall (cat :: TypeCategory) (s :: Stage).
UnionMember cat s -> TypeName
memberName :: TypeName
memberName} = forall (m :: * -> *).
CodeGenM m =>
TypeName -> TypeName -> m CodeGenConstructor
mkUnionFieldDefinition TypeName
typeName TypeName
memberName
mkUnionFieldDefinition :: CodeGenM m => TypeName -> TypeName -> m CodeGenConstructor
mkUnionFieldDefinition :: forall (m :: * -> *).
CodeGenM m =>
TypeName -> TypeName -> m CodeGenConstructor
mkUnionFieldDefinition TypeName
typeName TypeName
memberName = do
TypeName
fieldType <- forall (m :: * -> *). CodeGenM m => TypeName -> m TypeName
getFieldTypeName TypeName
memberName
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
CodeGenConstructor
{ CodeGenTypeName
constructorName :: CodeGenTypeName
constructorName :: CodeGenTypeName
constructorName,
constructorFields :: [CodeGenField]
constructorFields =
[ CodeGenField
{ fieldName :: FieldName
fieldName = FieldName
"_",
TypeName
fieldType :: TypeName
fieldType :: TypeName
fieldType,
wrappers :: [FIELD_TYPE_WRAPPER]
wrappers = [FIELD_TYPE_WRAPPER
MONAD, FIELD_TYPE_WRAPPER
PARAMETRIZED],
fieldIsNullable :: Bool
fieldIsNullable = Bool
False
}
]
}
where
constructorName :: CodeGenTypeName
constructorName = [FieldName] -> [Text] -> TypeName -> CodeGenTypeName
CodeGenTypeName [coerce :: forall a b. Coercible a b => a -> b
coerce TypeName
typeName] [] TypeName
memberName
genArgumentTypes :: CodeGenM m => FieldsDefinition OUT CONST -> m [ServerDeclaration]
genArgumentTypes :: forall (m :: * -> *).
CodeGenM m =>
FieldsDefinition OUT CONST -> m [ServerDeclaration]
genArgumentTypes = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *).
CodeGenM m =>
FieldDefinition OUT CONST -> m [ServerDeclaration]
genArgumentType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
genArgumentType :: CodeGenM m => FieldDefinition OUT CONST -> m [ServerDeclaration]
genArgumentType :: forall (m :: * -> *).
CodeGenM m =>
FieldDefinition OUT CONST -> m [ServerDeclaration]
genArgumentType
FieldDefinition
{ FieldName
fieldName :: FieldName
fieldName :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldName,
fieldContent :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Maybe (FieldContent TRUE cat s)
fieldContent = Just (FieldArgs ArgumentsDefinition CONST
arguments)
}
| forall (t :: * -> *) a. Foldable t => t a -> Int
length ArgumentsDefinition CONST
arguments forall a. Ord a => a -> a -> Bool
> Int
1 = do
TypeName
tName <- (FieldName
fieldName forall a b. a -> (a -> b) -> b
&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ServerCodeGenContext -> FieldName -> TypeName
toArgsTypeName
forall (m :: * -> *) a.
MonadReader ServerCodeGenContext m =>
Maybe TypeName -> m a -> m a
inType (forall a. a -> Maybe a
Just TypeName
tName) forall a b. (a -> b) -> a -> b
$ do
let argumentFields :: [FieldDefinition IN CONST]
argumentFields = forall (s :: Stage). ArgumentDefinition s -> FieldDefinition IN s
argument forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a. Foldable t => t a -> [a]
toList ArgumentsDefinition CONST
arguments
[CodeGenField]
fields <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *) (c :: TypeCategory).
CodeGenM m =>
FieldDefinition c CONST -> m CodeGenField
renderDataField [FieldDefinition IN CONST]
argumentFields
let typename :: Text
typename = TypeName -> Text
toHaskellTypeName TypeName
tName
[ServerDirectiveUsage]
namespaceDirs <- forall (m :: * -> *).
CodeGenM m =>
Text -> m [ServerDirectiveUsage]
getNamespaceDirs Text
typename
[ServerDirectiveUsage]
dirs <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *) a.
(CodeGenM m, Meta a) =>
a -> m [ServerDirectiveUsage]
getDirectives [FieldDefinition IN CONST]
argumentFields
let cgTypeName :: CodeGenTypeName
cgTypeName = TypeName -> CodeGenTypeName
fromTypeName (forall a (t :: NAME). NamePacking a => a -> Name t
packName Text
typename)
[ServerDirectiveUsage]
defaultValueDirs <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *) (c :: TypeCategory).
CodeGenM m =>
FieldDefinition c CONST -> m [ServerDirectiveUsage]
getDefaultValueDir [FieldDefinition IN CONST]
argumentFields
forall (f :: * -> *) a. Applicative f => a -> f a
pure
[ CodeGenType -> ServerDeclaration
DataType
CodeGenType
{ CodeGenTypeName
cgTypeName :: CodeGenTypeName
cgTypeName :: CodeGenTypeName
cgTypeName,
cgConstructors :: [CodeGenConstructor]
cgConstructors = TypeName -> [CodeGenField] -> [CodeGenConstructor]
mkObjectCons TypeName
tName [CodeGenField]
fields,
cgDerivations :: [DerivingClass]
cgDerivations = Bool -> [DerivingClass]
derivesClasses Bool
False
},
GQLTypeDefinition -> ServerDeclaration
gqlTypeToInstance
GQLTypeDefinition
{ gqlTarget :: CodeGenTypeName
gqlTarget = CodeGenTypeName
cgTypeName,
gqlKind :: Kind
gqlKind = Kind
Type,
gqlTypeDirectiveUses :: [ServerDirectiveUsage]
gqlTypeDirectiveUses = [ServerDirectiveUsage]
namespaceDirs forall a. Semigroup a => a -> a -> a
<> [ServerDirectiveUsage]
dirs forall a. Semigroup a => a -> a -> a
<> [ServerDirectiveUsage]
defaultValueDirs
}
]
genArgumentType FieldDefinition OUT CONST
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
getInputFields :: TypeDefinition c s -> [FieldDefinition IN s]
getInputFields :: forall (c :: TypeCategory) (s :: Stage).
TypeDefinition c s -> [FieldDefinition IN s]
getInputFields TypeDefinition {typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent = DataInputObject {FieldsDefinition IN s
inputObjectFields :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent INPUT_OBJECT a s -> FieldsDefinition IN s
inputObjectFields :: FieldsDefinition IN s
inputObjectFields}} = forall (t :: * -> *) a. Foldable t => t a -> [a]
toList FieldsDefinition IN s
inputObjectFields
getInputFields TypeDefinition c s
_ = []