{-# 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!"