{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.CodeGen.Server.Printing.TH
  ( compileDocument,
    gqlDocument,
  )
where

import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Morpheus.CodeGen.Internal.AST (CodeGenTypeName (..))
import Data.Morpheus.CodeGen.Server.Internal.AST
  ( CodeGenConfig (..),
    GQLDirectiveTypeClass (..),
    GQLTypeDefinition (..),
    InterfaceDefinition (..),
    ServerDeclaration (..),
    ServerDirectiveUsage,
    TypeKind,
  )
import Data.Morpheus.CodeGen.Server.Interpreting.Transform
  ( parseServerTypeDefinitions,
  )
import Data.Morpheus.CodeGen.TH
  ( PrintExp (..),
    PrintType (..),
    ToName (..),
    apply,
    m',
    m_,
    printDec,
    printTypeClass,
    printTypeSynonym,
    toCon,
    _',
  )
import Data.Morpheus.Server.Types
  ( GQLDirective (..),
    GQLType (..),
    TypeGuard (..),
    dropNamespaceOptions,
  )
import Data.Morpheus.Types.Internal.AST (DirectiveLocation)
import Language.Haskell.TH
import Language.Haskell.TH.Quote (QuasiQuoter (..))
import Relude hiding (ByteString, Type)

gqlDocument :: QuasiQuoter
gqlDocument :: QuasiQuoter
gqlDocument = CodeGenConfig -> QuasiQuoter
mkQuasiQuoter CodeGenConfig {namespace :: Bool
namespace = Bool
False}

mkQuasiQuoter :: CodeGenConfig -> QuasiQuoter
mkQuasiQuoter :: CodeGenConfig -> QuasiQuoter
mkQuasiQuoter CodeGenConfig
ctx =
  QuasiQuoter
    { quoteExp :: String -> Q Exp
quoteExp = forall {a}. Text -> a
notHandled Text
"Expressions",
      quotePat :: String -> Q Pat
quotePat = forall {a}. Text -> a
notHandled Text
"Patterns",
      quoteType :: String -> Q Type
quoteType = forall {a}. Text -> a
notHandled Text
"Types",
      quoteDec :: String -> Q [Dec]
quoteDec = CodeGenConfig -> ByteString -> Q [Dec]
compileDocument CodeGenConfig
ctx forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
LB.pack
    }
  where
    notHandled :: Text -> a
notHandled Text
things =
      forall a t. (HasCallStack, IsText t) => t -> a
error forall a b. (a -> b) -> a -> b
$ Text
things forall a. Semigroup a => a -> a -> a
<> Text
" are not supported by the GraphQL QuasiQuoter"

compileDocument :: CodeGenConfig -> LB.ByteString -> Q [Dec]
compileDocument :: CodeGenConfig -> ByteString -> Q [Dec]
compileDocument CodeGenConfig
ctx = forall (m :: * -> *).
CodeGenMonad m =>
CodeGenConfig -> ByteString -> m [ServerDeclaration]
parseServerTypeDefinitions CodeGenConfig
ctx forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall a. PrintDecQ a => a -> Q [Dec]
printDecQ

class PrintDecQ a where
  printDecQ :: a -> Q [Dec]

instance PrintDecQ a => PrintDecQ [a] where
  printDecQ :: [a] -> Q [Dec]
printDecQ = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat 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. PrintDecQ a => a -> Q [Dec]
printDecQ

instance PrintDecQ InterfaceDefinition where
  printDecQ :: InterfaceDefinition -> Q [Dec]
printDecQ InterfaceDefinition {TypeName
unionName :: InterfaceDefinition -> TypeName
interfaceName :: InterfaceDefinition -> TypeName
aliasName :: InterfaceDefinition -> TypeName
unionName :: TypeName
interfaceName :: TypeName
aliasName :: TypeName
..} =
    forall (f :: * -> *) a. Applicative f => a -> f a
pure [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']])]

instance PrintDecQ GQLTypeDefinition where
  printDecQ :: GQLTypeDefinition -> Q [Dec]
printDecQ GQLTypeDefinition {[ServerDirectiveUsage]
Maybe (TypeKind, Text)
Map Text (Value CONST)
CodeGenTypeName
Kind
dropNamespace :: GQLTypeDefinition -> Maybe (TypeKind, Text)
gqlTypeDefaultValues :: GQLTypeDefinition -> Map Text (Value CONST)
gqlTypeDirectiveUses :: GQLTypeDefinition -> [ServerDirectiveUsage]
gqlKind :: GQLTypeDefinition -> Kind
gqlTarget :: GQLTypeDefinition -> CodeGenTypeName
dropNamespace :: Maybe (TypeKind, Text)
gqlTypeDefaultValues :: Map Text (Value CONST)
gqlTypeDirectiveUses :: [ServerDirectiveUsage]
gqlKind :: Kind
gqlTarget :: CodeGenTypeName
..} = do
    let params :: [Name]
params = forall a b. (a -> b) -> [a] -> [b]
map forall a. ToName a => a -> Name
toName (CodeGenTypeName -> [Text]
typeParameters CodeGenTypeName
gqlTarget)
    [(Name, Type)]
associatedTypes <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. (''KIND,)) (forall a. PrintType a => a -> Q Type
printType Kind
gqlKind)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Name, Name)]
-> Name
-> Q Type
-> [(Name, Type)]
-> [(Name, [Q Pat], Q Exp)]
-> Q Dec
printTypeClass (forall a b. (a -> b) -> [a] -> [b]
map (''Typeable,) [Name]
params) ''GQLType (forall a. PrintType a => a -> Q Type
printType CodeGenTypeName
gqlTarget) [(Name, Type)]
associatedTypes [(Name, [Q Pat], Q Exp)]
methods
    where
      methods :: [(Name, [Q Pat], Q Exp)]
