{-# 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"
  -- TODO: on scalar we should render user provided type
  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