{-# LANGUAGE LambdaCase #-}
{-# 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
, providedRequiredInputFieldsRule
, providedRequiredArgumentsRule
, scalarLeafsRule
, singleFieldSubscriptionsRule
, specifiedRules
, uniqueArgumentNamesRule
, uniqueDirectiveNamesRule
, uniqueFragmentNamesRule
, uniqueInputFieldNamesRule
, uniqueOperationNamesRule
, uniqueVariableNamesRule
, variablesAreInputTypesRule
) where
import Control.Monad ((>=>), foldM)
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Reader (ReaderT(..), asks, mapReaderT)
import Control.Monad.Trans.State (StateT, evalStateT, gets, modify)
import Data.Bifunctor (first)
import Data.Foldable (find, 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 (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
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
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
]
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 _ -> 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 _ location' :: 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 _ location' :: 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
location' = Error :: String -> [Location] -> Error
Error
{ message :: String
message =
"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 Full.Subscription name' :: Maybe Name
name' _ _ rootFields :: SelectionSet
rootFields location' :: 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
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
_
| Just name :: 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
[ "Subscription \""
, Name -> String
Text.unpack Name
name
, "\" 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']
}
_ -> 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 =
"Anonymous Subscription must select only one top level field."
collectFields :: SelectionSet
-> StateT (HashSet Name) (ReaderT (Validation m) m) (HashSet Name)
collectFields selectionSet :: 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 accumulator :: HashSet Name
accumulator = \case
Full.FieldSelection 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 fragmentSelection :: FragmentSpread
fragmentSelection ->
HashSet Name
-> FragmentSpread
-> StateT (HashSet Name) (ReaderT (Validation m) m) (HashSet Name)
forSpread HashSet Name
accumulator FragmentSpread
fragmentSelection
Full.InlineFragmentSelection fragmentSelection :: 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 accumulator :: HashSet Name
accumulator (Full.Field alias :: Maybe Name
alias name :: Name
name _ directives' :: [Directive]
directives' _ _)
| (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 aliasedName :: 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 accumulator :: HashSet Name
accumulator (Full.FragmentSpread fragmentName :: Name
fragmentName directives' :: [Directive]
directives' _)
| (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 accumulator :: HashSet Name
accumulator (Full.InlineFragment maybeType :: Maybe Name
maybeType directives' :: [Directive]
directives' selections :: SelectionSet
selections _)
| (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 typeCondition :: 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 "skip" [Full.Argument "if" (Full.Node argumentValue :: Value
argumentValue _) _] _) =
Bool -> Value
Full.Boolean Bool
True Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
argumentValue
skip (Full.Directive "include" [Full.Argument "if" (Full.Node argumentValue :: Value
argumentValue _) _] _) =
Bool -> Value
Full.Boolean Bool
False Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
argumentValue
skip _ = Bool
False
collectFromFragment :: Name
-> SelectionSet
-> HashSet Name
-> StateT (HashSet Name) (ReaderT (Validation m) m) (HashSet Name)
collectFromFragment typeCondition :: Name
typeCondition selectionSet :: SelectionSet
selectionSet accumulator :: 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
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 :: CompositeType m
compositeType
| Just objectType :: 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 fragmentName :: Name
fragmentName accumulator :: 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
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 _ typeCondition :: Name
typeCondition _ selectionSet :: SelectionSet
selectionSet _) ->
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 _ thisLocation :: Location
thisLocation -> Location -> RuleT m
forall (m :: * -> *). Location -> ReaderT (Validation m) Seq Error
check Location
thisLocation
Full.OperationDefinition _ Nothing _ _ _ thisLocation :: Location
thisLocation ->
Location -> RuleT m
forall (m :: * -> *). Location -> ReaderT (Validation m) Seq Error
check Location
thisLocation
_ -> 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 thisLocation :: 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 thisLocation :: Location
thisLocation definition :: Definition
definition Empty
| (Definition -> Maybe OperationDefinition
viewOperation -> Just operationDefinition :: 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 _ _ accumulator :: Seq Error
accumulator = Seq Error
accumulator
compareAnonymousOperations :: Location -> OperationDefinition -> f Error
compareAnonymousOperations thisLocation :: Location
thisLocation = \case
Full.OperationDefinition _ _ _ _ _ thatLocation :: 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 _ thatLocation :: 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
_ -> f Error
forall a. Monoid a => a
mempty
error' :: Location -> Error
error' location' :: Location
location' = Error :: String -> [Location] -> Error
Error
{ message :: String
message =
"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 _ (Just thisName :: Name
thisName) _ _ _ thisLocation :: 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)
_ -> 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' operationName :: Name
operationName = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ "There can be only one operation named \""
, Name -> String
Text.unpack Name
operationName
, "\"."
]
filterByName :: Name -> Definition -> [Location] -> [Location]
filterByName thisName :: Name
thisName definition' :: Definition
definition' accumulator :: [Location]
accumulator
| (Definition -> Maybe OperationDefinition
viewOperation -> Just operationDefinition :: OperationDefinition
operationDefinition) <- Definition
definition'
, Full.OperationDefinition _ (Just thatName :: Name
thatName) _ _ _ thatLocation :: 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 filterByName :: Definition -> [Location] -> [Location]
filterByName thisLocation :: Location
thisLocation errorMessage :: 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
> 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' locations' :: [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
definition
| Full.ExecutableDefinition executableDefinition :: ExecutableDefinition
executableDefinition <- Definition
definition
, Full.DefinitionOperation operationDefinition :: OperationDefinition
operationDefinition <- ExecutableDefinition
executableDefinition =
OperationDefinition -> Maybe OperationDefinition
forall a. a -> Maybe a
Just OperationDefinition
operationDefinition
viewOperation _ = Maybe OperationDefinition
forall a. Maybe a
Nothing
viewFragment :: Full.Definition -> Maybe Full.FragmentDefinition
viewFragment :: Definition -> Maybe FragmentDefinition
viewFragment definition :: Definition
definition
| Full.ExecutableDefinition executableDefinition :: ExecutableDefinition
executableDefinition <- Definition
definition
, Full.DefinitionFragment fragmentDefinition :: FragmentDefinition
fragmentDefinition <- ExecutableDefinition
executableDefinition =
FragmentDefinition -> Maybe FragmentDefinition
forall a. a -> Maybe a
Just FragmentDefinition
fragmentDefinition
viewFragment _ = 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 thisName :: Name
thisName _ _ _ thisLocation :: 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' fragmentName :: Name
fragmentName = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ "There can be only one fragment named \""
, Name -> String
Text.unpack Name
fragmentName
, "\"."
]
filterByName :: Name -> Definition -> [Location] -> [Location]
filterByName thisName :: Name
thisName definition :: Definition
definition accumulator :: [Location]
accumulator
| Just fragmentDefinition :: FragmentDefinition
fragmentDefinition <- Definition -> Maybe FragmentDefinition
viewFragment Definition
definition
, Full.FragmentDefinition thatName :: Name
thatName _ _ _ thatLocation :: 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 fragmentName :: Name
fragmentName _ location' :: 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
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 _ -> 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' fragmentName :: Name
fragmentName = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ "Fragment target \""
, Name -> String
Text.unpack Name
fragmentName
, "\" is undefined."
]
isSpreadTarget :: Text -> Full.Definition -> Bool
isSpreadTarget :: Name -> Definition -> Bool
isSpreadTarget thisName :: Name
thisName (Definition -> Maybe FragmentDefinition
viewFragment -> Just fragmentDefinition :: FragmentDefinition
fragmentDefinition)
| Full.FragmentDefinition thatName :: Name
thatName _ _ _ _ <- FragmentDefinition
fragmentDefinition
, Name
thisName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
thatName = Bool
True
isSpreadTarget _ _ = 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 fragmentSelection :: FragmentSpread
fragmentSelection
| Full.FragmentSpread fragmentName :: Name
fragmentName _ location' :: Location
location' <- FragmentSpread
fragmentSelection -> 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 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'
Name
typeCondition <- Seq Name -> ReaderT (Validation m) Seq Name
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Seq Name -> ReaderT (Validation m) Seq Name)
-> Seq Name -> ReaderT (Validation m) 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
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
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 _ -> 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 fragmentSelection :: InlineFragment
fragmentSelection
| Full.InlineFragment maybeType :: Maybe Name
maybeType _ _ location' :: Location
location' <- InlineFragment
fragmentSelection
, Just typeCondition :: 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
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 _ -> 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
_ -> 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
extractTypeCondition :: Definition -> Maybe Name
extractTypeCondition (Definition -> Maybe FragmentDefinition
viewFragment -> Just fragmentDefinition :: FragmentDefinition
fragmentDefinition) =
let Full.FragmentDefinition _ typeCondition :: Name
typeCondition _ _ _ = FragmentDefinition
fragmentDefinition
in Name -> Maybe Name
forall a. a -> Maybe a
Just Name
typeCondition
extractTypeCondition _ = Maybe Name
forall a. Maybe a
Nothing
spreadError :: Name -> Name -> String
spreadError fragmentName :: Name
fragmentName typeCondition :: Name
typeCondition = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ "Fragment \""
, Name -> String
Text.unpack Name
fragmentName
, "\" is specified on type \""
, Name -> String
Text.unpack Name
typeCondition
, "\" which doesn't exist in the schema."
]
inlineError :: Name -> String
inlineError typeCondition :: Name
typeCondition = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ "Inline fragment is specified on type \""
, Name -> String
Text.unpack Name
typeCondition
, "\" which doesn't exist in the schema."
]
maybeToSeq :: forall a. Maybe a -> Seq a
maybeToSeq :: Maybe a -> Seq a
maybeToSeq (Just x :: a
x) = a -> Seq a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
maybeToSeq 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 typeCondition :: Name
typeCondition) _ _ location' :: Location
location') =
Name -> Location -> ReaderT (Validation m) Seq Error
forall (m :: * -> *).
Name -> Location -> ReaderT (Validation m) Seq Error
check Name
typeCondition Location
location'
inlineRule _ = 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 _ typeCondition :: Name
typeCondition _ _ location' :: 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 typeCondition :: Name
typeCondition location' :: 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
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 _ -> 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 typeCondition :: Name
typeCondition = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ "Fragment cannot condition on non composite type \""
, Name -> String
Text.unpack Name
typeCondition,
"\"."
]
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
$ \fragment :: FragmentDefinition
fragment -> do
let Full.FragmentDefinition fragmentName :: Name
fragmentName _ _ _ location' :: 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)
-> [Selection]
-> 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
([Selection]
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) Name)
-> (Document -> [Selection])
-> Document
-> StateT (HashSet Name) (ReaderT (Validation m) Seq) Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Definition -> [Selection]) -> Document -> [Selection]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Definition -> [Selection]
definitionSelections
where
checkFragmentName :: Name -> Location -> t Name -> f Error
checkFragmentName fragmentName :: Name
fragmentName location' :: Location
location' elements :: 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 fragName :: Name
fragName location' :: Location
location' = Error :: String -> [Location] -> Error
Error
{ message :: String
message = Name -> String
errorMessage Name
fragName
, locations :: [Location]
locations = [Location
location']
}
errorMessage :: Name -> String
errorMessage fragName :: Name
fragName = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ "Fragment \""
, Name -> String
Text.unpack Name
fragName
, "\" is never used."
]
evaluateSelection :: Selection -> t (t m) Name
evaluateSelection selection :: Selection
selection
| Full.FragmentSpreadSelection spreadSelection :: FragmentSpread
spreadSelection <- Selection
selection
, Full.FragmentSpread spreadName :: Name
spreadName _ _ <- 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 _ = 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 -> [Selection]
definitionSelections (Definition -> Maybe OperationDefinition
viewOperation -> Just operation :: OperationDefinition
operation)
| Full.OperationDefinition _ _ _ _ selections :: SelectionSet
selections _ <- OperationDefinition
operation =
SelectionSet -> [Selection]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList SelectionSet
selections
| Full.SelectionSet selections :: SelectionSet
selections _ <- OperationDefinition
operation = SelectionSet -> [Selection]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList SelectionSet
selections
definitionSelections (Definition -> Maybe FragmentDefinition
viewFragment -> Just fragment :: FragmentDefinition
fragment)
| Full.FragmentDefinition _ _ _ selections :: SelectionSet
selections _ <- FragmentDefinition
fragment = SelectionSet -> [Selection]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList SelectionSet
selections
definitionSelections _ = []
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 applyFilter :: Selection -> ValidationState m a
applyFilter selections :: 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) ([Selection] -> Seq Selection
forall a. [a] -> Seq a
Seq.fromList ([Selection] -> Seq Selection) -> [Selection] -> Seq Selection
forall a b. (a -> b) -> a -> b
$ (Selection -> [Selection] -> [Selection])
-> [Selection] -> t Selection -> [Selection]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Selection -> [Selection] -> [Selection]
evaluateSelection [Selection]
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 -> [Selection] -> [Selection]
evaluateSelection selection :: Selection
selection accumulator :: [Selection]
accumulator
| Full.FragmentSpreadSelection{} <- Selection
selection = Selection
selection Selection -> [Selection] -> [Selection]
forall a. a -> [a] -> [a]
: [Selection]
accumulator
| Full.FieldSelection fieldSelection :: Field
fieldSelection <- Selection
selection
, Full.Field _ _ _ _ subselections :: [Selection]
subselections _ <- Field
fieldSelection =
Selection
selection Selection -> [Selection] -> [Selection]
forall a. a -> [a] -> [a]
: (Selection -> [Selection] -> [Selection])
-> [Selection] -> [Selection] -> [Selection]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Selection -> [Selection] -> [Selection]
evaluateSelection [Selection]
accumulator [Selection]
subselections
| Full.InlineFragmentSelection inlineSelection :: InlineFragment
inlineSelection <- Selection
selection
, Full.InlineFragment _ _ subselections :: SelectionSet
subselections _ <- InlineFragment
inlineSelection =
Selection
selection Selection -> [Selection] -> [Selection]
forall a. a -> [a] -> [a]
: (Selection -> [Selection] -> [Selection])
-> [Selection] -> SelectionSet -> [Selection]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Selection -> [Selection] -> [Selection]
evaluateSelection [Selection]
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 fragmentName :: Name
fragmentName _ _ selections :: SelectionSet
selections location' :: 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)
collectFields SelectionSet
selections)
(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
x :: Name
x : _ | 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
[ "Cannot spread fragment \""
, Name -> String
Text.unpack Name
fragmentName
, "\" 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
forall a b. (a -> b) -> a -> b
$ Name
fragmentName Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
spreadPath
, ")."
]
, locations :: [Location]
locations = [Location
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
where
collectFields :: Traversable t
=> t Full.Selection
-> StateT (Int, Full.Name) (ReaderT (Validation m) Seq) (HashMap Full.Name Int)
collectFields :: t Selection
-> StateT
(Int, Name) (ReaderT (Validation m) Seq) (HashMap Name Int)
collectFields selectionSet :: 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 accumulator :: HashMap Name Int
accumulator = \case
Full.FieldSelection 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 fragmentSelection :: 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 fragmentSelection :: 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 accumulator :: HashMap Name Int
accumulator (Full.FragmentSpread fragmentName :: Name
fragmentName _ _) = 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
+ 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 accumulator :: HashMap Name Int
accumulator (Full.InlineFragment _ _ selections :: SelectionSet
selections _) =
(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)
collectFields SelectionSet
selections
forField :: HashMap Name Int
-> Field
-> StateT
(Int, Name) (ReaderT (Validation m) Seq) (HashMap Name Int)
forField accumulator :: HashMap Name Int
accumulator (Full.Field _ _ _ _ selections :: [Selection]
selections _) =
(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
<$> [Selection]
-> 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)
collectFields [Selection]
selections
collectFromSpread :: Name
-> HashMap Name Int
-> StateT
(Int, Name) (ReaderT (Validation m) Seq) (HashMap Name Int)
collectFromSpread fragmentName :: Name
fragmentName accumulator :: 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
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 _ _ _ selections :: SelectionSet
selections _) ->
(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)
collectFields SelectionSet
selections
findFragmentDefinition :: Text
-> NonEmpty Full.Definition
-> Maybe Full.FragmentDefinition
findFragmentDefinition :: Name -> Document -> Maybe FragmentDefinition
findFragmentDefinition fragmentName :: 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
executableDefinition) Nothing
| Full.DefinitionFragment fragmentDefinition :: FragmentDefinition
fragmentDefinition <- ExecutableDefinition
executableDefinition
, Full.FragmentDefinition anotherName :: Name
anotherName _ _ _ _ <- 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 _ accumulator :: 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 _ (Full.Field _ _ arguments :: [Argument]
arguments _ _ _) =
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 "argument" [Argument]
arguments
directiveRule :: Directive -> t Seq Error
directiveRule (Full.Directive _ arguments :: [Argument]
arguments _) =
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 "argument" [Argument]
arguments
extract :: Argument -> (Name, Location)
extract (Full.Argument argumentName :: Name
argumentName _ location' :: 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 "directive"
where
extract :: Directive -> (Name, Location)
extract (Full.Directive directiveName :: Name
directiveName _ location' :: Location
location') =
(Name
directiveName, Location
location')
filterDuplicates :: (a -> (Text, Full.Location)) -> String -> [a] -> Seq Error
filterDuplicates :: (a -> (Name, Location)) -> String -> [a] -> Seq Error
filterDuplicates extract :: a -> (Name, Location)
extract nodeType :: 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
> 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 -> 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
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
equalByName :: a -> a -> Bool
equalByName lhs :: a
lhs rhs :: a
rhs = a -> Name
getName a
lhs Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== a -> Name
getName a
rhs
makeError :: [a] -> Error
makeError directives' :: [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 directive :: a
directive = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ "There can be only one "
, String
nodeType
, " 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
, "\"."
]
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 "variable"
where
extract :: VariableDefinition -> (Name, Location)
extract (Full.VariableDefinition variableName :: Name
variableName _ _ location' :: 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
name typeName :: Type
typeName _ location' :: 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
name typeName :: Type
typeName location' :: 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
[ "Variable \"$"
, Name -> String
Text.unpack Name
name
, "\" 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
, "\"."
]
, locations :: [Location]
locations = [Location
location']
}
getTypeName :: Type -> Name
getTypeName (Full.TypeNamed name :: Name
name) = Name
name
getTypeName (Full.TypeList name :: Type
name) = Type -> Name
getTypeName Type
name
getTypeName (Full.TypeNonNull (Full.NonNullTypeNamed nonNull :: Name
nonNull)) = Name
nonNull
getTypeName (Full.TypeNonNull (Full.NonNullTypeList nonNull :: 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 Nothing variableName :: Name
variableName = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ "Variable \"$"
, Name -> String
Text.unpack Name
variableName
, "\" is not defined."
]
errorMessage (Just operationName :: Name
operationName) variableName :: Name
variableName = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ "Variable \"$"
, Name -> String
Text.unpack Name
variableName
, "\" is not defined by operation \""
, Name -> String
Text.unpack Name
operationName
, "\"."
]
type UsageDifference
= HashMap Full.Name [Full.Location]
-> HashMap Full.Name [Full.Location]
-> HashMap Full.Name [Full.Location]
variableUsageDifference :: forall m. UsageDifference
-> (Maybe Full.Name -> Full.Name -> String)
-> Rule m
variableUsageDifference :: UsageDifference -> (Maybe Name -> Name -> String) -> Rule m
variableUsageDifference difference :: UsageDifference
difference errorMessage :: 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 _ _ -> 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 _ operationName :: Maybe Name
operationName variables :: [VariableDefinition]
variables _ selections :: SelectionSet
selections _ ->
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
$ [Selection]
-> 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'
([Selection]
-> StateT
(HashSet Name) (ReaderT (Validation m) Seq) (Name, [Location]))
-> [Selection]
-> StateT
(HashSet Name) (ReaderT (Validation m) Seq) (Name, [Location])
forall a b. (a -> b) -> a -> b
$ SelectionSet -> [Selection]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList SelectionSet
selections
where
readerMapper :: Maybe Name
-> HashMap Name [Location] -> t (Name, [Location]) -> Seq Error
readerMapper operationName :: Maybe Name
operationName variableNames' :: 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 variableName :: Name
variableName _ _ location' :: 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 inline :: InlineFragment
inline)
| Full.InlineFragment _ directives' :: [Directive]
directives' _ _ <- 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 fieldSelection :: Field
fieldSelection)
| Full.Field _ _ arguments :: [Argument]
arguments directives' :: [Directive]
directives' _ _ <- 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 spread :: FragmentSpread
spread)
| Full.FragmentSpread fragmentName :: Name
fragmentName _ _ <- FragmentSpread
spread = 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
fragmentDefinition)
| Bool -> Bool
not Bool
visited -> FragmentDefinition
-> StateT
(HashSet Name) (ReaderT (Validation m) Seq) (Name, [Location])
diveIntoSpread FragmentDefinition
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 _ _ directives' :: [Directive]
directives' selections :: SelectionSet
selections _)
= 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 _ arguments :: [Argument]
arguments _) = [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 _ Full.Node{ $sel:node:Node :: forall a. Node a -> a
node = Full.Variable value' :: Name
value', ..} _) =
(Name, [Location]) -> Maybe (Name, [Location])
forall a. a -> Maybe a
Just (Name
value', [Location
location])
findArgumentVariables _ = Maybe (Name, [Location])
forall a. Maybe a
Nothing
makeError :: Maybe Name -> (Name, [Location]) -> Error
makeError operationName :: Maybe Name
operationName (variableName :: Name
variableName, locations' :: [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 Nothing variableName :: Name
variableName = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ "Variable \"$"
, Name -> String
Text.unpack Name
variableName
, "\" is never used."
]
errorMessage (Just operationName :: Name
operationName) variableName :: Name
variableName = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ "Variable \"$"
, Name -> String
Text.unpack Name
variableName
, "\" is never used in operation \""
, Name -> String
Text.unpack Name
operationName
, "\"."
]
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 fields :: [ObjectField Value]
fields) _) = [ObjectField Value] -> Seq Error
forall a. [ObjectField a] -> Seq Error
filterFieldDuplicates [ObjectField Value]
fields
go _ = Seq Error
forall a. Monoid a => a
mempty
filterFieldDuplicates :: [ObjectField a] -> Seq Error
filterFieldDuplicates fields :: [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 "input field" [ObjectField a]
fields
getFieldName :: ObjectField a -> (Name, Location)
getFieldName (Full.ObjectField fieldName :: Name
fieldName _ location' :: Location
location') = (Name
fieldName, Location
location')
constGo :: Node ConstValue -> Seq Error
constGo (Full.Node (Full.ConstObject fields :: [ObjectField ConstValue]
fields) _) = [ObjectField ConstValue] -> Seq Error
forall a. [ObjectField a] -> Seq Error
filterFieldDuplicates [ObjectField ConstValue]
fields
constGo _ = 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 parentType :: Maybe (Type m)
parentType (Full.Field _ fieldName :: Name
fieldName _ _ _ location' :: Location
location')
| Just objectType :: 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 typeName :: Name
typeName <- Type m -> Maybe Name
forall (m :: * -> *). Type m -> Maybe Name
compositeTypeName 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 fieldName :: Name
fieldName typeName :: Name
typeName = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ "Cannot query field \""
, Name -> String
Text.unpack Name
fieldName
, "\" on type \""
, Name -> String
Text.unpack Name
typeName
, "\"."
]
compositeTypeName :: forall m. Out.Type m -> Maybe Full.Name
compositeTypeName :: Type m -> Maybe Name
compositeTypeName (Out.ObjectBaseType (Out.ObjectType typeName :: Name
typeName _ _ _)) =
Name -> Maybe Name
forall a. a -> Maybe a
Just Name
typeName
compositeTypeName (Out.InterfaceBaseType interfaceType :: InterfaceType m
interfaceType) =
let Out.InterfaceType typeName :: Name
typeName _ _ _ = InterfaceType m
interfaceType
in Name -> Maybe Name
forall a. a -> Maybe a
Just Name
typeName
compositeTypeName (Out.UnionBaseType (Out.UnionType typeName :: Name
typeName _ _)) =
Name -> Maybe Name
forall a. a -> Maybe a
Just Name
typeName
compositeTypeName (Out.ScalarBaseType _) =
Maybe Name
forall a. Maybe a
Nothing
compositeTypeName (Out.EnumBaseType _) =
Maybe Name
forall a. Maybe a
Nothing
compositeTypeName (Out.ListBaseType wrappedType :: Type m
wrappedType) =
Type m -> Maybe Name
forall (m :: * -> *). Type m -> Maybe Name
compositeTypeName Type m
wrappedType
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 parentType :: Maybe (Type m)
parentType selectionField :: Field
selectionField@(Full.Field _ fieldName :: Name
fieldName _ _ _ _)
| Just objectType :: Type m
objectType <- Maybe (Type m)
parentType
, Just field :: 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 _ fieldType :: Type m
fieldType _ = 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 typeName :: Name
typeName _ _ _)) =
Name -> Field -> f Error
forall (f :: * -> *).
(Applicative f, Monoid (f Error)) =>
Name -> Field -> f Error
checkNotEmpty Name
typeName
check (Out.InterfaceBaseType (Out.InterfaceType typeName :: Name
typeName _ _ _)) =
Name -> Field -> f Error
forall (f :: * -> *).
(Applicative f, Monoid (f Error)) =>
Name -> Field -> f Error
checkNotEmpty Name
typeName
check (Out.UnionBaseType (Out.UnionType typeName :: Name
typeName _ _)) =
Name -> Field -> f Error
forall (f :: * -> *).
(Applicative f, Monoid (f Error)) =>
Name -> Field -> f Error
checkNotEmpty Name
typeName
check (Out.ScalarBaseType (Definition.ScalarType typeName :: Name
typeName _)) =
Name -> Field -> f Error
forall (f :: * -> *).
(Monoid (f Error), Applicative f) =>
Name -> Field -> f Error
checkEmpty Name
typeName
check (Out.EnumBaseType (Definition.EnumType typeName :: Name
typeName _ _)) =
Name -> Field -> f Error
forall (f :: * -> *).
(Monoid (f Error), Applicative f) =>
Name -> Field -> f Error
checkEmpty Name
typeName
check (Out.ListBaseType wrappedType :: Type m
wrappedType) = Type m -> Field -> f Error
check Type m
wrappedType
checkNotEmpty :: Name -> Field -> f Error
checkNotEmpty typeName :: Name
typeName (Full.Field _ fieldName :: Name
fieldName _ _ [] location' :: 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
[ "Field \""
, String
fieldName'
, "\" of type \""
, Name -> String
Text.unpack Name
typeName
, "\" must have a selection of subfields. Did you mean \""
, String
fieldName'
, " { ... }\"?"
]
checkNotEmpty _ _ = f Error
forall a. Monoid a => a
mempty
checkEmpty :: Name -> Field -> f Error
checkEmpty _ (Full.Field _ _ _ _ [] _) = f Error
forall a. Monoid a => a
mempty
checkEmpty typeName :: Name
typeName field' :: Field
field' =
let Full.Field _ fieldName :: Name
fieldName _ _ _ location' :: 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
[ "Field \""
, Name -> String
Text.unpack Name
fieldName
, "\" must not have a selection since type \""
, Name -> String
Text.unpack Name
typeName
, "\" has no subfields."
]
makeError :: Location -> String -> f Error
makeError location' :: Location
location' errorMessage :: 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 objectType :: Type m
objectType) (Full.Field _ fieldName :: Name
fieldName arguments :: [Argument]
arguments _ _ _)
| Just typeField :: 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 typeName :: Name
typeName <- Type m -> Maybe Name
forall (m :: * -> *). Type m -> Maybe Name
compositeTypeName 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 _ _ = 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 typeName :: Name
typeName fieldName :: Name
fieldName fieldDefinition :: Field m
fieldDefinition (Full.Argument argumentName :: Name
argumentName _ location' :: Location
location') errors :: Seq Error
errors
| Out.Field _ _ definitions :: Arguments
definitions <- Field m
fieldDefinition
, Just _ <- 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 argumentName :: Name
argumentName fieldName :: Name
fieldName typeName :: Name
typeName = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ "Unknown argument \""
, Name -> String
Text.unpack Name
argumentName
, "\" on field \""
, Name -> String
Text.unpack Name
typeName
, "."
, Name -> String
Text.unpack Name
fieldName
, "\"."
]
directiveRule :: Directive -> ReaderT (Validation m) Seq Error
directiveRule (Full.Directive directiveName :: Name
directiveName arguments :: [Argument]
arguments _) = 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 argumentName :: Name
argumentName _ location' :: 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 _ _ definitions :: 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'
_ -> 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 argumentName :: Name
argumentName directiveName :: Name
directiveName location' :: 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 argumentName :: Name
argumentName directiveName :: Name
directiveName = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ "Unknown argument \""
, Name -> String
Text.unpack Name
argumentName
, "\" on directive \"@"
, Name -> String
Text.unpack Name
directiveName
, "\"."
]
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
$ \directives' :: [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 difference :: 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 directiveName' :: Name
directiveName' _ _) = Name
directiveName'
makeError :: Directive -> Error
makeError (Full.Directive directiveName' :: Name
directiveName' _ location' :: Location
location') = Error :: String -> [Location] -> Error
Error
{ message :: String
message = Name -> String
errorMessage Name
directiveName'
, locations :: [Location]
locations = [Location
location']
}
errorMessage :: Name -> String
errorMessage directiveName' :: Name
directiveName' = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ "Unknown directive \"@"
, Name -> String
Text.unpack Name
directiveName'
, "\"."
]
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 valueType :: Type
valueType) (Full.Node (Full.Object inputFields :: [ObjectField Value]
inputFields) _)
| In.InputObjectBaseType objectType :: 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 _ _ = 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 valueType :: Type
valueType) (Full.Node (Full.ConstObject inputFields :: [ObjectField ConstValue]
inputFields) _)
| In.InputObjectBaseType objectType :: 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 _ _ = 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 objectType :: InputObjectType
objectType (Full.ObjectField inputFieldName :: Name
inputFieldName _ location' :: Location
location')
| In.InputObjectType _ _ fieldTypes :: HashMap Name InputField
fieldTypes <- InputObjectType
objectType
, Just _ <- 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 typeName :: Name
typeName _ _ <- 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 fieldName :: Name
fieldName typeName :: Name
typeName = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ "Field \""
, Name -> String
Text.unpack Name
fieldName
, "\" is not defined by type \""
, Name -> String
Text.unpack Name
typeName
, "\"."
]
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
directiveLocation directives' :: [Directive]
directives' = do
Full.Directive directiveName :: Name
directiveName _ location :: 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 _ allowedLocations :: [DirectiveLocation]
allowedLocations _)
| 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]
}
_ -> 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 directiveName :: Name
directiveName directiveLocation :: a
directiveLocation = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ "Directive \"@"
, Name -> String
Text.unpack Name
directiveName
, "\" may not be used on "
, a -> String
forall a. Show a => a -> String
show a
directiveLocation
, "."
]
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 objectType :: Type a
objectType) (Full.Field _ fieldName :: Name
fieldName arguments :: [Argument]
arguments _ _ location' :: Location
location')
| Just typeField :: 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 _ _ definitions :: 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 _ _ = 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 directiveName :: Name
directiveName arguments :: [Argument]
arguments location' :: 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 _ _ definitions :: 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
_ -> 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 makeMessage :: Name -> Name -> String
makeMessage arguments :: t Argument
arguments location' :: Location
location' argumentName :: Name
argumentName argumentType :: Argument
argumentType errors :: Seq Error
errors
| In.Argument _ type' :: Type
type' optionalValue :: 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 errorMessage :: String
errorMessage location' :: 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 _ (Full.Node Full.Null _) _)) = Bool
True
isNothingOrNull x :: Maybe Argument
x = Maybe Argument -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Argument
x
lookupArgument :: Name -> Argument -> Bool
lookupArgument needle :: Name
needle (Full.Argument argumentName :: Name
argumentName _ _) =
Name
needle Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
argumentName
fieldMessage :: Name -> Name -> Name -> String
fieldMessage fieldName :: Name
fieldName argumentName :: Name
argumentName typeName :: Name
typeName = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ "Field \""
, Name -> String
Text.unpack Name
fieldName
, "\" argument \""
, Name -> String
Text.unpack Name
argumentName
, "\" of type \""
, Name -> String
Text.unpack Name
typeName
, "\" is required, but it was not provided."
]
directiveMessage :: Name -> Name -> Name -> String
directiveMessage directiveName :: Name
directiveName argumentName :: Name
argumentName typeName :: Name
typeName = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ "Directive \"@"
, Name -> String
Text.unpack Name
directiveName
, "\" argument \""
, Name -> String
Text.unpack Name
argumentName
, "\" of type \""
, Name -> String
Text.unpack Name
typeName
, "\" is required, but it was not provided."
]
inputTypeName :: In.Type -> Text
inputTypeName :: Type -> Name
inputTypeName (In.ScalarBaseType (Definition.ScalarType typeName :: Name
typeName _)) = Name
typeName
inputTypeName (In.EnumBaseType (Definition.EnumType typeName :: Name
typeName _ _)) = Name
typeName
inputTypeName (In.InputObjectBaseType (In.InputObjectType typeName :: Name
typeName _ _)) =
Name
typeName
inputTypeName (In.ListBaseType listType :: 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 valueType :: Type
valueType) (Full.Node (Full.Object inputFields :: [ObjectField Value]
inputFields) location' :: Location
location')
| In.InputObjectBaseType objectType :: InputObjectType
objectType <- Type
valueType
, In.InputObjectType objectTypeName :: Name
objectTypeName _ fieldDefinitions :: 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 _ _ = 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 _ _ = 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 inputFields :: t (ObjectField Value)
inputFields typeName :: Name
typeName location' :: Location
location' definitionName :: Name
definitionName fieldDefinition :: InputField
fieldDefinition
| In.InputField _ inputType :: Type
inputType optionalValue :: 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 _ (Full.Node Full.Null _) _)) = Bool
True
isNothingOrNull x :: Maybe (ObjectField Value)
x = Maybe (ObjectField Value) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (ObjectField Value)
x
lookupField :: Name -> ObjectField a -> Bool
lookupField needle :: Name
needle (Full.ObjectField fieldName :: Name
fieldName _ _) = Name
needle Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
fieldName
makeError :: Name -> Name -> Location -> Error
makeError fieldName :: Name
fieldName typeName :: Name
typeName location' :: 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 fieldName :: Name
fieldName typeName :: Name
typeName = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ "Input field \""
, Name -> String
Text.unpack Name
fieldName
, "\" of type \""
, Name -> String
Text.unpack Name
typeName
, "\" is required, but it was not provided."
]