Allow version 2.0 of the text package.

- `Serialize` instance for `Type.Definition.Value`.
- `VariableValue` instance for `Type.Definition.Value`.

It makes it possible to use the library without an additional
serialization format like JSON.

CHANGELOG.md

@@ -6,6 +6,24 @@ The format is based on
 and this project adheres to
 [Haskell Package Versioning Policy](https://pvp.haskell.org/).
 
+## [1.0.3.0] - 2022-03-27
+### Fixed
+- Index position in error path. (Index and Segment paths of a field have been
+  swapped).
+- Parsing empty list as an argument.
+
+### Added
+- quickCheck Parser test for arguments. Arbitrary instances for Language.GraphQL.AST.Document.
+- Enhanced query error messages. Add tests for these cases.
+- Allow version 2.0 of the text package.
+
+## [1.0.2.0] - 2021-12-26
+### Added
+- `Serialize` instance for `Type.Definition.Value`.
+- `VariableValue` instance for `Type.Definition.Value`.
+- `Json` build flag, enabled by default. JSON and Aeson support can be disabled
+  by disabling this flag.
+
 ## [1.0.1.0] - 2021-09-27
 ### Added
 - Custom `Show` instance for `Type.Definition.Value` (for error
@@ -459,6 +477,8 @@ and this project adheres to
 ### Added
 - Data types for the GraphQL language.
 
+[1.0.3.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=1.0.3.0&rev_to=v1.0.2.0
+[1.0.2.0]: https://www.caraus.tech/projects/pub-graphql/repository/23/diff?rev=1.0.2.0&rev_to=v1.0.1.0
 [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

graphql.cabal

@@ -1,7 +1,7 @@
-cabal-version: 2.2
+cabal-version: 2.4
 
 name:           graphql
-version:        1.0.1.0
+version:        1.0.3.0
 synopsis:       Haskell GraphQL implementation
 description:    Haskell <https://spec.graphql.org/June2018/ GraphQL> implementation.
 category:       Language
@@ -18,93 +18,103 @@ license-files:  LICENSE,
                 LICENSE.MPL
 build-type:     Simple
 extra-source-files:
-    CHANGELOG.md
-    README.md
+  CHANGELOG.md
+  README.md
 tested-with:
-    GHC == 8.10.7
-  , GHC == 9.0.1
+  GHC == 8.10.7,
+  GHC == 9.2.2
 
 source-repository head
   type: git
   location: git://caraus.tech/pub/graphql.git
 
+flag Json
+  description: Whether to build against @aeson 1.x@
+  default: True
+  manual: True
+
 library
   exposed-modules:
-      Language.GraphQL
-      Language.GraphQL.AST
-      Language.GraphQL.AST.DirectiveLocation
-      Language.GraphQL.AST.Document
-      Language.GraphQL.AST.Encoder
-      Language.GraphQL.AST.Lexer
-      Language.GraphQL.AST.Parser
-      Language.GraphQL.Error
-      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
-      Language.GraphQL.Type.Schema
-      Language.GraphQL.Validate
-      Language.GraphQL.Validate.Validation
-      Test.Hspec.GraphQL
+    Language.GraphQL
+    Language.GraphQL.AST
+    Language.GraphQL.AST.DirectiveLocation
+    Language.GraphQL.AST.Document
+    Language.GraphQL.AST.Encoder
+    Language.GraphQL.AST.Lexer
+    Language.GraphQL.AST.Parser
+    Language.GraphQL.Error
+    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
+    Language.GraphQL.Type.Schema
+    Language.GraphQL.Validate
+    Language.GraphQL.Validate.Validation
+    Test.Hspec.GraphQL
   other-modules:
-      Language.GraphQL.Execute.Transform
-      Language.GraphQL.Type.Definition
-      Language.GraphQL.Type.Internal
-      Language.GraphQL.Validate.Rules
+    Language.GraphQL.Execute.Transform
+    Language.GraphQL.Type.Definition
+    Language.GraphQL.Type.Internal
+    Language.GraphQL.Validate.Rules
   hs-source-dirs:
-      src
+    src
   ghc-options: -Wall
+
   build-depends:
-      aeson >= 1.5.6 && < 1.6
-    , base >= 4.7 && < 5
-    , conduit >= 1.3.4 && < 1.4
-    , containers >= 0.6.2 && < 0.7
-    , exceptions >= 0.10.4 && < 0.11
-    , hspec-expectations >= 0.8.2 && < 0.9
-    , 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
-    , vector >= 0.12.3 && < 0.13
+    base >= 4.7 && < 5,
+    conduit ^>= 1.3.4,
+    containers ^>= 0.6.2,
+    exceptions ^>= 0.10.4,
+    megaparsec >= 9.0 && < 10,
+    parser-combinators >= 1.3 && < 2,
+    template-haskell >= 2.16 && < 3,
+    text >= 1.2 && < 3,
+    transformers ^>= 0.5.6,
+    unordered-containers ^>= 0.2.14,
+    vector ^>= 0.12.3
+  if flag(Json)
+    build-depends:
+      aeson >= 1.5.6 && < 1.6,
+      hspec-expectations >= 0.8.2 && < 0.9,
+      scientific >= 0.3.7 && < 0.4
+    cpp-options: -DWITH_JSON
+
   default-language: Haskell2010
 
 test-suite graphql-test
   type: exitcode-stdio-1.0
   main-is: Spec.hs
   other-modules:
-      Language.GraphQL.AST.DocumentSpec
-      Language.GraphQL.AST.EncoderSpec
-      Language.GraphQL.AST.LexerSpec
-      Language.GraphQL.AST.ParserSpec
-      Language.GraphQL.ErrorSpec
-      Language.GraphQL.Execute.CoerceSpec
-      Language.GraphQL.Execute.OrderedMapSpec
-      Language.GraphQL.ExecuteSpec
-      Language.GraphQL.Type.OutSpec
-      Language.GraphQL.Validate.RulesSpec
-      Test.DirectiveSpec
-      Test.FragmentSpec
-      Test.RootOperationSpec
+    Language.GraphQL.AST.DocumentSpec
+    Language.GraphQL.AST.EncoderSpec
+    Language.GraphQL.AST.LexerSpec
+    Language.GraphQL.AST.ParserSpec
+    Language.GraphQL.AST.Arbitrary
+    Language.GraphQL.ErrorSpec
+    Language.GraphQL.Execute.CoerceSpec
+    Language.GraphQL.Execute.OrderedMapSpec
+    Language.GraphQL.ExecuteSpec
+    Language.GraphQL.Type.OutSpec
+    Language.GraphQL.Validate.RulesSpec
+    Schemas.HeroSchema
   hs-source-dirs:
-      tests
+    tests
   ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall
+
   build-depends:
-      QuickCheck >= 2.14.1 && < 2.15
-    , aeson
-    , base >= 4.8 && < 5
-    , conduit
-    , exceptions
-    , graphql
-    , hspec >= 2.8.2 && < 2.9
-    , hspec-megaparsec >= 2.2.0 && < 2.3
-    , megaparsec
-    , scientific
-    , text
-    , unordered-containers
+    QuickCheck ^>= 2.14.1,
+    base,
+    conduit,
+    exceptions,
+    graphql,
+    hspec ^>= 2.9.1,
+    hspec-megaparsec ^>= 2.2.0,
+    megaparsec,
+    text,
+    unordered-containers,
+    containers,
+    vector
   default-language: Haskell2010

src/Language/GraphQL.hs

@@ -1,6 +1,8 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 
+#ifdef WITH_JSON
 -- | This module provides the functions to parse and execute @GraphQL@ queries.
 module Language.GraphQL
     ( graphql
@@ -73,3 +75,49 @@ graphqlSubs schema operationName variableValues document' =
         [ ("line", Aeson.toJSON line)
         , ("column", Aeson.toJSON column)
         ]
+#else
+-- | This module provides the functions to parse and execute @GraphQL@ queries.
+module Language.GraphQL
+    ( graphql
+    ) where
+
+import Control.Monad.Catch (MonadCatch)
+import Data.HashMap.Strict (HashMap)
+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.Error
+import Language.GraphQL.Execute
+import qualified Language.GraphQL.Validate as Validate
+import Language.GraphQL.Type.Schema (Schema)
+import Prelude hiding (null)
+import Text.Megaparsec (parse)
+
+-- | If the text parses correctly as a @GraphQL@ query the query is
+-- executed using the given 'Schema'.
+--
+-- An operation name can be given if the document contains multiple operations.
+graphql :: (MonadCatch m, VariableValue a, Serialize b)
+    => Schema m -- ^ Resolvers.
+    -> Maybe Text -- ^ Operation name.
+    -> HashMap Full.Name a -- ^ Variable substitution function.
+    -> Text -- ^ Text representing a @GraphQL@ request document.
+    -> m (Either (ResponseEventStream m b) (Response b)) -- ^ Response.
+graphql schema operationName variableValues document' =
+    case parse Full.document "" document' of
+        Left errorBundle -> pure  <$> parseError errorBundle
+        Right parsed ->
+            case validate parsed of
+                Seq.Empty -> execute schema operationName variableValues parsed
+                errors -> pure $ pure
+                    $ Response null
+                    $ fromValidationError <$> errors
+  where
+    validate = Validate.document schema Validate.specifiedRules
+    fromValidationError Validate.Error{..} = Error
+        { message = Text.pack message
+        , locations = locations
+        , path = []
+        }
+#endif

src/Language/GraphQL/AST/Document.hs

@@ -49,6 +49,8 @@ module Language.GraphQL.AST.Document
     , Value(..)
     , VariableDefinition(..)
     , escape
+    , showVariableName
+    , showVariable
     ) where
 
 import Data.Char (ord)
@@ -339,6 +341,12 @@ data VariableDefinition =
     VariableDefinition Name Type (Maybe (Node ConstValue)) Location
     deriving (Eq, Show)
 
+showVariableName :: VariableDefinition -> String
+showVariableName (VariableDefinition name _ _ _) = "$" <> Text.unpack name
+
+showVariable :: VariableDefinition -> String
+showVariable var@(VariableDefinition _ type' _ _) = showVariableName var <> ":" <> " " <> show type'
+
 -- ** Type References
 
 -- | Type representation.

src/Language/GraphQL/AST/Parser.hs

@@ -450,8 +450,8 @@ value = Full.Variable <$> variable
     <|> Full.Null <$  nullValue
     <|> Full.String <$> stringValue
     <|> Full.Enum <$> try enumValue
-    <|> Full.List <$> brackets (some $ valueNode value)
-    <|> Full.Object <$> braces (some $ objectField $ valueNode value)
+    <|> Full.List <$> brackets (many $ valueNode value)
+    <|> Full.Object <$> braces (many $ objectField $ valueNode value)
     <?> "Value"
 
 constValue :: Parser Full.ConstValue

src/Language/GraphQL/Execute.hs

@@ -61,6 +61,7 @@ import Language.GraphQL.Error
     , ResponseEventStream
     )
 import Prelude hiding (null)
+import Language.GraphQL.AST.Document (showVariableName)
 
 newtype ExecutorT m a = ExecutorT
     { runExecutorT :: ReaderT (HashMap Full.Name (Type m)) (WriterT (Seq Error) m) a
@@ -190,32 +191,42 @@ data QueryError
 tell :: Monad m => Seq Error -> ExecutorT m ()
 tell = ExecutorT . lift . Writer.tell
 
+operationNameErrorText :: Text
+operationNameErrorText = Text.unlines
+    [ "Named operations must be provided with the name of the desired operation."
+    , "See https://spec.graphql.org/June2018/#sec-Language.Document description."
+    ]
+
 queryError :: QueryError -> Error
 queryError OperationNameRequired =
-    Error{ message = "Operation name is required.", locations = [], path = [] }
+    let queryErrorMessage = "Operation name is required. " <> operationNameErrorText
+    in Error{ message = queryErrorMessage, locations = [], path = [] }
 queryError (OperationNotFound operationName) =
-    let queryErrorMessage = Text.concat
-            [ "Operation \""
-            , Text.pack operationName
-            , "\" not found."
+    let queryErrorMessage = Text.unlines
+            [ Text.concat
+              [ "Operation \""
+              , Text.pack operationName
+              , "\" is not found in the named operations you've provided. "
+              ]
+            , operationNameErrorText
             ]
      in Error{ message = queryErrorMessage, locations = [], path = [] }
 queryError (CoercionError variableDefinition) =
-    let Full.VariableDefinition variableName _ _ location = variableDefinition
+    let (Full.VariableDefinition _ _ _ location) = variableDefinition
         queryErrorMessage = Text.concat
-            [ "Failed to coerce the variable \""
-            , variableName
-            , "\"."
+            [ "Failed to coerce the variable "
+            , Text.pack $ Full.showVariable variableDefinition
+            , "."
             ]
      in Error{ message = queryErrorMessage, locations = [location], path = [] }
 queryError (UnknownInputType variableDefinition) =
-    let Full.VariableDefinition variableName variableTypeName _ location = variableDefinition
+    let Full.VariableDefinition _ variableTypeName _ location = variableDefinition
         queryErrorMessage = Text.concat
-            [ "Variable \""
-            , variableName
-            , "\" has unknown type \""
+            [ "Variable "
+            , Text.pack $ showVariableName variableDefinition
+            , " has unknown type "
             , Text.pack $ show variableTypeName
-            , "\"."
+            , "."
             ]
      in Error{ message = queryErrorMessage, locations = [location], path = [] }
 
@@ -375,6 +386,7 @@ executeField objectValue fields (viewResolver -> resolverPair) errorPath =
         , Handler (resolverHandler fieldLocation)
         ]
   where
+    fieldErrorPath = fieldsSegment fields : errorPath
     inputCoercionHandler :: (MonadCatch m, Serialize a)
         => Full.Location
         -> InputCoercionException
@@ -402,17 +414,16 @@ executeField objectValue fields (viewResolver -> resolverPair) errorPath =
              then throwM e
              else returnError newError
     exceptionHandler errorLocation e =
-        let newPath = fieldsSegment fields : errorPath
-            newError = constructError e errorLocation newPath
+        let newError = constructError e errorLocation fieldErrorPath
          in if Out.isNonNullType fieldType
-             then throwM $ FieldException errorLocation newPath e
+             then throwM $ FieldException errorLocation fieldErrorPath 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
+        completeValue fieldType fields fieldErrorPath resolvedValue
     (resolverField, resolveFunction) = resolverPair
     Out.Field _ fieldType argumentTypes = resolverField
 
@@ -445,6 +456,7 @@ resolveAbstractType abstractType values'
             _ -> pure Nothing
     | otherwise = pure Nothing
 
+-- https://spec.graphql.org/October2021/#sec-Value-Completion
 completeValue :: (MonadCatch m, Serialize a)
     => Out.Type m
     -> NonEmpty (Transform.Field m)
@@ -476,8 +488,7 @@ completeValue outputType@(Out.EnumBaseType enumType) _ _ (Type.Enum enum) =
             $ ValueCompletionException (show outputType)
             $ Type.Enum enum
 completeValue (Out.ObjectBaseType objectType) fields errorPath result
-    = executeSelectionSet (mergeSelectionSets fields) objectType result
-    $ fieldsSegment fields : errorPath
+    = executeSelectionSet (mergeSelectionSets fields) objectType result errorPath
 completeValue outputType@(Out.InterfaceBaseType interfaceType) fields errorPath result
     | Type.Object objectMap <- result = do
         let abstractType = Type.Internal.AbstractInterfaceType interfaceType

src/Language/GraphQL/Execute/Coerce.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE ExplicitForAll #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE CPP #-}
 
 -- | Types and functions used for input and result coercion.
 module Language.GraphQL.Execute.Coerce
@@ -15,7 +16,10 @@ module Language.GraphQL.Execute.Coerce
     , matchFieldValues
     ) where
 
+#ifdef WITH_JSON
 import qualified Data.Aeson as Aeson
+import Data.Scientific (toBoundedInteger, toRealFloat)
+#endif
 import Data.Int (Int32)
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
@@ -24,7 +28,6 @@ import Data.Text (Text)
 import qualified Data.Text.Lazy as Text.Lazy
 import qualified Data.Text.Lazy.Builder as Text.Builder
 import qualified Data.Text.Lazy.Builder.Int as Text.Builder
-import Data.Scientific (toBoundedInteger, toRealFloat)
 import Language.GraphQL.AST (Name)
 import Language.GraphQL.Execute.OrderedMap (OrderedMap)
 import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap
@@ -61,20 +64,13 @@ class VariableValue a where
         -> a -- ^ Variable value being coerced.
         -> Maybe Type.Value -- ^ Coerced value on success, 'Nothing' otherwise.
 
-instance VariableValue Aeson.Value where
-    coerceVariableValue _ Aeson.Null = Just Type.Null
-    coerceVariableValue (In.ScalarBaseType scalarType) value
-        | (Aeson.String stringValue) <- value = Just $ Type.String stringValue
-        | (Aeson.Bool booleanValue) <- value = Just $ Type.Boolean booleanValue
-        | (Aeson.Number numberValue) <- value
-        , (Type.ScalarType "Float" _) <- scalarType =
-            Just $ Type.Float $ toRealFloat numberValue
-        | (Aeson.Number numberValue) <- value = -- ID or Int
-            Type.Int <$> toBoundedInteger numberValue
-    coerceVariableValue (In.EnumBaseType _) (Aeson.String stringValue) =
+instance VariableValue Type.Value where
+    coerceVariableValue _ Type.Null = Just Type.Null
+    coerceVariableValue (In.ScalarBaseType _) value = Just value
+    coerceVariableValue (In.EnumBaseType _) (Type.Enum stringValue) =
         Just $ Type.Enum stringValue
     coerceVariableValue (In.InputObjectBaseType objectType) value
-        | (Aeson.Object objectValue) <- value = do
+        | (Type.Object objectValue) <- value = do
             let (In.InputObjectType _ _ inputFields) = objectType
             (newObjectValue, resultMap) <- foldWithKey objectValue inputFields
             if HashMap.null newObjectValue
@@ -94,14 +90,9 @@ instance VariableValue Aeson.Value where
                         pure (newObjectValue, insert coerced)
                     Nothing -> Just (objectValue, resultMap)
     coerceVariableValue (In.ListBaseType listType) value
-        | (Aeson.Array arrayValue) <- value =
-            Type.List <$> foldr foldVector (Just []) arrayValue
+        | (Type.List arrayValue) <- value =
+            Type.List <$> traverse (coerceVariableValue listType) arrayValue
         | otherwise = coerceVariableValue listType value
-      where
-        foldVector _ Nothing = Nothing
-        foldVector variableValue (Just list) = do
-            coerced <- coerceVariableValue listType variableValue
-            pure $ coerced : list 
     coerceVariableValue _ _ = Nothing
 
 -- | Looks up a value by name in the given map, coerces it and inserts into the
@@ -216,6 +207,28 @@ data Output a
 instance forall a. IsString (Output a) where
     fromString = String . fromString
 
+instance Serialize Type.Value where
+    null = Type.Null
+    serialize (Out.ScalarBaseType scalarType) value
+        | Type.ScalarType "Int" _ <- scalarType
+        , Int int <- value = Just $ Type.Int int
+        | Type.ScalarType "Float" _ <- scalarType
+        , Float float <- value = Just $ Type.Float float
+        | Type.ScalarType "String" _ <- scalarType
+        , String string <- value = Just $ Type.String string
+        | Type.ScalarType "ID" _ <- scalarType
+        , String string <- value = Just $ Type.String string
+        | Type.ScalarType "Boolean" _ <- scalarType
+        , Boolean boolean <- value = Just $ Type.Boolean boolean
+    serialize _ (Enum enum) = Just $ Type.Enum enum
+    serialize _ (List list) = Just $ Type.List list
+    serialize _ (Object object) = Just
+        $ Type.Object
+        $ HashMap.fromList
+        $ OrderedMap.toList object
+    serialize _ _ = Nothing
+
+#ifdef WITH_JSON
 instance Serialize Aeson.Value where
     serialize (Out.ScalarBaseType scalarType) value
         | Type.ScalarType "Int" _ <- scalarType
@@ -236,3 +249,47 @@ instance Serialize Aeson.Value where
         $ Aeson.toJSON <$> object
     serialize _ _ = Nothing
     null = Aeson.Null
+
+instance VariableValue Aeson.Value where
+    coerceVariableValue _ Aeson.Null = Just Type.Null
+    coerceVariableValue (In.ScalarBaseType scalarType) value
+        | (Aeson.String stringValue) <- value = Just $ Type.String stringValue
+        | (Aeson.Bool booleanValue) <- value = Just $ Type.Boolean booleanValue
+        | (Aeson.Number numberValue) <- value
+        , (Type.ScalarType "Float" _) <- scalarType =
+            Just $ Type.Float $ toRealFloat numberValue
+        | (Aeson.Number numberValue) <- value = -- ID or Int
+            Type.Int <$> toBoundedInteger numberValue
+    coerceVariableValue (In.EnumBaseType _) (Aeson.String stringValue) =
+        Just $ Type.Enum stringValue
+    coerceVariableValue (In.InputObjectBaseType objectType) value
+        | (Aeson.Object objectValue) <- value = do
+            let (In.InputObjectType _ _ inputFields) = objectType
+            (newObjectValue, resultMap) <- foldWithKey objectValue inputFields
+            if HashMap.null newObjectValue
+                then Just $ Type.Object resultMap
+                else Nothing
+      where
+        foldWithKey objectValue = HashMap.foldrWithKey matchFieldValues'
+            $ Just (objectValue, HashMap.empty)
+        matchFieldValues' _ _ Nothing = Nothing
+        matchFieldValues' fieldName inputField (Just (objectValue, resultMap)) =
+            let (In.InputField _ fieldType _) = inputField
+                insert = flip (HashMap.insert fieldName) resultMap
+                newObjectValue = HashMap.delete fieldName objectValue
+             in case HashMap.lookup fieldName objectValue of
+                    Just variableValue -> do
+                        coerced <- coerceVariableValue fieldType variableValue
+                        pure (newObjectValue, insert coerced)
+                    Nothing -> Just (objectValue, resultMap)
+    coerceVariableValue (In.ListBaseType listType) value
+        | (Aeson.Array arrayValue) <- value =
+            Type.List <$> foldr foldVector (Just []) arrayValue
+        | otherwise = coerceVariableValue listType value
+      where
+        foldVector _ Nothing = Nothing
+        foldVector variableValue (Just list) = do
+            coerced <- coerceVariableValue listType variableValue
+            pure $ coerced : list 
+    coerceVariableValue _ _ = Nothing
+#endif

src/Language/GraphQL/Type/Schema.hs

@@ -205,5 +205,5 @@ collectImplementations = HashMap.foldr go HashMap.empty
         let Out.ObjectType _ _ interfaces _ = objectType
          in foldr (add implementation) accumulator interfaces
     go _ accumulator = accumulator
-    add implementation (Out.InterfaceType typeName _ _ _) accumulator =
-        HashMap.insertWith (++) typeName [implementation] accumulator
+    add implementation (Out.InterfaceType typeName _ _ _) =
+        HashMap.insertWith (++) typeName [implementation]

src/Language/GraphQL/Validate/Rules.hs

@@ -152,7 +152,7 @@ singleFieldSubscriptionsRule = OperationDefinitionRule $ \case
   where
     errorMessage =
         "Anonymous Subscription must select only one top level field."
-    collectFields selectionSet = foldM forEach HashSet.empty selectionSet
+    collectFields = foldM forEach HashSet.empty
     forEach accumulator = \case
         Full.FieldSelection fieldSelection -> forField accumulator fieldSelection
         Full.FragmentSpreadSelection fragmentSelection ->
@@ -472,7 +472,7 @@ noFragmentCyclesRule = FragmentDefinitionRule $ \case
     collectCycles :: Traversable t
         => t Full.Selection
         -> StateT (Int, Full.Name) (ReaderT (Validation m) Seq) (HashMap Full.Name Int)
-    collectCycles selectionSet = foldM forEach HashMap.empty selectionSet
+    collectCycles = foldM forEach HashMap.empty
     forEach accumulator = \case
         Full.FieldSelection fieldSelection -> forField accumulator fieldSelection
         Full.InlineFragmentSelection fragmentSelection ->
@@ -702,8 +702,7 @@ uniqueInputFieldNamesRule =
   where
     go (Full.Node (Full.Object fields) _) = filterFieldDuplicates fields
     go _ = mempty
-    filterFieldDuplicates fields =
-        filterDuplicates getFieldName "input field" fields
+    filterFieldDuplicates = filterDuplicates getFieldName "input field"
     getFieldName (Full.ObjectField fieldName _ location') = (fieldName, location')
     constGo (Full.Node (Full.ConstObject fields) _) = filterFieldDuplicates fields
     constGo _ = mempty
@@ -1331,8 +1330,8 @@ variablesInAllowedPositionRule = OperationDefinitionRule $ \case
         -> Type.CompositeType m
         -> t Full.Selection
         -> ValidationState m (Seq Error)
-    visitSelectionSet variables selectionType selections =
-        foldM (evaluateSelection variables selectionType) mempty selections
+    visitSelectionSet variables selectionType =
+        foldM (evaluateSelection variables selectionType) mempty
     evaluateFieldSelection variables selections accumulator = \case
         Just newParentType -> do
             let folder = evaluateSelection variables newParentType
@@ -1617,4 +1616,3 @@ valuesOfCorrectTypeRule = ValueRule go constGo
                         }
                 | otherwise -> mempty
             _ -> checkResult
-

src/Test/Hspec/GraphQL.hs

@@ -2,6 +2,9 @@
    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 CPP #-}
+
+#ifdef WITH_JSON
 {-# LANGUAGE ExplicitForAll #-}
 {-# LANGUAGE OverloadedStrings #-}
 
@@ -39,3 +42,8 @@ shouldResolve executor query = do
             response `shouldNotSatisfy` HashMap.member "errors"
         _ -> expectationFailure
             "the query is expected to resolve to a value, but it resolved to an event stream"
+#else
+module Test.Hspec.GraphQL
+    (
+    ) where
+#endif

tests/Language/GraphQL/AST/Arbitrary.hs

@@ -0,0 +1,99 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Language.GraphQL.AST.Arbitrary where
+
+import qualified Language.GraphQL.AST.Document as Doc
+import Test.QuickCheck.Arbitrary (Arbitrary (arbitrary))
+import Test.QuickCheck (oneof, elements, listOf, resize, NonEmptyList (..))
+import Test.QuickCheck.Gen (Gen (..))
+import Data.Text (Text, pack)
+
+newtype AnyPrintableChar = AnyPrintableChar { getAnyPrintableChar :: Char } deriving (Eq, Show)
+
+alpha :: String
+alpha = ['a'..'z'] <> ['A'..'Z']
+
+num :: String
+num = ['0'..'9']
+
+instance Arbitrary AnyPrintableChar where
+    arbitrary = AnyPrintableChar <$> elements chars
+        where
+           chars = alpha <> num <> ['_'] 
+
+newtype AnyPrintableText = AnyPrintableText { getAnyPrintableText :: Text } deriving (Eq, Show)
+
+instance Arbitrary AnyPrintableText where
+    arbitrary = do
+        nonEmptyStr <- getNonEmpty <$> (arbitrary :: Gen (NonEmptyList AnyPrintableChar))
+        pure $ AnyPrintableText (pack $ map getAnyPrintableChar nonEmptyStr)
+
+-- https://spec.graphql.org/June2018/#Name
+newtype AnyName = AnyName { getAnyName :: Text } deriving (Eq, Show)
+
+instance Arbitrary AnyName where
+    arbitrary = do
+        firstChar <- elements $ alpha <> ['_']
+        rest <- (arbitrary :: Gen [AnyPrintableChar])
+        pure $ AnyName (pack $ firstChar : map getAnyPrintableChar rest)
+
+newtype AnyLocation = AnyLocation { getAnyLocation :: Doc.Location } deriving (Eq, Show)
+
+instance Arbitrary AnyLocation where
+    arbitrary = AnyLocation <$> (Doc.Location <$> arbitrary <*> arbitrary)
+
+newtype AnyNode a = AnyNode { getAnyNode :: Doc.Node a } deriving (Eq, Show)
+
+instance Arbitrary a => Arbitrary (AnyNode a) where
+    arbitrary = do
+        (AnyLocation location') <- arbitrary
+        node' <- flip Doc.Node location' <$> arbitrary
+        pure $ AnyNode node'
+
+newtype AnyObjectField a = AnyObjectField { getAnyObjectField :: Doc.ObjectField a } deriving (Eq, Show)
+
+instance Arbitrary a => Arbitrary (AnyObjectField a) where
+    arbitrary = do
+        name' <- getAnyName <$> arbitrary
+        value' <- getAnyNode <$> arbitrary
+        location' <- getAnyLocation <$> arbitrary
+        pure $ AnyObjectField $ Doc.ObjectField name' value' location'
+
+newtype AnyValue = AnyValue { getAnyValue :: Doc.Value } deriving (Eq, Show)
+
+instance Arbitrary AnyValue where
+    arbitrary = AnyValue <$> oneof
+        [ variableGen
+        , Doc.Int <$> arbitrary
+        , Doc.Float <$> arbitrary
+        , Doc.String <$> (getAnyPrintableText <$> arbitrary)
+        , Doc.Boolean <$> arbitrary
+        , MkGen $ \_ _ -> Doc.Null
+        , Doc.Enum <$> (getAnyName <$> arbitrary)
+        , Doc.List <$> listGen
+        , Doc.Object <$> objectGen
+        ]
+            where
+                variableGen :: Gen Doc.Value
+                variableGen = Doc.Variable <$> (getAnyName <$> arbitrary)
+                listGen :: Gen [Doc.Node Doc.Value]
+                listGen = (resize 5 . listOf) nodeGen
+                nodeGen = do
+                    node' <- getAnyNode <$> (arbitrary :: Gen (AnyNode AnyValue))
+                    pure (getAnyValue <$> node')
+                objectGen :: Gen [Doc.ObjectField Doc.Value]
+                objectGen = resize 1 $ do
+                    list <- getNonEmpty <$> (arbitrary :: Gen (NonEmptyList (AnyObjectField AnyValue)))
+                    pure $ map (fmap getAnyValue . getAnyObjectField) list
+
+newtype AnyArgument a = AnyArgument { getAnyArgument :: Doc.Argument } deriving (Eq, Show)
+
+instance Arbitrary a => Arbitrary (AnyArgument a) where
+    arbitrary = do
+        name' <- getAnyName <$> arbitrary
+        (AnyValue value') <- arbitrary
+        (AnyLocation location') <- arbitrary
+        pure $ AnyArgument $ Doc.Argument name' (Doc.Node value' location') location'
+
+printArgument :: AnyArgument AnyValue -> Text
+printArgument (AnyArgument (Doc.Argument name' (Doc.Node value' _) _)) = name' <> ": " <> (pack . show) value'

tests/Language/GraphQL/AST/ParserSpec.hs

@@ -5,46 +5,78 @@ module Language.GraphQL.AST.ParserSpec
     ) where
 
 import Data.List.NonEmpty (NonEmpty(..))
+import Data.Text (Text)
+import qualified Data.Text as Text
 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 (Spec, describe, it, context)
 import Test.Hspec.Megaparsec (shouldParse, shouldFailOn, shouldSucceedOn)
 import Text.Megaparsec (parse)
+import Test.QuickCheck (property, NonEmptyList (..), mapSize)
+import Language.GraphQL.AST.Arbitrary
 
 spec :: Spec
 spec = describe "Parser" $ do
     it "accepts BOM header" $
         parse document "" `shouldSucceedOn` "\xfeff{foo}"
 
-    it "accepts block strings as argument" $
-        parse document "" `shouldSucceedOn` [gql|{
-              hello(text: """Argument""")
-            }|]
+    context "Arguments" $ do
+       it "accepts block strings as argument" $
+           parse document "" `shouldSucceedOn` [gql|{
+                 hello(text: """Argument""")
+               }|]
 
-    it "accepts strings as argument" $
-        parse document "" `shouldSucceedOn` [gql|{
-              hello(text: "Argument")
-            }|]
+       it "accepts strings as argument" $
+           parse document "" `shouldSucceedOn` [gql|{
+                 hello(text: "Argument")
+               }|]
 
-    it "accepts two required arguments" $
-        parse document "" `shouldSucceedOn` [gql|
-            mutation auth($username: String!, $password: String!){
-              test
-            }|]
+       it "accepts int as argument1" $
+           parse document "" `shouldSucceedOn` [gql|{
+                 user(id: 4)
+               }|]
 
-    it "accepts two string arguments" $
-        parse document "" `shouldSucceedOn` [gql|
-            mutation auth{
-              test(username: "username", password: "password")
-            }|]
+       it "accepts boolean as argument" $
+           parse document "" `shouldSucceedOn` [gql|{
+                 hello(flag: true) { field1 }
+               }|]
 
-    it "accepts two block string arguments" $
-        parse document "" `shouldSucceedOn` [gql|
-            mutation auth{
-              test(username: """username""", password: """password""")
-            }|]
+       it "accepts float as argument" $
+           parse document "" `shouldSucceedOn` [gql|{
+                 body(height: 172.5) { height }
+               }|]
+
+       it "accepts empty list as argument" $
+           parse document "" `shouldSucceedOn` [gql|{
+                 query(list: []) { field1 }
+               }|]
+
+       it "accepts two required arguments" $
+           parse document "" `shouldSucceedOn` [gql|
+               mutation auth($username: String!, $password: String!){
+                 test
+               }|]
+
+       it "accepts two string arguments" $
+           parse document "" `shouldSucceedOn` [gql|
+               mutation auth{
+                 test(username: "username", password: "password")
+               }|]
+
+       it "accepts two block string arguments" $
+           parse document "" `shouldSucceedOn` [gql|
+               mutation auth{
+                 test(username: """username""", password: """password""")
+               }|]
+ 
+       it "accepts any arguments" $ mapSize (const 10) $ property $ \xs ->
+            let
+                query' :: Text
+                arguments = map printArgument $ getNonEmpty (xs :: NonEmptyList (AnyArgument AnyValue))
+                query' = "query(" <> Text.intercalate ", " arguments <> ")" in
+            parse document "" `shouldSucceedOn` ("{ " <> query' <> " }")
 
     it "parses minimal schema definition" $
         parse document "" `shouldSucceedOn` [gql|schema { query: Query }|]
@@ -95,16 +127,6 @@ spec = describe "Parser" $ do
             }
         |]
 
-    it "parses minimal enum type definition" $
-        parse document "" `shouldSucceedOn` [gql|
-            enum Direction {
-              NORTH
-              EAST
-              SOUTH
-              WEST
-            }
-        |]
-
     it "parses minimal input object type definition" $
         parse document "" `shouldSucceedOn` [gql|
             input Point2D {
@@ -202,6 +224,13 @@ spec = describe "Parser" $ do
             }
         |]
 
+    it "rejects empty selection set" $
+       parse document "" `shouldFailOn` [gql|
+            query {
+              innerField {}
+            }
+        |]
+
     it "parses documents beginning with a comment" $
         parse document "" `shouldSucceedOn` [gql|
             """

tests/Language/GraphQL/ErrorSpec.hs

@@ -7,9 +7,9 @@ module Language.GraphQL.ErrorSpec
     ( spec
     ) where
 
-import qualified Data.Aeson as Aeson
 import Data.List.NonEmpty (NonEmpty (..))
 import Language.GraphQL.Error
+import qualified Language.GraphQL.Type as Type
 import Test.Hspec
     ( Spec
     , describe
@@ -31,6 +31,6 @@ spec = describe "parseError" $
                 , pstateTabWidth = mkPos 1
                 , pstateLinePrefix = ""
                 }
-        Response Aeson.Null actual <-
+        Response Type.Null actual <-
             parseError (ParseErrorBundle parseErrors posState)
         length actual `shouldBe` 1

tests/Language/GraphQL/Execute/CoerceSpec.hs

@@ -7,12 +7,8 @@ module Language.GraphQL.Execute.CoerceSpec
     ( spec
     ) where
 
-import Data.Aeson as Aeson ((.=))
-import qualified Data.Aeson as Aeson
-import qualified Data.Aeson.Types as Aeson
 import qualified Data.HashMap.Strict as HashMap
 import Data.Maybe (isNothing)
-import Data.Scientific (scientific)
 import qualified Language.GraphQL.Execute.Coerce as Coerce
 import Language.GraphQL.Type
 import qualified Language.GraphQL.Type.In as In
@@ -27,81 +23,11 @@ direction = EnumType "Direction" Nothing  $ HashMap.fromList
     , ("WEST", EnumValue Nothing)
     ]
 
-singletonInputObject :: In.Type
-singletonInputObject = In.NamedInputObjectType type'
-  where
-    type' = In.InputObjectType "ObjectName" Nothing inputFields
-    inputFields = HashMap.singleton "field" field
-    field = In.InputField Nothing (In.NamedScalarType string) Nothing
-
 namedIdType :: In.Type
 namedIdType = In.NamedScalarType id
 
 spec :: Spec
-spec = do
-    describe "VariableValue Aeson" $ do
-        it "coerces strings" $
-            let expected = Just (String "asdf")
-                actual = Coerce.coerceVariableValue
-                    (In.NamedScalarType string) (Aeson.String "asdf")
-             in actual `shouldBe` expected
-        it "coerces non-null strings" $
-            let expected = Just (String "asdf")
-                actual = Coerce.coerceVariableValue
-                    (In.NonNullScalarType string) (Aeson.String "asdf")
-             in actual `shouldBe` expected
-        it "coerces booleans" $
-            let expected = Just (Boolean True)
-                actual = Coerce.coerceVariableValue
-                    (In.NamedScalarType boolean) (Aeson.Bool True)
-             in actual `shouldBe` expected
-        it "coerces zero to an integer" $
-            let expected = Just (Int 0)
-                actual = Coerce.coerceVariableValue
-                    (In.NamedScalarType int) (Aeson.Number 0)
-             in actual `shouldBe` expected
-        it "rejects fractional if an integer is expected" $
-            let actual = Coerce.coerceVariableValue
-                    (In.NamedScalarType int) (Aeson.Number $ scientific 14 (-1))
-             in actual `shouldSatisfy` isNothing
-        it "coerces float numbers" $
-            let expected = Just (Float 1.4)
-                actual = Coerce.coerceVariableValue
-                    (In.NamedScalarType float) (Aeson.Number $ scientific 14 (-1))
-             in actual `shouldBe` expected
-        it "coerces IDs" $
-            let expected = Just (String "1234")
-                json = Aeson.String "1234"
-                actual = Coerce.coerceVariableValue namedIdType json
-             in actual `shouldBe` expected
-        it "coerces input objects" $
-            let actual = Coerce.coerceVariableValue singletonInputObject
-                    $ Aeson.object ["field" .= ("asdf" :: Aeson.Value)]
-                expected = Just $ Object $ HashMap.singleton "field" "asdf"
-             in actual `shouldBe` expected
-        it "skips the field if it is missing in the variables" $
-            let actual = Coerce.coerceVariableValue
-                    singletonInputObject Aeson.emptyObject
-                expected = Just $ Object HashMap.empty
-             in actual `shouldBe` expected
-        it "fails if input object value contains extra fields" $
-            let actual = Coerce.coerceVariableValue singletonInputObject
-                    $ Aeson.object variableFields
-                variableFields =
-                    [ "field" .= ("asdf" :: Aeson.Value)
-                    , "extra" .= ("qwer" :: Aeson.Value)
-                    ]
-             in actual `shouldSatisfy` isNothing
-        it "preserves null" $
-            let actual = Coerce.coerceVariableValue namedIdType Aeson.Null
-             in actual `shouldBe` Just Null
-        it "preserves list order" $
-            let list = Aeson.toJSONList ["asdf" :: Aeson.Value, "qwer"]
-                listType = (In.ListType $ In.NamedScalarType string)
-                actual = Coerce.coerceVariableValue listType list
-                expected = Just $ List [String "asdf", String "qwer"]
-             in actual `shouldBe` expected
-
+spec =
     describe "coerceInputLiteral" $ do
         it "coerces enums" $
             let expected = Just (Enum "NORTH")

tests/Language/GraphQL/ExecuteSpec.hs

@@ -4,15 +4,13 @@
 
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
+
 module Language.GraphQL.ExecuteSpec
     ( spec
     ) where
 
 import Control.Exception (Exception(..), SomeException)
 import Control.Monad.Catch (throwM)
-import Data.Aeson ((.=))
-import qualified Data.Aeson as Aeson
-import Data.Aeson.Types (emptyObject)
 import Data.Conduit
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
@@ -23,12 +21,17 @@ import Language.GraphQL.Error
 import Language.GraphQL.Execute (execute)
 import Language.GraphQL.TH
 import qualified Language.GraphQL.Type.Schema as Schema
+import qualified Language.GraphQL.Type as Type
 import Language.GraphQL.Type
 import qualified Language.GraphQL.Type.In as In
 import qualified Language.GraphQL.Type.Out as Out
 import Prelude hiding (id)
 import Test.Hspec (Spec, context, describe, it, shouldBe)
 import Text.Megaparsec (parse)
+import Schemas.HeroSchema (heroSchema)
+import Data.Maybe (fromJust)
+import qualified Data.Sequence as Seq
+import qualified Data.Text as Text
 
 data PhilosopherException = PhilosopherException
     deriving Show
@@ -181,7 +184,7 @@ quoteType = Out.ObjectType "Quote" Nothing []
     quoteField =
         Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
 
-schoolType :: EnumType
+schoolType :: Type.EnumType
 schoolType = EnumType "School" Nothing $ HashMap.fromList
     [ ("NOMINALISM", EnumValue Nothing)
     , ("REALISM", EnumValue Nothing)
@@ -189,12 +192,12 @@ schoolType = EnumType "School" Nothing $ HashMap.fromList
     ]
 
 type EitherStreamOrValue = Either
-    (ResponseEventStream (Either SomeException) Aeson.Value)
-    (Response Aeson.Value)
+    (ResponseEventStream (Either SomeException) Type.Value)
+    (Response Type.Value)
 
 execute' :: Document -> Either SomeException EitherStreamOrValue
 execute' =
-    execute philosopherSchema Nothing (mempty :: HashMap Name Aeson.Value)
+    execute philosopherSchema Nothing (mempty :: HashMap Name Type.Value)
 
 spec :: Spec
 spec =
@@ -209,38 +212,37 @@ spec =
                 ...cyclicFragment
               }
             |]
-                expected = Response emptyObject mempty
+                expected = Response (Object mempty) mempty
                 Right (Right actual) = either (pure . parseError) execute'
                     $ parse document "" sourceQuery
              in actual `shouldBe` expected
 
         context "Query" $ do
             it "skips unknown fields" $
-                let data'' = Aeson.object
-                        [ "philosopher" .= Aeson.object
-                            [ "firstName" .= ("Friedrich" :: String)
-                            ]
-                        ]
+                let data'' = Object
+                        $ HashMap.singleton "philosopher"
+                        $ Object
+                        $ HashMap.singleton "firstName"
+                        $ String "Friedrich"
                     expected = Response data'' mempty
                     Right (Right actual) = either (pure . parseError) execute'
                         $ parse document "" "{ philosopher { firstName surname } }"
                 in actual `shouldBe` expected
             it "merges selections" $
-                let data'' = Aeson.object
-                        [ "philosopher" .= Aeson.object
-                            [ "firstName" .= ("Friedrich" :: String)
-                            , "lastName" .= ("Nietzsche" :: String)
+                let data'' = Object
+                        $ HashMap.singleton "philosopher"
+                        $ Object
+                        $ HashMap.fromList
+                            [ ("firstName", String "Friedrich")
+                            , ("lastName", String "Nietzsche")
                             ]
-                        ]
                     expected = Response data'' mempty
                     Right (Right actual) = either (pure . parseError) execute'
                         $ parse document "" "{ philosopher { firstName } philosopher { lastName } }"
                 in actual `shouldBe` expected
 
             it "errors on invalid output enum values" $
-                let data'' = Aeson.object
-                        [ "philosopher" .= Aeson.Null
-                        ]
+                let data'' = Object $ HashMap.singleton "philosopher" Null
                     executionErrors = pure $ Error
                         { message =
                             "Value completion error. Expected type !School, found: EXISTENTIALISM."
@@ -253,9 +255,7 @@ spec =
                 in actual `shouldBe` expected
 
             it "gives location information for non-null unions" $
-                let data'' = Aeson.object
-                        [ "philosopher" .= Aeson.Null
-                        ]
+                let data'' = Object $ HashMap.singleton "philosopher" Null
                     executionErrors = pure $ Error
                         { message =
                             "Value completion error. Expected type !Interest, found: { instrument: \"piano\" }."
@@ -268,9 +268,7 @@ spec =
                 in actual `shouldBe` expected
 
             it "gives location information for invalid interfaces" $
-                let data'' = Aeson.object
-                        [ "philosopher" .= Aeson.Null
-                        ]
+                let data'' = Object $ HashMap.singleton "philosopher" Null
                     executionErrors = pure $ Error
                         { message
                             = "Value completion error. Expected type !Work, found:\
@@ -284,9 +282,7 @@ spec =
                 in actual `shouldBe` expected
 
             it "gives location information for invalid scalar arguments" $
-                let data'' = Aeson.object
-                        [ "philosopher" .= Aeson.Null
-                        ]
+                let data'' = Object $ HashMap.singleton "philosopher" Null
                     executionErrors = pure $ Error
                         { message =
                             "Argument \"id\" has invalid type. Expected type ID, found: True."
@@ -299,9 +295,7 @@ spec =
                 in actual `shouldBe` expected
 
             it "gives location information for failed result coercion" $
-                let data'' = Aeson.object
-                        [ "philosopher" .= Aeson.Null
-                        ]
+                let data'' = Object $ HashMap.singleton "philosopher" Null
                     executionErrors = pure $ Error
                         { message = "Unable to coerce result to !Int."
                         , locations = [Location 1 26]
@@ -313,9 +307,7 @@ spec =
                 in actual `shouldBe` expected
 
             it "gives location information for failed result coercion" $
-                let data'' = Aeson.object
-                        [ "genres" .= Aeson.Null
-                        ]
+                let data'' = Object $ HashMap.singleton "genres" Null
                     executionErrors = pure $ Error
                         { message = "PhilosopherException"
                         , locations = [Location 1 3]
@@ -332,15 +324,13 @@ spec =
                         , locations = [Location 1 3]
                         , path = [Segment "count"]
                         }
-                    expected = Response Aeson.Null executionErrors
+                    expected = Response 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
-                        ]
+                let data'' = Object $ HashMap.singleton "philosopher" Null
                     executionErrors = pure $ Error
                         { message = "Value completion error. Expected type !String, found: null."
                         , locations = [Location 1 26]
@@ -351,13 +341,75 @@ spec =
                         $ parse document "" "{ philosopher(id: \"1\") { firstLanguage } }"
                 in actual `shouldBe` expected
 
+            context "queryError" $ do
+                let
+                  namedQuery name = "query " <> name <> " { philosopher(id: \"1\") { interest } }"
+                  twoQueries = namedQuery "A" <> " " <> namedQuery "B"
+                  startsWith :: Text.Text -> Text.Text -> Bool
+                  startsWith xs ys = Text.take (Text.length ys) xs == ys
+
+                it "throws operation name is required error" $
+                    let expectedErrorMessage :: Text.Text
+                        expectedErrorMessage = "Operation name is required"
+                        Right (Right (Response _ executionErrors)) = either (pure . parseError) execute' $ parse document "" twoQueries
+                        Error msg _ _ = Seq.index executionErrors 0
+                     in msg `startsWith` expectedErrorMessage `shouldBe` True
+
+                it "throws operation not found error" $
+                    let expectedErrorMessage :: Text.Text
+                        expectedErrorMessage = "Operation \"C\" is not found"
+                        execute'' :: Document -> Either SomeException EitherStreamOrValue
+                        execute'' = execute philosopherSchema (Just "C") (mempty :: HashMap Name Type.Value)
+                        Right (Right (Response _ executionErrors)) = either (pure . parseError) execute''
+                            $ parse document "" twoQueries
+                        Error msg _ _ = Seq.index executionErrors 0
+                     in msg `startsWith` expectedErrorMessage `shouldBe` True
+
+                it "throws variable coercion error" $
+                    let data'' = Null
+                        executionErrors = pure $ Error
+                            { message = "Failed to coerce the variable $id: String."
+                            , locations =[Location 1 7]
+                            , path = []
+                            }
+                        expected = Response data'' executionErrors
+                        executeWithVars :: Document -> Either SomeException EitherStreamOrValue
+                        executeWithVars = execute philosopherSchema Nothing (HashMap.singleton "id" (Type.Int 1))
+                        Right (Right actual) = either (pure . parseError) executeWithVars
+                            $ parse document "" "query($id: String) { philosopher(id: \"1\") { firstLanguage } }"
+                    in actual `shouldBe` expected
+
+                it "throws variable unkown input type error" $
+                    let data'' = Null
+                        executionErrors = pure $ Error
+                            { message = "Variable $id has unknown type Cat."
+                            , locations =[Location 1 7]
+                            , path = []
+                            }
+                        expected = Response data'' executionErrors
+                        Right (Right actual) = either (pure . parseError) execute'
+                            $ parse document "" "query($id: Cat) { philosopher(id: \"1\") { firstLanguage } }"
+                    in actual `shouldBe` expected
+
+            context "Error path" $ do
+                let executeHero :: Document -> Either SomeException EitherStreamOrValue
+                    executeHero = execute heroSchema Nothing (HashMap.empty :: HashMap Name Type.Value)
+
+                it "at the beggining of the list" $
+                    let Right (Right actual) = either (pure . parseError) executeHero
+                            $ parse document "" "{ hero(id: \"1\") { friends { name } } }"
+                        Response _ errors' = actual
+                        Error _ _ path' = fromJust $ Seq.lookup 0 errors'
+                        expected = [Segment "hero", Segment "friends", Index 0, Segment "name"]
+                    in path' `shouldBe` expected
+
         context "Subscription" $
             it "subscribes" $
-                let data'' = Aeson.object
-                        [ "newQuote" .= Aeson.object
-                            [ "quote" .= ("Naturam expelles furca, tamen usque recurret." :: String)
-                            ]
-                        ]
+                let data'' = Object
+                        $ HashMap.singleton "newQuote"
+                        $ Object
+                        $ HashMap.singleton "quote"
+                        $ String "Naturam expelles furca, tamen usque recurret."
                     expected = Response data'' mempty
                     Right (Left stream) = either (pure . parseError) execute'
                         $ parse document "" "subscription { newQuote { quote } }"

tests/Schemas/HeroSchema.hs

@@ -0,0 +1,70 @@
+{- 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 #-}
+
+module Schemas.HeroSchema (heroSchema) where
+
+import Control.Exception (Exception(..), SomeException)
+import Control.Monad.Catch (throwM)
+import Language.GraphQL.Error (ResolverException (..))
+import qualified Language.GraphQL.Type.In as In
+import qualified Language.GraphQL.Type as Type
+import Language.GraphQL.Type.Schema (schemaWithTypes)
+import qualified Data.HashMap.Strict as HashMap
+import Data.Typeable (cast)
+import qualified Language.GraphQL.Type.Out as Out
+
+data HeroException = HeroException
+    deriving Show
+
+instance Exception HeroException where
+    toException = toException. ResolverException
+    fromException e = do
+        ResolverException resolverException <- fromException e
+        cast resolverException
+
+heroSchema :: Type.Schema (Either SomeException)
+heroSchema =
+    schemaWithTypes Nothing queryType Nothing Nothing [] mempty
+
+type ObjectType = Out.ObjectType (Either SomeException)
+
+queryType :: ObjectType
+queryType = Out.ObjectType "Query" Nothing []
+    $ HashMap.fromList
+        [ ("hero", Out.ValueResolver heroField heroResolver)
+        ]
+  where
+    heroField = Out.Field Nothing (Out.NamedObjectType heroType)
+        $ HashMap.singleton "id"
+        $ In.Argument Nothing (In.NamedScalarType Type.id) Nothing
+    heroResolver = pure $ Type.Object mempty
+
+stringField :: Out.Field (Either SomeException)
+stringField = Out.Field Nothing (Out.NonNullScalarType Type.string) HashMap.empty
+
+heroType :: ObjectType
+heroType = Out.ObjectType "Hero" Nothing [] $ HashMap.fromList resolvers
+  where
+    resolvers =
+        [ ("id", Out.ValueResolver stringField (pure $ Type.String "4111"))
+        , ("name", Out.ValueResolver stringField (pure $ Type.String "R2D2"))
+        , ("friends", Out.ValueResolver friendsField (pure $ Type.List [luke]))
+        ]
+    friendsField = Out.Field Nothing (Out.ListType $ Out.NonNullObjectType lukeType) HashMap.empty
+    -- This list values are ignored because of current realisation (types and resolvers are the same entity)
+    -- The values from lukeType will be used
+    luke = Type.Object $ HashMap.fromList
+        [ ("id", "dfdfdf")
+        , ("name", "dfdfdff")
+        ]
+
+lukeType :: ObjectType
+lukeType = Out.ObjectType "Luke" Nothing [] $ HashMap.fromList resolvers
+  where
+    resolvers =
+        [ ("id", Out.ValueResolver stringField (pure $ Type.String "1000"))
+        , ("name", Out.ValueResolver stringField (throwM HeroException))
+        ]

tests/Test/DirectiveSpec.hs

@@ -1,92 +0,0 @@
-{- This Source Code Form is subject to the terms of the Mozilla Public License,
-   v. 2.0. If a copy of the MPL was not distributed with this file, You can
-   obtain one at https://mozilla.org/MPL/2.0/. -}
-
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
-module Test.DirectiveSpec
-    ( spec
-    ) where
-
-import Data.Aeson (object, (.=))
-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
-
-experimentalResolver :: Schema IO
-experimentalResolver = schema queryType Nothing Nothing mempty
-  where
-    queryType = Out.ObjectType "Query" Nothing []
-        $ HashMap.singleton "experimentalField"
-        $ Out.ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
-        $ pure $ Int 5
-
-emptyObject :: Aeson.Object
-emptyObject = HashMap.singleton "data" $ object []
-
-spec :: Spec
-spec =
-    describe "Directive executor" $ do
-        it "should be able to @skip fields" $ do
-            let sourceQuery = [gql|
-              {
-                experimentalField @skip(if: true)
-              }
-            |]
-
-            actual <- graphql experimentalResolver sourceQuery
-            actual `shouldResolveTo` emptyObject
-
-        it "should not skip fields if @skip is false" $ do
-            let sourceQuery = [gql|
-              {
-                experimentalField @skip(if: false)
-              }
-            |]
-                expected = HashMap.singleton "data"
-                    $ object
-                        [ "experimentalField" .= (5 :: Int)
-                        ]
-            actual <- graphql experimentalResolver sourceQuery
-            actual `shouldResolveTo` expected
-
-        it "should skip fields if @include is false" $ do
-            let sourceQuery = [gql|
-              {
-                experimentalField @include(if: false)
-              }
-            |]
-
-            actual <- graphql experimentalResolver sourceQuery
-            actual `shouldResolveTo` emptyObject
-
-        it "should be able to @skip a fragment spread" $ do
-            let sourceQuery = [gql|
-              {
-                ...experimentalFragment @skip(if: true)
-              }
-
-              fragment experimentalFragment on Query {
-                experimentalField
-              }
-            |]
-
-            actual <- graphql experimentalResolver sourceQuery
-            actual `shouldResolveTo` emptyObject
-
-        it "should be able to @skip an inline fragment" $ do
-            let sourceQuery = [gql|
-              {
-                ... on Query @skip(if: true) {
-                  experimentalField
-                }
-              }
-            |]
-
-            actual <- graphql experimentalResolver sourceQuery
-            actual `shouldResolveTo` emptyObject

tests/Test/FragmentSpec.hs

@@ -1,204 +0,0 @@
-{- This Source Code Form is subject to the terms of the Mozilla Public License,
-   v. 2.0. If a copy of the MPL was not distributed with this file, You can
-   obtain one at https://mozilla.org/MPL/2.0/. -}
-
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
-module Test.FragmentSpec
-    ( spec
-    ) where
-
-import Data.Aeson ((.=))
-import qualified Data.Aeson as Aeson
-import qualified Data.HashMap.Strict as HashMap
-import Data.Text (Text)
-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
-
-size :: (Text, Value)
-size = ("size", String "L")
-
-circumference :: (Text, Value)
-circumference = ("circumference", Int 60)
-
-garment :: Text -> (Text, Value)
-garment typeName =
-    ("garment",  Object $ HashMap.fromList
-        [ if typeName == "Hat" then circumference else size
-        , ("__typename", String typeName)
-        ]
-    )
-
-inlineQuery :: Text
-inlineQuery = [gql|
-  {
-    garment {
-      ... on Hat {
-        circumference
-      }
-      ... on Shirt {
-        size
-      }
-    }
-  }
-|]
-
-shirtType :: Out.ObjectType IO
-shirtType = Out.ObjectType "Shirt" Nothing [] $ HashMap.fromList
-    [ ("size", sizeFieldType)
-    ]
-
-hatType :: Out.ObjectType IO
-hatType = Out.ObjectType "Hat" Nothing [] $ HashMap.fromList
-    [ ("size", sizeFieldType)
-    , ("circumference", circumferenceFieldType)
-    ]
-
-circumferenceFieldType :: Out.Resolver IO
-circumferenceFieldType
-    = Out.ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
-    $ pure $ snd circumference
-
-sizeFieldType :: Out.Resolver IO
-sizeFieldType
-    = Out.ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
-    $ pure $ snd size
-
-toSchema :: Text -> (Text, Value) -> Schema IO
-toSchema t (_, resolve) = schema queryType Nothing Nothing mempty
-  where
-    garmentType = Out.UnionType "Garment" Nothing [hatType, shirtType]
-    typeNameField = Out.Field Nothing (Out.NamedScalarType string) mempty
-    garmentField = Out.Field Nothing (Out.NamedUnionType garmentType) mempty
-    queryType =
-        case t of
-            "circumference" -> hatType
-            "size" -> shirtType
-            _ -> Out.ObjectType "Query" Nothing []
-                $ HashMap.fromList
-                    [ ("garment", ValueResolver garmentField (pure resolve))
-                    , ("__typename", ValueResolver typeNameField (pure $ String "Shirt"))
-                    ]
-
-spec :: Spec
-spec = do
-    describe "Inline fragment executor" $ do
-        it "chooses the first selection if the type matches" $ do
-            actual <- graphql (toSchema "Hat" $ garment "Hat") inlineQuery
-            let expected = HashMap.singleton "data"
-                    $ Aeson.object
-                        [ "garment" .= Aeson.object
-                            [ "circumference" .= (60 :: Int)
-                            ]
-                        ]
-             in actual `shouldResolveTo` expected
-
-        it "chooses the last selection if the type matches" $ do
-            actual <- graphql (toSchema "Shirt" $ garment "Shirt") inlineQuery
-            let expected = HashMap.singleton "data"
-                    $ Aeson.object
-                        [ "garment" .= Aeson.object
-                            [ "size" .= ("L" :: Text)
-                            ]
-                        ]
-             in actual `shouldResolveTo` expected
-
-        it "embeds inline fragments without type" $ do
-            let sourceQuery = [gql|
-              {
-                circumference
-                ... {
-                  size
-                }
-              }
-            |]
-            actual <- graphql (toSchema "circumference" circumference) sourceQuery
-            let expected = HashMap.singleton "data"
-                    $ Aeson.object
-                        [ "circumference" .= (60 :: Int)
-                        , "size" .= ("L" :: Text)
-                        ]
-             in actual `shouldResolveTo` expected
-
-        it "evaluates fragments on Query" $ do
-            let sourceQuery = [gql|
-              {
-                ... {
-                  size
-                }
-              }
-            |]
-             in graphql (toSchema "size" size) `shouldResolve` sourceQuery
-
-    describe "Fragment spread executor" $ do
-        it "evaluates fragment spreads" $ do
-            let sourceQuery = [gql|
-              {
-                ...circumferenceFragment
-              }
-
-              fragment circumferenceFragment on Hat {
-                circumference
-              }
-            |]
-
-            actual <- graphql (toSchema "circumference" circumference) sourceQuery
-            let expected = HashMap.singleton "data"
-                    $ Aeson.object
-                        [ "circumference" .= (60 :: Int)
-                        ]
-             in actual `shouldResolveTo` expected
-
-        it "evaluates nested fragments" $ do
-            let sourceQuery = [gql|
-              {
-                garment {
-                  ...circumferenceFragment
-                }
-              }
-
-              fragment circumferenceFragment on Hat {
-                ...hatFragment
-              }
-
-              fragment hatFragment on Hat {
-                circumference
-              }
-            |]
-
-            actual <- graphql (toSchema "Hat" $ garment "Hat") sourceQuery
-            let expected = HashMap.singleton "data"
-                    $ Aeson.object
-                        [ "garment" .= Aeson.object
-                            [ "circumference" .= (60 :: Int)
-                            ]
-                        ]
-             in actual `shouldResolveTo` expected
-
-        it "considers type condition" $ do
-            let sourceQuery = [gql|
-              {
-                garment {
-                  ...circumferenceFragment
-                  ...sizeFragment
-                }
-              }
-              fragment circumferenceFragment on Hat {
-                circumference
-              }
-              fragment sizeFragment on Shirt {
-                size
-              }
-            |]
-                expected = HashMap.singleton "data"
-                    $ Aeson.object
-                        [ "garment" .= Aeson.object
-                            [ "circumference" .= (60 :: Int)
-                            ]
-                        ]
-            actual <- graphql (toSchema "Hat" $ garment "Hat") sourceQuery
-            actual `shouldResolveTo` expected

tests/Test/RootOperationSpec.hs

@@ -1,72 +0,0 @@
-{- This Source Code Form is subject to the terms of the Mozilla Public License,
-   v. 2.0. If a copy of the MPL was not distributed with this file, You can
-   obtain one at https://mozilla.org/MPL/2.0/. -}
-
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
-module Test.RootOperationSpec
-    ( spec
-    ) where
-
-import Data.Aeson ((.=), object)
-import qualified Data.HashMap.Strict as HashMap
-import Language.GraphQL
-import Test.Hspec (Spec, describe, it)
-import Language.GraphQL.TH
-import Language.GraphQL.Type
-import qualified Language.GraphQL.Type.Out as Out
-import Test.Hspec.GraphQL
-
-hatType :: Out.ObjectType IO
-hatType = Out.ObjectType "Hat" Nothing []
-    $ HashMap.singleton "circumference"
-    $ ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
-    $ pure $ Int 60
-
-garmentSchema :: Schema IO
-garmentSchema = schema queryType (Just mutationType) Nothing mempty
-  where
-    queryType = Out.ObjectType "Query" Nothing [] hatFieldResolver
-    mutationType = Out.ObjectType "Mutation" Nothing [] incrementFieldResolver
-    garment = pure $ Object $ HashMap.fromList
-        [ ("circumference", Int 60)
-        ]
-    incrementFieldResolver = HashMap.singleton "incrementCircumference"
-        $ ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
-        $ pure $ Int 61
-    hatField = Out.Field Nothing (Out.NamedObjectType hatType) mempty
-    hatFieldResolver =
-        HashMap.singleton "garment" $ ValueResolver hatField garment
-
-spec :: Spec
-spec =
-    describe "Root operation type" $ do
-        it "returns objects from the root resolvers" $ do
-            let querySource = [gql|
-              {
-                garment {
-                  circumference
-                }
-              }
-            |]
-                expected = HashMap.singleton "data"
-                    $ object
-                        [ "garment" .= object
-                            [ "circumference" .= (60 :: Int)
-                            ]
-                        ]
-            actual <- graphql garmentSchema querySource
-            actual `shouldResolveTo` expected
-
-        it "chooses Mutation" $ do
-            let querySource = [gql|
-              mutation {
-                incrementCircumference
-              }
-            |]
-                expected = HashMap.singleton "data"
-                    $ object
-                        [ "incrementCircumference" .= (61 :: Int)
-                        ]
-            actual <- graphql garmentSchema querySource
-            actual `shouldResolveTo` expected