graphql 1.0.0.0 → 1.0.1.0

raw patch · 21 files changed

+1385/−1064 lines, 21 filesdep +template-haskelldep −raw-strings-qqdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: template-haskell

Dependencies removed: raw-strings-qq

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +18/−1
• graphql.cabal +7/−7
• src/Language/GraphQL/AST.hs +1/−3
• src/Language/GraphQL/AST/DirectiveLocation.hs +0/−4
• src/Language/GraphQL/Error.hs +47/−32
• src/Language/GraphQL/Execute.hs +686/−35
• src/Language/GraphQL/Execute/Execution.hs +0/−253
• src/Language/GraphQL/Execute/Internal.hs +0/−31
• src/Language/GraphQL/Execute/Subscribe.hs +0/−113
• src/Language/GraphQL/Execute/Transform.hs +238/−338
• src/Language/GraphQL/TH.hs +38/−0
• src/Language/GraphQL/Type/Definition.hs +29/−2
• src/Language/GraphQL/Type/In.hs +1/−0
• tests/Language/GraphQL/AST/EncoderSpec.hs +90/−52
• tests/Language/GraphQL/AST/LexerSpec.hs +19/−19
• tests/Language/GraphQL/AST/ParserSpec.hs +30/−30
• tests/Language/GraphQL/ExecuteSpec.hs +59/−28
• tests/Language/GraphQL/Validate/RulesSpec.hs +86/−86
• tests/Test/DirectiveSpec.hs +6/−6
• tests/Test/FragmentSpec.hs +27/−21
• tests/Test/RootOperationSpec.hs +3/−3

