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

module Data.Morpheus.CodeGen.Server.Internal.AST
  ( CodeGenConfig (..),
    ServerDeclaration (..),
    GQLTypeDefinition (..),
    CONST,
    TypeKind (..),
    TypeName,
    TypeRef (..),
    TypeWrapper (..),
    unpackName,
    DerivingClass (..),
    FIELD_TYPE_WRAPPER (..),
    Kind (..),
    ServerDirectiveUsage (..),
    TypeValue (..),
    InterfaceDefinition (..),
    GQLDirectiveTypeClass (..),
    ServerMethod (..),
  )
where

import Data.Morpheus.CodeGen.Internal.AST
  ( CodeGenType,
    CodeGenTypeName,
    DerivingClass (..),
    FIELD_TYPE_WRAPPER (..),
    TypeClassInstance (..),
    TypeValue (..),
  )
import Data.Morpheus.CodeGen.Printer
  ( Printer (..),
    ignore,
    unpack,
    (.<>),
  )
import Data.Morpheus.CodeGen.TH (PrintDec (..), PrintExp (..), ToName (..), apply, m', m_, printTypeSynonym)
import Data.Morpheus.Server.Types (DIRECTIVE, SCALAR, TYPE, TypeGuard, enumDirective, fieldDirective, typeDirective)
import Data.Morpheus.Types.Internal.AST
  ( CONST,
    DirectiveLocation (..),
    FieldName,
    TypeKind (..),
    TypeName,
    TypeRef (..),
    TypeWrapper (..),
    Value,
    unpackName,
  )
import Language.Haskell.TH.Lib (appE, varE)
import Prettyprinter
  ( Pretty (..),
    align,
    concatWith,
    indent,
    line,
    pretty,
    (<+>),
  )
import Relude hiding (Show, optional, print, show)
import Prelude (Show (..))

data Kind
  = Scalar
  | Type
  | Directive
  deriving (Int -> Kind -> ShowS
[Kind] -> ShowS
Kind -> String
(Int -> Kind -> ShowS)
-> (Kind -> String) -> ([Kind] -> ShowS) -> Show Kind
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Kind -> ShowS
showsPrec :: Int -> Kind -> ShowS
$cshow :: Kind -> String
show :: Kind -> String
$cshowList :: [Kind] -> ShowS
showList :: [Kind] -> ShowS
Show, Kind -> Kind -> Bool
(Kind -> Kind -> Bool) -> (Kind -> Kind -> Bool) -> Eq Kind
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Kind -> Kind -> Bool
== :: Kind -> Kind -> Bool
$c/= :: Kind -> Kind -> Bool
/= :: Kind -> Kind -> Bool
Eq)

instance Pretty Kind where
  pretty :: forall ann. Kind -> Doc ann
pretty Kind
Type = Doc ann
"TYPE"
  pretty Kind
Scalar = Doc ann
"SCALAR"
  pretty Kind
Directive = Doc ann
"DIRECTIVE"

instance ToName Kind where
  toName :: Kind -> Name
toName Kind
Scalar = ''SCALAR
  toName Kind
Type = ''TYPE
  toName Kind
Directive = ''DIRECTIVE

data ServerDirectiveUsage
  = TypeDirectiveUsage TypeValue
  | FieldDirectiveUsage FieldName TypeValue
  | EnumDirectiveUsage TypeName TypeValue
  deriving (Int -> ServerDirectiveUsage -> ShowS
[ServerDirectiveUsage] -> ShowS
ServerDirectiveUsage -> String
(Int -> ServerDirectiveUsage -> ShowS)
-> (ServerDirectiveUsage -> String)
-> ([ServerDirectiveUsage] -> ShowS)
-> Show ServerDirectiveUsage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ServerDirectiveUsage -> ShowS
showsPrec :: Int -> ServerDirectiveUsage -> ShowS
$cshow :: ServerDirectiveUsage -> String
show :: ServerDirectiveUsage -> String
$cshowList :: [ServerDirectiveUsage] -> ShowS
showList :: [ServerDirectiveUsage] -> ShowS
Show)

instance PrintExp ServerDirectiveUsage where
  printExp :: ServerDirectiveUsage -> ExpQ
printExp (TypeDirectiveUsage TypeValue
x) = ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'typeDirective) (TypeValue -> ExpQ
forall a. PrintExp a => a -> ExpQ
printExp TypeValue
x)
  printExp (FieldDirectiveUsage FieldName
field TypeValue
x) = ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'fieldDirective) [|field|]) (TypeValue -> ExpQ
forall a. PrintExp a => a -> ExpQ
printExp TypeValue
x)
  printExp (EnumDirectiveUsage TypeName
enum TypeValue
x) = ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'enumDirective) [|enum|]) (TypeValue -> ExpQ
forall a. PrintExp a => a -> ExpQ
printExp TypeValue
x)

