Release 0.9.0.0

Let's try MonadThrow/MonadCatch. It looks nice at a first glance. The
monad transformer stack contains only the ReaderT, less lifts are
required. Exception subtyping is easier, the user can (and should)
define custom error types and throw them. And it is still possible to
use pure error handling, if someone doesn't like runtime exceptions or
need to run a query in a pure environment.

Fixes #42.

.github/workflows/haskell.yml

@@ -0,0 +1,63 @@
+name: Haskell CI
+
+on:
+  push: ~
+  pull_request:
+    branches: [master]
+
+jobs:
+  test:
+    runs-on: ubuntu-latest
+
+    steps:
+    - uses: actions/checkout@v2
+    - uses: actions/setup-haskell@v1
+      with:
+        enable-stack: true
+        stack-no-global: true
+        stack-version: latest
+
+    - name: Cache
+      uses: actions/cache@v2
+      with:
+        path: |
+          ~/.stack
+          stack.yaml.lock
+        key: ${{ runner.os }}-test-${{ hashFiles('**/stack.yaml') }}
+        restore-keys: ${{ runner.os }}-test-
+
+    - name: Install dependencies
+      run: stack --no-terminal test --only-snapshot
+    - name: Run tests
+      run: stack --no-terminal test --pedantic
+    - name: Build the documentation
+      run: |
+        stack --no-terminal ghc -- -Wall -Werror -fno-code docs/tutorial/tutorial.lhs
+        stack --no-terminal haddock --no-haddock-deps
+
+  lint:
+    runs-on: ubuntu-latest
+
+    steps:
+    - uses: actions/checkout@v2
+    - uses: actions/setup-haskell@v1
+      with:
+        enable-stack: true
+        stack-no-global: true
+        stack-version: latest
+
+    - name: Cache
+      uses: actions/cache@v2
+      with:
+        path: |
+          ~/.stack
+          stack.yaml.lock
+        key: ${{ runner.os }}-lint-${{ hashFiles('**/stack.yaml') }}
+        restore-keys: ${{ runner.os }}-lint-
+
+    - name: Build HLint
+      run: stack --no-terminal build hlint
+    - name: Install HLint
+      run: stack --no-terminal install hlint
+    - name: Lint
+      run: stack --no-terminal exec hlint -- src tests docs

.gitignore

@@ -8,7 +8,8 @@
 .cabal-sandbox/
 cabal.sandbox.config
 cabal.project.local
-/graphql.cabal
 
 # GHC
 *.hi
+*.o
+/docs/tutorial/tutorial

CHANGELOG.md

