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

module Data.Morpheus.Server.TH.Transform
  ( toTHDefinitions,
    TypeDec (..),
  )
where

-- MORPHEUS

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