{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Data.Morpheus.CodeGen.Server.Printing.Document
( renderDocument,
)
where
import Data.ByteString.Lazy.Char8 (ByteString)
import Data.Morpheus.CodeGen.Internal.AST (CodeGenTypeName (..))
import Data.Morpheus.CodeGen.Printer
( Printer (..),
ignore,
optional,
renderExtension,
renderImport,
unpack,
)
import Data.Morpheus.CodeGen.Server.Internal.AST
( GQLTypeDefinition (..),
Kind (..),
ModuleDefinition (..),
ServerDeclaration (..),
ServerDirectiveUsage (..),
TypeKind,
)
import Data.Text
( pack,
)
import qualified Data.Text.Lazy as LT
( fromStrict,
)
import Data.Text.Lazy.Encoding (encodeUtf8)
import Prettyprinter
( Doc,
align,
indent,
line,
pretty,
punctuate,
tupled,
vsep,
(<+>),
)
import Relude hiding (ByteString, encodeUtf8, optional, print)
renderDocument :: String -> [ServerDeclaration] -> ByteString
renderDocument :: String -> [ServerDeclaration] -> ByteString
renderDocument String
moduleName [ServerDeclaration]
types =
Text -> ByteString
encodeUtf8 forall a b. (a -> b) -> a -> b
$
Text -> Text
LT.fromStrict forall a b. (a -> b) -> a -> b
$
String -> Text
pack forall a b. (a -> b) -> a -> b
$
forall b a. (Show a, IsString b) => a -> b
show forall a b. (a -> b) -> a -> b
$
forall n. ModuleDefinition -> Doc n
renderModuleDefinition
ModuleDefinition
{ moduleName :: Text
moduleName = String -> Text
pack String
moduleName,
imports :: [(Text, [Text])]
imports =
[ (Text
"Data.Data", [Text
"Typeable"]),
(Text
"Data.Morpheus.Kind", [Text
"TYPE"]),
(Text
"Data.Morpheus.Types", [Text
"*"]),
(Text
"Data.Morpheus", []),
(Text
"Data.Text", [Text
"Text"]),
(Text
"GHC.Generics", [Text
"Generic"])
],
extensions :: [Text]
extensions =
[ Text
"DeriveGeneric",
Text
"TypeFamilies",
Text
"OverloadedStrings",
Text
"DataKinds",
Text
"DuplicateRecordFields"
],
[ServerDeclaration]
types :: [ServerDeclaration]
types :: [ServerDeclaration]
types
}
renderModuleDefinition :: ModuleDefinition -> Doc n
renderModuleDefinition :: forall n. ModuleDefinition -> Doc n
renderModuleDefinition
ModuleDefinition
{ [Text]
extensions :: [Text]
extensions :: ModuleDefinition -> [Text]
extensions,
Text
moduleName :: Text
moduleName :: ModuleDefinition -> Text
moduleName,
[(Text, [Text])]
imports :: [(Text, [Text])]
imports :: ModuleDefinition -> [(Text, [Text])]
imports,
[ServerDeclaration]
types :: [ServerDeclaration]
types :: ModuleDefinition -> [ServerDeclaration]
types
} =
forall ann. [Doc ann] -> Doc ann
vsep (forall a b. (a -> b) -> [a] -> [b]
map forall ann. Text -> Doc ann
renderExtension [Text]
extensions)
forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
line
forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
line
forall a. Semigroup a => a -> a -> a
<> Doc n
"module"
forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Text
moduleName
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc n
"where"
forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
line
forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
line
forall a. Semigroup a => a -> a -> a
<> forall ann. [Doc ann] -> Doc ann
vsep (forall a b. (a -> b) -> [a] -> [b]
map forall ann. (Text, [Text]) -> Doc ann
renderImport [(Text, [Text])]
imports)
forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
line
forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
line
forall a. Semigroup a => a -> a -> a
<> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a t. (HasCallStack, IsText t) => t -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. (Show a, IsString b) => a -> b
show) forall a. a -> a
id (forall ann. [ServerDeclaration] -> Either Text (Doc ann)
renderTypes [ServerDeclaration]
types)
type Result = Either Text
renderTypes :: [ServerDeclaration] -> Either Text (Doc ann)
renderTypes :: forall ann. [ServerDeclaration] -> Either Text (Doc ann)
renderTypes = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall ann. [Doc ann] -> Doc ann
vsep 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 ann. RenderType a => a -> Result (Doc ann)
render
class RenderType a where
render :: a -> Result (Doc ann)
instance RenderType ServerDeclaration where
render :: forall ann. ServerDeclaration -> Result (Doc ann)
render InterfaceType {} = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"not supported"
render ScalarType {Text
scalarTypeName :: ServerDeclaration -> Text
scalarTypeName :: Text
scalarTypeName} =
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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"
render (DataType CodeGenType
cgType) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a ann. Pretty a => a -> Doc ann
pretty CodeGenType
cgType)
render (GQLTypeInstance GQLTypeDefinition
gqlType) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall ann. GQLTypeDefinition -> Doc ann
renderGQLType GQLTypeDefinition
gqlType
render (GQLDirectiveInstance GQLDirectiveTypeClass
_) = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"not supported"
renderTypeableConstraints :: [Text] -> Doc n
renderTypeableConstraints :: forall n. [Text] -> Doc n
renderTypeableConstraints [Text]
xs = forall ann. [Doc ann] -> Doc ann
tupled (forall a b. (a -> b) -> [a] -> [b]
map ((Doc n
"Typeable" forall ann. Doc ann -> Doc ann -> Doc ann
<+>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
pretty) [Text]
xs) forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc n
"=>"
defineTypeOptions :: Maybe (TypeKind, Text) -> [Doc n]
defineTypeOptions :: forall n. Maybe (TypeKind, Text) -> [Doc n]
defineTypeOptions (Just (TypeKind
kind, Text
tName)) = [Doc n
"typeOptions _ = dropNamespaceOptions" forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc n
"(" forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty (forall b a. (Show a, IsString b) => a -> b
show TypeKind
kind :: String) forall a. Semigroup a => a -> a -> a
<> Doc n
")" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (forall b a. (Show a, IsString b) => a -> b
show Text
tName :: String)]
defineTypeOptions Maybe (TypeKind, Text)
_ = []
renderGQLType :: GQLTypeDefinition -> Doc ann
renderGQLType :: forall ann. GQLTypeDefinition -> Doc ann
renderGQLType gql :: GQLTypeDefinition
gql@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
..}
| Kind
gqlKind forall a. Eq a => a -> a -> Bool
== Kind
Scalar = Doc ann
""
| Bool
otherwise =
Doc ann
"instance"
forall a. Semigroup a => a -> a -> a
<> forall a n. ([a] -> Doc n) -> [a] -> Doc n
optional forall n. [Text] -> Doc n
renderTypeableConstraints (CodeGenTypeName -> [Text]
typeParameters CodeGenTypeName
gqlTarget)
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"GQLType"
forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann
typeHead
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"where"
forall a. Semigroup a => a -> a -> a
<> 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
vsep (forall n. Doc n -> GQLTypeDefinition -> [Doc n]
renderMethods forall ann. Doc ann
typeHead GQLTypeDefinition
gql forall a. Semigroup a => a -> a -> a
<> forall n. Maybe (TypeKind, Text) -> [Doc n]
defineTypeOptions Maybe (TypeKind, Text)
dropNamespace))
where
typeHead :: Doc n
typeHead = forall n. HSDoc n -> Doc n
unpack (forall a ann. Printer a => a -> HSDoc ann
print CodeGenTypeName
gqlTarget)
renderMethods :: Doc n -> GQLTypeDefinition -> [Doc n]
renderMethods :: forall n. Doc n -> GQLTypeDefinition -> [Doc n]
renderMethods Doc n
typeHead GQLTypeDefinition {[ServerDirectiveUsage]
Maybe (TypeKind, Text)
Map Text (Value CONST)
CodeGenTypeName
Kind
dropNamespace :: Maybe (TypeKind, Text)
gqlTypeDefaultValues :: Map Text (Value CONST)
gqlTypeDirectiveUses :: [ServerDirectiveUsage]
gqlKind :: Kind
gqlTarget :: CodeGenTypeName
dropNamespace :: GQLTypeDefinition -> Maybe (TypeKind, Text)
gqlTypeDefaultValues :: GQLTypeDefinition -> Map Text (Value CONST)
gqlTypeDirectiveUses :: GQLTypeDefinition -> [ServerDirectiveUsage]
gqlKind :: GQLTypeDefinition -> Kind
gqlTarget :: GQLTypeDefinition -> CodeGenTypeName
..} =
[Doc n
"type KIND" forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc n
typeHead forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc n
"=" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Kind
gqlKind]
forall a. Semigroup a => a -> a -> a
<> [Doc n
"directives _=" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall n. [ServerDirectiveUsage] -> Doc n
renderDirectiveUsages [ServerDirectiveUsage]
gqlTypeDirectiveUses | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ServerDirectiveUsage]
gqlTypeDirectiveUses)]
renderDirectiveUsages :: [ServerDirectiveUsage] -> Doc n
renderDirectiveUsages :: forall n. [ServerDirectiveUsage] -> Doc n
renderDirectiveUsages = forall ann. Doc ann -> Doc ann
align forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. [Doc ann] -> Doc ann
vsep forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc n
" <>" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a ann. Pretty a => a -> Doc ann
pretty