{-# 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 Prettyprinter
  ( 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 :: forall ann. [ServerTypeDefinition] -> 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 DerivingClass where
  render :: forall ann. DerivingClass -> Result (Doc ann)
render DerivingClass
SHOW = forall (f :: * -> *) a. Applicative f => a -> f a
pure Doc ann
"Show"
  render DerivingClass
GENERIC = forall (f :: * -> *) a. Applicative f => a -> f a
pure Doc ann
"Generic"

instance RenderType ServerTypeDefinition where
  render :: forall ann. ServerTypeDefinition -> Result (Doc ann)
render ServerInterfaceDefinition {} = 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} =
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall ann. Text -> Doc ann
label Text
tName forall a. Semigroup a => a -> a -> a
<> Doc ann
"type" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Text
tName 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 <- Either Text (Doc ann)
renderTypeDef
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall ann. Text -> Doc ann
label Text
tName forall a. Semigroup a => a -> a -> a
<> forall ann. [Doc ann] -> Doc ann
vsep [Doc ann
typeRendering, forall n. ServerTypeDefinition -> Doc n
renderGQLType ServerTypeDefinition
typeDef]
    where
      renderTypeDef :: Either Text (Doc ann)
renderTypeDef = do
        Doc ann
cons <- forall {a} {ann}. RenderType a => [a] -> Either Text (Doc ann)
renderConstructors [ServerConstructorDefinition]
tCons
        Doc ann
derivations <- forall n. [DerivingClass] -> Result (Doc n)
renderDeriving [DerivingClass]
derives
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
          Doc ann
"data"
            forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Text -> [Text] -> Doc ann
parametrizedType Text
tName [Text]
typeParameters
              forall a. Semigroup a => a -> a -> a
<> Doc ann
cons
              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 Doc ann
derivations
              forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
line
      renderConstructors :: [a] -> Either Text (Doc ann)
renderConstructors [a
cons] = (Doc ann
" =" forall ann. Doc ann -> Doc ann -> Doc ann
<+>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a ann. RenderType a => a -> Result (Doc ann)
render a
cons
      renderConstructors [a]
conses = forall ann. Int -> Doc ann -> Doc ann
nest Int
2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall ann. Doc ann
line forall a. Semigroup a => a -> a -> a
<>) 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]
prefixVariants forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 [a]
conses
      prefixVariants :: [Doc ann] -> [Doc ann]
prefixVariants (Doc ann
x : [Doc ann]
xs) = Doc ann
"=" forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
x forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (Doc ann
"|" forall ann. Doc ann -> Doc ann -> Doc ann
<+>) [Doc ann]
xs
      prefixVariants [] = []
  render typeDef :: ServerTypeDefinition
typeDef@DirectiveTypeDefinition {ServerConstructorDefinition
directiveConstructor :: ServerTypeDefinition -> ServerConstructorDefinition
directiveConstructor :: ServerConstructorDefinition
directiveConstructor, [DerivingClass]
directiveDerives :: ServerTypeDefinition -> [DerivingClass]
directiveDerives :: [DerivingClass]
directiveDerives} = do
    Doc ann
typeRendering <- Either Text (Doc ann)
renderTypeDef
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall ann. Text -> Doc ann
label Text
name forall a. Semigroup a => a -> a -> a
<> forall ann. [Doc ann] -> Doc ann
vsep [Doc ann
typeRendering, forall n. ServerTypeDefinition -> Doc n
renderGQLType ServerTypeDefinition
typeDef]
    where
      renderTypeDef :: Either Text (Doc ann)
renderTypeDef = do
        Doc ann
cons <- (Doc ann
" =" forall ann. Doc ann -> Doc ann -> Doc ann
<+>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a ann. RenderType a => a -> Result (Doc ann)
render ServerConstructorDefinition
directiveConstructor
        Doc ann
derivations <- forall n. [DerivingClass] -> Result (Doc n)
renderDeriving [DerivingClass]
directiveDerives
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
          Doc ann
"data"
            forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Text -> [Text] -> Doc ann
parametrizedType Text
name []
              forall a. Semigroup a => a -> a -> a
<> Doc ann
cons
              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 Doc ann
derivations
              forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
line
      name :: Text
name = forall a (t :: NAME). NamePacking a => Name t -> a
unpackName (ServerConstructorDefinition -> TypeName
constructorName ServerConstructorDefinition
directiveConstructor)

renderDeriving :: [DerivingClass] -> Result (Doc n)
renderDeriving :: forall n. [DerivingClass] -> Result (Doc n)
renderDeriving [DerivingClass]
list = (Doc n
"deriving" forall ann. Doc ann -> Doc ann -> Doc ann
<+>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. [Doc ann] -> Doc ann
tupled forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 [DerivingClass]
list

instance RenderType ServerConstructorDefinition where
  render :: forall ann. ServerConstructorDefinition -> Result (Doc ann)
render ServerConstructorDefinition {TypeName
constructorName :: TypeName
constructorName :: ServerConstructorDefinition -> TypeName
constructorName, constructorFields :: ServerConstructorDefinition -> [ServerFieldDefinition]
constructorFields = []} =
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 <- 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 [ServerFieldDefinition]
constructorFields
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall ann. TypeName -> Doc ann
renderName TypeName
constructorName forall a. Semigroup a => a -> a -> a
<> forall ann. [Doc ann] -> Doc ann
renderSet [Doc ann]
fields
    where
      renderSet :: [Doc ann] -> Doc ann
renderSet = forall ann. Int -> Doc ann -> Doc ann
nest Int
2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. Doc ann -> Doc ann -> Doc ann -> Doc ann
enclose Doc ann
"\n{ " Doc ann
"\n}" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. Int -> Doc ann -> Doc ann
nest Int
2 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 forall ann. Doc ann
comma

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

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

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