graphql 0.11.0.0 → 0.11.1.0

raw patch · 15 files changed

+1779/−785 lines, 15 filesdep ~QuickCheckdep ~aesondep ~conduitPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: QuickCheck, aeson, conduit, hspec, hspec-megaparsec, megaparsec, text, unordered-containers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +14/−0
• README.md +3/−22
• graphql.cabal +17/−16
• src/Language/GraphQL/AST/Document.hs +74/−6
• src/Language/GraphQL/AST/Encoder.hs +5/−20
• src/Language/GraphQL/Type/Definition.hs +7/−0
• src/Language/GraphQL/Type/In.hs +14/−0
• src/Language/GraphQL/Type/Internal.hs +32/−11
• src/Language/GraphQL/Type/Out.hs +24/−0
• src/Language/GraphQL/Type/Schema.hs +21/−1
• src/Language/GraphQL/Validate.hs +1/−1
• src/Language/GraphQL/Validate/Rules.hs +633/−43
• tests/Language/GraphQL/AST/DocumentSpec.hs +20/−0
• tests/Language/GraphQL/Validate/RulesSpec.hs +914/−0
• tests/Language/GraphQL/ValidateSpec.hs +0/−665

@@ -6,6 +6,19 @@ and this project adheres to [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## [0.11.1.0] - 2021-02-07+### Added+- `Validate.Rules`:+  - `overlappingFieldsCanBeMergedRule`+  - `possibleFragmentSpreadsRule`+  - `variablesInAllowedPositionRule`+  - `valuesOfCorrectTypeRule`+- `Type.Schema.implementations` contains a map from interfaces and objects to+  interfaces they implement.+- Show instances for GraphQL type definitions in the `Type` modules.+- Custom Show instances for type and value representations in the AST.+- `AST.Document.escape` escapes a single character in a `StringValue`.+ ## [0.11.0.0] - 2020-11-07 ### Changed - `AST.Document.Selection` wraps additional new types: `Field`, `FragmentSpread`@@ -400,6 +413,7 @@ ### Added - Data types for the GraphQL language. +[0.11.1.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.11.1.0&rev_to=v0.11.0.0 [0.11.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.11.0.0&rev_to=v0.10.0.0 [0.10.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.10.0.0&rev_to=v0.9.0.0 [0.9.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v0.9.0.0&rev_to=v0.8.0.0

@@ -3,29 +3,10 @@ [![Simple Haskell](https://www.simplehaskell.org/badges/badge.svg)](https://www.simplehaskell.org) [![CI/CD](https://img.shields.io/badge/CI-CD-brightgreen)](https://build.caraus.tech/go/pipelines) -This implementation is relatively low-level by design, it doesn't provide any-mappings between the GraphQL types and Haskell's type system and avoids-compile-time magic. It focuses on flexibility instead, so other solutions can-be built on top of it.--## State of the work--For now this library provides:--- Parser for the query and schema languages, as well as a printer for the query-  language (minimizer and pretty-printer).-- Data structures to define a type system.-- Executor (queries, mutations and subscriptions are supported).-- Validation is work in progress.-- Introspection isn't available yet.--But the idea is to be a Haskell port of-[`graphql-js`](https://github.com/graphql/graphql-js).--For a more precise list of currently missing features see-[issues](https://www.caraus.tech/projects/pub-graphql/issues).+See https://www.caraus.tech/projects/pub-graphql. -## Documentation+Report issues on the+[bug tracker](https://www.caraus.tech/projects/pub-graphql/issues).  API documentation is available through [Hackage](https://hackage.haskell.org/package/graphql).

@@ -1,10 +1,10 @@ cabal-version:      2.2 name:               graphql-version:            0.11.0.0+version:            0.11.1.0 license:            MPL-2.0 AND BSD-3-Clause license-file:       LICENSE LICENSE.MPL copyright:-    (c) 2019-2020 Eugen Wissner,+    (c) 2019-2021 Eugen Wissner,     (c) 2015-2017 J. Daniel Navarro  maintainer:         belka@caraus.de@@ -60,24 +60,25 @@      default-language: Haskell2010     build-depends:-        aeson >=1.4.7.1,+        aeson >=1.5.5.1,         base >=4.7 && <5,-        conduit >=1.3.3,+        conduit >=1.3.4,         containers >=0.6.2.1,         exceptions >=0.10.4,         hspec-expectations >=0.8.2,-        megaparsec >=8.0.0,+        megaparsec >=9.0.1,         parser-combinators >=1.2.1,         scientific >=0.3.6.2,-        text >=1.2.4.0,+        text >=1.2.4.1,         transformers >=0.5.6.2,-        unordered-containers >=0.2.10.0+        unordered-containers >=0.2.13.0  test-suite graphql-test     type:             exitcode-stdio-1.0     main-is:          Spec.hs     hs-source-dirs:   tests     other-modules:+        Language.GraphQL.AST.DocumentSpec         Language.GraphQL.AST.EncoderSpec         Language.GraphQL.AST.LexerSpec         Language.GraphQL.AST.ParserSpec@@ -85,7 +86,7 @@         Language.GraphQL.Execute.CoerceSpec         Language.GraphQL.ExecuteSpec         Language.GraphQL.Type.OutSpec-        Language.GraphQL.ValidateSpec+        Language.GraphQL.Validate.RulesSpec         Test.DirectiveSpec         Test.FragmentSpec         Test.RootOperationSpec@@ -95,20 +96,20 @@     default-language: Haskell2010     ghc-options:      -threaded -rtsopts -with-rtsopts=-N     build-depends:-        QuickCheck >=2.13.2,-        aeson >=1.4.7.1,+        QuickCheck >=2.14.2,+        aeson >=1.5.5.1,         base >=4.7 && <5,-        conduit >=1.3.3,+        conduit >=1.3.4,         containers >=0.6.2.1,         exceptions >=0.10.4,         graphql -any,-        hspec >=2.7.4,+        hspec >=2.7.8,         hspec-expectations >=0.8.2,-        hspec-megaparsec >=2.1.0,-        megaparsec >=8.0.0,+        hspec-megaparsec >=2.2.0,+        megaparsec >=9.0.1,         parser-combinators >=1.2.1,         raw-strings-qq >=1.1,         scientific >=0.3.6.2,-        text >=1.2.4.0,+        text >=1.2.4.1,         transformers >=0.5.6.2,-        unordered-containers >=0.2.10.0+        unordered-containers >=0.2.13.0

@@ -1,5 +1,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE Safe #-}@@ -47,11 +48,15 @@     , UnionMemberTypes(..)     , Value(..)     , VariableDefinition(..)+    , escape     ) where +import Data.Char (ord) import Data.Foldable (toList) import Data.Int (Int32)+import Data.List (intercalate) import Data.List.NonEmpty (NonEmpty)+import Numeric (showFloat, showHex) import Data.Text (Text) import qualified Data.Text as Text import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation)@@ -79,8 +84,11 @@ data Node a = Node     { node :: a     , location :: Location-    } deriving (Eq, Show)+    } deriving Eq +instance Show a => Show (Node a) where+    show Node{ node } = show node+ instance Functor Node where     fmap f Node{..} = Node (f node) location @@ -218,6 +226,28 @@  -- ** Input Values +escape :: Char -> String+escape char'+    | char' == '\\' = "\\\\"+    | char' == '\"' = "\\\""+    | char' == '\b' = "\\b"+    | char' == '\f' = "\\f"+    | char' == '\n' = "\\n"+    | char' == '\r' = "\\r"+    | char' == '\t' = "\\t"+    | char' < '\x0010' = unicode  "\\u000" char'+    | char' < '\x0020' = unicode "\\u00" char'+    | otherwise = [char']+  where+    unicode prefix uchar = prefix <> (showHex $ ord uchar) ""++showList' :: Show a => [a] -> String+showList' list = "[" ++ intercalate ", " (show <$> list) ++ "]"++showObject :: Show a => [ObjectField a] -> String+showObject fields =+    "{ " ++ intercalate ", " (show <$> fields) ++ " }"+ -- | Input value (literal or variable). data Value     = Variable Name@@ -229,8 +259,20 @@     | Enum Name     | List [Value]     | Object [ObjectField Value]-    deriving (Eq, Show)+    deriving Eq +instance Show Value where+    showList = mappend . showList'+    show (Variable variableName) = '$' : Text.unpack variableName+    show (Int integer) = show integer+    show (Float float) = show $ ConstFloat float+    show (String text) = show $  ConstString text+    show (Boolean boolean) = show boolean+    show Null = "null"+    show (Enum name) = Text.unpack name+    show (List list) = show list+    show (Object fields) = showObject fields+ -- | Constant input value. data ConstValue     = ConstInt Int32@@ -241,8 +283,19 @@     | ConstEnum Name     | ConstList [ConstValue]     | ConstObject [ObjectField ConstValue]-    deriving (Eq, Show)+    deriving Eq +instance Show ConstValue where+    showList = mappend . showList'+    show (ConstInt integer) = show integer+    show (ConstFloat float) = showFloat float mempty+    show (ConstString text) = "\"" <> Text.foldr (mappend . escape) "\"" text+    show (ConstBoolean boolean) = show boolean+    show ConstNull = "null"+    show (ConstEnum name) = Text.unpack name+    show (ConstList list) = show list+    show (ConstObject fields) = showObject fields+ -- | Key-value pair. -- -- A list of 'ObjectField's represents a GraphQL object type.@@ -250,8 +303,14 @@     { name :: Name     , value :: Node a     , location :: Location-    } deriving (Eq, Show)+    } deriving Eq +instance Show a => Show (ObjectField a) where+    show ObjectField{..} = Text.unpack name ++ ": " ++ show value++instance Functor ObjectField where+    fmap f ObjectField{..} = ObjectField name (f <$> value) location+ -- ** Variables  -- | Variable definition.@@ -281,8 +340,13 @@     = TypeNamed Name     | TypeList Type     | TypeNonNull NonNullType-    deriving (Eq, Show)+    deriving Eq +instance Show Type where+    show (TypeNamed typeName) = Text.unpack typeName+    show (TypeList listType) = concat ["[", show listType, "]"]+    show (TypeNonNull nonNullType) = show nonNullType+ -- | Represents type names. type NamedType = Name @@ -290,7 +354,11 @@ data NonNullType     = NonNullTypeNamed Name     | NonNullTypeList Type-    deriving (Eq, Show)+    deriving Eq++instance Show NonNullType where+    show (NonNullTypeNamed typeName) = '!' : Text.unpack typeName+    show (NonNullTypeList listType) =  concat ["![", show listType, "]"]  -- ** Directives 

@@ -16,7 +16,6 @@     , value     ) where -import Data.Char (ord) import Data.Foldable (fold) import qualified Data.List.NonEmpty as NonEmpty import Data.Text (Text)@@ -25,7 +24,7 @@ import qualified Data.Text.Lazy as Lazy.Text import Data.Text.Lazy.Builder (Builder) import qualified Data.Text.Lazy.Builder as Builder-import Data.Text.Lazy.Builder.Int (decimal, hexadecimal)+import Data.Text.Lazy.Builder.Int (decimal) import Data.Text.Lazy.Builder.RealFloat (realFloat) import qualified Language.GraphQL.AST.Document as Full @@ -234,11 +233,12 @@ quote = Builder.singleton '\"'  oneLine :: Text -> Builder-oneLine string = quote <> Text.foldr (mappend . escape) quote string+oneLine string = quote <> Text.foldr merge quote string+  where+    merge = mappend . Builder.fromString . Full.escape  stringValue :: Formatter -> Text -> Lazy.Text-stringValue Minified string = Builder.toLazyText-    $ quote <> Text.foldr (mappend . escape) quote string+stringValue Minified string = Builder.toLazyText $ oneLine string stringValue (Pretty indentation) string =   if hasEscaped string   then stringValue Minified string@@ -265,21 +265,6 @@       transformLine line' acc             = Builder.fromLazyText (indent (indentation + 1))             <> line' <> newline <> acc--escape :: Char -> Builder-escape char'-    | char' == '\\' = Builder.fromString "\\\\"-    | char' == '\"' = Builder.fromString "\\\""-    | char' == '\b' = Builder.fromString "\\b"-    | char' == '\f' = Builder.fromString "\\f"-    | char' == '\n' = Builder.fromString "\\n"-    | char' == '\r' = Builder.fromString "\\r"-    | char' == '\t' = Builder.fromString "\\t"-    | char' < '\x0010' = unicode  "\\u000" char'-    | char' < '\x0020' = unicode "\\u00" char'-    | otherwise = Builder.singleton char'-  where-    unicode prefix = mappend (Builder.fromString prefix) . (hexadecimal . ord)  listValue :: Formatter -> [Full.Value] -> Lazy.Text listValue formatter = bracketsCommas formatter $ value formatter

@@ -22,6 +22,7 @@ import qualified Data.HashMap.Strict as HashMap import Data.String (IsString(..)) import Data.Text (Text)+import qualified Data.Text as Text import Language.GraphQL.AST (Name) import Prelude hiding (id) @@ -63,6 +64,9 @@ instance Eq ScalarType where     (ScalarType this _) == (ScalarType that _) = this == that +instance Show ScalarType where+    show (ScalarType typeName _) = Text.unpack typeName+ -- | Enum type definition. -- -- Some leaf values of requests and input values are Enums. GraphQL serializes@@ -72,6 +76,9 @@  instance Eq EnumType where     (EnumType this _ _) == (EnumType that _ _) = this == that++instance Show EnumType where+    show (EnumType typeName _ _) = Text.unpack typeName  -- | Enum value is a single member of an 'EnumType'. newtype EnumValue = EnumValue (Maybe Text)

@@ -24,6 +24,7 @@  import Data.HashMap.Strict (HashMap) import Data.Text (Text)+import qualified Data.Text as Text import Language.GraphQL.AST.Document (Name) import qualified Language.GraphQL.Type.Definition as Definition @@ -40,6 +41,9 @@ instance Eq InputObjectType where     (InputObjectType this _ _) == (InputObjectType that _ _) = this == that +instance Show InputObjectType where+    show (InputObjectType typeName _ _) = Text.unpack typeName+ -- | These types may be used as input types for arguments and directives. -- -- GraphQL distinguishes between "wrapping" and "named" types. Each wrapping@@ -55,6 +59,16 @@     | NonNullInputObjectType InputObjectType     | NonNullListType Type     deriving Eq++instance Show Type where+    show (NamedScalarType scalarType) = show scalarType+    show (NamedEnumType enumType) = show enumType+    show (NamedInputObjectType inputObjectType) = show inputObjectType+    show (ListType baseType) = concat ["[", show baseType, "]"]+    show (NonNullScalarType scalarType) = '!' : show scalarType+    show (NonNullEnumType enumType) = '!' : show enumType+    show (NonNullInputObjectType inputObjectType) = '!' : show inputObjectType+    show (NonNullListType baseType) = concat ["![", show baseType, "]"]  -- | Field argument definition. data Argument = Argument (Maybe Text) Type (Maybe Definition.Value)

@@ -14,11 +14,14 @@     , Type(..)     , directives     , doesFragmentTypeApply+    , implementations     , instanceOf+    , lookupCompositeField     , lookupInputType     , lookupTypeCondition     , lookupTypeField     , mutation+    , outToComposite     , subscription     , query     , types@@ -62,27 +65,32 @@     (Maybe (Out.ObjectType m))     Directives     (HashMap Full.Name (Type m))+    (HashMap Full.Name [Type m])  -- | Schema query type. query :: forall m. Schema m -> Out.ObjectType m-query (Schema query' _ _ _ _) = query'+query (Schema query' _ _ _ _ _) = query'  -- | Schema mutation type. mutation :: forall m. Schema m -> Maybe (Out.ObjectType m)-mutation (Schema _ mutation' _ _ _) = mutation'+mutation (Schema _ mutation' _ _ _ _) = mutation'  -- | Schema subscription type. subscription :: forall m. Schema m -> Maybe (Out.ObjectType m)-subscription (Schema _ _ subscription' _ _) = subscription'+subscription (Schema _ _ subscription' _ _ _) = subscription'  -- | Schema directive definitions. directives :: forall m. Schema m -> Directives-directives (Schema _ _ _ directives' _) = directives'+directives (Schema _ _ _ directives' _ _) = directives'  -- | Types referenced by the schema. types :: forall m. Schema m -> HashMap Full.Name (Type m)-types (Schema _ _ _ _ types') = types'+types (Schema _ _ _ _ types' _) = types' +-- | Interface implementations.+implementations :: forall m. Schema m -> HashMap Full.Name [Type m]+implementations (Schema _ _ _ _ _ implementations') = implementations'+ -- | These types may describe the parent context of a selection set. data CompositeType m     = CompositeUnionType (Out.UnionType m)@@ -160,12 +168,16 @@     <$> lookupInputType nonNull types'  lookupTypeField :: forall a. Full.Name -> Out.Type a -> Maybe (Out.Field a)-lookupTypeField fieldName = \case-    Out.ObjectBaseType objectType ->-        objectChild objectType-    Out.InterfaceBaseType interfaceType ->-        interfaceChild interfaceType-    Out.ListBaseType listType -> lookupTypeField fieldName listType+lookupTypeField fieldName outputType =+    outToComposite outputType >>= lookupCompositeField fieldName++lookupCompositeField :: forall a+    . Full.Name+    -> CompositeType a+    -> Maybe (Out.Field a)+lookupCompositeField fieldName = \case+    CompositeObjectType objectType -> objectChild objectType+    CompositeInterfaceType interfaceType -> interfaceChild interfaceType     _ -> Nothing   where     objectChild (Out.ObjectType _ _ _ resolvers) =@@ -174,3 +186,12 @@         HashMap.lookup fieldName fields     resolverType (Out.ValueResolver objectField _) = objectField     resolverType (Out.EventStreamResolver objectField _ _) = objectField++outToComposite :: forall a. Out.Type a -> Maybe (CompositeType a)+outToComposite = \case+    Out.ObjectBaseType objectType -> Just $ CompositeObjectType objectType+    Out.InterfaceBaseType interfaceType ->+        Just $ CompositeInterfaceType interfaceType+    Out.UnionBaseType unionType -> Just $ CompositeUnionType unionType+    Out.ListBaseType listType -> outToComposite listType+    _ -> Nothing

@@ -38,6 +38,7 @@ import qualified Data.HashMap.Strict as HashMap import Data.Maybe (fromMaybe) import Data.Text (Text)+import qualified Data.Text as Text import Language.GraphQL.AST (Name) import Language.GraphQL.Type.Definition import qualified Language.GraphQL.Type.In as In@@ -52,6 +53,9 @@ instance forall a. Eq (ObjectType a) where     (ObjectType this _ _ _) == (ObjectType that _ _ _) = this == that +instance forall a. Show (ObjectType a) where+    show (ObjectType typeName _ _ _) = Text.unpack typeName+ -- | Interface Type Definition. -- -- When a field can return one of a heterogeneous set of types, a Interface type@@ -63,6 +67,9 @@ instance forall a. Eq (InterfaceType a) where     (InterfaceType this _ _ _) == (InterfaceType that _ _ _) = this == that +instance forall a. Show (InterfaceType a) where+    show (InterfaceType typeName _ _ _) = Text.unpack typeName+ -- | Union Type Definition. -- -- When a field can return one of a heterogeneous set of types, a Union type is@@ -72,6 +79,9 @@ instance forall a. Eq (UnionType a) where     (UnionType this _ _) == (UnionType that _ _) = this == that +instance forall a. Show (UnionType a) where+    show (UnionType typeName _ _) = Text.unpack typeName+ -- | Output object field definition. data Field m = Field     (Maybe Text) -- ^ Description.@@ -97,6 +107,20 @@     | NonNullUnionType (UnionType m)     | NonNullListType (Type m)     deriving Eq++instance forall a. Show (Type a) where+    show (NamedScalarType scalarType) = show scalarType+    show (NamedEnumType enumType) = show enumType+    show (NamedObjectType inputObjectType) = show inputObjectType+    show (NamedInterfaceType interfaceType) = show interfaceType+    show (NamedUnionType unionType) = show unionType+    show (ListType baseType) = concat ["[", show baseType, "]"]+    show (NonNullScalarType scalarType) = '!' : show scalarType+    show (NonNullEnumType enumType) = '!' : show enumType+    show (NonNullObjectType inputObjectType) = '!' : show inputObjectType+    show (NonNullInterfaceType interfaceType) = '!' : show interfaceType+    show (NonNullUnionType unionType) = '!' : show unionType+    show (NonNullListType baseType) = concat ["![", show baseType, "]"]  -- | Matches either 'NamedScalarType' or 'NonNullScalarType'. pattern ScalarBaseType :: forall m. ScalarType -> Type m

@@ -23,6 +23,7 @@     , Schema     , Type(..)     , directives+    , implementations     , mutation     , subscription     , query@@ -41,9 +42,11 @@     -> Directives -- ^ Directive definitions.     -> Schema m -- ^ Schema. schema queryRoot mutationRoot subscriptionRoot directiveDefinitions =-    Internal.Schema queryRoot mutationRoot subscriptionRoot allDirectives collectedTypes+    Internal.Schema queryRoot mutationRoot subscriptionRoot+        allDirectives collectedTypes collectedImplementations   where     collectedTypes = collectReferencedTypes queryRoot mutationRoot subscriptionRoot+    collectedImplementations = collectImplementations collectedTypes     allDirectives = HashMap.union directiveDefinitions defaultDirectives     defaultDirectives = HashMap.fromList         [ ("skip", skipDirective)@@ -153,3 +156,20 @@     polymorphicTraverser interfaces fields         = flip (foldr visitFields) fields         . flip (foldr traverseInterfaceType) interfaces++-- | Looks for objects and interfaces under the schema types and collects the+-- interfaces they implement.+collectImplementations :: forall m+    . HashMap Full.Name (Type m)+    -> HashMap Full.Name [Type m]+collectImplementations = HashMap.foldr go HashMap.empty+  where+    go implementation@(InterfaceType interfaceType) accumulator =+        let Out.InterfaceType _ _ interfaces _ = interfaceType+         in foldr (add implementation) accumulator interfaces+    go implementation@(ObjectType objectType) accumulator =+        let Out.ObjectType _ _ interfaces _ = objectType+         in foldr (add implementation) accumulator interfaces+    go _ accumulator = accumulator+    add implementation (Out.InterfaceType typeName _ _ _) accumulator =+        HashMap.insertWith (++) typeName [implementation] accumulator

@@ -210,7 +210,7 @@         directives context rule scalarLocation directives'     Full.ObjectTypeDefinition _ _ _ directives' fields         -> directives context rule objectLocation directives'-         >< foldMap (fieldDefinition context rule) fields+        >< foldMap (fieldDefinition context rule) fields     Full.InterfaceTypeDefinition _ _ directives' fields         -> directives context rule interfaceLocation directives'         >< foldMap (fieldDefinition context rule) fields

@@ -3,6 +3,7 @@    obtain one at https://mozilla.org/MPL/2.0/. -}  {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -24,6 +25,8 @@     , noUndefinedVariablesRule     , noUnusedFragmentsRule     , noUnusedVariablesRule+    , overlappingFieldsCanBeMergedRule+    , possibleFragmentSpreadsRule     , providedRequiredInputFieldsRule     , providedRequiredArgumentsRule     , scalarLeafsRule@@ -35,22 +38,24 @@     , uniqueInputFieldNamesRule     , uniqueOperationNamesRule     , uniqueVariableNamesRule+    , valuesOfCorrectTypeRule+    , variablesInAllowedPositionRule     , variablesAreInputTypesRule     ) where  import Control.Monad ((>=>), foldM) import Control.Monad.Trans.Class (MonadTrans(..))-import Control.Monad.Trans.Reader (ReaderT(..), asks, mapReaderT)+import Control.Monad.Trans.Reader (ReaderT(..), ask, asks, mapReaderT) import Control.Monad.Trans.State (StateT, evalStateT, gets, modify) import Data.Bifunctor (first)-import Data.Foldable (find, toList)+import Data.Foldable (find, fold, foldl', toList) import qualified Data.HashMap.Strict as HashMap import Data.HashMap.Strict (HashMap) import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet import Data.List (groupBy, sortBy, sortOn)-import Data.Maybe (isNothing, mapMaybe)-import Data.List.NonEmpty (NonEmpty)+import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, mapMaybe)+import Data.List.NonEmpty (NonEmpty(..)) import Data.Ord (comparing) import Data.Sequence (Seq(..), (|>)) import qualified Data.Sequence as Seq@@ -80,6 +85,7 @@     -- Fields     , fieldsOnCorrectTypeRule     , scalarLeafsRule+    , overlappingFieldsCanBeMergedRule     -- Arguments.     , knownArgumentNamesRule     , uniqueArgumentNamesRule@@ -91,7 +97,9 @@     , noUnusedFragmentsRule     , fragmentSpreadTargetDefinedRule     , noFragmentCyclesRule+    , possibleFragmentSpreadsRule     -- Values+    , valuesOfCorrectTypeRule     , knownInputFieldNamesRule     , uniqueInputFieldNamesRule     , providedRequiredInputFieldsRule@@ -104,6 +112,7 @@     , variablesAreInputTypesRule     , noUndefinedVariablesRule     , noUnusedVariablesRule+    , variablesInAllowedPositionRule     ]  -- | Definition must be OperationDefinition or FragmentDefinition.@@ -320,10 +329,8 @@ fragmentSpreadTypeExistenceRule = SelectionRule $ const $ \case     Full.FragmentSpreadSelection fragmentSelection         | Full.FragmentSpread fragmentName _ location' <- fragmentSelection -> do-            ast' <- asks ast-            let target = find (isSpreadTarget fragmentName) ast'-            typeCondition <- lift $ maybeToSeq $ target >>= extractTypeCondition             types' <- asks $ Schema.types . schema+            typeCondition <- findSpreadTarget fragmentName             case HashMap.lookup typeCondition types' of                 Nothing -> pure $ Error                     { message = spreadError fragmentName typeCondition@@ -342,10 +349,6 @@                 Just _ -> lift mempty     _ -> lift mempty   where-    extractTypeCondition (viewFragment -> Just fragmentDefinition) =-        let Full.FragmentDefinition _ typeCondition _ _ _ = fragmentDefinition-         in Just typeCondition-    extractTypeCondition _ = Nothing     spreadError fragmentName typeCondition = concat         [ "Fragment \""         , Text.unpack fragmentName@@ -451,8 +454,7 @@ noFragmentCyclesRule :: forall m. Rule m noFragmentCyclesRule = FragmentDefinitionRule $ \case     Full.FragmentDefinition fragmentName _ _ selections location' -> do-        state <- evalStateT (collectFields selections)-            (0, fragmentName)+        state <- evalStateT (collectCycles selections) (0, fragmentName)         let spreadPath = fst <$> sortBy (comparing snd) (HashMap.toList state)         case reverse spreadPath of             x : _ | x == fragmentName -> pure $ Error@@ -467,10 +469,10 @@                 }             _ -> lift mempty   where-    collectFields :: Traversable t+    collectCycles :: Traversable t         => t Full.Selection         -> StateT (Int, Full.Name) (ReaderT (Validation m) Seq) (HashMap Full.Name Int)-    collectFields selectionSet = foldM forEach HashMap.empty selectionSet+    collectCycles selectionSet = foldM forEach HashMap.empty selectionSet     forEach accumulator = \case         Full.FieldSelection fieldSelection -> forField accumulator fieldSelection         Full.InlineFragmentSelection fragmentSelection ->@@ -487,15 +489,15 @@             then pure newAccumulator             else collectFromSpread fragmentName newAccumulator     forInline accumulator (Full.InlineFragment _ _ selections _) =-        (accumulator <>) <$> collectFields selections+        (accumulator <>) <$> collectCycles selections     forField accumulator (Full.Field _ _ _ _ selections _) =-        (accumulator <>) <$> collectFields selections+        (accumulator <>) <$> collectCycles selections     collectFromSpread fragmentName accumulator = do         ast' <- lift $ asks ast         case findFragmentDefinition fragmentName ast' of             Nothing -> pure accumulator             Just (Full.FragmentDefinition _ _ _ selections _) ->-                (accumulator <>) <$> collectFields selections+                (accumulator <>) <$> collectCycles selections  findFragmentDefinition :: Text     -> NonEmpty Full.Definition@@ -531,15 +533,22 @@     extract (Full.Directive directiveName _ location') =         (directiveName, location') -filterDuplicates :: (a -> (Text, Full.Location)) -> String -> [a] -> Seq Error+groupSorted :: forall a. (a -> Text) -> [a] -> [[a]]+groupSorted getName = groupBy equalByName . sortOn getName+  where+    equalByName lhs rhs = getName lhs == getName rhs++filterDuplicates :: forall a+    . (a -> (Text, Full.Location))+    -> String+    -> [a]+    -> Seq Error filterDuplicates extract nodeType = Seq.fromList     . fmap makeError     . filter ((> 1) . length)-    . groupBy equalByName-    . sortOn getName+    . groupSorted getName   where     getName = fst . extract-    equalByName lhs rhs = getName lhs == getName rhs     makeError directives' = Error         { message = makeMessage $ head directives'         , locations = snd . extract <$> directives'@@ -647,12 +656,9 @@             lift $ lift $ mapArguments arguments <> mapDirectives directives'     variableFilter (Full.FragmentSpreadSelection spread)         | Full.FragmentSpread fragmentName _ _ <- spread = do-            definitions <- lift $ asks ast-            visited <- gets (HashSet.member fragmentName)-            modify (HashSet.insert fragmentName)-            case find (isSpreadTarget fragmentName) definitions of-                Just (viewFragment -> Just fragmentDefinition)-                    | not visited -> diveIntoSpread fragmentDefinition+            nonVisitedFragmentDefinition <- visitFragmentDefinition fragmentName+            case nonVisitedFragmentDefinition of+                Just fragmentDefinition -> diveIntoSpread fragmentDefinition                 _ -> lift $ lift mempty     diveIntoSpread (Full.FragmentDefinition _ _ directives' selections _)         = filterSelections' selections@@ -710,7 +716,7 @@     fieldRule parentType (Full.Field _ fieldName _ _ _ location')         | Just objectType <- parentType         , Nothing <- Type.lookupTypeField fieldName objectType-        , Just typeName <- compositeTypeName objectType = pure $ Error+        , Just typeName <- typeNameIfComposite objectType = pure $ Error             { message = errorMessage fieldName typeName             , locations = [location']             }@@ -723,21 +729,18 @@         , "\"."         ] -compositeTypeName :: forall m. Out.Type m -> Maybe Full.Name-compositeTypeName (Out.ObjectBaseType (Out.ObjectType typeName _ _ _)) =-    Just typeName-compositeTypeName (Out.InterfaceBaseType interfaceType) =+compositeTypeName :: forall m. Type.CompositeType m -> Full.Name+compositeTypeName (Type.CompositeObjectType (Out.ObjectType typeName _ _ _)) =+    typeName+compositeTypeName (Type.CompositeInterfaceType interfaceType) =     let Out.InterfaceType typeName _ _ _ = interfaceType-        in Just typeName-compositeTypeName (Out.UnionBaseType (Out.UnionType typeName _ _)) =-    Just typeName-compositeTypeName (Out.ScalarBaseType _) =-    Nothing-compositeTypeName (Out.EnumBaseType _) =-    Nothing-compositeTypeName (Out.ListBaseType wrappedType) =-    compositeTypeName wrappedType+     in typeName+compositeTypeName (Type.CompositeUnionType (Out.UnionType typeName _ _)) =+    typeName +typeNameIfComposite :: forall m. Out.Type m -> Maybe Full.Name+typeNameIfComposite = fmap compositeTypeName . Type.outToComposite+ -- | Field selections on scalars or enums are never allowed, because they are -- the leaf nodes of any GraphQL query. scalarLeafsRule :: forall m. Rule m@@ -794,7 +797,7 @@   where     fieldRule (Just objectType) (Full.Field _ fieldName arguments  _ _ _)         | Just typeField <- Type.lookupTypeField fieldName objectType-        , Just typeName <- compositeTypeName objectType =+        , Just typeName <- typeNameIfComposite objectType =             lift $ foldr (go typeName fieldName typeField) Seq.empty arguments     fieldRule _ _ = lift mempty     go typeName fieldName fieldDefinition (Full.Argument argumentName _ location') errors@@ -1013,3 +1016,590 @@         , Text.unpack typeName         , "\" is required, but it was not provided."         ]++-- | If multiple field selections with the same response names are encountered+-- during execution, the field and arguments to execute and the resulting value+-- should be unambiguous. Therefore any two field selections which might both be+-- encountered for the same object are only valid if they are equivalent.+--+-- For simple hand‐written GraphQL, this rule is obviously a clear developer+-- error, however nested fragments can make this difficult to detect manually.+overlappingFieldsCanBeMergedRule :: Rule m+overlappingFieldsCanBeMergedRule = OperationDefinitionRule $ \case+    Full.SelectionSet selectionSet _ -> do+        schema' <- asks schema+        go (toList selectionSet)+            $ Type.CompositeObjectType+            $ Schema.query schema'+    Full.OperationDefinition operationType _ _ _ selectionSet _ -> do+        schema' <- asks schema+        let root = go (toList selectionSet) . Type.CompositeObjectType+        case operationType of+            Full.Query -> root $ Schema.query schema'+            Full.Mutation+                | Just objectType <- Schema.mutation schema' -> root objectType+            Full.Subscription+                | Just objectType <- Schema.mutation schema' -> root objectType+            _ -> lift mempty+  where+    go selectionSet selectionType = do+        fieldTuples <- evalStateT (collectFields selectionType selectionSet) HashSet.empty+        fieldsInSetCanMerge fieldTuples+    fieldsInSetCanMerge :: forall m+        . HashMap Full.Name (NonEmpty (Full.Field, Type.CompositeType m))+        -> ReaderT (Validation m) Seq Error+    fieldsInSetCanMerge fieldTuples = do+        validation <- ask+        let (lonely, paired) = flattenPairs fieldTuples+        let reader = flip runReaderT validation+        lift $ foldMap (reader . visitLonelyFields) lonely+            <> foldMap (reader . forEachFieldTuple) paired+    forEachFieldTuple :: forall m+        . (FieldInfo m, FieldInfo m)+        -> ReaderT (Validation m) Seq Error+    forEachFieldTuple (fieldA, fieldB) =+        case (parent fieldA, parent fieldB) of+            (parentA@Type.CompositeObjectType{}, parentB@Type.CompositeObjectType{})+                | parentA /= parentB -> sameResponseShape fieldA fieldB+            _ -> mapReaderT (checkEquality (node fieldA) (node fieldB))+                $ sameResponseShape fieldA fieldB+    checkEquality fieldA fieldB Seq.Empty+        | Full.Field _ fieldNameA _ _ _ _ <- fieldA+        , Full.Field _ fieldNameB _ _ _ _ <- fieldB+        , fieldNameA /= fieldNameB = pure $ makeError fieldA fieldB+        | Full.Field _ fieldNameA argumentsA _ _ locationA <- fieldA+        , Full.Field _ _ argumentsB _ _ locationB <- fieldB+        , argumentsA /= argumentsB =+            let message = concat+                    [ "Fields \""+                    , Text.unpack fieldNameA+                    , "\" conflict because they have different arguments. Use "+                    , "different aliases on the fields to fetch both if this "+                    , "was intentional."+                    ]+             in pure $ Error message [locationB, locationA]+    checkEquality _ _ previousErrors = previousErrors+    visitLonelyFields FieldInfo{..} =+        let Full.Field _ _ _ _ subSelections _ = node+            compositeFieldType = Type.outToComposite type'+         in maybe (lift Seq.empty) (go subSelections) compositeFieldType+    sameResponseShape :: forall m+        . FieldInfo m+        -> FieldInfo m+        -> ReaderT (Validation m) Seq Error+    sameResponseShape fieldA fieldB =+        let Full.Field _ _ _ _ selectionsA _ = node fieldA+            Full.Field _ _ _ _ selectionsB _ = node fieldB+         in case unwrapTypes (type' fieldA) (type' fieldB) of+            Left True -> lift mempty+            Right (compositeA, compositeB) -> do+                validation <- ask+                let collectFields' composite = flip runReaderT validation+                        . flip evalStateT HashSet.empty+                        . collectFields composite+                let collectA = collectFields' compositeA selectionsA+                let collectB = collectFields' compositeB selectionsB+                fieldsInSetCanMerge+                    $ foldl' (HashMap.unionWith (<>)) HashMap.empty+                    $ collectA <> collectB+            _ -> pure $ makeError (node fieldA) (node fieldB)+    makeError fieldA fieldB =+        let Full.Field aliasA fieldNameA _ _ _ locationA = fieldA+            Full.Field _ fieldNameB _ _ _ locationB = fieldB+            message = concat+                [ "Fields \""+                , Text.unpack (fromMaybe fieldNameA aliasA)+                , "\" conflict because \""+                , Text.unpack fieldNameB+                , "\" and \""+                , Text.unpack fieldNameA+                , "\" are different fields. Use different aliases on the fields "+                , "to fetch both if this was intentional."+                ]+             in Error message [locationB, locationA]+    unwrapTypes typeA@Out.ScalarBaseType{} typeB@Out.ScalarBaseType{} =+        Left $ typeA == typeB+    unwrapTypes typeA@Out.EnumBaseType{} typeB@Out.EnumBaseType{} =+        Left $ typeA == typeB+    unwrapTypes (Out.ListType listA) (Out.ListType listB) =+        unwrapTypes listA listB+    unwrapTypes (Out.NonNullListType listA) (Out.NonNullListType listB) =+        unwrapTypes listA listB+    unwrapTypes typeA typeB+        | Out.isNonNullType typeA == Out.isNonNullType typeB+        , Just compositeA <- Type.outToComposite typeA+        , Just compositeB <- Type.outToComposite typeB =+            Right (compositeA, compositeB)+        | otherwise = Left False+    flattenPairs :: forall m+        . HashMap Full.Name (NonEmpty (Full.Field, Type.CompositeType m))+        -> (Seq (FieldInfo m), Seq (FieldInfo m, FieldInfo m))+    flattenPairs xs = HashMap.foldr splitSingleFields (Seq.empty, Seq.empty)+        $ foldr lookupTypeField [] <$> xs+    splitSingleFields :: forall m+        . [FieldInfo m]+        -> (Seq (FieldInfo m), Seq (FieldInfo m, FieldInfo m))+        -> (Seq (FieldInfo m), Seq (FieldInfo m, FieldInfo m))+    splitSingleFields [head'] (fields, pairList) = (fields |> head', pairList)+    splitSingleFields xs (fields, pairList) = (fields, pairs pairList xs)+    lookupTypeField (field, parentType) accumulator =+        let Full.Field _ fieldName _ _ _ _ = field+         in case Type.lookupCompositeField fieldName parentType of+            Nothing -> accumulator+            Just (Out.Field _ typeField _) ->+                FieldInfo field typeField parentType : accumulator+    pairs :: forall m+        . Seq (FieldInfo m, FieldInfo m)+        -> [FieldInfo m]+        -> Seq (FieldInfo m, FieldInfo m)+    pairs accumulator [] = accumulator+    pairs accumulator (fieldA : fields) =+        pair fieldA (pairs accumulator fields) fields+    pair _ accumulator [] = accumulator+    pair field accumulator (fieldA : fields) =+        pair field accumulator fields |> (field, fieldA)+    collectFields objectType = accumulateFields objectType mempty+    accumulateFields = foldM . forEach+    forEach parentType accumulator = \case+        Full.FieldSelection fieldSelection ->+            forField parentType accumulator fieldSelection+        Full.FragmentSpreadSelection fragmentSelection ->+            forSpread accumulator fragmentSelection+        Full.InlineFragmentSelection fragmentSelection ->+            forInline parentType accumulator fragmentSelection+    forField parentType accumulator field@(Full.Field alias fieldName _ _ _ _) =+        let key = fromMaybe fieldName alias+            value = (field, parentType) :| []+         in pure $ HashMap.insertWith (<>) key value accumulator+    forSpread accumulator (Full.FragmentSpread fragmentName _ _) = do+        inVisitetFragments <- gets $ HashSet.member fragmentName+        if inVisitetFragments+            then pure accumulator+            else collectFromSpread fragmentName accumulator+    forInline parentType accumulator = \case+        Full.InlineFragment maybeType _ selections _+            | Just typeCondition <- maybeType ->+                collectFromFragment typeCondition selections accumulator+            | otherwise -> accumulateFields parentType accumulator $ toList selections+    collectFromFragment typeCondition selectionSet' accumulator = do+        types' <- lift $ asks $ Schema.types . schema+        case Type.lookupTypeCondition typeCondition types' of+            Nothing -> pure accumulator+            Just compositeType ->+                accumulateFields compositeType accumulator $ toList selectionSet'+    collectFromSpread fragmentName accumulator = do+        modify $ HashSet.insert fragmentName+        ast' <- lift $ asks ast+        case findFragmentDefinition fragmentName ast' of+            Nothing -> pure accumulator+            Just (Full.FragmentDefinition _ typeCondition _ selectionSet' _) ->+                collectFromFragment typeCondition selectionSet' accumulator++data FieldInfo m = FieldInfo+    { node :: Full.Field+    , type' :: Out.Type m+    , parent :: Type.CompositeType m+    }++-- | Fragments are declared on a type and will only apply when the runtime+-- object type matches the type condition. They also are spread within the+-- context of a parent type. A fragment spread is only valid if its type+-- condition could ever apply within the parent type.+possibleFragmentSpreadsRule :: forall m. Rule m+possibleFragmentSpreadsRule = SelectionRule go+  where+    go (Just parentType) (Full.InlineFragmentSelection fragmentSelection)+        | Full.InlineFragment maybeType _ _ location' <- fragmentSelection+        , Just typeCondition <- maybeType = do+            (fragmentTypeName, parentTypeName) <-+                compareTypes typeCondition parentType+            pure $ Error+                { message = concat+                    [ "Fragment cannot be spread here as objects of type \""+                    , Text.unpack parentTypeName+                    , "\" can never be of type \""+                    , Text.unpack fragmentTypeName+                    , "\"."+                    ]+                , locations = [location']+                }+    go (Just parentType) (Full.FragmentSpreadSelection fragmentSelection)+        | Full.FragmentSpread fragmentName _ location' <- fragmentSelection = do+            typeCondition <- findSpreadTarget fragmentName+            (fragmentTypeName, parentTypeName) <-+                compareTypes typeCondition parentType+            pure $ Error+                { message = concat+                    [ "Fragment \""+                    , Text.unpack fragmentName+                    , "\" cannot be spread here as objects of type \""+                    , Text.unpack parentTypeName+                    , "\" can never be of type \""+                    , Text.unpack fragmentTypeName+                    , "\"."+                    ]+                , locations = [location']+                }+    go _ _ = lift mempty+    compareTypes typeCondition parentType = do+        types' <- asks $ Schema.types . schema+        fragmentType <- lift+            $ maybeToSeq+            $ Type.lookupTypeCondition typeCondition types'+        parentComposite <- lift+            $ maybeToSeq+            $ Type.outToComposite parentType+        possibleFragments <- getPossibleTypes fragmentType+        possibleParents <- getPossibleTypes parentComposite+        let fragmentTypeName = compositeTypeName fragmentType+        let parentTypeName = compositeTypeName parentComposite+        if HashSet.null $ HashSet.intersection possibleFragments possibleParents+            then pure (fragmentTypeName, parentTypeName)+            else lift mempty+    getPossibleTypeList (Type.CompositeObjectType objectType) =+        pure [Schema.ObjectType objectType]+    getPossibleTypeList (Type.CompositeUnionType unionType) =+        let Out.UnionType _ _ members = unionType+         in pure $ Schema.ObjectType <$> members+    getPossibleTypeList (Type.CompositeInterfaceType interfaceType) =+        let Out.InterfaceType typeName _ _ _ = interfaceType+         in HashMap.lookupDefault [] typeName+        <$> asks (Schema.implementations . schema)+    getPossibleTypes compositeType+        = foldr (HashSet.insert . internalTypeName) HashSet.empty+        <$> getPossibleTypeList compositeType++internalTypeName :: forall m. Schema.Type m -> Full.Name+internalTypeName (Schema.ScalarType (Definition.ScalarType typeName _)) =+    typeName+internalTypeName (Schema.EnumType (Definition.EnumType typeName _ _)) = typeName+internalTypeName (Schema.ObjectType (Out.ObjectType typeName _ _ _)) = typeName+internalTypeName (Schema.InputObjectType (In.InputObjectType typeName _ _)) =+    typeName+internalTypeName (Schema.InterfaceType (Out.InterfaceType typeName _ _ _)) =+    typeName+internalTypeName (Schema.UnionType (Out.UnionType typeName _ _)) = typeName++findSpreadTarget :: Full.Name -> ReaderT (Validation m1) Seq Full.TypeCondition+findSpreadTarget fragmentName = do+    ast' <- asks ast+    let target = find (isSpreadTarget fragmentName) ast'+    lift $ maybeToSeq $ target >>= extractTypeCondition+  where+    extractTypeCondition (viewFragment -> Just fragmentDefinition) =+        let Full.FragmentDefinition _ typeCondition _ _ _ = fragmentDefinition+            in Just typeCondition+    extractTypeCondition _ = Nothing++visitFragmentDefinition :: forall m+    . Text+    -> ValidationState m (Maybe Full.FragmentDefinition)+visitFragmentDefinition fragmentName = do+    definitions <- lift $ asks ast+    visited <- gets (HashSet.member fragmentName)+    modify (HashSet.insert fragmentName)+    case find (isSpreadTarget fragmentName) definitions of+        Just (viewFragment -> Just fragmentDefinition)+            | not visited -> pure $ Just fragmentDefinition+        _ -> pure Nothing++-- | Variable usages must be compatible with the arguments they are passed to.+--+-- Validation failures occur when variables are used in the context of types+-- that are complete mismatches, or if a nullable type in a variable is passed+-- to a non‐null argument type.+variablesInAllowedPositionRule :: forall m. Rule m+variablesInAllowedPositionRule = OperationDefinitionRule $ \case+    Full.OperationDefinition operationType _ variables _ selectionSet _ -> do+        schema' <- asks schema+        let root = go variables (toList selectionSet) . Type.CompositeObjectType+        case operationType of+            Full.Query -> root $ Schema.query schema'+            Full.Mutation+                | Just objectType <- Schema.mutation schema' -> root objectType+            Full.Subscription+                | Just objectType <- Schema.mutation schema' -> root objectType+            _ -> lift mempty+    _ -> lift mempty+  where+    go variables selections selectionType = mapReaderT (foldr (<>) Seq.empty)+        $ flip evalStateT HashSet.empty+        $ visitSelectionSet variables selectionType+        $ toList selections+    visitSelectionSet :: Foldable t+        => [Full.VariableDefinition]+        -> Type.CompositeType m+        -> t Full.Selection+        -> ValidationState m (Seq Error)+    visitSelectionSet variables selectionType selections =+        foldM (evaluateSelection variables selectionType) mempty selections+    evaluateFieldSelection variables selections accumulator = \case+        Just newParentType -> do+            let folder = evaluateSelection variables newParentType+            selectionErrors <- foldM folder accumulator selections+            pure $ accumulator <> selectionErrors+        Nothing -> pure accumulator+    evaluateSelection :: [Full.VariableDefinition]+        -> Type.CompositeType m+        -> Seq Error+        -> Full.Selection+        -> ValidationState m (Seq Error)+    evaluateSelection variables selectionType accumulator selection+        | Full.FragmentSpreadSelection spread <- selection+        , Full.FragmentSpread fragmentName _ _ <- spread = do+            types' <- lift $ asks $ Schema.types . schema+            nonVisitedFragmentDefinition <- visitFragmentDefinition fragmentName+            case nonVisitedFragmentDefinition of+                Just fragmentDefinition+                    | Full.FragmentDefinition _ typeCondition _ _ _ <- fragmentDefinition+                    , Just spreadType <- Type.lookupTypeCondition typeCondition types' -> do+                        spreadErrors <- spreadVariables variables spread+                        selectionErrors <- diveIntoSpread variables spreadType fragmentDefinition+                        pure $ accumulator <> spreadErrors <> selectionErrors+                _ -> lift $ lift mempty+        | Full.FieldSelection fieldSelection <- selection+        , Full.Field _ fieldName _ _ subselections _ <- fieldSelection =+            case Type.lookupCompositeField fieldName selectionType of+                Just (Out.Field _ typeField argumentTypes) -> do+                    fieldErrors <- fieldVariables variables argumentTypes fieldSelection+                    selectionErrors <- evaluateFieldSelection variables subselections accumulator+                            $ Type.outToComposite typeField+                    pure $ selectionErrors <> fieldErrors+                Nothing -> pure accumulator+        | Full.InlineFragmentSelection inlineSelection <- selection+        , Full.InlineFragment typeCondition _ subselections _ <- inlineSelection = do+            types' <- lift $ asks $ Schema.types . schema+            let inlineType = fromMaybe selectionType+                    $ typeCondition >>= flip Type.lookupTypeCondition types'+            fragmentErrors <- inlineVariables variables inlineSelection+            let folder = evaluateSelection variables inlineType+            selectionErrors <- foldM folder accumulator subselections+            pure $ accumulator <> fragmentErrors <> selectionErrors+    inlineVariables variables inline+        | Full.InlineFragment _ directives' _ _ <- inline =+            mapDirectives variables directives'+    fieldVariables :: [Full.VariableDefinition]+        -> In.Arguments+        -> Full.Field+        -> ValidationState m (Seq Error)+    fieldVariables variables argumentTypes fieldSelection = do+        let Full.Field _ _ arguments directives' _ _ = fieldSelection+        argumentErrors <- mapArguments variables argumentTypes arguments+        directiveErrors <- mapDirectives variables directives'+        pure $ argumentErrors <> directiveErrors+    spreadVariables variables (Full.FragmentSpread _ directives' _) =+        mapDirectives variables directives'+    diveIntoSpread variables fieldType fragmentDefinition = do+        let Full.FragmentDefinition _ _ directives' selections _ =+                fragmentDefinition+        selectionErrors <- visitSelectionSet variables fieldType selections+        directiveErrors <- mapDirectives variables directives'+        pure $ selectionErrors <> directiveErrors+    findDirectiveVariables variables directive = do+        let Full.Directive directiveName arguments _ = directive+        directiveDefinitions <- lift $ asks $ Schema.directives . schema+        case HashMap.lookup directiveName directiveDefinitions of+            Just (Schema.Directive _ _ directiveArguments) ->+                mapArguments variables directiveArguments arguments+            Nothing -> pure mempty+    mapArguments variables argumentTypes = fmap fold+        . traverse (findArgumentVariables variables argumentTypes)+    mapDirectives variables = fmap fold+        <$> traverse (findDirectiveVariables variables)+    lookupInputObject variables objectFieldValue locationInfo+        | Full.Node{ node = Full.Object objectFields } <- objectFieldValue+        , Just (expectedType, _) <- locationInfo+        , In.InputObjectBaseType inputObjectType <- expectedType+        , In.InputObjectType _ _ fieldTypes' <- inputObjectType =+            fold <$> traverse (traverseObjectField variables fieldTypes') objectFields+        | otherwise = pure mempty+    maybeUsageAllowed variableName variables locationInfo+        | Just (locationType, locationValue) <- locationInfo+        , findVariableDefinition' <- findVariableDefinition variableName+        , Just variableDefinition <- find findVariableDefinition' variables+            = maybeToSeq+            <$> isVariableUsageAllowed locationType locationValue variableDefinition+        | otherwise = pure mempty+    findArgumentVariables :: [Full.VariableDefinition]+        -> HashMap Full.Name In.Argument+        -> Full.Argument+        -> ValidationState m (Seq Error)+    findArgumentVariables variables argumentTypes argument+        | Full.Argument argumentName argumentValue _ <- argument+        , Full.Node{ node = Full.Variable variableName } <- argumentValue+            = maybeUsageAllowed variableName variables+            $ locationPair extractArgument argumentTypes argumentName+        | Full.Argument argumentName argumentValue _ <- argument+            = lookupInputObject variables argumentValue+            $ locationPair extractArgument argumentTypes argumentName+    extractField (In.InputField _ locationType locationValue) =+        (locationType, locationValue)+    extractArgument (In.Argument _ locationType locationValue) =+        (locationType, locationValue)+    locationPair extract fieldTypes name =+        extract <$> HashMap.lookup name fieldTypes+    traverseObjectField variables fieldTypes Full.ObjectField{..}+        | Full.Node{ node = Full.Variable variableName } <- value+            = maybeUsageAllowed variableName variables+            $ locationPair extractField fieldTypes name+        | otherwise = lookupInputObject variables value+            $  locationPair extractField fieldTypes name+    findVariableDefinition variableName variableDefinition =+        let Full.VariableDefinition variableName' _ _ _ = variableDefinition+         in variableName == variableName'+    isVariableUsageAllowed locationType locationDefaultValue variableDefinition+        | Full.VariableDefinition _ variableType _ _ <- variableDefinition+        , Full.TypeNonNull _ <- variableType =+            typesCompatibleOrError variableDefinition locationType+        | Just nullableLocationType <- unwrapInType locationType+        , Full.VariableDefinition _ variableType variableDefaultValue _ <-+            variableDefinition+        , hasNonNullVariableDefaultValue' <-+            hasNonNullVariableDefaultValue variableDefaultValue+        , hasLocationDefaultValue <- isJust locationDefaultValue =+            if (hasNonNullVariableDefaultValue' || hasLocationDefaultValue)+                && areTypesCompatible variableType nullableLocationType+                then pure Nothing+                else pure $ makeError variableDefinition locationType+        | otherwise = typesCompatibleOrError variableDefinition locationType+    typesCompatibleOrError variableDefinition locationType+        | Full.VariableDefinition _ variableType _ _ <- variableDefinition+        , areTypesCompatible variableType locationType = pure Nothing+        | otherwise = pure $ makeError variableDefinition locationType+    areTypesCompatible nonNullType (unwrapInType -> Just nullableLocationType)+        | Full.TypeNonNull (Full.NonNullTypeNamed namedType) <- nonNullType =+            areTypesCompatible (Full.TypeNamed namedType) nullableLocationType+        | Full.TypeNonNull (Full.NonNullTypeList namedList) <- nonNullType =+            areTypesCompatible (Full.TypeList namedList) nullableLocationType+    areTypesCompatible _ (In.isNonNullType -> True) = False+    areTypesCompatible (Full.TypeNonNull nonNullType) locationType+        | Full.NonNullTypeNamed namedType <- nonNullType =+            areTypesCompatible (Full.TypeNamed namedType) locationType+        | Full.NonNullTypeList namedType <- nonNullType =+            areTypesCompatible (Full.TypeList namedType) locationType+    areTypesCompatible variableType locationType+        | Full.TypeList itemVariableType <- variableType+        , In.ListType itemLocationType <- locationType =+            areTypesCompatible itemVariableType itemLocationType+        | areIdentical variableType locationType = True+        | otherwise = False+    areIdentical (Full.TypeList typeList) (In.ListType itemLocationType) =+        areIdentical typeList itemLocationType+    areIdentical (Full.TypeNonNull nonNullType) locationType+        | Full.NonNullTypeList nonNullList <- nonNullType+        , In.NonNullListType  itemLocationType <- locationType =+            areIdentical nonNullList itemLocationType+        | Full.NonNullTypeNamed _ <- nonNullType+        , In.ListBaseType _ <- locationType = False+        | Full.NonNullTypeNamed nonNullList <- nonNullType+        , In.isNonNullType locationType =+            nonNullList == inputTypeName locationType+    areIdentical (Full.TypeNamed _) (In.ListBaseType _) = False+    areIdentical (Full.TypeNamed typeNamed) locationType+        | not $ In.isNonNullType locationType =+            typeNamed == inputTypeName locationType+    areIdentical _ _ = False+    hasNonNullVariableDefaultValue (Just (Full.Node Full.ConstNull _)) = False+    hasNonNullVariableDefaultValue Nothing = False+    hasNonNullVariableDefaultValue _ = True+    unwrapInType (In.NonNullScalarType nonNullType) =+        Just $ In.NamedScalarType nonNullType+    unwrapInType (In.NonNullEnumType nonNullType) =+        Just $ In.NamedEnumType nonNullType+    unwrapInType (In.NonNullInputObjectType nonNullType) =+        Just $ In.NamedInputObjectType nonNullType+    unwrapInType (In.NonNullListType nonNullType) =+        Just $ In.ListType nonNullType+    unwrapInType _ = Nothing+    makeError variableDefinition expectedType =+        let Full.VariableDefinition variableName variableType _ location' =+                variableDefinition+         in Just $ Error+            { message = concat+                [ "Variable \"$"+                , Text.unpack variableName+                , "\" of type \""+                , show variableType+                , "\" used in position expecting type \""+                , show expectedType+                , "\"."+                ]+            , locations = [location']+            }++-- | Literal values must be compatible with the type expected in the position+-- they are found as per the coercion rules.+--+-- The type expected in a position include the type defined by the argument a+-- value is provided for, the type defined by an input object field a value is+-- provided for, and the type of a variable definition a default value is+-- provided for.+valuesOfCorrectTypeRule :: forall m. Rule m+valuesOfCorrectTypeRule = ValueRule go constGo+  where+    go (Just inputType) value+        | Just constValue <- toConstNode value =+            lift $ check inputType constValue+    go _ _ = lift mempty+    toConstNode Full.Node{..} = flip Full.Node location <$> toConst node+    toConst (Full.Variable _) = Nothing+    toConst (Full.Int integer) = Just $ Full.ConstInt integer+    toConst (Full.Float double) = Just $ Full.ConstFloat double+    toConst (Full.String string) = Just $ Full.ConstString string+    toConst (Full.Boolean boolean) = Just $ Full.ConstBoolean boolean+    toConst Full.Null = Just Full.ConstNull+    toConst (Full.Enum enum) = Just $ Full.ConstEnum enum+    toConst (Full.List values) =+        Just $ Full.ConstList $ catMaybes $ toConst <$> values+    toConst (Full.Object fields) = Just $ Full.ConstObject+        $ catMaybes $ constObjectField <$> fields+    constObjectField Full.ObjectField{..}+        | Just constValue <- toConstNode value =+            Just $ Full.ObjectField name constValue location+        | otherwise = Nothing+    constGo Nothing = const $ lift mempty+    constGo (Just inputType) = lift . check inputType+    check :: In.Type -> Full.Node Full.ConstValue -> Seq Error+    check _ Full.Node{ node = Full.ConstNull } =+        mempty -- Ignore, required fields are checked elsewhere.+    check (In.ScalarBaseType scalarType) Full.Node{ node }+        | Definition.ScalarType "Int" _ <- scalarType+        , Full.ConstInt _ <- node = mempty+        | Definition.ScalarType "Boolean" _ <- scalarType+        , Full.ConstBoolean _ <- node = mempty+        | Definition.ScalarType "String" _ <- scalarType+        , Full.ConstString _ <- node = mempty+        | Definition.ScalarType "ID" _ <- scalarType+        , Full.ConstString _ <- node = mempty+        | Definition.ScalarType "ID" _ <- scalarType+        , Full.ConstInt _ <- node = mempty+        | Definition.ScalarType "Float" _ <- scalarType+        , Full.ConstFloat _ <- node = mempty+        | Definition.ScalarType "Float" _ <- scalarType+        , Full.ConstInt _ <- node = mempty+    check (In.EnumBaseType enumType) Full.Node{ node }+        | Definition.EnumType _ _ members <- enumType+        , Full.ConstEnum memberValue <- node+        , HashMap.member memberValue members = mempty+    check (In.InputObjectBaseType objectType) Full.Node{ node }+        | In.InputObjectType _ _ typeFields <- objectType+        , Full.ConstObject valueFields <- node =+            foldMap (checkObjectField typeFields) valueFields+    check (In.ListBaseType listType) constValue@Full.Node{ .. }+        | Full.ConstList listValues <- node =+            foldMap (check listType) $ flip Full.Node location <$> listValues+        | otherwise = check listType constValue+    check inputType Full.Node{ .. } = pure $ Error+        { message = concat+            [ "Value "+            , show node, " cannot be coerced to type \""+            , show inputType+            , "\"."+            ]+        , locations = [location]+        }+    checkObjectField typeFields Full.ObjectField{..}+        | Just typeField <- HashMap.lookup name typeFields+        , In.InputField _ fieldType _ <- typeField =+            check fieldType value+    checkObjectField _ _ = mempty

@@ -0,0 +1,20 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}+module Language.GraphQL.AST.DocumentSpec+    ( spec+    ) where++import Language.GraphQL.AST.Document+import Test.Hspec (Spec, describe, it, shouldBe)++spec :: Spec+spec = do+    describe "Document" $ do+        it "shows objects" $+            let zero = Location 0 0+                object = ConstObject+                    [ ObjectField "field1" (Node (ConstFloat 1.2) zero) zero+                    , ObjectField "field2" (Node ConstNull zero) zero+                    ]+                expected = "{ field1: 1.2, field2: null }"+             in show object `shouldBe` expected

@@ -0,0 +1,914 @@+{- 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 OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++module Language.GraphQL.Validate.RulesSpec+    ( spec+    ) where++import Data.Foldable (toList)+import qualified Data.HashMap.Strict as HashMap+import Data.Text (Text)+import qualified Language.GraphQL.AST as AST+import Language.GraphQL.Type+import qualified Language.GraphQL.Type.In as In+import qualified Language.GraphQL.Type.Out as Out+import Language.GraphQL.Validate+import Test.Hspec (Spec, context, describe, it, shouldBe, shouldContain)+import Text.Megaparsec (parse, errorBundlePretty)+import Text.RawString.QQ (r)++petSchema :: Schema IO+petSchema = schema queryType Nothing (Just subscriptionType) mempty++queryType :: ObjectType IO+queryType = ObjectType "Query" Nothing [] $ HashMap.fromList+    [ ("dog", dogResolver)+    , ("cat", catResolver)+    , ("findDog", findDogResolver)+    ]+  where+    dogField = Field Nothing (Out.NamedObjectType dogType) mempty+    dogResolver = ValueResolver dogField $ pure Null+    findDogArguments = HashMap.singleton "complex"+        $ In.Argument Nothing (In.NonNullInputObjectType dogDataType) Nothing+    findDogField = Field Nothing (Out.NamedObjectType dogType) findDogArguments+    findDogResolver = ValueResolver findDogField $ pure Null+    catField = Field Nothing (Out.NamedObjectType catType) mempty+    catResolver = ValueResolver catField $ pure Null++catCommandType :: EnumType+catCommandType = EnumType "CatCommand" Nothing $ HashMap.fromList+    [ ("JUMP", EnumValue Nothing)+    ]++catType :: ObjectType IO+catType = ObjectType "Cat" Nothing [petType] $ HashMap.fromList+    [ ("name", nameResolver)+    , ("nickname", nicknameResolver)+    , ("doesKnowCommand", doesKnowCommandResolver)+    , ("meowVolume", meowVolumeResolver)+    ]+  where+    meowVolumeField = Field Nothing (Out.NamedScalarType int) mempty+    meowVolumeResolver = ValueResolver meowVolumeField $ pure $ Int 3+    doesKnowCommandField = Field Nothing (Out.NonNullScalarType boolean)+        $ HashMap.singleton "catCommand"+        $ In.Argument Nothing (In.NonNullEnumType catCommandType) Nothing+    doesKnowCommandResolver = ValueResolver doesKnowCommandField+        $ pure $ Boolean True++nameResolver :: Resolver IO+nameResolver = ValueResolver nameField $ pure "Name"+  where+    nameField = Field Nothing (Out.NonNullScalarType string) mempty++nicknameResolver :: Resolver IO+nicknameResolver = ValueResolver nicknameField $ pure "Nickname"+  where+    nicknameField = Field Nothing (Out.NamedScalarType string) mempty++dogCommandType :: EnumType+dogCommandType = EnumType "DogCommand" Nothing $ HashMap.fromList+    [ ("SIT", EnumValue Nothing)+    , ("DOWN", EnumValue Nothing)+    , ("HEEL", EnumValue Nothing)+    ]++dogType :: ObjectType IO+dogType = ObjectType "Dog" Nothing [petType] $ HashMap.fromList+    [ ("name", nameResolver)+    , ("nickname", nicknameResolver)+    , ("barkVolume", barkVolumeResolver)+    , ("doesKnowCommand", doesKnowCommandResolver)+    , ("isHousetrained", isHousetrainedResolver)+    , ("owner", ownerResolver)+    ]+  where+    barkVolumeField = Field Nothing (Out.NamedScalarType int) mempty+    barkVolumeResolver = ValueResolver barkVolumeField $ pure $ Int 3+    doesKnowCommandField = Field Nothing (Out.NonNullScalarType boolean)+        $ HashMap.singleton "dogCommand"+        $ In.Argument Nothing (In.NonNullEnumType dogCommandType) Nothing+    doesKnowCommandResolver = ValueResolver doesKnowCommandField+        $ pure $ Boolean True+    isHousetrainedField = Field Nothing (Out.NonNullScalarType boolean)+        $ HashMap.singleton "atOtherHomes"+        $ In.Argument Nothing (In.NamedScalarType boolean) Nothing+    isHousetrainedResolver = ValueResolver isHousetrainedField+        $ pure $ Boolean True+    ownerField = Field Nothing (Out.NamedObjectType humanType) mempty+    ownerResolver = ValueResolver ownerField $ pure Null++dogDataType :: InputObjectType+dogDataType = InputObjectType "DogData" Nothing+    $ HashMap.singleton "name" nameInputField+  where+    nameInputField = InputField Nothing (In.NonNullScalarType string) Nothing++sentientType :: InterfaceType IO+sentientType = InterfaceType "Sentient" Nothing []+    $ HashMap.singleton "name"+    $ Field Nothing (Out.NonNullScalarType string) mempty++petType :: InterfaceType IO+petType = InterfaceType "Pet" Nothing []+    $ HashMap.singleton "name"+    $ Field Nothing (Out.NonNullScalarType string) mempty++subscriptionType :: ObjectType IO+subscriptionType = ObjectType "Subscription" Nothing [] $ HashMap.fromList+    [ ("newMessage", newMessageResolver)+    , ("disallowedSecondRootField", newMessageResolver)+    ]+  where+    newMessageField = Field Nothing (Out.NonNullObjectType messageType) mempty+    newMessageResolver = ValueResolver newMessageField+        $ pure $ Object HashMap.empty++messageType :: ObjectType IO+messageType = ObjectType "Message" Nothing [] $ HashMap.fromList+    [ ("sender", senderResolver)+    , ("body", bodyResolver)+    ]+  where+    senderField = Field Nothing (Out.NonNullScalarType string) mempty+    senderResolver = ValueResolver senderField $ pure "Sender"+    bodyField = Field Nothing (Out.NonNullScalarType string) mempty+    bodyResolver = ValueResolver bodyField $ pure "Message body."++humanType :: ObjectType IO+humanType = ObjectType "Human" Nothing [sentientType] $ HashMap.fromList+    [ ("name", nameResolver)+    , ("pets", petsResolver)+    ]+  where+    petsField =+        Field Nothing (Out.ListType $ Out.NonNullInterfaceType petType) mempty+    petsResolver = ValueResolver petsField $ pure $ List []++validate :: Text -> [Error]+validate queryString =+    case parse AST.document "" queryString of+        Left parseErrors -> error $ errorBundlePretty parseErrors+        Right ast -> toList $ document petSchema specifiedRules ast++spec :: Spec+spec =+    describe "document" $ do+        context "executableDefinitionsRule" $+            it "rejects type definitions" $+                let queryString = [r|+                  query getDogName {+                    dog {+                      name+                      color+                    }+                  }++                  extend type Dog {+                    color: String+                  }+                |]+                    expected = Error+                        { message =+                            "Definition must be OperationDefinition or \+                            \FragmentDefinition."+                        , locations = [AST.Location 9 19]+                        }+                 in validate queryString `shouldContain` [expected]++        context "singleFieldSubscriptionsRule" $ do+            it "rejects multiple subscription root fields" $+                let queryString = [r|+                  subscription sub {+                    newMessage {+                      body+                      sender+                    }+                    disallowedSecondRootField+                  }+                |]+                    expected = Error+                        { message =+                            "Subscription \"sub\" must select only one top \+                            \level field."+                        , locations = [AST.Location 2 19]+                        }+                 in validate queryString `shouldContain` [expected]++            it "rejects multiple subscription root fields coming from a fragment" $+                let queryString = [r|+                  subscription sub {+                    ...multipleSubscriptions+                  }++                  fragment multipleSubscriptions on Subscription {+                    newMessage {+                      body+                      sender+                    }+                    disallowedSecondRootField+                  }+                |]+                    expected = Error+                        { message =+                            "Subscription \"sub\" must select only one top \+                            \level field."+                        , locations = [AST.Location 2 19]+                        }+                 in validate queryString `shouldContain` [expected]++            it "finds corresponding subscription fragment" $+                let queryString = [r|+                  subscription sub {+                    ...anotherSubscription+                    ...multipleSubscriptions+                  }+                  fragment multipleSubscriptions on Subscription {+                    newMessage {+                      body+                    }+                    disallowedSecondRootField {+                      sender+                    }+                  }+                  fragment anotherSubscription on Subscription {+                    newMessage {+                      body+                      sender+                    }+                  }+                |]+                    expected = Error+                        { message =+                            "Subscription \"sub\" must select only one top \+                            \level field."+                        , locations = [AST.Location 2 19]+                        }+                 in validate queryString `shouldBe` [expected]++        context "loneAnonymousOperationRule" $+            it "rejects multiple anonymous operations" $+                let queryString = [r|+                  {+                    dog {+                      name+                    }+                  }++                  query getName {+                    dog {+                      owner {+                        name+                      }+                    }+                  }+                |]+                    expected = Error+                        { message =+                            "This anonymous operation must be the only defined \+                            \operation."+                        , locations = [AST.Location 2 19]+                        }+                 in validate queryString `shouldBe` [expected]++        context "uniqueOperationNamesRule" $+            it "rejects operations with the same name" $+                let queryString = [r|+                  query dogOperation {+                    dog {+                      name+                    }+                  }++                  mutation dogOperation {+                    mutateDog {+                      id+                    }+                }+                |]+                    expected = Error+                        { message =+                            "There can be only one operation named \+                            \\"dogOperation\"."+                        , locations = [AST.Location 2 19, AST.Location 8 19]+                        }+                 in validate queryString `shouldBe` [expected]++        context "uniqueFragmentNamesRule" $+            it "rejects fragments with the same name" $+                let queryString = [r|+                  {+                    dog {+                      ...fragmentOne+                    }+                  }++                  fragment fragmentOne on Dog {+                    name+                  }++                  fragment fragmentOne on Dog {+                    owner {+                      name+                    }+                  }+                |]+                    expected = Error+                        { message =+                            "There can be only one fragment named \+                            \\"fragmentOne\"."+                        , locations = [AST.Location 8 19, AST.Location 12 19]+                        }+                 in validate queryString `shouldBe` [expected]++        context "fragmentSpreadTargetDefinedRule" $+            it "rejects the fragment spread without a target" $+                let queryString = [r|+                  {+                    dog {+                      ...undefinedFragment+                    }+                  }+                |]+                    expected = Error+                        { message =+                            "Fragment target \"undefinedFragment\" is \+                            \undefined."+                        , locations = [AST.Location 4 23]+                        }+                 in validate queryString `shouldBe` [expected]++        context "fragmentSpreadTypeExistenceRule" $ do+            it "rejects fragment spreads without an unknown target type" $+                let queryString = [r|+                  {+                    dog {+                      ...notOnExistingType+                    }+                  }+                  fragment notOnExistingType on NotInSchema {+                    name+                  }+                |]+                    expected = Error+                        { message =+                            "Fragment \"notOnExistingType\" is specified on \+                            \type \"NotInSchema\" which doesn't exist in the \+                            \schema."+                        , locations = [AST.Location 4 23]+                        }+                 in validate queryString `shouldBe` [expected]++            it "rejects inline fragments without a target" $+                let queryString = [r|+                  {+                    ... on NotInSchema {+                      name+                    }+                  }+                |]+                    expected = Error+                        { message =+                            "Inline fragment is specified on type \+                            \\"NotInSchema\" which doesn't exist in the schema."+                        , locations = [AST.Location 3 21]+                        }+                 in validate queryString `shouldBe` [expected]++        context "fragmentsOnCompositeTypesRule" $ do+            it "rejects fragments on scalar types" $+                let queryString = [r|+                  {+                    dog {+                      ...fragOnScalar+                    }+                  }+                  fragment fragOnScalar on Int {+                    name+                  }+                |]+                    expected = Error+                        { message =+                            "Fragment cannot condition on non composite type \+                            \\"Int\"."+                        , locations = [AST.Location 7 19]+                        }+                 in validate queryString `shouldContain` [expected]++            it "rejects inline fragments on scalar types" $+                let queryString = [r|+                  {+                    ... on Boolean {+                      name+                    }+                  }+                |]+                    expected = Error+                        { message =+                            "Fragment cannot condition on non composite type \+                            \\"Boolean\"."+                        , locations = [AST.Location 3 21]+                        }+                in validate queryString `shouldContain` [expected]++        context "noUnusedFragmentsRule" $+            it "rejects unused fragments" $+                let queryString = [r|+                  fragment nameFragment on Dog { # unused+                    name+                  }++                  {+                    dog {+                      name+                    }+                  }+                |]+                    expected = Error+                        { message =+                            "Fragment \"nameFragment\" is never used."+                        , locations = [AST.Location 2 19]+                        }+                 in validate queryString `shouldBe` [expected]++        context "noFragmentCyclesRule" $+            it "rejects spreads that form cycles" $+                let queryString = [r|+                  {+                    dog {+                      ...nameFragment+                    }+                  }+                  fragment nameFragment on Dog {+                    name+                    ...barkVolumeFragment+                  }+                  fragment barkVolumeFragment on Dog {+                    barkVolume+                    ...nameFragment+                  }+                |]+                    error1 = Error+                        { message =+                            "Cannot spread fragment \"barkVolumeFragment\" \+                            \within itself (via barkVolumeFragment -> \+                            \nameFragment -> barkVolumeFragment)."+                        , locations = [AST.Location 11 19]+                        }+                    error2 = Error+                        { message =+                            "Cannot spread fragment \"nameFragment\" within \+                            \itself (via nameFragment -> barkVolumeFragment -> \+                            \nameFragment)."+                        , locations = [AST.Location 7 19]+                        }+                 in validate queryString `shouldBe` [error1, error2]++        context "uniqueArgumentNamesRule" $+            it "rejects duplicate field arguments" $+                let queryString = [r|+                  {+                    dog {+                      isHousetrained(atOtherHomes: true, atOtherHomes: true)+                    }+                  }+                |]+                    expected = Error+                        { message =+                            "There can be only one argument named \+                            \\"atOtherHomes\"."+                        , locations = [AST.Location 4 38, AST.Location 4 58]+                        }+                 in validate queryString `shouldBe` [expected]++        context "uniqueDirectiveNamesRule" $+            it "rejects more than one directive per location" $+                let queryString = [r|+                  query ($foo: Boolean = true, $bar: Boolean = false) {+                    dog @skip(if: $foo) @skip(if: $bar) {+                      name+                    }+                  }+                |]+                    expected = Error+                        { message =+                            "There can be only one directive named \"skip\"."+                        , locations = [AST.Location 3 25, AST.Location 3 41]+                        }+                 in validate queryString `shouldBe` [expected]++        context "uniqueVariableNamesRule" $+            it "rejects duplicate variables" $+                let queryString = [r|+                  query houseTrainedQuery($atOtherHomes: Boolean, $atOtherHomes: Boolean) {+                    dog {+                      isHousetrained(atOtherHomes: $atOtherHomes)+                    }+                  }+                |]+                    expected = Error+                        { message =+                            "There can be only one variable named \+                            \\"atOtherHomes\"."+                        , locations = [AST.Location 2 43, AST.Location 2 67]+                        }+                 in validate queryString `shouldBe` [expected]++        context "variablesAreInputTypesRule" $+            it "rejects non-input types as variables" $+                let queryString = [r|+                  query takesDogBang($dog: Dog!) {+                    dog {+                      isHousetrained(atOtherHomes: $dog)+                    }+                  }+                |]+                    expected = Error+                        { message =+                            "Variable \"$dog\" cannot be non-input type \+                            \\"Dog\"."+                        , locations = [AST.Location 2 38]+                        }+                 in validate queryString `shouldContain` [expected]++        context "noUndefinedVariablesRule" $+            it "rejects undefined variables" $+                let queryString = [r|+                  query variableIsNotDefinedUsedInSingleFragment {+                    dog {+                      ...isHousetrainedFragment+                    }+                  }++                  fragment isHousetrainedFragment on Dog {+                    isHousetrained(atOtherHomes: $atOtherHomes)+                  }+                |]+                    expected = Error+                        { message =+                            "Variable \"$atOtherHomes\" is not defined by \+                            \operation \+                            \\"variableIsNotDefinedUsedInSingleFragment\"."+                        , locations = [AST.Location 9 50]+                        }+                 in validate queryString `shouldBe` [expected]++        context "noUnusedVariablesRule" $+            it "rejects unused variables" $+                let queryString = [r|+                  query variableUnused($atOtherHomes: Boolean) {+                    dog {+                      isHousetrained+                    }+                  }+                |]+                    expected = Error+                        { message =+                            "Variable \"$atOtherHomes\" is never used in \+                            \operation \"variableUnused\"."+                        , locations = [AST.Location 2 40]+                        }+                 in validate queryString `shouldBe` [expected]++        context "uniqueInputFieldNamesRule" $+            it "rejects duplicate fields in input objects" $+                let queryString = [r|+                  {+                    findDog(complex: { name: "Fido", name: "Jack" }) {+                      name+                    }+                  }+                |]+                    expected = Error+                        { message =+                            "There can be only one input field named \"name\"."+                        , locations = [AST.Location 3 40, AST.Location 3 54]+                        }+                 in validate queryString `shouldBe` [expected]++        context "fieldsOnCorrectTypeRule" $+            it "rejects undefined fields" $+                let queryString = [r|+                  {+                    dog {+                      meowVolume+                    }+                  }+                |]+                    expected = Error+                        { message =+                            "Cannot query field \"meowVolume\" on type \"Dog\"."+                        , locations = [AST.Location 4 23]+                        }+                 in validate queryString `shouldBe` [expected]++        context "scalarLeafsRule" $+            it "rejects scalar fields with not empty selection set" $+                let queryString = [r|+                  {+                    dog {+                      barkVolume {+                        sinceWhen+                      }+                    }+                  }+                |]+                    expected = Error+                        { message =+                            "Field \"barkVolume\" must not have a selection \+                            \since type \"Int\" has no subfields."+                        , locations = [AST.Location 4 23]+                        }+                 in validate queryString `shouldBe` [expected]++        context "knownArgumentNamesRule" $ do+            it "rejects field arguments missing in the type" $+                let queryString = [r|+                  {+                    dog {+                      doesKnowCommand(command: CLEAN_UP_HOUSE, dogCommand: SIT)+                    }+                  }+                |]+                    expected = Error+                        { message =+                            "Unknown argument \"command\" on field \+                            \\"Dog.doesKnowCommand\"."+                        , locations = [AST.Location 4 39]+                        }+                 in validate queryString `shouldBe` [expected]++            it "rejects directive arguments missing in the definition" $+                let queryString = [r|+                  {+                    dog {+                      isHousetrained(atOtherHomes: true) @include(unless: false, if: true)+                    }+                  }+                |]+                    expected = Error+                        { message =+                            "Unknown argument \"unless\" on directive \+                            \\"@include\"."+                        , locations = [AST.Location 4 67]+                        }+                 in validate queryString `shouldBe` [expected]++        context "knownDirectiveNamesRule" $+            it "rejects undefined directives" $+                let queryString = [r|+                  {+                    dog {+                      isHousetrained(atOtherHomes: true) @ignore(if: true)+                    }+                  }+                |]+                    expected = Error+                        { message = "Unknown directive \"@ignore\"."+                        , locations = [AST.Location 4 58]+                        }+                 in validate queryString `shouldBe` [expected]++        context "knownInputFieldNamesRule" $+            it "rejects undefined input object fields" $+                let queryString = [r|+                  {+                    findDog(complex: { favoriteCookieFlavor: "Bacon", name: "Jack" }) {+                      name+                    }+                  }+                |]+                    expected = Error+                        { message =+                            "Field \"favoriteCookieFlavor\" is not defined \+                            \by type \"DogData\"."+                        , locations = [AST.Location 3 40]+                        }+                 in validate queryString `shouldBe` [expected]++        context "directivesInValidLocationsRule" $+            it "rejects directives in invalid locations" $+                let queryString = [r|+                  query @skip(if: $foo) {+                    dog {+                      name+                    }+                  }+                |]+                    expected = Error+                        { message =+                            "Directive \"@skip\" may not be used on QUERY."+                        , locations = [AST.Location 2 25]+                        }+                 in validate queryString `shouldBe` [expected]++        context "overlappingFieldsCanBeMergedRule" $ do+            it "fails to merge fields of mismatching types" $+                let queryString = [r|+                  {+                    dog {+                      name: nickname+                      name+                    }+                  }+                |]+                    expected = Error+                        { message =+                            "Fields \"name\" conflict because \"nickname\" and \+                            \\"name\" are different fields. Use different \+                            \aliases on the fields to fetch both if this was \+                            \intentional."+                        , locations = [AST.Location 4 23, AST.Location 5 23]+                        }+                 in validate queryString `shouldBe` [expected]++            it "fails if the arguments of the same field don't match" $+                let queryString = [r|+                  {+                    dog {+                      doesKnowCommand(dogCommand: SIT)+                      doesKnowCommand(dogCommand: HEEL)+                    }+                  }+                |]+                    expected = Error+                        { message =+                            "Fields \"doesKnowCommand\" conflict because they \+                            \have different arguments. Use different aliases \+                            \on the fields to fetch both if this was \+                            \intentional."+                        , locations = [AST.Location 4 23, AST.Location 5 23]+                        }+                 in validate queryString `shouldBe` [expected]++            it "fails to merge same-named field and alias" $+                let queryString = [r|+                  {+                    dog {+                      doesKnowCommand(dogCommand: SIT)+                      doesKnowCommand: isHousetrained(atOtherHomes: true)+                    }+                  }+                |]+                    expected = Error+                        { message =+                            "Fields \"doesKnowCommand\" conflict because \+                            \\"doesKnowCommand\" and \"isHousetrained\" are \+                            \different fields. Use different aliases on the \+                            \fields to fetch both if this was intentional."+                        , locations = [AST.Location 4 23, AST.Location 5 23]+                        }+                 in validate queryString `shouldBe` [expected]++            it "looks for fields after a successfully merged field pair" $+                let queryString = [r|+                  {+                    dog {+                      name+                      doesKnowCommand(dogCommand: SIT)+                    }+                    dog {+                      name+                      doesKnowCommand: isHousetrained(atOtherHomes: true)+                    }+                  }+                |]+                    expected = Error+                        { message =+                            "Fields \"doesKnowCommand\" conflict because \+                            \\"doesKnowCommand\" and \"isHousetrained\" are \+                            \different fields. Use different aliases on the \+                            \fields to fetch both if this was intentional."+                        , locations = [AST.Location 5 23, AST.Location 9 23]+                        }+                 in validate queryString `shouldBe` [expected]++        context "possibleFragmentSpreadsRule" $ do+            it "rejects object inline spreads outside object scope" $+                let queryString = [r|+                  {+                    dog {+                      ... on Cat {+                        meowVolume+                      }+                    }+                  }+                |]+                    expected = Error+                        { message =+                            "Fragment cannot be spread here as objects of type \+                            \\"Dog\" can never be of type \"Cat\"."+                        , locations = [AST.Location 4 23]+                        }+                 in validate queryString `shouldBe` [expected]++            it "rejects object named spreads outside object scope" $+                let queryString = [r|+                  {+                    dog {+                      ... catInDogFragmentInvalid+                    }+                  }++                  fragment catInDogFragmentInvalid on Cat {+                    meowVolume+                  }+                |]+                    expected = Error+                        { message =+                            "Fragment \"catInDogFragmentInvalid\" cannot be \+                            \spread here as objects of type \"Dog\" can never \+                            \be of type \"Cat\"."+                        , locations = [AST.Location 4 23]+                        }+                 in validate queryString `shouldBe` [expected]++        context "providedRequiredInputFieldsRule" $+            it "rejects missing required input fields" $+                let queryString = [r|+                  {+                    findDog(complex: { name: null }) {+                      name+                    }+                  }+                |]+                    expected = Error+                        { message =+                            "Input field \"name\" of type \"DogData\" is \+                            \required, but it was not provided."+                        , locations = [AST.Location 3 38]+                        }+                 in validate queryString `shouldBe` [expected]++        context "providedRequiredArgumentsRule" $+            it "checks for (non-)nullable arguments" $+                let queryString = [r|+                  {+                    dog {+                      doesKnowCommand(dogCommand: null)+                    }+                  }+                |]+                    expected = Error+                        { message =+                            "Field \"doesKnowCommand\" argument \"dogCommand\" \+                            \of type \"DogCommand\" is required, but it was \+                            \not provided."+                        , locations = [AST.Location 4 23]+                        }+                 in validate queryString `shouldBe` [expected]++        context "variablesInAllowedPositionRule" $ do+            it "rejects wrongly typed variable arguments" $+                let queryString = [r|+                  query catCommandArgQuery($catCommandArg: CatCommand) {+                    cat {+                      doesKnowCommand(catCommand: $catCommandArg)+                    }+                  }+                |]+                    expected = Error+                        { message =+                            "Variable \"$catCommandArg\" of type \+                            \\"CatCommand\" used in position expecting type \+                            \\"!CatCommand\"."+                        , locations = [AST.Location 2 44]+                        }+                 in validate queryString `shouldBe` [expected]++            it "rejects wrongly typed variable arguments" $+                let queryString = [r|+                  query intCannotGoIntoBoolean($intArg: Int) {+                    dog {+                      isHousetrained(atOtherHomes: $intArg)+                    }+                  }+                |]+                    expected = Error+                        { message =+                            "Variable \"$intArg\" of type \"Int\" used in \+                            \position expecting type \"Boolean\"."+                        , locations = [AST.Location 2 48]+                        }+                 in validate queryString `shouldBe` [expected]++        context "valuesOfCorrectTypeRule" $+            it "rejects values of incorrect types" $+                let queryString = [r|+                  {+                    dog {+                      isHousetrained(atOtherHomes: 3)+                    }+                  }+                |]+                    expected = Error+                        { message =+                            "Value 3 cannot be coerced to type \"Boolean\"."+                        , locations = [AST.Location 4 52]+                        }+                 in validate queryString `shouldBe` [expected]

@@ -1,665 +0,0 @@-{- 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 OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}--module Language.GraphQL.ValidateSpec-    ( spec-    ) where--import Data.Foldable (toList)-import qualified Data.HashMap.Strict as HashMap-import Data.Text (Text)-import qualified Language.GraphQL.AST as AST-import Language.GraphQL.Type-import qualified Language.GraphQL.Type.In as In-import qualified Language.GraphQL.Type.Out as Out-import Language.GraphQL.Validate-import Test.Hspec (Spec, describe, it, shouldBe, shouldContain)-import Text.Megaparsec (parse)-import Text.RawString.QQ (r)--petSchema :: Schema IO-petSchema = schema queryType Nothing (Just subscriptionType) mempty--queryType :: ObjectType IO-queryType = ObjectType "Query" Nothing [] $ HashMap.fromList-    [ ("dog", dogResolver)-    , ("findDog", findDogResolver)-    ]-  where-    dogField = Field Nothing (Out.NamedObjectType dogType) mempty-    dogResolver = ValueResolver dogField $ pure Null-    findDogArguments = HashMap.singleton "complex"-        $ In.Argument Nothing (In.NonNullInputObjectType dogDataType) Nothing-    findDogField = Field Nothing (Out.NamedObjectType dogType) findDogArguments-    findDogResolver = ValueResolver findDogField $ pure Null--dogCommandType :: EnumType-dogCommandType = EnumType "DogCommand" Nothing $ HashMap.fromList-    [ ("SIT", EnumValue Nothing)-    , ("DOWN", EnumValue Nothing)-    , ("HEEL", EnumValue Nothing)-    ]--dogType :: ObjectType IO-dogType = ObjectType "Dog" Nothing [petType] $ HashMap.fromList-    [ ("name", nameResolver)-    , ("nickname", nicknameResolver)-    , ("barkVolume", barkVolumeResolver)-    , ("doesKnowCommand", doesKnowCommandResolver)-    , ("isHousetrained", isHousetrainedResolver)-    , ("owner", ownerResolver)-    ]-  where-    nameField = Field Nothing (Out.NonNullScalarType string) mempty-    nameResolver = ValueResolver nameField $ pure "Name"-    nicknameField = Field Nothing (Out.NamedScalarType string) mempty-    nicknameResolver = ValueResolver nicknameField $ pure "Nickname"-    barkVolumeField = Field Nothing (Out.NamedScalarType int) mempty-    barkVolumeResolver = ValueResolver barkVolumeField $ pure $ Int 3-    doesKnowCommandField = Field Nothing (Out.NonNullScalarType boolean)-        $ HashMap.singleton "dogCommand"-        $ In.Argument Nothing (In.NonNullEnumType dogCommandType) Nothing-    doesKnowCommandResolver = ValueResolver doesKnowCommandField-        $ pure $ Boolean True-    isHousetrainedField = Field Nothing (Out.NonNullScalarType boolean)-        $ HashMap.singleton "atOtherHomes"-        $ In.Argument Nothing (In.NamedScalarType boolean) Nothing-    isHousetrainedResolver = ValueResolver isHousetrainedField-        $ pure $ Boolean True-    ownerField = Field Nothing (Out.NamedObjectType humanType) mempty-    ownerResolver = ValueResolver ownerField $ pure Null--dogDataType :: InputObjectType-dogDataType = InputObjectType "DogData" Nothing-    $ HashMap.singleton "name" nameInputField-  where-    nameInputField = InputField Nothing (In.NonNullScalarType string) Nothing--sentientType :: InterfaceType IO-sentientType = InterfaceType "Sentient" Nothing []-    $ HashMap.singleton "name"-    $ Field Nothing (Out.NonNullScalarType string) mempty--petType :: InterfaceType IO-petType = InterfaceType "Pet" Nothing []-    $ HashMap.singleton "name"-    $ Field Nothing (Out.NonNullScalarType string) mempty--subscriptionType :: ObjectType IO-subscriptionType = ObjectType "Subscription" Nothing [] $ HashMap.fromList-    [ ("newMessage", newMessageResolver)-    , ("disallowedSecondRootField", newMessageResolver)-    ]-  where-    newMessageField = Field Nothing (Out.NonNullObjectType messageType) mempty-    newMessageResolver = ValueResolver newMessageField-        $ pure $ Object HashMap.empty--messageType :: ObjectType IO-messageType = ObjectType "Message" Nothing [] $ HashMap.fromList-    [ ("sender", senderResolver)-    , ("body", bodyResolver)-    ]-  where-    senderField = Field Nothing (Out.NonNullScalarType string) mempty-    senderResolver = ValueResolver senderField $ pure "Sender"-    bodyField = Field Nothing (Out.NonNullScalarType string) mempty-    bodyResolver = ValueResolver bodyField $ pure "Message body."--humanType :: ObjectType IO-humanType = ObjectType "Human" Nothing [sentientType] $ HashMap.fromList-    [ ("name", nameResolver)-    , ("pets", petsResolver)-    ]-  where-    nameField = Field Nothing (Out.NonNullScalarType string) mempty-    nameResolver = ValueResolver nameField $ pure "Name"-    petsField =-        Field Nothing (Out.ListType $ Out.NonNullInterfaceType petType) mempty-    petsResolver = ValueResolver petsField $ pure $ List []-{--catOrDogType :: UnionType IO-catOrDogType = UnionType "CatOrDog" Nothing [catType, dogType]--}-validate :: Text -> [Error]-validate queryString =-    case parse AST.document "" queryString of-        Left _ -> []-        Right ast -> toList $ document petSchema specifiedRules ast--spec :: Spec-spec =-    describe "document" $ do-        it "rejects type definitions" $-            let queryString = [r|-              query getDogName {-                dog {-                  name-                  color-                }-              }--              extend type Dog {-                color: String-              }-            |]-                expected = Error-                    { message =-                        "Definition must be OperationDefinition or FragmentDefinition."-                    , locations = [AST.Location 9 15]-                    }-               in validate queryString `shouldContain` [expected]--        it "rejects multiple subscription root fields" $-            let queryString = [r|-              subscription sub {-                newMessage {-                  body-                  sender-                }-                disallowedSecondRootField-              }-            |]-                expected = Error-                    { message =-                        "Subscription \"sub\" must select only one top level \-                        \field."-                    , locations = [AST.Location 2 15]-                    }-             in validate queryString `shouldContain` [expected]--        it "rejects multiple subscription root fields coming from a fragment" $-            let queryString = [r|-              subscription sub {-                ...multipleSubscriptions-              }--              fragment multipleSubscriptions on Subscription {-                newMessage {-                  body-                  sender-                }-                disallowedSecondRootField-              }-            |]-                expected = Error-                    { message =-                        "Subscription \"sub\" must select only one top level \-                        \field."-                    , locations = [AST.Location 2 15]-                    }-             in validate queryString `shouldContain` [expected]--        it "rejects multiple anonymous operations" $-            let queryString = [r|-              {-                dog {-                  name-                }-              }--              query getName {-                dog {-                  owner {-                    name-                  }-                }-              }-            |]-                expected = Error-                    { message =-                        "This anonymous operation must be the only defined operation."-                    , locations = [AST.Location 2 15]-                    }-             in validate queryString `shouldBe` [expected]--        it "rejects operations with the same name" $-            let queryString = [r|-              query dogOperation {-                dog {-                  name-                }-              }--              mutation dogOperation {-                mutateDog {-                  id-                }-            }-            |]-                expected = Error-                    { message =-                        "There can be only one operation named \"dogOperation\"."-                    , locations = [AST.Location 2 15, AST.Location 8 15]-                    }-             in validate queryString `shouldBe` [expected]--        it "rejects fragments with the same name" $-            let queryString = [r|-              {-                dog {-                  ...fragmentOne-                }-              }--              fragment fragmentOne on Dog {-                name-              }--              fragment fragmentOne on Dog {-                owner {-                  name-                }-              }-            |]-                expected = Error-                    { message =-                        "There can be only one fragment named \"fragmentOne\"."-                    , locations = [AST.Location 8 15, AST.Location 12 15]-                    }-             in validate queryString `shouldBe` [expected]--        it "rejects the fragment spread without a target" $-            let queryString = [r|-              {-                dog {-                  ...undefinedFragment-                }-              }-            |]-                expected = Error-                    { message =-                        "Fragment target \"undefinedFragment\" is undefined."-                    , locations = [AST.Location 4 19]-                    }-             in validate queryString `shouldBe` [expected]--        it "rejects fragment spreads without an unknown target type" $-            let queryString = [r|-              {-                dog {-                  ...notOnExistingType-                }-              }-              fragment notOnExistingType on NotInSchema {-                name-              }-            |]-                expected = Error-                    { message =-                        "Fragment \"notOnExistingType\" is specified on type \-                        \\"NotInSchema\" which doesn't exist in the schema."-                    , locations = [AST.Location 4 19]-                    }-             in validate queryString `shouldBe` [expected]--        it "rejects inline fragments without a target" $-            let queryString = [r|-              {-                ... on NotInSchema {-                  name-                }-              }-            |]-                expected = Error-                    { message =-                        "Inline fragment is specified on type \"NotInSchema\" \-                        \which doesn't exist in the schema."-                    , locations = [AST.Location 3 17]-                    }-             in validate queryString `shouldBe` [expected]--        it "rejects fragments on scalar types" $-            let queryString = [r|-              {-                dog {-                  ...fragOnScalar-                }-              }-              fragment fragOnScalar on Int {-                name-              }-            |]-                expected = Error-                    { message =-                        "Fragment cannot condition on non composite type \-                        \\"Int\"."-                    , locations = [AST.Location 7 15]-                    }-             in validate queryString `shouldContain` [expected]--        it "rejects inline fragments on scalar types" $-            let queryString = [r|-              {-                ... on Boolean {-                  name-                }-              }-            |]-                expected = Error-                    { message =-                        "Fragment cannot condition on non composite type \-                        \\"Boolean\"."-                    , locations = [AST.Location 3 17]-                    }-             in validate queryString `shouldContain` [expected]--        it "rejects unused fragments" $-            let queryString = [r|-              fragment nameFragment on Dog { # unused-                name-              }--              {-                dog {-                  name-                }-              }-            |]-                expected = Error-                    { message =-                        "Fragment \"nameFragment\" is never used."-                    , locations = [AST.Location 2 15]-                    }-             in validate queryString `shouldBe` [expected]--        it "rejects spreads that form cycles" $-            let queryString = [r|-              {-                dog {-                  ...nameFragment-                }-              }-              fragment nameFragment on Dog {-                name-                ...barkVolumeFragment-              }-              fragment barkVolumeFragment on Dog {-                barkVolume-                ...nameFragment-              }-            |]-                error1 = Error-                    { message =-                        "Cannot spread fragment \"barkVolumeFragment\" within \-                        \itself (via barkVolumeFragment -> nameFragment -> \-                        \barkVolumeFragment)."-                    , locations = [AST.Location 11 15]-                    }-                error2 = Error-                    { message =-                        "Cannot spread fragment \"nameFragment\" within itself \-                        \(via nameFragment -> barkVolumeFragment -> \-                        \nameFragment)."-                    , locations = [AST.Location 7 15]-                    }-             in validate queryString `shouldBe` [error1, error2]--        it "rejects duplicate field arguments" $ do-            let queryString = [r|-              {-                dog {-                  isHousetrained(atOtherHomes: true, atOtherHomes: true)-                }-              }-            |]-                expected = Error-                    { message =-                        "There can be only one argument named \"atOtherHomes\"."-                    , locations = [AST.Location 4 34, AST.Location 4 54]-                    }-             in validate queryString `shouldBe` [expected]--        it "rejects more than one directive per location" $ do-            let queryString = [r|-              query ($foo: Boolean = true, $bar: Boolean = false) {-                dog @skip(if: $foo) @skip(if: $bar) {-                  name-                }-              }-            |]-                expected = Error-                    { message =-                        "There can be only one directive named \"skip\"."-                    , locations = [AST.Location 3 21, AST.Location 3 37]-                    }-             in validate queryString `shouldBe` [expected]--        it "rejects duplicate variables" $-            let queryString = [r|-              query houseTrainedQuery($atOtherHomes: Boolean, $atOtherHomes: Boolean) {-                dog {-                  isHousetrained(atOtherHomes: $atOtherHomes)-                }-              }-            |]-                expected = Error-                    { message =-                        "There can be only one variable named \"atOtherHomes\"."-                    , locations = [AST.Location 2 39, AST.Location 2 63]-                    }-             in validate queryString `shouldBe` [expected]--        it "rejects non-input types as variables" $-            let queryString = [r|-              query takesDogBang($dog: Dog!) {-                dog {-                  isHousetrained(atOtherHomes: $dog)-                }-              }-            |]-                expected = Error-                    { message =-                        "Variable \"$dog\" cannot be non-input type \"Dog\"."-                    , locations = [AST.Location 2 34]-                    }-             in validate queryString `shouldBe` [expected]--        it "rejects undefined variables" $-            let queryString = [r|-              query variableIsNotDefinedUsedInSingleFragment {-                dog {-                  ...isHousetrainedFragment-                }-              }--              fragment isHousetrainedFragment on Dog {-                isHousetrained(atOtherHomes: $atOtherHomes)-              }-            |]-                expected = Error-                    { message =-                        "Variable \"$atOtherHomes\" is not defined by \-                        \operation \-                        \\"variableIsNotDefinedUsedInSingleFragment\"."-                    , locations = [AST.Location 9 46]-                    }-             in validate queryString `shouldBe` [expected]--        it "rejects unused variables" $-            let queryString = [r|-              query variableUnused($atOtherHomes: Boolean) {-                dog {-                  isHousetrained-                }-              }-            |]-                expected = Error-                    { message =-                        "Variable \"$atOtherHomes\" is never used in operation \-                        \\"variableUnused\"."-                    , locations = [AST.Location 2 36]-                    }-             in validate queryString `shouldBe` [expected]--        it "rejects duplicate fields in input objects" $-            let queryString = [r|-              {-                findDog(complex: { name: "Fido", name: "Jack" }) {-                  name-                }-              }-            |]-                expected = Error-                    { message =-                        "There can be only one input field named \"name\"."-                    , locations = [AST.Location 3 36, AST.Location 3 50]-                    }-             in validate queryString `shouldBe` [expected]--        it "rejects undefined fields" $-            let queryString = [r|-              {-                dog {-                  meowVolume-                }-              }-            |]-                expected = Error-                    { message =-                        "Cannot query field \"meowVolume\" on type \"Dog\"."-                    , locations = [AST.Location 4 19]-                    }-             in validate queryString `shouldBe` [expected]--        it "rejects scalar fields with not empty selection set" $-            let queryString = [r|-              {-                dog {-                  barkVolume {-                    sinceWhen-                  }-                }-              }-            |]-                expected = Error-                    { message =-                        "Field \"barkVolume\" must not have a selection since \-                        \type \"Int\" has no subfields."-                    , locations = [AST.Location 4 19]-                    }-             in validate queryString `shouldBe` [expected]--        it "rejects field arguments missing in the type" $-            let queryString = [r|-              {-                dog {-                  doesKnowCommand(command: CLEAN_UP_HOUSE, dogCommand: SIT)-                }-              }-            |]-                expected = Error-                    { message =-                        "Unknown argument \"command\" on field \-                        \\"Dog.doesKnowCommand\"."-                    , locations = [AST.Location 4 35]-                    }-             in validate queryString `shouldBe` [expected]--        it "rejects directive arguments missing in the definition" $-            let queryString = [r|-              {-                dog {-                  isHousetrained(atOtherHomes: true) @include(unless: false, if: true)-                }-              }-            |]-                expected = Error-                    { message =-                        "Unknown argument \"unless\" on directive \"@include\"."-                    , locations = [AST.Location 4 63]-                    }-             in validate queryString `shouldBe` [expected]--        it "rejects undefined directives" $-            let queryString = [r|-              {-                dog {-                  isHousetrained(atOtherHomes: true) @ignore(if: true)-                }-              }-            |]-                expected = Error-                    { message = "Unknown directive \"@ignore\"."-                    , locations = [AST.Location 4 54]-                    }-             in validate queryString `shouldBe` [expected]--        it "rejects undefined input object fields" $-            let queryString = [r|-              {-                findDog(complex: { favoriteCookieFlavor: "Bacon", name: "Jack" }) {-                  name-                }-              }-            |]-                expected = Error-                    { message =-                        "Field \"favoriteCookieFlavor\" is not defined \-                        \by type \"DogData\"."-                    , locations = [AST.Location 3 36]-                    }-             in validate queryString `shouldBe` [expected]--        it "rejects directives in invalid locations" $-            let queryString = [r|-              query @skip(if: $foo) {-                dog {-                  name-                }-              }-            |]-                expected = Error-                    { message = "Directive \"@skip\" may not be used on QUERY."-                    , locations = [AST.Location 2 21]-                    }-             in validate queryString `shouldBe` [expected]--        it "rejects missing required input fields" $-            let queryString = [r|-              {-                findDog(complex: { name: null }) {-                  name-                }-              }-            |]-                expected = Error-                    { message =-                        "Input field \"name\" of type \"DogData\" is required, \-                        \but it was not provided."-                    , locations = [AST.Location 3 34]-                    }-             in validate queryString `shouldBe` [expected]--        it "finds corresponding subscription fragment" $-            let queryString = [r|-              subscription sub {-                ...anotherSubscription-                ...multipleSubscriptions-              }-              fragment multipleSubscriptions on Subscription {-                newMessage {-                  body-                }-                disallowedSecondRootField {-                  sender-                }-              }-              fragment anotherSubscription on Subscription {-                newMessage {-                  body-                  sender-                }-              }-            |]-                expected = Error-                    { message =-                        "Subscription \"sub\" must select only one top level \-                        \field."-                    , locations = [AST.Location 2 15]-                    }-             in validate queryString `shouldBe` [expected]