Validate field selections on composite types

2020-09-25 21:57:25 +02:00
parent 9bfa2aa7e8
commit 3373c94895
10 changed files with 295 additions and 174 deletions
--- a/CHANGELOG.md
+++ b/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`.
--- a/src/Language/GraphQL/Execute/Execution.hs
+++ b/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
--- a/src/Language/GraphQL/Type/Internal.hs
+++ b/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'
--- a/src/Language/GraphQL/Validate.hs
+++ b/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 (DefinitionRule rule) definition' accumulator =
+definition :: Rule m
+    -> Validation m
+    -> Definition
+    -> Seq (RuleT m)
+    -> Seq (RuleT m)
+definition (DefinitionRule rule) _ definition' accumulator =
    accumulator |> rule definition'
-definition rule (ExecutableDefinition executableDefinition') accumulator =
-    accumulator >< executableDefinition rule executableDefinition'
-definition rule (TypeSystemDefinition typeSystemDefinition' _) accumulator =
+definition rule context (ExecutableDefinition definition') accumulator =
+    accumulator >< executableDefinition rule context definition'
+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 (DefinitionOperation operation) =
-    operationDefinition rule operation
-executableDefinition rule (DefinitionFragment fragment) =
-    fragmentDefinition rule fragment
+executableDefinition :: Rule m
+    -> Validation m
+    -> ExecutableDefinition
+    -> Seq (RuleT m)
+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,60 +138,103 @@ inputValueDefinition :: Rule m -> InputValueDefinition -> Seq (RuleT m)
 inputValueDefinition rule (InputValueDefinition _ _ _ _ directives') =
    directives rule directives'

-operationDefinition :: Rule m -> OperationDefinition -> Seq (RuleT m)
-operationDefinition rule operation
+operationDefinition :: Rule m
+    -> 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
-    | OperationDefinition _ _ _ directives' selections _  <- operation =
-        selectionSet rule selections >< directives rule directives'
+    | SelectionSet selections _ <- operation =
+        selectionSet types' rule (getRootType Query) selections
+    | 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 (FragmentDefinitionRule rule) fragmentDefinition' =
-    pure $ rule fragmentDefinition'
-fragmentDefinition rule fragmentDefinition'@(FragmentDefinition _ _ directives' selections _)
-    | FragmentRule definitionRule _ <- rule =
-        applyToChildren |> definitionRule fragmentDefinition'
-    | otherwise = applyToChildren
+fragmentDefinition :: forall m
+    . Rule m
+    -> Validation m
+    -> FragmentDefinition
+    -> Seq (RuleT m)
+fragmentDefinition (FragmentDefinitionRule rule) _ definition' =
+    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)
-selectionSet = foldMap . selection
+lookupType :: forall m
+    . 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)
-selection rule selection'
+selectionSet :: Traversable t => forall m. ApplyRule m (t 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 rule field'@(Field _ _ arguments' directives' selections _)
-    | FieldRule fieldRule <- rule = applyToChildren |> fieldRule field'
-    | ArgumentsRule fieldRule _  <- rule = applyToChildren |> fieldRule field'
-    | otherwise = applyToChildren
+field :: forall m. ApplyRule m Field
+field types' rule objectType field' = go field'
  where
-    applyToChildren = selectionSet rule selections
-        >< directives rule directives'
-        >< arguments rule arguments'
+    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'

 arguments :: Rule m -> [Argument] -> Seq (RuleT m)
 arguments = (.) Seq.fromList . fmap . argument
@@ -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 rule inlineFragment'@(InlineFragment _ directives' selections _)
-    | FragmentRule _ fragmentRule <- rule =
-        applyToChildren |> fragmentRule inlineFragment'
-    | otherwise = applyToChildren
+inlineFragment :: forall m. ApplyRule m InlineFragment
+inlineFragment types' rule objectType inlineFragment' = go inlineFragment'
  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)
--- a/src/Language/GraphQL/Validate/Rules.hs
+++ b/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
--- a/src/Language/GraphQL/Validate/Validation.hs
+++ b/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)
--- a/tests/Language/GraphQL/ValidateSpec.hs
+++ b/tests/Language/GraphQL/ValidateSpec.hs
@@ -9,8 +9,7 @@ module Language.GraphQL.ValidateSpec
    ( spec
    ) where

-import Data.Sequence (Seq(..))
-import qualified Data.Sequence as Seq
+import Data.Foldable (toList)
 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 []
-    $ HashMap.singleton "dog" dogResolver
+queryType = ObjectType "Query" Nothing [] $ HashMap.fromList
+    [ ("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
-        Right ast -> document schema specifiedRules ast
+        Left _ -> []
+        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]
--- a/tests/Test/FragmentSpec.hs
+++ b/tests/Test/FragmentSpec.hs
@@ -108,20 +108,16 @@ spec = do

        it "embeds inline fragments without type" $ do
            let sourceQuery = [r|{
-              garment {
-                circumference
-                ... {
-                  size
-                }
+              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)
-                            ]
+                        [ "circumference" .= (60 :: Int)
+                        , "size" .= ("L" :: Text)
                        ]
             in actual `shouldResolveTo` expected

--- a/tests/Test/StarWars/QuerySpec.hs
+++ b/tests/Test/StarWars/QuerySpec.hs
@@ -23,9 +23,9 @@ spec = describe "Star Wars Query Tests" $ do
      it "R2-D2 hero" $ testQuery
        [r| query HeroNameQuery {
            hero {
-                id
-            }
+              id
            }
+          }
        |]
        $ Aeson.object
            [ "data" .= Aeson.object
@@ -35,13 +35,13 @@ spec = describe "Star Wars Query Tests" $ do
      it "R2-D2 ID and friends" $ testQuery
        [r| query HeroNameAndFriendsQuery {
            hero {
-                id
+              id
+              name
+              friends {
                name
-                friends {
-                  name
-                }
-            }
+              }
            }
+          }
        |]
        $ Aeson.object [ "data" .= Aeson.object [
            "hero" .= Aeson.object
@@ -266,7 +266,7 @@ spec = describe "Star Wars Query Tests" $ do
            query HeroNameQuery {
              hero {
                name
-                  secretBackstory
+                secretBackstory
              }
            }
          |]
--- a/tests/Test/StarWars/Schema.hs
+++ b/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)
-    , ("appearsIn", appearsInField)
+    , ("friends", friendsFieldResolver)
+    , ("appearsIn", appearsInFieldResolver)
    , ("homePlanet", homePlanetFieldType)
-    , ("secretBackstory", secretBackstoryFieldType)
-    , ("__typename", typenameFieldType)
+    , ("secretBackstory", secretBackstoryFieldResolver)
+    , ("__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)
-    , ("appearsIn", appearsInField)
+    , ("friends", friendsFieldResolver)
+    , ("appearsIn", appearsInFieldResolver)
    , ("primaryFunction", primaryFunctionFieldType)
-    , ("secretBackstory", secretBackstoryFieldType)
-    , ("__typename", typenameFieldType)
+    , ("secretBackstory", secretBackstoryFieldResolver)
+    , ("__typename", typenameFieldResolver)
    ]
  where
    primaryFunctionFieldType
        = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
-        $ idField "primaryFunction"
+        $ defaultResolver "primaryFunction"

-typenameFieldType :: Resolver (Either SomeException)
-typenameFieldType
+typenameFieldResolver :: Resolver (Either SomeException)
+typenameFieldResolver
    = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
-    $ idField "__typename"
+    $ defaultResolver "__typename"

 idFieldType :: Resolver (Either SomeException)
-idFieldType
-    = ValueResolver (Out.Field Nothing (Out.NamedScalarType id) mempty)
-    $ idField "id"
+idFieldType = ValueResolver idField $ defaultResolver "id"

 nameFieldType :: Resolver (Either SomeException)
-nameFieldType
-    = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
-    $ idField "name"
+nameFieldType = ValueResolver nameField $ defaultResolver "name"

-friendsFieldType :: Resolver (Either SomeException)
-friendsFieldType
-    = ValueResolver (Out.Field Nothing fieldType mempty)
-    $ idField "friends"
+friendsFieldResolver :: Resolver (Either SomeException)
+friendsFieldResolver = ValueResolver friendsField $ defaultResolver "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
-    = ValueResolver (Out.Field (Just description) fieldType mempty)
-    $ idField "appearsIn"
+appearsInField :: Field (Either SomeException)
+appearsInField = Field appearsInDescription appearsInFieldType mempty
  where
-    fieldType = Out.ListType $ Out.NamedEnumType episodeEnum
-    description = "Which movies they appear in."
+    appearsInDescription = Just "Which movies they appear in."
+    appearsInFieldType = Out.ListType $ Out.NamedEnumType episodeEnum

-secretBackstoryFieldType :: Resolver (Either SomeException)
-secretBackstoryFieldType = ValueResolver field secretBackstory
-  where
-    field = Out.Field Nothing (Out.NamedScalarType string) mempty
+secretBackstoryField :: Field (Either SomeException)
+secretBackstoryField =
+    Out.Field Nothing (Out.NamedScalarType string) mempty

-idField :: Text -> Resolve (Either SomeException)
-idField f = do
+appearsInFieldResolver :: Resolver (Either SomeException)
+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