{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Data.Morpheus.Server.TH.Transform
( toTHDefinitions,
TypeDec (..),
)
where
import Data.Morpheus.Internal.Utils
( capitalTypeName,
elems,
empty,
singleton,
)
import Data.Morpheus.Server.Internal.TH.Types
( ServerConsD,
ServerFieldDefinition (..),
ServerTypeDefinition (..),
toServerField,
)
import Data.Morpheus.Server.Internal.TH.Utils (isParametrizedResolverType)
import Data.Morpheus.Types.Internal.AST
( ANY,
ArgumentDefinition (..),
ConsD (..),
FieldContent (..),
FieldDefinition (..),
FieldName,
FieldsDefinition,
IN,
OUT,
TRUE,
TypeContent (..),
TypeDefinition (..),
TypeKind (..),
TypeName,
TypeRef (..),
UnionMember (..),
hsTypeName,
kindOf,
mkConsEnum,
toFieldName,
)
import Language.Haskell.TH
import Relude hiding (empty)
data TypeDec s = InputType (ServerTypeDefinition IN s) | OutputType (ServerTypeDefinition OUT s)
toTHDefinitions ::
forall s.
Bool ->
[TypeDefinition ANY s] ->
Q [TypeDec s]
toTHDefinitions :: Bool -> [TypeDefinition ANY s] -> Q [TypeDec s]
toTHDefinitions Bool
namespace [TypeDefinition ANY s]
schema = (TypeDefinition ANY s -> Q (TypeDec s))
-> [TypeDefinition ANY s] -> Q [TypeDec s]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse TypeDefinition ANY s -> Q (TypeDec s)
generateType [TypeDefinition ANY s]
schema
where
generateType :: TypeDefinition ANY s -> Q (TypeDec s)
generateType :: TypeDefinition ANY s -> Q (TypeDec s)
generateType
typeDef :: TypeDefinition ANY s
typeDef@TypeDefinition
{ TypeName
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName :: TypeName
typeName,
TypeContent TRUE ANY s
typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent :: TypeContent TRUE ANY s
typeContent
} =
BuildPlan s -> TypeDec s
withType (BuildPlan s -> TypeDec s) -> Q (BuildPlan s) -> Q (TypeDec s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TypeDefinition ANY s]
-> (FieldName -> TypeName)
-> TypeName
-> TypeContent TRUE ANY s
-> Q (BuildPlan s)
forall (s :: Stage).
[TypeDefinition ANY s]
-> (FieldName -> TypeName)
-> TypeName
-> TypeContent TRUE ANY s
-> Q (BuildPlan s)
genTypeContent [TypeDefinition ANY s]
schema FieldName -> TypeName
toArgsTypeName TypeName
typeName TypeContent TRUE ANY s
typeContent
where
toArgsTypeName :: FieldName -> TypeName
toArgsTypeName :: FieldName -> TypeName
toArgsTypeName = Bool -> TypeName -> FieldName -> TypeName
mkArgsTypeName Bool
namespace TypeName
typeName
tKind :: TypeKind
tKind = TypeDefinition ANY s -> TypeKind
forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeKind
kindOf TypeDefinition ANY s
typeDef
typeOriginal :: Maybe (TypeDefinition ANY s)
typeOriginal = TypeDefinition ANY s -> Maybe (TypeDefinition ANY s)
forall a. a -> Maybe a
Just TypeDefinition ANY s
typeDef
withType :: BuildPlan s -> TypeDec s
withType (ConsIN [ServerConsD IN s]
tCons) =
ServerTypeDefinition IN s -> TypeDec s
forall (s :: Stage). ServerTypeDefinition IN s -> TypeDec s
InputType
ServerTypeDefinition :: forall (cat :: TypeCategory) (s :: Stage).
TypeName
-> [ServerTypeDefinition IN s]
-> [ServerConsD cat s]
-> TypeKind
-> Maybe (TypeDefinition ANY s)
-> ServerTypeDefinition cat s
ServerTypeDefinition
{ tName :: TypeName
tName = TypeName -> TypeName
hsTypeName TypeName
typeName,
[ServerConsD IN s]
tCons :: [ServerConsD IN s]
tCons :: [ServerConsD IN s]
tCons,
typeArgD :: [ServerTypeDefinition IN s]
typeArgD = [ServerTypeDefinition IN s]
forall coll. Empty coll => coll
empty,
Maybe (TypeDefinition ANY s)
TypeKind
typeOriginal :: Maybe (TypeDefinition ANY s)
tKind :: TypeKind
typeOriginal :: Maybe (TypeDefinition ANY s)
tKind :: TypeKind
..
}
withType (ConsOUT [ServerTypeDefinition IN s]
typeArgD [ServerConsD OUT s]
tCons) =
ServerTypeDefinition OUT s -> TypeDec s
forall (s :: Stage). ServerTypeDefinition OUT s -> TypeDec s
OutputType
ServerTypeDefinition :: forall (cat :: TypeCategory) (s :: Stage).
TypeName
-> [ServerTypeDefinition IN s]
-> [ServerConsD cat s]
-> TypeKind
-> Maybe (TypeDefinition ANY s)
-> ServerTypeDefinition cat s
ServerTypeDefinition
{ tName :: TypeName
tName = TypeName -> TypeName
hsTypeName TypeName
typeName,
[ServerConsD OUT s]
tCons :: [ServerConsD OUT s]
tCons :: [ServerConsD OUT s]
tCons,
[ServerTypeDefinition IN s]
Maybe (TypeDefinition ANY s)
TypeKind
typeArgD :: [ServerTypeDefinition IN s]
typeOriginal :: Maybe (TypeDefinition ANY s)
tKind :: TypeKind
typeArgD :: [ServerTypeDefinition IN s]
typeOriginal :: Maybe (TypeDefinition ANY s)
tKind :: TypeKind
..
}
toHSTypeRef :: TypeRef -> TypeRef
toHSTypeRef :: TypeRef -> TypeRef
toHSTypeRef tyRef :: TypeRef
tyRef@TypeRef {TypeName
typeConName :: TypeRef -> TypeName
typeConName :: TypeName
typeConName} = TypeRef
tyRef {typeConName :: TypeName
typeConName = TypeName -> TypeName
hsTypeName TypeName
typeConName}
toHSFieldDefinition :: FieldDefinition cat s -> FieldDefinition cat s
toHSFieldDefinition :: FieldDefinition cat s -> FieldDefinition cat s
toHSFieldDefinition FieldDefinition cat s
field = FieldDefinition cat s
field {fieldType :: TypeRef
fieldType = TypeRef -> TypeRef
toHSTypeRef (FieldDefinition cat s -> TypeRef
forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> TypeRef
fieldType FieldDefinition cat s
field)}
toHSServerFieldDefinition :: ServerFieldDefinition cat s -> ServerFieldDefinition cat s
toHSServerFieldDefinition :: ServerFieldDefinition cat s -> ServerFieldDefinition cat s
toHSServerFieldDefinition ServerFieldDefinition cat s
field = ServerFieldDefinition cat s
field {originalField :: FieldDefinition cat s
originalField = FieldDefinition cat s -> FieldDefinition cat s
forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldDefinition cat s
toHSFieldDefinition (ServerFieldDefinition cat s -> FieldDefinition cat s
forall (cat :: TypeCategory) (s :: Stage).
ServerFieldDefinition cat s -> FieldDefinition cat s
originalField ServerFieldDefinition cat s
field)}
mkCons :: TypeName -> [ServerFieldDefinition cat s] -> ServerConsD cat s
mkCons :: TypeName -> [ServerFieldDefinition cat s] -> ServerConsD cat s
mkCons TypeName
typename [ServerFieldDefinition cat s]
fields =
ConsD :: forall f. TypeName -> [f] -> ConsD f
ConsD
{ cName :: TypeName
cName = TypeName -> TypeName
hsTypeName TypeName
typename,
cFields :: [ServerFieldDefinition cat s]
cFields = (ServerFieldDefinition cat s -> ServerFieldDefinition cat s)
-> [ServerFieldDefinition cat s] -> [ServerFieldDefinition cat s]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ServerFieldDefinition cat s -> ServerFieldDefinition cat s
forall (cat :: TypeCategory) (s :: Stage).
ServerFieldDefinition cat s -> ServerFieldDefinition cat s
toHSServerFieldDefinition [ServerFieldDefinition cat s]
fields
}
mkObjectCons :: TypeName -> [ServerFieldDefinition cat s] -> [ServerConsD cat s]
mkObjectCons :: TypeName -> [ServerFieldDefinition cat s] -> [ServerConsD cat s]
mkObjectCons TypeName
typeName [ServerFieldDefinition cat s]
fields = [TypeName -> [ServerFieldDefinition cat s] -> ServerConsD cat s
forall (cat :: TypeCategory) (s :: Stage).
TypeName -> [ServerFieldDefinition cat s] -> ServerConsD cat s
mkCons TypeName
typeName [ServerFieldDefinition cat s]
fields]
mkArgsTypeName :: Bool -> TypeName -> FieldName -> TypeName
mkArgsTypeName :: Bool -> TypeName -> FieldName -> TypeName
mkArgsTypeName Bool
namespace TypeName
typeName FieldName
fieldName
| Bool
namespace = TypeName -> TypeName
hsTypeName TypeName
typeName TypeName -> TypeName -> TypeName
forall a. Semigroup a => a -> a -> a
<> TypeName
argTName
| Bool
otherwise = TypeName
argTName
where
argTName :: TypeName
argTName = FieldName -> TypeName
capitalTypeName (FieldName
fieldName FieldName -> FieldName -> FieldName
forall a. Semigroup a => a -> a -> a
<> FieldName
"Args")
mkObjectField ::
[TypeDefinition ANY s] ->
(FieldName -> TypeName) ->
FieldDefinition OUT s ->
Q (ServerFieldDefinition OUT s)
mkObjectField :: [TypeDefinition ANY s]
-> (FieldName -> TypeName)
-> FieldDefinition OUT s
-> Q (ServerFieldDefinition OUT s)
mkObjectField
[TypeDefinition ANY s]
schema
FieldName -> TypeName
genArgsTypeName
originalField :: FieldDefinition OUT s
originalField@FieldDefinition
{ FieldName
fieldName :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldName :: FieldName
fieldName,
Maybe (FieldContent TRUE OUT s)
fieldContent :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Maybe (FieldContent TRUE cat s)
fieldContent :: Maybe (FieldContent TRUE OUT s)
fieldContent,
fieldType :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> TypeRef
fieldType = TypeRef {TypeName
typeConName :: TypeName
typeConName :: TypeRef -> TypeName
typeConName}
} = do
Bool
isParametrized <- TypeName -> [TypeDefinition ANY s] -> Q Bool
forall (s :: Stage). TypeName -> [TypeDefinition ANY s] -> Q Bool
isParametrizedResolverType TypeName
typeConName [TypeDefinition ANY s]
schema
ServerFieldDefinition OUT s -> Q (ServerFieldDefinition OUT s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
ServerFieldDefinition :: forall (cat :: TypeCategory) (s :: Stage).
Bool
-> Maybe TypeName
-> FieldDefinition cat s
-> ServerFieldDefinition cat s
ServerFieldDefinition
{ argumentsTypeName :: Maybe TypeName
argumentsTypeName = Maybe (FieldContent TRUE OUT s)
fieldContent Maybe (FieldContent TRUE OUT s)
-> (FieldContent TRUE OUT s -> Maybe TypeName) -> Maybe TypeName
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FieldContent TRUE OUT s -> Maybe TypeName
forall (s :: Stage). FieldContent TRUE OUT s -> Maybe TypeName
fieldCont,
Bool
FieldDefinition OUT s
isParametrized :: Bool
isParametrized :: Bool
originalField :: FieldDefinition OUT s
originalField :: FieldDefinition OUT s
..
}
where
fieldCont :: FieldContent TRUE OUT s -> Maybe TypeName
fieldCont :: FieldContent TRUE OUT s -> Maybe TypeName
fieldCont (FieldArgs ArgumentsDefinition s
arguments)
| Bool -> Bool
not (ArgumentsDefinition s -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ArgumentsDefinition s
arguments) = TypeName -> Maybe TypeName
forall a. a -> Maybe a
Just (TypeName -> Maybe TypeName) -> TypeName -> Maybe TypeName
forall a b. (a -> b) -> a -> b
$ FieldName -> TypeName
genArgsTypeName FieldName
fieldName
fieldCont FieldContent TRUE OUT s
_ = Maybe TypeName
forall a. Maybe a
Nothing
data BuildPlan s
= ConsIN [ServerConsD IN s]
| ConsOUT [ServerTypeDefinition IN s] [ServerConsD OUT s]
genTypeContent ::
[TypeDefinition ANY s] ->
(FieldName -> TypeName) ->
TypeName ->
TypeContent TRUE ANY s ->
Q (BuildPlan s)
genTypeContent :: [TypeDefinition ANY s]
-> (FieldName -> TypeName)
-> TypeName
-> TypeContent TRUE ANY s
-> Q (BuildPlan s)
genTypeContent [TypeDefinition ANY s]
_ FieldName -> TypeName
_ TypeName
_ DataScalar {} = BuildPlan s -> Q (BuildPlan s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ServerConsD IN s] -> BuildPlan s
forall (s :: Stage). [ServerConsD IN s] -> BuildPlan s
ConsIN [])
genTypeContent [TypeDefinition ANY s]
_ FieldName -> TypeName
_ TypeName
_ (DataEnum DataEnum s
tags) = BuildPlan s -> Q (BuildPlan s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BuildPlan s -> Q (BuildPlan s)) -> BuildPlan s -> Q (BuildPlan s)
forall a b. (a -> b) -> a -> b
$ [ServerConsD IN s] -> BuildPlan s
forall (s :: Stage). [ServerConsD IN s] -> BuildPlan s
ConsIN ((DataEnumValue s -> ServerConsD IN s)
-> DataEnum s -> [ServerConsD IN s]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DataEnumValue s -> ServerConsD IN s
forall (s :: Stage) f. DataEnumValue s -> ConsD f
mkConsEnum DataEnum s
tags)
genTypeContent [TypeDefinition ANY s]
_ FieldName -> TypeName
_ TypeName
typeName (DataInputObject FieldsDefinition IN s
fields) =
BuildPlan s -> Q (BuildPlan s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BuildPlan s -> Q (BuildPlan s)) -> BuildPlan s -> Q (BuildPlan s)
forall a b. (a -> b) -> a -> b
$ [ServerConsD IN s] -> BuildPlan s
forall (s :: Stage). [ServerConsD IN s] -> BuildPlan s
ConsIN (TypeName -> [ServerFieldDefinition IN s] -> [ServerConsD IN s]
forall (cat :: TypeCategory) (s :: Stage).
TypeName -> [ServerFieldDefinition cat s] -> [ServerConsD cat s]
mkObjectCons TypeName
typeName ([ServerFieldDefinition IN s] -> [ServerConsD IN s])
-> [ServerFieldDefinition IN s] -> [ServerConsD IN s]
forall a b. (a -> b) -> a -> b
$ (FieldDefinition IN s -> ServerFieldDefinition IN s)
-> [FieldDefinition IN s] -> [ServerFieldDefinition IN s]
forall a b. (a -> b) -> [a] -> [b]
map FieldDefinition IN s -> ServerFieldDefinition IN s
forall (c :: TypeCategory) (s :: Stage).
FieldDefinition c s -> ServerFieldDefinition c s
toServerField ([FieldDefinition IN s] -> [ServerFieldDefinition IN s])
-> [FieldDefinition IN s] -> [ServerFieldDefinition IN s]
forall a b. (a -> b) -> a -> b
$ FieldsDefinition IN s -> [FieldDefinition IN s]
forall a coll. Elems a coll => coll -> [a]
elems FieldsDefinition IN s
fields)
genTypeContent [TypeDefinition ANY s]
_ FieldName -> TypeName
_ TypeName
_ DataInputUnion {} = String -> Q (BuildPlan s)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Input Unions not Supported"
genTypeContent [TypeDefinition ANY s]
schema FieldName -> TypeName
toArgsTyName TypeName
typeName DataInterface {FieldsDefinition OUT s
interfaceFields :: forall (a :: TypeCategory) (s :: Stage).
CondTypeContent IMPLEMENTABLE a s -> FieldsDefinition OUT s
interfaceFields :: FieldsDefinition OUT s
interfaceFields} = do
[ServerTypeDefinition IN s]
typeArgD <- (FieldName -> TypeName)
-> FieldsDefinition OUT s -> Q [ServerTypeDefinition IN s]
forall (s :: Stage).
(FieldName -> TypeName)
-> FieldsDefinition OUT s -> Q [ServerTypeDefinition IN s]
genArgumentTypes FieldName -> TypeName
toArgsTyName FieldsDefinition OUT s
interfaceFields
[ServerConsD OUT s]
objCons <- TypeName -> [ServerFieldDefinition OUT s] -> [ServerConsD OUT s]
forall (cat :: TypeCategory) (s :: Stage).
TypeName -> [ServerFieldDefinition cat s] -> [ServerConsD cat s]
mkObjectCons TypeName
typeName ([ServerFieldDefinition OUT s] -> [ServerConsD OUT s])
-> Q [ServerFieldDefinition OUT s] -> Q [ServerConsD OUT s]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FieldDefinition OUT s -> Q (ServerFieldDefinition OUT s))
-> [FieldDefinition OUT s] -> Q [ServerFieldDefinition OUT s]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ([TypeDefinition ANY s]
-> (FieldName -> TypeName)
-> FieldDefinition OUT s
-> Q (ServerFieldDefinition OUT s)
forall (s :: Stage).
[TypeDefinition ANY s]
-> (FieldName -> TypeName)
-> FieldDefinition OUT s
-> Q (ServerFieldDefinition OUT s)
mkObjectField [TypeDefinition ANY s]
schema FieldName -> TypeName
toArgsTyName) (FieldsDefinition OUT s -> [FieldDefinition OUT s]
forall a coll. Elems a coll => coll -> [a]
elems FieldsDefinition OUT s
interfaceFields)
BuildPlan s -> Q (BuildPlan s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BuildPlan s -> Q (BuildPlan s)) -> BuildPlan s -> Q (BuildPlan s)
forall a b. (a -> b) -> a -> b
$ [ServerTypeDefinition IN s] -> [ServerConsD OUT s] -> BuildPlan s
forall (s :: Stage).
[ServerTypeDefinition IN s] -> [ServerConsD OUT s] -> BuildPlan s
ConsOUT [ServerTypeDefinition IN s]
typeArgD [ServerConsD OUT s]
objCons
genTypeContent [TypeDefinition ANY s]
schema FieldName -> TypeName
toArgsTyName TypeName
typeName DataObject {FieldsDefinition OUT s
objectFields :: forall (a :: TypeCategory) (s :: Stage).
CondTypeContent OBJECT a s -> FieldsDefinition OUT s
objectFields :: FieldsDefinition OUT s
objectFields} = do
[ServerTypeDefinition IN s]
typeArgD <- (FieldName -> TypeName)
-> FieldsDefinition OUT s -> Q [ServerTypeDefinition IN s]
forall (s :: Stage).
(FieldName -> TypeName)
-> FieldsDefinition OUT s -> Q [ServerTypeDefinition IN s]
genArgumentTypes FieldName -> TypeName
toArgsTyName FieldsDefinition OUT s
objectFields
[ServerConsD OUT s]
objCons <-
TypeName -> [ServerFieldDefinition OUT s] -> [ServerConsD OUT s]
forall (cat :: TypeCategory) (s :: Stage).
TypeName -> [ServerFieldDefinition cat s] -> [ServerConsD cat s]
mkObjectCons TypeName
typeName
([ServerFieldDefinition OUT s] -> [ServerConsD OUT s])
-> Q [ServerFieldDefinition OUT s] -> Q [ServerConsD OUT s]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FieldDefinition OUT s -> Q (ServerFieldDefinition OUT s))
-> [FieldDefinition OUT s] -> Q [ServerFieldDefinition OUT s]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ([TypeDefinition ANY s]
-> (FieldName -> TypeName)
-> FieldDefinition OUT s
-> Q (ServerFieldDefinition OUT s)
forall (s :: Stage).
[TypeDefinition ANY s]
-> (FieldName -> TypeName)
-> FieldDefinition OUT s
-> Q (ServerFieldDefinition OUT s)
mkObjectField [TypeDefinition ANY s]
schema FieldName -> TypeName
toArgsTyName) (FieldsDefinition OUT s -> [FieldDefinition OUT s]
forall a coll. Elems a coll => coll -> [a]
elems FieldsDefinition OUT s
objectFields)
BuildPlan s -> Q (BuildPlan s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BuildPlan s -> Q (BuildPlan s)) -> BuildPlan s -> Q (BuildPlan s)
forall a b. (a -> b) -> a -> b
$ [ServerTypeDefinition IN s] -> [ServerConsD OUT s] -> BuildPlan s
forall (s :: Stage).
[ServerTypeDefinition IN s] -> [ServerConsD OUT s] -> BuildPlan s
ConsOUT [ServerTypeDefinition IN s]
typeArgD [ServerConsD OUT s]
objCons
genTypeContent [TypeDefinition ANY s]
_ FieldName -> TypeName
_ TypeName
typeName (DataUnion DataUnion s
members) =
BuildPlan s -> Q (BuildPlan s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BuildPlan s -> Q (BuildPlan s)) -> BuildPlan s -> Q (BuildPlan s)
forall a b. (a -> b) -> a -> b
$ [ServerTypeDefinition IN s] -> [ServerConsD OUT s] -> BuildPlan s
forall (s :: Stage).
[ServerTypeDefinition IN s] -> [ServerConsD OUT s] -> BuildPlan s
ConsOUT [] ((UnionMember OUT s -> ServerConsD OUT s)
-> DataUnion s -> [ServerConsD OUT s]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UnionMember OUT s -> ServerConsD OUT s
unionCon DataUnion s
members)
where
unionCon :: UnionMember OUT s -> ServerConsD OUT s
unionCon UnionMember {TypeName
memberName :: forall (cat :: TypeCategory) (s :: Stage).
UnionMember cat s -> TypeName
memberName :: TypeName
memberName} =
TypeName -> [ServerFieldDefinition OUT s] -> ServerConsD OUT s
forall (cat :: TypeCategory) (s :: Stage).
TypeName -> [ServerFieldDefinition cat s] -> ServerConsD cat s
mkCons
TypeName
cName
([ServerFieldDefinition OUT s] -> ServerConsD OUT s)
-> [ServerFieldDefinition OUT s] -> ServerConsD OUT s
forall a b. (a -> b) -> a -> b
$ ServerFieldDefinition OUT s -> [ServerFieldDefinition OUT s]
forall a coll. Collection a coll => a -> coll
singleton
ServerFieldDefinition :: forall (cat :: TypeCategory) (s :: Stage).
Bool
-> Maybe TypeName
-> FieldDefinition cat s
-> ServerFieldDefinition cat s
ServerFieldDefinition
{ isParametrized :: Bool
isParametrized = Bool
True,
argumentsTypeName :: Maybe TypeName
argumentsTypeName = Maybe TypeName
forall a. Maybe a
Nothing,
originalField :: FieldDefinition OUT s
originalField =
FieldDefinition :: forall (cat :: TypeCategory) (s :: Stage).
Maybe Description
-> FieldName
-> TypeRef
-> Maybe (FieldContent TRUE cat s)
-> [Directive s]
-> FieldDefinition cat s
FieldDefinition
{ fieldName :: FieldName
fieldName = FieldName
"un" FieldName -> FieldName -> FieldName
forall a. Semigroup a => a -> a -> a
<> TypeName -> FieldName
toFieldName TypeName
cName,
fieldType :: TypeRef
fieldType =
TypeRef :: TypeName -> [TypeWrapper] -> TypeRef
TypeRef
{ typeConName :: TypeName
typeConName = TypeName
utName,
typeWrappers :: [TypeWrapper]
typeWrappers = []
},
fieldDescription :: Maybe Description
fieldDescription = Maybe Description
forall a. Maybe a
Nothing,
fieldDirectives :: [Directive s]
fieldDirectives = [Directive s]
forall coll. Empty coll => coll
empty,
fieldContent :: Maybe (FieldContent TRUE OUT s)
fieldContent = Maybe (FieldContent TRUE OUT s)
forall a. Maybe a
Nothing
}
}
where
cName :: TypeName
cName = TypeName -> TypeName
hsTypeName TypeName
typeName TypeName -> TypeName -> TypeName
forall a. Semigroup a => a -> a -> a
<> TypeName
utName
utName :: TypeName
utName = TypeName -> TypeName
hsTypeName TypeName
memberName
genArgumentTypes :: (FieldName -> TypeName) -> FieldsDefinition OUT s -> Q [ServerTypeDefinition IN s]
genArgumentTypes :: (FieldName -> TypeName)
-> FieldsDefinition OUT s -> Q [ServerTypeDefinition IN s]
genArgumentTypes FieldName -> TypeName
genArgsTypeName FieldsDefinition OUT s
fields =
[[ServerTypeDefinition IN s]] -> [ServerTypeDefinition IN s]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[ServerTypeDefinition IN s]] -> [ServerTypeDefinition IN s])
-> Q [[ServerTypeDefinition IN s]] -> Q [ServerTypeDefinition IN s]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FieldDefinition OUT s -> Q [ServerTypeDefinition IN s])
-> [FieldDefinition OUT s] -> Q [[ServerTypeDefinition IN s]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((FieldName -> TypeName)
-> FieldDefinition OUT s -> Q [ServerTypeDefinition IN s]
forall (s :: Stage).
(FieldName -> TypeName)
-> FieldDefinition OUT s -> Q [ServerTypeDefinition IN s]
genArgumentType FieldName -> TypeName
genArgsTypeName) (FieldsDefinition OUT s -> [FieldDefinition OUT s]
forall a coll. Elems a coll => coll -> [a]
elems FieldsDefinition OUT s
fields)
genArgumentType :: (FieldName -> TypeName) -> FieldDefinition OUT s -> Q [ServerTypeDefinition IN s]
genArgumentType :: (FieldName -> TypeName)
-> FieldDefinition OUT s -> Q [ServerTypeDefinition IN s]
genArgumentType FieldName -> TypeName
namespaceWith 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 s
arguments)}
| Bool -> Bool
not (ArgumentsDefinition s -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ArgumentsDefinition s
arguments) =
[ServerTypeDefinition IN s] -> Q [ServerTypeDefinition IN s]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
[ ServerTypeDefinition :: forall (cat :: TypeCategory) (s :: Stage).
TypeName
-> [ServerTypeDefinition IN s]
-> [ServerConsD cat s]
-> TypeKind
-> Maybe (TypeDefinition ANY s)
-> ServerTypeDefinition cat s
ServerTypeDefinition
{ TypeName
tName :: TypeName
tName :: TypeName
tName,
tCons :: [ServerConsD IN s]
tCons = [TypeName -> [ServerFieldDefinition IN s] -> ServerConsD IN s
forall (cat :: TypeCategory) (s :: Stage).
TypeName -> [ServerFieldDefinition cat s] -> ServerConsD cat s
mkCons TypeName
tName ([ServerFieldDefinition IN s] -> ServerConsD IN s)
-> [ServerFieldDefinition IN s] -> ServerConsD IN s
forall a b. (a -> b) -> a -> b
$ (ArgumentDefinition s -> ServerFieldDefinition IN s)
-> [ArgumentDefinition s] -> [ServerFieldDefinition IN s]
forall a b. (a -> b) -> [a] -> [b]
map (FieldDefinition IN s -> ServerFieldDefinition IN s
forall (c :: TypeCategory) (s :: Stage).
FieldDefinition c s -> ServerFieldDefinition c s
toServerField (FieldDefinition IN s -> ServerFieldDefinition IN s)
-> (ArgumentDefinition s -> FieldDefinition IN s)
-> ArgumentDefinition s
-> ServerFieldDefinition IN s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArgumentDefinition s -> FieldDefinition IN s
forall (s :: Stage). ArgumentDefinition s -> FieldDefinition IN s
argument) ([ArgumentDefinition s] -> [ServerFieldDefinition IN s])
-> [ArgumentDefinition s] -> [ServerFieldDefinition IN s]
forall a b. (a -> b) -> a -> b
$ ArgumentsDefinition s -> [ArgumentDefinition s]
forall a coll. Elems a coll => coll -> [a]
elems ArgumentsDefinition s
arguments],
tKind :: TypeKind
tKind = TypeKind
KindInputObject,
typeArgD :: [ServerTypeDefinition IN s]
typeArgD = [],
typeOriginal :: Maybe (TypeDefinition ANY s)
typeOriginal = Maybe (TypeDefinition ANY s)
forall a. Maybe a
Nothing
}
]
where
tName :: TypeName
tName = TypeName -> TypeName
hsTypeName (FieldName -> TypeName
namespaceWith FieldName
fieldName)
genArgumentType FieldName -> TypeName
_ FieldDefinition OUT s
_ = [ServerTypeDefinition IN s] -> Q [ServerTypeDefinition IN s]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []