{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.CodeGen.Server.Interpreting.Transform
  ( parseServerTypeDefinitions,
  )
where

import Data.ByteString.Lazy.Char8 (ByteString)
import Data.Morpheus.CodeGen.Internal.AST
  ( CodeGenConstructor (..),
    CodeGenField (..),
    CodeGenType (..),
    CodeGenTypeName (CodeGenTypeName),
    fromTypeName,
    getFullName,
  )
import Data.Morpheus.CodeGen.Server.Internal.AST
  ( CodeGenConfig (..),
    DerivingClass (..),
    FIELD_TYPE_WRAPPER (..),
    GQLDirectiveTypeClass (..),
    GQLTypeDefinition (..),
    InterfaceDefinition (..),
    Kind (..),
    ServerDeclaration (..),
    ServerDirectiveUsage (..),
    TypeValue (..),
  )
import Data.Morpheus.CodeGen.TH
  ( ToName (toName),
  )
import Data.Morpheus.CodeGen.Utils
  ( camelCaseFieldName,
    camelCaseTypeName,
    toHaskellTypeName,
  )
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.Server.Types (Arg, SubscriptionField)
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,
    TypeContent (..),
    TypeDefinition (..),
    TypeKind (..),
    TypeName,
    TypeRef (..),
    UnionMember (..),
    isNullable,
    isPossibleInterfaceType,
    isResolverType,
    kindOf,
    lookupWith,
    packName,
    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 [ServerDeclaration]
parseServerTypeDefinitions :: forall (m :: * -> *).
CodeGenMonad m =>
CodeGenConfig -> ByteString -> m [ServerDeclaration]
parseServerTypeDefinitions CodeGenConfig
ctx ByteString
txt =
  case ByteString -> GQLResult [RawTypeDefinition]
parseDefinitions ByteString
txt of
    Failure NonEmpty GQLError
errors -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail (NonEmpty GQLError -> String
renderGQLErrors NonEmpty GQLError
errors)
    Success {[RawTypeDefinition]
result :: forall err a. Result err a -> a
result :: [RawTypeDefinition]
result, [GQLError]
warnings :: forall err a. Result err a -> [err]
warnings :: [GQLError]
warnings} -> forall (m :: * -> *). CodeGenMonad m => [GQLError] -> m ()
printWarnings [GQLError]
warnings forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *).
CodeGenMonad m =>
Bool -> [RawTypeDefinition] -> m [ServerDeclaration]
toTHDefinitions (CodeGenConfig -> Bool
namespace CodeGenConfig
ctx) [RawTypeDefinition]
result

toTHDefinitions ::
  CodeGenMonad m =>
  Bool ->
  [RawTypeDefinition] ->
  m [ServerDeclaration]
toTHDefinitions :: forall (m :: * -> *).
CodeGenMonad m =>
Bool -> [RawTypeDefinition] -> m [ServerDeclaration]
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 [ServerDeclaration]
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 [ServerDeclaration]
    generateTypes :: forall (m :: * -> *).
CodeGenMonad m =>
RawTypeDefinition -> m [ServerDeclaration]
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 [ServerDeclaration]
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
            [CodeGenField]
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 CodeGenField
renderDataField (forall (s :: Stage). ArgumentDefinition s -> FieldDefinition IN s
argument forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a. Foldable t => t a -> [a]
toList ArgumentsDefinition CONST
directiveDefinitionArgs)
            let typename :: TypeName
typename = coerce :: forall a b. Coercible a b => a -> b
coerce FieldName
directiveDefinitionName
            Maybe (TypeKind, Text)
dropNamespace <- forall (s :: Stage) (m :: * -> *).
MonadReader (TypeContext s) m =>
TypeKind -> Text -> m (Maybe (TypeKind, Text))
defineTypeOptions TypeKind
KindInputObject (forall a (t :: NAME). NamePacking a => Name t -> a
unpackName TypeName
typename)
            let cgTypeName :: CodeGenTypeName
cgTypeName = TypeName -> CodeGenTypeName
fromTypeName TypeName
typename
            forall (f :: * -> *) a. Applicative f => a -> f a
