Merge selection sets

CHANGELOG.md

@@ -18,6 +18,7 @@ and this project adheres to
 - Argument value coercion.
 - Variable value coercion.
 - The executor should skip the fields missing in the object type and not fail.
+- Merging subselections.
 
 ### Changed
 - `Schema.Resolver` was moved to `Type.Out`, it is a field and resolver function

src/Language/GraphQL/Execute/Execution.hs

@@ -10,6 +10,7 @@ import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.Except (runExceptT)
 import Control.Monad.Trans.Reader (runReaderT)
 import Control.Monad.Trans.State (gets)
+import Data.List.NonEmpty (NonEmpty(..))
 import Data.Map.Strict (Map)
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
@@ -17,7 +18,6 @@ import qualified Data.Map.Strict as Map
 import Data.Maybe (fromMaybe)
 import Data.Sequence (Seq(..))
 import Data.Text (Text)
-import qualified Data.Sequence as Seq
 import Language.GraphQL.AST (Name)
 import Language.GraphQL.AST.Core
 import Language.GraphQL.Error
@@ -42,12 +42,12 @@ resolveFieldValue result args =
 collectFields :: Monad m
     => Out.ObjectType m
     -> Seq (Selection m)
-    -> Map Name (Seq (Field m))
+    -> Map Name (NonEmpty (Field m))
 collectFields objectType = foldl forEach Map.empty
   where
     forEach groupedFields (SelectionField field) =
         let responseKey = aliasOrName field
-         in Map.insertWith (<>) responseKey (Seq.singleton field) groupedFields
+         in Map.insertWith (<>) responseKey (field :| []) groupedFields
     forEach groupedFields (SelectionFragment selectionFragment)
         | Fragment fragmentType fragmentSelectionSet <- selectionFragment
         , doesFragmentTypeApply fragmentType objectType =
@@ -98,24 +98,24 @@ instanceOf objectType (AbstractUnionType unionType) =
     go unionMemberType acc = acc || objectType == unionMemberType
 
 executeField :: Monad m
-    => Definition.Value
-    -> Field m
-    -> Out.Resolver m
+    => Out.Resolver m
+    -> Definition.Value
+    -> NonEmpty (Field m)
     -> CollectErrsT m Aeson.Value
-executeField prev field (Out.Resolver fieldDefinition resolver) = do
+executeField (Out.Resolver fieldDefinition resolver) prev fields = do
     let Out.Field _ fieldType argumentDefinitions = fieldDefinition
