Validate field selections on composite types

4 files changed, 111 insertions, 111 deletions

diff --git a/tests/Language/GraphQL/ValidateSpec.hs b/tests/Language/GraphQL/ValidateSpec.hs
index 75e78d4..9127a94 100644
--- a/tests/Language/GraphQL/ValidateSpec.hs
+++ b/tests/Language/GraphQL/ValidateSpec.hs
@@ -9,8 +9,7 @@ module Language.GraphQL.ValidateSpec
     ( spec
     ) where
 
-import Data.Sequence (Seq(..))
-import qualified Data.Sequence as Seq
+import Data.Foldable (toList)
 import qualified Data.HashMap.Strict as HashMap
 import Data.Text (Text)
 import qualified Language.GraphQL.AST as AST
@@ -18,7 +17,7 @@ import Language.GraphQL.Type
 import qualified Language.GraphQL.Type.In as In
 import qualified Language.GraphQL.Type.Out as Out
 import Language.GraphQL.Validate
-import Test.Hspec (Spec, describe, it, shouldBe)
+import Test.Hspec (Spec, describe, it, shouldBe, shouldContain)
 import Text.Megaparsec (parse)
 import Text.RawString.QQ (r)
 
@@ -30,11 +29,17 @@ schema = Schema
     } 
 
 queryType :: ObjectType IO
-queryType = ObjectType "Query" Nothing []
-    $ HashMap.singleton "dog" dogResolver
+queryType = ObjectType "Query" Nothing [] $ HashMap.fromList
+    [ ("dog", dogResolver)
+    , ("findDog", findDogResolver)
+    ]
   where
     dogField = Field Nothing (Out.NamedObjectType dogType) mempty
     dogResolver = ValueResolver dogField $ pure Null
+    findDogArguments = HashMap.singleton "complex"
+        $ In.Argument Nothing (In.NonNullInputObjectType dogDataType) Nothing
+    findDogField = Field Nothing (Out.NamedObjectType dogType) findDogArguments
+    findDogResolver = ValueResolver findDogField $ pure Null
 
 dogCommandType :: EnumType
 dogCommandType = EnumType "DogCommand" Nothing $ HashMap.fromList
@@ -72,6 +77,12 @@ dogType = ObjectType "Dog" Nothing [petType] $ HashMap.fromList
     ownerField = Field Nothing (Out.NamedObjectType humanType) mempty
     ownerResolver = ValueResolver ownerField $ pure Null
 
+dogDataType :: InputObjectType
+dogDataType = InputObjectType "DogData" Nothing
+    $ HashMap.singleton "name" nameInputField
+  where
+    nameInputField = InputField Nothing (In.NonNullScalarType string) Nothing
+
 sentientType :: InterfaceType IO
 sentientType = InterfaceType "Sentient" Nothing []
     $ HashMap.singleton "name"
@@ -114,39 +125,14 @@ humanType = ObjectType "Human" Nothing [sentientType] $ HashMap.fromList
         Field Nothing (Out.ListType $ Out.NonNullInterfaceType petType) mempty
     petsResolver = ValueResolver petsField $ pure $ List []
 {-
-catCommandType :: EnumType
-catCommandType = EnumType "CatCommand" Nothing $ HashMap.fromList
-    [ ("JUMP", EnumValue Nothing)
-    ]
-
-catType :: ObjectType IO
-catType = ObjectType "Cat" Nothing [petType] $ HashMap.fromList
-    [ ("name", nameResolver)
-    , ("nickname", nicknameResolver)
-    , ("doesKnowCommand", doesKnowCommandResolver)
-    , ("meowVolume", meowVolumeResolver)
-    ]
-  where
-    nameField = Field Nothing (Out.NonNullScalarType string) mempty
-    nameResolver = ValueResolver nameField $ pure "Name"
-    nicknameField = Field Nothing (Out.NamedScalarType string) mempty
-    nicknameResolver = ValueResolver nicknameField $ pure "Nickname"
-    doesKnowCommandField = Field Nothing (Out.NonNullScalarType boolean)
-        $ HashMap.singleton "catCommand"
-        $ In.Argument Nothing (In.NonNullEnumType catCommandType) Nothing
-    doesKnowCommandResolver = ValueResolver doesKnowCommandField
-        $ pure $ Boolean True
-    meowVolumeField = Field Nothing (Out.NamedScalarType int) mempty
-    meowVolumeResolver = ValueResolver meowVolumeField $ pure $ Int 2
-
 catOrDogType :: UnionType IO
 catOrDogType = UnionType "CatOrDog" Nothing [catType, dogType]
 -}
