Fail with a location for result coercion

The intermediate representation was further modified so that the
operation definitions contain location information. Probably I should
introduce a data type that generalizes fields and operations, so it
contains object type, location and the selection set, so the functions
don't accept so many arguments.

src/Language/GraphQL/Execute.hs

@@ -8,7 +8,7 @@ import Control.Monad.Catch (MonadCatch)
 import Data.HashMap.Strict (HashMap)
 import Data.Sequence (Seq(..))
 import Data.Text (Text)
-import Language.GraphQL.AST.Document (Document, Name)
+import qualified Language.GraphQL.AST.Document as Full
 import Language.GraphQL.Execute.Coerce
 import Language.GraphQL.Execute.Execution
 import Language.GraphQL.Execute.Internal
@@ -28,8 +28,8 @@ import Language.GraphQL.Type.Schema
 execute :: (MonadCatch m, VariableValue a, Serialize b)
     => Schema m -- ^ Resolvers.
     -> Maybe Text -- ^ Operation name.
-    -> HashMap Name a -- ^ Variable substitution function.
+    -> HashMap Full.Name a -- ^ Variable substitution function.
-    -> Document -- @GraphQL@ document.
+    -> Full.Document -- @GraphQL@ document.
     -> m (Either (ResponseEventStream m b) (Response b))
 execute schema' operationName subs document =
     case Transform.document schema' operationName subs document of