instance Pretty ServerDirectiveUsage where
  pretty :: forall ann. ServerDirectiveUsage -> Doc ann
pretty (TypeDirectiveUsage TypeValue
value) = Doc ann
"typeDirective" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> TypeValue -> Doc ann
forall ann. TypeValue -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty TypeValue
value
  pretty (FieldDirectiveUsage FieldName
place TypeValue
value) = Doc ann
"fieldDirective" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (FieldName -> String
forall a. Show a => a -> String
show FieldName
place :: String) Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> TypeValue -> Doc ann
forall ann. TypeValue -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty TypeValue
value
  pretty (EnumDirectiveUsage TypeName
place TypeValue
value) = Doc ann
"enumDirective" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (TypeName -> String
forall a. Show a => a -> String
show TypeName
place :: String) Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> TypeValue -> Doc ann
forall ann. TypeValue -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty TypeValue
value

data GQLTypeDefinition = GQLTypeDefinition
  { GQLTypeDefinition -> CodeGenTypeName
gqlTarget :: CodeGenTypeName,
    GQLTypeDefinition -> Kind
gqlKind :: Kind,
    GQLTypeDefinition -> [ServerDirectiveUsage]
gqlTypeDirectiveUses :: [ServerDirectiveUsage]
  }
  deriving (Int -> GQLTypeDefinition -> ShowS
[GQLTypeDefinition] -> ShowS
GQLTypeDefinition -> String
(Int -> GQLTypeDefinition -> ShowS)
-> (GQLTypeDefinition -> String)
-> ([GQLTypeDefinition] -> ShowS)
-> Show GQLTypeDefinition
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GQLTypeDefinition -> ShowS
showsPrec :: Int -> GQLTypeDefinition -> ShowS
$cshow :: GQLTypeDefinition -> String
show :: GQLTypeDefinition -> String
$cshowList :: [GQLTypeDefinition] -> ShowS
showList :: [GQLTypeDefinition] -> ShowS
Show)

data InterfaceDefinition = InterfaceDefinition
  { InterfaceDefinition -> TypeName
aliasName :: TypeName,
    InterfaceDefinition -> TypeName
interfaceName :: TypeName,
    InterfaceDefinition -> TypeName
unionName :: TypeName
  }
  deriving (Int -> InterfaceDefinition -> ShowS
[InterfaceDefinition] -> ShowS
InterfaceDefinition -> String
(Int -> InterfaceDefinition -> ShowS)
-> (InterfaceDefinition -> String)
-> ([InterfaceDefinition] -> ShowS)
-> Show InterfaceDefinition
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> InterfaceDefinition -> ShowS
showsPrec :: Int -> InterfaceDefinition -> ShowS
$cshow :: InterfaceDefinition -> String
show :: InterfaceDefinition -> String
$cshowList :: [InterfaceDefinition] -> ShowS
showList :: [InterfaceDefinition] -> ShowS
Show)

instance PrintDec InterfaceDefinition where
  printDec :: InterfaceDefinition -> Q Dec
printDec InterfaceDefinition {TypeName
aliasName :: InterfaceDefinition -> TypeName
interfaceName :: InterfaceDefinition -> TypeName
unionName :: InterfaceDefinition -> TypeName
aliasName :: TypeName
interfaceName :: TypeName
unionName :: TypeName
..} =
    Dec -> Q Dec
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$
      TypeName -> [Name] -> Type -> Dec
