{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} module Data.Morpheus.Server.Deriving.Schema.TypeContent ( buildTypeContent, insertTypeContent, deriveTypeContentWith, ) where import Data.Morpheus.Server.Deriving.Schema.Directive (deriveTypeDirectives) import Data.Morpheus.Server.Deriving.Schema.Enum ( buildEnumTypeContent, ) import Data.Morpheus.Server.Deriving.Schema.Internal ( KindedType (..), TyContent, ) import Data.Morpheus.Server.Deriving.Schema.Object ( buildObjectTypeContent, ) import Data.Morpheus.Server.Deriving.Schema.Union (buildUnionTypeContent) import Data.Morpheus.Server.Deriving.Utils ( ConsRep (..), DeriveTypeOptions, DeriveWith, deriveTypeWith, isEmptyConstraint, unpackMonad, ) import Data.Morpheus.Server.Deriving.Utils.Kinded ( CategoryValue (..), ) import Data.Morpheus.Server.Types.GQLType ( GQLType (..), deriveFingerprint, deriveTypename, ) import Data.Morpheus.Server.Types.SchemaT ( SchemaT, updateSchema, ) import Data.Morpheus.Types.Internal.AST import GHC.Generics (Rep) buildTypeContent :: (GQLType a, CategoryValue kind) => KindedType kind a -> [ConsRep (TyContent kind)] -> SchemaT kind (TypeContent TRUE kind CONST) buildTypeContent :: forall a (kind :: TypeCategory). (GQLType a, CategoryValue kind) => KindedType kind a -> [ConsRep (TyContent kind)] -> SchemaT kind (TypeContent TRUE kind CONST) buildTypeContent KindedType kind a scope [ConsRep (TyContent kind)] cons | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool all forall a. ConsRep a -> Bool isEmptyConstraint [ConsRep (TyContent kind)] cons = forall a (kind :: TypeCategory) (c :: TypeCategory). GQLType a => KindedType kind a -> [TypeName] -> SchemaT c (TypeContent TRUE kind CONST) buildEnumTypeContent KindedType kind a scope (forall v. ConsRep v -> TypeName consName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [ConsRep (TyContent kind)] cons) buildTypeContent KindedType kind a scope [ConsRep {[FieldRep (TyContent kind)] consFields :: forall v. ConsRep v -> [FieldRep v] consFields :: [FieldRep (TyContent kind)] consFields}] = forall a (cat :: TypeCategory) (c :: TypeCategory). GQLType a => KindedType cat a -> [FieldRep (Maybe (FieldContent TRUE cat CONST))] -> SchemaT c (TypeContent TRUE cat CONST) buildObjectTypeContent KindedType kind a scope [FieldRep (TyContent kind)] consFields buildTypeContent KindedType kind a scope [ConsRep (TyContent kind)] cons = forall a (kind :: TypeCategory) (c :: TypeCategory). (GQLType a, CategoryValue kind) => KindedType kind a -> [ConsRep (Maybe (FieldContent TRUE kind CONST))] -> SchemaT c (TypeContent TRUE kind CONST) buildUnionTypeContent KindedType kind a scope [ConsRep (TyContent kind)] cons insertTypeContent :: (GQLType a, CategoryValue kind) => (f kind a -> SchemaT c (TypeContent TRUE kind CONST)) -> f kind a -> SchemaT c () insertTypeContent :: forall a (kind :: TypeCategory) (f :: TypeCategory -> * -> *) (c :: TypeCategory). (GQLType a, CategoryValue kind) => (f kind a -> SchemaT c (TypeContent TRUE kind CONST)) -> f kind a -> SchemaT c () insertTypeContent f kind a -> SchemaT c (TypeContent TRUE kind CONST) f f kind a proxy = forall a (cat' :: TypeCategory) (cat :: TypeCategory). TypeFingerprint -> (a -> SchemaT cat' (TypeDefinition cat CONST)) -> a -> SchemaT cat' () updateSchema (forall a (kind :: TypeCategory) (kinded :: TypeCategory -> * -> *). (GQLType a, CategoryValue kind) => kinded kind a -> TypeFingerprint deriveFingerprint f kind a proxy) f kind a -> SchemaT c (TypeDefinition kind CONST) deriveD f kind a proxy where deriveD :: f kind a -> SchemaT c (TypeDefinition kind CONST) deriveD f kind a x = do TypeContent TRUE kind CONST content <- f kind a -> SchemaT c (TypeContent TRUE kind CONST) f f kind a x Directives CONST dirs <- forall (c :: TypeCategory) (f :: * -> *) a. GQLType a => f a -> SchemaT c (Directives CONST) deriveTypeDirectives f kind a proxy forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ forall (a :: TypeCategory) (s :: Stage). Maybe Description -> TypeName -> Directives s -> TypeContent TRUE a s -> TypeDefinition a s TypeDefinition (forall a (f :: * -> *). GQLType a => f a -> Maybe Description description f kind a proxy) (forall a (kind :: TypeCategory) (kinded :: TypeCategory -> * -> *). (GQLType a, CategoryValue kind) => kinded kind a -> TypeName deriveTypename f kind a proxy) Directives CONST dirs TypeContent TRUE kind CONST content deriveTypeContentWith :: ( CategoryValue kind, DeriveWith c (SchemaT kind (TyContent kind)) (Rep a), GQLType a ) => DeriveTypeOptions kind c (SchemaT kind (TyContent kind)) -> KindedType kind a -> SchemaT kind (TypeContent TRUE kind CONST) deriveTypeContentWith :: forall (kind :: TypeCategory) (c :: * -> Constraint) a. (CategoryValue kind, DeriveWith c (SchemaT kind (TyContent kind)) (Rep a), GQLType a) => DeriveTypeOptions kind c (SchemaT kind (TyContent kind)) -> KindedType kind a -> SchemaT kind (TypeContent TRUE kind CONST) deriveTypeContentWith DeriveTypeOptions kind c (SchemaT kind (TyContent kind)) x KindedType kind a kindedProxy = forall (m :: * -> *) a. Monad m => [ConsRep (m a)] -> m [ConsRep a] unpackMonad ( forall (kind :: TypeCategory) (c :: * -> Constraint) v (kinded :: TypeCategory -> * -> *) a. (CategoryValue kind, DeriveWith c v (Rep a)) => DeriveTypeOptions kind c v -> kinded kind a -> [ConsRep v] deriveTypeWith DeriveTypeOptions kind c (SchemaT kind (TyContent kind)) x KindedType kind a kindedProxy ) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= forall a (kind :: TypeCategory). (GQLType a, CategoryValue kind) => KindedType kind a -> [ConsRep (TyContent kind)] -> SchemaT kind (TypeContent TRUE kind CONST) buildTypeContent KindedType kind a kindedProxy