{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} module Data.Morpheus.Server.Deriving.Schema.Object ( asObjectType, withObject, buildObjectTypeContent, defineObjectType, ) where import Control.Monad.Except (throwError) import Data.Morpheus.Internal.Utils ( empty, singleton, ) import Data.Morpheus.Server.Deriving.Schema.Enum (defineEnumUnit) import Data.Morpheus.Server.Deriving.Schema.Internal ( lookupDescription, lookupDirectives, lookupFieldContent, ) import Data.Morpheus.Server.Deriving.Utils ( ConsRep (..), FieldRep (..), ) import Data.Morpheus.Server.Deriving.Utils.Kinded ( CategoryValue (..), KindedType (..), outputType, ) import Data.Morpheus.Server.Types.GQLType ( GQLType (..), TypeData (..), __typeData, ) import Data.Morpheus.Server.Types.SchemaT ( SchemaT, insertType, ) import Data.Morpheus.Types.Internal.AST ( CONST, FieldContent (..), FieldDefinition (..), FieldsDefinition, OBJECT, OUT, TRUE, TypeCategory, TypeContent (..), TypeDefinition, mkField, mkType, mkTypeRef, msg, unitFieldName, unitTypeName, unpackName, unsafeFromFields, ) import Relude hiding (empty) defineObjectType :: KindedType kind a -> ConsRep (Maybe (FieldContent TRUE kind CONST)) -> SchemaT cat () defineObjectType :: KindedType kind a -> ConsRep (Maybe (FieldContent TRUE kind CONST)) -> SchemaT cat () defineObjectType KindedType kind a proxy ConsRep {TypeName consName :: forall v. ConsRep v -> TypeName consName :: TypeName consName, [FieldRep (Maybe (FieldContent TRUE kind CONST))] consFields :: forall v. ConsRep v -> [FieldRep v] consFields :: [FieldRep (Maybe (FieldContent TRUE kind CONST))] consFields} = TypeDefinition kind CONST -> SchemaT cat () forall (cat :: TypeCategory) (cat' :: TypeCategory). TypeDefinition cat CONST -> SchemaT cat' () insertType (TypeDefinition kind CONST -> SchemaT cat ()) -> (FieldsDefinition kind CONST -> TypeDefinition kind CONST) -> FieldsDefinition kind CONST -> SchemaT cat () forall b c a. (b -> c) -> (a -> b) -> a -> c . TypeName -> TypeContent TRUE kind CONST -> TypeDefinition kind CONST forall (a :: TypeCategory) (s :: Stage). TypeName -> TypeContent TRUE a s -> TypeDefinition a s mkType TypeName consName (TypeContent TRUE kind CONST -> TypeDefinition kind CONST) -> (FieldsDefinition kind CONST -> TypeContent TRUE kind CONST) -> FieldsDefinition kind CONST -> TypeDefinition kind CONST forall b c a. (b -> c) -> (a -> b) -> a -> c . KindedType kind a -> FieldsDefinition kind CONST -> TypeContent TRUE kind CONST forall (kind :: TypeCategory) a. KindedType kind a -> FieldsDefinition kind CONST -> TypeContent TRUE kind CONST mkObjectTypeContent KindedType kind a proxy (FieldsDefinition kind CONST -> SchemaT cat ()) -> SchemaT cat (FieldsDefinition kind CONST) -> SchemaT cat () forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< SchemaT cat (FieldsDefinition kind CONST) fields where fields :: SchemaT cat (FieldsDefinition kind CONST) fields | [FieldRep (Maybe (FieldContent TRUE kind CONST))] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [FieldRep (Maybe (FieldContent TRUE kind CONST))] consFields = SchemaT cat () forall (cat :: TypeCategory). SchemaT cat () defineEnumUnit SchemaT cat () -> FieldsDefinition kind CONST -> SchemaT cat (FieldsDefinition kind CONST) forall (f :: * -> *) a b. Functor f => f a -> b -> f b $> FieldName -> FieldDefinition kind CONST -> FieldsDefinition kind CONST forall k (m :: * -> *) a. IsMap k m => k -> a -> m a singleton FieldName unitFieldName FieldDefinition kind CONST forall (cat :: TypeCategory) (s :: Stage). FieldDefinition cat s mkFieldUnit | Bool otherwise = FieldsDefinition kind CONST -> SchemaT cat (FieldsDefinition kind CONST) forall (f :: * -> *) a. Applicative f => a -> f a pure (FieldsDefinition kind CONST -> SchemaT cat (FieldsDefinition kind CONST)) -> FieldsDefinition kind CONST -> SchemaT cat (FieldsDefinition kind CONST) forall a b. (a -> b) -> a -> b $ [FieldDefinition kind CONST] -> FieldsDefinition kind CONST forall (cat :: TypeCategory) (s :: Stage). [FieldDefinition cat s] -> FieldsDefinition cat s unsafeFromFields ([FieldDefinition kind CONST] -> FieldsDefinition kind CONST) -> [FieldDefinition kind CONST] -> FieldsDefinition kind CONST forall a b. (a -> b) -> a -> b $ (FieldRep (Maybe (FieldContent TRUE kind CONST)) -> FieldDefinition kind CONST) -> [FieldRep (Maybe (FieldContent TRUE kind CONST))] -> [FieldDefinition kind CONST] forall a b. (a -> b) -> [a] -> [b] map FieldRep (Maybe (FieldContent TRUE kind CONST)) -> FieldDefinition kind CONST forall (kind :: TypeCategory). FieldRep (Maybe (FieldContent TRUE kind CONST)) -> FieldDefinition kind CONST repToFieldDefinition [FieldRep (Maybe (FieldContent TRUE kind CONST))] consFields mkFieldUnit :: FieldDefinition cat s mkFieldUnit :: FieldDefinition cat s mkFieldUnit = Maybe (FieldContent TRUE cat s) -> FieldName -> TypeRef -> FieldDefinition cat s forall (cat :: TypeCategory) (s :: Stage). Maybe (FieldContent TRUE cat s) -> FieldName -> TypeRef -> FieldDefinition cat s mkField Maybe (FieldContent TRUE cat s) forall a. Maybe a Nothing FieldName unitFieldName (TypeName -> TypeRef mkTypeRef TypeName unitTypeName) buildObjectTypeContent :: (Applicative f, GQLType a) => KindedType cat a -> [FieldRep (Maybe (FieldContent TRUE cat CONST))] -> f (TypeContent TRUE cat CONST) buildObjectTypeContent :: KindedType cat a -> [FieldRep (Maybe (FieldContent TRUE cat CONST))] -> f (TypeContent TRUE cat CONST) buildObjectTypeContent KindedType cat a scope [FieldRep (Maybe (FieldContent TRUE cat CONST))] consFields = TypeContent TRUE cat CONST -> f (TypeContent TRUE cat CONST) forall (f :: * -> *) a. Applicative f => a -> f a pure (TypeContent TRUE cat CONST -> f (TypeContent TRUE cat CONST)) -> TypeContent TRUE cat CONST -> f (TypeContent TRUE cat CONST) forall a b. (a -> b) -> a -> b $ KindedType cat a -> FieldsDefinition cat CONST -> TypeContent TRUE cat CONST forall (kind :: TypeCategory) a. KindedType kind a -> FieldsDefinition kind CONST -> TypeContent TRUE kind CONST mkObjectTypeContent KindedType cat a scope (FieldsDefinition cat CONST -> TypeContent TRUE cat CONST) -> FieldsDefinition cat CONST -> TypeContent TRUE cat CONST forall a b. (a -> b) -> a -> b $ [FieldDefinition cat CONST] -> FieldsDefinition cat CONST forall (cat :: TypeCategory) (s :: Stage). [FieldDefinition cat s] -> FieldsDefinition cat s unsafeFromFields ([FieldDefinition cat CONST] -> FieldsDefinition cat CONST) -> [FieldDefinition cat CONST] -> FieldsDefinition cat CONST forall a b. (a -> b) -> a -> b $ (FieldRep (Maybe (FieldContent TRUE cat CONST)) -> FieldDefinition cat CONST) -> [FieldRep (Maybe (FieldContent TRUE cat CONST))] -> [FieldDefinition cat CONST] forall a b. (a -> b) -> [a] -> [b] map (KindedType cat a -> FieldDefinition cat CONST -> FieldDefinition cat CONST forall a (kind :: TypeCategory). GQLType a => KindedType kind a -> FieldDefinition kind CONST -> FieldDefinition kind CONST setGQLTypeProps KindedType cat a scope (FieldDefinition cat CONST -> FieldDefinition cat CONST) -> (FieldRep (Maybe (FieldContent TRUE cat CONST)) -> FieldDefinition cat CONST) -> FieldRep (Maybe (FieldContent TRUE cat CONST)) -> FieldDefinition cat CONST forall b c a. (b -> c) -> (a -> b) -> a -> c . FieldRep (Maybe (FieldContent TRUE cat CONST)) -> FieldDefinition cat CONST forall (kind :: TypeCategory). FieldRep (Maybe (FieldContent TRUE kind CONST)) -> FieldDefinition kind CONST repToFieldDefinition) [FieldRep (Maybe (FieldContent TRUE cat CONST))] consFields repToFieldDefinition :: FieldRep (Maybe (FieldContent TRUE kind CONST)) -> FieldDefinition kind CONST repToFieldDefinition :: FieldRep (Maybe (FieldContent TRUE kind CONST)) -> FieldDefinition kind CONST repToFieldDefinition FieldRep { fieldSelector :: forall a. FieldRep a -> FieldName fieldSelector = FieldName fieldName, fieldTypeRef :: forall a. FieldRep a -> TypeRef fieldTypeRef = TypeRef fieldType, Maybe (FieldContent TRUE kind CONST) fieldValue :: forall a. FieldRep a -> a fieldValue :: Maybe (FieldContent TRUE kind CONST) fieldValue } = FieldDefinition :: forall (cat :: TypeCategory) (s :: Stage). Maybe Description -> FieldName -> TypeRef -> Maybe (FieldContent TRUE cat s) -> Directives s -> FieldDefinition cat s FieldDefinition { fieldDescription :: Maybe Description fieldDescription = Maybe Description forall a. Monoid a => a mempty, fieldDirectives :: Directives CONST fieldDirectives = Directives CONST forall coll. Empty coll => coll empty, fieldContent :: Maybe (FieldContent TRUE kind CONST) fieldContent = Maybe (FieldContent TRUE kind CONST) fieldValue, TypeRef FieldName fieldName :: FieldName fieldType :: TypeRef fieldType :: TypeRef fieldName :: FieldName .. } asObjectType :: (GQLType a) => (f a -> SchemaT kind (FieldsDefinition OUT CONST)) -> f a -> SchemaT kind (TypeDefinition OBJECT CONST) asObjectType :: (f a -> SchemaT kind (FieldsDefinition OUT CONST)) -> f a -> SchemaT kind (TypeDefinition OBJECT CONST) asObjectType f a -> SchemaT kind (FieldsDefinition OUT CONST) f f a proxy = TypeName -> TypeContent TRUE OBJECT CONST -> TypeDefinition OBJECT CONST forall (a :: TypeCategory) (s :: Stage). TypeName -> TypeContent TRUE a s -> TypeDefinition a s mkType (TypeData -> TypeName gqlTypeName (KindedType OUT a -> TypeData forall (kinded :: TypeCategory -> * -> *) (kind :: TypeCategory) a. (GQLType a, CategoryValue kind) => kinded kind a -> TypeData __typeData (f a -> KindedType OUT a forall k (f :: k -> *) (a :: k). f a -> KindedType OUT a outputType f a proxy))) (TypeContent TRUE OBJECT CONST -> TypeDefinition OBJECT CONST) -> (FieldsDefinition OUT CONST -> TypeContent TRUE OBJECT CONST) -> FieldsDefinition OUT CONST -> TypeDefinition OBJECT CONST forall b c a. (b -> c) -> (a -> b) -> a -> c . [TypeName] -> FieldsDefinition OUT CONST -> TypeContent (OBJECT <=? OBJECT) OBJECT CONST forall (s :: Stage) (a :: TypeCategory). [TypeName] -> FieldsDefinition OUT s -> TypeContent (OBJECT <=? a) a s DataObject [] (FieldsDefinition OUT CONST -> TypeDefinition OBJECT CONST) -> SchemaT kind (FieldsDefinition OUT CONST) -> SchemaT kind (TypeDefinition OBJECT CONST) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> f a -> SchemaT kind (FieldsDefinition OUT CONST) f f a proxy withObject :: (GQLType a, CategoryValue c) => KindedType c a -> TypeContent TRUE any s -> SchemaT c (FieldsDefinition c s) withObject :: KindedType c a -> TypeContent TRUE any s -> SchemaT c (FieldsDefinition c s) withObject KindedType c a InputType DataInputObject {FieldsDefinition IN s inputObjectFields :: forall (a :: TypeCategory) (s :: Stage). CondTypeContent INPUT_OBJECT a s -> FieldsDefinition IN s inputObjectFields :: FieldsDefinition IN s inputObjectFields} = FieldsDefinition IN s -> SchemaT c (FieldsDefinition IN s) forall (f :: * -> *) a. Applicative f => a -> f a pure FieldsDefinition IN s inputObjectFields withObject KindedType c a OutputType DataObject {FieldsDefinition OUT s objectFields :: forall (a :: TypeCategory) (s :: Stage). CondTypeContent OBJECT a s -> FieldsDefinition OUT s objectFields :: FieldsDefinition OUT s objectFields} = FieldsDefinition OUT s -> SchemaT c (FieldsDefinition OUT s) forall (f :: * -> *) a. Applicative f => a -> f a pure FieldsDefinition OUT s objectFields withObject KindedType c a x TypeContent TRUE any s _ = KindedType c a -> SchemaT c (FieldsDefinition c s) forall (c :: TypeCategory) a b. (GQLType a, CategoryValue c) => KindedType c a -> SchemaT c b failureOnlyObject KindedType c a x failureOnlyObject :: forall (c :: TypeCategory) a b. (GQLType a, CategoryValue c) => KindedType c a -> SchemaT c b failureOnlyObject :: KindedType c a -> SchemaT c b failureOnlyObject KindedType c a proxy = GQLError -> SchemaT c b forall e (m :: * -> *) a. MonadError e m => e -> m a throwError (GQLError -> SchemaT c b) -> GQLError -> SchemaT c b forall a b. (a -> b) -> a -> b $ TypeName -> GQLError forall a. Msg a => a -> GQLError msg (TypeData -> TypeName gqlTypeName (TypeData -> TypeName) -> TypeData -> TypeName forall a b. (a -> b) -> a -> b $ KindedType c a -> TypeData forall (kinded :: TypeCategory -> * -> *) (kind :: TypeCategory) a. (GQLType a, CategoryValue kind) => kinded kind a -> TypeData __typeData KindedType c a proxy) GQLError -> GQLError -> GQLError forall a. Semigroup a => a -> a -> a <> GQLError " should have only one nonempty constructor" mkObjectTypeContent :: KindedType kind a -> FieldsDefinition kind CONST -> TypeContent TRUE kind CONST mkObjectTypeContent :: KindedType kind a -> FieldsDefinition kind CONST -> TypeContent TRUE kind CONST mkObjectTypeContent KindedType kind a InputType = FieldsDefinition kind CONST -> TypeContent TRUE kind CONST forall (s :: Stage) (a :: TypeCategory). FieldsDefinition IN s -> TypeContent (INPUT_OBJECT <=? a) a s DataInputObject mkObjectTypeContent KindedType kind a OutputType = [TypeName] -> FieldsDefinition OUT CONST -> TypeContent (OBJECT <=? kind) kind CONST forall (s :: Stage) (a :: TypeCategory). [TypeName] -> FieldsDefinition OUT s -> TypeContent (OBJECT <=? a) a s DataObject [] setGQLTypeProps :: GQLType a => KindedType kind a -> FieldDefinition kind CONST -> FieldDefinition kind CONST setGQLTypeProps :: KindedType kind a -> FieldDefinition kind CONST -> FieldDefinition kind CONST setGQLTypeProps KindedType kind a proxy FieldDefinition {Maybe Description Maybe (FieldContent TRUE kind CONST) TypeRef FieldName Directives CONST fieldDirectives :: Directives CONST fieldContent :: Maybe (FieldContent TRUE kind CONST) fieldType :: TypeRef fieldName :: FieldName fieldDescription :: Maybe Description fieldName :: forall (cat :: TypeCategory) (s :: Stage). FieldDefinition cat s -> FieldName fieldType :: forall (cat :: TypeCategory) (s :: Stage). FieldDefinition cat s -> TypeRef fieldContent :: forall (cat :: TypeCategory) (s :: Stage). FieldDefinition cat s -> Maybe (FieldContent TRUE cat s) fieldDirectives :: forall (cat :: TypeCategory) (s :: Stage). FieldDefinition cat s -> Directives s fieldDescription :: forall (cat :: TypeCategory) (s :: Stage). FieldDefinition cat s -> Maybe Description ..} = FieldDefinition :: forall (cat :: TypeCategory) (s :: Stage). Maybe Description -> FieldName -> TypeRef -> Maybe (FieldContent TRUE cat s) -> Directives s -> FieldDefinition cat s FieldDefinition { FieldName fieldName :: FieldName fieldName :: FieldName fieldName, fieldDescription :: Maybe Description fieldDescription = KindedType kind a -> Description -> Maybe Description forall a (f :: * -> *). GQLType a => f a -> Description -> Maybe Description lookupDescription KindedType kind a proxy Description key, fieldDirectives :: Directives CONST fieldDirectives = KindedType kind a -> Description -> Directives CONST forall a (f :: * -> *). GQLType a => f a -> Description -> Directives CONST lookupDirectives KindedType kind a proxy Description key, fieldContent :: Maybe (FieldContent TRUE kind CONST) fieldContent = KindedType kind a -> Description -> Maybe (FieldContent TRUE kind CONST) forall a (kind :: TypeCategory). GQLType a => KindedType kind a -> Description -> Maybe (FieldContent TRUE kind CONST) lookupFieldContent KindedType kind a proxy Description key Maybe (FieldContent TRUE kind CONST) -> Maybe (FieldContent TRUE kind CONST) -> Maybe (FieldContent TRUE kind CONST) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a <|> Maybe (FieldContent TRUE kind CONST) fieldContent, TypeRef fieldType :: TypeRef fieldType :: TypeRef .. } where key :: Description key = FieldName -> Description forall a (t :: NAME). NamePacking a => Name t -> a unpackName FieldName fieldName