pure
              [ CodeGenType -> ServerDeclaration
DataType
                  CodeGenType
                    { CodeGenTypeName
cgTypeName :: CodeGenTypeName
cgTypeName :: CodeGenTypeName
cgTypeName,
                      cgConstructors :: [CodeGenConstructor]
cgConstructors = [CodeGenTypeName -> [CodeGenField] -> CodeGenConstructor
CodeGenConstructor (TypeName -> CodeGenTypeName
fromTypeName TypeName
typename) [CodeGenField]
fields],
                      cgDerivations :: [DerivingClass]
cgDerivations = [DerivingClass
SHOW, DerivingClass
GENERIC]
                    },
                GQLDirectiveTypeClass -> ServerDeclaration
GQLDirectiveInstance
                  GQLDirectiveTypeClass
                    { directiveTypeName :: CodeGenTypeName
directiveTypeName = CodeGenTypeName
cgTypeName,
                      directiveLocations :: [DirectiveLocation]
directiveLocations = [DirectiveLocation]
directiveDefinitionLocations
                    },
                GQLTypeDefinition -> ServerDeclaration
GQLTypeInstance
                  GQLTypeDefinition
                    { gqlTarget :: CodeGenTypeName
gqlTarget = CodeGenTypeName
cgTypeName,
                      gqlKind :: Kind
gqlKind = Kind
Type,
                      gqlTypeDefaultValues :: Map Text (Value CONST)
gqlTypeDefaultValues = forall a. Monoid a => a
mempty,
                      gqlTypeDirectiveUses :: [ServerDirectiveUsage]
gqlTypeDirectiveUses = [],
                      Maybe (TypeKind, Text)
dropNamespace :: Maybe (TypeKind, Text)
dropNamespace :: Maybe (TypeKind, Text)
dropNamespace
                    }
              ]
        )
        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 []

defineTypeOptions :: MonadReader (TypeContext s) m => TypeKind -> Text -> m (Maybe (TypeKind, Text))
defineTypeOptions :: forall (s :: Stage) (m :: * -> *).
MonadReader (TypeContext s) m =>
TypeKind -> Text -> m (Maybe (TypeKind, Text))
defineTypeOptions TypeKind
kind Text
tName = do
  Bool
namespaces <- 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 forall a b. (a -> b) -> a -> b
$ if Bool
namespaces then forall a. a -> Maybe a
Just (TypeKind
kind, Text
tName) else forall a. Maybe a
Nothing

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 [ServerDeclaration]
genTypeDefinition :: forall (m :: * -> *).
CodeGenMonad m =>
TypeDefinition ANY CONST -> ServerQ m [ServerDeclaration]
genTypeDefinition
  typeDef :: TypeDefinition ANY CONST
typeDef@TypeDefinition {typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName = TypeName
originalTypeName, TypeContent TRUE ANY CONST
typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent :: TypeContent TRUE ANY CONST
typeContent} =
    case TypeKind
tKind of
      TypeKind
KindScalar -> do
        ServerDeclaration
scalarGQLType <- ReaderT (TypeContext CONST) m ServerDeclaration
deriveGQL
        forall (f :: * -> *) a. Applicative f => a -> f a
pure
          [ Text -> ServerDeclaration
ScalarType (TypeName -> Text
toHaskellTypeName TypeName
typeName),
            ServerDeclaration
scalarGQLType
          ]
      TypeKind
_ -> forall (m :: * -> *).
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 -> ServerQ m [ServerDeclaration]
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
      cgTypeName :: CodeGenTypeName
cgTypeName = [FieldName] -> [Text] -> TypeName -> CodeGenTypeName
CodeGenTypeName [] [Text
"m" | forall t. Strictness t => t -> Bool
isResolverType TypeKind
tKind] (forall a (t :: NAME). NamePacking a => a -> Name t
packName forall a b. (a -> b) -> a -> b
$ TypeName -> Text
toHaskellTypeName TypeName
typeName)
      deriveGQL :: ReaderT (TypeContext CONST) m ServerDeclaration
deriveGQL = do
        [ServerDirectiveUsage]
gqlTypeDirectiveUses <- forall a (m :: * -> *).
(Meta a, MonadFail m) =>
a -> ServerQ m [ServerDirectiveUsage]
getDirs TypeDefinition ANY CONST
typeDef
        Maybe (TypeKind, Text)
dropNamespace <- forall (s :: Stage) (m :: * -> *).
MonadReader (TypeContext s) m =>
TypeKind -> Text -> m (Maybe (TypeKind, Text))
defineTypeOptions TypeKind
tKind (forall a (t :: NAME). NamePacking a => Name t -> a
unpackName TypeName
typeName)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
          GQLTypeDefinition -> ServerDeclaration
