graphql/src/Language/GraphQL/Validate/Rules.hs

{- This Source Code Form is subject to the terms of the Mozilla Public License,
   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 LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}

-- | This module contains default rules defined in the GraphQL specification.
module Language.GraphQL.Validate.Rules
    ( directivesInValidLocationsRule
    , executableDefinitionsRule
    , fieldsOnCorrectTypeRule
    , fragmentsOnCompositeTypesRule
    , fragmentSpreadTargetDefinedRule
    , fragmentSpreadTypeExistenceRule
    , loneAnonymousOperationRule
    , knownArgumentNamesRule
    , knownDirectiveNamesRule
    , knownInputFieldNamesRule
    , noFragmentCyclesRule
    , noUndefinedVariablesRule
    , noUnusedFragmentsRule
    , noUnusedVariablesRule
    , overlappingFieldsCanBeMergedRule
    , possibleFragmentSpreadsRule
    , providedRequiredInputFieldsRule
    , providedRequiredArgumentsRule
    , scalarLeafsRule
    , singleFieldSubscriptionsRule
    , specifiedRules
    , uniqueArgumentNamesRule
    , uniqueDirectiveNamesRule
    , uniqueFragmentNamesRule
    , uniqueInputFieldNamesRule
    , uniqueOperationNamesRule
    , uniqueVariableNamesRule
    , valuesOfCorrectTypeRule
    , variablesInAllowedPositionRule
    , variablesAreInputTypesRule
    ) where

import Control.Monad ((>=>), foldM)
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Reader (ReaderT(..), ask, asks, mapReaderT)
import Control.Monad.Trans.State (StateT, evalStateT, gets, modify)
import Data.Bifunctor (first)
import Data.Foldable (find, fold, foldl', toList)
import qualified Data.HashMap.Strict as HashMap
import Data.HashMap.Strict (HashMap)
import Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet
import Data.List (groupBy, sortBy, sortOn)
import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, mapMaybe)
import Data.List.NonEmpty (NonEmpty(..))
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 qualified Language.GraphQL.AST.Document as Full
import qualified Language.GraphQL.Type.Definition as Definition
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 qualified Language.GraphQL.Type.Schema as Schema
import Language.GraphQL.Validate.Validation

-- Local help type that contains a hash set to track visited fragments.
type ValidationState m a =
    StateT (HashSet Full.Name) (ReaderT (Validation m) Seq) a

-- | Default rules given in the specification.
specifiedRules :: forall m. [Rule m]
specifiedRules =
    -- Documents.
    [ executableDefinitionsRule
    -- Operations.
    , singleFieldSubscriptionsRule
    , loneAnonymousOperationRule
    , uniqueOperationNamesRule
    -- Fields
    , fieldsOnCorrectTypeRule
    , scalarLeafsRule
    , overlappingFieldsCanBeMergedRule
    -- Arguments.
    , knownArgumentNamesRule
    , uniqueArgumentNamesRule
    , providedRequiredArgumentsRule
    -- Fragments.
    , uniqueFragmentNamesRule
    , fragmentSpreadTypeExistenceRule
    , fragmentsOnCompositeTypesRule
    , noUnusedFragmentsRule
    , fragmentSpreadTargetDefinedRule
    , noFragmentCyclesRule
    , possibleFragmentSpreadsRule
    -- Values
    , valuesOfCorrectTypeRule
    , knownInputFieldNamesRule
    , uniqueInputFieldNamesRule
    , providedRequiredInputFieldsRule
    -- Directives.
    , knownDirectiveNamesRule
    , directivesInValidLocationsRule
    , uniqueDirectiveNamesRule
    -- Variables.
    , uniqueVariableNamesRule
    , variablesAreInputTypesRule
    , noUndefinedVariablesRule
    , noUnusedVariablesRule
    , variablesInAllowedPositionRule
    ]