forall a. ToName a => a -> [Name] -> Type -> Dec
printTypeSynonym
        TypeName
aliasName
        [Name
m_]
        ( Name -> [Type] -> Type
forall a i. (Apply a, ToCon i a) => i -> [a] -> a
forall i. ToCon i Type => i -> [Type] -> Type
apply
            ''TypeGuard
            [TypeName -> [Type] -> Type
forall a i. (Apply a, ToCon i a) => i -> [a] -> a
forall i. ToCon i Type => i -> [Type] -> Type
apply TypeName
interfaceName [Type
m'], TypeName -> [Type] -> Type
forall a i. (Apply a, ToCon i a) => i -> [a] -> a
forall i. ToCon i Type => i -> [Type] -> Type
apply TypeName
unionName [Type
m']]
        )

data GQLDirectiveTypeClass = GQLDirectiveTypeClass
  { GQLDirectiveTypeClass -> CodeGenTypeName
directiveTypeName :: CodeGenTypeName,
    GQLDirectiveTypeClass -> [DirectiveLocation]
directiveLocations :: [DirectiveLocation]
  }
  deriving (Int -> GQLDirectiveTypeClass -> ShowS
[GQLDirectiveTypeClass] -> ShowS
GQLDirectiveTypeClass -> String
(Int -> GQLDirectiveTypeClass -> ShowS)
-> (GQLDirectiveTypeClass -> String)
-> ([GQLDirectiveTypeClass] -> ShowS)
-> Show GQLDirectiveTypeClass
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GQLDirectiveTypeClass -> ShowS
showsPrec :: Int -> GQLDirectiveTypeClass -> ShowS
$cshow :: GQLDirectiveTypeClass -> String
show :: GQLDirectiveTypeClass -> String
$cshowList :: [GQLDirectiveTypeClass] -> ShowS
showList :: [GQLDirectiveTypeClass] -> ShowS
Show)

data ServerDeclaration
  = GQLTypeInstance Kind (TypeClassInstance ServerMethod)
  | GQLDirectiveInstance (TypeClassInstance ServerMethod)
  | DataType CodeGenType
  | ScalarType {ServerDeclaration -> Text
scalarTypeName :: Text}
  | InterfaceType InterfaceDefinition
  deriving (Int -> ServerDeclaration -> ShowS
[ServerDeclaration] -> ShowS
ServerDeclaration -> String
(Int -> ServerDeclaration -> ShowS)
-> (ServerDeclaration -> String)
-> ([ServerDeclaration] -> ShowS)
-> Show ServerDeclaration
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ServerDeclaration -> ShowS
showsPrec :: Int -> ServerDeclaration -> ShowS
$cshow :: ServerDeclaration -> String
show :: ServerDeclaration -> String
$cshowList :: [ServerDeclaration] -> ShowS
showList :: [ServerDeclaration] -> ShowS
Show)

instance Pretty ServerDeclaration where
  pretty :: forall ann. ServerDeclaration -> Doc ann
pretty (InterfaceType InterfaceDefinition {TypeName
aliasName :: InterfaceDefinition -> TypeName
interfaceName :: InterfaceDefinition -> TypeName
unionName :: InterfaceDefinition -> TypeName
aliasName :: TypeName
interfaceName :: TypeName
unionName :: TypeName
..}) =
    Doc ann
"type"
      Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> HSDoc ann -> Doc ann
forall n. HSDoc n -> Doc n
ignore (TypeName -> HSDoc ann
forall a ann. Printer a => a -> HSDoc ann
forall ann. TypeName -> HSDoc ann
print TypeName
aliasName)
      Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"m"
      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
<+> Doc ann
"TypeGuard"
      Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> HSDoc ann -> Doc ann
forall n. HSDoc n -> Doc n
unpack (TypeName -> HSDoc ann
forall a ann. Printer a => a -> HSDoc ann
forall ann. TypeName -> HSDoc ann
print TypeName
interfaceName HSDoc ann -> HSDoc ann -> HSDoc ann
forall n. HSDoc n -> HSDoc n -> HSDoc n
.<> HSDoc ann
"m")
      Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> HSDoc ann -> Doc ann
forall n. HSDoc n -> Doc n
unpack (TypeName -> HSDoc ann
forall a ann. Printer a => a -> HSDoc ann
forall ann. TypeName -> HSDoc ann
print TypeName
unionName HSDoc ann -> HSDoc ann -> HSDoc ann
forall n. HSDoc n -> HSDoc n -> HSDoc n
.<> HSDoc ann
"m")
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line
  pretty ScalarType {} = Doc ann
""
  pretty (DataType CodeGenType
cgType) = CodeGenType -> Doc ann
forall ann. CodeGenType -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty CodeGenType
cgType
  pretty (GQLTypeInstance Kind
kind TypeClassInstance ServerMethod
gql)
    | Kind
kind Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
Scalar = Doc ann
""
    | Bool
otherwise = TypeClassInstance ServerMethod -> Doc ann
forall ann. TypeClassInstance ServerMethod -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty TypeClassInstance ServerMethod
gql
  pretty (GQLDirectiveInstance TypeClassInstance ServerMethod
_) = Doc ann
""

newtype CodeGenConfig = CodeGenConfig {CodeGenConfig -> Bool
namespace :: Bool}

data ServerMethod
  = ServerMethodDefaultValues (Map Text (Value CONST))
  | ServerMethodDirectives [ServerDirectiveUsage]
  deriving (Int -> ServerMethod -> ShowS
[ServerMethod] -> ShowS
ServerMethod -> String
(Int -> ServerMethod -> ShowS)
-> (ServerMethod -> String)
-> ([ServerMethod] -> ShowS)
-> Show ServerMethod
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ServerMethod -> ShowS
showsPrec :: Int -> ServerMethod -> ShowS
$cshow :: ServerMethod -> String
show :: ServerMethod -> String
$cshowList :: [ServerMethod] -> ShowS
showList :: [ServerMethod] -> ShowS
Show)

instance Pretty ServerMethod where
  pretty :: forall ann. ServerMethod -> Doc ann
pretty (ServerMethodDefaultValues Map Text (Value CONST)
x) = String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Map Text (Value CONST) -> String
forall a. Show a => a -> String
show Map Text (Value CONST)
x)
  pretty (ServerMethodDirectives [ServerDirectiveUsage]
dirs) = 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 -> Doc ann
forall ann. Doc ann -> Doc ann
align (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ (Doc ann -> Doc ann -> Doc ann) -> [Doc ann] -> Doc ann
forall (t :: * -> *) ann.
Foldable t =>
(Doc ann -> Doc ann -> Doc ann) -> t (Doc ann) -> Doc ann
concatWith (\Doc ann
x Doc ann
y -> Doc ann
x Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"\n  <>" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
y) ((ServerDirectiveUsage -> Doc ann)
-> [ServerDirectiveUsage] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map ServerDirectiveUsage -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. ServerDirectiveUsage -> Doc ann
pretty [ServerDirectiveUsage]
dirs))

instance PrintExp ServerMethod where
  printExp :: ServerMethod -> ExpQ
printExp (ServerMethodDefaultValues Map Text (Value CONST)
values) = [|values|]
  printExp (ServerMethodDirectives [ServerDirectiveUsage]
dirs) = (ServerDirectiveUsage -> ExpQ -> ExpQ)
-> ExpQ -> [ServerDirectiveUsage] -> ExpQ
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (ExpQ -> ExpQ -> ExpQ)
-> (ServerDirectiveUsage -> ExpQ)
-> ServerDirectiveUsage
-> ExpQ
-> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [|(<>)|] (ExpQ -> ExpQ)
-> (ServerDirectiveUsage -> ExpQ) -> ServerDirectiveUsage -> ExpQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerDirectiveUsage -> ExpQ
forall a. PrintExp a => a -> ExpQ
printExp) [|mempty|] [ServerDirectiveUsage]
dirs