Validate arguments are defined

CHANGELOG.md

@@ -23,6 +23,7 @@ and this project adheres to
   the path without executing the query.
 - `Error.Error`: `path` added. It is currently always empty.
 - `Validate.Validation.Path` was moved to `Error`.
+- `Type.Schema.Schema` gets an additional field, `Schema.directives`.
 
 ### Added
 - `Validate.Validation.Rule` constructors:
@@ -32,6 +33,7 @@ and this project adheres to
   - `ArgumentsRule`
   - `DirectivesRule`
   - `VariablesRule`
+  - `FieldRule`
 - `Validate.Rules`:
   - `fragmentsOnCompositeTypesRule`
   - `fragmentSpreadTargetDefinedRule`
@@ -48,10 +50,15 @@ and this project adheres to
   - `uniqueInputFieldNamesRule`
   - `fieldsOnCorrectTypeRule`
   - `scalarLeafsRule`
+  - `knownArgumentNamesRule`
 - `AST.Document.Field`.
 - `AST.Document.FragmentSpread`.
 - `AST.Document.InlineFragment`.
 - `AST.Document.Node`.
+- `Type.In.Arguments`: Type alias for an argument map.
+- `Type.Schema.Directive` and `Type.Schema.Directives` are directive definition
+  representation.
+- `Type.Schema.schema`: Shortcut for creating a schema.
 
 ### Fixed
 - Collecting existing types from the schema considers subscriptions.

src/Language/GraphQL.hs

@@ -18,7 +18,7 @@ import Language.GraphQL.AST
 import Language.GraphQL.Error
 import Language.GraphQL.Execute
 import qualified Language.GraphQL.Validate as Validate
-import Language.GraphQL.Type.Schema
+import Language.GraphQL.Type.Schema (Schema)
 import Text.Megaparsec (parse)
 
 -- | If the text parses correctly as a @GraphQL@ query the query is

src/Language/GraphQL/Execute.hs

@@ -32,8 +32,8 @@ execute :: (MonadCatch m, VariableValue a, Serialize b)
     -> HashMap Name a -- ^ Variable substitution function.
     -> Document -- @GraphQL@ document.
     -> m (Either (ResponseEventStream m b) (Response b))
-execute schema operationName subs document =
+execute schema' operationName subs document =
-    case Transform.document schema operationName subs document of
+    case Transform.document schema' operationName subs document of
         Left queryError -> pure
             $ Right
             $ singleError

src/Language/GraphQL/Execute/Transform.hs

@@ -49,14 +49,15 @@ import qualified Language.GraphQL.Type.Definition as Definition
 import qualified Language.GraphQL.Type as Type
 import Language.GraphQL.Type.Internal
 import qualified Language.GraphQL.Type.Out as Out
-import Language.GraphQL.Type.Schema
+import Language.GraphQL.Type.Schema (Schema)
+import qualified Language.GraphQL.Type.Schema as Schema
 
 -- | Associates a fragment name with a list of 'Field's.
 data Replacement m = Replacement
     { fragments :: HashMap Full.Name (Fragment m)
     , fragmentDefinitions :: FragmentDefinitions
     , variableValues :: Type.Subs
-    , types :: HashMap Full.Name (Type m)
+    , types :: HashMap Full.Name (Schema.Type m)
     }
 
 type FragmentDefinitions = HashMap Full.Name Full.FragmentDefinition
@@ -84,7 +85,7 @@ data Field m = Field
 
 -- | Contains the operation to be executed along with its root type.
 data Document m = Document
-    (HashMap Full.Name (Type m)) (Out.ObjectType m) (Operation m)
+    (HashMap Full.Name (Schema.Type m)) (Out.ObjectType m) (Operation m)
 
 data OperationDefinition = OperationDefinition
     Full.OperationType
@@ -140,7 +141,7 @@ getOperation (Just operationName) operations
 
 coerceVariableValues :: Coerce.VariableValue a
     => forall m
-    . HashMap Full.Name (Type m)
+    . HashMap Full.Name (Schema.Type m)
     -> OperationDefinition
     -> HashMap.HashMap Full.Name a
     -> Either QueryError Type.Subs
@@ -203,14 +204,14 @@ document schema operationName subs ast = do
             }
     case chosenOperation of
         OperationDefinition Full.Query _ _ _ _ ->
-            pure $ Document referencedTypes (query schema)
+            pure $ Document referencedTypes (Schema.query schema)
                 $ operation chosenOperation replacement
         OperationDefinition Full.Mutation _ _ _ _
-            | Just mutationType <- mutation schema ->
+            | Just mutationType <- Schema.mutation schema ->
                 pure $ Document referencedTypes mutationType
                     $ operation chosenOperation replacement
         OperationDefinition Full.Subscription _ _ _ _
-            | Just subscriptionType <- subscription schema ->
+            | Just subscriptionType <- Schema.subscription schema ->
                 pure $ Document referencedTypes subscriptionType
                     $ operation chosenOperation replacement
         _ -> Left UnsupportedRootOperation

src/Language/GraphQL/Type.hs

@@ -21,6 +21,6 @@ module Language.GraphQL.Type
     ) where
 
 import Language.GraphQL.Type.Definition
-import Language.GraphQL.Type.Schema (Schema(..))
+import Language.GraphQL.Type.Schema (Schema(..), schema)
 import qualified Language.GraphQL.Type.In as In
 import qualified Language.GraphQL.Type.Out as Out

src/Language/GraphQL/Type/In.hs

