{- 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 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
    , providedRequiredInputFieldsRule
    , providedRequiredArgumentsRule
    , scalarLeafsRule
    , singleFieldSubscriptionsRule
    , specifiedRules
    , uniqueArgumentNamesRule
    , uniqueDirectiveNamesRule
    , uniqueFragmentNamesRule
    , uniqueInputFieldNamesRule
    , uniqueOperationNamesRule
    , uniqueVariableNamesRule
    , variablesAreInputTypesRule
    ) where

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

compositeTypeName :: forall m. Out.Type m -> Maybe Full.Name
compositeTypeName :: Type m -> Maybe Name
compositeTypeName (Out.ObjectBaseType (Out.ObjectType typeName :: Name
typeName _ _ _)) =
    Name -> Maybe Name
forall a. a -> Maybe a
Just Name
typeName
compositeTypeName (Out.InterfaceBaseType interfaceType :: InterfaceType m
interfaceType) =
    let Out.InterfaceType typeName :: Name
typeName _ _ _ = InterfaceType m
interfaceType
        in Name -> Maybe Name
forall a. a -> Maybe a
Just Name
typeName
compositeTypeName (Out.UnionBaseType (Out.UnionType typeName :: Name
typeName _ _)) =
    Name -> Maybe Name
forall a. a -> Maybe a
Just Name
typeName
compositeTypeName (Out.ScalarBaseType _) =
    Maybe Name
forall a. Maybe a
Nothing
compositeTypeName (Out.EnumBaseType _) =
    Maybe Name
forall a. Maybe a
Nothing
compositeTypeName (Out.ListBaseType wrappedType :: Type m
wrappedType) =
    Type m -> Maybe Name
forall (m :: * -> *). Type m -> Maybe Name
compositeTypeName Type m
wrappedType

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

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

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

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

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

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

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

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