{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.CodeGen.Internal.AST
  ( CodeGenConstructor (..),
    CodeGenField (..),
    CodeGenType (..),
    CodeGenTypeName (..),
    DerivingClass (..),
    FIELD_TYPE_WRAPPER (..),
    TypeValue (..),
    fromTypeName,
    getFullName,
  )
where

import Data.Morpheus.CodeGen.Internal.Name (camelCaseTypeName)
import Data.Morpheus.CodeGen.Printer
import Data.Morpheus.Types.Internal.AST
  ( FieldName,
    TypeName,
    TypeRef,
    TypeWrapper,
    unpackName,
  )
import qualified Language.Haskell.TH.Syntax as TH
import Prettyprinter
  ( Doc,
    Pretty (..),
    comma,
    enclose,
    hsep,
    indent,
    line,
    nest,
    pretty,
    punctuate,
    tupled,
    vsep,
    (<+>),
  )
import Relude hiding (print)

data DerivingClass
  = SHOW
  | GENERIC
  | CLASS_EQ
  deriving (Int -> DerivingClass -> ShowS
[DerivingClass] -> ShowS
DerivingClass -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DerivingClass] -> ShowS
$cshowList :: [DerivingClass] -> ShowS
show :: DerivingClass -> String
$cshow :: DerivingClass -> String
showsPrec :: Int -> DerivingClass -> ShowS
$cshowsPrec :: Int -> DerivingClass -> ShowS
Show)

instance Pretty DerivingClass where
  pretty :: forall ann. DerivingClass -> Doc ann
pretty DerivingClass
SHOW = Doc ann
"Show"
  pretty DerivingClass
GENERIC = Doc ann
"Generic"
  pretty DerivingClass
CLASS_EQ = Doc ann
"Eq"

data TypeValue
  = TypeValueObject TypeName [(FieldName, TypeValue)]
  | TypeValueNumber Double
  | TypeValueString Text
  | TypeValueBool Bool
  | TypeValueList [TypeValue]
  | TypedValueMaybe (Maybe TypeValue)
  deriving (Int -> TypeValue -> ShowS
[TypeValue] -> ShowS
TypeValue -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TypeValue] -> ShowS
$cshowList :: [TypeValue] -> ShowS
show :: TypeValue -> String
$cshow :: TypeValue -> String
showsPrec :: Int -> TypeValue -> ShowS
$cshowsPrec :: Int -> TypeValue -> ShowS
Show)

renderField :: (FieldName, TypeValue) -> Doc n
renderField :: forall n. (FieldName, TypeValue) -> Doc n
renderField (FieldName
fName, TypeValue
fValue) = forall a ann. Pretty a => a -> Doc ann
pretty (forall a (t :: NAME). NamePacking a => Name t -> a
unpackName FieldName
fName :: Text) 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 TypeValue
fValue

instance Pretty TypeValue where
  pretty :: forall ann. TypeValue -> Doc ann
pretty (TypeValueObject TypeName
name [(FieldName, TypeValue)]
xs) =
    forall a ann. Pretty a => a -> Doc ann
pretty (forall a (t :: NAME). NamePacking a => Name t -> a
unpackName TypeName
name :: Text)
      forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"{"
      forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. [Doc ann] -> Doc ann
vsep (forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc ann
"," (forall a b. (a -> b) -> [a] -> [b]
map forall n. (FieldName, TypeValue) -> Doc n
renderField [(FieldName, TypeValue)]
xs))
      forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"}"
  pretty (TypeValueNumber Double
x) = forall a ann. Pretty a => a -> Doc ann
pretty Double
x
  pretty (TypeValueString Text
x) = forall a ann. Pretty a => a -> Doc ann
pretty (forall b a. (Show a, IsString b) => a -> b
show Text
x :: String)
  pretty (TypeValueBool Bool
x) = forall a ann. Pretty a => a -> Doc ann
pretty Bool
x
  pretty (TypedValueMaybe (Just TypeValue
x)) = Doc ann
"Just" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty TypeValue
x
  pretty (TypedValueMaybe Maybe TypeValue
Nothing) = Doc ann
"Nothing"
  pretty (TypeValueList [TypeValue]
xs) = forall a ann. Pretty a => [a] -> Doc ann
prettyList [TypeValue]
xs

