{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.Server.TH.Declare.GQLType ( deriveGQLType, ) where import Data.Morpheus.CodeGen.Internal.AST ( CodeGenConfig (..), GQLTypeDefinition (..), Kind (..), ServerConstructorDefinition (constructorName), ServerDirectiveUsage (..), ServerTypeDefinition (..), TypeValue (..), unpackName, ) import Data.Morpheus.CodeGen.Internal.TH ( ToName (..), apply, applyVars, typeInstanceDec, ) import Data.Morpheus.Kind ( SCALAR, TYPE, ) import Data.Morpheus.Server.TH.Utils ( ServerDec, funDProxy, mkTypeableConstraints, renderTypeVars, ) import Data.Morpheus.Server.Types.GQLType ( enumDirective, fieldDirective, typeDirective, ) import Data.Morpheus.Server.Types.Internal ( dropNamespaceOptions, ) import Data.Morpheus.Types ( GQLType (..), ) import Data.Morpheus.Types.Internal.AST ( FieldName, TypeKind (..), ) import qualified Data.Text as T import Language.Haskell.TH ( Dec, DecQ, ExpQ, FieldExp, Name, Q, Type (ConT), appE, conE, instanceD, listE, litE, recConE, stringL, ) import Relude hiding (toString) deriveGQLType :: ServerTypeDefinition -> ServerDec [Dec] deriveGQLType :: ServerTypeDefinition -> ServerDec [Dec] deriveGQLType ServerTypeDefinition { Text tName :: ServerTypeDefinition -> Text tName :: Text tName, TypeKind tKind :: ServerTypeDefinition -> TypeKind tKind :: TypeKind tKind, [Text] typeParameters :: ServerTypeDefinition -> [Text] typeParameters :: [Text] typeParameters, Maybe GQLTypeDefinition typeGQLType :: ServerTypeDefinition -> Maybe GQLTypeDefinition typeGQLType :: Maybe GQLTypeDefinition typeGQLType } = do let typeVars :: [Name] typeVars = [Text] -> [Name] renderTypeVars [Text] typeParameters let constrains :: CxtQ constrains = [Name] -> CxtQ mkTypeableConstraints [Name] typeVars let typeSignature :: Q Type typeSignature = forall a i. (Apply a, ToCon i a) => i -> [a] -> a apply ''GQLType [forall con var res. (ToName con, ToName var, Apply res, ToCon con res, ToVar var res) => con -> [var] -> res applyVars Text tName [Name] typeVars] [Q Dec] methods <- Text -> TypeKind -> [Name] -> Maybe GQLTypeDefinition -> ServerDec [Q Dec] defineMethods Text tName TypeKind tKind [Name] typeVars Maybe GQLTypeDefinition typeGQLType 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] deriveGQLType 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 typeVars :: [Name] typeVars = [] :: [Name] let tName :: Text tName = forall a (t :: NAME). NamePacking a => Name t -> a unpackName (ServerConstructorDefinition -> TypeName constructorName ServerConstructorDefinition directiveConstructor) let constrains :: CxtQ constrains = [Name] -> CxtQ mkTypeableConstraints [Name] typeVars let typeSignature :: Q Type typeSignature = forall a i. (Apply a, ToCon i a) => i -> [a] -> a apply ''GQLType [forall con var res. (ToName con, ToName var, Apply res, ToCon con res, ToVar var res) => con -> [var] -> res applyVars Text tName [Name] typeVars] [Q Dec] methods <- Text -> TypeKind -> [Name] -> Maybe GQLTypeDefinition -> ServerDec [Q Dec] defineMethods Text tName TypeKind KindInputObject [Name] typeVars (forall a. a -> Maybe a Just GQLTypeDefinition directiveGQLType) 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] deriveGQLType ServerTypeDefinition _ = forall (f :: * -> *) a. Applicative f => a -> f a pure [] defineTypeOptions :: Text -> TypeKind -> ServerDec [DecQ] defineTypeOptions :: Text -> TypeKind -> ServerDec [Q Dec] defineTypeOptions Text tName TypeKind kind = do CodeGenConfig {Bool namespace :: CodeGenConfig -> Bool namespace :: Bool namespace} <- forall r (m :: * -> *). MonadReader r m => m r ask forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ [(Name, ExpQ)] -> [Q Dec] funDProxy [('typeOptions, [|dropNamespaceOptions kind tName|]) | Bool namespace] defineMethods :: Text -> TypeKind -> [Name] -> Maybe GQLTypeDefinition -> ServerDec [Q Dec] defineMethods :: Text -> TypeKind -> [Name] -> Maybe GQLTypeDefinition -> ServerDec [Q Dec] defineMethods Text tName TypeKind kind [Name] _ Maybe GQLTypeDefinition Nothing = Text -> TypeKind -> ServerDec [Q Dec] defineTypeOptions Text tName TypeKind kind defineMethods Text tName TypeKind kind [Name] typeParameters ( Just GQLTypeDefinition { Maybe Text gqlTypeDescription :: GQLTypeDefinition -> Maybe Text gqlTypeDescription :: Maybe Text gqlTypeDescription, Map Text Text gqlTypeDescriptions :: GQLTypeDefinition -> Map Text Text gqlTypeDescriptions :: Map Text Text gqlTypeDescriptions, Map Text (Value CONST) gqlTypeDefaultValues :: GQLTypeDefinition -> Map Text (Value CONST) gqlTypeDefaultValues :: Map Text (Value CONST) gqlTypeDefaultValues, [ServerDirectiveUsage] gqlTypeDirectiveUses :: GQLTypeDefinition -> [ServerDirectiveUsage] gqlTypeDirectiveUses :: [ServerDirectiveUsage] gqlTypeDirectiveUses, Kind gqlKind :: GQLTypeDefinition -> Kind gqlKind :: Kind gqlKind } ) = do [Q Dec] options <- Text -> TypeKind -> ServerDec [Q Dec] defineTypeOptions Text tName TypeKind kind forall (f :: * -> *) a. Applicative f => a -> f a pure (Q Dec typeFamilies forall a. a -> [a] -> [a] : [Q Dec] functions forall a. Semigroup a => a -> a -> a <> [Q Dec] options) where functions :: [Q Dec] functions = [(Name, ExpQ)] -> [Q Dec] funDProxy [ ('description, [|gqlTypeDescription|]), ('getDescriptions, [|gqlTypeDescriptions|]), ('defaultValues, [|gqlTypeDefaultValues|]), ('directives, [ServerDirectiveUsage] -> ExpQ renderDirectiveUsages [ServerDirectiveUsage] gqlTypeDirectiveUses) ] typeFamilies :: Q Dec typeFamilies = do Type currentType <- forall con var res. (ToName con, ToName var, Apply res, ToCon con res, ToVar var res) => con -> [var] -> res applyVars Text tName [Name] typeParameters forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ Name -> Type -> Type -> Dec typeInstanceDec ''KIND Type currentType (Name -> Type ConT (Kind -> Name kindName Kind gqlKind)) kindName :: Kind -> Name kindName :: Kind -> Name kindName Kind Scalar = ''SCALAR kindName Kind Type = ''TYPE renderDirectiveUsages :: [ServerDirectiveUsage] -> ExpQ renderDirectiveUsages :: [ServerDirectiveUsage] -> ExpQ renderDirectiveUsages = forall (t :: * -> *) a b. Foldable t => (a -> b -> b) -> b -> t a -> b foldr (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp appE forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp appE [|(<>)|] forall b c a. (b -> c) -> (a -> b) -> a -> c . ServerDirectiveUsage -> ExpQ renderDirectiveUsage) [|mempty|] renderDirectiveUsage :: ServerDirectiveUsage -> ExpQ renderDirectiveUsage :: ServerDirectiveUsage -> ExpQ renderDirectiveUsage (TypeDirectiveUsage TypeValue x) = [|typeDirective $(renderValue x)|] renderDirectiveUsage (FieldDirectiveUsage FieldName field TypeValue x) = [|fieldDirective field $(renderValue x)|] renderDirectiveUsage (EnumDirectiveUsage TypeName enum TypeValue x) = [|enumDirective enum $(renderValue x)|] renderField :: (FieldName, TypeValue) -> Q FieldExp renderField :: (FieldName, TypeValue) -> Q FieldExp renderField (FieldName fName, TypeValue fValue) = do Exp v <- TypeValue -> ExpQ renderValue TypeValue fValue forall (f :: * -> *) a. Applicative f => a -> f a pure (forall a. ToName a => a -> Name toName FieldName fName, Exp v) renderValue :: TypeValue -> ExpQ renderValue :: TypeValue -> ExpQ renderValue (TypeValueObject TypeName name [(FieldName, TypeValue)] xs) = forall (m :: * -> *). Quote m => Name -> [m FieldExp] -> m Exp recConE (forall a. ToName a => a -> Name toName TypeName name) (forall a b. (a -> b) -> [a] -> [b] map (FieldName, TypeValue) -> Q FieldExp renderField [(FieldName, TypeValue)] xs) renderValue (TypeValueNumber Double x) = [|x|] renderValue (TypeValueString Text x) = forall (m :: * -> *). Quote m => Lit -> m Exp litE (String -> Lit stringL (Text -> String T.unpack Text x)) renderValue (TypeValueBool Bool _) = [|x|] renderValue (TypedValueMaybe (Just TypeValue x)) = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp appE (forall (m :: * -> *). Quote m => Name -> m Exp conE 'Just) (TypeValue -> ExpQ renderValue TypeValue x) renderValue (TypedValueMaybe Maybe TypeValue Nothing) = forall (m :: * -> *). Quote m => Name -> m Exp conE 'Nothing renderValue (TypeValueList [TypeValue] xs) = forall (m :: * -> *). Quote m => [m Exp] -> m Exp listE forall a b. (a -> b) -> a -> b $ forall a b. (a -> b) -> [a] -> [b] map TypeValue -> ExpQ renderValue [TypeValue] xs