-validate :: Text -> Seq Error
+validate :: Text -> [Error]
 validate queryString =
     case parse AST.document "" queryString of
-        Left _ -> Seq.empty
-        Right ast -> document schema specifiedRules ast
+        Left _ -> []
+        Right ast -> toList $ document schema specifiedRules ast
 
 spec :: Spec
 spec =
@@ -169,7 +155,7 @@ spec =
                         "Definition must be OperationDefinition or FragmentDefinition."
                     , locations = [AST.Location 9 15]
                     }
-             in validate queryString `shouldBe` Seq.singleton expected
+               in validate queryString `shouldContain` [expected]
 
         it "rejects multiple subscription root fields" $
             let queryString = [r|
@@ -186,7 +172,7 @@ spec =
                         "Subscription sub must select only one top level field."
                     , locations = [AST.Location 2 15]
                     }
-             in validate queryString `shouldBe` Seq.singleton expected
+             in validate queryString `shouldContain` [expected]
 
         it "rejects multiple subscription root fields coming from a fragment" $
             let queryString = [r|
@@ -207,7 +193,7 @@ spec =
                         "Subscription sub must select only one top level field."
                     , locations = [AST.Location 2 15]
                     }
-             in validate queryString `shouldBe` Seq.singleton expected
+             in validate queryString `shouldContain` [expected]
 
         it "rejects multiple anonymous operations" $
             let queryString = [r|
@@ -230,7 +216,7 @@ spec =
                         "This anonymous operation must be the only defined operation."
                     , locations = [AST.Location 2 15]
                     }
-             in validate queryString `shouldBe` Seq.singleton expected
+             in validate queryString `shouldBe` [expected]
 
         it "rejects operations with the same name" $
             let queryString = [r|
@@ -251,7 +237,7 @@ spec =
                         "There can be only one operation named \"dogOperation\"."
                     , locations = [AST.Location 2 15, AST.Location 8 15]
                     }
-             in validate queryString `shouldBe` Seq.singleton expected
+             in validate queryString `shouldBe` [expected]
 
         it "rejects fragments with the same name" $
             let queryString = [r|
@@ -276,7 +262,7 @@ spec =
                         "There can be only one fragment named \"fragmentOne\"."
                     , locations = [AST.Location 8 15, AST.Location 12 15]
                     }
-             in validate queryString `shouldBe` Seq.singleton expected
+             in validate queryString `shouldBe` [expected]
 
         it "rejects the fragment spread without a target" $
             let queryString = [r|
@@ -291,7 +277,7 @@ spec =
                         "Fragment target \"undefinedFragment\" is undefined."
                     , locations = [AST.Location 4 19]
                     }
-             in validate queryString `shouldBe` Seq.singleton expected
+             in validate queryString `shouldBe` [expected]
 
         it "rejects fragment spreads without an unknown target type" $
             let queryString = [r|
@@ -310,7 +296,7 @@ spec =
                         \\"NotInSchema\" which doesn't exist in the schema."
                     , locations = [AST.Location 4 19]
                     }
-             in validate queryString `shouldBe` Seq.singleton expected
+             in validate queryString `shouldBe` [expected]
 
         it "rejects inline fragments without a target" $
             let queryString = [r|
@@ -326,7 +312,7 @@ spec =
                         \which doesn't exist in the schema."
                     , locations = [AST.Location 3 17]
                     }