-    let Field _ _ arguments' _ = field
+    let (Field _ _ arguments' _ :| []) = fields
     case coerceArgumentValues argumentDefinitions arguments' of
         Nothing -> errmsg "Argument coercing failed."
         Just argumentValues -> do
             answer <- lift $ resolveFieldValue prev argumentValues resolver
             case answer of
-                Right result -> completeValue fieldType field result
+                Right result -> completeValue fieldType fields result
                 Left errorMessage -> errmsg errorMessage
 
 completeValue :: Monad m
     => Out.Type m
-    -> Field m
+    -> NonEmpty (Field m)
     -> Definition.Value
     -> CollectErrsT m Aeson.Value
 completeValue _ _ Definition.Null = pure Aeson.Null
@@ -124,24 +124,32 @@ completeValue _ _ (Definition.Boolean boolean') = pure $ Aeson.Bool boolean'
 completeValue _ _ (Definition.Float float') = pure $ Aeson.toJSON float'
 completeValue _ _ (Definition.Enum enum) = pure $ Aeson.String enum
 completeValue _ _ (Definition.String string') = pure $ Aeson.String string'
-completeValue (Out.ObjectBaseType objectType) (Field _ _ _ seqSelection) result =
-    executeSelectionSet result objectType seqSelection
-completeValue (Out.ListBaseType listType) selectionField (Definition.List list) =
-    Aeson.toJSON <$> traverse (completeValue listType selectionField) list
-completeValue (Out.InterfaceBaseType interfaceType) (Field _ _ _ seqSelection) result
+completeValue (Out.ListBaseType listType) fields (Definition.List list) =
+    Aeson.toJSON <$> traverse (completeValue listType fields) list
+completeValue (Out.ObjectBaseType objectType) fields result =
+    executeSelectionSet result objectType $ mergeSelectionSets fields
+completeValue (Out.InterfaceBaseType interfaceType) fields result
     | Definition.Object objectMap <- result = do
         abstractType <- resolveAbstractType (AbstractInterfaceType interfaceType) objectMap
         case abstractType of
-            Just objectType -> executeSelectionSet result objectType seqSelection
+            Just objectType -> executeSelectionSet result objectType
+                $ mergeSelectionSets fields
             Nothing -> errmsg "Value completion failed."
-completeValue (Out.UnionBaseType unionType) (Field _ _ _ seqSelection) result
+completeValue (Out.UnionBaseType unionType) fields result
     | Definition.Object objectMap <- result = do
         abstractType <- resolveAbstractType (AbstractUnionType unionType) objectMap
         case abstractType of
-            Just objectType -> executeSelectionSet result objectType seqSelection
+            Just objectType -> executeSelectionSet result objectType
+                $ mergeSelectionSets fields
             Nothing -> errmsg "Value completion failed."
 completeValue _ _ _ = errmsg "Value completion failed."
 
+mergeSelectionSets :: Monad m => NonEmpty (Field m) -> Seq (Selection m)
+mergeSelectionSets fields = foldr forEach mempty fields
+  where
+    forEach (Field _ _ _ fieldSelectionSet) selectionSet =
+        selectionSet <> fieldSelectionSet
+
 errmsg :: Monad m => Text -> CollectErrsT m Aeson.Value
 errmsg errorMessage = addErrMsg errorMessage >> pure Aeson.Null
 
@@ -154,17 +162,16 @@ executeSelectionSet :: Monad m
     -> Seq (Selection m)
     -> CollectErrsT m Aeson.Value
 executeSelectionSet result objectType@(Out.ObjectType _ _ _ resolvers) selectionSet = do
-    resolvedValues <- Map.traverseMaybeWithKey forEach
-        $ collectFields objectType selectionSet
+    let fields = collectFields objectType selectionSet
+    resolvedValues <- Map.traverseMaybeWithKey forEach fields
     pure $ Aeson.toJSON resolvedValues
   where
-    forEach _responseKey (field :<| _) =
+    forEach _ fields@(field :| _) =
         let Field _ name _ _ = field
-         in traverse (tryResolver field) $ lookupResolver name
-    forEach _ _ = pure Nothing
+         in traverse (tryResolver fields) $ lookupResolver name
     lookupResolver = flip HashMap.lookup resolvers
-    tryResolver typeField field =
-        executeField result typeField field >>= lift . pure
+    tryResolver fields resolver =
+        executeField resolver result fields >>= lift . pure
 
 coerceArgumentValues
     :: HashMap Name In.Argument

tests/Language/GraphQL/ExecuteSpec.hs

@@ -22,21 +22,54 @@ schema = Schema {query = queryType, mutation = Nothing}
 
 queryType :: Out.ObjectType Identity
 queryType = Out.ObjectType "Query" Nothing []
-    $ HashMap.singleton "count"
-    $ Out.Resolver countField
+    $ HashMap.singleton "philosopher"
+    $ Out.Resolver philosopherField
     $ pure
-    $ Int 8
+    $ Object mempty
   where
-    countField = Out.Field Nothing (Out.NonNullScalarType int) HashMap.empty
+    philosopherField =
+        Out.Field Nothing (Out.NonNullObjectType philosopherType) HashMap.empty
+
+philosopherType :: Out.ObjectType Identity
+philosopherType = Out.ObjectType "Philosopher" Nothing []
+    $ HashMap.fromList resolvers
+  where
+    resolvers =
+        [ ("firstName", firstNameResolver)
+        , ("lastName", lastNameResolver)
+        ]
+    firstNameResolver = Out.Resolver firstNameField $ pure $ String "Friedrich"
+    lastNameResolver = Out.Resolver lastNameField $ pure $ String "Nietzsche"
+    firstNameField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
+    lastNameField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
 
 spec :: Spec
 spec =
-    describe "execute" $
+    describe "execute" $ do
         it "skips unknown fields" $
             let expected = Aeson.object
-                    ["data" .= Aeson.object ["count" .= (8 :: Int)]]
+                    [ "data" .= Aeson.object
+                        [ "philosopher" .= Aeson.object
+                            [ "firstName" .= ("Friedrich" :: String)
+                            ]
+                        ]
+                    ]
                 execute' = execute schema (mempty :: HashMap Name Aeson.Value)
                 actual = runIdentity
                     $ either parseError execute'
-                    $ parse document "" "{ count number }"
+                    $ parse document "" "{ philosopher { firstName surname } }"
+             in actual `shouldBe` expected
+        it "merges selections" $
+            let expected = Aeson.object
+                    [ "data" .= Aeson.object
+                        [ "philosopher" .= Aeson.object
+                            [ "firstName" .= ("Friedrich" :: String)
+                            , "lastName" .= ("Nietzsche" :: String)
+                            ]
+                        ]
+                    ]
+                execute' = execute schema (mempty :: HashMap Name Aeson.Value)
+                actual = runIdentity
+                    $ either parseError execute'
+                    $ parse document "" "{ philosopher { firstName } philosopher { lastName } }"
              in actual `shouldBe` expected