GQLTypeInstance forall a b. (a -> b) -> a -> b
$
            GQLTypeDefinition
              { gqlTarget :: CodeGenTypeName
gqlTarget = CodeGenTypeName
cgTypeName,
                [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,
                Maybe (TypeKind, Text)
dropNamespace :: Maybe (TypeKind, Text)
dropNamespace :: Maybe (TypeKind, Text)
dropNamespace
              }
      cgDerivations :: [DerivingClass]
cgDerivations = Bool -> [DerivingClass]
derivesClasses (forall t. Strictness t => t -> Bool
isResolverType TypeKind
tKind)
      -------------------------
      withType :: BuildPlan -> ServerQ m [ServerDeclaration]
withType (ConsIN [CodeGenConstructor]
cgConstructors) = do
        ServerDeclaration
gqlType <- ReaderT (TypeContext CONST) m ServerDeclaration
deriveGQL
        forall (f :: * -> *) a. Applicative f => a -> f a
pure [CodeGenType -> ServerDeclaration
DataType CodeGenType {[DerivingClass]
[CodeGenConstructor]
CodeGenTypeName
cgConstructors :: [CodeGenConstructor]
cgDerivations :: [DerivingClass]
cgTypeName :: CodeGenTypeName
cgDerivations :: [DerivingClass]
cgConstructors :: [CodeGenConstructor]
cgTypeName :: CodeGenTypeName
..}, ServerDeclaration
gqlType]
      withType (ConsOUT [ServerDeclaration]
others [CodeGenConstructor]
cgConstructors) = do
        ServerDeclaration
gqlType <- ReaderT (TypeContext CONST) m ServerDeclaration
deriveGQL
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (CodeGenType -> ServerDeclaration
DataType CodeGenType {[DerivingClass]
[CodeGenConstructor]
CodeGenTypeName
cgConstructors :: [CodeGenConstructor]
cgDerivations :: [DerivingClass]
cgTypeName :: CodeGenTypeName
cgDerivations :: [DerivingClass]
cgConstructors :: [CodeGenConstructor]
cgTypeName :: CodeGenTypeName
..} forall a. a -> [a] -> [a]
: ServerDeclaration
gqlType forall a. a -> [a] -> [a]
: [ServerDeclaration]
others)

derivingKind :: TypeKind -> Kind
derivingKind :: TypeKind -> Kind
derivingKind TypeKind
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 -> [CodeGenField] -> [CodeGenConstructor]
mkObjectCons :: TypeName -> [CodeGenField] -> [CodeGenConstructor]
mkObjectCons TypeName
name = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. CodeGenTypeName -> [CodeGenField] -> CodeGenConstructor
CodeGenConstructor (TypeName -> CodeGenTypeName
fromTypeName TypeName
name)

mkArgsTypeName :: Bool -> TypeName -> FieldName -> TypeName
mkArgsTypeName :: Bool -> TypeName -> FieldName -> TypeName
mkArgsTypeName Bool
namespace TypeName
typeName FieldName
fieldName
  | Bool
namespace = TypeName
typeName forall a. Semigroup a => a -> a -> a
<> TypeName
argTName
  | Bool
otherwise = TypeName
argTName
  where
    argTName :: TypeName
argTName = forall (t :: NAME). [Name t] -> TypeName -> TypeName
camelCaseTypeName [FieldName
fieldName] TypeName
"Args"

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 CodeGenField
mkObjectField :: forall (m :: * -> *).
CodeGenMonad m =>
FieldDefinition OUT CONST -> ServerQ m CodeGenField
mkObjectField
  FieldDefinition
    { fieldName :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldName = FieldName
fName,
      Maybe (FieldContent TRUE OUT CONST)
fieldContent :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Maybe (FieldContent TRUE cat s)
fieldContent :: Maybe (FieldContent TRUE OUT CONST)
fieldContent,
      fieldType :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> TypeRef
fieldType = TypeRef {TypeName
typeConName :: TypeRef -> TypeName
typeConName :: TypeName
typeConName, TypeWrapper
typeWrappers :: TypeRef -> TypeWrapper
typeWrappers :: TypeWrapper
typeWrappers}
    } = do
    Bool
isParametrized <- forall (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
      CodeGenField
        { fieldType :: TypeName
fieldType = forall a (t :: NAME). NamePacking a => a -> Name t
packName (TypeName -> Text
toHaskellTypeName TypeName
typeConName),
          fieldIsNullable :: Bool
fieldIsNullable = forall a. Nullable a => a -> Bool
isNullable TypeWrapper
typeWrappers,
          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
<> [Name -> FIELD_TYPE_WRAPPER
SUBSCRIPTION ''SubscriptionField | forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TypeKind -> Bool
isSubscription Maybe TypeKind
kind forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Bool
True]
              forall a. Semigroup a => a -> a -> a
<> [FIELD_TYPE_WRAPPER
MONAD]
              forall a. Semigroup a => a -> a -> a
<> [TypeWrapper -> FIELD_TYPE_WRAPPER
GQL_WRAPPER TypeWrapper
typeWrappers]
              forall a. Semigroup a => a -> a -> a
<> [FIELD_TYPE_WRAPPER
PARAMETRIZED | Bool
isParametrized],
          FieldName
fieldName :: FieldName
fieldName :: FieldName
..
        }

mkFieldArguments :: 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}
    ] = [Name -> FieldName -> TypeRef -> FIELD_TYPE_WRAPPER
TAGGED_ARG ''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 [CodeGenConstructor]
  | ConsOUT [ServerDeclaration] [CodeGenConstructor]

genInterfaceUnion :: Monad m => TypeName -> ServerQ m [ServerDeclaration]
genInterfaceUnion :: forall (m :: * -> *).
Monad m =>
TypeName -> ServerQ m [ServerDeclaration]
genInterfaceUnion TypeName
interfaceName =
  [TypeName] -> [ServerDeclaration]
mkInterface forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall (c :: TypeCategory) (s :: Stage).
TypeName -> TypeDefinition c s -> Maybe (TypeDefinition c s)
isPossibleInterfaceType TypeName
interfaceName)
    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
    mkInterface :: [TypeName] -> [ServerDeclaration]