@@ -40,20 +40,22 @@ executeRequest :: (MonadCatch m, Serialize a)
     => Transform.Document m
     -> m (Either (ResponseEventStream m a) (Response a))
 executeRequest (Transform.Document types' rootObjectType operation)
-    | (Transform.Query _ fields) <- operation =
+    | (Transform.Query _ fields objectLocation) <- operation =
-        Right <$> executeOperation types' rootObjectType fields
+        Right <$> executeOperation types' rootObjectType objectLocation fields
-    | (Transform.Mutation _ fields) <- operation =
+    | (Transform.Mutation _ fields objectLocation) <- operation =
-        Right <$> executeOperation types' rootObjectType fields
+        Right <$> executeOperation types' rootObjectType objectLocation fields
-    | (Transform.Subscription _ fields) <- operation
+    | (Transform.Subscription _ fields objectLocation) <- operation
         = either singleError Left
-        <$> Subscribe.subscribe types' rootObjectType fields
+        <$> Subscribe.subscribe types' rootObjectType objectLocation fields
 
 -- This is actually executeMutation, but we don't distinguish between queries
 -- and mutations yet.
 executeOperation :: (MonadCatch m, Serialize a)
-    => HashMap Name (Type m)
+    => HashMap Full.Name (Type m)
     -> Out.ObjectType m
+    -> Full.Location
     -> Seq (Transform.Selection m)
     -> m (Response a)
-executeOperation types' objectType fields =
+executeOperation types' objectType objectLocation fields
-    runCollectErrs types' $ executeSelectionSet Definition.Null objectType fields
+    = runCollectErrs types'
+    $ executeSelectionSet Definition.Null objectType objectLocation fields

src/Language/GraphQL/Execute/Execution.hs

@@ -117,41 +117,42 @@ completeValue :: (MonadCatch m, Serialize a)
 completeValue (Out.isNonNullType -> False) _ Type.Null = pure null
 completeValue outputType@(Out.ListBaseType listType) fields (Type.List list)
     = traverse (completeValue listType fields) list
-    >>= coerceResult outputType . List
+    >>= coerceResult outputType (firstFieldLocation fields) . List
-completeValue outputType@(Out.ScalarBaseType _) _ (Type.Int int) =
+completeValue outputType@(Out.ScalarBaseType _) fields (Type.Int int) =
-    coerceResult outputType $ Int int
+    coerceResult outputType (firstFieldLocation fields) $ Int int
-completeValue outputType@(Out.ScalarBaseType _) _ (Type.Boolean boolean) =
+completeValue outputType@(Out.ScalarBaseType _) fields (Type.Boolean boolean) =
-    coerceResult outputType $ Boolean boolean
+    coerceResult outputType (firstFieldLocation fields) $ Boolean boolean
-completeValue outputType@(Out.ScalarBaseType _) _ (Type.Float float) =
+completeValue outputType@(Out.ScalarBaseType _) fields (Type.Float float) =
-    coerceResult outputType $ Float float
+    coerceResult outputType (firstFieldLocation fields) $ Float float
-completeValue outputType@(Out.ScalarBaseType _) _ (Type.String string) =
+completeValue outputType@(Out.ScalarBaseType _) fields (Type.String string) =
-    coerceResult outputType $ String string
+    coerceResult outputType (firstFieldLocation fields) $ String string
 completeValue outputType@(Out.EnumBaseType enumType) fields (Type.Enum enum) =
     let Type.EnumType _ _ enumMembers = enumType
-        Transform.Field _ _ _ _ location = NonEmpty.head fields
+        location = firstFieldLocation fields
      in if HashMap.member enum enumMembers
-        then coerceResult outputType $ Enum enum
+        then coerceResult outputType location $ Enum enum
         else addError null $ Error "Enum value completion failed." [location] []
-completeValue (Out.ObjectBaseType objectType) fields result =
+completeValue (Out.ObjectBaseType objectType) fields result
-    executeSelectionSet result objectType $ mergeSelectionSets fields
+    = executeSelectionSet result objectType (firstFieldLocation fields)
+    $ mergeSelectionSets fields
 completeValue (Out.InterfaceBaseType interfaceType) fields result
     | Type.Object objectMap <- result = do
         let abstractType = Internal.AbstractInterfaceType interfaceType
-        let Transform.Field _ _ _ _ location = NonEmpty.head fields
+        let location = firstFieldLocation fields
         concreteType <- resolveAbstractType abstractType objectMap
         case concreteType of
-            Just objectType -> executeSelectionSet result objectType
+            Just objectType -> executeSelectionSet result objectType location
                 $ mergeSelectionSets fields
             Nothing -> addError null
                 $ Error "Interface value completion failed." [location] []
 completeValue (Out.UnionBaseType unionType) fields result
     | Type.Object objectMap <- result = do
         let abstractType = Internal.AbstractUnionType unionType
-        let Transform.Field _ _ _ _ location = NonEmpty.head fields
+        let  location = firstFieldLocation fields
         concreteType <- resolveAbstractType abstractType objectMap
         case concreteType of
             Just objectType -> executeSelectionSet result objectType
-                $ mergeSelectionSets fields
+                location $ mergeSelectionSets fields
             Nothing -> addError null
                 $ Error "Union value completion failed." [location] []
 completeValue _ (Transform.Field _ _ _ _ location :| _) _ =
@@ -165,13 +166,18 @@ mergeSelectionSets = foldr forEach mempty
     forEach (Transform.Field _ _ _ fieldSelectionSet _) selectionSet =
         selectionSet <> fieldSelectionSet
 
+firstFieldLocation :: MonadCatch m => NonEmpty (Transform.Field m) -> Full.Location
+firstFieldLocation (Transform.Field _ _ _ _ fieldLocation :| _) = fieldLocation
+
 coerceResult :: (MonadCatch m, Serialize a)
     => Out.Type m
+    -> Full.Location
     -> Output a
     -> CollectErrsT m a
-coerceResult outputType result
+coerceResult outputType parentLocation result
     | Just serialized <- serialize outputType result = pure serialized
-    | otherwise = addError null $ Error "Result coercion failed." [] []
+    | otherwise = addError null
+        $ Error "Result coercion failed." [parentLocation] []
 
 -- | Takes an 'Out.ObjectType' and a list of 'Transform.Selection's and applies
 -- each field to each 'Transform.Selection'. Resolves into a value containing
@@ -179,12 +185,14 @@ coerceResult outputType result
 executeSelectionSet :: (MonadCatch m, Serialize a)
     => Type.Value
     -> Out.ObjectType m
+    -> Full.Location
     -> Seq (Transform.Selection m)
     -> CollectErrsT m a
-executeSelectionSet result objectType@(Out.ObjectType _ _ _ resolvers) selectionSet = do
+executeSelectionSet result objectType@(Out.ObjectType _ _ _ resolvers) objectLocation selectionSet = do
     let fields = collectFields objectType selectionSet
     resolvedValues <- OrderedMap.traverseMaybe forEach fields
-    coerceResult (Out.NonNullObjectType objectType) $ Object resolvedValues
+    coerceResult (Out.NonNullObjectType objectType) objectLocation
+        $ Object resolvedValues
   where
     forEach fields@(field :| _) =
         let Transform.Field _ name _ _ _ = field

src/Language/GraphQL/Execute/Subscribe.hs

@@ -15,7 +15,7 @@ import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
 import qualified Data.List.NonEmpty as NonEmpty
 import Data.Sequence (Seq(..))
-import Language.GraphQL.AST (Name)
+import qualified Language.GraphQL.AST as Full
 import Language.GraphQL.Execute.Coerce
 import Language.GraphQL.Execute.Execution
 import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap
@@ -27,26 +27,31 @@ import qualified Language.GraphQL.Type.Out as Out
 import Language.GraphQL.Type.Schema
 
 subscribe :: (MonadCatch m, Serialize a)
-    => HashMap Name (Type m)
+    => HashMap Full.Name (Type m)
     -> Out.ObjectType m
+    -> Full.Location
     -> Seq (Transform.Selection m)
     -> m (Either String (ResponseEventStream m a))
-subscribe types' objectType fields = do
+subscribe types' objectType objectLocation fields = do
     sourceStream <- createSourceEventStream types' objectType fields
-    traverse (mapSourceToResponseEvent types' objectType fields) sourceStream
+    let traverser =
+            mapSourceToResponseEvent types' objectType objectLocation fields
+    traverse traverser sourceStream
 
 mapSourceToResponseEvent :: (MonadCatch m, Serialize a)
-    => HashMap Name (Type m)
+    => HashMap Full.Name (Type m)
     -> Out.ObjectType m
+    -> Full.Location
     -> Seq (Transform.Selection m)
     -> Out.SourceEventStream m
     -> m (ResponseEventStream m a)
-mapSourceToResponseEvent types' subscriptionType fields sourceStream = pure
+mapSourceToResponseEvent types' subscriptionType objectLocation fields sourceStream
+    = pure
     $ sourceStream
-    .| mapMC (executeSubscriptionEvent types' subscriptionType fields)
+    .| mapMC (executeSubscriptionEvent types' subscriptionType objectLocation fields)
 
 createSourceEventStream :: MonadCatch m
-    => HashMap Name (Type m)
+    => HashMap Full.Name (Type m)
     -> Out.ObjectType m
     -> Seq (Transform.Selection m)
     -> m (Either String (Out.SourceEventStream m))
@@ -82,10 +87,12 @@ resolveFieldEventStream result args resolver =
         }
 
 executeSubscriptionEvent :: (MonadCatch m, Serialize a)
-    => HashMap Name (Type m)
+    => HashMap Full.Name (Type m)
     -> Out.ObjectType m
+    -> Full.Location
     -> Seq (Transform.Selection m)
     -> Definition.Value
     -> m (Response a)
-executeSubscriptionEvent types' objectType fields initialValue =
+executeSubscriptionEvent types' objectType objectLocation fields initialValue
-    runCollectErrs types' $ executeSelectionSet initialValue objectType fields
+    = runCollectErrs types'
+    $ executeSelectionSet initialValue objectType objectLocation fields

src/Language/GraphQL/Execute/Transform.hs

@@ -75,9 +75,9 @@ data Selection m
 
 -- | GraphQL has 3 operation types: queries, mutations and subscribtions.
 data Operation m
-    = Query (Maybe Text) (Seq (Selection m))
+    = Query (Maybe Text) (Seq (Selection m)) Full.Location
-    | Mutation (Maybe Text) (Seq (Selection m))
+    | Mutation (Maybe Text) (Seq (Selection m)) Full.Location
-    | Subscription (Maybe Text) (Seq (Selection m))
+    | Subscription (Maybe Text) (Seq (Selection m)) Full.Location
 
 -- | Single GraphQL field.
 data Field m = Field
@@ -97,6 +97,7 @@ data OperationDefinition = OperationDefinition
     [Full.VariableDefinition]
     [Full.Directive]
     Full.SelectionSet
+    Full.Location
 
 -- | Query error types.
 data QueryError
@@ -138,7 +139,7 @@ getOperation (Just operationName) operations
     | Just operation' <- find matchingName operations = pure operation'
     | otherwise = Left $ OperationNotFound operationName
   where
-    matchingName (OperationDefinition _ name _ _ _) =
+    matchingName (OperationDefinition _ name _ _ _ _) =
         name == Just operationName
 
 coerceVariableValues :: Coerce.VariableValue a
@@ -148,7 +149,7 @@ coerceVariableValues :: Coerce.VariableValue a
     -> HashMap.HashMap Full.Name a
     -> Either QueryError Type.Subs
 coerceVariableValues types operationDefinition variableValues =
-    let OperationDefinition _ _ variableDefinitions _ _ = operationDefinition
+    let OperationDefinition _ _ variableDefinitions _ _ _ = operationDefinition
      in maybe (Left CoercionError) Right
         $ foldr forEach (Just HashMap.empty) variableDefinitions
   where
@@ -206,14 +207,14 @@ document schema operationName subs ast = do
             , types = referencedTypes
             }
     case chosenOperation of
-        OperationDefinition Full.Query _ _ _ _ ->
+        OperationDefinition Full.Query _ _ _ _ _ ->
             pure $ Document referencedTypes (Schema.query schema)
                 $ operation chosenOperation replacement
-        OperationDefinition Full.Mutation _ _ _ _
+        OperationDefinition Full.Mutation _ _ _ _ _
             | Just mutationType <- Schema.mutation schema ->
                 pure $ Document referencedTypes mutationType
                     $ operation chosenOperation replacement
-        OperationDefinition Full.Subscription _ _ _ _
+        OperationDefinition Full.Subscription _ _ _ _ _
             | Just subscriptionType <- Schema.subscription schema ->
                 pure $ Document referencedTypes subscriptionType
                     $ operation chosenOperation replacement
@@ -238,10 +239,10 @@ defragment ast =
             (operations, HashMap.insert name fragment fragments')
     defragment' _ acc = acc
     transform = \case
-        Full.OperationDefinition type' name variables directives' selections _ ->
+        Full.OperationDefinition type' name variables directives' selections location ->
-            OperationDefinition type' name variables directives' selections
+            OperationDefinition type' name variables directives' selections location
-        Full.SelectionSet selectionSet _ ->
+        Full.SelectionSet selectionSet location ->
-            OperationDefinition Full.Query Nothing mempty mempty selectionSet
+            OperationDefinition Full.Query Nothing mempty mempty selectionSet location
 
 -- * Operation
 
@@ -250,12 +251,12 @@ operation operationDefinition replacement
     = runIdentity
     $ evalStateT (collectFragments >> transform operationDefinition) replacement
   where
-    transform (OperationDefinition Full.Query name _ _ sels) =
+    transform (OperationDefinition Full.Query name _ _ sels location) =
-        Query name <$> appendSelection sels
+        flip (Query name) location <$> appendSelection sels
-    transform (OperationDefinition Full.Mutation name _ _ sels) =
+    transform (OperationDefinition Full.Mutation name _ _ sels location) =
-        Mutation name <$> appendSelection sels
+        flip (Mutation name) location <$> appendSelection sels
-    transform (OperationDefinition Full.Subscription name _ _ sels) =
+    transform (OperationDefinition Full.Subscription name _ _ sels location) =
-        Subscription name <$> appendSelection sels
+        flip (Subscription name) location <$> appendSelection sels
 
 -- * Selection
 

tests/Language/GraphQL/ExecuteSpec.hs

@@ -82,6 +82,7 @@ philosopherType = Out.ObjectType "Philosopher" Nothing []
         , ("school", ValueResolver schoolField schoolResolver)
         , ("interest", ValueResolver interestField interestResolver)
         , ("majorWork", ValueResolver majorWorkField majorWorkResolver)
+        , ("century", ValueResolver centuryField centuryResolver)
         ]
     firstNameField =
         Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
@@ -104,6 +105,9 @@ philosopherType = Out.ObjectType "Philosopher" Nothing []
         $ HashMap.fromList
             [ ("title", "Also sprach Zarathustra: Ein Buch für Alle und Keinen")
             ]
+    centuryField =
+        Out.Field Nothing (Out.NonNullScalarType int) HashMap.empty
+    centuryResolver = pure $ Float 18.5
 
 workType :: Out.InterfaceType (Either SomeException)
 workType = Out.InterfaceType "Work" Nothing []
@@ -268,6 +272,22 @@ spec =
                         $ parse document "" "{ philosopher(id: true) { lastName } }"
                 in actual `shouldBe` expected
 
+            it "gives location information for failed result coercion" $
+                let data'' = Aeson.object
+                        [ "philosopher" .= Aeson.object
+                            [ "century" .= Aeson.Null
+                            ]
+                        ]
+                    executionErrors = pure $ Error
+                        { message = "Result coercion failed."
+                        , locations = [Location 1 26]
+                        , path = []
+                        }
+                    expected = Response data'' executionErrors
+                    Right (Right actual) = either (pure . parseError) execute'
+                        $ parse document "" "{ philosopher(id: \"1\") { century } }"
+                in actual `shouldBe` expected
+
         context "Subscription" $
             it "subscribes" $
                 let data'' = Aeson.object