{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.CodeGen.Printing.Type
  ( renderTypes,
  )
where

import Data.Morpheus.CodeGen.Internal.AST
  ( DerivingClass (..),
    FIELD_TYPE_WRAPPER (..),
    ServerConstructorDefinition (..),
    ServerFieldDefinition (..),
    ServerTypeDefinition (..),
    TypeKind (..),
    TypeRef (..),
    unpackName,
  )
import Data.Morpheus.CodeGen.Printing.GQLType
  ( renderGQLType,
  )
import Data.Morpheus.CodeGen.Printing.Terms
  ( TypeDoc (TypeDoc, unDoc),
    appendType,
    label,
    parametrizedType,
    renderName,
    renderType,
    renderWrapped,
  )
import Data.Text.Prettyprint.Doc
  ( (<+>),
    Doc,
    comma,
    enclose,
    indent,
    line,
    nest,
    pretty,
    punctuate,
    tupled,
    vsep,
  )
import Relude hiding (show)
import Prelude (show)

type Result = Either Text

renderTypes :: [ServerTypeDefinition] -> Either Text (Doc ann)
renderTypes :: [ServerTypeDefinition] -> Either Text (Doc ann)
renderTypes = ([Doc ann] -> Doc ann)
-> Either Text [Doc ann] -> Either Text (Doc ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep (Either Text [Doc ann] -> Either Text (Doc ann))
-> ([ServerTypeDefinition] -> Either Text [Doc ann])
-> [ServerTypeDefinition]
-> Either Text (Doc ann)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ServerTypeDefinition -> Either Text (Doc ann))
-> [ServerTypeDefinition] -> Either Text [Doc ann]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ServerTypeDefinition -> Either Text (Doc ann)
forall a ann. RenderType a => a -> Result (Doc ann)
render

class RenderType a where
  render :: a -> Result (Doc ann)

instance RenderType DerivingClass where
  render :: DerivingClass -> Result (Doc ann)
render DerivingClass
SHOW = Doc ann -> Result (Doc ann)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Doc ann
"Show"
  render DerivingClass
GENERIC = Doc ann -> Result (Doc ann)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Doc ann
"Generic"

instance RenderType ServerTypeDefinition where
  render :: ServerTypeDefinition -> Result (Doc ann)
render ServerInterfaceDefinition {} = String -> Result (Doc ann)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"not supported"
  -- TODO: on scalar we should render user provided type
  render ServerTypeDefinition {tKind :: ServerTypeDefinition -> TypeKind
tKind = TypeKind
KindScalar, Text
tName :: ServerTypeDefinition -> Text
tName :: Text
tName} =
    Doc ann -> Result (Doc ann)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Doc ann -> Result (Doc ann)) -> Doc ann -> Result (Doc ann)
forall a b. (a -> b) -> a -> b
$ Text -> Doc ann
forall ann. Text -> Doc ann
label Text
tName Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"type" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
tName Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"= Int"
  render typeDef :: ServerTypeDefinition
typeDef@ServerTypeDefinition {Text
tName :: Text
tName :: ServerTypeDefinition -> Text
tName, [ServerConstructorDefinition]
tCons :: ServerTypeDefinition -> [ServerConstructorDefinition]
tCons :: [ServerConstructorDefinition]
tCons, [Text]
typeParameters :: ServerTypeDefinition -> [Text]
typeParameters :: [Text]
typeParameters, [DerivingClass]
derives :: ServerTypeDefinition -> [DerivingClass]
derives :: [DerivingClass]
derives} = do
    Doc ann
typeRendering <- Result (Doc ann)
renderTypeDef
    Doc ann -> Result (Doc ann)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Doc ann -> Result (Doc ann)) -> Doc ann -> Result (Doc ann)
forall a b. (a -> b) -> a -> b
$ Text -> Doc ann
forall ann. Text -> Doc ann
label Text
tName Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep [Doc ann
typeRendering, ServerTypeDefinition -> Doc ann
forall n. ServerTypeDefinition -> Doc n
renderGQLType ServerTypeDefinition
typeDef]
    where
      renderTypeDef :: Result (Doc ann)
renderTypeDef = do
        Doc ann
cons <- [ServerConstructorDefinition] -> Result (Doc ann)
forall a ann. RenderType a => [a] -> Either Text (Doc ann)
renderConstructors [ServerConstructorDefinition]
tCons
        Doc ann
derivations <- [DerivingClass] -> Result (Doc ann)
forall n. [DerivingClass] -> Result (Doc n)
renderDeriving [DerivingClass]
derives
        Doc ann -> Result (Doc ann)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Doc ann -> Result (Doc ann)) -> Doc ann -> Result (Doc ann)
forall a b. (a -> b) -> a -> b
$
          Doc ann
"data"
            Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> [Text] -> Doc ann
forall ann. Text -> [Text] -> Doc ann
parametrizedType Text
tName [Text]
typeParameters
            Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
cons
            Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> 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
derivations
            Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line
      renderConstructors :: [a] -> Either Text (Doc ann)