mkInterface [] = []
    mkInterface [TypeName
possibleTypeName] = [TypeName -> ServerDeclaration
mkGuardWithPossibleType TypeName
possibleTypeName]
    mkInterface [TypeName]
members =
      [ TypeName -> ServerDeclaration
mkGuardWithPossibleType TypeName
tName,
        CodeGenType -> ServerDeclaration
DataType
          CodeGenType
            { cgTypeName :: CodeGenTypeName
cgTypeName = CodeGenTypeName
possTypeName,
              cgConstructors :: [CodeGenConstructor]
cgConstructors = forall a b. (a -> b) -> [a] -> [b]
map (TypeName -> TypeName -> CodeGenConstructor
mkUnionFieldDefinition TypeName
tName) [TypeName]
members,
              cgDerivations :: [DerivingClass]
cgDerivations = Bool -> [DerivingClass]
derivesClasses Bool
True
            },
        GQLTypeDefinition -> ServerDeclaration
GQLTypeInstance
          GQLTypeDefinition
            { gqlTarget :: CodeGenTypeName
gqlTarget = CodeGenTypeName
possTypeName,
              gqlKind :: Kind
gqlKind = Kind
Type,
              gqlTypeDirectiveUses :: [ServerDirectiveUsage]
gqlTypeDirectiveUses = forall (f :: * -> *) a. Alternative f => f a
empty,
              gqlTypeDefaultValues :: Map Text (Value CONST)
gqlTypeDefaultValues = forall a. Monoid a => a
mempty,
              dropNamespace :: Maybe (TypeKind, Text)
dropNamespace = forall a. Maybe a
Nothing
            }
      ]
      where
        possTypeName :: CodeGenTypeName
possTypeName = [FieldName] -> [Text] -> TypeName -> CodeGenTypeName
CodeGenTypeName [] [Text
"m"] (forall a (t :: NAME). NamePacking a => a -> Name t
packName forall a b. (a -> b) -> a -> b
$ TypeName -> Text
toHaskellTypeName TypeName
tName)
    mkGuardWithPossibleType :: TypeName -> ServerDeclaration
mkGuardWithPossibleType = InterfaceDefinition -> ServerDeclaration
InterfaceType forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeName -> TypeName -> TypeName -> InterfaceDefinition
InterfaceDefinition TypeName
interfaceName (TypeName -> TypeName
mkInterfaceName TypeName
interfaceName)
    tName :: TypeName