@@ -6,6 +6,62 @@ The format is based on
 and this project adheres to
 [Haskell Package Versioning Policy](https://pvp.haskell.org/).
 
+## [Unreleased]
+## Fixed
+- Location of a parse error is returned in a singleton array with key
+  `locations`.
+- Parsing comments in the front of definitions.
+- Some missing labels were added to the parsers, some labels were fixed to
+  refer to the AST nodes being parsed. 
+
+## Added
+- `AST` reexports `AST.Parser`.
+- `AST.Document.Location` is a token location as a line and column pair.
+- `Execute` reexports `Execute.Coerce`.
+- `Error.Error` is an error representation with a message and source location.
+- `Error.Response` represents a result of running a GraphQL query.
+- `Type.Schema` exports `Type` which lists all types possible in the schema.
+- Parsing subscriptions (the execution always fails yet).
+- `Error.ResponseEventStream`, `Type.Out.Resolve`, `Type.Out.Subscribe` and
+  `Type.Out.SourceEventStream` define subscription resolvers.
+- `Error.ResolverException` is an exception that can be thrown by (field value
+  and event stream) resolvers to signalize an error. Other exceptions will
+  escape.
+- `Test.Hspec.GraphQL` contains some test helpers.
+- `Validate` contains the validator and standard rules.
+
+## Changed
+- `Type.Out.Resolver`: Interface fields don't have resolvers, object fields
+  have value resolvers, root subscription type resolvers need an additional
+  resolver that creates an event stream. `Resolver` represents these differences
+  now and pairs a field with the function(s). Resolvers don't have `ExceptT`,
+  errors are handled with `MonadThrow`/`MonadCatch`.
+- All code from `Trans` is moved to `Type.Out` and exported by `Type` and
+  `Type.Out`.
+- `AST.Core` contained only `Arguments` which was moved to `Type.Definition`.
+  `AST` provides now only functionality related to parsing and encoding, as it
+  should be.
+- `Execute.execute` takes an additional argument, a possible operation name
+  and returns either a stream or the response.
+- `Error` module was changed to work with dedicated types for errors and the
+  response instead of JSON.
+- `graphqlSubs` takes an additional argument, the operation name. The type of
+  variable names is changed back to JSON since it is a common format and it
+  saves additional conversions. Custom format still can be used with the
+  underlying functions (in the `Execute` module). The function returns either a
+  a stream or the resolved value.
+- `graphql` returns either a stream or the resolved value.
+- The constraint of the base monad was changed to `MonadCatch` (and it implies
+  `MonadThrow`).
+
+## Removed
+- `Trans.ActionT` is an unneeded layer of complexity. `Type.Out.Resolver`
+  represents possible resolver configurations.
+- `Type.Out.Resolver`: It . Resolvers are a
+  part of the fields and are called `Trans.ResolverT`.
+- `Execute.executeWithName`. `Execute.execute` takes the operation name and
+   completely replaces `executeWithName`.
+
 ## [0.8.0.0] - 2020-06-20
 ### Fixed
 - The parser rejects variables when parsing defaultValue (DefaultValue). The
@@ -267,6 +323,7 @@ and this project adheres to
 ### Added
 - Data types for the GraphQL language.
 
+[Unreleased]: https://github.com/caraus-ecms/graphql/compare/v0.8.0.0...HEAD
 [0.8.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.7.0.0...v0.8.0.0
 [0.7.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.6.1.0...v0.7.0.0
 [0.6.1.0]: https://github.com/caraus-ecms/graphql/compare/v0.6.0.0...v0.6.1.0

README.md

@@ -1,7 +1,7 @@
 # Haskell GraphQL
 
 [![Hackage Version](https://img.shields.io/hackage/v/graphql.svg)](https://hackage.haskell.org/package/graphql)
-[![Build Status](https://semaphoreci.com/api/v1/belka-ew/graphql/branches/master/badge.svg)](https://semaphoreci.com/belka-ew/graphql)
+[![Build Status](https://github.com/caraus-ecms/graphql/workflows/Haskell%20CI/badge.svg)](https://github.com/caraus-ecms/graphql/actions?query=workflow%3A%22Haskell+CI%22)
 [![License](https://img.shields.io/badge/license-BSD--3--Clause-blue.svg)](https://raw.githubusercontent.com/caraus-ecms/graphql/master/LICENSE)
 
 GraphQL implementation in Haskell.
@@ -13,9 +13,9 @@ be built on top of it.
 
 ## State of the work
 
-For now this only provides a parser and a printer for the GraphQL query
+For now this only provides a parser and a printer for the GraphQL query language
-language and allows to execute queries and mutations without the schema
+and allows to execute queries and mutations using the given schema, but without
-validation step. But the idea is to be a Haskell port of
+the validation step. But the idea is to be a Haskell port of
 [`graphql-js`](https://github.com/graphql/graphql-js).
 
 For the list of currently missing features see issues marked as

docs/tutorial/tutorial.lhs

@@ -5,11 +5,13 @@ title: GraphQL Haskell Tutorial
 
 == Getting started ==
 
-Welcome to graphql-haskell!
+Welcome to GraphQL!
 
-We have written a small tutorial to help you (and ourselves) understand the graphql package.
+We have written a small tutorial to help you (and ourselves) understand the
+graphql package.
 
-Since this file is a literate haskell file, we start by importing some dependencies.
+Since this file is a literate haskell file, we start by importing some
+dependencies.
 
 > {-# LANGUAGE OverloadedStrings #-}
 > module Main where
@@ -23,75 +25,76 @@ Since this file is a literate haskell file, we start by importing some dependenc
 > import Data.Time (getCurrentTime)
 >
 > import Language.GraphQL
-> import Language.GraphQL.Trans
 > import Language.GraphQL.Type
 > import qualified Language.GraphQL.Type.Out as Out
 >
 > import Prelude hiding (putStrLn)
 
+
 === First example ===
 
-Now, as our first example, we are going to look at the
+Now, as our first example, we are going to look at the example from
-example from [graphql.js](https://github.com/graphql/graphql-js).
+[graphql.js](https://github.com/graphql/graphql-js).
 
 First we build a GraphQL schema.
 
 > schema1 :: Schema IO
-> schema1 = Schema queryType Nothing
+> schema1 = Schema
+>   { query = queryType , mutation = Nothing , subscription = Nothing }
 >
 > queryType :: ObjectType IO
 > queryType = ObjectType "Query" Nothing []
 >   $ HashMap.singleton "hello"
->   $ Out.Resolver helloField hello
+>   $ ValueResolver helloField hello
 >
 > helloField :: Field IO
 > helloField = Field Nothing (Out.NamedScalarType string) mempty
 >
-> hello :: ActionT IO Value
+> hello :: Resolve IO
 > hello = pure $ String "it's me"
 
-This defines a simple schema with one type and one field, that resolves to a fixed value.
+This defines a simple schema with one type and one field, that resolves to a
+fixed value.
 
 Next we define our query.
 
 > query1 :: Text
 > query1 = "{ hello }"
 
-
 To run the query, we call the `graphql` with the schema and the query.
 
 > main1 :: IO ()
-> main1 = graphql schema1 query1 >>= putStrLn . encode
+> main1 = graphql schema1 query1
+>   >>= either (const $ pure ()) (putStrLn . encode)
 
-This runs the query by fetching the one field defined,
+This runs the query by fetching the one field defined, returning
-returning
 
 ```{"data" : {"hello":"it's me"}}```
 
 
-
 === Monadic actions ===
 
 For this example, we're going to be using time.
 
 > schema2 :: Schema IO
-> schema2 = Schema queryType2 Nothing
+> schema2 = Schema
+>   { query = queryType2, mutation = Nothing, subscription = Nothing }
 >
 > queryType2 :: ObjectType IO
 > queryType2 = ObjectType "Query" Nothing []
 >   $ HashMap.singleton "time"
->   $ Out.Resolver timeField time
+>   $ ValueResolver timeField time
 >
 > timeField :: Field IO
 > timeField = Field Nothing (Out.NamedScalarType string) mempty
 >
-> time :: ActionT IO Value
+> time :: Resolve IO
 > time = do
 >   t <- liftIO getCurrentTime
 >   pure $ String $ Text.pack $ show t
 
-This defines a simple schema with one type and one field,
+This defines a simple schema with one type and one field, which resolves to the
-which resolves to the current time.
+current time.
 
 Next we define our query.
 
@@ -99,76 +102,51 @@ Next we define our query.
 > query2 = "{ time }"
 >
 > main2 :: IO ()
-> main2 = graphql schema2 query2 >>= putStrLn . encode
+> main2 = graphql schema2 query2
+>   >>= either (const $ pure ()) (putStrLn . encode)
 
 This runs the query, returning the current time
 
 ```{"data": {"time":"2016-03-08 23:28:14.546899 UTC"}}```
 
 
-=== Errors ===
-
-Errors are handled according to the spec,
-with fields that cause erros being resolved to `null`,
-and an error being added to the error list.
-
-An example of this is the following query:
-
-> queryShouldFail :: Text
-> queryShouldFail = "{ boyhowdy }"
-
-Since there is no `boyhowdy` field in our schema, it will not resolve,
-and the query will fail, as we can see in the following example.
-
-> mainShouldFail :: IO ()
-> mainShouldFail = do
->   success <- graphql schema1 query1
->   putStrLn $ encode success
->   putStrLn "This will fail"
->   failure <- graphql schema1 queryShouldFail
->   putStrLn $ encode failure
->
-
-This outputs:
-
-```
-{"data": {"hello": "it's me"}}
-This will fail
-{"data": {"boyhowdy": null}, "errors":[{"message": "the field boyhowdy did not resolve."}]}
-```
-
 === Combining resolvers ===
 
 Now that we have two resolvers, we can define a schema which uses them both.
 
 > schema3 :: Schema IO
-> schema3 = Schema queryType3 Nothing
+> schema3 = Schema
+>   { query = queryType3, mutation = Nothing, subscription = Nothing }
 >
 > queryType3 :: ObjectType IO
 > queryType3 = ObjectType "Query" Nothing [] $ HashMap.fromList
->   [ ("hello", Out.Resolver helloField hello)
+>   [ ("hello", ValueResolver helloField hello)
->   , ("time", Out.Resolver timeField time)
+>   , ("time", ValueResolver timeField time)
 >   ]
 >
 > query3 :: Text
 > query3 = "query timeAndHello { time hello }"
 >
 > main3 :: IO ()
-> main3 = graphql schema3 query3 >>= putStrLn . encode
+> main3 = graphql schema3 query3
+>   >>= either (const $ pure ()) (putStrLn . encode)
 
 This queries for both time and hello, returning
 
 ```{ "data": {"hello":"it's me","time":"2016-03-08 23:29:11.62108 UTC"}}```
 
-Notice that we can name our queries, as we did with `timeAndHello`. Since we have only been using single queries, we can use the shorthand `{ time hello}`, as we have been doing in the previous examples.
+Notice that we can name our queries, as we did with `timeAndHello`. Since we
+have only been using single queries, we can use the shorthand `{ time hello }`,
+as we have been doing in the previous examples.
 
 In GraphQL there can only be one operation per query.
 
 
 == Further examples ==
 
-More examples on queries and a more complex schema can be found in the test directory,
+More examples on queries and a more complex schema can be found in the test
-in the [Test.StarWars](../../tests/Test/StarWars) module. This includes a more complex schema, and more complex queries.
+directory, in the [Test.StarWars](../../tests/Test/StarWars) module. This
+includes a more complex schema, and more complex queries.
 
 > main :: IO ()
-> main = main1 >> main2 >> mainShouldFail >> main3
+> main = main1 >> main2 >> main3

graphql.cabal

@@ -0,0 +1,121 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.33.0.
+--
+-- see: https://github.com/sol/hpack
+--
+-- hash: ba234bcfff46df053a3466359e32682c4592b88894911ecbe78bd00fa00929b5
+
+name:           graphql
+version:        0.8.0.0
+synopsis:       Haskell GraphQL implementation
+description:    This package provides a rudimentary parser for the <https://graphql.github.io/graphql-spec/June2018/ GraphQL> language.
+category:       Language
+homepage:       https://github.com/caraus-ecms/graphql#readme
+bug-reports:    https://github.com/caraus-ecms/graphql/issues
+author:         Danny Navarro <j@dannynavarro.net>,
+                Matthías Páll Gissurarson <mpg@mpg.is>,
+                Sólrún Halla Einarsdóttir <she@mpg.is>
+maintainer:     belka@caraus.de
+copyright:      (c) 2019-2020 Eugen Wissner,
+                (c) 2015-2017 J. Daniel Navarro
+license:        BSD3
+license-file:   LICENSE
+build-type:     Simple
+extra-source-files:
+    CHANGELOG.md
+    README.md
+    LICENSE
+    docs/tutorial/tutorial.lhs
+data-files:
+    tests/data/kitchen-sink.graphql
+    tests/data/kitchen-sink.min.graphql
+
+source-repository head
+  type: git
+  location: https://github.com/caraus-ecms/graphql
+
+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.Type
+      Language.GraphQL.Type.In
+      Language.GraphQL.Type.Out
+      Language.GraphQL.Type.Schema
+      Language.GraphQL.Validate
+      Test.Hspec.GraphQL
+  other-modules:
+      Language.GraphQL.Execute.Execution
+      Language.GraphQL.Execute.Subscribe
+      Language.GraphQL.Execute.Transform
+      Language.GraphQL.Type.Definition
+      Language.GraphQL.Type.Internal
+      Language.GraphQL.Validate.Rules
+  hs-source-dirs:
+      src
+  build-depends:
+      aeson
+    , base >=4.7 && <5
+    , conduit
+    , containers
+    , exceptions
+    , hspec-expectations
+    , megaparsec
+    , parser-combinators
+    , scientific
+    , text
+    , transformers
+    , unordered-containers
+  default-language: Haskell2010
+
+test-suite tasty
+  type: exitcode-stdio-1.0
+  main-is: Spec.hs
+  other-modules:
+      Language.GraphQL.AST.EncoderSpec
+      Language.GraphQL.AST.LexerSpec
+      Language.GraphQL.AST.ParserSpec
+      Language.GraphQL.ErrorSpec
+      Language.GraphQL.Execute.CoerceSpec
+      Language.GraphQL.ExecuteSpec
+      Language.GraphQL.Type.OutSpec
+      Language.GraphQL.ValidateSpec
+      Test.DirectiveSpec
+      Test.FragmentSpec
+      Test.KitchenSinkSpec
+      Test.RootOperationSpec
+      Test.StarWars.Data
+      Test.StarWars.QuerySpec
+      Test.StarWars.Schema
+      Paths_graphql
+  hs-source-dirs:
+      tests
+  ghc-options: -threaded -rtsopts -with-rtsopts=-N
+  build-depends:
+      QuickCheck
+    , aeson
+    , base >=4.7 && <5
+    , conduit
+    , containers
+    , exceptions
+    , graphql
+    , hspec
+    , hspec-expectations
+    , hspec-megaparsec
+    , megaparsec
+    , parser-combinators
+    , raw-strings-qq
+    , scientific
+    , text
+    , transformers
+    , unordered-containers
+  default-language: Haskell2010

package.yaml

@@ -1,5 +1,5 @@
 name:                graphql
-version:             0.8.0.0
+version:             0.9.0.0
 synopsis:            Haskell GraphQL implementation
 description:
   This package provides a rudimentary parser for the
@@ -28,23 +28,26 @@ data-files:
 dependencies:
 - aeson
 - base >= 4.7 && < 5
+- conduit
 - containers
+- exceptions
+- hspec-expectations
 - megaparsec
 - parser-combinators
 - scientific
 - text
 - transformers
 - unordered-containers
-- vector
 
 library:
   source-dirs: src
   other-modules:
   - Language.GraphQL.Execute.Execution
+  - Language.GraphQL.Execute.Subscribe
   - Language.GraphQL.Execute.Transform
   - Language.GraphQL.Type.Definition
-  - Language.GraphQL.Type.Directive
+  - Language.GraphQL.Type.Internal
-  - Language.GraphQL.Type.Schema
+  - Language.GraphQL.Validate.Rules
 
 tests:
   tasty:
@@ -57,7 +60,6 @@ tests:
     dependencies:
     - graphql
     - hspec
-    - hspec-expectations
     - hspec-megaparsec
     - QuickCheck
     - raw-strings-qq

semaphoreci.sh

@@ -1,40 +0,0 @@
-#!/bin/bash
-
-STACK=$SEMAPHORE_CACHE_DIR/stack
-export STACK_ROOT=$SEMAPHORE_CACHE_DIR/.stack
-
-setup() {
-	if [ ! -e "$STACK" ]
-	then
-		curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C $SEMAPHORE_CACHE_DIR '*/stack'
-	fi
-	if [ -e "$SEMAPHORE_CACHE_DIR/graphql.cabal" ]
-	then
-		cp -a $SEMAPHORE_CACHE_DIR/graphql.cabal graphql.cabal
-	fi
-	$STACK --no-terminal setup
-	cp -a graphql.cabal $SEMAPHORE_CACHE_DIR/graphql.cabal
-}
-
-setup_test() {
-	$STACK --no-terminal test --only-snapshot
-}
-
-test() {
-	$STACK --no-terminal test --pedantic
-}
-
-test_docs() {
-	$STACK --no-terminal ghc -- -Wall -Werror -fno-code docs/tutorial/tutorial.lhs
-	$STACK --no-terminal haddock --no-haddock-deps
-}
-
-setup_lint() {
-	$STACK --no-terminal install hlint
-}
-
-lint() {
-	$STACK --no-terminal exec hlint -- src tests
-}
-
-$1

src/Language/GraphQL.hs

@@ -1,36 +1,79 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
 -- | This module provides the functions to parse and execute @GraphQL@ queries.
 module Language.GraphQL
     ( graphql
     , graphqlSubs
     ) where
 
+import Control.Monad.Catch (MonadCatch)
 import qualified Data.Aeson as Aeson
-import Data.HashMap.Strict (HashMap)
+import qualified Data.Aeson.Types as Aeson
+import qualified Data.HashMap.Strict as HashMap
+import qualified Data.Sequence as Seq
 import Data.Text (Text)
-import Language.GraphQL.AST.Document
+import Language.GraphQL.AST
-import Language.GraphQL.AST.Parser
 import Language.GraphQL.Error
 import Language.GraphQL.Execute
-import Language.GraphQL.Execute.Coerce
+import qualified Language.GraphQL.Validate as Validate
 import Language.GraphQL.Type.Schema
 import Text.Megaparsec (parse)
 
 -- | If the text parses correctly as a @GraphQL@ query the query is
 -- executed using the given 'Schema'.
-graphql :: Monad m
+graphql :: MonadCatch m
     => Schema m -- ^ Resolvers.
     -> Text -- ^ Text representing a @GraphQL@ request document.
-    -> m Aeson.Value -- ^ Response.
+    -> m (Either (ResponseEventStream m Aeson.Value) Aeson.Object) -- ^ Response.
-graphql = flip graphqlSubs (mempty :: Aeson.Object)
+graphql schema = graphqlSubs schema mempty mempty
 
 -- | If the text parses correctly as a @GraphQL@ query the substitution is
 -- applied to the query and the query is then executed using to the given
 -- 'Schema'.
-graphqlSubs :: (Monad m, VariableValue a)
+graphqlSubs :: MonadCatch m
     => Schema m -- ^ Resolvers.
-    -> HashMap Name a -- ^ Variable substitution function.
+    -> Maybe Text -- ^ Operation name.
+    -> Aeson.Object -- ^ Variable substitution function.
     -> Text -- ^ Text representing a @GraphQL@ request document.
-    -> m Aeson.Value -- ^ Response.
+    -> m (Either (ResponseEventStream m Aeson.Value) Aeson.Object) -- ^ Response.
-graphqlSubs schema f
+graphqlSubs schema operationName variableValues document' =
-    = either parseError (execute schema f)
+    case parse document "" document' of
-    . parse document ""
+        Left errorBundle -> pure . formatResponse <$> parseError errorBundle
+        Right parsed ->
+            case validate parsed of
+                Seq.Empty -> fmap formatResponse
+                    <$> execute schema operationName variableValues parsed
+                errors -> pure $ pure
+                    $ HashMap.singleton "errors"
+                    $ Aeson.toJSON
+                    $ fromValidationError <$> errors
+  where
+    validate = Validate.document schema Validate.specifiedRules
+    formatResponse (Response data'' Seq.Empty) = HashMap.singleton "data" data''
+    formatResponse (Response data'' errors') = HashMap.fromList
+        [ ("data", data'')
+        , ("errors", Aeson.toJSON $ fromError <$> errors')
+        ]
+    fromError Error{ locations = [], ..} =
+        Aeson.object [("message", Aeson.toJSON message)]
+    fromError Error{..} = Aeson.object
+        [ ("message", Aeson.toJSON message)
+        , ("locations", Aeson.listValue fromLocation locations)
+        ]
+    fromValidationError Validate.Error{..}
+        | [] <- path = Aeson.object
+            [ ("message", Aeson.toJSON message)
+            , ("locations", Aeson.listValue fromLocation locations)
+            ]
+        | otherwise = Aeson.object
+            [ ("message", Aeson.toJSON message)
+            , ("locations", Aeson.listValue fromLocation locations)
+            , ("path", Aeson.listValue fromPath path)
+            ]
+    fromPath (Validate.Segment segment) = Aeson.String segment
+    fromPath (Validate.Index index) = Aeson.toJSON index
+    fromLocation Location{..} = Aeson.object
+        [ ("line", Aeson.toJSON line)
+        , ("column", Aeson.toJSON column)
+        ]

src/Language/GraphQL/AST.hs

@@ -1,6 +1,8 @@
--- | Target AST for Parser.
+-- | Target AST for parser.
 module Language.GraphQL.AST
     ( module Language.GraphQL.AST.Document
+    , module Language.GraphQL.AST.Parser
     ) where
 
 import Language.GraphQL.AST.Document
+import Language.GraphQL.AST.Parser

src/Language/GraphQL/AST/Core.hs

@@ -1,19 +0,0 @@
--- | This is the AST meant to be executed.
-module Language.GraphQL.AST.Core
-    ( Arguments(..)
-    ) where
-
-import Data.HashMap.Strict (HashMap)
-import Language.GraphQL.AST (Name)
-import Language.GraphQL.Type.Definition
-
--- | Argument list.
-newtype Arguments = Arguments (HashMap Name Value)
-    deriving (Eq, Show)
-
-instance Semigroup Arguments where
-    (Arguments x) <> (Arguments y) = Arguments $ x <> y
-
-instance Monoid Arguments where
-    mempty = Arguments mempty
-

src/Language/GraphQL/AST/Document.hs

@@ -19,6 +19,7 @@ module Language.GraphQL.AST.Document
     , FragmentDefinition(..)
     , ImplementsInterfaces(..)
     , InputValueDefinition(..)
+    , Location(..)
     , Name
     , NamedType
     , NonNullType(..)
@@ -55,6 +56,12 @@ import Language.GraphQL.AST.DirectiveLocation
 -- | Name.
 type Name = Text
 
+-- | Error location, line and column.
+data Location = Location
+    { line :: Word
+    , column :: Word
+    } deriving (Eq, Show)
+
 -- ** Document
 
 -- | GraphQL document.
@@ -62,9 +69,9 @@ type Document = NonEmpty Definition
 
 -- | All kinds of definitions that can occur in a GraphQL document.
 data Definition
-    = ExecutableDefinition ExecutableDefinition
+    = ExecutableDefinition ExecutableDefinition Location
-    | TypeSystemDefinition TypeSystemDefinition
+    | TypeSystemDefinition TypeSystemDefinition Location
-    | TypeSystemExtension TypeSystemExtension
+    | TypeSystemExtension TypeSystemExtension Location
     deriving (Eq, Show)
 
 -- | Top-level definition of a document, either an operation or a fragment.
@@ -92,9 +99,7 @@ data OperationDefinition
 -- * mutation - a write operation followed by a fetch.
 -- * subscription - a long-lived request that fetches data in response to
 -- source events.
---
+data OperationType = Query | Mutation | Subscription deriving (Eq, Show)
--- Currently only queries and mutations are supported.
-data OperationType = Query | Mutation deriving (Eq, Show)
 
 -- ** Selection Sets
 

src/Language/GraphQL/AST/Encoder.hs

@@ -1,5 +1,6 @@
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
 
 -- | This module defines a minifier and a printer for the @GraphQL@ language.
 module Language.GraphQL.AST.Encoder
@@ -49,7 +50,8 @@ document formatter defs
     | Minified <-formatter = Lazy.Text.snoc (mconcat encodeDocument) '\n'
   where
     encodeDocument = foldr executableDefinition [] defs
-    executableDefinition (ExecutableDefinition x) acc = definition formatter x : acc
+    executableDefinition (ExecutableDefinition x _) acc =
+        definition formatter x : acc
     executableDefinition _ acc = acc
 
 -- | Converts a t'ExecutableDefinition' into a string.
@@ -65,12 +67,14 @@ definition formatter x
 
 -- | Converts a 'OperationDefinition into a string.
 operationDefinition :: Formatter -> OperationDefinition -> Lazy.Text
-operationDefinition formatter (SelectionSet sels)
+operationDefinition formatter = \case
-    = selectionSet formatter sels
+    SelectionSet sels -> selectionSet formatter sels
-operationDefinition formatter (OperationDefinition Query name vars dirs sels)
+    OperationDefinition Query name vars dirs sels ->
-    = "query " <> node formatter name vars dirs sels
+        "query " <> node formatter name vars dirs sels
-operationDefinition formatter (OperationDefinition Mutation name vars dirs sels)
+    OperationDefinition Mutation name vars dirs sels ->
-    = "mutation " <> node formatter name vars dirs sels
+        "mutation " <> node formatter name vars dirs sels
+    OperationDefinition Subscription name vars dirs sels ->
+        "subscription " <> node formatter name vars dirs sels
 
 -- | Converts a Query or Mutation into a string.
 node :: Formatter ->
@@ -254,19 +258,20 @@ stringValue (Pretty indentation) string =
           char == '\t' || isNewline char || (char >= '\x0020' && char /= '\x007F')
 
       tripleQuote = Builder.fromText "\"\"\""
-      start = tripleQuote <> Builder.singleton '\n'
+      newline = Builder.singleton '\n'
-      end = Builder.fromLazyText (indent indentation) <> tripleQuote
 
       strip = Text.dropWhile isWhiteSpace . Text.dropWhileEnd isWhiteSpace
       lines' = map Builder.fromText $ Text.split isNewline (Text.replace "\r\n" "\n" $ strip string)
       encoded [] = oneLine string
       encoded [_] = oneLine string
-      encoded lines'' = start <> transformLines lines'' <> end
+      encoded lines'' = tripleQuote <> newline
-      transformLines = foldr ((\line acc -> line <> Builder.singleton '\n' <> acc) . transformLine) mempty
+        <> transformLines lines''
-      transformLine line =
+        <> Builder.fromLazyText (indent indentation) <> tripleQuote
-        if Lazy.Text.null (Builder.toLazyText line)
+      transformLines = foldr transformLine mempty
-        then line
+      transformLine "" acc = newline <> acc
-        else Builder.fromLazyText (indent (indentation + 1)) <> line
+      transformLine line' acc
+            = Builder.fromLazyText (indent (indentation + 1))
+            <> line' <> newline <> acc
 
 escape :: Char -> Builder
 escape char'

src/Language/GraphQL/AST/Lexer.hs

@@ -168,11 +168,11 @@ blockString = between "\"\"\"" "\"\"\"" stringValue <* spaceConsumer
 
 -- | Parser for integers.
 integer :: Integral a => Parser a
-integer = Lexer.signed (pure ()) $ lexeme Lexer.decimal
+integer = Lexer.signed (pure ()) (lexeme Lexer.decimal) <?> "IntValue"
 
 -- | Parser for floating-point numbers.
 float :: Parser Double
-float = Lexer.signed (pure ()) $ lexeme Lexer.float
+float = Lexer.signed (pure ()) (lexeme Lexer.float) <?> "FloatValue"
 
 -- | Parser for names (/[_A-Za-z][_0-9A-Za-z]*/).
 name :: Parser T.Text
@@ -233,4 +233,4 @@ extend token extensionLabel parsers
     tryExtension extensionParser = try
         $ symbol "extend"
         *> symbol token
-        *> extensionParser
+        *> extensionParser

src/Language/GraphQL/AST/Parser.hs

@@ -1,12 +1,13 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
 
 -- | @GraphQL@ document parser.
 module Language.GraphQL.AST.Parser
     ( document
     ) where
 
-import Control.Applicative (Alternative(..), optional)
+import Control.Applicative (Alternative(..), liftA2, optional)
 import Control.Applicative.Combinators (sepBy1)
 import qualified Control.Applicative.Combinators.NonEmpty as NonEmpty
 import Data.List.NonEmpty (NonEmpty(..))
@@ -19,19 +20,47 @@ import Language.GraphQL.AST.DirectiveLocation
     )
 import Language.GraphQL.AST.Document
 import Language.GraphQL.AST.Lexer
-import Text.Megaparsec (lookAhead, option, try, (<?>))
+import Text.Megaparsec
+    ( SourcePos(..)
+    , getSourcePos
+    , lookAhead
+    , option
+    , try
+    , unPos
+    , (<?>)
+    )
 
 -- | Parser for the GraphQL documents.
 document :: Parser Document
 document = unicodeBOM
-    >> spaceConsumer
+    *> spaceConsumer
-    >> lexeme (NonEmpty.some definition)
+    *> lexeme (NonEmpty.some definition)
 
 definition :: Parser Definition
-definition = ExecutableDefinition <$> executableDefinition
+definition = executableDefinition'
-    <|> TypeSystemDefinition <$> typeSystemDefinition
+    <|> typeSystemDefinition'
-    <|> TypeSystemExtension <$> typeSystemExtension
+    <|> typeSystemExtension'
     <?> "Definition"
+  where
+    executableDefinition' = do
+        location <- getLocation
+        definition' <- executableDefinition
+        pure $ ExecutableDefinition definition' location
+    typeSystemDefinition' = do
+        location <- getLocation
+        definition' <- typeSystemDefinition
+        pure $ TypeSystemDefinition definition' location
+    typeSystemExtension' = do
+        location <- getLocation
+        definition' <- typeSystemExtension
+        pure $ TypeSystemExtension definition' location
+
+getLocation :: Parser Location
+getLocation = fromSourcePosition <$> getSourcePos
+  where
+    fromSourcePosition SourcePos{..} =
+        Location (wordFromPosition sourceLine) (wordFromPosition sourceColumn)
+    wordFromPosition = fromIntegral . unPos
 
 executableDefinition :: Parser ExecutableDefinition
 executableDefinition = DefinitionOperation <$> operationDefinition
@@ -40,19 +69,22 @@ executableDefinition = DefinitionOperation <$> operationDefinition
 
 typeSystemDefinition :: Parser TypeSystemDefinition
 typeSystemDefinition = schemaDefinition
-    <|> TypeDefinition <$> typeDefinition
+    <|> typeSystemDefinitionWithDescription
-    <|> directiveDefinition
     <?> "TypeSystemDefinition"
+  where
+    typeSystemDefinitionWithDescription = description
+        >>= liftA2 (<|>) typeDefinition' directiveDefinition
+    typeDefinition' description' = TypeDefinition
+        <$> typeDefinition description'
 
 typeSystemExtension :: Parser TypeSystemExtension
 typeSystemExtension = SchemaExtension <$> schemaExtension
     <|> TypeExtension <$> typeExtension
     <?> "TypeSystemExtension"
 
-directiveDefinition :: Parser TypeSystemDefinition
+directiveDefinition :: Description -> Parser TypeSystemDefinition
-directiveDefinition = DirectiveDefinition
+directiveDefinition description' = DirectiveDefinition description'
-    <$> description
+    <$ symbol "directive"
-    <* symbol "directive"
     <* at
     <*> name
     <*> argumentsDefinition
@@ -63,11 +95,13 @@ directiveDefinition = DirectiveDefinition
 directiveLocations :: Parser (NonEmpty DirectiveLocation)
 directiveLocations = optional pipe
     *> directiveLocation `NonEmpty.sepBy1` pipe
+    <?> "DirectiveLocations"
 
 directiveLocation :: Parser DirectiveLocation
 directiveLocation
     = Directive.ExecutableDirectiveLocation <$> executableDirectiveLocation
     <|> Directive.TypeSystemDirectiveLocation <$> typeSystemDirectiveLocation
+    <?> "DirectiveLocation"
 
 executableDirectiveLocation :: Parser ExecutableDirectiveLocation
 executableDirectiveLocation = Directive.Query <$ symbol "QUERY"
@@ -77,6 +111,7 @@ executableDirectiveLocation = Directive.Query <$ symbol "QUERY"
     <|> Directive.FragmentDefinition <$ "FRAGMENT_DEFINITION"
     <|> Directive.FragmentSpread <$ "FRAGMENT_SPREAD"
     <|> Directive.InlineFragment <$ "INLINE_FRAGMENT"
+    <?> "ExecutableDirectiveLocation"
 
 typeSystemDirectiveLocation :: Parser TypeSystemDirectiveLocation
 typeSystemDirectiveLocation = Directive.Schema <$ symbol "SCHEMA"
@@ -90,14 +125,15 @@ typeSystemDirectiveLocation = Directive.Schema <$ symbol "SCHEMA"
     <|> Directive.EnumValue <$ symbol "ENUM_VALUE"
     <|> Directive.InputObject <$ symbol "INPUT_OBJECT"
     <|> Directive.InputFieldDefinition <$ symbol "INPUT_FIELD_DEFINITION"
+    <?> "TypeSystemDirectiveLocation"
 
-typeDefinition :: Parser TypeDefinition
+typeDefinition :: Description -> Parser TypeDefinition
-typeDefinition = scalarTypeDefinition
+typeDefinition description' = scalarTypeDefinition description'
-    <|> objectTypeDefinition
+    <|> objectTypeDefinition description'
-    <|> interfaceTypeDefinition
+    <|> interfaceTypeDefinition description'
-    <|> unionTypeDefinition
+    <|> unionTypeDefinition description'
-    <|> enumTypeDefinition
+    <|> enumTypeDefinition description'
-    <|> inputObjectTypeDefinition
+    <|> inputObjectTypeDefinition description'
     <?> "TypeDefinition"
 
 typeExtension :: Parser TypeExtension
@@ -109,10 +145,9 @@ typeExtension = scalarTypeExtension
     <|> inputObjectTypeExtension
     <?> "TypeExtension"
 
-scalarTypeDefinition :: Parser TypeDefinition
+scalarTypeDefinition :: Description -> Parser TypeDefinition
-scalarTypeDefinition = ScalarTypeDefinition
+scalarTypeDefinition description' = ScalarTypeDefinition description'
-    <$> description
+    <$ symbol "scalar"
-    <* symbol "scalar"
     <*> name
     <*> directives
     <?> "ScalarTypeDefinition"
@@ -121,10 +156,9 @@ scalarTypeExtension :: Parser TypeExtension
 scalarTypeExtension = extend "scalar" "ScalarTypeExtension"
     $ (ScalarTypeExtension <$> name <*> NonEmpty.some directive) :| []
 
-objectTypeDefinition :: Parser TypeDefinition
+objectTypeDefinition :: Description -> Parser TypeDefinition
-objectTypeDefinition = ObjectTypeDefinition
+objectTypeDefinition description' = ObjectTypeDefinition description'
-    <$> description
+    <$ symbol "type"
-    <* symbol "type"
     <*> name
     <*> option (ImplementsInterfaces []) (implementsInterfaces sepBy1)
     <*> directives
@@ -153,13 +187,12 @@ objectTypeExtension = extend "type" "ObjectTypeExtension"
 
 description :: Parser Description
 description = Description
-    <$> optional (string <|> blockString)
+    <$> optional stringValue
     <?> "Description"
 
-unionTypeDefinition :: Parser TypeDefinition
+unionTypeDefinition :: Description -> Parser TypeDefinition
-unionTypeDefinition = UnionTypeDefinition
+unionTypeDefinition description' = UnionTypeDefinition description'
-    <$> description
+    <$ symbol "union"
-    <* symbol "union"
     <*> name
     <*> directives
     <*> option (UnionMemberTypes []) (unionMemberTypes sepBy1)
@@ -187,10 +220,9 @@ unionMemberTypes sepBy' = UnionMemberTypes
     <*> name `sepBy'` pipe
     <?> "UnionMemberTypes"
 
-interfaceTypeDefinition :: Parser TypeDefinition
+interfaceTypeDefinition :: Description -> Parser TypeDefinition
-interfaceTypeDefinition = InterfaceTypeDefinition
+interfaceTypeDefinition description' = InterfaceTypeDefinition description'
-    <$> description
+    <$ symbol "interface"
-    <* symbol "interface"
     <*> name
     <*> directives
     <*> braces (many fieldDefinition)
@@ -208,10 +240,9 @@ interfaceTypeExtension = extend "interface" "InterfaceTypeExtension"
         <$> name
         <*> NonEmpty.some directive
 
-enumTypeDefinition :: Parser TypeDefinition
+enumTypeDefinition :: Description -> Parser TypeDefinition
-enumTypeDefinition = EnumTypeDefinition
+enumTypeDefinition description' = EnumTypeDefinition description'
-    <$> description
+    <$ symbol "enum"
-    <* symbol "enum"
     <*> name
     <*> directives
     <*> listOptIn braces enumValueDefinition
@@ -229,10 +260,9 @@ enumTypeExtension = extend "enum" "EnumTypeExtension"
         <$> name
         <*> NonEmpty.some directive
 
-inputObjectTypeDefinition :: Parser TypeDefinition
+inputObjectTypeDefinition :: Description -> Parser TypeDefinition
-inputObjectTypeDefinition = InputObjectTypeDefinition
+inputObjectTypeDefinition description' = InputObjectTypeDefinition description'
-    <$> description
+    <$ symbol "input"
-    <* symbol "input"
     <*> name
     <*> directives
     <*> listOptIn braces inputValueDefinition
@@ -321,7 +351,7 @@ operationTypeDefinition = OperationTypeDefinition
 operationDefinition :: Parser OperationDefinition
 operationDefinition = SelectionSet <$> selectionSet
     <|> operationDefinition'
-    <?> "operationDefinition error"
+    <?> "OperationDefinition"
   where
     operationDefinition'
         = OperationDefinition <$> operationType
@@ -333,23 +363,20 @@ operationDefinition = SelectionSet <$> selectionSet
 operationType :: Parser OperationType
 operationType = Query <$ symbol "query"
     <|> Mutation <$ symbol "mutation"
-    -- <?> Keep default error message
+    <|> Subscription <$ symbol "subscription"
-
+    <?> "OperationType"
--- * SelectionSet
 
 selectionSet :: Parser SelectionSet
-selectionSet = braces $ NonEmpty.some selection
+selectionSet = braces (NonEmpty.some selection) <?> "SelectionSet"
 
 selectionSetOpt :: Parser SelectionSetOpt
-selectionSetOpt = listOptIn braces selection
+selectionSetOpt = listOptIn braces selection <?> "SelectionSet"
 
 selection :: Parser Selection
 selection = field
     <|> try fragmentSpread
     <|> inlineFragment
-    <?> "selection error!"
+    <?> "Selection"
-
--- * Field
 
 field :: Parser Selection
 field = Field
@@ -358,25 +385,23 @@ field = Field
     <*> arguments
     <*> directives
     <*> selectionSetOpt
+    <?> "Field"
 
 alias :: Parser Alias
-alias = try $ name <* colon
+alias = try (name <* colon) <?> "Alias"
-
--- * Arguments
 
 arguments :: Parser [Argument]
-arguments = listOptIn parens argument
+arguments = listOptIn parens argument <?> "Arguments"
 
 argument :: Parser Argument
-argument = Argument <$> name <* colon <*> value
+argument = Argument <$> name <* colon <*> value <?> "Argument"
-
--- * Fragments
 
 fragmentSpread :: Parser Selection
 fragmentSpread = FragmentSpread
     <$ spread
     <*> fragmentName
     <*> directives
+    <?> "FragmentSpread"
 
 inlineFragment :: Parser Selection
 inlineFragment = InlineFragment
@@ -384,62 +409,74 @@ inlineFragment = InlineFragment
     <*> optional typeCondition
     <*> directives
     <*> selectionSet
+    <?> "InlineFragment"
 
 fragmentDefinition :: Parser FragmentDefinition
 fragmentDefinition = FragmentDefinition
-                 <$  symbol "fragment"
+    <$  symbol "fragment"
-                 <*> name
+    <*> name
-                 <*> typeCondition
+    <*> typeCondition
-                 <*> directives
+    <*> directives
-                 <*> selectionSet
+    <*> selectionSet
+    <?> "FragmentDefinition"
 
 fragmentName :: Parser Name
-fragmentName = but (symbol "on") *> name
+fragmentName = but (symbol "on") *> name <?> "FragmentName"
 
 typeCondition :: Parser TypeCondition
-typeCondition = symbol "on" *> name
+typeCondition = symbol "on" *> name <?> "TypeCondition"
-
--- * Input Values
 
 value :: Parser Value
 value = Variable <$> variable
     <|> Float <$> try float
     <|> Int <$> integer
     <|> Boolean <$> booleanValue
-    <|> Null <$  symbol "null"
+    <|> Null <$  nullValue
-    <|> String <$> blockString
+    <|> String <$> stringValue
-    <|> String <$> string
     <|> Enum <$> try enumValue
     <|> List <$> brackets (some value)
     <|> Object <$> braces (some $ objectField value)
-    <?> "value error!"
+    <?> "Value"
 
 constValue :: Parser ConstValue
 constValue = ConstFloat <$> try float
     <|> ConstInt <$> integer
     <|> ConstBoolean <$> booleanValue
-    <|> ConstNull <$  symbol "null"
+    <|> ConstNull <$ nullValue
-    <|> ConstString <$> blockString
+    <|> ConstString <$> stringValue
-    <|> ConstString <$> string
     <|> ConstEnum <$> try enumValue
     <|> ConstList <$> brackets (some constValue)
     <|> ConstObject <$> braces (some $ objectField constValue)
-    <?> "value error!"
+    <?> "Value"
 
 booleanValue :: Parser Bool
 booleanValue = True  <$ symbol "true"
     <|> False <$ symbol "false"
+    <?> "BooleanValue"
 
 enumValue :: Parser Name
-enumValue = but (symbol "true") *> but (symbol "false") *> but (symbol "null") *> name
+enumValue = but (symbol "true")
+    *> but (symbol "false")
+    *> but (symbol "null")
+    *> name
+    <?> "EnumValue"
+
+stringValue :: Parser Text
+stringValue = blockString <|> string <?> "StringValue"
+
+nullValue :: Parser Text
+nullValue = symbol "null" <?> "NullValue"
 
 objectField :: Parser a -> Parser (ObjectField a)
-objectField valueParser = ObjectField <$> name <* colon <*> valueParser
+objectField valueParser = ObjectField
-
+    <$> name
--- * Variables
+    <* colon
+    <*> valueParser
+    <?> "ObjectField"
 
 variableDefinitions :: Parser [VariableDefinition]
 variableDefinitions = listOptIn parens variableDefinition
+    <?> "VariableDefinitions"
 
 variableDefinition :: Parser VariableDefinition
 variableDefinition = VariableDefinition
@@ -450,13 +487,11 @@ variableDefinition = VariableDefinition
     <?> "VariableDefinition"
 
 variable :: Parser Name
-variable = dollar *> name
+variable = dollar *> name <?> "Variable"
 
 defaultValue :: Parser (Maybe ConstValue)
 defaultValue = optional (equals *> constValue) <?> "DefaultValue"
 
--- * Input Types
-
 type' :: Parser Type
 type' = try (TypeNonNull <$> nonNullType)
     <|> TypeList <$> brackets type'
@@ -465,21 +500,18 @@ type' = try (TypeNonNull <$> nonNullType)
 
 nonNullType :: Parser NonNullType
 nonNullType = NonNullTypeNamed <$> name <* bang
-          <|> NonNullTypeList  <$> brackets type'  <* bang
+    <|> NonNullTypeList  <$> brackets type'  <* bang
-          <?> "nonNullType error!"
+    <?> "NonNullType"
-
--- * Directives
 
 directives :: Parser [Directive]
-directives = many directive
+directives = many directive <?> "Directives"
 
 directive :: Parser Directive
 directive = Directive
     <$  at
     <*> name
     <*> arguments
-
+    <?> "Directive"
--- * Internal
 
 listOptIn :: (Parser [a] -> Parser [a]) -> Parser a -> Parser [a]
 listOptIn surround = option [] . surround . some

src/Language/GraphQL/Error.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 
@@ -5,20 +7,29 @@
 module Language.GraphQL.Error
     ( parseError
     , CollectErrsT
+    , Error(..)
     , Resolution(..)
+    , ResolverException(..)
+    , Response(..)
+    , ResponseEventStream
     , addErr
     , addErrMsg
     , runCollectErrs
     , singleError
     ) where
 
+import Conduit
+import Control.Exception (Exception(..))
 import Control.Monad.Trans.State (StateT, modify, runStateT)
-import qualified Data.Aeson as Aeson
 import Data.HashMap.Strict (HashMap)
+import Data.Sequence (Seq(..), (|>))
+import qualified Data.Sequence as Seq
 import Data.Text (Text)
-import Data.Void (Void)
+import qualified Data.Text as Text
-import Language.GraphQL.AST.Document (Name)
+import Language.GraphQL.AST (Location(..), Name)
+import Language.GraphQL.Execute.Coerce
 import Language.GraphQL.Type.Schema
+import Prelude hiding (null)
 import Text.Megaparsec
     ( ParseErrorBundle(..)
     , PosState(..)
@@ -31,59 +42,85 @@ import Text.Megaparsec
 
 -- | Executor context.
 data Resolution m = Resolution
-    { errors :: [Aeson.Value]
+    { errors :: Seq Error
     , types :: HashMap Name (Type m)
     }
 
 -- | Wraps a parse error into a list of errors.
-parseError :: Applicative f => ParseErrorBundle Text Void -> f Aeson.Value
+parseError :: (Applicative f, Serialize a)
+    => ParseErrorBundle Text Void
+    -> f (Response a)
 parseError ParseErrorBundle{..}  =
-    pure $ Aeson.object [("errors", Aeson.toJSON $ fst $ foldl go ([], bundlePosState) bundleErrors)]
+    pure $ Response null $ fst
+        $ foldl go (Seq.empty, bundlePosState) bundleErrors
   where
-    errorObject s SourcePos{..} = Aeson.object
+    errorObject s SourcePos{..} = Error
-        [ ("message", Aeson.toJSON $ init $ parseErrorTextPretty s)
+        { message = Text.pack $ init $ parseErrorTextPretty s
-        , ("line", Aeson.toJSON $ unPos sourceLine)
+        , locations = [Location (unPos' sourceLine) (unPos' sourceColumn)]
-        , ("column", Aeson.toJSON $ unPos sourceColumn)
+        }
-        ]
+    unPos' = fromIntegral . unPos
     go (result, state) x =
         let (_, newState) = reachOffset (errorOffset x) state
             sourcePosition = pstateSourcePos newState
-         in (errorObject x sourcePosition : result, 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.
-addErr :: Monad m => Aeson.Value -> CollectErrsT m ()
+addErr :: Monad m => Error -> CollectErrsT m ()
 addErr v = modify appender
   where
-    appender resolution@Resolution{..} = resolution{ errors = v : errors }
+    appender :: Monad m => Resolution m -> Resolution m
+    appender resolution@Resolution{..} = resolution{ errors = errors |> v }
 
-makeErrorMessage :: Text -> Aeson.Value
+makeErrorMessage :: Text -> Error
-makeErrorMessage s = Aeson.object [("message", Aeson.toJSON s)]
+makeErrorMessage s = Error s []
 
 -- | Constructs a response object containing only the error with the given
---   message.
+-- message.
-singleError :: Text -> Aeson.Value
+singleError :: Serialize a => Text -> Response a
-singleError message = Aeson.object
+singleError message = Response null $ Seq.singleton $ makeErrorMessage message
-    [ ("errors", Aeson.toJSON [makeErrorMessage message])
-    ]
 
 -- | Convenience function for just wrapping an error message.
-addErrMsg :: Monad m => Text -> CollectErrsT m ()
+addErrMsg :: (Monad m, Serialize a) => Text -> CollectErrsT m a
-addErrMsg = addErr . makeErrorMessage
+addErrMsg errorMessage = (addErr . makeErrorMessage) errorMessage >> pure null
+
+-- | @GraphQL@ error.
+data Error = Error
+    { message :: Text
+    , locations :: [Location]
+    } deriving (Eq, Show)
+
+-- | The server\'s response describes the result of executing the requested
+-- operation if successful, and describes any errors encountered during the
+-- request.
+data Response a = Response
+    { data' :: a
+    , errors :: Seq Error
+    } deriving (Eq, Show)
+
+-- | Each event in the underlying Source Stream triggers execution of the
+-- subscription selection set. The results of the execution generate a Response
+-- Stream.
+type ResponseEventStream m a = ConduitT () (Response a) m ()
+
+-- | Only exceptions that inherit from 'ResolverException' a cought by the
+-- executor.
+data ResolverException = forall e. Exception e => ResolverException e
+
+instance Show ResolverException where
+    show (ResolverException e) = show e
+
+instance Exception ResolverException
 
 -- | Runs the given query computation, but collects the errors into an error
---   list, which is then sent back with the data.
+-- list, which is then sent back with the data.
-runCollectErrs :: Monad m
+runCollectErrs :: (Monad m, Serialize a)
     => HashMap Name (Type m)
-    -> CollectErrsT m Aeson.Value
+    -> CollectErrsT m a
-    -> m Aeson.Value
+    -> m (Response a)
 runCollectErrs types' res = do
-    (dat, Resolution{..}) <- runStateT res $ Resolution{ errors = [], types = types' }
+    (dat, Resolution{..}) <- runStateT res
-    if null errors
+        $ Resolution{ errors = Seq.empty, types = types' }
-       then return $ Aeson.object [("data", dat)]
+    pure $ Response dat errors
-       else return $ Aeson.object
-           [ ("data", dat)
-           , ("errors", Aeson.toJSON $ reverse errors)
-           ]

src/Language/GraphQL/Execute.hs

@@ -1,71 +1,63 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 -- | This module provides functions to execute a @GraphQL@ request.
 module Language.GraphQL.Execute
     ( execute
-    , executeWithName
+    , module Language.GraphQL.Execute.Coerce
     ) where
 
-import qualified Data.Aeson as Aeson
+import Control.Monad.Catch (MonadCatch)
 import Data.HashMap.Strict (HashMap)
-import qualified Data.HashMap.Strict as HashMap
 import Data.Sequence (Seq(..))
 import Data.Text (Text)
 import Language.GraphQL.AST.Document (Document, Name)
 import Language.GraphQL.Execute.Coerce
 import Language.GraphQL.Execute.Execution
 import qualified Language.GraphQL.Execute.Transform as Transform
+import qualified Language.GraphQL.Execute.Subscribe as Subscribe
 import Language.GraphQL.Error
 import qualified Language.GraphQL.Type.Definition as Definition
 import qualified Language.GraphQL.Type.Out as Out
 import Language.GraphQL.Type.Schema
 
--- | The substitution is applied to the document, and the resolvers are applied
--- to the resulting fields.
---
--- Returns the result of the query against the schema wrapped in a /data/
--- field, or errors wrapped in an /errors/ field.
-execute :: (Monad m, VariableValue a)
-    => Schema m -- ^ Resolvers.
-    -> HashMap.HashMap Name a -- ^ Variable substitution function.
-    -> Document -- @GraphQL@ document.
-    -> m Aeson.Value
-execute schema = executeRequest schema Nothing
-
 -- | 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.
 --
 -- Returns the result of the query against the schema wrapped in a /data/
 -- field, or errors wrapped in an /errors/ field.
-executeWithName :: (Monad m, VariableValue a)
+execute :: (MonadCatch m, VariableValue a, Serialize b)
-    => Schema m -- ^ Resolvers
+    => Schema m -- ^ Resolvers.
-    -> Text -- ^ Operation name.
+    -> Maybe Text -- ^ Operation name.
-    -> HashMap.HashMap Name a -- ^ Variable substitution function.
+    -> HashMap Name a -- ^ Variable substitution function.
-    -> Document -- ^ @GraphQL@ Document.
+    -> Document -- @GraphQL@ document.
-    -> m Aeson.Value
+    -> m (Either (ResponseEventStream m b) (Response b))
-executeWithName schema operationName =
+execute schema operationName subs document =
-    executeRequest schema (Just operationName)
-
-executeRequest :: (Monad m, VariableValue a)
-    => Schema m
-    -> Maybe Text
-    -> HashMap.HashMap Name a
-    -> Document
-    -> m Aeson.Value
-executeRequest schema operationName subs document =
     case Transform.document schema operationName subs document of
-        Left queryError -> pure $ singleError $ Transform.queryError queryError
+        Left queryError -> pure
-        Right (Transform.Document types' rootObjectType operation)
+            $ Right
-          | (Transform.Query _ fields) <- operation ->
+            $ singleError
-              executeOperation types' rootObjectType fields
+            $ Transform.queryError queryError
-          | (Transform.Mutation _ fields) <- operation ->
+        Right transformed -> executeRequest transformed
-              executeOperation types' rootObjectType fields
+
+executeRequest :: (MonadCatch m, Serialize a)
+    => Transform.Document m
+    -> m (Either (ResponseEventStream m a) (Response a))
+executeRequest (Transform.Document types' rootObjectType operation)
+    | (Transform.Query _ fields) <- operation =
+        Right <$> executeOperation types' rootObjectType fields
+    | (Transform.Mutation _ fields) <- operation =
+        Right <$> executeOperation types' rootObjectType fields
+    | (Transform.Subscription _ fields) <- operation
+        = either (Right . singleError) Left
+        <$> Subscribe.subscribe types' rootObjectType fields
 
 -- This is actually executeMutation, but we don't distinguish between queries
 -- and mutations yet.
-executeOperation :: Monad m
+executeOperation :: (MonadCatch m, Serialize a)
     => HashMap Name (Type m)
     -> Out.ObjectType m
     -> Seq (Transform.Selection m)
-    -> m Aeson.Value
+    -> m (Response a)
 executeOperation types' objectType fields =
     runCollectErrs types' $ executeSelectionSet Definition.Null objectType fields

src/Language/GraphQL/Execute/Execution.hs

@@ -3,11 +3,13 @@
 {-# LANGUAGE ViewPatterns #-}
 
 module Language.GraphQL.Execute.Execution
-    ( executeSelectionSet
+    ( coerceArgumentValues
+    , collectFields
+    , executeSelectionSet
     ) where
 
+import Control.Monad.Catch (Exception(..), MonadCatch(..))
 import Control.Monad.Trans.Class (lift)
-import Control.Monad.Trans.Except (runExceptT)
 import Control.Monad.Trans.Reader (runReaderT)
 import Control.Monad.Trans.State (gets)
 import Data.List.NonEmpty (NonEmpty(..))
@@ -17,28 +19,35 @@ import qualified Data.HashMap.Strict as HashMap
 import qualified Data.Map.Strict as Map
 import Data.Maybe (fromMaybe)
 import Data.Sequence (Seq(..))
-import Data.Text (Text)
+import qualified Data.Text as Text
 import Language.GraphQL.AST (Name)
-import Language.GraphQL.AST.Core
 import Language.GraphQL.Error
 import Language.GraphQL.Execute.Coerce
 import qualified Language.GraphQL.Execute.Transform as Transform
-import Language.GraphQL.Trans
 import qualified Language.GraphQL.Type as Type
 import qualified Language.GraphQL.Type.In as In
 import qualified Language.GraphQL.Type.Out as Out
+import Language.GraphQL.Type.Internal
 import Language.GraphQL.Type.Schema
 import Prelude hiding (null)
 
-resolveFieldValue :: Monad m
+resolveFieldValue :: MonadCatch m
     => Type.Value
     -> Type.Subs
-    -> ActionT m a
+    -> Type.Resolve m
-    -> m (Either Text a)
+    -> CollectErrsT m Type.Value
-resolveFieldValue result args =
+resolveFieldValue result args resolver =
-    flip runReaderT (Context {arguments = Arguments args, values = result})
+    catch (lift $ runReaderT resolver context) handleFieldError
-    . runExceptT
+  where
-    . runActionT
+    handleFieldError :: MonadCatch m
+        => ResolverException
+        -> CollectErrsT m Type.Value
+    handleFieldError e =
+        addErr (Error (Text.pack $ displayException e) []) >> pure Type.Null
+    context = Type.Context
+        { Type.arguments = Type.Arguments args
+        , Type.values = result
+        }
 
 collectFields :: Monad m
     => Out.ObjectType m
@@ -98,23 +107,27 @@ instanceOf objectType (AbstractUnionType unionType) =
   where
     go unionMemberType acc = acc || objectType == unionMemberType
 
-executeField :: (Monad m, Serialize a)
+executeField :: (MonadCatch m, Serialize a)
     => Out.Resolver m
     -> Type.Value
     -> NonEmpty (Transform.Field m)
     -> CollectErrsT m a
-executeField (Out.Resolver fieldDefinition resolver) prev fields = do
+executeField fieldResolver prev fields
-    let Out.Field _ fieldType argumentDefinitions = fieldDefinition
+    | Out.ValueResolver fieldDefinition resolver <- fieldResolver =
-    let (Transform.Field _ _ arguments' _ :| []) = fields
+        executeField' fieldDefinition resolver
-    case coerceArgumentValues argumentDefinitions arguments' of
+    | Out.EventStreamResolver fieldDefinition resolver _ <- fieldResolver =
-        Nothing -> errmsg "Argument coercing failed."
+        executeField' fieldDefinition resolver
-        Just argumentValues -> do
+  where
-            answer <- lift $ resolveFieldValue prev argumentValues resolver
+    executeField' fieldDefinition resolver = do
-            case answer of
+        let Out.Field _ fieldType argumentDefinitions = fieldDefinition
-                Right result -> completeValue fieldType fields result
+        let (Transform.Field _ _ arguments' _ :| []) = fields
-                Left errorMessage -> errmsg errorMessage
+        case coerceArgumentValues argumentDefinitions arguments' of
+            Nothing -> addErrMsg "Argument coercing failed."
+            Just argumentValues -> do
+                answer <- resolveFieldValue prev argumentValues resolver
+                completeValue fieldType fields answer
 
-completeValue :: (Monad m, Serialize a)
+completeValue :: (MonadCatch m, Serialize a)
     => Out.Type m
     -> NonEmpty (Transform.Field m)
     -> Type.Value
@@ -135,7 +148,7 @@ 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 errmsg "Value completion failed."
+        else addErrMsg "Value completion failed."
 completeValue (Out.ObjectBaseType objectType) fields result =
     executeSelectionSet result objectType $ mergeSelectionSets fields
 completeValue (Out.InterfaceBaseType interfaceType) fields result
@@ -145,7 +158,7 @@ completeValue (Out.InterfaceBaseType interfaceType) fields result
         case concreteType of
             Just objectType -> executeSelectionSet result objectType
                 $ mergeSelectionSets fields
-            Nothing -> errmsg "Value completion failed."
+            Nothing -> addErrMsg "Value completion failed."
 completeValue (Out.UnionBaseType unionType) fields result
     | Type.Object objectMap <- result = do
         let abstractType = AbstractUnionType unionType
@@ -153,30 +166,29 @@ completeValue (Out.UnionBaseType unionType) fields result
         case concreteType of
             Just objectType -> executeSelectionSet result objectType
                 $ mergeSelectionSets fields
-            Nothing -> errmsg "Value completion failed."
+            Nothing -> addErrMsg "Value completion failed."
-completeValue _ _ _ = errmsg "Value completion failed."
+completeValue _ _ _ = addErrMsg "Value completion failed."
 
-mergeSelectionSets :: Monad m => NonEmpty (Transform.Field m) -> Seq (Transform.Selection m)
+mergeSelectionSets :: MonadCatch m
+    => NonEmpty (Transform.Field m)
+    -> Seq (Transform.Selection m)
 mergeSelectionSets = foldr forEach mempty
   where
     forEach (Transform.Field _ _ _ fieldSelectionSet) selectionSet =
         selectionSet <> fieldSelectionSet
 
-errmsg :: (Monad m, Serialize a) => Text -> CollectErrsT m a
+coerceResult :: (MonadCatch m, Serialize a)
-errmsg errorMessage = addErrMsg errorMessage >> pure null
-
-coerceResult :: (Monad m, Serialize a)
     => Out.Type m
     -> Output a
     -> CollectErrsT m a
 coerceResult outputType result
     | Just serialized <- serialize outputType result = pure serialized
-    | otherwise = errmsg "Result coercion failed."
+    | otherwise = addErrMsg "Result coercion failed."
 
 -- | 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 :: (Monad m, Serialize a)
+executeSelectionSet :: (MonadCatch m, Serialize a)
     => Type.Value
     -> Out.ObjectType m
     -> Seq (Transform.Selection m)

src/Language/GraphQL/Execute/Subscribe.hs

@@ -0,0 +1,97 @@
+{- 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.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.Map.Strict as Map
+import qualified Data.List.NonEmpty as NonEmpty
+import Data.Sequence (Seq(..))
+import Data.Text (Text)
+import qualified Data.Text as Text
+import Language.GraphQL.AST (Name)
+import Language.GraphQL.Execute.Coerce
+import Language.GraphQL.Execute.Execution
+import qualified Language.GraphQL.Execute.Transform as Transform
+import Language.GraphQL.Error
+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
+
+-- This is actually executeMutation, but we don't distinguish between queries
+-- and mutations yet.
+subscribe :: (MonadCatch m, Serialize a)
+    => HashMap Name (Type m)
+    -> Out.ObjectType m
+    -> Seq (Transform.Selection m)
+    -> m (Either Text (ResponseEventStream m a))
+subscribe types' objectType fields = do
+    sourceStream <- createSourceEventStream types' objectType fields
+    traverse (mapSourceToResponseEvent types' objectType fields) sourceStream
+
+mapSourceToResponseEvent :: (MonadCatch m, Serialize a)
+    => HashMap 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 Name (Type m)
+    -> Out.ObjectType m
+    -> Seq (Transform.Selection m)
+    -> m (Either Text (Out.SourceEventStream m))
+createSourceEventStream _types subscriptionType@(Out.ObjectType _ _ _ fieldTypes) fields
+    | [fieldGroup] <- Map.elems groupedFieldSet
+    , Transform.Field _ fieldName arguments' _ <- NonEmpty.head fieldGroup
+    , resolverT <- fieldTypes HashMap.! fieldName
+    , Out.EventStreamResolver fieldDefinition _ resolver <- resolverT
+    , Out.Field _ _fieldType argumentDefinitions <- fieldDefinition =
+        case coerceArgumentValues argumentDefinitions arguments' of
+            Nothing -> pure $ Left "Argument coercion failed."
+            Just argumentValues ->
+                resolveFieldEventStream Type.Null argumentValues resolver
+    | otherwise = pure $ Left "Subscription contains more than one field."
+  where
+    groupedFieldSet = collectFields subscriptionType fields
+
+resolveFieldEventStream :: MonadCatch m
+    => Type.Value
+    -> Type.Subs
+    -> Out.Subscribe m
+    -> m (Either Text (Out.SourceEventStream m))
+resolveFieldEventStream result args resolver =
+    catch (Right <$> runReaderT resolver context) handleEventStreamError
+  where
+    handleEventStreamError :: MonadCatch m
+        => ResolverException
+        -> m (Either Text (Out.SourceEventStream m))
+    handleEventStreamError = pure . Left . Text.pack . displayException
+    context = Type.Context
+        { Type.arguments = Type.Arguments args
+        , Type.values = result
+        }
+
+-- This is actually executeMutation, but we don't distinguish between queries
+-- and mutations yet.
+executeSubscriptionEvent :: (MonadCatch m, Serialize a)
+    => HashMap Name (Type m)
+    -> Out.ObjectType m
+    -> Seq (Transform.Selection m)
+    -> Definition.Value
+    -> m (Response a)
+executeSubscriptionEvent types' objectType fields initialValue =
+    runCollectErrs types' $ executeSelectionSet initialValue objectType fields

src/Language/GraphQL/Execute/Transform.hs

@@ -44,12 +44,11 @@ import Data.Text (Text)
 import qualified Data.Text as Text
 import qualified Language.GraphQL.AST as Full
 import Language.GraphQL.AST (Name)
-import Language.GraphQL.AST.Core
 import qualified Language.GraphQL.Execute.Coerce as Coerce
-import Language.GraphQL.Type.Directive (Directive(..))
+import qualified Language.GraphQL.Type.Definition as Definition
-import qualified Language.GraphQL.Type.Directive as Directive
 import qualified Language.GraphQL.Type as Type
 import qualified Language.GraphQL.Type.In as In
+import Language.GraphQL.Type.Internal
 import qualified Language.GraphQL.Type.Out as Out
 import Language.GraphQL.Type.Schema
 
@@ -78,6 +77,7 @@ data Selection m
 data Operation m
     = Query (Maybe Text) (Seq (Selection m))
     | Mutation (Maybe Text) (Seq (Selection m))
+    | Subscription (Maybe Text) (Seq (Selection m))
 
 -- | Single GraphQL field.
 data Field m = Field
@@ -239,6 +239,10 @@ document schema operationName subs ast = do
             | Just mutationType <- mutation schema ->
                 pure $ Document referencedTypes mutationType
                     $ operation chosenOperation replacement
+        OperationDefinition Full.Subscription _ _ _ _
+            | Just subscriptionType <- subscription schema ->
+                pure $ Document referencedTypes subscriptionType
+                    $ operation chosenOperation replacement
         _ -> Left UnsupportedRootOperation
 
 defragment
@@ -251,10 +255,10 @@ defragment ast =
      in (, fragmentTable) <$> maybe emptyDocument Right nonEmptyOperations
   where
     defragment' definition (operations, fragments')
-        | (Full.ExecutableDefinition executable) <- definition
+        | (Full.ExecutableDefinition executable _) <- definition
         , (Full.DefinitionOperation operation') <- executable =
             (transform operation' : operations, fragments')
-        | (Full.ExecutableDefinition executable) <- definition
+        | (Full.ExecutableDefinition executable _) <- definition
         , (Full.DefinitionFragment fragment) <- executable
         , (Full.FragmentDefinition name _ _ _) <- fragment =
             (operations, HashMap.insert name fragment fragments')
@@ -276,6 +280,8 @@ operation operationDefinition replacement
         Query name <$> appendSelection sels
     transform (OperationDefinition Full.Mutation name _ _ sels) =
         Mutation name <$> appendSelection sels
+    transform (OperationDefinition Full.Subscription name _ _ sels) =
+        Subscription name <$> appendSelection sels
 
 -- * Selection
 
@@ -286,7 +292,7 @@ selection (Full.Field alias name arguments' directives' selections) =
     maybe (Left mempty) (Right . SelectionField) <$> do
         fieldArguments <- foldM go HashMap.empty arguments'
         fieldSelections <- appendSelection selections
-        fieldDirectives <- Directive.selection <$> directives directives'
+        fieldDirectives <- Definition.selection <$> directives directives'
         let field' = Field alias name fieldArguments fieldSelections
         pure $ field' <$ fieldDirectives
   where
@@ -295,7 +301,7 @@ selection (Full.Field alias name arguments' directives' selections) =
 
 selection (Full.FragmentSpread name directives') =
     maybe (Left mempty) (Right . SelectionFragment) <$> do
-        spreadDirectives <- Directive.selection <$> directives directives'
+        spreadDirectives <- Definition.selection <$> directives directives'
         fragments' <- gets fragments
 
         fragmentDefinitions' <- gets fragmentDefinitions
@@ -309,7 +315,7 @@ selection (Full.FragmentSpread name directives') =
                         _ -> lift $ pure  Nothing
                 | otherwise -> lift $ pure  Nothing
 selection (Full.InlineFragment type' directives' selections) = do
-    fragmentDirectives <- Directive.selection <$> directives directives'
+    fragmentDirectives <- Definition.selection <$> directives directives'
     case fragmentDirectives of
         Nothing -> pure $ Left mempty
         _ -> do
@@ -337,11 +343,11 @@ appendSelection = foldM go mempty
     append acc (Left list) = list >< acc
     append acc (Right one) = one <| acc
 
-directives :: [Full.Directive] ->  State (Replacement m) [Directive]
+directives :: [Full.Directive] ->  State (Replacement m) [Definition.Directive]
 directives = traverse directive
   where
     directive (Full.Directive directiveName directiveArguments)
-        = Directive directiveName . Arguments
+        = Definition.Directive directiveName . Type.Arguments
         <$> foldM go HashMap.empty directiveArguments
     go arguments (Full.Argument name value') = do
         substitutedValue <- value value'

src/Language/GraphQL/Trans.hs

@@ -1,67 +0,0 @@
--- | Monad transformer stack used by the @GraphQL@ resolvers.
-module Language.GraphQL.Trans
-    ( argument
-    , ActionT(..)
-    , Context(..)
-    ) where
-
-import Control.Applicative (Alternative(..))
-import Control.Monad (MonadPlus(..))
-import Control.Monad.IO.Class (MonadIO(..))
-import Control.Monad.Trans.Class (MonadTrans(..))
-import Control.Monad.Trans.Except (ExceptT)
-import Control.Monad.Trans.Reader (ReaderT, asks)
-import qualified Data.HashMap.Strict as HashMap
-import Data.Maybe (fromMaybe)
-import Data.Text (Text)
-import Language.GraphQL.AST (Name)
-import Language.GraphQL.AST.Core
-import Language.GraphQL.Type.Definition
-import Prelude hiding (lookup)
-
--- | Resolution context holds resolver arguments.
-data Context = Context
-    { arguments :: Arguments
-    , values :: Value
-    }
-
--- | Monad transformer stack used by the resolvers to provide error handling
---   and resolution context (resolver arguments).
-newtype ActionT m a = ActionT
-    { runActionT :: ExceptT Text (ReaderT Context m) a
-    }
-
-instance Functor m => Functor (ActionT m) where
-    fmap f = ActionT . fmap f . runActionT
-
-instance Monad m => Applicative (ActionT m) where
-    pure = ActionT . pure
-    (ActionT f) <*> (ActionT x) = ActionT $ f <*> x
-
-instance Monad m => Monad (ActionT m) where
-    return = pure
-    (ActionT action) >>= f = ActionT $ action >>= runActionT . f
-
-instance MonadTrans ActionT where
-    lift = ActionT . lift . lift
-
-instance MonadIO m => MonadIO (ActionT m) where
-    liftIO = lift . liftIO
-
-instance Monad m => Alternative (ActionT m) where
-    empty = ActionT empty
-    (ActionT x) <|> (ActionT y) = ActionT $ x <|> y
-
-instance Monad m => MonadPlus (ActionT m) where
-    mzero = empty
-    mplus = (<|>)
-
--- | Retrieves an argument by its name. If the argument with this name couldn't
---   be found, returns 'Null' (i.e. the argument is assumed to
---   be optional then).
-argument :: Monad m => Name -> ActionT m Value
-argument argumentName = do
-    argumentValue <- ActionT $ lift $ asks $ lookup . arguments
-    pure $ fromMaybe Null argumentValue
-  where
-    lookup (Arguments argumentMap) = HashMap.lookup argumentName argumentMap

src/Language/GraphQL/Type.hs

@@ -1,11 +1,21 @@
+{- 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/. -}
+
 -- | Reexports non-conflicting type system and schema definitions.
 module Language.GraphQL.Type
     ( In.InputField(..)
     , In.InputObjectType(..)
+    , Out.Context(..)
     , Out.Field(..)
     , Out.InterfaceType(..)
     , Out.ObjectType(..)
+    , Out.Resolve
+    , Out.Resolver(..)
+    , Out.SourceEventStream
+    , Out.Subscribe
     , Out.UnionType(..)
+    , Out.argument
     , module Language.GraphQL.Type.Definition
     , module Language.GraphQL.Type.Schema
     ) where

src/Language/GraphQL/Type/Definition.hs

@@ -2,7 +2,9 @@
 
 -- | Types that can be used as both input and output types.
 module Language.GraphQL.Type.Definition
-    ( EnumType(..)
+    ( Arguments(..)
+    , Directive(..)
+    , EnumType(..)
     , EnumValue(..)
     , ScalarType(..)
     , Subs
@@ -11,14 +13,16 @@ module Language.GraphQL.Type.Definition
     , float
     , id
     , int
+    , selection
     , string
     ) where
 
 import Data.Int (Int32)
 import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
 import Data.String (IsString(..))
 import Data.Text (Text)
-import Language.GraphQL.AST.Document (Name)
+import Language.GraphQL.AST (Name)
 import Prelude hiding (id)
 
 -- | Represents accordingly typed GraphQL values.
@@ -40,6 +44,16 @@ instance IsString Value where
 -- and the value is the variable value.
 type Subs = HashMap Name Value
 
+-- | Argument list.
+newtype Arguments = Arguments (HashMap Name Value)
+    deriving (Eq, Show)
+
+instance Semigroup Arguments where
+    (Arguments x) <> (Arguments y) = Arguments $ x <> y
+
+instance Monoid Arguments where
+    mempty = Arguments mempty
+
 -- | Scalar type definition.
 --
 -- The leaf values of any request and input values to arguments are Scalars (or
@@ -113,3 +127,49 @@ id = ScalarType "ID" (Just description)
         \JSON response as a String; however, it is not intended to be \
         \human-readable. When expected as an input type, any string (such as \
         \`\"4\"`) or integer (such as `4`) input value will be accepted as an ID."
+
+-- | Directive.
+data Directive = Directive Name Arguments
+    deriving (Eq, Show)
+
+-- | Directive processing status.
+data Status
+    = Skip -- ^ Skip the selection and stop directive processing
+    | Include Directive -- ^ The directive was processed, try other handlers
+    | Continue Directive -- ^ Directive handler mismatch, try other handlers
+
+-- | Takes a list of directives, handles supported directives and excludes them
+--   from the result. If the selection should be skipped, returns 'Nothing'.
+selection :: [Directive] -> Maybe [Directive]
+selection = foldr go (Just [])
+  where
+    go directive' directives' =
+        case (skip . include) (Continue directive') of
+            (Include _) -> directives'
+            Skip -> Nothing
+            (Continue x) -> (x :) <$> directives'
+
+handle :: (Directive -> Status) -> Status -> Status
+handle _ Skip = Skip
+handle handler (Continue directive) = handler directive
+handle handler (Include directive) = handler directive
+
+-- * Directive implementations
+
+skip :: Status -> Status
+skip = handle skip'
+  where
+    skip' directive'@(Directive "skip" (Arguments arguments)) =
+        case HashMap.lookup "if" arguments of
+            (Just (Boolean True)) -> Skip
+            _ -> Include directive'
+    skip' directive' = Continue directive'
+
+include :: Status -> Status
+include = handle include'
+  where
+    include' directive'@(Directive "include" (Arguments arguments)) =
+        case HashMap.lookup "if" arguments of
+            (Just (Boolean True)) -> Include directive'
+            _ -> Skip
+    include' directive' = Continue directive'

src/Language/GraphQL/Type/Directive.hs

@@ -1,57 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Language.GraphQL.Type.Directive
-    ( Directive(..)
-    , selection
-    ) where
-
-import qualified Data.HashMap.Strict as HashMap
-import Language.GraphQL.AST (Name)
-import Language.GraphQL.AST.Core
-import Language.GraphQL.Type.Definition
-
--- | Directive.
-data Directive = Directive Name Arguments
-    deriving (Eq, Show)
-
--- | Directive processing status.
-data Status
-    = Skip -- ^ Skip the selection and stop directive processing
-    | Include Directive -- ^ The directive was processed, try other handlers
-    | Continue Directive -- ^ Directive handler mismatch, try other handlers
-
--- | Takes a list of directives, handles supported directives and excludes them
---   from the result. If the selection should be skipped, returns 'Nothing'.
-selection :: [Directive] -> Maybe [Directive]
-selection = foldr go (Just [])
-  where
-    go directive' directives' =
-        case (skip . include) (Continue directive') of
-            (Include _) -> directives'
-            Skip -> Nothing
-            (Continue x) -> (x :) <$> directives'
-
-handle :: (Directive -> Status) -> Status -> Status
-handle _ Skip = Skip
-handle handler (Continue directive) = handler directive
-handle handler (Include directive) = handler directive
-
--- * Directive implementations
-
-skip :: Status -> Status
-skip = handle skip'
-  where
-    skip' directive'@(Directive "skip" (Arguments arguments)) =
-        case HashMap.lookup "if" arguments of
-            (Just (Boolean True)) -> Skip
-            _ -> Include directive'
-    skip' directive' = Continue directive'
-
-include :: Status -> Status
-include = handle include'
-  where
-    include' directive'@(Directive "include" (Arguments arguments)) =
-        case HashMap.lookup "if" arguments of
-            (Just (Boolean True)) -> Include directive'
-            _ -> Skip
-    include' directive' = Continue directive'

src/Language/GraphQL/Type/Internal.hs

@@ -0,0 +1,91 @@
+{- 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 #-}
+
+module Language.GraphQL.Type.Internal
+    ( AbstractType(..)
+    , CompositeType(..)
+    , collectReferencedTypes
+    ) where
+
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
+import Language.GraphQL.AST (Name)
+import qualified Language.GraphQL.Type.Definition as Definition
+import qualified Language.GraphQL.Type.In as In
+import qualified Language.GraphQL.Type.Out as Out
+import Language.GraphQL.Type.Schema
+
+-- | These types may describe the parent context of a selection set.
+data CompositeType m
+    = CompositeUnionType (Out.UnionType m)
+    | CompositeObjectType (Out.ObjectType m)
+    | CompositeInterfaceType (Out.InterfaceType m)
+    deriving Eq
+
+-- | These types may describe the parent context of a selection set.
+data AbstractType m
+    = AbstractUnionType (Out.UnionType m)
+    | AbstractInterfaceType (Out.InterfaceType m)
+    deriving Eq
+
+-- | Traverses the schema and finds all referenced types.
+collectReferencedTypes :: forall m. Schema m -> HashMap Name (Type m)
+collectReferencedTypes schema =
+    let queryTypes = traverseObjectType (query schema) HashMap.empty
+     in maybe queryTypes (`traverseObjectType` queryTypes) $ mutation schema
+  where
+    collect traverser typeName element foundTypes
+        | HashMap.member typeName foundTypes = foundTypes
+        | otherwise = traverser $ HashMap.insert typeName element foundTypes
+    visitFields (Out.Field _ outputType arguments) foundTypes
+        = traverseOutputType outputType
+        $ foldr visitArguments foundTypes arguments
+    visitArguments (In.Argument _ inputType _) = traverseInputType inputType
+    visitInputFields (In.InputField _ inputType _) = traverseInputType inputType
+    getField (Out.ValueResolver field _) = field
+    getField (Out.EventStreamResolver field _ _) = field
+    traverseInputType (In.InputObjectBaseType objectType) =
+        let (In.InputObjectType typeName _ inputFields) = objectType
+            element = InputObjectType objectType
+            traverser = flip (foldr visitInputFields) inputFields
+         in collect traverser typeName element
+    traverseInputType (In.ListBaseType listType) =
+        traverseInputType listType
+    traverseInputType (In.ScalarBaseType scalarType) =
+        let (Definition.ScalarType typeName _) = scalarType
+         in collect Prelude.id typeName (ScalarType scalarType)
+    traverseInputType (In.EnumBaseType enumType) =
+        let (Definition.EnumType typeName _ _) = enumType
+         in collect Prelude.id typeName (EnumType enumType)
+    traverseOutputType (Out.ObjectBaseType objectType) =
+        traverseObjectType objectType
+    traverseOutputType (Out.InterfaceBaseType interfaceType) =
+        traverseInterfaceType interfaceType
+    traverseOutputType (Out.UnionBaseType unionType) =
+        let (Out.UnionType typeName _ types) = unionType
+            traverser = flip (foldr traverseObjectType) types
+         in collect traverser typeName (UnionType unionType)
+    traverseOutputType (Out.ListBaseType listType) =
+        traverseOutputType listType
+    traverseOutputType (Out.ScalarBaseType scalarType) =
+        let (Definition.ScalarType typeName _) = scalarType
+         in collect Prelude.id typeName (ScalarType scalarType)
+    traverseOutputType (Out.EnumBaseType enumType) =
+        let (Definition.EnumType typeName _ _) = enumType
+         in collect Prelude.id typeName (EnumType enumType)
+    traverseObjectType objectType foundTypes =
+        let (Out.ObjectType typeName _ interfaces fields) = objectType
+            element = ObjectType objectType
+            traverser = polymorphicTraverser interfaces (getField <$> fields)
+         in collect traverser typeName element foundTypes
+    traverseInterfaceType interfaceType foundTypes =
+        let (Out.InterfaceType typeName _ interfaces fields) = interfaceType
+            element = InterfaceType interfaceType
+            traverser = polymorphicTraverser interfaces fields
+         in collect traverser typeName element foundTypes
+    polymorphicTraverser interfaces fields
+        = flip (foldr visitFields) fields
+        . flip (foldr traverseInterfaceType) interfaces

src/Language/GraphQL/Type/Out.hs

@@ -1,18 +1,28 @@
+{- 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 PatternSynonyms #-}
 {-# LANGUAGE ViewPatterns #-}
 
--- | Output types and values.
+-- | Output types and values, monad transformer stack used by the @GraphQL@
+-- resolvers.
 --
 -- This module is intended to be imported qualified, to avoid name clashes
 -- with 'Language.GraphQL.Type.In'.
 module Language.GraphQL.Type.Out
-    ( Field(..)
+    ( Context(..)
+    , Field(..)
     , InterfaceType(..)
     , ObjectType(..)
+    , Resolve
+    , Subscribe
     , Resolver(..)
+    , SourceEventStream
     , Type(..)
     , UnionType(..)
+    , argument
     , isNonNullType
     , pattern EnumBaseType
     , pattern InterfaceBaseType
@@ -22,26 +32,20 @@ module Language.GraphQL.Type.Out
     , pattern UnionBaseType
     ) where
 
+import Conduit
+import Control.Monad.Trans.Reader (ReaderT, asks)
 import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
+import Data.Maybe (fromMaybe)
 import Data.Text (Text)
 import Language.GraphQL.AST (Name)
-import Language.GraphQL.Trans
 import Language.GraphQL.Type.Definition
 import qualified Language.GraphQL.Type.In as In
 
--- | Resolves a 'Field' into an @Aeson.@'Data.Aeson.Types.Object' with error
--- information (if an error has occurred). @m@ is an arbitrary monad, usually
--- 'IO'.
---
--- Resolving a field can result in a leaf value or an object, which is
--- represented as a list of nested resolvers, used to resolve the fields of that
--- object.
-data Resolver m = Resolver (Field m) (ActionT m Value)
-
 -- | Object type definition.
 --
---   Almost all of the GraphQL types you define will be object types. Object
+-- Almost all of the GraphQL types you define will be object types. Object
---   types have a name, but most importantly describe their fields.
+-- types have a name, but most importantly describe their fields.
 data ObjectType m = ObjectType
     Name (Maybe Text) [InterfaceType m] (HashMap Name (Resolver m))
 
@@ -166,3 +170,43 @@ isNonNullType (NonNullInterfaceType _) = True
 isNonNullType (NonNullUnionType _) = True
 isNonNullType (NonNullListType _) = True
 isNonNullType _ = False
+
+-- | Resolution context holds resolver arguments and the root value.
+data Context = Context
+    { arguments :: Arguments
+    , values :: Value
+    }
+
+-- | Monad transformer stack used by the resolvers for determining the resolved
+-- value of a field.
+type Resolve m = ReaderT Context m Value
+
+-- | Monad transformer stack used by the resolvers for determining the resolved
+-- event stream of a subscription field.
+type Subscribe m = ReaderT Context m (SourceEventStream m)
+
+-- | A source stream represents the sequence of events, each of which will
+-- trigger a GraphQL execution corresponding to that event.
+type SourceEventStream m = ConduitT () Value m ()
+
+-- | 'Resolver' associates some function(s) with each 'Field'. 'ValueResolver'
+-- resolves a 'Field' into a 'Value'. 'EventStreamResolver' resolves
+-- additionally a 'Field' into a 'SourceEventStream' if it is the field of a
+-- root subscription type.
+--
+-- The resolvers aren't part of the 'Field' itself because not all fields
+-- have resolvers (interface fields don't have an implementation).
+data Resolver m
+    = ValueResolver (Field m) (Resolve m)
+    | EventStreamResolver (Field m) (Resolve m) (Subscribe m)
+
+-- | Retrieves an argument by its name. If the argument with this name couldn't
+-- be found, returns 'Null' (i.e. the argument is assumed to
+-- be optional then).
+argument :: Monad m => Name -> Resolve m
+argument argumentName = do
+    argumentValue <- asks $ lookupArgument . arguments
+    pure $ fromMaybe Null argumentValue
+  where
+    lookupArgument (Arguments argumentMap) =
+        HashMap.lookup argumentName argumentMap

src/Language/GraphQL/Type/Schema.hs

@@ -1,18 +1,10 @@
-{-# LANGUAGE ExplicitForAll #-}
-
 -- | This module provides a representation of a @GraphQL@ Schema in addition to
 -- functions for defining and manipulating schemas.
 module Language.GraphQL.Type.Schema
-    ( AbstractType(..)
+    ( Schema(..)
-    , CompositeType(..)
-    , Schema(..)
     , Type(..)
-    , collectReferencedTypes
     ) where
 
-import Data.HashMap.Strict (HashMap)
-import qualified Data.HashMap.Strict as HashMap
-import Language.GraphQL.AST.Document (Name)
 import qualified Language.GraphQL.Type.Definition as Definition
 import qualified Language.GraphQL.Type.In as In
 import qualified Language.GraphQL.Type.Out as Out
@@ -27,19 +19,6 @@ data Type m
     | UnionType (Out.UnionType m)
     deriving Eq
 
--- | These types may describe the parent context of a selection set.
-data CompositeType m
-    = CompositeUnionType (Out.UnionType m)
-    | CompositeObjectType (Out.ObjectType m)
-    | CompositeInterfaceType (Out.InterfaceType m)
-    deriving Eq
-
--- | These types may describe the parent context of a selection set.
-data AbstractType m
-    = AbstractUnionType (Out.UnionType m)
-    | AbstractInterfaceType (Out.InterfaceType m)
-    deriving Eq
-
 -- | A Schema is created by supplying the root types of each type of operation,
 --   query and mutation (optional). A schema definition is then supplied to the
 --   validator and executor.
@@ -50,63 +29,5 @@ data AbstractType m
 data Schema m = Schema
     { query :: Out.ObjectType m
     , mutation :: Maybe (Out.ObjectType m)
+    , subscription :: Maybe (Out.ObjectType m)
     }
-
--- | Traverses the schema and finds all referenced types.
-collectReferencedTypes :: forall m. Schema m -> HashMap Name (Type m)
-collectReferencedTypes schema =
-    let queryTypes = traverseObjectType (query schema) HashMap.empty
-     in maybe queryTypes (`traverseObjectType` queryTypes) $ mutation schema
-  where
-    collect traverser typeName element foundTypes
-        | HashMap.member typeName foundTypes = foundTypes
-        | otherwise = traverser $ HashMap.insert typeName element foundTypes
-    visitFields (Out.Field _ outputType arguments) foundTypes
-        = traverseOutputType outputType
-        $ foldr visitArguments foundTypes arguments
-    visitArguments (In.Argument _ inputType _) = traverseInputType inputType
-    visitInputFields (In.InputField _ inputType _) = traverseInputType inputType
-    traverseInputType (In.InputObjectBaseType objectType) =
-        let (In.InputObjectType typeName _ inputFields) = objectType
-            element = InputObjectType objectType
-            traverser = flip (foldr visitInputFields) inputFields
-         in collect traverser typeName element
-    traverseInputType (In.ListBaseType listType) =
-        traverseInputType listType
-    traverseInputType (In.ScalarBaseType scalarType) =
-        let (Definition.ScalarType typeName _) = scalarType
-         in collect Prelude.id typeName (ScalarType scalarType)
-    traverseInputType (In.EnumBaseType enumType) =
-        let (Definition.EnumType typeName _ _) = enumType
-         in collect Prelude.id typeName (EnumType enumType)
-    traverseOutputType (Out.ObjectBaseType objectType) =
-        traverseObjectType objectType
-    traverseOutputType (Out.InterfaceBaseType interfaceType) =
-        traverseInterfaceType interfaceType
-    traverseOutputType (Out.UnionBaseType unionType) =
-        let (Out.UnionType typeName _ types) = unionType
-            traverser = flip (foldr traverseObjectType) types
-         in collect traverser typeName (UnionType unionType)
-    traverseOutputType (Out.ListBaseType listType) =
-        traverseOutputType listType
-    traverseOutputType (Out.ScalarBaseType scalarType) =
-        let (Definition.ScalarType typeName _) = scalarType
-         in collect Prelude.id typeName (ScalarType scalarType)
-    traverseOutputType (Out.EnumBaseType enumType) =
-        let (Definition.EnumType typeName _ _) = enumType
-         in collect Prelude.id typeName (EnumType enumType)
-    traverseObjectType objectType foundTypes =
-        let (Out.ObjectType typeName _ interfaces resolvers) = objectType
-            element = ObjectType objectType
-            fields = extractObjectField <$> resolvers
-            traverser = polymorphicTraverser interfaces fields
-         in collect traverser typeName element foundTypes
-    traverseInterfaceType interfaceType foundTypes =
-        let (Out.InterfaceType typeName _ interfaces fields) = interfaceType
-            element = InterfaceType interfaceType
-            traverser = polymorphicTraverser interfaces fields
-         in collect traverser typeName element foundTypes
-    polymorphicTraverser interfaces fields
-        = flip (foldr visitFields) fields
-        . flip (foldr traverseInterfaceType) interfaces
-    extractObjectField (Out.Resolver field _) = field

src/Language/GraphQL/Validate.hs

@@ -0,0 +1,97 @@
+{- 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 LambdaCase #-}
+
+-- | GraphQL validator.
+module Language.GraphQL.Validate
+    ( Error(..)
+    , Path(..)
+    , document
+    , module Language.GraphQL.Validate.Rules
+    ) where
+
+import Control.Monad.Trans.Reader (Reader, asks, runReader)
+import Data.Foldable (foldrM)
+import Data.Sequence (Seq(..), (><), (|>))
+import qualified Data.Sequence as Seq
+import Data.Text (Text)
+import Language.GraphQL.AST.Document
+import Language.GraphQL.Type.Schema
+import Language.GraphQL.Validate.Rules
+
+data Context m = Context
+    { ast :: Document
+    , schema :: Schema m
+    , rules :: [Rule]
+    }
+
+type ValidateT m = Reader (Context m) (Seq Error)
+
+-- | 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
+-- whether a null result is intentional or caused by a runtime error.
+data Path
+    = Segment Text -- ^ Field name.
+    | Index Int -- ^ List index if a field returned a list.
+    deriving (Eq, Show)
+
+-- | Validation error.
+data Error = Error
+    { message :: String
+    , locations :: [Location]
+    , path :: [Path]
+    } deriving (Eq, Show)
+
+-- | Validates a document and returns a list of found errors. If the returned
+-- list is empty, the document is valid.
+document :: forall m. Schema m -> [Rule] -> Document -> Seq Error
+document schema' rules' document' =
+    runReader (foldrM go Seq.empty document') context
+  where
+    context = Context
+        { ast = document'
+        , schema = schema'
+        , rules = rules'
+        }
+    go definition' accumulator = (accumulator ><) <$> definition definition'
+
+definition :: forall m. Definition -> ValidateT m
+definition = \case
+    definition'@(ExecutableDefinition executableDefinition' _) -> do
+        applied <- applyRules definition'
+        children <- executableDefinition executableDefinition'
+        pure $ children >< applied
+    definition' -> applyRules definition'
+  where
+    applyRules definition' = foldr (ruleFilter definition') Seq.empty
+        <$> asks rules
+    ruleFilter definition' (DefinitionRule rule) accumulator
+        | Just message' <- rule definition' =
+            accumulator |> Error
+                { message = message'
+                , locations = [definitionLocation definition']
+                , path = []
+                }
+        | otherwise = accumulator
+    definitionLocation (ExecutableDefinition _ location) = location
+    definitionLocation (TypeSystemDefinition _ location) = location
+    definitionLocation (TypeSystemExtension _ location) = location
+
+executableDefinition :: forall m. ExecutableDefinition -> ValidateT m
+executableDefinition (DefinitionOperation definition') =
+    operationDefinition definition'
+executableDefinition (DefinitionFragment definition') =
+    fragmentDefinition definition'
+
+operationDefinition :: forall m. OperationDefinition -> ValidateT m
+operationDefinition (SelectionSet _operation) =
+    pure Seq.empty
+operationDefinition (OperationDefinition _type _name _variables _directives _selection) =
+    pure Seq.empty
+
+fragmentDefinition :: forall m. FragmentDefinition -> ValidateT m
+fragmentDefinition _fragment = pure Seq.empty

src/Language/GraphQL/Validate/Rules.hs

@@ -0,0 +1,31 @@
+{- 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/. -}
+
+-- | This module contains default rules defined in the GraphQL specification.
+module Language.GraphQL.Validate.Rules
+    ( Rule(..)
+    , executableDefinitionsRule
+    , specifiedRules
+    ) where
+
+import Language.GraphQL.AST.Document
+
+-- | 'Rule' assigns a function to each AST node that can be validated. If the
+-- validation fails, the function should return an error message, or 'Nothing'
+-- otherwise.
+newtype Rule
+    = DefinitionRule (Definition -> Maybe String)
+
+-- | Default reules given in the specification.
+specifiedRules :: [Rule]
+specifiedRules =
+    [ executableDefinitionsRule
+    ]
+
+-- | Definition must be OperationDefinition or FragmentDefinition.
+executableDefinitionsRule :: Rule
+executableDefinitionsRule = DefinitionRule go
+  where
+    go (ExecutableDefinition _definition _) = Nothing
+    go _ = Just "Definition must be OperationDefinition or FragmentDefinition."

src/Test/Hspec/GraphQL.hs

@@ -0,0 +1,40 @@
+{- 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 #-}
+
+-- | Test helpers.
+module Test.Hspec.GraphQL
+    ( shouldResolve
+    , shouldResolveTo
+    ) where
+
+import qualified Data.Aeson as Aeson
+import qualified Data.HashMap.Strict as HashMap
+import Data.Text (Text)
+import Language.GraphQL.Error
+import Test.Hspec.Expectations (Expectation, expectationFailure, shouldBe, shouldNotSatisfy)
+
+-- | Asserts that a query resolves to some value.
+shouldResolveTo
+    :: Either (ResponseEventStream IO Aeson.Value) Aeson.Object
+    -> Aeson.Object
+    -> Expectation
+shouldResolveTo (Right actual) expected = actual `shouldBe` expected
+shouldResolveTo _ _ = expectationFailure
+    "the query is expected to resolve to a value, but it resolved to an event stream"
+
+-- | Asserts that the response doesn't contain any errors.
+shouldResolve
+    :: (Text -> IO (Either (ResponseEventStream IO Aeson.Value) Aeson.Object))
+    -> Text
+    -> Expectation
+shouldResolve executor query = do
+    actual <- executor query
+    case actual of
+        Right response ->
+            response `shouldNotSatisfy` HashMap.member "errors"
+        _ -> expectationFailure
+            "the query is expected to resolve to a value, but it resolved to an event stream"

stack.yaml

@@ -1,4 +1,4 @@
-resolver: lts-16.1
+resolver: lts-16.6
 
 packages:
 - .

tests/Language/GraphQL/AST/ParserSpec.hs

@@ -129,10 +129,11 @@ spec = describe "Parser" $ do
 
     it "parses schema extension with an operation type and directive" $
         let newDirective = Directive "newDirective" []
-            testSchemaExtension = TypeSystemExtension
+            schemaExtension = SchemaExtension
-                $ SchemaExtension
                 $ SchemaOperationExtension [newDirective]
                 $ OperationTypeDefinition Query "Query" :| []
+            testSchemaExtension = TypeSystemExtension schemaExtension
+                $ Location 1 1
             query = [r|extend schema @newDirective { query: Query }|]
          in parse document "" query `shouldParse` (testSchemaExtension :| [])
 
@@ -149,3 +150,22 @@ spec = describe "Parser" $ do
               title
             }
         |]
+
+    it "parses documents beginning with a comment" $
+        parse document "" `shouldSucceedOn` [r|
+            """
+            Query
+            """
+            type Query {
+                queryField: String
+            }
+        |]
+
+    it "parses subscriptions" $
+        parse document "" `shouldSucceedOn` [r|
+            subscription NewMessages {
+              newMessage(roomId: 123) {
+                sender
+              }
+            }
+        |]

tests/Language/GraphQL/ErrorSpec.hs

@@ -4,6 +4,7 @@ module Language.GraphQL.ErrorSpec
     ) where
 
 import qualified Data.Aeson as Aeson
+import qualified Data.Sequence as Seq
 import Language.GraphQL.Error
 import Test.Hspec ( Spec
                   , describe
@@ -14,11 +15,6 @@ import Test.Hspec ( Spec
 spec :: Spec
 spec = describe "singleError" $
     it "constructs an error with the given message" $
-        let expected = Aeson.object
+        let errors'' = Seq.singleton $ Error "Message." []
-                [
+            expected = Response Aeson.Null errors''
-                    ("errors", Aeson.toJSON
-                        [ Aeson.object [("message", "Message.")]
-                        ]
-                    )
-                ]
          in singleError "Message." `shouldBe` expected

tests/Language/GraphQL/ExecuteSpec.hs

@@ -1,11 +1,16 @@
+{- 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 Language.GraphQL.ExecuteSpec
     ( spec
     ) where
 
+import Control.Exception (SomeException)
 import Data.Aeson ((.=))
 import qualified Data.Aeson as Aeson
-import Data.Functor.Identity (Identity(..))
+import Data.Conduit
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
 import Language.GraphQL.AST (Name)
@@ -14,62 +19,95 @@ import Language.GraphQL.Error
 import Language.GraphQL.Execute
 import Language.GraphQL.Type as Type
 import Language.GraphQL.Type.Out as Out
-import Test.Hspec (Spec, describe, it, shouldBe)
+import Test.Hspec (Spec, context, describe, it, shouldBe)
 import Text.Megaparsec (parse)
 
-schema :: Schema Identity
+schema :: Schema (Either SomeException)
-schema = Schema {query = queryType, mutation = Nothing}
+schema = Schema
+    { query = queryType
+    , mutation = Nothing
+    , subscription = Just subscriptionType
+    }
 
-queryType :: Out.ObjectType Identity
+queryType :: Out.ObjectType (Either SomeException)
 queryType = Out.ObjectType "Query" Nothing []
-    $ HashMap.singleton "philosopher"
+    $ HashMap.singleton "philosopher" 
-    $ Out.Resolver philosopherField
+    $ ValueResolver philosopherField
-    $ pure
+    $ pure $ Type.Object mempty
-    $ Type.Object mempty
   where
     philosopherField =
         Out.Field Nothing (Out.NonNullObjectType philosopherType) HashMap.empty
 
-philosopherType :: Out.ObjectType Identity
+philosopherType :: Out.ObjectType (Either SomeException)
 philosopherType = Out.ObjectType "Philosopher" Nothing []
     $ HashMap.fromList resolvers
   where
     resolvers =
-        [ ("firstName", firstNameResolver)
+        [ ("firstName", ValueResolver firstNameField firstNameResolver)
-        , ("lastName", lastNameResolver)
+        , ("lastName", ValueResolver lastNameField lastNameResolver)
         ]
-    firstNameResolver = Out.Resolver firstNameField $ pure $ Type.String "Friedrich"
+    firstNameField =
-    lastNameResolver = Out.Resolver lastNameField $ pure $ Type.String "Nietzsche"
+        Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
-    firstNameField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
+    firstNameResolver = pure $ Type.String "Friedrich"
-    lastNameField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
+    lastNameField
+        = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
+    lastNameResolver = pure $ Type.String "Nietzsche"
+
+subscriptionType :: Out.ObjectType (Either SomeException)
+subscriptionType = Out.ObjectType "Subscription" Nothing []
+    $ HashMap.singleton "newQuote"
+    $ EventStreamResolver quoteField (pure $ Type.Object mempty)
+    $ pure $ yield $ Type.Object mempty
+  where
+    quoteField =
+        Out.Field Nothing (Out.NonNullObjectType quoteType) HashMap.empty
+
+quoteType :: Out.ObjectType (Either SomeException)
+quoteType = Out.ObjectType "Quote" Nothing []
+    $ HashMap.singleton "quote"
+    $ ValueResolver quoteField
+    $ pure "Naturam expelles furca, tamen usque recurret."
+  where
+    quoteField =
+        Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
 
 spec :: Spec
 spec =
     describe "execute" $ do
-        it "skips unknown fields" $
+        context "Query" $ do
-            let expected = Aeson.object
+            it "skips unknown fields" $
-                    [ "data" .= Aeson.object
+                let data'' = Aeson.object
                         [ "philosopher" .= Aeson.object
                             [ "firstName" .= ("Friedrich" :: String)
                             ]
                         ]
-                    ]
+                    expected = Response data'' mempty
-                execute' = execute schema (mempty :: HashMap Name Aeson.Value)
+                    execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)
-                actual = runIdentity
+                    Right (Right actual) = either (pure . parseError) execute'
-                    $ either parseError execute'
+                        $ parse document "" "{ philosopher { firstName surname } }"
-                    $ parse document "" "{ philosopher { firstName surname } }"
+                in actual `shouldBe` expected
-             in actual `shouldBe` expected
+            it "merges selections" $
-        it "merges selections" $
+                let data'' = Aeson.object
-            let expected = Aeson.object
-                    [ "data" .= Aeson.object
                         [ "philosopher" .= Aeson.object
                             [ "firstName" .= ("Friedrich" :: String)
                             , "lastName" .= ("Nietzsche" :: String)
                             ]
                         ]
-                    ]
+                    expected = Response data'' mempty
-                execute' = execute schema (mempty :: HashMap Name Aeson.Value)
+                    execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)
-                actual = runIdentity
+                    Right (Right actual) = either (pure . parseError) execute'
-                    $ either parseError execute'
+                        $ parse document "" "{ philosopher { firstName } philosopher { lastName } }"
-                    $ parse document "" "{ philosopher { firstName } philosopher { lastName } }"
+                in actual `shouldBe` expected
-             in actual `shouldBe` expected
+        context "Subscription" $
+            it "subscribes" $
+                let data'' = Aeson.object
+                        [ "newQuote" .= Aeson.object
+                            [ "quote" .= ("Naturam expelles furca, tamen usque recurret." :: String)
+                            ]
+                        ]
+                    expected = Response data'' mempty
+                    execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)
+                    Right (Left stream) = either (pure . parseError) execute'
+                        $ parse document "" "subscription { newQuote { quote } }"
+                    Right (Just actual) = runConduit $ stream .| await
+                in actual `shouldBe` expected

tests/Language/GraphQL/ValidateSpec.hs

@@ -0,0 +1,171 @@
+{- This Source Code Form is subject to the terms of the Mozilla Public License,
+   v. 2.0. If a copy of the MPL was not distributed with this file, You can
+   obtain one at https://mozilla.org/MPL/2.0/. -}
+
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+module Language.GraphQL.ValidateSpec
+    ( spec
+    ) where
+
+import Data.Sequence (Seq(..))
+import qualified Data.Sequence as Seq
+import qualified Data.HashMap.Strict as HashMap
+import Data.Text (Text)
+import qualified Language.GraphQL.AST as AST
+import Language.GraphQL.Type
+import qualified Language.GraphQL.Type.In as In
+import qualified Language.GraphQL.Type.Out as Out
+import Language.GraphQL.Validate
+import Test.Hspec (Spec, describe, it, shouldBe)
+import Text.Megaparsec (parse)
+import Text.RawString.QQ (r)
+
+schema :: Schema IO
+schema = Schema
+    { query = queryType
+    , mutation = Nothing
+    , subscription = Nothing
+    } 
+
+queryType :: ObjectType IO
+queryType = ObjectType "Query" Nothing []
+    $ HashMap.singleton "dog" dogResolver
+  where
+    dogField = Field Nothing (Out.NamedObjectType dogType) mempty
+    dogResolver = ValueResolver dogField $ pure Null
+
+dogCommandType :: EnumType
+dogCommandType = EnumType "DogCommand" Nothing $ HashMap.fromList
+    [ ("SIT", EnumValue Nothing)
+    , ("DOWN", EnumValue Nothing)
+    , ("HEEL", EnumValue Nothing)
+    ]
+
+dogType :: ObjectType IO
+dogType = ObjectType "Dog" Nothing [petType] $ HashMap.fromList
+    [ ("name", nameResolver)
+    , ("nickname", nicknameResolver)
+    , ("barkVolume", barkVolumeResolver)
+    , ("doesKnowCommand", doesKnowCommandResolver)
+    , ("isHousetrained", isHousetrainedResolver)
+    , ("owner", ownerResolver)
+    ]
+  where
+    nameField = Field Nothing (Out.NonNullScalarType string) mempty
+    nameResolver = ValueResolver nameField $ pure "Name"
+    nicknameField = Field Nothing (Out.NamedScalarType string) mempty
+    nicknameResolver = ValueResolver nicknameField $ pure "Nickname"
+    barkVolumeField = Field Nothing (Out.NamedScalarType int) mempty
+    barkVolumeResolver = ValueResolver barkVolumeField $ pure $ Int 3
+    doesKnowCommandField = Field Nothing (Out.NonNullScalarType boolean)
+        $ HashMap.singleton "dogCommand"
+        $ In.Argument Nothing (In.NonNullEnumType dogCommandType) Nothing
+    doesKnowCommandResolver = ValueResolver doesKnowCommandField
+        $ pure $ Boolean True
+    isHousetrainedField = Field Nothing (Out.NonNullScalarType boolean)
+        $ HashMap.singleton "atOtherHomes"
+        $ In.Argument Nothing (In.NamedScalarType boolean) Nothing
+    isHousetrainedResolver = ValueResolver isHousetrainedField
+        $ pure $ Boolean True
+    ownerField = Field Nothing (Out.NamedObjectType humanType) mempty
+    ownerResolver = ValueResolver ownerField $ pure Null
+
+sentientType :: InterfaceType IO
+sentientType = InterfaceType "Sentient" Nothing []
+    $ HashMap.singleton "name"
+    $ Field Nothing (Out.NonNullScalarType string) mempty
+
+petType :: InterfaceType IO
+petType = InterfaceType "Pet" Nothing []
+    $ HashMap.singleton "name"
+    $ Field Nothing (Out.NonNullScalarType string) mempty
+{-
+alienType :: ObjectType IO
+alienType = ObjectType "Alien" Nothing [sentientType] $ HashMap.fromList
+    [ ("name", nameResolver)
+    , ("homePlanet", homePlanetResolver)
+    ]
+  where
+    nameField = Field Nothing (Out.NonNullScalarType string) mempty
+    nameResolver = ValueResolver nameField $ pure "Name"
+    homePlanetField =
+        Field Nothing (Out.NamedScalarType string) mempty
+    homePlanetResolver = ValueResolver homePlanetField $ pure "Home planet"
+-}
+humanType :: ObjectType IO
+humanType = ObjectType "Human" Nothing [sentientType] $ HashMap.fromList
+    [ ("name", nameResolver)
+    , ("pets", petsResolver)
+    ]
+  where
+    nameField = Field Nothing (Out.NonNullScalarType string) mempty
+    nameResolver = ValueResolver nameField $ pure "Name"
+    petsField =
+        Field Nothing (Out.ListType $ Out.NonNullInterfaceType petType) mempty
+    petsResolver = ValueResolver petsField $ pure $ List []
+{-
+catCommandType :: EnumType
+catCommandType = EnumType "CatCommand" Nothing $ HashMap.fromList
+    [ ("JUMP", EnumValue Nothing)
+    ]
+
+catType :: ObjectType IO
+catType = ObjectType "Cat" Nothing [petType] $ HashMap.fromList
+    [ ("name", nameResolver)
+    , ("nickname", nicknameResolver)
+    , ("doesKnowCommand", doesKnowCommandResolver)
+    , ("meowVolume", meowVolumeResolver)
+    ]
+  where
+    nameField = Field Nothing (Out.NonNullScalarType string) mempty
+    nameResolver = ValueResolver nameField $ pure "Name"
+    nicknameField = Field Nothing (Out.NamedScalarType string) mempty
+    nicknameResolver = ValueResolver nicknameField $ pure "Nickname"
+    doesKnowCommandField = Field Nothing (Out.NonNullScalarType boolean)
+        $ HashMap.singleton "catCommand"
+        $ In.Argument Nothing (In.NonNullEnumType catCommandType) Nothing
+    doesKnowCommandResolver = ValueResolver doesKnowCommandField
+        $ pure $ Boolean True
+    meowVolumeField = Field Nothing (Out.NamedScalarType int) mempty
+    meowVolumeResolver = ValueResolver meowVolumeField $ pure $ Int 2
+
+catOrDogType :: UnionType IO
+catOrDogType = UnionType "CatOrDog" Nothing [catType, dogType]
+
+dogOrHumanType :: UnionType IO
+dogOrHumanType = UnionType "DogOrHuman" Nothing [dogType, humanType]
+
+humanOrAlienType :: UnionType IO
+humanOrAlienType = UnionType "HumanOrAlien" Nothing [humanType, alienType]
+-}
+validate :: Text -> Seq Error
+validate queryString =
+    case parse AST.document "" queryString of
+        Left _ -> Seq.empty
+        Right ast -> document schema specifiedRules ast
+
+spec :: Spec
+spec =
+    describe "document" $
+        it "rejects type definitions" $
+            let queryString = [r|
+              query getDogName {
+                dog {
+                  name
+                  color
+                }
+              }
+
+              extend type Dog {
+                color: String
+              }
+            |]
+                expected = Error
+                    { message =
+                        "Definition must be OperationDefinition or FragmentDefinition."
+                    , locations = [AST.Location 9 15]
+                    , path = []
+                    }
+             in validate queryString `shouldBe` Seq.singleton expected

tests/Test/DirectiveSpec.hs

@@ -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 OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
 module Test.DirectiveSpec
@@ -10,21 +14,21 @@ import qualified Data.HashMap.Strict as HashMap
 import Language.GraphQL
 import Language.GraphQL.Type
 import qualified Language.GraphQL.Type.Out as Out
-import Test.Hspec (Spec, describe, it, shouldBe)
+import Test.Hspec (Spec, describe, it)
+import Test.Hspec.GraphQL
 import Text.RawString.QQ (r)
 
 experimentalResolver :: Schema IO
-experimentalResolver = Schema { query = queryType, mutation = Nothing }
+experimentalResolver = Schema
+    { query = queryType, mutation = Nothing, subscription = Nothing }
   where
-    resolver = pure $ Int 5
     queryType = Out.ObjectType "Query" Nothing []
         $ HashMap.singleton "experimentalField"
-        $ Out.Resolver (Out.Field Nothing (Out.NamedScalarType int) mempty) resolver
+        $ Out.ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
+        $ pure $ Int 5
 
-emptyObject :: Aeson.Value
+emptyObject :: Aeson.Object
-emptyObject = object
+emptyObject = HashMap.singleton "data" $ object []
-    [ "data" .= object []
-    ]
 
 spec :: Spec
 spec =
@@ -37,7 +41,7 @@ spec =
             |]
 
             actual <- graphql experimentalResolver sourceQuery
-            actual `shouldBe` emptyObject
+            actual `shouldResolveTo` emptyObject
 
         it "should not skip fields if @skip is false" $ do
             let sourceQuery = [r|
@@ -45,14 +49,12 @@ spec =
                 experimentalField @skip(if: false)
               }
             |]
-                expected = object
+                expected = HashMap.singleton "data"
-                    [ "data" .= object
+                    $ object
                         [ "experimentalField" .= (5 :: Int)
                         ]
-                    ]
-
             actual <- graphql experimentalResolver sourceQuery
-            actual `shouldBe` expected
+            actual `shouldResolveTo` expected
 
         it "should skip fields if @include is false" $ do
             let sourceQuery = [r|
@@ -62,7 +64,7 @@ spec =
             |]
 
             actual <- graphql experimentalResolver sourceQuery
-            actual `shouldBe` emptyObject
+            actual `shouldResolveTo` emptyObject
 
         it "should be able to @skip a fragment spread" $ do
             let sourceQuery = [r|
@@ -76,7 +78,7 @@ spec =
             |]
 
             actual <- graphql experimentalResolver sourceQuery
-            actual `shouldBe` emptyObject
+            actual `shouldResolveTo` emptyObject
 
         it "should be able to @skip an inline fragment" $ do
             let sourceQuery = [r|
@@ -88,4 +90,4 @@ spec =
             |]
 
             actual <- graphql experimentalResolver sourceQuery
-            actual `shouldBe` emptyObject
+            actual `shouldResolveTo` emptyObject

tests/Test/FragmentSpec.hs

@@ -1,23 +1,22 @@
+{- 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 (object, (.=))
+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 Test.Hspec
+import Test.Hspec (Spec, describe, it)
-    ( Spec
+import Test.Hspec.GraphQL
-    , describe
-    , it
-    , shouldBe
-    , shouldNotSatisfy
-    )
 import Text.RawString.QQ (r)
 
 size :: (Text, Value)
@@ -46,33 +45,33 @@ inlineQuery = [r|{
   }
 }|]
 
-hasErrors :: Aeson.Value -> Bool
-hasErrors (Aeson.Object object') = HashMap.member "errors" object'
-hasErrors _ = True
-
 shirtType :: Out.ObjectType IO
 shirtType = Out.ObjectType "Shirt" Nothing []
     $ HashMap.fromList
-        [ ("size", Out.Resolver sizeFieldType $ pure $ snd size)
+        [ ("size", sizeFieldType)
-        , ("circumference", Out.Resolver circumferenceFieldType $ pure $ snd circumference)
+        , ("circumference", circumferenceFieldType)
         ]
 
 hatType :: Out.ObjectType IO
 hatType = Out.ObjectType "Hat" Nothing []
     $ HashMap.fromList
-        [ ("size", Out.Resolver sizeFieldType $ pure $ snd size)
+        [ ("size", sizeFieldType)
-        , ("circumference", Out.Resolver circumferenceFieldType $ pure $ snd circumference)
+        , ("circumference", circumferenceFieldType)
         ]
 
-circumferenceFieldType :: Out.Field IO
+circumferenceFieldType :: Out.Resolver IO
-circumferenceFieldType = Out.Field Nothing (Out.NamedScalarType int) mempty
+circumferenceFieldType
+    = Out.ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
+    $ pure $ snd circumference
 
-sizeFieldType :: Out.Field IO
+sizeFieldType :: Out.Resolver IO
-sizeFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
+sizeFieldType
+    = Out.ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
+    $ pure $ snd size
 
 toSchema :: Text -> (Text, Value) -> Schema IO
 toSchema t (_, resolve) = Schema
-    { query = queryType, mutation = Nothing }
+    { query = queryType, mutation = Nothing, subscription = Nothing }
   where
     unionMember = if t == "Hat" then hatType else shirtType
     typeNameField = Out.Field Nothing (Out.NamedScalarType string) mempty
@@ -83,8 +82,8 @@ toSchema t (_, resolve) = Schema
             "size" -> shirtType
             _ -> Out.ObjectType "Query" Nothing []
                 $ HashMap.fromList
-                    [ ("garment", Out.Resolver garmentField $ pure resolve)
+                    [ ("garment", ValueResolver garmentField (pure resolve))
-                    , ("__typename", Out.Resolver typeNameField $ pure $ String "Shirt")
+                    , ("__typename", ValueResolver typeNameField (pure $ String "Shirt"))
                     ]
 
 spec :: Spec
@@ -92,25 +91,23 @@ 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 = object
+            let expected = HashMap.singleton "data"
-                    [ "data" .= object
+                    $ Aeson.object
-                        [ "garment" .= object
+                        [ "garment" .= Aeson.object
                             [ "circumference" .= (60 :: Int)
                             ]
                         ]
-                    ]
+             in actual `shouldResolveTo` expected
-             in actual `shouldBe` expected
 
         it "chooses the last selection if the type matches" $ do
             actual <- graphql (toSchema "Shirt" $ garment "Shirt") inlineQuery
-            let expected = object
+            let expected = HashMap.singleton "data"
-                    [ "data" .= object
+                    $ Aeson.object
-                        [ "garment" .= object
+                        [ "garment" .= Aeson.object
                             [ "size" .= ("L" :: Text)
                             ]
                         ]
-                    ]
+             in actual `shouldResolveTo` expected
-             in actual `shouldBe` expected
 
         it "embeds inline fragments without type" $ do
             let sourceQuery = [r|{
@@ -124,15 +121,14 @@ spec = do
                 resolvers = ("garment", Object $ HashMap.fromList [circumference,  size])
 
             actual <- graphql (toSchema "garment" resolvers) sourceQuery
-            let expected = object
+            let expected = HashMap.singleton "data"
-                    [ "data" .= object
+                    $ Aeson.object
-                        [ "garment" .= object
+                        [ "garment" .= Aeson.object
                             [ "circumference" .= (60 :: Int)
                             , "size" .= ("L" :: Text)
                             ]
                         ]
-                    ]
+             in actual `shouldResolveTo` expected
-             in actual `shouldBe` expected
 
         it "evaluates fragments on Query" $ do
             let sourceQuery = [r|{
@@ -140,9 +136,7 @@ spec = do
                 size
               }
             }|]
-
+             in graphql (toSchema "size" size) `shouldResolve` sourceQuery
-            actual <- graphql (toSchema "size" size) sourceQuery
-            actual `shouldNotSatisfy` hasErrors
 
     describe "Fragment spread executor" $ do
         it "evaluates fragment spreads" $ do
@@ -157,12 +151,11 @@ spec = do
             |]
 
             actual <- graphql (toSchema "circumference" circumference) sourceQuery
-            let expected = object
+            let expected = HashMap.singleton "data"
-                    [ "data" .= object
+                    $ Aeson.object
                         [ "circumference" .= (60 :: Int)
                         ]
-                    ]
+             in actual `shouldResolveTo` expected
-             in actual `shouldBe` expected
 
         it "evaluates nested fragments" $ do
             let sourceQuery = [r|
@@ -182,19 +175,16 @@ spec = do
             |]
 
             actual <- graphql (toSchema "Hat" $ garment "Hat") sourceQuery
-            let expected = object
+            let expected = HashMap.singleton "data"
-                    [ "data" .= object
+                    $ Aeson.object
-                        [ "garment" .= object
+                        [ "garment" .= Aeson.object
                             [ "circumference" .= (60 :: Int)
                             ]
                         ]
-                    ]
+             in actual `shouldResolveTo` expected
-             in actual `shouldBe` expected
 
         it "rejects recursive fragments" $ do
-            let expected = object
+            let expected = HashMap.singleton "data" $ Aeson.object []
-                    [ "data" .= object []
-                    ]
                 sourceQuery = [r|
               {
                 ...circumferenceFragment
@@ -206,7 +196,7 @@ spec = do
             |]
 
             actual <- graphql (toSchema "circumference" circumference) sourceQuery
-            actual `shouldBe` expected
+            actual `shouldResolveTo` expected
 
         it "considers type condition" $ do
             let sourceQuery = [r|
@@ -223,12 +213,11 @@ spec = do
                 size
               }
             |]
-                expected = object
+                expected = HashMap.singleton "data"
-                    [ "data" .= object
+                    $ Aeson.object
-                        [ "garment" .= object
+                        [ "garment" .= Aeson.object
                             [ "circumference" .= (60 :: Int)
                             ]
                         ]
-                    ]
             actual <- graphql (toSchema "Hat" $ garment "Hat") sourceQuery
-            actual `shouldBe` expected
+            actual `shouldResolveTo` expected

tests/Test/RootOperationSpec.hs

@@ -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 OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
 module Test.RootOperationSpec
@@ -7,30 +11,34 @@ module Test.RootOperationSpec
 import Data.Aeson ((.=), object)
 import qualified Data.HashMap.Strict as HashMap
 import Language.GraphQL
-import Test.Hspec (Spec, describe, it, shouldBe)
+import Test.Hspec (Spec, describe, it)
 import Text.RawString.QQ (r)
 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"
-    $ Out.Resolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
+    $ ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
     $ pure $ Int 60
 
 schema :: Schema IO
 schema = Schema
-    (Out.ObjectType "Query" Nothing [] hatField)
+    { query = Out.ObjectType "Query" Nothing [] hatFieldResolver
-    (Just $ Out.ObjectType "Mutation" Nothing [] incrementField)
+    , mutation = Just $ Out.ObjectType "Mutation" Nothing [] incrementFieldResolver
+    , subscription = Nothing
+    }
   where
     garment = pure $ Object $ HashMap.fromList
         [ ("circumference", Int 60)
         ]
-    incrementField = HashMap.singleton "incrementCircumference"
+    incrementFieldResolver = HashMap.singleton "incrementCircumference"
-        $ Out.Resolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
+        $ ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
         $ pure $ Int 61
-    hatField = HashMap.singleton "garment"
+    hatField = Out.Field Nothing (Out.NamedObjectType hatType) mempty
-        $ Out.Resolver (Out.Field Nothing (Out.NamedObjectType hatType) mempty) garment
+    hatFieldResolver =
+        HashMap.singleton "garment" $ ValueResolver hatField garment
 
 spec :: Spec
 spec =
@@ -43,15 +51,14 @@ spec =
                 }
               }
             |]
-                expected = object
+                expected = HashMap.singleton "data"
-                    [ "data" .= object
+                    $ object
                         [ "garment" .= object
                             [ "circumference" .= (60 :: Int)
                             ]
                         ]
-                    ]
             actual <- graphql schema querySource
-            actual `shouldBe` expected
+            actual `shouldResolveTo` expected
 
         it "chooses Mutation" $ do
             let querySource = [r|
@@ -59,10 +66,9 @@ spec =
                 incrementCircumference
               }
             |]
-                expected = object
+                expected = HashMap.singleton "data"
-                    [ "data" .= object
+                    $ object
                         [ "incrementCircumference" .= (61 :: Int)
                         ]
-                    ]
             actual <- graphql schema querySource
-            actual `shouldBe` expected
+            actual `shouldResolveTo` expected

tests/Test/StarWars/Data.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Test.StarWars.Data
     ( Character
+    , StarWarsException(..)
     , appearsIn
     , artoo
     , getDroid
@@ -16,12 +17,13 @@ module Test.StarWars.Data
     , typeName
     ) where
 
-import Data.Functor.Identity (Identity)
+import Control.Monad.Catch (Exception(..), MonadThrow(..), SomeException)
 import Control.Applicative (Alternative(..), liftA2)
-import Control.Monad.Trans.Except (throwE)
 import Data.Maybe (catMaybes)
 import Data.Text (Text)
-import Language.GraphQL.Trans
+import Data.Typeable (cast)
+import Language.GraphQL.Error
+import Language.GraphQL.Type
 
 -- * Data
 -- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsData.js
@@ -66,8 +68,20 @@ appearsIn :: Character -> [Int]
 appearsIn (Left  x) = _appearsIn . _droidChar $ x
 appearsIn (Right x) = _appearsIn . _humanChar $ x
 
-secretBackstory :: ActionT Identity Text
+data StarWarsException = SecretBackstory | InvalidArguments
-secretBackstory = ActionT $ throwE "secretBackstory is secret."
+
+instance Show StarWarsException where
+    show SecretBackstory = "secretBackstory is secret."
+    show InvalidArguments = "Invalid arguments."
+
+instance Exception StarWarsException where
+    toException = toException . ResolverException
+    fromException e = do
+        ResolverException resolverException <- fromException e
+        cast resolverException
+
+secretBackstory :: Resolve (Either SomeException)
+secretBackstory = throwM SecretBackstory
 
 typeName :: Character -> Text
 typeName = either (const "Droid") (const "Human")
@@ -161,10 +175,10 @@ getHero :: Int -> Character
 getHero 5 = luke
 getHero _ = artoo
 
-getHuman :: Alternative f => ID -> f Character
+getHuman :: ID -> Maybe Character
 getHuman = fmap Right . getHuman'
 
-getHuman' :: Alternative f => ID -> f Human
+getHuman' :: ID -> Maybe Human
 getHuman' "1000" = pure luke'
 getHuman' "1001" = pure vader
 getHuman' "1002" = pure han
@@ -172,10 +186,10 @@ getHuman' "1003" = pure leia
 getHuman' "1004" = pure tarkin
 getHuman' _      = empty
 
-getDroid :: Alternative f => ID -> f Character
+getDroid :: ID -> Maybe Character
 getDroid = fmap Left . getDroid'
 
-getDroid' :: Alternative f => ID -> f Droid
+getDroid' :: ID -> Maybe Droid
 getDroid' "2000" = pure threepio
 getDroid' "2001" = pure artoo'
 getDroid' _      = empty

tests/Test/StarWars/QuerySpec.hs

@@ -6,7 +6,6 @@ module Test.StarWars.QuerySpec
 
 import qualified Data.Aeson as Aeson
 import Data.Aeson ((.=))
-import Data.Functor.Identity (Identity(..))
 import qualified Data.HashMap.Strict as HashMap
 import Data.Text (Text)
 import Language.GraphQL
@@ -357,8 +356,11 @@ spec = describe "Star Wars Query Tests" $ do
     alderaan = "homePlanet" .= ("Alderaan" :: Text)
 
 testQuery :: Text -> Aeson.Value -> Expectation
-testQuery q expected = runIdentity (graphql schema q) `shouldBe` expected
+testQuery q expected =
+    let Right (Right actual) = graphql schema q
+     in Aeson.Object actual `shouldBe` expected
 
 testQueryParams :: Aeson.Object -> Text -> Aeson.Value -> Expectation
 testQueryParams f q expected =
-    runIdentity (graphqlSubs schema f q) `shouldBe` expected
+    let Right (Right actual) = graphqlSubs schema Nothing f q
+     in Aeson.Object actual `shouldBe` expected

tests/Test/StarWars/Schema.hs

@@ -4,14 +4,11 @@ module Test.StarWars.Schema
     ( schema
     ) where
 
+import Control.Monad.Catch (MonadThrow(..), SomeException)
 import Control.Monad.Trans.Reader (asks)
-import Control.Monad.Trans.Except (throwE)
-import Control.Monad.Trans.Class (lift)
-import Data.Functor.Identity (Identity)
 import qualified Data.HashMap.Strict as HashMap
 import Data.Maybe (catMaybes)
 import Data.Text (Text)
-import Language.GraphQL.Trans
 import Language.GraphQL.Type
 import qualified Language.GraphQL.Type.In as In
 import qualified Language.GraphQL.Type.Out as Out
@@ -20,69 +17,97 @@ import Prelude hiding (id)
 
 -- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js
 
-schema :: Schema Identity
+schema :: Schema (Either SomeException)
-schema = Schema { query = queryType, mutation = Nothing }
+schema = Schema
+    { query = queryType
+    , mutation = Nothing
+    , subscription = Nothing
+    }
   where
     queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList
-        [ ("hero", Out.Resolver heroField hero)
+        [ ("hero", heroFieldResolver)
-        , ("human", Out.Resolver humanField human)
+        , ("human", humanFieldResolver)
-        , ("droid", Out.Resolver droidField droid)
+        , ("droid", droidFieldResolver)
         ]
     heroField = Out.Field Nothing (Out.NamedObjectType heroObject)
         $ HashMap.singleton "episode"
         $ In.Argument Nothing (In.NamedEnumType episodeEnum) Nothing
+    heroFieldResolver = ValueResolver heroField hero
     humanField = Out.Field Nothing (Out.NamedObjectType heroObject)
         $ HashMap.singleton "id"
         $ In.Argument Nothing (In.NonNullScalarType string) Nothing
+    humanFieldResolver = ValueResolver humanField human
     droidField = Out.Field Nothing (Out.NamedObjectType droidObject) mempty
+    droidFieldResolver = ValueResolver droidField droid
 
-heroObject :: Out.ObjectType Identity
+heroObject :: Out.ObjectType (Either SomeException)
 heroObject = Out.ObjectType "Human" Nothing [] $ HashMap.fromList
-    [ ("id", Out.Resolver idFieldType (idField "id"))
+    [ ("id", idFieldType)
-    , ("name", Out.Resolver nameFieldType (idField "name"))
+    , ("name", nameFieldType)
-    , ("friends", Out.Resolver friendsFieldType (idField "friends"))
+    , ("friends", friendsFieldType)
-    , ("appearsIn", Out.Resolver appearsInField (idField "appearsIn"))
+    , ("appearsIn", appearsInField)
-    , ("homePlanet", Out.Resolver homePlanetFieldType (idField "homePlanet"))
+    , ("homePlanet", homePlanetFieldType)
-    , ("secretBackstory", Out.Resolver secretBackstoryFieldType (String <$> secretBackstory))
+    , ("secretBackstory", secretBackstoryFieldType)
-    , ("__typename", Out.Resolver (Out.Field Nothing (Out.NamedScalarType string) mempty) (idField "__typename"))
+    , ("__typename", typenameFieldType)
     ]
   where
-    homePlanetFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
+    homePlanetFieldType
+      = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
+      $ idField "homePlanet"
 
-droidObject :: Out.ObjectType Identity
+droidObject :: Out.ObjectType (Either SomeException)
 droidObject = Out.ObjectType "Droid" Nothing [] $ HashMap.fromList
-    [ ("id", Out.Resolver idFieldType (idField "id"))
+    [ ("id", idFieldType)
-    , ("name", Out.Resolver nameFieldType (idField "name"))
+    , ("name", nameFieldType)
-    , ("friends", Out.Resolver friendsFieldType (idField "friends"))
+    , ("friends", friendsFieldType)
-    , ("appearsIn", Out.Resolver appearsInField (idField "appearsIn"))
+    , ("appearsIn", appearsInField)
-    , ("primaryFunction", Out.Resolver primaryFunctionFieldType (idField "primaryFunction"))
+    , ("primaryFunction", primaryFunctionFieldType)
-    , ("secretBackstory", Out.Resolver secretBackstoryFieldType (String <$> secretBackstory))
+    , ("secretBackstory", secretBackstoryFieldType)
-    , ("__typename", Out.Resolver (Out.Field Nothing (Out.NamedScalarType string) mempty) (idField "__typename"))
+    , ("__typename", typenameFieldType)
     ]
   where
-    primaryFunctionFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
+    primaryFunctionFieldType
+        = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
+        $ idField "primaryFunction"
 
-idFieldType :: Out.Field Identity
+typenameFieldType :: Resolver (Either SomeException)
-idFieldType = Out.Field Nothing (Out.NamedScalarType id) mempty
+typenameFieldType
+    = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
+    $ idField "__typename"
 
-nameFieldType :: Out.Field Identity
+idFieldType :: Resolver (Either SomeException)
-nameFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
+idFieldType
+    = ValueResolver (Out.Field Nothing (Out.NamedScalarType id) mempty)
+    $ idField "id"
 
-friendsFieldType :: Out.Field Identity
+nameFieldType :: Resolver (Either SomeException)
-friendsFieldType = Out.Field Nothing (Out.ListType $ Out.NamedObjectType droidObject) mempty
+nameFieldType
+    = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
+    $ idField "name"
 
-appearsInField :: Out.Field Identity
+friendsFieldType :: Resolver (Either SomeException)
-appearsInField = Out.Field (Just description) fieldType mempty
+friendsFieldType
+    = ValueResolver (Out.Field Nothing fieldType mempty)
+    $ idField "friends"
+  where
+    fieldType = Out.ListType $ Out.NamedObjectType droidObject
+
+appearsInField :: Resolver (Either SomeException)
+appearsInField
+    = ValueResolver (Out.Field (Just description) fieldType mempty)
+    $ idField "appearsIn"
   where
     fieldType = Out.ListType $ Out.NamedEnumType episodeEnum
     description = "Which movies they appear in."
 
-secretBackstoryFieldType :: Out.Field Identity
+secretBackstoryFieldType :: Resolver (Either SomeException)
-secretBackstoryFieldType = Out.Field Nothing (Out.NamedScalarType string) mempty
+secretBackstoryFieldType = ValueResolver field secretBackstory
+  where
+    field = Out.Field Nothing (Out.NamedScalarType string) mempty
 
-idField :: Text -> ActionT Identity Value
+idField :: Text -> Resolve (Either SomeException)
 idField f = do
-    v <- ActionT $ lift $ asks values
+    v <- asks values
     let (Object v') = v
     pure $ v' HashMap.! f
 
@@ -95,7 +120,7 @@ episodeEnum = EnumType "Episode" (Just description)
     empire = ("EMPIRE", EnumValue $ Just "Released in 1980.")
     jedi = ("JEDI", EnumValue $ Just "Released in 1983.")
 
-hero :: ActionT Identity Value
+hero :: Resolve (Either SomeException)
 hero = do
   episode <- argument "episode"
   pure $ character $ case episode of
@@ -104,23 +129,19 @@ hero = do
       Enum "JEDI" -> getHero 6
       _ -> artoo
 
-human :: ActionT Identity Value
+human :: Resolve (Either SomeException)
 human = do
     id' <- argument "id"
     case id' of
-        String i -> do
+        String i -> pure $ maybe Null character $ getHuman i >>= Just
-            humanCharacter <- lift $ return $ getHuman i >>= Just
+        _ -> throwM InvalidArguments
-            case humanCharacter of
-                Nothing -> pure Null
-                Just e -> pure $ character e
-        _ -> ActionT $ throwE "Invalid arguments."
 
-droid :: ActionT Identity Value
+droid :: Resolve (Either SomeException)
 droid = do
     id' <- argument "id"
     case id' of
-        String i -> character <$> getDroid i
+        String i -> pure $ maybe Null character $ getDroid i >>= Just
-        _ -> ActionT $ throwE "Invalid arguments."
+        _ -> throwM InvalidArguments
 
 character :: Character -> Value
 character char = Object $ HashMap.fromList