{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Data.Morpheus.Server.TH.Compile
( compileDocument,
gqlDocument,
gqlDocumentNamespace,
)
where
import qualified Data.ByteString.Lazy.Char8 as LB
( pack,
)
import Data.Morpheus.App.Internal.Resolving
( Result (..),
)
import Data.Morpheus.Core
( parseTypeDefinitions,
)
import Data.Morpheus.Error
( gqlWarnings,
renderGQLErrors,
)
import Data.Morpheus.Server.Internal.TH.Types
( ServerDecContext (..),
)
import Data.Morpheus.Server.TH.Declare
( declare,
)
import Data.Morpheus.Server.TH.Transform
( toTHDefinitions,
)
import Language.Haskell.TH (Dec, Q)
import Language.Haskell.TH.Quote (QuasiQuoter (..))
import Relude
gqlDocumentNamespace :: QuasiQuoter
gqlDocumentNamespace :: QuasiQuoter
gqlDocumentNamespace =
QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
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 = ServerDecContext -> String -> Q [Dec]
compileDocument ServerDecContext :: Bool -> ServerDecContext
ServerDecContext {namespace :: Bool
namespace = Bool
True}
}
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"
gqlDocument :: QuasiQuoter
gqlDocument :: QuasiQuoter
gqlDocument =
QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
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 = ServerDecContext -> String -> Q [Dec]
compileDocument ServerDecContext :: Bool -> ServerDecContext
ServerDecContext {namespace :: Bool
namespace = Bool
False}
}
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 :: ServerDecContext -> String -> Q [Dec]
compileDocument :: ServerDecContext -> String -> Q [Dec]
compileDocument ServerDecContext
ctx String
documentTXT =
case ByteString -> Eventless [TypeDefinition ANY CONST]
parseTypeDefinitions (String -> ByteString
LB.pack String
documentTXT) of
Failure GQLErrors
errors -> String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (GQLErrors -> String
renderGQLErrors GQLErrors
errors)
Success {result :: forall events a. Result events a -> a
result = [TypeDefinition ANY CONST]
schema, GQLErrors
warnings :: forall events a. Result events a -> GQLErrors
warnings :: GQLErrors
warnings} ->
GQLErrors -> Q ()
gqlWarnings GQLErrors
warnings Q () -> Q [TypeDec CONST] -> Q [TypeDec CONST]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> [TypeDefinition ANY CONST] -> Q [TypeDec CONST]
forall (s :: Stage).
Bool -> [TypeDefinition ANY s] -> Q [TypeDec s]
toTHDefinitions (ServerDecContext -> Bool
namespace ServerDecContext
ctx) [TypeDefinition ANY CONST]
schema Q [TypeDec CONST] -> ([TypeDec CONST] -> Q [Dec]) -> Q [Dec]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ServerDecContext -> [TypeDec CONST] -> Q [Dec]
forall a. Declare a => ServerDecContext -> a -> Q [Dec]
declare ServerDecContext
ctx