{-# 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 (SCALAR, TYPE, TypeGuard, enumDirective, fieldDirective, typeDirective)
import Data.Morpheus.Types.Internal.AST
  ( CONST,
    DirectiveLocation (..),
    FieldName,
    TypeKind (..),
    TypeName,
    TypeRef (..),
    TypeWrapper (..),
    Value,
    unpackName,
  )
import Data.Text.Prettyprint.Doc (concatWith, indent, line)
import Language.Haskell.TH.Lib (appE, varE)
import Prettyprinter
  ( Pretty (..),
    align,
    pretty,
    (<+>),
  )
import Relude hiding (Show, optional, print, show)
import Prelude (Show (..))

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

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

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

instance PrintExp ServerDirectiveUsage where
  printExp :: ServerDirectiveUsage -> ExpQ
printExp (TypeDirectiveUsage TypeValue
x) = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE 'typeDirective) (forall a. PrintExp a => a -> ExpQ
printExp TypeValue
x)
  printExp (FieldDirectiveUsage FieldName
field TypeValue
x) = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE 'fieldDirective) [|field|]) (forall a. PrintExp a => a -> ExpQ
printExp TypeValue
x)
  printExp (EnumDirectiveUsage TypeName
enum TypeValue
x) = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE 'enumDirective) [|enum|]) (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" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty TypeValue
value
  pretty (FieldDirectiveUsage FieldName
place TypeValue
value) = Doc ann
"fieldDirective" 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
place :: String) forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty TypeValue
value
  pretty (EnumDirectiveUsage TypeName
place TypeValue
value) = Doc ann
"enumDirective" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty (forall a. Show a => a -> String
show TypeName
place :: String) forall ann. Doc ann -> Doc ann -> 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GQLTypeDefinition] -> ShowS
$cshowList :: [GQLTypeDefinition] -> ShowS
show :: GQLTypeDefinition -> String
$cshow :: GQLTypeDefinition -> String
showsPrec :: Int -> GQLTypeDefinition -> ShowS
$cshowsPrec :: Int -> 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InterfaceDefinition] -> ShowS
$cshowList :: [InterfaceDefinition] -> ShowS
show :: InterfaceDefinition -> String
$cshow :: InterfaceDefinition -> String
showsPrec :: Int -> InterfaceDefinition -> ShowS
$cshowsPrec :: Int -> InterfaceDefinition -> ShowS
Show)

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

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

instance Pretty ServerDeclaration where
  pretty :: forall ann. ServerDeclaration -> Doc ann
pretty (InterfaceType InterfaceDefinition {TypeName
unionName :: TypeName
interfaceName :: TypeName
aliasName :: TypeName
unionName :: InterfaceDefinition -> TypeName
interfaceName :: InterfaceDefinition -> TypeName
aliasName :: InterfaceDefinition -> TypeName
..}) =
    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 TypeName
aliasName)
      forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"m"
      forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"="
      forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"TypeGuard"
      forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall n. HSDoc n -> Doc n
unpack (forall a ann. Printer a => a -> HSDoc ann
print TypeName
interfaceName forall n. HSDoc n -> HSDoc n -> HSDoc n
.<> HSDoc ann
"m")
      forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall n. HSDoc n -> Doc n
unpack (forall a ann. Printer a => a -> HSDoc ann
print TypeName
unionName forall n. HSDoc n -> HSDoc n -> HSDoc n
.<> HSDoc ann
"m")
        forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
line
  pretty ScalarType {} = Doc ann
""
  pretty (DataType CodeGenType
cgType) = forall a ann. Pretty a => a -> Doc ann
pretty CodeGenType
cgType
  pretty (GQLTypeInstance Kind
kind TypeClassInstance ServerMethod
gql)
    | Kind
kind forall a. Eq a => a -> a -> Bool
== Kind
Scalar = Doc ann
""
    | Bool
otherwise = 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ServerMethod] -> ShowS
$cshowList :: [ServerMethod] -> ShowS
show :: ServerMethod -> String
$cshow :: ServerMethod -> String
showsPrec :: Int -> ServerMethod -> ShowS
$cshowsPrec :: Int -> ServerMethod -> ShowS
Show)

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

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