Consider __typename when evaluating fragments

Fixes #30.

CHANGELOG.md

@@ -6,6 +6,9 @@ All notable changes to this project will be documented in this file.
 - Parsing multiple string arguments, such as 
   `login(username: "username", password: "password")` would fail on the comma
   due to strings not having a space consumer.
+- Fragment spread is evaluated based on the `__typename` resolver. If the
+  resolver is missing, it is assumed that the type condition is satisfied (all
+  fragments are included).
 
 ## [0.6.0.0] - 2019-11-27
 ### Changed

src/Language/GraphQL/AST/Transform.hs

@@ -23,7 +23,7 @@ import qualified Language.GraphQL.Schema as Schema
 
 -- | Associates a fragment name with a list of 'Core.Field's.
 data Replacement = Replacement
-    { fragments :: HashMap Core.Name (Seq Core.Selection)
+    { fragments :: HashMap Core.Name Core.Fragment
     , fragmentDefinitions :: HashMap Full.Name Full.FragmentDefinition
     }
 
@@ -65,15 +65,8 @@ selection ::
     Full.Selection ->
     TransformT (Either (Seq Core.Selection) Core.Selection)
 selection (Full.SelectionField fld) = Right . Core.SelectionField <$> field fld
-selection (Full.SelectionFragmentSpread (Full.FragmentSpread name _)) = do
-    fragments' <- gets fragments
-    Left <$> maybe lookupDefinition liftJust (HashMap.lookup name fragments')
-  where
-    lookupDefinition :: TransformT (Seq Core.Selection)
-    lookupDefinition = do
-        fragmentDefinitions' <- gets fragmentDefinitions
-        found <- lift . lift $ HashMap.lookup name fragmentDefinitions'
-        fragmentDefinition found
+selection (Full.SelectionFragmentSpread fragment) =
+    Right . Core.SelectionFragment <$> fragmentSpread fragment
 selection (Full.SelectionInlineFragment fragment)
     | (Full.InlineFragment (Just typeCondition) _ selectionSet) <- fragment
         = Right
@@ -94,12 +87,23 @@ collectFragments = do
         _ <- fragmentDefinition nextValue
         collectFragments
 
+fragmentSpread :: Full.FragmentSpread -> TransformT Core.Fragment
+fragmentSpread (Full.FragmentSpread name _) = do
+    fragments' <- gets fragments
+    maybe lookupDefinition liftJust (HashMap.lookup name fragments')
+  where
+    lookupDefinition = do
+        fragmentDefinitions' <- gets fragmentDefinitions
+        found <- lift . lift $ HashMap.lookup name fragmentDefinitions'
+        fragmentDefinition found
+
 fragmentDefinition ::
     Full.FragmentDefinition ->
-    TransformT (Seq Core.Selection)
-fragmentDefinition (Full.FragmentDefinition name _tc _dirs selections) = do
+    TransformT Core.Fragment
+fragmentDefinition (Full.FragmentDefinition name typeCondition _dirs selections) = do
     modify deleteFragmentDefinition
-    newValue <- appendSelection selections
+    fragmentSelection <- appendSelection selections
+    let newValue = Core.Fragment typeCondition fragmentSelection
     modify $ insertFragment newValue
     liftJust newValue
   where

src/Language/GraphQL/Schema.hs

@@ -131,8 +131,8 @@ resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers
     tryResolvers (SelectionField fld@(Field _ name _ _))
         = maybe (errmsg fld) (tryResolver fld) $ find (compareResolvers name) resolvers
     tryResolvers (SelectionFragment (Fragment typeCondition selections')) = do
-        that <-  maybe (return "") resolveTypeName (find (compareResolvers "__typename") resolvers)
-        if Aeson.String typeCondition == that
+        that <- traverse resolveTypeName (find (compareResolvers "__typename") resolvers)
+        if maybe True (Aeson.String typeCondition ==) that
             then fmap fold . traverse tryResolvers $ selections'
             else return mempty
     compareResolvers name (Resolver name' _) = name == name'

tests/Test/FragmentSpec.hs

@@ -48,7 +48,8 @@ hasErrors (Object object') = HashMap.member "errors" object'
 hasErrors _ = True
 
 spec :: Spec
-spec = describe "Inline fragment executor" $ do
+spec = do
+    describe "Inline fragment executor" $ do
         it "chooses the first selection if the type matches" $ do
             actual <- graphql (garment "Hat" :| []) inlineQuery
             let expected = object
@@ -103,7 +104,8 @@ spec = describe "Inline fragment executor" $ do
             actual <- graphql (size :| []) query
             actual `shouldNotSatisfy` hasErrors
 
-    it "evaluates nested fragments" $ do
+    describe "Fragment spread executor" $ do
+        it "evaluates fragment spreads" $ do
             let query = [r|
               {
                 ...circumferenceFragment
@@ -112,10 +114,6 @@ spec = describe "Inline fragment executor" $ do
               fragment circumferenceFragment on Hat {
                 circumference
               }
-
-          fragment hatFragment on Hat {
-            ...circumferenceFragment
-          }
             |]
 
             actual <- graphql (circumference :| []) query
@@ -126,11 +124,13 @@ spec = describe "Inline fragment executor" $ do
                     ]
              in actual `shouldBe` expected
 
-    it "evaluates fragments defined in any order" $ do
+        it "evaluates nested fragments" $ do
             let query = [r|
               {
+                garment {
                   ...circumferenceFragment
                 }
+              }
 
               fragment circumferenceFragment on Hat {
                 ...hatFragment
@@ -141,15 +141,17 @@ spec = describe "Inline fragment executor" $ do
               }
             |]
 
-        actual <- graphql (circumference :| []) query
+            actual <- graphql (garment "Hat" :| []) query
             let expected = object
                     [ "data" .= object
+                        [ "garment" .= object
                             [ "circumference" .= (60 :: Int)
                             ]
                         ]
+                    ]
              in actual `shouldBe` expected
 
-    it "rejects recursive" $ do
+        it "rejects recursive fragments" $ do
             let query = [r|
               {
                 ...circumferenceFragment
@@ -162,3 +164,28 @@ spec = describe "Inline fragment executor" $ do
 
             actual <- graphql (circumference :| []) query
             actual `shouldSatisfy` hasErrors
+
+        it "considers type condition" $ do
+            let query = [r|
+              {
+                garment {
+                  ...circumferenceFragment
+                  ...sizeFragment
+                }
+              }
+              fragment circumferenceFragment on Hat {
+                circumference
+              }
+              fragment sizeFragment on Shirt {
+                size
+              }
+            |]
+                expected = object
+                    [ "data" .= object
+                        [ "garment" .= object
+                            [ "circumference" .= (60 :: Int)
+                            ]
+                        ]
+                    ]
+            actual <- graphql (garment "Hat" :| []) query
+            actual `shouldBe` expected