{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Schema.DSL (dsl) where

import Data.ByteString.Lazy.Char8
  ( ByteString,
    pack,
  )
import Data.Morpheus.Error
  ( gqlWarnings,
    renderGQLErrors,
  )
import Data.Morpheus.Parsing.Document.TypeSystem
  ( parseSchema,
  )
import Data.Morpheus.Types.Internal.Resolving
  ( Result (..),
  )
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Relude hiding (ByteString)

dsl :: QuasiQuoter
dsl :: QuasiQuoter
dsl =
  QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
    { quoteExp :: String -> Q Exp
quoteExp = ByteString -> Q Exp
dslExpression (ByteString -> Q Exp) -> (String -> ByteString) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
pack,
      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 = Text -> String -> Q [Dec]
forall a. Text -> a
notHandled Text
"Declarations"
    }
  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"

dslExpression :: ByteString -> Q Exp
dslExpression :: ByteString -> Q Exp
dslExpression ByteString
doc = case ByteString -> Eventless (Schema CONST)
parseSchema ByteString
doc of
  Failure GQLErrors
errors -> String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (GQLErrors -> String
renderGQLErrors GQLErrors
errors)
  Success {Schema CONST
result :: forall events a. Result events a -> a
result :: Schema CONST
result, GQLErrors
warnings :: forall events a. Result events a -> GQLErrors
warnings :: GQLErrors
warnings} -> GQLErrors -> Q ()
gqlWarnings GQLErrors
warnings Q () -> Q Exp -> Q Exp
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [|result|]