{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} module Data.Morpheus.Server.Deriving.Internal.Schema.Object ( buildObjectTypeContent, defineObjectType, ) where import Data.Morpheus.Internal.Utils ( empty, singleton, ) import Data.Morpheus.Server.Deriving.Internal.Schema.Directive ( UseDeriving, deriveFieldDirectives, visitFieldContent, visitFieldDescription, visitFieldName, ) import Data.Morpheus.Server.Deriving.Internal.Schema.Enum ( defineEnumUnit, ) import Data.Morpheus.Server.Deriving.Utils.GRep ( ConsRep (..), FieldRep (..), ) import Data.Morpheus.Server.Deriving.Utils.Kinded ( CatType (..), ) import Data.Morpheus.Server.Types.SchemaT ( SchemaT, insertType, ) import Data.Morpheus.Types.Internal.AST (ArgumentsDefinition, CONST, FieldContent (..), FieldDefinition (..), FieldsDefinition, TRUE, TypeContent (..), mkField, mkType, mkTypeRef, unitFieldName, unitTypeName, unsafeFromFields) import Relude hiding (empty) defineObjectType :: CatType kind a -> ConsRep (Maybe (ArgumentsDefinition CONST)) -> SchemaT cat () defineObjectType :: forall (kind :: TypeCategory) a (cat :: TypeCategory). CatType kind a -> ConsRep (Maybe (ArgumentsDefinition CONST)) -> SchemaT cat () defineObjectType CatType kind a proxy ConsRep {TypeName consName :: forall v. ConsRep v -> TypeName consName :: TypeName consName, [FieldRep (Maybe (ArgumentsDefinition CONST))] consFields :: forall v. ConsRep v -> [FieldRep v] consFields :: [FieldRep (Maybe (ArgumentsDefinition 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. CatType kind a -> FieldsDefinition kind CONST -> TypeContent TRUE kind CONST mkObjectTypeContent CatType 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 (ArgumentsDefinition 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 (c :: TypeCategory) a. CatType c a -> FieldRep (Maybe (ArgumentsDefinition CONST)) -> FieldDefinition c CONST repToFieldDefinition CatType kind a proxy) [FieldRep (Maybe (ArgumentsDefinition 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 :: gql a => UseDeriving gql args -> CatType cat a -> [FieldRep (Maybe (ArgumentsDefinition CONST))] -> SchemaT k (TypeContent TRUE cat CONST) buildObjectTypeContent :: forall (gql :: * -> Constraint) a (args :: * -> Constraint) (cat :: TypeCategory) (k :: TypeCategory). gql a => UseDeriving gql args -> CatType cat a -> [FieldRep (Maybe (ArgumentsDefinition CONST))] -> SchemaT k (TypeContent TRUE cat CONST) buildObjectTypeContent UseDeriving gql args options CatType cat a scope [FieldRep (Maybe (ArgumentsDefinition 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 (gql :: * -> Constraint) a (args :: * -> Constraint) (kind :: TypeCategory) (k :: TypeCategory). gql a => UseDeriving gql args -> CatType kind a -> FieldDefinition kind CONST -> SchemaT k (FieldDefinition kind CONST) setGQLTypeProps UseDeriving gql args options CatType cat a scope forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (c :: TypeCategory) a. CatType c a -> FieldRep (Maybe (ArgumentsDefinition CONST)) -> FieldDefinition c CONST repToFieldDefinition CatType cat a scope) [FieldRep (Maybe (ArgumentsDefinition CONST))] consFields forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ forall (kind :: TypeCategory) a. CatType kind a -> FieldsDefinition kind CONST -> TypeContent TRUE kind CONST mkObjectTypeContent CatType 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 :: CatType c a -> FieldRep (Maybe (ArgumentsDefinition CONST)) -> FieldDefinition c CONST repToFieldDefinition :: forall (c :: TypeCategory) a. CatType c a -> FieldRep (Maybe (ArgumentsDefinition CONST)) -> FieldDefinition c CONST repToFieldDefinition CatType c a x FieldRep { fieldSelector :: forall a. FieldRep a -> FieldName fieldSelector = FieldName fieldName, fieldTypeRef :: forall a. FieldRep a -> TypeRef fieldTypeRef = TypeRef fieldType, Maybe (ArgumentsDefinition CONST) fieldValue :: forall a. FieldRep a -> a fieldValue :: Maybe (ArgumentsDefinition 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 c CONST) fieldContent = forall (c :: TypeCategory) a. CatType c a -> Maybe (ArgumentsDefinition CONST) -> Maybe (FieldContent TRUE c CONST) toFieldContent CatType c a x Maybe (ArgumentsDefinition CONST) fieldValue, TypeRef FieldName fieldName :: FieldName fieldType :: TypeRef fieldType :: TypeRef fieldName :: FieldName .. } toFieldContent :: CatType c a -> Maybe (ArgumentsDefinition CONST) -> Maybe (FieldContent TRUE c CONST) toFieldContent :: forall (c :: TypeCategory) a. CatType c a -> Maybe (ArgumentsDefinition CONST) -> Maybe (FieldContent TRUE c CONST) toFieldContent CatType c a OutputType (Just ArgumentsDefinition CONST x) = forall a. a -> Maybe a Just (forall (s :: Stage) (cat :: TypeCategory). ArgumentsDefinition s -> FieldContent ('OUT <=? cat) cat s FieldArgs ArgumentsDefinition CONST x) toFieldContent CatType c a _ Maybe (ArgumentsDefinition CONST) _ = forall a. Maybe a Nothing mkObjectTypeContent :: CatType kind a -> FieldsDefinition kind CONST -> TypeContent TRUE kind CONST mkObjectTypeContent :: forall (kind :: TypeCategory) a. CatType kind a -> FieldsDefinition kind CONST -> TypeContent TRUE kind CONST mkObjectTypeContent CatType kind a InputType = forall (s :: Stage) (a :: TypeCategory). FieldsDefinition 'IN s -> TypeContent (INPUT_OBJECT <=? a) a s DataInputObject mkObjectTypeContent CatType kind a OutputType = forall (s :: Stage) (a :: TypeCategory). [TypeName] -> FieldsDefinition 'OUT s -> TypeContent (OBJECT <=? a) a s DataObject [] setGQLTypeProps :: gql a => UseDeriving gql args -> CatType kind a -> FieldDefinition kind CONST -> SchemaT k (FieldDefinition kind CONST) setGQLTypeProps :: forall (gql :: * -> Constraint) a (args :: * -> Constraint) (kind :: TypeCategory) (k :: TypeCategory). gql a => UseDeriving gql args -> CatType kind a -> FieldDefinition kind CONST -> SchemaT k (FieldDefinition kind CONST) setGQLTypeProps UseDeriving gql args options CatType 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 (gql :: * -> Constraint) a (args :: * -> Constraint) (f :: * -> *) (kind :: TypeCategory). gql a => UseDeriving gql args -> f a -> FieldName -> SchemaT kind (Directives CONST) deriveFieldDirectives UseDeriving gql args options CatType kind a proxy FieldName fieldName forall (f :: * -> *) a. Applicative f => a -> f a pure FieldDefinition { fieldName :: FieldName fieldName = forall (gql :: * -> Constraint) a (args :: * -> Constraint) (f :: * -> *). gql a => UseDeriving gql args -> f a -> FieldName -> FieldName visitFieldName UseDeriving gql args options CatType kind a proxy FieldName fieldName, fieldDescription :: Maybe Description fieldDescription = forall (gql :: * -> Constraint) a (args :: * -> Constraint) (f :: * -> *). gql a => UseDeriving gql args -> f a -> FieldName -> Maybe Description -> Maybe Description visitFieldDescription UseDeriving gql args options CatType kind a proxy FieldName fieldName forall a. Maybe a Nothing, fieldContent :: Maybe (FieldContent TRUE kind CONST) fieldContent = forall (gql :: * -> Constraint) a (args :: * -> Constraint) (kind :: TypeCategory). gql a => UseDeriving gql args -> CatType kind a -> FieldName -> Maybe (FieldContent TRUE kind CONST) -> Maybe (FieldContent TRUE kind CONST) visitFieldContent UseDeriving gql args options CatType kind a proxy FieldName fieldName Maybe (FieldContent TRUE kind CONST) fieldContent, fieldDirectives :: Directives CONST fieldDirectives = Directives CONST dirs, TypeRef fieldType :: TypeRef fieldType :: TypeRef .. }