data CodeGenType = CodeGenType
  { CodeGenType -> CodeGenTypeName
cgTypeName :: CodeGenTypeName,
    CodeGenType -> [CodeGenConstructor]
cgConstructors :: [CodeGenConstructor],
    CodeGenType -> [DerivingClass]
cgDerivations :: [DerivingClass]
  }
  deriving (Int -> CodeGenType -> ShowS
[CodeGenType] -> ShowS
CodeGenType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CodeGenType] -> ShowS
$cshowList :: [CodeGenType] -> ShowS
show :: CodeGenType -> String
$cshow :: CodeGenType -> String
showsPrec :: Int -> CodeGenType -> ShowS
$cshowsPrec :: Int -> CodeGenType -> ShowS
Show)

instance Pretty CodeGenType where
  pretty :: forall ann. CodeGenType -> Doc ann
pretty CodeGenType {[CodeGenConstructor]
[DerivingClass]
CodeGenTypeName
cgDerivations :: [DerivingClass]
cgConstructors :: [CodeGenConstructor]
cgTypeName :: CodeGenTypeName
cgDerivations :: CodeGenType -> [DerivingClass]
cgConstructors :: CodeGenType -> [CodeGenConstructor]
cgTypeName :: CodeGenType -> CodeGenTypeName
..} =
    Doc ann
"data"
      forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall n. HSDoc n -> Doc n
ignore (forall a ann. Printer a => a -> HSDoc ann
print CodeGenTypeName
cgTypeName)
        forall a. Semigroup a => a -> a -> a
<> forall {a} {ann}. Printer a => [a] -> Doc ann
renderConstructors [CodeGenConstructor]
cgConstructors
        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. [DerivingClass] -> Doc ann
renderDeriving [DerivingClass]
cgDerivations)
        forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
line
    where
      renderConstructors :: [a] -> Doc ann
renderConstructors [a
cons] = (Doc ann
" =" forall ann. Doc ann -> Doc ann -> Doc ann
<+>) forall a b. (a -> b) -> a -> b
$ forall a n. Printer a => a -> Doc n
print' 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 a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a n. Printer a => a -> Doc n
print' [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 [] = []

renderDeriving :: [DerivingClass] -> Doc n
renderDeriving :: forall ann. [DerivingClass] -> Doc ann
renderDeriving = (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 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

data CodeGenConstructor = CodeGenConstructor
  { CodeGenConstructor -> CodeGenTypeName
constructorName :: CodeGenTypeName,
    CodeGenConstructor -> [CodeGenField]
constructorFields :: [CodeGenField]
  }
  deriving (Int -> CodeGenConstructor -> ShowS
[CodeGenConstructor] -> ShowS
CodeGenConstructor -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CodeGenConstructor] -> ShowS
$cshowList :: [CodeGenConstructor] -> ShowS
show :: CodeGenConstructor -> String
$cshow :: CodeGenConstructor -> String
showsPrec :: Int -> CodeGenConstructor -> ShowS
$cshowsPrec :: Int -> CodeGenConstructor -> ShowS
Show)

instance Printer CodeGenConstructor where
  print :: forall ann. CodeGenConstructor -> HSDoc ann
print CodeGenConstructor {constructorFields :: CodeGenConstructor -> [CodeGenField]
constructorFields = [], CodeGenTypeName
constructorName :: CodeGenTypeName
constructorName :: CodeGenConstructor -> CodeGenTypeName
..} =
    forall a ann. Printer a => a -> HSDoc ann