tName = TypeName -> TypeName
mkPossibleTypesName TypeName
interfaceName

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 CodeGenConstructor
mkConsEnum :: forall (m :: * -> *).
Monad m =>
TypeName -> DataEnumValue CONST -> ServerQ m CodeGenConstructor
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
    CodeGenConstructor
      { constructorName :: CodeGenTypeName
constructorName =
          if Bool
namespace
            then [FieldName] -> [Text] -> TypeName -> CodeGenTypeName
CodeGenTypeName [coerce :: forall a b. Coercible a b => a -> b
coerce TypeName
name] [] TypeName
enumName
            else TypeName -> CodeGenTypeName
fromTypeName TypeName
enumName,
        constructorFields :: [CodeGenField]
constructorFields = []
      }

renderDataField :: Monad m => FieldDefinition c CONST -> ServerQ m CodeGenField
renderDataField :: forall (m :: * -> *) (c :: TypeCategory).
Monad m =>
FieldDefinition c CONST -> ServerQ m CodeGenField
renderDataField FieldDefinition {fieldType :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> TypeRef
fieldType = TypeRef {TypeName
typeConName :: TypeName
typeConName :: TypeRef -> TypeName
typeConName, TypeWrapper
typeWrappers :: TypeWrapper
typeWrappers :: TypeRef -> TypeWrapper
typeWrappers}, fieldName :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldName = FieldName
fName} = do
  FieldName
fieldName <- forall (m :: * -> *). 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 :: TypeName
fieldType = forall a (t :: NAME). NamePacking a => a -> Name t
packName (TypeName -> Text
toHaskellTypeName TypeName
typeConName)
  let fieldIsNullable :: Bool
fieldIsNullable = forall a. Nullable a => a -> Bool
isNullable TypeWrapper
typeWrappers
  forall (f :: * -> *) a. Applicative f => a -> f a
pure CodeGenField {Bool
[FIELD_TYPE_WRAPPER]
FieldName
TypeName
fieldIsNullable :: Bool
fieldType :: TypeName
wrappers :: [FIELD_TYPE_WRAPPER]
fieldName :: FieldName
fieldName :: FieldName
wrappers :: [FIELD_TYPE_WRAPPER]
fieldIsNullable :: Bool
fieldType :: TypeName
..}

genTypeContent ::
  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 ([CodeGenConstructor] -> BuildPlan
ConsIN [])
genTypeContent TypeName
typeName (DataEnum DataEnum CONST
tags) = [CodeGenConstructor] -> BuildPlan
ConsIN forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (m :: * -> *).
Monad m =>
TypeName -> DataEnumValue CONST -> ServerQ m CodeGenConstructor
mkConsEnum TypeName
typeName) DataEnum CONST
tags
genTypeContent TypeName
typeName (DataInputObject FieldsDefinition IN CONST
fields) =
  [CodeGenConstructor] -> BuildPlan
ConsIN forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeName -> [CodeGenField] -> [CodeGenConstructor]
mkObjectCons TypeName
typeName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *) (c :: TypeCategory).
Monad m =>
FieldDefinition c CONST -> ServerQ m CodeGenField
renderDataField (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList FieldsDefinition IN CONST
fields)
genTypeContent TypeName
_ DataInputUnion {} = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Input Unions not Supported"
genTypeContent TypeName
typeName DataInterface {FieldsDefinition OUT CONST
interfaceFields :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent IMPLEMENTABLE a s -> FieldsDefinition OUT s
interfaceFields :: FieldsDefinition OUT CONST
interfaceFields} =
  [ServerDeclaration] -> [CodeGenConstructor] -> BuildPlan
ConsOUT
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Semigroup a => a -> a -> a
(<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadFail m =>
FieldsDefinition OUT CONST -> ServerQ m [ServerDeclaration]
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 [ServerDeclaration]
genInterfaceUnion TypeName
typeName)
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ( do
            let interfaceName :: TypeName
interfaceName = TypeName -> TypeName
mkInterfaceName TypeName
typeName
            forall (s :: Stage) (m :: * -> *) a.
MonadReader (TypeContext s) m =>
Maybe TypeName -> m a -> m a
inType
              (forall a. a -> Maybe a
Just TypeName
interfaceName)
              ( TypeName -> [CodeGenField] -> [CodeGenConstructor]
mkObjectCons TypeName
interfaceName
                  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *).
CodeGenMonad m =>
FieldDefinition OUT CONST -> ServerQ m CodeGenField
mkObjectField (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList FieldsDefinition OUT CONST
interfaceFields)
              )
        )
