1 files changed, 483 insertions, 58 deletions
diff --git a/src/Language/GraphQL/Validate.hs b/src/Language/GraphQL/Validate.hs
index 53dc6f9..277f84d 100644
--- a/src/Language/GraphQL/Validate.hs
+++ b/src/Language/GraphQL/Validate.hs
@@ -2,80 +2,505 @@
    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 RecordWildCards #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 -- | GraphQL validator.
 module Language.GraphQL.Validate
-    ( Error(..)
-    , Path(..)
+    ( Validation.Error(..)
     , document
     , module Language.GraphQL.Validate.Rules
     ) where
 
-import Control.Monad (foldM)
-import Control.Monad.Trans.Reader (Reader, asks, mapReaderT, runReader)
-import Data.Foldable (foldrM)
+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 Language.GraphQL.Type.Schema (Schema(..))
+import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation(..))
+import qualified Language.GraphQL.AST.DirectiveLocation as DirectiveLocation
+import qualified Language.GraphQL.AST.Document as Full
+import qualified Language.GraphQL.Type.Internal as Type
+import qualified Language.GraphQL.Type.In as In
+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
+import Language.GraphQL.Validate.Validation (Validation(Validation))
+import qualified Language.GraphQL.Validate.Validation as Validation
 
-type ValidateT m = Reader (Validation m) (Seq Error)
+type ApplySelectionRule m a
+    = HashMap Full.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]
+    -> Full.Document
+    -> Seq Validation.Error
 document schema' rules' document' =
