{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.Server.TH.Declare.GQLType ( deriveGQLType, ) where import Data.Char (toLower) import Data.Morpheus.CodeGen.Internal.AST ( CodeGenConfig (..), GQLTypeDefinition (..), Kind (..), ServerTypeDefinition (..), ) import Data.Morpheus.CodeGen.Internal.TH ( apply, applyVars, typeInstanceDec, ) import Data.Morpheus.Kind ( SCALAR, TYPE, ) import Data.Morpheus.Server.TH.Utils ( ServerDec, funDProxy, mkTypeableConstraints, renderTypeVars, ) import Data.Morpheus.Types ( GQLType (..), GQLTypeOptions (..), ) import Data.Morpheus.Types.Internal.AST ( TypeKind (..), ) import qualified Data.Text as T import Language.Haskell.TH ( Dec, DecQ, Name, Q, Type (ConT), instanceD, ) import Relude dropPrefix :: Text -> String -> String dropPrefix :: Text -> String -> String dropPrefix Text name = Int -> String -> String forall a. Int -> [a] -> [a] drop (Text -> Int T.length Text name) stripConstructorNamespace :: Text -> String -> String stripConstructorNamespace :: Text -> String -> String stripConstructorNamespace = Text -> String -> String dropPrefix stripFieldNamespace :: Text -> String -> String stripFieldNamespace :: Text -> String -> String stripFieldNamespace Text prefix = String -> String __uncapitalize (String -> String) -> (String -> String) -> String -> String forall b c a. (b -> c) -> (a -> b) -> a -> c . Text -> String -> String dropPrefix Text prefix where __uncapitalize :: String -> String __uncapitalize [] = [] __uncapitalize (Char x : String xs) = Char -> Char toLower Char x Char -> String -> String forall a. a -> [a] -> [a] : String xs dropNamespaceOptions :: TypeKind -> Text -> GQLTypeOptions -> GQLTypeOptions dropNamespaceOptions :: TypeKind -> Text -> GQLTypeOptions -> GQLTypeOptions dropNamespaceOptions TypeKind KindInterface Text tName GQLTypeOptions opt = GQLTypeOptions opt { typeNameModifier :: Bool -> String -> String typeNameModifier = (String -> String) -> Bool -> String -> String forall a b. a -> b -> a const (Text -> String -> String stripConstructorNamespace Text "Interface"), fieldLabelModifier :: String -> String fieldLabelModifier = Text -> String -> String stripFieldNamespace Text tName } dropNamespaceOptions TypeKind KindEnum Text tName GQLTypeOptions opt = GQLTypeOptions opt {constructorTagModifier :: String -> String constructorTagModifier = Text -> String -> String stripConstructorNamespace Text tName} dropNamespaceOptions TypeKind _ Text tName GQLTypeOptions opt = GQLTypeOptions opt {fieldLabelModifier :: String -> String fieldLabelModifier = Text -> String -> String stripFieldNamespace Text tName} deriveGQLType :: ServerTypeDefinition -> ServerDec [Dec] deriveGQLType :: ServerTypeDefinition -> ServerDec [Dec] deriveGQLType ServerInterfaceDefinition {} = [Dec] -> ServerDec [Dec] forall (f :: * -> *) a. Applicative f => a -> f a pure [] 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 gql :: ServerTypeDefinition -> Maybe GQLTypeDefinition gql :: Maybe GQLTypeDefinition gql } = do let typeVars :: [Name] typeVars = [Text] -> [Name] renderTypeVars [Text] typeParameters let constrains :: CxtQ constrains = [Name] -> CxtQ mkTypeableConstraints [Name] typeVars let typeSignature :: TypeQ typeSignature = Name -> [TypeQ] -> TypeQ forall a i. (Apply a, ToCon i a) => i -> [a] -> a apply ''GQLType [Text -> [Name] -> TypeQ 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 gql Dec gqlTypeDeclaration <- Q Dec -> ReaderT CodeGenConfig Q Dec forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift (CxtQ -> TypeQ -> [Q Dec] -> Q Dec instanceD CxtQ constrains TypeQ typeSignature [Q Dec] methods) [Dec] -> ServerDec [Dec] forall (f :: * -> *) a. Applicative f => a -> f a pure [Dec gqlTypeDeclaration] 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} <- ReaderT CodeGenConfig Q CodeGenConfig forall r (m :: * -> *). MonadReader r m => m r ask [Q Dec] -> ServerDec [Q Dec] forall (f :: * -> *) a. Applicative f => a -> f a pure ([Q Dec] -> ServerDec [Q Dec]) -> [Q Dec] -> ServerDec [Q Dec] 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 (Directives CONST) gqlTypeDirectives :: GQLTypeDefinition -> Map Text (Directives CONST) gqlTypeDirectives :: Map Text (Directives CONST) gqlTypeDirectives, Map Text (Value CONST) gqlTypeDefaultValues :: GQLTypeDefinition -> Map Text (Value CONST) gqlTypeDefaultValues :: Map Text (Value CONST) gqlTypeDefaultValues, Kind gqlKind :: GQLTypeDefinition -> Kind gqlKind :: Kind gqlKind } ) = do [Q Dec] options <- Text -> TypeKind -> ServerDec [Q Dec] defineTypeOptions Text tName TypeKind kind [Q Dec] -> ServerDec [Q Dec] forall (f :: * -> *) a. Applicative f => a -> f a pure (Q Dec typeFamilies Q Dec -> [Q Dec] -> [Q Dec] forall a. a -> [a] -> [a] : [Q Dec] functions [Q Dec] -> [Q Dec] -> [Q Dec] forall a. Semigroup a => a -> a -> a <> [Q Dec] options) where functions :: [Q Dec] functions = [(Name, ExpQ)] -> [Q Dec] funDProxy [ ('description, [|gqlTypeDescription|]), ('getDescriptions, [|gqlTypeDescriptions|]), ('getDirectives, [|gqlTypeDirectives|]), ('defaultValues, [|gqlTypeDefaultValues|]) ] typeFamilies :: Q Dec typeFamilies = do Type currentType <- Text -> [Name] -> TypeQ forall con var res. (ToName con, ToName var, Apply res, ToCon con res, ToVar var res) => con -> [var] -> res applyVars Text tName [Name] typeParameters Dec -> Q Dec forall (f :: * -> *) a. Applicative f => a -> f a pure (Dec -> Q Dec) -> Dec -> Q Dec 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