-             in validate queryString `shouldBe` Seq.singleton expected
+             in validate queryString `shouldBe` [expected]
 
         it "rejects fragments on scalar types" $
             let queryString = [r|
@@ -345,7 +331,7 @@ spec =
                         \\"Int\"."
                     , locations = [AST.Location 7 15]
                     }
-             in validate queryString `shouldBe` Seq.singleton expected
+             in validate queryString `shouldContain` [expected]
 
         it "rejects inline fragments on scalar types" $
             let queryString = [r|
@@ -361,7 +347,7 @@ spec =
                         \\"Boolean\"."
                     , locations = [AST.Location 3 17]
                     }
-             in validate queryString `shouldBe` Seq.singleton expected
+             in validate queryString `shouldContain` [expected]
 
         it "rejects unused fragments" $
             let queryString = [r|
@@ -380,7 +366,7 @@ spec =
                         "Fragment \"nameFragment\" is never used."
                     , locations = [AST.Location 2 15]
                     }
-             in validate queryString `shouldBe` Seq.singleton expected
+             in validate queryString `shouldBe` [expected]
 
         it "rejects spreads that form cycles" $
             let queryString = [r|
@@ -412,7 +398,7 @@ spec =
                         \nameFragment)."
                     , locations = [AST.Location 7 15]
                     }
-             in validate queryString `shouldBe` Seq.fromList [error1, error2]
+             in validate queryString `shouldBe` [error1, error2]
 
         it "rejects duplicate field arguments" $ do
             let queryString = [r|
@@ -427,20 +413,22 @@ spec =
                         "There can be only one argument named \"atOtherHomes\"."
                     , locations = [AST.Location 4 34, AST.Location 4 54]
                     }
-             in validate queryString `shouldBe` Seq.singleton expected
+             in validate queryString `shouldBe` [expected]
 
         it "rejects more than one directive per location" $ do
             let queryString = [r|
               query ($foo: Boolean = true, $bar: Boolean = false) {
-                field @skip(if: $foo) @skip(if: $bar)
+                dog @skip(if: $foo) @skip(if: $bar) {
+                  name
+                }
               }
             |]
                 expected = Error
                     { message =
                         "There can be only one directive named \"skip\"."
-                    , locations = [AST.Location 3 23, AST.Location 3 39]
+                    , locations = [AST.Location 3 21, AST.Location 3 37]
                     }
-             in validate queryString `shouldBe` Seq.singleton expected
+             in validate queryString `shouldBe` [expected]
 
         it "rejects duplicate variables" $
             let queryString = [r|
@@ -455,7 +443,7 @@ spec =
                         "There can be only one variable named \"atOtherHomes\"."
                     , locations = [AST.Location 2 39, AST.Location 2 63]
                     }
-             in validate queryString `shouldBe` Seq.singleton expected
+             in validate queryString `shouldBe` [expected]
 
         it "rejects non-input types as variables" $
             let queryString = [r|
@@ -470,7 +458,7 @@ spec =
                         "Variable \"$dog\" cannot be non-input type \"Dog\"."
                     , locations = [AST.Location 2 34]
                     }
-             in validate queryString `shouldBe` Seq.singleton expected
+             in validate queryString `shouldBe` [expected]
 
         it "rejects undefined variables" $
             let queryString = [r|
@@ -491,7 +479,7 @@ spec =
                         \\"variableIsNotDefinedUsedInSingleFragment\"."
                     , locations = [AST.Location 9 46]
                     }
-             in validate queryString `shouldBe` Seq.singleton expected
+             in validate queryString `shouldBe` [expected]
 
         it "rejects unused variables" $
             let queryString = [r|
@@ -507,7 +495,7 @@ spec =
                         \\"variableUnused\"."
                     , locations = [AST.Location 2 36]
                     }
-             in validate queryString `shouldBe` Seq.singleton expected
+             in validate queryString `shouldBe` [expected]
 
         it "rejects duplicate fields in input objects" $
             let queryString = [r|
@@ -520,4 +508,4 @@ spec =
                         "There can be only one input field named \"name\"."
                     , locations = [AST.Location 3 36, AST.Location 3 50]
                     }
