{- This Source Code Form is subject to the terms of the Mozilla Public License,
   v. 2.0. If a copy of the MPL was not distributed with this file, You can
   obtain one at https://mozilla.org/MPL/2.0/. -}

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}

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

import Control.Monad ((>=>), foldM)
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Reader (ReaderT(..), ask, asks, mapReaderT)
import Control.Monad.Trans.State (StateT, evalStateT, gets, modify)
import Data.Bifunctor (first)
import Data.Foldable (find, fold, foldl', toList)
import qualified Data.HashMap.Strict as HashMap
import Data.HashMap.Strict (HashMap)
import Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet
import Data.List (groupBy, sortBy, sortOn)
import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Ord (comparing)
import Data.Sequence (Seq(..), (|>))
import qualified Data.Sequence as Seq
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Language.GraphQL.AST.Document as Full
import qualified Language.GraphQL.Type.Definition as Definition
import qualified Language.GraphQL.Type.Internal as Type
import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type.Out as Out
import qualified Language.GraphQL.Type.Schema as Schema
import Language.GraphQL.Validate.Validation

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

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

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

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

-- | GraphQL allows a short‐hand form for defining query operations when only
-- that one operation exists in the document.
loneAnonymousOperationRule :: forall m. Rule m
loneAnonymousOperationRule :: forall (m :: * -> *). Rule m
loneAnonymousOperationRule = forall (m :: * -> *). (OperationDefinition -> RuleT m) -> Rule m
OperationDefinitionRule forall a b. (a -> b) -> a -> b
$ \case
      Full.SelectionSet SelectionSet
_ Location
thisLocation -> forall {m :: * -> *}. Location -> ReaderT (Validation m) Seq Error
check Location
thisLocation
      Full.OperationDefinition OperationType
_ Maybe Text
Nothing [VariableDefinition]
_ [Directive]
_ SelectionSet
_ Location
thisLocation ->
          forall {m :: * -> *}. Location -> ReaderT (Validation m) Seq Error
check Location
thisLocation
      OperationDefinition
_ -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a. Monoid a => a
mempty
    where
      check :: Location -> ReaderT (Validation m) Seq Error
check Location
thisLocation = forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks forall (m :: * -> *). Validation m -> Document
ast
          forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Location -> Definition -> Seq Error -> Seq Error
filterAnonymousOperations Location
thisLocation) forall a. Monoid a => a
mempty
      filterAnonymousOperations :: Location -> Definition -> Seq Error -> Seq Error
filterAnonymousOperations Location
thisLocation Definition
definition Seq Error
Empty
          | (Definition -> Maybe OperationDefinition
viewOperation -> Just OperationDefinition
operationDefinition) <- Definition
definition =
              forall {f :: * -> *}.
(Applicative f, Monoid (f Error)) =>
Location -> OperationDefinition -> f Error
compareAnonymousOperations Location
thisLocation OperationDefinition
operationDefinition
      filterAnonymousOperations Location
_ Definition
_ Seq Error
accumulator = Seq Error
accumulator
      compareAnonymousOperations :: Location -> OperationDefinition -> f Error
compareAnonymousOperations Location
thisLocation = \case
          Full.OperationDefinition OperationType
_ Maybe Text
_ [VariableDefinition]
_ [Directive]
_ SelectionSet
_ Location
thatLocation
              | Location
thisLocation forall a. Eq a => a -> a -> Bool
/= Location
thatLocation -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Location -> Error
error' Location
thisLocation
          Full.SelectionSet SelectionSet
_ Location
thatLocation
              | Location
thisLocation forall a. Eq a => a -> a -> Bool
/= Location
thatLocation -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Location -> Error
error' Location
thisLocation
          OperationDefinition
_ -> forall a. Monoid a => a
mempty
      error' :: Location -> Error
error' Location
location' = Error
          { message :: String
message =
              String
"This anonymous operation must be the only defined operation."
          , locations :: [Location]
locations = [Location
location']
          }

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

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

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

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

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

-- | Named fragment spreads must refer to fragments defined within the document.
-- It is a validation error if the target of a spread is not defined.
fragmentSpreadTargetDefinedRule :: forall m. Rule m
fragmentSpreadTargetDefinedRule :: forall (m :: * -> *). Rule m
fragmentSpreadTargetDefinedRule = forall (m :: * -> *). (FragmentSpread -> RuleT m) -> Rule m
FragmentSpreadRule forall a b. (a -> b) -> a -> b
$ \case
    Full.FragmentSpread Text
fragmentName [Directive]
_ Location
location' -> do
        Document
ast' <- forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks forall (m :: * -> *). Validation m -> Document
ast
        case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Text -> Definition -> Bool
isSpreadTarget Text
fragmentName) Document
ast' of
            Maybe Definition
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Error
                { message :: String
message = Text -> String
error' Text
fragmentName
                , locations :: [Location]
locations = [Location
location']
                }
            Just Definition
_ -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a. Monoid a => a
mempty
  where
    error' :: Text -> String
error' Text
fragmentName = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Fragment target \""
        , Text -> String
Text.unpack Text
fragmentName
        , String
"\" is undefined."
        ]

isSpreadTarget :: Text -> Full.Definition -> Bool
isSpreadTarget :: Text -> Definition -> Bool
isSpreadTarget Text
thisName (Definition -> Maybe FragmentDefinition
viewFragment -> Just FragmentDefinition
fragmentDefinition)
    | Full.FragmentDefinition Text
thatName Text
_ [Directive]
_ SelectionSet
_ Location
_ <- FragmentDefinition
fragmentDefinition
    , Text
thisName forall a. Eq a => a -> a -> Bool
== Text
thatName = Bool
True
isSpreadTarget Text
_ Definition
_ = Bool
False

