{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Data.Morpheus.CodeGen.Interpreting.Transform
( parseServerTypeDefinitions,
)
where
import Data.ByteString.Lazy.Char8 (ByteString)
import Data.Morpheus.CodeGen.Internal.AST
( CodeGenConfig (..),
DerivingClass (..),
FIELD_TYPE_WRAPPER (..),
GQLTypeDefinition (..),
Kind (..),
ServerConstructorDefinition (..),
ServerDirectiveUsage (..),
ServerFieldDefinition (..),
ServerTypeDefinition (..),
TypeValue (..),
)
import Data.Morpheus.CodeGen.Internal.Name
( camelCaseFieldName,
toHaskellTypeName,
)
import Data.Morpheus.CodeGen.Internal.TH
( ToName (toName),
camelCaseTypeName,
)
import Data.Morpheus.Core (internalSchema, parseDefinitions, render)
import Data.Morpheus.Error (gqlWarnings, renderGQLErrors)
import Data.Morpheus.Internal.Ext (GQLResult, Result (..))
import Data.Morpheus.Internal.Utils (IsMap, selectOr)
import Data.Morpheus.Types.Internal.AST
( ANY,
Argument (..),
ArgumentDefinition (..),
CONST,
DataEnumValue (..),
Description,
Directive (Directive, directiveArgs, directiveName),
DirectiveDefinition (..),
FieldContent (..),
FieldDefinition (..),
FieldName,
FieldsDefinition,
GQLError,
IN,
OUT,
ObjectEntry (..),
OperationType (Subscription),
RawTypeDefinition (..),
TRUE,
Token,
TypeContent (..),
TypeDefinition (..),
TypeKind (..),
TypeName,
TypeRef (..),
UnionMember (..),
isPossibleInterfaceType,
isResolverType,
kindOf,
lookupWith,
unpackName,
)
import qualified Data.Morpheus.Types.Internal.AST as AST
import qualified Data.Morpheus.Types.Internal.AST as V
import Language.Haskell.TH
( Dec (..),
Info (..),
Q,
TyVarBndr,
reify,
)
import Relude hiding (ByteString, get)
type ServerQ m = ReaderT (TypeContext CONST) m
class (Monad m, MonadFail m) => CodeGenMonad m where
isParametrizedType :: TypeName -> m Bool
printWarnings :: [GQLError] -> m ()
isParametrizedHaskellType :: Info -> Bool
isParametrizedHaskellType :: Info -> Bool
isParametrizedHaskellType (TyConI Dec
x) = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ Dec -> [TyVarBndr ()]
getTypeVariables Dec
x
isParametrizedHaskellType Info
_ = Bool
False
#if MIN_VERSION_template_haskell(2,17,0)
getTypeVariables :: Dec -> [TyVarBndr ()]
#else
getTypeVariables :: Dec -> [TyVarBndr]
#endif
getTypeVariables :: Dec -> [TyVarBndr ()]
getTypeVariables (DataD Cxt
_ Name
_ [TyVarBndr ()]
args Maybe Kind
_ [Con]
_ [DerivClause]
_) = [TyVarBndr ()]
args
getTypeVariables (NewtypeD Cxt
_ Name
_ [TyVarBndr ()]
args Maybe Kind
_ Con
_ [DerivClause]
_) = [TyVarBndr ()]
args
getTypeVariables (TySynD Name
_ [TyVarBndr ()]
args Kind
_) = [TyVarBndr ()]
args
getTypeVariables Dec
_ = []
instance CodeGenMonad Q where
isParametrizedType :: TypeName -> Q Bool
isParametrizedType TypeName
name = Info -> Bool
isParametrizedHaskellType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q Info
reify (forall a. ToName a => a -> Name
toName TypeName
name)
printWarnings :: [GQLError] -> Q ()
printWarnings = [GQLError] -> Q ()
gqlWarnings
instance CodeGenMonad GQLResult where
isParametrizedType :: TypeName -> GQLResult Bool
isParametrizedType TypeName
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
printWarnings :: [GQLError] -> GQLResult ()
printWarnings [GQLError]
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
data TypeContext s = TypeContext
{ forall (s :: Stage). TypeContext s -> FieldName -> TypeName
toArgsTypeName :: FieldName -> TypeName,
forall (s :: Stage). TypeContext s -> [TypeDefinition ANY s]
typeDefinitions :: [TypeDefinition ANY s],
forall (s :: Stage). TypeContext s -> [DirectiveDefinition s]
directiveDefinitions :: [DirectiveDefinition s],
forall (s :: Stage). TypeContext s -> Maybe TypeName
currentTypeName :: Maybe TypeName,
forall (s :: Stage). TypeContext s -> Maybe TypeKind
currentKind :: Maybe TypeKind,
forall (s :: Stage). TypeContext s -> Bool
hasNamespace :: Bool
}
parseServerTypeDefinitions :: CodeGenMonad m => CodeGenConfig -> ByteString -> m [ServerTypeDefinition]
parseServerTypeDefinitions :: forall (m :: * -> *).
CodeGenMonad m =>
CodeGenConfig -> ByteString -> m [ServerTypeDefinition]
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 [ServerTypeDefinition]
toTHDefinitions (CodeGenConfig -> Bool
namespace CodeGenConfig
ctx) [RawTypeDefinition]
result
toTHDefinitions ::
CodeGenMonad m =>
Bool ->
[RawTypeDefinition] ->
m [ServerTypeDefinition]
toTHDefinitions :: forall (m :: * -> *).
CodeGenMonad m =>
Bool -> [RawTypeDefinition] -> m [ServerTypeDefinition]
toTHDefinitions Bool
namespace [RawTypeDefinition]
defs = 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 :: * -> *).
CodeGenMonad m =>
RawTypeDefinition -> m [ServerTypeDefinition]
generateTypes [RawTypeDefinition]
defs
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 [ServerTypeDefinition]
generateTypes :: forall (m :: * -> *).
CodeGenMonad m =>
RawTypeDefinition -> m [ServerTypeDefinition]
generateTypes (RawTypeDefinition TypeDefinition ANY CONST
typeDef) =
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT
(forall (m :: * -> *).
CodeGenMonad m =>
TypeDefinition ANY CONST -> ServerQ m [ServerTypeDefinition]
genTypeDefinition TypeDefinition ANY CONST
typeDef)
TypeContext
{ 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 :: 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 r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT
( do
[ServerFieldDefinition]
fields <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *) (c :: TypeCategory).
Monad m =>
FieldDefinition c CONST -> ServerQ m ServerFieldDefinition
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)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
[ DirectiveTypeDefinition
{ directiveConstructor :: ServerConstructorDefinition
directiveConstructor = TypeName -> [ServerFieldDefinition] -> ServerConstructorDefinition
ServerConstructorDefinition (coerce :: forall a b. Coercible a b => a -> b
coerce FieldName
directiveDefinitionName) [ServerFieldDefinition]
fields,
directiveDerives :: [DerivingClass]
directiveDerives = [DerivingClass
SHOW, DerivingClass
GENERIC],
directiveLocations :: [DirectiveLocation]
directiveLocations = [DirectiveLocation]
directiveDefinitionLocations,
directiveGQLType :: GQLTypeDefinition
directiveGQLType =
GQLTypeDefinition
{ gqlKind :: Kind
gqlKind = Kind
Type,
gqlTypeDescription :: Maybe Text
gqlTypeDescription = forall a. Maybe a
Nothing,
gqlTypeDescriptions :: Map Text Text
gqlTypeDescriptions = forall a. Monoid a => a
mempty,
gqlTypeDefaultValues :: Map Text (Value CONST)
gqlTypeDefaultValues = forall a. Monoid a => a
mempty,
gqlTypeDirectiveUses :: [ServerDirectiveUsage]
gqlTypeDirectiveUses = []
}
}
]
)
TypeContext
{ 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 []
inType :: MonadReader (TypeContext s) m => Maybe TypeName -> m a -> m a
inType :: forall (s :: Stage) (m :: * -> *) a.
MonadReader (TypeContext s) m =>
Maybe TypeName -> m a -> m a
inType Maybe TypeName
name = forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\TypeContext s
x -> TypeContext s
x {currentTypeName :: Maybe TypeName
currentTypeName = Maybe TypeName
name, currentKind :: Maybe TypeKind
currentKind = forall a. Maybe a
Nothing})
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 ::
CodeGenMonad m =>
TypeDefinition ANY CONST ->
ServerQ m [ServerTypeDefinition]
genTypeDefinition :: forall (m :: * -> *).
CodeGenMonad m =>
TypeDefinition ANY CONST -> ServerQ m [ServerTypeDefinition]
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,
Maybe Text
typeDescription :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Maybe Text
typeDescription :: Maybe Text
typeDescription
} = forall (m :: * -> *).
CodeGenMonad m =>
TypeName -> TypeContent TRUE ANY CONST -> ServerQ m BuildPlan
genTypeContent TypeName
originalTypeName TypeContent TRUE ANY CONST
typeContent forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BuildPlan -> ReaderT (TypeContext CONST) m [ServerTypeDefinition]
withType
where
typeName :: TypeName
typeName = case TypeContent TRUE ANY CONST
typeContent of
DataInterface {} -> TypeName -> TypeName
mkInterfaceName TypeName
originalTypeName
TypeContent TRUE ANY CONST
_ -> TypeName
originalTypeName
tKind :: TypeKind
tKind = forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeKind
kindOf TypeDefinition ANY CONST
typeDef
tName :: Text
tName = TypeName -> Text
toHaskellTypeName TypeName
typeName
deriveGQL :: ReaderT (TypeContext CONST) m (Maybe GQLTypeDefinition)
deriveGQL = do
Map Text Text
gqlTypeDescriptions <- forall (m :: * -> *) (c :: TypeCategory).
MonadFail m =>
TypeDefinition c CONST -> ServerQ m (Map Text Text)
getDesc TypeDefinition ANY CONST
typeDef
[ServerDirectiveUsage]
gqlTypeDirectiveUses <- forall (m :: * -> *) (c :: TypeCategory).
MonadFail m =>
TypeDefinition c CONST -> ServerQ m [ServerDirectiveUsage]
getDirs TypeDefinition ANY CONST
typeDef
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
forall a. a -> Maybe a
Just
GQLTypeDefinition
{ gqlTypeDescription :: Maybe Text
gqlTypeDescription = Maybe Text
typeDescription,
Map Text Text
gqlTypeDescriptions :: Map Text Text
gqlTypeDescriptions :: Map Text Text
gqlTypeDescriptions,
[ServerDirectiveUsage]
gqlTypeDirectiveUses :: [ServerDirectiveUsage]
gqlTypeDirectiveUses :: [ServerDirectiveUsage]
gqlTypeDirectiveUses,
gqlKind :: Kind
gqlKind = TypeKind -> Kind
derivingKind TypeKind
tKind,
gqlTypeDefaultValues :: Map Text (Value CONST)
gqlTypeDefaultValues =
forall l. IsList l => [Item l] -> l
fromList forall a b. (a -> b) -> a -> b
$
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall (c :: TypeCategory) (s :: Stage).
FieldDefinition c s -> Maybe (Text, Value s)
getDefaultValue forall a b. (a -> b) -> a -> b
$
forall (c :: TypeCategory) (s :: Stage).
TypeDefinition c s -> [FieldDefinition IN s]
getInputFields TypeDefinition ANY CONST
typeDef
}
typeParameters :: [Text]
typeParameters
| forall t. Strictness t => t -> Bool
isResolverType TypeKind
tKind = [Text
"m"]
| Bool
otherwise = []
derives :: [DerivingClass]
derives = Bool -> [DerivingClass]
derivesClasses (forall t. Strictness t => t -> Bool
isResolverType TypeKind
tKind)
withType :: BuildPlan -> ReaderT (TypeContext CONST) m [ServerTypeDefinition]
withType (ConsIN [ServerConstructorDefinition]
tCons) = do
Maybe GQLTypeDefinition
typeGQLType <- ReaderT (TypeContext CONST) m (Maybe GQLTypeDefinition)
deriveGQL
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ServerTypeDefinition {[Text]
[ServerConstructorDefinition]
[DerivingClass]
Maybe GQLTypeDefinition
Text
TypeKind
typeGQLType :: Maybe GQLTypeDefinition
derives :: [DerivingClass]
tKind :: TypeKind
tCons :: [ServerConstructorDefinition]
typeParameters :: [Text]
tName :: Text
typeGQLType :: Maybe GQLTypeDefinition
tCons :: [ServerConstructorDefinition]
derives :: [DerivingClass]
typeParameters :: [Text]
tName :: Text
tKind :: TypeKind
..}]
withType (ConsOUT [ServerTypeDefinition]
others [ServerConstructorDefinition]
tCons) = do
Maybe GQLTypeDefinition
typeGQLType <- ReaderT (TypeContext CONST) m (Maybe GQLTypeDefinition)
deriveGQL
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ServerTypeDefinition {[Text]
[ServerConstructorDefinition]
[DerivingClass]
Maybe GQLTypeDefinition
Text
TypeKind
typeGQLType :: Maybe GQLTypeDefinition
tCons :: [ServerConstructorDefinition]
typeGQLType :: Maybe GQLTypeDefinition
derives :: [DerivingClass]
tKind :: TypeKind
tCons :: [ServerConstructorDefinition]
typeParameters :: [Text]
tName :: Text
derives :: [DerivingClass]
typeParameters :: [Text]
tName :: Text
tKind :: TypeKind
..} forall a. a -> [a] -> [a]
: [ServerTypeDefinition]
others)
derivingKind :: TypeKind -> Kind
derivingKind :: TypeKind -> Kind
derivingKind TypeKind
KindScalar = 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 -> [ServerFieldDefinition] -> [ServerConstructorDefinition]
mkObjectCons :: TypeName
-> [ServerFieldDefinition] -> [ServerConstructorDefinition]
mkObjectCons TypeName
name = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeName -> [ServerFieldDefinition] -> ServerConstructorDefinition
ServerConstructorDefinition 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"
isParametrizedResolverType :: CodeGenMonad m => TypeName -> [TypeDefinition ANY s] -> m Bool
isParametrizedResolverType :: forall (m :: * -> *) (s :: Stage).
CodeGenMonad m =>
TypeName -> [TypeDefinition ANY s] -> m Bool
isParametrizedResolverType TypeName
"__TypeKind" [TypeDefinition ANY s]
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
isParametrizedResolverType TypeName
"Boolean" [TypeDefinition ANY s]
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
isParametrizedResolverType TypeName
"String" [TypeDefinition ANY s]
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
isParametrizedResolverType TypeName
"Int" [TypeDefinition ANY s]
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
isParametrizedResolverType TypeName
"Float" [TypeDefinition ANY s]
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
isParametrizedResolverType TypeName
name [TypeDefinition ANY s]
lib = case forall k a. Eq k => (a -> k) -> k -> [a] -> Maybe a
lookupWith forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName TypeName
name [TypeDefinition ANY s]
lib of
Just TypeDefinition ANY s
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall t. Strictness t => t -> Bool
isResolverType TypeDefinition ANY s
x)
Maybe (TypeDefinition ANY s)
Nothing -> forall (m :: * -> *). CodeGenMonad m => TypeName -> m Bool
isParametrizedType TypeName
name
isSubscription :: TypeKind -> Bool
isSubscription :: TypeKind -> Bool
isSubscription (KindObject (Just OperationType
Subscription)) = Bool
True
isSubscription TypeKind
_ = Bool
False
mkObjectField ::
CodeGenMonad m =>
FieldDefinition OUT CONST ->
ServerQ m ServerFieldDefinition
mkObjectField :: forall (m :: * -> *).
CodeGenMonad m =>
FieldDefinition OUT CONST -> ServerQ m ServerFieldDefinition
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 (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) (s :: Stage).
CodeGenMonad m =>
TypeName -> [TypeDefinition ANY s] -> m Bool
isParametrizedResolverType TypeName
typeConName forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall (s :: Stage). TypeContext s -> [TypeDefinition ANY s]
typeDefinitions
FieldName -> TypeName
genName <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall (s :: Stage). TypeContext s -> FieldName -> TypeName
toArgsTypeName
Maybe TypeKind
kind <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall (s :: Stage). TypeContext s -> Maybe TypeKind
currentKind
FieldName
fieldName <- forall (m :: * -> *). Monad m => FieldName -> ServerQ m FieldName
renderFieldName FieldName
fName
forall (f :: * -> *) a. Applicative f => a -> f a
pure
ServerFieldDefinition
{ fieldType :: Text
fieldType = TypeName -> Text
toHaskellTypeName TypeName
typeConName,
wrappers :: [FIELD_TYPE_WRAPPER]
wrappers =
forall (s :: Stage).
FieldName
-> (FieldName -> TypeName)
-> [ArgumentDefinition s]
-> [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)
forall a. Semigroup a => a -> a -> a
<> [FIELD_TYPE_WRAPPER
SUBSCRIPTION | 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 :: FieldName -> (FieldName -> TypeName) -> [ArgumentDefinition s] -> [FIELD_TYPE_WRAPPER]
mkFieldArguments :: forall (s :: Stage).
FieldName
-> (FieldName -> TypeName)
-> [ArgumentDefinition s]
-> [FIELD_TYPE_WRAPPER]
mkFieldArguments FieldName
_ FieldName -> TypeName
_ [] = []
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}
] = [FieldName -> TypeRef -> FIELD_TYPE_WRAPPER
TAGGED_ARG FieldName
fieldName TypeRef
fieldType]
mkFieldArguments FieldName
fName FieldName -> TypeName
genName [ArgumentDefinition s]
_ = [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 [ServerConstructorDefinition]
| ConsOUT [ServerTypeDefinition] [ServerConstructorDefinition]
genInterfaceUnion :: Monad m => TypeName -> ServerQ m [ServerTypeDefinition]
genInterfaceUnion :: forall (m :: * -> *).
Monad m =>
TypeName -> ServerQ m [ServerTypeDefinition]
genInterfaceUnion TypeName
interfaceName =
[TypeName] -> [ServerTypeDefinition]
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)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall (s :: Stage). TypeContext s -> [TypeDefinition ANY s]
typeDefinitions
where
tKind :: TypeKind
tKind = TypeKind
KindUnion
mkInterface :: [TypeName] -> [ServerTypeDefinition]
mkInterface [] = []
mkInterface [TypeName
possibleTypeName] = [TypeName -> ServerTypeDefinition
mkGuardWithPossibleType TypeName
possibleTypeName]
mkInterface [TypeName]
members =
[ TypeName -> ServerTypeDefinition
mkGuardWithPossibleType TypeName
tName,
ServerTypeDefinition
{ tName :: Text
tName = TypeName -> Text
toHaskellTypeName TypeName
tName,
tCons :: [ServerConstructorDefinition]
tCons = forall a b. (a -> b) -> [a] -> [b]
map (TypeName -> TypeName -> ServerConstructorDefinition
mkUnionFieldDefinition TypeName
tName) [TypeName]
members,
TypeKind
tKind :: TypeKind
tKind :: TypeKind
tKind,
typeParameters :: [Text]
typeParameters = [Text
"m"],
derives :: [DerivingClass]
derives = Bool -> [DerivingClass]
derivesClasses Bool
True,
typeGQLType :: Maybe GQLTypeDefinition
typeGQLType = forall a. Maybe a
Nothing
}
]
mkGuardWithPossibleType :: TypeName -> ServerTypeDefinition
mkGuardWithPossibleType = TypeName -> TypeName -> TypeName -> ServerTypeDefinition
ServerInterfaceDefinition TypeName
interfaceName (TypeName -> TypeName
mkInterfaceName TypeName
interfaceName)
tName :: TypeName
tName = TypeName -> TypeName
mkPossibleTypesName TypeName
interfaceName
renderFieldName :: Monad m => FieldName -> ServerQ m FieldName
renderFieldName :: forall (m :: * -> *). Monad m => FieldName -> ServerQ m FieldName
renderFieldName FieldName
fieldName = do
TypeContext {Bool
hasNamespace :: Bool
hasNamespace :: forall (s :: Stage). TypeContext s -> Bool
hasNamespace, Maybe TypeName
currentTypeName :: Maybe TypeName
currentTypeName :: forall (s :: Stage). TypeContext s -> Maybe TypeName
currentTypeName} <- forall r (m :: * -> *). MonadReader r m => m r
ask
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
if Bool
hasNamespace
then forall b a. b -> (a -> b) -> Maybe a -> b
maybe FieldName
fieldName (TypeName -> FieldName -> FieldName
`camelCaseFieldName` FieldName
fieldName) Maybe TypeName
currentTypeName
else FieldName
fieldName
mkConsEnum :: Monad m => TypeName -> DataEnumValue CONST -> ServerQ m ServerConstructorDefinition
mkConsEnum :: forall (m :: * -> *).
Monad m =>
TypeName
-> DataEnumValue CONST -> ServerQ m ServerConstructorDefinition
mkConsEnum TypeName
name DataEnumValue {TypeName
enumName :: forall (s :: Stage). DataEnumValue s -> TypeName
enumName :: TypeName
enumName} = do
Bool
namespace <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall (s :: Stage). TypeContext s -> Bool
hasNamespace
forall (f :: * -> *) a. Applicative f => a -> f a
pure
ServerConstructorDefinition
{ constructorName :: TypeName
constructorName =
if Bool
namespace
then forall (t :: NAME). [Name t] -> TypeName -> TypeName
camelCaseTypeName [TypeName
name] TypeName
enumName
else TypeName
enumName,
constructorFields :: [ServerFieldDefinition]
constructorFields = []
}
renderDataField :: Monad m => FieldDefinition c CONST -> ServerQ m ServerFieldDefinition
renderDataField :: forall (m :: * -> *) (c :: TypeCategory).
Monad m =>
FieldDefinition c CONST -> ServerQ m ServerFieldDefinition
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 :: * -> *). Monad m => FieldName -> ServerQ m FieldName
renderFieldName FieldName
fName
let wrappers :: [FIELD_TYPE_WRAPPER]
wrappers = [TypeWrapper -> FIELD_TYPE_WRAPPER
GQL_WRAPPER TypeWrapper
typeWrappers]
let fieldType :: Text
fieldType = TypeName -> Text
toHaskellTypeName TypeName
typeConName
forall (f :: * -> *) a. Applicative f => a -> f a
pure ServerFieldDefinition {[FIELD_TYPE_WRAPPER]
Text
FieldName
fieldType :: Text
wrappers :: [FIELD_TYPE_WRAPPER]
fieldName :: FieldName
fieldName :: FieldName
wrappers :: [FIELD_TYPE_WRAPPER]
fieldType :: Text
..}
genTypeContent ::
CodeGenMonad m =>
TypeName ->
TypeContent TRUE ANY CONST ->
ServerQ m BuildPlan
genTypeContent :: forall (m :: * -> *).
CodeGenMonad m =>
TypeName -> TypeContent TRUE ANY CONST -> ServerQ m BuildPlan
genTypeContent TypeName
_ DataScalar {} = forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ServerConstructorDefinition] -> BuildPlan
ConsIN [])
genTypeContent TypeName
typeName (DataEnum DataEnum CONST
tags) = [ServerConstructorDefinition] -> 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 :: * -> *).
Monad m =>
TypeName
-> DataEnumValue CONST -> ServerQ m ServerConstructorDefinition
mkConsEnum TypeName
typeName) DataEnum CONST
tags
genTypeContent TypeName
typeName (DataInputObject FieldsDefinition IN CONST
fields) =
[ServerConstructorDefinition] -> BuildPlan
ConsIN forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeName
-> [ServerFieldDefinition] -> [ServerConstructorDefinition]
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).
Monad m =>
FieldDefinition c CONST -> ServerQ m ServerFieldDefinition
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} =
[ServerTypeDefinition]
-> [ServerConstructorDefinition] -> 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 :: * -> *).
Monad m =>
FieldsDefinition OUT CONST -> ServerQ m [ServerTypeDefinition]
genArgumentTypes FieldsDefinition OUT CONST
interfaceFields forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *).
Monad m =>
TypeName -> ServerQ m [ServerTypeDefinition]
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 (s :: Stage) (m :: * -> *) a.
MonadReader (TypeContext s) m =>
Maybe TypeName -> m a -> m a
inType
(forall a. a -> Maybe a
Just TypeName
interfaceName)
( TypeName
-> [ServerFieldDefinition] -> [ServerConstructorDefinition]
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 :: * -> *).
CodeGenMonad m =>
FieldDefinition OUT CONST -> ServerQ m ServerFieldDefinition
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} =
[ServerTypeDefinition]
-> [ServerConstructorDefinition] -> BuildPlan
ConsOUT
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
Monad m =>
FieldsDefinition OUT CONST -> ServerQ m [ServerTypeDefinition]
genArgumentTypes FieldsDefinition OUT CONST
objectFields
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ( TypeName
-> [ServerFieldDefinition] -> [ServerConstructorDefinition]
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 :: * -> *).
CodeGenMonad m =>
FieldDefinition OUT CONST -> ServerQ m ServerFieldDefinition
mkObjectField (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList FieldsDefinition OUT CONST
objectFields)
)
genTypeContent TypeName
typeName (DataUnion UnionTypeDefinition OUT CONST
members) =
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [ServerTypeDefinition]
-> [ServerConstructorDefinition] -> BuildPlan
ConsOUT [] (UnionMember OUT CONST -> ServerConstructorDefinition
unionCon forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a. Foldable t => t a -> [a]
toList UnionTypeDefinition OUT CONST
members)
where
unionCon :: UnionMember OUT CONST -> ServerConstructorDefinition
unionCon UnionMember {TypeName
memberName :: forall (cat :: TypeCategory) (s :: Stage).
UnionMember cat s -> TypeName
memberName :: TypeName
memberName} = TypeName -> TypeName -> ServerConstructorDefinition
mkUnionFieldDefinition TypeName
typeName TypeName
memberName
mkUnionFieldDefinition :: TypeName -> TypeName -> ServerConstructorDefinition
mkUnionFieldDefinition :: TypeName -> TypeName -> ServerConstructorDefinition
mkUnionFieldDefinition TypeName
typeName TypeName
memberName =
ServerConstructorDefinition
{ TypeName
constructorName :: TypeName
constructorName :: TypeName
constructorName,
constructorFields :: [ServerFieldDefinition]
constructorFields =
[ ServerFieldDefinition
{ fieldName :: FieldName
fieldName = coerce :: forall a b. Coercible a b => a -> b
coerce (TypeName
"un" forall a. Semigroup a => a -> a -> a
<> TypeName
constructorName),
fieldType :: Text
fieldType = TypeName -> Text
toHaskellTypeName TypeName
memberName,
wrappers :: [FIELD_TYPE_WRAPPER]
wrappers = [FIELD_TYPE_WRAPPER
PARAMETRIZED]
}
]
}
where
constructorName :: TypeName
constructorName = forall (t :: NAME). [Name t] -> TypeName -> TypeName
camelCaseTypeName [TypeName
typeName] TypeName
memberName
genArgumentTypes :: Monad m => FieldsDefinition OUT CONST -> ServerQ m [ServerTypeDefinition]
genArgumentTypes :: forall (m :: * -> *).
Monad m =>
FieldsDefinition OUT CONST -> ServerQ m [ServerTypeDefinition]
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 :: * -> *).
Monad m =>
FieldDefinition OUT CONST -> ServerQ m [ServerTypeDefinition]
genArgumentType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
genArgumentType :: Monad m => FieldDefinition OUT CONST -> ServerQ m [ServerTypeDefinition]
genArgumentType :: forall (m :: * -> *).
Monad m =>
FieldDefinition OUT CONST -> ServerQ m [ServerTypeDefinition]
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 forall (s :: Stage). TypeContext s -> FieldName -> TypeName
toArgsTypeName
forall (s :: Stage) (m :: * -> *) a.
MonadReader (TypeContext s) 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
[ServerFieldDefinition]
fields <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *) (c :: TypeCategory).
Monad m =>
FieldDefinition c CONST -> ServerQ m ServerFieldDefinition
renderDataField [FieldDefinition IN CONST]
argumentFields
let tKind :: TypeKind
tKind = TypeKind
KindInputObject
forall (f :: * -> *) a. Applicative f => a -> f a
pure
[ ServerTypeDefinition
{ tName :: Text
tName = TypeName -> Text
toHaskellTypeName TypeName
tName,
TypeKind
tKind :: TypeKind
tKind :: TypeKind
tKind,
tCons :: [ServerConstructorDefinition]
tCons = TypeName
-> [ServerFieldDefinition] -> [ServerConstructorDefinition]
mkObjectCons TypeName
tName [ServerFieldDefinition]
fields,
derives :: [DerivingClass]
derives = Bool -> [DerivingClass]
derivesClasses Bool
False,
typeParameters :: [Text]
typeParameters = [],
typeGQLType :: Maybe GQLTypeDefinition
typeGQLType =
forall a. a -> Maybe a
Just
( GQLTypeDefinition
{ gqlKind :: Kind
gqlKind = Kind
Type,
gqlTypeDescription :: Maybe Text
gqlTypeDescription = forall a. Maybe a
Nothing,
gqlTypeDescriptions :: Map Text Text
gqlTypeDescriptions = forall l. IsList l => [Item l] -> l
fromList (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Maybe (Text, Text)
mkFieldDescription [FieldDefinition IN CONST]
argumentFields),
gqlTypeDefaultValues :: Map Text (Value CONST)
gqlTypeDefaultValues = forall l. IsList l => [Item l] -> l
fromList (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall (c :: TypeCategory) (s :: Stage).
FieldDefinition c s -> Maybe (Text, Value s)
getDefaultValue [FieldDefinition IN CONST]
argumentFields),
gqlTypeDirectiveUses :: [ServerDirectiveUsage]
gqlTypeDirectiveUses = []
}
)
}
]
genArgumentType FieldDefinition OUT CONST
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
mkFieldDescription :: FieldDefinition cat s -> Maybe (Text, Description)
mkFieldDescription :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Maybe (Text, Text)
mkFieldDescription FieldDefinition {Maybe Text
Maybe (FieldContent TRUE cat s)
TypeRef
FieldName
Directives s
fieldDescription :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Maybe Text
fieldDirectives :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Directives s
fieldDirectives :: Directives s
fieldContent :: Maybe (FieldContent TRUE cat s)
fieldType :: TypeRef
fieldName :: FieldName
fieldDescription :: Maybe Text
fieldType :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> TypeRef
fieldContent :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Maybe (FieldContent TRUE cat s)
fieldName :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
..} = (forall a (t :: NAME). NamePacking a => Name t -> a
unpackName FieldName
fieldName,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
fieldDescription
getDesc :: MonadFail m => TypeDefinition c CONST -> ServerQ m (Map Token Description)
getDesc :: forall (m :: * -> *) (c :: TypeCategory).
MonadFail m =>
TypeDefinition c CONST -> ServerQ m (Map Text Text)
getDesc = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall l. IsList l => [Item l] -> l
fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a v (m :: * -> *).
(Meta a v, MonadFail m) =>
a -> ServerQ m [(Text, v)]
get
getDirs :: MonadFail m => TypeDefinition c CONST -> ServerQ m [ServerDirectiveUsage]
getDirs :: forall (m :: * -> *) (c :: TypeCategory).
MonadFail m =>
TypeDefinition c CONST -> ServerQ m [ServerDirectiveUsage]
getDirs TypeDefinition c CONST
x = do
[ServerDirectiveUsage]
contentD <- forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a v (m :: * -> *).
(Meta a v, MonadFail m) =>
a -> ServerQ m [(Text, v)]
get TypeDefinition c CONST
x
[ServerDirectiveUsage]
typeD <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {m :: * -> *}.
MonadFail m =>
Directive CONST
-> ReaderT (TypeContext CONST) m ServerDirectiveUsage
transform (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Directives s
AST.typeDirectives TypeDefinition c CONST
x)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ServerDirectiveUsage]
contentD forall a. Semigroup a => a -> a -> a
<> [ServerDirectiveUsage]
typeD)
where
transform :: Directive CONST
-> ReaderT (TypeContext CONST) m ServerDirectiveUsage
transform Directive CONST
v = TypeValue -> ServerDirectiveUsage
TypeDirectiveUsage forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadFail m =>
Directive CONST -> ServerQ m TypeValue
directiveTypeValue Directive CONST
v
class Meta a v where
get :: MonadFail m => a -> ServerQ m [(Token, v)]
instance (Meta a v) => Meta (Maybe a) v where
get :: forall (m :: * -> *).
MonadFail m =>
Maybe a -> ServerQ m [(Text, v)]
get (Just a
x) = forall a v (m :: * -> *).
(Meta a v, MonadFail m) =>
a -> ServerQ m [(Text, v)]
get a
x
get Maybe a
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
instance
( Meta (FieldsDefinition IN s) v,
Meta (FieldsDefinition OUT s) v,
Meta (DataEnumValue s) v
) =>
Meta (TypeDefinition c s) v
where
get :: forall (m :: * -> *).
MonadFail m =>
TypeDefinition c s -> ServerQ m [(Text, v)]
get TypeDefinition {TypeContent TRUE c s
typeContent :: TypeContent TRUE c s
typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent} = forall a v (m :: * -> *).
(Meta a v, MonadFail m) =>
a -> ServerQ m [(Text, v)]
get TypeContent TRUE c s
typeContent
instance
( Meta (FieldsDefinition IN s) v,
Meta (FieldsDefinition OUT s) v,
Meta (DataEnumValue s) v
) =>
Meta (TypeContent a c s) v
where
get :: forall (m :: * -> *).
MonadFail m =>
TypeContent a c s -> ServerQ m [(Text, v)]
get DataObject {FieldsDefinition OUT s
objectFields :: FieldsDefinition OUT s
objectFields :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent OBJECT a s -> FieldsDefinition OUT s
objectFields} = forall a v (m :: * -> *).
(Meta a v, MonadFail m) =>
a -> ServerQ m [(Text, v)]
get FieldsDefinition OUT s
objectFields
get DataInputObject {FieldsDefinition IN s
inputObjectFields :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent INPUT_OBJECT a s -> FieldsDefinition IN s
inputObjectFields :: FieldsDefinition IN s
inputObjectFields} = forall a v (m :: * -> *).
(Meta a v, MonadFail m) =>
a -> ServerQ m [(Text, v)]
get FieldsDefinition IN s
inputObjectFields
get DataInterface {FieldsDefinition OUT s
interfaceFields :: FieldsDefinition OUT s
interfaceFields :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent IMPLEMENTABLE a s -> FieldsDefinition OUT s
interfaceFields} = forall a v (m :: * -> *).
(Meta a v, MonadFail m) =>
a -> ServerQ m [(Text, v)]
get FieldsDefinition OUT s
interfaceFields
get DataEnum {DataEnum s
enumMembers :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent LEAF a s -> DataEnum s
enumMembers :: DataEnum s
enumMembers} = 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 a v (m :: * -> *).
(Meta a v, MonadFail m) =>
a -> ServerQ m [(Text, v)]
get DataEnum s
enumMembers
get TypeContent a c s
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
instance Meta (DataEnumValue CONST) Description where
get :: forall (m :: * -> *).
MonadFail m =>
DataEnumValue CONST -> ServerQ m [(Text, Text)]
get DataEnumValue {TypeName
enumName :: TypeName
enumName :: forall (s :: Stage). DataEnumValue s -> TypeName
enumName, enumDescription :: forall (s :: Stage). DataEnumValue s -> Maybe Text
enumDescription = Just Text
x} = forall (f :: * -> *) a. Applicative f => a -> f a
pure [(forall a (t :: NAME). NamePacking a => Name t -> a
unpackName TypeName
enumName, Text
x)]
get DataEnumValue CONST
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
instance Meta (DataEnumValue CONST) ServerDirectiveUsage where
get :: forall (m :: * -> *).
MonadFail m =>
DataEnumValue CONST -> ServerQ m [(Text, ServerDirectiveUsage)]
get DataEnumValue {TypeName
enumName :: TypeName
enumName :: forall (s :: Stage). DataEnumValue s -> TypeName
enumName, Directives CONST
enumDirectives :: forall (s :: Stage). DataEnumValue s -> Directives s
enumDirectives :: Directives CONST
enumDirectives}
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null Directives CONST
enumDirectives = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
| Bool
otherwise = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Directive CONST
-> ReaderT (TypeContext CONST) m (Text, ServerDirectiveUsage)
transform (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Directives CONST
enumDirectives)
where
transform :: Directive CONST
-> ReaderT (TypeContext CONST) m (Text, ServerDirectiveUsage)
transform Directive CONST
x = (forall a (t :: NAME). NamePacking a => Name t -> a
unpackName TypeName
enumName,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeName -> TypeValue -> ServerDirectiveUsage
EnumDirectiveUsage TypeName
enumName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadFail m =>
Directive CONST -> ServerQ m TypeValue
directiveTypeValue Directive CONST
x
instance
Meta (FieldDefinition c CONST) v =>
Meta (FieldsDefinition c CONST) v
where
get :: forall (m :: * -> *).
MonadFail m =>
FieldsDefinition c CONST -> ServerQ m [(Text, v)]
get = 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 a v (m :: * -> *).
(Meta a v, MonadFail m) =>
a -> ServerQ m [(Text, v)]
get forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
instance Meta (FieldDefinition c CONST) Description where
get :: forall (m :: * -> *).
MonadFail m =>
FieldDefinition c CONST -> ServerQ m [(Text, Text)]
get FieldDefinition {FieldName
fieldName :: FieldName
fieldName :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldName, fieldDescription :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Maybe Text
fieldDescription = Just Text
x} = forall (f :: * -> *) a. Applicative f => a -> f a
pure [(forall a (t :: NAME). NamePacking a => Name t -> a
unpackName FieldName
fieldName, Text
x)]
get FieldDefinition c CONST
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
instance Meta (FieldDefinition c CONST) ServerDirectiveUsage where
get :: forall (m :: * -> *).
MonadFail m =>
FieldDefinition c CONST -> ServerQ m [(Text, ServerDirectiveUsage)]
get FieldDefinition {FieldName
fieldName :: FieldName
fieldName :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldName, Directives CONST
fieldDirectives :: Directives CONST
fieldDirectives :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Directives s
fieldDirectives}
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null Directives CONST
fieldDirectives = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
| Bool
otherwise = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Directive CONST
-> ReaderT (TypeContext CONST) m (Text, ServerDirectiveUsage)
transform (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Directives CONST
fieldDirectives)
where
transform :: Directive CONST
-> ReaderT (TypeContext CONST) m (Text, ServerDirectiveUsage)
transform Directive CONST
x = (forall a (t :: NAME). NamePacking a => Name t -> a
unpackName FieldName
fieldName,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> TypeValue -> ServerDirectiveUsage
FieldDirectiveUsage FieldName
fieldName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadFail m =>
Directive CONST -> ServerQ m TypeValue
directiveTypeValue Directive CONST
x
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 :: FieldsDefinition IN s
inputObjectFields :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent INPUT_OBJECT a s -> FieldsDefinition IN s
inputObjectFields}} = forall (t :: * -> *) a. Foldable t => t a -> [a]
toList FieldsDefinition IN s
inputObjectFields
getInputFields TypeDefinition c s
_ = []
getDefaultValue :: FieldDefinition c s -> Maybe (Text, V.Value s)
getDefaultValue :: forall (c :: TypeCategory) (s :: Stage).
FieldDefinition c s -> Maybe (Text, Value s)
getDefaultValue
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 DefaultInputValue {Value s
defaultInputValue :: forall (s :: Stage) (cat :: TypeCategory).
FieldContent (IN <=? cat) cat s -> Value s
defaultInputValue :: Value s
defaultInputValue}
} = forall a. a -> Maybe a
Just (forall a (t :: NAME). NamePacking a => Name t -> a
unpackName FieldName
fieldName, Value s
defaultInputValue)
getDefaultValue FieldDefinition c s
_ = forall a. Maybe a
Nothing
nativeDirectives :: V.DirectivesDefinition CONST
nativeDirectives :: DirectivesDefinition CONST
nativeDirectives = forall (s :: Stage). Schema s -> DirectivesDefinition s
AST.directiveDefinitions forall (s :: Stage). Schema s
internalSchema
getDirective :: (MonadReader (TypeContext CONST) m, MonadFail m) => FieldName -> m (DirectiveDefinition CONST)
getDirective :: forall (m :: * -> *).
(MonadReader (TypeContext CONST) m, MonadFail m) =>
FieldName -> m (DirectiveDefinition CONST)
getDirective FieldName
directiveName = do
[DirectiveDefinition CONST]
dirs <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall (s :: Stage). TypeContext s -> [DirectiveDefinition s]
directiveDefinitions
case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\DirectiveDefinition {FieldName
directiveDefinitionName :: FieldName
directiveDefinitionName :: forall (s :: Stage). DirectiveDefinition s -> FieldName
directiveDefinitionName} -> FieldName
directiveDefinitionName forall a. Eq a => a -> a -> Bool
== FieldName
directiveName) [DirectiveDefinition CONST]
dirs of
Just DirectiveDefinition CONST
dir -> forall (f :: * -> *) a. Applicative f => a -> f a
pure DirectiveDefinition CONST
dir
Maybe (DirectiveDefinition CONST)
_ -> forall k (c :: * -> *) d a.
IsMap k c =>
d -> (a -> d) -> k -> c a -> d
selectOr (forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"unknown directive" forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show FieldName
directiveName) forall (f :: * -> *) a. Applicative f => a -> f a
pure FieldName
directiveName DirectivesDefinition CONST
nativeDirectives
directiveTypeValue :: MonadFail m => Directive CONST -> ServerQ m TypeValue
directiveTypeValue :: forall (m :: * -> *).
MonadFail m =>
Directive CONST -> ServerQ m TypeValue
directiveTypeValue Directive {FieldName
Position
Arguments CONST
directivePosition :: forall (s :: Stage). Directive s -> Position
directiveArgs :: Arguments CONST
directiveName :: FieldName
directivePosition :: Position
directiveName :: forall (s :: Stage). Directive s -> FieldName
directiveArgs :: forall (s :: Stage). Directive s -> Arguments s
..} = forall (s :: Stage) (m :: * -> *) a.
MonadReader (TypeContext s) m =>
Maybe TypeName -> m a -> m a
inType Maybe TypeName
typeContext forall a b. (a -> b) -> a -> b
$ do
DirectiveDefinition CONST
dirs <- forall (m :: * -> *).
(MonadReader (TypeContext CONST) m, MonadFail m) =>
FieldName -> m (DirectiveDefinition CONST)
getDirective FieldName
directiveName
TypeName -> [(FieldName, TypeValue)] -> TypeValue
TypeValueObject 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 (c :: * -> *) (m :: * -> *) (s :: Stage).
(IsMap FieldName c, MonadFail m) =>
c (Argument CONST)
-> ArgumentDefinition s
-> ReaderT (TypeContext CONST) m (FieldName, TypeValue)
renderArgumentValue Arguments CONST
directiveArgs) (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ forall (s :: Stage). DirectiveDefinition s -> ArgumentsDefinition s
directiveDefinitionArgs DirectiveDefinition CONST
dirs)
where
(Maybe TypeName
typeContext, TypeName
typename) = FieldName -> (Maybe TypeName, TypeName)
renderDirectiveTypeName FieldName
directiveName
renderDirectiveTypeName :: FieldName -> (Maybe TypeName, TypeName)
renderDirectiveTypeName :: FieldName -> (Maybe TypeName, TypeName)
renderDirectiveTypeName FieldName
"deprecated" = (forall a. Maybe a
Nothing, TypeName
"Deprecated")
renderDirectiveTypeName FieldName
name = (forall a. a -> Maybe a
Just (coerce :: forall a b. Coercible a b => a -> b
coerce FieldName
name), coerce :: forall a b. Coercible a b => a -> b
coerce FieldName
name)
renderArgumentValue ::
(IsMap FieldName c, MonadFail m) =>
c (Argument CONST) ->
ArgumentDefinition s ->
ReaderT (TypeContext CONST) m (FieldName, TypeValue)
renderArgumentValue :: forall (c :: * -> *) (m :: * -> *) (s :: Stage).
(IsMap FieldName c, MonadFail m) =>
c (Argument CONST)
-> ArgumentDefinition s
-> ReaderT (TypeContext CONST) m (FieldName, TypeValue)
renderArgumentValue c (Argument CONST)
args ArgumentDefinition {FieldDefinition IN s
argument :: FieldDefinition IN s
argument :: forall (s :: Stage). ArgumentDefinition s -> FieldDefinition IN s
..} = do
let dirName :: FieldName
dirName = forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
AST.fieldName FieldDefinition IN s
argument
Value CONST
gqlValue <- forall k (c :: * -> *) d a.
IsMap k c =>
d -> (a -> d) -> k -> c a -> d
selectOr (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (stage :: Stage). Value stage
AST.Null) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (valid :: Stage). Argument valid -> Value valid
argumentValue) FieldName
dirName c (Argument CONST)
args
TypeValue
typeValue <- forall (m :: * -> *).
MonadFail m =>
TypeRef -> Value CONST -> ServerQ m TypeValue
mapWrappedValue (forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> TypeRef
AST.fieldType FieldDefinition IN s
argument) Value CONST
gqlValue
FieldName
fName <- forall (m :: * -> *). Monad m => FieldName -> ServerQ m FieldName
renderFieldName FieldName
dirName
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FieldName
fName, TypeValue
typeValue)
notFound :: MonadFail m => String -> String -> m a
notFound :: forall (m :: * -> *) a. MonadFail m => String -> String -> m a
notFound String
name String
at = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"can't found " forall a. Semigroup a => a -> a -> a
<> String
name forall a. Semigroup a => a -> a -> a
<> String
"at " forall a. Semigroup a => a -> a -> a
<> String
at forall a. Semigroup a => a -> a -> a
<> String
"!"
lookupType :: MonadFail m => TypeName -> ServerQ m (TypeDefinition ANY CONST)
lookupType :: forall (m :: * -> *).
MonadFail m =>
TypeName -> ServerQ m (TypeDefinition ANY CONST)
lookupType TypeName
name = do
[TypeDefinition ANY CONST]
types <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall (s :: Stage). TypeContext s -> [TypeDefinition ANY s]
typeDefinitions
case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\TypeDefinition ANY CONST
t -> forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName TypeDefinition ANY CONST
t forall a. Eq a => a -> a -> Bool
== TypeName
name) [TypeDefinition ANY CONST]
types of
Just TypeDefinition ANY CONST
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeDefinition ANY CONST
x
Maybe (TypeDefinition ANY CONST)
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> String -> m a
notFound (forall b a. (Show a, IsString b) => a -> b
show TypeName
name) String
"type definitions"
lookupValueFieldType :: MonadFail m => TypeName -> FieldName -> ServerQ m TypeRef
lookupValueFieldType :: forall (m :: * -> *).
MonadFail m =>
TypeName -> FieldName -> ServerQ m TypeRef
lookupValueFieldType TypeName
name FieldName
fieldName = do
TypeDefinition {TypeContent TRUE ANY CONST
typeContent :: TypeContent TRUE ANY CONST
typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent} <- forall (m :: * -> *).
MonadFail m =>
TypeName -> ServerQ m (TypeDefinition ANY CONST)
lookupType TypeName
name
case TypeContent TRUE ANY CONST
typeContent of
DataInputObject FieldsDefinition IN CONST
fields -> do
FieldDefinition {TypeRef
fieldType :: TypeRef
fieldType :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> TypeRef
fieldType} <- forall k (c :: * -> *) d a.
IsMap k c =>
d -> (a -> d) -> k -> c a -> d
selectOr (forall (m :: * -> *) a. MonadFail m => String -> String -> m a
notFound (forall b a. (Show a, IsString b) => a -> b
show FieldName
fieldName) (forall b a. (Show a, IsString b) => a -> b
show TypeName
name)) forall (f :: * -> *) a. Applicative f => a -> f a
pure FieldName
fieldName FieldsDefinition IN CONST
fields
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeRef
fieldType
TypeContent TRUE ANY CONST
_ -> forall (m :: * -> *) a. MonadFail m => String -> String -> m a
notFound String
"input object" (forall b a. (Show a, IsString b) => a -> b
show TypeName
name)
mapField :: MonadFail m => TypeName -> ObjectEntry CONST -> ServerQ m (FieldName, TypeValue)
mapField :: forall (m :: * -> *).
MonadFail m =>
TypeName -> ObjectEntry CONST -> ServerQ m (FieldName, TypeValue)
mapField TypeName
tName ObjectEntry {Value CONST
FieldName
entryName :: forall (s :: Stage). ObjectEntry s -> FieldName
entryValue :: forall (s :: Stage). ObjectEntry s -> Value s
entryValue :: Value CONST
entryName :: FieldName
..} = do
TypeRef
t <- forall (m :: * -> *).
MonadFail m =>
TypeName -> FieldName -> ServerQ m TypeRef
lookupValueFieldType TypeName
tName FieldName
entryName
TypeValue
value <- forall (m :: * -> *).
MonadFail m =>
TypeRef -> Value CONST -> ServerQ m TypeValue
mapWrappedValue TypeRef
t Value CONST
entryValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FieldName
entryName, TypeValue
value)
expected :: MonadFail m => String -> V.Value CONST -> ServerQ m TypeValue
expected :: forall (m :: * -> *).
MonadFail m =>
String -> Value CONST -> ServerQ m TypeValue
expected String
typ Value CONST
value = forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"expected " forall a. Semigroup a => a -> a -> a
<> String
typ forall a. Semigroup a => a -> a -> a
<> String
", found " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show (forall a. RenderGQL a => a -> ByteString
render Value CONST
value) forall a. Semigroup a => a -> a -> a
<> String
"!")
mapWrappedValue :: MonadFail m => TypeRef -> V.Value CONST -> ServerQ m TypeValue
mapWrappedValue :: forall (m :: * -> *).
MonadFail m =>
TypeRef -> Value CONST -> ServerQ m TypeValue
mapWrappedValue (TypeRef TypeName
name (AST.BaseType Bool
isRequired)) Value CONST
value
| Bool
isRequired = forall (m :: * -> *).
MonadFail m =>
TypeName -> Value CONST -> ServerQ m TypeValue
mapValue TypeName
name Value CONST
value
| Value CONST
value forall a. Eq a => a -> a -> Bool
== forall (stage :: Stage). Value stage
V.Null = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe TypeValue -> TypeValue
TypedValueMaybe forall a. Maybe a
Nothing)
| Bool
otherwise = Maybe TypeValue -> TypeValue
TypedValueMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadFail m =>
TypeName -> Value CONST -> ServerQ m TypeValue
mapValue TypeName
name Value CONST
value
mapWrappedValue (TypeRef TypeName
name (AST.TypeList TypeWrapper
elems Bool
isRequired)) Value CONST
d = case Value CONST
d of
Value CONST
V.Null | Bool -> Bool
not Bool
isRequired -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe TypeValue -> TypeValue
TypedValueMaybe forall a. Maybe a
Nothing)
(V.List [Value CONST]
xs) -> Maybe TypeValue -> TypeValue
TypedValueMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TypeValue] -> TypeValue
TypeValueList 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 :: * -> *).
MonadFail m =>
TypeRef -> Value CONST -> ServerQ m TypeValue
mapWrappedValue (TypeName -> TypeWrapper -> TypeRef
TypeRef TypeName
name TypeWrapper
elems)) [Value CONST]
xs
Value CONST
value -> forall (m :: * -> *).
MonadFail m =>
String -> Value CONST -> ServerQ m TypeValue
expected String
"list" Value CONST
value
mapValue :: MonadFail m => TypeName -> V.Value CONST -> ServerQ m TypeValue
mapValue :: forall (m :: * -> *).
MonadFail m =>
TypeName -> Value CONST -> ServerQ m TypeValue
mapValue TypeName
name (V.List [Value CONST]
xs) = [TypeValue] -> TypeValue
TypeValueList 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 :: * -> *).
MonadFail m =>
TypeName -> Value CONST -> ServerQ m TypeValue
mapValue TypeName
name) [Value CONST]
xs
mapValue TypeName
_ (V.Enum TypeName
name) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ TypeName -> [(FieldName, TypeValue)] -> TypeValue
TypeValueObject TypeName
name []
mapValue TypeName
name (V.Object Object CONST
fields) = TypeName -> [(FieldName, TypeValue)] -> TypeValue
TypeValueObject TypeName
name 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 :: * -> *).
MonadFail m =>
TypeName -> ObjectEntry CONST -> ServerQ m (FieldName, TypeValue)
mapField TypeName
name) (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Object CONST
fields)
mapValue TypeName
_ (V.Scalar ScalarValue
x) = forall (m :: * -> *).
MonadFail m =>
ScalarValue -> ServerQ m TypeValue
mapScalarValue ScalarValue
x
mapValue TypeName
t Value CONST
v = forall (m :: * -> *).
MonadFail m =>
String -> Value CONST -> ServerQ m TypeValue
expected (forall b a. (Show a, IsString b) => a -> b
show TypeName
t) Value CONST
v
mapScalarValue :: MonadFail m => V.ScalarValue -> ServerQ m TypeValue
mapScalarValue :: forall (m :: * -> *).
MonadFail m =>
ScalarValue -> ServerQ m TypeValue
mapScalarValue (V.Int Int
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Double -> TypeValue
TypeValueNumber (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x)
mapScalarValue (V.Float Double
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Double -> TypeValue
TypeValueNumber Double
x
mapScalarValue (V.String Text
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> TypeValue
TypeValueString Text
x
mapScalarValue (V.Boolean Bool
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Bool -> TypeValue
TypeValueBool Bool
x
mapScalarValue (V.Value Value
_) = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"JSON objects are not supported!"