{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}

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

import Data.ByteString.Lazy.Char8 (ByteString, pack)
import Data.Morpheus.CodeGen.Server.Internal.AST
  ( CodeGenConfig (..),
    ServerDeclaration (..),
  )
import Data.Morpheus.CodeGen.Server.Interpreting.Transform
  ( parseServerTypeDefinitions,
  )
import Data.Morpheus.CodeGen.TH
  ( PrintDec (..),
  )
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 = Text -> String -> Q Exp
forall {a}. Text -> a
notHandled Text
"Expressions",
      quotePat :: String -> Q Pat
quotePat = Text -> String -> Q Pat
forall {a}. Text -> a
notHandled Text
"Patterns",
      quoteType :: String -> Q Type
quoteType = Text -> String -> Q Type
forall {a}. Text -> a
notHandled Text
"Types",
      quoteDec :: String -> Q [Dec]
quoteDec = CodeGenConfig -> ByteString -> Q [Dec]
compileDocument CodeGenConfig
ctx (ByteString -> Q [Dec])
-> (String -> ByteString) -> String -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
pack
    }
  where
    notHandled :: Text -> a
notHandled Text
things =
      Text -> a
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> a) -> Text -> a
forall a b. (a -> b) -> a -> b
$ Text
things Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" are not supported by the GraphQL QuasiQuoter"

compileDocument :: CodeGenConfig -> ByteString -> Q [Dec]
compileDocument :: CodeGenConfig -> ByteString -> Q [Dec]
compileDocument CodeGenConfig
config =
  CodeGenConfig -> ByteString -> Q ([ServerDeclaration], Flags)
forall (m :: * -> *).
CodeGenMonad m =>
CodeGenConfig -> ByteString -> m ([ServerDeclaration], Flags)
parseServerTypeDefinitions CodeGenConfig
config
    (ByteString -> Q ([ServerDeclaration], Flags))
-> (([ServerDeclaration], Flags) -> Q [Dec])
-> ByteString
-> Q [Dec]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec])
-> (([ServerDeclaration], Flags) -> Q [[Dec]])
-> ([ServerDeclaration], Flags)
-> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ServerDeclaration -> Q [Dec]) -> [ServerDeclaration] -> Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ServerDeclaration -> Q [Dec]
printServerDec ([ServerDeclaration] -> Q [[Dec]])
-> (([ServerDeclaration], Flags) -> [ServerDeclaration])
-> ([ServerDeclaration], Flags)
-> Q [[Dec]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([ServerDeclaration], Flags) -> [ServerDeclaration]
forall a b. (a, b) -> a
fst

printServerDec :: ServerDeclaration -> Q [Dec]
printServerDec :: ServerDeclaration -> Q [Dec]
printServerDec (InterfaceType InterfaceDefinition
interface) = Dec -> [Dec]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InterfaceDefinition -> Q Dec
forall a. PrintDec a => a -> Q Dec
printDec InterfaceDefinition
interface
printServerDec ScalarType {} = [Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
printServerDec (DataType CodeGenType
dataType) = Dec -> [Dec]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CodeGenType -> Q Dec
forall a. PrintDec a => a -> Q Dec
printDec CodeGenType
dataType
printServerDec (GQLTypeInstance Kind
_ TypeClassInstance ServerMethod
gql) = Dec -> [Dec]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeClassInstance ServerMethod -> Q Dec
forall a. PrintDec a => a -> Q Dec
printDec TypeClassInstance ServerMethod
gql
printServerDec (GQLDirectiveInstance TypeClassInstance ServerMethod
dir) = Dec -> [Dec]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeClassInstance ServerMethod -> Q Dec
forall a. PrintDec a => a -> Q Dec
printDec TypeClassInstance ServerMethod
dir