{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Server.TH.Compile
  ( compileDocument,
    gqlDocument,
    gqlDocumentNamespace,
  )
where

--
--  Morpheus

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