{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.CodeGen.Server.Internal.AST ( CodeGenConfig (..), ServerDeclaration (..), GQLTypeDefinition (..), CONST, TypeKind (..), TypeName, TypeRef (..), TypeWrapper (..), unpackName, DerivingClass (..), FIELD_TYPE_WRAPPER (..), Kind (..), ServerDirectiveUsage (..), TypeValue (..), InterfaceDefinition (..), GQLDirectiveTypeClass (..), ServerMethod (..), ) where import Data.Morpheus.CodeGen.Internal.AST ( CodeGenType, CodeGenTypeName, DerivingClass (..), FIELD_TYPE_WRAPPER (..), TypeClassInstance (..), TypeValue (..), ) import Data.Morpheus.CodeGen.Printer ( Printer (..), ignore, unpack, (.<>), ) import Data.Morpheus.CodeGen.TH (PrintDec (..), PrintExp (..), ToName (..), apply, m', m_, printTypeSynonym) import Data.Morpheus.Server.Types (DIRECTIVE, SCALAR, TYPE, TypeGuard, enumDirective, fieldDirective, typeDirective) import Data.Morpheus.Types.Internal.AST ( CONST, DirectiveLocation (..), FieldName, TypeKind (..), TypeName, TypeRef (..), TypeWrapper (..), Value, unpackName, ) import Language.Haskell.TH.Lib (appE, varE) import Prettyprinter ( Pretty (..), align, concatWith, indent, line, pretty, (<+>), ) import Relude hiding (Show, optional, print, show) import Prelude (Show (..)) data Kind = Scalar | Type | Directive deriving (Int -> Kind -> ShowS [Kind] -> ShowS Kind -> String (Int -> Kind -> ShowS) -> (Kind -> String) -> ([Kind] -> ShowS) -> Show Kind forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a $cshowsPrec :: Int -> Kind -> ShowS showsPrec :: Int -> Kind -> ShowS $cshow :: Kind -> String show :: Kind -> String $cshowList :: [Kind] -> ShowS showList :: [Kind] -> ShowS Show, Kind -> Kind -> Bool (Kind -> Kind -> Bool) -> (Kind -> Kind -> Bool) -> Eq Kind forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a $c== :: Kind -> Kind -> Bool == :: Kind -> Kind -> Bool $c/= :: Kind -> Kind -> Bool /= :: Kind -> Kind -> Bool Eq) instance Pretty Kind where pretty :: forall ann. Kind -> Doc ann pretty Kind Type = Doc ann "TYPE" pretty Kind Scalar = Doc ann "SCALAR" pretty Kind Directive = Doc ann "DIRECTIVE" instance ToName Kind where toName :: Kind -> Name toName Kind Scalar = ''SCALAR toName Kind Type = ''TYPE toName Kind Directive = ''DIRECTIVE data ServerDirectiveUsage = TypeDirectiveUsage TypeValue | FieldDirectiveUsage FieldName TypeValue | EnumDirectiveUsage TypeName TypeValue deriving (Int -> ServerDirectiveUsage -> ShowS [ServerDirectiveUsage] -> ShowS ServerDirectiveUsage -> String (Int -> ServerDirectiveUsage -> ShowS) -> (ServerDirectiveUsage -> String) -> ([ServerDirectiveUsage] -> ShowS) -> Show ServerDirectiveUsage forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a $cshowsPrec :: Int -> ServerDirectiveUsage -> ShowS showsPrec :: Int -> ServerDirectiveUsage -> ShowS $cshow :: ServerDirectiveUsage -> String show :: ServerDirectiveUsage -> String $cshowList :: [ServerDirectiveUsage] -> ShowS showList :: [ServerDirectiveUsage] -> ShowS Show) instance PrintExp ServerDirectiveUsage where printExp :: ServerDirectiveUsage -> ExpQ printExp (TypeDirectiveUsage TypeValue x) = ExpQ -> ExpQ -> ExpQ forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp appE (Name -> ExpQ forall (m :: * -> *). Quote m => Name -> m Exp varE 'typeDirective) (TypeValue -> ExpQ forall a. PrintExp a => a -> ExpQ printExp TypeValue x) printExp (FieldDirectiveUsage FieldName field TypeValue x) = ExpQ -> ExpQ -> ExpQ forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp appE (ExpQ -> ExpQ -> ExpQ forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp appE (Name -> ExpQ forall (m :: * -> *). Quote m => Name -> m Exp varE 'fieldDirective) [|field|]) (TypeValue -> ExpQ forall a. PrintExp a => a -> ExpQ printExp TypeValue x) printExp (EnumDirectiveUsage TypeName enum TypeValue x) = ExpQ -> ExpQ -> ExpQ forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp appE (ExpQ -> ExpQ -> ExpQ forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp appE (Name -> ExpQ forall (m :: * -> *). Quote m => Name -> m Exp varE 'enumDirective) [|enum|]) (TypeValue -> ExpQ forall a. PrintExp a => a -> ExpQ printExp TypeValue x) instance Pretty ServerDirectiveUsage where pretty :: forall ann. ServerDirectiveUsage -> Doc ann pretty (TypeDirectiveUsage TypeValue value) = Doc ann "typeDirective" Doc ann -> Doc ann -> Doc ann forall ann. Doc ann -> Doc ann -> Doc ann <+> TypeValue -> Doc ann forall ann. TypeValue -> Doc ann forall a ann. Pretty a => a -> Doc ann pretty TypeValue value pretty (FieldDirectiveUsage FieldName place TypeValue value) = Doc ann "fieldDirective" Doc ann -> Doc ann -> Doc ann forall ann. Doc ann -> Doc ann -> Doc ann <+> String -> Doc ann forall ann. String -> Doc ann forall a ann. Pretty a => a -> Doc ann pretty (FieldName -> String forall a. Show a => a -> String show FieldName place :: String) Doc ann -> Doc ann -> Doc ann forall ann. Doc ann -> Doc ann -> Doc ann <+> TypeValue -> Doc ann forall ann. TypeValue -> Doc ann forall a ann. Pretty a => a -> Doc ann pretty TypeValue value pretty (EnumDirectiveUsage TypeName place TypeValue value) = Doc ann "enumDirective" Doc ann -> Doc ann -> Doc ann forall ann. Doc ann -> Doc ann -> Doc ann <+> String -> Doc ann forall ann. String -> Doc ann forall a ann. Pretty a => a -> Doc ann pretty (TypeName -> String forall a. Show a => a -> String show TypeName place :: String) Doc ann -> Doc ann -> Doc ann forall ann. Doc ann -> Doc ann -> Doc ann <+> TypeValue -> Doc ann forall ann. TypeValue -> Doc ann forall a ann. Pretty a => a -> Doc ann pretty TypeValue value data GQLTypeDefinition = GQLTypeDefinition { GQLTypeDefinition -> CodeGenTypeName gqlTarget :: CodeGenTypeName, GQLTypeDefinition -> Kind gqlKind :: Kind, GQLTypeDefinition -> [ServerDirectiveUsage] gqlTypeDirectiveUses :: [ServerDirectiveUsage] } deriving (Int -> GQLTypeDefinition -> ShowS [GQLTypeDefinition] -> ShowS GQLTypeDefinition -> String (Int -> GQLTypeDefinition -> ShowS) -> (GQLTypeDefinition -> String) -> ([GQLTypeDefinition] -> ShowS) -> Show GQLTypeDefinition forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a $cshowsPrec :: Int -> GQLTypeDefinition -> ShowS showsPrec :: Int -> GQLTypeDefinition -> ShowS $cshow :: GQLTypeDefinition -> String show :: GQLTypeDefinition -> String $cshowList :: [GQLTypeDefinition] -> ShowS showList :: [GQLTypeDefinition] -> ShowS Show) data InterfaceDefinition = InterfaceDefinition { InterfaceDefinition -> TypeName aliasName :: TypeName, InterfaceDefinition -> TypeName interfaceName :: TypeName, InterfaceDefinition -> TypeName unionName :: TypeName } deriving (Int -> InterfaceDefinition -> ShowS [InterfaceDefinition] -> ShowS InterfaceDefinition -> String (Int -> InterfaceDefinition -> ShowS) -> (InterfaceDefinition -> String) -> ([InterfaceDefinition] -> ShowS) -> Show InterfaceDefinition forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a $cshowsPrec :: Int -> InterfaceDefinition -> ShowS showsPrec :: Int -> InterfaceDefinition -> ShowS $cshow :: InterfaceDefinition -> String show :: InterfaceDefinition -> String $cshowList :: [InterfaceDefinition] -> ShowS showList :: [InterfaceDefinition] -> ShowS Show) instance PrintDec InterfaceDefinition where printDec :: InterfaceDefinition -> Q Dec printDec InterfaceDefinition {TypeName aliasName :: InterfaceDefinition -> TypeName interfaceName :: InterfaceDefinition -> TypeName unionName :: InterfaceDefinition -> TypeName aliasName :: TypeName interfaceName :: TypeName unionName :: TypeName ..} = Dec -> Q Dec forall a. a -> Q a forall (f :: * -> *) a. Applicative f => a -> f a pure (Dec -> Q Dec) -> Dec -> Q Dec forall a b. (a -> b) -> a -> b $ TypeName -> [Name] -> Type -> Dec forall a. ToName a => a -> [Name] -> Type -> Dec printTypeSynonym TypeName aliasName [Name m_] ( Name -> [Type] -> Type forall a i. (Apply a, ToCon i a) => i -> [a] -> a forall i. ToCon i Type => i -> [Type] -> Type apply ''TypeGuard [TypeName -> [Type] -> Type forall a i. (Apply a, ToCon i a) => i -> [a] -> a forall i. ToCon i Type => i -> [Type] -> Type apply TypeName interfaceName [Type m'], TypeName -> [Type] -> Type forall a i. (Apply a, ToCon i a) => i -> [a] -> a forall i. ToCon i Type => i -> [Type] -> Type apply TypeName unionName [Type m']] ) data GQLDirectiveTypeClass = GQLDirectiveTypeClass { GQLDirectiveTypeClass -> CodeGenTypeName directiveTypeName :: CodeGenTypeName, GQLDirectiveTypeClass -> [DirectiveLocation] directiveLocations :: [DirectiveLocation] } deriving (Int -> GQLDirectiveTypeClass -> ShowS [GQLDirectiveTypeClass] -> ShowS GQLDirectiveTypeClass -> String (Int -> GQLDirectiveTypeClass -> ShowS) -> (GQLDirectiveTypeClass -> String) -> ([GQLDirectiveTypeClass] -> ShowS) -> Show GQLDirectiveTypeClass forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a $cshowsPrec :: Int -> GQLDirectiveTypeClass -> ShowS showsPrec :: Int -> GQLDirectiveTypeClass -> ShowS $cshow :: GQLDirectiveTypeClass -> String show :: GQLDirectiveTypeClass -> String $cshowList :: [GQLDirectiveTypeClass] -> ShowS showList :: [GQLDirectiveTypeClass] -> ShowS Show) data ServerDeclaration = GQLTypeInstance Kind (TypeClassInstance ServerMethod) | GQLDirectiveInstance (TypeClassInstance ServerMethod) | DataType CodeGenType | ScalarType {ServerDeclaration -> Text scalarTypeName :: Text} | InterfaceType InterfaceDefinition deriving (Int -> ServerDeclaration -> ShowS [ServerDeclaration] -> ShowS ServerDeclaration -> String (Int -> ServerDeclaration -> ShowS) -> (ServerDeclaration -> String) -> ([ServerDeclaration] -> ShowS) -> Show ServerDeclaration forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a $cshowsPrec :: Int -> ServerDeclaration -> ShowS showsPrec :: Int -> ServerDeclaration -> ShowS $cshow :: ServerDeclaration -> String show :: ServerDeclaration -> String $cshowList :: [ServerDeclaration] -> ShowS showList :: [ServerDeclaration] -> ShowS Show) instance Pretty ServerDeclaration where pretty :: forall ann. ServerDeclaration -> Doc ann pretty (InterfaceType InterfaceDefinition {TypeName aliasName :: InterfaceDefinition -> TypeName interfaceName :: InterfaceDefinition -> TypeName unionName :: InterfaceDefinition -> TypeName aliasName :: TypeName interfaceName :: TypeName unionName :: TypeName ..}) = Doc ann "type" Doc ann -> Doc ann -> Doc ann forall ann. Doc ann -> Doc ann -> Doc ann <+> HSDoc ann -> Doc ann forall n. HSDoc n -> Doc n ignore (TypeName -> HSDoc ann forall a ann. Printer a => a -> HSDoc ann forall ann. TypeName -> HSDoc ann print TypeName aliasName) Doc ann -> Doc ann -> Doc ann forall ann. Doc ann -> Doc ann -> Doc ann <+> Doc ann "m" Doc ann -> Doc ann -> Doc ann forall ann. Doc ann -> Doc ann -> Doc ann <+> Doc ann "=" Doc ann -> Doc ann -> Doc ann forall ann. Doc ann -> Doc ann -> Doc ann <+> Doc ann "TypeGuard" Doc ann -> Doc ann -> Doc ann forall ann. Doc ann -> Doc ann -> Doc ann <+> HSDoc ann -> Doc ann forall n. HSDoc n -> Doc n unpack (TypeName -> HSDoc ann forall a ann. Printer a => a -> HSDoc ann forall ann. TypeName -> HSDoc ann print TypeName interfaceName HSDoc ann -> HSDoc ann -> HSDoc ann forall n. HSDoc n -> HSDoc n -> HSDoc n .<> HSDoc ann "m") Doc ann -> Doc ann -> Doc ann forall ann. Doc ann -> Doc ann -> Doc ann <+> HSDoc ann -> Doc ann forall n. HSDoc n -> Doc n unpack (TypeName -> HSDoc ann forall a ann. Printer a => a -> HSDoc ann forall ann. TypeName -> HSDoc ann print TypeName unionName HSDoc ann -> HSDoc ann -> HSDoc ann forall n. HSDoc n -> HSDoc n -> HSDoc n .<> HSDoc ann "m") Doc ann -> Doc ann -> Doc ann forall a. Semigroup a => a -> a -> a <> Doc ann forall ann. Doc ann line pretty ScalarType {} = Doc ann "" pretty (DataType CodeGenType cgType) = CodeGenType -> Doc ann forall ann. CodeGenType -> Doc ann forall a ann. Pretty a => a -> Doc ann pretty CodeGenType cgType pretty (GQLTypeInstance Kind kind TypeClassInstance ServerMethod gql) | Kind kind Kind -> Kind -> Bool forall a. Eq a => a -> a -> Bool == Kind Scalar = Doc ann "" | Bool otherwise = TypeClassInstance ServerMethod -> Doc ann forall ann. TypeClassInstance ServerMethod -> Doc ann forall a ann. Pretty a => a -> Doc ann pretty TypeClassInstance ServerMethod gql pretty (GQLDirectiveInstance TypeClassInstance ServerMethod _) = Doc ann "" newtype CodeGenConfig = CodeGenConfig {CodeGenConfig -> Bool namespace :: Bool} data ServerMethod = ServerMethodDefaultValues (Map Text (Value CONST)) | ServerMethodDirectives [ServerDirectiveUsage] deriving (Int -> ServerMethod -> ShowS [ServerMethod] -> ShowS ServerMethod -> String (Int -> ServerMethod -> ShowS) -> (ServerMethod -> String) -> ([ServerMethod] -> ShowS) -> Show ServerMethod forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a $cshowsPrec :: Int -> ServerMethod -> ShowS showsPrec :: Int -> ServerMethod -> ShowS $cshow :: ServerMethod -> String show :: ServerMethod -> String $cshowList :: [ServerMethod] -> ShowS showList :: [ServerMethod] -> ShowS Show) instance Pretty ServerMethod where pretty :: forall ann. ServerMethod -> Doc ann pretty (ServerMethodDefaultValues Map Text (Value CONST) x) = String -> Doc ann forall ann. String -> Doc ann forall a ann. Pretty a => a -> Doc ann pretty (Map Text (Value CONST) -> String forall a. Show a => a -> String show Map Text (Value CONST) x) pretty (ServerMethodDirectives [ServerDirectiveUsage] dirs) = Doc ann forall ann. Doc ann line Doc ann -> Doc ann -> Doc ann forall a. Semigroup a => a -> a -> a <> Int -> Doc ann -> Doc ann forall ann. Int -> Doc ann -> Doc ann indent Int 2 (Doc ann -> Doc ann forall ann. Doc ann -> Doc ann align (Doc ann -> Doc ann) -> Doc ann -> Doc ann forall a b. (a -> b) -> a -> b $ (Doc ann -> Doc ann -> Doc ann) -> [Doc ann] -> Doc ann forall (t :: * -> *) ann. Foldable t => (Doc ann -> Doc ann -> Doc ann) -> t (Doc ann) -> Doc ann concatWith (\Doc ann x Doc ann y -> Doc ann x Doc ann -> Doc ann -> Doc ann forall a. Semigroup a => a -> a -> a <> Doc ann "\n <>" Doc ann -> Doc ann -> Doc ann forall ann. Doc ann -> Doc ann -> Doc ann <+> Doc ann y) ((ServerDirectiveUsage -> Doc ann) -> [ServerDirectiveUsage] -> [Doc ann] forall a b. (a -> b) -> [a] -> [b] map ServerDirectiveUsage -> Doc ann forall a ann. Pretty a => a -> Doc ann forall ann. ServerDirectiveUsage -> Doc ann pretty [ServerDirectiveUsage] dirs)) instance PrintExp ServerMethod where printExp :: ServerMethod -> ExpQ printExp (ServerMethodDefaultValues Map Text (Value CONST) values) = [|values|] printExp (ServerMethodDirectives [ServerDirectiveUsage] dirs) = (ServerDirectiveUsage -> ExpQ -> ExpQ) -> ExpQ -> [ServerDirectiveUsage] -> ExpQ forall a b. (a -> b -> b) -> b -> [a] -> b forall (t :: * -> *) a b. Foldable t => (a -> b -> b) -> b -> t a -> b foldr (ExpQ -> ExpQ -> ExpQ forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp appE (ExpQ -> ExpQ -> ExpQ) -> (ServerDirectiveUsage -> ExpQ) -> ServerDirectiveUsage -> ExpQ -> ExpQ forall b c a. (b -> c) -> (a -> b) -> a -> c . ExpQ -> ExpQ -> ExpQ forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp appE [|(<>)|] (ExpQ -> ExpQ) -> (ServerDirectiveUsage -> ExpQ) -> ServerDirectiveUsage -> ExpQ forall b c a. (b -> c) -> (a -> b) -> a -> c . ServerDirectiveUsage -> ExpQ forall a. PrintExp a => a -> ExpQ printExp) [|mempty|] [ServerDirectiveUsage] dirs