{-# 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, TypeData (gqlTypeName), __typeData, ) 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 :: 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 = KindedType kind a -> [TypeName] -> [ConsRep (Maybe (FieldContent TRUE kind CONST))] -> SchemaT c (TypeContent TRUE kind CONST) 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 = FieldRep (Maybe (FieldContent TRUE kind CONST)) -> TypeName forall k. FieldRep k -> TypeName fieldTypeName (FieldRep (Maybe (FieldContent TRUE kind CONST)) -> TypeName) -> [FieldRep (Maybe (FieldContent TRUE kind CONST))] -> [TypeName] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (ConsRep (Maybe (FieldContent TRUE kind CONST)) -> [FieldRep (Maybe (FieldContent TRUE kind CONST))]) -> [ConsRep (Maybe (FieldContent TRUE kind CONST))] -> [FieldRep (Maybe (FieldContent TRUE kind CONST))] forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap ConsRep (Maybe (FieldContent TRUE kind CONST)) -> [FieldRep (Maybe (FieldContent TRUE kind CONST))] 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) = (ConsRep (Maybe (FieldContent TRUE kind CONST)) -> Bool) -> [ConsRep (Maybe (FieldContent TRUE kind CONST))] -> ([ConsRep (Maybe (FieldContent TRUE kind CONST))], [ConsRep (Maybe (FieldContent TRUE kind CONST))]) forall a. (a -> Bool) -> [a] -> ([a], [a]) partition (TypeName -> ConsRep (Maybe (FieldContent TRUE kind CONST)) -> Bool forall k. TypeName -> ConsRep k -> Bool isUnionRef (TypeData -> TypeName gqlTypeName (KindedType kind a -> TypeData forall (kinded :: TypeCategory -> * -> *) (kind :: TypeCategory) a. (GQLType a, CategoryValue kind) => kinded kind a -> TypeData __typeData 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 :: 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 = UnionTypeDefinition IN CONST -> TypeContent TRUE kind CONST forall (s :: Stage) (a :: TypeCategory). UnionTypeDefinition IN s -> TypeContent (IN <=? a) a s DataInputUnion (UnionTypeDefinition IN CONST -> TypeContent TRUE kind CONST) -> SchemaT c (UnionTypeDefinition IN CONST) -> SchemaT c (TypeContent TRUE kind CONST) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (SchemaT c [UnionMember IN CONST] typeMembers SchemaT c [UnionMember IN CONST] -> ([UnionMember IN CONST] -> SchemaT c (UnionTypeDefinition IN CONST)) -> SchemaT c (UnionTypeDefinition IN CONST) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= [UnionMember IN CONST] -> SchemaT c (UnionTypeDefinition IN CONST) 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) = (ConsRep (Maybe (FieldContent TRUE kind CONST)) -> Bool) -> [ConsRep (Maybe (FieldContent TRUE kind CONST))] -> ([ConsRep (Maybe (FieldContent TRUE kind CONST))], [ConsRep (Maybe (FieldContent TRUE kind CONST))]) forall a. (a -> Bool) -> [a] -> ([a], [a]) partition ConsRep (Maybe (FieldContent TRUE kind CONST)) -> Bool forall a. ConsRep a -> Bool isEmptyConstraint [ConsRep (Maybe (FieldContent TRUE kind CONST))] unionCons nullaryMembers :: [UnionMember IN CONST] nullaryMembers :: [UnionMember IN CONST] nullaryMembers = TypeName -> UnionMember IN CONST forall (cat :: TypeCategory) (s :: Stage). TypeName -> UnionMember cat s mkNullaryMember (TypeName -> UnionMember IN CONST) -> (ConsRep (Maybe (FieldContent TRUE kind CONST)) -> TypeName) -> ConsRep (Maybe (FieldContent TRUE kind CONST)) -> UnionMember IN CONST forall b c a. (b -> c) -> (a -> b) -> a -> c . ConsRep (Maybe (FieldContent TRUE kind CONST)) -> TypeName forall v. ConsRep v -> TypeName consName (ConsRep (Maybe (FieldContent TRUE kind CONST)) -> UnionMember IN CONST) -> [ConsRep (Maybe (FieldContent TRUE kind CONST))] -> [UnionMember IN CONST] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [ConsRep (Maybe (FieldContent TRUE kind CONST))] nullaryCons defineEnumEmpty :: SchemaT c () defineEnumEmpty | [ConsRep (Maybe (FieldContent TRUE kind CONST))] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [ConsRep (Maybe (FieldContent TRUE kind CONST))] nullaryCons = () -> SchemaT c () forall (f :: * -> *) a. Applicative f => a -> f a pure () | Bool otherwise = SchemaT c () forall (cat :: TypeCategory). SchemaT cat () defineEnumUnit typeMembers :: SchemaT c [UnionMember IN CONST] typeMembers = ([UnionMember IN CONST] -> [UnionMember IN CONST] -> [UnionMember IN CONST] forall a. Semigroup a => a -> a -> a <> [UnionMember IN CONST] nullaryMembers) ([UnionMember IN CONST] -> [UnionMember IN CONST]) -> ([TypeName] -> [UnionMember IN CONST]) -> [TypeName] -> [UnionMember IN CONST] forall b c a. (b -> c) -> (a -> b) -> a -> c . [TypeName] -> [UnionMember IN CONST] withRefs ([TypeName] -> [UnionMember IN CONST]) -> SchemaT c [TypeName] -> SchemaT c [UnionMember IN CONST] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> ( SchemaT c () defineEnumEmpty SchemaT c () -> SchemaT c [TypeName] -> SchemaT c [TypeName] forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b *> KindedType kind a -> [ConsRep (Maybe (FieldContent TRUE kind CONST))] -> SchemaT c [TypeName] 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 = (TypeName -> UnionMember IN CONST) -> [TypeName] -> [UnionMember IN CONST] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap TypeName -> UnionMember IN CONST forall (cat :: TypeCategory) (s :: Stage). TypeName -> UnionMember cat s mkUnionMember ([TypeName] -> [UnionMember IN CONST]) -> ([TypeName] -> [TypeName]) -> [TypeName] -> [UnionMember IN CONST] forall b c a. (b -> c) -> (a -> b) -> a -> c . ([TypeName] unionRef [TypeName] -> [TypeName] -> [TypeName] 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 = UnionTypeDefinition OUT CONST -> TypeContent TRUE kind CONST forall (s :: Stage) (a :: TypeCategory). UnionTypeDefinition OUT s -> TypeContent (OUT <=? a) a s DataUnion (UnionTypeDefinition OUT CONST -> TypeContent TRUE kind CONST) -> SchemaT c (UnionTypeDefinition OUT CONST) -> SchemaT c (TypeContent TRUE kind CONST) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (KindedType kind a -> [ConsRep (Maybe (FieldContent TRUE kind CONST))] -> SchemaT c [TypeName] 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 SchemaT c [TypeName] -> ([TypeName] -> SchemaT c (UnionTypeDefinition OUT CONST)) -> SchemaT c (UnionTypeDefinition OUT CONST) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= [UnionMember OUT CONST] -> SchemaT c (UnionTypeDefinition OUT CONST) forall (m :: * -> *) k a (map :: * -> * -> *). (Monad m, KeyOf k a, FromList m map k a) => [a] -> m (map k a) fromElems ([UnionMember OUT CONST] -> SchemaT c (UnionTypeDefinition OUT CONST)) -> ([TypeName] -> [UnionMember OUT CONST]) -> [TypeName] -> SchemaT c (UnionTypeDefinition OUT CONST) forall b c a. (b -> c) -> (a -> b) -> a -> c . (TypeName -> UnionMember OUT CONST) -> [TypeName] -> [UnionMember OUT CONST] forall a b. (a -> b) -> [a] -> [b] map TypeName -> UnionMember OUT CONST forall (cat :: TypeCategory) (s :: Stage). TypeName -> UnionMember cat s mkUnionMember ([TypeName] -> [UnionMember OUT CONST]) -> ([TypeName] -> [TypeName]) -> [TypeName] -> [UnionMember OUT CONST] forall b c a. (b -> c) -> (a -> b) -> a -> c . ([TypeName] unionRef [TypeName] -> [TypeName] -> [TypeName] forall a. Semigroup a => a -> a -> a <>)) buildUnions :: KindedType kind a -> [ConsRep (Maybe (FieldContent TRUE kind CONST))] -> SchemaT c [TypeName] buildUnions :: KindedType kind a -> [ConsRep (Maybe (FieldContent TRUE kind CONST))] -> SchemaT c [TypeName] buildUnions KindedType kind a proxy [ConsRep (Maybe (FieldContent TRUE kind CONST))] cons = (ConsRep (Maybe (FieldContent TRUE kind CONST)) -> SchemaT c ()) -> [ConsRep (Maybe (FieldContent TRUE kind CONST))] -> SchemaT c () forall (t :: * -> *) (f :: * -> *) a b. (Foldable t, Applicative f) => (a -> f b) -> t a -> f () traverse_ (KindedType kind a -> ConsRep (Maybe (FieldContent TRUE kind CONST)) -> SchemaT c () 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 SchemaT c () -> [TypeName] -> SchemaT c [TypeName] forall (f :: * -> *) a b. Functor f => f a -> b -> f b $> (ConsRep (Maybe (FieldContent TRUE kind CONST)) -> TypeName) -> [ConsRep (Maybe (FieldContent TRUE kind CONST))] -> [TypeName] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap ConsRep (Maybe (FieldContent TRUE kind CONST)) -> TypeName forall v. ConsRep v -> TypeName consName [ConsRep (Maybe (FieldContent TRUE kind CONST))] cons