Deprecate internal error generation functions

The functions generating errors in the executor should be changed anyway
when we provide better error messages from the executor, with the error
location and response path. So public definitions of these functions are
deprecated now and they are replaced by more generic functions in the
executor code.

7 files changed, 57 insertions, 30 deletions

diff --git a/CHANGELOG.md b/CHANGELOG.md
index ad90db9..b18668a 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -23,6 +23,8 @@ and this project adheres to
 ### Changed
 - `AST.Document.Value.List` and `AST.Document.ConstValue.ConstList` contain
   location information for each list item.
+- `Error`: `singleError`, `addErr` and `addErrMsg` are deprecated. They are
+  internal functions used by the executor for error handling.
 
 ## [0.11.1.0] - 2021-02-07
 ### Added
diff --git a/src/Language/GraphQL/Error.hs b/src/Language/GraphQL/Error.hs
index d3625a7..2061c20 100644
--- a/src/Language/GraphQL/Error.hs
+++ b/src/Language/GraphQL/Error.hs
@@ -69,21 +69,25 @@ parseError ParseErrorBundle{..}  =
 type CollectErrsT m = StateT (Resolution m) m
 
 -- | Adds an error to the list of errors.
+{-# DEPRECATED #-}
 addErr :: Monad m => Error -> CollectErrsT m ()
 addErr v = modify appender
   where
     appender :: Monad m => Resolution m -> Resolution m
     appender resolution@Resolution{..} = resolution{ errors = errors |> v }
 
+{-# DEPRECATED #-}
 makeErrorMessage :: Text -> Error
 makeErrorMessage s = Error s [] []
 
 -- | Constructs a response object containing only the error with the given
 -- message.
+{-# DEPRECATED #-}
 singleError :: Serialize a => Text -> Response a
-singleError message = Response null $ Seq.singleton $ makeErrorMessage message
+singleError message = Response null $ Seq.singleton $ Error message [] []
 
 -- | Convenience function for just wrapping an error message.
+{-# DEPRECATED #-}
 addErrMsg :: (Monad m, Serialize a) => Text -> CollectErrsT m a
 addErrMsg errorMessage = (addErr . makeErrorMessage) errorMessage >> pure null
 
diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs
index 3b262d5..6e46d7c 100644
--- a/src/Language/GraphQL/Execute.hs
+++ b/src/Language/GraphQL/Execute.hs
@@ -11,9 +11,10 @@ import Data.Text (Text)
 import Language.GraphQL.AST.Document (Document, Name)
 import Language.GraphQL.Execute.Coerce
 import Language.GraphQL.Execute.Execution
+import Language.GraphQL.Execute.Internal
 import qualified Language.GraphQL.Execute.Transform as Transform
 import qualified Language.GraphQL.Execute.Subscribe as Subscribe
-import Language.GraphQL.Error
+import Language.GraphQL.Error (ResponseEventStream, Response, runCollectErrs)
 import qualified Language.GraphQL.Type.Definition as Definition
 import qualified Language.GraphQL.Type.Out as Out
 import Language.GraphQL.Type.Schema
@@ -32,10 +33,7 @@ execute :: (MonadCatch m, VariableValue a, Serialize b)
     -> m (Either (ResponseEventStream m b) (Response b))
 execute schema' operationName subs document =
     case Transform.document schema' operationName subs document of
-        Left queryError -> pure
-            $ Right
-            $ singleError
-            $ Transform.queryError queryError
+        Left queryError -> pure $ singleError $ Transform.queryError queryError
         Right transformed -> executeRequest transformed
 
 executeRequest :: (MonadCatch m, Serialize a)
@@ -47,7 +45,7 @@ executeRequest (Transform.Document types' rootObjectType operation)
     | (Transform.Mutation _ fields) <- operation =
         Right <$> executeOperation types' rootObjectType fields
     | (Transform.Subscription _ fields) <- operation
-        = either (Right . singleError) Left
+        = either singleError Left
         <$> Subscribe.subscribe types' rootObjectType fields
 
 -- This is actually executeMutation, but we don't distinguish between queries
diff --git a/src/Language/GraphQL/Execute/Execution.hs b/src/Language/GraphQL/Execute/Execution.hs
index 38355ce..529c3b1 100644
--- a/src/Language/GraphQL/Execute/Execution.hs
+++ b/src/Language/GraphQL/Execute/Execution.hs
@@ -43,7 +43,7 @@ resolveFieldValue result args resolver =
         => ResolverException
         -> CollectErrsT m Type.Value
     handleFieldError e =
-        addErr (Error (Text.pack $ displayException e) [] []) >> pure Type.Null
+        addError Type.Null $ Error (Text.pack $ displayException e) [] []
     context = Type.Context
         { Type.arguments = Type.Arguments args
         , Type.values = result
@@ -98,7 +98,7 @@ executeField fieldResolver prev fields
         let Out.Field _ fieldType argumentDefinitions = fieldDefinition
         let (Transform.Field _ _ arguments' _ :| []) = fields
         case coerceArgumentValues argumentDefinitions arguments' of
-            Nothing -> addErrMsg "Argument coercing failed."
+            Nothing -> addError null $ Error "Argument coercing failed." [] []
             Just argumentValues -> do
                 answer <- resolveFieldValue prev argumentValues resolver
                 completeValue fieldType fields answer
@@ -124,7 +124,7 @@ completeValue outputType@(Out.EnumBaseType enumType) _ (Type.Enum enum) =
     let Type.EnumType _ _ enumMembers = enumType
      in if HashMap.member enum enumMembers
         then coerceResult outputType $ Enum enum
-        else addError $ Error "Enum value completion failed." [] []
+        else addError null $ Error "Enum value completion failed." [] []
 completeValue (Out.ObjectBaseType objectType) fields result =
     executeSelectionSet result objectType $ mergeSelectionSets fields
 completeValue (Out.InterfaceBaseType interfaceType) fields result
@@ -134,7 +134,8 @@ completeValue (Out.InterfaceBaseType interfaceType) fields result
         case concreteType of
             Just objectType -> executeSelectionSet result objectType
                 $ mergeSelectionSets fields
-            Nothing -> addErrMsg "Interface value completion failed."
+            Nothing -> addError null
+                $ Error "Interface value completion failed." [] []
 completeValue (Out.UnionBaseType unionType) fields result
     | Type.Object objectMap <- result = do
         let abstractType = Internal.AbstractUnionType unionType
@@ -142,8 +143,9 @@ completeValue (Out.UnionBaseType unionType) fields result
         case concreteType of
             Just objectType -> executeSelectionSet result objectType
                 $ mergeSelectionSets fields
-            Nothing -> addErrMsg "Union value completion failed."
-completeValue _ _ _ = addErrMsg "Value completion failed."
+            Nothing -> addError null
+                $ Error "Union value completion failed." [] []
+completeValue _ _ _ = addError null $ Error "Value completion failed." [] []
 
 mergeSelectionSets :: MonadCatch m
     => NonEmpty (Transform.Field m)
@@ -159,7 +161,7 @@ coerceResult :: (MonadCatch m, Serialize a)
     -> CollectErrsT m a
 coerceResult outputType result
     | Just serialized <- serialize outputType result = pure serialized
-    | otherwise = addErrMsg "Result coercion failed."
+    | otherwise = addError null $ Error "Result coercion failed." [] []
 
 -- | Takes an 'Out.ObjectType' and a list of 'Transform.Selection's and applies
 -- each field to each 'Transform.Selection'. Resolves into a value containing
diff --git a/src/Language/GraphQL/Execute/Internal.hs b/src/Language/GraphQL/Execute/Internal.hs
index 3b75da1..792a758 100644
--- a/src/Language/GraphQL/Execute/Internal.hs
+++ b/src/Language/GraphQL/Execute/Internal.hs
@@ -3,23 +3,34 @@
    obtain one at https://mozilla.org/MPL/2.0/. -}
 
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE ExplicitForAll #-}
 {-# LANGUAGE NamedFieldPuns #-}
 
 module Language.GraphQL.Execute.Internal
     ( addError
+    , singleError
     ) where
 
 import Control.Monad.Trans.State (modify)
 import Control.Monad.Catch (MonadCatch)
 import Data.Sequence ((|>))
-import Language.GraphQL.Error
+import Data.Text (Text)
 import Language.GraphQL.Execute.Coerce
+import Language.GraphQL.Error
+    ( CollectErrsT
+    , Error(..)
+    , Resolution(..)
+    , Response(..)
+    )
 import Prelude hiding (null)
 
-addError :: (Serialize a, MonadCatch m) => Error -> CollectErrsT m a
-addError error' = modify appender >> pure null
+addError :: MonadCatch m => forall a. a -> Error -> CollectErrsT m a
+addError returnValue error' = modify appender >> pure returnValue
   where
    appender :: Resolution m -> Resolution m
    appender resolution@Resolution{ errors } = resolution
        { errors = errors |> error'
        }
+
+singleError :: Serialize b => forall a. Text -> Either a (Response b)
+singleError message = Right $ Response null $ pure $ Error message [] []
diff --git a/src/Language/GraphQL/Execute/Subscribe.hs b/src/Language/GraphQL/Execute/Subscribe.hs
index 4f2a6a6..44be965 100644
--- a/src/Language/GraphQL/Execute/Subscribe.hs
+++ b/src/Language/GraphQL/Execute/Subscribe.hs
@@ -28,8 +28,6 @@ import qualified Language.GraphQL.Type as Type
 import qualified Language.GraphQL.Type.Out as Out
 import Language.GraphQL.Type.Schema
 
--- This is actually executeMutation, but we don't distinguish between queries
--- and mutations yet.
 subscribe :: (MonadCatch m, Serialize a)
     => HashMap Name (Type m)
     -> Out.ObjectType m
diff --git a/tests/Language/GraphQL/ErrorSpec.hs b/tests/Language/GraphQL/ErrorSpec.hs
index 38d7d3a..f64e70a 100644
--- a/tests/Language/GraphQL/ErrorSpec.hs
+++ b/tests/Language/GraphQL/ErrorSpec.hs
@@ -8,17 +8,29 @@ module Language.GraphQL.ErrorSpec
     ) where
 
 import qualified Data.Aeson as Aeson
-import qualified Data.Sequence as Seq
+import Data.List.NonEmpty (NonEmpty (..))
 import Language.GraphQL.Error
-import Test.Hspec ( Spec
-                  , describe
-                  , it
-                  , shouldBe
-                  )
+import Test.Hspec
+    ( Spec
+    , describe
+    , it
+    , shouldBe
+    )
+import Text.Megaparsec (PosState(..))
+import Text.Megaparsec.Error (ParseError(..), ParseErrorBundle(..))
+import Text.Megaparsec.Pos (SourcePos(..), mkPos)
 
 spec :: Spec
-spec = describe "singleError" $
-    it "constructs an error with the given message" $
-        let errors'' = Seq.singleton $ Error "Message." [] []
-            expected = Response Aeson.Null errors''
-         in singleError "Message." `shouldBe` expected
+spec = describe "parseError" $
+    it "generates response with a single error" $ do
+        let parseErrors = TrivialError 0 Nothing mempty :| []
+            posState = PosState
+                { pstateInput = ""
+                , pstateOffset = 0
+                , pstateSourcePos = SourcePos "" (mkPos 1) (mkPos 1)
+                , pstateTabWidth = mkPos 1
+                , pstateLinePrefix = ""
+                }
+        Response Aeson.Null actual <-
+            parseError (ParseErrorBundle parseErrors posState)
+        length actual `shouldBe` 1