print CodeGenTypeName
constructorName
  print CodeGenConstructor {[CodeGenField]
CodeGenTypeName
constructorFields :: [CodeGenField]
constructorName :: CodeGenTypeName
constructorFields :: CodeGenConstructor -> [CodeGenField]
constructorName :: CodeGenConstructor -> CodeGenTypeName
..} = do
    let fields :: [Doc n]
fields = forall a b. (a -> b) -> [a] -> [b]
map (forall n. HSDoc n -> Doc n
unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Printer a => a -> HSDoc ann
print) [CodeGenField]
constructorFields
    forall n. Doc n -> HSDoc n
pack (forall a n. Printer a => a -> Doc n
print' CodeGenTypeName
constructorName forall a. Semigroup a => a -> a -> a
<> forall ann. [Doc ann] -> Doc ann
renderSet forall {n}. [Doc n]
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

data CodeGenField = CodeGenField
  { CodeGenField -> FieldName
fieldName :: FieldName,
    CodeGenField -> TypeName
fieldType :: TypeName,
    CodeGenField -> [FIELD_TYPE_WRAPPER]
wrappers :: [FIELD_TYPE_WRAPPER],
    CodeGenField -> Bool
fieldIsNullable :: Bool
  }
  deriving (Int -> CodeGenField -> ShowS
[CodeGenField] -> ShowS
CodeGenField -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CodeGenField] -> ShowS
$cshowList :: [CodeGenField] -> ShowS
show :: CodeGenField -> String
$cshow :: CodeGenField -> String
showsPrec :: Int -> CodeGenField -> ShowS
$cshowsPrec :: Int -> CodeGenField -> ShowS
Show)

instance Printer CodeGenField where
  print :: forall ann. CodeGenField -> HSDoc ann
print CodeGenField {Bool
[FIELD_TYPE_WRAPPER]
FieldName
TypeName
fieldIsNullable :: Bool
wrappers :: [FIELD_TYPE_WRAPPER]
fieldType :: TypeName
fieldName :: FieldName
fieldIsNullable :: CodeGenField -> Bool
wrappers :: CodeGenField -> [FIELD_TYPE_WRAPPER]
fieldType :: CodeGenField -> TypeName
fieldName :: CodeGenField -> FieldName
..} = forall n. HSDoc n -> HSDoc n -> HSDoc n -> HSDoc n
infix' (forall a ann. Printer a => a -> HSDoc ann
print FieldName
fieldName) HSDoc ann
"::" (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall n. FIELD_TYPE_WRAPPER -> HSDoc n -> HSDoc n
renderWrapper (forall a ann. Printer a => a -> HSDoc ann
print TypeName
fieldType) [FIELD_TYPE_WRAPPER]
wrappers)

data FIELD_TYPE_WRAPPER
  = MONAD
  | SUBSCRIPTION TH.Name
  | PARAMETRIZED
  | ARG TypeName
  | TAGGED_ARG TH.Name FieldName TypeRef
  | GQL_WRAPPER TypeWrapper
  deriving (Int -> FIELD_TYPE_WRAPPER -> ShowS
[FIELD_TYPE_WRAPPER] -> ShowS
FIELD_TYPE_WRAPPER -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FIELD_TYPE_WRAPPER] -> ShowS
$cshowList :: [FIELD_TYPE_WRAPPER] -> ShowS
show :: FIELD_TYPE_WRAPPER -> String
$cshow :: FIELD_TYPE_WRAPPER -> String
showsPrec :: Int -> FIELD_TYPE_WRAPPER -> ShowS
$cshowsPrec :: Int -> FIELD_TYPE_WRAPPER -> ShowS
Show)