@@ -11,6 +11,7 @@
 -- with 'Language.GraphQL.Type.Out'.
 module Language.GraphQL.Type.In
     ( Argument(..)
+    , Arguments
     , InputField(..)
     , InputObjectType(..)
     , Type(..)
@@ -24,10 +25,10 @@ module Language.GraphQL.Type.In
 import Data.HashMap.Strict (HashMap)
 import Data.Text (Text)
 import Language.GraphQL.AST.Document (Name)
-import Language.GraphQL.Type.Definition
+import qualified Language.GraphQL.Type.Definition as Definition
 
 -- | Single field of an 'InputObjectType'.
-data InputField = InputField (Maybe Text) Type (Maybe Value)
+data InputField = InputField (Maybe Text) Type (Maybe Definition.Value)
 
 -- | Input object type definition.
 --
@@ -45,25 +46,28 @@ instance Eq InputObjectType where
 -- type can wrap other wrapping or named types. Wrapping types are lists and
 -- Non-Null types (named types are nullable by default).
 data Type
-    = NamedScalarType ScalarType
+    = NamedScalarType Definition.ScalarType
-    | NamedEnumType EnumType
+    | NamedEnumType Definition.EnumType
     | NamedInputObjectType InputObjectType
     | ListType Type
-    | NonNullScalarType ScalarType
+    | NonNullScalarType Definition.ScalarType
-    | NonNullEnumType EnumType
+    | NonNullEnumType Definition.EnumType
     | NonNullInputObjectType InputObjectType
     | NonNullListType Type
     deriving Eq
 
 -- | Field argument definition.
-data Argument = Argument (Maybe Text) Type (Maybe Value)
+data Argument = Argument (Maybe Text) Type (Maybe Definition.Value)
+
+-- | Field argument definitions.
+type Arguments = HashMap Name Argument
 
 -- | Matches either 'NamedScalarType' or 'NonNullScalarType'.
-pattern ScalarBaseType :: ScalarType -> Type
+pattern ScalarBaseType :: Definition.ScalarType -> Type
 pattern ScalarBaseType scalarType <- (isScalarType -> Just scalarType)
 
 -- | Matches either 'NamedEnumType' or 'NonNullEnumType'.
-pattern EnumBaseType :: EnumType -> Type
+pattern EnumBaseType :: Definition.EnumType -> Type
 pattern EnumBaseType enumType <- (isEnumType -> Just enumType)
 
 -- | Matches either 'NamedInputObjectType' or 'NonNullInputObjectType'.
@@ -76,7 +80,7 @@ pattern ListBaseType listType <- (isListType -> Just listType)
 
 {-# COMPLETE EnumBaseType, ListBaseType, InputObjectBaseType, ScalarBaseType #-}
 
-isScalarType :: Type -> Maybe ScalarType
+isScalarType :: Type -> Maybe Definition.ScalarType
 isScalarType (NamedScalarType inputType) = Just inputType
 isScalarType (NonNullScalarType inputType) = Just inputType
 isScalarType _ = Nothing
@@ -86,7 +90,7 @@ isInputObjectType (NamedInputObjectType inputType) = Just inputType
 isInputObjectType (NonNullInputObjectType inputType) = Just inputType
 isInputObjectType _ = Nothing
 
-isEnumType :: Type -> Maybe EnumType
+isEnumType :: Type -> Maybe Definition.EnumType
 isEnumType (NamedEnumType inputType) = Just inputType
 isEnumType (NonNullEnumType inputType) = Just inputType
 isEnumType _ = Nothing

src/Language/GraphQL/Type/Internal.hs

@@ -18,12 +18,12 @@ module Language.GraphQL.Type.Internal
 
 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
 import qualified Language.GraphQL.Type.Out as Out
-import Language.GraphQL.Type.Schema
+import Language.GraphQL.Type.Schema (Schema)
+import qualified Language.GraphQL.Type.Schema as Schema
 
 -- | These types may describe the parent context of a selection set.
 data CompositeType m
@@ -39,13 +39,15 @@ data AbstractType m
     deriving Eq
 
 -- | Traverses the schema and finds all referenced types.
-collectReferencedTypes :: forall m. Schema m -> HashMap Full.Name (Type m)
+collectReferencedTypes :: forall m
+    . Schema m
+    -> HashMap Full.Name (Schema.Type m)
 collectReferencedTypes schema =
-    let queryTypes = traverseObjectType (query schema) HashMap.empty
+    let queryTypes = traverseObjectType (Schema.query schema) HashMap.empty
         mutationTypes = maybe queryTypes (`traverseObjectType` queryTypes)
-            $ mutation schema
+            $ Schema.mutation schema
      in maybe mutationTypes (`traverseObjectType` queryTypes)
-        $ subscription schema
+        $ Schema.subscription schema
   where
     collect traverser typeName element foundTypes
         | HashMap.member typeName foundTypes = foundTypes
@@ -59,17 +61,17 @@ collectReferencedTypes schema =
     getField (Out.EventStreamResolver field _ _) = field
     traverseInputType (In.InputObjectBaseType objectType) =
         let In.InputObjectType typeName _ inputFields = objectType
-            element = InputObjectType objectType
+            element = Schema.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
-         in collect Prelude.id typeName (ScalarType scalarType)
+         in collect Prelude.id typeName (Schema.ScalarType scalarType)
     traverseInputType (In.EnumBaseType enumType) =
         let Definition.EnumType typeName _ _ = enumType
-         in collect Prelude.id typeName (EnumType enumType)
+         in collect Prelude.id typeName (Schema.EnumType enumType)
     traverseOutputType (Out.ObjectBaseType objectType) =
         traverseObjectType objectType
     traverseOutputType (Out.InterfaceBaseType interfaceType) =
@@ -77,23 +79,23 @@ collectReferencedTypes schema =
     traverseOutputType (Out.UnionBaseType unionType) =
         let Out.UnionType typeName _ types = unionType
             traverser = flip (foldr traverseObjectType) types
-         in collect traverser typeName (UnionType unionType)
+         in collect traverser typeName (Schema.UnionType unionType)
     traverseOutputType (Out.ListBaseType listType) =
         traverseOutputType listType
     traverseOutputType (Out.ScalarBaseType scalarType) =
         let Definition.ScalarType typeName _ = scalarType
-         in collect Prelude.id typeName (ScalarType scalarType)
+         in collect Prelude.id typeName (Schema.ScalarType scalarType)
     traverseOutputType (Out.EnumBaseType enumType) =
         let Definition.EnumType typeName _ _ = enumType
-         in collect Prelude.id typeName (EnumType enumType)
+         in collect Prelude.id typeName (Schema.EnumType enumType)
     traverseObjectType objectType foundTypes =
         let Out.ObjectType typeName _ interfaces fields = objectType
-            element = ObjectType objectType
+            element = Schema.ObjectType objectType
             traverser = polymorphicTraverser interfaces (getField <$> fields)
          in collect traverser typeName element foundTypes
     traverseInterfaceType interfaceType foundTypes =
         let Out.InterfaceType typeName _ interfaces fields = interfaceType
-            element = InterfaceType interfaceType
+            element = Schema.InterfaceType interfaceType
             traverser = polymorphicTraverser interfaces fields
          in collect traverser typeName element foundTypes
     polymorphicTraverser interfaces fields
@@ -126,27 +128,28 @@ instanceOf objectType (AbstractUnionType unionType) =
 
 lookupTypeCondition :: forall m
     . Full.Name
-    -> HashMap Full.Name (Type m)
+    -> HashMap Full.Name (Schema.Type m)
     -> Maybe (CompositeType m)
 lookupTypeCondition type' types' =
     case HashMap.lookup type' types' of
-        Just (ObjectType objectType) -> Just $ CompositeObjectType objectType
+        Just (Schema.ObjectType objectType) ->
-        Just (UnionType unionType) -> Just $ CompositeUnionType unionType
+            Just $ CompositeObjectType objectType
-        Just (InterfaceType interfaceType) ->
+        Just (Schema.UnionType unionType) -> Just $ CompositeUnionType unionType
+        Just (Schema.InterfaceType interfaceType) ->
             Just $ CompositeInterfaceType interfaceType
         _ -> Nothing
 
 lookupInputType
     :: Full.Type
-    -> HashMap.HashMap Full.Name (Type m)
+    -> HashMap.HashMap Full.Name (Schema.Type m)
     -> Maybe In.Type
 lookupInputType (Full.TypeNamed name) types =
     case HashMap.lookup name types of
-        Just (ScalarType scalarType) ->
+        Just (Schema.ScalarType scalarType) ->
             Just $ In.NamedScalarType scalarType
-        Just (EnumType enumType) ->
+        Just (Schema.EnumType enumType) ->
             Just $ In.NamedEnumType enumType
-        Just (InputObjectType objectType) ->
+        Just (Schema.InputObjectType objectType) ->
             Just $ In.NamedInputObjectType objectType
         _ -> Nothing
 lookupInputType (Full.TypeList list) types
@@ -154,18 +157,18 @@ lookupInputType (Full.TypeList list) types
     <$> lookupInputType list types
 lookupInputType (Full.TypeNonNull (Full.NonNullTypeNamed nonNull)) types  =
     case HashMap.lookup nonNull types of
-        Just (ScalarType scalarType) ->
+        Just (Schema.ScalarType scalarType) ->
             Just $ In.NonNullScalarType scalarType
-        Just (EnumType enumType) ->
+        Just (Schema.EnumType enumType) ->
             Just $ In.NonNullEnumType enumType
-        Just (InputObjectType objectType) ->
+        Just (Schema.InputObjectType objectType) ->
             Just $ In.NonNullInputObjectType objectType
         _ -> Nothing
 lookupInputType (Full.TypeNonNull (Full.NonNullTypeList nonNull)) types
     = In.NonNullListType
     <$> lookupInputType nonNull types
 
-lookupTypeField :: forall a. Text -> Out.Type a -> Maybe (Out.Type a)
+lookupTypeField :: forall a. Full.Name -> Out.Type a -> Maybe (Out.Field a)
 lookupTypeField fieldName = \case
     Out.ObjectBaseType objectType ->
         objectChild objectType
@@ -177,8 +180,6 @@ lookupTypeField fieldName = \case
     objectChild (Out.ObjectType _ _ _ resolvers) =
         resolverType <$> HashMap.lookup fieldName resolvers
     interfaceChild (Out.InterfaceType _ _ _ fields) =
-        fieldType <$> HashMap.lookup fieldName fields
+        HashMap.lookup fieldName fields
-    resolverType (Out.ValueResolver objectField _) = fieldType objectField
+    resolverType (Out.ValueResolver objectField _) = objectField
-    resolverType (Out.EventStreamResolver objectField _ _) =
+    resolverType (Out.EventStreamResolver objectField _ _) = objectField
-        fieldType objectField
-    fieldType (Out.Field _ type' _) = type'

src/Language/GraphQL/Type/Schema.hs

@@ -2,13 +2,22 @@
    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 #-}
+
 -- | This module provides a representation of a @GraphQL@ Schema in addition to
 -- functions for defining and manipulating schemas.
 module Language.GraphQL.Type.Schema
-    ( Schema(..)
+    ( Directive(..)
+    , Directives
+    , Schema(..)
     , Type(..)
+    , schema
     ) where
 
+import Data.HashMap.Strict (HashMap)
+import Data.Text (Text)
+import qualified Language.GraphQL.AST.Document as Full
+import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation)
 import qualified Language.GraphQL.Type.Definition as Definition
 import qualified Language.GraphQL.Type.In as In
 import qualified Language.GraphQL.Type.Out as Out
@@ -23,6 +32,12 @@ data Type m
     | UnionType (Out.UnionType m)
     deriving Eq
 
+-- | Directive definition.
+data Directive = Directive (Maybe Text) [DirectiveLocation] In.Arguments
+
+-- | Directive definitions.
+type Directives = HashMap Full.Name Directive
+
 -- | A Schema is created by supplying the root types of each type of operation,
 --   query and mutation (optional). A schema definition is then supplied to the
 --   validator and executor.
@@ -34,4 +49,14 @@ data Schema m = Schema
     { query :: Out.ObjectType m
     , mutation :: Maybe (Out.ObjectType m)
     , subscription :: Maybe (Out.ObjectType m)
+    , directives :: Directives
+    }
+
+-- | Shortcut for creating a schema.
+schema :: forall m. Out.ObjectType m -> Schema m
+schema query' = Schema
+    { query = query'
+    , mutation = Nothing
+    , subscription = Nothing
+    , directives = mempty
     }

src/Language/GraphQL/Validate.hs

@@ -3,11 +3,12 @@
    obtain one at https://mozilla.org/MPL/2.0/. -}
 
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 -- | GraphQL validator.
 module Language.GraphQL.Validate
-    ( Error(..)
+    ( Validation.Error(..)
     , document
     , module Language.GraphQL.Validate.Rules
     ) where
@@ -20,38 +21,100 @@ 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.DirectiveLocation (DirectiveLocation(..))
+import qualified Language.GraphQL.AST.DirectiveLocation as DirectiveLocation
 import Language.GraphQL.AST.Document
 import Language.GraphQL.Type.Internal
+import qualified Language.GraphQL.Type.Definition as Definition
+import qualified Language.GraphQL.Type.In as In
 import qualified Language.GraphQL.Type.Out as Out
-import Language.GraphQL.Type.Schema (Schema(..))
+import Language.GraphQL.Type.Schema (Schema)
 import qualified Language.GraphQL.Type.Schema as Schema
 import Language.GraphQL.Validate.Rules
-import Language.GraphQL.Validate.Validation
+import Language.GraphQL.Validate.Validation (Validation(Validation))
+import qualified Language.GraphQL.Validate.Validation as Validation
 
-type ApplyRule m a =
+type ApplySelectionRule m a
-    HashMap Name (Schema.Type m) -> Rule m -> Maybe (Out.Type m) -> a -> Seq (RuleT m)
+    = HashMap Name (Schema.Type m)
+    -> Validation.Rule m
+    -> Maybe (Out.Type m)
+    -> a
+    -> Seq (Validation.RuleT m)
+
+type ApplyRule m a = Validation.Rule m -> a -> Seq (Validation.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
+document :: forall m
+    . Schema m
+    -> [Validation.Rule m]
+    -> Document
+    -> Seq Validation.Error
 document schema' rules' document' =
     runReaderT reader context
   where
     context = Validation
-        { ast = document'
+        { Validation.ast = document'
-        , schema = schema'
+        , Validation.schema = schema'
-        , types = collectReferencedTypes schema'
+        , Validation.types = collectReferencedTypes schema'
+        , Validation.directives = allDirectives
         }
+    allDirectives = 
+        HashMap.union (Schema.directives schema') defaultDirectives
+    defaultDirectives = HashMap.fromList
+        [ ("skip", skipDirective)
+        , ("include", includeDirective)
+        , ("deprecated", deprecatedDirective)
+        ]
+    includeDirective =
+        Schema.Directive includeDescription skipIncludeLocations includeArguments
+    includeArguments = HashMap.singleton "if"
+        $ In.Argument (Just "Included when true.") ifType Nothing
+    includeDescription = Just
+        "Directs the executor to include this field or fragment only when the \
+        \`if` argument is true."
+    skipDirective =
+        Schema.Directive skipDescription skipIncludeLocations skipArguments
+    skipArguments = HashMap.singleton "if"
+        $ In.Argument (Just "skipped when true.") ifType Nothing
+    ifType = In.NonNullScalarType Definition.boolean
+    skipDescription = Just
+        "Directs the executor to skip this field or fragment when the `if` \
+        \argument is true."
+    skipIncludeLocations =
+        [ ExecutableDirectiveLocation DirectiveLocation.Field
+        , ExecutableDirectiveLocation DirectiveLocation.FragmentSpread
+        , ExecutableDirectiveLocation DirectiveLocation.InlineFragment
+        ]
+    deprecatedDirective =
+        Schema.Directive deprecatedDescription deprecatedLocations deprecatedArguments
+    reasonDescription = Just
+        "Explains why this element was deprecated, usually also including a \
+        \suggestion for how to access supported similar data. Formatted using \
+        \the Markdown syntax, as specified by \
+        \[CommonMark](https://commonmark.org/).'"
+    deprecatedArguments = HashMap.singleton "reason"
+        $ In.Argument reasonDescription reasonType
+        $ Just "No longer supported"
+    reasonType = In.NamedScalarType Definition.string
+    deprecatedDescription = Just
+        "Marks an element of a GraphQL schema as no longer supported."
+    deprecatedLocations =
+        [ TypeSystemDirectiveLocation DirectiveLocation.FieldDefinition
+        , TypeSystemDirectiveLocation DirectiveLocation.ArgumentDefinition
+        , TypeSystemDirectiveLocation DirectiveLocation.InputFieldDefinition
+        , TypeSystemDirectiveLocation DirectiveLocation.EnumValue
+        ]
     reader = do
         rule' <- lift $ Seq.fromList rules'
         join $ lift $ foldr (definition rule' context) Seq.empty document'
 
-definition :: Rule m
+definition :: Validation.Rule m
     -> Validation m
     -> Definition
-    -> Seq (RuleT m)
+    -> Seq (Validation.RuleT m)
-    -> Seq (RuleT m)
+    -> Seq (Validation.RuleT m)
-definition (DefinitionRule rule) _ definition' accumulator =
+definition (Validation.DefinitionRule rule) _ definition' accumulator =
     accumulator |> rule definition'
 definition rule context (ExecutableDefinition definition') accumulator =
     accumulator >< executableDefinition rule context definition'
@@ -60,12 +123,12 @@ definition rule _ (TypeSystemDefinition typeSystemDefinition' _) accumulator =
 definition rule _ (TypeSystemExtension extension _) accumulator =
     accumulator >< typeSystemExtension rule extension
 
-typeSystemExtension :: Rule m -> TypeSystemExtension -> Seq (RuleT m)
+typeSystemExtension :: forall m. ApplyRule m TypeSystemExtension
 typeSystemExtension rule = \case
     SchemaExtension extension -> schemaExtension rule extension
     TypeExtension extension -> typeExtension rule extension
 
-typeExtension :: Rule m -> TypeExtension -> Seq (RuleT m)
+typeExtension :: forall m. ApplyRule m TypeExtension
 typeExtension rule = \case
     ScalarTypeExtension _ directives' -> directives rule directives'
     ObjectTypeFieldsDefinitionExtension _ _ directives' fields ->
@@ -88,27 +151,28 @@ typeExtension rule = \case
     InputObjectTypeDirectivesExtension _ directives' ->
         directives rule directives'
 
-schemaExtension :: Rule m -> SchemaExtension -> Seq (RuleT m)
+schemaExtension :: forall m. ApplyRule m SchemaExtension
 schemaExtension rule = \case
     SchemaOperationExtension directives' _ -> directives rule directives'
     SchemaDirectivesExtension directives' -> directives rule directives'
 
-executableDefinition :: Rule m
+executableDefinition :: forall m
+    . Validation.Rule m
     -> Validation m
     -> ExecutableDefinition
-    -> Seq (RuleT m)
+    -> Seq (Validation.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 :: forall m. ApplyRule m TypeSystemDefinition
 typeSystemDefinition rule = \case
     SchemaDefinition directives' _ -> directives rule directives'
     TypeDefinition typeDefinition' -> typeDefinition rule typeDefinition'
     DirectiveDefinition _ _ arguments' _ -> argumentsDefinition rule arguments'
 
-typeDefinition :: Rule m -> TypeDefinition -> Seq (RuleT m)
+typeDefinition :: forall m. ApplyRule m TypeDefinition
 typeDefinition rule = \case
     ScalarTypeDefinition _ _ directives' -> directives rule directives'
     ObjectTypeDefinition _ _ _ directives' fields ->
@@ -122,30 +186,31 @@ typeDefinition rule = \case
         -> directives rule directives'
         <> foldMap (inputValueDefinition rule) fields
 
-enumValueDefinition :: Rule m -> EnumValueDefinition -> Seq (RuleT m)
+enumValueDefinition :: forall m. ApplyRule m EnumValueDefinition
 enumValueDefinition rule (EnumValueDefinition _ _ directives') =
     directives rule directives'
 
-fieldDefinition :: Rule m -> FieldDefinition -> Seq (RuleT m)
+fieldDefinition :: forall m. ApplyRule m FieldDefinition
 fieldDefinition rule (FieldDefinition _ _ arguments' _ directives') =
     directives rule directives' >< argumentsDefinition rule arguments'
 
-argumentsDefinition :: Rule m -> ArgumentsDefinition -> Seq (RuleT m)
+argumentsDefinition :: forall m. ApplyRule m ArgumentsDefinition
 argumentsDefinition rule (ArgumentsDefinition definitions) =
     foldMap (inputValueDefinition rule) definitions
 
-inputValueDefinition :: Rule m -> InputValueDefinition -> Seq (RuleT m)
+inputValueDefinition :: forall m. ApplyRule m InputValueDefinition
 inputValueDefinition rule (InputValueDefinition _ _ _ _ directives') =
     directives rule directives'
 
-operationDefinition :: Rule m
+operationDefinition :: forall m
+    . Validation.Rule m
     -> Validation m
     -> OperationDefinition
-    -> Seq (RuleT m)
+    -> Seq (Validation.RuleT m)
 operationDefinition rule context operation
-    | OperationDefinitionRule operationRule <- rule =
+    | Validation.OperationDefinitionRule operationRule <- rule =
         pure $ operationRule operation
-    | VariablesRule variablesRule <- rule
+    | Validation.VariablesRule variablesRule <- rule
     , OperationDefinition _ _ variables _ _ _ <- operation
         = Seq.fromList (variableDefinition rule <$> variables)
         |> variablesRule variables
@@ -155,11 +220,13 @@ operationDefinition rule context operation
         = selectionSet types' rule (getRootType operationType) selections
         >< directives rule directives'
   where
-    types' = types context
+    types' = Validation.types context
-    getRootType Query = Just $ Out.NamedObjectType $ query $ schema context
+    getRootType Query =
-    getRootType Mutation = Out.NamedObjectType <$> mutation (schema context)
+       Just $ Out.NamedObjectType $ Schema.query $ Validation.schema context
+    getRootType Mutation =
+       Out.NamedObjectType <$> Schema.mutation (Validation.schema context)
     getRootType Subscription =
-        Out.NamedObjectType <$> subscription (schema context)
+        Out.NamedObjectType <$> Schema.subscription (Validation.schema context)
         
 typeToOut :: forall m. Schema.Type m -> Maybe (Out.Type m)
 typeToOut (Schema.ObjectType objectType) =
@@ -171,27 +238,30 @@ 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 :: forall m
-variableDefinition (ValueRule _ rule) (VariableDefinition _ _ value _) =
+    . Validation.Rule m
+    -> VariableDefinition
+    -> Validation.RuleT m
+variableDefinition (Validation.ValueRule _ rule) (VariableDefinition _ _ value _) =
     maybe (lift mempty) rule value
 variableDefinition _ _ = lift mempty
 
 fragmentDefinition :: forall m
-    . Rule m
+    . Validation.Rule m
     -> Validation m
     -> FragmentDefinition
-    -> Seq (RuleT m)
+    -> Seq (Validation.RuleT m)
-fragmentDefinition (FragmentDefinitionRule rule) _ definition' =
+fragmentDefinition (Validation.FragmentDefinitionRule rule) _ definition' =
     pure $ rule definition'
 fragmentDefinition rule context definition'
     | FragmentDefinition _ typeCondition directives' selections _ <- definition'
-    , FragmentRule definitionRule _ <- rule
+    , Validation.FragmentRule definitionRule _ <- rule
         = applyToChildren typeCondition directives' selections
         |> definitionRule definition'
     | FragmentDefinition _ typeCondition directives' selections _ <- definition'
         = applyToChildren typeCondition directives' selections
   where
-    types' = types context
+    types' = Validation.types context
     applyToChildren typeCondition directives' selections
         = selectionSet types' rule (lookupType' typeCondition) selections
         >< directives rule directives'
@@ -204,12 +274,12 @@ lookupType :: forall m
 lookupType typeCondition types' = HashMap.lookup typeCondition types'
     >>= typeToOut
 
-selectionSet :: Traversable t => forall m. ApplyRule m (t Selection)
+selectionSet :: Traversable t => forall m. ApplySelectionRule m (t Selection)
 selectionSet types' rule = foldMap . selection types' rule
 
-selection :: forall m. ApplyRule m Selection
+selection :: forall m. ApplySelectionRule m Selection
 selection types' rule objectType selection'
-    | SelectionRule selectionRule <- rule =
+    | Validation.SelectionRule selectionRule <- rule =
         applyToChildren |> selectionRule objectType selection'
     | otherwise = applyToChildren
   where
@@ -221,33 +291,37 @@ selection types' rule objectType selection'
             FragmentSpreadSelection fragmentSpread' ->
                 fragmentSpread rule fragmentSpread'
 
-field :: forall m. ApplyRule m Field
+field :: forall m. ApplySelectionRule m Field
 field types' rule objectType field' = go field'
   where
-    go (Field _ fieldName arguments' directives' selections _)
+    go (Field _ fieldName _ _ _ _)
-        | ArgumentsRule fieldRule _  <- rule
+        | Validation.FieldRule fieldRule <- rule =
-            = applyToChildren fieldName arguments' directives' selections
+            applyToChildren fieldName |> fieldRule objectType field'
-            |> fieldRule field'
+        | Validation.ArgumentsRule argumentsRule _  <- rule =
-        | otherwise =
+            applyToChildren fieldName |> argumentsRule objectType field'
-            applyToChildren fieldName arguments' directives' selections
+        | otherwise = applyToChildren fieldName
-    applyToChildren fieldName arguments' directives' selections =
+    typeFieldType (Out.Field _ type' _) = type'
-        let child = objectType >>= lookupTypeField fieldName
+    applyToChildren fieldName =
-         in selectionSet types' rule child selections
+        let Field _ _ arguments' directives' selections _ = field'
+            fieldType = objectType
+               >>= fmap typeFieldType . lookupTypeField fieldName
+         in selectionSet types' rule fieldType selections
             >< directives rule directives'
             >< arguments rule arguments'
 
-arguments :: Rule m -> [Argument] -> Seq (RuleT m)
+arguments :: forall m. ApplyRule m [Argument]
 arguments = (.) Seq.fromList . fmap . argument
 
-argument :: Rule m -> Argument -> RuleT m
+argument :: forall m. Validation.Rule m -> Argument -> Validation.RuleT m
-argument (ValueRule rule _) (Argument _ (Node value _) _) = rule value
+argument (Validation.ValueRule rule _) (Argument _ (Node value _) _) =
+    rule value
 argument _ _ = lift mempty
 
-inlineFragment :: forall m. ApplyRule m InlineFragment
+inlineFragment :: forall m. ApplySelectionRule m InlineFragment
 inlineFragment types' rule objectType inlineFragment' = go inlineFragment'
   where
     go (InlineFragment optionalType directives' selections _)
-        | FragmentRule _ fragmentRule <- rule
+        | Validation.FragmentRule _ fragmentRule <- rule
             = applyToChildren (refineTarget optionalType) directives' selections
             |> fragmentRule inlineFragment'
         | otherwise = applyToChildren (refineTarget optionalType) directives' selections
@@ -257,24 +331,24 @@ inlineFragment types' rule objectType inlineFragment' = go inlineFragment'
         = selectionSet types' rule objectType' selections
         >< directives rule directives'
 
-fragmentSpread :: Rule m -> FragmentSpread -> Seq (RuleT m)
+fragmentSpread :: forall m. ApplyRule m FragmentSpread
 fragmentSpread rule fragmentSpread'@(FragmentSpread _ directives' _)
-    | FragmentSpreadRule fragmentRule <- rule =
+    | Validation.FragmentSpreadRule fragmentRule <- rule =
         applyToChildren |> fragmentRule fragmentSpread'
     | otherwise = applyToChildren
   where
     applyToChildren = directives rule directives'
 
-directives :: Traversable t => Rule m -> t Directive -> Seq (RuleT m)
+directives :: Traversable t => forall m. ApplyRule m (t Directive)
 directives rule directives'
-    | DirectivesRule directivesRule <- rule =
+    | Validation.DirectivesRule directivesRule <- rule =
         applyToChildren |> directivesRule directiveList
     | otherwise = applyToChildren
   where
     directiveList = toList directives'
     applyToChildren = foldMap (directive rule) directiveList
 
-directive :: Rule m -> Directive -> Seq (RuleT m)
+directive :: forall m. ApplyRule m Directive
-directive (ArgumentsRule _ argumentsRule) directive' =
+directive (Validation.ArgumentsRule _ argumentsRule) directive' =
     pure $ argumentsRule directive'
 directive rule (Directive _ arguments' _) = arguments rule arguments'

src/Language/GraphQL/Validate/Rules.hs

@@ -15,6 +15,7 @@ module Language.GraphQL.Validate.Rules
     , fragmentSpreadTargetDefinedRule
     , fragmentSpreadTypeExistenceRule
     , loneAnonymousOperationRule
+    , knownArgumentNamesRule
     , noFragmentCyclesRule
     , noUndefinedVariablesRule
     , noUnusedFragmentsRule
@@ -44,7 +45,7 @@ import qualified Data.HashSet as HashSet
 import Data.List (groupBy, sortBy, sortOn)
 import Data.Maybe (mapMaybe)
 import Data.Ord (comparing)
-import Data.Sequence (Seq(..))
+import Data.Sequence (Seq(..), (|>))
 import qualified Data.Sequence as Seq
 import Data.Text (Text)
 import qualified Data.Text as Text
@@ -71,6 +72,7 @@ specifiedRules =
     , fieldsOnCorrectTypeRule
     , scalarLeafsRule
     -- Arguments.
+    , knownArgumentNamesRule
     , uniqueArgumentNamesRule
     -- Fragments.
     , uniqueFragmentNamesRule
@@ -134,20 +136,20 @@ singleFieldSubscriptionsRule = OperationDefinitionRule $ \case
             forSpread accumulator fragmentSelection
         InlineFragmentSelection fragmentSelection ->
             forInline accumulator fragmentSelection
-    forField accumulator (Field alias name _ directives _ _)
+    forField accumulator (Field alias name _ directives' _ _)
-        | any skip directives = pure accumulator
+        | any skip directives' = pure accumulator
         | Just aliasedName <- alias = pure
             $ HashSet.insert aliasedName accumulator
         | otherwise = pure $ HashSet.insert name accumulator
-    forSpread accumulator (FragmentSpread fragmentName directives _)
+    forSpread accumulator (FragmentSpread fragmentName directives' _)
-        | any skip directives = pure accumulator
+        | any skip directives' = pure accumulator
         | otherwise = do
             inVisitetFragments <- gets $ HashSet.member fragmentName
             if inVisitetFragments
                then pure accumulator
                else collectFromSpread fragmentName accumulator
-    forInline accumulator (InlineFragment maybeType directives selections _)
+    forInline accumulator (InlineFragment maybeType directives' selections _)
-        | any skip directives = pure accumulator
+        | any skip directives' = pure accumulator
         | Just typeCondition <- maybeType =
             collectFromFragment typeCondition selections accumulator
         | otherwise = HashSet.union accumulator
@@ -494,7 +496,7 @@ noFragmentCyclesRule = FragmentDefinitionRule $ \case
 uniqueArgumentNamesRule :: forall m. Rule m
 uniqueArgumentNamesRule = ArgumentsRule fieldRule directiveRule
   where
-    fieldRule (Field _ _ arguments _ _ _) =
+    fieldRule _ (Field _ _ arguments _ _ _) =
         lift $ filterDuplicates extract "argument" arguments
     directiveRule (Directive _ arguments _) =
         lift $ filterDuplicates extract "argument" arguments
@@ -519,9 +521,9 @@ filterDuplicates extract nodeType = Seq.fromList
   where
     getName = fst . extract
     equalByName lhs rhs = getName lhs == getName rhs
-    makeError directives = Error
+    makeError directives' = Error
-        { message = makeMessage $ head directives
+        { message = makeMessage $ head directives'
-        , locations = snd . extract <$> directives
+        , locations = snd . extract <$> directives'
         }
     makeMessage directive = concat
         [ "There can be only one "
@@ -614,11 +616,11 @@ variableUsageDifference difference errorMessage = OperationDefinitionRule $ \cas
     filterSelections' = filterSelections variableFilter
     variableFilter :: Selection -> ValidationState m (Name, [Location])
     variableFilter (InlineFragmentSelection inline)
-        | InlineFragment _ directives _ _ <- inline =
+        | InlineFragment _ directives' _ _ <- inline =
-            lift $ lift $ mapDirectives directives
+            lift $ lift $ mapDirectives directives'
     variableFilter (FieldSelection fieldSelection)
-        | Field _ _ arguments directives _ _ <- fieldSelection =
+        | Field _ _ arguments directives' _ _ <- fieldSelection =
-            lift $ lift $ mapArguments arguments <> mapDirectives directives
+            lift $ lift $ mapArguments arguments <> mapDirectives directives'
     variableFilter (FragmentSpreadSelection spread)
         | FragmentSpread fragmentName _ _ <- spread = do
             definitions <- lift $ asks ast
@@ -628,9 +630,9 @@ variableUsageDifference difference errorMessage = OperationDefinitionRule $ \cas
                 Just (viewFragment -> Just fragmentDefinition)
                     | not visited -> diveIntoSpread fragmentDefinition
                 _ -> lift $ lift mempty
-    diveIntoSpread (FragmentDefinition _ _ directives selections _)
+    diveIntoSpread (FragmentDefinition _ _ directives' selections _)
         = filterSelections' selections
-        >>= lift . mapReaderT (<> mapDirectives directives) . pure
+        >>= lift . mapReaderT (<> mapDirectives directives') . pure
     findDirectiveVariables (Directive _ arguments _) = mapArguments arguments
     mapArguments = Seq.fromList . mapMaybe findArgumentVariables
     mapDirectives = foldMap findDirectiveVariables
@@ -683,13 +685,11 @@ uniqueInputFieldNamesRule = ValueRule (lift . go) (lift . constGo)
 -- | 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
+fieldsOnCorrectTypeRule = FieldRule fieldRule
   where
-    go (Just objectType) (FieldSelection fieldSelection) =
+    fieldRule parentType (Field _ fieldName _ _ _ location)
-       fieldRule objectType fieldSelection
+        | Just objectType <- parentType
-    go _ _ = lift mempty
+        , Nothing <- lookupTypeField fieldName objectType
-    fieldRule objectType (Field _ fieldName _ _ _ location)
-        | Nothing <- lookupTypeField fieldName objectType
         , Just typeName <- compositeTypeName objectType = pure $ Error
             { message = errorMessage fieldName typeName
             , locations = [location]
@@ -702,6 +702,8 @@ fieldsOnCorrectTypeRule = SelectionRule go
         , Text.unpack typeName
         , "\"."
         ]
+
+compositeTypeName :: forall m. Out.Type m -> Maybe Name
 compositeTypeName (Out.ObjectBaseType (Out.ObjectType typeName _ _ _)) =
     Just typeName
 compositeTypeName (Out.InterfaceBaseType interfaceType) =
@@ -719,14 +721,13 @@ fieldsOnCorrectTypeRule = SelectionRule go
 -- | Field selections on scalars or enums are never allowed, because they are
 -- the leaf nodes of any GraphQL query.
 scalarLeafsRule :: forall m. Rule m
-scalarLeafsRule = SelectionRule go
+scalarLeafsRule = FieldRule fieldRule
   where
-    go (Just objectType) (FieldSelection fieldSelection) =
+    fieldRule parentType selectionField@(Field _ fieldName _ _ _ _)
-       fieldRule objectType fieldSelection
+        | Just objectType <- parentType
-    go _ _ = lift mempty
+        , Just field <- lookupTypeField fieldName objectType =
-    fieldRule objectType selectionField@(Field _ fieldName _ _ _ _)
+            let Out.Field _ fieldType _ = field
-        | Just fieldType <- lookupTypeField fieldName objectType =
+             in lift $ check fieldType selectionField
-            lift $ check fieldType selectionField
         | otherwise = lift mempty
     check (Out.ObjectBaseType (Out.ObjectType typeName _ _ _)) =
         checkNotEmpty typeName
@@ -765,3 +766,49 @@ scalarLeafsRule = SelectionRule go
         { message = errorMessage
         , locations = [location]
         }
+
+-- | Every argument provided to a field or directive must be defined in the set
+-- of possible arguments of that field or directive.
+knownArgumentNamesRule :: forall m. Rule m
+knownArgumentNamesRule = ArgumentsRule fieldRule directiveRule
+  where
+    fieldRule (Just objectType) (Field _ fieldName arguments  _ _ _)
+        | Just typeField <- lookupTypeField fieldName objectType
+        , Just typeName <- compositeTypeName objectType =
+            lift $ foldr (go typeName fieldName typeField) Seq.empty arguments
+    fieldRule _ _ = lift mempty
+    go typeName fieldName fieldDefinition (Argument argumentName _ location) errors
+        | Out.Field _ _ definitions <- fieldDefinition
+        , Just _ <- HashMap.lookup argumentName definitions = errors
+        | otherwise = errors |> Error
+            { message = fieldMessage argumentName fieldName typeName
+            , locations = [location]
+            }
+    fieldMessage argumentName fieldName typeName = concat
+        [ "Unknown argument \""
+        , Text.unpack argumentName
+        , "\" on field \""
+        , Text.unpack typeName
+        , "."
+        , Text.unpack fieldName
+        , "\"."
+        ]
+    directiveRule (Directive directiveName arguments _) = do
+        available <- asks $ HashMap.lookup directiveName . directives
+        Argument argumentName _ location <- lift $ Seq.fromList arguments
+        case available of
+            Just (Schema.Directive _ _ definitions)
+                | not $ HashMap.member argumentName definitions ->
+                    pure $ makeError argumentName directiveName location
+            _ -> lift mempty
+    makeError argumentName directiveName location = Error
+        { message = directiveMessage argumentName directiveName
+        , locations = [location]
+        }
+    directiveMessage argumentName directiveName = concat
+        [ "Unknown argument \""
+        , Text.unpack argumentName
+        , "\" on directive \"@"
+        , Text.unpack directiveName
+        , "\"."
+        ]

src/Language/GraphQL/Validate/Validation.hs

@@ -29,6 +29,7 @@ data Validation m = Validation
     { ast :: Document
     , schema :: Schema m
     , types :: HashMap Name (Schema.Type m)
+    , directives :: Schema.Directives
     }
 
 -- | 'Rule' assigns a function to each AST node that can be validated. If the
@@ -41,7 +42,8 @@ data Rule m
     | SelectionRule (Maybe (Out.Type m) -> Selection -> RuleT m)
     | FragmentRule (FragmentDefinition -> RuleT m) (InlineFragment -> RuleT m)
     | FragmentSpreadRule (FragmentSpread -> RuleT m)
-    | ArgumentsRule (Field -> RuleT m) (Directive -> RuleT m)
+    | FieldRule (Maybe (Out.Type m) -> Field -> RuleT m)
+    | ArgumentsRule (Maybe (Out.Type m) -> Field -> RuleT m) (Directive -> RuleT m)
     | DirectivesRule ([Directive] -> RuleT m)
     | VariablesRule ([VariableDefinition] -> RuleT m)
     | ValueRule (Value -> RuleT m) (ConstValue -> RuleT m)

stack.yaml

@@ -1,4 +1,4 @@
-resolver: lts-16.15
+resolver: lts-16.16
 
 packages:
 - .

tests/Language/GraphQL/ExecuteSpec.hs

@@ -25,11 +25,12 @@ import Test.Hspec (Spec, context, describe, it, shouldBe)
 import Text.Megaparsec (parse)
 import Text.RawString.QQ (r)
 
-schema :: Schema (Either SomeException)
+philosopherSchema :: Schema (Either SomeException)
-schema = Schema
+philosopherSchema = Schema
     { query = queryType
     , mutation = Nothing
     , subscription = Just subscriptionType
+    , directives = HashMap.empty
     }
 
 queryType :: Out.ObjectType (Either SomeException)
@@ -79,7 +80,8 @@ type EitherStreamOrValue = Either
     (Response Aeson.Value)
 
 execute' :: Document -> Either SomeException EitherStreamOrValue
-execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)
+execute' =
+    execute philosopherSchema Nothing (mempty :: HashMap Name Aeson.Value)
 
 spec :: Spec
 spec =

tests/Language/GraphQL/ValidateSpec.hs

@@ -21,11 +21,12 @@ import Test.Hspec (Spec, describe, it, shouldBe, shouldContain)
 import Text.Megaparsec (parse)
 import Text.RawString.QQ (r)
 
-schema :: Schema IO
+petSchema :: Schema IO
-schema = Schema
+petSchema = Schema
     { query = queryType
     , mutation = Nothing
     , subscription = Just subscriptionType
+    , directives = HashMap.empty
     } 
 
 queryType :: ObjectType IO
@@ -132,7 +133,7 @@ validate :: Text -> [Error]
 validate queryString =
     case parse AST.document "" queryString of
         Left _ -> []
-        Right ast -> toList $ document schema specifiedRules ast
+        Right ast -> toList $ document petSchema specifiedRules ast
 
 spec :: Spec
 spec =
@@ -544,3 +545,34 @@ spec =
                     , locations = [AST.Location 4 19]
                     }
              in validate queryString `shouldBe` [expected]
+
+        it "rejects field arguments missing in the type" $
+            let queryString = [r|
+              {
+                dog {
+                  doesKnowCommand(command: CLEAN_UP_HOUSE)
+                }
+              }
+            |]
+                expected = Error
+                    { message =
+                        "Unknown argument \"command\" on field \
+                        \\"Dog.doesKnowCommand\"."
+                    , locations = [AST.Location 4 35]
+                    }
+             in validate queryString `shouldBe` [expected]
+
+        it "rejects directive arguments missing in the definition" $
+            let queryString = [r|
+              {
+                dog {
+                  isHousetrained(atOtherHomes: true) @include(unless: false)
+                }
+              }
+            |]
+                expected = Error
+                    { message =
+                        "Unknown argument \"unless\" on directive \"@include\"."
+                    , locations = [AST.Location 4 63]
+                    }
+             in validate queryString `shouldBe` [expected]

tests/Test/DirectiveSpec.hs

@@ -19,8 +19,7 @@ import Test.Hspec.GraphQL
 import Text.RawString.QQ (r)
 
 experimentalResolver :: Schema IO
-experimentalResolver = Schema
+experimentalResolver = schema queryType
-    { query = queryType, mutation = Nothing, subscription = Nothing }
   where
     queryType = Out.ObjectType "Query" Nothing []
         $ HashMap.singleton "experimentalField"

tests/Test/FragmentSpec.hs

@@ -67,8 +67,7 @@ sizeFieldType
     $ pure $ snd size
 
 toSchema :: Text -> (Text, Value) -> Schema IO
-toSchema t (_, resolve) = Schema
+toSchema t (_, resolve) = schema queryType
-    { query = queryType, mutation = Nothing, subscription = Nothing }
   where
     garmentType = Out.UnionType "Garment" Nothing [hatType, shirtType]
     typeNameField = Out.Field Nothing (Out.NamedScalarType string) mempty

tests/Test/RootOperationSpec.hs

@@ -23,11 +23,12 @@ hatType = Out.ObjectType "Hat" Nothing []
     $ ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
     $ pure $ Int 60
 
-schema :: Schema IO
+garmentSchema :: Schema IO
-schema = Schema
+garmentSchema = Schema
     { query = Out.ObjectType "Query" Nothing [] hatFieldResolver
     , mutation = Just $ Out.ObjectType "Mutation" Nothing [] incrementFieldResolver
     , subscription = Nothing
+    , directives = HashMap.empty
     }
   where
     garment = pure $ Object $ HashMap.fromList
@@ -57,7 +58,7 @@ spec =
                             [ "circumference" .= (60 :: Int)
                             ]
                         ]
-            actual <- graphql schema querySource
+            actual <- graphql garmentSchema querySource
             actual `shouldResolveTo` expected
 
         it "chooses Mutation" $ do
@@ -70,5 +71,5 @@ spec =
                     $ object
                         [ "incrementCircumference" .= (61 :: Int)
                         ]
-            actual <- graphql schema querySource
+            actual <- graphql garmentSchema querySource
             actual `shouldResolveTo` expected

tests/Test/StarWars/QuerySpec.hs

@@ -357,10 +357,10 @@ spec = describe "Star Wars Query Tests" $ do
 
 testQuery :: Text -> Aeson.Value -> Expectation
 testQuery q expected =
-    let Right (Right actual) = graphql schema q
+    let Right (Right actual) = graphql starWarsSchema q
      in Aeson.Object actual `shouldBe` expected
 
 testQueryParams :: Aeson.Object -> Text -> Aeson.Value -> Expectation
 testQueryParams f q expected =
-    let Right (Right actual) = graphqlSubs schema Nothing f q
+    let Right (Right actual) = graphqlSubs starWarsSchema Nothing f q
      in Aeson.Object actual `shouldBe` expected

tests/Test/StarWars/Schema.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 module Test.StarWars.Schema
-    ( schema
+    ( starWarsSchema
     ) where
 
 import Control.Monad.Catch (MonadThrow(..), SomeException)
@@ -17,12 +17,8 @@ import Prelude hiding (id)
 
 -- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js
 
-schema :: Schema (Either SomeException)
+starWarsSchema :: Schema (Either SomeException)
-schema = Schema
+starWarsSchema = schema queryType
-    { query = queryType
-    , mutation = Nothing
-    , subscription = Nothing
-    }
   where
     queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList
         [ ("hero", heroFieldResolver)