{- 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 :: [Rule m]
specifiedRules =
    -- Documents.
    [ Rule m
forall (m :: * -> *). Rule m
executableDefinitionsRule
    -- Operations.
    , Rule m
forall (m :: * -> *). Rule m
singleFieldSubscriptionsRule
    , Rule m
forall (m :: * -> *). Rule m
loneAnonymousOperationRule
    , Rule m
forall (m :: * -> *). Rule m
uniqueOperationNamesRule
    -- Fields
    , Rule m
forall (m :: * -> *). Rule m
fieldsOnCorrectTypeRule
    , Rule m
forall (m :: * -> *). Rule m
scalarLeafsRule
    , Rule m
forall (m :: * -> *). Rule m
overlappingFieldsCanBeMergedRule
    -- Arguments.
    , Rule m
forall (m :: * -> *). Rule m
knownArgumentNamesRule
    , Rule m
forall (m :: * -> *). Rule m
uniqueArgumentNamesRule
    , Rule m
forall (m :: * -> *). Rule m
providedRequiredArgumentsRule
    -- Fragments.
    , Rule m
forall (m :: * -> *). Rule m
uniqueFragmentNamesRule
    , Rule m
forall (m :: * -> *). Rule m
fragmentSpreadTypeExistenceRule
    , Rule m
forall (m :: * -> *). Rule m
fragmentsOnCompositeTypesRule
    , Rule m
forall (m :: * -> *). Rule m
noUnusedFragmentsRule
    , Rule m
forall (m :: * -> *). Rule m
fragmentSpreadTargetDefinedRule
    , Rule m
forall (m :: * -> *). Rule m
noFragmentCyclesRule
    , Rule m
forall (m :: * -> *). Rule m
possibleFragmentSpreadsRule
    -- Values
    , Rule m
forall (m :: * -> *). Rule m
valuesOfCorrectTypeRule
    , Rule m
forall (m :: * -> *). Rule m
knownInputFieldNamesRule
    , Rule m
forall (m :: * -> *). Rule m
uniqueInputFieldNamesRule
    , Rule m
forall (m :: * -> *). Rule m
providedRequiredInputFieldsRule
    -- Directives.
    , Rule m
forall (m :: * -> *). Rule m
knownDirectiveNamesRule
    , Rule m
forall (m :: * -> *). Rule m
directivesInValidLocationsRule
    , Rule m
forall (m :: * -> *). Rule m
uniqueDirectiveNamesRule
    -- Variables.
    , Rule m
forall (m :: * -> *). Rule m
uniqueVariableNamesRule
    , Rule m
forall (m :: * -> *). Rule m
variablesAreInputTypesRule
    , Rule m
forall (m :: * -> *). Rule m
noUndefinedVariablesRule
    , Rule m
forall (m :: * -> *). Rule m
noUnusedVariablesRule
    , Rule m
forall (m :: * -> *). Rule m
variablesInAllowedPositionRule
    ]

-- | Definition must be OperationDefinition or FragmentDefinition.
executableDefinitionsRule :: forall m. Rule m
executableDefinitionsRule :: Rule m
executableDefinitionsRule = (Definition -> RuleT m) -> Rule m
forall (m :: * -> *). (Definition -> RuleT m) -> Rule m
DefinitionRule ((Definition -> RuleT m) -> Rule m)
-> (Definition -> RuleT m) -> Rule m
forall a b. (a -> b) -> a -> b
$ \case
    Full.ExecutableDefinition ExecutableDefinition
_ -> Seq Error -> RuleT m
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Seq Error
forall a. Monoid a => a
mempty
    Full.TypeSystemDefinition TypeSystemDefinition
_ Location
location' -> Error -> RuleT m
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Error -> RuleT m) -> Error -> RuleT m
forall a b. (a -> b) -> a -> b
$ Location -> Error
error' Location
location'
    Full.TypeSystemExtension TypeSystemExtension
_ Location
location' -> Error -> RuleT m
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Error -> RuleT m) -> Error -> RuleT m
forall a b. (a -> b) -> a -> b
$ Location -> Error
error' Location
location'
  where
    error' :: Location -> Error
error' Location
location' = Error :: String -> [Location] -> Error
Error
        { message :: String
message =
            String
"Definition must be OperationDefinition or FragmentDefinition."
        , locations :: [Location]
locations = [Location
location']
        }

-- | Subscription operations must have exactly one root field.
singleFieldSubscriptionsRule :: forall m. Rule m
singleFieldSubscriptionsRule :: Rule m
singleFieldSubscriptionsRule = (OperationDefinition -> RuleT m) -> Rule m
forall (m :: * -> *). (OperationDefinition -> RuleT m) -> Rule m
OperationDefinitionRule ((OperationDefinition -> RuleT m) -> Rule m)
-> (OperationDefinition -> RuleT m) -> Rule m
forall a b. (a -> b) -> a -> b
$ \case
    Full.OperationDefinition OperationType
Full.Subscription Maybe Name
name' [VariableDefinition]
_ [Directive]
_ SelectionSet
rootFields Location
location' -> do
        HashSet Name
groupedFieldSet <- StateT (HashSet Name) (ReaderT (Validation m) Seq) (HashSet Name)
-> HashSet Name -> ReaderT (Validation m) Seq (HashSet Name)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (SelectionSet
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (HashSet Name)
forall (m :: * -> *).
SelectionSet
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (HashSet Name)
collectFields SelectionSet
rootFields) HashSet Name
forall a. HashSet a
HashSet.empty
        case HashSet Name -> Int
forall a. HashSet a -> Int
HashSet.size HashSet Name
groupedFieldSet of
            Int
1 -> Seq Error -> RuleT m
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Seq Error
forall a. Monoid a => a
mempty
            Int
_
                | Just Name
name <- Maybe Name
name' -> Error -> RuleT m
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Error -> RuleT m) -> Error -> RuleT m
forall a b. (a -> b) -> a -> b
$ Error :: String -> [Location] -> Error
Error
                    { message :: String
message = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                        [ String
"Subscription \""
                        , Name -> String
Text.unpack Name
name
                        , String
"\" must select only one top level field."
                        ]
                    , locations :: [Location]
locations = [Location
location']
                    }
                | Bool
otherwise -> Error -> RuleT m
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Error -> RuleT m) -> Error -> RuleT m
forall a b. (a -> b) -> a -> b
$ Error :: String -> [Location] -> Error
Error
                    { message :: String
message = String
errorMessage
                    , locations :: [Location]
locations = [Location
location']
                    }
    OperationDefinition
_ -> Seq Error -> RuleT m
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Seq Error
forall a. Monoid a => a
mempty
  where
    errorMessage :: String
errorMessage =
        String
"Anonymous Subscription must select only one top level field."
    collectFields :: SelectionSet
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (HashSet Name)
collectFields = (HashSet Name
 -> Selection
 -> StateT
      (HashSet Name) (ReaderT (Validation m) Seq) (HashSet Name))
-> HashSet Name
-> SelectionSet
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (HashSet Name)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM HashSet Name
-> Selection
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (HashSet Name)
forEach HashSet Name
forall a. HashSet a
HashSet.empty
    forEach :: HashSet Name
-> Selection
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (HashSet Name)
forEach HashSet Name
accumulator = \case
        Full.FieldSelection Field
fieldSelection -> HashSet Name
-> Field
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (HashSet Name)
forall (f :: * -> *).
Applicative f =>
HashSet Name -> Field -> f (HashSet Name)
forField HashSet Name
accumulator Field
fieldSelection
        Full.FragmentSpreadSelection FragmentSpread
fragmentSelection ->
            HashSet Name
-> FragmentSpread
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (HashSet Name)
forSpread HashSet Name
accumulator FragmentSpread
fragmentSelection
        Full.InlineFragmentSelection InlineFragment
fragmentSelection ->
            HashSet Name
-> InlineFragment
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (HashSet Name)
forInline HashSet Name
accumulator InlineFragment
fragmentSelection
    forField :: HashSet Name -> Field -> f (HashSet Name)
forField HashSet Name
accumulator (Full.Field Maybe Name
alias Name
name [Argument]
_ [Directive]
directives' SelectionSetOpt
_ Location
_)
        | (Directive -> Bool) -> [Directive] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Directive -> Bool
skip [Directive]
directives' = HashSet Name -> f (HashSet Name)
forall (f :: * -> *) a. Applicative f => a -> f a
pure HashSet Name
accumulator
        | Just Name
aliasedName <- Maybe Name
alias = HashSet Name -> f (HashSet Name)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
            (HashSet Name -> f (HashSet Name))
-> HashSet Name -> f (HashSet Name)
forall a b. (a -> b) -> a -> b
$ Name -> HashSet Name -> HashSet Name
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HashSet.insert Name
aliasedName HashSet Name
accumulator
        | Bool
otherwise = HashSet Name -> f (HashSet Name)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashSet Name -> f (HashSet Name))
-> HashSet Name -> f (HashSet Name)
forall a b. (a -> b) -> a -> b
$ Name -> HashSet Name -> HashSet Name
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HashSet.insert Name
name HashSet Name
accumulator
    forSpread :: HashSet Name
-> FragmentSpread
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (HashSet Name)
forSpread HashSet Name
accumulator (Full.FragmentSpread Name
fragmentName [Directive]
directives' Location
_)
        | (Directive -> Bool) -> [Directive] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Directive -> Bool
skip [Directive]
directives' = HashSet Name
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (HashSet Name)
forall (f :: * -> *) a. Applicative f => a -> f a
pure HashSet Name
accumulator
        | Bool
otherwise = do
            Bool
inVisitetFragments <- (HashSet Name -> Bool)
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) Bool
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets ((HashSet Name -> Bool)
 -> StateT (HashSet Name) (ReaderT (Validation m) Seq) Bool)
-> (HashSet Name -> Bool)
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) Bool
forall a b. (a -> b) -> a -> b
$ Name -> HashSet Name -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
HashSet.member Name
fragmentName
            if Bool
inVisitetFragments
               then HashSet Name
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (HashSet Name)
forall (f :: * -> *) a. Applicative f => a -> f a
pure HashSet Name
accumulator
               else Name
-> HashSet Name
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (HashSet Name)
collectFromSpread Name
fragmentName HashSet Name
accumulator
    forInline :: HashSet Name
-> InlineFragment
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (HashSet Name)
forInline HashSet Name
accumulator (Full.InlineFragment Maybe Name
maybeType [Directive]
directives' SelectionSet
selections Location
_)
        | (Directive -> Bool) -> [Directive] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Directive -> Bool
skip [Directive]
directives' = HashSet Name
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (HashSet Name)
forall (f :: * -> *) a. Applicative f => a -> f a
pure HashSet Name
accumulator
        | Just Name
typeCondition <- Maybe Name
maybeType =
            Name
-> SelectionSet
-> HashSet Name
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (HashSet Name)
collectFromFragment Name
typeCondition SelectionSet
selections HashSet Name
accumulator
        | Bool
otherwise = HashSet Name -> HashSet Name -> HashSet Name
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
HashSet.union HashSet Name
accumulator
            (HashSet Name -> HashSet Name)
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (HashSet Name)
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (HashSet Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SelectionSet
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (HashSet Name)
collectFields SelectionSet
selections
    skip :: Directive -> Bool
skip (Full.Directive Name
"skip" [Full.Argument Name
"if" (Full.Node Value
argumentValue Location
_) Location
_] Location
_) =
        Bool -> Value
Full.Boolean Bool
True Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
argumentValue
    skip (Full.Directive Name
"include" [Full.Argument Name
"if" (Full.Node Value
argumentValue Location
_) Location
_] Location
_) =
        Bool -> Value
Full.Boolean Bool
False Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
argumentValue
    skip Directive
_ = Bool
False
    collectFromFragment :: Name
-> SelectionSet
-> HashSet Name
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (HashSet Name)
collectFromFragment Name
typeCondition SelectionSet
selectionSet HashSet Name
accumulator = do
        HashMap Name (Type m)
types' <- ReaderT (Validation m) Seq (HashMap Name (Type m))
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (HashMap Name (Type m))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT (Validation m) Seq (HashMap Name (Type m))
 -> StateT
      (HashSet Name)
      (ReaderT (Validation m) Seq)
      (HashMap Name (Type m)))
-> ReaderT (Validation m) Seq (HashMap Name (Type m))
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (HashMap Name (Type m))
forall a b. (a -> b) -> a -> b
$ (Validation m -> HashMap Name (Type m))
-> ReaderT (Validation m) Seq (HashMap Name (Type m))
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks ((Validation m -> HashMap Name (Type m))
 -> ReaderT (Validation m) Seq (HashMap Name (Type m)))
-> (Validation m -> HashMap Name (Type m))
-> ReaderT (Validation m) Seq (HashMap Name (Type m))
forall a b. (a -> b) -> a -> b
$ Schema m -> HashMap Name (Type m)
forall (m :: * -> *). Schema m -> HashMap Name (Type m)
Schema.types (Schema m -> HashMap Name (Type m))
-> (Validation m -> Schema m)
-> Validation m
-> HashMap Name (Type m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validation m -> Schema m
forall (m :: * -> *). Validation m -> Schema m
schema
        Schema m
schema' <- ReaderT (Validation m) Seq (Schema m)
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Schema m)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT (Validation m) Seq (Schema m)
 -> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Schema m))
-> ReaderT (Validation m) Seq (Schema m)
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Schema m)
forall a b. (a -> b) -> a -> b
$ (Validation m -> Schema m) -> ReaderT (Validation m) Seq (Schema m)
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Validation m -> Schema m
forall (m :: * -> *). Validation m -> Schema m
schema
        case Name -> HashMap Name (Type m) -> Maybe (CompositeType m)
forall (m :: * -> *).
Name -> HashMap Name (Type m) -> Maybe (CompositeType m)
Type.lookupTypeCondition Name
typeCondition HashMap Name (Type m)
types' of
            Maybe (CompositeType m)
Nothing -> HashSet Name
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (HashSet Name)
forall (f :: * -> *) a. Applicative f => a -> f a
pure HashSet Name
accumulator
            Just CompositeType m
compositeType
                | Just ObjectType m
objectType <- Schema m -> Maybe (ObjectType m)
forall (m :: * -> *). Schema m -> Maybe (ObjectType m)
Schema.subscription Schema m
schema'
                , Bool
True <- CompositeType m -> ObjectType m -> Bool
forall (m :: * -> *). CompositeType m -> ObjectType m -> Bool
Type.doesFragmentTypeApply CompositeType m
compositeType ObjectType m
objectType ->
                    HashSet Name -> HashSet Name -> HashSet Name
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
HashSet.union HashSet Name
accumulator (HashSet Name -> HashSet Name)
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (HashSet Name)
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (HashSet Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SelectionSet
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (HashSet Name)
collectFields SelectionSet
selectionSet
                | Bool
otherwise -> HashSet Name
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (HashSet Name)
forall (f :: * -> *) a. Applicative f => a -> f a
pure HashSet Name
accumulator
    collectFromSpread :: Name
-> HashSet Name
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (HashSet Name)
collectFromSpread Name
fragmentName HashSet Name
accumulator = do
        (HashSet Name -> HashSet Name)
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify ((HashSet Name -> HashSet Name)
 -> StateT (HashSet Name) (ReaderT (Validation m) Seq) ())
-> (HashSet Name -> HashSet Name)
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) ()
forall a b. (a -> b) -> a -> b
$ Name -> HashSet Name -> HashSet Name
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HashSet.insert Name
fragmentName
        Document
ast' <- ReaderT (Validation m) Seq Document
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) Document
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT (Validation m) Seq Document
 -> StateT (HashSet Name) (ReaderT (Validation m) Seq) Document)
-> ReaderT (Validation m) Seq Document
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) Document
forall a b. (a -> b) -> a -> b
$ (Validation m -> Document) -> ReaderT (Validation m) Seq Document
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Validation m -> Document
forall (m :: * -> *). Validation m -> Document
ast
        case Name -> Document -> Maybe FragmentDefinition
findFragmentDefinition Name
fragmentName Document
ast' of
            Maybe FragmentDefinition
Nothing -> HashSet Name
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (HashSet Name)
forall (f :: * -> *) a. Applicative f => a -> f a
pure HashSet Name
accumulator
            Just (Full.FragmentDefinition Name
_ Name
typeCondition [Directive]
_ SelectionSet
selectionSet Location
_) ->
                Name
-> SelectionSet
-> HashSet Name
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (HashSet Name)
collectFromFragment Name
typeCondition SelectionSet
selectionSet HashSet Name
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 :: Rule m
loneAnonymousOperationRule = (OperationDefinition -> RuleT m) -> Rule m
forall (m :: * -> *). (OperationDefinition -> RuleT m) -> Rule m
OperationDefinitionRule ((OperationDefinition -> RuleT m) -> Rule m)
-> (OperationDefinition -> RuleT m) -> Rule m
forall a b. (a -> b) -> a -> b
$ \case
      Full.SelectionSet SelectionSet
_ Location
thisLocation -> Location -> RuleT m
forall (m :: * -> *). Location -> ReaderT (Validation m) Seq Error
check Location
thisLocation
      Full.OperationDefinition OperationType
_ Maybe Name
Nothing [VariableDefinition]
_ [Directive]
_ SelectionSet
_ Location
thisLocation ->
          Location -> RuleT m
forall (m :: * -> *). Location -> ReaderT (Validation m) Seq Error
check Location
thisLocation
      OperationDefinition
_ -> Seq Error -> RuleT m
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Seq Error
forall a. Monoid a => a
mempty
    where
      check :: Location -> ReaderT (Validation m) Seq Error
check Location
thisLocation = (Validation m -> Document) -> ReaderT (Validation m) Seq Document
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Validation m -> Document
forall (m :: * -> *). Validation m -> Document
ast
          ReaderT (Validation m) Seq Document
-> (Document -> ReaderT (Validation m) Seq Error)
-> ReaderT (Validation m) Seq Error
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Seq Error -> ReaderT (Validation m) Seq Error
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Seq Error -> ReaderT (Validation m) Seq Error)
-> (Document -> Seq Error)
-> Document
-> ReaderT (Validation m) Seq Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Definition -> Seq Error -> Seq Error)
-> Seq Error -> Document -> Seq Error
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Location -> Definition -> Seq Error -> Seq Error
filterAnonymousOperations Location
thisLocation) Seq Error
forall a. Monoid a => a
mempty
      filterAnonymousOperations :: Location -> Definition -> Seq Error -> Seq Error
filterAnonymousOperations Location
thisLocation Definition
definition Seq Error
Empty
          | (Definition -> Maybe OperationDefinition
viewOperation -> Just OperationDefinition
operationDefinition) <- Definition
definition =
              Location -> OperationDefinition -> Seq Error
forall (f :: * -> *).
(Applicative f, Monoid (f Error)) =>
Location -> OperationDefinition -> f Error
compareAnonymousOperations Location
thisLocation OperationDefinition
operationDefinition
      filterAnonymousOperations Location
_ Definition
_ Seq Error
accumulator = Seq Error
accumulator
      compareAnonymousOperations :: Location -> OperationDefinition -> f Error
compareAnonymousOperations Location
thisLocation = \case
          Full.OperationDefinition OperationType
_ Maybe Name
_ [VariableDefinition]
_ [Directive]
_ SelectionSet
_ Location
thatLocation
              | Location
thisLocation Location -> Location -> Bool
forall a. Eq a => a -> a -> Bool
/= Location
thatLocation -> Error -> f Error
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Error -> f Error) -> Error -> f Error
forall a b. (a -> b) -> a -> b
$ Location -> Error
error' Location
thisLocation
          Full.SelectionSet SelectionSet
_ Location
thatLocation
              | Location
thisLocation Location -> Location -> Bool
forall a. Eq a => a -> a -> Bool
/= Location
thatLocation -> Error -> f Error
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Error -> f Error) -> Error -> f Error
forall a b. (a -> b) -> a -> b
$ Location -> Error
error' Location
thisLocation
          OperationDefinition
_ -> f Error
forall a. Monoid a => a
mempty
      error' :: Location -> Error
error' Location
location' = Error :: String -> [Location] -> Error
Error
          { message :: String
message =
              String
"This anonymous operation must be the only defined operation."
          , locations :: [Location]
locations = [Location
location']
          }

-- | Each named operation definition must be unique within a document when
-- referred to by its name.
uniqueOperationNamesRule :: forall m. Rule m
uniqueOperationNamesRule :: Rule m
uniqueOperationNamesRule = (OperationDefinition -> RuleT m) -> Rule m
forall (m :: * -> *). (OperationDefinition -> RuleT m) -> Rule m
OperationDefinitionRule ((OperationDefinition -> RuleT m) -> Rule m)
-> (OperationDefinition -> RuleT m) -> Rule m
forall a b. (a -> b) -> a -> b
$ \case
    Full.OperationDefinition OperationType
_ (Just Name
thisName) [VariableDefinition]
_ [Directive]
_ SelectionSet
_ Location
thisLocation ->
        (Definition -> [Location] -> [Location])
-> Location -> String -> RuleT m
forall (m :: * -> *).
(Definition -> [Location] -> [Location])
-> Location -> String -> RuleT m
findDuplicates (Name -> Definition -> [Location] -> [Location]
filterByName Name
thisName) Location
thisLocation (Name -> String
error' Name
thisName)
    OperationDefinition
_ -> Seq Error -> RuleT m
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Seq Error
forall a. Monoid a => a
mempty
  where
    error' :: Name -> String
error' Name
operationName = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"There can be only one operation named \""
        , Name -> String
Text.unpack Name
operationName
        , String
"\"."
        ]
    filterByName :: Name -> Definition -> [Location] -> [Location]
filterByName Name
thisName Definition
definition' [Location]
accumulator
        | (Definition -> Maybe OperationDefinition
viewOperation -> Just OperationDefinition
operationDefinition) <- Definition
definition'
        , Full.OperationDefinition OperationType
_ (Just Name
thatName) [VariableDefinition]
_ [Directive]
_ SelectionSet
_ Location
thatLocation <- OperationDefinition
operationDefinition
        , Name
thisName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
thatName = Location
thatLocation Location -> [Location] -> [Location]
forall a. a -> [a] -> [a]
: [Location]
accumulator
        | Bool
otherwise = [Location]
accumulator

findDuplicates :: (Full.Definition -> [Full.Location] -> [Full.Location])
    -> Full.Location
    -> String
    -> RuleT m
findDuplicates :: (Definition -> [Location] -> [Location])
-> Location -> String -> RuleT m
findDuplicates Definition -> [Location] -> [Location]
filterByName Location
thisLocation String
errorMessage = do
    Document
ast' <- (Validation m -> Document) -> ReaderT (Validation m) Seq Document
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Validation m -> Document
forall (m :: * -> *). Validation m -> Document
ast
    let locations' :: [Location]
locations' = (Definition -> [Location] -> [Location])
-> [Location] -> Document -> [Location]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Definition -> [Location] -> [Location]
filterByName [] Document
ast'
    if [Location] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Location]
locations' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 Bool -> Bool -> Bool
&& [Location] -> Location
forall a. [a] -> a
head [Location]
locations' Location -> Location -> Bool
forall a. Eq a => a -> a -> Bool
== Location
thisLocation
        then Error -> RuleT m
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Error -> RuleT m) -> Error -> RuleT m
forall a b. (a -> b) -> a -> b
$ [Location] -> Error
error' [Location]
locations'
        else Seq Error -> RuleT m
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Seq Error
forall a. Monoid a => a
mempty
  where
    error' :: [Location] -> Error
error' [Location]
locations' = Error :: String -> [Location] -> Error
Error 
        { message :: String
message = String
errorMessage
        , locations :: [Location]
locations = [Location]
locations'
        }

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

viewFragment :: Full.Definition -> Maybe Full.FragmentDefinition
viewFragment :: Definition -> Maybe FragmentDefinition
viewFragment Definition
definition
    | Full.ExecutableDefinition ExecutableDefinition
executableDefinition <- Definition
definition
    , Full.DefinitionFragment FragmentDefinition
fragmentDefinition <- ExecutableDefinition
executableDefinition =
        FragmentDefinition -> Maybe FragmentDefinition
forall a. a -> Maybe a
Just FragmentDefinition
fragmentDefinition
viewFragment Definition
_ = Maybe FragmentDefinition
forall a. Maybe a
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 :: Rule m
uniqueFragmentNamesRule = (FragmentDefinition -> RuleT m) -> Rule m
forall (m :: * -> *). (FragmentDefinition -> RuleT m) -> Rule m
FragmentDefinitionRule ((FragmentDefinition -> RuleT m) -> Rule m)
-> (FragmentDefinition -> RuleT m) -> Rule m
forall a b. (a -> b) -> a -> b
$ \case
    Full.FragmentDefinition Name
thisName Name
_ [Directive]
_ SelectionSet
_ Location
thisLocation ->
        (Definition -> [Location] -> [Location])
-> Location -> String -> RuleT m
forall (m :: * -> *).
(Definition -> [Location] -> [Location])
-> Location -> String -> RuleT m
findDuplicates (Name -> Definition -> [Location] -> [Location]
filterByName Name
thisName) Location
thisLocation (Name -> String
error' Name
thisName)
  where
    error' :: Name -> String
error' Name
fragmentName = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"There can be only one fragment named \""
        , Name -> String
Text.unpack Name
fragmentName
        , String
"\"."
        ]
    filterByName :: Name -> Definition -> [Location] -> [Location]
filterByName Name
thisName Definition
definition [Location]
accumulator
        | Just FragmentDefinition
fragmentDefinition <- Definition -> Maybe FragmentDefinition
viewFragment Definition
definition
        , Full.FragmentDefinition Name
thatName Name
_ [Directive]
_ SelectionSet
_ Location
thatLocation <- FragmentDefinition
fragmentDefinition
        , Name
thisName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
thatName = Location
thatLocation Location -> [Location] -> [Location]
forall a. a -> [a] -> [a]
: [Location]
accumulator
        | Bool
otherwise = [Location]
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 :: Rule m
fragmentSpreadTargetDefinedRule = (FragmentSpread -> RuleT m) -> Rule m
forall (m :: * -> *). (FragmentSpread -> RuleT m) -> Rule m
FragmentSpreadRule ((FragmentSpread -> RuleT m) -> Rule m)
-> (FragmentSpread -> RuleT m) -> Rule m
forall a b. (a -> b) -> a -> b
$ \case
    Full.FragmentSpread Name
fragmentName [Directive]
_ Location
location' -> do
        Document
ast' <- (Validation m -> Document) -> ReaderT (Validation m) Seq Document
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Validation m -> Document
forall (m :: * -> *). Validation m -> Document
ast
        case (Definition -> Bool) -> Document -> Maybe Definition
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Name -> Definition -> Bool
isSpreadTarget Name
fragmentName) Document
ast' of
            Maybe Definition
Nothing -> Error -> RuleT m
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Error -> RuleT m) -> Error -> RuleT m
forall a b. (a -> b) -> a -> b
$ Error :: String -> [Location] -> Error
Error
                { message :: String
message = Name -> String
error' Name
fragmentName
                , locations :: [Location]
locations = [Location
location']
                }
            Just Definition
_ -> Seq Error -> RuleT m
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Seq Error
forall a. Monoid a => a
mempty
  where
    error' :: Name -> String
error' Name
fragmentName = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Fragment target \""
        , Name -> String
Text.unpack Name
fragmentName
        , String
"\" is undefined."
        ]

isSpreadTarget :: Text -> Full.Definition -> Bool
isSpreadTarget :: Name -> Definition -> Bool
isSpreadTarget Name
thisName (Definition -> Maybe FragmentDefinition
viewFragment -> Just FragmentDefinition
fragmentDefinition)
    | Full.FragmentDefinition Name
thatName Name
_ [Directive]
_ SelectionSet
_ Location
_ <- FragmentDefinition
fragmentDefinition
    , Name
thisName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
thatName = Bool
True
isSpreadTarget Name
_ Definition
_ = Bool
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 :: Rule m
fragmentSpreadTypeExistenceRule = (Maybe (Type m) -> Selection -> RuleT m) -> Rule m
forall (m :: * -> *).
(Maybe (Type m) -> Selection -> RuleT m) -> Rule m
SelectionRule ((Maybe (Type m) -> Selection -> RuleT m) -> Rule m)
-> (Maybe (Type m) -> Selection -> RuleT m) -> Rule m
forall a b. (a -> b) -> a -> b
$ (Selection -> RuleT m) -> Maybe (Type m) -> Selection -> RuleT m
forall a b. a -> b -> a
const ((Selection -> RuleT m) -> Maybe (Type m) -> Selection -> RuleT m)
-> (Selection -> RuleT m) -> Maybe (Type m) -> Selection -> RuleT m
forall a b. (a -> b) -> a -> b
$ \case
    Full.FragmentSpreadSelection FragmentSpread
fragmentSelection
        | Full.FragmentSpread Name
fragmentName [Directive]
_ Location
location' <- FragmentSpread
fragmentSelection -> do
            HashMap Name (Type m)
types' <- (Validation m -> HashMap Name (Type m))
-> ReaderT (Validation m) Seq (HashMap Name (Type m))
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks ((Validation m -> HashMap Name (Type m))
 -> ReaderT (Validation m) Seq (HashMap Name (Type m)))
