{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.Server.TH.Declare.GQLDirective ( deriveGQLDirective, ) where import Data.Morpheus.CodeGen.Internal.AST ( ServerConstructorDefinition (..), ServerTypeDefinition (..), TypeName, ) import Data.Morpheus.CodeGen.Internal.TH ( apply, applyVars, typeInstanceDec, ) import Data.Morpheus.Server.TH.Utils ( ServerDec, mkTypeableConstraints, ) import Data.Morpheus.Server.Types.Directives ( GQLDirective (..), ) import Data.Morpheus.Types.Internal.AST ( DirectiveLocation (..), ) import Language.Haskell.TH ( Dec, Name, Q, Type (..), instanceD, ) import Relude hiding (Type, toString) noVars :: [Name] noVars :: [Name] noVars = [] deriveGQLDirective :: ServerTypeDefinition -> ServerDec [Dec] deriveGQLDirective :: ServerTypeDefinition -> ServerDec [Dec] deriveGQLDirective DirectiveTypeDefinition {[DerivingClass] [DirectiveLocation] GQLTypeDefinition ServerConstructorDefinition directiveConstructor :: ServerTypeDefinition -> ServerConstructorDefinition directiveDerives :: ServerTypeDefinition -> [DerivingClass] directiveLocations :: ServerTypeDefinition -> [DirectiveLocation] directiveGQLType :: ServerTypeDefinition -> GQLTypeDefinition directiveGQLType :: GQLTypeDefinition directiveLocations :: [DirectiveLocation] directiveDerives :: [DerivingClass] directiveConstructor :: ServerConstructorDefinition ..} = do let constrains :: CxtQ constrains = [Name] -> CxtQ mkTypeableConstraints [Name] noVars let tName :: TypeName tName = ServerConstructorDefinition -> TypeName constructorName ServerConstructorDefinition directiveConstructor let typeSignature :: Q Type typeSignature = forall a i. (Apply a, ToCon i a) => i -> [a] -> a apply ''GQLDirective [forall con var res. (ToName con, ToName var, Apply res, ToCon con res, ToVar var res) => con -> [var] -> res applyVars TypeName tName [Name] noVars] [Q Dec] methods <- TypeName -> [DirectiveLocation] -> ServerDec [Q Dec] defineMethods (ServerConstructorDefinition -> TypeName constructorName ServerConstructorDefinition directiveConstructor) [DirectiveLocation] directiveLocations Dec gqlTypeDeclaration <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift (forall (m :: * -> *). Quote m => m Cxt -> m Type -> [m Dec] -> m Dec instanceD CxtQ constrains Q Type typeSignature [Q Dec] methods) forall (f :: * -> *) a. Applicative f => a -> f a pure [Dec gqlTypeDeclaration] deriveGQLDirective ServerTypeDefinition _ = forall (f :: * -> *) a. Applicative f => a -> f a pure [] defineMethods :: TypeName -> [DirectiveLocation] -> ServerDec [Q Dec] defineMethods :: TypeName -> [DirectiveLocation] -> ServerDec [Q Dec] defineMethods TypeName tName [DirectiveLocation] locations = do let currentType :: Type currentType = forall con var res. (ToName con, ToName var, Apply res, ToCon con res, ToVar var res) => con -> [var] -> res applyVars TypeName tName [Name] noVars let inst :: Dec inst = Name -> Type -> Type -> Dec typeInstanceDec ''DIRECTIVE_LOCATIONS Type currentType ([DirectiveLocation] -> Type promotedList [DirectiveLocation] locations) forall (f :: * -> *) a. Applicative f => a -> f a pure [forall (f :: * -> *) a. Applicative f => a -> f a pure Dec inst] locationName :: DirectiveLocation -> Name locationName :: DirectiveLocation -> Name locationName DirectiveLocation QUERY = 'QUERY locationName DirectiveLocation MUTATION = 'MUTATION locationName DirectiveLocation SUBSCRIPTION = 'SUBSCRIPTION locationName DirectiveLocation FIELD = 'FIELD locationName DirectiveLocation FRAGMENT_DEFINITION = 'FRAGMENT_DEFINITION locationName DirectiveLocation FRAGMENT_SPREAD = 'FRAGMENT_SPREAD locationName DirectiveLocation INLINE_FRAGMENT = 'INLINE_FRAGMENT locationName DirectiveLocation SCHEMA = 'SCHEMA locationName DirectiveLocation SCALAR = 'SCALAR locationName DirectiveLocation OBJECT = 'OBJECT locationName DirectiveLocation FIELD_DEFINITION = 'FIELD_DEFINITION locationName DirectiveLocation ARGUMENT_DEFINITION = 'ARGUMENT_DEFINITION locationName DirectiveLocation INTERFACE = 'INTERFACE locationName DirectiveLocation UNION = 'UNION locationName DirectiveLocation ENUM = 'ENUM locationName DirectiveLocation ENUM_VALUE = 'ENUM_VALUE locationName DirectiveLocation INPUT_OBJECT = 'INPUT_OBJECT locationName DirectiveLocation INPUT_FIELD_DEFINITION = 'INPUT_FIELD_DEFINITION promotedList :: [DirectiveLocation] -> Type promotedList :: [DirectiveLocation] -> Type promotedList = forall (t :: * -> *) a b. Foldable t => (a -> b -> b) -> b -> t a -> b foldr (Type -> Type -> Type AppT forall b c a. (b -> c) -> (a -> b) -> a -> c . Type -> Type -> Type AppT Type PromotedConsT forall b c a. (b -> c) -> (a -> b) -> a -> c . Name -> Type PromotedT forall b c a. (b -> c) -> (a -> b) -> a -> c . DirectiveLocation -> Name locationName) Type PromotedNilT