{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# 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.Ext.Result
  ( Result (..),
  )
import Data.Morpheus.Parsing.Document.TypeSystem
  ( parseSchema,
  )
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 -> GQLResult (Schema CONST)
parseSchema ByteString
doc of
  Failure NonEmpty GQLError
errors -> String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (NonEmpty GQLError -> String
renderGQLErrors NonEmpty GQLError
errors)
  Success {Schema CONST
result :: forall err a. Result err a -> a
result :: Schema CONST
result, [GQLError]
warnings :: forall err a. Result err a -> [err]
warnings :: [GQLError]
warnings} -> [GQLError] -> Q ()
gqlWarnings [GQLError]
warnings Q () -> Q Exp -> Q Exp
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [|result|]