-- | Definition must be OperationDefinition or FragmentDefinition.
executableDefinitionsRule :: forall m. Rule m
executableDefinitionsRule = DefinitionRule $ \case
    Full.ExecutableDefinition _ -> lift mempty
    Full.TypeSystemDefinition _ location' -> pure $ error' location'
    Full.TypeSystemExtension _ location' -> pure $ error' location'
  where
    error' location' = Error
        { message =
            "Definition must be OperationDefinition or FragmentDefinition."
        , locations = [location']
        }

-- | Subscription operations must have exactly one root field.
singleFieldSubscriptionsRule :: forall m. Rule m
singleFieldSubscriptionsRule = OperationDefinitionRule $ \case
    Full.OperationDefinition Full.Subscription name' _ _ rootFields location' -> do
        groupedFieldSet <- evalStateT (collectFields rootFields) HashSet.empty
        case HashSet.size groupedFieldSet of
            1 -> lift mempty
            _
                | Just name <- name' -> pure $ Error
                    { message = concat
                        [ "Subscription \""
                        , Text.unpack name
                        , "\" must select only one top level field."
                        ]
                    , locations = [location']
                    }
                | otherwise -> pure $ Error
                    { message = errorMessage
                    , locations = [location']
                    }
    _ -> lift mempty
  where
    errorMessage =
        "Anonymous Subscription must select only one top level field."
    collectFields selectionSet = foldM forEach HashSet.empty selectionSet
    forEach accumulator = \case
        Full.FieldSelection fieldSelection -> forField accumulator fieldSelection
        Full.FragmentSpreadSelection fragmentSelection ->
            forSpread accumulator fragmentSelection
        Full.InlineFragmentSelection fragmentSelection ->
            forInline accumulator fragmentSelection
    forField accumulator (Full.Field alias name _ directives' _ _)
        | any skip directives' = pure accumulator
        | Just aliasedName <- alias = pure
            $ HashSet.insert aliasedName accumulator
        | otherwise = pure $ HashSet.insert name accumulator
    forSpread accumulator (Full.FragmentSpread fragmentName directives' _)
        | any skip directives' = pure accumulator
        | otherwise = do
            inVisitetFragments <- gets $ HashSet.member fragmentName
            if inVisitetFragments
               then pure accumulator
               else collectFromSpread fragmentName accumulator
    forInline accumulator (Full.InlineFragment maybeType directives' selections _)
        | any skip directives' = pure accumulator
        | Just typeCondition <- maybeType =
            collectFromFragment typeCondition selections accumulator
        | otherwise = HashSet.union accumulator
            <$> collectFields selections
    skip (Full.Directive "skip" [Full.Argument "if" (Full.Node argumentValue _) _] _) =
        Full.Boolean True == argumentValue
    skip (Full.Directive "include" [Full.Argument "if" (Full.Node argumentValue _) _] _) =
        Full.Boolean False == argumentValue
    skip _ = False
    collectFromFragment typeCondition selectionSet accumulator = do
        types' <- lift $ asks $ Schema.types . schema
        schema' <- lift $ asks schema
        case Type.lookupTypeCondition typeCondition types' of
            Nothing -> pure accumulator
            Just compositeType
                | Just objectType <- Schema.subscription schema'
                , True <- Type.doesFragmentTypeApply compositeType objectType ->
                    HashSet.union accumulator <$> collectFields selectionSet
                | otherwise -> pure accumulator
    collectFromSpread fragmentName accumulator = do
        modify $ HashSet.insert fragmentName
        ast' <- lift $ asks ast
        case findFragmentDefinition fragmentName ast' of
            Nothing -> pure accumulator
            Just (Full.FragmentDefinition _ typeCondition _ selectionSet _) ->
                collectFromFragment typeCondition selectionSet accumulator

-- | GraphQL allows a short‐hand form for defining query operations when only
-- that one operation exists in the document.
loneAnonymousOperationRule :: forall m. Rule m
loneAnonymousOperationRule = OperationDefinitionRule $ \case
      Full.SelectionSet _ thisLocation -> check thisLocation
      Full.OperationDefinition _ Nothing _ _ _ thisLocation ->
          check thisLocation
      _ -> lift mempty
    where
      check thisLocation = asks ast
          >>= lift . foldr (filterAnonymousOperations thisLocation) mempty
      filterAnonymousOperations thisLocation definition Empty
          | (viewOperation -> Just operationDefinition) <- definition =
              compareAnonymousOperations thisLocation operationDefinition
      filterAnonymousOperations _ _ accumulator = accumulator
      compareAnonymousOperations thisLocation = \case
          Full.OperationDefinition _ _ _ _ _ thatLocation
              | thisLocation /= thatLocation -> pure $ error' thisLocation
          Full.SelectionSet _ thatLocation
              | thisLocation /= thatLocation -> pure $ error' thisLocation
          _ -> mempty
      error' location' = Error
          { message =
              "This anonymous operation must be the only defined operation."
          , locations = [location']
          }

-- | Each named operation definition must be unique within a document when
-- referred to by its name.
uniqueOperationNamesRule :: forall m. Rule m
uniqueOperationNamesRule = OperationDefinitionRule $ \case
    Full.OperationDefinition _ (Just thisName) _ _ _ thisLocation ->
        findDuplicates (filterByName thisName) thisLocation (error' thisName)
    _ -> lift mempty
  where
    error' operationName = concat
        [ "There can be only one operation named \""
        , Text.unpack operationName
        , "\"."
        ]
    filterByName thisName definition' accumulator
        | (viewOperation -> Just operationDefinition) <- definition'
        , Full.OperationDefinition _ (Just thatName) _ _ _ thatLocation <- operationDefinition
        , thisName == thatName = thatLocation : accumulator
        | otherwise = accumulator

findDuplicates :: (Full.Definition -> [Full.Location] -> [Full.Location])
    -> Full.Location
    -> String
    -> RuleT m
findDuplicates filterByName thisLocation errorMessage = do
    ast' <- asks ast
    let locations' = foldr filterByName [] ast'
    if length locations' > 1 && head locations' == thisLocation
        then pure $ error' locations'
        else lift mempty
  where
    error' locations' = Error 
        { message = errorMessage
        , locations = locations'
        }

viewOperation :: Full.Definition -> Maybe Full.OperationDefinition
viewOperation definition
    | Full.ExecutableDefinition executableDefinition <- definition
    , Full.DefinitionOperation operationDefinition <- executableDefinition =
        Just operationDefinition
viewOperation _ = Nothing

viewFragment :: Full.Definition -> Maybe Full.FragmentDefinition
viewFragment definition
    | Full.ExecutableDefinition executableDefinition <- definition
    , Full.DefinitionFragment fragmentDefinition <- executableDefinition =
        Just fragmentDefinition
viewFragment _ = Nothing

-- | Fragment definitions are referenced in fragment spreads by name. To avoid
-- ambiguity, each fragment’s name must be unique within a document.
--
-- Inline fragments are not considered fragment definitions, and are unaffected
-- by this validation rule.
uniqueFragmentNamesRule :: forall m. Rule m
uniqueFragmentNamesRule = FragmentDefinitionRule $ \case
    Full.FragmentDefinition thisName _ _ _ thisLocation ->
        findDuplicates (filterByName thisName) thisLocation (error' thisName)
  where
    error' fragmentName = concat
        [ "There can be only one fragment named \""
        , Text.unpack fragmentName
        , "\"."
        ]
    filterByName thisName definition accumulator
        | Just fragmentDefinition <- viewFragment definition
        , Full.FragmentDefinition thatName _ _ _ thatLocation <- fragmentDefinition
        , thisName == thatName = thatLocation : accumulator
        | otherwise = accumulator

-- | Named fragment spreads must refer to fragments defined within the document.
-- It is a validation error if the target of a spread is not defined.
fragmentSpreadTargetDefinedRule :: forall m. Rule m
fragmentSpreadTargetDefinedRule = FragmentSpreadRule $ \case
    Full.FragmentSpread fragmentName _ location' -> do
        ast' <- asks ast
        case find (isSpreadTarget fragmentName) ast' of
            Nothing -> pure $ Error
                { message = error' fragmentName
                , locations = [location']
                }
            Just _ -> lift mempty
  where
    error' fragmentName = concat
        [ "Fragment target \""
        , Text.unpack fragmentName
        , "\" is undefined."
        ]

isSpreadTarget :: Text -> Full.Definition -> Bool
isSpreadTarget thisName (viewFragment -> Just fragmentDefinition)
    | Full.FragmentDefinition thatName _ _ _ _ <- fragmentDefinition
    , thisName == thatName = True
isSpreadTarget _ _ = False

-- | Fragments must be specified on types that exist in the schema. This applies
-- 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 $ const $ \case
    Full.FragmentSpreadSelection fragmentSelection
        | Full.FragmentSpread fragmentName _ location' <- fragmentSelection -> do
            types' <- asks $ Schema.types . schema
            typeCondition <- findSpreadTarget fragmentName
            case HashMap.lookup typeCondition types' of
                Nothing -> pure $ Error
                    { message = spreadError fragmentName typeCondition
                    , locations = [location']
                    }
                Just _ -> lift mempty
    Full.InlineFragmentSelection fragmentSelection
        | Full.InlineFragment maybeType _ _ location' <- fragmentSelection
        , Just typeCondition <- maybeType -> do
            types' <- asks $ Schema.types . schema
            case HashMap.lookup typeCondition types' of
                Nothing -> pure $ Error
                    { message = inlineError typeCondition
                    , locations = [location']
                    }
                Just _ -> lift mempty
    _ -> lift mempty
  where
    spreadError fragmentName typeCondition = concat
        [ "Fragment \""
        , Text.unpack fragmentName
        , "\" is specified on type \""
        , Text.unpack typeCondition
        , "\" which doesn't exist in the schema."
        ]
    inlineError typeCondition = concat
        [ "Inline fragment is specified on type \""
        , Text.unpack typeCondition
        , "\" which doesn't exist in the schema."
        ]

maybeToSeq :: forall a. Maybe a -> Seq a
maybeToSeq (Just x) = pure x
maybeToSeq Nothing = mempty

-- | Fragments can only be declared on unions, interfaces, and objects. They are
-- invalid on scalars. They can only be applied on non‐leaf fields. This rule
-- applies to both inline and named fragments.
fragmentsOnCompositeTypesRule :: forall m. Rule m
fragmentsOnCompositeTypesRule = FragmentRule definitionRule inlineRule
  where
    inlineRule (Full.InlineFragment (Just typeCondition) _ _ location') =
        check typeCondition location'
    inlineRule _ = lift mempty
    definitionRule (Full.FragmentDefinition _ typeCondition _ _ location') =
        check typeCondition location'
    check typeCondition location' = do
        types' <- asks $ Schema.types . schema
        -- Skip unknown types, they are checked by another rule.
        _ <- lift $ maybeToSeq $ HashMap.lookup typeCondition types'
        case Type.lookupTypeCondition typeCondition types' of
            Nothing -> pure $ Error
                { message = errorMessage typeCondition
                , locations = [location']
                }
            Just _ -> lift mempty
    errorMessage typeCondition = concat
        [ "Fragment cannot condition on non composite type \""
        , Text.unpack typeCondition,
        "\"."
        ]

-- | Defined fragments must be used within a document.
noUnusedFragmentsRule :: forall m. Rule m
noUnusedFragmentsRule = FragmentDefinitionRule $ \fragment -> do
    let Full.FragmentDefinition fragmentName _ _ _ location' = fragment
     in mapReaderT (checkFragmentName fragmentName location')
        $ asks ast
        >>= flip evalStateT HashSet.empty
        . filterSelections evaluateSelection
        . foldMap definitionSelections
  where
    checkFragmentName fragmentName location' elements
        | fragmentName `elem` elements = mempty
        | otherwise = pure $ makeError fragmentName location'
    makeError fragName location' = Error
        { message = errorMessage fragName
        , locations = [location']
        }
    errorMessage fragName = concat
        [ "Fragment \""
        , Text.unpack fragName
        , "\" is never used."
        ]
    evaluateSelection selection
        | Full.FragmentSpreadSelection spreadSelection <- selection
        , Full.FragmentSpread spreadName _ _ <- spreadSelection =
            lift $ pure spreadName
    evaluateSelection _ = lift $ lift mempty

definitionSelections :: Full.Definition -> Full.SelectionSetOpt
definitionSelections (viewOperation -> Just operation)
    | Full.OperationDefinition _ _ _ _ selections _ <- operation =
        toList selections
    | Full.SelectionSet selections _ <- operation = toList selections
definitionSelections (viewFragment -> Just fragment)
    | Full.FragmentDefinition _ _ _ selections _ <- fragment = toList selections
definitionSelections _ = []

filterSelections :: Foldable t
    => forall a m
    . (Full.Selection -> ValidationState m a)
    -> t Full.Selection
    -> ValidationState m a
filterSelections applyFilter selections
    = (lift . lift) (Seq.fromList $ foldr evaluateSelection mempty selections)
    >>= applyFilter
  where
    evaluateSelection selection accumulator
        | Full.FragmentSpreadSelection{} <- selection = selection : accumulator
        | Full.FieldSelection fieldSelection <- selection
        , Full.Field _ _ _ _ subselections _ <- fieldSelection =
            selection : foldr evaluateSelection accumulator subselections
        | Full.InlineFragmentSelection inlineSelection <- selection
        , Full.InlineFragment _ _ subselections _ <- inlineSelection =
            selection : foldr evaluateSelection accumulator subselections

-- | The graph of fragment spreads must not form any cycles including spreading
-- itself. Otherwise an operation could infinitely spread or infinitely execute
-- on cycles in the underlying data.
noFragmentCyclesRule :: forall m. Rule m
noFragmentCyclesRule = FragmentDefinitionRule $ \case
    Full.FragmentDefinition fragmentName _ _ selections location' -> do
        state <- evalStateT (collectCycles selections) (0, fragmentName)
        let spreadPath = fst <$> sortBy (comparing snd) (HashMap.toList state)
        case reverse spreadPath of
            x : _ | x == fragmentName -> pure $ Error
                { message = concat
                    [ "Cannot spread fragment \""
                    , Text.unpack fragmentName
                    , "\" within itself (via "
                    , Text.unpack $ Text.intercalate " -> " $ fragmentName : spreadPath
                    , ")."
                    ]
                , locations = [location']
                }
            _ -> lift mempty
  where
    collectCycles :: Traversable t
        => t Full.Selection
        -> StateT (Int, Full.Name) (ReaderT (Validation m) Seq) (HashMap Full.Name Int)
    collectCycles selectionSet = foldM forEach HashMap.empty selectionSet
    forEach accumulator = \case
        Full.FieldSelection fieldSelection -> forField accumulator fieldSelection
        Full.InlineFragmentSelection fragmentSelection ->
            forInline accumulator fragmentSelection
        Full.FragmentSpreadSelection fragmentSelection ->
            forSpread accumulator fragmentSelection
    forSpread accumulator (Full.FragmentSpread fragmentName _ _) = do
        firstFragmentName <- gets snd
        modify $ first (+ 1)
        lastIndex <- gets fst
        let newAccumulator = HashMap.insert fragmentName lastIndex accumulator
        let inVisitetFragment = HashMap.member fragmentName accumulator
        if fragmentName == firstFragmentName || inVisitetFragment
            then pure newAccumulator
            else collectFromSpread fragmentName newAccumulator
    forInline accumulator (Full.InlineFragment _ _ selections _) =
        (accumulator <>) <$> collectCycles selections
    forField accumulator (Full.Field _ _ _ _ selections _) =
        (accumulator <>) <$> collectCycles selections
    collectFromSpread fragmentName accumulator = do
        ast' <- lift $ asks ast
        case findFragmentDefinition fragmentName ast' of
            Nothing -> pure accumulator
            Just (Full.FragmentDefinition _ _ _ selections _) ->
                (accumulator <>) <$> collectCycles selections

findFragmentDefinition :: Text
    -> NonEmpty Full.Definition
    -> Maybe Full.FragmentDefinition
findFragmentDefinition fragmentName = foldr compareDefinition Nothing
  where
    compareDefinition (Full.ExecutableDefinition executableDefinition) Nothing
        | Full.DefinitionFragment fragmentDefinition <- executableDefinition
        , Full.FragmentDefinition anotherName _ _ _ _ <- fragmentDefinition
        , anotherName == fragmentName = Just fragmentDefinition
    compareDefinition _ accumulator = accumulator

-- | Fields and directives treat arguments as a mapping of argument name to
-- value. More than one argument with the same name in an argument set is
-- ambiguous and invalid.
uniqueArgumentNamesRule :: forall m. Rule m
uniqueArgumentNamesRule = ArgumentsRule fieldRule directiveRule
  where
    fieldRule _ (Full.Field _ _ arguments _ _ _) =
        lift $ filterDuplicates extract "argument" arguments
    directiveRule (Full.Directive _ arguments _) =
        lift $ filterDuplicates extract "argument" arguments
    extract (Full.Argument argumentName _ location') = (argumentName, location')

-- | Directives are used to describe some metadata or behavioral change on the
-- definition they apply to. When more than one directive of the same name is
-- used, the expected metadata or behavior becomes ambiguous, therefore only one
-- of each directive is allowed per location.
uniqueDirectiveNamesRule :: forall m. Rule m
uniqueDirectiveNamesRule = DirectivesRule
    $ const $ lift . filterDuplicates extract "directive"
  where
    extract (Full.Directive directiveName _ location') =
        (directiveName, location')

groupSorted :: forall a. (a -> Text) -> [a] -> [[a]]
groupSorted getName = groupBy equalByName . sortOn getName
  where
    equalByName lhs rhs = getName lhs == getName rhs

filterDuplicates :: forall a
    . (a -> (Text, Full.Location))
    -> String
    -> [a]
    -> Seq Error
filterDuplicates extract nodeType = Seq.fromList
    . fmap makeError
    . filter ((> 1) . length)
    . groupSorted getName
  where
    getName = fst . extract
    makeError directives' = Error
        { message = makeMessage $ head directives'
        , locations = snd . extract <$> directives'
        }
    makeMessage directive = concat
        [ "There can be only one "
        , nodeType
        , " named \""
        , Text.unpack $ fst $ extract directive
        , "\"."
        ]

-- | If any operation defines more than one variable with the same name, it is
-- ambiguous and invalid. It is invalid even if the type of the duplicate
-- variable is the same.
uniqueVariableNamesRule :: forall m. Rule m
uniqueVariableNamesRule = VariablesRule
    $ lift . filterDuplicates extract "variable"
  where
    extract (Full.VariableDefinition variableName _ _ location') =
        (variableName, location')

-- | Variables can only be input types. Objects, unions and interfaces cannot be
-- used as inputs.
variablesAreInputTypesRule :: forall m. Rule m
variablesAreInputTypesRule = VariablesRule
    $ (traverse check . Seq.fromList) >=> lift
  where
    check (Full.VariableDefinition name typeName _ location')
        = asks (Schema.types . schema)
        >>= lift
        . maybe (makeError name typeName location') (const mempty)
        . Type.lookupInputType typeName
    makeError name typeName location' = pure $ Error
        { message = concat
            [ "Variable \"$"
            , Text.unpack name
            , "\" cannot be non-input type \""
            , Text.unpack $ getTypeName typeName
            , "\"."
            ]
        , locations = [location']
        }
    getTypeName (Full.TypeNamed name) = name
    getTypeName (Full.TypeList name) = getTypeName name
    getTypeName (Full.TypeNonNull (Full.NonNullTypeNamed nonNull)) = nonNull
    getTypeName (Full.TypeNonNull (Full.NonNullTypeList nonNull)) =
        getTypeName nonNull

-- | Variables are scoped on a per‐operation basis. That means that any variable
-- used within the context of an operation must be defined at the top level of
-- that operation.
noUndefinedVariablesRule :: forall m. Rule m
noUndefinedVariablesRule =
    variableUsageDifference (flip HashMap.difference) errorMessage
  where
    errorMessage Nothing variableName = concat
        [ "Variable \"$"
        , Text.unpack variableName
        , "\" is not defined."
        ]
    errorMessage (Just operationName) variableName = concat
        [ "Variable \"$"
        , Text.unpack variableName
        , "\" is not defined by operation \""
        , Text.unpack operationName
        , "\"."
        ]

type UsageDifference
    = HashMap Full.Name [Full.Location]
    -> HashMap Full.Name [Full.Location]
    -> HashMap Full.Name [Full.Location]

variableUsageDifference :: forall m. UsageDifference
    -> (Maybe Full.Name -> Full.Name -> String)
    -> Rule m
variableUsageDifference difference errorMessage = OperationDefinitionRule $ \case
    Full.SelectionSet _ _ -> lift mempty
    Full.OperationDefinition _ operationName variables _ selections _ ->
        let variableNames = HashMap.fromList $ getVariableName <$> variables
         in mapReaderT (readerMapper operationName variableNames)
            $ flip evalStateT HashSet.empty
            $ filterSelections'
            $ toList selections
  where
    readerMapper operationName variableNames' = Seq.fromList
        . fmap (makeError operationName)
        . HashMap.toList
        . difference variableNames'
        . HashMap.fromListWith (++)
        . toList
    getVariableName (Full.VariableDefinition variableName _ _ location') =
        (variableName, [location'])
    filterSelections' :: Foldable t
        => t Full.Selection
        -> ValidationState m (Full.Name, [Full.Location])
    filterSelections' = filterSelections variableFilter
    variableFilter :: Full.Selection -> ValidationState m (Full.Name, [Full.Location])
    variableFilter (Full.InlineFragmentSelection inline)
        | Full.InlineFragment _ directives' _ _ <- inline =
            lift $ lift $ mapDirectives directives'
    variableFilter (Full.FieldSelection fieldSelection)
        | Full.Field _ _ arguments directives' _ _ <- fieldSelection =
            lift $ lift $ mapArguments arguments <> mapDirectives directives'
    variableFilter (Full.FragmentSpreadSelection spread)
        | Full.FragmentSpread fragmentName _ _ <- spread = do
            nonVisitedFragmentDefinition <- visitFragmentDefinition fragmentName
            case nonVisitedFragmentDefinition of
                Just fragmentDefinition -> diveIntoSpread fragmentDefinition
                _ -> lift $ lift mempty
    diveIntoSpread (Full.FragmentDefinition _ _ directives' selections _)
        = filterSelections' selections
        >>= lift . mapReaderT (<> mapDirectives directives') . pure
    findDirectiveVariables (Full.Directive _ arguments _) = mapArguments arguments
    mapArguments = Seq.fromList . mapMaybe findArgumentVariables
    mapDirectives = foldMap findDirectiveVariables
    findArgumentVariables (Full.Argument _ Full.Node{ node = Full.Variable value', ..} _) =
        Just (value', [location])
    findArgumentVariables _ = Nothing
    makeError operationName (variableName, locations') = Error
        { message = errorMessage operationName variableName
        , locations = locations'
        }

-- | All variables defined by an operation must be used in that operation or a
-- fragment transitively included by that operation. Unused variables cause a
-- validation error.
noUnusedVariablesRule :: forall m. Rule m
noUnusedVariablesRule = variableUsageDifference HashMap.difference errorMessage
  where
    errorMessage Nothing variableName = concat
        [ "Variable \"$"
        , Text.unpack variableName
        , "\" is never used."
        ]
    errorMessage (Just operationName) variableName = concat
        [ "Variable \"$"
        , Text.unpack variableName
        , "\" is never used in operation \""
        , Text.unpack operationName
        , "\"."
        ]

-- | Input objects must not contain more than one field of the same name,
-- otherwise an ambiguity would exist which includes an ignored portion of
-- syntax.
uniqueInputFieldNamesRule :: forall m. Rule m
uniqueInputFieldNamesRule =
    ValueRule (const $ lift . go) (const $ lift . constGo)
  where
    go (Full.Node (Full.Object fields) _) = filterFieldDuplicates fields
    go _ = mempty
    filterFieldDuplicates fields =
        filterDuplicates getFieldName "input field" fields
    getFieldName (Full.ObjectField fieldName _ location') = (fieldName, location')
    constGo (Full.Node (Full.ConstObject fields) _) = filterFieldDuplicates fields
    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 = FieldRule fieldRule
  where
    fieldRule parentType (Full.Field _ fieldName _ _ _ location')
        | Just objectType <- parentType
        , Nothing <- Type.lookupTypeField fieldName objectType
        , Just typeName <- typeNameIfComposite objectType = pure $ Error
            { message = errorMessage fieldName typeName
            , locations = [location']
            }
        | otherwise = lift mempty
    errorMessage fieldName typeName = concat
        [ "Cannot query field \""
        , Text.unpack fieldName
        , "\" on type \""
        , Text.unpack typeName
        , "\"."
        ]

compositeTypeName :: forall m. Type.CompositeType m -> Full.Name
compositeTypeName (Type.CompositeObjectType (Out.ObjectType typeName _ _ _)) =
    typeName
compositeTypeName (Type.CompositeInterfaceType interfaceType) =
    let Out.InterfaceType typeName _ _ _ = interfaceType
     in typeName
compositeTypeName (Type.CompositeUnionType (Out.UnionType typeName _ _)) =
    typeName

typeNameIfComposite :: forall m. Out.Type m -> Maybe Full.Name
typeNameIfComposite = fmap compositeTypeName . Type.outToComposite

-- | 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 = FieldRule fieldRule
  where
    fieldRule parentType selectionField@(Full.Field _ fieldName _ _ _ _)
        | Just objectType <- parentType
        , Just field <- Type.lookupTypeField fieldName objectType =
            let Out.Field _ fieldType _ = field
             in lift $ check fieldType selectionField
        | otherwise = lift mempty
    check (Out.ObjectBaseType (Out.ObjectType typeName _ _ _)) =
        checkNotEmpty typeName
    check (Out.InterfaceBaseType (Out.InterfaceType typeName _ _ _)) =
        checkNotEmpty typeName
    check (Out.UnionBaseType (Out.UnionType typeName _ _)) =
        checkNotEmpty typeName
    check (Out.ScalarBaseType (Definition.ScalarType typeName _)) =
        checkEmpty typeName
    check (Out.EnumBaseType (Definition.EnumType typeName _ _)) =
        checkEmpty typeName
    check (Out.ListBaseType wrappedType) = check wrappedType
    checkNotEmpty typeName (Full.Field _ fieldName _ _ [] location') =
        let fieldName' = Text.unpack fieldName
         in makeError location' $ concat
            [ "Field \""
            , fieldName'
            , "\" of type \""
            , Text.unpack typeName
            , "\" must have a selection of subfields. Did you mean \""
            , fieldName'
            , " { ... }\"?"
            ]
    checkNotEmpty _ _ = mempty
    checkEmpty _ (Full.Field _ _ _ _ [] _) = mempty
    checkEmpty typeName field' =
        let Full.Field _ fieldName _ _ _ location' = field'
         in makeError location' $ concat
            [ "Field \""
            , Text.unpack fieldName
            , "\" must not have a selection since type \""
            , Text.unpack typeName
            , "\" has no subfields."
            ]
    makeError location' errorMessage = pure $ Error
        { 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) (Full.Field _ fieldName arguments  _ _ _)
        | Just typeField <- Type.lookupTypeField fieldName objectType
        , Just typeName <- typeNameIfComposite objectType =
            lift $ foldr (go typeName fieldName typeField) Seq.empty arguments
    fieldRule _ _ = lift mempty
    go typeName fieldName fieldDefinition (Full.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 (Full.Directive directiveName arguments _) = do
        available <- asks $ HashMap.lookup directiveName
            . Schema.directives . schema
        Full.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
        , "\"."
        ]

-- | GraphQL servers define what directives they support. For each usage of a
-- directive, the directive must be available on that server.
knownDirectiveNamesRule :: Rule m
knownDirectiveNamesRule = DirectivesRule $ const $ \directives' -> do
    definitions' <- asks $ Schema.directives . schema
    let directiveSet = HashSet.fromList $ fmap directiveName directives'
    let definitionSet = HashSet.fromList $ HashMap.keys definitions'
    let difference = HashSet.difference directiveSet definitionSet
    let undefined' = filter (definitionFilter difference) directives'
    lift $ Seq.fromList $ makeError <$> undefined'
  where
    definitionFilter difference = flip HashSet.member difference
        . directiveName
    directiveName (Full.Directive directiveName' _ _) = directiveName'
    makeError (Full.Directive directiveName' _ location') = Error
        { message = errorMessage directiveName'
        , locations = [location']
        }
    errorMessage directiveName' = concat
        [ "Unknown directive \"@"
        , Text.unpack directiveName'
        , "\"."
        ]

-- | Every input field provided in an input object value must be defined in the
-- set of possible fields of that input object’s expected type.
knownInputFieldNamesRule :: Rule m
knownInputFieldNamesRule = ValueRule go constGo
  where
    go (Just valueType) (Full.Node (Full.Object inputFields) _)
        | In.InputObjectBaseType objectType <- valueType =
             lift $ Seq.fromList $ mapMaybe (forEach objectType) inputFields
    go _ _ = lift mempty
    constGo (Just valueType) (Full.Node (Full.ConstObject inputFields) _)
        | In.InputObjectBaseType objectType <- valueType =
             lift $ Seq.fromList $ mapMaybe (forEach objectType) inputFields
    constGo  _ _ = lift mempty
    forEach objectType (Full.ObjectField inputFieldName _ location')
        | In.InputObjectType _ _ fieldTypes <- objectType
        , Just _ <- HashMap.lookup inputFieldName fieldTypes = Nothing
        | otherwise
        , In.InputObjectType typeName _ _ <- objectType = pure $ Error
            { message = errorMessage inputFieldName typeName
            , locations = [location']
            }
    errorMessage fieldName typeName = concat
        [ "Field \""
        , Text.unpack fieldName
        , "\" is not defined by type \""
        , Text.unpack typeName
        , "\"."
        ]

-- | GraphQL servers define what directives they support and where they support
-- them. For each usage of a directive, the directive must be used in a location
-- that the server has declared support for.
directivesInValidLocationsRule :: Rule m
directivesInValidLocationsRule = DirectivesRule directivesRule
  where
    directivesRule directiveLocation directives' = do
        Full.Directive directiveName _ location <- lift $ Seq.fromList directives'
        maybeDefinition <- asks
            $ HashMap.lookup directiveName . Schema.directives . schema
        case maybeDefinition of
            Just (Schema.Directive _ allowedLocations _)
                | directiveLocation `notElem` allowedLocations -> pure $ Error
                    { message = errorMessage directiveName directiveLocation
                    , locations = [location]
                    }
            _ -> lift mempty
    errorMessage directiveName directiveLocation = concat
        [ "Directive \"@"
        , Text.unpack directiveName
        , "\" may not be used on "
        , show directiveLocation
        , "."
        ]

-- | Arguments can be required. An argument is required if the argument type is
-- non‐null and does not have a default value. Otherwise, the argument is
-- optional.
providedRequiredArgumentsRule :: Rule m
providedRequiredArgumentsRule = ArgumentsRule fieldRule directiveRule
  where
    fieldRule (Just objectType) (Full.Field _ fieldName arguments  _ _ location')
        | Just typeField <- Type.lookupTypeField fieldName objectType
        , Out.Field _ _ definitions <- typeField =
            let forEach = go (fieldMessage fieldName) arguments location'
             in lift $ HashMap.foldrWithKey forEach Seq.empty definitions
    fieldRule _ _ = lift mempty
    directiveRule (Full.Directive directiveName arguments location') = do
        available <- asks
            $ HashMap.lookup directiveName . Schema.directives . schema
        case available of
            Just (Schema.Directive _ _ definitions) ->
                let forEach = go (directiveMessage directiveName) arguments location'
                 in lift $ HashMap.foldrWithKey forEach Seq.empty definitions
            _ -> lift mempty
    go makeMessage arguments location' argumentName argumentType errors
        | In.Argument _ type' optionalValue <- argumentType
        , In.isNonNullType type'
        , typeName <- inputTypeName type'
        , isNothing optionalValue
        , isNothingOrNull $ find (lookupArgument argumentName) arguments
            = errors
            |> makeError (makeMessage argumentName typeName) location'
        | otherwise = errors
    makeError errorMessage location' = Error
        { message = errorMessage
        , locations = [location']
        }
    isNothingOrNull (Just (Full.Argument _ (Full.Node Full.Null _) _)) = True
    isNothingOrNull x = isNothing x
    lookupArgument needle (Full.Argument argumentName _ _) =
        needle == argumentName
    fieldMessage fieldName argumentName typeName = concat
        [ "Field \""
        , Text.unpack fieldName
        , "\" argument \""
        , Text.unpack argumentName
        , "\" of type \""
        , Text.unpack typeName
        , "\" is required, but it was not provided."
        ]
    directiveMessage directiveName argumentName typeName = concat
        [ "Directive \"@"
        , Text.unpack directiveName
        , "\" argument \""
        , Text.unpack argumentName
        , "\" of type \""
        , Text.unpack typeName
        , "\" is required, but it was not provided."
        ]

inputTypeName :: In.Type -> Text
inputTypeName (In.ScalarBaseType (Definition.ScalarType typeName _)) = typeName
inputTypeName (In.EnumBaseType (Definition.EnumType typeName _ _)) = typeName
inputTypeName (In.InputObjectBaseType (In.InputObjectType typeName _ _)) =
    typeName
inputTypeName (In.ListBaseType listType) = inputTypeName listType

-- | Input object fields may be required. Much like a field may have required
-- arguments, an input object may have required fields. An input field is
-- required if it has a non‐null type and does not have a default value.
-- Otherwise, the input object field is optional.
providedRequiredInputFieldsRule :: Rule m
providedRequiredInputFieldsRule = ValueRule go constGo
  where
    go (Just valueType) (Full.Node (Full.Object inputFields) location')
        | In.InputObjectBaseType objectType <- valueType
        , In.InputObjectType objectTypeName _ fieldDefinitions <- objectType
            = lift
            $ Seq.fromList
            $ HashMap.elems
            $ flip HashMap.mapMaybeWithKey fieldDefinitions
            $ forEach inputFields objectTypeName location'
    go _ _ = lift mempty
    constGo  _ _ = lift mempty
    forEach inputFields typeName location' definitionName fieldDefinition
        | In.InputField _ inputType optionalValue <- fieldDefinition
        , In.isNonNullType inputType
        , isNothing optionalValue
        , isNothingOrNull $ find (lookupField definitionName) inputFields =
            Just $ makeError definitionName typeName location'
        | otherwise = Nothing
    isNothingOrNull (Just (Full.ObjectField _ (Full.Node Full.Null _) _)) = True
    isNothingOrNull x = isNothing x
    lookupField needle (Full.ObjectField fieldName _ _) = needle == fieldName
    makeError fieldName typeName location' = Error
        { message = errorMessage fieldName typeName
        , locations = [location']
        }
    errorMessage fieldName typeName = concat
        [ "Input field \""
        , Text.unpack fieldName
        , "\" of type \""
        , Text.unpack typeName
        , "\" is required, but it was not provided."
        ]

-- | If multiple field selections with the same response names are encountered
-- during execution, the field and arguments to execute and the resulting value
-- should be unambiguous. Therefore any two field selections which might both be
-- encountered for the same object are only valid if they are equivalent.
--
-- For simple hand‐written GraphQL, this rule is obviously a clear developer
-- error, however nested fragments can make this difficult to detect manually.
overlappingFieldsCanBeMergedRule :: Rule m
overlappingFieldsCanBeMergedRule = OperationDefinitionRule $ \case
    Full.SelectionSet selectionSet _ -> do
        schema' <- asks schema
        go (toList selectionSet)
            $ Type.CompositeObjectType
            $ Schema.query schema'
    Full.OperationDefinition operationType _ _ _ selectionSet _ -> do
        schema' <- asks schema
        let root = go (toList selectionSet) . Type.CompositeObjectType
        case operationType of
            Full.Query -> root $ Schema.query schema'
            Full.Mutation
                | Just objectType <- Schema.mutation schema' -> root objectType
            Full.Subscription
                | Just objectType <- Schema.mutation schema' -> root objectType
            _ -> lift mempty
  where
    go selectionSet selectionType = do
        fieldTuples <- evalStateT (collectFields selectionType selectionSet) HashSet.empty
        fieldsInSetCanMerge fieldTuples
    fieldsInSetCanMerge :: forall m
        . HashMap Full.Name (NonEmpty (Full.Field, Type.CompositeType m))
        -> ReaderT (Validation m) Seq Error
    fieldsInSetCanMerge fieldTuples = do
        validation <- ask
        let (lonely, paired) = flattenPairs fieldTuples
        let reader = flip runReaderT validation
        lift $ foldMap (reader . visitLonelyFields) lonely
            <> foldMap (reader . forEachFieldTuple) paired
    forEachFieldTuple :: forall m
        . (FieldInfo m, FieldInfo m)
        -> ReaderT (Validation m) Seq Error
    forEachFieldTuple (fieldA, fieldB) =
        case (parent fieldA, parent fieldB) of
            (parentA@Type.CompositeObjectType{}, parentB@Type.CompositeObjectType{})
                | parentA /= parentB -> sameResponseShape fieldA fieldB
            _ -> mapReaderT (checkEquality (node fieldA) (node fieldB))
                $ sameResponseShape fieldA fieldB
    checkEquality fieldA fieldB Seq.Empty
        | Full.Field _ fieldNameA _ _ _ _ <- fieldA
        , Full.Field _ fieldNameB _ _ _ _ <- fieldB
        , fieldNameA /= fieldNameB = pure $ makeError fieldA fieldB
        | Full.Field _ fieldNameA argumentsA _ _ locationA <- fieldA
        , Full.Field _ _ argumentsB _ _ locationB <- fieldB
        , argumentsA /= argumentsB =
            let message = concat
                    [ "Fields \""
                    , Text.unpack fieldNameA
                    , "\" conflict because they have different arguments. Use "
                    , "different aliases on the fields to fetch both if this "
                    , "was intentional."
                    ]
             in pure $ Error message [locationB, locationA]
    checkEquality _ _ previousErrors = previousErrors
    visitLonelyFields FieldInfo{..} =
        let Full.Field _ _ _ _ subSelections _ = node
            compositeFieldType = Type.outToComposite type'
         in maybe (lift Seq.empty) (go subSelections) compositeFieldType
    sameResponseShape :: forall m
        . FieldInfo m
        -> FieldInfo m
        -> ReaderT (Validation m) Seq Error
    sameResponseShape fieldA fieldB =
        let Full.Field _ _ _ _ selectionsA _ = node fieldA
            Full.Field _ _ _ _ selectionsB _ = node fieldB
         in case unwrapTypes (type' fieldA) (type' fieldB) of
            Left True -> lift mempty
            Right (compositeA, compositeB) -> do
                validation <- ask
                let collectFields' composite = flip runReaderT validation
                        . flip evalStateT HashSet.empty
                        . collectFields composite
                let collectA = collectFields' compositeA selectionsA
                let collectB = collectFields' compositeB selectionsB
                fieldsInSetCanMerge
                    $ foldl' (HashMap.unionWith (<>)) HashMap.empty
                    $ collectA <> collectB
            _ -> pure $ makeError (node fieldA) (node fieldB)
    makeError fieldA fieldB =
        let Full.Field aliasA fieldNameA _ _ _ locationA = fieldA
            Full.Field _ fieldNameB _ _ _ locationB = fieldB
            message = concat
                [ "Fields \""
                , Text.unpack (fromMaybe fieldNameA aliasA)
                , "\" conflict because \""
                , Text.unpack fieldNameB
                , "\" and \""
                , Text.unpack fieldNameA
                , "\" are different fields. Use different aliases on the fields "
                , "to fetch both if this was intentional."
                ]
             in Error message [locationB, locationA]
    unwrapTypes typeA@Out.ScalarBaseType{} typeB@Out.ScalarBaseType{} =
        Left $ typeA == typeB
    unwrapTypes typeA@Out.EnumBaseType{} typeB@Out.EnumBaseType{} =
        Left $ typeA == typeB
    unwrapTypes (Out.ListType listA) (Out.ListType listB) =
        unwrapTypes listA listB
    unwrapTypes (Out.NonNullListType listA) (Out.NonNullListType listB) =
        unwrapTypes listA listB
    unwrapTypes typeA typeB
        | Out.isNonNullType typeA == Out.isNonNullType typeB
        , Just compositeA <- Type.outToComposite typeA
        , Just compositeB <- Type.outToComposite typeB =
            Right (compositeA, compositeB)
        | otherwise = Left False
    flattenPairs :: forall m
        . HashMap Full.Name (NonEmpty (Full.Field, Type.CompositeType m))
        -> (Seq (FieldInfo m), Seq (FieldInfo m, FieldInfo m))
    flattenPairs xs = HashMap.foldr splitSingleFields (Seq.empty, Seq.empty)
        $ foldr lookupTypeField [] <$> xs
    splitSingleFields :: forall m
        . [FieldInfo m]
        -> (Seq (FieldInfo m), Seq (FieldInfo m, FieldInfo m))
        -> (Seq (FieldInfo m), Seq (FieldInfo m, FieldInfo m))
    splitSingleFields [head'] (fields, pairList) = (fields |> head', pairList)
    splitSingleFields xs (fields, pairList) = (fields, pairs pairList xs)
    lookupTypeField (field, parentType) accumulator =
        let Full.Field _ fieldName _ _ _ _ = field
         in case Type.lookupCompositeField fieldName parentType of
            Nothing -> accumulator
            Just (Out.Field _ typeField _) ->
                FieldInfo field typeField parentType : accumulator
    pairs :: forall m
        . Seq (FieldInfo m, FieldInfo m)
        -> [FieldInfo m]
        -> Seq (FieldInfo m, FieldInfo m)
    pairs accumulator [] = accumulator
    pairs accumulator (fieldA : fields) =
        pair fieldA (pairs accumulator fields) fields
    pair _ accumulator [] = accumulator
    pair field accumulator (fieldA : fields) =
        pair field accumulator fields |> (field, fieldA)
    collectFields objectType = accumulateFields objectType mempty
    accumulateFields = foldM . forEach
    forEach parentType accumulator = \case
        Full.FieldSelection fieldSelection ->
            forField parentType accumulator fieldSelection
        Full.FragmentSpreadSelection fragmentSelection ->
            forSpread accumulator fragmentSelection
        Full.InlineFragmentSelection fragmentSelection ->
            forInline parentType accumulator fragmentSelection
    forField parentType accumulator field@(Full.Field alias fieldName _ _ _ _) =
        let key = fromMaybe fieldName alias
            value = (field, parentType) :| []
         in pure $ HashMap.insertWith (<>) key value accumulator
    forSpread accumulator (Full.FragmentSpread fragmentName _ _) = do
        inVisitetFragments <- gets $ HashSet.member fragmentName
        if inVisitetFragments
            then pure accumulator
            else collectFromSpread fragmentName accumulator
    forInline parentType accumulator = \case
        Full.InlineFragment maybeType _ selections _
            | Just typeCondition <- maybeType ->
                collectFromFragment typeCondition selections accumulator
            | otherwise -> accumulateFields parentType accumulator $ toList selections
    collectFromFragment typeCondition selectionSet' accumulator = do
        types' <- lift $ asks $ Schema.types . schema
        case Type.lookupTypeCondition typeCondition types' of
            Nothing -> pure accumulator
            Just compositeType ->
                accumulateFields compositeType accumulator $ toList selectionSet'
    collectFromSpread fragmentName accumulator = do
        modify $ HashSet.insert fragmentName
        ast' <- lift $ asks ast
        case findFragmentDefinition fragmentName ast' of
            Nothing -> pure accumulator
            Just (Full.FragmentDefinition _ typeCondition _ selectionSet' _) ->
                collectFromFragment typeCondition selectionSet' accumulator

data FieldInfo m = FieldInfo
    { node :: Full.Field
    , type' :: Out.Type m
    , parent :: Type.CompositeType m
    }

-- | Fragments are declared on a type and will only apply when the runtime
-- object type matches the type condition. They also are spread within the
-- context of a parent type. A fragment spread is only valid if its type
-- condition could ever apply within the parent type.
possibleFragmentSpreadsRule :: forall m. Rule m
possibleFragmentSpreadsRule = SelectionRule go
  where
    go (Just parentType) (Full.InlineFragmentSelection fragmentSelection)
        | Full.InlineFragment maybeType _ _ location' <- fragmentSelection
        , Just typeCondition <- maybeType = do
            (fragmentTypeName, parentTypeName) <-
                compareTypes typeCondition parentType
            pure $ Error
                { message = concat
                    [ "Fragment cannot be spread here as objects of type \""
                    , Text.unpack parentTypeName
                    , "\" can never be of type \""
                    , Text.unpack fragmentTypeName
                    , "\"."
                    ]
                , locations = [location']
                }
    go (Just parentType) (Full.FragmentSpreadSelection fragmentSelection)
        | Full.FragmentSpread fragmentName _ location' <- fragmentSelection = do
            typeCondition <- findSpreadTarget fragmentName
            (fragmentTypeName, parentTypeName) <-
                compareTypes typeCondition parentType
            pure $ Error
                { message = concat
                    [ "Fragment \""
                    , Text.unpack fragmentName
                    , "\" cannot be spread here as objects of type \""
                    , Text.unpack parentTypeName
                    , "\" can never be of type \""
                    , Text.unpack fragmentTypeName
                    , "\"."
                    ]
                , locations = [location']
                }
    go _ _ = lift mempty
    compareTypes typeCondition parentType = do
        types' <- asks $ Schema.types . schema
        fragmentType <- lift
            $ maybeToSeq
            $ Type.lookupTypeCondition typeCondition types'
        parentComposite <- lift
            $ maybeToSeq
            $ Type.outToComposite parentType
        possibleFragments <- getPossibleTypes fragmentType
        possibleParents <- getPossibleTypes parentComposite
        let fragmentTypeName = compositeTypeName fragmentType
        let parentTypeName = compositeTypeName parentComposite
        if HashSet.null $ HashSet.intersection possibleFragments possibleParents
            then pure (fragmentTypeName, parentTypeName)
            else lift mempty
    getPossibleTypeList (Type.CompositeObjectType objectType) =
        pure [Schema.ObjectType objectType]
    getPossibleTypeList (Type.CompositeUnionType unionType) =
        let Out.UnionType _ _ members = unionType
         in pure $ Schema.ObjectType <$> members
    getPossibleTypeList (Type.CompositeInterfaceType interfaceType) =
        let Out.InterfaceType typeName _ _ _ = interfaceType
         in HashMap.lookupDefault [] typeName
        <$> asks (Schema.implementations . schema)
    getPossibleTypes compositeType
        = foldr (HashSet.insert . internalTypeName) HashSet.empty
        <$> getPossibleTypeList compositeType

internalTypeName :: forall m. Schema.Type m -> Full.Name
internalTypeName (Schema.ScalarType (Definition.ScalarType typeName _)) =
    typeName
internalTypeName (Schema.EnumType (Definition.EnumType typeName _ _)) = typeName
internalTypeName (Schema.ObjectType (Out.ObjectType typeName _ _ _)) = typeName
internalTypeName (Schema.InputObjectType (In.InputObjectType typeName _ _)) =
    typeName
internalTypeName (Schema.InterfaceType (Out.InterfaceType typeName _ _ _)) =
    typeName
internalTypeName (Schema.UnionType (Out.UnionType typeName _ _)) = typeName

findSpreadTarget :: Full.Name -> ReaderT (Validation m1) Seq Full.TypeCondition
findSpreadTarget fragmentName = do
    ast' <- asks ast
    let target = find (isSpreadTarget fragmentName) ast'
    lift $ maybeToSeq $ target >>= extractTypeCondition
  where
    extractTypeCondition (viewFragment -> Just fragmentDefinition) =
        let Full.FragmentDefinition _ typeCondition _ _ _ = fragmentDefinition
            in Just typeCondition
    extractTypeCondition _ = Nothing

visitFragmentDefinition :: forall m
    . Text
    -> ValidationState m (Maybe Full.FragmentDefinition)
visitFragmentDefinition fragmentName = do
    definitions <- lift $ asks ast
    visited <- gets (HashSet.member fragmentName)
    modify (HashSet.insert fragmentName)
    case find (isSpreadTarget fragmentName) definitions of
        Just (viewFragment -> Just fragmentDefinition)
            | not visited -> pure $ Just fragmentDefinition
        _ -> pure Nothing

-- | Variable usages must be compatible with the arguments they are passed to.
--
-- Validation failures occur when variables are used in the context of types
-- that are complete mismatches, or if a nullable type in a variable is passed
-- to a non‐null argument type.
variablesInAllowedPositionRule :: forall m. Rule m
variablesInAllowedPositionRule = OperationDefinitionRule $ \case
    Full.OperationDefinition operationType _ variables _ selectionSet _ -> do
        schema' <- asks schema
        let root = go variables (toList selectionSet) . Type.CompositeObjectType
        case operationType of
            Full.Query -> root $ Schema.query schema'
            Full.Mutation
                | Just objectType <- Schema.mutation schema' -> root objectType
            Full.Subscription
                | Just objectType <- Schema.mutation schema' -> root objectType
            _ -> lift mempty
    _ -> lift mempty
  where
    go variables selections selectionType = mapReaderT (foldr (<>) Seq.empty)
        $ flip evalStateT HashSet.empty
        $ visitSelectionSet variables selectionType
        $ toList selections
    visitSelectionSet :: Foldable t
        => [Full.VariableDefinition]
        -> Type.CompositeType m
        -> t Full.Selection
        -> ValidationState m (Seq Error)
    visitSelectionSet variables selectionType selections =
        foldM (evaluateSelection variables selectionType) mempty selections
    evaluateFieldSelection variables selections accumulator = \case
        Just newParentType -> do
            let folder = evaluateSelection variables newParentType
            selectionErrors <- foldM folder accumulator selections
            pure $ accumulator <> selectionErrors
        Nothing -> pure accumulator
    evaluateSelection :: [Full.VariableDefinition]
        -> Type.CompositeType m
        -> Seq Error
        -> Full.Selection
        -> ValidationState m (Seq Error)
    evaluateSelection variables selectionType accumulator selection
        | Full.FragmentSpreadSelection spread <- selection
        , Full.FragmentSpread fragmentName _ _ <- spread = do
            types' <- lift $ asks $ Schema.types . schema
            nonVisitedFragmentDefinition <- visitFragmentDefinition fragmentName
            case nonVisitedFragmentDefinition of
                Just fragmentDefinition
                    | Full.FragmentDefinition _ typeCondition _ _ _ <- fragmentDefinition
                    , Just spreadType <- Type.lookupTypeCondition typeCondition types' -> do
                        spreadErrors <- spreadVariables variables spread
                        selectionErrors <- diveIntoSpread variables spreadType fragmentDefinition
                        pure $ accumulator <> spreadErrors <> selectionErrors
                _ -> lift $ lift mempty
        | Full.FieldSelection fieldSelection <- selection
        , Full.Field _ fieldName _ _ subselections _ <- fieldSelection =
            case Type.lookupCompositeField fieldName selectionType of
                Just (Out.Field _ typeField argumentTypes) -> do
                    fieldErrors <- fieldVariables variables argumentTypes fieldSelection
                    selectionErrors <- evaluateFieldSelection variables subselections accumulator
                            $ Type.outToComposite typeField
                    pure $ selectionErrors <> fieldErrors
                Nothing -> pure accumulator
        | Full.InlineFragmentSelection inlineSelection <- selection
        , Full.InlineFragment typeCondition _ subselections _ <- inlineSelection = do
            types' <- lift $ asks $ Schema.types . schema
            let inlineType = fromMaybe selectionType
                    $ typeCondition >>= flip Type.lookupTypeCondition types'
            fragmentErrors <- inlineVariables variables inlineSelection
            let folder = evaluateSelection variables inlineType
            selectionErrors <- foldM folder accumulator subselections
            pure $ accumulator <> fragmentErrors <> selectionErrors
    inlineVariables variables inline
        | Full.InlineFragment _ directives' _ _ <- inline =
            mapDirectives variables directives'
    fieldVariables :: [Full.VariableDefinition]
        -> In.Arguments
        -> Full.Field
        -> ValidationState m (Seq Error)
    fieldVariables variables argumentTypes fieldSelection = do
        let Full.Field _ _ arguments directives' _ _ = fieldSelection
        argumentErrors <- mapArguments variables argumentTypes arguments
        directiveErrors <- mapDirectives variables directives'
        pure $ argumentErrors <> directiveErrors
    spreadVariables variables (Full.FragmentSpread _ directives' _) =
        mapDirectives variables directives'
    diveIntoSpread variables fieldType fragmentDefinition = do
        let Full.FragmentDefinition _ _ directives' selections _ =
                fragmentDefinition
        selectionErrors <- visitSelectionSet variables fieldType selections
        directiveErrors <- mapDirectives variables directives'
        pure $ selectionErrors <> directiveErrors
    findDirectiveVariables variables directive = do
        let Full.Directive directiveName arguments _ = directive
        directiveDefinitions <- lift $ asks $ Schema.directives . schema
        case HashMap.lookup directiveName directiveDefinitions of
            Just (Schema.Directive _ _ directiveArguments) ->
                mapArguments variables directiveArguments arguments
            Nothing -> pure mempty
    mapArguments variables argumentTypes = fmap fold
        . traverse (findArgumentVariables variables argumentTypes)
    mapDirectives variables = fmap fold
        <$> traverse (findDirectiveVariables variables)
    lookupInputObject variables objectFieldValue locationInfo
        | Full.Node{ node = Full.Object objectFields } <- objectFieldValue
        , Just (expectedType, _) <- locationInfo
        , In.InputObjectBaseType inputObjectType <- expectedType
        , In.InputObjectType _ _ fieldTypes' <- inputObjectType =
            fold <$> traverse (traverseObjectField variables fieldTypes') objectFields
        | otherwise = pure mempty
    maybeUsageAllowed variableName variables locationInfo
        | Just (locationType, locationValue) <- locationInfo
        , findVariableDefinition' <- findVariableDefinition variableName
        , Just variableDefinition <- find findVariableDefinition' variables
            = maybeToSeq
            <$> isVariableUsageAllowed locationType locationValue variableDefinition
        | otherwise = pure mempty
    findArgumentVariables :: [Full.VariableDefinition]
        -> HashMap Full.Name In.Argument
        -> Full.Argument
        -> ValidationState m (Seq Error)
    findArgumentVariables variables argumentTypes argument
        | Full.Argument argumentName argumentValue _ <- argument
        , Full.Node{ node = Full.Variable variableName } <- argumentValue
            = maybeUsageAllowed variableName variables
            $ locationPair extractArgument argumentTypes argumentName
        | Full.Argument argumentName argumentValue _ <- argument
            = lookupInputObject variables argumentValue
            $ locationPair extractArgument argumentTypes argumentName
    extractField (In.InputField _ locationType locationValue) =
        (locationType, locationValue)
    extractArgument (In.Argument _ locationType locationValue) =
        (locationType, locationValue)
    locationPair extract fieldTypes name =
        extract <$> HashMap.lookup name fieldTypes
    traverseObjectField variables fieldTypes Full.ObjectField{..}
        | Full.Node{ node = Full.Variable variableName } <- value
            = maybeUsageAllowed variableName variables
            $ locationPair extractField fieldTypes name
        | otherwise = lookupInputObject variables value
            $  locationPair extractField fieldTypes name
    findVariableDefinition variableName variableDefinition =
        let Full.VariableDefinition variableName' _ _ _ = variableDefinition
         in variableName == variableName'
    isVariableUsageAllowed locationType locationDefaultValue variableDefinition
        | Full.VariableDefinition _ variableType _ _ <- variableDefinition
        , Full.TypeNonNull _ <- variableType =
            typesCompatibleOrError variableDefinition locationType
        | Just nullableLocationType <- unwrapInType locationType
        , Full.VariableDefinition _ variableType variableDefaultValue _ <-
            variableDefinition
        , hasNonNullVariableDefaultValue' <-
            hasNonNullVariableDefaultValue variableDefaultValue
        , hasLocationDefaultValue <- isJust locationDefaultValue =
            if (hasNonNullVariableDefaultValue' || hasLocationDefaultValue)
                && areTypesCompatible variableType nullableLocationType
                then pure Nothing
                else pure $ makeError variableDefinition locationType
        | otherwise = typesCompatibleOrError variableDefinition locationType
    typesCompatibleOrError variableDefinition locationType
        | Full.VariableDefinition _ variableType _ _ <- variableDefinition
        , areTypesCompatible variableType locationType = pure Nothing
        | otherwise = pure $ makeError variableDefinition locationType
    areTypesCompatible nonNullType (unwrapInType -> Just nullableLocationType)
        | Full.TypeNonNull (Full.NonNullTypeNamed namedType) <- nonNullType =
            areTypesCompatible (Full.TypeNamed namedType) nullableLocationType
        | Full.TypeNonNull (Full.NonNullTypeList namedList) <- nonNullType =
            areTypesCompatible (Full.TypeList namedList) nullableLocationType
    areTypesCompatible _ (In.isNonNullType -> True) = False
    areTypesCompatible (Full.TypeNonNull nonNullType) locationType
        | Full.NonNullTypeNamed namedType <- nonNullType =
            areTypesCompatible (Full.TypeNamed namedType) locationType
        | Full.NonNullTypeList namedType <- nonNullType =
            areTypesCompatible (Full.TypeList namedType) locationType
    areTypesCompatible variableType locationType
        | Full.TypeList itemVariableType <- variableType
        , In.ListType itemLocationType <- locationType =
            areTypesCompatible itemVariableType itemLocationType
        | areIdentical variableType locationType = True
        | otherwise = False
    areIdentical (Full.TypeList typeList) (In.ListType itemLocationType) =
        areIdentical typeList itemLocationType
    areIdentical (Full.TypeNonNull nonNullType) locationType
        | Full.NonNullTypeList nonNullList <- nonNullType
        , In.NonNullListType  itemLocationType <- locationType =
            areIdentical nonNullList itemLocationType
        | Full.NonNullTypeNamed _ <- nonNullType
        , In.ListBaseType _ <- locationType = False
        | Full.NonNullTypeNamed nonNullList <- nonNullType
        , In.isNonNullType locationType =
            nonNullList == inputTypeName locationType
    areIdentical (Full.TypeNamed _) (In.ListBaseType _) = False
    areIdentical (Full.TypeNamed typeNamed) locationType
        | not $ In.isNonNullType locationType =
            typeNamed == inputTypeName locationType
    areIdentical _ _ = False
    hasNonNullVariableDefaultValue (Just (Full.Node Full.ConstNull _)) = False
    hasNonNullVariableDefaultValue Nothing = False
    hasNonNullVariableDefaultValue _ = True
    unwrapInType (In.NonNullScalarType nonNullType) =
        Just $ In.NamedScalarType nonNullType
    unwrapInType (In.NonNullEnumType nonNullType) =
        Just $ In.NamedEnumType nonNullType
    unwrapInType (In.NonNullInputObjectType nonNullType) =
        Just $ In.NamedInputObjectType nonNullType
    unwrapInType (In.NonNullListType nonNullType) =
        Just $ In.ListType nonNullType
    unwrapInType _ = Nothing
    makeError variableDefinition expectedType =
        let Full.VariableDefinition variableName variableType _ location' =
                variableDefinition
         in Just $ Error
            { message = concat
                [ "Variable \"$"
                , Text.unpack variableName
                , "\" of type \""
                , show variableType
                , "\" used in position expecting type \""
                , show expectedType
                , "\"."
                ]
            , locations = [location']
            }

-- | Literal values must be compatible with the type expected in the position
-- they are found as per the coercion rules.
--
-- The type expected in a position include the type defined by the argument a
-- value is provided for, the type defined by an input object field a value is
-- provided for, and the type of a variable definition a default value is
-- provided for.
valuesOfCorrectTypeRule :: forall m. Rule m
valuesOfCorrectTypeRule = ValueRule go constGo
  where
    go (Just inputType) value
        | Just constValue <- toConstNode value =
            lift $ check inputType constValue
    go _ _ = lift mempty -- This rule checks only literals.
    toConstNode Full.Node{..} = flip Full.Node location <$> toConst node
    toConst (Full.Variable _) = Nothing
    toConst (Full.Int integer) = Just $ Full.ConstInt integer
    toConst (Full.Float double) = Just $ Full.ConstFloat double
    toConst (Full.String string) = Just $ Full.ConstString string
    toConst (Full.Boolean boolean) = Just $ Full.ConstBoolean boolean
    toConst Full.Null = Just Full.ConstNull
    toConst (Full.Enum enum) = Just $ Full.ConstEnum enum
    toConst (Full.List values) =
        Just $ Full.ConstList $ catMaybes $ toConstNode <$> values
    toConst (Full.Object fields) = Just $ Full.ConstObject
        $ catMaybes $ constObjectField <$> fields
    constObjectField Full.ObjectField{..}
        | Just constValue <- toConstNode value =
            Just $ Full.ObjectField name constValue location
        | otherwise = Nothing
    constGo Nothing = const $ lift mempty
    constGo (Just inputType) = lift . check inputType
    check :: In.Type -> Full.Node Full.ConstValue -> Seq Error
    check _ Full.Node{ node = Full.ConstNull } =
        mempty -- Ignore, required fields are checked elsewhere.
    check (In.ScalarBaseType scalarType) Full.Node{ node }
        | Definition.ScalarType "Int" _ <- scalarType
        , Full.ConstInt _ <- node = mempty
        | Definition.ScalarType "Boolean" _ <- scalarType
        , Full.ConstBoolean _ <- node = mempty
        | Definition.ScalarType "String" _ <- scalarType
        , Full.ConstString _ <- node = mempty
        | Definition.ScalarType "ID" _ <- scalarType
        , Full.ConstString _ <- node = mempty
        | Definition.ScalarType "ID" _ <- scalarType
        , Full.ConstInt _ <- node = mempty
        | Definition.ScalarType "Float" _ <- scalarType
        , Full.ConstFloat _ <- node = mempty
        | Definition.ScalarType "Float" _ <- scalarType
        , Full.ConstInt _ <- node = mempty
    check (In.EnumBaseType enumType) Full.Node{ node }
        | Definition.EnumType _ _ members <- enumType
        , Full.ConstEnum memberValue <- node
        , HashMap.member memberValue members = mempty
    check (In.InputObjectBaseType objectType) Full.Node{ node }
        | In.InputObjectType _ _ typeFields <- objectType
        , Full.ConstObject valueFields <- node =
            foldMap (checkObjectField typeFields) valueFields
    check (In.ListBaseType listType) constValue@Full.Node{ .. }
        -- Skip, lists are checked recursively by the validation traverser.
        | Full.ConstList _ <- node = mempty
        | otherwise = check listType constValue
    check inputType Full.Node{ .. } = pure $ Error
        { message = concat
            [ "Value "
            , show node, " cannot be coerced to type \""
            , show inputType
            , "\"."
            ]
        , locations = [location]
        }
    checkObjectField typeFields Full.ObjectField{..}
        | Just typeField <- HashMap.lookup name typeFields
        , In.InputField _ fieldType _ <- typeField =
            check fieldType value
    checkObjectField _ _ = mempty