From fc9ad9c4a1e2e79a6b93d2599ca8fa6770caf631 Mon Sep 17 00:00:00 2001
From: Eugen Wissner <belka@caraus.de>
Date: Sun, 1 Dec 2019 20:43:19 +0100
Subject: Consider __typename when evaluating fragments

Fixes #30.
---
 src/Language/GraphQL/AST/Transform.hs | 30 +++++++++++++++++-------------
 src/Language/GraphQL/Schema.hs        |  4 ++--
 2 files changed, 19 insertions(+), 15 deletions(-)

(limited to 'src/Language')

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'
-- 
cgit v1.2.3