-             in validate queryString `shouldBe` Seq.singleton expected
+             in validate queryString `shouldBe` [expected]
diff --git a/tests/Test/FragmentSpec.hs b/tests/Test/FragmentSpec.hs
index 27b08a2..8ee1ad2 100644
--- a/tests/Test/FragmentSpec.hs
+++ b/tests/Test/FragmentSpec.hs
@@ -108,20 +108,16 @@ spec = do
 
         it "embeds inline fragments without type" $ do
             let sourceQuery = [r|{
-              garment {
-                circumference
-                ... {
-                  size
-                }
+              circumference
+              ... {
+                size
               }
             }|]
-            actual <- graphql (toSchema "garment" $ garment "Hat") sourceQuery
+            actual <- graphql (toSchema "circumference" circumference) sourceQuery
             let expected = HashMap.singleton "data"
                     $ Aeson.object
-                        [ "garment" .= Aeson.object
-                            [ "circumference" .= (60 :: Int)
-                            , "size" .= ("L" :: Text)
-                            ]
+                        [ "circumference" .= (60 :: Int)
+                        , "size" .= ("L" :: Text)
                         ]
              in actual `shouldResolveTo` expected
 
diff --git a/tests/Test/StarWars/QuerySpec.hs b/tests/Test/StarWars/QuerySpec.hs
index 95b18d3..8d744ab 100644
--- a/tests/Test/StarWars/QuerySpec.hs
+++ b/tests/Test/StarWars/QuerySpec.hs
@@ -23,9 +23,9 @@ spec = describe "Star Wars Query Tests" $ do
       it "R2-D2 hero" $ testQuery
         [r| query HeroNameQuery {
             hero {
-                id
-            }
+              id
             }
+          }
         |]
         $ Aeson.object
             [ "data" .= Aeson.object
@@ -35,13 +35,13 @@ spec = describe "Star Wars Query Tests" $ do
       it "R2-D2 ID and friends" $ testQuery
         [r| query HeroNameAndFriendsQuery {
             hero {
-                id
+              id
+              name
+              friends {
                 name
-                friends {
-                  name
-                }
-            }
+              }
             }
+          }
         |]
         $ Aeson.object [ "data" .= Aeson.object [
             "hero" .= Aeson.object
@@ -266,7 +266,7 @@ spec = describe "Star Wars Query Tests" $ do
             query HeroNameQuery {
               hero {
                 name
-                  secretBackstory
+                secretBackstory
               }
             }
           |]
diff --git a/tests/Test/StarWars/Schema.hs b/tests/Test/StarWars/Schema.hs
index cecd8eb..34a6a35 100644
--- a/tests/Test/StarWars/Schema.hs
+++ b/tests/Test/StarWars/Schema.hs
@@ -41,72 +41,88 @@ schema = Schema
     droidFieldResolver = ValueResolver droidField droid
 
 heroObject :: Out.ObjectType (Either SomeException)
-heroObject = Out.ObjectType "Human" Nothing [] $ HashMap.fromList
+heroObject = Out.ObjectType "Human" Nothing [characterType] $ HashMap.fromList
     [ ("id", idFieldType)
     , ("name", nameFieldType)
-    , ("friends", friendsFieldType)
-    , ("appearsIn", appearsInField)
+    , ("friends", friendsFieldResolver)
+    , ("appearsIn", appearsInFieldResolver)
     , ("homePlanet", homePlanetFieldType)
-    , ("secretBackstory", secretBackstoryFieldType)
-    , ("__typename", typenameFieldType)
+    , ("secretBackstory", secretBackstoryFieldResolver)
+    , ("__typename", typenameFieldResolver)
     ]
   where
     homePlanetFieldType
       = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
-      $ idField "homePlanet"
+      $ defaultResolver "homePlanet"
 
 droidObject :: Out.ObjectType (Either SomeException)
-droidObject = Out.ObjectType "Droid" Nothing [] $ HashMap.fromList
+droidObject = Out.ObjectType "Droid" Nothing [characterType] $ HashMap.fromList
     [ ("id", idFieldType)
     , ("name", nameFieldType)
-    , ("friends", friendsFieldType)
-    , ("appearsIn", appearsInField)
+    , ("friends", friendsFieldResolver)
+    , ("appearsIn", appearsInFieldResolver)
     , ("primaryFunction", primaryFunctionFieldType)
-    , ("secretBackstory", secretBackstoryFieldType)
-    , ("__typename", typenameFieldType)
+    , ("secretBackstory", secretBackstoryFieldResolver)
+    , ("__typename", typenameFieldResolver)
     ]
   where
     primaryFunctionFieldType
         = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
-        $ idField "primaryFunction"
+        $ defaultResolver "primaryFunction"
 
-typenameFieldType :: Resolver (Either SomeException)
-typenameFieldType
+typenameFieldResolver :: Resolver (Either SomeException)
+typenameFieldResolver
     = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
-    $ idField "__typename"
+    $ defaultResolver "__typename"
 
 idFieldType :: Resolver (Either SomeException)
-idFieldType
-    = ValueResolver (Out.Field Nothing (Out.NamedScalarType id) mempty)
-    $ idField "id"
+idFieldType = ValueResolver idField $ defaultResolver "id"
 
 nameFieldType :: Resolver (Either SomeException)
-nameFieldType
-    = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
-    $ idField "name"
+nameFieldType = ValueResolver nameField $ defaultResolver "name"
 
-friendsFieldType :: Resolver (Either SomeException)
-friendsFieldType
-    = ValueResolver (Out.Field Nothing fieldType mempty)
-    $ idField "friends"
-  where
-    fieldType = Out.ListType $ Out.NamedObjectType droidObject
+friendsFieldResolver :: Resolver (Either SomeException)
+friendsFieldResolver = ValueResolver friendsField $ defaultResolver "friends"
+
+characterType :: InterfaceType (Either SomeException)
+characterType = InterfaceType "Character" Nothing [] $ HashMap.fromList
+    [ ("id", idField)
+    , ("name", nameField)
+    , ("friends", friendsField)
+    , ("appearsIn", appearsInField)
+    , ("secretBackstory", secretBackstoryField)
+    ]
+
+idField :: Field (Either SomeException)
+idField = Field Nothing (Out.NonNullScalarType id) mempty
+
+nameField :: Field (Either SomeException)
+nameField = Field Nothing (Out.NamedScalarType string) mempty
 
-appearsInField :: Resolver (Either SomeException)
-appearsInField
-    = ValueResolver (Out.Field (Just description) fieldType mempty)
-    $ idField "appearsIn"
+friendsField :: Field (Either SomeException)
+friendsField = Field Nothing friendsFieldType mempty
   where
-    fieldType = Out.ListType $ Out.NamedEnumType episodeEnum
-    description = "Which movies they appear in."
+    friendsFieldType = Out.ListType (Out.NamedInterfaceType characterType)
 
-secretBackstoryFieldType :: Resolver (Either SomeException)
-secretBackstoryFieldType = ValueResolver field secretBackstory
+appearsInField :: Field (Either SomeException)
+appearsInField = Field appearsInDescription appearsInFieldType mempty
   where
-    field = Out.Field Nothing (Out.NamedScalarType string) mempty
+    appearsInDescription = Just "Which movies they appear in."
+    appearsInFieldType = Out.ListType $ Out.NamedEnumType episodeEnum
+
+secretBackstoryField :: Field (Either SomeException)
+secretBackstoryField =
+    Out.Field Nothing (Out.NamedScalarType string) mempty
+
+appearsInFieldResolver :: Resolver (Either SomeException)
+appearsInFieldResolver = ValueResolver appearsInField
+    $ defaultResolver "appearsIn"
+
+secretBackstoryFieldResolver :: Resolver (Either SomeException)
+secretBackstoryFieldResolver = ValueResolver secretBackstoryField secretBackstory
 
-idField :: Text -> Resolve (Either SomeException)
-idField f = do
+defaultResolver :: Text -> Resolve (Either SomeException)
+defaultResolver f = do
     v <- asks values
     let (Object v') = v
     pure $ v' HashMap.! f