-> (Validation m -> HashMap Name (Type m))
-> ReaderT (Validation m) Seq (HashMap Name (Type m))
forall a b. (a -> b) -> a -> b
$ Schema m -> HashMap Name (Type m)
forall (m :: * -> *). Schema m -> HashMap Name (Type m)
Schema.types (Schema m -> HashMap Name (Type m))
-> (Validation m -> Schema m)
-> Validation m
-> HashMap Name (Type m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validation m -> Schema m
forall (m :: * -> *). Validation m -> Schema m
schema
            Name
typeCondition <- Name -> ReaderT (Validation m) Seq Name
forall (m1 :: * -> *). Name -> ReaderT (Validation m1) Seq Name
findSpreadTarget Name
fragmentName
            case Name -> HashMap Name (Type m) -> Maybe (Type m)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
typeCondition HashMap Name (Type m)
types' of
                Maybe (Type m)
Nothing -> Error -> RuleT m
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Error -> RuleT m) -> Error -> RuleT m
forall a b. (a -> b) -> a -> b
$ Error :: String -> [Location] -> Error
Error
                    { message :: String
message = Name -> Name -> String
spreadError Name
fragmentName Name
typeCondition
                    , locations :: [Location]
locations = [Location
location']
                    }
                Just Type m
_ -> Seq Error -> RuleT m
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Seq Error
forall a. Monoid a => a
mempty
    Full.InlineFragmentSelection InlineFragment
fragmentSelection
        | Full.InlineFragment Maybe Name
maybeType [Directive]
_ SelectionSet
_ Location
location' <- InlineFragment
fragmentSelection
        , Just Name
typeCondition <- Maybe Name
maybeType -> do
            HashMap Name (Type m)
types' <- (Validation m -> HashMap Name (Type m))
-> ReaderT (Validation m) Seq (HashMap Name (Type m))
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks ((Validation m -> HashMap Name (Type m))
 -> ReaderT (Validation m) Seq (HashMap Name (Type m)))
-> (Validation m -> HashMap Name (Type m))
-> ReaderT (Validation m) Seq (HashMap Name (Type m))
forall a b. (a -> b) -> a -> b
$ Schema m -> HashMap Name (Type m)
forall (m :: * -> *). Schema m -> HashMap Name (Type m)
Schema.types (Schema m -> HashMap Name (Type m))
-> (Validation m -> Schema m)
-> Validation m
-> HashMap Name (Type m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validation m -> Schema m
forall (m :: * -> *). Validation m -> Schema m
schema
            case Name -> HashMap Name (Type m) -> Maybe (Type m)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
typeCondition HashMap Name (Type m)
types' of
                Maybe (Type m)
Nothing -> Error -> RuleT m
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Error -> RuleT m) -> Error -> RuleT m
forall a b. (a -> b) -> a -> b
$ Error :: String -> [Location] -> Error
Error
                    { message :: String
message = Name -> String
inlineError Name
typeCondition
                    , locations :: [Location]
locations = [Location
location']
                    }
                Just Type m
_ -> Seq Error -> RuleT m
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Seq Error
forall a. Monoid a => a
mempty
    Selection
_ -> Seq Error -> RuleT m
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Seq Error
forall a. Monoid a => a
mempty
  where
    spreadError :: Name -> Name -> String
spreadError Name
fragmentName Name
typeCondition = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Fragment \""
        , Name -> String
Text.unpack Name
fragmentName
        , String
"\" is specified on type \""
        , Name -> String
Text.unpack Name
typeCondition
        , String
"\" which doesn't exist in the schema."
        ]
    inlineError :: Name -> String
inlineError Name
typeCondition = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Inline fragment is specified on type \""
        , Name -> String
Text.unpack Name
typeCondition
        , String
"\" which doesn't exist in the schema."
        ]

maybeToSeq :: forall a. Maybe a -> Seq a
maybeToSeq :: Maybe a -> Seq a
maybeToSeq (Just a
x) = a -> Seq a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
maybeToSeq Maybe a
Nothing = Seq a
forall a. Monoid a => a
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 :: Rule m
fragmentsOnCompositeTypesRule = (FragmentDefinition -> RuleT m)
-> (InlineFragment -> RuleT m) -> Rule m
forall (m :: * -> *).
(FragmentDefinition -> RuleT m)
-> (InlineFragment -> RuleT m) -> Rule m
FragmentRule FragmentDefinition -> RuleT m
forall (m :: * -> *).
FragmentDefinition -> ReaderT (Validation m) Seq Error
definitionRule InlineFragment -> RuleT m
forall (m :: * -> *).
InlineFragment -> ReaderT (Validation m) Seq Error
inlineRule
  where
    inlineRule :: InlineFragment -> ReaderT (Validation m) Seq Error
inlineRule (Full.InlineFragment (Just Name
typeCondition) [Directive]
_ SelectionSet
_ Location
location') =
        Name -> Location -> ReaderT (Validation m) Seq Error
forall (m :: * -> *).
Name -> Location -> ReaderT (Validation m) Seq Error
check Name
typeCondition Location
location'
    inlineRule InlineFragment
_ = Seq Error -> ReaderT (Validation m) Seq Error
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Seq Error
forall a. Monoid a => a
mempty
    definitionRule :: FragmentDefinition -> ReaderT (Validation m) Seq Error
definitionRule (Full.FragmentDefinition Name
_ Name
typeCondition [Directive]
_ SelectionSet
_ Location
location') =
        Name -> Location -> ReaderT (Validation m) Seq Error
forall (m :: * -> *).
Name -> Location -> ReaderT (Validation m) Seq Error
check Name
typeCondition Location
location'
    check :: Name -> Location -> ReaderT (Validation m) Seq Error
check Name
typeCondition Location
location' = do
        HashMap Name (Type m)
types' <- (Validation m -> HashMap Name (Type m))
-> ReaderT (Validation m) Seq (HashMap Name (Type m))
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks ((Validation m -> HashMap Name (Type m))
 -> ReaderT (Validation m) Seq (HashMap Name (Type m)))
-> (Validation m -> HashMap Name (Type m))
-> ReaderT (Validation m) Seq (HashMap Name (Type m))
forall a b. (a -> b) -> a -> b
$ Schema m -> HashMap Name (Type m)
forall (m :: * -> *). Schema m -> HashMap Name (Type m)
Schema.types (Schema m -> HashMap Name (Type m))
-> (Validation m -> Schema m)
-> Validation m
-> HashMap Name (Type m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validation m -> Schema m
forall (m :: * -> *). Validation m -> Schema m
schema
        -- Skip unknown types, they are checked by another rule.
        Type m
_ <- Seq (Type m) -> ReaderT (Validation m) Seq (Type m)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Seq (Type m) -> ReaderT (Validation m) Seq (Type m))
-> Seq (Type m) -> ReaderT (Validation m) Seq (Type m)
forall a b. (a -> b) -> a -> b
$ Maybe (Type m) -> Seq (Type m)
forall a. Maybe a -> Seq a
maybeToSeq (Maybe (Type m) -> Seq (Type m)) -> Maybe (Type m) -> Seq (Type m)
forall a b. (a -> b) -> a -> b
$ Name -> HashMap Name (Type m) -> Maybe (Type m)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
typeCondition HashMap Name (Type m)
types'
        case Name -> HashMap Name (Type m) -> Maybe (CompositeType m)
forall (m :: * -> *).
Name -> HashMap Name (Type m) -> Maybe (CompositeType m)
Type.lookupTypeCondition Name
typeCondition HashMap Name (Type m)
types' of
            Maybe (CompositeType m)
Nothing -> Error -> ReaderT (Validation m) Seq Error
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Error -> ReaderT (Validation m) Seq Error)
-> Error -> ReaderT (Validation m) Seq Error
forall a b. (a -> b) -> a -> b
$ Error :: String -> [Location] -> Error
Error
                { message :: String
message = Name -> String
errorMessage Name
typeCondition
                , locations :: [Location]
locations = [Location
location']
                }
            Just CompositeType m
_ -> Seq Error -> ReaderT (Validation m) Seq Error
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Seq Error
forall a. Monoid a => a
mempty
    errorMessage :: Name -> String
errorMessage Name
typeCondition = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Fragment cannot condition on non composite type \""
        , Name -> String
Text.unpack Name
typeCondition,
        String
"\"."
        ]

-- | Defined fragments must be used within a document.
noUnusedFragmentsRule :: forall m. Rule m
noUnusedFragmentsRule :: Rule m
noUnusedFragmentsRule = (FragmentDefinition -> RuleT m) -> Rule m
forall (m :: * -> *). (FragmentDefinition -> RuleT m) -> Rule m
FragmentDefinitionRule ((FragmentDefinition -> RuleT m) -> Rule m)
-> (FragmentDefinition -> RuleT m) -> Rule m
forall a b. (a -> b) -> a -> b
$ \FragmentDefinition
fragment -> do
    let Full.FragmentDefinition Name
fragmentName Name
_ [Directive]
_ SelectionSet
_ Location
location' = FragmentDefinition
fragment
     in (Seq Name -> Seq Error)
-> ReaderT (Validation m) Seq Name -> RuleT m
forall (m :: * -> *) a (n :: * -> *) b r.
(m a -> n b) -> ReaderT r m a -> ReaderT r n b
mapReaderT (Name -> Location -> Seq Name -> Seq Error
forall (t :: * -> *) (f :: * -> *).
(Foldable t, Monoid (f Error), Applicative f) =>
Name -> Location -> t Name -> f Error
checkFragmentName Name
fragmentName Location
location')
        (ReaderT (Validation m) Seq Name -> RuleT m)
-> ReaderT (Validation m) Seq Name -> RuleT m
forall a b. (a -> b) -> a -> b
$ (Validation m -> Document) -> ReaderT (Validation m) Seq Document
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Validation m -> Document
forall (m :: * -> *). Validation m -> Document
ast
        ReaderT (Validation m) Seq Document
-> (Document -> ReaderT (Validation m) Seq Name)
-> ReaderT (Validation m) Seq Name
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (StateT (HashSet Name) (ReaderT (Validation m) Seq) Name
 -> HashSet Name -> ReaderT (Validation m) Seq Name)
-> HashSet Name
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) Name
-> ReaderT (Validation m) Seq Name
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT (HashSet Name) (ReaderT (Validation m) Seq) Name
-> HashSet Name -> ReaderT (Validation m) Seq Name
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT HashSet Name
forall a. HashSet a
HashSet.empty
        (StateT (HashSet Name) (ReaderT (Validation m) Seq) Name
 -> ReaderT (Validation m) Seq Name)
-> (Document
    -> StateT (HashSet Name) (ReaderT (Validation m) Seq) Name)
-> Document
-> ReaderT (Validation m) Seq Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Selection
 -> StateT (HashSet Name) (ReaderT (Validation m) Seq) Name)
-> SelectionSetOpt
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) Name
forall (t :: * -> *) a (m :: * -> *).
Foldable t =>
(Selection -> ValidationState m a)
-> t Selection -> ValidationState m a
filterSelections Selection
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) Name
forall (t :: (* -> *) -> * -> *) (t :: (* -> *) -> * -> *)
       (m :: * -> *).
(MonadTrans t, MonadTrans t, Monad m, Monad (t m),
 Monoid (m Name)) =>
Selection -> t (t m) Name
evaluateSelection
        (SelectionSetOpt
 -> StateT (HashSet Name) (ReaderT (Validation m) Seq) Name)
-> (Document -> SelectionSetOpt)
-> Document
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Definition -> SelectionSetOpt) -> Document -> SelectionSetOpt
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Definition -> SelectionSetOpt
definitionSelections
  where
    checkFragmentName :: Name -> Location -> t Name -> f Error
checkFragmentName Name
fragmentName Location
location' t Name
elements
        | Name
fragmentName Name -> t Name -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t Name
elements = f Error
forall a. Monoid a => a
mempty
        | Bool
otherwise = Error -> f Error
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Error -> f Error) -> Error -> f Error
forall a b. (a -> b) -> a -> b
$ Name -> Location -> Error
makeError Name
fragmentName Location
location'
    makeError :: Name -> Location -> Error
makeError Name
fragName Location
location' = Error :: String -> [Location] -> Error
Error
        { message :: String
message = Name -> String
errorMessage Name
fragName
        , locations :: [Location]
locations = [Location
location']
        }
    errorMessage :: Name -> String
errorMessage Name
fragName = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Fragment \""
        , Name -> String
Text.unpack Name
fragName
        , String
"\" is never used."
        ]
    evaluateSelection :: Selection -> t (t m) Name
evaluateSelection Selection
selection
        | Full.FragmentSpreadSelection FragmentSpread
spreadSelection <- Selection
selection
        , Full.FragmentSpread Name
spreadName [Directive]
_ Location
_ <- FragmentSpread
spreadSelection =
            t m Name -> t (t m) Name
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (t m Name -> t (t m) Name) -> t m Name -> t (t m) Name
forall a b. (a -> b) -> a -> b
$ Name -> t m Name
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
spreadName
    evaluateSelection Selection
_ = t m Name -> t (t m) Name
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (t m Name -> t (t m) Name) -> t m Name -> t (t m) Name
forall a b. (a -> b) -> a -> b
$ m Name -> t m Name
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Name
forall a. Monoid a => a
mempty

definitionSelections :: Full.Definition -> Full.SelectionSetOpt
definitionSelections :: Definition -> SelectionSetOpt
definitionSelections (Definition -> Maybe OperationDefinition
viewOperation -> Just OperationDefinition
operation)
    | Full.OperationDefinition OperationType
_ Maybe Name
_ [VariableDefinition]
_ [Directive]
_ SelectionSet
selections Location
_ <- OperationDefinition
operation =
        SelectionSet -> SelectionSetOpt
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList SelectionSet
selections
    | Full.SelectionSet SelectionSet
selections Location
_ <- OperationDefinition
operation = SelectionSet -> SelectionSetOpt
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList SelectionSet
selections
definitionSelections (Definition -> Maybe FragmentDefinition
viewFragment -> Just FragmentDefinition
fragment)
    | Full.FragmentDefinition Name
_ Name
_ [Directive]
_ SelectionSet
selections Location
_ <- FragmentDefinition
fragment = SelectionSet -> SelectionSetOpt
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList SelectionSet
selections
definitionSelections Definition
_ = []

filterSelections :: Foldable t
    => forall a m
    . (Full.Selection -> ValidationState m a)
    -> t Full.Selection
    -> ValidationState m a
filterSelections :: forall a (m :: * -> *).
(Selection -> ValidationState m a)
-> t Selection -> ValidationState m a
filterSelections Selection -> ValidationState m a
applyFilter t Selection
selections
    = (ReaderT (Validation m) Seq Selection
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) Selection
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT (Validation m) Seq Selection
 -> StateT (HashSet Name) (ReaderT (Validation m) Seq) Selection)
-> (Seq Selection -> ReaderT (Validation m) Seq Selection)
-> Seq Selection
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) Selection
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq Selection -> ReaderT (Validation m) Seq Selection
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift) (SelectionSetOpt -> Seq Selection
forall a. [a] -> Seq a
Seq.fromList (SelectionSetOpt -> Seq Selection)
-> SelectionSetOpt -> Seq Selection
forall a b. (a -> b) -> a -> b
$ (Selection -> SelectionSetOpt -> SelectionSetOpt)
-> SelectionSetOpt -> t Selection -> SelectionSetOpt
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Selection -> SelectionSetOpt -> SelectionSetOpt
evaluateSelection SelectionSetOpt
forall a. Monoid a => a
mempty t Selection
selections)
    StateT (HashSet Name) (ReaderT (Validation m) Seq) Selection
-> (Selection -> ValidationState m a) -> ValidationState m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Selection -> ValidationState m a
applyFilter
  where
    evaluateSelection :: Selection -> SelectionSetOpt -> SelectionSetOpt
evaluateSelection Selection
selection SelectionSetOpt
accumulator
        | Full.FragmentSpreadSelection{} <- Selection
selection = Selection
selection Selection -> SelectionSetOpt -> SelectionSetOpt
forall a. a -> [a] -> [a]
: SelectionSetOpt
accumulator
        | Full.FieldSelection Field
fieldSelection <- Selection
selection
        , Full.Field Maybe Name
_ Name
_ [Argument]
_ [Directive]
_ SelectionSetOpt
subselections Location
_ <- Field
fieldSelection =
            Selection
selection Selection -> SelectionSetOpt -> SelectionSetOpt
forall a. a -> [a] -> [a]
: (Selection -> SelectionSetOpt -> SelectionSetOpt)
-> SelectionSetOpt -> SelectionSetOpt -> SelectionSetOpt
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Selection -> SelectionSetOpt -> SelectionSetOpt
evaluateSelection SelectionSetOpt
accumulator SelectionSetOpt
subselections
        | Full.InlineFragmentSelection InlineFragment
inlineSelection <- Selection
selection
        , Full.InlineFragment Maybe Name
_ [Directive]
_ SelectionSet
subselections Location
_ <- InlineFragment
inlineSelection =
            Selection
selection Selection -> SelectionSetOpt -> SelectionSetOpt
forall a. a -> [a] -> [a]
: (Selection -> SelectionSetOpt -> SelectionSetOpt)
-> SelectionSetOpt -> SelectionSet -> SelectionSetOpt
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Selection -> SelectionSetOpt -> SelectionSetOpt
evaluateSelection SelectionSetOpt
accumulator SelectionSet
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 :: Rule m
noFragmentCyclesRule = (FragmentDefinition -> RuleT m) -> Rule m
forall (m :: * -> *). (FragmentDefinition -> RuleT m) -> Rule m
FragmentDefinitionRule ((FragmentDefinition -> RuleT m) -> Rule m)
-> (FragmentDefinition -> RuleT m) -> Rule m
forall a b. (a -> b) -> a -> b
$ \case
    Full.FragmentDefinition Name
fragmentName Name
_ [Directive]
_ SelectionSet
selections Location
location' -> do
        HashMap Name Int
state <- StateT (Int, Name) (ReaderT (Validation m) Seq) (HashMap Name Int)
-> (Int, Name) -> ReaderT (Validation m) Seq (HashMap Name Int)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (SelectionSet
-> StateT
     (Int, Name) (ReaderT (Validation m) Seq) (HashMap Name Int)
forall (t :: * -> *).
Traversable t =>
t Selection
-> StateT
     (Int, Name) (ReaderT (Validation m) Seq) (HashMap Name Int)
collectCycles SelectionSet
selections) (Int
0, Name
fragmentName)
        let spreadPath :: [Name]