genTypeContent TypeName
typeName DataObject {FieldsDefinition OUT CONST
objectFields :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent OBJECT a s -> FieldsDefinition OUT s
objectFields :: FieldsDefinition OUT CONST
objectFields} =
  [ServerDeclaration] -> [CodeGenConstructor] -> BuildPlan
ConsOUT
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadFail m =>
FieldsDefinition OUT CONST -> ServerQ m [ServerDeclaration]
genArgumentTypes FieldsDefinition OUT CONST
objectFields
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ( TypeName -> [CodeGenField] -> [CodeGenConstructor]
mkObjectCons TypeName
typeName
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *).
CodeGenMonad m =>
FieldDefinition OUT CONST -> ServerQ m CodeGenField
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
$ [ServerDeclaration] -> [CodeGenConstructor] -> BuildPlan
ConsOUT [] (UnionMember OUT CONST -> CodeGenConstructor
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 -> CodeGenConstructor
unionCon UnionMember {TypeName
memberName :: forall (cat :: TypeCategory) (s :: Stage).
UnionMember cat s -> TypeName
memberName :: TypeName
memberName} = TypeName -> TypeName -> CodeGenConstructor
mkUnionFieldDefinition TypeName
typeName TypeName
memberName

mkUnionFieldDefinition :: TypeName -> TypeName -> CodeGenConstructor
mkUnionFieldDefinition :: TypeName -> TypeName -> CodeGenConstructor
mkUnionFieldDefinition TypeName
typeName TypeName
memberName =
  CodeGenConstructor
    { CodeGenTypeName
constructorName :: CodeGenTypeName
constructorName :: CodeGenTypeName
constructorName,
      constructorFields :: [CodeGenField]
constructorFields =
        [ CodeGenField
            { fieldName :: FieldName
fieldName = coerce :: forall a b. Coercible a b => a -> b
coerce (TypeName
"un" forall a. Semigroup a => a -> a -> a
<> CodeGenTypeName -> TypeName
getFullName CodeGenTypeName
constructorName),
              fieldType :: TypeName
fieldType = forall a (t :: NAME). NamePacking a => a -> Name t
packName (TypeName -> Text
toHaskellTypeName TypeName
memberName),
              wrappers :: [FIELD_TYPE_WRAPPER]
wrappers = [FIELD_TYPE_WRAPPER
PARAMETRIZED],
              fieldIsNullable :: Bool
fieldIsNullable = Bool
False
            }
        ]
    }
  where
    constructorName :: CodeGenTypeName
constructorName = [FieldName] -> [Text] -> TypeName -> CodeGenTypeName
CodeGenTypeName [coerce :: forall a b. Coercible a b => a -> b
coerce TypeName
typeName] [] TypeName
memberName

genArgumentTypes :: MonadFail m => FieldsDefinition OUT CONST -> ServerQ m [ServerDeclaration]
genArgumentTypes :: forall (m :: * -> *).
MonadFail m =>
FieldsDefinition OUT CONST -> ServerQ m [ServerDeclaration]
genArgumentTypes = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *).
MonadFail m =>
FieldDefinition OUT CONST -> ServerQ m [ServerDeclaration]
genArgumentType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

genArgumentType :: MonadFail m => FieldDefinition OUT CONST -> ServerQ m [ServerDeclaration]
genArgumentType :: forall (m :: * -> *).
MonadFail m =>
FieldDefinition OUT CONST -> ServerQ m [ServerDeclaration]
genArgumentType
  FieldDefinition
    { FieldName
fieldName :: FieldName
fieldName :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldName,
      fieldContent :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Maybe (FieldContent TRUE cat s)
fieldContent = Just (FieldArgs ArgumentsDefinition CONST
arguments)
    }
    | forall (t :: * -> *) a. Foldable t => t a -> Int
length ArgumentsDefinition CONST
arguments forall a. Ord a => a -> a -> Bool
> Int
1 = do
        TypeName
