{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} module Data.Morpheus.Server.Deriving.Internal.Type ( toTypeDefinition, deriveTypeDefinition, deriveScalarDefinition, deriveInterfaceDefinition, deriveTypeGuardUnions, DERIVE_TYPE, ) where import Control.Monad.Except ( MonadError (..), ) import Data.Foldable import Data.List (partition) import Data.Morpheus.Generic ( GRep, GRepCons (..), GRepField (..), GRepFun (..), GRepType (..), deriveType, ) import Data.Morpheus.Internal.Ext (GQLResult) import Data.Morpheus.Internal.Utils (Empty (..), fromElems) import Data.Morpheus.Server.Deriving.Internal.Directive ( UseDeriving (..), getEnumDirectives, getFieldDirectives, getTypeDirectives, serializeDirectives, visitEnumName, visitEnumValueDescription, visitFieldContent, visitFieldDescription, visitFieldName, visitTypeDescription, ) import Data.Morpheus.Server.Deriving.Utils.Kinded ( mapCat, mkEnum, mkObject, mkScalar, ) import Data.Morpheus.Server.Deriving.Utils.Types ( CatType (..), GQLTypeNode (..), GQLTypeNodeExtension (..), NodeTypeVariant (..), toFieldContent, withObject, ) import Data.Morpheus.Server.Deriving.Utils.Use ( UseGQLType (..), ) import Data.Morpheus.Types.Internal.AST ( ArgumentsDefinition, CONST, DataEnumValue (..), FieldDefinition (..), OUT, ScalarDefinition, TRUE, TypeContent (..), TypeDefinition (..), TypeName, UnionMember (..), mkField, mkNullaryMember, mkTypeRef, mkUnionMember, toAny, unitFieldName, unitTypeName, ) import GHC.Generics (Rep) import Relude hiding (empty) type DERIVE_TYPE gql a = ( gql a, GRep gql gql (GQLResult (ArgumentsDefinition CONST)) (Rep a) ) toEnumValue :: (gql a) => UseDeriving gql args -> f a -> TypeName -> GQLResult (DataEnumValue CONST) toEnumValue :: forall (gql :: * -> Constraint) a (args :: * -> Constraint) (f :: * -> *). gql a => UseDeriving gql args -> f a -> TypeName -> GQLResult (DataEnumValue CONST) toEnumValue UseDeriving gql args ctx f a proxy TypeName enumName = do Directives CONST enumDirectives <- UseDeriving gql args -> [GDirectiveUsage gql args] -> GQLResult (Directives CONST) forall (gql :: * -> Constraint) (args :: * -> Constraint). UseDeriving gql args -> [GDirectiveUsage gql args] -> GQLResult (Directives CONST) serializeDirectives UseDeriving gql args ctx (UseDeriving gql args -> f a -> TypeName -> [GDirectiveUsage gql args] forall (gql :: * -> Constraint) a (args :: * -> Constraint) (f :: * -> *). gql a => UseDeriving gql args -> f a -> TypeName -> [GDirectiveUsage gql args] getEnumDirectives UseDeriving gql args ctx f a proxy TypeName enumName) DataEnumValue CONST -> GQLResult (DataEnumValue CONST) forall a. a -> Result GQLError a forall (f :: * -> *) a. Applicative f => a -> f a pure DataEnumValue { enumName :: TypeName enumName = UseDeriving gql args -> f a -> TypeName -> TypeName forall (gql :: * -> Constraint) a (args :: * -> Constraint) (f :: * -> *). gql a => UseDeriving gql args -> f a -> TypeName -> TypeName visitEnumName UseDeriving gql args ctx f a proxy TypeName enumName, enumDescription :: Maybe Description enumDescription = UseDeriving gql args -> f a -> TypeName -> Maybe Description -> Maybe Description forall (gql :: * -> Constraint) a (args :: * -> Constraint) (f :: * -> *). gql a => UseDeriving gql args -> f a -> TypeName -> Maybe Description -> Maybe Description visitEnumValueDescription UseDeriving gql args ctx f a proxy TypeName enumName Maybe Description forall a. Maybe a Nothing, Directives CONST enumDirectives :: Directives CONST enumDirectives :: Directives CONST .. } repToField :: CatType c a -> GRepField (ArgumentsDefinition CONST) -> FieldDefinition c CONST repToField :: forall (c :: TypeCategory) a. CatType c a -> GRepField (ArgumentsDefinition CONST) -> FieldDefinition c CONST repToField CatType c a proxy GRepField {ArgumentsDefinition CONST FieldName TypeRef fieldSelector :: FieldName fieldTypeRef :: TypeRef fieldValue :: ArgumentsDefinition CONST fieldSelector :: forall a. GRepField a -> FieldName fieldTypeRef :: forall a. GRepField a -> TypeRef fieldValue :: forall a. GRepField a -> a ..} = 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 c CONST) fieldContent = CatType c a -> ArgumentsDefinition CONST -> Maybe (FieldContent TRUE c CONST) forall (c :: TypeCategory) a. CatType c a -> ArgumentsDefinition CONST -> Maybe (FieldContent TRUE c CONST) toFieldContent CatType c a proxy ArgumentsDefinition CONST fieldValue, fieldName :: FieldName fieldName = FieldName fieldSelector, fieldType :: TypeRef fieldType = TypeRef fieldTypeRef } visitField :: (gql a) => UseDeriving gql args -> CatType kind a -> FieldDefinition kind CONST -> GQLResult (FieldDefinition kind CONST) visitField :: forall (gql :: * -> Constraint) a (args :: * -> Constraint) (kind :: TypeCategory). gql a => UseDeriving gql args -> CatType kind a -> FieldDefinition kind CONST -> GQLResult (FieldDefinition kind CONST) visitField UseDeriving gql args ctx CatType kind a proxy FieldDefinition {Maybe Description Maybe (FieldContent TRUE kind CONST) Directives CONST FieldName TypeRef fieldDescription :: forall (cat :: TypeCategory) (s :: Stage). FieldDefinition cat s -> Maybe Description fieldDirectives :: forall (cat :: TypeCategory) (s :: Stage). FieldDefinition cat s -> Directives s fieldContent :: forall (cat :: TypeCategory) (s :: Stage). FieldDefinition cat s -> Maybe (FieldContent TRUE cat s) fieldName :: forall (cat :: TypeCategory) (s :: Stage). FieldDefinition cat s -> FieldName fieldType :: forall (cat :: TypeCategory) (s :: Stage). FieldDefinition cat s -> TypeRef fieldDescription :: Maybe Description fieldName :: FieldName fieldType :: TypeRef fieldContent :: Maybe (FieldContent TRUE kind CONST) fieldDirectives :: Directives CONST ..} = do Directives CONST dirs <- UseDeriving gql args -> [GDirectiveUsage gql args] -> GQLResult (Directives CONST) forall (gql :: * -> Constraint) (args :: * -> Constraint). UseDeriving gql args -> [GDirectiveUsage gql args] -> GQLResult (Directives CONST) serializeDirectives UseDeriving gql args ctx (UseDeriving gql args -> CatType kind a -> FieldName -> [GDirectiveUsage gql args] forall (gql :: * -> Constraint) a (args :: * -> Constraint) (f :: * -> *). gql a => UseDeriving gql args -> f a -> FieldName -> [GDirectiveUsage gql args] getFieldDirectives UseDeriving gql args ctx CatType kind a proxy FieldName fieldName) FieldDefinition kind CONST -> GQLResult (FieldDefinition kind CONST) forall a. a -> Result GQLError a forall (f :: * -> *) a. Applicative f => a -> f a pure FieldDefinition { fieldName :: FieldName fieldName = UseDeriving gql args -> CatType kind a -> FieldName -> FieldName forall (gql :: * -> Constraint) a (args :: * -> Constraint) (f :: * -> *). gql a => UseDeriving gql args -> f a -> FieldName -> FieldName visitFieldName UseDeriving gql args ctx CatType kind a proxy FieldName fieldName, fieldDescription :: Maybe Description fieldDescription = UseDeriving gql args -> CatType kind a -> FieldName -> Maybe Description -> Maybe Description forall (gql :: * -> Constraint) a (args :: * -> Constraint) (f :: * -> *). gql a => UseDeriving gql args -> f a -> FieldName -> Maybe Description -> Maybe Description visitFieldDescription UseDeriving gql args ctx CatType kind a proxy FieldName fieldName Maybe Description forall a. Maybe a Nothing, fieldContent :: Maybe (FieldContent TRUE kind CONST) fieldContent = UseDeriving gql args -> CatType kind a -> FieldName -> Maybe (FieldContent TRUE kind CONST) -> Maybe (FieldContent TRUE kind CONST) 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 ctx CatType kind a proxy FieldName fieldName Maybe (FieldContent TRUE kind CONST) fieldContent, fieldDirectives :: Directives CONST fieldDirectives = Directives CONST dirs, TypeRef fieldType :: TypeRef fieldType :: TypeRef .. } toUnion :: CatType kind a -> [TypeName] -> [GRepCons (ArgumentsDefinition CONST)] -> GQLResult (TypeContent TRUE kind CONST, [GQLTypeNodeExtension]) toUnion :: forall (kind :: TypeCategory) a. CatType kind a -> [TypeName] -> [GRepCons (ArgumentsDefinition CONST)] -> GQLResult (TypeContent TRUE kind CONST, [GQLTypeNodeExtension]) toUnion prx :: CatType kind a prx@CatType kind a InputType [TypeName] variantRefs [GRepCons (ArgumentsDefinition CONST)] inlineVariants = do let nodes :: [GQLTypeNodeExtension] nodes = [[NodeTypeVariant] -> GQLTypeNodeExtension UnionVariantsExtension ([NodeTypeVariant NodeUnitType | Bool -> Bool not ([GRepCons (ArgumentsDefinition CONST)] -> Bool forall a. [a] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [GRepCons (ArgumentsDefinition CONST)] nullaryVariants)] [NodeTypeVariant] -> [NodeTypeVariant] -> [NodeTypeVariant] forall a. Semigroup a => a -> a -> a <> [[NodeTypeVariant]] -> [NodeTypeVariant] forall (t :: * -> *) a. Foldable t => t [a] -> [a] concat ((GRepCons (ArgumentsDefinition CONST) -> [NodeTypeVariant]) -> [GRepCons (ArgumentsDefinition CONST)] -> [[NodeTypeVariant]] forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) forall (f :: * -> *) a b. Applicative f => (a -> f b) -> [a] -> f [b] traverse (CatType kind a -> GRepCons (ArgumentsDefinition CONST) -> [NodeTypeVariant] forall (kind :: TypeCategory) a. CatType kind a -> GRepCons (ArgumentsDefinition CONST) -> [NodeTypeVariant] toTypeVariants CatType kind a prx) [GRepCons (ArgumentsDefinition CONST)] objectVariants))] OrdMap TypeName (UnionMember 'IN CONST) variants <- [UnionMember 'IN CONST] -> Result GQLError (OrdMap TypeName (UnionMember 'IN CONST)) forall (m :: * -> *) k a (map :: * -> * -> *). (Monad m, KeyOf k a, FromList m map k a) => [a] -> m (map k a) fromElems [UnionMember 'IN CONST] members (TypeContent TRUE kind CONST, [GQLTypeNodeExtension]) -> GQLResult (TypeContent TRUE kind CONST, [GQLTypeNodeExtension]) forall a. a -> Result GQLError a forall (f :: * -> *) a. Applicative f => a -> f a pure (OrdMap TypeName (UnionMember 'IN CONST) -> TypeContent ('IN <=? kind) kind CONST forall (s :: Stage) (a :: TypeCategory). UnionTypeDefinition 'IN s -> TypeContent ('IN <=? a) a s DataInputUnion OrdMap TypeName (UnionMember 'IN CONST) variants, [GQLTypeNodeExtension] nodes) where ([GRepCons (ArgumentsDefinition CONST)] nullaryVariants, [GRepCons (ArgumentsDefinition CONST)] objectVariants) = (GRepCons (ArgumentsDefinition CONST) -> Bool) -> [GRepCons (ArgumentsDefinition CONST)] -> ([GRepCons (ArgumentsDefinition CONST)], [GRepCons (ArgumentsDefinition CONST)]) forall a. (a -> Bool) -> [a] -> ([a], [a]) partition GRepCons (ArgumentsDefinition CONST) -> Bool forall a. GRepCons a -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [GRepCons (ArgumentsDefinition CONST)] inlineVariants members :: [UnionMember 'IN CONST] members = (TypeName -> UnionMember 'IN CONST) -> [TypeName] -> [UnionMember 'IN CONST] forall a b. (a -> b) -> [a] -> [b] map TypeName -> UnionMember 'IN CONST forall (cat :: TypeCategory) (s :: Stage). TypeName -> UnionMember cat s mkUnionMember ([TypeName] variantRefs [TypeName] -> [TypeName] -> [TypeName] forall a. Semigroup a => a -> a -> a <> (GRepCons (ArgumentsDefinition CONST) -> TypeName) -> [GRepCons (ArgumentsDefinition CONST)] -> [TypeName] forall a b. (a -> b) -> [a] -> [b] map GRepCons (ArgumentsDefinition CONST) -> TypeName forall a. GRepCons a -> TypeName consName [GRepCons (ArgumentsDefinition CONST)] objectVariants) [UnionMember 'IN CONST] -> [UnionMember 'IN CONST] -> [UnionMember 'IN CONST] forall a. Semigroup a => a -> a -> a <> (GRepCons (ArgumentsDefinition CONST) -> UnionMember 'IN CONST) -> [GRepCons (ArgumentsDefinition CONST)] -> [UnionMember 'IN CONST] forall a b. (a -> b) -> [a] -> [b] 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 mkNullaryMember (TypeName -> UnionMember 'IN CONST) -> (GRepCons (ArgumentsDefinition CONST) -> TypeName) -> GRepCons (ArgumentsDefinition CONST) -> UnionMember 'IN CONST forall b c a. (b -> c) -> (a -> b) -> a -> c . GRepCons (ArgumentsDefinition CONST) -> TypeName forall a. GRepCons a -> TypeName consName) [GRepCons (ArgumentsDefinition CONST)] nullaryVariants toUnion prx :: CatType kind a prx@CatType kind a OutputType [TypeName] unionRef [GRepCons (ArgumentsDefinition CONST)] unionCons = do OrdMap TypeName (UnionMember 'OUT CONST) variants <- [UnionMember 'OUT CONST] -> Result GQLError (OrdMap TypeName (UnionMember 'OUT CONST)) forall (m :: * -> *) k a (map :: * -> * -> *). (Monad m, KeyOf k a, FromList m map k a) => [a] -> m (map k a) fromElems ((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] unionRef [TypeName] -> [TypeName] -> [TypeName] forall a. Semigroup a => a -> a -> a <> (GRepCons (ArgumentsDefinition CONST) -> TypeName) -> [GRepCons (ArgumentsDefinition CONST)] -> [TypeName] forall a b. (a -> b) -> [a] -> [b] map GRepCons (ArgumentsDefinition CONST) -> TypeName forall a. GRepCons a -> TypeName consName [GRepCons (ArgumentsDefinition CONST)] unionCons)) (TypeContent TRUE kind CONST, [GQLTypeNodeExtension]) -> GQLResult (TypeContent TRUE kind CONST, [GQLTypeNodeExtension]) forall a. a -> Result GQLError a forall (f :: * -> *) a. Applicative f => a -> f a pure (OrdMap TypeName (UnionMember 'OUT CONST) -> TypeContent ('OUT <=? kind) kind CONST forall (s :: Stage) (a :: TypeCategory). UnionTypeDefinition 'OUT s -> TypeContent ('OUT <=? a) a s DataUnion OrdMap TypeName (UnionMember 'OUT CONST) variants, [[NodeTypeVariant] -> GQLTypeNodeExtension UnionVariantsExtension ([[NodeTypeVariant]] -> [NodeTypeVariant] forall (t :: * -> *) a. Foldable t => t [a] -> [a] concat ([[NodeTypeVariant]] -> [NodeTypeVariant]) -> [[NodeTypeVariant]] -> [NodeTypeVariant] forall a b. (a -> b) -> a -> b $ (GRepCons (ArgumentsDefinition CONST) -> [NodeTypeVariant]) -> [GRepCons (ArgumentsDefinition CONST)] -> [[NodeTypeVariant]] forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) forall (f :: * -> *) a b. Applicative f => (a -> f b) -> [a] -> f [b] traverse (CatType kind a -> GRepCons (ArgumentsDefinition CONST) -> [NodeTypeVariant] forall (kind :: TypeCategory) a. CatType kind a -> GRepCons (ArgumentsDefinition CONST) -> [NodeTypeVariant] toTypeVariants CatType kind a prx) [GRepCons (ArgumentsDefinition CONST)] unionCons)]) toTypeVariants :: CatType kind a -> GRepCons (ArgumentsDefinition CONST) -> [NodeTypeVariant] toTypeVariants :: forall (kind :: TypeCategory) a. CatType kind a -> GRepCons (ArgumentsDefinition CONST) -> [NodeTypeVariant] toTypeVariants CatType kind a proxy GRepCons {TypeName consName :: forall a. GRepCons a -> TypeName consName :: TypeName consName, [GRepField (ArgumentsDefinition CONST)] consFields :: [GRepField (ArgumentsDefinition CONST)] consFields :: forall a. GRepCons a -> [GRepField a] consFields} = [TypeName -> TypeContent TRUE ANY CONST -> NodeTypeVariant NodeTypeVariant TypeName consName (TypeContent TRUE kind CONST -> TypeContent TRUE ANY CONST forall (a :: TypeCategory -> Stage -> *) (k :: TypeCategory) (s :: Stage). ToCategory a k ANY => a k s -> a ANY s toAny (CatType kind a -> [FieldDefinition kind CONST] -> TypeContent TRUE kind CONST forall {k} (kind :: TypeCategory) (a :: k) (s :: Stage). CatType kind a -> [FieldDefinition kind s] -> TypeContent TRUE kind s mkObject CatType kind a proxy [FieldDefinition kind CONST] fields))] [NodeTypeVariant] -> [NodeTypeVariant] -> [NodeTypeVariant] forall a. Semigroup a => a -> a -> a <> [NodeTypeVariant NodeUnitType | [GRepField (ArgumentsDefinition CONST)] -> Bool forall a. [a] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [GRepField (ArgumentsDefinition CONST)] consFields] where fields :: [FieldDefinition kind CONST] fields | [GRepField (ArgumentsDefinition CONST)] -> Bool forall a. [a] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [GRepField (ArgumentsDefinition CONST)] consFields = [Maybe (FieldContent TRUE kind CONST) -> FieldName -> TypeRef -> FieldDefinition kind CONST forall (cat :: TypeCategory) (s :: Stage). Maybe (FieldContent TRUE cat s) -> FieldName -> TypeRef -> FieldDefinition cat s mkField Maybe (FieldContent TRUE kind CONST) forall a. Maybe a Nothing FieldName unitFieldName (TypeName -> TypeRef mkTypeRef TypeName unitTypeName)] | Bool otherwise = (GRepField (ArgumentsDefinition CONST) -> FieldDefinition kind CONST) -> [GRepField (ArgumentsDefinition CONST)] -> [FieldDefinition kind CONST] forall a b. (a -> b) -> [a] -> [b] map (CatType kind a -> GRepField (ArgumentsDefinition CONST) -> FieldDefinition kind CONST forall (c :: TypeCategory) a. CatType c a -> GRepField (ArgumentsDefinition CONST) -> FieldDefinition c CONST repToField CatType kind a proxy) [GRepField (ArgumentsDefinition CONST)] consFields toTypeContent :: (gql a) => UseDeriving gql args -> CatType kind a -> GRepType (ArgumentsDefinition CONST) -> GQLResult (TypeContent TRUE kind CONST, [GQLTypeNodeExtension]) toTypeContent :: forall (gql :: * -> Constraint) a (args :: * -> Constraint) (kind :: TypeCategory). gql a => UseDeriving gql args -> CatType kind a -> GRepType (ArgumentsDefinition CONST) -> GQLResult (TypeContent TRUE kind CONST, [GQLTypeNodeExtension]) toTypeContent UseDeriving gql args ctx CatType kind a prx (GRepTypeEnum [TypeName] variants) = (,[]) (TypeContent TRUE kind CONST -> (TypeContent TRUE kind CONST, [GQLTypeNodeExtension])) -> ([DataEnumValue CONST] -> TypeContent TRUE kind CONST) -> [DataEnumValue CONST] -> (TypeContent TRUE kind CONST, [GQLTypeNodeExtension]) forall b c a. (b -> c) -> (a -> b) -> a -> c . CatType kind a -> [DataEnumValue CONST] -> TypeContent TRUE kind CONST forall {k} (c :: TypeCategory) (a :: k) (s :: Stage). CatType c a -> [DataEnumValue s] -> TypeContent TRUE c s mkEnum CatType kind a prx ([DataEnumValue CONST] -> (TypeContent TRUE kind CONST, [GQLTypeNodeExtension])) -> Result GQLError [DataEnumValue CONST] -> Result GQLError (TypeContent TRUE kind CONST, [GQLTypeNodeExtension]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (TypeName -> GQLResult (DataEnumValue CONST)) -> [TypeName] -> Result GQLError [DataEnumValue CONST] forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) forall (f :: * -> *) a b. Applicative f => (a -> f b) -> [a] -> f [b] traverse (UseDeriving gql args -> CatType kind a -> TypeName -> GQLResult (DataEnumValue CONST) forall (gql :: * -> Constraint) a (args :: * -> Constraint) (f :: * -> *). gql a => UseDeriving gql args -> f a -> TypeName -> GQLResult (DataEnumValue CONST) toEnumValue UseDeriving gql args ctx CatType kind a prx) [TypeName] variants toTypeContent UseDeriving gql args ctx CatType kind a prx (GRepTypeObject [GRepField (ArgumentsDefinition CONST)] fields) = (,[]) (TypeContent TRUE kind CONST -> (TypeContent TRUE kind CONST, [GQLTypeNodeExtension])) -> ([FieldDefinition kind CONST] -> TypeContent TRUE kind CONST) -> [FieldDefinition kind CONST] -> (TypeContent TRUE kind CONST, [GQLTypeNodeExtension]) forall b c a. (b -> c) -> (a -> b) -> a -> c . CatType kind a -> [FieldDefinition kind CONST] -> TypeContent TRUE kind CONST forall {k} (kind :: TypeCategory) (a :: k) (s :: Stage). CatType kind a -> [FieldDefinition kind s] -> TypeContent TRUE kind s mkObject CatType kind a prx ([FieldDefinition kind CONST] -> (TypeContent TRUE kind CONST, [GQLTypeNodeExtension])) -> Result GQLError [FieldDefinition kind CONST] -> Result GQLError (TypeContent TRUE kind CONST, [GQLTypeNodeExtension]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (GRepField (ArgumentsDefinition CONST) -> Result GQLError (FieldDefinition kind CONST)) -> [GRepField (ArgumentsDefinition CONST)] -> Result GQLError [FieldDefinition kind CONST] forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) forall (f :: * -> *) a b. Applicative f => (a -> f b) -> [a] -> f [b] traverse (UseDeriving gql args -> CatType kind a -> FieldDefinition kind CONST -> Result GQLError (FieldDefinition kind CONST) forall (gql :: * -> Constraint) a (args :: * -> Constraint) (kind :: TypeCategory). gql a => UseDeriving gql args -> CatType kind a -> FieldDefinition kind CONST -> GQLResult (FieldDefinition kind CONST) visitField UseDeriving gql args ctx CatType kind a prx (FieldDefinition kind CONST -> Result GQLError (FieldDefinition kind CONST)) -> (GRepField (ArgumentsDefinition CONST) -> FieldDefinition kind CONST) -> GRepField (ArgumentsDefinition CONST) -> Result GQLError (FieldDefinition kind CONST) forall b c a. (b -> c) -> (a -> b) -> a -> c . CatType kind a -> GRepField (ArgumentsDefinition CONST) -> FieldDefinition kind CONST forall (c :: TypeCategory) a. CatType c a -> GRepField (ArgumentsDefinition CONST) -> FieldDefinition c CONST repToField CatType kind a prx) [GRepField (ArgumentsDefinition CONST)] fields toTypeContent UseDeriving gql args _ CatType kind a prx GRepTypeUnion {[(TypeName, ArgumentsDefinition CONST)] [GRepCons (ArgumentsDefinition CONST)] variantRefs :: [(TypeName, ArgumentsDefinition CONST)] inlineVariants :: [GRepCons (ArgumentsDefinition CONST)] variantRefs :: forall v. GRepType v -> [(TypeName, v)] inlineVariants :: forall v. GRepType v -> [GRepCons v] ..} = CatType kind a -> [TypeName] -> [GRepCons (ArgumentsDefinition CONST)] -> Result GQLError (TypeContent TRUE kind CONST, [GQLTypeNodeExtension]) forall (kind :: TypeCategory) a. CatType kind a -> [TypeName] -> [GRepCons (ArgumentsDefinition CONST)] -> GQLResult (TypeContent TRUE kind CONST, [GQLTypeNodeExtension]) toUnion CatType kind a prx (((TypeName, ArgumentsDefinition CONST) -> TypeName) -> [(TypeName, ArgumentsDefinition CONST)] -> [TypeName] forall a b. (a -> b) -> [a] -> [b] map (TypeName, ArgumentsDefinition CONST) -> TypeName forall a b. (a, b) -> a fst [(TypeName, ArgumentsDefinition CONST)] variantRefs) [GRepCons (ArgumentsDefinition CONST)] inlineVariants type TypeProxy gql args kind a = (UseDeriving gql args, CatType kind a) deriveTypeContent :: (DERIVE_TYPE gql a) => TypeProxy gql args kind a -> GQLResult (TypeContent TRUE kind CONST, [GQLTypeNodeExtension]) deriveTypeContent :: forall (gql :: * -> Constraint) a (args :: * -> Constraint) (kind :: TypeCategory). DERIVE_TYPE gql a => TypeProxy gql args kind a -> GQLResult (TypeContent TRUE kind CONST, [GQLTypeNodeExtension]) deriveTypeContent (UseDeriving gql args cxt, CatType kind a prx) = GRepFun gql gql Proxy (Result GQLError (ArgumentsDefinition CONST)) -> CatType kind a -> Result GQLError (GRepType (ArgumentsDefinition CONST)) forall {k} (kind :: k) (gql :: * -> Constraint) (c :: * -> Constraint) v (kinded :: k -> * -> *) (m :: * -> *) a. (GRep gql c (m v) (Rep a), Monad m, gql a) => GRepFun gql c Proxy (m v) -> kinded kind a -> m (GRepType v) deriveType (CatType kind a -> UseDeriving gql args -> GRepFun gql gql Proxy (Result GQLError (ArgumentsDefinition CONST)) forall ctx (gql :: * -> Constraint) (cat :: TypeCategory) a. UseGQLType ctx gql => CatType cat a -> ctx -> GRepFun gql gql Proxy (Result GQLError (ArgumentsDefinition CONST)) fieldGRep CatType kind a prx UseDeriving gql args cxt) CatType kind a prx Result GQLError (GRepType (ArgumentsDefinition CONST)) -> (GRepType (ArgumentsDefinition CONST) -> Result GQLError (TypeContent TRUE kind CONST, [GQLTypeNodeExtension])) -> Result GQLError (TypeContent TRUE kind CONST, [GQLTypeNodeExtension]) forall a b. Result GQLError a -> (a -> Result GQLError b) -> Result GQLError b forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= UseDeriving gql args -> CatType kind a -> GRepType (ArgumentsDefinition CONST) -> Result GQLError (TypeContent TRUE kind CONST, [GQLTypeNodeExtension]) forall (gql :: * -> Constraint) a (args :: * -> Constraint) (kind :: TypeCategory). gql a => UseDeriving gql args -> CatType kind a -> GRepType (ArgumentsDefinition CONST) -> GQLResult (TypeContent TRUE kind CONST, [GQLTypeNodeExtension]) toTypeContent UseDeriving gql args cxt CatType kind a prx deriveTypeGuardUnions :: (DERIVE_TYPE gql a) => TypeProxy gql args OUT a -> GQLResult [TypeName] deriveTypeGuardUnions :: forall (gql :: * -> Constraint) a (args :: * -> Constraint). DERIVE_TYPE gql a => TypeProxy gql args 'OUT a -> GQLResult [TypeName] deriveTypeGuardUnions TypeProxy gql args 'OUT a prx = TypeProxy gql args 'OUT a -> GQLResult (TypeContent TRUE 'OUT CONST, [GQLTypeNodeExtension]) forall (gql :: * -> Constraint) a (args :: * -> Constraint) (kind :: TypeCategory). DERIVE_TYPE gql a => TypeProxy gql args kind a -> GQLResult (TypeContent TRUE kind CONST, [GQLTypeNodeExtension]) deriveTypeContent TypeProxy gql args 'OUT a prx GQLResult (TypeContent TRUE 'OUT CONST, [GQLTypeNodeExtension]) -> ((TypeContent TRUE 'OUT CONST, [GQLTypeNodeExtension]) -> GQLResult [TypeName]) -> GQLResult [TypeName] forall a b. Result GQLError a -> (a -> Result GQLError b) -> Result GQLError b forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= TypeProxy gql args 'OUT a -> TypeContent TRUE 'OUT CONST -> GQLResult [TypeName] forall (gql :: * -> Constraint) a (args :: * -> Constraint) (kind :: TypeCategory). DERIVE_TYPE gql a => TypeProxy gql args kind a -> TypeContent TRUE 'OUT CONST -> GQLResult [TypeName] getUnionNames TypeProxy gql args 'OUT a prx (TypeContent TRUE 'OUT CONST -> GQLResult [TypeName]) -> ((TypeContent TRUE 'OUT CONST, [GQLTypeNodeExtension]) -> TypeContent TRUE 'OUT CONST) -> (TypeContent TRUE 'OUT CONST, [GQLTypeNodeExtension]) -> GQLResult [TypeName] forall b c a. (b -> c) -> (a -> b) -> a -> c . (TypeContent TRUE 'OUT CONST, [GQLTypeNodeExtension]) -> TypeContent TRUE 'OUT CONST forall a b. (a, b) -> a fst getUnionNames :: (DERIVE_TYPE gql a) => TypeProxy gql args kind a -> TypeContent TRUE OUT CONST -> GQLResult [TypeName] getUnionNames :: forall (gql :: * -> Constraint) a (args :: * -> Constraint) (kind :: TypeCategory). DERIVE_TYPE gql a => TypeProxy gql args kind a -> TypeContent TRUE 'OUT CONST -> GQLResult [TypeName] getUnionNames TypeProxy gql args kind a _ DataUnion {OrdMap TypeName (UnionMember 'OUT CONST) unionMembers :: OrdMap TypeName (UnionMember 'OUT CONST) unionMembers :: forall (s :: Stage) (a :: TypeCategory). CondTypeContent 'OUT a s -> UnionTypeDefinition 'OUT s unionMembers} = [TypeName] -> GQLResult [TypeName] forall a. a -> Result GQLError a forall (f :: * -> *) a. Applicative f => a -> f a pure ([TypeName] -> GQLResult [TypeName]) -> [TypeName] -> GQLResult [TypeName] forall a b. (a -> b) -> a -> b $ OrdMap TypeName TypeName -> [TypeName] forall a. OrdMap TypeName a -> [a] forall (t :: * -> *) a. Foldable t => t a -> [a] toList (OrdMap TypeName TypeName -> [TypeName]) -> OrdMap TypeName TypeName -> [TypeName] forall a b. (a -> b) -> a -> b $ UnionMember 'OUT CONST -> TypeName forall (cat :: TypeCategory) (s :: Stage). UnionMember cat s -> TypeName memberName (UnionMember 'OUT CONST -> TypeName) -> OrdMap TypeName (UnionMember 'OUT CONST) -> OrdMap TypeName TypeName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> OrdMap TypeName (UnionMember 'OUT CONST) unionMembers getUnionNames (UseDeriving gql args ctx, CatType kind a prx) DataObject {} = [TypeName] -> GQLResult [TypeName] forall a. a -> Result GQLError a forall (f :: * -> *) a. Applicative f => a -> f a pure [UseDeriving gql args -> CatType kind a -> TypeName forall a (c :: TypeCategory). gql a => UseDeriving gql args -> CatType c a -> TypeName forall ctx (con :: * -> Constraint) a (c :: TypeCategory). (UseGQLType ctx con, con a) => ctx -> CatType c a -> TypeName useTypename UseDeriving gql args ctx CatType kind a prx] getUnionNames TypeProxy gql args kind a _ TypeContent TRUE 'OUT CONST _ = GQLError -> GQLResult [TypeName] forall a. GQLError -> Result GQLError a forall e (m :: * -> *) a. MonadError e m => e -> m a throwError GQLError "guarded type must be an union or object" deriveScalarDefinition :: (gql a) => (CatType cat a -> ScalarDefinition) -> UseDeriving gql args -> CatType cat a -> GQLResult (GQLTypeNode cat) deriveScalarDefinition :: forall (gql :: * -> Constraint) a (cat :: TypeCategory) (args :: * -> Constraint). gql a => (CatType cat a -> ScalarDefinition) -> UseDeriving gql args -> CatType cat a -> GQLResult (GQLTypeNode cat) deriveScalarDefinition CatType cat a -> ScalarDefinition f UseDeriving gql args ctx CatType cat a p = (TypeDefinition cat CONST -> [GQLTypeNodeExtension] -> GQLTypeNode cat forall (c :: TypeCategory). TypeDefinition c CONST -> [GQLTypeNodeExtension] -> GQLTypeNode c `GQLTypeNode` []) (TypeDefinition cat CONST -> GQLTypeNode cat) -> Result GQLError (TypeDefinition cat CONST) -> Result GQLError (GQLTypeNode cat) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> UseDeriving gql args -> CatType cat a -> TypeContent TRUE cat CONST -> Result GQLError (TypeDefinition cat CONST) forall (gql :: * -> Constraint) a (args :: * -> Constraint) (c :: TypeCategory) (cat :: TypeCategory). gql a => UseDeriving gql args -> CatType c a -> TypeContent TRUE cat CONST -> GQLResult (TypeDefinition cat CONST) toTypeDefinition UseDeriving gql args ctx CatType cat a p (CatType cat a -> ScalarDefinition -> TypeContent TRUE cat CONST forall {k} (c :: TypeCategory) (a :: k) (s :: Stage). CatType c a -> ScalarDefinition -> TypeContent TRUE c s mkScalar CatType cat a p (CatType cat a -> ScalarDefinition f CatType cat a p)) deriveTypeDefinition :: (DERIVE_TYPE gql a) => UseDeriving gql args -> CatType c a -> GQLResult (TypeDefinition c CONST, [GQLTypeNodeExtension]) deriveTypeDefinition :: forall (gql :: * -> Constraint) a (args :: * -> Constraint) (c :: TypeCategory). DERIVE_TYPE gql a => UseDeriving gql args -> CatType c a -> GQLResult (TypeDefinition c CONST, [GQLTypeNodeExtension]) deriveTypeDefinition UseDeriving gql args ctx CatType c a proxy = do (TypeContent TRUE c CONST content, [GQLTypeNodeExtension] ext) <- TypeProxy gql args c a -> GQLResult (TypeContent TRUE c CONST, [GQLTypeNodeExtension]) forall (gql :: * -> Constraint) a (args :: * -> Constraint) (kind :: TypeCategory). DERIVE_TYPE gql a => TypeProxy gql args kind a -> GQLResult (TypeContent TRUE kind CONST, [GQLTypeNodeExtension]) deriveTypeContent (UseDeriving gql args ctx, CatType c a proxy) (,[GQLTypeNodeExtension] ext) (TypeDefinition c CONST -> (TypeDefinition c CONST, [GQLTypeNodeExtension])) -> Result GQLError (TypeDefinition c CONST) -> GQLResult (TypeDefinition c CONST, [GQLTypeNodeExtension]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> UseDeriving gql args -> CatType c a -> TypeContent TRUE c CONST -> Result GQLError (TypeDefinition c CONST) forall (gql :: * -> Constraint) a (args :: * -> Constraint) (c :: TypeCategory) (cat :: TypeCategory). gql a => UseDeriving gql args -> CatType c a -> TypeContent TRUE cat CONST -> GQLResult (TypeDefinition cat CONST) toTypeDefinition UseDeriving gql args ctx CatType c a proxy TypeContent TRUE c CONST content deriveInterfaceDefinition :: (DERIVE_TYPE gql a) => UseDeriving gql args -> CatType OUT a -> GQLResult (TypeDefinition OUT CONST, [GQLTypeNodeExtension]) deriveInterfaceDefinition :: forall (gql :: * -> Constraint) a (args :: * -> Constraint). DERIVE_TYPE gql a => UseDeriving gql args -> CatType 'OUT a -> GQLResult (TypeDefinition 'OUT CONST, [GQLTypeNodeExtension]) deriveInterfaceDefinition UseDeriving gql args ctx CatType 'OUT a proxy = do (TypeContent TRUE 'OUT CONST content, [GQLTypeNodeExtension] ext) <- TypeProxy gql args 'OUT a -> GQLResult (TypeContent TRUE 'OUT CONST, [GQLTypeNodeExtension]) forall (gql :: * -> Constraint) a (args :: * -> Constraint) (kind :: TypeCategory). DERIVE_TYPE gql a => TypeProxy gql args kind a -> GQLResult (TypeContent TRUE kind CONST, [GQLTypeNodeExtension]) deriveTypeContent (UseDeriving gql args ctx, CatType 'OUT a proxy) FieldsDefinition 'OUT CONST fields <- TypeName -> TypeContent TRUE 'OUT CONST -> Result GQLError (FieldsDefinition 'OUT CONST) forall (m :: * -> *) (any :: TypeCategory) (s :: Stage). DerivingMonad m => TypeName -> TypeContent TRUE any s -> m (FieldsDefinition 'OUT s) withObject (UseDeriving gql args -> CatType 'OUT a -> TypeName forall a (c :: TypeCategory). gql a => UseDeriving gql args -> CatType c a -> TypeName forall ctx (con :: * -> Constraint) a (c :: TypeCategory). (UseGQLType ctx con, con a) => ctx -> CatType c a -> TypeName useTypename UseDeriving gql args ctx CatType 'OUT a proxy) TypeContent TRUE 'OUT CONST content (,[GQLTypeNodeExtension] ext) (TypeDefinition 'OUT CONST -> (TypeDefinition 'OUT CONST, [GQLTypeNodeExtension])) -> Result GQLError (TypeDefinition 'OUT CONST) -> GQLResult (TypeDefinition 'OUT CONST, [GQLTypeNodeExtension]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> UseDeriving gql args -> CatType 'OUT a -> TypeContent TRUE 'OUT CONST -> Result GQLError (TypeDefinition 'OUT CONST) forall (gql :: * -> Constraint) a (args :: * -> Constraint) (c :: TypeCategory) (cat :: TypeCategory). gql a => UseDeriving gql args -> CatType c a -> TypeContent TRUE cat CONST -> GQLResult (TypeDefinition cat CONST) toTypeDefinition UseDeriving gql args ctx CatType 'OUT a proxy (FieldsDefinition 'OUT CONST -> TypeContent (IMPLEMENTABLE <=? 'OUT) 'OUT CONST forall (s :: Stage) (a :: TypeCategory). FieldsDefinition 'OUT s -> TypeContent (IMPLEMENTABLE <=? a) a s DataInterface FieldsDefinition 'OUT CONST fields) toTypeDefinition :: (gql a) => UseDeriving gql args -> CatType c a -> TypeContent TRUE cat CONST -> GQLResult (TypeDefinition cat CONST) toTypeDefinition :: forall (gql :: * -> Constraint) a (args :: * -> Constraint) (c :: TypeCategory) (cat :: TypeCategory). gql a => UseDeriving gql args -> CatType c a -> TypeContent TRUE cat CONST -> GQLResult (TypeDefinition cat CONST) toTypeDefinition UseDeriving gql args ctx CatType c a proxy TypeContent TRUE cat CONST content = do Directives CONST dirs <- UseDeriving gql args -> [GDirectiveUsage gql args] -> GQLResult (Directives CONST) forall (gql :: * -> Constraint) (args :: * -> Constraint). UseDeriving gql args -> [GDirectiveUsage gql args] -> GQLResult (Directives CONST) serializeDirectives UseDeriving gql args ctx (UseDeriving gql args -> CatType c a -> [GDirectiveUsage gql args] forall (gql :: * -> Constraint) a (args :: * -> Constraint) (f :: * -> *). gql a => UseDeriving gql args -> f a -> [GDirectiveUsage gql args] getTypeDirectives UseDeriving gql args ctx CatType c a proxy) TypeDefinition cat CONST -> GQLResult (TypeDefinition cat CONST) forall a. a -> Result GQLError a forall (f :: * -> *) a. Applicative f => a -> f a pure (TypeDefinition cat CONST -> GQLResult (TypeDefinition cat CONST)) -> TypeDefinition cat CONST -> GQLResult (TypeDefinition cat CONST) forall a b. (a -> b) -> a -> b $ Maybe Description -> TypeName -> Directives CONST -> TypeContent TRUE cat CONST -> TypeDefinition cat CONST forall (a :: TypeCategory) (s :: Stage). Maybe Description -> TypeName -> Directives s -> TypeContent TRUE a s -> TypeDefinition a s TypeDefinition (UseDeriving gql args -> CatType c a -> Maybe Description -> Maybe Description forall (gql :: * -> Constraint) a (args :: * -> Constraint) (f :: * -> *). gql a => UseDeriving gql args -> f a -> Maybe Description -> Maybe Description visitTypeDescription UseDeriving gql args ctx CatType c a proxy Maybe Description forall a. Maybe a Nothing) (UseDeriving gql args -> CatType c a -> TypeName forall a (c :: TypeCategory). gql a => UseDeriving gql args -> CatType c a -> TypeName forall ctx (con :: * -> Constraint) a (c :: TypeCategory). (UseGQLType ctx con, con a) => ctx -> CatType c a -> TypeName useTypename UseDeriving gql args ctx CatType c a proxy) Directives CONST dirs TypeContent TRUE cat CONST content fieldGRep :: (UseGQLType ctx gql) => CatType cat a -> ctx -> GRepFun gql gql Proxy (GQLResult (ArgumentsDefinition CONST)) fieldGRep :: forall ctx (gql :: * -> Constraint) (cat :: TypeCategory) a. UseGQLType ctx gql => CatType cat a -> ctx -> GRepFun gql gql Proxy (Result GQLError (ArgumentsDefinition CONST)) fieldGRep CatType cat a cat ctx gql = GRepFun { grepTypename :: forall (proxy :: * -> *) a. gql a => proxy a -> TypeName grepTypename = ctx -> CatType cat a -> TypeName forall a (c :: TypeCategory). gql a => ctx -> CatType c a -> TypeName forall ctx (con :: * -> Constraint) a (c :: TypeCategory). (UseGQLType ctx con, con a) => ctx -> CatType c a -> TypeName useTypename ctx gql (CatType cat a -> TypeName) -> (proxy a -> CatType cat a) -> proxy a -> TypeName forall b c a. (b -> c) -> (a -> b) -> a -> c . (proxy a -> CatType cat a -> CatType cat a forall {k1} {k2} (f :: k1 -> *) (a :: k1) (cat :: TypeCategory) (b :: k2). f a -> CatType cat b -> CatType cat a `mapCat` CatType cat a cat), grepWrappers :: forall (proxy :: * -> *) a. gql a => proxy a -> TypeWrapper grepWrappers = ctx -> CatType cat a -> TypeWrapper forall a (c :: TypeCategory). gql a => ctx -> CatType c a -> TypeWrapper forall ctx (con :: * -> Constraint) a (c :: TypeCategory). (UseGQLType ctx con, con a) => ctx -> CatType c a -> TypeWrapper useWrappers ctx gql (CatType cat a -> TypeWrapper) -> (proxy a -> CatType cat a) -> proxy a -> TypeWrapper forall b c a. (b -> c) -> (a -> b) -> a -> c . (proxy a -> CatType cat a -> CatType cat a forall {k1} {k2} (f :: k1 -> *) (a :: k1) (cat :: TypeCategory) (b :: k2). f a -> CatType cat b -> CatType cat a `mapCat` CatType cat a cat), grepFun :: forall a. gql a => Proxy a -> Result GQLError (ArgumentsDefinition CONST) grepFun = ctx -> CatType cat a -> Result GQLError (ArgumentsDefinition CONST) forall a (c :: TypeCategory). gql a => ctx -> CatType c a -> Result GQLError (ArgumentsDefinition CONST) forall ctx (con :: * -> Constraint) a (c :: TypeCategory). (UseGQLType ctx con, con a) => ctx -> CatType c a -> Result GQLError (ArgumentsDefinition CONST) useDeriveFieldArgs ctx gql (CatType cat a -> Result GQLError (ArgumentsDefinition CONST)) -> (Proxy a -> CatType cat a) -> Proxy a -> Result GQLError (ArgumentsDefinition CONST) forall b c a. (b -> c) -> (a -> b) -> a -> c . (Proxy a -> CatType cat a -> CatType cat a forall {k1} {k2} (f :: k1 -> *) (a :: k1) (cat :: TypeCategory) (b :: k2). f a -> CatType cat b -> CatType cat a `mapCat` CatType cat a cat) }