From 5cf10b38ec95d60922caf6cf0c9a6fd1cb0e54e4 Mon Sep 17 00:00:00 2001
From: Eugen Wissner <belka@caraus.de>
Date: Fri, 19 Jul 2019 06:38:54 +0200
Subject: [PATCH] Report parse errors with line and column numbers

---
 src/Language/GraphQL.hs       |  6 ++----
 src/Language/GraphQL/Error.hs | 26 ++++++++++++++++++++++----
 2 files changed, 24 insertions(+), 8 deletions(-)

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