@@ -6,8 +6,24 @@ and this project adheres to [Haskell Package Versioning Policy](https://pvp.haskell.org/). -## [1.0.0.0]+## [1.0.1.0] - 2021-09-27 ### Added+- Custom `Show` instance for `Type.Definition.Value` (for error+  messages).+- Path information in errors (path to the field throwing the error).+- Deprecation notes in the `Error` module for `Resolution`, `CollectErrsT` and+  `runCollectErrs`. These symbols are part of the old executor and aren't used+  anymore, it will be deprecated in the future and removed.+- `TH` module with the `gql` quasi quoter.++### Fixed+- Error messages are more concrete, they also contain type information and+  wrong values, where appropriate and possible.+- If the field with an error is Non-Nullable, the error is propagated to the+  first nullable field, as required by the specification.++## [1.0.0.0] - 2021-07-04+### Added - `Language.GraphQL.Execute.OrderedMap` is a map data structure, that preserves   insertion order. - `Language.GraphQL.Schema.schemaWithTypes` constructs a complete schema,@@ -443,6 +459,7 @@ ### Added - Data types for the GraphQL language. +[1.0.1.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v1.0.1.0&rev_to=v1.0.0.0 [1.0.0.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=v1.0.0.0&rev_to=v0.11.1.0 [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

@@ -1,7 +1,7 @@ cabal-version: 2.2  name:           graphql-version:        1.0.0.0+version:        1.0.1.0 synopsis:       Haskell GraphQL implementation description:    Haskell <https://spec.graphql.org/June2018/ GraphQL> implementation. category:       Language@@ -20,7 +20,9 @@ extra-source-files:     CHANGELOG.md     README.md-tested-with: GHC == 8.10.4+tested-with:+    GHC == 8.10.7+  , GHC == 9.0.1  source-repository head   type: git@@ -39,6 +41,7 @@       Language.GraphQL.Execute       Language.GraphQL.Execute.Coerce       Language.GraphQL.Execute.OrderedMap+      Language.GraphQL.TH       Language.GraphQL.Type       Language.GraphQL.Type.In       Language.GraphQL.Type.Out@@ -47,9 +50,6 @@       Language.GraphQL.Validate.Validation       Test.Hspec.GraphQL   other-modules:-      Language.GraphQL.Execute.Execution-      Language.GraphQL.Execute.Internal-      Language.GraphQL.Execute.Subscribe       Language.GraphQL.Execute.Transform       Language.GraphQL.Type.Definition       Language.GraphQL.Type.Internal@@ -67,6 +67,7 @@     , megaparsec >= 9.0.1 && < 9.1     , parser-combinators >= 1.3.0 && < 1.4     , scientific >= 0.3.7 && < 0.4+    , template-haskell >= 2.16 && < 2.18     , text >= 1.2.4 && < 1.3     , transformers >= 0.5.6 && < 0.6     , unordered-containers >= 0.2.14 && < 0.3@@ -96,14 +97,13 @@   build-depends:       QuickCheck >= 2.14.1 && < 2.15     , aeson-    , base >= 4.7 && < 5+    , base >= 4.8 && < 5     , conduit     , exceptions     , graphql     , hspec >= 2.8.2 && < 2.9     , hspec-megaparsec >= 2.2.0 && < 2.3     , megaparsec-    , raw-strings-qq >= 1.1 && < 1.2     , scientific     , text     , unordered-containers

@@ -1,6 +1,4 @@-{- 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 Safe #-}  -- | Target AST for parser. module Language.GraphQL.AST

@@ -1,7 +1,3 @@-{- 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 Safe #-}  -- | Various parts of a GraphQL document can be annotated with directives. 

@@ -1,3 +1,7 @@+{- 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 DuplicateRecordFields #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RecordWildCards #-}@@ -40,12 +44,6 @@     , unPos     ) --- | Executor context.-data Resolution m = Resolution-    { errors :: Seq Error-    , types :: HashMap Name (Schema.Type m)-    }- -- | Wraps a parse error into a list of errors. parseError :: (Applicative f, Serialize a)     => ParseErrorBundle Text Void@@ -65,32 +63,6 @@             sourcePosition = pstateSourcePos newState          in (result |> errorObject x sourcePosition, newState) --- | A wrapper to pass error messages around.-type CollectErrsT m = StateT (Resolution m) m---- | Adds an error to the list of errors.-{-# DEPRECATED #-}-addErr :: Monad m => Error -> CollectErrsT m ()-addErr v = modify appender-  where-    appender :: Monad m => Resolution m -> Resolution m-    appender resolution@Resolution{..} = resolution{ errors = errors |> v }--{-# DEPRECATED #-}-makeErrorMessage :: Text -> Error-makeErrorMessage s = Error s [] []---- | Constructs a response object containing only the error with the given--- message.-{-# DEPRECATED #-}-singleError :: Serialize a => Text -> Response a-singleError message = Response null $ Seq.singleton $ Error message [] []---- | Convenience function for just wrapping an error message.-{-# DEPRECATED #-}-addErrMsg :: (Monad m, Serialize a) => Text -> CollectErrsT m a-addErrMsg errorMessage = (addErr . makeErrorMessage) errorMessage >> pure null- -- | If an error can be associated to a particular field in the GraphQL result, -- it must contain an entry with the key path that details the path of the -- response field which experienced the error. This allows clients to identify@@ -129,8 +101,13 @@  instance Exception ResolverException +-- * Deprecated+ -- | Runs the given query computation, but collects the errors into an error -- list, which is then sent back with the data.+--+-- /runCollectErrs was part of the old executor and isn't used anymore, it will+-- be deprecated in the future and removed./ runCollectErrs :: (Monad m, Serialize a)     => HashMap Name (Schema.Type m)     -> CollectErrsT m a@@ -139,3 +116,41 @@     (dat, Resolution{..}) <- runStateT res         $ Resolution{ errors = Seq.empty, types = types' }     pure $ Response dat errors++-- | Executor context.+--+-- /Resolution was part of the old executor and isn't used anymore, it will be+-- deprecated in the future and removed./+data Resolution m = Resolution+    { errors :: Seq Error+    , types :: HashMap Name (Schema.Type m)+    }++-- | A wrapper to pass error messages around.+--+-- /CollectErrsT was part of the old executor and isn't used anymore, it will be+-- deprecated in the future and removed./+type CollectErrsT m = StateT (Resolution m) m++-- | Adds an error to the list of errors.+{-# DEPRECATED #-}+addErr :: Monad m => Error -> CollectErrsT m ()+addErr v = modify appender+  where+    appender :: Monad m => Resolution m -> Resolution m+    appender resolution@Resolution{..} = resolution{ errors = errors |> v }++{-# DEPRECATED #-}+makeErrorMessage :: Text -> Error+makeErrorMessage s = Error s [] []++-- | Constructs a response object containing only the error with the given+-- message.+{-# DEPRECATED #-}+singleError :: Serialize a => Text -> Response a+singleError message = Response null $ Seq.singleton $ Error message [] []++-- | Convenience function for just wrapping an error message.+{-# DEPRECATED #-}+addErrMsg :: (Monad m, Serialize a) => Text -> CollectErrsT m a+addErrMsg errorMessage = (addErr . makeErrorMessage) errorMessage >> pure null

@@ -1,32 +1,224 @@-{-# LANGUAGE ExplicitForAll #-}+{- 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 DataKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TypeApplications #-}+ -- | This module provides functions to execute a @GraphQL@ request. module Language.GraphQL.Execute     ( execute     , module Language.GraphQL.Execute.Coerce     ) where -import Control.Monad.Catch (MonadCatch)+import Conduit (mapMC, (.|))+import Control.Arrow (left)+import Control.Monad.Catch+     ( Exception(..)+     , Handler(..)+     , MonadCatch(..)+     , MonadThrow(..)+     , SomeException(..)+     , catches+     )+import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad.Trans.Reader (ReaderT(..), ask, runReaderT)+import Control.Monad.Trans.Writer (WriterT(..), runWriterT)+import qualified Control.Monad.Trans.Writer as Writer+import Control.Monad (foldM)+import qualified Language.GraphQL.AST.Document as Full+import Data.Foldable (find) import Data.HashMap.Strict (HashMap)-import Data.Sequence (Seq(..))+import qualified Data.HashMap.Strict as HashMap+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NonEmpty+import Data.Maybe (fromMaybe)+import Data.Sequence (Seq)+import qualified Data.Sequence as Seq import Data.Text (Text)-import qualified Language.GraphQL.AST.Document as Full+import qualified Data.Text as Text+import Data.Typeable (cast)+import GHC.Records (HasField(..)) import Language.GraphQL.Execute.Coerce-import Language.GraphQL.Execute.Execution-import Language.GraphQL.Execute.Internal+import Language.GraphQL.Execute.OrderedMap (OrderedMap)+import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap import qualified Language.GraphQL.Execute.Transform as Transform-import qualified Language.GraphQL.Execute.Subscribe as Subscribe+import qualified Language.GraphQL.Type.In as In+import qualified Language.GraphQL.Type.Out as Out+import qualified Language.GraphQL.Type as Type+import qualified Language.GraphQL.Type.Internal as Type.Internal+import Language.GraphQL.Type.Schema (Schema, Type)+import qualified Language.GraphQL.Type.Schema as Schema import Language.GraphQL.Error-    ( Error-    , ResponseEventStream+    ( Error(..)     , Response(..)-    , runCollectErrs+    , Path(..)+    , ResolverException(..)+    , ResponseEventStream     )-import qualified Language.GraphQL.Type.Definition as Definition-import qualified Language.GraphQL.Type.Out as Out-import Language.GraphQL.Type.Schema import Prelude hiding (null) +newtype ExecutorT m a = ExecutorT+    { runExecutorT :: ReaderT (HashMap Full.Name (Type m)) (WriterT (Seq Error) m) a+    }++instance Functor m => Functor (ExecutorT m) where+    fmap f = ExecutorT . fmap f . runExecutorT++instance Applicative m => Applicative (ExecutorT m) where+    pure = ExecutorT . pure+    ExecutorT f <*> ExecutorT x = ExecutorT $ f <*> x++instance Monad m => Monad (ExecutorT m) where+    ExecutorT x >>= f = ExecutorT $ x >>= runExecutorT . f++instance MonadTrans ExecutorT where+    lift = ExecutorT . lift . lift++instance MonadThrow m => MonadThrow (ExecutorT m) where+    throwM = lift . throwM++instance MonadCatch m => MonadCatch (ExecutorT m) where+  catch (ExecutorT stack) handler =+      ExecutorT $ catch stack $ runExecutorT . handler++data GraphQLException = forall e. Exception e => GraphQLException e++instance Show GraphQLException where+    show (GraphQLException e) = show e++instance Exception GraphQLException++graphQLExceptionToException :: Exception e => e -> SomeException+graphQLExceptionToException = toException . GraphQLException++graphQLExceptionFromException :: Exception e => SomeException -> Maybe e+graphQLExceptionFromException e = do+    GraphQLException graphqlException <- fromException e+    cast graphqlException++data ResultException = forall e. Exception e => ResultException e++instance Show ResultException where+    show (ResultException e) = show e++instance Exception ResultException where+    toException = graphQLExceptionToException+    fromException = graphQLExceptionFromException++resultExceptionToException :: Exception e => e -> SomeException+resultExceptionToException = toException . ResultException++resultExceptionFromException :: Exception e => SomeException -> Maybe e+resultExceptionFromException e = do+    ResultException resultException <- fromException e+    cast resultException++data FieldException = forall e. Exception e => FieldException Full.Location [Path] e++instance Show FieldException where+    show (FieldException _ _ e) = displayException e++instance Exception FieldException where+    toException = graphQLExceptionToException+    fromException = graphQLExceptionFromException++data ValueCompletionException = ValueCompletionException String Type.Value++instance Show ValueCompletionException where+    show (ValueCompletionException typeRepresentation found) = concat+        [ "Value completion error. Expected type "+        , typeRepresentation+        , ", found: "+        , show found+        , "."+        ]++instance Exception ValueCompletionException where+    toException = resultExceptionToException+    fromException = resultExceptionFromException++data InputCoercionException =+    InputCoercionException String In.Type (Maybe (Full.Node Transform.Input))++instance Show InputCoercionException where+    show (InputCoercionException argumentName argumentType Nothing) = concat+        [ "Required argument \""+        , argumentName+        , "\" of type "+        , show argumentType+        , " not specified."+        ]+    show (InputCoercionException argumentName argumentType (Just givenValue)) = concat+        [ "Argument \""+        , argumentName+        , "\" has invalid type. Expected type "+        , show argumentType+        , ", found: "+        , show givenValue+        , "."+        ]++instance Exception InputCoercionException where+    toException = graphQLExceptionToException+    fromException = graphQLExceptionFromException++newtype ResultCoercionException = ResultCoercionException String++instance Show ResultCoercionException where+    show (ResultCoercionException typeRepresentation) = concat+        [ "Unable to coerce result to "+        , typeRepresentation+        , "."+        ]++instance Exception ResultCoercionException where+    toException = resultExceptionToException+    fromException = resultExceptionFromException++-- | Query error types.+data QueryError+    = OperationNameRequired+    | OperationNotFound String+    | CoercionError Full.VariableDefinition+    | UnknownInputType Full.VariableDefinition++tell :: Monad m => Seq Error -> ExecutorT m ()+tell = ExecutorT . lift . Writer.tell++queryError :: QueryError -> Error+queryError OperationNameRequired =+    Error{ message = "Operation name is required.", locations = [], path = [] }+queryError (OperationNotFound operationName) =+    let queryErrorMessage = Text.concat+            [ "Operation \""+            , Text.pack operationName+            , "\" not found."+            ]+     in Error{ message = queryErrorMessage, locations = [], path = [] }+queryError (CoercionError variableDefinition) =+    let Full.VariableDefinition variableName _ _ location = variableDefinition+        queryErrorMessage = Text.concat+            [ "Failed to coerce the variable \""+            , variableName+            , "\"."+            ]+     in Error{ message = queryErrorMessage, locations = [location], path = [] }+queryError (UnknownInputType variableDefinition) =+    let Full.VariableDefinition variableName variableTypeName _ location = variableDefinition+        queryErrorMessage = Text.concat+            [ "Variable \""+            , variableName+            , "\" has unknown type \""+            , Text.pack $ show variableTypeName+            , "\"."+            ]+     in Error{ message = queryErrorMessage, locations = [location], path = [] }+ -- | The substitution is applied to the document, and the resolvers are applied -- to the resulting fields. The operation name can be used if the document -- defines multiple root operations.@@ -39,33 +231,492 @@     -> HashMap Full.Name a -- ^ Variable substitution function.     -> Full.Document -- @GraphQL@ document.     -> m (Either (ResponseEventStream m b) (Response b))-execute schema' operationName subs document-    = either (pure . rightErrorResponse . singleError [] . show) executeRequest-    $ Transform.document schema' operationName subs document+execute schema' operationName subs document' =+    executeRequest schema' document' (Text.unpack <$> operationName) subs -executeRequest :: (MonadCatch m, Serialize a)-    => Transform.Document m+executeRequest :: (MonadCatch m, Serialize a, VariableValue b)+    => Schema m+    -> Full.Document+    -> Maybe String+    -> HashMap Full.Name b     -> m (Either (ResponseEventStream m a) (Response a))-executeRequest (Transform.Document types' rootObjectType operation)-    | (Transform.Query _ fields objectLocation) <- operation =-        Right <$> executeOperation types' rootObjectType objectLocation fields-    | (Transform.Mutation _ fields objectLocation) <- operation =-        Right <$> executeOperation types' rootObjectType objectLocation fields-    | (Transform.Subscription _ fields objectLocation) <- operation-        = either rightErrorResponse Left-        <$> Subscribe.subscribe types' rootObjectType objectLocation fields+executeRequest schema sourceDocument operationName variableValues = do+    operationAndVariables <- sequence buildOperation+    case operationAndVariables of+        Left queryError' -> pure+            $ Right+            $ Response null $ pure $ queryError queryError'+        Right operation+            | Transform.Operation Full.Query topSelections _operationLocation <- operation ->+                 Right <$> executeQuery topSelections schema+            | Transform.Operation Full.Mutation topSelections operationLocation <- operation ->+                Right <$> executeMutation topSelections schema operationLocation+            | Transform.Operation Full.Subscription topSelections operationLocation <- operation ->+                either rightErrorResponse Left <$> subscribe topSelections schema operationLocation+  where+    schemaTypes = Schema.types schema+    (operationDefinitions, fragmentDefinitions') =+        Transform.document sourceDocument+    buildOperation = do+        operationDefinition <- getOperation operationDefinitions operationName+        coercedVariableValues <- coerceVariableValues+            schemaTypes+            operationDefinition+            variableValues+        let replacement = Transform.Replacement+                { variableValues = coercedVariableValues+                , fragmentDefinitions = fragmentDefinitions'+                , visitedFragments = mempty+                , types = schemaTypes+                }+        pure $ flip runReaderT replacement+            $ Transform.runTransformT+            $ Transform.transform operationDefinition --- This is actually executeMutation, but we don't distinguish between queries--- and mutations yet.-executeOperation :: (MonadCatch m, Serialize a)+rightErrorResponse :: Serialize b => forall a. Error -> Either a (Response b)+rightErrorResponse = Right . Response null . pure++getOperation :: [Full.OperationDefinition] -> Maybe String -> Either QueryError Full.OperationDefinition+getOperation [operation] Nothing = Right operation+getOperation operations (Just givenOperationName)+    = maybe (Left $ OperationNotFound givenOperationName) Right+    $ find findOperationByName operations+  where+    findOperationByName (Full.OperationDefinition _ (Just operationName) _ _ _ _) =+        givenOperationName == Text.unpack operationName+    findOperationByName _ = False+getOperation _ _ = Left OperationNameRequired++executeQuery :: (MonadCatch m, Serialize a)+    => Seq (Transform.Selection m)+    -> Schema m+    -> m (Response a)+executeQuery topSelections schema = do+    let queryType = Schema.query schema+    (data', errors) <- runWriterT+        $ flip runReaderT (Schema.types schema)+        $ runExecutorT+        $ catch (executeSelectionSet topSelections queryType Type.Null [])+        handleException+    pure $ Response data' errors++handleException :: (MonadCatch m, Serialize a)+    => FieldException+    -> ExecutorT m a+handleException (FieldException fieldLocation errorPath next) =+    let newError = constructError next fieldLocation errorPath+     in tell (Seq.singleton newError) >> pure null++constructError :: Exception e => e -> Full.Location -> [Path] -> Error+constructError e fieldLocation errorPath = Error+    { message = Text.pack (displayException e)+    , path = reverse errorPath+    , locations = [fieldLocation]+    }++executeMutation :: (MonadCatch m, Serialize a)+    => Seq (Transform.Selection m)+    -> Schema m+    -> Full.Location+    -> m (Response a)+executeMutation topSelections schema operationLocation+    | Just mutationType <- Schema.mutation schema = do+        (data', errors) <- runWriterT+            $ flip runReaderT (Schema.types schema)+            $ runExecutorT+            $ catch (executeSelectionSet topSelections mutationType Type.Null [])+            handleException+        pure $ Response data' errors+    | otherwise = pure+        $ Response null+        $ Seq.singleton+        $ Error "Schema doesn't support mutations." [operationLocation] []++executeSelectionSet :: (MonadCatch m, Serialize a)+    => Seq (Transform.Selection m)+    -> Out.ObjectType m+    -> Type.Value+    -> [Path]+    -> ExecutorT m a+executeSelectionSet selections objectType objectValue errorPath = do+    let groupedFieldSet = collectFields objectType selections+    resolvedValues <- OrderedMap.traverseMaybe go groupedFieldSet+    coerceResult (Out.NonNullObjectType objectType) $ Object resolvedValues+  where+    executeField' fields resolver =+        executeField objectValue fields resolver errorPath+    Out.ObjectType _ _ _ resolvers = objectType+    go fields@(Transform.Field _ fieldName _ _ _ :| _) =+        traverse (executeField' fields) $ HashMap.lookup fieldName resolvers++fieldsSegment :: forall m. NonEmpty (Transform.Field m) -> Path+fieldsSegment (Transform.Field alias fieldName _ _ _ :| _) =+    Segment (fromMaybe fieldName alias)++viewResolver :: Out.Resolver m -> (Out.Field m, Out.Resolve m)+viewResolver (Out.ValueResolver resolverField' resolveFunction) =+    (resolverField', resolveFunction)+viewResolver (Out.EventStreamResolver resolverField' resolveFunction _) =+    (resolverField', resolveFunction)++executeField :: forall m a+    . (MonadCatch m, Serialize a)+    => Type.Value+    -> NonEmpty (Transform.Field m)+    -> Out.Resolver m+    -> [Path]+    -> ExecutorT m a+executeField objectValue fields (viewResolver -> resolverPair) errorPath =+    let Transform.Field _ fieldName inputArguments _ fieldLocation :| _ = fields+     in catches (go fieldName inputArguments)+        [ Handler nullResultHandler+        , Handler (inputCoercionHandler fieldLocation)+        , Handler (resultHandler fieldLocation)+        , Handler (resolverHandler fieldLocation)+        ]+  where+    inputCoercionHandler :: (MonadCatch m, Serialize a)+        => Full.Location+        -> InputCoercionException+        -> ExecutorT m a+    inputCoercionHandler _ e@(InputCoercionException _ _ (Just valueNode)) =+        let argumentLocation = getField @"location" valueNode+         in exceptionHandler argumentLocation e+    inputCoercionHandler fieldLocation e = exceptionHandler fieldLocation e+    resultHandler :: (MonadCatch m, Serialize a)+        => Full.Location+        -> ResultException+        -> ExecutorT m a+    resultHandler = exceptionHandler+    resolverHandler :: (MonadCatch m, Serialize a)+        => Full.Location+        -> ResolverException+        -> ExecutorT m a+    resolverHandler = exceptionHandler+    nullResultHandler :: (MonadCatch m, Serialize a)+        => FieldException+        -> ExecutorT m a+    nullResultHandler e@(FieldException fieldLocation errorPath' next) =+        let newError = constructError next fieldLocation errorPath'+         in if Out.isNonNullType fieldType+             then throwM e+             else returnError newError+    exceptionHandler errorLocation e =+        let newPath = fieldsSegment fields : errorPath+            newError = constructError e errorLocation newPath+         in if Out.isNonNullType fieldType+             then throwM $ FieldException errorLocation newPath e+             else returnError newError+    returnError newError = tell (Seq.singleton newError) >> pure null+    go fieldName inputArguments = do+        argumentValues <- coerceArgumentValues argumentTypes inputArguments+        resolvedValue <-+           resolveFieldValue resolveFunction objectValue fieldName argumentValues+        completeValue fieldType fields errorPath resolvedValue+    (resolverField, resolveFunction) = resolverPair+    Out.Field _ fieldType argumentTypes = resolverField++resolveFieldValue :: MonadCatch m+    => Out.Resolve m+    -> Type.Value+    -> Full.Name+    -> Type.Subs+    -> ExecutorT m Type.Value+resolveFieldValue resolver objectValue _fieldName argumentValues =+    lift $ runReaderT resolver context+  where+    context = Type.Context+        { Type.arguments = Type.Arguments argumentValues+        , Type.values = objectValue+        }++resolveAbstractType :: Monad m+    => Type.Internal.AbstractType m+    -> Type.Subs+    -> ExecutorT m (Maybe (Out.ObjectType m))+resolveAbstractType abstractType values'+    | Just (Type.String typeName) <- HashMap.lookup "__typename" values' = do+        types' <- ExecutorT ask+        case HashMap.lookup typeName types' of+            Just (Type.Internal.ObjectType objectType) ->+                if Type.Internal.instanceOf objectType abstractType+                    then pure $ Just objectType+                    else pure Nothing+            _ -> pure Nothing+    | otherwise = pure Nothing++completeValue :: (MonadCatch m, Serialize a)+    => Out.Type m+    -> NonEmpty (Transform.Field m)+    -> [Path]+    -> Type.Value+    -> ExecutorT m a+completeValue (Out.isNonNullType -> False) _ _ Type.Null =+    pure null+completeValue outputType@(Out.ListBaseType listType) fields errorPath (Type.List list)+    = foldM go (0, []) list >>= coerceResult outputType . List . snd+  where+    go (index, accumulator) listItem = do+        let updatedPath = Index index : errorPath+        completedValue <- completeValue listType fields updatedPath listItem+        pure (index + 1, completedValue : accumulator)+completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.Int int) =+    coerceResult outputType $ Int int+completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.Boolean boolean) =+    coerceResult outputType $ Boolean boolean+completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.Float float) =+    coerceResult outputType $ Float float+completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.String string) =+    coerceResult outputType $ String string+completeValue outputType@(Out.EnumBaseType enumType) _ _ (Type.Enum enum) =+    let Type.EnumType _ _ enumMembers = enumType+     in if HashMap.member enum enumMembers+        then coerceResult outputType $ Enum enum+        else throwM+            $ ValueCompletionException (show outputType)+            $ Type.Enum enum+completeValue (Out.ObjectBaseType objectType) fields errorPath result+    = executeSelectionSet (mergeSelectionSets fields) objectType result+    $ fieldsSegment fields : errorPath+completeValue outputType@(Out.InterfaceBaseType interfaceType) fields errorPath result+    | Type.Object objectMap <- result = do+        let abstractType = Type.Internal.AbstractInterfaceType interfaceType+        concreteType <- resolveAbstractType abstractType objectMap+        case concreteType of+            Just objectType+                -> executeSelectionSet (mergeSelectionSets fields) objectType result+                $ fieldsSegment fields : errorPath+            Nothing -> throwM+                $ ValueCompletionException (show outputType) result+completeValue outputType@(Out.UnionBaseType unionType) fields errorPath result+    | Type.Object objectMap <- result = do+        let abstractType = Type.Internal.AbstractUnionType unionType+        concreteType <- resolveAbstractType abstractType objectMap+        case concreteType of+            Just objectType+                -> executeSelectionSet (mergeSelectionSets fields) objectType result+                $ fieldsSegment fields : errorPath+            Nothing -> throwM+                $ ValueCompletionException (show outputType) result+completeValue outputType _ _ result =+    throwM $ ValueCompletionException (show outputType) result++coerceResult :: (MonadCatch m, Serialize a)+    => Out.Type m+    -> Output a+    -> ExecutorT m a+coerceResult outputType result+    | Just serialized <- serialize outputType result = pure serialized+    | otherwise = throwM $ ResultCoercionException $ show outputType++mergeSelectionSets :: MonadCatch m+    => NonEmpty (Transform.Field m)+    -> Seq (Transform.Selection m)+mergeSelectionSets = foldr forEach mempty+  where+    forEach (Transform.Field _ _ _ fieldSelectionSet _) selectionSet' =+        selectionSet' <> fieldSelectionSet++coerceArgumentValues :: MonadCatch m+    => HashMap Full.Name In.Argument+    -> HashMap Full.Name (Full.Node Transform.Input)+    -> m Type.Subs+coerceArgumentValues argumentDefinitions argumentValues =+    HashMap.foldrWithKey c pure argumentDefinitions mempty+  where+    c argumentName argumentType pure' resultMap =+        forEach argumentName argumentType resultMap >>= pure'+    forEach :: MonadCatch m+         => Full.Name+         -> In.Argument+         -> Type.Subs+         -> m Type.Subs+    forEach argumentName (In.Argument _ variableType defaultValue) resultMap = do+        let matchedMap+                = matchFieldValues' argumentName variableType defaultValue+                $ Just resultMap+         in case matchedMap of+            Just matchedValues -> pure matchedValues+            Nothing+                | Just inputValue <- HashMap.lookup argumentName argumentValues+                    -> throwM+                    $ InputCoercionException (Text.unpack argumentName) variableType+                    $ Just inputValue+                | otherwise -> throwM+                    $ InputCoercionException (Text.unpack argumentName) variableType Nothing+    matchFieldValues' = matchFieldValues coerceArgumentValue+        $ Full.node <$> argumentValues+    coerceArgumentValue inputType (Transform.Int integer) =+        coerceInputLiteral inputType (Type.Int integer)+    coerceArgumentValue inputType (Transform.Boolean boolean) =+        coerceInputLiteral inputType (Type.Boolean boolean)+    coerceArgumentValue inputType (Transform.String string) =+        coerceInputLiteral inputType (Type.String string)+    coerceArgumentValue inputType (Transform.Float float) =+        coerceInputLiteral inputType (Type.Float float)+    coerceArgumentValue inputType (Transform.Enum enum) =+        coerceInputLiteral inputType (Type.Enum enum)+    coerceArgumentValue inputType Transform.Null+        | In.isNonNullType inputType = Nothing+        | otherwise = coerceInputLiteral inputType Type.Null+    coerceArgumentValue (In.ListBaseType inputType) (Transform.List list) =+        let coerceItem = coerceArgumentValue inputType+         in Type.List <$> traverse coerceItem list+    coerceArgumentValue (In.InputObjectBaseType inputType) (Transform.Object object)+        | In.InputObjectType _ _ inputFields <- inputType = +            let go = forEachField object+                resultMap = HashMap.foldrWithKey go (pure mempty) inputFields+             in Type.Object <$> resultMap+    coerceArgumentValue _ (Transform.Variable variable) = pure variable+    coerceArgumentValue _ _ = Nothing+    forEachField object variableName (In.InputField _ variableType defaultValue) =+        matchFieldValues coerceArgumentValue object variableName variableType defaultValue++collectFields :: Monad m+    => Out.ObjectType m+    -> Seq (Transform.Selection m)+    -> OrderedMap (NonEmpty (Transform.Field m))+collectFields objectType = foldl forEach OrderedMap.empty+  where+    forEach groupedFields (Transform.FieldSelection fieldSelection) =+        let Transform.Field maybeAlias fieldName _ _ _ = fieldSelection+            responseKey = fromMaybe fieldName maybeAlias+         in OrderedMap.insert responseKey (fieldSelection :| []) groupedFields+    forEach groupedFields (Transform.FragmentSelection selectionFragment)+        | Transform.Fragment fragmentType fragmentSelectionSet _ <- selectionFragment+        , Type.Internal.doesFragmentTypeApply fragmentType objectType =+            let fragmentGroupedFieldSet =+                    collectFields objectType fragmentSelectionSet+             in groupedFields <> fragmentGroupedFieldSet+        | otherwise = groupedFields++coerceVariableValues :: (Monad m, VariableValue b)+    => HashMap Full.Name (Schema.Type m)+    -> Full.OperationDefinition+    -> HashMap Full.Name b+    -> Either QueryError Type.Subs+coerceVariableValues types operationDefinition' variableValues+    | Full.OperationDefinition _ _ variableDefinitions _ _ _ <-+        operationDefinition'+    = foldr forEach (Right HashMap.empty) variableDefinitions+    | otherwise = pure mempty+  where+    forEach variableDefinition (Right coercedValues) =+        let Full.VariableDefinition variableName variableTypeName defaultValue _ =+                variableDefinition+            defaultValue' = constValue . Full.node <$> defaultValue+         in case Type.Internal.lookupInputType variableTypeName types of+            Just variableType ->+                maybe (Left $ CoercionError variableDefinition) Right+                    $ matchFieldValues+                        coerceVariableValue'+                        variableValues+                        variableName+                        variableType+                        defaultValue'+                    $ Just coercedValues+            Nothing -> Left $ UnknownInputType variableDefinition+    forEach _ coercedValuesOrError = coercedValuesOrError+    coerceVariableValue' variableType value'+        = coerceVariableValue variableType value'+        >>= coerceInputLiteral variableType++constValue :: Full.ConstValue -> Type.Value+constValue (Full.ConstInt i) = Type.Int i+constValue (Full.ConstFloat f) = Type.Float f+constValue (Full.ConstString x) = Type.String x+constValue (Full.ConstBoolean b) = Type.Boolean b+constValue Full.ConstNull = Type.Null+constValue (Full.ConstEnum e) = Type.Enum e+constValue (Full.ConstList list) = Type.List $ constValue . Full.node <$> list+constValue (Full.ConstObject o) =+    Type.Object $ HashMap.fromList $ constObjectField <$> o+  where+    constObjectField Full.ObjectField{value = value', ..} =+        (name, constValue $ Full.node value')++subscribe :: (MonadCatch m, Serialize a)+    => Seq (Transform.Selection m)+    -> Schema m+    -> Full.Location+    -> m (Either Error (ResponseEventStream m a))+subscribe fields schema objectLocation+    | Just objectType <- Schema.subscription schema = do+        let types' = Schema.types schema+        sourceStream <-+            createSourceEventStream types' objectType objectLocation fields+        let traverser =+                mapSourceToResponseEvent types' objectType fields+        traverse traverser sourceStream+    | otherwise = pure $ Left+        $ Error "Schema doesn't support subscriptions." [] []++mapSourceToResponseEvent :: (MonadCatch m, Serialize a)     => HashMap Full.Name (Type m)     -> Out.ObjectType m+    -> Seq (Transform.Selection m)+    -> Out.SourceEventStream m+    -> m (ResponseEventStream m a)+mapSourceToResponseEvent types' subscriptionType fields sourceStream+    = pure+    $ sourceStream+    .| mapMC (executeSubscriptionEvent types' subscriptionType fields)++createSourceEventStream :: MonadCatch m+    => HashMap Full.Name (Type m)+    -> Out.ObjectType m     -> Full.Location     -> Seq (Transform.Selection m)-    -> m (Response a)-executeOperation types' objectType objectLocation fields-    = runCollectErrs types'-    $ executeSelectionSet Definition.Null objectType objectLocation fields+    -> m (Either Error (Out.SourceEventStream m))+createSourceEventStream _types subscriptionType objectLocation fields+    | [fieldGroup] <- OrderedMap.elems groupedFieldSet+    , Transform.Field _ fieldName arguments' _ errorLocation <-+        NonEmpty.head fieldGroup+    , Out.ObjectType _ _ _ fieldTypes <- subscriptionType+    , resolverT <- fieldTypes HashMap.! fieldName+    , Out.EventStreamResolver fieldDefinition _ resolver <- resolverT+    , Out.Field _ _fieldType argumentDefinitions <- fieldDefinition =+        case coerceArgumentValues argumentDefinitions arguments' of+            Left _ -> pure+                $ Left+                $ Error "Argument coercion failed." [errorLocation] []+            Right  argumentValues -> left (singleError [errorLocation])+                <$> resolveFieldEventStream Type.Null argumentValues resolver+    | otherwise = pure+        $ Left+        $ Error "Subscription contains more than one field." [objectLocation] []+  where+    groupedFieldSet = collectFields subscriptionType fields+    singleError :: [Full.Location] -> String -> Error+    singleError errorLocations message = Error (Text.pack message) errorLocations [] -rightErrorResponse :: Serialize b => forall a. Error -> Either a (Response b)-rightErrorResponse = Right . Response null . pure+resolveFieldEventStream :: MonadCatch m+    => Type.Value+    -> Type.Subs+    -> Out.Subscribe m+    -> m (Either String (Out.SourceEventStream m))+resolveFieldEventStream result args resolver =+    catch (Right <$> runReaderT resolver context) handleEventStreamError+  where+    handleEventStreamError :: MonadCatch m+        => ResolverException+        -> m (Either String (Out.SourceEventStream m))+    handleEventStreamError = pure . Left . displayException+    context = Type.Context+        { Type.arguments = Type.Arguments args+        , Type.values = result+        }++executeSubscriptionEvent :: (MonadCatch m, Serialize a)+    => HashMap Full.Name (Type m)+    -> Out.ObjectType m+    -> Seq (Transform.Selection m)+    -> Type.Value+    -> m (Response a)+executeSubscriptionEvent types' objectType fields initialValue = do+    (data', errors) <- runWriterT+        $ flip runReaderT types'+        $ runExecutorT+        $ catch (executeSelectionSet fields objectType initialValue [])+        handleException+    pure $ Response data' errors

@@ -1,253 +0,0 @@-{-# LANGUAGE ExplicitForAll #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ViewPatterns #-}--module Language.GraphQL.Execute.Execution-    ( coerceArgumentValues-    , collectFields-    , executeSelectionSet-    ) where--import Control.Monad.Catch (Exception(..), MonadCatch(..))-import Control.Monad.Trans.Class (lift)-import Control.Monad.Trans.Reader (runReaderT)-import Control.Monad.Trans.State (gets)-import Data.List.NonEmpty (NonEmpty(..))-import qualified Data.List.NonEmpty as NonEmpty-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HashMap-import Data.Maybe (fromMaybe)-import Data.Sequence (Seq(..))-import qualified Data.Text as Text-import qualified Language.GraphQL.AST as Full-import Language.GraphQL.Error-import Language.GraphQL.Execute.Coerce-import Language.GraphQL.Execute.Internal-import Language.GraphQL.Execute.OrderedMap (OrderedMap)-import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap-import qualified Language.GraphQL.Execute.Transform as Transform-import qualified Language.GraphQL.Type as Type-import qualified Language.GraphQL.Type.In as In-import qualified Language.GraphQL.Type.Out as Out-import qualified Language.GraphQL.Type.Internal as Internal-import Prelude hiding (null)--resolveFieldValue :: MonadCatch m-    => Type.Value-    -> Type.Subs-    -> Type.Resolve m-    -> Full.Location-    -> CollectErrsT m Type.Value-resolveFieldValue result args resolver location' =-    catch (lift $ runReaderT resolver context) handleFieldError-  where-    handleFieldError :: MonadCatch m-        => ResolverException-        -> CollectErrsT m Type.Value-    handleFieldError e-        = addError Type.Null-        $ Error (Text.pack $ displayException e) [location'] []-    context = Type.Context-        { Type.arguments = Type.Arguments args-        , Type.values = result-        }--collectFields :: Monad m-    => Out.ObjectType m-    -> Seq (Transform.Selection m)-    -> OrderedMap (NonEmpty (Transform.Field m))-collectFields objectType = foldl forEach OrderedMap.empty-  where-    forEach groupedFields (Transform.SelectionField field) =-        let responseKey = aliasOrName field-         in OrderedMap.insert responseKey (field :| []) groupedFields-    forEach groupedFields (Transform.SelectionFragment selectionFragment)-        | Transform.Fragment fragmentType fragmentSelectionSet <- selectionFragment-        , Internal.doesFragmentTypeApply fragmentType objectType =-            let fragmentGroupedFieldSet = collectFields objectType fragmentSelectionSet-             in groupedFields <> fragmentGroupedFieldSet-        | otherwise = groupedFields--aliasOrName :: forall m. Transform.Field m -> Full.Name-aliasOrName (Transform.Field alias name _ _ _) = fromMaybe name alias--resolveAbstractType :: Monad m-    => Internal.AbstractType m-    -> Type.Subs-    -> CollectErrsT m (Maybe (Out.ObjectType m))-resolveAbstractType abstractType values'-    | Just (Type.String typeName) <- HashMap.lookup "__typename" values' = do-        types' <- gets types-        case HashMap.lookup typeName types' of-            Just (Internal.ObjectType objectType) ->-                if Internal.instanceOf objectType abstractType-                    then pure $ Just objectType-                    else pure Nothing-            _ -> pure Nothing-    | otherwise = pure Nothing--executeField :: (MonadCatch m, Serialize a)-    => Out.Resolver m-    -> Type.Value-    -> NonEmpty (Transform.Field m)-    -> CollectErrsT m a-executeField fieldResolver prev fields-    | Out.ValueResolver fieldDefinition resolver <- fieldResolver =-        executeField' fieldDefinition resolver-    | Out.EventStreamResolver fieldDefinition resolver _ <- fieldResolver =-        executeField' fieldDefinition resolver-  where-    executeField' fieldDefinition resolver = do-        let Out.Field _ fieldType argumentDefinitions = fieldDefinition-        let Transform.Field _ _ arguments' _ location' = NonEmpty.head fields-        case coerceArgumentValues argumentDefinitions arguments' of-            Left [] ->-                let errorMessage = "Not all required arguments are specified."-                 in addError null $ Error errorMessage [location'] []-            Left errorLocations -> addError null-                $ Error "Argument coercing failed." errorLocations []-            Right argumentValues -> do-                answer <- resolveFieldValue prev argumentValues resolver location'-                completeValue fieldType fields answer--completeValue :: (MonadCatch m, Serialize a)-    => Out.Type m-    -> NonEmpty (Transform.Field m)-    -> Type.Value-    -> CollectErrsT m a-completeValue (Out.isNonNullType -> False) _ Type.Null = pure null-completeValue outputType@(Out.ListBaseType listType) fields (Type.List list)-    = traverse (completeValue listType fields) list-    >>= coerceResult outputType (firstFieldLocation fields) . List-completeValue outputType@(Out.ScalarBaseType _) fields (Type.Int int) =-    coerceResult outputType (firstFieldLocation fields) $ Int int-completeValue outputType@(Out.ScalarBaseType _) fields (Type.Boolean boolean) =-    coerceResult outputType (firstFieldLocation fields) $ Boolean boolean-completeValue outputType@(Out.ScalarBaseType _) fields (Type.Float float) =-    coerceResult outputType (firstFieldLocation fields) $ Float float-completeValue outputType@(Out.ScalarBaseType _) fields (Type.String string) =-    coerceResult outputType (firstFieldLocation fields) $ String string-completeValue outputType@(Out.EnumBaseType enumType) fields (Type.Enum enum) =-    let Type.EnumType _ _ enumMembers = enumType-        location = firstFieldLocation fields-     in if HashMap.member enum enumMembers-        then coerceResult outputType location $ Enum enum-        else addError null $ Error "Enum value completion failed." [location] []-completeValue (Out.ObjectBaseType objectType) fields result-    = executeSelectionSet result objectType (firstFieldLocation fields)-    $ mergeSelectionSets fields-completeValue (Out.InterfaceBaseType interfaceType) fields result-    | Type.Object objectMap <- result = do-        let abstractType = Internal.AbstractInterfaceType interfaceType-        let location = firstFieldLocation fields-        concreteType <- resolveAbstractType abstractType objectMap-        case concreteType of-            Just objectType -> executeSelectionSet result objectType location-                $ mergeSelectionSets fields-            Nothing -> addError null-                $ Error "Interface value completion failed." [location] []-completeValue (Out.UnionBaseType unionType) fields result-    | Type.Object objectMap <- result = do-        let abstractType = Internal.AbstractUnionType unionType-        let  location = firstFieldLocation fields-        concreteType <- resolveAbstractType abstractType objectMap-        case concreteType of-            Just objectType -> executeSelectionSet result objectType-                location $ mergeSelectionSets fields-            Nothing -> addError null-                $ Error "Union value completion failed." [location] []-completeValue _ (Transform.Field _ _ _ _ location :| _) _ =-    addError null $ Error "Value completion failed." [location] []--mergeSelectionSets :: MonadCatch m-    => NonEmpty (Transform.Field m)-    -> Seq (Transform.Selection m)-mergeSelectionSets = foldr forEach mempty-  where-    forEach (Transform.Field _ _ _ fieldSelectionSet _) selectionSet =-        selectionSet <> fieldSelectionSet--firstFieldLocation :: MonadCatch m => NonEmpty (Transform.Field m) -> Full.Location-firstFieldLocation (Transform.Field _ _ _ _ fieldLocation :| _) = fieldLocation--coerceResult :: (MonadCatch m, Serialize a)-    => Out.Type m-    -> Full.Location-    -> Output a-    -> CollectErrsT m a-coerceResult outputType parentLocation result-    | Just serialized <- serialize outputType result = pure serialized-    | otherwise = addError null-        $ Error "Result coercion failed." [parentLocation] []---- | Takes an 'Out.ObjectType' and a list of 'Transform.Selection's and applies--- each field to each 'Transform.Selection'. Resolves into a value containing--- the resolved 'Transform.Selection', or a null value and error information.-executeSelectionSet :: (MonadCatch m, Serialize a)-    => Type.Value-    -> Out.ObjectType m-    -> Full.Location-    -> Seq (Transform.Selection m)-    -> CollectErrsT m a-executeSelectionSet result objectType@(Out.ObjectType _ _ _ resolvers) objectLocation selectionSet = do-    let fields = collectFields objectType selectionSet-    resolvedValues <- OrderedMap.traverseMaybe forEach fields-    coerceResult (Out.NonNullObjectType objectType) objectLocation-        $ Object resolvedValues-  where-    forEach fields@(field :| _) =-        let Transform.Field _ name _ _ _ = field-         in traverse (tryResolver fields) $ lookupResolver name-    lookupResolver = flip HashMap.lookup resolvers-    tryResolver fields resolver =-        executeField resolver result fields >>= lift . pure--coerceArgumentValues-    :: HashMap Full.Name In.Argument-    -> HashMap Full.Name (Full.Node Transform.Input)-    -> Either [Full.Location] Type.Subs-coerceArgumentValues argumentDefinitions argumentNodes =-    HashMap.foldrWithKey forEach (pure mempty) argumentDefinitions-  where-    forEach argumentName (In.Argument _ variableType defaultValue) = \case-        Right resultMap-            | Just matchedValues-                <- matchFieldValues' argumentName variableType defaultValue $ Just resultMap-                -> Right matchedValues-            | otherwise -> Left $ generateError argumentName []-        Left errorLocations-            | Just _-                <- matchFieldValues' argumentName variableType defaultValue $ pure mempty-                -> Left errorLocations-            | otherwise -> Left $ generateError argumentName errorLocations-    generateError argumentName errorLocations =-        case HashMap.lookup argumentName argumentNodes of-            Just (Full.Node _ errorLocation) -> [errorLocation]-            Nothing -> errorLocations-    matchFieldValues' = matchFieldValues coerceArgumentValue (Full.node <$> argumentNodes)-    coerceArgumentValue inputType (Transform.Int integer) =-        coerceInputLiteral inputType (Type.Int integer)-    coerceArgumentValue inputType (Transform.Boolean boolean) =-        coerceInputLiteral inputType (Type.Boolean boolean)-    coerceArgumentValue inputType (Transform.String string) =-        coerceInputLiteral inputType (Type.String string)-    coerceArgumentValue inputType (Transform.Float float) =-        coerceInputLiteral inputType (Type.Float float)-    coerceArgumentValue inputType (Transform.Enum enum) =-        coerceInputLiteral inputType (Type.Enum enum)-    coerceArgumentValue inputType Transform.Null-        | In.isNonNullType inputType = Nothing-        | otherwise = coerceInputLiteral inputType Type.Null-    coerceArgumentValue (In.ListBaseType inputType) (Transform.List list) =-        let coerceItem = coerceInputLiteral inputType-         in Type.List <$> traverse coerceItem list-    coerceArgumentValue (In.InputObjectBaseType inputType) (Transform.Object object)-        | In.InputObjectType _ _ inputFields <- inputType = -            let go = forEachField object-                resultMap = HashMap.foldrWithKey go (pure mempty) inputFields-             in Type.Object <$> resultMap-    coerceArgumentValue _ (Transform.Variable variable) = pure variable-    coerceArgumentValue _ _ = Nothing-    forEachField object variableName (In.InputField _ variableType defaultValue) =-        matchFieldValues coerceArgumentValue object variableName variableType defaultValue

@@ -1,31 +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 DuplicateRecordFields #-}-{-# LANGUAGE ExplicitForAll #-}-{-# LANGUAGE NamedFieldPuns #-}--module Language.GraphQL.Execute.Internal-    ( addError-    , singleError-    ) where--import Control.Monad.Trans.State (modify)-import Control.Monad.Catch (MonadCatch)-import Data.Sequence ((|>))-import qualified Data.Text as Text-import qualified Language.GraphQL.AST as Full-import Language.GraphQL.Error (CollectErrsT, Error(..), Resolution(..))-import Prelude hiding (null)--addError :: MonadCatch m => forall a. a -> Error -> CollectErrsT m a-addError returnValue error' = modify appender >> pure returnValue-  where-   appender :: Resolution m -> Resolution m-   appender resolution@Resolution{ errors } = resolution-       { errors = errors |> error'-       }--singleError :: [Full.Location] -> String -> Error-singleError errorLocations message = Error (Text.pack message) errorLocations []

@@ -1,113 +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 ExplicitForAll #-}-{-# LANGUAGE OverloadedStrings #-}-module Language.GraphQL.Execute.Subscribe-    ( subscribe-    ) where--import Conduit-import Control.Arrow (left)-import Control.Monad.Catch (Exception(..), MonadCatch(..))-import Control.Monad.Trans.Reader (ReaderT(..), runReaderT)-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HashMap-import qualified Data.List.NonEmpty as NonEmpty-import Data.Sequence (Seq(..))-import qualified Language.GraphQL.AST as Full-import Language.GraphQL.Execute.Coerce-import Language.GraphQL.Execute.Execution-import Language.GraphQL.Execute.Internal-import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap-import qualified Language.GraphQL.Execute.Transform as Transform-import Language.GraphQL.Error-    ( Error(..)-    , ResolverException-    , Response-    , ResponseEventStream-    , runCollectErrs-    )-import qualified Language.GraphQL.Type.Definition as Definition-import qualified Language.GraphQL.Type as Type-import qualified Language.GraphQL.Type.Out as Out-import Language.GraphQL.Type.Schema--subscribe :: (MonadCatch m, Serialize a)-    => HashMap Full.Name (Type m)-    -> Out.ObjectType m-    -> Full.Location-    -> Seq (Transform.Selection m)-    -> m (Either Error (ResponseEventStream m a))-subscribe types' objectType objectLocation fields = do-    sourceStream <--        createSourceEventStream types' objectType objectLocation fields-    let traverser =-            mapSourceToResponseEvent types' objectType objectLocation fields-    traverse traverser sourceStream--mapSourceToResponseEvent :: (MonadCatch m, Serialize a)-    => HashMap Full.Name (Type m)-    -> Out.ObjectType m-    -> Full.Location-    -> Seq (Transform.Selection m)-    -> Out.SourceEventStream m-    -> m (ResponseEventStream m a)-mapSourceToResponseEvent types' subscriptionType objectLocation fields sourceStream-    = pure-    $ sourceStream-    .| mapMC (executeSubscriptionEvent types' subscriptionType objectLocation fields)--createSourceEventStream :: MonadCatch m-    => HashMap Full.Name (Type m)-    -> Out.ObjectType m-    -> Full.Location-    -> Seq (Transform.Selection m)-    -> m (Either Error (Out.SourceEventStream m))-createSourceEventStream _types subscriptionType objectLocation fields-    | [fieldGroup] <- OrderedMap.elems groupedFieldSet-    , Transform.Field _ fieldName arguments' _ errorLocation <- NonEmpty.head fieldGroup-    , Out.ObjectType _ _ _ fieldTypes <- subscriptionType-    , resolverT <- fieldTypes HashMap.! fieldName-    , Out.EventStreamResolver fieldDefinition _ resolver <- resolverT-    , Out.Field _ _fieldType argumentDefinitions <- fieldDefinition =-        case coerceArgumentValues argumentDefinitions arguments' of-            Left _ -> pure-                $ Left-                $ Error "Argument coercion failed." [errorLocation] []-            Right  argumentValues -> left (singleError [errorLocation])-                <$> resolveFieldEventStream Type.Null argumentValues resolver-    | otherwise = pure-        $ Left-        $ Error "Subscription contains more than one field." [objectLocation] []-  where-    groupedFieldSet = collectFields subscriptionType fields--resolveFieldEventStream :: MonadCatch m-    => Type.Value-    -> Type.Subs-    -> Out.Subscribe m-    -> m (Either String (Out.SourceEventStream m))-resolveFieldEventStream result args resolver =-    catch (Right <$> runReaderT resolver context) handleEventStreamError-  where-    handleEventStreamError :: MonadCatch m-        => ResolverException-        -> m (Either String (Out.SourceEventStream m))-    handleEventStreamError = pure . Left . displayException-    context = Type.Context-        { Type.arguments = Type.Arguments args-        , Type.values = result-        }--executeSubscriptionEvent :: (MonadCatch m, Serialize a)-    => HashMap Full.Name (Type m)-    -> Out.ObjectType m-    -> Full.Location-    -> Seq (Transform.Selection m)-    -> Definition.Value-    -> m (Response a)-executeSubscriptionEvent types' objectType objectLocation fields initialValue-    = runCollectErrs types'-    $ executeSelectionSet initialValue objectType objectLocation fields

@@ -6,7 +6,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TupleSections #-}+{-# LANGUAGE NamedFieldPuns #-}  -- | After the document is parsed, before getting executed, the AST is -- transformed into a similar, simpler AST. Performed transformations include:@@ -21,65 +21,87 @@ -- This module is also responsible for smaller rewrites that touch only parts of -- the original AST. module Language.GraphQL.Execute.Transform-    ( Document(..)-    , Field(..)+    ( Field(..)     , Fragment(..)     , Input(..)     , Operation(..)-    , QueryError(..)+    , Replacement(..)     , Selection(..)+    , TransformT(..)     , document+    , transform     ) where -import Control.Monad (foldM, unless)-import Control.Monad.Trans.Class (lift)-import Control.Monad.Trans.State (State, evalStateT, gets, modify)-import Data.Foldable (find)-import Data.Functor.Identity (Identity(..))+import Control.Monad (foldM)+import Control.Monad.Catch (MonadCatch(..), MonadThrow(..))+import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad.Trans.Reader (ReaderT(..), local)+import qualified Control.Monad.Trans.Reader as Reader+import Data.Bifunctor (first)+import Data.Functor ((<&>)) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap+import Data.HashSet (HashSet)+import qualified Data.HashSet as HashSet import Data.Int (Int32)-import Data.Maybe (fromMaybe)-import Data.List.NonEmpty (NonEmpty(..))+import Data.List (intercalate) import qualified Data.List.NonEmpty as NonEmpty-import Data.Sequence (Seq, (<|), (><))+import Data.Maybe (fromMaybe, isJust)+import Data.Sequence (Seq, (><))+import qualified Data.Sequence as Seq import Data.Text (Text) import qualified Data.Text as Text-import qualified Language.GraphQL.AST as Full-import Language.GraphQL.AST (Name)-import qualified Language.GraphQL.Execute.Coerce as Coerce-import qualified Language.GraphQL.Type.Definition as Definition+import qualified Language.GraphQL.AST.Document as Full+import Language.GraphQL.Type.Schema (Type) import qualified Language.GraphQL.Type as Type+import qualified Language.GraphQL.Type.Definition as Definition import qualified Language.GraphQL.Type.Internal as Type-import qualified Language.GraphQL.Type.Out as Out-import qualified Language.GraphQL.Type.Schema as Schema+import Numeric (showFloat)  -- | Associates a fragment name with a list of 'Field's. data Replacement m = Replacement-    { fragments :: HashMap Full.Name (Fragment m)-    , fragmentDefinitions :: FragmentDefinitions-    , variableValues :: Type.Subs-    , types :: HashMap Full.Name (Schema.Type m)+    { variableValues :: Type.Subs+    , fragmentDefinitions :: HashMap Full.Name Full.FragmentDefinition+    , visitedFragments :: HashSet Full.Name+    , types :: HashMap Full.Name (Type m)     } -type FragmentDefinitions = HashMap Full.Name Full.FragmentDefinition+newtype TransformT m a = TransformT+    { runTransformT :: ReaderT (Replacement m) m a+    } --- | Represents fragments and inline fragments.-data Fragment m-    = Fragment (Type.CompositeType m) (Seq (Selection m))+instance Functor m => Functor (TransformT m) where+    fmap f = TransformT . fmap f . runTransformT --- | Single selection element.-data Selection m-    = SelectionFragment (Fragment m)-    | SelectionField (Field m)+instance Applicative m => Applicative (TransformT m) where+    pure = TransformT . pure+    TransformT f <*> TransformT x = TransformT $ f <*> x +instance Monad m => Monad (TransformT m) where+    TransformT x >>= f = TransformT $ x >>= runTransformT . f++instance MonadTrans TransformT where+    lift = TransformT . lift++instance MonadThrow m => MonadThrow (TransformT m) where+    throwM = lift . throwM++instance MonadCatch m => MonadCatch (TransformT m) where+  catch (TransformT stack) handler =+      TransformT $ catch stack $ runTransformT . handler++asks :: Monad m => forall a. (Replacement m -> a) -> TransformT m a+asks = TransformT . Reader.asks+ -- | GraphQL has 3 operation types: queries, mutations and subscribtions. data Operation m-    = Query (Maybe Text) (Seq (Selection m)) Full.Location-    | Mutation (Maybe Text) (Seq (Selection m)) Full.Location-    | Subscription (Maybe Text) (Seq (Selection m)) Full.Location+    = Operation Full.OperationType (Seq (Selection m)) Full.Location --- | Single GraphQL field.+-- | Field or inlined fragment.+data Selection m+    = FieldSelection (Field m)+    | FragmentSelection (Fragment m)+ data Field m = Field     (Maybe Full.Name)     Full.Name@@ -87,339 +109,217 @@     (Seq (Selection m))     Full.Location --- | Contains the operation to be executed along with its root type.-data Document m = Document-    (HashMap Full.Name (Schema.Type m)) (Out.ObjectType m) (Operation m)--data OperationDefinition = OperationDefinition-    Full.OperationType-    (Maybe Full.Name)-    [Full.VariableDefinition]-    [Full.Directive]-    Full.SelectionSet-    Full.Location---- | Query error types.-data QueryError-    = OperationNotFound Text-    | OperationNameRequired-    | CoercionError-    | EmptyDocument-    | UnsupportedRootOperation--instance Show QueryError where-    show (OperationNotFound operationName) = unwords-        ["Operation", Text.unpack operationName, "couldn't be found in the document."]-    show OperationNameRequired = "Missing operation name."-    show CoercionError = "Coercion error."-    show EmptyDocument =-        "The document doesn't contain any executable operations."-    show UnsupportedRootOperation =-        "Root operation type couldn't be found in the schema."+data Fragment m = Fragment+    (Type.CompositeType m) (Seq (Selection m)) Full.Location  data Input-    = Int Int32+    = Variable Type.Value+    | Int Int32     | Float Double     | String Text     | Boolean Bool     | Null-    | Enum Name-    | List [Type.Value]-    | Object (HashMap Name Input)-    | Variable Type.Value-    deriving (Eq, Show)--getOperation-    :: Maybe Full.Name-    -> NonEmpty OperationDefinition-    -> Either QueryError OperationDefinition-getOperation Nothing (operation' :| []) = pure operation'-getOperation Nothing _ = Left OperationNameRequired-getOperation (Just operationName) operations-    | Just operation' <- find matchingName operations = pure operation'-    | otherwise = Left $ OperationNotFound operationName-  where-    matchingName (OperationDefinition _ name _ _ _ _) =-        name == Just operationName--coerceVariableValues :: Coerce.VariableValue a-    => forall m-    . HashMap Full.Name (Schema.Type m)-    -> OperationDefinition-    -> HashMap.HashMap Full.Name a-    -> Either QueryError Type.Subs-coerceVariableValues types operationDefinition variableValues =-    let OperationDefinition _ _ variableDefinitions _ _ _ = operationDefinition-     in maybe (Left CoercionError) Right-        $ foldr forEach (Just HashMap.empty) variableDefinitions-  where-    forEach variableDefinition coercedValues = do-        let Full.VariableDefinition variableName variableTypeName defaultValue _ =-                variableDefinition-        let defaultValue' = constValue . Full.node <$> defaultValue-        variableType <- Type.lookupInputType variableTypeName types+    | Enum Full.Name+    | List [Input]+    | Object (HashMap Full.Name Input)+    deriving Eq -        Coerce.matchFieldValues-            coerceVariableValue'-            variableValues-            variableName-            variableType-            defaultValue'-            coercedValues-    coerceVariableValue' variableType value'-        = Coerce.coerceVariableValue variableType value'-        >>= Coerce.coerceInputLiteral variableType+instance Show Input where+    showList = mappend . showList'+      where+        showList' list = "[" ++ intercalate ", " (show <$> list) ++ "]"+    show (Int integer) = show integer+    show (Float float') = showFloat float' mempty+    show (String text) = "\"" <> Text.foldr (mappend . Full.escape) "\"" text+    show (Boolean boolean') = show boolean'+    show Null = "null"+    show (Enum name) = Text.unpack name+    show (List list) = show list+    show (Object fields) = unwords+        [ "{"+        , intercalate ", " (HashMap.foldrWithKey showObject [] fields)+        , "}"+        ]+      where+        showObject key value accumulator =+            concat [Text.unpack key, ": ", show value] : accumulator+    show variableValue = show variableValue -constValue :: Full.ConstValue -> Type.Value-constValue (Full.ConstInt i) = Type.Int i-constValue (Full.ConstFloat f) = Type.Float f-constValue (Full.ConstString x) = Type.String x-constValue (Full.ConstBoolean b) = Type.Boolean b-constValue Full.ConstNull = Type.Null-constValue (Full.ConstEnum e) = Type.Enum e-constValue (Full.ConstList list) = Type.List $ constValue . Full.node <$> list-constValue (Full.ConstObject o) =-    Type.Object $ HashMap.fromList $ constObjectField <$> o+-- | Extracts operations and fragment definitions of the document.+document :: Full.Document+    -> ([Full.OperationDefinition], HashMap Full.Name Full.FragmentDefinition)+document = foldr filterOperation ([], HashMap.empty)   where-    constObjectField Full.ObjectField{value = value', ..} =-        (name, constValue $ Full.node value')+    filterOperation (Full.ExecutableDefinition executableDefinition) accumulator+        | Full.DefinitionOperation operationDefinition' <- executableDefinition =+            first (operationDefinition' :) accumulator+        | Full.DefinitionFragment fragmentDefinition <- executableDefinition+        , Full.FragmentDefinition fragmentName _ _ _ _ <- fragmentDefinition =+            HashMap.insert fragmentName fragmentDefinition <$> accumulator+    filterOperation _ accumulator = accumulator -- Type system definitions.  -- | Rewrites the original syntax tree into an intermediate representation used--- for query execution.-document :: Coerce.VariableValue a-    => forall m-    . Type.Schema m-    -> Maybe Full.Name-    -> HashMap Full.Name a-    -> Full.Document-    -> Either QueryError (Document m)-document schema operationName subs ast = do-    let referencedTypes = Schema.types schema--    (operations, fragmentTable) <- defragment ast-    chosenOperation <- getOperation operationName operations-    coercedValues <- coerceVariableValues referencedTypes chosenOperation subs+-- for the query execution.+transform :: Monad m => Full.OperationDefinition -> TransformT m (Operation m)+transform (Full.OperationDefinition operationType _ _ _ selectionSet' operationLocation) = do+    transformedSelections <- selectionSet selectionSet'+    pure $ Operation operationType transformedSelections operationLocation+transform (Full.SelectionSet selectionSet' operationLocation) = do+    transformedSelections <- selectionSet selectionSet'+    pure $ Operation Full.Query transformedSelections operationLocation -    let replacement = Replacement-            { fragments = HashMap.empty-            , fragmentDefinitions = fragmentTable-            , variableValues = coercedValues-            , types = referencedTypes-            }-    case chosenOperation of-        OperationDefinition Full.Query _ _ _ _ _ ->-            pure $ Document referencedTypes (Schema.query schema)-                $ operation chosenOperation replacement-        OperationDefinition Full.Mutation _ _ _ _ _-            | Just mutationType <- Schema.mutation schema ->-                pure $ Document referencedTypes mutationType-                    $ operation chosenOperation replacement-        OperationDefinition Full.Subscription _ _ _ _ _-            | Just subscriptionType <- Schema.subscription schema ->-                pure $ Document referencedTypes subscriptionType-                    $ operation chosenOperation replacement-        _ -> Left UnsupportedRootOperation+selectionSet :: Monad m => Full.SelectionSet -> TransformT m (Seq (Selection m))+selectionSet = selectionSetOpt . NonEmpty.toList -defragment-    :: Full.Document-    -> Either QueryError (NonEmpty OperationDefinition, FragmentDefinitions)-defragment ast =-    let (operations, fragmentTable) = foldr defragment' ([], HashMap.empty) ast-        nonEmptyOperations = NonEmpty.nonEmpty operations-        emptyDocument = Left EmptyDocument-     in (, fragmentTable) <$> maybe emptyDocument Right nonEmptyOperations+selectionSetOpt :: Monad m => Full.SelectionSetOpt -> TransformT m (Seq (Selection m))+selectionSetOpt = foldM go Seq.empty   where-    defragment' definition (operations, fragments')-        | (Full.ExecutableDefinition executable) <- definition-        , (Full.DefinitionOperation operation') <- executable =-            (transform operation' : operations, fragments')-        | (Full.ExecutableDefinition executable) <- definition-        , (Full.DefinitionFragment fragment) <- executable-        , (Full.FragmentDefinition name _ _ _ _) <- fragment =-            (operations, HashMap.insert name fragment fragments')-    defragment' _ acc = acc-    transform = \case-        Full.OperationDefinition type' name variables directives' selections location ->-            OperationDefinition type' name variables directives' selections location-        Full.SelectionSet selectionSet location ->-            OperationDefinition Full.Query Nothing mempty mempty selectionSet location+    go accumulatedSelections currentSelection =+        selection currentSelection <&> (accumulatedSelections ><) --- * Operation+selection :: Monad m => Full.Selection -> TransformT m (Seq (Selection m))+selection (Full.FieldSelection field') =+    maybeToSelectionSet FieldSelection $ field field'+selection (Full.FragmentSpreadSelection fragmentSpread') =+    maybeToSelectionSet FragmentSelection $ fragmentSpread fragmentSpread'+selection (Full.InlineFragmentSelection inlineFragment') =+    either id (pure . FragmentSelection) <$> inlineFragment inlineFragment' -operation :: OperationDefinition -> Replacement m -> Operation m-operation operationDefinition replacement-    = runIdentity-    $ evalStateT (collectFragments >> transform operationDefinition) replacement-  where-    transform (OperationDefinition Full.Query name _ _ sels location) =-        flip (Query name) location <$> appendSelection sels-    transform (OperationDefinition Full.Mutation name _ _ sels location) =-        flip (Mutation name) location <$> appendSelection sels-    transform (OperationDefinition Full.Subscription name _ _ sels location) =-        flip (Subscription name) location <$> appendSelection sels+maybeToSelectionSet :: Monad m+    => forall a+    . (a -> Selection m)+    -> TransformT m (Maybe a)+    -> TransformT m (Seq (Selection m))+maybeToSelectionSet selectionType = fmap (maybe Seq.empty $ pure . selectionType) --- * Selection+directives :: Monad m => [Full.Directive] -> TransformT m (Maybe [Definition.Directive])+directives = fmap Type.selection . traverse directive -selection-    :: Full.Selection-    ->  State (Replacement m) (Either (Seq (Selection m)) (Selection m))-selection (Full.FieldSelection fieldSelection) =-    maybe (Left mempty) (Right . SelectionField) <$> field fieldSelection-selection (Full.FragmentSpreadSelection fragmentSelection)-    = maybe (Left mempty) (Right . SelectionFragment)-    <$> fragmentSpread fragmentSelection-selection (Full.InlineFragmentSelection fragmentSelection) =-    inlineFragment fragmentSelection+inlineFragment :: Monad m+    => Full.InlineFragment+    -> TransformT m (Either (Seq (Selection m)) (Fragment m))+inlineFragment (Full.InlineFragment maybeCondition directives' selectionSet' location)+    | Just typeCondition <- maybeCondition = do+        transformedSelections <- selectionSet selectionSet'+        transformedDirectives <- directives directives'+        maybeFragmentType <- asks+            $ Type.lookupTypeCondition typeCondition+            . types+        pure $ case transformedDirectives >> maybeFragmentType of+            Just fragmentType -> Right+                $ Fragment fragmentType transformedSelections location+            Nothing -> Left Seq.empty+    | otherwise = do+        transformedSelections <- selectionSet selectionSet'+        transformedDirectives <- directives directives'+        pure $ if isJust transformedDirectives+            then Left transformedSelections+            else Left Seq.empty -field :: Full.Field ->  State (Replacement m) (Maybe (Field m))-field (Full.Field alias name arguments' directives' selections location) = do-    fieldArguments <- foldM go HashMap.empty arguments'-    fieldSelections <- appendSelection selections-    fieldDirectives <- Definition.selection <$> directives directives'-    let field' = Field alias name fieldArguments fieldSelections location-    pure $ field' <$ fieldDirectives+fragmentSpread :: Monad m => Full.FragmentSpread -> TransformT m (Maybe (Fragment m))+fragmentSpread (Full.FragmentSpread spreadName directives' location) = do+    transformedDirectives <- directives directives'+    visitedFragment <- asks $ HashSet.member spreadName . visitedFragments+    possibleFragmentDefinition <- asks+        $ HashMap.lookup spreadName+        . fragmentDefinitions+    case transformedDirectives >> possibleFragmentDefinition of+        Just (Full.FragmentDefinition _ typeCondition _ selections _)+            | visitedFragment -> pure Nothing+            | otherwise -> do+                fragmentType <- asks+                    $ Type.lookupTypeCondition typeCondition+                    . types+                traverse (traverseSelections selections) fragmentType+        Nothing -> pure Nothing   where-    go arguments (Full.Argument name' (Full.Node value' _) location') = do-        objectFieldValue <-  input value'-        case objectFieldValue of-            Just fieldValue ->-                let argumentNode = Full.Node fieldValue location'-                 in pure $ HashMap.insert name' argumentNode arguments-            Nothing -> pure arguments--fragmentSpread-    :: Full.FragmentSpread-    -> State (Replacement m) (Maybe (Fragment m))-fragmentSpread (Full.FragmentSpread name directives' _) = do-    spreadDirectives <- Definition.selection <$> directives directives'-    fragments' <- gets fragments--    fragmentDefinitions' <- gets fragmentDefinitions-    case HashMap.lookup name fragments' of-        Just definition -> lift $ pure $ definition <$ spreadDirectives-        Nothing-            | Just definition <- HashMap.lookup name fragmentDefinitions' -> do-                fragDef <- fragmentDefinition definition-                case fragDef of-                    Just fragment -> lift $ pure $ fragment <$ spreadDirectives-                    _ -> lift $ pure  Nothing-            | otherwise -> lift $ pure  Nothing+    traverseSelections selections typeCondition = do+        transformedSelections <- TransformT+            $ local fragmentInserter+            $ runTransformT+            $ selectionSet selections+        pure $ Fragment typeCondition transformedSelections location+    fragmentInserter replacement@Replacement{ visitedFragments } = replacement+        { visitedFragments = HashSet.insert spreadName visitedFragments } -inlineFragment-    :: Full.InlineFragment-    ->  State (Replacement m) (Either (Seq (Selection m)) (Selection m))-inlineFragment (Full.InlineFragment type' directives' selections _) = do-    fragmentDirectives <- Definition.selection <$> directives directives'-    case fragmentDirectives of-        Nothing -> pure $ Left mempty-        _ -> do-            fragmentSelectionSet <- appendSelection selections+field :: Monad m => Full.Field -> TransformT m (Maybe (Field m))+field (Full.Field alias' name' arguments' directives' selectionSet' location') = do+    transformedSelections <- selectionSetOpt selectionSet'+    transformedDirectives <- directives directives'+    transformedArguments <- arguments arguments'+    let transformedField = Field+            alias'+            name'+            transformedArguments+            transformedSelections+            location'+    pure $ transformedDirectives >> pure transformedField -            case type' of-                Nothing -> pure $ Left fragmentSelectionSet-                Just typeName -> do-                    types' <- gets types-                    case Type.lookupTypeCondition typeName types' of-                        Just typeCondition -> pure $-                            selectionFragment typeCondition fragmentSelectionSet-                        Nothing -> pure $ Left mempty+arguments :: Monad m => [Full.Argument] -> TransformT m (HashMap Full.Name (Full.Node Input))+arguments = foldM go HashMap.empty   where-    selectionFragment typeName = Right-        . SelectionFragment-        . Fragment typeName+    go accumulator (Full.Argument name' valueNode argumentLocation) = do+        let replaceLocation = flip Full.Node argumentLocation . Full.node+        argumentValue <- fmap replaceLocation <$> node valueNode+        pure $ insertIfGiven name' argumentValue accumulator -appendSelection :: Traversable t-    => t Full.Selection-    ->  State (Replacement m) (Seq (Selection m))-appendSelection = foldM go mempty+directive :: Monad m => Full.Directive -> TransformT m Definition.Directive+directive (Full.Directive name' arguments' _)+    = Definition.Directive name'+    . Type.Arguments+    <$> foldM go HashMap.empty arguments'   where-    go acc sel = append acc <$> selection sel-    append acc (Left list) = list >< acc-    append acc (Right one) = one <| acc+    go accumulator (Full.Argument argumentName Full.Node{ node = node' } _) = do+        transformedValue <- directiveValue node'+        pure $ HashMap.insert argumentName transformedValue accumulator -directives :: [Full.Directive] ->  State (Replacement m) [Definition.Directive]-directives = traverse directive+directiveValue :: Monad m => Full.Value -> TransformT m Type.Value+directiveValue = \case+    (Full.Variable name') -> asks+        $ HashMap.lookupDefault Type.Null name'+        . variableValues+    (Full.Int integer) -> pure $ Type.Int integer+    (Full.Float double) -> pure $ Type.Float double+    (Full.String string) -> pure $ Type.String string+    (Full.Boolean boolean) -> pure $ Type.Boolean boolean+    Full.Null -> pure Type.Null+    (Full.Enum enum) -> pure $ Type.Enum enum+    (Full.List list) -> Type.List <$> traverse directiveNode list+    (Full.Object objectFields) ->+        Type.Object <$> foldM objectField HashMap.empty objectFields   where-    directive (Full.Directive directiveName directiveArguments _)-        = Definition.Directive directiveName . Type.Arguments-        <$> foldM go HashMap.empty directiveArguments-    go arguments (Full.Argument name (Full.Node value' _) _) = do-        substitutedValue <- value value'-        return $ HashMap.insert name substitutedValue arguments---- * Fragment replacement---- | Extract fragment definitions into a single 'HashMap'.-collectFragments ::  State (Replacement m) ()-collectFragments = do-    fragDefs <- gets fragmentDefinitions-    let nextValue = head $ HashMap.elems fragDefs-    unless (HashMap.null fragDefs) $ do-        _ <- fragmentDefinition nextValue-        collectFragments--fragmentDefinition-    :: Full.FragmentDefinition-    ->  State (Replacement m) (Maybe (Fragment m))-fragmentDefinition (Full.FragmentDefinition name type' _ selections _) = do-    modify deleteFragmentDefinition-    fragmentSelection <- appendSelection selections-    types' <- gets types+    directiveNode Full.Node{ node = node'} = directiveValue node'+    objectField accumulator Full.ObjectField{ name, value } = do+        transformedValue <- directiveNode value+        pure $ HashMap.insert name transformedValue accumulator -    case Type.lookupTypeCondition type' types' of-        Just compositeType -> do-            let newValue = Fragment compositeType fragmentSelection-            modify $ insertFragment newValue-            lift $ pure $ Just newValue-        _ -> lift $ pure Nothing+input :: Monad m => Full.Value -> TransformT m (Maybe Input)+input (Full.Variable name') =+    asks (HashMap.lookup name' . variableValues) <&> fmap Variable+input (Full.Int integer) = pure $ Just $ Int integer+input (Full.Float double) = pure $ Just $ Float double+input (Full.String string) = pure $ Just $ String string+input (Full.Boolean boolean) = pure $ Just $ Boolean boolean+input Full.Null = pure $ Just Null+input (Full.Enum enum) = pure $ Just $ Enum enum+input (Full.List list) = Just . List+    <$> traverse (fmap (fromMaybe Null) . input . Full.node) list+input (Full.Object objectFields) = Just . Object+    <$> foldM objectField HashMap.empty objectFields   where-    deleteFragmentDefinition replacement@Replacement{..} =-        let newDefinitions = HashMap.delete name fragmentDefinitions-         in replacement{ fragmentDefinitions = newDefinitions }-    insertFragment newValue replacement@Replacement{..} =-        let newFragments = HashMap.insert name newValue fragments-         in replacement{ fragments = newFragments }+    objectField accumulator Full.ObjectField{..} = do+        objectFieldValue <- fmap Full.node <$> node value+        pure $ insertIfGiven name objectFieldValue accumulator -value :: forall m. Full.Value -> State (Replacement m) Type.Value-value (Full.Variable name) =-    gets (fromMaybe Type.Null . HashMap.lookup name . variableValues)-value (Full.Int int) = pure $ Type.Int int-value (Full.Float float) = pure $ Type.Float float-value (Full.String string) = pure $ Type.String string-value (Full.Boolean boolean) = pure $ Type.Boolean boolean-value Full.Null = pure Type.Null-value (Full.Enum enum) = pure $ Type.Enum enum-value (Full.List list) = Type.List <$> traverse (value . Full.node) list-value (Full.Object object) =-    Type.Object . HashMap.fromList <$> traverse objectField object-  where-    objectField Full.ObjectField{value = value', ..} =-        (name,) <$> value (Full.node value')+insertIfGiven :: forall a+    . Full.Name+    -> Maybe a+    -> HashMap Full.Name a+    -> HashMap Full.Name a+insertIfGiven name (Just v) = HashMap.insert name v+insertIfGiven _ _ = id -input :: forall m. Full.Value -> State (Replacement m) (Maybe Input)-input (Full.Variable name) =-    gets (fmap Variable . HashMap.lookup name . variableValues)-input (Full.Int int) = pure $ pure $ Int int-input (Full.Float float) = pure $ pure $ Float float-input (Full.String string) = pure $ pure $ String string-input (Full.Boolean boolean) = pure $ pure $ Boolean boolean-input Full.Null = pure $ pure Null-input (Full.Enum enum) = pure $ pure $ Enum enum-input (Full.List list) = pure . List <$> traverse (value . Full.node) list-input (Full.Object object) = do-    objectFields <- foldM objectField HashMap.empty object-    pure $ pure $ Object objectFields-  where-    objectField resultMap Full.ObjectField{value = value', ..} =-        inputField resultMap name $ Full.node value'+node :: Monad m => Full.Node Full.Value -> TransformT m (Maybe (Full.Node Input))+node Full.Node{node = node', ..} =+    traverse Full.Node <$> input node' <*> pure location -inputField :: forall m-    . HashMap Full.Name Input-    -> Full.Name-    -> Full.Value-    -> State (Replacement m) (HashMap Full.Name Input)-inputField resultMap name value' = do-    objectFieldValue <-  input value'-    case objectFieldValue of-        Just fieldValue -> pure $ HashMap.insert name fieldValue resultMap-        Nothing -> pure resultMap

@@ -0,0 +1,38 @@+{- 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/. -}++-- | Template Haskell helpers.+module Language.GraphQL.TH+    ( gql+    ) where++import Language.Haskell.TH.Quote (QuasiQuoter(..))+import Language.Haskell.TH (Exp(..), Lit(..))++stripIndentation :: String -> String+stripIndentation code = reverse+    $ dropNewlines+    $ reverse+    $ unlines+    $ indent spaces <$> lines withoutLeadingNewlines+  where+    indent 0 xs = xs+    indent count (' ' : xs) = indent (count - 1) xs+    indent _ xs = xs+    withoutLeadingNewlines = dropNewlines code+    dropNewlines = dropWhile (== '\n')+    spaces = length $ takeWhile (== ' ') withoutLeadingNewlines++-- | Removes leading and trailing newlines. Indentation of the first line is+-- removed from each line of the string.+gql :: QuasiQuoter+gql = QuasiQuoter+    { quoteExp = pure . LitE . StringL . stripIndentation+    , quotePat = const+        $ fail "Illegal gql QuasiQuote (allowed as expression only, used as a pattern)"+    , quoteType = const+        $ fail "Illegal gql QuasiQuote (allowed as expression only, used as a type)"+    , quoteDec = const+        $ fail "Illegal gql QuasiQuote (allowed as expression only, used as a declaration)"+    }

@@ -1,4 +1,9 @@+{- 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 Safe #-}  -- | Types that can be used as both input and output types. module Language.GraphQL.Type.Definition@@ -20,10 +25,12 @@ import Data.Int (Int32) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap+import Data.List (intercalate) import Data.String (IsString(..)) import Data.Text (Text) import qualified Data.Text as Text-import Language.GraphQL.AST (Name)+import Language.GraphQL.AST (Name, escape)+import Numeric (showFloat) import Prelude hiding (id)  -- | Represents accordingly typed GraphQL values.@@ -36,7 +43,27 @@     | Enum Name     | List [Value] -- ^ Arbitrary nested list.     | Object (HashMap Name Value)-    deriving (Eq, Show)+    deriving Eq++instance Show Value where+    showList = mappend . showList'+      where+        showList' list = "[" ++ intercalate ", " (show <$> list) ++ "]"+    show (Int integer) = show integer+    show (Float float') = showFloat float' mempty+    show (String text) = "\"" <> Text.foldr (mappend . escape) "\"" text+    show (Boolean boolean') = show boolean'+    show Null = "null"+    show (Enum name) = Text.unpack name+    show (List list) = show list+    show (Object fields) = unwords+        [ "{"+        , intercalate ", " (HashMap.foldrWithKey showObject [] fields)+        , "}"+        ]+      where+        showObject key value accumulator =+            concat [Text.unpack key, ": ", show value] : accumulator  instance IsString Value where     fromString = String . fromString

@@ -3,6 +3,7 @@    obtain one at https://mozilla.org/MPL/2.0/. -}  {-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE Safe #-} {-# LANGUAGE ViewPatterns #-}  -- | Input types and values.

@@ -6,10 +6,10 @@  import qualified Language.GraphQL.AST.Document as Full import Language.GraphQL.AST.Encoder+import Language.GraphQL.TH import Test.Hspec (Spec, context, describe, it, shouldBe, shouldStartWith, shouldEndWith, shouldNotContain) import Test.QuickCheck (choose, oneof, forAll)-import Text.RawString.QQ (r)-import Data.Text.Lazy (cons, toStrict, unpack)+import qualified Data.Text.Lazy as Text.Lazy  spec :: Spec spec = do@@ -48,23 +48,32 @@             it "uses strings for short string values" $                 value pretty (Full.String "Short text") `shouldBe` "\"Short text\""             it "uses block strings for text with new lines, with newline symbol" $-                value pretty (Full.String "Line 1\nLine 2")-                    `shouldBe` [r|"""-  Line 1-  Line 2-"""|]+                let expected = [gql|+                  """+                    Line 1+                    Line 2+                  """+                |]+                    actual = value pretty $ Full.String "Line 1\nLine 2"+                 in actual `shouldBe` expected             it "uses block strings for text with new lines, with CR symbol" $-                value pretty (Full.String "Line 1\rLine 2")-                    `shouldBe` [r|"""-  Line 1-  Line 2-"""|]+                let expected = [gql|+                  """+                    Line 1+                    Line 2+                  """+                |]+                    actual = value pretty $ Full.String "Line 1\rLine 2"+                 in actual `shouldBe` expected             it "uses block strings for text with new lines, with CR symbol followed by newline" $-                value pretty (Full.String "Line 1\r\nLine 2")-                    `shouldBe` [r|"""-  Line 1-  Line 2-"""|]+                let expected = [gql|+                  """+                    Line 1+                    Line 2+                  """+                |]+                    actual = value pretty $ Full.String "Line 1\r\nLine 2"+                 in actual `shouldBe` expected             it "encodes as one line string if has escaped symbols" $ do                 let                   genNotAllowedSymbol = oneof@@ -76,48 +85,74 @@                  forAll genNotAllowedSymbol $ \x -> do                     let-                      rawValue = "Short \n" <> cons x "text"-                      encoded = value pretty (Full.String $ toStrict rawValue)-                    shouldStartWith (unpack encoded) "\""-                    shouldEndWith (unpack encoded) "\""-                    shouldNotContain (unpack encoded) "\"\"\""+                      rawValue = "Short \n" <> Text.Lazy.cons x "text"+                      encoded = value pretty+                          $ Full.String $ Text.Lazy.toStrict rawValue+                    shouldStartWith (Text.Lazy.unpack encoded) "\""+                    shouldEndWith (Text.Lazy.unpack encoded) "\""+                    shouldNotContain (Text.Lazy.unpack encoded) "\"\"\"" -            it "Hello world" $ value pretty (Full.String "Hello,\n  World!\n\nYours,\n  GraphQL.")-              `shouldBe` [r|"""-  Hello,-    World!+            it "Hello world" $+                let actual = value pretty+                        $ Full.String "Hello,\n  World!\n\nYours,\n  GraphQL."+                    expected = [gql|+                      """+                        Hello,+                          World! -  Yours,-    GraphQL.-"""|]+                        Yours,+                          GraphQL.+                      """+                    |]+                  in actual `shouldBe` expected -            it "has only newlines" $ value pretty (Full.String "\n") `shouldBe` [r|"""+            it "has only newlines" $+                let actual = value pretty $ Full.String "\n"+                    expected = [gql|+                      """  -"""|]+                      """+                    |]+                 in actual `shouldBe` expected             it "has newlines and one symbol at the begining" $-              value pretty (Full.String "a\n\n") `shouldBe` [r|"""-  a+                let actual = value pretty $ Full.String "a\n\n"+                    expected = [gql|+                      """+                        a  -"""|]+                      """|]+                 in actual `shouldBe` expected             it "has newlines and one symbol at the end" $-              value pretty (Full.String "\n\na") `shouldBe` [r|"""+                let actual = value pretty $ Full.String "\n\na"+                    expected = [gql|+                      """  -  a-"""|]+                        a+                      """+                    |]+                 in actual `shouldBe` expected             it "has newlines and one symbol in the middle" $-              value pretty (Full.String "\na\n") `shouldBe` [r|"""+                let actual = value pretty $ Full.String "\na\n"+                    expected = [gql|+                      """ -  a+                        a -"""|]-            it "skip trailing whitespaces" $ value pretty (Full.String "  Short\ntext    ")-              `shouldBe` [r|"""-  Short-  text-"""|]+                      """+                    |]+                 in actual `shouldBe` expected+            it "skip trailing whitespaces" $+                let actual = value pretty $ Full.String "  Short\ntext    "+                    expected = [gql|+                      """+                        Short+                        text+                      """+                    |]+                 in actual `shouldBe` expected      describe "definition" $         it "indents block strings in arguments" $@@ -128,10 +163,13 @@                 fieldSelection = pure $ Full.FieldSelection field                 operation = Full.DefinitionOperation                     $ Full.SelectionSet fieldSelection location-             in definition pretty operation `shouldBe` [r|{-  field(message: """-    line1-    line2-  """)-}-|]+                expected = Text.Lazy.snoc [gql|+                  {+                    field(message: """+                      line1+                      line2+                    """)+                  }+                |] '\n'+                actual = definition pretty operation+             in actual `shouldBe` expected

@@ -7,10 +7,10 @@ import Data.Text (Text) import Data.Void (Void) import Language.GraphQL.AST.Lexer+import Language.GraphQL.TH import Test.Hspec (Spec, context, describe, it) import Test.Hspec.Megaparsec (shouldParse, shouldFailOn, shouldSucceedOn) import Text.Megaparsec (ParseErrorBundle, parse)-import Text.RawString.QQ (r)  spec :: Spec spec = describe "Lexer" $ do@@ -19,32 +19,32 @@             parse unicodeBOM "" `shouldSucceedOn` "\xfeff"          it "lexes strings" $ do-            parse string "" [r|"simple"|] `shouldParse` "simple"-            parse string "" [r|" white space "|] `shouldParse` " white space "-            parse string "" [r|"quote \""|] `shouldParse` [r|quote "|]-            parse string "" [r|"escaped \n"|] `shouldParse` "escaped \n"-            parse string "" [r|"slashes \\ \/"|] `shouldParse` [r|slashes \ /|]-            parse string "" [r|"unicode \u1234\u5678\u90AB\uCDEF"|]+            parse string "" [gql|"simple"|] `shouldParse` "simple"+            parse string "" [gql|" white space "|] `shouldParse` " white space "+            parse string "" [gql|"quote \""|] `shouldParse` [gql|quote "|]+            parse string "" [gql|"escaped \n"|] `shouldParse` "escaped \n"+            parse string "" [gql|"slashes \\ \/"|] `shouldParse` [gql|slashes \ /|]+            parse string "" [gql|"unicode \u1234\u5678\u90AB\uCDEF"|]                 `shouldParse` "unicode ሴ噸邫췯"          it "lexes block string" $ do-            parse blockString "" [r|"""simple"""|] `shouldParse` "simple"-            parse blockString "" [r|""" white space """|]+            parse blockString "" [gql|"""simple"""|] `shouldParse` "simple"+            parse blockString "" [gql|""" white space """|]                 `shouldParse` " white space "-            parse blockString "" [r|"""contains " quote"""|]-                `shouldParse` [r|contains " quote|]-            parse blockString "" [r|"""contains \""" triplequote"""|]-                `shouldParse` [r|contains """ triplequote|]+            parse blockString "" [gql|"""contains " quote"""|]+                `shouldParse` [gql|contains " quote|]+            parse blockString "" [gql|"""contains \""" triplequote"""|]+                `shouldParse` [gql|contains """ triplequote|]             parse blockString "" "\"\"\"multi\nline\"\"\"" `shouldParse` "multi\nline"             parse blockString "" "\"\"\"multi\rline\r\nnormalized\"\"\""                 `shouldParse` "multi\nline\nnormalized"             parse blockString "" "\"\"\"multi\rline\r\nnormalized\"\"\""                 `shouldParse` "multi\nline\nnormalized"-            parse blockString "" [r|"""unescaped \n\r\b\t\f\u1234"""|]-                `shouldParse` [r|unescaped \n\r\b\t\f\u1234|]-            parse blockString "" [r|"""slashes \\ \/"""|]-                `shouldParse` [r|slashes \\ \/|]-            parse blockString "" [r|"""+            parse blockString "" [gql|"""unescaped \n\r\b\t\f\u1234"""|]+                `shouldParse` [gql|unescaped \n\r\b\t\f\u1234|]+            parse blockString "" [gql|"""slashes \\ \/"""|]+                `shouldParse` [gql|slashes \\ \/|]+            parse blockString "" [gql|"""                  spans                   multiple@@ -84,7 +84,7 @@      context "Implementation tests" $ do         it "lexes empty block strings" $-            parse blockString "" [r|""""""|] `shouldParse` ""+            parse blockString "" [gql|""""""|] `shouldParse` ""         it "lexes ampersand" $             parse amp "" "&" `shouldParse` "&"         it "lexes schema extensions" $

@@ -8,10 +8,10 @@ import Language.GraphQL.AST.Document import qualified Language.GraphQL.AST.DirectiveLocation as DirLoc import Language.GraphQL.AST.Parser+import Language.GraphQL.TH import Test.Hspec (Spec, describe, it) import Test.Hspec.Megaparsec (shouldParse, shouldFailOn, shouldSucceedOn) import Text.Megaparsec (parse)-import Text.RawString.QQ (r)  spec :: Spec spec = describe "Parser" $ do@@ -19,74 +19,74 @@         parse document "" `shouldSucceedOn` "\xfeff{foo}"      it "accepts block strings as argument" $-        parse document "" `shouldSucceedOn` [r|{+        parse document "" `shouldSucceedOn` [gql|{               hello(text: """Argument""")             }|]      it "accepts strings as argument" $-        parse document "" `shouldSucceedOn` [r|{+        parse document "" `shouldSucceedOn` [gql|{               hello(text: "Argument")             }|]      it "accepts two required arguments" $-        parse document "" `shouldSucceedOn` [r|+        parse document "" `shouldSucceedOn` [gql|             mutation auth($username: String!, $password: String!){               test             }|]      it "accepts two string arguments" $-        parse document "" `shouldSucceedOn` [r|+        parse document "" `shouldSucceedOn` [gql|             mutation auth{               test(username: "username", password: "password")             }|]      it "accepts two block string arguments" $-        parse document "" `shouldSucceedOn` [r|+        parse document "" `shouldSucceedOn` [gql|             mutation auth{               test(username: """username""", password: """password""")             }|]      it "parses minimal schema definition" $-        parse document "" `shouldSucceedOn` [r|schema { query: Query }|]+        parse document "" `shouldSucceedOn` [gql|schema { query: Query }|]      it "parses minimal scalar definition" $-        parse document "" `shouldSucceedOn` [r|scalar Time|]+        parse document "" `shouldSucceedOn` [gql|scalar Time|]      it "parses ImplementsInterfaces" $-        parse document "" `shouldSucceedOn` [r|+        parse document "" `shouldSucceedOn` [gql|             type Person implements NamedEntity & ValuedEntity {               name: String             }         |]      it "parses a  type without ImplementsInterfaces" $-        parse document "" `shouldSucceedOn` [r|+        parse document "" `shouldSucceedOn` [gql|             type Person {               name: String             }         |]      it "parses ArgumentsDefinition in an ObjectDefinition" $-        parse document "" `shouldSucceedOn` [r|+        parse document "" `shouldSucceedOn` [gql|             type Person {               name(first: String, last: String): String             }         |]      it "parses minimal union type definition" $-        parse document "" `shouldSucceedOn` [r|+        parse document "" `shouldSucceedOn` [gql|             union SearchResult = Photo | Person         |]      it "parses minimal interface type definition" $-        parse document "" `shouldSucceedOn` [r|+        parse document "" `shouldSucceedOn` [gql|             interface NamedEntity {               name: String             }         |]      it "parses minimal enum type definition" $-        parse document "" `shouldSucceedOn` [r|+        parse document "" `shouldSucceedOn` [gql|             enum Direction {               NORTH               EAST@@ -96,7 +96,7 @@         |]      it "parses minimal enum type definition" $-        parse document "" `shouldSucceedOn` [r|+        parse document "" `shouldSucceedOn` [gql|             enum Direction {               NORTH               EAST@@ -106,7 +106,7 @@         |]      it "parses minimal input object type definition" $-        parse document "" `shouldSucceedOn` [r|+        parse document "" `shouldSucceedOn` [gql|             input Point2D {               x: Float               y: Float@@ -114,7 +114,7 @@         |]      it "parses minimal input enum definition with an optional pipe" $-        parse document "" `shouldSucceedOn` [r|+        parse document "" `shouldSucceedOn` [gql|             directive @example on               | FIELD               | FRAGMENT_SPREAD@@ -131,15 +131,15 @@             example1 =                 directive "example1"                     (DirLoc.TypeSystemDirectiveLocation DirLoc.FieldDefinition)-                    (Location {line = 2, column = 17})+                    (Location {line = 1, column = 1})             example2 =                 directive "example2"                     (DirLoc.ExecutableDirectiveLocation DirLoc.Field)-                    (Location {line = 3, column = 17})+                    (Location {line = 2, column = 1})             testSchemaExtension = example1 :| [ example2 ]-            query = [r|-                directive @example1 on FIELD_DEFINITION-                directive @example2 on FIELD+            query = [gql|+              directive @example1 on FIELD_DEFINITION+              directive @example2 on FIELD             |]          in parse document "" query `shouldParse` testSchemaExtension @@ -167,16 +167,16 @@                           $ Node (ConstList [])                           $ Location {line = 1, column = 33})]                     (Location {line = 1, column = 1})-            query = [r|directive @test(foo: [String] = []) on FIELD_DEFINITION|]+            query = [gql|directive @test(foo: [String] = []) on FIELD_DEFINITION|]          in parse document "" query `shouldParse` (defn :| [ ])      it "parses schema extension with a new directive" $-        parse document "" `shouldSucceedOn`[r|+        parse document "" `shouldSucceedOn`[gql|             extend schema @newDirective         |]      it "parses schema extension with an operation type definition" $-        parse document "" `shouldSucceedOn` [r|extend schema { query: Query }|]+        parse document "" `shouldSucceedOn` [gql|extend schema { query: Query }|]      it "parses schema extension with an operation type and directive" $         let newDirective = Directive "newDirective" [] $ Location 1 15@@ -185,25 +185,25 @@                 $ OperationTypeDefinition Query "Query" :| []             testSchemaExtension = TypeSystemExtension schemaExtension                 $ Location 1 1-            query = [r|extend schema @newDirective { query: Query }|]+            query = [gql|extend schema @newDirective { query: Query }|]          in parse document "" query `shouldParse` (testSchemaExtension :| [])      it "parses an object extension" $-        parse document "" `shouldSucceedOn` [r|+        parse document "" `shouldSucceedOn` [gql|             extend type Story {               isHiddenLocally: Boolean             }         |]      it "rejects variables in DefaultValue" $-        parse document "" `shouldFailOn` [r|+        parse document "" `shouldFailOn` [gql|             query ($book: String = "Zarathustra", $author: String = $book) {               title             }         |]      it "parses documents beginning with a comment" $-        parse document "" `shouldSucceedOn` [r|+        parse document "" `shouldSucceedOn` [gql|             """             Query             """@@ -213,7 +213,7 @@         |]      it "parses subscriptions" $-        parse document "" `shouldSucceedOn` [r|+        parse document "" `shouldSucceedOn` [gql|             subscription NewMessages {               newMessage(roomId: 123) {                 sender

@@ -21,6 +21,7 @@ import Language.GraphQL.AST.Parser (document) import Language.GraphQL.Error import Language.GraphQL.Execute (execute)+import Language.GraphQL.TH import qualified Language.GraphQL.Type.Schema as Schema import Language.GraphQL.Type import qualified Language.GraphQL.Type.In as In@@ -28,7 +29,6 @@ import Prelude hiding (id) import Test.Hspec (Spec, context, describe, it, shouldBe) import Text.Megaparsec (parse)-import Text.RawString.QQ (r)  data PhilosopherException = PhilosopherException     deriving Show@@ -54,18 +54,23 @@     $ HashMap.fromList     [ ("philosopher", ValueResolver philosopherField philosopherResolver)     , ("genres", ValueResolver genresField genresResolver)+    , ("count", ValueResolver countField countResolver)     ]   where     philosopherField =-        Out.Field Nothing (Out.NonNullObjectType philosopherType)+        Out.Field Nothing (Out.NamedObjectType philosopherType)         $ HashMap.singleton "id"         $ In.Argument Nothing (In.NamedScalarType id) Nothing     philosopherResolver = pure $ Object mempty     genresField =-      let fieldType = Out.ListType $ Out.NonNullScalarType string-       in Out.Field Nothing fieldType HashMap.empty+        let fieldType = Out.ListType $ Out.NonNullScalarType string+         in Out.Field Nothing fieldType HashMap.empty     genresResolver :: Resolve (Either SomeException)     genresResolver = throwM PhilosopherException+    countField =+        let fieldType = Out.NonNullScalarType int+         in Out.Field Nothing fieldType HashMap.empty+    countResolver = pure ""  musicType :: Out.ObjectType (Either SomeException) musicType = Out.ObjectType "Music" Nothing []@@ -101,6 +106,7 @@         , ("interest", ValueResolver interestField interestResolver)         , ("majorWork", ValueResolver majorWorkField majorWorkResolver)         , ("century", ValueResolver centuryField centuryResolver)+        , ("firstLanguage", ValueResolver firstLanguageField firstLanguageResolver)         ]     firstNameField =         Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty@@ -126,6 +132,9 @@     centuryField =         Out.Field Nothing (Out.NonNullScalarType int) HashMap.empty     centuryResolver = pure $ Float 18.5+    firstLanguageField+        = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty+    firstLanguageResolver = pure Null  workType :: Out.InterfaceType (Either SomeException) workType = Out.InterfaceType "Work" Nothing []@@ -191,7 +200,7 @@ spec =     describe "execute" $ do         it "rejects recursive fragments" $-            let sourceQuery = [r|+            let sourceQuery = [gql|               {                 ...cyclicFragment               }@@ -230,14 +239,13 @@              it "errors on invalid output enum values" $                 let data'' = Aeson.object-                        [ "philosopher" .= Aeson.object-                            [ "school" .= Aeson.Null-                            ]+                        [ "philosopher" .= Aeson.Null                         ]                     executionErrors = pure $ Error-                        { message = "Enum value completion failed."+                        { message =+                            "Value completion error. Expected type !School, found: EXISTENTIALISM."                         , locations = [Location 1 17]-                        , path = []+                        , path = [Segment "philosopher", Segment "school"]                         }                     expected = Response data'' executionErrors                     Right (Right actual) = either (pure . parseError) execute'@@ -246,14 +254,13 @@              it "gives location information for non-null unions" $                 let data'' = Aeson.object-                        [ "philosopher" .= Aeson.object-                            [ "interest" .= Aeson.Null-                            ]+                        [ "philosopher" .= Aeson.Null                         ]                     executionErrors = pure $ Error-                        { message = "Union value completion failed."+                        { message =+                            "Value completion error. Expected type !Interest, found: { instrument: \"piano\" }."                         , locations = [Location 1 17]-                        , path = []+                        , path = [Segment "philosopher", Segment "interest"]                         }                     expected = Response data'' executionErrors                     Right (Right actual) = either (pure . parseError) execute'@@ -262,14 +269,14 @@              it "gives location information for invalid interfaces" $                 let data'' = Aeson.object-                        [ "philosopher" .= Aeson.object-                            [ "majorWork" .= Aeson.Null-                            ]+                        [ "philosopher" .= Aeson.Null                         ]                     executionErrors = pure $ Error-                        { message = "Interface value completion failed."+                        { message+                            = "Value completion error. Expected type !Work, found:\+                            \ { title: \"Also sprach Zarathustra: Ein Buch f\252r Alle und Keinen\" }."                         , locations = [Location 1 17]-                        , path = []+                        , path = [Segment "philosopher", Segment "majorWork"]                         }                     expected = Response data'' executionErrors                     Right (Right actual) = either (pure . parseError) execute'@@ -281,9 +288,10 @@                         [ "philosopher" .= Aeson.Null                         ]                     executionErrors = pure $ Error-                        { message = "Argument coercing failed."+                        { message =+                            "Argument \"id\" has invalid type. Expected type ID, found: True."                         , locations = [Location 1 15]-                        , path = []+                        , path = [Segment "philosopher"]                         }                     expected = Response data'' executionErrors                     Right (Right actual) = either (pure . parseError) execute'@@ -292,14 +300,12 @@              it "gives location information for failed result coercion" $                 let data'' = Aeson.object-                        [ "philosopher" .= Aeson.object-                            [ "century" .= Aeson.Null-                            ]+                        [ "philosopher" .= Aeson.Null                         ]                     executionErrors = pure $ Error-                        { message = "Result coercion failed."+                        { message = "Unable to coerce result to !Int."                         , locations = [Location 1 26]-                        , path = []+                        , path = [Segment "philosopher", Segment "century"]                         }                     expected = Response data'' executionErrors                     Right (Right actual) = either (pure . parseError) execute'@@ -313,11 +319,36 @@                     executionErrors = pure $ Error                         { message = "PhilosopherException"                         , locations = [Location 1 3]-                        , path = []+                        , path = [Segment "genres"]                         }                     expected = Response data'' executionErrors                     Right (Right actual) = either (pure . parseError) execute'                         $ parse document "" "{ genres }"+                in actual `shouldBe` expected++            it "sets data to null if a root field isn't nullable" $+                let executionErrors = pure $ Error+                        { message = "Unable to coerce result to !Int."+                        , locations = [Location 1 3]+                        , path = [Segment "count"]+                        }+                    expected = Response Aeson.Null executionErrors+                    Right (Right actual) = either (pure . parseError) execute'+                        $ parse document "" "{ count }"+                in actual `shouldBe` expected++            it "detects nullability errors" $+                let data'' = Aeson.object+                        [ "philosopher" .= Aeson.Null+                        ]+                    executionErrors = pure $ Error+                        { message = "Value completion error. Expected type !String, found: null."+                        , locations = [Location 1 26]+                        , path = [Segment "philosopher", Segment "firstLanguage"]+                        }+                    expected = Response data'' executionErrors+                    Right (Right actual) = either (pure . parseError) execute'+                        $ parse document "" "{ philosopher(id: \"1\") { firstLanguage } }"                 in actual `shouldBe` expected          context "Subscription" $

@@ -13,13 +13,13 @@ import qualified Data.HashMap.Strict as HashMap import Data.Text (Text) import qualified Language.GraphQL.AST as AST+import Language.GraphQL.TH 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@@ -163,7 +163,7 @@     describe "document" $ do         context "executableDefinitionsRule" $             it "rejects type definitions" $-                let queryString = [r|+                let queryString = [gql|                   query getDogName {                     dog {                       name@@ -179,13 +179,13 @@                         { message =                             "Definition must be OperationDefinition or \                             \FragmentDefinition."-                        , locations = [AST.Location 9 19]+                        , locations = [AST.Location 8 1]                         }                  in validate queryString `shouldContain` [expected]          context "singleFieldSubscriptionsRule" $ do             it "rejects multiple subscription root fields" $-                let queryString = [r|+                let queryString = [gql|                   subscription sub {                     newMessage {                       body@@ -198,12 +198,12 @@                         { message =                             "Subscription \"sub\" must select only one top \                             \level field."-                        , locations = [AST.Location 2 19]+                        , locations = [AST.Location 1 1]                         }                  in validate queryString `shouldContain` [expected]              it "rejects multiple subscription root fields coming from a fragment" $-                let queryString = [r|+                let queryString = [gql|                   subscription sub {                     ...multipleSubscriptions                   }@@ -220,12 +220,12 @@                         { message =                             "Subscription \"sub\" must select only one top \                             \level field."-                        , locations = [AST.Location 2 19]+                        , locations = [AST.Location 1 1]                         }                  in validate queryString `shouldContain` [expected]              it "finds corresponding subscription fragment" $-                let queryString = [r|+                let queryString = [gql|                   subscription sub {                     ...anotherSubscription                     ...multipleSubscriptions@@ -249,13 +249,13 @@                         { message =                             "Subscription \"sub\" must select only one top \                             \level field."-                        , locations = [AST.Location 2 19]+                        , locations = [AST.Location 1 1]                         }                  in validate queryString `shouldBe` [expected]          context "loneAnonymousOperationRule" $             it "rejects multiple anonymous operations" $-                let queryString = [r|+                let queryString = [gql|                   {                     dog {                       name@@ -274,13 +274,13 @@                         { message =                             "This anonymous operation must be the only defined \                             \operation."-                        , locations = [AST.Location 2 19]+                        , locations = [AST.Location 1 1]                         }                  in validate queryString `shouldBe` [expected]          context "uniqueOperationNamesRule" $             it "rejects operations with the same name" $-                let queryString = [r|+                let queryString = [gql|                   query dogOperation {                     dog {                       name@@ -297,13 +297,13 @@                         { message =                             "There can be only one operation named \                             \\"dogOperation\"."-                        , locations = [AST.Location 2 19, AST.Location 8 19]+                        , locations = [AST.Location 1 1, AST.Location 7 1]                         }                  in validate queryString `shouldBe` [expected]          context "uniqueFragmentNamesRule" $             it "rejects fragments with the same name" $-                let queryString = [r|+                let queryString = [gql|                   {                     dog {                       ...fragmentOne@@ -324,13 +324,13 @@                         { message =                             "There can be only one fragment named \                             \\"fragmentOne\"."-                        , locations = [AST.Location 8 19, AST.Location 12 19]+                        , locations = [AST.Location 7 1, AST.Location 11 1]                         }                  in validate queryString `shouldBe` [expected]          context "fragmentSpreadTargetDefinedRule" $             it "rejects the fragment spread without a target" $-                let queryString = [r|+                let queryString = [gql|                   {                     dog {                       ...undefinedFragment@@ -341,13 +341,13 @@                         { message =                             "Fragment target \"undefinedFragment\" is \                             \undefined."-                        , locations = [AST.Location 4 23]+                        , locations = [AST.Location 3 5]                         }                  in validate queryString `shouldBe` [expected]          context "fragmentSpreadTypeExistenceRule" $ do             it "rejects fragment spreads without an unknown target type" $-                let queryString = [r|+                let queryString = [gql|                   {                     dog {                       ...notOnExistingType@@ -362,12 +362,12 @@                             "Fragment \"notOnExistingType\" is specified on \                             \type \"NotInSchema\" which doesn't exist in the \                             \schema."-                        , locations = [AST.Location 4 23]+                        , locations = [AST.Location 3 5]                         }                  in validate queryString `shouldBe` [expected]              it "rejects inline fragments without a target" $-                let queryString = [r|+                let queryString = [gql|                   {                     ... on NotInSchema {                       name@@ -378,13 +378,13 @@                         { message =                             "Inline fragment is specified on type \                             \\"NotInSchema\" which doesn't exist in the schema."-                        , locations = [AST.Location 3 21]+                        , locations = [AST.Location 2 3]                         }                  in validate queryString `shouldBe` [expected]          context "fragmentsOnCompositeTypesRule" $ do             it "rejects fragments on scalar types" $-                let queryString = [r|+                let queryString = [gql|                   {                     dog {                       ...fragOnScalar@@ -398,12 +398,12 @@                         { message =                             "Fragment cannot condition on non composite type \                             \\"Int\"."-                        , locations = [AST.Location 7 19]+                        , locations = [AST.Location 6 1]                         }                  in validate queryString `shouldContain` [expected]              it "rejects inline fragments on scalar types" $-                let queryString = [r|+                let queryString = [gql|                   {                     ... on Boolean {                       name@@ -414,13 +414,13 @@                         { message =                             "Fragment cannot condition on non composite type \                             \\"Boolean\"."-                        , locations = [AST.Location 3 21]+                        , locations = [AST.Location 2 3]                         }                 in validate queryString `shouldContain` [expected]          context "noUnusedFragmentsRule" $             it "rejects unused fragments" $-                let queryString = [r|+                let queryString = [gql|                   fragment nameFragment on Dog { # unused                     name                   }@@ -434,13 +434,13 @@                     expected = Error                         { message =                             "Fragment \"nameFragment\" is never used."-                        , locations = [AST.Location 2 19]+                        , locations = [AST.Location 1 1]                         }                  in validate queryString `shouldBe` [expected]          context "noFragmentCyclesRule" $             it "rejects spreads that form cycles" $-                let queryString = [r|+                let queryString = [gql|                   {                     dog {                       ...nameFragment@@ -460,20 +460,20 @@                             "Cannot spread fragment \"barkVolumeFragment\" \                             \within itself (via barkVolumeFragment -> \                             \nameFragment -> barkVolumeFragment)."-                        , locations = [AST.Location 11 19]+                        , locations = [AST.Location 10 1]                         }                     error2 = Error                         { message =                             "Cannot spread fragment \"nameFragment\" within \                             \itself (via nameFragment -> barkVolumeFragment -> \                             \nameFragment)."-                        , locations = [AST.Location 7 19]+                        , locations = [AST.Location 6 1]                         }                  in validate queryString `shouldBe` [error1, error2]          context "uniqueArgumentNamesRule" $             it "rejects duplicate field arguments" $-                let queryString = [r|+                let queryString = [gql|                   {                     dog {                       isHousetrained(atOtherHomes: true, atOtherHomes: true)@@ -484,13 +484,13 @@                         { message =                             "There can be only one argument named \                             \\"atOtherHomes\"."-                        , locations = [AST.Location 4 38, AST.Location 4 58]+                        , locations = [AST.Location 3 20, AST.Location 3 40]                         }                  in validate queryString `shouldBe` [expected]          context "uniqueDirectiveNamesRule" $             it "rejects more than one directive per location" $-                let queryString = [r|+                let queryString = [gql|                   query ($foo: Boolean = true, $bar: Boolean = false) {                     dog @skip(if: $foo) @skip(if: $bar) {                       name@@ -500,13 +500,13 @@                     expected = Error                         { message =                             "There can be only one directive named \"skip\"."-                        , locations = [AST.Location 3 25, AST.Location 3 41]+                        , locations = [AST.Location 2 7, AST.Location 2 23]                         }                  in validate queryString `shouldBe` [expected]          context "uniqueVariableNamesRule" $             it "rejects duplicate variables" $-                let queryString = [r|+                let queryString = [gql|                   query houseTrainedQuery($atOtherHomes: Boolean, $atOtherHomes: Boolean) {                     dog {                       isHousetrained(atOtherHomes: $atOtherHomes)@@ -517,13 +517,13 @@                         { message =                             "There can be only one variable named \                             \\"atOtherHomes\"."-                        , locations = [AST.Location 2 43, AST.Location 2 67]+                        , locations = [AST.Location 1 25, AST.Location 1 49]                         }                  in validate queryString `shouldBe` [expected]          context "variablesAreInputTypesRule" $             it "rejects non-input types as variables" $-                let queryString = [r|+                let queryString = [gql|                   query takesDogBang($dog: Dog!) {                     dog {                       isHousetrained(atOtherHomes: $dog)@@ -534,13 +534,13 @@                         { message =                             "Variable \"$dog\" cannot be non-input type \                             \\"Dog\"."-                        , locations = [AST.Location 2 38]+                        , locations = [AST.Location 1 20]                         }                  in validate queryString `shouldContain` [expected]          context "noUndefinedVariablesRule" $             it "rejects undefined variables" $-                let queryString = [r|+                let queryString = [gql|                   query variableIsNotDefinedUsedInSingleFragment {                     dog {                       ...isHousetrainedFragment@@ -556,13 +556,13 @@                             "Variable \"$atOtherHomes\" is not defined by \                             \operation \                             \\"variableIsNotDefinedUsedInSingleFragment\"."-                        , locations = [AST.Location 9 50]+                        , locations = [AST.Location 8 32]                         }                  in validate queryString `shouldBe` [expected]          context "noUnusedVariablesRule" $             it "rejects unused variables" $-                let queryString = [r|+                let queryString = [gql|                   query variableUnused($atOtherHomes: Boolean) {                     dog {                       isHousetrained@@ -573,13 +573,13 @@                         { message =                             "Variable \"$atOtherHomes\" is never used in \                             \operation \"variableUnused\"."-                        , locations = [AST.Location 2 40]+                        , locations = [AST.Location 1 22]                         }                  in validate queryString `shouldBe` [expected]          context "uniqueInputFieldNamesRule" $             it "rejects duplicate fields in input objects" $-                let queryString = [r|+                let queryString = [gql|                   {                     findDog(complex: { name: "Fido", name: "Jack" }) {                       name@@ -589,13 +589,13 @@                     expected = Error                         { message =                             "There can be only one input field named \"name\"."-                        , locations = [AST.Location 3 40, AST.Location 3 54]+                        , locations = [AST.Location 2 22, AST.Location 2 36]                         }                  in validate queryString `shouldBe` [expected]          context "fieldsOnCorrectTypeRule" $             it "rejects undefined fields" $-                let queryString = [r|+                let queryString = [gql|                   {                     dog {                       meowVolume@@ -605,13 +605,13 @@                     expected = Error                         { message =                             "Cannot query field \"meowVolume\" on type \"Dog\"."-                        , locations = [AST.Location 4 23]+                        , locations = [AST.Location 3 5]                         }                  in validate queryString `shouldBe` [expected]          context "scalarLeafsRule" $             it "rejects scalar fields with not empty selection set" $-                let queryString = [r|+                let queryString = [gql|                   {                     dog {                       barkVolume {@@ -624,13 +624,13 @@                         { message =                             "Field \"barkVolume\" must not have a selection \                             \since type \"Int\" has no subfields."-                        , locations = [AST.Location 4 23]+                        , locations = [AST.Location 3 5]                         }                  in validate queryString `shouldBe` [expected]          context "knownArgumentNamesRule" $ do             it "rejects field arguments missing in the type" $-                let queryString = [r|+                let queryString = [gql|                   {                     dog {                       doesKnowCommand(command: CLEAN_UP_HOUSE, dogCommand: SIT)@@ -641,12 +641,12 @@                         { message =                             "Unknown argument \"command\" on field \                             \\"Dog.doesKnowCommand\"."-                        , locations = [AST.Location 4 39]+                        , locations = [AST.Location 3 21]                         }                  in validate queryString `shouldBe` [expected]              it "rejects directive arguments missing in the definition" $-                let queryString = [r|+                let queryString = [gql|                   {                     dog {                       isHousetrained(atOtherHomes: true) @include(unless: false, if: true)@@ -657,13 +657,13 @@                         { message =                             "Unknown argument \"unless\" on directive \                             \\"@include\"."-                        , locations = [AST.Location 4 67]+                        , locations = [AST.Location 3 49]                         }                  in validate queryString `shouldBe` [expected]          context "knownDirectiveNamesRule" $             it "rejects undefined directives" $-                let queryString = [r|+                let queryString = [gql|                   {                     dog {                       isHousetrained(atOtherHomes: true) @ignore(if: true)@@ -672,13 +672,13 @@                 |]                     expected = Error                         { message = "Unknown directive \"@ignore\"."-                        , locations = [AST.Location 4 58]+                        , locations = [AST.Location 3 40]                         }                  in validate queryString `shouldBe` [expected]          context "knownInputFieldNamesRule" $             it "rejects undefined input object fields" $-                let queryString = [r|+                let queryString = [gql|                   {                     findDog(complex: { favoriteCookieFlavor: "Bacon", name: "Jack" }) {                       name@@ -689,13 +689,13 @@                         { message =                             "Field \"favoriteCookieFlavor\" is not defined \                             \by type \"DogData\"."-                        , locations = [AST.Location 3 40]+                        , locations = [AST.Location 2 22]                         }                  in validate queryString `shouldBe` [expected]          context "directivesInValidLocationsRule" $             it "rejects directives in invalid locations" $-                let queryString = [r|+                let queryString = [gql|                   query @skip(if: $foo) {                     dog {                       name@@ -705,13 +705,13 @@                     expected = Error                         { message =                             "Directive \"@skip\" may not be used on QUERY."-                        , locations = [AST.Location 2 25]+                        , locations = [AST.Location 1 7]                         }                  in validate queryString `shouldBe` [expected]          context "overlappingFieldsCanBeMergedRule" $ do             it "fails to merge fields of mismatching types" $-                let queryString = [r|+                let queryString = [gql|                   {                     dog {                       name: nickname@@ -725,12 +725,12 @@                             \\"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]+                        , locations = [AST.Location 3 5, AST.Location 4 5]                         }                  in validate queryString `shouldBe` [expected]              it "fails if the arguments of the same field don't match" $-                let queryString = [r|+                let queryString = [gql|                   {                     dog {                       doesKnowCommand(dogCommand: SIT)@@ -744,12 +744,12 @@                             \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]+                        , locations = [AST.Location 3 5, AST.Location 4 5]                         }                  in validate queryString `shouldBe` [expected]              it "fails to merge same-named field and alias" $-                let queryString = [r|+                let queryString = [gql|                   {                     dog {                       doesKnowCommand(dogCommand: SIT)@@ -763,12 +763,12 @@                             \\"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]+                        , locations = [AST.Location 3 5, AST.Location 4 5]                         }                  in validate queryString `shouldBe` [expected]              it "looks for fields after a successfully merged field pair" $-                let queryString = [r|+                let queryString = [gql|                   {                     dog {                       name@@ -786,13 +786,13 @@                             \\"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]+                        , locations = [AST.Location 4 5, AST.Location 8 5]                         }                  in validate queryString `shouldBe` [expected]          context "possibleFragmentSpreadsRule" $ do             it "rejects object inline spreads outside object scope" $-                let queryString = [r|+                let queryString = [gql|                   {                     dog {                       ... on Cat {@@ -805,12 +805,12 @@                         { message =                             "Fragment cannot be spread here as objects of type \                             \\"Dog\" can never be of type \"Cat\"."-                        , locations = [AST.Location 4 23]+                        , locations = [AST.Location 3 5]                         }                  in validate queryString `shouldBe` [expected]              it "rejects object named spreads outside object scope" $-                let queryString = [r|+                let queryString = [gql|                   {                     dog {                       ... catInDogFragmentInvalid@@ -826,13 +826,13 @@                             "Fragment \"catInDogFragmentInvalid\" cannot be \                             \spread here as objects of type \"Dog\" can never \                             \be of type \"Cat\"."-                        , locations = [AST.Location 4 23]+                        , locations = [AST.Location 3 5]                         }                  in validate queryString `shouldBe` [expected]          context "providedRequiredInputFieldsRule" $             it "rejects missing required input fields" $-                let queryString = [r|+                let queryString = [gql|                   {                     findDog(complex: { name: null }) {                       name@@ -843,13 +843,13 @@                         { message =                             "Input field \"name\" of type \"DogData\" is \                             \required, but it was not provided."-                        , locations = [AST.Location 3 38]+                        , locations = [AST.Location 2 20]                         }                  in validate queryString `shouldBe` [expected]          context "providedRequiredArgumentsRule" $ do             it "checks for (non-)nullable arguments" $-                let queryString = [r|+                let queryString = [gql|                   {                     dog {                       doesKnowCommand(dogCommand: null)@@ -861,13 +861,13 @@                             "Field \"doesKnowCommand\" argument \"dogCommand\" \                             \of type \"DogCommand\" is required, but it was \                             \not provided."-                        , locations = [AST.Location 4 23]+                        , locations = [AST.Location 3 5]                         }                  in validate queryString `shouldBe` [expected]          context "variablesInAllowedPositionRule" $ do             it "rejects wrongly typed variable arguments" $-                let queryString = [r|+                let queryString = [gql|                   query dogCommandArgQuery($dogCommandArg: DogCommand) {                     dog {                       doesKnowCommand(dogCommand: $dogCommandArg)@@ -879,12 +879,12 @@                             "Variable \"$dogCommandArg\" of type \                             \\"DogCommand\" used in position expecting type \                             \\"!DogCommand\"."-                        , locations = [AST.Location 2 44]+                        , locations = [AST.Location 1 26]                         }                  in validate queryString `shouldBe` [expected]              it "rejects wrongly typed variable arguments" $-                let queryString = [r|+                let queryString = [gql|                   query intCannotGoIntoBoolean($intArg: Int) {                     dog {                       isHousetrained(atOtherHomes: $intArg)@@ -895,13 +895,13 @@                         { message =                             "Variable \"$intArg\" of type \"Int\" used in \                             \position expecting type \"Boolean\"."-                        , locations = [AST.Location 2 48]+                        , locations = [AST.Location 1 30]                         }                  in validate queryString `shouldBe` [expected]          context "valuesOfCorrectTypeRule" $ do             it "rejects values of incorrect types" $-                let queryString = [r|+                let queryString = [gql|                   {                     dog {                       isHousetrained(atOtherHomes: 3)@@ -911,12 +911,12 @@                     expected = Error                         { message =                             "Value 3 cannot be coerced to type \"Boolean\"."-                        , locations = [AST.Location 4 52]+                        , locations = [AST.Location 3 34]                         }                  in validate queryString `shouldBe` [expected]              it "uses the location of a single list value" $-                let queryString = [r|+                let queryString = [gql|                   {                     cat {                       doesKnowCommands(catCommands: [3])@@ -926,12 +926,12 @@                     expected = Error                         { message =                             "Value 3 cannot be coerced to type \"!CatCommand\"."-                        , locations = [AST.Location 4 54]+                        , locations = [AST.Location 3 36]                         }                  in validate queryString `shouldBe` [expected]              it "validates input object properties once" $-                let queryString = [r|+                let queryString = [gql|                   {                     findDog(complex: { name: 3 }) {                       name@@ -941,12 +941,12 @@                     expected = Error                         { message =                             "Value 3 cannot be coerced to type \"!String\"."-                        , locations = [AST.Location 3 46]+                        , locations = [AST.Location 2 28]                         }                  in validate queryString `shouldBe` [expected]              it "checks for required list members" $-                let queryString = [r|+                let queryString = [gql|                   {                     cat {                       doesKnowCommands(catCommands: [null])@@ -957,6 +957,6 @@                         { message =                             "List of non-null values of type \"CatCommand\" \                             \cannot contain null values."-                        , locations = [AST.Location 4 54]+                        , locations = [AST.Location 3 36]                         }                  in validate queryString `shouldBe` [expected]

@@ -12,11 +12,11 @@ import qualified Data.Aeson as Aeson import qualified Data.HashMap.Strict as HashMap import Language.GraphQL+import Language.GraphQL.TH import Language.GraphQL.Type import qualified Language.GraphQL.Type.Out as Out import Test.Hspec (Spec, describe, it) import Test.Hspec.GraphQL-import Text.RawString.QQ (r)  experimentalResolver :: Schema IO experimentalResolver = schema queryType Nothing Nothing mempty@@ -33,7 +33,7 @@ spec =     describe "Directive executor" $ do         it "should be able to @skip fields" $ do-            let sourceQuery = [r|+            let sourceQuery = [gql|               {                 experimentalField @skip(if: true)               }@@ -43,7 +43,7 @@             actual `shouldResolveTo` emptyObject          it "should not skip fields if @skip is false" $ do-            let sourceQuery = [r|+            let sourceQuery = [gql|               {                 experimentalField @skip(if: false)               }@@ -56,7 +56,7 @@             actual `shouldResolveTo` expected          it "should skip fields if @include is false" $ do-            let sourceQuery = [r|+            let sourceQuery = [gql|               {                 experimentalField @include(if: false)               }@@ -66,7 +66,7 @@             actual `shouldResolveTo` emptyObject          it "should be able to @skip a fragment spread" $ do-            let sourceQuery = [r|+            let sourceQuery = [gql|               {                 ...experimentalFragment @skip(if: true)               }@@ -80,7 +80,7 @@             actual `shouldResolveTo` emptyObject          it "should be able to @skip an inline fragment" $ do-            let sourceQuery = [r|+            let sourceQuery = [gql|               {                 ... on Query @skip(if: true) {                   experimentalField

@@ -15,9 +15,9 @@ import Language.GraphQL import Language.GraphQL.Type import qualified Language.GraphQL.Type.Out as Out+import Language.GraphQL.TH import Test.Hspec (Spec, describe, it) import Test.Hspec.GraphQL-import Text.RawString.QQ (r)  size :: (Text, Value) size = ("size", String "L")@@ -34,16 +34,18 @@     )  inlineQuery :: Text-inlineQuery = [r|{-  garment {-    ... on Hat {-      circumference-    }-    ... on Shirt {-      size+inlineQuery = [gql|+  {+    garment {+      ... on Hat {+        circumference+      }+      ... on Shirt {+        size+      }     }   }-}|]+|]  shirtType :: Out.ObjectType IO shirtType = Out.ObjectType "Shirt" Nothing [] $ HashMap.fromList@@ -106,12 +108,14 @@              in actual `shouldResolveTo` expected          it "embeds inline fragments without type" $ do-            let sourceQuery = [r|{-              circumference-              ... {-                size+            let sourceQuery = [gql|+              {+                circumference+                ... {+                  size+                }               }-            }|]+            |]             actual <- graphql (toSchema "circumference" circumference) sourceQuery             let expected = HashMap.singleton "data"                     $ Aeson.object@@ -121,16 +125,18 @@              in actual `shouldResolveTo` expected          it "evaluates fragments on Query" $ do-            let sourceQuery = [r|{-              ... {-                size+            let sourceQuery = [gql|+              {+                ... {+                  size+                }               }-            }|]+            |]              in graphql (toSchema "size" size) `shouldResolve` sourceQuery      describe "Fragment spread executor" $ do         it "evaluates fragment spreads" $ do-            let sourceQuery = [r|+            let sourceQuery = [gql|               {                 ...circumferenceFragment               }@@ -148,7 +154,7 @@              in actual `shouldResolveTo` expected          it "evaluates nested fragments" $ do-            let sourceQuery = [r|+            let sourceQuery = [gql|               {                 garment {                   ...circumferenceFragment@@ -174,7 +180,7 @@              in actual `shouldResolveTo` expected          it "considers type condition" $ do-            let sourceQuery = [r|+            let sourceQuery = [gql|               {                 garment {                   ...circumferenceFragment

@@ -12,7 +12,7 @@ import qualified Data.HashMap.Strict as HashMap import Language.GraphQL import Test.Hspec (Spec, describe, it)-import Text.RawString.QQ (r)+import Language.GraphQL.TH import Language.GraphQL.Type import qualified Language.GraphQL.Type.Out as Out import Test.Hspec.GraphQL@@ -42,7 +42,7 @@ spec =     describe "Root operation type" $ do         it "returns objects from the root resolvers" $ do-            let querySource = [r|+            let querySource = [gql|               {                 garment {                   circumference@@ -59,7 +59,7 @@             actual `shouldResolveTo` expected          it "chooses Mutation" $ do-            let querySource = [r|+            let querySource = [gql|               mutation {                 incrementCircumference               }