spreadPath = (Name, Int) -> Name
forall a b. (a, b) -> a
fst ((Name, Int) -> Name) -> [(Name, Int)] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Name, Int) -> (Name, Int) -> Ordering)
-> [(Name, Int)] -> [(Name, Int)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Name, Int) -> Int) -> (Name, Int) -> (Name, Int) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Name, Int) -> Int
forall a b. (a, b) -> b
snd) (HashMap Name Int -> [(Name, Int)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList HashMap Name Int
state)
        case [Name] -> [Name]
forall a. [a] -> [a]
reverse [Name]
spreadPath of
            Name
x : [Name]
_ | Name
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
fragmentName -> Error -> RuleT m
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Error -> RuleT m) -> Error -> RuleT m
forall a b. (a -> b) -> a -> b
$ Error :: String -> [Location] -> Error
Error
                { message :: String
message = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                    [ String
"Cannot spread fragment \""
                    , Name -> String
Text.unpack Name
fragmentName
                    , String
"\" within itself (via "
                    , Name -> String
Text.unpack (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ Name -> [Name] -> Name
Text.intercalate Name
" -> " ([Name] -> Name) -> [Name] -> Name
forall a b. (a -> b) -> a -> b
$ Name
fragmentName Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
spreadPath
                    , String
")."
                    ]
                , locations :: [Location]
locations = [Location
location']
                }
            [Name]
_ -> Seq Error -> RuleT m
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Seq Error
forall a. Monoid a => a
mempty
  where
    collectCycles :: Traversable t
        => t Full.Selection
        -> StateT (Int, Full.Name) (ReaderT (Validation m) Seq) (HashMap Full.Name Int)
    collectCycles :: t Selection
-> StateT
     (Int, Name) (ReaderT (Validation m) Seq) (HashMap Name Int)
collectCycles = (HashMap Name Int
 -> Selection
 -> StateT
      (Int, Name) (ReaderT (Validation m) Seq) (HashMap Name Int))
-> HashMap Name Int
-> t Selection
-> StateT
     (Int, Name) (ReaderT (Validation m) Seq) (HashMap Name Int)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM HashMap Name Int
-> Selection
-> StateT
     (Int, Name) (ReaderT (Validation m) Seq) (HashMap Name Int)
forEach HashMap Name Int
forall k v. HashMap k v
HashMap.empty
    forEach :: HashMap Name Int
-> Selection
-> StateT
     (Int, Name) (ReaderT (Validation m) Seq) (HashMap Name Int)
forEach HashMap Name Int
accumulator = \case
        Full.FieldSelection Field
fieldSelection -> HashMap Name Int
-> Field
-> StateT
     (Int, Name) (ReaderT (Validation m) Seq) (HashMap Name Int)
forField HashMap Name Int
accumulator Field
fieldSelection
        Full.InlineFragmentSelection InlineFragment
fragmentSelection ->
            HashMap Name Int
-> InlineFragment
-> StateT
     (Int, Name) (ReaderT (Validation m) Seq) (HashMap Name Int)
forInline HashMap Name Int
accumulator InlineFragment
fragmentSelection
        Full.FragmentSpreadSelection FragmentSpread
fragmentSelection ->
            HashMap Name Int
-> FragmentSpread
-> StateT
     (Int, Name) (ReaderT (Validation m) Seq) (HashMap Name Int)
forSpread HashMap Name Int
accumulator FragmentSpread
fragmentSelection
    forSpread :: HashMap Name Int
-> FragmentSpread
-> StateT
     (Int, Name) (ReaderT (Validation m) Seq) (HashMap Name Int)
forSpread HashMap Name Int
accumulator (Full.FragmentSpread Name
fragmentName [Directive]
_ Location
_) = do
        Name
firstFragmentName <- ((Int, Name) -> Name)
-> StateT (Int, Name) (ReaderT (Validation m) Seq) Name
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets (Int, Name) -> Name
forall a b. (a, b) -> b
snd
        ((Int, Name) -> (Int, Name))
-> StateT (Int, Name) (ReaderT (Validation m) Seq) ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (((Int, Name) -> (Int, Name))
 -> StateT (Int, Name) (ReaderT (Validation m) Seq) ())
-> ((Int, Name) -> (Int, Name))
-> StateT (Int, Name) (ReaderT (Validation m) Seq) ()
forall a b. (a -> b) -> a -> b
$ (Int -> Int) -> (Int, Name) -> (Int, Name)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
        Int
lastIndex <- ((Int, Name) -> Int)
-> StateT (Int, Name) (ReaderT (Validation m) Seq) Int
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets (Int, Name) -> Int
forall a b. (a, b) -> a
fst
        let newAccumulator :: HashMap Name Int
newAccumulator = Name -> Int -> HashMap Name Int -> HashMap Name Int
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert Name
fragmentName Int
lastIndex HashMap Name Int
accumulator
        let inVisitetFragment :: Bool
inVisitetFragment = Name -> HashMap Name Int -> Bool
forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
HashMap.member Name
fragmentName HashMap Name Int
accumulator
        if Name
fragmentName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
firstFragmentName Bool -> Bool -> Bool
|| Bool
inVisitetFragment
            then HashMap Name Int
-> StateT
     (Int, Name) (ReaderT (Validation m) Seq) (HashMap Name Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure HashMap Name Int
newAccumulator
            else Name
-> HashMap Name Int
-> StateT
     (Int, Name) (ReaderT (Validation m) Seq) (HashMap Name Int)
collectFromSpread Name
fragmentName HashMap Name Int
newAccumulator
    forInline :: HashMap Name Int
-> InlineFragment
-> StateT
     (Int, Name) (ReaderT (Validation m) Seq) (HashMap Name Int)
forInline HashMap Name Int
accumulator (Full.InlineFragment Maybe Name
_ [Directive]
_ SelectionSet
selections Location
_) =
        (HashMap Name Int
accumulator HashMap Name Int -> HashMap Name Int -> HashMap Name Int
forall a. Semigroup a => a -> a -> a
<>) (HashMap Name Int -> HashMap Name Int)
-> StateT
     (Int, Name) (ReaderT (Validation m) Seq) (HashMap Name Int)
-> StateT
     (Int, Name) (ReaderT (Validation m) Seq) (HashMap Name Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SelectionSet
-> StateT
     (Int, Name) (ReaderT (Validation m) Seq) (HashMap Name Int)
forall (t :: * -> *).
Traversable t =>
t Selection
-> StateT
     (Int, Name) (ReaderT (Validation m) Seq) (HashMap Name Int)
collectCycles SelectionSet
selections
    forField :: HashMap Name Int
-> Field
-> StateT
     (Int, Name) (ReaderT (Validation m) Seq) (HashMap Name Int)
forField HashMap Name Int
accumulator (Full.Field Maybe Name
_ Name
_ [Argument]
_ [Directive]
_ SelectionSetOpt
selections Location
_) =
        (HashMap Name Int
accumulator HashMap Name Int -> HashMap Name Int -> HashMap Name Int
forall a. Semigroup a => a -> a -> a
<>) (HashMap Name Int -> HashMap Name Int)
-> StateT
     (Int, Name) (ReaderT (Validation m) Seq) (HashMap Name Int)
-> StateT
     (Int, Name) (ReaderT (Validation m) Seq) (HashMap Name Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SelectionSetOpt
-> StateT
     (Int, Name) (ReaderT (Validation m) Seq) (HashMap Name Int)
forall (t :: * -> *).
Traversable t =>
t Selection
-> StateT
     (Int, Name) (ReaderT (Validation m) Seq) (HashMap Name Int)
collectCycles SelectionSetOpt
selections
    collectFromSpread :: Name
-> HashMap Name Int
-> StateT
     (Int, Name) (ReaderT (Validation m) Seq) (HashMap Name Int)
collectFromSpread Name
fragmentName HashMap Name Int
accumulator = do
        Document
ast' <- ReaderT (Validation m) Seq Document
-> StateT (Int, Name) (ReaderT (Validation m) Seq) Document
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT (Validation m) Seq Document
 -> StateT (Int, Name) (ReaderT (Validation m) Seq) Document)
-> ReaderT (Validation m) Seq Document
-> StateT (Int, Name) (ReaderT (Validation m) Seq) Document
forall a b. (a -> b) -> a -> b
$ (Validation m -> Document) -> ReaderT (Validation m) Seq Document
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Validation m -> Document
forall (m :: * -> *). Validation m -> Document
ast
        case Name -> Document -> Maybe FragmentDefinition
findFragmentDefinition Name
fragmentName Document
ast' of
            Maybe FragmentDefinition
Nothing -> HashMap Name Int
-> StateT
     (Int, Name) (ReaderT (Validation m) Seq) (HashMap Name Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure HashMap Name Int
accumulator
            Just (Full.FragmentDefinition Name
_ Name
_ [Directive]
_ SelectionSet
selections Location
_) ->
                (HashMap Name Int
accumulator HashMap Name Int -> HashMap Name Int -> HashMap Name Int
forall a. Semigroup a => a -> a -> a
<>) (HashMap Name Int -> HashMap Name Int)
-> StateT
     (Int, Name) (ReaderT (Validation m) Seq) (HashMap Name Int)
-> StateT
     (Int, Name) (ReaderT (Validation m) Seq) (HashMap Name Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SelectionSet
-> StateT
     (Int, Name) (ReaderT (Validation m) Seq) (HashMap Name Int)
forall (t :: * -> *).
Traversable t =>
t Selection
-> StateT
     (Int, Name) (ReaderT (Validation m) Seq) (HashMap Name Int)
collectCycles SelectionSet
selections

findFragmentDefinition :: Text
    -> NonEmpty Full.Definition
    -> Maybe Full.FragmentDefinition
findFragmentDefinition :: Name -> Document -> Maybe FragmentDefinition
findFragmentDefinition Name
fragmentName = (Definition
 -> Maybe FragmentDefinition -> Maybe FragmentDefinition)
-> Maybe FragmentDefinition -> Document -> Maybe FragmentDefinition
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Definition -> Maybe FragmentDefinition -> Maybe FragmentDefinition
compareDefinition Maybe FragmentDefinition
forall a. Maybe a
Nothing
  where
    compareDefinition :: Definition -> Maybe FragmentDefinition -> Maybe FragmentDefinition
compareDefinition (Full.ExecutableDefinition ExecutableDefinition
executableDefinition) Maybe FragmentDefinition
Nothing
        | Full.DefinitionFragment FragmentDefinition
fragmentDefinition <- ExecutableDefinition
executableDefinition
        , Full.FragmentDefinition Name
anotherName Name
_ [Directive]
_ SelectionSet
_ Location
_ <- FragmentDefinition
fragmentDefinition
        , Name
anotherName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
fragmentName = FragmentDefinition -> Maybe FragmentDefinition
forall a. a -> Maybe a
Just FragmentDefinition
fragmentDefinition
    compareDefinition Definition
_ Maybe FragmentDefinition
accumulator = Maybe FragmentDefinition
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 :: Rule m
uniqueArgumentNamesRule = (Maybe (Type m) -> Field -> RuleT m)
-> (Directive -> RuleT m) -> Rule m
forall (m :: * -> *).
(Maybe (Type m) -> Field -> RuleT m)
-> (Directive -> RuleT m) -> Rule m
ArgumentsRule Maybe (Type m) -> Field -> RuleT m
forall (t :: (* -> *) -> * -> *) p.
MonadTrans t =>
p -> Field -> t Seq Error
fieldRule Directive -> RuleT m
forall (t :: (* -> *) -> * -> *).
MonadTrans t =>
Directive -> t Seq Error
directiveRule
  where
    fieldRule :: p -> Field -> t Seq Error
fieldRule p
_ (Full.Field Maybe Name
_ Name
_ [Argument]
arguments [Directive]
_ SelectionSetOpt
_ Location
_) =
        Seq Error -> t Seq Error
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Seq Error -> t Seq Error) -> Seq Error -> t Seq Error
forall a b. (a -> b) -> a -> b
$ (Argument -> (Name, Location)) -> String -> [Argument] -> Seq Error
forall a. (a -> (Name, Location)) -> String -> [a] -> Seq Error
filterDuplicates Argument -> (Name, Location)
extract String
"argument" [Argument]
arguments
    directiveRule :: Directive -> t Seq Error
directiveRule (Full.Directive Name
_ [Argument]
arguments Location
_) =
        Seq Error -> t Seq Error
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Seq Error -> t Seq Error) -> Seq Error -> t Seq Error
forall a b. (a -> b) -> a -> b
$ (Argument -> (Name, Location)) -> String -> [Argument] -> Seq Error
forall a. (a -> (Name, Location)) -> String -> [a] -> Seq Error
filterDuplicates Argument -> (Name, Location)
extract String
"argument" [Argument]
arguments
    extract :: Argument -> (Name, Location)
extract (Full.Argument Name
argumentName Node Value
_ Location
location') = (Name
argumentName, Location
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 :: Rule m
uniqueDirectiveNamesRule = (DirectiveLocation -> [Directive] -> RuleT m) -> Rule m
forall (m :: * -> *).
(DirectiveLocation -> [Directive] -> RuleT m) -> Rule m
DirectivesRule
    ((DirectiveLocation -> [Directive] -> RuleT m) -> Rule m)
-> (DirectiveLocation -> [Directive] -> RuleT m) -> Rule m
forall a b. (a -> b) -> a -> b
$ ([Directive] -> RuleT m)
-> DirectiveLocation -> [Directive] -> RuleT m
forall a b. a -> b -> a
const (([Directive] -> RuleT m)
 -> DirectiveLocation -> [Directive] -> RuleT m)
-> ([Directive] -> RuleT m)
-> DirectiveLocation
-> [Directive]
-> RuleT m
forall a b. (a -> b) -> a -> b
$ Seq Error -> RuleT m
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Seq Error -> RuleT m)
-> ([Directive] -> Seq Error) -> [Directive] -> RuleT m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Directive -> (Name, Location))
-> String -> [Directive] -> Seq Error
forall a. (a -> (Name, Location)) -> String -> [a] -> Seq Error
filterDuplicates Directive -> (Name, Location)
extract String
"directive"
  where
    extract :: Directive -> (Name, Location)
extract (Full.Directive Name
directiveName [Argument]
_ Location
location') =
        (Name
directiveName, Location
location')

groupSorted :: forall a. (a -> Text) -> [a] -> [[a]]
groupSorted :: (a -> Name) -> [a] -> [[a]]
groupSorted a -> Name
getName = (a -> a -> Bool) -> [a] -> [[a]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy a -> a -> Bool
equalByName ([a] -> [[a]]) -> ([a] -> [a]) -> [a] -> [[a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Name) -> [a] -> [a]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn a -> Name
getName
  where
    equalByName :: a -> a -> Bool
equalByName a
lhs a
rhs = a -> Name
getName a
lhs Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== a -> Name
getName a
rhs

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

-- | 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 :: Rule m
uniqueVariableNamesRule = ([VariableDefinition] -> RuleT m) -> Rule m
forall (m :: * -> *). ([VariableDefinition] -> RuleT m) -> Rule m
VariablesRule
    (([VariableDefinition] -> RuleT m) -> Rule m)
-> ([VariableDefinition] -> RuleT m) -> Rule m
forall a b. (a -> b) -> a -> b
$ Seq Error -> RuleT m
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Seq Error -> RuleT m)
-> ([VariableDefinition] -> Seq Error)
-> [VariableDefinition]
-> RuleT m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VariableDefinition -> (Name, Location))
-> String -> [VariableDefinition] -> Seq Error
forall a. (a -> (Name, Location)) -> String -> [a] -> Seq Error
filterDuplicates VariableDefinition -> (Name, Location)
extract String
"variable"
  where
    extract :: VariableDefinition -> (Name, Location)
extract (Full.VariableDefinition Name
variableName Type
_ Maybe (Node ConstValue)
_ Location
location') =
        (Name
variableName, Location
location')

-- | Variables can only be input types. Objects, unions and interfaces cannot be
-- used as inputs.
variablesAreInputTypesRule :: forall m. Rule m
variablesAreInputTypesRule :: Rule m
variablesAreInputTypesRule = ([VariableDefinition] -> RuleT m) -> Rule m
forall (m :: * -> *). ([VariableDefinition] -> RuleT m) -> Rule m
VariablesRule
    (([VariableDefinition] -> RuleT m) -> Rule m)
-> ([VariableDefinition] -> RuleT m) -> Rule m
forall a b. (a -> b) -> a -> b
$ ((VariableDefinition -> RuleT m)
-> Seq VariableDefinition -> ReaderT (Validation m) Seq (Seq Error)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse VariableDefinition -> RuleT m
forall (m :: * -> *) (m :: * -> *).
(Monad m, Monoid (m Error)) =>
VariableDefinition -> ReaderT (Validation m) m Error
check (Seq VariableDefinition -> ReaderT (Validation m) Seq (Seq Error))
-> ([VariableDefinition] -> Seq VariableDefinition)
-> [VariableDefinition]
-> ReaderT (Validation m) Seq (Seq Error)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [VariableDefinition] -> Seq VariableDefinition
forall a. [a] -> Seq a
Seq.fromList) ([VariableDefinition] -> ReaderT (Validation m) Seq (Seq Error))
-> (Seq Error -> RuleT m) -> [VariableDefinition] -> RuleT m
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Seq Error -> RuleT m
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
  where
    check :: VariableDefinition -> ReaderT (Validation m) m Error
check (Full.VariableDefinition Name
name Type
typeName Maybe (Node ConstValue)
_ Location
location')
        = (Validation m -> HashMap Name (Type m))
-> ReaderT (Validation m) m (HashMap Name (Type m))
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks (Schema m -> HashMap Name (Type m)
forall (m :: * -> *). Schema m -> HashMap Name (Type m)
Schema.types (Schema m -> HashMap Name (Type m))
-> (Validation m -> Schema m)
-> Validation m
-> HashMap Name (Type m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validation m -> Schema m
forall (m :: * -> *). Validation m -> Schema m
schema)
        ReaderT (Validation m) m (HashMap Name (Type m))
-> (HashMap Name (Type m) -> ReaderT (Validation m) m Error)
-> ReaderT (Validation m) m Error
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m Error -> ReaderT (Validation m) m Error
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
        (m Error -> ReaderT (Validation m) m Error)
-> (HashMap Name (Type m) -> m Error)
-> HashMap Name (Type m)
-> ReaderT (Validation m) m Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m Error -> (Type -> m Error) -> Maybe Type -> m Error
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Name -> Type -> Location -> m Error
forall (f :: * -> *).
Applicative f =>
Name -> Type -> Location -> f Error
makeError Name
name Type
typeName Location
location') (m Error -> Type -> m Error
forall a b. a -> b -> a
const m Error
forall a. Monoid a => a
mempty)
        (Maybe Type -> m Error)
-> (HashMap Name (Type m) -> Maybe Type)
-> HashMap Name (Type m)
-> m Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> HashMap Name (Type m) -> Maybe Type
forall (m :: * -> *). Type -> HashMap Name (Type m) -> Maybe Type
Type.lookupInputType Type
typeName
    makeError :: Name -> Type -> Location -> f Error
makeError Name
name Type
typeName Location
location' = Error -> f Error
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Error -> f Error) -> Error -> f Error
forall a b. (a -> b) -> a -> b
$ Error :: String -> [Location] -> Error
Error
        { message :: String
message = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ String
"Variable \"$"
            , Name -> String
Text.unpack Name
name
            , String
"\" cannot be non-input type \""
            , Name -> String
Text.unpack (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ Type -> Name
getTypeName Type
typeName
            , String
"\"."
            ]
        , locations :: [Location]
locations = [Location
location']
        }
    getTypeName :: Type -> Name
getTypeName (Full.TypeNamed Name
name) = Name
name
    getTypeName (Full.TypeList Type
name) = Type -> Name
getTypeName Type
name
    getTypeName (Full.TypeNonNull (Full.NonNullTypeNamed Name
nonNull)) = Name
nonNull
    getTypeName (Full.TypeNonNull (Full.NonNullTypeList Type
nonNull)) =
        Type -> Name
getTypeName Type
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 :: Rule m
noUndefinedVariablesRule =
    UsageDifference -> (Maybe Name -> Name -> String) -> Rule m
forall (m :: * -> *).
UsageDifference -> (Maybe Name -> Name -> String) -> Rule m
variableUsageDifference (UsageDifference -> UsageDifference
forall a b c. (a -> b -> c) -> b -> a -> c
flip UsageDifference
forall k v w.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k w -> HashMap k v
HashMap.difference) Maybe Name -> Name -> String
errorMessage
  where
    errorMessage :: Maybe Name -> Name -> String
errorMessage Maybe Name
Nothing Name
variableName = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Variable \"$"
        , Name -> String
Text.unpack Name
variableName
        , String
"\" is not defined."
        ]
    errorMessage (Just Name
operationName) Name
variableName = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Variable \"$"
        , Name -> String
Text.unpack Name
variableName
        , String
"\" is not defined by operation \""
        , Name -> String
Text.unpack Name
operationName
        , String
"\"."
        ]

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 :: UsageDifference -> (Maybe Name -> Name -> String) -> Rule m
variableUsageDifference UsageDifference
difference Maybe Name -> Name -> String
errorMessage = (OperationDefinition -> RuleT m) -> Rule m
forall (m :: * -> *). (OperationDefinition -> RuleT m) -> Rule m
OperationDefinitionRule ((OperationDefinition -> RuleT m) -> Rule m)
-> (OperationDefinition -> RuleT m) -> Rule m
forall a b. (a -> b) -> a -> b
$ \case
    Full.SelectionSet SelectionSet
_ Location
_ -> Seq Error -> RuleT m
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Seq Error
forall a. Monoid a => a
mempty
    Full.OperationDefinition OperationType
_ Maybe Name
operationName [VariableDefinition]
variables [Directive]
_ SelectionSet
selections Location
_ ->
        let variableNames :: HashMap Name [Location]
variableNames = [(Name, [Location])] -> HashMap Name [Location]
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList ([(Name, [Location])] -> HashMap Name [Location])
-> [(Name, [Location])] -> HashMap Name [Location]
forall a b. (a -> b) -> a -> b
$ VariableDefinition -> (Name, [Location])
getVariableName (VariableDefinition -> (Name, [Location]))
-> [VariableDefinition] -> [(Name, [Location])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [VariableDefinition]
variables
         in (Seq (Name, [Location]) -> Seq Error)
-> ReaderT (Validation m) Seq (Name, [Location]) -> RuleT m
forall (m :: * -> *) a (n :: * -> *) b r.
(m a -> n b) -> ReaderT r m a -> ReaderT r n b
mapReaderT (Maybe Name
-> HashMap Name [Location] -> Seq (Name, [Location]) -> Seq Error
forall (t :: * -> *).
Foldable t =>
Maybe Name
-> HashMap Name [Location] -> t (Name, [Location]) -> Seq Error
readerMapper Maybe Name
operationName HashMap Name [Location]
variableNames)
            (ReaderT (Validation m) Seq (Name, [Location]) -> RuleT m)
-> ReaderT (Validation m) Seq (Name, [Location]) -> RuleT m
forall a b. (a -> b) -> a -> b
$ (StateT
   (HashSet Name) (ReaderT (Validation m) Seq) (Name, [Location])
 -> HashSet Name -> ReaderT (Validation m) Seq (Name, [Location]))
-> HashSet Name
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (Name, [Location])
-> ReaderT (Validation m) Seq (Name, [Location])
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT
  (HashSet Name) (ReaderT (Validation m) Seq) (Name, [Location])
-> HashSet Name -> ReaderT (Validation m) Seq (Name, [Location])
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT HashSet Name
forall a. HashSet a
HashSet.empty
            (StateT
   (HashSet Name) (ReaderT (Validation m) Seq) (Name, [Location])
 -> ReaderT (Validation m) Seq (Name, [Location]))
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (Name, [Location])
-> ReaderT (Validation m) Seq (Name, [Location])
forall a b. (a -> b) -> a -> b
$ SelectionSetOpt
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (Name, [Location])
forall (t :: * -> *).
Foldable t =>
t Selection
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (Name, [Location])
filterSelections'
            (SelectionSetOpt
 -> StateT
      (HashSet Name) (ReaderT (Validation m) Seq) (Name, [Location]))
-> SelectionSetOpt
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (Name, [Location])
forall a b. (a -> b) -> a -> b
$ SelectionSet -> SelectionSetOpt
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList SelectionSet
selections
  where
    readerMapper :: Maybe Name
-> HashMap Name [Location] -> t (Name, [Location]) -> Seq Error
readerMapper Maybe Name
operationName HashMap Name [Location]
variableNames' = [Error] -> Seq Error
forall a. [a] -> Seq a
Seq.fromList
        ([Error] -> Seq Error)
-> (t (Name, [Location]) -> [Error])
-> t (Name, [Location])
-> Seq Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Name, [Location]) -> Error) -> [(Name, [Location])] -> [Error]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe Name -> (Name, [Location]) -> Error
makeError Maybe Name
operationName)
        ([(Name, [Location])] -> [Error])
-> (t (Name, [Location]) -> [(Name, [Location])])
-> t (Name, [Location])
-> [Error]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap Name [Location] -> [(Name, [Location])]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList
        (HashMap Name [Location] -> [(Name, [Location])])
-> (t (Name, [Location]) -> HashMap Name [Location])
-> t (Name, [Location])
-> [(Name, [Location])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UsageDifference
difference HashMap Name [Location]
variableNames'
        (HashMap Name [Location] -> HashMap Name [Location])
-> (t (Name, [Location]) -> HashMap Name [Location])
-> t (Name, [Location])
-> HashMap Name [Location]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Location] -> [Location] -> [Location])
-> [(Name, [Location])] -> HashMap Name [Location]
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> [(k, v)] -> HashMap k v
HashMap.fromListWith [Location] -> [Location] -> [Location]
forall a. [a] -> [a] -> [a]
(++)
        ([(Name, [Location])] -> HashMap Name [Location])
-> (t (Name, [Location]) -> [(Name, [Location])])
-> t (Name, [Location])
-> HashMap Name [Location]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t (Name, [Location]) -> [(Name, [Location])]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
    getVariableName :: VariableDefinition -> (Name, [Location])
getVariableName (Full.VariableDefinition Name
variableName Type
_ Maybe (Node ConstValue)
_ Location
location') =
        (Name
variableName, [Location
location'])
    filterSelections' :: Foldable t
        => t Full.Selection
        -> ValidationState m (Full.Name, [Full.Location])
    filterSelections' :: t Selection
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (Name, [Location])
filterSelections' = (Selection
 -> StateT
      (HashSet Name) (ReaderT (Validation m) Seq) (Name, [Location]))
-> t Selection
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (Name, [Location])
forall (t :: * -> *) a (m :: * -> *).
Foldable t =>
(Selection -> ValidationState m a)
-> t Selection -> ValidationState m a
filterSelections Selection
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (Name, [Location])
variableFilter
    variableFilter :: Full.Selection -> ValidationState m (Full.Name, [Full.Location])
    variableFilter :: Selection
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (Name, [Location])
variableFilter (Full.InlineFragmentSelection InlineFragment
inline)
        | Full.InlineFragment Maybe Name
_ [Directive]
directives' SelectionSet
_ Location
_ <- InlineFragment
inline =
            ReaderT (Validation m) Seq (Name, [Location])
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (Name, [Location])
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT (Validation m) Seq (Name, [Location])
 -> StateT
      (HashSet Name) (ReaderT (Validation m) Seq) (Name, [Location]))
-> ReaderT (Validation m) Seq (Name, [Location])
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (Name, [Location])
forall a b. (a -> b) -> a -> b
$ Seq (Name, [Location])
-> ReaderT (Validation m) Seq (Name, [Location])
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Seq (Name, [Location])
 -> ReaderT (Validation m) Seq (Name, [Location]))
-> Seq (Name, [Location])
-> ReaderT (Validation m) Seq (Name, [Location])
forall a b. (a -> b) -> a -> b
$ [Directive] -> Seq (Name, [Location])
mapDirectives [Directive]
directives'
    variableFilter (Full.FieldSelection Field
fieldSelection)
        | Full.Field Maybe Name
_ Name
_ [Argument]
arguments [Directive]
directives' SelectionSetOpt
_ Location
_ <- Field
fieldSelection =
            ReaderT (Validation m) Seq (Name, [Location])
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (Name, [Location])
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT (Validation m) Seq (Name, [Location])
 -> StateT
      (HashSet Name) (ReaderT (Validation m) Seq) (Name, [Location]))
-> ReaderT (Validation m) Seq (Name, [Location])
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (Name, [Location])
forall a b. (a -> b) -> a -> b
$ Seq (Name, [Location])
-> ReaderT (Validation m) Seq (Name, [Location])
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Seq (Name, [Location])
 -> ReaderT (Validation m) Seq (Name, [Location]))
-> Seq (Name, [Location])
-> ReaderT (Validation m) Seq (Name, [Location])
forall a b. (a -> b) -> a -> b
$ [Argument] -> Seq (Name, [Location])
mapArguments [Argument]
arguments Seq (Name, [Location])
-> Seq (Name, [Location]) -> Seq (Name, [Location])
forall a. Semigroup a => a -> a -> a
<> [Directive] -> Seq (Name, [Location])
mapDirectives [Directive]
directives'
    variableFilter (Full.FragmentSpreadSelection FragmentSpread
spread)
        | Full.FragmentSpread Name
fragmentName [Directive]
_ Location
_ <- FragmentSpread
spread = do
            Maybe FragmentDefinition
nonVisitedFragmentDefinition <- Name -> ValidationState m (Maybe FragmentDefinition)
forall (m :: * -> *).
Name -> ValidationState m (Maybe FragmentDefinition)
visitFragmentDefinition Name
fragmentName
            case Maybe FragmentDefinition
nonVisitedFragmentDefinition of
                Just FragmentDefinition
fragmentDefinition -> FragmentDefinition
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (Name, [Location])
diveIntoSpread FragmentDefinition
fragmentDefinition
                Maybe FragmentDefinition
_ -> ReaderT (Validation m) Seq (Name, [Location])
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (Name, [Location])
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT (Validation m) Seq (Name, [Location])
 -> StateT
      (HashSet Name) (ReaderT (Validation m) Seq) (Name, [Location]))
-> ReaderT (Validation m) Seq (Name, [Location])
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (Name, [Location])
forall a b. (a -> b) -> a -> b
$ Seq (Name, [Location])
-> ReaderT (Validation m) Seq (Name, [Location])
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Seq (Name, [Location])
forall a. Monoid a => a
mempty
    diveIntoSpread :: FragmentDefinition
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (Name, [Location])
diveIntoSpread (Full.FragmentDefinition Name
_ Name
_ [Directive]
directives' SelectionSet
selections Location
_)
        = SelectionSet
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (Name, [Location])
forall (t :: * -> *).
Foldable t =>
t Selection
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (Name, [Location])
filterSelections' SelectionSet
selections
        StateT
  (HashSet Name) (ReaderT (Validation m) Seq) (Name, [Location])
-> ((Name, [Location])
    -> StateT
         (HashSet Name) (ReaderT (Validation m) Seq) (Name, [Location]))
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (Name, [Location])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ReaderT (Validation m) Seq (Name, [Location])
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (Name, [Location])
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT (Validation m) Seq (Name, [Location])
 -> StateT
      (HashSet Name) (ReaderT (Validation m) Seq) (Name, [Location]))
-> ((Name, [Location])
    -> ReaderT (Validation m) Seq (Name, [Location]))
-> (Name, [Location])
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (Name, [Location])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Seq (Name, [Location]) -> Seq (Name, [Location]))
-> ReaderT (Validation m) Seq (Name, [Location])
-> ReaderT (Validation m) Seq (Name, [Location])
forall (m :: * -> *) a (n :: * -> *) b r.
(m a -> n b) -> ReaderT r m a -> ReaderT r n b
mapReaderT (Seq (Name, [Location])
-> Seq (Name, [Location]) -> Seq (Name, [Location])
forall a. Semigroup a => a -> a -> a
<> [Directive] -> Seq (Name, [Location])
mapDirectives [Directive]
directives') (ReaderT (Validation m) Seq (Name, [Location])
 -> ReaderT (Validation m) Seq (Name, [Location]))
-> ((Name, [Location])
    -> ReaderT (Validation m) Seq (Name, [Location]))
-> (Name, [Location])
-> ReaderT (Validation m) Seq (Name, [Location])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, [Location]) -> ReaderT (Validation m) Seq (Name, [Location])
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    findDirectiveVariables :: Directive -> Seq (Name, [Location])
findDirectiveVariables (Full.Directive Name
_ [Argument]
arguments Location
_) = [Argument] -> Seq (Name, [Location])
mapArguments [Argument]
arguments
    mapArguments :: [Argument] -> Seq (Name, [Location])
mapArguments = [(Name, [Location])] -> Seq (Name, [Location])
forall a. [a] -> Seq a
Seq.fromList ([(Name, [Location])] -> Seq (Name, [Location]))
-> ([Argument] -> [(Name, [Location])])
-> [Argument]
-> Seq (Name, [Location])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Argument -> Maybe (Name, [Location]))
-> [Argument] -> [(Name, [Location])]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Argument -> Maybe (Name, [Location])
findArgumentVariables
    mapDirectives :: [Directive] -> Seq (Name, [Location])
mapDirectives = (Directive -> Seq (Name, [Location]))
-> [Directive] -> Seq (Name, [Location])
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Directive -> Seq (Name, [Location])
findDirectiveVariables
    findArgumentVariables :: Argument -> Maybe (Name, [Location])
findArgumentVariables (Full.Argument Name
_ Full.Node{ $sel:node:Node :: forall a. Node a -> a
node = Full.Variable Name
value', Location
$sel:location:Node :: forall a. Node a -> Location
location :: Location
..} Location
_) =
        (Name, [Location]) -> Maybe (Name, [Location])
forall a. a -> Maybe a
Just (Name
value', [Location
location])
    findArgumentVariables Argument
_ = Maybe (Name, [Location])
forall a. Maybe a
Nothing
    makeError :: Maybe Name -> (Name, [Location]) -> Error
makeError Maybe Name
operationName (Name
variableName, [Location]
locations') = Error :: String -> [Location] -> Error
Error
        { message :: String
message = Maybe Name -> Name -> String
errorMessage Maybe Name
operationName Name
variableName
        , locations :: [Location]
locations = [Location]
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 :: Rule m
noUnusedVariablesRule = UsageDifference -> (Maybe Name -> Name -> String) -> Rule m
forall (m :: * -> *).
UsageDifference -> (Maybe Name -> Name -> String) -> Rule m
variableUsageDifference UsageDifference
forall k v w.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k w -> HashMap k v
HashMap.difference Maybe Name -> Name -> String
errorMessage
  where
    errorMessage :: Maybe Name -> Name -> String
errorMessage Maybe Name
Nothing Name
variableName = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Variable \"$"
        , Name -> String
Text.unpack Name
variableName
        , String
"\" is never used."
        ]
    errorMessage (Just Name
operationName) Name
variableName = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Variable \"$"
        , Name -> String
Text.unpack Name
variableName
        , String
"\" is never used in operation \""
        , Name -> String
Text.unpack Name
operationName
        , String
"\"."
        ]

-- | 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 :: Rule m
uniqueInputFieldNamesRule =
    (Maybe Type -> Node Value -> RuleT m)
-> (Maybe Type -> Node ConstValue -> RuleT m) -> Rule m
forall (m :: * -> *).
(Maybe Type -> Node Value -> RuleT m)
-> (Maybe Type -> Node ConstValue -> RuleT m) -> Rule m
ValueRule ((Node Value -> RuleT m) -> Maybe Type -> Node Value -> RuleT m
forall a b. a -> b -> a
const ((Node Value -> RuleT m) -> Maybe Type -> Node Value -> RuleT m)
-> (Node Value -> RuleT m) -> Maybe Type -> Node Value -> RuleT m
forall a b. (a -> b) -> a -> b
$ Seq Error -> RuleT m
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Seq Error -> RuleT m)
-> (Node Value -> Seq Error) -> Node Value -> RuleT m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node Value -> Seq Error
go) ((Node ConstValue -> RuleT m)
-> Maybe Type -> Node ConstValue -> RuleT m
forall a b. a -> b -> a
const ((Node ConstValue -> RuleT m)
 -> Maybe Type -> Node ConstValue -> RuleT m)
-> (Node ConstValue -> RuleT m)
-> Maybe Type
-> Node ConstValue
-> RuleT m
forall a b. (a -> b) -> a -> b
$ Seq Error -> RuleT m
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Seq Error -> RuleT m)
-> (Node ConstValue -> Seq Error) -> Node ConstValue -> RuleT m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node ConstValue -> Seq Error
constGo)
  where
    go :: Node Value -> Seq Error
go (Full.Node (Full.Object [ObjectField Value]
fields) Location
_) = [ObjectField Value] -> Seq Error
forall a. [ObjectField a] -> Seq Error
filterFieldDuplicates [ObjectField Value]
fields
    go Node Value
_ = Seq Error
forall a. Monoid a => a
mempty
    filterFieldDuplicates :: [ObjectField a] -> Seq Error
filterFieldDuplicates = (ObjectField a -> (Name, Location))
-> String -> [ObjectField a] -> Seq Error
forall a. (a -> (Name, Location)) -> String -> [a] -> Seq Error
filterDuplicates ObjectField a -> (Name, Location)
forall a. ObjectField a -> (Name, Location)
getFieldName String
"input field"
    getFieldName :: ObjectField a -> (Name, Location)
getFieldName (Full.ObjectField Name
fieldName Node a
_ Location
location') = (Name
fieldName, Location
location')
    constGo :: Node ConstValue -> Seq Error
constGo (Full.Node (Full.ConstObject [ObjectField ConstValue]
fields) Location
_) = [ObjectField ConstValue] -> Seq Error
forall a. [ObjectField a] -> Seq Error
filterFieldDuplicates [ObjectField ConstValue]
fields
    constGo Node ConstValue
_ = Seq Error
forall a. Monoid a => a
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 :: Rule m
fieldsOnCorrectTypeRule = (Maybe (Type m) -> Field -> RuleT m) -> Rule m
forall (m :: * -> *).
(Maybe (Type m) -> Field -> RuleT m) -> Rule m
FieldRule Maybe (Type m) -> Field -> RuleT m
forall (t :: (* -> *) -> * -> *) (m :: * -> *) (m :: * -> *).
(MonadTrans t, Monad m, Monoid (m Error), Applicative (t m)) =>
Maybe (Type m) -> Field -> t m Error
fieldRule
  where
    fieldRule :: Maybe (Type m) -> Field -> t m Error
fieldRule Maybe (Type m)
parentType (Full.Field Maybe Name
_ Name
fieldName [Argument]
_ [Directive]
_ SelectionSetOpt
_ Location
location')
        | Just Type m
objectType <- Maybe (Type m)
parentType
        , Maybe (Field m)
Nothing <- Name -> Type m -> Maybe (Field m)
forall (a :: * -> *). Name -> Type a -> Maybe (Field a)
Type.lookupTypeField Name
fieldName Type m
objectType
        , Just Name
typeName <- Type m -> Maybe Name
forall (m :: * -> *). Type m -> Maybe Name
typeNameIfComposite Type m
objectType = Error -> t m Error
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Error -> t m Error) -> Error -> t m Error
forall a b. (a -> b) -> a -> b
$ Error :: String -> [Location] -> Error
Error
            { message :: String
message = Name -> Name -> String
errorMessage Name
fieldName Name
typeName
            , locations :: [Location]
locations = [Location
location']
            }
        | Bool
otherwise = m Error -> t m Error
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Error
forall a. Monoid a => a
mempty
    errorMessage :: Name -> Name -> String
errorMessage Name
fieldName Name
typeName = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Cannot query field \""
        , Name -> String
Text.unpack Name
fieldName
        , String
"\" on type \""
        , Name -> String
Text.unpack Name
typeName
        , String
"\"."
        ]

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

typeNameIfComposite :: forall m. Out.Type m -> Maybe Full.Name
typeNameIfComposite :: Type m -> Maybe Name
typeNameIfComposite = (CompositeType m -> Name) -> Maybe (CompositeType m) -> Maybe Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CompositeType m -> Name
forall (m :: * -> *). CompositeType m -> Name
compositeTypeName (Maybe (CompositeType m) -> Maybe Name)
-> (Type m -> Maybe (CompositeType m)) -> Type m -> Maybe Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type m -> Maybe (CompositeType m)
forall (a :: * -> *). Type a -> Maybe (CompositeType a)
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 :: Rule m
scalarLeafsRule = (Maybe (Type m) -> Field -> RuleT m) -> Rule m
forall (m :: * -> *).
(Maybe (Type m) -> Field -> RuleT m) -> Rule m
FieldRule Maybe (Type m) -> Field -> RuleT m
forall (t :: (* -> *) -> * -> *) (m :: * -> *) (m :: * -> *).
(MonadTrans t, Monad m, Monoid (m Error)) =>
Maybe (Type m) -> Field -> t m Error
fieldRule
  where
    fieldRule :: Maybe (Type m) -> Field -> t m Error
fieldRule Maybe (Type m)
parentType selectionField :: Field
selectionField@(Full.Field Maybe Name
_ Name
fieldName [Argument]
_ [Directive]
_ SelectionSetOpt
_ Location
_)
        | Just Type m
objectType <- Maybe (Type m)
parentType
        , Just Field m
field <- Name -> Type m -> Maybe (Field m)
forall (a :: * -> *). Name -> Type a -> Maybe (Field a)
Type.lookupTypeField Name
fieldName Type m
objectType =
            let Out.Field Maybe Name
_ Type m
fieldType Arguments
_ = Field m
field
             in m Error -> t m Error
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Error -> t m Error) -> m Error -> t m Error
forall a b. (a -> b) -> a -> b
$ Type m -> Field -> m Error
forall (f :: * -> *) (m :: * -> *).
(Applicative f, Monoid (f Error)) =>
Type m -> Field -> f Error
check Type m
fieldType Field
selectionField
        | Bool
otherwise = m Error -> t m Error
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Error
forall a. Monoid a => a
mempty
    check :: Type m -> Field -> f Error
check (Out.ObjectBaseType (Out.ObjectType Name
typeName Maybe Name
_ [InterfaceType m]
_ HashMap Name (Resolver m)
_)) =
        Name -> Field -> f Error
forall (f :: * -> *).
(Applicative f, Monoid (f Error)) =>
Name -> Field -> f Error
checkNotEmpty Name
typeName
    check (Out.InterfaceBaseType (Out.InterfaceType Name
typeName Maybe Name
_ [InterfaceType m]
_ HashMap Name (Field m)
_)) =
        Name -> Field -> f Error
