1 files changed, 23 insertions, 18 deletions

diff --git a/src/Language/GraphQL/Schema.hs b/src/Language/GraphQL/Schema.hs
index 428b80e..112847f 100644
--- a/src/Language/GraphQL/Schema.hs
+++ b/src/Language/GraphQL/Schema.hs
@@ -28,9 +28,7 @@ module Language.GraphQL.Schema
 import Control.Monad.IO.Class (MonadIO(..))
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.Except (runExceptT)
-import Data.Foldable ( find
-                     , fold
-                     )
+import Data.Foldable (find, fold)
 import Data.List.NonEmpty (NonEmpty)
 import Data.Maybe (fromMaybe)
 import qualified Data.Aeson as Aeson
@@ -48,16 +46,13 @@ import Language.GraphQL.AST.Core
 --   @m@ is usually expected to be an instance of 'MonadIO'.
 type Schema m = NonEmpty (Resolver m)
 
--- | Resolves a 'Field' into an @Aeson.@'Aeson.Object' with error information
---   (or 'empty'). @m@ is usually expected to be an instance of 'MonadIO.
+-- | Resolves a 'Field' into an @Aeson.@'Data.Aeson.Types.Object' with error
+--   information (if an error has occurred). @m@ is usually expected to be an
+--   instance of 'MonadIO'.
 data Resolver m = Resolver
     Text -- ^ Name
     (Field -> CollectErrsT m Aeson.Object) -- ^ Resolver
 
-type Fields = [Field]
-
-type Arguments = [Argument]
-
 -- | Variable substitution function.
 type Subs = Name -> Maybe Value
 
@@ -67,14 +62,14 @@ object name = objectA name . const
 
 -- | Like 'object' but also taking 'Argument's.
 objectA :: MonadIO m
-    => Name -> (Arguments -> ActionT m [Resolver m]) -> Resolver m
+    => Name -> ([Argument] -> ActionT m [Resolver m]) -> Resolver m
 objectA name f = Resolver name $ resolveFieldValue f resolveRight
   where
     resolveRight fld@(Field _ _ _ flds) resolver = withField (resolve resolver flds) fld
 
 -- | Like 'object' but also taking 'Argument's and can be null or a list of objects.
 wrappedObjectA :: MonadIO m
-    => Name -> (Arguments -> ActionT m (Wrapping [Resolver m])) -> Resolver m
+    => Name -> ([Argument] -> ActionT m (Wrapping [Resolver m])) -> Resolver m
 wrappedObjectA name f = Resolver name $ resolveFieldValue f resolveRight
   where
     resolveRight fld@(Field _ _ _ sels) resolver
@@ -91,14 +86,14 @@ scalar name = scalarA name . const
 
 -- | Like 'scalar' but also taking 'Argument's.
 scalarA :: (MonadIO m, Aeson.ToJSON a)
-    => Name -> (Arguments -> ActionT m a) -> Resolver m
+    => Name -> ([Argument] -> ActionT m a) -> Resolver m
 scalarA name f = Resolver name $ resolveFieldValue f resolveRight
   where
     resolveRight fld result = withField (return result) fld
 
 -- | Lika 'scalar' but also taking 'Argument's and can be null or a list of scalars.
 wrappedScalarA :: (MonadIO m, Aeson.ToJSON a)
-    => Name -> (Arguments -> ActionT m (Wrapping a)) -> Resolver m
+    => Name -> ([Argument] -> ActionT m (Wrapping a)) -> Resolver m
 wrappedScalarA name f = Resolver name $ resolveFieldValue f resolveRight
   where
     resolveRight fld (Named result) = withField (return result) fld
@@ -116,14 +111,14 @@ enum :: MonadIO m => Name -> ActionT m [Text] -> Resolver m
 enum name = enumA name . const
 
 {-# DEPRECATED enumA "Use scalarA instead" #-}
-enumA :: MonadIO m => Name -> (Arguments -> ActionT m [Text]) -> Resolver m
+enumA :: MonadIO m => Name -> ([Argument] -> ActionT m [Text]) -> Resolver m
 enumA name f = Resolver name $ resolveFieldValue f resolveRight
   where
     resolveRight fld resolver = withField (return resolver) fld
 
 {-# DEPRECATED wrappedEnumA "Use wrappedScalarA instead" #-}
 wrappedEnumA :: MonadIO m
-    => Name -> (Arguments -> ActionT m (Wrapping [Text])) -> Resolver m
+    => Name -> ([Argument] -> ActionT m (Wrapping [Text])) -> Resolver m
 wrappedEnumA name f = Resolver name $ resolveFieldValue f resolveRight
   where
     resolveRight fld (Named resolver) = withField (return resolver) fld
@@ -158,11 +153,21 @@ withField v fld
 --   'Resolver' to each 'Field'. Resolves into a value containing the
 --   resolved 'Field', or a null value and error information.
 resolve :: MonadIO m
-    => [Resolver m] -> Fields -> CollectErrsT m Aeson.Value
+    => [Resolver m] -> [Selection] -> CollectErrsT m Aeson.Value
 resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers
   where
-    tryResolvers fld = maybe (errmsg fld) (tryResolver fld) $ find (compareResolvers fld) resolvers
-    compareResolvers (Field _ name _ _) (Resolver name' _) = name == name'
+    resolveTypeName (Resolver "__typename" f) = do
+        value <- f $ Field Nothing "__typename" mempty mempty
+        return $ HashMap.lookupDefault "" "__typename" value
+    resolveTypeName _ = return ""
+    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
+            then fmap fold . traverse tryResolvers $ selections'
+            else return mempty
+    compareResolvers name (Resolver name' _) = name == name'
     tryResolver fld (Resolver _ resolver)  = resolver fld
     errmsg fld@(Field _ name _ _) = do
         addErrMsg $ T.unwords ["field", name, "not resolved."]