{-# LANGUAGE GADTs #-} module Data.Morpheus.Server.Deriving.Schema.Union ( buildUnionTypeContent, ) where import Data.List (partition) import Data.Morpheus.Internal.Utils (fromElems) import Data.Morpheus.Server.Deriving.Schema.Enum ( defineEnumUnit, ) import Data.Morpheus.Server.Deriving.Schema.Object ( defineObjectType, ) import Data.Morpheus.Server.Deriving.Utils ( ConsRep (..), fieldTypeName, isEmptyConstraint, isUnionRef, ) import Data.Morpheus.Server.Deriving.Utils.Kinded ( CategoryValue, KindedType (..), ) import Data.Morpheus.Server.Types.GQLType (GQLType, deriveTypename) import Data.Morpheus.Server.Types.SchemaT ( SchemaT, ) import Data.Morpheus.Types.Internal.AST ( CONST, FieldContent (..), IN, TRUE, TypeContent (..), TypeName, UnionMember (..), mkNullaryMember, mkUnionMember, ) import Relude buildUnionTypeContent :: ( GQLType a, CategoryValue kind ) => KindedType kind a -> [ConsRep (Maybe (FieldContent TRUE kind CONST))] -> SchemaT c (TypeContent TRUE kind CONST) buildUnionTypeContent :: 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 (Maybe (FieldContent TRUE kind CONST))] cons = forall a (kind :: TypeCategory) (c :: TypeCategory). GQLType a => KindedType kind a -> [TypeName] -> [ConsRep (Maybe (FieldContent TRUE kind CONST))] -> SchemaT c (TypeContent TRUE kind CONST) mkUnionType KindedType kind a scope [TypeName] unionRef [ConsRep (Maybe (FieldContent TRUE kind CONST))] unionCons where unionRef :: [TypeName] unionRef = forall k. FieldRep k -> TypeName fieldTypeName 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 (FieldContent TRUE kind CONST))] unionRefRep ([ConsRep (Maybe (FieldContent TRUE kind CONST))] unionRefRep, [ConsRep (Maybe (FieldContent TRUE kind CONST))] unionCons) = forall a. (a -> Bool) -> [a] -> ([a], [a]) partition (forall k. TypeName -> ConsRep k -> Bool isUnionRef (forall a (kind :: TypeCategory) (kinded :: TypeCategory -> * -> *). (GQLType a, CategoryValue kind) => kinded kind a -> TypeName deriveTypename KindedType kind a scope)) [ConsRep (Maybe (FieldContent TRUE kind CONST))] cons mkUnionType :: GQLType a => KindedType kind a -> [TypeName] -> [ConsRep (Maybe (FieldContent TRUE kind CONST))] -> SchemaT c (TypeContent TRUE kind CONST) mkUnionType :: forall a (kind :: TypeCategory) (c :: TypeCategory). GQLType a => KindedType kind a -> [TypeName] -> [ConsRep (Maybe (FieldContent TRUE kind CONST))] -> SchemaT c (TypeContent TRUE kind CONST) mkUnionType p :: KindedType kind a p@KindedType kind a InputType [TypeName] unionRef [ConsRep (Maybe (FieldContent TRUE kind 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 (FieldContent TRUE kind CONST))] nullaryCons, [ConsRep (Maybe (FieldContent TRUE kind CONST))] cons) = forall a. (a -> Bool) -> [a] -> ([a], [a]) partition forall a. ConsRep a -> Bool isEmptyConstraint [ConsRep (Maybe (FieldContent TRUE kind 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 (FieldContent TRUE kind CONST))] nullaryCons defineEnumEmpty :: SchemaT c () defineEnumEmpty | forall (t :: * -> *) a. Foldable t => t a -> Bool null [ConsRep (Maybe (FieldContent TRUE kind 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). KindedType kind a -> [ConsRep (Maybe (FieldContent TRUE kind CONST))] -> SchemaT c [TypeName] buildUnions KindedType kind a p [ConsRep (Maybe (FieldContent TRUE kind 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 :: KindedType kind a p@KindedType kind a OutputType [TypeName] unionRef [ConsRep (Maybe (FieldContent TRUE kind 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). KindedType kind a -> [ConsRep (Maybe (FieldContent TRUE kind CONST))] -> SchemaT c [TypeName] buildUnions KindedType kind a p [ConsRep (Maybe (FieldContent TRUE kind 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 :: KindedType kind a -> [ConsRep (Maybe (FieldContent TRUE kind CONST))] -> SchemaT c [TypeName] buildUnions :: forall (kind :: TypeCategory) a (c :: TypeCategory). KindedType kind a -> [ConsRep (Maybe (FieldContent TRUE kind CONST))] -> SchemaT c [TypeName] buildUnions KindedType kind a proxy [ConsRep (Maybe (FieldContent TRUE kind CONST))] cons = forall (t :: * -> *) (f :: * -> *) a b. (Foldable t, Applicative f) => (a -> f b) -> t a -> f () traverse_ (forall (kind :: TypeCategory) a (cat :: TypeCategory). KindedType kind a -> ConsRep (Maybe (FieldContent TRUE kind CONST)) -> SchemaT cat () defineObjectType KindedType kind a proxy) [ConsRep (Maybe (FieldContent TRUE kind 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 (FieldContent TRUE kind CONST))] cons