methods =
        [ ('defaultValues, [Q Pat
_'], [|gqlTypeDefaultValues|]),
          ('directives, [Q Pat
_'], [ServerDirectiveUsage] -> Q Exp
printDirectiveUsages [ServerDirectiveUsage]
gqlTypeDirectiveUses)
        ]
          forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map (TypeKind, Text) -> (Name, [Q Pat], Q Exp)
printTypeOptions (forall a. Maybe a -> [a]
maybeToList Maybe (TypeKind, Text)
dropNamespace)

instance PrintDecQ ServerDeclaration where
  printDecQ :: ServerDeclaration -> Q [Dec]
printDecQ (InterfaceType InterfaceDefinition
interface) = forall a. PrintDecQ a => a -> Q [Dec]
printDecQ InterfaceDefinition
interface
  printDecQ ScalarType {} = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  printDecQ (DataType CodeGenType
dataType) = forall (f :: * -> *) a. Applicative f => a -> f a
pure [forall a. PrintDec a => a -> Dec
printDec CodeGenType
dataType]
  printDecQ (GQLTypeInstance GQLTypeDefinition
gql) = forall a. PrintDecQ a => a -> Q [Dec]
printDecQ GQLTypeDefinition
gql
  printDecQ (GQLDirectiveInstance GQLDirectiveTypeClass
dir) = forall a. PrintDecQ a => a -> Q [Dec]
printDecQ GQLDirectiveTypeClass
dir

instance PrintDecQ GQLDirectiveTypeClass where
  printDecQ :: GQLDirectiveTypeClass -> Q [Dec]
printDecQ GQLDirectiveTypeClass {[DirectiveLocation]
CodeGenTypeName
directiveLocations :: GQLDirectiveTypeClass -> [DirectiveLocation]
directiveTypeName :: GQLDirectiveTypeClass -> CodeGenTypeName
directiveLocations :: [DirectiveLocation]
directiveTypeName :: CodeGenTypeName
..} =
    forall (f :: * -> *) a. Applicative f => a -> f a
pure
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Name, Name)]
-> Name
-> Q Type
-> [(Name, Type)]
-> [(Name, [Q Pat], Q Exp)]
-> Q Dec
printTypeClass
        []
        ''GQLDirective
        (forall a b. ToCon a b => a -> b
toCon CodeGenTypeName
directiveTypeName)
        [(''DIRECTIVE_LOCATIONS, [DirectiveLocation] -> Type
promotedList [DirectiveLocation]
directiveLocations)]
        []

promotedList :: [DirectiveLocation] -> Type
promotedList :: [DirectiveLocation] -> Type
promotedList = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Type -> Type -> Type
AppT forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type -> Type
AppT Type
PromotedConsT forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Type
PromotedT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToName a => a -> Name
toName) Type
PromotedNilT

printTypeOptions :: (TypeKind, Text) -> (Name, [PatQ], ExpQ)
printTypeOptions :: (TypeKind, Text) -> (Name, [Q Pat], Q Exp)
printTypeOptions (TypeKind
kind, Text
tName) = ('typeOptions, [Q Pat
_'], [|dropNamespaceOptions kind tName|])

printDirectiveUsages :: [ServerDirectiveUsage] -> ExpQ
printDirectiveUsages :: [ServerDirectiveUsage] -> Q Exp
printDirectiveUsages = 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 -> Q Exp
printExp) [|mempty|]