{-# 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 []