{-# 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],
GQLTypeDefinition -> Map Text (Value CONST)
gqlTypeDefaultValues :: Map Text (Value CONST)
}
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 {Text
scalarTypeName :: Text
scalarTypeName :: ServerDeclaration -> Text
..} = 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 Text
scalarTypeName) forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"= Int"
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
"TODO: not supported"
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