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