forall (f :: * -> *).
(Applicative f, Monoid (f Error)) =>
Name -> Field -> f Error
checkNotEmpty Name
typeName
    check (Out.UnionBaseType (Out.UnionType Name
typeName Maybe Name
_ [ObjectType m]
_)) =
        Name -> Field -> f Error
forall (f :: * -> *).
(Applicative f, Monoid (f Error)) =>
Name -> Field -> f Error
checkNotEmpty Name
typeName
    check (Out.ScalarBaseType (Definition.ScalarType Name
typeName Maybe Name
_)) =
        Name -> Field -> f Error
forall (f :: * -> *).
(Monoid (f Error), Applicative f) =>
Name -> Field -> f Error
checkEmpty Name
typeName
    check (Out.EnumBaseType (Definition.EnumType Name
typeName Maybe Name
_ HashMap Name EnumValue
_)) =
        Name -> Field -> f Error
forall (f :: * -> *).
(Monoid (f Error), Applicative f) =>
Name -> Field -> f Error
checkEmpty Name
typeName
    check (Out.ListBaseType Type m
wrappedType) = Type m -> Field -> f Error
check Type m
wrappedType
    checkNotEmpty :: Name -> Field -> f Error
checkNotEmpty Name
typeName (Full.Field Maybe Name
_ Name
fieldName [Argument]
_ [Directive]
_ [] Location
location') =
        let fieldName' :: String
fieldName' = Name -> String
Text.unpack Name
fieldName
         in Location -> String -> f Error
forall (f :: * -> *).
Applicative f =>
Location -> String -> f Error
makeError Location
location' (String -> f Error) -> String -> f Error
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ String
"Field \""
            , String
fieldName'
            , String
"\" of type \""
            , Name -> String
Text.unpack Name
typeName
            , String
"\" must have a selection of subfields. Did you mean \""
            , String
fieldName'
            , String
" { ... }\"?"
            ]
    checkNotEmpty Name
_ Field
_ = f Error
forall a. Monoid a => a
mempty
    checkEmpty :: Name -> Field -> f Error
checkEmpty Name
_ (Full.Field Maybe Name
_ Name
_ [Argument]
_ [Directive]
_ [] Location
_) = f Error
forall a. Monoid a => a
mempty
    checkEmpty Name
typeName Field
field' =
        let Full.Field Maybe Name
_ Name
fieldName [Argument]
_ [Directive]
_ SelectionSetOpt
_ Location
location' = Field
field'
         in Location -> String -> f Error
forall (f :: * -> *).
Applicative f =>
Location -> String -> f Error
makeError Location
location' (String -> f Error) -> String -> f Error
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ String
"Field \""
            , Name -> String
Text.unpack Name
fieldName
            , String
"\" must not have a selection since type \""
            , Name -> String
Text.unpack Name
typeName
            , String
"\" has no subfields."
            ]
    makeError :: Location -> String -> f Error
makeError Location
location' String
errorMessage = Error -> f Error
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Error -> f Error) -> Error -> f Error
forall a b. (a -> b) -> a -> b
$ Error :: String -> [Location] -> Error
Error
        { message :: String
message = String
errorMessage
        , locations :: [Location]
locations = [Location
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 :: Rule m
knownArgumentNamesRule = (Maybe (Type m) -> Field -> RuleT m)
-> (Directive -> RuleT m) -> Rule m
forall (m :: * -> *).
(Maybe (Type m) -> Field -> RuleT m)
-> (Directive -> RuleT m) -> Rule m
ArgumentsRule Maybe (Type m) -> Field -> RuleT m
forall (t :: (* -> *) -> * -> *) (m :: * -> *).
MonadTrans t =>
Maybe (Type m) -> Field -> t Seq Error
fieldRule Directive -> RuleT m
forall (m :: * -> *). Directive -> ReaderT (Validation m) Seq Error
directiveRule
  where
    fieldRule :: Maybe (Type m) -> Field -> t Seq Error
fieldRule (Just Type m
objectType) (Full.Field Maybe Name
_ Name
fieldName [Argument]
arguments  [Directive]
_ SelectionSetOpt
_ Location
_)
        | Just Field m
typeField <- Name -> Type m -> Maybe (Field m)
forall (a :: * -> *). Name -> Type a -> Maybe (Field a)
Type.lookupTypeField Name
fieldName Type m
objectType
        , Just Name
typeName <- Type m -> Maybe Name
forall (m :: * -> *). Type m -> Maybe Name
typeNameIfComposite Type m
objectType =
            Seq Error -> t Seq Error
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Seq Error -> t Seq Error) -> Seq Error -> t Seq Error
forall a b. (a -> b) -> a -> b
$ (Argument -> Seq Error -> Seq Error)
-> Seq Error -> [Argument] -> Seq Error
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Name -> Name -> Field m -> Argument -> Seq Error -> Seq Error
forall (m :: * -> *).
Name -> Name -> Field m -> Argument -> Seq Error -> Seq Error
go Name
typeName Name
fieldName Field m
typeField) Seq Error
forall a. Seq a
Seq.empty [Argument]
arguments
    fieldRule Maybe (Type m)
_ Field
_ = Seq Error -> t Seq Error
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Seq Error
forall a. Monoid a => a
mempty
    go :: Name -> Name -> Field m -> Argument -> Seq Error -> Seq Error
go Name
typeName Name
fieldName Field m
fieldDefinition (Full.Argument Name
argumentName Node Value
_ Location
location') Seq Error
errors
        | Out.Field Maybe Name
_ Type m
_ Arguments
definitions <- Field m
fieldDefinition
        , Just Argument
_ <- Name -> Arguments -> Maybe Argument
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
argumentName Arguments
definitions = Seq Error
errors
        | Bool
otherwise = Seq Error
errors Seq Error -> Error -> Seq Error
forall a. Seq a -> a -> Seq a
|> Error :: String -> [Location] -> Error
Error
            { message :: String
message = Name -> Name -> Name -> String
fieldMessage Name
argumentName Name
fieldName Name
typeName
            , locations :: [Location]
locations = [Location
location']
            }
    fieldMessage :: Name -> Name -> Name -> String
fieldMessage Name
argumentName Name
fieldName Name
typeName = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Unknown argument \""
        , Name -> String
Text.unpack Name
argumentName
        , String
"\" on field \""
        , Name -> String
Text.unpack Name
typeName
        , String
"."
        , Name -> String
Text.unpack Name
fieldName
        , String
"\"."
        ]
    directiveRule :: Directive -> ReaderT (Validation m) Seq Error
directiveRule (Full.Directive Name
directiveName [Argument]
arguments Location
_) = do
        Maybe Directive
available <- (Validation m -> Maybe Directive)
-> ReaderT (Validation m) Seq (Maybe Directive)
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks ((Validation m -> Maybe Directive)
 -> ReaderT (Validation m) Seq (Maybe Directive))
-> (Validation m -> Maybe Directive)
-> ReaderT (Validation m) Seq (Maybe Directive)
forall a b. (a -> b) -> a -> b
$ Name -> HashMap Name Directive -> Maybe Directive
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
directiveName
            (HashMap Name Directive -> Maybe Directive)
-> (Validation m -> HashMap Name Directive)
-> Validation m
-> Maybe Directive
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Schema m -> HashMap Name Directive
forall (m :: * -> *). Schema m -> HashMap Name Directive
Schema.directives (Schema m -> HashMap Name Directive)
-> (Validation m -> Schema m)
-> Validation m
-> HashMap Name Directive
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validation m -> Schema m
forall (m :: * -> *). Validation m -> Schema m
schema
        Full.Argument Name
argumentName Node Value
_ Location
location' <- Seq Argument -> ReaderT (Validation m) Seq Argument
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Seq Argument -> ReaderT (Validation m) Seq Argument)
-> Seq Argument -> ReaderT (Validation m) Seq Argument
forall a b. (a -> b) -> a -> b
$ [Argument] -> Seq Argument
forall a. [a] -> Seq a
Seq.fromList [Argument]
arguments
        case Maybe Directive
available of
            Just (Schema.Directive Maybe Name
_ [DirectiveLocation]
_ Arguments
definitions)
                | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Name -> Arguments -> Bool
forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
HashMap.member Name
argumentName Arguments
definitions ->
                    Error -> ReaderT (Validation m) Seq Error
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Error -> ReaderT (Validation m) Seq Error)
-> Error -> ReaderT (Validation m) Seq Error
forall a b. (a -> b) -> a -> b
$ Name -> Name -> Location -> Error
makeError Name
argumentName Name
directiveName Location
location'
            Maybe Directive
_ -> Seq Error -> ReaderT (Validation m) Seq Error
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Seq Error
forall a. Monoid a => a
mempty
    makeError :: Name -> Name -> Location -> Error
makeError Name
argumentName Name
directiveName Location
location' = Error :: String -> [Location] -> Error
Error
        { message :: String
message = Name -> Name -> String
directiveMessage Name
argumentName Name
directiveName
        , locations :: [Location]
locations = [Location
location']
        }
    directiveMessage :: Name -> Name -> String
directiveMessage Name
argumentName Name
directiveName = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Unknown argument \""
        , Name -> String
Text.unpack Name
argumentName
        , String
"\" on directive \"@"
        , Name -> String
Text.unpack Name
directiveName
        , String
"\"."
        ]

-- | 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 :: Rule m
knownDirectiveNamesRule = (DirectiveLocation -> [Directive] -> RuleT m) -> Rule m
forall (m :: * -> *).
(DirectiveLocation -> [Directive] -> RuleT m) -> Rule m
DirectivesRule ((DirectiveLocation -> [Directive] -> RuleT m) -> Rule m)
-> (DirectiveLocation -> [Directive] -> RuleT m) -> Rule m
forall a b. (a -> b) -> a -> b
$ ([Directive] -> RuleT m)
-> DirectiveLocation -> [Directive] -> RuleT m
forall a b. a -> b -> a
const (([Directive] -> RuleT m)
 -> DirectiveLocation -> [Directive] -> RuleT m)
-> ([Directive] -> RuleT m)
-> DirectiveLocation
-> [Directive]
-> RuleT m
forall a b. (a -> b) -> a -> b
$ \[Directive]
directives' -> do
    HashMap Name Directive
definitions' <- (Validation m -> HashMap Name Directive)
-> ReaderT (Validation m) Seq (HashMap Name Directive)
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks ((Validation m -> HashMap Name Directive)
 -> ReaderT (Validation m) Seq (HashMap Name Directive))
-> (Validation m -> HashMap Name Directive)
-> ReaderT (Validation m) Seq (HashMap Name Directive)
forall a b. (a -> b) -> a -> b
$ Schema m -> HashMap Name Directive
forall (m :: * -> *). Schema m -> HashMap Name Directive
Schema.directives (Schema m -> HashMap Name Directive)
-> (Validation m -> Schema m)
-> Validation m
-> HashMap Name Directive
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validation m -> Schema m
forall (m :: * -> *). Validation m -> Schema m
schema
    let directiveSet :: HashSet Name
directiveSet = [Name] -> HashSet Name
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HashSet.fromList ([Name] -> HashSet Name) -> [Name] -> HashSet Name
forall a b. (a -> b) -> a -> b
$ (Directive -> Name) -> [Directive] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Directive -> Name
directiveName [Directive]
directives'
    let definitionSet :: HashSet Name
definitionSet = [Name] -> HashSet Name
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HashSet.fromList ([Name] -> HashSet Name) -> [Name] -> HashSet Name
forall a b. (a -> b) -> a -> b
$ HashMap Name Directive -> [Name]
forall k v. HashMap k v -> [k]
HashMap.keys HashMap Name Directive
definitions'
    let difference :: HashSet Name
difference = HashSet Name -> HashSet Name -> HashSet Name
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
HashSet.difference HashSet Name
directiveSet HashSet Name
definitionSet
    let undefined' :: [Directive]
undefined' = (Directive -> Bool) -> [Directive] -> [Directive]
forall a. (a -> Bool) -> [a] -> [a]
filter (HashSet Name -> Directive -> Bool
definitionFilter HashSet Name
difference) [Directive]
directives'
    Seq Error -> RuleT m
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Seq Error -> RuleT m) -> Seq Error -> RuleT m
forall a b. (a -> b) -> a -> b
$ [Error] -> Seq Error
forall a. [a] -> Seq a
Seq.fromList ([Error] -> Seq Error) -> [Error] -> Seq Error
forall a b. (a -> b) -> a -> b
$ Directive -> Error
makeError (Directive -> Error) -> [Directive] -> [Error]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Directive]
undefined'
  where
    definitionFilter :: HashSet Name -> Directive -> Bool
definitionFilter HashSet Name
difference = (Name -> HashSet Name -> Bool) -> HashSet Name -> Name -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Name -> HashSet Name -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
HashSet.member HashSet Name
difference
        (Name -> Bool) -> (Directive -> Name) -> Directive -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Directive -> Name
directiveName
    directiveName :: Directive -> Name
directiveName (Full.Directive Name
directiveName' [Argument]
_ Location
_) = Name
directiveName'
    makeError :: Directive -> Error
makeError (Full.Directive Name
directiveName' [Argument]
_ Location
location') = Error :: String -> [Location] -> Error
Error
        { message :: String
message = Name -> String
errorMessage Name
directiveName'
        , locations :: [Location]
locations = [Location
location']
        }
    errorMessage :: Name -> String
errorMessage Name
directiveName' = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Unknown directive \"@"
        , Name -> String
Text.unpack Name
directiveName'
        , String
"\"."
        ]

-- | 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 :: Rule m
knownInputFieldNamesRule = (Maybe Type -> Node Value -> RuleT m)
-> (Maybe Type -> Node ConstValue -> RuleT m) -> Rule m
forall (m :: * -> *).
(Maybe Type -> Node Value -> RuleT m)
-> (Maybe Type -> Node ConstValue -> RuleT m) -> Rule m
ValueRule Maybe Type -> Node Value -> RuleT m
forall (t :: (* -> *) -> * -> *).
MonadTrans t =>
Maybe Type -> Node Value -> t Seq Error
go Maybe Type -> Node ConstValue -> RuleT m
forall (t :: (* -> *) -> * -> *).
MonadTrans t =>
Maybe Type -> Node ConstValue -> t Seq Error
constGo
  where
    go :: Maybe Type -> Node Value -> t Seq Error
go (Just Type
valueType) (Full.Node (Full.Object [ObjectField Value]
inputFields) Location
_)
        | In.InputObjectBaseType InputObjectType
objectType <- Type
valueType =
             Seq Error -> t Seq Error
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Seq Error -> t Seq Error) -> Seq Error -> t Seq Error
forall a b. (a -> b) -> a -> b
$ [Error] -> Seq Error
forall a. [a] -> Seq a
Seq.fromList ([Error] -> Seq Error) -> [Error] -> Seq Error
forall a b. (a -> b) -> a -> b
$ (ObjectField Value -> Maybe Error)
-> [ObjectField Value] -> [Error]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (InputObjectType -> ObjectField Value -> Maybe Error
forall a. InputObjectType -> ObjectField a -> Maybe Error
forEach InputObjectType
objectType) [ObjectField Value]
inputFields
    go Maybe Type
_ Node Value
_ = Seq Error -> t Seq Error
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Seq Error
forall a. Monoid a => a
mempty
    constGo :: Maybe Type -> Node ConstValue -> t Seq Error
constGo (Just Type
valueType) (Full.Node (Full.ConstObject [ObjectField ConstValue]
inputFields) Location
_)
        | In.InputObjectBaseType InputObjectType
objectType <- Type
valueType =
             Seq Error -> t Seq Error
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Seq Error -> t Seq Error) -> Seq Error -> t Seq Error
forall a b. (a -> b) -> a -> b
$ [Error] -> Seq Error
forall a. [a] -> Seq a
Seq.fromList ([Error] -> Seq Error) -> [Error] -> Seq Error
forall a b. (a -> b) -> a -> b
$ (ObjectField ConstValue -> Maybe Error)
-> [ObjectField ConstValue] -> [Error]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (InputObjectType -> ObjectField ConstValue -> Maybe Error
forall a. InputObjectType -> ObjectField a -> Maybe Error
forEach InputObjectType
objectType) [ObjectField ConstValue]
inputFields
    constGo  Maybe Type
_ Node ConstValue
_ = Seq Error -> t Seq Error
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Seq Error
forall a. Monoid a => a
mempty
    forEach :: InputObjectType -> ObjectField a -> Maybe Error
forEach InputObjectType
objectType (Full.ObjectField Name
inputFieldName Node a
_ Location
location')
        | In.InputObjectType Name
_ Maybe Name
_ HashMap Name InputField
fieldTypes <- InputObjectType
objectType
        , Just InputField
_ <- Name -> HashMap Name InputField -> Maybe InputField
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
inputFieldName HashMap Name InputField
fieldTypes = Maybe Error
forall a. Maybe a
Nothing
        | Bool
otherwise
        , In.InputObjectType Name
typeName Maybe Name
_ HashMap Name InputField
_ <- InputObjectType
objectType = Error -> Maybe Error
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Error -> Maybe Error) -> Error -> Maybe Error
forall a b. (a -> b) -> a -> b
$ Error :: String -> [Location] -> Error
Error
            { message :: String
message = Name -> Name -> String
errorMessage Name
inputFieldName Name
typeName
            , locations :: [Location]
locations = [Location
location']
            }
    errorMessage :: Name -> Name -> String
errorMessage Name
fieldName Name
typeName = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Field \""
        , Name -> String
Text.unpack Name
fieldName
        , String
"\" is not defined by type \""
        , Name -> String
Text.unpack Name
typeName
        , String
"\"."
        ]

-- | 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 :: Rule m
directivesInValidLocationsRule = (DirectiveLocation -> [Directive] -> RuleT m) -> Rule m
forall (m :: * -> *).
(DirectiveLocation -> [Directive] -> RuleT m) -> Rule m
DirectivesRule DirectiveLocation -> [Directive] -> RuleT m
forall (m :: * -> *).
DirectiveLocation
-> [Directive] -> ReaderT (Validation m) Seq Error
directivesRule
  where
    directivesRule :: DirectiveLocation
-> [Directive] -> ReaderT (Validation m) Seq Error
directivesRule DirectiveLocation
directiveLocation [Directive]
directives' = do
        Full.Directive Name
directiveName [Argument]
_ Location
location <- Seq Directive -> ReaderT (Validation m) Seq Directive
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Seq Directive -> ReaderT (Validation m) Seq Directive)
-> Seq Directive -> ReaderT (Validation m) Seq Directive
forall a b. (a -> b) -> a -> b
$ [Directive] -> Seq Directive
forall a. [a] -> Seq a
Seq.fromList [Directive]
directives'
        Maybe Directive
maybeDefinition <- (Validation m -> Maybe Directive)
-> ReaderT (Validation m) Seq (Maybe Directive)
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks
            ((Validation m -> Maybe Directive)
 -> ReaderT (Validation m) Seq (Maybe Directive))
-> (Validation m -> Maybe Directive)
-> ReaderT (Validation m) Seq (Maybe Directive)
forall a b. (a -> b) -> a -> b
$ Name -> HashMap Name Directive -> Maybe Directive
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
directiveName (HashMap Name Directive -> Maybe Directive)
-> (Validation m -> HashMap Name Directive)
-> Validation m
-> Maybe Directive
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Schema m -> HashMap Name Directive
forall (m :: * -> *). Schema m -> HashMap Name Directive
Schema.directives (Schema m -> HashMap Name Directive)
-> (Validation m -> Schema m)
-> Validation m
-> HashMap Name Directive
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validation m -> Schema m
forall (m :: * -> *). Validation m -> Schema m
schema
        case Maybe Directive
maybeDefinition of
            Just (Schema.Directive Maybe Name
_ [DirectiveLocation]
allowedLocations Arguments
_)
                | DirectiveLocation
directiveLocation DirectiveLocation -> [DirectiveLocation] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [DirectiveLocation]
allowedLocations -> Error -> ReaderT (Validation m) Seq Error
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Error -> ReaderT (Validation m) Seq Error)
-> Error -> ReaderT (Validation m) Seq Error
forall a b. (a -> b) -> a -> b
$ Error :: String -> [Location] -> Error
Error
                    { message :: String
message = Name -> DirectiveLocation -> String
forall a. Show a => Name -> a -> String
errorMessage Name
directiveName DirectiveLocation
directiveLocation
                    , locations :: [Location]
locations = [Location
location]
                    }
            Maybe Directive
_ -> Seq Error -> ReaderT (Validation m) Seq Error
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Seq Error
forall a. Monoid a => a
mempty
    errorMessage :: Name -> a -> String
errorMessage Name
directiveName a
directiveLocation = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Directive \"@"
        , Name -> String
Text.unpack Name
directiveName
        , String
"\" may not be used on "
        , a -> String
forall a. Show a => a -> String
show a
directiveLocation
        , String
"."
        ]

-- | 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 :: Rule m
providedRequiredArgumentsRule = (Maybe (Type m) -> Field -> RuleT m)
-> (Directive -> RuleT m) -> Rule m
forall (m :: * -> *).
(Maybe (Type m) -> Field -> RuleT m)
-> (Directive -> RuleT m) -> Rule m
ArgumentsRule Maybe (Type m) -> Field -> RuleT m
forall (t :: (* -> *) -> * -> *) (m :: * -> *).
MonadTrans t =>
Maybe (Type m) -> Field -> t Seq Error
fieldRule Directive -> RuleT m
forall (m :: * -> *). Directive -> ReaderT (Validation m) Seq Error
directiveRule
  where
    fieldRule :: Maybe (Type a) -> Field -> t Seq Error
fieldRule (Just Type a
objectType) (Full.Field Maybe Name
_ Name
fieldName [Argument]
arguments  [Directive]
_ SelectionSetOpt
_ Location
location')
        | Just Field a
typeField <- Name -> Type a -> Maybe (Field a)
forall (a :: * -> *). Name -> Type a -> Maybe (Field a)
Type.lookupTypeField Name
fieldName Type a
objectType
        , Out.Field Maybe Name
_ Type a
_ Arguments
definitions <- Field a
typeField =
            let forEach :: Name -> Argument -> Seq Error -> Seq Error
forEach = (Name -> Name -> String)
-> [Argument]
-> Location
-> Name
-> Argument
-> Seq Error
-> Seq Error
forall (t :: * -> *).
Foldable t =>
(Name -> Name -> String)
-> t Argument
-> Location
-> Name
-> Argument
-> Seq Error
-> Seq Error
go (Name -> Name -> Name -> String
fieldMessage Name
fieldName) [Argument]
arguments Location
location'
             in Seq Error -> t Seq Error
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Seq Error -> t Seq Error) -> Seq Error -> t Seq Error
forall a b. (a -> b) -> a -> b
$ (Name -> Argument -> Seq Error -> Seq Error)
-> Seq Error -> Arguments -> Seq Error
forall k v a. (k -> v -> a -> a) -> a -> HashMap k v -> a
HashMap.foldrWithKey Name -> Argument -> Seq Error -> Seq Error
forEach Seq Error
forall a. Seq a
Seq.empty Arguments
definitions
    fieldRule Maybe (Type a)
_ Field
_ = Seq Error -> t Seq Error
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Seq Error
forall a. Monoid a => a
mempty
    directiveRule :: Directive -> ReaderT (Validation m) Seq Error
directiveRule (Full.Directive Name
directiveName [Argument]
arguments Location
location') = do
        Maybe Directive
available <- (Validation m -> Maybe Directive)
-> ReaderT (Validation m) Seq (Maybe Directive)
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks
            ((Validation m -> Maybe Directive)
 -> ReaderT (Validation m) Seq (Maybe Directive))
-> (Validation m -> Maybe Directive)
-> ReaderT (Validation m) Seq (Maybe Directive)
forall a b. (a -> b) -> a -> b
$ Name -> HashMap Name Directive -> Maybe Directive
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
directiveName (HashMap Name Directive -> Maybe Directive)
-> (Validation m -> HashMap Name Directive)
-> Validation m
-> Maybe Directive
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Schema m -> HashMap Name Directive
forall (m :: * -> *). Schema m -> HashMap Name Directive
Schema.directives (Schema m -> HashMap Name Directive)
-> (Validation m -> Schema m)
-> Validation m
-> HashMap Name Directive
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validation m -> Schema m
forall (m :: * -> *). Validation m -> Schema m
schema
        case Maybe Directive
available of
            Just (Schema.Directive Maybe Name
_ [DirectiveLocation]
_ Arguments
definitions) ->
                let forEach :: Name -> Argument -> Seq Error -> Seq Error
forEach = (Name -> Name -> String)
-> [Argument]
-> Location
-> Name
-> Argument
-> Seq Error
-> Seq Error
forall (t :: * -> *).
Foldable t =>
(Name -> Name -> String)
-> t Argument
-> Location
-> Name
-> Argument
-> Seq Error
-> Seq Error
go (Name -> Name -> Name -> String
directiveMessage Name
directiveName) [Argument]
arguments Location
location'
                 in Seq Error -> ReaderT (Validation m) Seq Error
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Seq Error -> ReaderT (Validation m) Seq Error)
-> Seq Error -> ReaderT (Validation m) Seq Error
forall a b. (a -> b) -> a -> b
$ (Name -> Argument -> Seq Error -> Seq Error)
-> Seq Error -> Arguments -> Seq Error
forall k v a. (k -> v -> a -> a) -> a -> HashMap k v -> a
HashMap.foldrWithKey Name -> Argument -> Seq Error -> Seq Error
forEach Seq Error
forall a. Seq a
Seq.empty Arguments
definitions
            Maybe Directive
_ -> Seq Error -> ReaderT (Validation m) Seq Error
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Seq Error
forall a. Monoid a => a
mempty
    go :: (Name -> Name -> String)
-> t Argument
-> Location
-> Name
-> Argument
-> Seq Error
-> Seq Error
go Name -> Name -> String
makeMessage t Argument
arguments Location
location' Name
argumentName Argument
argumentType Seq Error
errors
        | In.Argument Maybe Name
_ Type
type' Maybe Value
optionalValue <- Argument
argumentType
        , Type -> Bool
In.isNonNullType Type
type'
        , Name
typeName <- Type -> Name
inputTypeName Type
type'
        , Maybe Value -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Value
optionalValue
        , Maybe Argument -> Bool
isNothingOrNull (Maybe Argument -> Bool) -> Maybe Argument -> Bool
forall a b. (a -> b) -> a -> b
$ (Argument -> Bool) -> t Argument -> Maybe Argument
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Name -> Argument -> Bool
lookupArgument Name
argumentName) t Argument
arguments
            = Seq Error
errors
            Seq Error -> Error -> Seq Error
forall a. Seq a -> a -> Seq a
|> String -> Location -> Error
makeError (Name -> Name -> String
makeMessage Name
argumentName Name
typeName) Location
location'
        | Bool
otherwise = Seq Error
errors
    makeError :: String -> Location -> Error
makeError String
errorMessage Location
location' = Error :: String -> [Location] -> Error
Error
        { message :: String
message = String
errorMessage
        , locations :: [Location]
locations = [Location
location']
        }
    isNothingOrNull :: Maybe Argument -> Bool
isNothingOrNull (Just (Full.Argument Name
_ (Full.Node Value
Full.Null Location
_) Location
_)) = Bool
True
    isNothingOrNull Maybe Argument
x = Maybe Argument -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Argument
x
    lookupArgument :: Name -> Argument -> Bool
lookupArgument Name
needle (Full.Argument Name
argumentName Node Value
_ Location
_) =
        Name
needle Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
argumentName
    fieldMessage :: Name -> Name -> Name -> String
fieldMessage Name
fieldName Name
argumentName Name
typeName = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Field \""
        , Name -> String
Text.unpack Name
fieldName
        , String
"\" argument \""
        , Name -> String
Text.unpack Name
argumentName
        , String
"\" of type \""
        , Name -> String
Text.unpack Name
typeName
        , String
"\" is required, but it was not provided."
        ]
    directiveMessage :: Name -> Name -> Name -> String
directiveMessage Name
directiveName Name
argumentName Name
typeName = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Directive \"@"
        , Name -> String
Text.unpack Name
directiveName
        , String
"\" argument \""
        , Name -> String
Text.unpack Name
argumentName
        , String
"\" of type \""
        , Name -> String
Text.unpack Name
typeName
        , String
"\" is required, but it was not provided."
        ]

inputTypeName :: In.Type -> Text
inputTypeName :: Type -> Name
inputTypeName (In.ScalarBaseType (Definition.ScalarType Name
typeName Maybe Name
_)) = Name
typeName
inputTypeName (In.EnumBaseType (Definition.EnumType Name
typeName Maybe Name
_ HashMap Name EnumValue
_)) = Name
typeName
inputTypeName (In.InputObjectBaseType (In.InputObjectType Name
typeName Maybe Name
_ HashMap Name InputField
_)) =
    Name
typeName
inputTypeName (In.ListBaseType Type
listType) = Type -> Name
inputTypeName Type
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 :: Rule m
providedRequiredInputFieldsRule = (Maybe Type -> Node Value -> RuleT m)
-> (Maybe Type -> Node ConstValue -> RuleT m) -> Rule m
forall (m :: * -> *).
(Maybe Type -> Node Value -> RuleT m)
-> (Maybe Type -> Node ConstValue -> RuleT m) -> Rule m
ValueRule Maybe Type -> Node Value -> RuleT m
forall (t :: (* -> *) -> * -> *).
MonadTrans t =>
Maybe Type -> Node Value -> t Seq Error
go Maybe Type -> Node ConstValue -> RuleT m
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a p p.
(MonadTrans t, Monad m, Monoid (m a)) =>
p -> p -> t m a
constGo
  where
    go :: Maybe Type -> Node Value -> t Seq Error