tName <- (FieldName
fieldName forall a b. a -> (a -> b) -> b
&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks 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
          [CodeGenField]
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 CodeGenField
renderDataField [FieldDefinition IN CONST]
argumentFields
          let typename :: Text
typename = TypeName -> Text
toHaskellTypeName TypeName
tName
          [ServerDirectiveUsage]
gqlTypeDirectiveUses <- 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 (m :: * -> *).
(Meta a, MonadFail m) =>
a -> ServerQ m [ServerDirectiveUsage]
getDirs [FieldDefinition IN CONST]
argumentFields
          Maybe (TypeKind, Text)
dropNamespace <- forall (s :: Stage) (m :: * -> *).
MonadReader (TypeContext s) m =>
TypeKind -> Text -> m (Maybe (TypeKind, Text))
defineTypeOptions TypeKind
KindInputObject Text
typename
          let cgTypeName :: CodeGenTypeName
cgTypeName = TypeName -> CodeGenTypeName
fromTypeName (forall a (t :: NAME). NamePacking a => a -> Name t
packName Text
typename)
          forall (f :: * -> *) a. Applicative f => a -> f a
pure
            [ CodeGenType -> ServerDeclaration
DataType
                CodeGenType
                  { CodeGenTypeName
cgTypeName :: CodeGenTypeName
cgTypeName :: CodeGenTypeName
cgTypeName,
                    cgConstructors :: [CodeGenConstructor]
cgConstructors = TypeName -> [CodeGenField] -> [CodeGenConstructor]
mkObjectCons TypeName
tName [CodeGenField]
fields,
                    cgDerivations :: [DerivingClass]
cgDerivations = Bool -> [DerivingClass]
derivesClasses Bool
False
                  },
              GQLTypeDefinition -> ServerDeclaration
GQLTypeInstance
                GQLTypeDefinition
                  { gqlTarget :: CodeGenTypeName
gqlTarget = CodeGenTypeName
cgTypeName,
                    gqlKind :: Kind
gqlKind = Kind
Type,
                    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),
                    [ServerDirectiveUsage]
gqlTypeDirectiveUses :: [ServerDirectiveUsage]
gqlTypeDirectiveUses :: [ServerDirectiveUsage]
gqlTypeDirectiveUses,
                    Maybe (TypeKind, Text)
dropNamespace :: Maybe (TypeKind, Text)
dropNamespace :: Maybe (TypeKind, Text)
dropNamespace
                  }
            ]
genArgumentType FieldDefinition OUT CONST
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure []

-- mkFieldDescription :: FieldDefinition cat s -> Maybe (Text, Description)
-- mkFieldDescription FieldDefinition {..} = (unpackName fieldName,) <$> fieldDescription

---

class Meta a where
  getDirs :: MonadFail m => a -> ServerQ m [ServerDirectiveUsage]

instance (Meta a) => Meta (Maybe a) where
  getDirs :: forall (m :: * -> *).
MonadFail m =>
Maybe a -> ServerQ m [ServerDirectiveUsage]
getDirs (Just a
x) = forall a (m :: * -> *).
(Meta a, MonadFail m) =>
a -> ServerQ m [ServerDirectiveUsage]
getDirs a
x
  getDirs Maybe a
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure []

descDirective :: Maybe Description -> [TypeValue]
descDirective :: Maybe Text -> [TypeValue]
descDirective Maybe Text
desc = forall a b. (a -> b) -> [a] -> [b]
map Text -> TypeValue
describe (forall a. Maybe a -> [a]
maybeToList Maybe Text
desc)
  where
    describe :: Text -> TypeValue
describe Text
x = TypeName -> [(FieldName, TypeValue)] -> TypeValue
TypeValueObject TypeName
"Describe" [(FieldName
"text", Text -> TypeValue
TypeValueString Text
x)]

instance Meta (TypeDefinition c CONST) where
  getDirs :: forall (m :: * -> *).
MonadFail m =>
TypeDefinition c CONST -> ServerQ m [ServerDirectiveUsage]
getDirs TypeDefinition {TypeContent TRUE c CONST
typeContent :: TypeContent TRUE c CONST
typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent, Directives CONST
typeDirectives :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Directives s
typeDirectives :: Directives CONST
typeDirectives, Maybe Text
typeDescription :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Maybe Text
typeDescription :: Maybe Text
typeDescription} = do
    [ServerDirectiveUsage]