-    runReader (foldrM go Seq.empty document') context
+    runReaderT reader context
   where
     context = Validation
-        { ast = document'
-        , schema = schema'
-        , types = collectReferencedTypes schema'
-        , rules = rules'
+        { Validation.ast = document'
+        , Validation.schema = schema'
         }
-    go definition' accumulator = (accumulator ><) <$> definition definition'
-
-definition :: forall m. Definition -> ValidateT m
-definition = \case
-    definition'@(ExecutableDefinition executableDefinition') -> do
-        applied <- applyRules definition'
-        children <- executableDefinition executableDefinition'
-        pure $ children >< applied
-    definition' -> applyRules definition'
-  where
-    applyRules definition' =
-        asks rules >>= foldM (ruleFilter definition') Seq.empty
-    ruleFilter definition' accumulator (DefinitionRule rule) =
-        mapReaderT (runRule accumulator) $ rule definition'
-    ruleFilter _ accumulator _ = pure accumulator
-
-runRule :: Applicative f => Seq Error -> Maybe Error -> f (Seq Error)
-runRule accumulator (Just error') = pure $ accumulator |> error'
-runRule accumulator Nothing = pure accumulator
-
-executableDefinition :: forall m. ExecutableDefinition -> ValidateT m
-executableDefinition (DefinitionOperation definition') =
-    operationDefinition definition'
-executableDefinition (DefinitionFragment definition') =
-    fragmentDefinition definition'
-
-operationDefinition :: forall m. OperationDefinition -> ValidateT m
-operationDefinition operation =
-    asks rules >>= foldM ruleFilter Seq.empty
-  where
-    ruleFilter accumulator (OperationDefinitionRule rule) =
-        mapReaderT (runRule accumulator) $ rule operation
-    ruleFilter accumulator _ = pure accumulator
-
-fragmentDefinition :: forall m. FragmentDefinition -> ValidateT m
-fragmentDefinition fragment =
-    asks rules >>= foldM ruleFilter Seq.empty
-  where
-    ruleFilter accumulator (FragmentDefinitionRule rule) =
-        mapReaderT (runRule accumulator) $ rule fragment
-    ruleFilter accumulator _ = pure accumulator
+    reader = do
+        rule' <- lift $ Seq.fromList rules'
+        join $ lift $ foldr (definition rule' context) Seq.empty document'
+
+definition :: Validation.Rule m
+    -> Validation m
+    -> Full.Definition
+    -> Seq (Validation.RuleT m)
+    -> Seq (Validation.RuleT m)
+definition (Validation.DefinitionRule rule) _ definition' accumulator =
+    accumulator |> rule definition'
+definition rule context (Full.ExecutableDefinition definition') accumulator =
+    accumulator >< executableDefinition rule context definition'
+definition rule context (Full.TypeSystemDefinition typeSystemDefinition' _) accumulator =
+    accumulator >< typeSystemDefinition context rule typeSystemDefinition'
+definition rule context (Full.TypeSystemExtension extension _) accumulator =
+    accumulator >< typeSystemExtension context rule extension
+
+typeSystemExtension :: forall m
+    . Validation m
+    -> ApplyRule m Full.TypeSystemExtension
+typeSystemExtension context rule = \case
+    Full.SchemaExtension extension -> schemaExtension context rule extension
+    Full.TypeExtension extension -> typeExtension context rule extension
+
+typeExtension :: forall m. Validation m -> ApplyRule m Full.TypeExtension
+typeExtension context rule = \case
+    Full.ScalarTypeExtension _ directives' ->
+        directives context rule scalarLocation directives'
+    Full.ObjectTypeFieldsDefinitionExtension _ _ directives' fields
+        -> directives context rule objectLocation directives'
+        >< foldMap (fieldDefinition context rule) fields
+    Full.ObjectTypeDirectivesExtension _ _ directives' ->
+        directives context rule objectLocation directives'
+    Full.ObjectTypeImplementsInterfacesExtension _ _ -> mempty
+    Full.InterfaceTypeFieldsDefinitionExtension _ directives' fields
+        -> directives context rule interfaceLocation directives'
+        >< foldMap (fieldDefinition context rule) fields
+    Full.InterfaceTypeDirectivesExtension _ directives' ->
+        directives context rule interfaceLocation directives'
+    Full.UnionTypeUnionMemberTypesExtension _ directives' _ ->
+        directives context rule unionLocation directives'
+    Full.UnionTypeDirectivesExtension _ directives' ->
+        directives context rule unionLocation directives'
+    Full.EnumTypeEnumValuesDefinitionExtension _ directives' values
+        -> directives context rule enumLocation directives'
+        >< foldMap (enumValueDefinition context rule) values
+    Full.EnumTypeDirectivesExtension _ directives' ->
+        directives context rule enumLocation directives'
+    Full.InputObjectTypeInputFieldsDefinitionExtension _ directives' fields
+        -> directives context rule inputObjectLocation directives'
+        >< foldMap forEachInputFieldDefinition fields
+    Full.InputObjectTypeDirectivesExtension _ directives' ->
+        directives context rule inputObjectLocation directives'
+  where
+    forEachInputFieldDefinition =
+        inputValueDefinition context rule inputFieldDefinitionLocation
+
+schemaExtension :: forall m. Validation m -> ApplyRule m Full.SchemaExtension
+schemaExtension context rule = \case
+    Full.SchemaOperationExtension directives' _ ->
+        directives context rule schemaLocation directives'
+    Full.SchemaDirectivesExtension directives' ->
+        directives context rule schemaLocation directives'
+
+schemaLocation :: DirectiveLocation
+schemaLocation = TypeSystemDirectiveLocation DirectiveLocation.Schema
+
+interfaceLocation :: DirectiveLocation
+interfaceLocation = TypeSystemDirectiveLocation DirectiveLocation.Interface
+
+objectLocation :: DirectiveLocation
+objectLocation = TypeSystemDirectiveLocation DirectiveLocation.Object
+
+unionLocation :: DirectiveLocation
+unionLocation = TypeSystemDirectiveLocation DirectiveLocation.Union
+
+enumLocation :: DirectiveLocation
+enumLocation = TypeSystemDirectiveLocation DirectiveLocation.Enum
+
+inputObjectLocation :: DirectiveLocation
+inputObjectLocation = TypeSystemDirectiveLocation DirectiveLocation.InputObject
+
+scalarLocation :: DirectiveLocation
+scalarLocation = TypeSystemDirectiveLocation DirectiveLocation.Scalar
+
+enumValueLocation :: DirectiveLocation
+enumValueLocation = TypeSystemDirectiveLocation DirectiveLocation.EnumValue
+
+fieldDefinitionLocation :: DirectiveLocation
+fieldDefinitionLocation =
+    TypeSystemDirectiveLocation DirectiveLocation.FieldDefinition
+
+inputFieldDefinitionLocation :: DirectiveLocation
+inputFieldDefinitionLocation =
+    TypeSystemDirectiveLocation DirectiveLocation.InputFieldDefinition
+
+argumentDefinitionLocation :: DirectiveLocation
+argumentDefinitionLocation =
+    TypeSystemDirectiveLocation DirectiveLocation.ArgumentDefinition
+
+queryLocation :: DirectiveLocation
+queryLocation = ExecutableDirectiveLocation DirectiveLocation.Query
+
+mutationLocation :: DirectiveLocation
+mutationLocation = ExecutableDirectiveLocation DirectiveLocation.Mutation
+
+subscriptionLocation :: DirectiveLocation
+subscriptionLocation =
+    ExecutableDirectiveLocation DirectiveLocation.Subscription
+
+fieldLocation :: DirectiveLocation
+fieldLocation = ExecutableDirectiveLocation DirectiveLocation.Field
+
+fragmentDefinitionLocation :: DirectiveLocation
+fragmentDefinitionLocation =
+    ExecutableDirectiveLocation DirectiveLocation.FragmentDefinition
+
+fragmentSpreadLocation :: DirectiveLocation
+fragmentSpreadLocation =
+    ExecutableDirectiveLocation DirectiveLocation.FragmentSpread
+
+inlineFragmentLocation :: DirectiveLocation
+inlineFragmentLocation =
+    ExecutableDirectiveLocation DirectiveLocation.InlineFragment
+
+executableDefinition :: forall m
+    . Validation.Rule m
+    -> Validation m
+    -> Full.ExecutableDefinition
+    -> Seq (Validation.RuleT m)
+executableDefinition rule context (Full.DefinitionOperation operation) =
+    operationDefinition rule context operation
+executableDefinition rule context (Full.DefinitionFragment fragment) =
+    fragmentDefinition rule context fragment
+
+typeSystemDefinition :: forall m
+    . Validation m
+    -> ApplyRule m Full.TypeSystemDefinition
+typeSystemDefinition context rule = \case
+    Full.SchemaDefinition directives' _ ->
+        directives context rule schemaLocation directives'
+    Full.TypeDefinition typeDefinition' ->
+        typeDefinition context rule typeDefinition'
+    Full.DirectiveDefinition _ _ arguments' _ ->
+        argumentsDefinition context rule arguments'
+
+typeDefinition :: forall m. Validation m -> ApplyRule m Full.TypeDefinition
+typeDefinition context rule = \case
+    Full.ScalarTypeDefinition _ _ directives' ->
+        directives context rule scalarLocation directives'
+    Full.ObjectTypeDefinition _ _ _ directives' fields
+        -> directives context rule objectLocation directives'
+         >< foldMap (fieldDefinition context rule) fields
+    Full.InterfaceTypeDefinition _ _ directives' fields
+        -> directives context rule interfaceLocation directives'
+        >< foldMap (fieldDefinition context rule) fields
+    Full.UnionTypeDefinition _ _ directives' _ ->
+        directives context rule unionLocation directives'
+    Full.EnumTypeDefinition _ _ directives' values
+        -> directives context rule enumLocation directives'
+        >< foldMap (enumValueDefinition context rule) values
+    Full.InputObjectTypeDefinition _ _ directives' fields
+        -> directives context rule inputObjectLocation directives'
+        <> foldMap forEachInputFieldDefinition fields
+  where
+    forEachInputFieldDefinition =
+        inputValueDefinition context rule inputFieldDefinitionLocation
+
+enumValueDefinition :: forall m
+    . Validation m
+    -> ApplyRule m Full.EnumValueDefinition
+enumValueDefinition context rule (Full.EnumValueDefinition _ _ directives') =
+    directives context rule enumValueLocation directives'
+
+fieldDefinition :: forall m. Validation m -> ApplyRule m Full.FieldDefinition
+fieldDefinition context rule (Full.FieldDefinition _ _ arguments' _ directives')
+    = directives context rule fieldDefinitionLocation directives'
+    >< argumentsDefinition context rule arguments'
+
+argumentsDefinition :: forall m
+    . Validation m
+    -> ApplyRule m Full.ArgumentsDefinition
+argumentsDefinition context rule (Full.ArgumentsDefinition definitions) =
+    foldMap forEachArgument definitions
+  where
+    forEachArgument =
+        inputValueDefinition context rule argumentDefinitionLocation
+
+inputValueDefinition :: forall m
+    . Validation m
+    -> Validation.Rule m
+    -> DirectiveLocation
+    -> Full.InputValueDefinition
+    -> Seq (Validation.RuleT m)
+inputValueDefinition context rule directiveLocation definition' =
+    let Full.InputValueDefinition _ _ _ _ directives' = definition'
+     in directives context rule directiveLocation directives'
+
+operationDefinition :: forall m
+    . Validation.Rule m
+    -> Validation m
+    -> Full.OperationDefinition
+    -> Seq (Validation.RuleT m)
+operationDefinition rule context operation
+    | Validation.OperationDefinitionRule operationRule <- rule =
+        pure $ operationRule operation
+    | Validation.VariablesRule variablesRule <- rule
+    , Full.OperationDefinition _ _ variables _ _ _ <- operation =
+        foldMap (variableDefinition context rule) variables |> variablesRule variables
+    | Full.SelectionSet selections _ <- operation =
+        selectionSet context types' rule queryRoot selections
+    | Full.OperationDefinition Full.Query _ _ directives' selections _  <- operation
+        = selectionSet context types' rule queryRoot selections
+        >< directives context rule queryLocation directives'
+    | Full.OperationDefinition Full.Mutation _ _ directives' selections _  <- operation =
+        let root = Out.NamedObjectType <$> Schema.mutation schema'
+         in selectionSet context types' rule root selections
+        >< directives context rule mutationLocation directives'
+    | Full.OperationDefinition Full.Subscription _ _ directives' selections _  <- operation =
+        let root = Out.NamedObjectType <$> Schema.subscription schema'
+         in selectionSet context types' rule root selections
+        >< directives context rule subscriptionLocation directives'
+  where
+    schema' = Validation.schema context
+    queryRoot = Just $ Out.NamedObjectType $ Schema.query schema'
+    types' = Schema.types schema'
+        
+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 :: forall m
+    . Validation m
+    -> ApplyRule m Full.VariableDefinition
+variableDefinition context rule (Full.VariableDefinition _ typeName value' _)
+    | Just defaultValue' <- value'
+    , types <- Schema.types $ Validation.schema context
+    , variableType <- Type.lookupInputType typeName types =
+        constValue rule variableType defaultValue'
+variableDefinition _ _ _ = mempty
+
+constValue :: forall m
+    . Validation.Rule m
+    -> Maybe In.Type
+    -> Full.Node Full.ConstValue
+    -> Seq (Validation.RuleT m)
+constValue (Validation.ValueRule _ rule) valueType = go valueType
+  where
+    go inputObjectType value'@(Full.Node (Full.ConstObject fields) _)
+        = foldMap (forEach inputObjectType) (Seq.fromList fields)
+        |> rule inputObjectType value'
+    go listType value'@(Full.Node (Full.ConstList values) location')
+        = embedListLocation go listType values location'
+        |> rule listType value'
+    go anotherValue value' = pure $ rule anotherValue value'
+    forEach inputObjectType Full.ObjectField{value = value', ..} =
+        go (valueTypeByName name inputObjectType) value'
+constValue _ _ = const mempty
+
+inputFieldType :: In.InputField -> In.Type
+inputFieldType (In.InputField _ inputFieldType' _) = inputFieldType'
+
+valueTypeByName :: Full.Name -> Maybe In.Type -> Maybe In.Type
+valueTypeByName fieldName (Just( In.InputObjectBaseType inputObjectType)) =
+    let In.InputObjectType _ _ fieldTypes = inputObjectType
+     in inputFieldType <$> HashMap.lookup fieldName fieldTypes
+valueTypeByName _ _ = Nothing
+
+fragmentDefinition :: forall m
+    . Validation.Rule m
+    -> Validation m
+    -> Full.FragmentDefinition
+    -> Seq (Validation.RuleT m)
+fragmentDefinition (Validation.FragmentDefinitionRule rule) _ definition' =
+    pure $ rule definition'
+fragmentDefinition rule context definition'
+    | Full.FragmentDefinition _ typeCondition directives' selections _ <- definition'
+    , Validation.FragmentRule definitionRule _ <- rule
+        = applyToChildren typeCondition directives' selections
+        |> definitionRule definition'
+    | Full.FragmentDefinition _ typeCondition directives' selections _ <- definition'
+        = applyToChildren typeCondition directives' selections
+  where
+    types' = Schema.types $ Validation.schema context
+    applyToChildren typeCondition directives' selections
+        = selectionSet context types' rule (lookupType' typeCondition) selections
+        >< directives context rule fragmentDefinitionLocation directives'
+    lookupType' = flip lookupType types'
+
+lookupType :: forall m
+    . Full.TypeCondition
+    -> HashMap Full.Name (Schema.Type m)
+    -> Maybe (Out.Type m)
+lookupType typeCondition types' = HashMap.lookup typeCondition types'
+    >>= typeToOut
+
+selectionSet :: Traversable t
+    => forall m
+    . Validation m
+    -> ApplySelectionRule m (t Full.Selection)
+selectionSet context types' rule = foldMap . selection context types' rule
+
+selection :: forall m. Validation m -> ApplySelectionRule m Full.Selection
+selection context types' rule objectType selection'
+    | Validation.SelectionRule selectionRule <- rule =
+        applyToChildren |> selectionRule objectType selection'
+    | otherwise = applyToChildren
+  where
+    applyToChildren =
+        case selection' of
+            Full.FieldSelection field' ->
+                field context types' rule objectType field'
+            Full.InlineFragmentSelection inlineFragment' ->
+                inlineFragment context types' rule objectType inlineFragment'
+            Full.FragmentSpreadSelection fragmentSpread' ->
+                fragmentSpread context rule fragmentSpread'
+
+field :: forall m. Validation m -> ApplySelectionRule m Full.Field
+field context types' rule objectType field' = go field'
+  where
+    go (Full.Field _ fieldName _ _ _ _)
+        | Validation.FieldRule fieldRule <- rule =
+            applyToChildren fieldName |> fieldRule objectType field'
+        | Validation.ArgumentsRule argumentsRule _  <- rule =
+            applyToChildren fieldName |> argumentsRule objectType field'
+        | otherwise = applyToChildren fieldName
+    typeFieldType (Out.Field _ type' _) = type'
+    typeFieldArguments (Out.Field _ _ argumentTypes) = argumentTypes
+    applyToChildren fieldName =
+        let Full.Field _ _ arguments' directives' selections _ = field'
+            typeField = objectType >>= Type.lookupTypeField fieldName
+            argumentTypes = maybe mempty typeFieldArguments typeField
+         in selectionSet context types' rule (typeFieldType <$> typeField) selections
+            >< directives context rule fieldLocation directives'
+            >< arguments rule argumentTypes arguments'
+
+arguments :: forall m
+    . Validation.Rule m
+    -> In.Arguments
+    -> [Full.Argument]
+    -> Seq (Validation.RuleT m)
+arguments rule argumentTypes = foldMap forEach . Seq.fromList
+  where
+    forEach argument'@(Full.Argument argumentName _ _) = 
+       let argumentType = HashMap.lookup argumentName argumentTypes
+        in argument rule argumentType argument'
+
+argument :: forall m
+    . Validation.Rule m
+    -> Maybe In.Argument
+    -> Full.Argument
+    -> Seq (Validation.RuleT m)
+argument rule argumentType (Full.Argument _ value' _) =
+    value rule (valueType <$> argumentType) value'
+  where
+    valueType (In.Argument _ valueType' _) = valueType'
+
+-- valueTypeFromList :: Maybe In.Type -> Maybe In.Type
+embedListLocation :: forall a m
+    . (Maybe In.Type -> Full.Node a -> Seq m)
+    -> Maybe In.Type
+    -> [a]
+    -> Full.Location
+    -> Seq m
+embedListLocation go listType values location'
+    = foldMap (go $ valueTypeFromList listType) 
+    $ flip Full.Node location' <$> Seq.fromList values
+  where
+    valueTypeFromList (Just (In.ListBaseType baseType)) = Just baseType
+    valueTypeFromList _ = Nothing
+
+value :: forall m
+    . Validation.Rule m
+    -> Maybe In.Type
+    -> Full.Node Full.Value
+    -> Seq (Validation.RuleT m)
+value (Validation.ValueRule rule _) valueType = go valueType
+  where
+    go inputObjectType value'@(Full.Node (Full.Object fields) _)
+        = foldMap (forEach inputObjectType) (Seq.fromList fields)
+        |> rule inputObjectType value'
+    go listType value'@(Full.Node (Full.List values) location')
+        = embedListLocation go listType values location'
+        |> rule listType value'
+    go anotherValue value' = pure $ rule anotherValue value'
+    forEach inputObjectType Full.ObjectField{value = value', ..} =
+        go (valueTypeByName name inputObjectType) value'
+value _ _ = const mempty
+
+inlineFragment :: forall m
+    . Validation m
+    -> ApplySelectionRule m Full.InlineFragment
+inlineFragment context types' rule objectType inlineFragment' =
+    go inlineFragment'
+  where
+    go (Full.InlineFragment optionalType directives' selections _)
+        | Validation.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 context types' rule objectType' selections
+        >< directives context rule inlineFragmentLocation directives'
+
+fragmentSpread :: forall m. Validation m -> ApplyRule m Full.FragmentSpread
+fragmentSpread context rule fragmentSpread'@(Full.FragmentSpread _ directives' _)
+    | Validation.FragmentSpreadRule fragmentRule <- rule =
+        applyToChildren |> fragmentRule fragmentSpread'
+    | otherwise = applyToChildren
+  where
+    applyToChildren = directives context rule fragmentSpreadLocation directives'
+
+directives :: Traversable t
+    => forall m
+    . Validation m
+    -> Validation.Rule m
+    -> DirectiveLocation
+    -> t Full.Directive
+    -> Seq (Validation.RuleT m)
+directives context rule directiveLocation directives'
+    | Validation.DirectivesRule directivesRule <- rule =
+        applyToChildren |> directivesRule directiveLocation directiveList
+    | otherwise = applyToChildren
+  where
+    directiveList = toList directives'
+    applyToChildren = foldMap (directive context rule) directiveList
+
+directive :: forall m. Validation m -> ApplyRule m Full.Directive
+directive _ (Validation.ArgumentsRule _ argumentsRule) directive' =
+    pure $ argumentsRule directive'
+directive context rule (Full.Directive directiveName arguments' _) =
+    let argumentTypes = maybe HashMap.empty directiveArguments
+            $ HashMap.lookup directiveName
+            $ Schema.directives
+            $ Validation.schema context
+     in arguments rule argumentTypes arguments'
+  where
+    directiveArguments (Schema.Directive _ _ argumentTypes) = argumentTypes