diff --git a/src/Language/GraphQL.hs b/src/Language/GraphQL.hs index 7a0163d..7ac08d7 100644 --- a/src/Language/GraphQL.hs +++ b/src/Language/GraphQL.hs @@ -8,9 +8,7 @@ import Control.Monad.IO.Class (MonadIO) import qualified Data.Text as T import qualified Data.Aeson as Aeson -import Text.Megaparsec ( errorBundlePretty - , parse - ) +import Text.Megaparsec (parse) import Language.GraphQL.Execute import Language.GraphQL.Parser @@ -34,5 +32,5 @@ graphql = flip graphqlSubs $ const Nothing -- Returns the response as an @Aeson.@'Aeson.Value'. graphqlSubs :: MonadIO m => Schema m -> Subs -> T.Text -> m Aeson.Value graphqlSubs schema f = - either (parseError . errorBundlePretty) (execute schema f) + either parseError (execute schema f) . parse document "" diff --git a/src/Language/GraphQL/Error.hs b/src/Language/GraphQL/Error.hs index 8289f79..69fc8db 100644 --- a/src/Language/GraphQL/Error.hs +++ b/src/Language/GraphQL/Error.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Language.GraphQL.Error ( parseError , CollectErrsT @@ -9,17 +10,34 @@ module Language.GraphQL.Error ) where import qualified Data.Aeson as Aeson -import Data.Text (Text, pack) +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 + ) -- | Wraps a parse error into a list of errors. -parseError :: Applicative f => String -> f Aeson.Value -parseError s = - pure $ Aeson.object [("errors", Aeson.toJSON [makeErrorMsg $ pack s])] +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) -- | A wrapper to pass error messages around. type CollectErrsT m = StateT [Aeson.Value] m