Emit list item errors once

4 files changed, 39 insertions, 16 deletions

diff --git a/CHANGELOG.md b/CHANGELOG.md
index 017a14c..eec1c07 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -14,6 +14,12 @@ and this project adheres to
 ### Fixed
 - Parser now accepts empty lists and objects.
 - Parser now accepts all directive locations.
+- `valuesOfCorrectTypeRule` doesn't check list items recursively since the
+  validation traverser calls it on all list items.
+
+### Changed
+- `AST.Document.Value.List` and `AST.Document.ConstValue.ConstList` contain
+  location information for each list item.
 
 ## [0.11.1.0] - 2021-02-07
 ### Added
diff --git a/src/Language/GraphQL/Validate/Rules.hs b/src/Language/GraphQL/Validate/Rules.hs
index ee2fdbe..905c2a7 100644
--- a/src/Language/GraphQL/Validate/Rules.hs
+++ b/src/Language/GraphQL/Validate/Rules.hs
@@ -1540,7 +1540,7 @@ valuesOfCorrectTypeRule = ValueRule go constGo
     go (Just inputType) value
         | Just constValue <- toConstNode value =
             lift $ check inputType constValue
-    go _ _ = lift mempty
+    go _ _ = lift mempty -- This rule checks only literals.
     toConstNode Full.Node{..} = flip Full.Node location <$> toConst node
     toConst (Full.Variable _) = Nothing
     toConst (Full.Int integer) = Just $ Full.ConstInt integer
@@ -1586,8 +1586,8 @@ valuesOfCorrectTypeRule = ValueRule go constGo
         , Full.ConstObject valueFields <- node =
             foldMap (checkObjectField typeFields) valueFields
     check (In.ListBaseType listType) constValue@Full.Node{ .. }
-        | Full.ConstList listValues <- node =
-            foldMap (check listType) listValues
+        -- Skip, lists are checked recursively by the validation traverser.
+        | Full.ConstList _ <- node = mempty
         | otherwise = check listType constValue
     check inputType Full.Node{ .. } = pure $ Error
         { message = concat
diff --git a/stack.yaml b/stack.yaml
index 85def2a..c4861c3 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -1,4 +1,4 @@
-resolver: lts-17.3
+resolver: lts-17.6
 
 packages:
 - .
diff --git a/tests/Language/GraphQL/Validate/RulesSpec.hs b/tests/Language/GraphQL/Validate/RulesSpec.hs
index 6f90436..ce12138 100644
--- a/tests/Language/GraphQL/Validate/RulesSpec.hs
+++ b/tests/Language/GraphQL/Validate/RulesSpec.hs
@@ -49,16 +49,18 @@ catType :: ObjectType IO
 catType = ObjectType "Cat" Nothing [petType] $ HashMap.fromList
     [ ("name", nameResolver)
     , ("nickname", nicknameResolver)
-    , ("doesKnowCommand", doesKnowCommandResolver)
+    , ("doesKnowCommands", doesKnowCommandsResolver)
     , ("meowVolume", meowVolumeResolver)
     ]
   where
     meowVolumeField = Field Nothing (Out.NamedScalarType int) mempty
     meowVolumeResolver = ValueResolver meowVolumeField $ pure $ Int 3
-    doesKnowCommandField = Field Nothing (Out.NonNullScalarType boolean)
-        $ HashMap.singleton "catCommand"
-        $ In.Argument Nothing (In.NonNullEnumType catCommandType) Nothing
-    doesKnowCommandResolver = ValueResolver doesKnowCommandField
+    doesKnowCommandsType = In.NonNullListType
+        $ In.NonNullEnumType catCommandType
+    doesKnowCommandsField = Field Nothing (Out.NonNullScalarType boolean)
+        $ HashMap.singleton "catCommands"
+        $ In.Argument Nothing doesKnowCommandsType Nothing
+    doesKnowCommandsResolver = ValueResolver doesKnowCommandsField
         $ pure $ Boolean True
 
 nameResolver :: Resolver IO
@@ -866,17 +868,17 @@ spec =
         context "variablesInAllowedPositionRule" $ do
             it "rejects wrongly typed variable arguments" $
                 let queryString = [r|
-                  query catCommandArgQuery($catCommandArg: CatCommand) {
-                    cat {
-                      doesKnowCommand(catCommand: $catCommandArg)
+                  query dogCommandArgQuery($dogCommandArg: DogCommand) {
+                    dog {
+                      doesKnowCommand(dogCommand: $dogCommandArg)
                     }
                   }
                 |]
                     expected = Error
                         { message =
-                            "Variable \"$catCommandArg\" of type \
-                            \\"CatCommand\" used in position expecting type \
-                            \\"!CatCommand\"."
+                            "Variable \"$dogCommandArg\" of type \
+                            \\"DogCommand\" used in position expecting type \
+                            \\"!DogCommand\"."
                         , locations = [AST.Location 2 44]
                         }
                  in validate queryString `shouldBe` [expected]
@@ -897,7 +899,7 @@ spec =
                         }
                  in validate queryString `shouldBe` [expected]
 
-        context "valuesOfCorrectTypeRule" $
+        context "valuesOfCorrectTypeRule" $ do
             it "rejects values of incorrect types" $
                 let queryString = [r|
                   {
@@ -912,3 +914,18 @@ spec =
                         , locations = [AST.Location 4 52]
                         }
                  in validate queryString `shouldBe` [expected]
+
+            it "uses the location of a single list value" $
+                let queryString = [r|
+                  {
+                    cat {
+                      doesKnowCommands(catCommands: [3])
+                    }
+                  }
+                |]
+                    expected = Error
+                        { message =
+                            "Value 3 cannot be coerced to type \"!CatCommand\"."
+                        , locations = [AST.Location 4 54]
+                        }
+                 in validate queryString `shouldBe` [expected]