renderConstructors [a
cons] = (Doc ann
" =" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+>) (Doc ann -> Doc ann)
-> Either Text (Doc ann) -> Either Text (Doc ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Either Text (Doc ann)
forall a ann. RenderType a => a -> Result (Doc ann)
render a
cons
      renderConstructors [a]
conses = Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann)
-> ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<>) (Doc ann -> Doc ann)
-> ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann)
-> ([Doc ann] -> [Doc ann]) -> [Doc ann] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc ann] -> [Doc ann]
forall ann. [Doc ann] -> [Doc ann]
prefixVariants ([Doc ann] -> Doc ann)
-> Either Text [Doc ann] -> Either Text (Doc ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> Either Text (Doc ann)) -> [a] -> Either Text [Doc ann]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> Either Text (Doc ann)
forall a ann. RenderType a => a -> Result (Doc ann)
render [a]
conses
      prefixVariants :: [Doc ann] -> [Doc ann]
prefixVariants (Doc ann
x : [Doc ann]
xs) = Doc ann
"=" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
x Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: (Doc ann -> Doc ann) -> [Doc ann] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (Doc ann
"|" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+>) [Doc ann]
xs
      prefixVariants [] = []

renderDeriving :: [DerivingClass] -> Result (Doc n)
renderDeriving :: [DerivingClass] -> Result (Doc n)
renderDeriving [DerivingClass]
list = (Doc n
"deriving" Doc n -> Doc n -> Doc n
forall ann. Doc ann -> Doc ann -> Doc ann
<+>) (Doc n -> Doc n) -> ([Doc n] -> Doc n) -> [Doc n] -> Doc n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc n] -> Doc n
forall ann. [Doc ann] -> Doc ann
tupled ([Doc n] -> Doc n) -> Either Text [Doc n] -> Result (Doc n)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DerivingClass -> Result (Doc n))
-> [DerivingClass] -> Either Text [Doc n]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse DerivingClass -> Result (Doc n)
forall a ann. RenderType a => a -> Result (Doc ann)
render [DerivingClass]
list

instance RenderType ServerConstructorDefinition where
  render :: ServerConstructorDefinition -> Result (Doc ann)
render ServerConstructorDefinition {TypeName
constructorName :: ServerConstructorDefinition -> TypeName
constructorName :: TypeName
constructorName, constructorFields :: ServerConstructorDefinition -> [ServerFieldDefinition]
constructorFields = []} =
    Doc ann -> Result (Doc ann)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Doc ann -> Result (Doc ann)) -> Doc ann -> Result (Doc ann)
forall a b. (a -> b) -> a -> b
$ TypeName -> Doc ann
forall ann. TypeName -> Doc ann
renderName TypeName
constructorName
  render ServerConstructorDefinition {TypeName
constructorName :: TypeName
constructorName :: ServerConstructorDefinition -> TypeName
constructorName, [ServerFieldDefinition]
constructorFields :: [ServerFieldDefinition]
constructorFields :: ServerConstructorDefinition -> [ServerFieldDefinition]
constructorFields} = do
    [Doc ann]
fields <- (ServerFieldDefinition -> Result (Doc ann))
-> [ServerFieldDefinition] -> Either Text [Doc ann]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ServerFieldDefinition -> Result (Doc ann)
forall a ann. RenderType a => a -> Result (Doc ann)
render [ServerFieldDefinition]
constructorFields
    Doc ann -> Result (Doc ann)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Doc ann -> Result (Doc ann)) -> Doc ann -> Result (Doc ann)
forall a b. (a -> b) -> a -> b
$ TypeName -> Doc ann
forall ann. TypeName -> Doc ann
renderName TypeName
constructorName Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
renderSet [Doc ann]
fields
    where
      renderSet :: [Doc ann] -> Doc ann
renderSet = Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann)
-> ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc ann -> Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann -> Doc ann
enclose Doc ann
"\n{ " Doc ann
"\n}" (Doc ann -> Doc ann)
-> ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann)
-> ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann)
-> ([Doc ann] -> [Doc ann]) -> [Doc ann] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc ann -> [Doc ann] -> [Doc ann]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc ann
forall ann. Doc ann
comma

instance RenderType ServerFieldDefinition where
  render :: ServerFieldDefinition -> Result (Doc ann)
render
    ServerFieldDefinition
      { FieldName
fieldName :: ServerFieldDefinition -> FieldName
fieldName :: FieldName
fieldName,
        [FIELD_TYPE_WRAPPER]
wrappers :: ServerFieldDefinition -> [FIELD_TYPE_WRAPPER]
wrappers :: [FIELD_TYPE_WRAPPER]
wrappers,
        Text
fieldType :: ServerFieldDefinition -> Text
fieldType :: Text
fieldType
      } =
      Doc ann -> Result (Doc ann)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Doc ann -> Result (Doc ann)) -> Doc ann -> Result (Doc ann)
forall a b. (a -> b) -> a -> b
$
        Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (FieldName -> Text
forall (t :: NAME). Name t -> Text
unpackName FieldName
fieldName)
          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