-- | Fragments must be specified on types that exist in the schema. This applies
-- for both named and inline fragments. If they are not defined in the schema,
-- the query does not validate.
fragmentSpreadTypeExistenceRule :: forall m. Rule m
fragmentSpreadTypeExistenceRule :: forall (m :: * -> *). Rule m
fragmentSpreadTypeExistenceRule = forall (m :: * -> *).
(Maybe (Type m) -> Selection -> RuleT m) -> Rule m
SelectionRule forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ \case
    Full.FragmentSpreadSelection FragmentSpread
fragmentSelection
        | Full.FragmentSpread Text
fragmentName [Directive]
_ Location
location' <- FragmentSpread
fragmentSelection -> do
            HashMap Text (Type m)
types' <- forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Schema m -> HashMap Text (Type m)
Schema.types forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Validation m -> Schema m
schema
            Text
typeCondition <- forall (m1 :: * -> *). Text -> ReaderT (Validation m1) Seq Text
findSpreadTarget Text
fragmentName
            case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
typeCondition HashMap Text (Type m)
types' of
                Maybe (Type m)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Error
                    { message :: String
message = Text -> Text -> String
spreadError Text
fragmentName Text
typeCondition
                    , locations :: [Location]
locations = [Location
location']
                    }
                Just Type m
_ -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a. Monoid a => a
mempty
    Full.InlineFragmentSelection InlineFragment
fragmentSelection
        | Full.InlineFragment Maybe Text
maybeType [Directive]
_ SelectionSet
_ Location
location' <- InlineFragment
fragmentSelection
        , Just Text
typeCondition <- Maybe Text
maybeType -> do
            HashMap Text (Type m)
types' <- forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Schema m -> HashMap Text (Type m)
Schema.types forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Validation m -> Schema m
schema
            case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
typeCondition HashMap Text (Type m)
types' of
                Maybe (Type m)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Error
                    { message :: String
message = Text -> String
inlineError Text
typeCondition
                    , locations :: [Location]
locations = [Location
location']
                    }
                Just Type m
_ -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a. Monoid a => a
mempty
    Selection
_ -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a. Monoid a => a
mempty
  where
    spreadError :: Text -> Text -> String
spreadError Text
fragmentName Text
typeCondition = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Fragment \""
        , Text -> String
Text.unpack Text
fragmentName
        , String
"\" is specified on type \""
        , Text -> String
Text.unpack Text
typeCondition
        , String
"\" which doesn't exist in the schema."
        ]
    inlineError :: Text -> String
inlineError Text
typeCondition = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Inline fragment is specified on type \""
        , Text -> String
Text.unpack Text
typeCondition
        , String
"\" which doesn't exist in the schema."
        ]

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

-- | Fragments can only be declared on unions, interfaces, and objects. They are
-- invalid on scalars. They can only be applied on non‐leaf fields. This rule
-- applies to both inline and named fragments.
fragmentsOnCompositeTypesRule :: forall m. Rule m
fragmentsOnCompositeTypesRule :: forall (m :: * -> *). Rule m
fragmentsOnCompositeTypesRule = forall (m :: * -> *).
(FragmentDefinition -> RuleT m)
-> (InlineFragment -> RuleT m) -> Rule m
FragmentRule forall {m :: * -> *}.
FragmentDefinition -> ReaderT (Validation m) Seq Error
definitionRule forall {m :: * -> *}.
InlineFragment -> ReaderT (Validation m) Seq Error
inlineRule
  where
    inlineRule :: InlineFragment -> ReaderT (Validation m) Seq Error
