{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE GADTs #-} module Data.Morpheus.Server.Deriving.Internal.Schema.Union ( buildUnionTypeContent, ) where import Data.List (partition) import Data.Morpheus.Internal.Utils (fromElems) import Data.Morpheus.Server.Deriving.Internal.Schema.Enum ( defineEnumUnit, ) import Data.Morpheus.Server.Deriving.Internal.Schema.Object ( defineObjectType, ) import Data.Morpheus.Server.Deriving.Utils.GRep ( ConsRep (..), FieldRep (fieldTypeRef), isEmptyConstraint, isUnionRef, ) import Data.Morpheus.Server.Deriving.Utils.Kinded ( CatType (..), ) import Data.Morpheus.Server.Deriving.Utils.Use (UseGQLType (..), useTypename) import Data.Morpheus.Server.Types.SchemaT ( SchemaT, ) import Data.Morpheus.Types.Internal.AST ( ArgumentsDefinition, CONST, IN, TRUE, TypeContent (..), TypeName, TypeRef (..), UnionMember (..), mkNullaryMember, mkUnionMember, ) import Relude buildUnionTypeContent :: (gql a) => UseGQLType gql -> CatType kind a -> [ConsRep (Maybe (ArgumentsDefinition CONST))] -> SchemaT k (TypeContent TRUE kind CONST) buildUnionTypeContent :: forall (gql :: * -> Constraint) a (kind :: TypeCategory) (k :: TypeCategory). gql a => UseGQLType gql -> CatType kind a -> [ConsRep (Maybe (ArgumentsDefinition CONST))] -> SchemaT k (TypeContent TRUE kind CONST) buildUnionTypeContent UseGQLType gql gql CatType kind a scope [ConsRep (Maybe (ArgumentsDefinition CONST))] cons = forall (kind :: TypeCategory) a (c :: TypeCategory). CatType kind a -> [TypeName] -> [ConsRep (Maybe (ArgumentsDefinition CONST))] -> SchemaT c (TypeContent TRUE kind CONST) mkUnionType CatType kind a scope [TypeName] unionRef [ConsRep (Maybe (ArgumentsDefinition CONST))] unionCons where unionRef :: [TypeName] unionRef = TypeRef -> TypeName typeConName forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. FieldRep a -> TypeRef fieldTypeRef forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap forall v. ConsRep v -> [FieldRep v] consFields [ConsRep (Maybe (ArgumentsDefinition CONST))] unionRefRep ([ConsRep (Maybe (ArgumentsDefinition CONST))] unionRefRep, [ConsRep (Maybe (ArgumentsDefinition CONST))] unionCons) = forall a. (a -> Bool) -> [a] -> ([a], [a]) partition (forall k. TypeName -> ConsRep k -> Bool isUnionRef (forall (gql :: * -> Constraint). UseGQLType gql -> forall (c :: TypeCategory) a. gql a => CatType c a -> TypeName useTypename UseGQLType gql gql CatType kind a scope)) [ConsRep (Maybe (ArgumentsDefinition CONST))] cons mkUnionType :: CatType kind a -> [TypeName] -> [ConsRep (Maybe (ArgumentsDefinition CONST))] -> SchemaT c (TypeContent TRUE kind CONST) mkUnionType :: forall (kind :: TypeCategory) a (c :: TypeCategory). CatType kind a -> [TypeName] -> [ConsRep (Maybe (ArgumentsDefinition CONST))] -> SchemaT c (TypeContent TRUE kind CONST) mkUnionType p :: CatType kind a p@CatType kind a InputType [TypeName] unionRef [ConsRep (Maybe (ArgumentsDefinition CONST))] unionCons = forall (s :: Stage) (a :: TypeCategory). UnionTypeDefinition 'IN s -> TypeContent ('IN <=? a) a s DataInputUnion forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (SchemaT c [UnionMember 'IN CONST] typeMembers forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= forall (m :: * -> *) k a (map :: * -> * -> *). (Monad m, KeyOf k a, FromList m map k a) => [a] -> m (map k a) fromElems) where ([ConsRep (Maybe (ArgumentsDefinition CONST))] nullaryCons, [ConsRep (Maybe (ArgumentsDefinition CONST))] cons) = forall a. (a -> Bool) -> [a] -> ([a], [a]) partition forall a. ConsRep a -> Bool isEmptyConstraint [ConsRep (Maybe (ArgumentsDefinition CONST))] unionCons nullaryMembers :: [UnionMember IN CONST] nullaryMembers :: [UnionMember 'IN CONST] nullaryMembers = forall (cat :: TypeCategory) (s :: Stage). TypeName -> UnionMember cat s mkNullaryMember forall b c a. (b -> c) -> (a -> b) -> a -> c . forall v. ConsRep v -> TypeName consName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [ConsRep (Maybe (ArgumentsDefinition CONST))] nullaryCons defineEnumEmpty :: SchemaT c () defineEnumEmpty | forall (t :: * -> *) a. Foldable t => t a -> Bool null [ConsRep (Maybe (ArgumentsDefinition CONST))] nullaryCons = forall (f :: * -> *) a. Applicative f => a -> f a pure () | Bool otherwise = forall (cat :: TypeCategory). SchemaT cat () defineEnumUnit typeMembers :: SchemaT c [UnionMember 'IN CONST] typeMembers = (forall a. Semigroup a => a -> a -> a <> [UnionMember 'IN CONST] nullaryMembers) forall b c a. (b -> c) -> (a -> b) -> a -> c . [TypeName] -> [UnionMember 'IN CONST] withRefs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> ( SchemaT c () defineEnumEmpty forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b *> forall (kind :: TypeCategory) a (c :: TypeCategory). CatType kind a -> [ConsRep (Maybe (ArgumentsDefinition CONST))] -> SchemaT c [TypeName] buildUnions CatType kind a p [ConsRep (Maybe (ArgumentsDefinition CONST))] cons ) where withRefs :: [TypeName] -> [UnionMember 'IN CONST] withRefs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap forall (cat :: TypeCategory) (s :: Stage). TypeName -> UnionMember cat s mkUnionMember forall b c a. (b -> c) -> (a -> b) -> a -> c . ([TypeName] unionRef forall a. Semigroup a => a -> a -> a <>) mkUnionType p :: CatType kind a p@CatType kind a OutputType [TypeName] unionRef [ConsRep (Maybe (ArgumentsDefinition CONST))] unionCons = forall (s :: Stage) (a :: TypeCategory). UnionTypeDefinition 'OUT s -> TypeContent ('OUT <=? a) a s DataUnion forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (forall (kind :: TypeCategory) a (c :: TypeCategory). CatType kind a -> [ConsRep (Maybe (ArgumentsDefinition CONST))] -> SchemaT c [TypeName] buildUnions CatType kind a p [ConsRep (Maybe (ArgumentsDefinition CONST))] unionCons forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= forall (m :: * -> *) k a (map :: * -> * -> *). (Monad m, KeyOf k a, FromList m map k a) => [a] -> m (map k a) fromElems forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> b) -> [a] -> [b] map forall (cat :: TypeCategory) (s :: Stage). TypeName -> UnionMember cat s mkUnionMember forall b c a. (b -> c) -> (a -> b) -> a -> c . ([TypeName] unionRef forall a. Semigroup a => a -> a -> a <>)) buildUnions :: CatType kind a -> [ConsRep (Maybe (ArgumentsDefinition CONST))] -> SchemaT c [TypeName] buildUnions :: forall (kind :: TypeCategory) a (c :: TypeCategory). CatType kind a -> [ConsRep (Maybe (ArgumentsDefinition CONST))] -> SchemaT c [TypeName] buildUnions CatType kind a proxy [ConsRep (Maybe (ArgumentsDefinition CONST))] cons = forall (t :: * -> *) (f :: * -> *) a b. (Foldable t, Applicative f) => (a -> f b) -> t a -> f () traverse_ (forall (kind :: TypeCategory) a (cat :: TypeCategory). CatType kind a -> ConsRep (Maybe (ArgumentsDefinition CONST)) -> SchemaT cat () defineObjectType CatType kind a proxy) [ConsRep (Maybe (ArgumentsDefinition CONST))] cons forall (f :: * -> *) a b. Functor f => f a -> b -> f b $> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap forall v. ConsRep v -> TypeName consName [ConsRep (Maybe (ArgumentsDefinition CONST))] cons