Validate field selections on composite types

CHANGELOG.md

@@ -27,7 +27,6 @@ and this project adheres to
 ### Added
 - `Validate.Validation.Rule` constructors:
   - `SelectionRule`
-  - `FieldRule`
   - `FragmentRule`
   - `FragmentSpreadRule`
   - `ArgumentsRule`
@@ -47,6 +46,7 @@ and this project adheres to
   - `noUndefinedVariablesRule`
   - `noUnusedVariablesRule`
   - `uniqueInputFieldNamesRule`
+  - `fieldsOnCorrectTypeRule`
 - `AST.Document.Field`.
 - `AST.Document.FragmentSpread`.
 - `AST.Document.InlineFragment`.

src/Language/GraphQL/Execute/Execution.hs

@@ -124,7 +124,7 @@ completeValue outputType@(Out.EnumBaseType enumType) _ (Type.Enum enum) =
     let Type.EnumType _ _ enumMembers = enumType
      in if HashMap.member enum enumMembers
         then coerceResult outputType $ Enum enum
-        else addErrMsg "Value completion failed."
+        else addErrMsg "Enum value completion failed."
 completeValue (Out.ObjectBaseType objectType) fields result =
     executeSelectionSet result objectType $ mergeSelectionSets fields
 completeValue (Out.InterfaceBaseType interfaceType) fields result
@@ -134,7 +134,7 @@ completeValue (Out.InterfaceBaseType interfaceType) fields result
         case concreteType of
             Just objectType -> executeSelectionSet result objectType
                 $ mergeSelectionSets fields
-            Nothing -> addErrMsg "Value completion failed."
+            Nothing -> addErrMsg "Interface value completion failed."
 completeValue (Out.UnionBaseType unionType) fields result
     | Type.Object objectMap <- result = do
         let abstractType = AbstractUnionType unionType
@@ -142,7 +142,7 @@ completeValue (Out.UnionBaseType unionType) fields result
         case concreteType of
             Just objectType -> executeSelectionSet result objectType
                 $ mergeSelectionSets fields
-            Nothing -> addErrMsg "Value completion failed."
+            Nothing -> addErrMsg "Union value completion failed."
 completeValue _ _ _ = addErrMsg "Value completion failed."
 
 mergeSelectionSets :: MonadCatch m

src/Language/GraphQL/Type/Internal.hs