go (Just Type
valueType) (Full.Node (Full.Object [ObjectField Value]
inputFields) Location
location')
        | In.InputObjectBaseType InputObjectType
objectType <- Type
valueType
        , In.InputObjectType Name
objectTypeName Maybe Name
_ HashMap Name InputField
fieldDefinitions <- InputObjectType
objectType
            = Seq Error -> t Seq Error
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
            (Seq Error -> t Seq Error) -> Seq Error -> t Seq Error
forall a b. (a -> b) -> a -> b
$ [Error] -> Seq Error
forall a. [a] -> Seq a
Seq.fromList
            ([Error] -> Seq Error) -> [Error] -> Seq Error
forall a b. (a -> b) -> a -> b
$ HashMap Name Error -> [Error]
forall k v. HashMap k v -> [v]
HashMap.elems
            (HashMap Name Error -> [Error]) -> HashMap Name Error -> [Error]
forall a b. (a -> b) -> a -> b
$ ((Name -> InputField -> Maybe Error)
 -> HashMap Name InputField -> HashMap Name Error)
-> HashMap Name InputField
-> (Name -> InputField -> Maybe Error)
-> HashMap Name Error
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Name -> InputField -> Maybe Error)
-> HashMap Name InputField -> HashMap Name Error
forall k v1 v2.
(k -> v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2
HashMap.mapMaybeWithKey HashMap Name InputField
fieldDefinitions
            ((Name -> InputField -> Maybe Error) -> HashMap Name Error)
-> (Name -> InputField -> Maybe Error) -> HashMap Name Error
forall a b. (a -> b) -> a -> b
$ [ObjectField Value]
-> Name -> Location -> Name -> InputField -> Maybe Error
forall (t :: * -> *).
Foldable t =>
t (ObjectField Value)
-> Name -> Location -> Name -> InputField -> Maybe Error
forEach [ObjectField Value]
inputFields Name
objectTypeName Location
location'
    go Maybe Type
_ Node Value
_ = Seq Error -> t Seq Error
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Seq Error
forall a. Monoid a => a
mempty
    constGo :: p -> p -> t m a
constGo  p
_ p
_ = m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m a
forall a. Monoid a => a
mempty
    forEach :: t (ObjectField Value)
-> Name -> Location -> Name -> InputField -> Maybe Error
forEach t (ObjectField Value)
inputFields Name
typeName Location
location' Name
definitionName InputField
fieldDefinition
        | In.InputField Maybe Name
_ Type
inputType Maybe Value
optionalValue <- InputField
fieldDefinition
        , Type -> Bool
In.isNonNullType Type
inputType
        , Maybe Value -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Value
optionalValue
        , Maybe (ObjectField Value) -> Bool
isNothingOrNull (Maybe (ObjectField Value) -> Bool)
-> Maybe (ObjectField Value) -> Bool
forall a b. (a -> b) -> a -> b
$ (ObjectField Value -> Bool)
-> t (ObjectField Value) -> Maybe (ObjectField Value)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Name -> ObjectField Value -> Bool
forall a. Name -> ObjectField a -> Bool
lookupField Name
definitionName) t (ObjectField Value)
inputFields =
            Error -> Maybe Error
forall a. a -> Maybe a
Just (Error -> Maybe Error) -> Error -> Maybe Error
forall a b. (a -> b) -> a -> b
$ Name -> Name -> Location -> Error
makeError Name
definitionName Name
typeName Location
location'
        | Bool
otherwise = Maybe Error
forall a. Maybe a
Nothing
    isNothingOrNull :: Maybe (ObjectField Value) -> Bool
isNothingOrNull (Just (Full.ObjectField Name
_ (Full.Node Value
Full.Null Location
_) Location
_)) = Bool
True
    isNothingOrNull Maybe (ObjectField Value)
x = Maybe (ObjectField Value) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (ObjectField Value)
x
    lookupField :: Name -> ObjectField a -> Bool
lookupField Name
needle (Full.ObjectField Name
fieldName Node a
_ Location
_) = Name
needle Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
fieldName
    makeError :: Name -> Name -> Location -> Error
makeError Name
fieldName Name
typeName Location
location' = Error :: String -> [Location] -> Error
Error
        { message :: String
message = Name -> Name -> String
errorMessage Name
fieldName Name
typeName
        , locations :: [Location]
locations = [Location
location']
        }
    errorMessage :: Name -> Name -> String
errorMessage Name
fieldName Name
typeName = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Input field \""
        , Name -> String
Text.unpack Name
fieldName
        , String
"\" of type \""
        , Name -> String
Text.unpack Name
typeName
        , String
"\" 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 :: Rule m
overlappingFieldsCanBeMergedRule = (OperationDefinition -> RuleT m) -> Rule m
forall (m :: * -> *). (OperationDefinition -> RuleT m) -> Rule m
OperationDefinitionRule ((OperationDefinition -> RuleT m) -> Rule m)
-> (OperationDefinition -> RuleT m) -> Rule m
forall a b. (a -> b) -> a -> b
$ \case
    Full.SelectionSet SelectionSet
selectionSet Location
_ -> do
        Schema m
schema' <- (Validation m -> Schema m) -> ReaderT (Validation m) Seq (Schema m)
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Validation m -> Schema m
forall (m :: * -> *). Validation m -> Schema m
schema
        SelectionSetOpt -> CompositeType m -> RuleT m
forall (m :: * -> *).
SelectionSetOpt
-> CompositeType m -> ReaderT (Validation m) Seq Error
go (SelectionSet -> SelectionSetOpt
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList SelectionSet
selectionSet)
            (CompositeType m -> RuleT m) -> CompositeType m -> RuleT m
forall a b. (a -> b) -> a -> b
$ ObjectType m -> CompositeType m
forall (m :: * -> *). ObjectType m -> CompositeType m
Type.CompositeObjectType
            (ObjectType m -> CompositeType m)
-> ObjectType m -> CompositeType m
forall a b. (a -> b) -> a -> b
$ Schema m -> ObjectType m
forall (m :: * -> *). Schema m -> ObjectType m
Schema.query Schema m
schema'
    Full.OperationDefinition OperationType
operationType Maybe Name
_ [VariableDefinition]
_ [Directive]
_ SelectionSet
selectionSet Location
_ -> do
        Schema m
schema' <- (Validation m -> Schema m) -> ReaderT (Validation m) Seq (Schema m)
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Validation m -> Schema m
forall (m :: * -> *). Validation m -> Schema m
schema
        let root :: ObjectType m -> ReaderT (Validation m) Seq Error
root = SelectionSetOpt
-> CompositeType m -> ReaderT (Validation m) Seq Error
forall (m :: * -> *).
SelectionSetOpt
-> CompositeType m -> ReaderT (Validation m) Seq Error
go (SelectionSet -> SelectionSetOpt
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList SelectionSet
selectionSet) (CompositeType m -> ReaderT (Validation m) Seq Error)
-> (ObjectType m -> CompositeType m)
-> ObjectType m
-> ReaderT (Validation m) Seq Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ObjectType m -> CompositeType m
forall (m :: * -> *). ObjectType m -> CompositeType m
Type.CompositeObjectType
        case OperationType
operationType of
            OperationType
Full.Query -> ObjectType m -> RuleT m
forall (m :: * -> *).
ObjectType m -> ReaderT (Validation m) Seq Error
root (ObjectType m -> RuleT m) -> ObjectType m -> RuleT m
forall a b. (a -> b) -> a -> b
$ Schema m -> ObjectType m
forall (m :: * -> *). Schema m -> ObjectType m
Schema.query Schema m
schema'
            OperationType
Full.Mutation
                | Just ObjectType m
objectType <- Schema m -> Maybe (ObjectType m)
forall (m :: * -> *). Schema m -> Maybe (ObjectType m)
Schema.mutation Schema m
schema' -> ObjectType m -> RuleT m
forall (m :: * -> *).
ObjectType m -> ReaderT (Validation m) Seq Error
root ObjectType m
objectType
            OperationType
Full.Subscription
                | Just ObjectType m
objectType <- Schema m -> Maybe (ObjectType m)
forall (m :: * -> *). Schema m -> Maybe (ObjectType m)
Schema.mutation Schema m
schema' -> ObjectType m -> RuleT m
forall (m :: * -> *).
ObjectType m -> ReaderT (Validation m) Seq Error
root ObjectType m
objectType
            OperationType
_ -> Seq Error -> RuleT m
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Seq Error
forall a. Monoid a => a
mempty
  where
    go :: SelectionSetOpt
-> CompositeType m -> ReaderT (Validation m) Seq Error
go SelectionSetOpt
selectionSet CompositeType m
selectionType = do
        HashMap Name (NonEmpty (Field, CompositeType m))
fieldTuples <- StateT
  (HashSet Name)
  (ReaderT (Validation m) Seq)
  (HashMap Name (NonEmpty (Field, CompositeType m)))
-> HashSet Name
-> ReaderT
     (Validation m)
     Seq
     (HashMap Name (NonEmpty (Field, CompositeType m)))
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (CompositeType m
-> SelectionSetOpt
-> StateT
     (HashSet Name)
     (ReaderT (Validation m) Seq)
     (HashMap Name (NonEmpty (Field, CompositeType m)))
forall (m :: * -> *).
CompositeType m
-> SelectionSetOpt
-> StateT
     (HashSet Name)
     (ReaderT (Validation m) Seq)
     (HashMap Name (NonEmpty (Field, CompositeType m)))
collectFields CompositeType m
selectionType SelectionSetOpt
selectionSet) HashSet Name
forall a. HashSet a
HashSet.empty
        HashMap Name (NonEmpty (Field, CompositeType m))
-> ReaderT (Validation m) Seq Error
forall (m :: * -> *).
HashMap Name (NonEmpty (Field, CompositeType m))
-> ReaderT (Validation m) Seq Error
fieldsInSetCanMerge HashMap Name (NonEmpty (Field, CompositeType m))
fieldTuples
    fieldsInSetCanMerge :: forall m
        . HashMap Full.Name (NonEmpty (Full.Field, Type.CompositeType m))
        -> ReaderT (Validation m) Seq Error
    fieldsInSetCanMerge :: HashMap Name (NonEmpty (Field, CompositeType m))
-> ReaderT (Validation m) Seq Error
fieldsInSetCanMerge HashMap Name (NonEmpty (Field, CompositeType m))
fieldTuples = do
        Validation m
validation <- ReaderT (Validation m) Seq (Validation m)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
        let (Seq (FieldInfo m)
lonely, Seq (FieldInfo m, FieldInfo m)
paired) = HashMap Name (NonEmpty (Field, CompositeType m))
-> (Seq (FieldInfo m), Seq (FieldInfo m, FieldInfo m))
forall (m :: * -> *).
HashMap Name (NonEmpty (Field, CompositeType m))
-> (Seq (FieldInfo m), Seq (FieldInfo m, FieldInfo m))
flattenPairs HashMap Name (NonEmpty (Field, CompositeType m))
fieldTuples
        let reader :: ReaderT (Validation m) m a -> m a
reader = (ReaderT (Validation m) m a -> Validation m -> m a)
-> Validation m -> ReaderT (Validation m) m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT (Validation m) m a -> Validation m -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Validation m
validation
        Seq Error -> ReaderT (Validation m) Seq Error
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Seq Error -> ReaderT (Validation m) Seq Error)
-> Seq Error -> ReaderT (Validation m) Seq Error
forall a b. (a -> b) -> a -> b
$ (FieldInfo m -> Seq Error) -> Seq (FieldInfo m) -> Seq Error
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (ReaderT (Validation m) Seq Error -> Seq Error
forall (m :: * -> *) a. ReaderT (Validation m) m a -> m a
reader (ReaderT (Validation m) Seq Error -> Seq Error)
-> (FieldInfo m -> ReaderT (Validation m) Seq Error)
-> FieldInfo m
-> Seq Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldInfo m -> ReaderT (Validation m) Seq Error
forall (m :: * -> *).
FieldInfo m -> ReaderT (Validation m) Seq Error
visitLonelyFields) Seq (FieldInfo m)
lonely
            Seq Error -> Seq Error -> Seq Error
forall a. Semigroup a => a -> a -> a
<> ((FieldInfo m, FieldInfo m) -> Seq Error)
-> Seq (FieldInfo m, FieldInfo m) -> Seq Error
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (ReaderT (Validation m) Seq Error -> Seq Error
forall (m :: * -> *) a. ReaderT (Validation m) m a -> m a
reader (ReaderT (Validation m) Seq Error -> Seq Error)
-> ((FieldInfo m, FieldInfo m) -> ReaderT (Validation m) Seq Error)
-> (FieldInfo m, FieldInfo m)
-> Seq Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldInfo m, FieldInfo m) -> ReaderT (Validation m) Seq Error
forall (m :: * -> *).
(FieldInfo m, FieldInfo m) -> ReaderT (Validation m) Seq Error
forEachFieldTuple) Seq (FieldInfo m, FieldInfo m)
paired
    forEachFieldTuple :: forall m
        . (FieldInfo m, FieldInfo m)
        -> ReaderT (Validation m) Seq Error
    forEachFieldTuple :: (FieldInfo m, FieldInfo m) -> ReaderT (Validation m) Seq Error
forEachFieldTuple (FieldInfo m
fieldA, FieldInfo m
fieldB) =
        case (FieldInfo m -> CompositeType m
forall (m :: * -> *). FieldInfo m -> CompositeType m
parent FieldInfo m
fieldA, FieldInfo m -> CompositeType m
forall (m :: * -> *). FieldInfo m -> CompositeType m
parent FieldInfo m
fieldB) of
            (parentA :: CompositeType m
parentA@Type.CompositeObjectType{}, parentB :: CompositeType m
parentB@Type.CompositeObjectType{})
                | CompositeType m
parentA CompositeType m -> CompositeType m -> Bool
forall a. Eq a => a -> a -> Bool
/= CompositeType m
parentB -> FieldInfo m -> FieldInfo m -> ReaderT (Validation m) Seq Error
forall (m :: * -> *).
FieldInfo m -> FieldInfo m -> ReaderT (Validation m) Seq Error
sameResponseShape FieldInfo m
fieldA FieldInfo m
fieldB
            (CompositeType m, CompositeType m)
_ -> (Seq Error -> Seq Error)
-> ReaderT (Validation m) Seq Error
-> ReaderT (Validation m) Seq Error
forall (m :: * -> *) a (n :: * -> *) b r.
(m a -> n b) -> ReaderT r m a -> ReaderT r n b
mapReaderT (Field -> Field -> Seq Error -> Seq Error
checkEquality (FieldInfo m -> Field
forall (m :: * -> *). FieldInfo m -> Field
node FieldInfo m
fieldA) (FieldInfo m -> Field
forall (m :: * -> *). FieldInfo m -> Field
node FieldInfo m
fieldB))
                (ReaderT (Validation m) Seq Error
 -> ReaderT (Validation m) Seq Error)
-> ReaderT (Validation m) Seq Error
-> ReaderT (Validation m) Seq Error
forall a b. (a -> b) -> a -> b
$ FieldInfo m -> FieldInfo m -> ReaderT (Validation m) Seq Error
forall (m :: * -> *).
FieldInfo m -> FieldInfo m -> ReaderT (Validation m) Seq Error
sameResponseShape FieldInfo m
fieldA FieldInfo m
fieldB
    checkEquality :: Field -> Field -> Seq Error -> Seq Error
checkEquality Field
fieldA Field
fieldB Seq Error
Seq.Empty
        | Full.Field Maybe Name
_ Name
fieldNameA [Argument]
_ [Directive]
_ SelectionSetOpt
_ Location
_ <- Field
fieldA
        , Full.Field Maybe Name
_ Name
fieldNameB [Argument]
_ [Directive]
_ SelectionSetOpt
_ Location
_ <- Field
fieldB
        , Name
fieldNameA Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name
fieldNameB = Error -> Seq Error
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Error -> Seq Error) -> Error -> Seq Error
forall a b. (a -> b) -> a -> b
$ Field -> Field -> Error
makeError Field
fieldA Field
fieldB
        | Full.Field Maybe Name
_ Name
fieldNameA [Argument]
argumentsA [Directive]
_ SelectionSetOpt
_ Location
locationA <- Field
fieldA
        , Full.Field Maybe Name
_ Name
_ [Argument]
argumentsB [Directive]
_ SelectionSetOpt
_ Location
locationB <- Field
fieldB
        , [Argument]
argumentsA [Argument] -> [Argument] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Argument]
argumentsB =
            let message :: String
message = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                    [ String
"Fields \""
                    , Name -> String
Text.unpack Name
fieldNameA
                    , String
"\" conflict because they have different arguments. Use "
                    , String
"different aliases on the fields to fetch both if this "
                    , String
"was intentional."
                    ]
             in Error -> Seq Error
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Error -> Seq Error) -> Error -> Seq Error
forall a b. (a -> b) -> a -> b
$ String -> [Location] -> Error
Error String
message [Location
locationB, Location
locationA]
    checkEquality Field
_ Field
_ Seq Error
previousErrors = Seq Error
previousErrors
    visitLonelyFields :: FieldInfo m -> ReaderT (Validation m) Seq Error
visitLonelyFields FieldInfo{Field
Type m
CompositeType m
type' :: forall (m :: * -> *). FieldInfo m -> Type m
parent :: CompositeType m
type' :: Type m
node :: Field
node :: forall (m :: * -> *). FieldInfo m -> Field
parent :: forall (m :: * -> *). FieldInfo m -> CompositeType m
..} =
        let Full.Field Maybe Name
_ Name
_ [Argument]
_ [Directive]
_ SelectionSetOpt
subSelections Location
_ = Field
node
            compositeFieldType :: Maybe (CompositeType m)
compositeFieldType = Type m -> Maybe (CompositeType m)
forall (a :: * -> *). Type a -> Maybe (CompositeType a)
Type.outToComposite Type m
type'
         in ReaderT (Validation m) Seq Error
-> (CompositeType m -> ReaderT (Validation m) Seq Error)
-> Maybe (CompositeType m)
-> ReaderT (Validation m) Seq Error
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Seq Error -> ReaderT (Validation m) Seq Error
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Seq Error
forall a. Seq a
Seq.empty) (SelectionSetOpt
-> CompositeType m -> ReaderT (Validation m) Seq Error
forall (m :: * -> *).
SelectionSetOpt
-> CompositeType m -> ReaderT (Validation m) Seq Error
go SelectionSetOpt
subSelections) Maybe (CompositeType m)
compositeFieldType
    sameResponseShape :: forall m
        . FieldInfo m
        -> FieldInfo m
        -> ReaderT (Validation m) Seq Error
    sameResponseShape :: FieldInfo m -> FieldInfo m -> ReaderT (Validation m) Seq Error
sameResponseShape FieldInfo m
fieldA FieldInfo m
fieldB =
        let Full.Field Maybe Name
_ Name
_ [Argument]
_ [Directive]
_ SelectionSetOpt
selectionsA Location
_ = FieldInfo m -> Field
forall (m :: * -> *). FieldInfo m -> Field
node FieldInfo m
fieldA
            Full.Field Maybe Name
_ Name
_ [Argument]
_ [Directive]
_ SelectionSetOpt
selectionsB Location
_ = FieldInfo m -> Field
forall (m :: * -> *). FieldInfo m -> Field
node FieldInfo m
fieldB
         in case Type m -> Type m -> Either Bool (CompositeType m, CompositeType m)
forall (a :: * -> *).
Type a -> Type a -> Either Bool (CompositeType a, CompositeType a)
unwrapTypes (FieldInfo m -> Type m
forall (m :: * -> *). FieldInfo m -> Type m
type' FieldInfo m
fieldA) (FieldInfo m -> Type m
forall (m :: * -> *). FieldInfo m -> Type m
type' FieldInfo m
fieldB) of
            Left Bool
True -> Seq Error -> ReaderT (Validation m) Seq Error
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Seq Error
forall a. Monoid a => a
mempty
            Right (CompositeType m
compositeA, CompositeType m
compositeB) -> do
                Validation m
validation <- ReaderT (Validation m) Seq (Validation m)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
                let collectFields' :: CompositeType m
-> SelectionSetOpt
-> Seq (HashMap Name (NonEmpty (Field, CompositeType m)))
collectFields' CompositeType m
composite = (ReaderT
   (Validation m)
   Seq
   (HashMap Name (NonEmpty (Field, CompositeType m)))
 -> Validation m
 -> Seq (HashMap Name (NonEmpty (Field, CompositeType m))))
-> Validation m
-> ReaderT
     (Validation m)
     Seq
     (HashMap Name (NonEmpty (Field, CompositeType m)))
-> Seq (HashMap Name (NonEmpty (Field, CompositeType m)))
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT
  (Validation m)
  Seq
  (HashMap Name (NonEmpty (Field, CompositeType m)))
-> Validation m
-> Seq (HashMap Name (NonEmpty (Field, CompositeType m)))
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Validation m
validation
                        (ReaderT
   (Validation m)
   Seq
   (HashMap Name (NonEmpty (Field, CompositeType m)))
 -> Seq (HashMap Name (NonEmpty (Field, CompositeType m))))
-> (SelectionSetOpt
    -> ReaderT
         (Validation m)
         Seq
         (HashMap Name (NonEmpty (Field, CompositeType m))))
