Collect types from the subscription root

tests/Language/GraphQL/ValidateSpec.hs

@@ -26,7 +26,7 @@ schema :: Schema IO
 schema = Schema
     { query = queryType
     , mutation = Nothing
-    , subscription = Nothing
+    , subscription = Just subscriptionType
     } 
 
 queryType :: ObjectType IO
@@ -81,19 +81,27 @@ petType :: InterfaceType IO
 petType = InterfaceType "Pet" Nothing []
     $ HashMap.singleton "name"
     $ Field Nothing (Out.NonNullScalarType string) mempty
-{-
-alienType :: ObjectType IO
-alienType = ObjectType "Alien" Nothing [sentientType] $ HashMap.fromList
-    [ ("name", nameResolver)
-    , ("homePlanet", homePlanetResolver)
+
+subscriptionType :: ObjectType IO
+subscriptionType = ObjectType "Subscription" Nothing [] $ HashMap.fromList
+    [ ("newMessage", newMessageResolver)
     ]
   where
-    nameField = Field Nothing (Out.NonNullScalarType string) mempty
-    nameResolver = ValueResolver nameField $ pure "Name"
-    homePlanetField =
-        Field Nothing (Out.NamedScalarType string) mempty
-    homePlanetResolver = ValueResolver homePlanetField $ pure "Home planet"
--}
+    newMessageField = Field Nothing (Out.NonNullObjectType messageType) mempty
+    newMessageResolver = ValueResolver newMessageField
+        $ pure $ Object HashMap.empty
+
+messageType :: ObjectType IO
+messageType = ObjectType "Message" Nothing [] $ HashMap.fromList
+    [ ("sender", senderResolver)
+    , ("body", bodyResolver)
+    ]
+  where
+    senderField = Field Nothing (Out.NonNullScalarType string) mempty
+    senderResolver = ValueResolver senderField $ pure "Sender"
+    bodyField = Field Nothing (Out.NonNullScalarType string) mempty
+    bodyResolver = ValueResolver bodyField $ pure "Message body."
+
 humanType :: ObjectType IO
 humanType = ObjectType "Human" Nothing [sentientType] $ HashMap.fromList
     [ ("name", nameResolver)
@@ -133,12 +141,6 @@ catType = ObjectType "Cat" Nothing [petType] $ HashMap.fromList
 
 catOrDogType :: UnionType IO
 catOrDogType = UnionType "CatOrDog" Nothing [catType, dogType]
-
-dogOrHumanType :: UnionType IO
-dogOrHumanType = UnionType "DogOrHuman" Nothing [dogType, humanType]
-
-humanOrAlienType :: UnionType IO
-humanOrAlienType = UnionType "HumanOrAlien" Nothing [humanType, alienType]
 -}
 validate :: Text -> Seq Error
 validate queryString =
@@ -297,3 +299,23 @@ spec =
                     , path = []
                     }
              in validate queryString `shouldBe` Seq.singleton expected
+
+        it "rejects the fragment spread without a target" $
+            let queryString = [r|
+              {
+                dog {
+                  ...notOnExistingType
+                }
+              }
+              fragment notOnExistingType on NotInSchema {
+                name
+              }
+            |]
+                expected = Error
+                    { message =
+                        "Fragment \"notOnExistingType\" is specified on type \
+                        \\"NotInSchema\" which doesn't exist in the schema."
+                    , locations = [AST.Location 4 19]
+                    , path = []
+                    }
+             in validate queryString `shouldBe` Seq.singleton expected

tests/Test/DirectiveSpec.hs

@@ -72,7 +72,7 @@ spec =
                 ...experimentalFragment @skip(if: true)
               }
 
-              fragment experimentalFragment on ExperimentalType {
+              fragment experimentalFragment on Query {
                 experimentalField
               }
             |]
@@ -83,7 +83,7 @@ spec =
         it "should be able to @skip an inline fragment" $ do
             let sourceQuery = [r|
               {
-                ... on ExperimentalType @skip(if: true) {
+                ... on Query @skip(if: true) {
                   experimentalField
                 }
               }

tests/Test/FragmentSpec.hs

@@ -46,18 +46,15 @@ inlineQuery = [r|{
 }|]
 
 shirtType :: Out.ObjectType IO
-shirtType = Out.ObjectType "Shirt" Nothing []
-    $ HashMap.fromList
-        [ ("size", sizeFieldType)
-        , ("circumference", circumferenceFieldType)
-        ]
+shirtType = Out.ObjectType "Shirt" Nothing [] $ HashMap.fromList
+    [ ("size", sizeFieldType)
+    ]
 
 hatType :: Out.ObjectType IO
-hatType = Out.ObjectType "Hat" Nothing []
-    $ HashMap.fromList
-        [ ("size", sizeFieldType)
-        , ("circumference", circumferenceFieldType)
-        ]
+hatType = Out.ObjectType "Hat" Nothing [] $ HashMap.fromList
+    [ ("size", sizeFieldType)
+    , ("circumference", circumferenceFieldType)
+    ]
 
 circumferenceFieldType :: Out.Resolver IO
 circumferenceFieldType
@@ -73,9 +70,9 @@ toSchema :: Text -> (Text, Value) -> Schema IO
 toSchema t (_, resolve) = Schema
     { query = queryType, mutation = Nothing, subscription = Nothing }
   where
-    unionMember = if t == "Hat" then hatType else shirtType
+    garmentType = Out.UnionType "Garment" Nothing [hatType, shirtType]
     typeNameField = Out.Field Nothing (Out.NamedScalarType string) mempty
-    garmentField = Out.Field Nothing (Out.NamedObjectType unionMember) mempty
+    garmentField = Out.Field Nothing (Out.NamedUnionType garmentType) mempty
     queryType =
         case t of
             "circumference" -> hatType
@@ -118,9 +115,7 @@ spec = do
                 }
               }
             }|]
-                resolvers = ("garment", Object $ HashMap.fromList [circumference,  size])
-
-            actual <- graphql (toSchema "garment" resolvers) sourceQuery
+            actual <- graphql (toSchema "garment" $ garment "Hat") sourceQuery
             let expected = HashMap.singleton "data"
                     $ Aeson.object
                         [ "garment" .= Aeson.object