{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
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
type ValidationState m a =
StateT (HashSet Full.Name) (ReaderT (Validation m) Seq) a
specifiedRules :: forall m. [Rule m]
specifiedRules :: [Rule m]
specifiedRules =
[ Rule m
forall (m :: * -> *). Rule m
executableDefinitionsRule
, Rule m
forall (m :: * -> *). Rule m
singleFieldSubscriptionsRule
, Rule m
forall (m :: * -> *). Rule m
loneAnonymousOperationRule
, Rule m
forall (m :: * -> *). Rule m
uniqueOperationNamesRule
, Rule m
forall (m :: * -> *). Rule m
fieldsOnCorrectTypeRule
, Rule m
forall (m :: * -> *). Rule m
scalarLeafsRule
, Rule m
forall (m :: * -> *). Rule m
overlappingFieldsCanBeMergedRule
, Rule m
forall (m :: * -> *). Rule m
knownArgumentNamesRule
, Rule m
forall (m :: * -> *). Rule m
uniqueArgumentNamesRule
, Rule m
forall (m :: * -> *). Rule m
providedRequiredArgumentsRule
, 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
, 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
, Rule m
forall (m :: * -> *). Rule m
knownDirectiveNamesRule
, Rule m
forall (m :: * -> *). Rule m
directivesInValidLocationsRule
, Rule m
forall (m :: * -> *). Rule m
uniqueDirectiveNamesRule
, 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
]
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']
}
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 :: * -> *) (m :: * -> *).
Monad m =>
SelectionSet
-> StateT (HashSet Name) (ReaderT (Validation m) m) (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) m) (HashSet Name)
collectFields SelectionSet
selectionSet = (HashSet Name
-> Selection
-> StateT (HashSet Name) (ReaderT (Validation m) m) (HashSet Name))
-> HashSet Name
-> SelectionSet
-> StateT (HashSet Name) (ReaderT (Validation m) m) (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) m) (HashSet Name)
forEach HashSet Name
forall a. HashSet a
HashSet.empty SelectionSet
selectionSet
forEach :: HashSet Name
-> Selection
-> StateT (HashSet Name) (ReaderT (Validation m) m) (HashSet Name)
forEach HashSet Name
accumulator = \case
Full.FieldSelection Field
fieldSelection -> HashSet Name
-> Field
-> StateT (HashSet Name) (ReaderT (Validation m) m) (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) m) (HashSet Name)
forSpread HashSet Name
accumulator FragmentSpread
fragmentSelection
Full.InlineFragmentSelection InlineFragment
fragmentSelection ->
HashSet Name
-> InlineFragment
-> StateT (HashSet Name) (ReaderT (Validation m) m) (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) m) (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) m) (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) m) Bool
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets ((HashSet Name -> Bool)
-> StateT (HashSet Name) (ReaderT (Validation m) m) Bool)
-> (HashSet Name -> Bool)
-> StateT (HashSet Name) (ReaderT (Validation m) m) 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) m) (HashSet Name)
forall (f :: * -> *) a. Applicative f => a -> f a
pure HashSet Name
accumulator
else Name
-> HashSet Name
-> StateT (HashSet Name) (ReaderT (Validation m) m) (HashSet Name)
collectFromSpread Name
fragmentName HashSet Name
accumulator
forInline :: HashSet Name
-> InlineFragment
-> StateT (HashSet Name) (ReaderT (Validation m) m) (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) m) (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) m) (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) m) (HashSet Name)
-> StateT (HashSet Name) (ReaderT (Validation m) m) (HashSet Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SelectionSet
-> StateT (HashSet Name) (ReaderT (Validation m) m) (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) m) (HashSet Name)
collectFromFragment Name
typeCondition SelectionSet
selectionSet HashSet Name
accumulator = do
HashMap Name (Type m)
types' <- ReaderT (Validation m) m (HashMap Name (Type m))
-> StateT
(HashSet Name) (ReaderT (Validation m) m) (HashMap Name (Type m))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT (Validation m) m (HashMap Name (Type m))
-> StateT
(HashSet Name) (ReaderT (Validation m) m) (HashMap Name (Type m)))
-> ReaderT (Validation m) m (HashMap Name (Type m))
-> StateT
(HashSet Name) (ReaderT (Validation m) m) (HashMap Name (Type m))
forall a b. (a -> b) -> a -> 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 ((Validation m -> HashMap Name (Type m))
-> ReaderT (Validation m) m (HashMap Name (Type m)))
-> (Validation m -> HashMap Name (Type m))
-> ReaderT (Validation m) m (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) m (Schema m)
-> StateT (HashSet Name) (ReaderT (Validation m) m) (Schema m)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT (Validation m) m (Schema m)
-> StateT (HashSet Name) (ReaderT (Validation m) m) (Schema m))
-> ReaderT (Validation m) m (Schema m)
-> StateT (HashSet Name) (ReaderT (Validation m) m) (Schema m)
forall a b. (a -> b) -> a -> b
$ (Validation m -> Schema m) -> ReaderT (Validation m) m (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) m) (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) m) (HashSet Name)
-> StateT (HashSet Name) (ReaderT (Validation m) m) (HashSet Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SelectionSet
-> StateT (HashSet Name) (ReaderT (Validation m) m) (HashSet Name)
collectFields SelectionSet
selectionSet
| Bool
otherwise -> HashSet Name
-> StateT (HashSet Name) (ReaderT (Validation m) m) (HashSet Name)
forall (f :: * -> *) a. Applicative f => a -> f a
pure HashSet Name
accumulator
collectFromSpread :: Name
-> HashSet Name
-> StateT (HashSet Name) (ReaderT (Validation m) m) (HashSet Name)
collectFromSpread Name
fragmentName HashSet Name
accumulator = do
(HashSet Name -> HashSet Name)
-> StateT (HashSet Name) (ReaderT (Validation m) m) ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify ((HashSet Name -> HashSet Name)
-> StateT (HashSet Name) (ReaderT (Validation m) m) ())
-> (HashSet Name -> HashSet Name)
-> StateT (HashSet Name) (ReaderT (Validation m) m) ()
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) m Document
-> StateT (HashSet Name) (ReaderT (Validation m) m) Document
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT (Validation m) m Document
-> StateT (HashSet Name) (ReaderT (Validation m) m) Document)
-> ReaderT (Validation m) m Document
-> StateT (HashSet Name) (ReaderT (Validation m) m) Document
forall a b. (a -> b) -> a -> b
$ (Validation m -> Document) -> ReaderT (Validation m) m 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) m) (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) m) (HashSet Name)
collectFromFragment Name
typeCondition SelectionSet
selectionSet HashSet Name
accumulator
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']
}
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
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
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
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
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
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
"\"."
]
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
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 t Selection
selectionSet = (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 t Selection
selectionSet
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
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')
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
"\"."
]
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')
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
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'
}
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
"\"."
]
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]
fields =
(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" [ObjectField a]
fields
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
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
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']
}
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
"\"."
]
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
"\"."
]
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
"\"."
]
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
"."
]
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
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."
]
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
}
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
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 t Selection
selections =
(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 t Selection
selections
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
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
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']
}
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
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 [Value]
values) =
ConstValue -> Maybe ConstValue
forall a. a -> Maybe a
Just (ConstValue -> Maybe ConstValue) -> ConstValue -> Maybe ConstValue
forall a b. (a -> b) -> a -> b
$ [ConstValue] -> ConstValue
Full.ConstList ([ConstValue] -> ConstValue) -> [ConstValue] -> ConstValue
forall a b. (a -> b) -> a -> b
$ [Maybe ConstValue] -> [ConstValue]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe ConstValue] -> [ConstValue])
-> [Maybe ConstValue] -> [ConstValue]
forall a b. (a -> b) -> a -> b
$ Value -> Maybe ConstValue
toConst (Value -> Maybe ConstValue) -> [Value] -> [Maybe ConstValue]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [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
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 }
| In.InputObjectType Name
_ Maybe Name
_ HashMap Name InputField
typeFields <- InputObjectType
objectType
, Full.ConstObject [ObjectField ConstValue]
valueFields <- ConstValue
node =
(ObjectField ConstValue -> Seq Error)
-> [ObjectField ConstValue] -> Seq Error
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (HashMap Name InputField -> ObjectField ConstValue -> Seq Error
checkObjectField HashMap Name InputField
typeFields) [ObjectField ConstValue]
valueFields
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 [ConstValue]
listValues <- 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
check Type
listType) ([Node ConstValue] -> Seq Error) -> [Node ConstValue] -> Seq Error
forall a b. (a -> b) -> a -> b
$ (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)
-> [ConstValue] -> [Node ConstValue]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ConstValue]
listValues
| 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]
}
checkObjectField :: HashMap Name InputField -> ObjectField ConstValue -> Seq Error
checkObjectField HashMap Name InputField
typeFields Full.ObjectField{Name
Node ConstValue
Location
location :: Location
value :: Node ConstValue
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 InputField
typeField <- Name -> HashMap Name InputField -> Maybe InputField
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
name HashMap Name InputField
typeFields
, In.InputField Maybe Name
_ Type
fieldType Maybe Value
_ <- InputField
typeField =
Type -> Node ConstValue -> Seq Error
check Type
fieldType Node ConstValue
value
checkObjectField HashMap Name InputField
_ ObjectField ConstValue
_ = Seq Error
forall a. Monoid a => a
mempty