Consider __typename when evaluating fragments

Fixes #30.

4 files changed, 154 insertions, 120 deletions

diff --git a/CHANGELOG.md b/CHANGELOG.md
index 1b41dfc..38d5217 100644
--- a/CHANGELOG.md
+++ b/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
diff --git a/src/Language/GraphQL/AST/Transform.hs b/src/Language/GraphQL/AST/Transform.hs
index 95cdfbb..4822248 100644
--- a/src/Language/GraphQL/AST/Transform.hs
+++ b/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
diff --git a/src/Language/GraphQL/Schema.hs b/src/Language/GraphQL/Schema.hs
index afe068f..fa8bf78 100644
--- a/src/Language/GraphQL/Schema.hs
+++ b/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'
diff --git a/tests/Test/FragmentSpec.hs b/tests/Test/FragmentSpec.hs
index 69f1344..de10d63 100644
--- a/tests/Test/FragmentSpec.hs
+++ b/tests/Test/FragmentSpec.hs
@@ -48,117 +48,144 @@ hasErrors (Object object') = HashMap.member "errors" object'
 hasErrors _ = True
 
 spec :: Spec
-spec = describe "Inline fragment executor" $ do
-    it "chooses the first selection if the type matches" $ do
-        actual <- graphql (garment "Hat" :| []) inlineQuery
-        let expected = object
-                [ "data" .= object
-                    [ "garment" .= object
-                        [ "circumference" .= (60 :: Int)
+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
+                    [ "data" .= object
+                        [ "garment" .= object
+                            [ "circumference" .= (60 :: Int)
+                            ]
+                        ]
+                    ]
+             in actual `shouldBe` expected
+
+        it "chooses the last selection if the type matches" $ do
+            actual <- graphql (garment "Shirt" :| []) inlineQuery
+            let expected = object
+                    [ "data" .= object
+                        [ "garment" .= object
+                            [ "size" .= ("L" :: Text)
+                            ]
                         ]
                     ]
-                ]
-         in actual `shouldBe` expected
-
-    it "chooses the last selection if the type matches" $ do
-        actual <- graphql (garment "Shirt" :| []) inlineQuery
-        let expected = object
-                [ "data" .= object
-                    [ "garment" .= object
-                        [ "size" .= ("L" :: Text)
+             in actual `shouldBe` expected
+
+        it "embeds inline fragments without type" $ do
+            let query = [r|{
+              garment {
+                circumference
+                ... {
+                  size
+                }
+              }
+            }|]
+                resolvers = Schema.object "garment" $ return [circumference,  size]
+
+            actual <- graphql (resolvers :| []) query
+            let expected = object
+                    [ "data" .= object
+                        [ "garment" .= object
+                            [ "circumference" .= (60 :: Int)
+                            , "size" .= ("L" :: Text)
+                            ]
                         ]
                     ]
-                ]
-         in actual `shouldBe` expected
-
-    it "embeds inline fragments without type" $ do
-        let query = [r|{
-          garment {
-            circumference
-            ... {
-              size
-            }
-          }
-        }|]
-            resolvers = Schema.object "garment" $ return [circumference,  size]
-
-        actual <- graphql (resolvers :| []) query
-        let expected = object
-                [ "data" .= object
-                    [ "garment" .= object
+             in actual `shouldBe` expected
+
+        it "evaluates fragments on Query" $ do
+            let query = [r|{
+              ... {
+                size
+              }
+            }|]
+
+            actual <- graphql (size :| []) query
+            actual `shouldNotSatisfy` hasErrors
+
+    describe "Fragment spread executor" $ do
+        it "evaluates fragment spreads" $ do
+            let query = [r|
+              {
+                ...circumferenceFragment
+              }
+
+              fragment circumferenceFragment on Hat {
+                circumference
+              }
+            |]
+
+            actual <- graphql (circumference :| []) query
+            let expected = object
+                    [ "data" .= object
                         [ "circumference" .= (60 :: Int)
-                        , "size" .= ("L" :: Text)
                         ]
                     ]
-                ]
-         in actual `shouldBe` expected
-
-    it "evaluates fragments on Query" $ do
-        let query = [r|{
-          ... {
-            size
-          }
-        }|]
-
-        actual <- graphql (size :| []) query
-        actual `shouldNotSatisfy` hasErrors
-
-    it "evaluates nested fragments" $ do
-        let query = [r|
-          {
-            ...circumferenceFragment
-          }
-
-          fragment circumferenceFragment on Hat {
-            circumference
-          }
-
-          fragment hatFragment on Hat {
-            ...circumferenceFragment
-          }
-        |]
-
-        actual <- graphql (circumference :| []) query
-        let expected = object
-                [ "data" .= object
-                    [ "circumference" .= (60 :: Int)
+             in actual `shouldBe` expected
+
+        it "evaluates nested fragments" $ do
+            let query = [r|
+              {
+                garment {
+                  ...circumferenceFragment
+                }
+              }
+
+              fragment circumferenceFragment on Hat {
+                ...hatFragment
+              }
+
+              fragment hatFragment on Hat {
+                circumference
+              }
+            |]
+
+            actual <- graphql (garment "Hat" :| []) query
+            let expected = object
+                    [ "data" .= object
+                        [ "garment" .= object
+                            [ "circumference" .= (60 :: Int)
+                            ]
+                        ]
                     ]
-                ]
-         in actual `shouldBe` expected
-
-    it "evaluates fragments defined in any order" $ do
-        let query = [r|
-          {
-            ...circumferenceFragment
-          }
-
-          fragment circumferenceFragment on Hat {
-            ...hatFragment
-          }
-
-          fragment hatFragment on Hat {
-            circumference
-          }
-        |]
-
-        actual <- graphql (circumference :| []) query
-        let expected = object
-                [ "data" .= object
-                    [ "circumference" .= (60 :: Int)
+             in actual `shouldBe` expected
+
+        it "rejects recursive fragments" $ do
+            let query = [r|
+              {
+                ...circumferenceFragment
+              }
+
+              fragment circumferenceFragment on Hat {
+                ...circumferenceFragment
+              }
+            |]
+
+            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)
+                            ]
+                        ]
                     ]
-                ]
-         in actual `shouldBe` expected
-
-    it "rejects recursive" $ do
-        let query = [r|
-          {
-            ...circumferenceFragment
-          }
-
-          fragment circumferenceFragment on Hat {
-            ...circumferenceFragment
-          }
-        |]
-
-        actual <- graphql (circumference :| []) query
-        actual `shouldSatisfy` hasErrors
+            actual <- graphql (garment "Hat" :| []) query
+            actual `shouldBe` expected