{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Language.GraphQL.Error
( parseError
, CollectErrsT
, addErr
, addErrMsg
, runCollectErrs
, runAppendErrs
, singleError
) where
import qualified Data.Aeson as Aeson
import Data.Text (Text)
import Data.Void (Void)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State ( StateT
, modify
, runStateT
)
import Text.Megaparsec ( ParseErrorBundle(..)
, SourcePos(..)
, errorOffset
, parseErrorTextPretty
, reachOffset
, unPos
)
parseError :: Applicative f => ParseErrorBundle Text Void -> f Aeson.Value
parseError ParseErrorBundle{..} =
pure $ Aeson.object [("errors", Aeson.toJSON $ fst $ foldl go ([], bundlePosState) bundleErrors)]
where
errorObject s SourcePos{..} = Aeson.object
[ ("message", Aeson.toJSON $ init $ parseErrorTextPretty s)
, ("line", Aeson.toJSON $ unPos sourceLine)
, ("column", Aeson.toJSON $ unPos sourceColumn)
]
go (result, state) x =
let (sourcePosition, _, newState) = reachOffset (errorOffset x) state
in (errorObject x sourcePosition : result, newState)
type CollectErrsT m = StateT [Aeson.Value] m
addErr :: Monad m => Aeson.Value -> CollectErrsT m ()
addErr v = modify (v :)
makeErrorMessage :: Text -> Aeson.Value
makeErrorMessage s = Aeson.object [("message", Aeson.toJSON s)]
singleError :: Text -> Aeson.Value
singleError message = Aeson.object
[ ("errors", Aeson.toJSON [makeErrorMessage message])
]
addErrMsg :: Monad m => Text -> CollectErrsT m ()
addErrMsg = addErr . makeErrorMessage
appendErrs :: Monad m => [Aeson.Value] -> CollectErrsT m ()
appendErrs errs = modify (errs ++)
runCollectErrs :: Monad m => CollectErrsT m Aeson.Value -> m Aeson.Value
runCollectErrs res = do
(dat, errs) <- runStateT res []
if null errs
then return $ Aeson.object [("data", dat)]
else return $ Aeson.object [("data", dat), ("errors", Aeson.toJSON $ reverse errs)]
runAppendErrs :: Monad m => CollectErrsT m a -> CollectErrsT m a
runAppendErrs f = do
(v, errs) <- lift $ runStateT f []
appendErrs errs
return v