<+> TypeDoc ann -> Doc ann
forall n. TypeDoc n -> Doc n
unDoc ((FIELD_TYPE_WRAPPER -> TypeDoc ann -> TypeDoc ann)
-> TypeDoc ann -> [FIELD_TYPE_WRAPPER] -> TypeDoc ann
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr FIELD_TYPE_WRAPPER -> TypeDoc ann -> TypeDoc ann
forall n. FIELD_TYPE_WRAPPER -> TypeDoc n -> TypeDoc n
renderWrapper (Bool -> Doc ann -> TypeDoc ann
forall n. Bool -> Doc n -> TypeDoc n
TypeDoc Bool
False (Doc ann -> TypeDoc ann) -> Doc ann -> TypeDoc ann
forall a b. (a -> b) -> a -> b
$ Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
fieldType) [FIELD_TYPE_WRAPPER]
wrappers)

renderWrapper :: FIELD_TYPE_WRAPPER -> TypeDoc n -> TypeDoc n
renderWrapper :: FIELD_TYPE_WRAPPER -> TypeDoc n -> TypeDoc n
renderWrapper FIELD_TYPE_WRAPPER
PARAMETRIZED = \TypeDoc n
x -> Bool -> Doc n -> TypeDoc n
forall n. Bool -> Doc n -> TypeDoc n
TypeDoc Bool
True (TypeDoc n -> Doc n
forall n. TypeDoc n -> Doc n
unDoc TypeDoc n
x Doc n -> Doc n -> Doc n
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc n
"m")
renderWrapper FIELD_TYPE_WRAPPER
MONAD = TypeName -> TypeDoc n -> TypeDoc n
forall n. TypeName -> TypeDoc n -> TypeDoc n
appendType TypeName
"m"
renderWrapper FIELD_TYPE_WRAPPER
SUBSCRIPTION = TypeDoc n -> TypeDoc n
forall a. a -> a
id
renderWrapper (GQL_WRAPPER TypeWrapper
typeWrappers) = TypeWrapper -> TypeDoc n -> TypeDoc n
forall n. TypeWrapper -> TypeDoc n -> TypeDoc n
renderWrapped TypeWrapper
typeWrappers
renderWrapper (ARG TypeName
name) = Bool -> Doc n -> TypeDoc n
forall n. Bool -> Doc n -> TypeDoc n
TypeDoc Bool
True (Doc n -> TypeDoc n)
-> (TypeDoc n -> Doc n) -> TypeDoc n -> TypeDoc n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TypeName -> Doc n
forall ann. TypeName -> Doc ann
renderName TypeName
name Doc n -> Doc n -> Doc n
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc n
"->") Doc n -> Doc n -> Doc n
forall ann. Doc ann -> Doc ann -> Doc ann
<+>) (Doc n -> Doc n) -> (TypeDoc n -> Doc n) -> TypeDoc n -> Doc n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeDoc n -> Doc n
forall n. TypeDoc n -> Doc n
unDoc
renderWrapper (TAGGED_ARG FieldName
name TypeRef
typeRef) =
  Bool -> Doc n -> TypeDoc n
forall n. Bool -> Doc n -> TypeDoc n
TypeDoc Bool
True
    (Doc n -> TypeDoc n)
-> (TypeDoc n -> Doc n) -> TypeDoc n -> TypeDoc n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ( ( Doc n
"Arg"
            Doc n -> Doc n -> Doc n
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc n
forall a ann. Pretty a => a -> Doc ann
pretty (FieldName -> String
forall a. Show a => a -> String
show FieldName
name)
            Doc n -> Doc n -> Doc n
forall ann. Doc ann -> Doc ann -> Doc ann
<+> TypeDoc n -> Doc n
forall n. TypeDoc n -> Doc n
renderType (TypeRef -> TypeDoc n
forall n. TypeRef -> TypeDoc n
renderTypeRef TypeRef
typeRef)
            Doc n -> Doc n -> Doc n
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc n
"->"
        )
          Doc n -> Doc n -> Doc n
forall ann. Doc ann -> Doc ann -> Doc ann
<+>
      )
    (Doc n -> Doc n) -> (TypeDoc n -> Doc n) -> TypeDoc n -> Doc n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeDoc n -> Doc n
forall n. TypeDoc n -> Doc n
unDoc

renderTypeRef :: TypeRef -> TypeDoc n
renderTypeRef :: TypeRef -> TypeDoc n
renderTypeRef
  TypeRef
    { TypeName
typeConName :: TypeRef -> TypeName
typeConName :: TypeName
typeConName,
      TypeWrapper
typeWrappers :: TypeRef -> TypeWrapper
typeWrappers :: TypeWrapper
typeWrappers
    } =
    TypeWrapper -> TypeDoc n -> TypeDoc n
forall n. TypeWrapper -> TypeDoc n -> TypeDoc n
renderWrapped
      TypeWrapper
typeWrappers
      (Bool -> Doc n -> TypeDoc n
forall n. Bool -> Doc n -> TypeDoc n
TypeDoc Bool
False (TypeName -> Doc n
forall ann. TypeName -> Doc ann
renderName TypeName
typeConName))