-> SelectionSetOpt
-> Seq (HashMap Name (NonEmpty (Field, CompositeType m)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StateT
   (HashSet Name)
   (ReaderT (Validation m) Seq)
   (HashMap Name (NonEmpty (Field, CompositeType m)))
 -> HashSet Name
 -> ReaderT
      (Validation m)
      Seq
      (HashMap Name (NonEmpty (Field, CompositeType m))))
-> HashSet Name
-> StateT
     (HashSet Name)
     (ReaderT (Validation m) Seq)
     (HashMap Name (NonEmpty (Field, CompositeType m)))
-> ReaderT
     (Validation m)
     Seq
     (HashMap Name (NonEmpty (Field, CompositeType m)))
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT
  (HashSet Name)
  (ReaderT (Validation m) Seq)
  (HashMap Name (NonEmpty (Field, CompositeType m)))
-> HashSet Name
-> ReaderT
     (Validation m)
     Seq
     (HashMap Name (NonEmpty (Field, CompositeType m)))
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT HashSet Name
forall a. HashSet a
HashSet.empty
                        (StateT
   (HashSet Name)
   (ReaderT (Validation m) Seq)
   (HashMap Name (NonEmpty (Field, CompositeType m)))
 -> ReaderT
      (Validation m)
      Seq
      (HashMap Name (NonEmpty (Field, CompositeType m))))
-> (SelectionSetOpt
    -> StateT
         (HashSet Name)
         (ReaderT (Validation m) Seq)
         (HashMap Name (NonEmpty (Field, CompositeType m))))
-> SelectionSetOpt
-> ReaderT
     (Validation m)
     Seq
     (HashMap Name (NonEmpty (Field, CompositeType m)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompositeType m
-> SelectionSetOpt
-> StateT
     (HashSet Name)
     (ReaderT (Validation m) Seq)
     (HashMap Name (NonEmpty (Field, CompositeType m)))
forall (m :: * -> *).
CompositeType m
-> SelectionSetOpt
-> StateT
     (HashSet Name)
     (ReaderT (Validation m) Seq)
     (HashMap Name (NonEmpty (Field, CompositeType m)))
collectFields CompositeType m
composite
                let collectA :: Seq (HashMap Name (NonEmpty (Field, CompositeType m)))
collectA = CompositeType m
-> SelectionSetOpt
-> Seq (HashMap Name (NonEmpty (Field, CompositeType m)))
collectFields' CompositeType m
compositeA SelectionSetOpt
selectionsA
                let collectB :: Seq (HashMap Name (NonEmpty (Field, CompositeType m)))
collectB = CompositeType m
-> SelectionSetOpt
-> Seq (HashMap Name (NonEmpty (Field, CompositeType m)))
collectFields' CompositeType m
compositeB SelectionSetOpt
selectionsB
                HashMap Name (NonEmpty (Field, CompositeType m))
-> ReaderT (Validation m) Seq Error
forall (m :: * -> *).
HashMap Name (NonEmpty (Field, CompositeType m))
-> ReaderT (Validation m) Seq Error
fieldsInSetCanMerge
                    (HashMap Name (NonEmpty (Field, CompositeType m))
 -> ReaderT (Validation m) Seq Error)
-> HashMap Name (NonEmpty (Field, CompositeType m))
-> ReaderT (Validation m) Seq Error
forall a b. (a -> b) -> a -> b
$ (HashMap Name (NonEmpty (Field, CompositeType m))
 -> HashMap Name (NonEmpty (Field, CompositeType m))
 -> HashMap Name (NonEmpty (Field, CompositeType m)))
-> HashMap Name (NonEmpty (Field, CompositeType m))
-> Seq (HashMap Name (NonEmpty (Field, CompositeType m)))
-> HashMap Name (NonEmpty (Field, CompositeType m))
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((NonEmpty (Field, CompositeType m)
 -> NonEmpty (Field, CompositeType m)
 -> NonEmpty (Field, CompositeType m))
-> HashMap Name (NonEmpty (Field, CompositeType m))
-> HashMap Name (NonEmpty (Field, CompositeType m))
-> HashMap Name (NonEmpty (Field, CompositeType m))
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v
HashMap.unionWith NonEmpty (Field, CompositeType m)
-> NonEmpty (Field, CompositeType m)
-> NonEmpty (Field, CompositeType m)
forall a. Semigroup a => a -> a -> a
(<>)) HashMap Name (NonEmpty (Field, CompositeType m))
forall k v. HashMap k v
HashMap.empty
                    (Seq (HashMap Name (NonEmpty (Field, CompositeType m)))
 -> HashMap Name (NonEmpty (Field, CompositeType m)))
-> Seq (HashMap Name (NonEmpty (Field, CompositeType m)))
-> HashMap Name (NonEmpty (Field, CompositeType m))
forall a b. (a -> b) -> a -> b
$ Seq (HashMap Name (NonEmpty (Field, CompositeType m)))
collectA Seq (HashMap Name (NonEmpty (Field, CompositeType m)))
-> Seq (HashMap Name (NonEmpty (Field, CompositeType m)))
-> Seq (HashMap Name (NonEmpty (Field, CompositeType m)))
forall a. Semigroup a => a -> a -> a
<> Seq (HashMap Name (NonEmpty (Field, CompositeType m)))
collectB
            Either Bool (CompositeType m, CompositeType m)
_ -> Error -> ReaderT (Validation m) Seq Error
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Error -> ReaderT (Validation m) Seq Error)
-> Error -> ReaderT (Validation m) Seq Error
forall a b. (a -> b) -> a -> b
$ Field -> Field -> Error
makeError (FieldInfo m -> Field
forall (m :: * -> *). FieldInfo m -> Field
node FieldInfo m
fieldA) (FieldInfo m -> Field
forall (m :: * -> *). FieldInfo m -> Field
node FieldInfo m
fieldB)
    makeError :: Field -> Field -> Error
makeError Field
fieldA Field
fieldB =
        let Full.Field Maybe Name
aliasA Name
fieldNameA [Argument]
_ [Directive]
_ SelectionSetOpt
_ Location
locationA = Field
fieldA
            Full.Field Maybe Name
_ Name
fieldNameB [Argument]
_ [Directive]
_ SelectionSetOpt
_ Location
locationB = Field
fieldB
            message :: String
message = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                [ String
"Fields \""
                , Name -> String
Text.unpack (Name -> Maybe Name -> Name
forall a. a -> Maybe a -> a
fromMaybe Name
fieldNameA Maybe Name
aliasA)
                , String
"\" conflict because \""
                , Name -> String
Text.unpack Name
fieldNameB
                , String
"\" and \""
                , Name -> String
Text.unpack Name
fieldNameA
                , String
"\" are different fields. Use different aliases on the fields "
                , String
"to fetch both if this was intentional."
                ]
             in String -> [Location] -> Error
Error String
message [Location
locationB, Location
locationA]
    unwrapTypes :: Type a -> Type a -> Either Bool (CompositeType a, CompositeType a)
unwrapTypes typeA :: Type a
typeA@Out.ScalarBaseType{} typeB :: Type a
typeB@Out.ScalarBaseType{} =
        Bool -> Either Bool (CompositeType a, CompositeType a)
forall a b. a -> Either a b
Left (Bool -> Either Bool (CompositeType a, CompositeType a))
-> Bool -> Either Bool (CompositeType a, CompositeType a)
forall a b. (a -> b) -> a -> b
$ Type a
typeA Type a -> Type a -> Bool
forall a. Eq a => a -> a -> Bool
== Type a
typeB
    unwrapTypes typeA :: Type a
typeA@Out.EnumBaseType{} typeB :: Type a
typeB@Out.EnumBaseType{} =
        Bool -> Either Bool (CompositeType a, CompositeType a)
forall a b. a -> Either a b
Left (Bool -> Either Bool (CompositeType a, CompositeType a))
-> Bool -> Either Bool (CompositeType a, CompositeType a)
forall a b. (a -> b) -> a -> b
$ Type a
typeA Type a -> Type a -> Bool
forall a. Eq a => a -> a -> Bool
== Type a
typeB
    unwrapTypes (Out.ListType Type a
listA) (Out.ListType Type a
listB) =
        Type a -> Type a -> Either Bool (CompositeType a, CompositeType a)
unwrapTypes Type a
listA Type a
listB
    unwrapTypes (Out.NonNullListType Type a
listA) (Out.NonNullListType Type a
listB) =
        Type a -> Type a -> Either Bool (CompositeType a, CompositeType a)
unwrapTypes Type a
listA Type a
listB
    unwrapTypes Type a
typeA Type a
typeB
        | Type a -> Bool
forall (m :: * -> *). Type m -> Bool
Out.isNonNullType Type a
typeA Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Type a -> Bool
forall (m :: * -> *). Type m -> Bool
Out.isNonNullType Type a
typeB
        , Just CompositeType a
compositeA <- Type a -> Maybe (CompositeType a)
forall (a :: * -> *). Type a -> Maybe (CompositeType a)
Type.outToComposite Type a
typeA
        , Just CompositeType a
compositeB <- Type a -> Maybe (CompositeType a)
forall (a :: * -> *). Type a -> Maybe (CompositeType a)
Type.outToComposite Type a
typeB =
            (CompositeType a, CompositeType a)
-> Either Bool (CompositeType a, CompositeType a)
forall a b. b -> Either a b
Right (CompositeType a
compositeA, CompositeType a
compositeB)
        | Bool
otherwise = Bool -> Either Bool (CompositeType a, CompositeType a)
forall a b. a -> Either a b
Left Bool
False
    flattenPairs :: forall m
        . HashMap Full.Name (NonEmpty (Full.Field, Type.CompositeType m))
        -> (Seq (FieldInfo m), Seq (FieldInfo m, FieldInfo m))
    flattenPairs :: HashMap Name (NonEmpty (Field, CompositeType m))
-> (Seq (FieldInfo m), Seq (FieldInfo m, FieldInfo m))
flattenPairs HashMap Name (NonEmpty (Field, CompositeType m))
xs = ([FieldInfo m]
 -> (Seq (FieldInfo m), Seq (FieldInfo m, FieldInfo m))
 -> (Seq (FieldInfo m), Seq (FieldInfo m, FieldInfo m)))
-> (Seq (FieldInfo m), Seq (FieldInfo m, FieldInfo m))
-> HashMap Name [FieldInfo m]
-> (Seq (FieldInfo m), Seq (FieldInfo m, FieldInfo m))
forall v a k. (v -> a -> a) -> a -> HashMap k v -> a
HashMap.foldr [FieldInfo m]
-> (Seq (FieldInfo m), Seq (FieldInfo m, FieldInfo m))
-> (Seq (FieldInfo m), Seq (FieldInfo m, FieldInfo m))
forall (m :: * -> *).
[FieldInfo m]
-> (Seq (FieldInfo m), Seq (FieldInfo m, FieldInfo m))
-> (Seq (FieldInfo m), Seq (FieldInfo m, FieldInfo m))
splitSingleFields (Seq (FieldInfo m)
forall a. Seq a
Seq.empty, Seq (FieldInfo m, FieldInfo m)
forall a. Seq a
Seq.empty)
        (HashMap Name [FieldInfo m]
 -> (Seq (FieldInfo m), Seq (FieldInfo m, FieldInfo m)))
-> HashMap Name [FieldInfo m]
-> (Seq (FieldInfo m), Seq (FieldInfo m, FieldInfo m))
forall a b. (a -> b) -> a -> b
$ ((Field, CompositeType m) -> [FieldInfo m] -> [FieldInfo m])
-> [FieldInfo m]
-> NonEmpty (Field, CompositeType m)
-> [FieldInfo m]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Field, CompositeType m) -> [FieldInfo m] -> [FieldInfo m]
forall (m :: * -> *).
(Field, CompositeType m) -> [FieldInfo m] -> [FieldInfo m]
lookupTypeField [] (NonEmpty (Field, CompositeType m) -> [FieldInfo m])
-> HashMap Name (NonEmpty (Field, CompositeType m))
-> HashMap Name [FieldInfo m]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashMap Name (NonEmpty (Field, CompositeType m))
xs
    splitSingleFields :: forall m
        . [FieldInfo m]
        -> (Seq (FieldInfo m), Seq (FieldInfo m, FieldInfo m))
        -> (Seq (FieldInfo m), Seq (FieldInfo m, FieldInfo m))
    splitSingleFields :: [FieldInfo m]
-> (Seq (FieldInfo m), Seq (FieldInfo m, FieldInfo m))
-> (Seq (FieldInfo m), Seq (FieldInfo m, FieldInfo m))
splitSingleFields [FieldInfo m
head'] (Seq (FieldInfo m)
fields, Seq (FieldInfo m, FieldInfo m)
pairList) = (Seq (FieldInfo m)
fields Seq (FieldInfo m) -> FieldInfo m -> Seq (FieldInfo m)
forall a. Seq a -> a -> Seq a
|> FieldInfo m
head', Seq (FieldInfo m, FieldInfo m)
pairList)
    splitSingleFields [FieldInfo m]
xs (Seq (FieldInfo m)
fields, Seq (FieldInfo m, FieldInfo m)
pairList) = (Seq (FieldInfo m)
fields, Seq (FieldInfo m, FieldInfo m)
-> [FieldInfo m] -> Seq (FieldInfo m, FieldInfo m)
forall (m :: * -> *).
Seq (FieldInfo m, FieldInfo m)
-> [FieldInfo m] -> Seq (FieldInfo m, FieldInfo m)
pairs Seq (FieldInfo m, FieldInfo m)
pairList [FieldInfo m]
xs)
    lookupTypeField :: (Field, CompositeType m) -> [FieldInfo m] -> [FieldInfo m]
lookupTypeField (Field
field, CompositeType m
parentType) [FieldInfo m]
accumulator =
        let Full.Field Maybe Name
_ Name
fieldName [Argument]
_ [Directive]
_ SelectionSetOpt
_ Location
_ = Field
field
         in case Name -> CompositeType m -> Maybe (Field m)
forall (a :: * -> *). Name -> CompositeType a -> Maybe (Field a)
Type.lookupCompositeField Name
fieldName CompositeType m
parentType of
            Maybe (Field m)
Nothing -> [FieldInfo m]
accumulator
            Just (Out.Field Maybe Name
_ Type m
typeField Arguments
_) ->
                Field -> Type m -> CompositeType m -> FieldInfo m
forall (m :: * -> *).
Field -> Type m -> CompositeType m -> FieldInfo m
FieldInfo Field
field Type m
typeField CompositeType m
parentType FieldInfo m -> [FieldInfo m] -> [FieldInfo m]
forall a. a -> [a] -> [a]
: [FieldInfo m]
accumulator
    pairs :: forall m
        . Seq (FieldInfo m, FieldInfo m)
        -> [FieldInfo m]
        -> Seq (FieldInfo m, FieldInfo m)
    pairs :: Seq (FieldInfo m, FieldInfo m)
-> [FieldInfo m] -> Seq (FieldInfo m, FieldInfo m)
pairs Seq (FieldInfo m, FieldInfo m)
accumulator [] = Seq (FieldInfo m, FieldInfo m)
accumulator
    pairs Seq (FieldInfo m, FieldInfo m)
accumulator (FieldInfo m
fieldA : [FieldInfo m]
fields) =
        FieldInfo m
-> Seq (FieldInfo m, FieldInfo m)
-> [FieldInfo m]
-> Seq (FieldInfo m, FieldInfo m)
forall a b. a -> Seq (a, b) -> [b] -> Seq (a, b)
pair FieldInfo m
fieldA (Seq (FieldInfo m, FieldInfo m)
-> [FieldInfo m] -> Seq (FieldInfo m, FieldInfo m)
forall (m :: * -> *).
Seq (FieldInfo m, FieldInfo m)
-> [FieldInfo m] -> Seq (FieldInfo m, FieldInfo m)
pairs Seq (FieldInfo m, FieldInfo m)
accumulator [FieldInfo m]
fields) [FieldInfo m]
fields
    pair :: a -> Seq (a, b) -> [b] -> Seq (a, b)
pair a
_ Seq (a, b)
accumulator [] = Seq (a, b)
accumulator
    pair a
field Seq (a, b)
accumulator (b
fieldA : [b]
fields) =
        a -> Seq (a, b) -> [b] -> Seq (a, b)
pair a
field Seq (a, b)
accumulator [b]
fields Seq (a, b) -> (a, b) -> Seq (a, b)
forall a. Seq a -> a -> Seq a
|> (a
field, b
fieldA)
    collectFields :: CompositeType m
-> SelectionSetOpt
-> StateT
     (HashSet Name)
     (ReaderT (Validation m) Seq)
     (HashMap Name (NonEmpty (Field, CompositeType m)))
collectFields CompositeType m
objectType = CompositeType m
-> HashMap Name (NonEmpty (Field, CompositeType m))
-> SelectionSetOpt
-> StateT
     (HashSet Name)
     (ReaderT (Validation m) Seq)
     (HashMap Name (NonEmpty (Field, CompositeType m)))
forall (m :: * -> *).
CompositeType m
-> HashMap Name (NonEmpty (Field, CompositeType m))
-> SelectionSetOpt
-> StateT
     (HashSet Name)
     (ReaderT (Validation m) Seq)
     (HashMap Name (NonEmpty (Field, CompositeType m)))
accumulateFields CompositeType m
objectType HashMap Name (NonEmpty (Field, CompositeType m))
forall a. Monoid a => a
mempty
    accumulateFields :: CompositeType m
-> HashMap Name (NonEmpty (Field, CompositeType m))
-> SelectionSetOpt
-> StateT
     (HashSet Name)
     (ReaderT (Validation m) Seq)
     (HashMap Name (NonEmpty (Field, CompositeType m)))
accumulateFields = (HashMap Name (NonEmpty (Field, CompositeType m))
 -> Selection
 -> StateT
      (HashSet Name)
      (ReaderT (Validation m) Seq)
      (HashMap Name (NonEmpty (Field, CompositeType m))))
-> HashMap Name (NonEmpty (Field, CompositeType m))
-> SelectionSetOpt
-> StateT
     (HashSet Name)
     (ReaderT (Validation m) Seq)
     (HashMap Name (NonEmpty (Field, CompositeType m)))
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ((HashMap Name (NonEmpty (Field, CompositeType m))
  -> Selection
  -> StateT
       (HashSet Name)
       (ReaderT (Validation m) Seq)
       (HashMap Name (NonEmpty (Field, CompositeType m))))
 -> HashMap Name (NonEmpty (Field, CompositeType m))
 -> SelectionSetOpt
 -> StateT
      (HashSet Name)
      (ReaderT (Validation m) Seq)
      (HashMap Name (NonEmpty (Field, CompositeType m))))
-> (CompositeType m
    -> HashMap Name (NonEmpty (Field, CompositeType m))
    -> Selection
    -> StateT
         (HashSet Name)
         (ReaderT (Validation m) Seq)
         (HashMap Name (NonEmpty (Field, CompositeType m))))
-> CompositeType m
-> HashMap Name (NonEmpty (Field, CompositeType m))
-> SelectionSetOpt
-> StateT
     (HashSet Name)
     (ReaderT (Validation m) Seq)
     (HashMap Name (NonEmpty (Field, CompositeType m)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompositeType m
-> HashMap Name (NonEmpty (Field, CompositeType m))
-> Selection
-> StateT
     (HashSet Name)
     (ReaderT (Validation m) Seq)
     (HashMap Name (NonEmpty (Field, CompositeType m)))
forEach
    forEach :: CompositeType m
-> HashMap Name (NonEmpty (Field, CompositeType m))
-> Selection
-> StateT
     (HashSet Name)
     (ReaderT (Validation m) Seq)
     (HashMap Name (NonEmpty (Field, CompositeType m)))
forEach CompositeType m
parentType HashMap Name (NonEmpty (Field, CompositeType m))
accumulator = \case
        Full.FieldSelection Field
fieldSelection ->
            CompositeType m
-> HashMap Name (NonEmpty (Field, CompositeType m))
-> Field
-> StateT
     (HashSet Name)
     (ReaderT (Validation m) Seq)
     (HashMap Name (NonEmpty (Field, CompositeType m)))
forall (f :: * -> *) b.
Applicative f =>
b
-> HashMap Name (NonEmpty (Field, b))
-> Field
-> f (HashMap Name (NonEmpty (Field, b)))
forField CompositeType m
parentType HashMap Name (NonEmpty (Field, CompositeType m))
accumulator Field
fieldSelection
        Full.FragmentSpreadSelection FragmentSpread
fragmentSelection ->
            HashMap Name (NonEmpty (Field, CompositeType m))
-> FragmentSpread
-> StateT
     (HashSet Name)
     (ReaderT (Validation m) Seq)
     (HashMap Name (NonEmpty (Field, CompositeType m)))
forSpread HashMap Name (NonEmpty (Field, CompositeType m))
accumulator FragmentSpread
fragmentSelection
        Full.InlineFragmentSelection InlineFragment
fragmentSelection ->
            CompositeType m
-> HashMap Name (NonEmpty (Field, CompositeType m))
-> InlineFragment
-> StateT
     (HashSet Name)
     (ReaderT (Validation m) Seq)
     (HashMap Name (NonEmpty (Field, CompositeType m)))
forInline CompositeType m
parentType HashMap Name (NonEmpty (Field, CompositeType m))
accumulator InlineFragment
fragmentSelection
    forField :: b
-> HashMap Name (NonEmpty (Field, b))
-> Field
-> f (HashMap Name (NonEmpty (Field, b)))
forField b
parentType HashMap Name (NonEmpty (Field, b))
accumulator field :: Field
field@(Full.Field Maybe Name
alias Name
fieldName [Argument]
_ [Directive]
_ SelectionSetOpt
_ Location
_) =
        let key :: Name
key = Name -> Maybe Name -> Name
forall a. a -> Maybe a -> a
fromMaybe Name
fieldName Maybe Name
alias
            value :: NonEmpty (Field, b)
value = (Field
field, b
parentType) (Field, b) -> [(Field, b)] -> NonEmpty (Field, b)
forall a. a -> [a] -> NonEmpty a
:| []
         in HashMap Name (NonEmpty (Field, b))
-> f (HashMap Name (NonEmpty (Field, b)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashMap Name (NonEmpty (Field, b))
 -> f (HashMap Name (NonEmpty (Field, b))))
-> HashMap Name (NonEmpty (Field, b))
-> f (HashMap Name (NonEmpty (Field, b)))
forall a b. (a -> b) -> a -> b
$ (NonEmpty (Field, b) -> NonEmpty (Field, b) -> NonEmpty (Field, b))
-> Name
-> NonEmpty (Field, b)
-> HashMap Name (NonEmpty (Field, b))
-> HashMap Name (NonEmpty (Field, b))
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
HashMap.insertWith NonEmpty (Field, b) -> NonEmpty (Field, b) -> NonEmpty (Field, b)
forall a. Semigroup a => a -> a -> a
(<>) Name
key NonEmpty (Field, b)
value HashMap Name (NonEmpty (Field, b))
accumulator
    forSpread :: HashMap Name (NonEmpty (Field, CompositeType m))
-> FragmentSpread
-> StateT
     (HashSet Name)
     (ReaderT (Validation m) Seq)
     (HashMap Name (NonEmpty (Field, CompositeType m)))
forSpread HashMap Name (NonEmpty (Field, CompositeType m))
accumulator (Full.FragmentSpread Name
fragmentName [Directive]
_ Location
_) = do
        Bool
inVisitetFragments <- (HashSet Name -> Bool)
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) Bool
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets ((HashSet Name -> Bool)
 -> StateT (HashSet Name) (ReaderT (Validation m) Seq) Bool)
-> (HashSet Name -> Bool)
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) Bool
forall a b. (a -> b) -> a -> b
$ Name -> HashSet Name -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
HashSet.member Name
fragmentName
        if Bool
inVisitetFragments
            then HashMap Name (NonEmpty (Field, CompositeType m))
-> StateT
     (HashSet Name)
     (ReaderT (Validation m) Seq)
     (HashMap Name (NonEmpty (Field, CompositeType m)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure HashMap Name (NonEmpty (Field, CompositeType m))
accumulator
            else Name
-> HashMap Name (NonEmpty (Field, CompositeType m))
-> StateT
     (HashSet Name)
     (ReaderT (Validation m) Seq)
     (HashMap Name (NonEmpty (Field, CompositeType m)))
collectFromSpread Name
fragmentName HashMap Name (NonEmpty (Field, CompositeType m))
accumulator
    forInline :: CompositeType m
-> HashMap Name (NonEmpty (Field, CompositeType m))
-> InlineFragment
-> StateT
     (HashSet Name)
     (ReaderT (Validation m) Seq)
     (HashMap Name (NonEmpty (Field, CompositeType m)))
forInline CompositeType m
parentType HashMap Name (NonEmpty (Field, CompositeType m))
accumulator = \case
        Full.InlineFragment Maybe Name
maybeType [Directive]
_ SelectionSet
selections Location
_
            | Just Name
typeCondition <- Maybe Name
maybeType ->
                Name
-> SelectionSet
-> HashMap Name (NonEmpty (Field, CompositeType m))
-> StateT
     (HashSet Name)
     (ReaderT (Validation m) Seq)
     (HashMap Name (NonEmpty (Field, CompositeType m)))
collectFromFragment Name
typeCondition SelectionSet
selections HashMap Name (NonEmpty (Field, CompositeType m))
accumulator
            | Bool
otherwise -> CompositeType m
-> HashMap Name (NonEmpty (Field, CompositeType m))
-> SelectionSetOpt
-> StateT
     (HashSet Name)
     (ReaderT (Validation m) Seq)
     (HashMap Name (NonEmpty (Field, CompositeType m)))
accumulateFields CompositeType m
parentType HashMap Name (NonEmpty (Field, CompositeType m))
accumulator (SelectionSetOpt
 -> StateT
      (HashSet Name)
      (ReaderT (Validation m) Seq)
      (HashMap Name (NonEmpty (Field, CompositeType m))))
-> SelectionSetOpt
-> StateT
     (HashSet Name)
     (ReaderT (Validation m) Seq)
     (HashMap Name (NonEmpty (Field, CompositeType m)))
forall a b. (a -> b) -> a -> b
$ SelectionSet -> SelectionSetOpt
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList SelectionSet
selections
    collectFromFragment :: Name
-> SelectionSet
-> HashMap Name (NonEmpty (Field, CompositeType m))
-> StateT
     (HashSet Name)
     (ReaderT (Validation m) Seq)
     (HashMap Name (NonEmpty (Field, CompositeType m)))
collectFromFragment Name
typeCondition SelectionSet
selectionSet' HashMap Name (NonEmpty (Field, CompositeType m))
accumulator = do
        HashMap Name (Type m)
types' <- ReaderT (Validation m) Seq (HashMap Name (Type m))
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (HashMap Name (Type m))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT (Validation m) Seq (HashMap Name (Type m))
 -> StateT
      (HashSet Name)
      (ReaderT (Validation m) Seq)
      (HashMap Name (Type m)))
-> ReaderT (Validation m) Seq (HashMap Name (Type m))
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (HashMap Name (Type m))
forall a b. (a -> b) -> a -> b
$ (Validation m -> HashMap Name (Type m))
-> ReaderT (Validation m) Seq (HashMap Name (Type m))
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks ((Validation m -> HashMap Name (Type m))
 -> ReaderT (Validation m) Seq (HashMap Name (Type m)))
-> (Validation m -> HashMap Name (Type m))
-> ReaderT (Validation m) Seq (HashMap Name (Type m))
forall a b. (a -> b) -> a -> b
$ Schema m -> HashMap Name (Type m)
forall (m :: * -> *). Schema m -> HashMap Name (Type m)
Schema.types (Schema m -> HashMap Name (Type m))
-> (Validation m -> Schema m)
-> Validation m
-> HashMap Name (Type m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validation m -> Schema m
forall (m :: * -> *). Validation m -> Schema m
schema
        case Name -> HashMap Name (Type m) -> Maybe (CompositeType m)
forall (m :: * -> *).
Name -> HashMap Name (Type m) -> Maybe (CompositeType m)
Type.lookupTypeCondition Name
typeCondition HashMap Name (Type m)
types' of
            Maybe (CompositeType m)
Nothing -> HashMap Name (NonEmpty (Field, CompositeType m))
-> StateT
     (HashSet Name)
     (ReaderT (Validation m) Seq)
     (HashMap Name (NonEmpty (Field, CompositeType m)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure HashMap Name (NonEmpty (Field, CompositeType m))
accumulator
            Just CompositeType m
compositeType ->
                CompositeType m
-> HashMap Name (NonEmpty (Field, CompositeType m))
-> SelectionSetOpt
-> StateT
     (HashSet Name)
     (ReaderT (Validation m) Seq)
     (HashMap Name (NonEmpty (Field, CompositeType m)))
accumulateFields CompositeType m
compositeType HashMap Name (NonEmpty (Field, CompositeType m))
accumulator (SelectionSetOpt
 -> StateT
      (HashSet Name)
      (ReaderT (Validation m) Seq)
      (HashMap Name (NonEmpty (Field, CompositeType m))))
-> SelectionSetOpt
-> StateT
     (HashSet Name)
     (ReaderT (Validation m) Seq)
     (HashMap Name (NonEmpty (Field, CompositeType m)))
forall a b. (a -> b) -> a -> b
$ SelectionSet -> SelectionSetOpt
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList SelectionSet
selectionSet'
    collectFromSpread :: Name
-> HashMap Name (NonEmpty (Field, CompositeType m))
-> StateT
     (HashSet Name)
     (ReaderT (Validation m) Seq)
     (HashMap Name (NonEmpty (Field, CompositeType m)))
collectFromSpread Name
fragmentName HashMap Name (NonEmpty (Field, CompositeType m))
accumulator = do
        (HashSet Name -> HashSet Name)
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify ((HashSet Name -> HashSet Name)
 -> StateT (HashSet Name) (ReaderT (Validation m) Seq) ())
-> (HashSet Name -> HashSet Name)
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) ()
forall a b. (a -> b) -> a -> b
$ Name -> HashSet Name -> HashSet Name
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HashSet.insert Name
fragmentName
        Document
ast' <- ReaderT (Validation m) Seq Document
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) Document
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT (Validation m) Seq Document
 -> StateT (HashSet Name) (ReaderT (Validation m) Seq) Document)
-> ReaderT (Validation m) Seq Document
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) Document
forall a b. (a -> b) -> a -> b
$ (Validation m -> Document) -> ReaderT (Validation m) Seq Document
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Validation m -> Document
forall (m :: * -> *). Validation m -> Document
ast
        case Name -> Document -> Maybe FragmentDefinition
findFragmentDefinition Name
fragmentName Document
ast' of
            Maybe FragmentDefinition
Nothing -> HashMap Name (NonEmpty (Field, CompositeType m))
-> StateT
     (HashSet Name)
     (ReaderT (Validation m) Seq)
     (HashMap Name (NonEmpty (Field, CompositeType m)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure HashMap Name (NonEmpty (Field, CompositeType m))
accumulator
            Just (Full.FragmentDefinition Name
_ Name
typeCondition [Directive]
_ SelectionSet
selectionSet' Location
_) ->
                Name
-> SelectionSet
-> HashMap Name (NonEmpty (Field, CompositeType m))
-> StateT
     (HashSet Name)
     (ReaderT (Validation m) Seq)
     (HashMap Name (NonEmpty (Field, CompositeType m)))
collectFromFragment Name
typeCondition SelectionSet
selectionSet' HashMap Name (NonEmpty (Field, CompositeType m))
accumulator

data FieldInfo m = FieldInfo
    { FieldInfo m -> Field
node :: Full.Field
    , FieldInfo m -> Type m
type' :: Out.Type m
    , FieldInfo m -> CompositeType 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 :: Rule m
possibleFragmentSpreadsRule = (Maybe (Type m) -> Selection -> RuleT m) -> Rule m
forall (m :: * -> *).
(Maybe (Type m) -> Selection -> RuleT m) -> Rule m
SelectionRule Maybe (Type m) -> Selection -> RuleT m
forall (m :: * -> *).
Maybe (Type m) -> Selection -> ReaderT (Validation m) Seq Error
go
  where
    go :: Maybe (Type m) -> Selection -> ReaderT (Validation m) Seq Error
go (Just Type m
parentType) (Full.InlineFragmentSelection InlineFragment
fragmentSelection)
        | Full.InlineFragment Maybe Name
maybeType [Directive]
_ SelectionSet
_ Location
location' <- InlineFragment
fragmentSelection
        , Just Name
typeCondition <- Maybe Name
maybeType = do
            (Name
fragmentTypeName, Name
parentTypeName) <-
                Name -> Type m -> ReaderT (Validation m) Seq (Name, Name)
forall (m :: * -> *).
Name -> Type m -> ReaderT (Validation m) Seq (Name, Name)
compareTypes Name
typeCondition Type m
parentType
            Error -> ReaderT (Validation m) Seq Error
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Error -> ReaderT (Validation m) Seq Error)
-> Error -> ReaderT (Validation m) Seq Error
forall a b. (a -> b) -> a -> b
$ Error :: String -> [Location] -> Error
Error
                { message :: String
message = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                    [ String
"Fragment cannot be spread here as objects of type \""
                    , Name -> String
Text.unpack Name
parentTypeName
                    , String
"\" can never be of type \""
                    , Name -> String
Text.unpack Name
fragmentTypeName
                    , String
"\"."
                    ]
                , locations :: [Location]
locations = [Location
location']
                }
    go (Just Type m
parentType) (Full.FragmentSpreadSelection FragmentSpread
fragmentSelection)
        | Full.FragmentSpread Name
fragmentName [Directive]
_ Location
location' <- FragmentSpread
fragmentSelection = do
            Name
typeCondition <- Name -> ReaderT (Validation m) Seq Name
forall (m1 :: * -> *). Name -> ReaderT (Validation m1) Seq Name
findSpreadTarget Name
fragmentName
            (Name
fragmentTypeName, Name
parentTypeName) <-
                Name -> Type m -> ReaderT (Validation m) Seq (Name, Name)
forall (m :: * -> *).
Name -> Type m -> ReaderT (Validation m) Seq (Name, Name)
compareTypes Name
typeCondition Type m
parentType
            Error -> ReaderT (Validation m) Seq Error
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Error -> ReaderT (Validation m) Seq Error)
-> Error -> ReaderT (Validation m) Seq Error
forall a b. (a -> b) -> a -> b
$ Error :: String -> [Location] -> Error
Error
                { message :: String
message = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                    [ String
"Fragment \""
                    , Name -> String
Text.unpack Name
fragmentName
                    , String
"\" cannot be spread here as objects of type \""
                    , Name -> String
Text.unpack Name
parentTypeName
                    , String
"\" can never be of type \""
                    , Name -> String
Text.unpack Name
fragmentTypeName
                    , String
"\"."
                    ]
                , locations :: [Location]
locations = [Location
location']
                }
    go Maybe (Type m)
_ Selection
_ = Seq Error -> ReaderT (Validation m) Seq Error
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Seq Error
forall a. Monoid a => a
mempty
    compareTypes :: Name -> Type m -> ReaderT (Validation m) Seq (Name, Name)
compareTypes Name
typeCondition Type m
parentType = do
        HashMap Name (Type m)
types' <- (Validation m -> HashMap Name (Type m))
-> ReaderT (Validation m) Seq (HashMap Name (Type m))
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks ((Validation m -> HashMap Name (Type m))
 -> ReaderT (Validation m) Seq (HashMap Name (Type m)))
-> (Validation m -> HashMap Name (Type m))
-> ReaderT (Validation m) Seq (HashMap Name (Type m))
forall a b. (a -> b) -> a -> b
$ Schema m -> HashMap Name (Type m)
forall (m :: * -> *). Schema m -> HashMap Name (Type m)
Schema.types (Schema m -> HashMap Name (Type m))
-> (Validation m -> Schema m)
-> Validation m
-> HashMap Name (Type m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validation m -> Schema m
forall (m :: * -> *). Validation m -> Schema m
schema
        CompositeType m
fragmentType <- Seq (CompositeType m)
-> ReaderT (Validation m) Seq (CompositeType m)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
            (Seq (CompositeType m)
 -> ReaderT (Validation m) Seq (CompositeType m))
-> Seq (CompositeType m)
-> ReaderT (Validation m) Seq (CompositeType m)
forall a b. (a -> b) -> a -> b
$ Maybe (CompositeType m) -> Seq (CompositeType m)
forall a. Maybe a -> Seq a
maybeToSeq
            (Maybe (CompositeType m) -> Seq (CompositeType m))
-> Maybe (CompositeType m) -> Seq (CompositeType m)
forall a b. (a -> b) -> a -> b
$ Name -> HashMap Name (Type m) -> Maybe (CompositeType m)
forall (m :: * -> *).
Name -> HashMap Name (Type m) -> Maybe (CompositeType m)
Type.lookupTypeCondition Name
typeCondition HashMap Name (Type m)
types'
        CompositeType m
parentComposite <- Seq (CompositeType m)
-> ReaderT (Validation m) Seq (CompositeType m)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
            (Seq (CompositeType m)
 -> ReaderT (Validation m) Seq (CompositeType m))
-> Seq (CompositeType m)
-> ReaderT (Validation m) Seq (CompositeType m)
forall a b. (a -> b) -> a -> b
$ Maybe (CompositeType m) -> Seq (CompositeType m)
forall a. Maybe a -> Seq a
maybeToSeq
            (Maybe (CompositeType m) -> Seq (CompositeType m))
-> Maybe (CompositeType m) -> Seq (CompositeType m)
forall a b. (a -> b) -> a -> b
$ Type m -> Maybe (CompositeType m)
forall (a :: * -> *). Type a -> Maybe (CompositeType a)
Type.outToComposite Type m
parentType
        HashSet Name
possibleFragments <- CompositeType m -> ReaderT (Validation m) Seq (HashSet Name)
forall (m :: * -> *) (m :: * -> *).
Monad m =>
CompositeType m -> ReaderT (Validation m) m (HashSet Name)
getPossibleTypes CompositeType m
fragmentType
        HashSet Name
possibleParents <- CompositeType m -> ReaderT (Validation m) Seq (HashSet Name)
forall (m :: * -> *) (m :: * -> *).
Monad m =>
CompositeType m -> ReaderT (Validation m) m (HashSet Name)
getPossibleTypes CompositeType m
parentComposite
        let fragmentTypeName :: Name
fragmentTypeName = CompositeType m -> Name
forall (m :: * -> *). CompositeType m -> Name
compositeTypeName CompositeType m
fragmentType
        let parentTypeName :: Name
parentTypeName = CompositeType m -> Name
forall (m :: * -> *). CompositeType m -> Name
compositeTypeName CompositeType m
parentComposite
        if HashSet Name -> Bool
forall a. HashSet a -> Bool
HashSet.null (HashSet Name -> Bool) -> HashSet Name -> Bool
forall a b. (a -> b) -> a -> b
$ HashSet Name -> HashSet Name -> HashSet Name
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
HashSet.intersection HashSet Name
possibleFragments HashSet Name
possibleParents
            then (Name, Name) -> ReaderT (Validation m) Seq (Name, Name)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
fragmentTypeName, Name
parentTypeName)
            else Seq (Name, Name) -> ReaderT (Validation m) Seq (Name, Name)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Seq (Name, Name)
forall a. Monoid a => a
mempty
    getPossibleTypeList :: CompositeType m -> ReaderT (Validation m) m [Type m]
getPossibleTypeList (Type.CompositeObjectType ObjectType m
objectType) =
        [Type m] -> ReaderT (Validation m) m [Type m]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ObjectType m -> Type m
forall (m :: * -> *). ObjectType m -> Type m
Schema.ObjectType ObjectType m
objectType]
    getPossibleTypeList (Type.CompositeUnionType UnionType m
unionType) =
        let Out.UnionType Name
_ Maybe Name
_ [ObjectType m]
members = UnionType m
unionType
         in [Type m] -> ReaderT (Validation m) m [Type m]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Type m] -> ReaderT (Validation m) m [Type m])
-> [Type m] -> ReaderT (Validation m) m [Type m]
forall a b. (a -> b) -> a -> b
$ ObjectType m -> Type m
forall (m :: * -> *). ObjectType m -> Type m
Schema.ObjectType (ObjectType m -> Type m) -> [ObjectType m] -> [Type m]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ObjectType m]
members
    getPossibleTypeList (Type.CompositeInterfaceType InterfaceType m
interfaceType) =
        let Out.InterfaceType Name
typeName Maybe Name
_ [InterfaceType m]
_ HashMap Name (Field m)
_ = InterfaceType m
interfaceType
         in [Type m] -> Name -> HashMap Name [Type m] -> [Type m]
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
HashMap.lookupDefault [] Name
typeName
        (HashMap Name [Type m] -> [Type m])
-> ReaderT (Validation m) m (HashMap Name [Type m])
-> ReaderT (Validation m) m [Type m]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Validation m -> HashMap Name [Type m])
-> ReaderT (Validation m) m (HashMap Name [Type m])
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks (Schema m -> HashMap Name [Type m]
forall (m :: * -> *). Schema m -> HashMap Name [Type m]
Schema.implementations (Schema m -> HashMap Name [Type m])
-> (Validation m -> Schema m)
-> Validation m
-> HashMap Name [Type m]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validation m -> Schema m
forall (m :: * -> *). Validation m -> Schema m
schema)
    getPossibleTypes :: CompositeType m -> ReaderT (Validation m) m (HashSet Name)