renderWrapper :: FIELD_TYPE_WRAPPER -> HSDoc n -> HSDoc n
renderWrapper :: forall n. FIELD_TYPE_WRAPPER -> HSDoc n -> HSDoc n
renderWrapper FIELD_TYPE_WRAPPER
PARAMETRIZED = (forall n. HSDoc n -> HSDoc n -> HSDoc n
.<> HSDoc n
"m")
renderWrapper FIELD_TYPE_WRAPPER
MONAD = (HSDoc n
"m" forall n. HSDoc n -> HSDoc n -> HSDoc n
.<>)
renderWrapper SUBSCRIPTION {} = forall a. a -> a
id
renderWrapper (GQL_WRAPPER TypeWrapper
typeWrappers) = forall n. TypeWrapper -> HSDoc n -> HSDoc n
wrapped TypeWrapper
typeWrappers
renderWrapper (ARG TypeName
name) = forall n. HSDoc n -> HSDoc n -> HSDoc n -> HSDoc n
infix' (forall a ann. Printer a => a -> HSDoc ann
print TypeName
name) HSDoc n
"->"
renderWrapper (TAGGED_ARG Name
_ FieldName
name TypeRef
typeRef) = forall n. HSDoc n -> HSDoc n -> HSDoc n -> HSDoc n
infix' (forall (t :: NAME) n. Name t -> [HSDoc n] -> HSDoc n
apply Name Any
"Arg" [forall a ann. Printer a => a -> HSDoc ann
print (forall b a. (Show a, IsString b) => a -> b
show FieldName
name :: String), forall a ann. Printer a => a -> HSDoc ann
print TypeRef
typeRef]) HSDoc n
"->"

data CodeGenTypeName = CodeGenTypeName
  { CodeGenTypeName -> [FieldName]
namespace :: [FieldName],
    CodeGenTypeName -> [Text]
typeParameters :: [Text],
    CodeGenTypeName -> TypeName
typename :: TypeName
  }
  deriving (Int -> CodeGenTypeName -> ShowS
[CodeGenTypeName] -> ShowS
CodeGenTypeName -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CodeGenTypeName] -> ShowS
$cshowList :: [CodeGenTypeName] -> ShowS
show :: CodeGenTypeName -> String
$cshow :: CodeGenTypeName -> String
showsPrec :: Int -> CodeGenTypeName -> ShowS
$cshowsPrec :: Int -> CodeGenTypeName -> ShowS
Show)

getFullName :: CodeGenTypeName -> TypeName
getFullName :: CodeGenTypeName -> TypeName
getFullName CodeGenTypeName {[Text]
[FieldName]
TypeName
typename :: TypeName
typeParameters :: [Text]
namespace :: [FieldName]
typename :: CodeGenTypeName -> TypeName
typeParameters :: CodeGenTypeName -> [Text]
namespace :: CodeGenTypeName -> [FieldName]
..} = forall (t :: NAME). [Name t] -> TypeName -> TypeName
camelCaseTypeName [FieldName]
namespace TypeName
typename

fromTypeName :: TypeName -> CodeGenTypeName
fromTypeName :: TypeName -> CodeGenTypeName
fromTypeName = [FieldName] -> [Text] -> TypeName -> CodeGenTypeName
CodeGenTypeName [] []

instance Printer CodeGenTypeName where
  print :: forall ann. CodeGenTypeName -> HSDoc ann
print CodeGenTypeName
cgName =
    forall n. Bool -> Doc n -> HSDoc n
HSDoc (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null (CodeGenTypeName -> [Text]
typeParameters CodeGenTypeName
cgName)) forall a b. (a -> b) -> a -> b
$
      forall ann. Text -> [Text] -> Doc ann
parametrizedType
        (forall a (t :: NAME). NamePacking a => Name t -> a
unpackName (CodeGenTypeName -> TypeName
getFullName CodeGenTypeName
cgName))
        (CodeGenTypeName -> [Text]
typeParameters CodeGenTypeName
cgName)

parametrizedType :: Text -> [Text] -> Doc ann
parametrizedType :: forall ann. Text -> [Text] -> Doc ann
parametrizedType Text
tName [Text]
typeParameters = forall ann. [Doc ann] -> Doc ann
hsep forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a ann. Pretty a => a -> Doc ann
pretty forall a b. (a -> b) -> a -> b
$ Text
tName forall a. a -> [a] -> [a]
: [Text]
typeParameters