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: Report parse errors with line and column numbers

---
 src/Language/GraphQL/Error.hs | 26 ++++++++++++++++++++++----
 1 file changed, 22 insertions(+), 4 deletions(-)

(limited to 'src/Language/GraphQL/Error.hs')

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
-- 
cgit v1.2.3