getPossibleTypes CompositeType m
compositeType
        = (Type m -> HashSet Name -> HashSet Name)
-> HashSet Name -> [Type m] -> HashSet Name
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Name -> HashSet Name -> HashSet Name
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HashSet.insert (Name -> HashSet Name -> HashSet Name)
-> (Type m -> Name) -> Type m -> HashSet Name -> HashSet Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type m -> Name
forall (m :: * -> *). Type m -> Name
internalTypeName) HashSet Name
forall a. HashSet a
HashSet.empty
        ([Type m] -> HashSet Name)
-> ReaderT (Validation m) m [Type m]
-> ReaderT (Validation m) m (HashSet Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CompositeType m -> ReaderT (Validation m) m [Type m]
forall (m :: * -> *) (m :: * -> *).
Monad m =>
CompositeType m -> ReaderT (Validation m) m [Type m]
getPossibleTypeList CompositeType m
compositeType

internalTypeName :: forall m. Schema.Type m -> Full.Name
internalTypeName :: Type m -> Name
internalTypeName (Schema.ScalarType (Definition.ScalarType Name
typeName Maybe Name
_)) =
    Name
typeName
internalTypeName (Schema.EnumType (Definition.EnumType Name
typeName Maybe Name
_ HashMap Name EnumValue
_)) = Name
typeName
internalTypeName (Schema.ObjectType (Out.ObjectType Name
typeName Maybe Name
_ [InterfaceType m]
_ HashMap Name (Resolver m)
_)) = Name
typeName
internalTypeName (Schema.InputObjectType (In.InputObjectType Name
typeName Maybe Name
_ HashMap Name InputField
_)) =
    Name
typeName
internalTypeName (Schema.InterfaceType (Out.InterfaceType Name
typeName Maybe Name
_ [InterfaceType m]
_ HashMap Name (Field m)
_)) =
    Name
typeName
internalTypeName (Schema.UnionType (Out.UnionType Name
typeName Maybe Name
_ [ObjectType m]
_)) = Name
typeName

findSpreadTarget :: Full.Name -> ReaderT (Validation m1) Seq Full.TypeCondition
findSpreadTarget :: Name -> ReaderT (Validation m1) Seq Name
findSpreadTarget Name
fragmentName = do
    Document
ast' <- (Validation m1 -> Document) -> ReaderT (Validation m1) Seq Document
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Validation m1 -> Document
forall (m :: * -> *). Validation m -> Document
ast
    let target :: Maybe Definition
target = (Definition -> Bool) -> Document -> Maybe Definition
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Name -> Definition -> Bool
isSpreadTarget Name
fragmentName) Document
ast'
    Seq Name -> ReaderT (Validation m1) Seq Name
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Seq Name -> ReaderT (Validation m1) Seq Name)
-> Seq Name -> ReaderT (Validation m1) Seq Name
forall a b. (a -> b) -> a -> b
$ Maybe Name -> Seq Name
forall a. Maybe a -> Seq a
maybeToSeq (Maybe Name -> Seq Name) -> Maybe Name -> Seq Name
forall a b. (a -> b) -> a -> b
$ Maybe Definition
target Maybe Definition -> (Definition -> Maybe Name) -> Maybe Name
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Definition -> Maybe Name
extractTypeCondition
  where
    extractTypeCondition :: Definition -> Maybe Name
extractTypeCondition (Definition -> Maybe FragmentDefinition
viewFragment -> Just FragmentDefinition
fragmentDefinition) =
        let Full.FragmentDefinition Name
_ Name
typeCondition [Directive]
_ SelectionSet
_ Location
_ = FragmentDefinition
fragmentDefinition
            in Name -> Maybe Name
forall a. a -> Maybe a
Just Name
typeCondition
    extractTypeCondition Definition
_ = Maybe Name
forall a. Maybe a
Nothing

visitFragmentDefinition :: forall m
    . Text
    -> ValidationState m (Maybe Full.FragmentDefinition)
visitFragmentDefinition :: Name -> ValidationState m (Maybe FragmentDefinition)
visitFragmentDefinition Name
fragmentName = do
    Document
definitions <- ReaderT (Validation m) Seq Document
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) Document
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT (Validation m) Seq Document
 -> StateT (HashSet Name) (ReaderT (Validation m) Seq) Document)
-> ReaderT (Validation m) Seq Document
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) Document
forall a b. (a -> b) -> a -> b
$ (Validation m -> Document) -> ReaderT (Validation m) Seq Document
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Validation m -> Document
forall (m :: * -> *). Validation m -> Document
ast
    Bool
visited <- (HashSet Name -> Bool)
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) Bool
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets (Name -> HashSet Name -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
HashSet.member Name
fragmentName)
    (HashSet Name -> HashSet Name)
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (Name -> HashSet Name -> HashSet Name
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HashSet.insert Name
fragmentName)
    case (Definition -> Bool) -> Document -> Maybe Definition
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Name -> Definition -> Bool
isSpreadTarget Name
fragmentName) Document
definitions of
        Just (Definition -> Maybe FragmentDefinition
viewFragment -> Just FragmentDefinition
fragmentDefinition)
            | Bool -> Bool
not Bool
visited -> Maybe FragmentDefinition
-> ValidationState m (Maybe FragmentDefinition)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe FragmentDefinition
 -> ValidationState m (Maybe FragmentDefinition))
-> Maybe FragmentDefinition
-> ValidationState m (Maybe FragmentDefinition)
forall a b. (a -> b) -> a -> b
$ FragmentDefinition -> Maybe FragmentDefinition
forall a. a -> Maybe a
Just FragmentDefinition
fragmentDefinition
        Maybe Definition
_ -> Maybe FragmentDefinition
-> ValidationState m (Maybe FragmentDefinition)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe FragmentDefinition
forall a. Maybe a
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 :: Rule m
variablesInAllowedPositionRule = (OperationDefinition -> RuleT m) -> Rule m
forall (m :: * -> *). (OperationDefinition -> RuleT m) -> Rule m
OperationDefinitionRule ((OperationDefinition -> RuleT m) -> Rule m)
-> (OperationDefinition -> RuleT m) -> Rule m
forall a b. (a -> b) -> a -> b
$ \case
    Full.OperationDefinition OperationType
operationType Maybe Name
_ [VariableDefinition]
variables [Directive]
_ SelectionSet
selectionSet Location
_ -> do
        Schema m
schema' <- (Validation m -> Schema m) -> ReaderT (Validation m) Seq (Schema m)
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Validation m -> Schema m
forall (m :: * -> *). Validation m -> Schema m
schema
        let root :: ObjectType m -> RuleT m
root = [VariableDefinition]
-> SelectionSetOpt -> CompositeType m -> RuleT m
forall (t :: * -> *).
Foldable t =>
[VariableDefinition] -> t Selection -> CompositeType m -> RuleT m
go [VariableDefinition]
variables (SelectionSet -> SelectionSetOpt
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList SelectionSet
selectionSet) (CompositeType m -> RuleT m)
-> (ObjectType m -> CompositeType m) -> ObjectType m -> RuleT m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ObjectType m -> CompositeType m
forall (m :: * -> *). ObjectType m -> CompositeType m
Type.CompositeObjectType
        case OperationType
operationType of
            OperationType
Full.Query -> ObjectType m -> RuleT m
root (ObjectType m -> RuleT m) -> ObjectType m -> RuleT m
forall a b. (a -> b) -> a -> b
$ Schema m -> ObjectType m
forall (m :: * -> *). Schema m -> ObjectType m
Schema.query Schema m
schema'
            OperationType
Full.Mutation
                | Just ObjectType m
objectType <- Schema m -> Maybe (ObjectType m)
forall (m :: * -> *). Schema m -> Maybe (ObjectType m)
Schema.mutation Schema m
schema' -> ObjectType m -> RuleT m
root ObjectType m
objectType
            OperationType
Full.Subscription
                | Just ObjectType m
objectType <- Schema m -> Maybe (ObjectType m)
forall (m :: * -> *). Schema m -> Maybe (ObjectType m)
Schema.mutation Schema m
schema' -> ObjectType m -> RuleT m
root ObjectType m
objectType
            OperationType
_ -> Seq Error -> RuleT m
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Seq Error
forall a. Monoid a => a
mempty
    OperationDefinition
_ -> Seq Error -> RuleT m
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Seq Error
forall a. Monoid a => a
mempty
  where
    go :: [VariableDefinition] -> t Selection -> CompositeType m -> RuleT m
go [VariableDefinition]
variables t Selection
selections CompositeType m
selectionType = (Seq (Seq Error) -> Seq Error)
-> ReaderT (Validation m) Seq (Seq Error) -> RuleT m
forall (m :: * -> *) a (n :: * -> *) b r.
(m a -> n b) -> ReaderT r m a -> ReaderT r n b
mapReaderT ((Seq Error -> Seq Error -> Seq Error)
-> Seq Error -> Seq (Seq Error) -> Seq Error
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Seq Error -> Seq Error -> Seq Error
forall a. Semigroup a => a -> a -> a
(<>) Seq Error
forall a. Seq a
Seq.empty)
        (ReaderT (Validation m) Seq (Seq Error) -> RuleT m)
-> ReaderT (Validation m) Seq (Seq Error) -> RuleT m
forall a b. (a -> b) -> a -> b
$ (StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
 -> HashSet Name -> ReaderT (Validation m) Seq (Seq Error))
-> HashSet Name
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
-> ReaderT (Validation m) Seq (Seq Error)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
-> HashSet Name -> ReaderT (Validation m) Seq (Seq Error)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT HashSet Name
forall a. HashSet a
HashSet.empty
        (StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
 -> ReaderT (Validation m) Seq (Seq Error))
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
-> ReaderT (Validation m) Seq (Seq Error)
forall a b. (a -> b) -> a -> b
$ [VariableDefinition]
-> CompositeType m
-> SelectionSetOpt
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
forall (t :: * -> *).
Foldable t =>
[VariableDefinition]
-> CompositeType m
-> t Selection
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
visitSelectionSet [VariableDefinition]
variables CompositeType m
selectionType
        (SelectionSetOpt
 -> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error))
-> SelectionSetOpt
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
forall a b. (a -> b) -> a -> b
$ t Selection -> SelectionSetOpt
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t Selection
selections
    visitSelectionSet :: Foldable t
        => [Full.VariableDefinition]
        -> Type.CompositeType m
        -> t Full.Selection
        -> ValidationState m (Seq Error)
    visitSelectionSet :: [VariableDefinition]
-> CompositeType m
-> t Selection
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
visitSelectionSet [VariableDefinition]
variables CompositeType m
selectionType =
        (Seq Error
 -> Selection
 -> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error))
-> Seq Error
-> t Selection
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ([VariableDefinition]
-> CompositeType m
-> Seq Error
-> Selection
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
evaluateSelection [VariableDefinition]
variables CompositeType m
selectionType) Seq Error
forall a. Monoid a => a
mempty
    evaluateFieldSelection :: [VariableDefinition]
-> t Selection
-> Seq Error
-> Maybe (CompositeType m)
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
evaluateFieldSelection [VariableDefinition]
variables t Selection
selections Seq Error
accumulator = \case
        Just CompositeType m
newParentType -> do
            let folder :: Seq Error
-> Selection
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
folder = [VariableDefinition]
-> CompositeType m
-> Seq Error
-> Selection
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
evaluateSelection [VariableDefinition]
variables CompositeType m
newParentType
            Seq Error
selectionErrors <- (Seq Error
 -> Selection
 -> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error))
-> Seq Error
-> t Selection
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Seq Error
-> Selection
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
folder Seq Error
accumulator t Selection
selections
            Seq Error
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Seq Error
 -> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error))
-> Seq Error
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
forall a b. (a -> b) -> a -> b
$ Seq Error
accumulator Seq Error -> Seq Error -> Seq Error
forall a. Semigroup a => a -> a -> a
<> Seq Error
selectionErrors
        Maybe (CompositeType m)
Nothing -> Seq Error
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Seq Error
accumulator
    evaluateSelection :: [Full.VariableDefinition]
        -> Type.CompositeType m
        -> Seq Error
        -> Full.Selection
        -> ValidationState m (Seq Error)
    evaluateSelection :: [VariableDefinition]
-> CompositeType m
-> Seq Error
-> Selection
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
evaluateSelection [VariableDefinition]
variables CompositeType m
selectionType Seq Error
accumulator Selection
selection
        | Full.FragmentSpreadSelection FragmentSpread
spread <- Selection
selection
        , Full.FragmentSpread Name
fragmentName [Directive]
_ Location
_ <- FragmentSpread
spread = do
            HashMap Name (Type m)
types' <- ReaderT (Validation m) Seq (HashMap Name (Type m))
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (HashMap Name (Type m))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT (Validation m) Seq (HashMap Name (Type m))
 -> StateT
      (HashSet Name)
      (ReaderT (Validation m) Seq)
      (HashMap Name (Type m)))
-> ReaderT (Validation m) Seq (HashMap Name (Type m))
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (HashMap Name (Type m))
forall a b. (a -> b) -> a -> b
$ (Validation m -> HashMap Name (Type m))
-> ReaderT (Validation m) Seq (HashMap Name (Type m))
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks ((Validation m -> HashMap Name (Type m))
 -> ReaderT (Validation m) Seq (HashMap Name (Type m)))
-> (Validation m -> HashMap Name (Type m))
-> ReaderT (Validation m) Seq (HashMap Name (Type m))
forall a b. (a -> b) -> a -> b
$ Schema m -> HashMap Name (Type m)
forall (m :: * -> *). Schema m -> HashMap Name (Type m)
Schema.types (Schema m -> HashMap Name (Type m))
-> (Validation m -> Schema m)
-> Validation m
-> HashMap Name (Type m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validation m -> Schema m
forall (m :: * -> *). Validation m -> Schema m
schema
            Maybe FragmentDefinition
nonVisitedFragmentDefinition <- Name -> ValidationState m (Maybe FragmentDefinition)
forall (m :: * -> *).
Name -> ValidationState m (Maybe FragmentDefinition)
visitFragmentDefinition Name
fragmentName
            case Maybe FragmentDefinition
nonVisitedFragmentDefinition of
                Just FragmentDefinition
fragmentDefinition
                    | Full.FragmentDefinition Name
_ Name
typeCondition [Directive]
_ SelectionSet
_ Location
_ <- FragmentDefinition
fragmentDefinition
                    , Just CompositeType m
spreadType <- Name -> HashMap Name (Type m) -> Maybe (CompositeType m)
forall (m :: * -> *).
Name -> HashMap Name (Type m) -> Maybe (CompositeType m)
Type.lookupTypeCondition Name
typeCondition HashMap Name (Type m)
types' -> do
                        Seq Error
spreadErrors <- [VariableDefinition]
-> FragmentSpread
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
spreadVariables [VariableDefinition]
variables FragmentSpread
spread
                        Seq Error
selectionErrors <- [VariableDefinition]
-> CompositeType m
-> FragmentDefinition
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
diveIntoSpread [VariableDefinition]
variables CompositeType m
spreadType FragmentDefinition
fragmentDefinition
                        Seq Error
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Seq Error
 -> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error))
-> Seq Error
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
forall a b. (a -> b) -> a -> b
$ Seq Error
accumulator Seq Error -> Seq Error -> Seq Error
forall a. Semigroup a => a -> a -> a
<> Seq Error
spreadErrors Seq Error -> Seq Error -> Seq Error
forall a. Semigroup a => a -> a -> a
<> Seq Error
selectionErrors
                Maybe FragmentDefinition
_ -> ReaderT (Validation m) Seq (Seq Error)
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT (Validation m) Seq (Seq Error)
 -> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error))
-> ReaderT (Validation m) Seq (Seq Error)
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
forall a b. (a -> b) -> a -> b
$ Seq (Seq Error) -> ReaderT (Validation m) Seq (Seq Error)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Seq (Seq Error)
forall a. Monoid a => a
mempty
        | Full.FieldSelection Field
fieldSelection <- Selection
selection
        , Full.Field Maybe Name
_ Name
fieldName [Argument]
_ [Directive]
_ SelectionSetOpt
subselections Location
_ <- Field
fieldSelection =
            case Name -> CompositeType m -> Maybe (Field m)
forall (a :: * -> *). Name -> CompositeType a -> Maybe (Field a)
Type.lookupCompositeField Name
fieldName CompositeType m
selectionType of
                Just (Out.Field Maybe Name
_ Type m
typeField Arguments
argumentTypes) -> do
                    Seq Error
fieldErrors <- [VariableDefinition]
-> Arguments
-> Field
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
fieldVariables [VariableDefinition]
variables Arguments
argumentTypes Field
fieldSelection
                    Seq Error
selectionErrors <- [VariableDefinition]
-> SelectionSetOpt
-> Seq Error
-> Maybe (CompositeType m)
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
forall (t :: * -> *).
Foldable t =>
[VariableDefinition]
-> t Selection
-> Seq Error
-> Maybe (CompositeType m)
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
evaluateFieldSelection [VariableDefinition]
variables SelectionSetOpt
subselections Seq Error
accumulator
                            (Maybe (CompositeType m)
 -> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error))
-> Maybe (CompositeType m)
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
forall a b. (a -> b) -> a -> b
$ Type m -> Maybe (CompositeType m)
forall (a :: * -> *). Type a -> Maybe (CompositeType a)
Type.outToComposite Type m
typeField
                    Seq Error
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Seq Error
 -> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error))
-> Seq Error
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
forall a b. (a -> b) -> a -> b
$ Seq Error
selectionErrors Seq Error -> Seq Error -> Seq Error
forall a. Semigroup a => a -> a -> a
<> Seq Error
fieldErrors
                Maybe (Field m)
Nothing -> Seq Error
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Seq Error
accumulator
        | Full.InlineFragmentSelection InlineFragment
inlineSelection <- Selection
selection
        , Full.InlineFragment Maybe Name
typeCondition [Directive]
_ SelectionSet
subselections Location
_ <- InlineFragment
inlineSelection = do
            HashMap Name (Type m)
types' <- ReaderT (Validation m) Seq (HashMap Name (Type m))
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (HashMap Name (Type m))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT (Validation m) Seq (HashMap Name (Type m))
 -> StateT
      (HashSet Name)
      (ReaderT (Validation m) Seq)
      (HashMap Name (Type m)))
-> ReaderT (Validation m) Seq (HashMap Name (Type m))
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (HashMap Name (Type m))
forall a b. (a -> b) -> a -> b
$ (Validation m -> HashMap Name (Type m))
-> ReaderT (Validation m) Seq (HashMap Name (Type m))
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks ((Validation m -> HashMap Name (Type m))
 -> ReaderT (Validation m) Seq (HashMap Name (Type m)))
-> (Validation m -> HashMap Name (Type m))
-> ReaderT (Validation m) Seq (HashMap Name (Type m))
forall a b. (a -> b) -> a -> b
$ Schema m -> HashMap Name (Type m)
forall (m :: * -> *). Schema m -> HashMap Name (Type m)
Schema.types (Schema m -> HashMap Name (Type m))
-> (Validation m -> Schema m)
-> Validation m
-> HashMap Name (Type m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validation m -> Schema m
forall (m :: * -> *). Validation m -> Schema m
schema
            let inlineType :: CompositeType m
inlineType = CompositeType m -> Maybe (CompositeType m) -> CompositeType m
forall a. a -> Maybe a -> a
fromMaybe CompositeType m
selectionType
                    (Maybe (CompositeType m) -> CompositeType m)
-> Maybe (CompositeType m) -> CompositeType m
forall a b. (a -> b) -> a -> b
$ Maybe Name
typeCondition Maybe Name
-> (Name -> Maybe (CompositeType m)) -> Maybe (CompositeType m)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Name -> HashMap Name (Type m) -> Maybe (CompositeType m))
-> HashMap Name (Type m) -> Name -> Maybe (CompositeType m)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Name -> HashMap Name (Type m) -> Maybe (CompositeType m)
forall (m :: * -> *).
Name -> HashMap Name (Type m) -> Maybe (CompositeType m)
Type.lookupTypeCondition HashMap Name (Type m)
types'
            Seq Error
fragmentErrors <- [VariableDefinition]
-> InlineFragment
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
inlineVariables [VariableDefinition]
variables InlineFragment
inlineSelection
            let folder :: Seq Error
-> Selection
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
folder = [VariableDefinition]
-> CompositeType m
-> Seq Error
-> Selection
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
evaluateSelection [VariableDefinition]
variables CompositeType m
inlineType
            Seq Error
selectionErrors <- (Seq Error
 -> Selection
 -> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error))
-> Seq Error
-> SelectionSet
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Seq Error
-> Selection
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
folder Seq Error
accumulator SelectionSet
subselections
            Seq Error
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Seq Error
 -> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error))
-> Seq Error
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
forall a b. (a -> b) -> a -> b
$ Seq Error
accumulator Seq Error -> Seq Error -> Seq Error
forall a. Semigroup a => a -> a -> a
<> Seq Error
fragmentErrors Seq Error -> Seq Error -> Seq Error
forall a. Semigroup a => a -> a -> a
<> Seq Error
selectionErrors
    inlineVariables :: [VariableDefinition]
-> InlineFragment
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
inlineVariables [VariableDefinition]
variables InlineFragment
inline
        | Full.InlineFragment Maybe Name
_ [Directive]
directives' SelectionSet
_ Location
_ <- InlineFragment
inline =
            [VariableDefinition]
-> [Directive]
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
forall (t :: * -> *).
Traversable t =>
[VariableDefinition]
-> t Directive
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
mapDirectives [VariableDefinition]
variables [Directive]
directives'
    fieldVariables :: [Full.VariableDefinition]
        -> In.Arguments
        -> Full.Field
        -> ValidationState m (Seq Error)
    fieldVariables :: [VariableDefinition]
-> Arguments
-> Field
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
fieldVariables [VariableDefinition]
variables Arguments
argumentTypes Field
fieldSelection = do
        let Full.Field Maybe Name
_ Name
_ [Argument]
arguments [Directive]
directives' SelectionSetOpt
_ Location
_ = Field
fieldSelection
        Seq Error
argumentErrors <- [VariableDefinition]
-> Arguments
-> [Argument]
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
forall (t :: * -> *).
Traversable t =>
[VariableDefinition]
-> Arguments
-> t Argument
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
mapArguments [VariableDefinition]
variables Arguments
argumentTypes [Argument]
arguments
        Seq Error
directiveErrors <- [VariableDefinition]
-> [Directive]
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
forall (t :: * -> *).
Traversable t =>
[VariableDefinition]
-> t Directive
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
mapDirectives [VariableDefinition]
variables [Directive]
directives'
        Seq Error
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Seq Error
 -> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error))
-> Seq Error
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
forall a b. (a -> b) -> a -> b
$ Seq Error
argumentErrors Seq Error -> Seq Error -> Seq Error
forall a. Semigroup a => a -> a -> a
<> Seq Error
directiveErrors
    spreadVariables :: [VariableDefinition]
-> FragmentSpread
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
spreadVariables [VariableDefinition]
variables (Full.FragmentSpread Name
_ [Directive]
directives' Location
_) =
        [VariableDefinition]
-> [Directive]
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
forall (t :: * -> *).
Traversable t =>
[VariableDefinition]
-> t Directive
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
mapDirectives [VariableDefinition]
variables [Directive]
directives'
    diveIntoSpread :: [VariableDefinition]
-> CompositeType m
-> FragmentDefinition
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
diveIntoSpread [VariableDefinition]
variables CompositeType m
fieldType FragmentDefinition
fragmentDefinition = do
        let Full.FragmentDefinition Name
_ Name
_ [Directive]
directives' SelectionSet
selections Location
_ =
                FragmentDefinition
fragmentDefinition
        Seq Error
selectionErrors <- [VariableDefinition]
-> CompositeType m
-> SelectionSet
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
forall (t :: * -> *).
Foldable t =>
[VariableDefinition]
-> CompositeType m
-> t Selection
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
visitSelectionSet [VariableDefinition]
variables CompositeType m
fieldType SelectionSet
selections
        Seq Error
directiveErrors <- [VariableDefinition]
-> [Directive]
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
forall (t :: * -> *).
Traversable t =>
[VariableDefinition]
-> t Directive
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
mapDirectives [VariableDefinition]
variables [Directive]
directives'
        Seq Error
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Seq Error
 -> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error))
-> Seq Error
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
forall a b. (a -> b) -> a -> b
$ Seq Error
selectionErrors Seq Error -> Seq Error -> Seq Error
forall a. Semigroup a => a -> a -> a
<> Seq Error
directiveErrors
    findDirectiveVariables :: [VariableDefinition]
-> Directive
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
findDirectiveVariables [VariableDefinition]
variables Directive
directive = do
        let Full.Directive Name
directiveName [Argument]
arguments Location
_ = Directive
directive
        HashMap Name Directive
directiveDefinitions <- ReaderT (Validation m) Seq (HashMap Name Directive)
-> StateT
     (HashSet Name)
     (ReaderT (Validation m) Seq)
     (HashMap Name Directive)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT (Validation m) Seq (HashMap Name Directive)
 -> StateT
      (HashSet Name)
      (ReaderT (Validation m) Seq)
      (HashMap Name Directive))
-> ReaderT (Validation m) Seq (HashMap Name Directive)
-> StateT
     (HashSet Name)
     (ReaderT (Validation m) Seq)
     (HashMap Name Directive)
forall a b. (a -> b) -> a -> b
$ (Validation m -> HashMap Name Directive)
-> ReaderT (Validation m) Seq (HashMap Name Directive)
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks ((Validation m -> HashMap Name Directive)
 -> ReaderT (Validation m) Seq (HashMap Name Directive))
-> (Validation m -> HashMap Name Directive)
-> ReaderT (Validation m) Seq (HashMap Name Directive)
forall a b. (a -> b) -> a -> b
$ Schema m -> HashMap Name Directive
forall (m :: * -> *). Schema m -> HashMap Name Directive
Schema.directives (Schema m -> HashMap Name Directive)
-> (Validation m -> Schema m)
-> Validation m
-> HashMap Name Directive
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validation m -> Schema m
forall (m :: * -> *). Validation m -> Schema m
schema
        case Name -> HashMap Name Directive -> Maybe Directive
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
directiveName HashMap Name Directive
directiveDefinitions of
            Just (Schema.Directive Maybe Name
_ [DirectiveLocation]
_ Arguments
directiveArguments) ->
                [VariableDefinition]
-> Arguments
-> [Argument]
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
forall (t :: * -> *).
Traversable t =>
[VariableDefinition]
-> Arguments
-> t Argument
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
mapArguments [VariableDefinition]
variables Arguments
directiveArguments [Argument]
arguments
            Maybe Directive
Nothing -> Seq Error
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Seq Error
forall a. Monoid a => a
mempty
    mapArguments :: [VariableDefinition]
-> Arguments
-> t Argument
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
mapArguments [VariableDefinition]
variables Arguments
argumentTypes = (t (Seq Error) -> Seq Error)
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (t (Seq Error))
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap t (Seq Error) -> Seq Error
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
        (StateT (HashSet Name) (ReaderT (Validation m) Seq) (t (Seq Error))
 -> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error))
-> (t Argument
    -> StateT
         (HashSet Name) (ReaderT (Validation m) Seq) (t (Seq Error)))
-> t Argument
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Argument
 -> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error))
-> t Argument
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (t (Seq Error))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ([VariableDefinition]
-> Arguments
-> Argument
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
findArgumentVariables [VariableDefinition]
variables Arguments
argumentTypes)
    mapDirectives :: [VariableDefinition]
-> t Directive
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
mapDirectives [VariableDefinition]
variables = (t (Seq Error) -> Seq Error)
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (t (Seq Error))
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap t (Seq Error) -> Seq Error
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
        (StateT (HashSet Name) (ReaderT (Validation m) Seq) (t (Seq Error))
 -> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error))
-> (t Directive
    -> StateT
         (HashSet Name) (ReaderT (Validation m) Seq) (t (Seq Error)))
-> t Directive
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Directive
 -> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error))
-> t Directive
-> StateT
     (HashSet Name) (ReaderT (Validation m) Seq) (t (Seq Error))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ([VariableDefinition]
-> Directive
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
findDirectiveVariables [VariableDefinition]
variables)
    lookupInputObject :: t VariableDefinition