@@ -3,6 +3,7 @@
    obtain one at https://mozilla.org/MPL/2.0/. -}
 
 {-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE LambdaCase #-}
 
 module Language.GraphQL.Type.Internal
     ( AbstractType(..)
@@ -12,10 +13,12 @@ module Language.GraphQL.Type.Internal
     , instanceOf
     , lookupInputType
     , lookupTypeCondition
+    , lookupTypeField
     ) where
 
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
+import Data.Text (Text)
 import qualified Language.GraphQL.AST as Full
 import qualified Language.GraphQL.Type.Definition as Definition
 import qualified Language.GraphQL.Type.In as In
@@ -55,41 +58,41 @@ collectReferencedTypes schema =
     getField (Out.ValueResolver field _) = field
     getField (Out.EventStreamResolver field _ _) = field
     traverseInputType (In.InputObjectBaseType objectType) =
-        let (In.InputObjectType typeName _ inputFields) = objectType
+        let In.InputObjectType typeName _ inputFields = objectType
             element = InputObjectType objectType
             traverser = flip (foldr visitInputFields) inputFields
          in collect traverser typeName element
     traverseInputType (In.ListBaseType listType) =
         traverseInputType listType
     traverseInputType (In.ScalarBaseType scalarType) =
-        let (Definition.ScalarType typeName _) = scalarType
+        let Definition.ScalarType typeName _ = scalarType
          in collect Prelude.id typeName (ScalarType scalarType)
     traverseInputType (In.EnumBaseType enumType) =
-        let (Definition.EnumType typeName _ _) = enumType
+        let Definition.EnumType typeName _ _ = enumType
          in collect Prelude.id typeName (EnumType enumType)
     traverseOutputType (Out.ObjectBaseType objectType) =
         traverseObjectType objectType
     traverseOutputType (Out.InterfaceBaseType interfaceType) =
         traverseInterfaceType interfaceType
     traverseOutputType (Out.UnionBaseType unionType) =
-        let (Out.UnionType typeName _ types) = unionType
+        let Out.UnionType typeName _ types = unionType
             traverser = flip (foldr traverseObjectType) types
          in collect traverser typeName (UnionType unionType)
     traverseOutputType (Out.ListBaseType listType) =
         traverseOutputType listType
     traverseOutputType (Out.ScalarBaseType scalarType) =
-        let (Definition.ScalarType typeName _) = scalarType
+        let Definition.ScalarType typeName _ = scalarType
          in collect Prelude.id typeName (ScalarType scalarType)
     traverseOutputType (Out.EnumBaseType enumType) =
-        let (Definition.EnumType typeName _ _) = enumType
+        let Definition.EnumType typeName _ _ = enumType
          in collect Prelude.id typeName (EnumType enumType)
     traverseObjectType objectType foundTypes =
-        let (Out.ObjectType typeName _ interfaces fields) = objectType
+        let Out.ObjectType typeName _ interfaces fields = objectType
             element = ObjectType objectType
             traverser = polymorphicTraverser interfaces (getField <$> fields)
          in collect traverser typeName element foundTypes
     traverseInterfaceType interfaceType foundTypes =
-        let (Out.InterfaceType typeName _ interfaces fields) = interfaceType
+        let Out.InterfaceType typeName _ interfaces fields = interfaceType
             element = InterfaceType interfaceType
             traverser = polymorphicTraverser interfaces fields
          in collect traverser typeName element foundTypes
@@ -161,3 +164,21 @@ lookupInputType (Full.TypeNonNull (Full.NonNullTypeNamed nonNull)) types  =
 lookupInputType (Full.TypeNonNull (Full.NonNullTypeList nonNull)) types
     = In.NonNullListType
     <$> lookupInputType nonNull types
+
+lookupTypeField :: forall a. Text -> Out.Type a -> Maybe (Out.Type a)
+lookupTypeField fieldName = \case
+    Out.ObjectBaseType objectType ->
+        objectChild objectType
+    Out.InterfaceBaseType interfaceType ->
+        interfaceChild interfaceType
+    Out.ListBaseType listType -> lookupTypeField fieldName listType
+    _ -> Nothing
+  where
+    objectChild (Out.ObjectType _ _ _ resolvers) =
+        resolverType <$> HashMap.lookup fieldName resolvers
+    interfaceChild (Out.InterfaceType _ _ _ fields) =
+        fieldType <$> HashMap.lookup fieldName fields
+    resolverType (Out.ValueResolver objectField _) = fieldType objectField
+    resolverType (Out.EventStreamResolver objectField _ _) =
+        fieldType objectField
+    fieldType (Out.Field _ type' _) = type'

src/Language/GraphQL/Validate.hs

@@ -2,8 +2,8 @@
    v. 2.0. If a copy of the MPL was not distributed with this file, You can
    obtain one at https://mozilla.org/MPL/2.0/. -}
 
-{-# LANGUAGE ExplicitForAll #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 -- | GraphQL validator.
 module Language.GraphQL.Validate
@@ -16,14 +16,21 @@ import Control.Monad (join)
 import Control.Monad.Trans.Class (MonadTrans(..))
 import Control.Monad.Trans.Reader (runReaderT)
 import Data.Foldable (toList)
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
 import Data.Sequence (Seq(..), (><), (|>))
 import qualified Data.Sequence as Seq
 import Language.GraphQL.AST.Document
 import Language.GraphQL.Type.Internal
+import qualified Language.GraphQL.Type.Out as Out
 import Language.GraphQL.Type.Schema (Schema(..))
+import qualified Language.GraphQL.Type.Schema as Schema
 import Language.GraphQL.Validate.Rules
 import Language.GraphQL.Validate.Validation
 
+type ApplyRule m a =
+    HashMap Name (Schema.Type m) -> Rule m -> Maybe (Out.Type m) -> a -> Seq (RuleT m)
+
 -- | Validates a document and returns a list of found errors. If the returned
 -- list is empty, the document is valid.
 document :: forall m. Schema m -> [Rule m] -> Document -> Seq Error
@@ -37,16 +44,20 @@ document schema' rules' document' =
         }
     reader = do
         rule' <- lift $ Seq.fromList rules'
-        join $ lift $ foldr (definition rule') Seq.empty document'
+        join $ lift $ foldr (definition rule' context) Seq.empty document'
 
-definition :: Rule m -> Definition -> Seq (RuleT m) -> Seq (RuleT m)
+definition :: Rule m
-definition (DefinitionRule rule) definition' accumulator =
+    -> Validation m
+    -> Definition
+    -> Seq (RuleT m)
+    -> Seq (RuleT m)
+definition (DefinitionRule rule) _ definition' accumulator =
     accumulator |> rule definition'
-definition rule (ExecutableDefinition executableDefinition') accumulator =
+definition rule context (ExecutableDefinition definition') accumulator =
-    accumulator >< executableDefinition rule executableDefinition'
+    accumulator >< executableDefinition rule context definition'
-definition rule (TypeSystemDefinition typeSystemDefinition' _) accumulator =
+definition rule _ (TypeSystemDefinition typeSystemDefinition' _) accumulator =
     accumulator >< typeSystemDefinition rule typeSystemDefinition'
-definition rule (TypeSystemExtension extension _) accumulator =
+definition rule _ (TypeSystemExtension extension _) accumulator =
     accumulator >< typeSystemExtension rule extension
 
 typeSystemExtension :: Rule m -> TypeSystemExtension -> Seq (RuleT m)
@@ -82,11 +93,14 @@ schemaExtension rule = \case
     SchemaOperationExtension directives' _ -> directives rule directives'
     SchemaDirectivesExtension directives' -> directives rule directives'
 
-executableDefinition :: Rule m -> ExecutableDefinition -> Seq (RuleT m)
+executableDefinition :: Rule m
-executableDefinition rule (DefinitionOperation operation) =
+    -> Validation m
-    operationDefinition rule operation
+    -> ExecutableDefinition
-executableDefinition rule (DefinitionFragment fragment) =
+    -> Seq (RuleT m)
-    fragmentDefinition rule fragment
+executableDefinition rule context (DefinitionOperation operation) =
+    operationDefinition rule context operation
+executableDefinition rule context (DefinitionFragment fragment) =
+    fragmentDefinition rule context fragment
 
 typeSystemDefinition :: Rule m -> TypeSystemDefinition -> Seq (RuleT m)
 typeSystemDefinition rule = \case
@@ -124,58 +138,101 @@ inputValueDefinition :: Rule m -> InputValueDefinition -> Seq (RuleT m)
 inputValueDefinition rule (InputValueDefinition _ _ _ _ directives') =
     directives rule directives'
 
-operationDefinition :: Rule m -> OperationDefinition -> Seq (RuleT m)
+operationDefinition :: Rule m
-operationDefinition rule operation
+    -> Validation m
+    -> OperationDefinition
+    -> Seq (RuleT m)
+operationDefinition rule context operation
     | OperationDefinitionRule operationRule <- rule =
         pure $ operationRule operation
     | VariablesRule variablesRule <- rule
     , OperationDefinition _ _ variables _ _ _ <- operation
         = Seq.fromList (variableDefinition rule <$> variables)
         |> variablesRule variables
-    | SelectionSet selections _ <- operation = selectionSet rule selections
+    | SelectionSet selections _ <- operation =
-    | OperationDefinition _ _ _ directives' selections _  <- operation =
+        selectionSet types' rule (getRootType Query) selections
-        selectionSet rule selections >< directives rule directives'
+    | OperationDefinition operationType _ _ directives' selections _  <- operation
+        = selectionSet types' rule (getRootType operationType) selections
+        >< directives rule directives'
+  where
+    types' = types context
+    getRootType Query = Just $ Out.NamedObjectType $ query $ schema context
+    getRootType Mutation = Out.NamedObjectType <$> mutation (schema context)
+    getRootType Subscription =
+        Out.NamedObjectType <$> subscription (schema context)
+        
+typeToOut :: forall m. Schema.Type m -> Maybe (Out.Type m)
+typeToOut (Schema.ObjectType objectType) =
+    Just $ Out.NamedObjectType objectType
+typeToOut (Schema.InterfaceType interfaceType) =
+    Just $ Out.NamedInterfaceType interfaceType
+typeToOut (Schema.UnionType unionType) = Just $ Out.NamedUnionType unionType
+typeToOut (Schema.EnumType enumType) = Just $ Out.NamedEnumType enumType
+typeToOut (Schema.ScalarType scalarType) = Just $ Out.NamedScalarType scalarType
+typeToOut _ = Nothing
 
 variableDefinition :: Rule m -> VariableDefinition -> RuleT m
 variableDefinition (ValueRule _ rule) (VariableDefinition _ _ value _) =
     maybe (lift mempty) rule value
 variableDefinition _ _ = lift mempty
 
-fragmentDefinition :: Rule m -> FragmentDefinition -> Seq (RuleT m)
+fragmentDefinition :: forall m
-fragmentDefinition (FragmentDefinitionRule rule) fragmentDefinition' =
+    . Rule m
-    pure $ rule fragmentDefinition'
+    -> Validation m
-fragmentDefinition rule fragmentDefinition'@(FragmentDefinition _ _ directives' selections _)
+    -> FragmentDefinition
-    | FragmentRule definitionRule _ <- rule =
+    -> Seq (RuleT m)
-        applyToChildren |> definitionRule fragmentDefinition'
+fragmentDefinition (FragmentDefinitionRule rule) _ definition' =
-    | otherwise = applyToChildren
+    pure $ rule definition'
+fragmentDefinition rule context definition'
+    | FragmentDefinition _ typeCondition directives' selections _ <- definition'
+    , FragmentRule definitionRule _ <- rule
+        = applyToChildren typeCondition directives' selections
+        |> definitionRule definition'
+    | FragmentDefinition _ typeCondition directives' selections _ <- definition'
+        = applyToChildren typeCondition directives' selections
   where
-    applyToChildren = selectionSet rule selections
+    types' = types context
+    applyToChildren typeCondition directives' selections
+        = selectionSet types' rule (lookupType' typeCondition) selections
         >< directives rule directives'
+    lookupType' = flip lookupType types'
 
-selectionSet :: Traversable t => Rule m -> t Selection -> Seq (RuleT m)
+lookupType :: forall m
-selectionSet = foldMap . selection
+    . TypeCondition
+    -> HashMap Name (Schema.Type m)
+    -> Maybe (Out.Type m)
+lookupType typeCondition types' = HashMap.lookup typeCondition types'
+    >>= typeToOut
 
-selection :: Rule m -> Selection -> Seq (RuleT m)
+selectionSet :: Traversable t => forall m. ApplyRule m (t Selection)
-selection rule selection'
+selectionSet types' rule = foldMap . selection types' rule
+
+selection :: forall m. ApplyRule m Selection
+selection types' rule objectType selection'
     | SelectionRule selectionRule <- rule =
-        applyToChildren |> selectionRule selection'
+        applyToChildren |> selectionRule objectType selection'
     | otherwise = applyToChildren
   where
     applyToChildren =
         case selection' of
-            FieldSelection field' -> field rule field'
+            FieldSelection field' -> field types' rule objectType field'
             InlineFragmentSelection inlineFragment' ->
-                inlineFragment rule inlineFragment'
+                inlineFragment types' rule objectType inlineFragment'
             FragmentSpreadSelection fragmentSpread' ->
                 fragmentSpread rule fragmentSpread'
 
-field :: Rule m -> Field -> Seq (RuleT m)
+field :: forall m. ApplyRule m Field
-field rule field'@(Field _ _ arguments' directives' selections _)
+field types' rule objectType field' = go field'
-    | FieldRule fieldRule <- rule = applyToChildren |> fieldRule field'
-    | ArgumentsRule fieldRule _  <- rule = applyToChildren |> fieldRule field'
-    | otherwise = applyToChildren
   where
-    applyToChildren = selectionSet rule selections
+    go (Field _ fieldName arguments' directives' selections _)
+        | ArgumentsRule fieldRule _  <- rule
+            = applyToChildren fieldName arguments' directives' selections
+            |> fieldRule field'
+        | otherwise =
+            applyToChildren fieldName arguments' directives' selections
+    applyToChildren fieldName arguments' directives' selections =
+        let child = objectType >>= lookupTypeField fieldName
+         in selectionSet types' rule child selections
             >< directives rule directives'
             >< arguments rule arguments'
 
@@ -186,13 +243,18 @@ argument :: Rule m -> Argument -> RuleT m
 argument (ValueRule rule _) (Argument _ (Node value _) _) = rule value
 argument _ _ = lift mempty
 
-inlineFragment :: Rule m -> InlineFragment -> Seq (RuleT m)
+inlineFragment :: forall m. ApplyRule m InlineFragment
-inlineFragment rule inlineFragment'@(InlineFragment _ directives' selections _)
+inlineFragment types' rule objectType inlineFragment' = go inlineFragment'
-    | FragmentRule _ fragmentRule <- rule =
-        applyToChildren |> fragmentRule inlineFragment'
-    | otherwise = applyToChildren
   where
-    applyToChildren = selectionSet rule selections
+    go (InlineFragment optionalType directives' selections _)
+        | FragmentRule _ fragmentRule <- rule
+            = applyToChildren (refineTarget optionalType) directives' selections
+            |> fragmentRule inlineFragment'
+        | otherwise = applyToChildren (refineTarget optionalType) directives' selections
+    refineTarget (Just typeCondition) = lookupType typeCondition types'
+    refineTarget Nothing = objectType
+    applyToChildren objectType' directives' selections
+        = selectionSet types' rule objectType' selections
         >< directives rule directives'
 
 fragmentSpread :: Rule m -> FragmentSpread -> Seq (RuleT m)

src/Language/GraphQL/Validate/Rules.hs

@@ -10,6 +10,7 @@
 -- | This module contains default rules defined in the GraphQL specification.
 module Language.GraphQL.Validate.Rules
     ( executableDefinitionsRule
+    , fieldsOnCorrectTypeRule
     , fragmentsOnCompositeTypesRule
     , fragmentSpreadTargetDefinedRule
     , fragmentSpreadTypeExistenceRule
@@ -40,14 +41,16 @@ import Data.HashMap.Strict (HashMap)
 import Data.HashSet (HashSet)
 import qualified Data.HashSet as HashSet
 import Data.List (groupBy, sortBy, sortOn)
-import Data.Maybe (mapMaybe)
+import Data.Maybe (isJust, mapMaybe)
 import Data.Ord (comparing)
 import Data.Sequence (Seq(..))
 import qualified Data.Sequence as Seq
 import Data.Text (Text)
 import qualified Data.Text as Text
 import Language.GraphQL.AST.Document
+import qualified Language.GraphQL.Type.Definition as Definition
 import Language.GraphQL.Type.Internal
+import qualified Language.GraphQL.Type.Out as Out
 import qualified Language.GraphQL.Type.Schema as Schema
 import Language.GraphQL.Validate.Validation
 
@@ -63,6 +66,8 @@ specifiedRules =
     , singleFieldSubscriptionsRule
     , loneAnonymousOperationRule
     , uniqueOperationNamesRule
+    -- Fields
+    , fieldsOnCorrectTypeRule
     -- Arguments.
     , uniqueArgumentNamesRule
     -- Fragments.
@@ -297,7 +302,7 @@ isSpreadTarget _ _ = False
 -- for both named and inline fragments. If they are not defined in the schema,
 -- the query does not validate.
 fragmentSpreadTypeExistenceRule :: forall m. Rule m
-fragmentSpreadTypeExistenceRule = SelectionRule $ \case
+fragmentSpreadTypeExistenceRule = SelectionRule $ const $ \case
     FragmentSpreadSelection fragmentSelection
         | FragmentSpread fragmentName _ location <- fragmentSelection -> do
             ast' <- asks ast
@@ -672,3 +677,36 @@ uniqueInputFieldNamesRule = ValueRule (lift . go) (lift . constGo)
         <> filterFieldDuplicates fields
     constGo (ConstList values) = foldMap constGo values
     constGo _ = mempty
+
+-- | The target field of a field selection must be defined on the scoped type of
+-- the selection set. There are no limitations on alias names.
+fieldsOnCorrectTypeRule :: forall m. Rule m
+fieldsOnCorrectTypeRule = SelectionRule go
+  where
+    go (Just objectType) (FieldSelection fieldSelection) =
+       fieldRule objectType fieldSelection
+    go _ _ = lift mempty
+    fieldRule objectType (Field _ fieldName _ _ _ location)
+        | isJust (lookupTypeField fieldName objectType) = lift mempty
+        | otherwise = pure $ Error
+            { message = errorMessage fieldName objectType
+            , locations = [location]
+            }
+    errorMessage fieldName objectType = concat
+        [ "Cannot query field \""
+        , Text.unpack fieldName
+        , "\" on type \""
+        , Text.unpack $ outputTypeName objectType
+        , "\"."
+        ]
+    outputTypeName (Out.ObjectBaseType (Out.ObjectType typeName _ _ _)) =
+        typeName
+    outputTypeName (Out.InterfaceBaseType (Out.InterfaceType typeName _ _ _)) =
+        typeName
+    outputTypeName (Out.UnionBaseType (Out.UnionType typeName _ _)) =
+        typeName
+    outputTypeName (Out.ScalarBaseType (Definition.ScalarType typeName _)) =
+        typeName
+    outputTypeName (Out.EnumBaseType (Definition.EnumType typeName _ _)) =
+        typeName
+    outputTypeName (Out.ListBaseType wrappedType) = outputTypeName wrappedType

src/Language/GraphQL/Validate/Validation.hs

@@ -14,6 +14,7 @@ import Control.Monad.Trans.Reader (ReaderT)
 import Data.HashMap.Strict (HashMap)
 import Data.Sequence (Seq)
 import Language.GraphQL.AST.Document
+import qualified Language.GraphQL.Type.Out as Out
 import Language.GraphQL.Type.Schema (Schema)
 import qualified Language.GraphQL.Type.Schema as Schema
 
@@ -37,10 +38,9 @@ data Rule m
     = DefinitionRule (Definition -> RuleT m)
     | OperationDefinitionRule (OperationDefinition -> RuleT m)
     | FragmentDefinitionRule (FragmentDefinition -> RuleT m)
-    | SelectionRule (Selection -> RuleT m)
+    | SelectionRule (Maybe (Out.Type m) -> Selection -> RuleT m)
     | FragmentRule (FragmentDefinition -> RuleT m) (InlineFragment -> RuleT m)
     | FragmentSpreadRule (FragmentSpread -> RuleT m)
-    | FieldRule (Field -> RuleT m)
     | ArgumentsRule (Field -> RuleT m) (Directive -> RuleT m)
     | DirectivesRule ([Directive] -> RuleT m)
     | VariablesRule ([VariableDefinition] -> RuleT m)

tests/Language/GraphQL/ValidateSpec.hs

@@ -9,8 +9,7 @@ module Language.GraphQL.ValidateSpec
     ( spec
     ) where
 
-import Data.Sequence (Seq(..))
+import Data.Foldable (toList)
-import qualified Data.Sequence as Seq
 import qualified Data.HashMap.Strict as HashMap
 import Data.Text (Text)
 import qualified Language.GraphQL.AST as AST
@@ -18,7 +17,7 @@ import Language.GraphQL.Type
 import qualified Language.GraphQL.Type.In as In
 import qualified Language.GraphQL.Type.Out as Out
 import Language.GraphQL.Validate
-import Test.Hspec (Spec, describe, it, shouldBe)
+import Test.Hspec (Spec, describe, it, shouldBe, shouldContain)
 import Text.Megaparsec (parse)
 import Text.RawString.QQ (r)
 
@@ -30,11 +29,17 @@ schema = Schema
     } 
 
 queryType :: ObjectType IO
-queryType = ObjectType "Query" Nothing []
+queryType = ObjectType "Query" Nothing [] $ HashMap.fromList
-    $ HashMap.singleton "dog" dogResolver
+    [ ("dog", dogResolver)
+    , ("findDog", findDogResolver)
+    ]
   where
     dogField = Field Nothing (Out.NamedObjectType dogType) mempty
     dogResolver = ValueResolver dogField $ pure Null
+    findDogArguments = HashMap.singleton "complex"
+        $ In.Argument Nothing (In.NonNullInputObjectType dogDataType) Nothing
+    findDogField = Field Nothing (Out.NamedObjectType dogType) findDogArguments
+    findDogResolver = ValueResolver findDogField $ pure Null
 
 dogCommandType :: EnumType
 dogCommandType = EnumType "DogCommand" Nothing $ HashMap.fromList
@@ -72,6 +77,12 @@ dogType = ObjectType "Dog" Nothing [petType] $ HashMap.fromList
     ownerField = Field Nothing (Out.NamedObjectType humanType) mempty
     ownerResolver = ValueResolver ownerField $ pure Null
 
+dogDataType :: InputObjectType
+dogDataType = InputObjectType "DogData" Nothing
+    $ HashMap.singleton "name" nameInputField
+  where
+    nameInputField = InputField Nothing (In.NonNullScalarType string) Nothing
+
 sentientType :: InterfaceType IO
 sentientType = InterfaceType "Sentient" Nothing []
     $ HashMap.singleton "name"
@@ -114,39 +125,14 @@ humanType = ObjectType "Human" Nothing [sentientType] $ HashMap.fromList
         Field Nothing (Out.ListType $ Out.NonNullInterfaceType petType) mempty
     petsResolver = ValueResolver petsField $ pure $ List []
 {-
-catCommandType :: EnumType
-catCommandType = EnumType "CatCommand" Nothing $ HashMap.fromList
-    [ ("JUMP", EnumValue Nothing)
-    ]
-
-catType :: ObjectType IO
-catType = ObjectType "Cat" Nothing [petType] $ HashMap.fromList
-    [ ("name", nameResolver)
-    , ("nickname", nicknameResolver)
-    , ("doesKnowCommand", doesKnowCommandResolver)
-    , ("meowVolume", meowVolumeResolver)
-    ]
-  where
-    nameField = Field Nothing (Out.NonNullScalarType string) mempty
-    nameResolver = ValueResolver nameField $ pure "Name"
-    nicknameField = Field Nothing (Out.NamedScalarType string) mempty
-    nicknameResolver = ValueResolver nicknameField $ pure "Nickname"
-    doesKnowCommandField = Field Nothing (Out.NonNullScalarType boolean)
-        $ HashMap.singleton "catCommand"
-        $ In.Argument Nothing (In.NonNullEnumType catCommandType) Nothing
-    doesKnowCommandResolver = ValueResolver doesKnowCommandField
-        $ pure $ Boolean True
-    meowVolumeField = Field Nothing (Out.NamedScalarType int) mempty
-    meowVolumeResolver = ValueResolver meowVolumeField $ pure $ Int 2
-
 catOrDogType :: UnionType IO
 catOrDogType = UnionType "CatOrDog" Nothing [catType, dogType]
 -}
-validate :: Text -> Seq Error
+validate :: Text -> [Error]
 validate queryString =
     case parse AST.document "" queryString of
-        Left _ -> Seq.empty
+        Left _ -> []
-        Right ast -> document schema specifiedRules ast
+        Right ast -> toList $ document schema specifiedRules ast
 
 spec :: Spec
 spec =
@@ -169,7 +155,7 @@ spec =
                         "Definition must be OperationDefinition or FragmentDefinition."
                     , locations = [AST.Location 9 15]
                     }
-             in validate queryString `shouldBe` Seq.singleton expected
+               in validate queryString `shouldContain` [expected]
 
         it "rejects multiple subscription root fields" $
             let queryString = [r|
@@ -186,7 +172,7 @@ spec =
                         "Subscription sub must select only one top level field."
                     , locations = [AST.Location 2 15]
                     }
-             in validate queryString `shouldBe` Seq.singleton expected
+             in validate queryString `shouldContain` [expected]
 
         it "rejects multiple subscription root fields coming from a fragment" $
             let queryString = [r|
@@ -207,7 +193,7 @@ spec =
                         "Subscription sub must select only one top level field."
                     , locations = [AST.Location 2 15]
                     }
-             in validate queryString `shouldBe` Seq.singleton expected
+             in validate queryString `shouldContain` [expected]
 
         it "rejects multiple anonymous operations" $
             let queryString = [r|
@@ -230,7 +216,7 @@ spec =
                         "This anonymous operation must be the only defined operation."
                     , locations = [AST.Location 2 15]
                     }
-             in validate queryString `shouldBe` Seq.singleton expected
+             in validate queryString `shouldBe` [expected]
 
         it "rejects operations with the same name" $
             let queryString = [r|
@@ -251,7 +237,7 @@ spec =
                         "There can be only one operation named \"dogOperation\"."
                     , locations = [AST.Location 2 15, AST.Location 8 15]
                     }
-             in validate queryString `shouldBe` Seq.singleton expected
+             in validate queryString `shouldBe` [expected]
 
         it "rejects fragments with the same name" $
             let queryString = [r|
@@ -276,7 +262,7 @@ spec =
                         "There can be only one fragment named \"fragmentOne\"."
                     , locations = [AST.Location 8 15, AST.Location 12 15]
                     }
-             in validate queryString `shouldBe` Seq.singleton expected
+             in validate queryString `shouldBe` [expected]
 
         it "rejects the fragment spread without a target" $
             let queryString = [r|
@@ -291,7 +277,7 @@ spec =
                         "Fragment target \"undefinedFragment\" is undefined."
                     , locations = [AST.Location 4 19]
                     }
-             in validate queryString `shouldBe` Seq.singleton expected
+             in validate queryString `shouldBe` [expected]
 
         it "rejects fragment spreads without an unknown target type" $
             let queryString = [r|
@@ -310,7 +296,7 @@ spec =
                         \\"NotInSchema\" which doesn't exist in the schema."
                     , locations = [AST.Location 4 19]
                     }
-             in validate queryString `shouldBe` Seq.singleton expected
+             in validate queryString `shouldBe` [expected]
 
         it "rejects inline fragments without a target" $
             let queryString = [r|
@@ -326,7 +312,7 @@ spec =
                         \which doesn't exist in the schema."
                     , locations = [AST.Location 3 17]
                     }
-             in validate queryString `shouldBe` Seq.singleton expected
+             in validate queryString `shouldBe` [expected]
 
         it "rejects fragments on scalar types" $
             let queryString = [r|
@@ -345,7 +331,7 @@ spec =
                         \\"Int\"."
                     , locations = [AST.Location 7 15]
                     }
-             in validate queryString `shouldBe` Seq.singleton expected
+             in validate queryString `shouldContain` [expected]
 
         it "rejects inline fragments on scalar types" $
             let queryString = [r|
@@ -361,7 +347,7 @@ spec =
                         \\"Boolean\"."
                     , locations = [AST.Location 3 17]
                     }
-             in validate queryString `shouldBe` Seq.singleton expected
+             in validate queryString `shouldContain` [expected]
 
         it "rejects unused fragments" $
             let queryString = [r|
@@ -380,7 +366,7 @@ spec =
                         "Fragment \"nameFragment\" is never used."
                     , locations = [AST.Location 2 15]
                     }
-             in validate queryString `shouldBe` Seq.singleton expected
+             in validate queryString `shouldBe` [expected]
 
         it "rejects spreads that form cycles" $
             let queryString = [r|
@@ -412,7 +398,7 @@ spec =
                         \nameFragment)."
                     , locations = [AST.Location 7 15]
                     }
-             in validate queryString `shouldBe` Seq.fromList [error1, error2]
+             in validate queryString `shouldBe` [error1, error2]
 
         it "rejects duplicate field arguments" $ do
             let queryString = [r|
@@ -427,20 +413,22 @@ spec =
                         "There can be only one argument named \"atOtherHomes\"."
                     , locations = [AST.Location 4 34, AST.Location 4 54]
                     }
-             in validate queryString `shouldBe` Seq.singleton expected
+             in validate queryString `shouldBe` [expected]
 
         it "rejects more than one directive per location" $ do
             let queryString = [r|
               query ($foo: Boolean = true, $bar: Boolean = false) {
-                field @skip(if: $foo) @skip(if: $bar)
+                dog @skip(if: $foo) @skip(if: $bar) {
+                  name
+                }
               }
             |]
                 expected = Error
                     { message =
                         "There can be only one directive named \"skip\"."
-                    , locations = [AST.Location 3 23, AST.Location 3 39]
+                    , locations = [AST.Location 3 21, AST.Location 3 37]
                     }
-             in validate queryString `shouldBe` Seq.singleton expected
+             in validate queryString `shouldBe` [expected]
 
         it "rejects duplicate variables" $
             let queryString = [r|
@@ -455,7 +443,7 @@ spec =
                         "There can be only one variable named \"atOtherHomes\"."
                     , locations = [AST.Location 2 39, AST.Location 2 63]
                     }
-             in validate queryString `shouldBe` Seq.singleton expected
+             in validate queryString `shouldBe` [expected]
 
         it "rejects non-input types as variables" $
             let queryString = [r|
@@ -470,7 +458,7 @@ spec =
                         "Variable \"$dog\" cannot be non-input type \"Dog\"."
                     , locations = [AST.Location 2 34]
                     }
-             in validate queryString `shouldBe` Seq.singleton expected
+             in validate queryString `shouldBe` [expected]
 
         it "rejects undefined variables" $
             let queryString = [r|
@@ -491,7 +479,7 @@ spec =
                         \\"variableIsNotDefinedUsedInSingleFragment\"."
                     , locations = [AST.Location 9 46]
                     }
-             in validate queryString `shouldBe` Seq.singleton expected
+             in validate queryString `shouldBe` [expected]
 
         it "rejects unused variables" $
             let queryString = [r|
@@ -507,7 +495,7 @@ spec =
                         \\"variableUnused\"."
                     , locations = [AST.Location 2 36]
                     }
-             in validate queryString `shouldBe` Seq.singleton expected
+             in validate queryString `shouldBe` [expected]
 
         it "rejects duplicate fields in input objects" $
             let queryString = [r|
@@ -520,4 +508,4 @@ spec =
                         "There can be only one input field named \"name\"."
                     , locations = [AST.Location 3 36, AST.Location 3 50]
                     }
-             in validate queryString `shouldBe` Seq.singleton expected
+             in validate queryString `shouldBe` [expected]

tests/Test/FragmentSpec.hs

@@ -108,21 +108,17 @@ spec = do
 
         it "embeds inline fragments without type" $ do
             let sourceQuery = [r|{
-              garment {
               circumference
               ... {
                 size
               }
-              }
             }|]
-            actual <- graphql (toSchema "garment" $ garment "Hat") sourceQuery
+            actual <- graphql (toSchema "circumference" circumference) sourceQuery
             let expected = HashMap.singleton "data"
                     $ Aeson.object
-                        [ "garment" .= Aeson.object
                         [ "circumference" .= (60 :: Int)
                         , "size" .= ("L" :: Text)
                         ]
-                        ]
              in actual `shouldResolveTo` expected
 
         it "evaluates fragments on Query" $ do

tests/Test/StarWars/Schema.hs

@@ -41,72 +41,88 @@ schema = Schema
     droidFieldResolver = ValueResolver droidField droid
 
 heroObject :: Out.ObjectType (Either SomeException)
-heroObject = Out.ObjectType "Human" Nothing [] $ HashMap.fromList
+heroObject = Out.ObjectType "Human" Nothing [characterType] $ HashMap.fromList
     [ ("id", idFieldType)
     , ("name", nameFieldType)
-    , ("friends", friendsFieldType)
+    , ("friends", friendsFieldResolver)
-    , ("appearsIn", appearsInField)
+    , ("appearsIn", appearsInFieldResolver)
     , ("homePlanet", homePlanetFieldType)
-    , ("secretBackstory", secretBackstoryFieldType)
+    , ("secretBackstory", secretBackstoryFieldResolver)
-    , ("__typename", typenameFieldType)
+    , ("__typename", typenameFieldResolver)
     ]
   where
     homePlanetFieldType
       = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
-      $ idField "homePlanet"
+      $ defaultResolver "homePlanet"
 
 droidObject :: Out.ObjectType (Either SomeException)
-droidObject = Out.ObjectType "Droid" Nothing [] $ HashMap.fromList
+droidObject = Out.ObjectType "Droid" Nothing [characterType] $ HashMap.fromList
     [ ("id", idFieldType)
     , ("name", nameFieldType)
-    , ("friends", friendsFieldType)
+    , ("friends", friendsFieldResolver)
-    , ("appearsIn", appearsInField)
+    , ("appearsIn", appearsInFieldResolver)
     , ("primaryFunction", primaryFunctionFieldType)
-    , ("secretBackstory", secretBackstoryFieldType)
+    , ("secretBackstory", secretBackstoryFieldResolver)
-    , ("__typename", typenameFieldType)
+    , ("__typename", typenameFieldResolver)
     ]
   where
     primaryFunctionFieldType
         = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
-        $ idField "primaryFunction"
+        $ defaultResolver "primaryFunction"
 
-typenameFieldType :: Resolver (Either SomeException)
+typenameFieldResolver :: Resolver (Either SomeException)
-typenameFieldType
+typenameFieldResolver
     = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
-    $ idField "__typename"
+    $ defaultResolver "__typename"
 
 idFieldType :: Resolver (Either SomeException)
-idFieldType
+idFieldType = ValueResolver idField $ defaultResolver "id"
-    = ValueResolver (Out.Field Nothing (Out.NamedScalarType id) mempty)
-    $ idField "id"
 
 nameFieldType :: Resolver (Either SomeException)
-nameFieldType
+nameFieldType = ValueResolver nameField $ defaultResolver "name"
-    = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
-    $ idField "name"
 
-friendsFieldType :: Resolver (Either SomeException)
+friendsFieldResolver :: Resolver (Either SomeException)
-friendsFieldType
+friendsFieldResolver = ValueResolver friendsField $ defaultResolver "friends"
-    = ValueResolver (Out.Field Nothing fieldType mempty)
+
-    $ idField "friends"
+characterType :: InterfaceType (Either SomeException)
+characterType = InterfaceType "Character" Nothing [] $ HashMap.fromList
+    [ ("id", idField)
+    , ("name", nameField)
+    , ("friends", friendsField)
+    , ("appearsIn", appearsInField)
+    , ("secretBackstory", secretBackstoryField)
+    ]
+
+idField :: Field (Either SomeException)
+idField = Field Nothing (Out.NonNullScalarType id) mempty
+
+nameField :: Field (Either SomeException)
+nameField = Field Nothing (Out.NamedScalarType string) mempty
+
+friendsField :: Field (Either SomeException)
+friendsField = Field Nothing friendsFieldType mempty
   where
-    fieldType = Out.ListType $ Out.NamedObjectType droidObject
+    friendsFieldType = Out.ListType (Out.NamedInterfaceType characterType)
 
-appearsInField :: Resolver (Either SomeException)
+appearsInField :: Field (Either SomeException)
-appearsInField
+appearsInField = Field appearsInDescription appearsInFieldType mempty
-    = ValueResolver (Out.Field (Just description) fieldType mempty)
-    $ idField "appearsIn"
   where
-    fieldType = Out.ListType $ Out.NamedEnumType episodeEnum
+    appearsInDescription = Just "Which movies they appear in."
-    description = "Which movies they appear in."
+    appearsInFieldType = Out.ListType $ Out.NamedEnumType episodeEnum
 
-secretBackstoryFieldType :: Resolver (Either SomeException)
+secretBackstoryField :: Field (Either SomeException)
-secretBackstoryFieldType = ValueResolver field secretBackstory
+secretBackstoryField =
-  where
+    Out.Field Nothing (Out.NamedScalarType string) mempty
-    field = Out.Field Nothing (Out.NamedScalarType string) mempty
 
-idField :: Text -> Resolve (Either SomeException)
+appearsInFieldResolver :: Resolver (Either SomeException)
-idField f = do
+appearsInFieldResolver = ValueResolver appearsInField
+    $ defaultResolver "appearsIn"
+
+secretBackstoryFieldResolver :: Resolver (Either SomeException)
+secretBackstoryFieldResolver = ValueResolver secretBackstoryField secretBackstory
+
+defaultResolver :: Text -> Resolve (Either SomeException)
+defaultResolver f = do
     v <- asks values
     let (Object v') = v
     pure $ v' HashMap.! f