{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Data.Morpheus.Server.TH.Transform
( toTHDefinitions,
TypeDec (..),
)
where
import Control.Applicative (pure)
import Control.Monad ((>>=))
import Control.Monad.Fail (fail)
import Data.Functor ((<$>), fmap)
import Data.Morpheus.Internal.TH
( infoTyVars,
toName,
)
import Data.Morpheus.Internal.Utils
( capitalTypeName,
elems,
empty,
singleton,
)
import Data.Morpheus.Server.Internal.TH.Types (ServerTypeDefinition (..))
import Data.Morpheus.Types.Internal.AST
( ANY,
ArgumentsDefinition (..),
ConsD,
FieldContent (..),
FieldDefinition (..),
FieldName,
FieldsDefinition,
IN,
OUT,
TRUE,
TypeContent (..),
TypeDefinition (..),
TypeKind (..),
TypeName,
TypeRef (..),
UnionMember (..),
hsTypeName,
kindOf,
lookupWith,
mkCons,
mkConsEnum,
toFieldName,
)
import Data.Semigroup ((<>))
import Language.Haskell.TH
import Prelude
( ($),
Bool (..),
Maybe (..),
String,
concat,
not,
null,
otherwise,
traverse,
)
m_ :: String
m_ :: String
m_ = String
"m"
getTypeArgs :: TypeName -> [TypeDefinition ANY s] -> Q (Maybe String)
getTypeArgs :: TypeName -> [TypeDefinition ANY s] -> Q (Maybe String)
getTypeArgs TypeName
"__TypeKind" [TypeDefinition ANY s]
_ = Maybe String -> Q (Maybe String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
getTypeArgs TypeName
"Boolean" [TypeDefinition ANY s]
_ = Maybe String -> Q (Maybe String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
getTypeArgs TypeName
"String" [TypeDefinition ANY s]
_ = Maybe String -> Q (Maybe String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
getTypeArgs TypeName
"Int" [TypeDefinition ANY s]
_ = Maybe String -> Q (Maybe String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
getTypeArgs TypeName
"Float" [TypeDefinition ANY s]
_ = Maybe String -> Q (Maybe String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
getTypeArgs TypeName
key [TypeDefinition ANY s]
lib = case TypeDefinition ANY s -> TypeContent TRUE ANY s
forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent (TypeDefinition ANY s -> TypeContent TRUE ANY s)
-> Maybe (TypeDefinition ANY s) -> Maybe (TypeContent TRUE ANY s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TypeDefinition ANY s -> TypeName)
-> TypeName
-> [TypeDefinition ANY s]
-> Maybe (TypeDefinition ANY s)
forall k a. Eq k => (a -> k) -> k -> [a] -> Maybe a
lookupWith TypeDefinition ANY s -> TypeName
forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName TypeName
key [TypeDefinition ANY s]
lib of
Just TypeContent TRUE ANY s
x -> Maybe String -> Q (Maybe String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeContent TRUE ANY s -> Maybe String
forall (s :: Stage). TypeContent TRUE ANY s -> Maybe String
kindToTyArgs TypeContent TRUE ANY s
x)
Maybe (TypeContent TRUE ANY s)
Nothing -> Info -> Maybe String
getTyArgs (Info -> Maybe String) -> Q Info -> Q (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q Info
reify (TypeName -> Name
forall a. ToName a => a -> Name
toName TypeName
key)
getTyArgs :: Info -> Maybe String
getTyArgs :: Info -> Maybe String
getTyArgs Info
x
| [TyVarBndr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Info -> [TyVarBndr]
infoTyVars Info
x) = Maybe String
forall a. Maybe a
Nothing
| Bool
otherwise = String -> Maybe String
forall a. a -> Maybe a
Just String
m_
kindToTyArgs :: TypeContent TRUE ANY s -> Maybe String
kindToTyArgs :: TypeContent TRUE ANY s -> Maybe String
kindToTyArgs DataObject {} = String -> Maybe String
forall a. a -> Maybe a
Just String
m_
kindToTyArgs DataUnion {} = String -> Maybe String
forall a. a -> Maybe a
Just String
m_
kindToTyArgs DataInterface {} = String -> Maybe String
forall a. a -> Maybe a
Just String
m_
kindToTyArgs TypeContent TRUE ANY s
_ = Maybe String
forall a. Maybe a
Nothing
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 :: TypeName
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName,
TypeContent TRUE ANY s
typeContent :: TypeContent TRUE ANY s
typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a 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 [ConsD 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]
-> [ConsD cat s]
-> TypeKind
-> Maybe (TypeDefinition ANY s)
-> ServerTypeDefinition cat s
ServerTypeDefinition
{ tName :: TypeName
tName = TypeName -> TypeName
hsTypeName TypeName
typeName,
[ConsD IN s]
tCons :: [ConsD IN s]
tCons :: [ConsD IN s]
tCons,
typeArgD :: [ServerTypeDefinition IN s]
typeArgD = [ServerTypeDefinition IN s]
forall a coll. Collection a 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 [ConsD 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]
-> [ConsD cat s]
-> TypeKind
-> Maybe (TypeDefinition ANY s)
-> ServerTypeDefinition cat s
ServerTypeDefinition
{ tName :: TypeName
tName = TypeName -> TypeName
hsTypeName TypeName
typeName,
[ConsD OUT s]
tCons :: [ConsD OUT s]
tCons :: [ConsD 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
..
}
mkObjectCons :: TypeName -> FieldsDefinition cat s -> [ConsD cat s]
mkObjectCons :: TypeName -> FieldsDefinition cat s -> [ConsD cat s]
mkObjectCons TypeName
typeName FieldsDefinition cat s
fields = [TypeName -> FieldsDefinition cat s -> ConsD cat s
forall (cat :: TypeCategory) (s :: Stage).
TypeName -> FieldsDefinition cat s -> ConsD cat s
mkCons TypeName
typeName FieldsDefinition 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 (FieldDefinition OUT s)
mkObjectField :: [TypeDefinition ANY s]
-> (FieldName -> TypeName)
-> FieldDefinition OUT s
-> Q (FieldDefinition OUT s)
mkObjectField [TypeDefinition ANY s]
schema FieldName -> TypeName
genArgsTypeName FieldDefinition {FieldName
fieldName :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldName :: FieldName
fieldName, fieldContent :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Maybe (FieldContent TRUE cat s)
fieldContent = Maybe (FieldContent TRUE OUT s)
cont, fieldType :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> TypeRef
fieldType = typeRef :: TypeRef
typeRef@TypeRef {TypeName
typeConName :: TypeRef -> TypeName
typeConName :: TypeName
typeConName}, [Directive s]
Maybe Description
fieldDescription :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Maybe Description
fieldDirectives :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> [Directive s]
fieldDirectives :: [Directive s]
fieldDescription :: Maybe Description
..} =
do
Maybe String
typeArgs <- TypeName -> [TypeDefinition ANY s] -> Q (Maybe String)
forall (s :: Stage).
TypeName -> [TypeDefinition ANY s] -> Q (Maybe String)
getTypeArgs TypeName
typeConName [TypeDefinition ANY s]
schema
FieldDefinition OUT s -> Q (FieldDefinition OUT s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
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 :: FieldName
fieldName,
fieldType :: TypeRef
fieldType = TypeRef
typeRef {typeConName :: TypeName
typeConName = TypeName -> TypeName
hsTypeName TypeName
typeConName, Maybe String
typeArgs :: Maybe String
typeArgs :: Maybe String
typeArgs},
fieldContent :: Maybe (FieldContent TRUE OUT s)
fieldContent = Maybe (FieldContent TRUE OUT s)
cont Maybe (FieldContent TRUE OUT s)
-> (FieldContent TRUE OUT s -> Maybe (FieldContent TRUE OUT s))
-> Maybe (FieldContent TRUE OUT s)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FieldContent TRUE OUT s -> Maybe (FieldContent TRUE OUT s)
forall (s :: Stage).
FieldContent TRUE OUT s -> Maybe (FieldContent TRUE OUT s)
fieldCont,
[Directive s]
Maybe Description
fieldDescription :: Maybe Description
fieldDirectives :: [Directive s]
fieldDirectives :: [Directive s]
fieldDescription :: Maybe Description
..
}
where
fieldCont :: FieldContent TRUE OUT s -> Maybe (FieldContent TRUE OUT s)
fieldCont :: FieldContent TRUE OUT s -> Maybe (FieldContent TRUE OUT s)
fieldCont (FieldArgs ArgumentsDefinition {OrdMap FieldName (ArgumentDefinition s)
arguments :: forall (s :: Stage).
ArgumentsDefinition s -> OrdMap FieldName (ArgumentDefinition s)
arguments :: OrdMap FieldName (ArgumentDefinition s)
arguments})
| Bool -> Bool
not (OrdMap FieldName (ArgumentDefinition s) -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null OrdMap FieldName (ArgumentDefinition s)
arguments) =
FieldContent TRUE OUT s -> Maybe (FieldContent TRUE OUT s)
forall a. a -> Maybe a
Just (FieldContent TRUE OUT s -> Maybe (FieldContent TRUE OUT s))
-> FieldContent TRUE OUT s -> Maybe (FieldContent TRUE OUT s)
forall a b. (a -> b) -> a -> b
$ ArgumentsDefinition s -> FieldContent (ELEM OUT OUT) OUT s
forall (s :: Stage) (cat :: TypeCategory).
ArgumentsDefinition s -> FieldContent (ELEM OUT cat) cat s
FieldArgs (ArgumentsDefinition s -> FieldContent (ELEM OUT OUT) OUT s)
-> ArgumentsDefinition s -> FieldContent (ELEM OUT OUT) OUT s
forall a b. (a -> b) -> a -> b
$
ArgumentsDefinition :: forall (s :: Stage).
Maybe TypeName
-> OrdMap FieldName (ArgumentDefinition s) -> ArgumentsDefinition s
ArgumentsDefinition
{ argumentsTypename :: Maybe TypeName
argumentsTypename = 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,
arguments :: OrdMap FieldName (ArgumentDefinition s)
arguments = OrdMap FieldName (ArgumentDefinition s)
arguments
}
fieldCont FieldContent TRUE OUT s
_ = Maybe (FieldContent TRUE OUT s)
forall a. Maybe a
Nothing
data BuildPlan s
= ConsIN [ConsD IN s]
| ConsOUT [ServerTypeDefinition IN s] [ConsD 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 ([ConsD IN s] -> BuildPlan s
forall (s :: Stage). [ConsD 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
$ [ConsD IN s] -> BuildPlan s
forall (s :: Stage). [ConsD IN s] -> BuildPlan s
ConsIN ((DataEnumValue s -> ConsD IN s) -> DataEnum s -> [ConsD IN s]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DataEnumValue s -> ConsD IN s
forall (s :: Stage) (cat :: TypeCategory).
DataEnumValue s -> ConsD cat s
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
$ [ConsD IN s] -> BuildPlan s
forall (s :: Stage). [ConsD IN s] -> BuildPlan s
ConsIN (TypeName -> FieldsDefinition IN s -> [ConsD IN s]
forall (cat :: TypeCategory) (s :: Stage).
TypeName -> FieldsDefinition cat s -> [ConsD cat s]
mkObjectCons TypeName
typeName 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).
TypeContent (ELEM IMPLEMENTABLE a) 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
[ConsD OUT s]
objCons <- TypeName -> FieldsDefinition OUT s -> [ConsD OUT s]
forall (cat :: TypeCategory) (s :: Stage).
TypeName -> FieldsDefinition cat s -> [ConsD cat s]
mkObjectCons TypeName
typeName (FieldsDefinition OUT s -> [ConsD OUT s])
-> Q (FieldsDefinition OUT s) -> Q [ConsD OUT s]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FieldDefinition OUT s -> Q (FieldDefinition OUT s))
-> FieldsDefinition OUT s -> Q (FieldsDefinition 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 (FieldDefinition OUT s)
forall (s :: Stage).
[TypeDefinition ANY s]
-> (FieldName -> TypeName)
-> FieldDefinition OUT s
-> Q (FieldDefinition OUT s)
mkObjectField [TypeDefinition ANY s]
schema FieldName -> TypeName
toArgsTyName) 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] -> [ConsD OUT s] -> BuildPlan s
forall (s :: Stage).
[ServerTypeDefinition IN s] -> [ConsD OUT s] -> BuildPlan s
ConsOUT [ServerTypeDefinition IN s]
typeArgD [ConsD OUT s]
objCons
genTypeContent [TypeDefinition ANY s]
schema FieldName -> TypeName
toArgsTyName TypeName
typeName DataObject {FieldsDefinition OUT s
objectFields :: forall (a :: TypeCategory) (s :: Stage).
TypeContent (ELEM OBJECT a) 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
[ConsD OUT s]
objCons <-
TypeName -> FieldsDefinition OUT s -> [ConsD OUT s]
forall (cat :: TypeCategory) (s :: Stage).
TypeName -> FieldsDefinition cat s -> [ConsD cat s]
mkObjectCons TypeName
typeName
(FieldsDefinition OUT s -> [ConsD OUT s])
-> Q (FieldsDefinition OUT s) -> Q [ConsD OUT s]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FieldDefinition OUT s -> Q (FieldDefinition OUT s))
-> FieldsDefinition OUT s -> Q (FieldsDefinition 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 (FieldDefinition OUT s)
forall (s :: Stage).
[TypeDefinition ANY s]
-> (FieldName -> TypeName)
-> FieldDefinition OUT s
-> Q (FieldDefinition OUT s)
mkObjectField [TypeDefinition ANY s]
schema FieldName -> TypeName
toArgsTyName) 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] -> [ConsD OUT s] -> BuildPlan s
forall (s :: Stage).
[ServerTypeDefinition IN s] -> [ConsD OUT s] -> BuildPlan s
ConsOUT [ServerTypeDefinition IN s]
typeArgD [ConsD 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] -> [ConsD OUT s] -> BuildPlan s
forall (s :: Stage).
[ServerTypeDefinition IN s] -> [ConsD OUT s] -> BuildPlan s
ConsOUT [] ((UnionMember OUT s -> ConsD OUT s) -> DataUnion s -> [ConsD OUT s]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UnionMember OUT s -> ConsD OUT s
unionCon DataUnion s
members)
where
unionCon :: UnionMember OUT s -> ConsD OUT s
unionCon UnionMember {TypeName
memberName :: forall (cat :: TypeCategory) (s :: Stage).
UnionMember cat s -> TypeName
memberName :: TypeName
memberName} =
TypeName -> FieldsDefinition OUT s -> ConsD OUT s
forall (cat :: TypeCategory) (s :: Stage).
TypeName -> FieldsDefinition cat s -> ConsD cat s
mkCons
TypeName
cName
( FieldDefinition OUT s -> FieldsDefinition OUT s
forall a coll. Collection a coll => a -> coll
singleton
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 -> Maybe String -> [TypeWrapper] -> TypeRef
TypeRef
{ typeConName :: TypeName
typeConName = TypeName
utName,
typeArgs :: Maybe String
typeArgs = String -> Maybe String
forall a. a -> Maybe a
Just String
m_,
typeWrappers :: [TypeWrapper]
typeWrappers = []
},
fieldDescription :: Maybe Description
fieldDescription = Maybe Description
forall a. Maybe a
Nothing,
fieldDirectives :: [Directive s]
fieldDirectives = [Directive s]
forall a coll. Collection a 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 {OrdMap FieldName (ArgumentDefinition s)
arguments :: OrdMap FieldName (ArgumentDefinition s)
arguments :: forall (s :: Stage).
ArgumentsDefinition s -> OrdMap FieldName (ArgumentDefinition s)
arguments})}
| Bool -> Bool
not (OrdMap FieldName (ArgumentDefinition s) -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null OrdMap FieldName (ArgumentDefinition 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]
-> [ConsD cat s]
-> TypeKind
-> Maybe (TypeDefinition ANY s)
-> ServerTypeDefinition cat s
ServerTypeDefinition
{ TypeName
tName :: TypeName
tName :: TypeName
tName,
tCons :: [ConsD IN s]
tCons = [TypeName -> OrdMap FieldName (ArgumentDefinition s) -> ConsD IN s
forall (cat :: TypeCategory) (s :: Stage).
TypeName -> FieldsDefinition cat s -> ConsD cat s
mkCons TypeName
tName OrdMap FieldName (ArgumentDefinition 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 []