{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.CodeGen.Server.Printing.TH ( compileDocument, gqlDocument, ) where import qualified Data.ByteString.Lazy.Char8 as LB import Data.Morpheus.CodeGen.Internal.AST (CodeGenTypeName (..)) import Data.Morpheus.CodeGen.Server.Internal.AST ( CodeGenConfig (..), GQLDirectiveTypeClass (..), GQLTypeDefinition (..), InterfaceDefinition (..), ServerDeclaration (..), ServerDirectiveUsage, TypeKind, ) import Data.Morpheus.CodeGen.Server.Interpreting.Transform ( parseServerTypeDefinitions, ) import Data.Morpheus.CodeGen.TH ( PrintExp (..), PrintType (..), ToName (..), apply, m', m_, printDec, printTypeClass, printTypeSynonym, toCon, _', ) import Data.Morpheus.Server.Types ( GQLDirective (..), GQLType (..), TypeGuard (..), dropNamespaceOptions, ) import Data.Morpheus.Types.Internal.AST (DirectiveLocation) import Language.Haskell.TH import Language.Haskell.TH.Quote (QuasiQuoter (..)) import Relude hiding (ByteString, Type) gqlDocument :: QuasiQuoter gqlDocument :: QuasiQuoter gqlDocument = CodeGenConfig -> QuasiQuoter mkQuasiQuoter CodeGenConfig {namespace :: Bool namespace = Bool False} mkQuasiQuoter :: CodeGenConfig -> QuasiQuoter mkQuasiQuoter :: CodeGenConfig -> QuasiQuoter mkQuasiQuoter CodeGenConfig ctx = QuasiQuoter { quoteExp :: String -> Q Exp quoteExp = forall {a}. Text -> a notHandled Text "Expressions", quotePat :: String -> Q Pat quotePat = forall {a}. Text -> a notHandled Text "Patterns", quoteType :: String -> Q Type quoteType = forall {a}. Text -> a notHandled Text "Types", quoteDec :: String -> Q [Dec] quoteDec = CodeGenConfig -> ByteString -> Q [Dec] compileDocument CodeGenConfig ctx forall b c a. (b -> c) -> (a -> b) -> a -> c . String -> ByteString LB.pack } where notHandled :: Text -> a notHandled Text things = forall a t. (HasCallStack, IsText t) => t -> a error forall a b. (a -> b) -> a -> b $ Text things forall a. Semigroup a => a -> a -> a <> Text " are not supported by the GraphQL QuasiQuoter" compileDocument :: CodeGenConfig -> LB.ByteString -> Q [Dec] compileDocument :: CodeGenConfig -> ByteString -> Q [Dec] compileDocument CodeGenConfig ctx = forall (m :: * -> *). CodeGenMonad m => CodeGenConfig -> ByteString -> m [ServerDeclaration] parseServerTypeDefinitions CodeGenConfig ctx forall (m :: * -> *) a b c. Monad m => (a -> m b) -> (b -> m c) -> a -> m c >=> forall a. PrintDecQ a => a -> Q [Dec] printDecQ class PrintDecQ a where printDecQ :: a -> Q [Dec] instance PrintDecQ a => PrintDecQ [a] where printDecQ :: [a] -> Q [Dec] printDecQ = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a] concat forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse forall a. PrintDecQ a => a -> Q [Dec] printDecQ instance PrintDecQ InterfaceDefinition where printDecQ :: InterfaceDefinition -> Q [Dec] printDecQ InterfaceDefinition {TypeName unionName :: InterfaceDefinition -> TypeName interfaceName :: InterfaceDefinition -> TypeName aliasName :: InterfaceDefinition -> TypeName unionName :: TypeName interfaceName :: TypeName aliasName :: TypeName ..} = forall (f :: * -> *) a. Applicative f => a -> f a pure [forall a. ToName a => a -> [Name] -> Type -> Dec printTypeSynonym TypeName aliasName [Name m_] (forall a i. (Apply a, ToCon i a) => i -> [a] -> a apply ''TypeGuard [forall a i. (Apply a, ToCon i a) => i -> [a] -> a apply TypeName interfaceName [Type m'], forall a i. (Apply a, ToCon i a) => i -> [a] -> a apply TypeName unionName [Type m']])] instance PrintDecQ GQLTypeDefinition where printDecQ :: GQLTypeDefinition -> Q [Dec] printDecQ GQLTypeDefinition {[ServerDirectiveUsage] Maybe (TypeKind, Text) Map Text (Value CONST) CodeGenTypeName Kind dropNamespace :: GQLTypeDefinition -> Maybe (TypeKind, Text) gqlTypeDefaultValues :: GQLTypeDefinition -> Map Text (Value CONST) gqlTypeDirectiveUses :: GQLTypeDefinition -> [ServerDirectiveUsage] gqlKind :: GQLTypeDefinition -> Kind gqlTarget :: GQLTypeDefinition -> CodeGenTypeName dropNamespace :: Maybe (TypeKind, Text) gqlTypeDefaultValues :: Map Text (Value CONST) gqlTypeDirectiveUses :: [ServerDirectiveUsage] gqlKind :: Kind gqlTarget :: CodeGenTypeName ..} = do let params :: [Name] params = forall a b. (a -> b) -> [a] -> [b] map forall a. ToName a => a -> Name toName (CodeGenTypeName -> [Text] typeParameters CodeGenTypeName gqlTarget) [(Name, Type)] associatedTypes <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (forall (f :: * -> *) a. Applicative f => a -> f a pure forall b c a. (b -> c) -> (a -> b) -> a -> c . (''KIND,)) (forall a. PrintType a => a -> Q Type printType Kind gqlKind) forall (f :: * -> *) a. Applicative f => a -> f a pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [(Name, Name)] -> Name -> Q Type -> [(Name, Type)] -> [(Name, [Q Pat], Q Exp)] -> Q Dec printTypeClass (forall a b. (a -> b) -> [a] -> [b] map (''Typeable,) [Name] params) ''GQLType (forall a. PrintType a => a -> Q Type printType CodeGenTypeName gqlTarget) [(Name, Type)] associatedTypes [(Name, [Q Pat], Q Exp)] methods where methods :: [(Name, [Q Pat], Q Exp)] methods = [ ('defaultValues, [Q Pat _'], [|gqlTypeDefaultValues|]), ('directives, [Q Pat _'], [ServerDirectiveUsage] -> Q Exp printDirectiveUsages [ServerDirectiveUsage] gqlTypeDirectiveUses) ] forall a. Semigroup a => a -> a -> a <> forall a b. (a -> b) -> [a] -> [b] map (TypeKind, Text) -> (Name, [Q Pat], Q Exp) printTypeOptions (forall a. Maybe a -> [a] maybeToList Maybe (TypeKind, Text) dropNamespace) instance PrintDecQ ServerDeclaration where printDecQ :: ServerDeclaration -> Q [Dec] printDecQ (InterfaceType InterfaceDefinition interface) = forall a. PrintDecQ a => a -> Q [Dec] printDecQ InterfaceDefinition interface printDecQ ScalarType {} = forall (f :: * -> *) a. Applicative f => a -> f a pure [] printDecQ (DataType CodeGenType dataType) = forall (f :: * -> *) a. Applicative f => a -> f a pure [forall a. PrintDec a => a -> Dec printDec CodeGenType dataType] printDecQ (GQLTypeInstance GQLTypeDefinition gql) = forall a. PrintDecQ a => a -> Q [Dec] printDecQ GQLTypeDefinition gql printDecQ (GQLDirectiveInstance GQLDirectiveTypeClass dir) = forall a. PrintDecQ a => a -> Q [Dec] printDecQ GQLDirectiveTypeClass dir instance PrintDecQ GQLDirectiveTypeClass where printDecQ :: GQLDirectiveTypeClass -> Q [Dec] printDecQ GQLDirectiveTypeClass {[DirectiveLocation] CodeGenTypeName directiveLocations :: GQLDirectiveTypeClass -> [DirectiveLocation] directiveTypeName :: GQLDirectiveTypeClass -> CodeGenTypeName directiveLocations :: [DirectiveLocation] directiveTypeName :: CodeGenTypeName ..} = forall (f :: * -> *) a. Applicative f => a -> f a pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [(Name, Name)] -> Name -> Q Type -> [(Name, Type)] -> [(Name, [Q Pat], Q Exp)] -> Q Dec printTypeClass [] ''GQLDirective (forall a b. ToCon a b => a -> b toCon CodeGenTypeName directiveTypeName) [(''DIRECTIVE_LOCATIONS, [DirectiveLocation] -> Type promotedList [DirectiveLocation] directiveLocations)] [] 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 . forall a. ToName a => a -> Name toName) Type PromotedNilT printTypeOptions :: (TypeKind, Text) -> (Name, [PatQ], ExpQ) printTypeOptions :: (TypeKind, Text) -> (Name, [Q Pat], Q Exp) printTypeOptions (TypeKind kind, Text tName) = ('typeOptions, [Q Pat _'], [|dropNamespaceOptions kind tName|]) printDirectiveUsages :: [ServerDirectiveUsage] -> ExpQ printDirectiveUsages :: [ServerDirectiveUsage] -> Q Exp printDirectiveUsages = 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 . forall a. PrintExp a => a -> Q Exp printExp) [|mempty|]