inlineRule (Full.InlineFragment (Just Text
typeCondition) [Directive]
_ SelectionSet
_ Location
location') =
        forall {m :: * -> *}.
Text -> Location -> ReaderT (Validation m) Seq Error
check Text
typeCondition Location
location'
    inlineRule InlineFragment
_ = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a. Monoid a => a
mempty
    definitionRule :: FragmentDefinition -> ReaderT (Validation m) Seq Error
definitionRule (Full.FragmentDefinition Text
_ Text
typeCondition [Directive]
_ SelectionSet
_ Location
location') =
        forall {m :: * -> *}.
Text -> Location -> ReaderT (Validation m) Seq Error
check Text
typeCondition Location
location'
    check :: Text -> Location -> ReaderT (Validation m) Seq Error
check Text
typeCondition Location
location' = do
        HashMap Text (Type m)
types' <- forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Schema m -> HashMap Text (Type m)
Schema.types forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Validation m -> Schema m
schema
        -- Skip unknown types, they are checked by another rule.
        Type m
_ <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Maybe a -> Seq a
maybeToSeq forall a b. (a -> b) -> a -> b
$ forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
typeCondition HashMap Text (Type m)
types'
        case forall (m :: * -> *).
Text -> HashMap Text (Type m) -> Maybe (CompositeType m)
Type.lookupTypeCondition Text
typeCondition HashMap Text (Type m)
types' of
            Maybe (CompositeType m)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Error
                { message :: String
message = Text -> String
errorMessage Text
typeCondition
                , locations :: [Location]
locations = [Location
location']
                }
            Just CompositeType m
_ -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a. Monoid a => a
mempty
    errorMessage :: Text -> String
errorMessage Text
typeCondition = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Fragment cannot condition on non composite type \""
        , Text -> String
Text.unpack Text
typeCondition,
        String
"\"."
        ]

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

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

filterSelections :: Foldable t
    => forall a m
    . (Full.Selection -> ValidationState m a)
    -> t Full.Selection
    -> ValidationState m a
filterSelections :: forall (t :: * -> *) a (m :: * -> *).
Foldable t =>
(Selection -> ValidationState m a)
-> t Selection -> ValidationState m a
filterSelections Selection -> ValidationState m a
applyFilter t Selection
selections
    = (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift) (forall a. [a] -> Seq a
Seq.fromList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Selection -> SelectionSetOpt -> SelectionSetOpt
evaluateSelection forall a. Monoid a => a
mempty t Selection
selections)
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Selection -> ValidationState m a
applyFilter
  where
    evaluateSelection :: Selection -> SelectionSetOpt -> SelectionSetOpt
evaluateSelection Selection
selection SelectionSetOpt
accumulator
        | Full.FragmentSpreadSelection{} <- Selection
selection = Selection
selection forall a. a -> [a] -> [a]
: SelectionSetOpt
accumulator
        | Full.FieldSelection Field
fieldSelection <- Selection
selection
        , Full.Field Maybe Text
_ Text
_ [Argument]
_ [Directive]
_ SelectionSetOpt
subselections Location
_ <- Field
fieldSelection =
            Selection
selection forall a. a -> [a] -> [a]
: forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Selection -> SelectionSetOpt -> SelectionSetOpt
evaluateSelection SelectionSetOpt
accumulator SelectionSetOpt
subselections
        | Full.InlineFragmentSelection InlineFragment
inlineSelection <- Selection
selection
        , Full.InlineFragment Maybe Text
_ [Directive]
_ SelectionSet
subselections Location
_ <- InlineFragment
inlineSelection =
            Selection
selection forall a. a -> [a] -> [a]
: forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Selection -> SelectionSetOpt -> SelectionSetOpt
evaluateSelection SelectionSetOpt
accumulator SelectionSet
subselections

-- | The graph of fragment spreads must not form any cycles including spreading
-- itself. Otherwise an operation could infinitely spread or infinitely execute
-- on cycles in the underlying data.
noFragmentCyclesRule :: forall m. Rule m
noFragmentCyclesRule :: forall (m :: * -> *). Rule m
noFragmentCyclesRule = forall (m :: * -> *). (FragmentDefinition -> RuleT m) -> Rule m
FragmentDefinitionRule forall a b. (a -> b) -> a -> b
$ \case
    Full.FragmentDefinition Text
fragmentName Text
_ [Directive]
_ SelectionSet
selections Location
location' -> do
        HashMap Text Int
state <- forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (forall (t :: * -> *).
Traversable t =>
t Selection
-> StateT
     (Int, Text) (ReaderT (Validation m) Seq) (HashMap Text Int)
collectCycles SelectionSet
selections) (Int
0, Text
fragmentName)
        let spreadPath :: [Text]
spreadPath = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall a b. (a, b) -> b
snd) (forall k v. HashMap k v -> [(k, v)]
HashMap.toList HashMap Text Int
state)
        case forall a. [a] -> [a]
reverse [Text]
spreadPath of
            Text
x : [Text]
_ | Text
x forall a. Eq a => a -> a -> Bool
== Text
fragmentName -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Error
                { message :: String
message = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                    [ String
"Cannot spread fragment \""
                    , Text -> String
Text.unpack Text
fragmentName
                    , String
"\" within itself (via "
                    , Text -> String
Text.unpack forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
Text.intercalate Text
" -> " forall a b. (a -> b) -> a -> b
$ Text
fragmentName forall a. a -> [a] -> [a]
: [Text]
spreadPath
                    , String
")."
                    ]
                , locations :: [Location]
locations = [Location
location']
                }
            [Text]
_ -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a. Monoid a => a
mempty
  where
    collectCycles :: Traversable t
        => t Full.Selection
        -> StateT (Int, Full.Name) (ReaderT (Validation m) Seq) (HashMap Full.Name Int)
    collectCycles :: forall (t :: * -> *).
Traversable t =>
t Selection
-> StateT
     (Int, Text) (ReaderT (Validation m) Seq) (HashMap Text Int)
collectCycles = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM HashMap Text Int
-> Selection
-> StateT
     (Int, Text) (ReaderT (Validation m) Seq) (HashMap Text Int)
forEach forall k v. HashMap k v
HashMap.empty
    forEach :: HashMap Text Int
-> Selection
-> StateT
     (Int, Text) (ReaderT (Validation m) Seq) (HashMap Text Int)
forEach HashMap Text Int
accumulator = \case
        Full.FieldSelection Field
fieldSelection -> HashMap Text Int
-> Field
-> StateT
     (Int, Text) (ReaderT (Validation m) Seq) (HashMap Text Int)
forField HashMap Text Int
accumulator Field
fieldSelection
        Full.InlineFragmentSelection InlineFragment
fragmentSelection ->
            HashMap Text Int
-> InlineFragment
-> StateT
     (Int, Text) (ReaderT (Validation m) Seq) (HashMap Text Int)
forInline HashMap Text Int
accumulator InlineFragment
fragmentSelection
        Full.FragmentSpreadSelection FragmentSpread
fragmentSelection ->
            HashMap Text Int
-> FragmentSpread
-> StateT
     (Int, Text) (ReaderT (Validation m) Seq) (HashMap Text Int)
forSpread HashMap Text Int
accumulator FragmentSpread
fragmentSelection
    forSpread :: HashMap Text Int
-> FragmentSpread
-> StateT
     (Int, Text) (ReaderT (Validation m) Seq) (HashMap Text Int)
forSpread HashMap Text Int
accumulator (Full.FragmentSpread Text
fragmentName [Directive]
_ Location
_) = do
        Text
firstFragmentName <- forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets forall a b. (a, b) -> b
snd
        forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall a. Num a => a -> a -> a
+ Int
1)
        Int
lastIndex <- forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets forall a b. (a, b) -> a
fst
        let newAccumulator :: HashMap Text Int
newAccumulator = forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert Text
fragmentName Int
lastIndex HashMap Text Int
accumulator
        let inVisitetFragment :: Bool
inVisitetFragment = forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
HashMap.member Text
fragmentName HashMap Text Int
accumulator
        if Text
fragmentName forall a. Eq a => a -> a -> Bool
== Text
firstFragmentName Bool -> Bool -> Bool
|| Bool
inVisitetFragment
            then forall (f :: * -> *) a. Applicative f => a -> f a
pure HashMap Text Int
newAccumulator
            else Text
-> HashMap Text Int
-> StateT
     (Int, Text) (ReaderT (Validation m) Seq) (HashMap Text Int)
collectFromSpread Text
fragmentName HashMap Text Int
newAccumulator
    forInline :: HashMap Text Int
-> InlineFragment
-> StateT
     (Int, Text) (ReaderT (Validation m) Seq) (HashMap Text Int)
forInline HashMap Text Int
accumulator (Full.InlineFragment Maybe Text
_ [Directive]
_ SelectionSet
selections Location
_) =
        (HashMap Text Int
accumulator forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *).
Traversable t =>
t Selection
-> StateT
     (Int, Text) (ReaderT (Validation m) Seq) (HashMap Text Int)
collectCycles SelectionSet
selections
    forField :: HashMap Text Int
-> Field
-> StateT
     (Int, Text) (ReaderT (Validation m) Seq) (HashMap Text Int)
forField HashMap Text Int
accumulator (Full.Field Maybe Text
_ Text
_ [Argument]
_ [Directive]
_ SelectionSetOpt
selections Location
_) =
        (HashMap Text Int
accumulator forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *).
Traversable t =>
t Selection
-> StateT
     (Int, Text) (ReaderT (Validation m) Seq) (HashMap Text Int)
collectCycles SelectionSetOpt
selections
    collectFromSpread :: Text
-> HashMap Text Int
-> StateT
     (Int, Text) (ReaderT (Validation m) Seq) (HashMap Text Int)
collectFromSpread Text
fragmentName HashMap Text Int
accumulator = do
        Document
ast' <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks forall (m :: * -> *). Validation m -> Document
ast
        case Text -> Document -> Maybe FragmentDefinition
findFragmentDefinition Text
fragmentName Document
ast' of
            Maybe FragmentDefinition
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure HashMap Text Int
accumulator
            Just (Full.FragmentDefinition Text
_ Text
_ [Directive]
_ SelectionSet
selections Location
_) ->
                (HashMap Text Int
accumulator forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *).
Traversable t =>
t Selection
-> StateT
     (Int, Text) (ReaderT (Validation m) Seq) (HashMap Text Int)
collectCycles SelectionSet
selections

findFragmentDefinition :: Text
    -> NonEmpty Full.Definition
    -> Maybe Full.FragmentDefinition
findFragmentDefinition :: Text -> Document -> Maybe FragmentDefinition
findFragmentDefinition Text
fragmentName = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Definition -> Maybe FragmentDefinition -> Maybe FragmentDefinition
compareDefinition forall a. Maybe a
Nothing
  where
    compareDefinition :: Definition -> Maybe FragmentDefinition -> Maybe FragmentDefinition
compareDefinition (Full.ExecutableDefinition ExecutableDefinition
executableDefinition) Maybe FragmentDefinition
Nothing
        | Full.DefinitionFragment FragmentDefinition
fragmentDefinition <- ExecutableDefinition
executableDefinition
        , Full.FragmentDefinition Text
anotherName Text
_ [Directive]
_ SelectionSet
_ Location
_ <- FragmentDefinition
fragmentDefinition
        , Text
anotherName forall a. Eq a => a -> a -> Bool
== Text
fragmentName = forall a. a -> Maybe a
Just FragmentDefinition
fragmentDefinition
    compareDefinition Definition
_ Maybe FragmentDefinition
accumulator = Maybe FragmentDefinition
accumulator

-- | Fields and directives treat arguments as a mapping of argument name to
-- value. More than one argument with the same name in an argument set is
-- ambiguous and invalid.
uniqueArgumentNamesRule :: forall m. Rule m
uniqueArgumentNamesRule :: forall (m :: * -> *). Rule m
uniqueArgumentNamesRule = forall (m :: * -> *).
(Maybe (Type m) -> Field -> RuleT m)
-> (Directive -> RuleT m) -> Rule m
ArgumentsRule forall {t :: (* -> *) -> * -> *} {p}.
MonadTrans t =>
p -> Field -> t Seq Error
fieldRule forall {t :: (* -> *) -> * -> *}.
MonadTrans t =>
Directive -> t Seq Error
directiveRule
  where
    fieldRule :: p -> Field -> t Seq Error
fieldRule p
_ (Full.Field Maybe Text
_ Text
_ [Argument]
arguments [Directive]
_ SelectionSetOpt
_ Location
_) =
        forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. (a -> (Text, Location)) -> String -> [a] -> Seq Error
filterDuplicates Argument -> (Text, Location)
extract String
"argument" [Argument]
arguments
    directiveRule :: Directive -> t Seq Error
directiveRule (Full.Directive Text
_ [Argument]
arguments Location
_) =
        forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. (a -> (Text, Location)) -> String -> [a] -> Seq Error
filterDuplicates Argument -> (Text, Location)
extract String
"argument" [Argument]
arguments
    extract :: Argument -> (Text, Location)
extract (Full.Argument Text
argumentName Node Value
_ Location
location') = (Text
argumentName, Location
location')

-- | Directives are used to describe some metadata or behavioral change on the
-- definition they apply to. When more than one directive of the same name is
-- used, the expected metadata or behavior becomes ambiguous, therefore only one
-- of each directive is allowed per location.
uniqueDirectiveNamesRule :: forall m. Rule m
uniqueDirectiveNamesRule :: forall (m :: * -> *). Rule m
uniqueDirectiveNamesRule = forall (m :: * -> *).
(DirectiveLocation -> [Directive] -> RuleT m) -> Rule m
DirectivesRule
    forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> (Text, Location)) -> String -> [a] -> Seq Error
filterDuplicates Directive -> (Text, Location)
extract String
"directive"
  where
    extract :: Directive -> (Text, Location)
extract (Full.Directive Text
directiveName [Argument]
_ Location
location') =
        (Text
directiveName, Location
location')

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

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

-- | If any operation defines more than one variable with the same name, it is
-- ambiguous and invalid. It is invalid even if the type of the duplicate
-- variable is the same.
uniqueVariableNamesRule :: forall m. Rule m
uniqueVariableNamesRule :: forall (m :: * -> *). Rule m
uniqueVariableNamesRule = forall (m :: * -> *). ([VariableDefinition] -> RuleT m) -> Rule m
VariablesRule
    forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> (Text, Location)) -> String -> [a] -> Seq Error
filterDuplicates VariableDefinition -> (Text, Location)
extract String
"variable"
  where
    extract :: VariableDefinition -> (Text, Location)
extract (Full.VariableDefinition Text
variableName Type
_ Maybe (Node ConstValue)
_ Location
location') =
        (Text
variableName, Location
location')

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

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

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

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

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

-- | Input objects must not contain more than one field of the same name,
-- otherwise an ambiguity would exist which includes an ignored portion of
-- syntax.
uniqueInputFieldNamesRule :: forall m. Rule m
uniqueInputFieldNamesRule :: forall (m :: * -> *). Rule m
uniqueInputFieldNamesRule =
    forall (m :: * -> *).
(Maybe Type -> Node Value -> RuleT m)
-> (Maybe Type -> Node ConstValue -> RuleT m) -> Rule m
ValueRule (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node Value -> Seq Error
go) (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node ConstValue -> Seq Error
constGo)
  where
    go :: Node Value -> Seq Error
go (Full.Node (Full.Object [ObjectField Value]
fields) Location
_) = forall {a}. [ObjectField a] -> Seq Error
filterFieldDuplicates [ObjectField Value]
fields
    go Node Value
_ = forall a. Monoid a => a
mempty
    filterFieldDuplicates :: [ObjectField a] -> Seq Error
filterFieldDuplicates = forall a. (a -> (Text, Location)) -> String -> [a] -> Seq Error
filterDuplicates forall {a}. ObjectField a -> (Text, Location)
getFieldName String
"input field"
    getFieldName :: ObjectField a -> (Text, Location)
getFieldName (Full.ObjectField Text
fieldName Node a
_ Location
location') = (Text
fieldName, Location
location')
    constGo :: Node ConstValue -> Seq Error
constGo (Full.Node (Full.ConstObject [ObjectField ConstValue]
fields) Location
_) = forall {a}. [ObjectField a] -> Seq Error
filterFieldDuplicates [ObjectField ConstValue]
fields
    constGo Node ConstValue
_ = forall a. Monoid a => a
mempty

-- | The target field of a field selection must be defined on the scoped type of
-- the selection set. There are no limitations on alias names.
fieldsOnCorrectTypeRule :: forall m. Rule m
fieldsOnCorrectTypeRule :: forall (m :: * -> *). Rule m
fieldsOnCorrectTypeRule = forall (m :: * -> *).
(Maybe (Type m) -> Field -> RuleT m) -> Rule m
FieldRule forall {t :: (* -> *) -> * -> *} {m :: * -> *} {m :: * -> *}.
(MonadTrans t, Monad m, Monoid (m Error), Applicative (t m)) =>
Maybe (Type m) -> Field -> t m Error
fieldRule
  where
    fieldRule :: Maybe (Type m) -> Field -> t m Error
fieldRule Maybe (Type m)
parentType (Full.Field Maybe Text
_ Text
fieldName [Argument]
_ [Directive]
_ SelectionSetOpt
_ Location
location')
        | Just Type m
objectType <- Maybe (Type m)
parentType
        , Maybe (Field m)
Nothing <- forall (a :: * -> *). Text -> Type a -> Maybe (Field a)
Type.lookupTypeField Text
fieldName Type m
objectType
        , Just Text
typeName <- forall (m :: * -> *). Type m -> Maybe Text
typeNameIfComposite Type m
objectType = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Error
            { message :: String
message = Text -> Text -> String
errorMessage Text
fieldName Text
typeName
            , locations :: [Location]
locations = [Location
location']
            }
        | Bool
otherwise = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a. Monoid a => a
mempty
    errorMessage :: Text -> Text -> String
errorMessage Text
fieldName Text
typeName = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Cannot query field \""
        , Text -> String
Text.unpack Text
fieldName
        , String
"\" on type \""
        , Text -> String
Text.unpack Text
typeName
        , String
"\"."
        ]

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

typeNameIfComposite :: forall m. Out.Type m -> Maybe Full.Name
typeNameIfComposite :: forall (m :: * -> *). Type m -> Maybe Text
typeNameIfComposite = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *). CompositeType m -> Text
compositeTypeName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> *). Type a -> Maybe (CompositeType a)
Type.outToComposite

-- | Field selections on scalars or enums are never allowed, because they are
-- the leaf nodes of any GraphQL query.
scalarLeafsRule :: forall m. Rule m
scalarLeafsRule :: forall (m :: * -> *). Rule m
scalarLeafsRule = forall (m :: * -> *).
(Maybe (Type m) -> Field -> RuleT m) -> Rule m
FieldRule forall {t :: (* -> *) -> * -> *} {m :: * -> *} {m :: * -> *}.
(MonadTrans t, Monad m, Monoid (m Error)) =>
Maybe (Type m) -> Field -> t m Error
fieldRule
  where
    fieldRule :: Maybe (Type m) -> Field -> t m Error
fieldRule Maybe (Type m)
parentType selectionField :: Field
selectionField@(Full.Field Maybe Text
_ Text
fieldName [Argument]
_ [Directive]
_ SelectionSetOpt
_ Location
_)
        | Just Type m
objectType <- Maybe (Type m)
parentType
        , Just Field m
field <- forall (a :: * -> *). Text -> Type a -> Maybe (Field a)
Type.lookupTypeField Text
fieldName Type m
objectType =
            let Out.Field Maybe Text
_ Type m
fieldType Arguments
_ = Field m
field
             in forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall {f :: * -> *} {m :: * -> *}.
(Applicative f, Monoid (f Error)) =>
Type m -> Field -> f Error
check Type m
fieldType Field
selectionField
        | Bool
otherwise = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a. Monoid a => a
mempty
    check :: Type m -> Field -> f Error
check (Out.ObjectBaseType (Out.ObjectType Text
typeName Maybe Text
_ [InterfaceType m]
_ HashMap Text (Resolver m)
_)) =
        forall {f :: * -> *}.
(Applicative f, Monoid (f Error)) =>
Text -> Field -> f Error
checkNotEmpty Text
typeName
    check (Out.InterfaceBaseType (Out.InterfaceType Text
typeName Maybe Text
_ [InterfaceType m]
_ HashMap Text (Field m)
_)) =
        forall {f :: * -> *}.
(Applicative f, Monoid (f Error)) =>
Text -> Field -> f Error
checkNotEmpty Text
typeName
    check (Out.UnionBaseType (Out.UnionType Text
typeName Maybe Text
_ [ObjectType m]
_)) =
        forall {f :: * -> *}.
(Applicative f, Monoid (f Error)) =>
Text -> Field -> f Error
checkNotEmpty Text
typeName
    check (Out.ScalarBaseType (Definition.ScalarType Text
typeName Maybe Text
_)) =
        forall {f :: * -> *}.
(Monoid (f Error), Applicative f) =>
Text -> Field -> f Error
checkEmpty Text
typeName
    check (Out.EnumBaseType (Definition.EnumType Text
typeName Maybe Text
_ HashMap Text EnumValue
_)) =
        forall {f :: * -> *}.
(Monoid (f Error), Applicative f) =>
Text -> Field -> f Error
checkEmpty Text
typeName
    check (Out.ListBaseType Type m
wrappedType) = Type m -> Field -> f Error
check Type m
wrappedType
    checkNotEmpty :: Text -> Field -> f Error
checkNotEmpty Text
typeName (Full.Field Maybe Text
_ Text
fieldName [Argument]
_ [Directive]
_ [] Location
location') =
        let fieldName' :: String
fieldName' = Text -> String
Text.unpack Text
fieldName
         in forall {f :: * -> *}.
Applicative f =>
Location -> String -> f Error
makeError Location
location' forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ String
"Field \""
            , String
fieldName'
            , String
"\" of type \""
            , Text -> String
Text.unpack Text
typeName
            , String
"\" must have a selection of subfields. Did you mean \""
            , String
fieldName'
            , String
" { ... }\"?"
            ]
    checkNotEmpty Text
_ Field
_ = forall a. Monoid a => a
mempty
    checkEmpty :: Text -> Field -> f Error
checkEmpty Text
_ (Full.Field Maybe Text
_ Text
_ [Argument]
_ [Directive]
_ [] Location
_) = forall a. Monoid a => a
mempty
    checkEmpty Text
typeName Field
field' =
        let Full.Field Maybe Text
_ Text
fieldName [Argument]
_ [Directive]
_ SelectionSetOpt
_ Location
location' = Field
field'
         in forall {f :: * -> *}.
Applicative f =>
Location -> String -> f Error
makeError Location
location' forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ String
"Field \""
            , Text -> String
Text.unpack Text
fieldName
            , String
"\" must not have a selection since type \""
            , Text -> String
Text.unpack Text
typeName
            , String
"\" has no subfields."
            ]
    makeError :: Location -> String -> f Error
makeError Location
location' String
errorMessage = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Error
        { message :: String
message = String
errorMessage
        , locations :: [Location]
locations = [Location
location']
        }

-- | Every argument provided to a field or directive must be defined in the set
-- of possible arguments of that field or directive.
knownArgumentNamesRule :: forall m. Rule m
knownArgumentNamesRule :: forall (m :: * -> *). Rule m
knownArgumentNamesRule = forall (m :: * -> *).
(Maybe (Type m) -> Field -> RuleT m)
-> (Directive -> RuleT m) -> Rule m
ArgumentsRule forall {t :: (* -> *) -> * -> *} {m :: * -> *}.
MonadTrans t =>
Maybe (Type m) -> Field -> t Seq Error
fieldRule forall {m :: * -> *}. Directive -> ReaderT (Validation m) Seq Error
directiveRule
  where
    fieldRule :: Maybe (Type m) -> Field -> t Seq Error
fieldRule (Just Type m
objectType) (Full.Field Maybe Text
_ Text
fieldName [Argument]
arguments  [Directive]
_ SelectionSetOpt
_ Location
_)
        | Just Field m
typeField <- forall (a :: * -> *). Text -> Type a -> Maybe (Field a)
Type.lookupTypeField Text
fieldName Type m
objectType
        , Just Text
typeName <- forall (m :: * -> *). Type m -> Maybe Text
typeNameIfComposite Type m
objectType =
            forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall {m :: * -> *}.
Text -> Text -> Field m -> Argument -> Seq Error -> Seq Error
go Text
typeName Text
fieldName Field m
typeField) forall a. Seq a
Seq.empty [Argument]
arguments
    fieldRule Maybe (Type m)
_ Field
_ = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a. Monoid a => a
mempty
    go :: Text -> Text -> Field m -> Argument -> Seq Error -> Seq Error
go Text
typeName Text
fieldName Field m
fieldDefinition (Full.Argument Text
argumentName Node Value
_ Location
location') Seq Error
errors
        | Out.Field Maybe Text
_ Type m
_ Arguments
definitions <- Field m
fieldDefinition
        , Just Argument
_ <- forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
argumentName Arguments
definitions = Seq Error
errors
        | Bool
otherwise = Seq Error
errors forall a. Seq a -> a -> Seq a
|> Error
            { message :: String
message = Text -> Text -> Text -> String
fieldMessage Text
argumentName Text
fieldName Text
typeName
            , locations :: [Location]
locations = [Location
location']
            }
    fieldMessage :: Text -> Text -> Text -> String
fieldMessage Text
argumentName Text
fieldName Text
typeName = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Unknown argument \""
        , Text -> String
Text.unpack Text
argumentName
        , String
"\" on field \""
        , Text -> String
Text.unpack Text
typeName
        , String
"."
        , Text -> String
Text.unpack Text
fieldName
        , String
"\"."
        ]
    directiveRule :: Directive -> ReaderT (Validation m) Seq Error
directiveRule (Full.Directive Text
directiveName [Argument]
arguments Location
_) = do
        Maybe Directive
available <- forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks forall a b. (a -> b) -> a -> b
$ forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
directiveName
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Schema m -> HashMap Text Directive
Schema.directives forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Validation m -> Schema m
schema
        Full.Argument Text
argumentName Node Value
_ Location
location' <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Seq a
Seq.fromList [Argument]
arguments
        case Maybe Directive
available of
            Just (Schema.Directive Maybe Text
_ [DirectiveLocation]
_ Arguments
definitions)
                | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
HashMap.member Text
argumentName Arguments
definitions ->
                    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> Text -> Location -> Error
makeError Text
argumentName Text
directiveName Location
location'
            Maybe Directive
_ -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a. Monoid a => a
mempty
    makeError :: Text -> Text -> Location -> Error
makeError Text
argumentName Text
directiveName Location
location' = Error
        { message :: String
message = Text -> Text -> String
directiveMessage Text
argumentName Text
directiveName
        , locations :: [Location]
locations = [Location
location']
        }
    directiveMessage :: Text -> Text -> String
directiveMessage Text
argumentName Text
directiveName = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Unknown argument \""
        , Text -> String
Text.unpack Text
argumentName
        , String
"\" on directive \"@"
        , Text -> String
Text.unpack Text
directiveName
        , String
"\"."
        ]

-- | GraphQL servers define what directives they support. For each usage of a
-- directive, the directive must be available on that server.
knownDirectiveNamesRule :: Rule m
knownDirectiveNamesRule :: forall (m :: * -> *). Rule m
knownDirectiveNamesRule = forall (m :: * -> *).
(DirectiveLocation -> [Directive] -> RuleT m) -> Rule m
DirectivesRule forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ \[Directive]
directives' -> do
    HashMap Text Directive
definitions' <- forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Schema m -> HashMap Text Directive
Schema.directives forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Validation m -> Schema m
schema
    let directiveSet :: HashSet Text
directiveSet = forall a. (Eq a, Hashable a) => [a] -> HashSet a
HashSet.fromList forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Directive -> Text
directiveName [Directive]
directives'
    let definitionSet :: HashSet Text
definitionSet = forall a. (Eq a, Hashable a) => [a] -> HashSet a
HashSet.fromList forall a b. (a -> b) -> a -> b
$ forall k v. HashMap k v -> [k]
HashMap.keys HashMap Text Directive
definitions'
    let difference :: HashSet Text
difference = forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
HashSet.difference HashSet Text
directiveSet HashSet Text
definitionSet
    let undefined' :: [Directive]
undefined' = forall a. (a -> Bool) -> [a] -> [a]
filter (HashSet Text -> Directive -> Bool
definitionFilter HashSet Text
difference) [Directive]
directives'
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Seq a
Seq.fromList forall a b. (a -> b) -> a -> b
$ Directive -> Error
makeError forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Directive]
undefined'
  where
    definitionFilter :: HashSet Text -> Directive -> Bool
definitionFilter HashSet Text
difference = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
HashSet.member HashSet Text
difference
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. Directive -> Text
directiveName
    directiveName :: Directive -> Text
directiveName (Full.Directive Text
directiveName' [Argument]
_ Location
_) = Text
directiveName'
    makeError :: Directive -> Error
makeError (Full.Directive Text
directiveName' [Argument]
_ Location
location') = Error
        { message :: String
message = Text -> String
errorMessage Text
directiveName'
        , locations :: [Location]
locations = [Location
location']
        }
    errorMessage :: Text -> String
errorMessage Text
directiveName' = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Unknown directive \"@"
        , Text -> String
Text.unpack Text
directiveName'
        , String
"\"."
        ]

-- | Every input field provided in an input object value must be defined in the
-- set of possible fields of that input object’s expected type.
knownInputFieldNamesRule :: Rule m
knownInputFieldNamesRule :: forall (m :: * -> *). Rule m
knownInputFieldNamesRule = forall (m :: * -> *).
(Maybe Type -> Node Value -> RuleT m)
-> (Maybe Type -> Node ConstValue -> RuleT m) -> Rule m
ValueRule forall {t :: (* -> *) -> * -> *}.
MonadTrans t =>
Maybe Type -> Node Value -> t Seq Error
go forall {t :: (* -> *) -> * -> *}.
MonadTrans t =>
Maybe Type -> Node ConstValue -> t Seq Error
constGo
  where
    go :: Maybe Type -> Node Value -> t Seq Error
go (Just Type
valueType) (Full.Node (Full.Object [ObjectField Value]
inputFields) Location
_)
        | In.InputObjectBaseType InputObjectType
objectType <- Type
valueType =
             forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Seq a
Seq.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall {a}. InputObjectType -> ObjectField a -> Maybe Error
forEach InputObjectType
objectType) [ObjectField Value]
inputFields
    go Maybe Type
_ Node Value
_ = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a. Monoid a => a
mempty
    constGo :: Maybe Type -> Node ConstValue -> t Seq Error
constGo (Just Type
valueType) (Full.Node (Full.ConstObject [ObjectField ConstValue]
inputFields) Location
_)
        | In.InputObjectBaseType InputObjectType
objectType <- Type
valueType =
             forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Seq a
Seq.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall {a}. InputObjectType -> ObjectField a -> Maybe Error
forEach InputObjectType
objectType) [ObjectField ConstValue]
inputFields
    constGo  Maybe Type
_ Node ConstValue
_ = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a. Monoid a => a
mempty
    forEach :: InputObjectType -> ObjectField a -> Maybe Error
forEach InputObjectType
objectType (Full.ObjectField Text
inputFieldName Node a
_ Location
location')
        | In.InputObjectType Text
_ Maybe Text
_ HashMap Text InputField
fieldTypes <- InputObjectType
objectType
        , Just InputField
_ <- forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
inputFieldName HashMap Text InputField
fieldTypes = forall a. Maybe a
Nothing
        | Bool
otherwise
        , In.InputObjectType Text
typeName Maybe Text
_ HashMap Text InputField
_ <- InputObjectType
objectType = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Error
            { message :: String
message = Text -> Text -> String
errorMessage Text
inputFieldName Text
typeName
            , locations :: [Location]
locations = [Location
location']
            }
    errorMessage :: Text -> Text -> String
errorMessage Text
fieldName Text
typeName = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Field \""
        , Text -> String
Text.unpack Text
fieldName
        , String
"\" is not defined by type \""
        , Text -> String
Text.unpack Text
typeName
        , String
"\"."
        ]

-- | GraphQL servers define what directives they support and where they support
-- them. For each usage of a directive, the directive must be used in a location
-- that the server has declared support for.
directivesInValidLocationsRule :: Rule m
directivesInValidLocationsRule :: forall (m :: * -> *). Rule m
directivesInValidLocationsRule = forall (m :: * -> *).
(DirectiveLocation -> [Directive] -> RuleT m) -> Rule m
DirectivesRule forall {m :: * -> *}.
DirectiveLocation
-> [Directive] -> ReaderT (Validation m) Seq Error
directivesRule
  where
    directivesRule :: DirectiveLocation
-> [Directive] -> ReaderT (Validation m) Seq Error
directivesRule DirectiveLocation
directiveLocation [Directive]
directives' = do
        Full.Directive Text
directiveName [Argument]
_ Location
location <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Seq a
Seq.fromList [Directive]
directives'
        Maybe Directive
maybeDefinition <- forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks
            forall a b. (a -> b) -> a -> b
$ forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
directiveName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Schema m -> HashMap Text Directive
Schema.directives forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Validation m -> Schema m
schema
        case Maybe Directive
maybeDefinition of
            Just (Schema.Directive Maybe Text
_ [DirectiveLocation]
allowedLocations Arguments
_)
                | DirectiveLocation
directiveLocation forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [DirectiveLocation]
allowedLocations -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Error
                    { message :: String
message = forall {a}. Show a => Text -> a -> String
errorMessage Text
directiveName DirectiveLocation
directiveLocation
                    , locations :: [Location]
locations = [Location
location]
                    }
            Maybe Directive
_ -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a. Monoid a => a
mempty
    errorMessage :: Text -> a -> String
errorMessage Text
directiveName a
directiveLocation = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Directive \"@"
        , Text -> String
Text.unpack Text
directiveName
        , String
"\" may not be used on "
        , forall a. Show a => a -> String
show a
directiveLocation
        , String
"."
        ]

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

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

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

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

data FieldInfo m = FieldInfo
    { forall (m :: * -> *). FieldInfo m -> Field
node :: Full.Field
    , forall (m :: * -> *). FieldInfo m -> Type m
type' :: Out.Type m
    , forall (m :: * -> *). FieldInfo m -> CompositeType m
parent :: Type.CompositeType m
    }

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

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

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

visitFragmentDefinition :: forall m
    . Text
    -> ValidationState m (Maybe Full.FragmentDefinition)
visitFragmentDefinition :: forall (m :: * -> *).
Text -> ValidationState m (Maybe FragmentDefinition)
visitFragmentDefinition Text
fragmentName = do
    Document
definitions <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks forall (m :: * -> *). Validation m -> Document
ast
    Bool
visited <- forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets (forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
HashSet.member Text
fragmentName)
    forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HashSet.insert Text
fragmentName)
    case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Text -> Definition -> Bool
isSpreadTarget Text
fragmentName) Document
definitions of
        Just (Definition -> Maybe FragmentDefinition
viewFragment -> Just FragmentDefinition
fragmentDefinition)
            | Bool -> Bool
not Bool
visited -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just FragmentDefinition
fragmentDefinition
        Maybe Definition
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

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

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

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