{-# 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.Directive (deriveFieldDirectives) import Data.Morpheus.Server.Deriving.Schema.Enum (defineEnumUnit) import Data.Morpheus.Server.Deriving.Schema.Internal ( lookupDescription, 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, ) import Data.Morpheus.Server.Types.Internal ( 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 :: forall (kind :: TypeCategory) a (cat :: TypeCategory). 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} = forall (cat :: TypeCategory) (cat' :: TypeCategory). TypeDefinition cat CONST -> SchemaT cat' () insertType forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (a :: TypeCategory) (s :: Stage). TypeName -> TypeContent TRUE a s -> TypeDefinition a s mkType TypeName consName forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (kind :: TypeCategory) a. KindedType kind a -> FieldsDefinition kind CONST -> TypeContent TRUE kind CONST mkObjectTypeContent KindedType kind a proxy 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 | forall (t :: * -> *) a. Foldable t => t a -> Bool null [FieldRep (Maybe (FieldContent TRUE kind CONST))] consFields = forall (cat :: TypeCategory). SchemaT cat () defineEnumUnit forall (f :: * -> *) a b. Functor f => f a -> b -> f b $> forall k (m :: * -> *) a. IsMap k m => k -> a -> m a singleton FieldName unitFieldName forall (cat :: TypeCategory) (s :: Stage). FieldDefinition cat s mkFieldUnit | Bool otherwise = forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ forall (cat :: TypeCategory) (s :: Stage). [FieldDefinition cat s] -> FieldsDefinition cat s unsafeFromFields forall a b. (a -> b) -> a -> b $ forall a b. (a -> b) -> [a] -> [b] map 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 :: forall (cat :: TypeCategory) (s :: Stage). FieldDefinition cat s mkFieldUnit = forall (cat :: TypeCategory) (s :: Stage). Maybe (FieldContent TRUE cat s) -> FieldName -> TypeRef -> FieldDefinition cat s mkField forall a. Maybe a Nothing FieldName unitFieldName (TypeName -> TypeRef mkTypeRef TypeName unitTypeName) buildObjectTypeContent :: GQLType a => KindedType cat a -> [FieldRep (Maybe (FieldContent TRUE cat CONST))] -> SchemaT c (TypeContent TRUE cat CONST) buildObjectTypeContent :: 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 cat a scope [FieldRep (Maybe (FieldContent TRUE cat CONST))] consFields = do [FieldDefinition cat CONST] xs <- forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse (forall a (kind :: TypeCategory) (c :: TypeCategory). GQLType a => KindedType kind a -> FieldDefinition kind CONST -> SchemaT c (FieldDefinition kind CONST) setGQLTypeProps KindedType cat a scope forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (kind :: TypeCategory). FieldRep (Maybe (FieldContent TRUE kind CONST)) -> FieldDefinition kind CONST repToFieldDefinition) [FieldRep (Maybe (FieldContent TRUE cat CONST))] consFields forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ forall (kind :: TypeCategory) a. KindedType kind a -> FieldsDefinition kind CONST -> TypeContent TRUE kind CONST mkObjectTypeContent KindedType cat a scope forall a b. (a -> b) -> a -> b $ forall (cat :: TypeCategory) (s :: Stage). [FieldDefinition cat s] -> FieldsDefinition cat s unsafeFromFields [FieldDefinition cat CONST] xs repToFieldDefinition :: FieldRep (Maybe (FieldContent TRUE kind CONST)) -> FieldDefinition kind CONST repToFieldDefinition :: forall (kind :: TypeCategory). 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 { fieldDescription :: Maybe Description fieldDescription = forall a. Monoid a => a mempty, fieldDirectives :: Directives CONST fieldDirectives = 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 :: forall a (f :: * -> *) (kind :: TypeCategory). 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 f a proxy = forall (a :: TypeCategory) (s :: Stage). TypeName -> TypeContent TRUE a s -> TypeDefinition a s mkType (TypeData -> TypeName gqlTypeName (forall (kinded :: TypeCategory -> * -> *) (kind :: TypeCategory) a. (GQLType a, CategoryValue kind) => kinded kind a -> TypeData __typeData (forall {k} (f :: k -> *) (a :: k). f a -> KindedType OUT a outputType f a proxy))) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (s :: Stage) (a :: TypeCategory). [TypeName] -> FieldsDefinition OUT s -> TypeContent (OBJECT <=? a) a s DataObject [] 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 :: forall a (c :: TypeCategory) (any :: TypeCategory) (s :: Stage). (GQLType a, CategoryValue c) => KindedType c a -> TypeContent TRUE any s -> SchemaT c (FieldsDefinition c s) withObject KindedType c a InputType DataInputObject {FieldsDefinition 'IN s inputObjectFields :: forall (s :: Stage) (a :: TypeCategory). CondTypeContent INPUT_OBJECT a s -> FieldsDefinition 'IN s inputObjectFields :: FieldsDefinition 'IN s inputObjectFields} = forall (f :: * -> *) a. Applicative f => a -> f a pure FieldsDefinition 'IN s inputObjectFields withObject KindedType c a OutputType DataObject {FieldsDefinition OUT s objectFields :: forall (s :: Stage) (a :: TypeCategory). CondTypeContent OBJECT a s -> FieldsDefinition OUT s objectFields :: FieldsDefinition OUT s objectFields} = forall (f :: * -> *) a. Applicative f => a -> f a pure FieldsDefinition OUT s objectFields withObject KindedType c a x TypeContent TRUE any 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 :: forall (c :: TypeCategory) a b. (GQLType a, CategoryValue c) => KindedType c a -> SchemaT c b failureOnlyObject KindedType c a proxy = forall e (m :: * -> *) a. MonadError e m => e -> m a throwError forall a b. (a -> b) -> a -> b $ forall a. Msg a => a -> GQLError msg (TypeData -> TypeName gqlTypeName forall a b. (a -> b) -> a -> b $ forall (kinded :: TypeCategory -> * -> *) (kind :: TypeCategory) a. (GQLType a, CategoryValue kind) => kinded kind a -> TypeData __typeData KindedType c a proxy) 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 :: forall (kind :: TypeCategory) a. KindedType kind a -> FieldsDefinition kind CONST -> TypeContent TRUE kind CONST mkObjectTypeContent KindedType kind a InputType = forall (s :: Stage) (a :: TypeCategory). FieldsDefinition 'IN s -> TypeContent (INPUT_OBJECT <=? a) a s DataInputObject mkObjectTypeContent KindedType kind a OutputType = forall (s :: Stage) (a :: TypeCategory). [TypeName] -> FieldsDefinition OUT s -> TypeContent (OBJECT <=? a) a s DataObject [] setGQLTypeProps :: GQLType a => KindedType kind a -> FieldDefinition kind CONST -> SchemaT c (FieldDefinition kind CONST) setGQLTypeProps :: forall a (kind :: TypeCategory) (c :: TypeCategory). GQLType a => KindedType kind a -> FieldDefinition kind CONST -> SchemaT c (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 ..} = do Directives CONST dirs <- forall a (f :: * -> *) (c :: TypeCategory). GQLType a => f a -> FieldName -> SchemaT c (Directives CONST) deriveFieldDirectives KindedType kind a proxy FieldName fieldName forall (f :: * -> *) a. Applicative f => a -> f a pure FieldDefinition { FieldName fieldName :: FieldName fieldName :: FieldName fieldName, fieldDescription :: Maybe Description fieldDescription = forall a (f :: * -> *). GQLType a => f a -> Description -> Maybe Description lookupDescription KindedType kind a proxy Description key, fieldContent :: Maybe (FieldContent TRUE kind CONST) fieldContent = forall a (kind :: TypeCategory). GQLType a => KindedType kind a -> Description -> Maybe (FieldContent TRUE kind CONST) lookupFieldContent KindedType kind a proxy Description key forall (f :: * -> *) a. Alternative f => f a -> f a -> f a <|> Maybe (FieldContent TRUE kind CONST) fieldContent, fieldDirectives :: Directives CONST fieldDirectives = Directives CONST dirs, TypeRef fieldType :: TypeRef fieldType :: TypeRef .. } where key :: Description key = forall a (t :: NAME). NamePacking a => Name t -> a unpackName FieldName fieldName