-> Node Value -> Maybe (Type, Maybe Value) -> f (Seq Error)
lookupInputObject t VariableDefinition
variables Node Value
objectFieldValue Maybe (Type, Maybe Value)
locationInfo
        | Full.Node{ $sel:node:Node :: forall a. Node a -> a
node = Full.Object [ObjectField Value]
objectFields } <- Node Value
objectFieldValue
        , Just (Type
expectedType, Maybe Value
_) <- Maybe (Type, Maybe Value)
locationInfo
        , In.InputObjectBaseType InputObjectType
inputObjectType <- Type
expectedType
        , In.InputObjectType Name
_ Maybe Name
_ HashMap Name InputField
fieldTypes' <- InputObjectType
inputObjectType =
            [Seq Error] -> Seq Error
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([Seq Error] -> Seq Error) -> f [Seq Error] -> f (Seq Error)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ObjectField Value -> f (Seq Error))
-> [ObjectField Value] -> f [Seq Error]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (t VariableDefinition
-> HashMap Name InputField -> ObjectField Value -> f (Seq Error)
traverseObjectField t VariableDefinition
variables HashMap Name InputField
fieldTypes') [ObjectField Value]
objectFields
        | Bool
otherwise = Seq Error -> f (Seq Error)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Seq Error
forall a. Monoid a => a
mempty
    maybeUsageAllowed :: Name
-> t VariableDefinition -> Maybe (Type, Maybe a) -> f (Seq Error)
maybeUsageAllowed Name
variableName t VariableDefinition
variables Maybe (Type, Maybe a)
locationInfo
        | Just (Type
locationType, Maybe a
locationValue) <- Maybe (Type, Maybe a)
locationInfo
        , VariableDefinition -> Bool
findVariableDefinition' <- Name -> VariableDefinition -> Bool
findVariableDefinition Name
variableName
        , Just VariableDefinition
variableDefinition <- (VariableDefinition -> Bool)
-> t VariableDefinition -> Maybe VariableDefinition
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find VariableDefinition -> Bool
findVariableDefinition' t VariableDefinition
variables
            = Maybe Error -> Seq Error
forall a. Maybe a -> Seq a
maybeToSeq
            (Maybe Error -> Seq Error) -> f (Maybe Error) -> f (Seq Error)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Maybe a -> VariableDefinition -> f (Maybe Error)
forall (f :: * -> *) a.
Applicative f =>
Type -> Maybe a -> VariableDefinition -> f (Maybe Error)
isVariableUsageAllowed Type
locationType Maybe a
locationValue VariableDefinition
variableDefinition
        | Bool
otherwise = Seq Error -> f (Seq Error)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Seq Error
forall a. Monoid a => a
mempty
    findArgumentVariables :: [Full.VariableDefinition]
        -> HashMap Full.Name In.Argument
        -> Full.Argument
        -> ValidationState m (Seq Error)
    findArgumentVariables :: [VariableDefinition]
-> Arguments
-> Argument
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
findArgumentVariables [VariableDefinition]
variables Arguments
argumentTypes Argument
argument
        | Full.Argument Name
argumentName Node Value
argumentValue Location
_ <- Argument
argument
        , Full.Node{ $sel:node:Node :: forall a. Node a -> a
node = Full.Variable Name
variableName } <- Node Value
argumentValue
            = Name
-> [VariableDefinition]
-> Maybe (Type, Maybe Value)
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Applicative f) =>
Name
-> t VariableDefinition -> Maybe (Type, Maybe a) -> f (Seq Error)
maybeUsageAllowed Name
variableName [VariableDefinition]
variables
            (Maybe (Type, Maybe Value)
 -> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error))
-> Maybe (Type, Maybe Value)
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
forall a b. (a -> b) -> a -> b
$ (Argument -> (Type, Maybe Value))
-> Arguments -> Name -> Maybe (Type, Maybe Value)
forall k a b.
(Eq k, Hashable k) =>
(a -> b) -> HashMap k a -> k -> Maybe b
locationPair Argument -> (Type, Maybe Value)
extractArgument Arguments
argumentTypes Name
argumentName
        | Full.Argument Name
argumentName Node Value
argumentValue Location
_ <- Argument
argument
            = [VariableDefinition]
-> Node Value
-> Maybe (Type, Maybe Value)
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
forall (f :: * -> *) (t :: * -> *).
(Applicative f, Foldable t) =>
t VariableDefinition
-> Node Value -> Maybe (Type, Maybe Value) -> f (Seq Error)
lookupInputObject [VariableDefinition]
variables Node Value
argumentValue
            (Maybe (Type, Maybe Value)
 -> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error))
-> Maybe (Type, Maybe Value)
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) (Seq Error)
forall a b. (a -> b) -> a -> b
$ (Argument -> (Type, Maybe Value))
-> Arguments -> Name -> Maybe (Type, Maybe Value)
forall k a b.
(Eq k, Hashable k) =>
(a -> b) -> HashMap k a -> k -> Maybe b
locationPair Argument -> (Type, Maybe Value)
extractArgument Arguments
argumentTypes Name
argumentName
    extractField :: InputField -> (Type, Maybe Value)
extractField (In.InputField Maybe Name
_ Type
locationType Maybe Value
locationValue) =
        (Type
locationType, Maybe Value
locationValue)
    extractArgument :: Argument -> (Type, Maybe Value)
extractArgument (In.Argument Maybe Name
_ Type
locationType Maybe Value
locationValue) =
        (Type
locationType, Maybe Value
locationValue)
    locationPair :: (a -> b) -> HashMap k a -> k -> Maybe b
locationPair a -> b
extract HashMap k a
fieldTypes k
name =
        a -> b
extract (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> k -> HashMap k a -> Maybe a
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup k
name HashMap k a
fieldTypes
    traverseObjectField :: t VariableDefinition
-> HashMap Name InputField -> ObjectField Value -> f (Seq Error)
traverseObjectField t VariableDefinition
variables HashMap Name InputField
fieldTypes Full.ObjectField{Name
Node Value
Location
$sel:location:ObjectField :: forall a. ObjectField a -> Location
$sel:value:ObjectField :: forall a. ObjectField a -> Node a
$sel:name:ObjectField :: forall a. ObjectField a -> Name
location :: Location
value :: Node Value
name :: Name
..}
        | Full.Node{ $sel:node:Node :: forall a. Node a -> a
node = Full.Variable Name
variableName } <- Node Value
value
            = Name
-> t VariableDefinition
-> Maybe (Type, Maybe Value)
-> f (Seq Error)
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Applicative f) =>
Name
-> t VariableDefinition -> Maybe (Type, Maybe a) -> f (Seq Error)
maybeUsageAllowed Name
variableName t VariableDefinition
variables
            (Maybe (Type, Maybe Value) -> f (Seq Error))
-> Maybe (Type, Maybe Value) -> f (Seq Error)
forall a b. (a -> b) -> a -> b
$ (InputField -> (Type, Maybe Value))
-> HashMap Name InputField -> Name -> Maybe (Type, Maybe Value)
forall k a b.
(Eq k, Hashable k) =>
(a -> b) -> HashMap k a -> k -> Maybe b
locationPair InputField -> (Type, Maybe Value)
extractField HashMap Name InputField
fieldTypes Name
name
        | Bool
otherwise = t VariableDefinition
-> Node Value -> Maybe (Type, Maybe Value) -> f (Seq Error)
lookupInputObject t VariableDefinition
variables Node Value
value
            (Maybe (Type, Maybe Value) -> f (Seq Error))
-> Maybe (Type, Maybe Value) -> f (Seq Error)
forall a b. (a -> b) -> a -> b
$  (InputField -> (Type, Maybe Value))
-> HashMap Name InputField -> Name -> Maybe (Type, Maybe Value)
forall k a b.
(Eq k, Hashable k) =>
(a -> b) -> HashMap k a -> k -> Maybe b
locationPair InputField -> (Type, Maybe Value)
extractField HashMap Name InputField
fieldTypes Name
name
    findVariableDefinition :: Name -> VariableDefinition -> Bool
findVariableDefinition Name
variableName VariableDefinition
variableDefinition =
        let Full.VariableDefinition Name
variableName' Type
_ Maybe (Node ConstValue)
_ Location
_ = VariableDefinition
variableDefinition
         in Name
variableName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
variableName'
    isVariableUsageAllowed :: Type -> Maybe a -> VariableDefinition -> f (Maybe Error)
isVariableUsageAllowed Type
locationType Maybe a
locationDefaultValue VariableDefinition
variableDefinition
        | Full.VariableDefinition Name
_ Type
variableType Maybe (Node ConstValue)
_ Location
_ <- VariableDefinition
variableDefinition
        , Full.TypeNonNull NonNullType
_ <- Type
variableType =
            VariableDefinition -> Type -> f (Maybe Error)
forall (f :: * -> *).
Applicative f =>
VariableDefinition -> Type -> f (Maybe Error)
typesCompatibleOrError VariableDefinition
variableDefinition Type
locationType
        | Just Type
nullableLocationType <- Type -> Maybe Type
unwrapInType Type
locationType
        , Full.VariableDefinition Name
_ Type
variableType Maybe (Node ConstValue)
variableDefaultValue Location
_ <-
            VariableDefinition
variableDefinition
        , Bool
hasNonNullVariableDefaultValue' <-
            Maybe (Node ConstValue) -> Bool
hasNonNullVariableDefaultValue Maybe (Node ConstValue)
variableDefaultValue
        , Bool
hasLocationDefaultValue <- Maybe a -> Bool
forall a. Maybe a -> Bool
isJust Maybe a
locationDefaultValue =
            if (Bool
hasNonNullVariableDefaultValue' Bool -> Bool -> Bool
|| Bool
hasLocationDefaultValue)
                Bool -> Bool -> Bool
&& Type -> Type -> Bool
areTypesCompatible Type
variableType Type
nullableLocationType
                then Maybe Error -> f (Maybe Error)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Error
forall a. Maybe a
Nothing
                else Maybe Error -> f (Maybe Error)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Error -> f (Maybe Error)) -> Maybe Error -> f (Maybe Error)
forall a b. (a -> b) -> a -> b
$ VariableDefinition -> Type -> Maybe Error
forall a. Show a => VariableDefinition -> a -> Maybe Error
makeError VariableDefinition
variableDefinition Type
locationType
        | Bool
otherwise = VariableDefinition -> Type -> f (Maybe Error)
forall (f :: * -> *).
Applicative f =>
VariableDefinition -> Type -> f (Maybe Error)
typesCompatibleOrError VariableDefinition
variableDefinition Type
locationType
    typesCompatibleOrError :: VariableDefinition -> Type -> f (Maybe Error)
typesCompatibleOrError VariableDefinition
variableDefinition Type
locationType
        | Full.VariableDefinition Name
_ Type
variableType Maybe (Node ConstValue)
_ Location
_ <- VariableDefinition
variableDefinition
        , Type -> Type -> Bool
areTypesCompatible Type
variableType Type
locationType = Maybe Error -> f (Maybe Error)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Error
forall a. Maybe a
Nothing
        | Bool
otherwise = Maybe Error -> f (Maybe Error)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Error -> f (Maybe Error)) -> Maybe Error -> f (Maybe Error)
forall a b. (a -> b) -> a -> b
$ VariableDefinition -> Type -> Maybe Error
forall a. Show a => VariableDefinition -> a -> Maybe Error
makeError VariableDefinition
variableDefinition Type
locationType
    areTypesCompatible :: Type -> Type -> Bool
areTypesCompatible Type
nonNullType (Type -> Maybe Type
unwrapInType -> Just Type
nullableLocationType)
        | Full.TypeNonNull (Full.NonNullTypeNamed Name
namedType) <- Type
nonNullType =
            Type -> Type -> Bool
areTypesCompatible (Name -> Type
Full.TypeNamed Name
namedType) Type
nullableLocationType
        | Full.TypeNonNull (Full.NonNullTypeList Type
namedList) <- Type
nonNullType =
            Type -> Type -> Bool
areTypesCompatible (Type -> Type
Full.TypeList Type
namedList) Type
nullableLocationType
    areTypesCompatible Type
_ (Type -> Bool
In.isNonNullType -> Bool
True) = Bool
False
    areTypesCompatible (Full.TypeNonNull NonNullType
nonNullType) Type
locationType
        | Full.NonNullTypeNamed Name
namedType <- NonNullType
nonNullType =
            Type -> Type -> Bool
areTypesCompatible (Name -> Type
Full.TypeNamed Name
namedType) Type
locationType
        | Full.NonNullTypeList Type
namedType <- NonNullType
nonNullType =
            Type -> Type -> Bool
areTypesCompatible (Type -> Type
Full.TypeList Type
namedType) Type
locationType
    areTypesCompatible Type
variableType Type
locationType
        | Full.TypeList Type
itemVariableType <- Type
variableType
        , In.ListType Type
itemLocationType <- Type
locationType =
            Type -> Type -> Bool
areTypesCompatible Type
itemVariableType Type
itemLocationType
        | Type -> Type -> Bool
areIdentical Type
variableType Type
locationType = Bool
True
        | Bool
otherwise = Bool
False
    areIdentical :: Type -> Type -> Bool
areIdentical (Full.TypeList Type
typeList) (In.ListType Type
itemLocationType) =
        Type -> Type -> Bool
areIdentical Type
typeList Type
itemLocationType
    areIdentical (Full.TypeNonNull NonNullType
nonNullType) Type
locationType
        | Full.NonNullTypeList Type
nonNullList <- NonNullType
nonNullType
        , In.NonNullListType  Type
itemLocationType <- Type
locationType =
            Type -> Type -> Bool
areIdentical Type
nonNullList Type
itemLocationType
        | Full.NonNullTypeNamed Name
_ <- NonNullType
nonNullType
        , In.ListBaseType Type
_ <- Type
locationType = Bool
False
        | Full.NonNullTypeNamed Name
nonNullList <- NonNullType
nonNullType
        , Type -> Bool
In.isNonNullType Type
locationType =
            Name
nonNullList Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Type -> Name
inputTypeName Type
locationType
    areIdentical (Full.TypeNamed Name
_) (In.ListBaseType Type
_) = Bool
False
    areIdentical (Full.TypeNamed Name
typeNamed) Type
locationType
        | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Type -> Bool
In.isNonNullType Type
locationType =
            Name
typeNamed Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Type -> Name
inputTypeName Type
locationType
    areIdentical Type
_ Type
_ = Bool
False
    hasNonNullVariableDefaultValue :: Maybe (Node ConstValue) -> Bool
hasNonNullVariableDefaultValue (Just (Full.Node ConstValue
Full.ConstNull Location
_)) = Bool
False
    hasNonNullVariableDefaultValue Maybe (Node ConstValue)
Nothing = Bool
False
    hasNonNullVariableDefaultValue Maybe (Node ConstValue)
_ = Bool
True
    makeError :: VariableDefinition -> a -> Maybe Error
makeError VariableDefinition
variableDefinition a
expectedType =
        let Full.VariableDefinition Name
variableName Type
variableType Maybe (Node ConstValue)
_ Location
location' =
                VariableDefinition
variableDefinition
         in Error -> Maybe Error
forall a. a -> Maybe a
Just (Error -> Maybe Error) -> Error -> Maybe Error
forall a b. (a -> b) -> a -> b
$ Error :: String -> [Location] -> Error
Error
            { message :: String
message = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                [ String
"Variable \"$"
                , Name -> String
Text.unpack Name
variableName
                , String
"\" of type \""
                , Type -> String
forall a. Show a => a -> String
show Type
variableType
                , String
"\" used in position expecting type \""
                , a -> String
forall a. Show a => a -> String
show a
expectedType
                , String
"\"."
                ]
            , locations :: [Location]
locations = [Location
location']
            }

unwrapInType :: In.Type -> Maybe In.Type
unwrapInType :: Type -> Maybe Type
unwrapInType (In.NonNullScalarType ScalarType
nonNullType) =
    Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Maybe Type) -> Type -> Maybe Type
forall a b. (a -> b) -> a -> b
$ ScalarType -> Type
In.NamedScalarType ScalarType
nonNullType
unwrapInType (In.NonNullEnumType EnumType
nonNullType) =
    Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Maybe Type) -> Type -> Maybe Type
forall a b. (a -> b) -> a -> b
$ EnumType -> Type
In.NamedEnumType EnumType
nonNullType
unwrapInType (In.NonNullInputObjectType InputObjectType
nonNullType) =
    Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Maybe Type) -> Type -> Maybe Type
forall a b. (a -> b) -> a -> b
$ InputObjectType -> Type
In.NamedInputObjectType InputObjectType
nonNullType
unwrapInType (In.NonNullListType Type
nonNullType) =
    Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Maybe Type) -> Type -> Maybe Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
In.ListType Type
nonNullType
unwrapInType Type
_ = Maybe Type
forall a. Maybe a
Nothing

-- | 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 :: Rule m
valuesOfCorrectTypeRule = (Maybe Type -> Node Value -> RuleT m)
-> (Maybe Type -> Node ConstValue -> RuleT m) -> Rule m
forall (m :: * -> *).
(Maybe Type -> Node Value -> RuleT m)
-> (Maybe Type -> Node ConstValue -> RuleT m) -> Rule m
ValueRule Maybe Type -> Node Value -> RuleT m
forall (t :: (* -> *) -> * -> *).
MonadTrans t =>
Maybe Type -> Node Value -> t Seq Error
go Maybe Type -> Node ConstValue -> RuleT m
forall (t :: (* -> *) -> * -> *).
MonadTrans t =>
Maybe Type -> Node ConstValue -> t Seq Error
constGo
  where
    go :: Maybe Type -> Node Value -> t Seq Error
go (Just Type
inputType) Node Value
value
        | Just Node ConstValue
constValue <- Node Value -> Maybe (Node ConstValue)
toConstNode Node Value
value =
            Seq Error -> t Seq Error
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Seq Error -> t Seq Error) -> Seq Error -> t Seq Error
forall a b. (a -> b) -> a -> b
$ Type -> Node ConstValue -> Seq Error
check Type
inputType Node ConstValue
constValue
    go Maybe Type
_ Node Value
_ = Seq Error -> t Seq Error
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Seq Error
forall a. Monoid a => a
mempty -- This rule checks only literals.
    toConstNode :: Node Value -> Maybe (Node ConstValue)
toConstNode Full.Node{Value
Location
location :: Location
node :: Value
$sel:location:Node :: forall a. Node a -> Location
$sel:node:Node :: forall a. Node a -> a
..} = (ConstValue -> Location -> Node ConstValue)
-> Location -> ConstValue -> Node ConstValue
forall a b c. (a -> b -> c) -> b -> a -> c
flip ConstValue -> Location -> Node ConstValue
forall a. a -> Location -> Node a
Full.Node Location
location (ConstValue -> Node ConstValue)
-> Maybe ConstValue -> Maybe (Node ConstValue)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Maybe ConstValue
toConst Value
node
    toConst :: Value -> Maybe ConstValue
toConst (Full.Variable Name
_) = Maybe ConstValue
forall a. Maybe a
Nothing
    toConst (Full.Int Int32
integer) = ConstValue -> Maybe ConstValue
forall a. a -> Maybe a
Just (ConstValue -> Maybe ConstValue) -> ConstValue -> Maybe ConstValue
forall a b. (a -> b) -> a -> b
$ Int32 -> ConstValue
Full.ConstInt Int32
integer
    toConst (Full.Float Double
double) = ConstValue -> Maybe ConstValue
forall a. a -> Maybe a
Just (ConstValue -> Maybe ConstValue) -> ConstValue -> Maybe ConstValue
forall a b. (a -> b) -> a -> b
$ Double -> ConstValue
Full.ConstFloat Double
double
    toConst (Full.String Name
string) = ConstValue -> Maybe ConstValue
forall a. a -> Maybe a
Just (ConstValue -> Maybe ConstValue) -> ConstValue -> Maybe ConstValue
forall a b. (a -> b) -> a -> b
$ Name -> ConstValue
Full.ConstString Name
string
    toConst (Full.Boolean Bool
boolean) = ConstValue -> Maybe ConstValue
forall a. a -> Maybe a
Just (ConstValue -> Maybe ConstValue) -> ConstValue -> Maybe ConstValue
forall a b. (a -> b) -> a -> b
$ Bool -> ConstValue
Full.ConstBoolean Bool
boolean
    toConst Value
Full.Null = ConstValue -> Maybe ConstValue
forall a. a -> Maybe a
Just ConstValue
Full.ConstNull
    toConst (Full.Enum Name
enum) = ConstValue -> Maybe ConstValue
forall a. a -> Maybe a
Just (ConstValue -> Maybe ConstValue) -> ConstValue -> Maybe ConstValue
forall a b. (a -> b) -> a -> b
$ Name -> ConstValue
Full.ConstEnum Name
enum
    toConst (Full.List [Node Value]
values) =
        ConstValue -> Maybe ConstValue
forall a. a -> Maybe a
Just (ConstValue -> Maybe ConstValue) -> ConstValue -> Maybe ConstValue
forall a b. (a -> b) -> a -> b
$ [Node ConstValue] -> ConstValue
Full.ConstList ([Node ConstValue] -> ConstValue)
-> [Node ConstValue] -> ConstValue
forall a b. (a -> b) -> a -> b
$ [Maybe (Node ConstValue)] -> [Node ConstValue]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Node ConstValue)] -> [Node ConstValue])
-> [Maybe (Node ConstValue)] -> [Node ConstValue]
forall a b. (a -> b) -> a -> b
$ Node Value -> Maybe (Node ConstValue)
toConstNode (Node Value -> Maybe (Node ConstValue))
-> [Node Value] -> [Maybe (Node ConstValue)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Node Value]
values
    toConst (Full.Object [ObjectField Value]
fields) = ConstValue -> Maybe ConstValue
forall a. a -> Maybe a
Just (ConstValue -> Maybe ConstValue) -> ConstValue -> Maybe ConstValue
forall a b. (a -> b) -> a -> b
$ [ObjectField ConstValue] -> ConstValue
Full.ConstObject
        ([ObjectField ConstValue] -> ConstValue)
-> [ObjectField ConstValue] -> ConstValue
forall a b. (a -> b) -> a -> b
$ [Maybe (ObjectField ConstValue)] -> [ObjectField ConstValue]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (ObjectField ConstValue)] -> [ObjectField ConstValue])
-> [Maybe (ObjectField ConstValue)] -> [ObjectField ConstValue]
forall a b. (a -> b) -> a -> b
$ ObjectField Value -> Maybe (ObjectField ConstValue)
constObjectField (ObjectField Value -> Maybe (ObjectField ConstValue))
-> [ObjectField Value] -> [Maybe (ObjectField ConstValue)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ObjectField Value]
fields
    constObjectField :: ObjectField Value -> Maybe (ObjectField ConstValue)
constObjectField Full.ObjectField{Name
Node Value
Location
location :: Location
value :: Node Value
name :: Name
$sel:location:ObjectField :: forall a. ObjectField a -> Location
$sel:value:ObjectField :: forall a. ObjectField a -> Node a
$sel:name:ObjectField :: forall a. ObjectField a -> Name
..}
        | Just Node ConstValue
constValue <- Node Value -> Maybe (Node ConstValue)
toConstNode Node Value
value =
            ObjectField ConstValue -> Maybe (ObjectField ConstValue)
forall a. a -> Maybe a
Just (ObjectField ConstValue -> Maybe (ObjectField ConstValue))
-> ObjectField ConstValue -> Maybe (ObjectField ConstValue)
forall a b. (a -> b) -> a -> b
$ Name -> Node ConstValue -> Location -> ObjectField ConstValue
forall a. Name -> Node a -> Location -> ObjectField a
Full.ObjectField Name
name Node ConstValue
constValue Location
location
        | Bool
otherwise = Maybe (ObjectField ConstValue)
forall a. Maybe a
Nothing
    constGo :: Maybe Type -> Node ConstValue -> t Seq Error
constGo Maybe Type
Nothing = t Seq Error -> Node ConstValue -> t Seq Error
forall a b. a -> b -> a
const (t Seq Error -> Node ConstValue -> t Seq Error)
-> t Seq Error -> Node ConstValue -> t Seq Error
forall a b. (a -> b) -> a -> b
$ Seq Error -> t Seq Error
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Seq Error
forall a. Monoid a => a
mempty
    constGo (Just Type
inputType) = Seq Error -> t Seq Error
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Seq Error -> t Seq Error)
-> (Node ConstValue -> Seq Error) -> Node ConstValue -> t Seq Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Node ConstValue -> Seq Error
check Type
inputType
    check :: In.Type -> Full.Node Full.ConstValue -> Seq Error
    check :: Type -> Node ConstValue -> Seq Error
check Type
_ Full.Node{ $sel:node:Node :: forall a. Node a -> a
node = ConstValue
Full.ConstNull } =
        Seq Error
forall a. Monoid a => a
mempty -- Ignore, required fields are checked elsewhere.
    check (In.ScalarBaseType ScalarType
scalarType) Full.Node{ ConstValue
node :: ConstValue
$sel:node:Node :: forall a. Node a -> a
node }
        | Definition.ScalarType Name
"Int" Maybe Name
_ <- ScalarType
scalarType
        , Full.ConstInt Int32
_ <- ConstValue
node = Seq Error
forall a. Monoid a => a
mempty
        | Definition.ScalarType Name
"Boolean" Maybe Name
_ <- ScalarType
scalarType
        , Full.ConstBoolean Bool
_ <- ConstValue
node = Seq Error
forall a. Monoid a => a
mempty
        | Definition.ScalarType Name
"String" Maybe Name
_ <- ScalarType
scalarType
        , Full.ConstString Name
_ <- ConstValue
node = Seq Error
forall a. Monoid a => a
mempty
        | Definition.ScalarType Name
"ID" Maybe Name
_ <- ScalarType
scalarType
        , Full.ConstString Name
_ <- ConstValue
node = Seq Error
forall a. Monoid a => a
mempty
        | Definition.ScalarType Name
"ID" Maybe Name
_ <- ScalarType
scalarType
        , Full.ConstInt Int32
_ <- ConstValue
node = Seq Error
forall a. Monoid a => a
mempty
        | Definition.ScalarType Name
"Float" Maybe Name
_ <- ScalarType
scalarType
        , Full.ConstFloat Double
_ <- ConstValue
node = Seq Error
forall a. Monoid a => a
mempty
        | Definition.ScalarType Name
"Float" Maybe Name
_ <- ScalarType
scalarType
        , Full.ConstInt Int32
_ <- ConstValue
node = Seq Error
forall a. Monoid a => a
mempty
    check (In.EnumBaseType EnumType
enumType) Full.Node{ ConstValue
node :: ConstValue
$sel:node:Node :: forall a. Node a -> a
node }
        | Definition.EnumType Name
_ Maybe Name
_ HashMap Name EnumValue
members <- EnumType
enumType
        , Full.ConstEnum Name
memberValue <- ConstValue
node
        , Name -> HashMap Name EnumValue -> Bool
forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
HashMap.member Name
memberValue HashMap Name EnumValue
members = Seq Error
forall a. Monoid a => a
mempty
    check (In.InputObjectBaseType InputObjectType
objectType) Full.Node{ ConstValue
node :: ConstValue
$sel:node:Node :: forall a. Node a -> a
node }
        -- Skip, objects are checked recursively by the validation traverser.
        | In.InputObjectType{}  <- InputObjectType
objectType
        , Full.ConstObject{} <- ConstValue
node = Seq Error
forall a. Monoid a => a
mempty
    check (In.ListBaseType Type
listType) constValue :: Node ConstValue
constValue@Full.Node{ ConstValue
Location
location :: Location
node :: ConstValue
$sel:location:Node :: forall a. Node a -> Location
$sel:node:Node :: forall a. Node a -> a
.. }
        | Full.ConstList [Node ConstValue]
values <- ConstValue
node =
            (Node ConstValue -> Seq Error) -> [Node ConstValue] -> Seq Error
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Type -> Node ConstValue -> Seq Error
checkNull Type
listType) [Node ConstValue]
values
        | Bool
otherwise = Type -> Node ConstValue -> Seq Error
check Type
listType Node ConstValue
constValue
    check Type
inputType Full.Node{ ConstValue
Location
location :: Location
node :: ConstValue
$sel:location:Node :: forall a. Node a -> Location
$sel:node:Node :: forall a. Node a -> a
.. } = Error -> Seq Error
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Error -> Seq Error) -> Error -> Seq Error
forall a b. (a -> b) -> a -> b
$ Error :: String -> [Location] -> Error
Error
        { message :: String
message = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ String
"Value "
            , ConstValue -> String
forall a. Show a => a -> String
show ConstValue
node
            , String
" cannot be coerced to type \""
            , Type -> String
forall a. Show a => a -> String
show Type
inputType
            , String
"\"."
            ]
        , locations :: [Location]
locations = [Location
location]
        }
    checkNull :: Type -> Node ConstValue -> Seq Error
checkNull Type
inputType Node ConstValue
constValue =
        let checkResult :: Seq Error
checkResult = Type -> Node ConstValue -> Seq Error
check Type
inputType Node ConstValue
constValue
         in case Seq Error -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Seq Error
checkResult of
            Bool
True
                | Just Type
unwrappedType <- Type -> Maybe Type
unwrapInType Type
inputType
                , Full.Node{ $sel:node:Node :: forall a. Node a -> a
node = ConstValue
Full.ConstNull, Location
location :: Location
$sel:location:Node :: forall a. Node a -> Location
.. } <- Node ConstValue
constValue ->
                    Error -> Seq Error
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Error -> Seq Error) -> Error -> Seq Error
forall a b. (a -> b) -> a -> b
$ Error :: String -> [Location] -> Error
Error
                        { message :: String
message = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                            [ String
"List of non-null values of type \""
                            , Type -> String
forall a. Show a => a -> String
show Type
unwrappedType
                            , String
"\" cannot contain null values."
                            ]
                        , locations :: [Location]
locations = [Location
location]
                        }
                | Bool
otherwise -> Seq Error
forall a. Monoid a => a
mempty
            Bool
_ -> Seq Error
checkResult