contentD <- forall a (m :: * -> *).
(Meta a, MonadFail m) =>
a -> ServerQ m [ServerDirectiveUsage]
getDirs TypeContent TRUE c CONST
typeContent
    [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 Directives CONST
typeDirectives)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ServerDirectiveUsage]
contentD forall a. Semigroup a => a -> a -> a
<> [ServerDirectiveUsage]
typeD forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map TypeValue -> ServerDirectiveUsage
TypeDirectiveUsage (Maybe Text -> [TypeValue]
descDirective Maybe Text
typeDescription))
    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

instance Meta (TypeContent a c CONST) where
  getDirs :: forall (m :: * -> *).
MonadFail m =>
TypeContent a c CONST -> ServerQ m [ServerDirectiveUsage]
getDirs DataObject {FieldsDefinition OUT CONST
objectFields :: FieldsDefinition OUT CONST
objectFields :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent OBJECT a s -> FieldsDefinition OUT s
objectFields} = forall a (m :: * -> *).
(Meta a, MonadFail m) =>
a -> ServerQ m [ServerDirectiveUsage]
getDirs FieldsDefinition OUT CONST
objectFields
  getDirs DataInputObject {FieldsDefinition IN CONST
inputObjectFields :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent INPUT_OBJECT a s -> FieldsDefinition IN s
inputObjectFields :: FieldsDefinition IN CONST
inputObjectFields} = forall a (m :: * -> *).
(Meta a, MonadFail m) =>
a -> ServerQ m [ServerDirectiveUsage]
getDirs FieldsDefinition IN CONST
inputObjectFields
  getDirs DataInterface {FieldsDefinition OUT CONST
interfaceFields :: FieldsDefinition OUT CONST
interfaceFields :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent IMPLEMENTABLE a s -> FieldsDefinition OUT s
interfaceFields} = forall a (m :: * -> *).
(Meta a, MonadFail m) =>
a -> ServerQ m [ServerDirectiveUsage]
getDirs FieldsDefinition OUT CONST
interfaceFields
  getDirs DataEnum {DataEnum CONST
enumMembers :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent LEAF a s -> DataEnum s
enumMembers :: DataEnum CONST
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 (m :: * -> *).
(Meta a, MonadFail m) =>
a -> ServerQ m [ServerDirectiveUsage]
getDirs DataEnum CONST
enumMembers
  getDirs TypeContent a c CONST
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure []

instance Meta (DataEnumValue CONST) where
  getDirs :: forall (m :: * -> *).
MonadFail m =>
DataEnumValue CONST -> ServerQ m [ServerDirectiveUsage]
getDirs 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, Maybe Text
enumDescription :: forall (s :: Stage). DataEnumValue s -> Maybe Text
enumDescription :: Maybe Text
enumDescription} = do
    [TypeValue]
dirs <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *).
MonadFail m =>
Directive CONST -> ServerQ m TypeValue
directiveTypeValue (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Directives CONST
enumDirectives)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (TypeName -> TypeValue -> ServerDirectiveUsage
EnumDirectiveUsage TypeName
enumName) ([TypeValue]
dirs forall a. Semigroup a => a -> a -> a
<> Maybe Text -> [TypeValue]
descDirective Maybe Text
enumDescription)

instance Meta (FieldsDefinition c CONST) where
  getDirs :: forall (m :: * -> *).
MonadFail m =>
FieldsDefinition c CONST -> ServerQ m [ServerDirectiveUsage]
getDirs = 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 (m :: * -> *).
(Meta a, MonadFail m) =>
a -> ServerQ m [ServerDirectiveUsage]
getDirs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

instance Meta (FieldDefinition c CONST) where
  getDirs :: forall (m :: * -> *).
MonadFail m =>
FieldDefinition c CONST -> ServerQ m [ServerDirectiveUsage]
getDirs FieldDefinition {FieldName
fieldName :: FieldName
fieldName :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldName, Directives CONST
fieldDirectives :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Directives s
fieldDirectives :: Directives CONST
fieldDirectives, Maybe Text
fieldDescription :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Maybe Text
fieldDescription :: Maybe Text
fieldDescription} = do
    [TypeValue]
dirs <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *).
MonadFail m =>
Directive CONST -> ServerQ m TypeValue
directiveTypeValue (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Directives CONST
fieldDirectives)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (FieldName -> TypeValue -> ServerDirectiveUsage
FieldDirectiveUsage FieldName
fieldName) ([TypeValue]
dirs forall a. Semigroup a => a -> a -> a
<> Maybe Text -> [TypeValue]
descDirective Maybe Text
fieldDescription)

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