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

@@ -7,6 +7,114 @@ 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
+  specification defines default values as `Value` with `const` parameter and
+  constants cannot be variables. `AST.Document.ConstValue` was added,
+  `AST.Document.ObjectField` was modified.
+- AST transformation should never fail.
+    * Arguments and fields with a missing variable as value should be left out.
+    * Invalid (recusrive or non-existing) fragments should be skipped.
+- Argument value coercion.
+- Variable value coercion.
+- Result coercion.
+- The executor should skip the fields missing in the object type and not fail.
+- Merging subselections.
+
+### Changed
+- `Schema.Resolver` was moved to `Type.Out`, it is a field and resolver function
+  pair.
+- `AST.Core.Value` was moved into `Type.Definition`. These values are used only
+  in the execution and type system, it is not a part of the parsing tree.
+- `Type` module is superseded by `Type.Out`. This module contains now only
+  exports from other module that complete `Type.In` and `Type.Out` exports.
+- `Error.CollectErrsT` contains the new `Resolution` data structure.
+  `Resolution` represents the state used by the executor. It contains all types
+  defined in the schema and collects the thrown errors.
+
+### Added
+- `Type.Definition` contains base type system definition, e.g. Enums and
+  Scalars.
+- `Type.Schema` describes a schema. Both public functions that execute queries
+  accept a `Schema` now instead of a `HashMap`. The execution fails if the root
+  operation doesn't match the root Query type in the schema.
+- `Type.In` and `Type.Out` contain definitions for input and output types.
+- `Execute.Coerce` defines a typeclass responsible for input, variable value
+  coercion. It decouples us a bit from JSON since any format can be used to pass
+  query variables. Execution functions accept (`HashMap Name a`) instead of
+  `Subs`, where a is an instance of `VariableValue`.
+
+### Removed
+- `Schema.scalar`, `Schema.wrappedScalar`. They accepted everything can be
+  converted to JSON and JSON is not suitable as an internal representation for
+  GraphQL. E.g. GraphQL distinguishes between Floats and Integers.
+- `Schema.wrappedObject`, `Schema.object`, `Schema.resolversToMap`. There is no
+  need in special functions to construct field resolvers anymore, resolvers are
+  normal functions attached to the fields in the schema representation.
+- `Schema.resolve` is superseded by `Execute.Execution`.
+- `Error.runAppendErrs` isn't used anywhere.
+- `AST.Core`: `Document`, `Directive`, `Field`, `Fragment`, `Selection`, `Alias`
+  `TypeCondition` were modified, moved into `Execute.Transform.Document` and
+  made private. These types describe intermediate representation used by the
+  executor internally. Moving was required to avoid cyclic dependencies between
+  the executor and type system.
+- `AST.Core` doesn't reexports anything.
 
 ## [0.7.0.0] - 2020-05-11
 ### Fixed
@@ -20,7 +128,7 @@ and this project adheres to
 - `Trans.argument`.
 - Schema extension parser.
 - Contributing guidelines.
-- `Schema.resolversToMap` (intended for to be used internally).
+- `Schema.resolversToMap` (intended to be used internally).
 
 ### Changed
 - Rename `AST.Definition` into `AST.Document.ExecutableDefinition`.
@@ -215,7 +323,8 @@ and this project adheres to
 ### Added
 - Data types for the GraphQL language.
 
-[Unreleased]: https://github.com/caraus-ecms/graphql/compare/v0.6.1.0...HEAD
+[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
 [0.6.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.5.1.0...v0.6.0.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
@@ -17,64 +19,82 @@ Since this file is a literate haskell file, we start by importing some dependenc
 > import Control.Monad.IO.Class (liftIO)
 > import Data.Aeson (encode)
 > import Data.ByteString.Lazy.Char8 (putStrLn)
-> import Data.HashMap.Strict (HashMap)
 > import qualified Data.HashMap.Strict as HashMap
-> import Data.List.NonEmpty (NonEmpty(..))
 > import Data.Text (Text)
+> import qualified Data.Text as Text
 > import Data.Time (getCurrentTime)
 >
 > import Language.GraphQL
-> import qualified Language.GraphQL.Schema as Schema
+> 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 :: HashMap Text (NonEmpty (Schema.Resolver IO))
+> schema1 :: Schema IO
-> schema1 = HashMap.singleton "Query" $ hello :| []
+> schema1 = Schema
+>   { query = queryType , mutation = Nothing , subscription = Nothing }
 >
-> hello :: Schema.Resolver IO
+> queryType :: ObjectType IO
-> hello = Schema.scalar "hello" (return ("it's me" :: Text))
+> queryType = ObjectType "Query" Nothing []
+>   $ HashMap.singleton "hello"
+>   $ ValueResolver helloField hello
+>
+> helloField :: Field IO
+> helloField = Field Nothing (Out.NamedScalarType string) mempty
+>
+> 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 = putStrLn =<< encode <$> graphql schema1 query1
+> 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 :: HashMap Text (NonEmpty (Schema.Resolver IO))
+> schema2 :: Schema IO
-> schema2 = HashMap.singleton "Query" $ time :| []
+> schema2 = Schema
+>   { query = queryType2, mutation = Nothing, subscription = Nothing }
 >
-> time :: Schema.Resolver IO
+> queryType2 :: ObjectType IO
-> time = Schema.scalar "time" $ do
+> queryType2 = ObjectType "Query" Nothing []
+>   $ HashMap.singleton "time"
+>   $ ValueResolver timeField time
+>
+> timeField :: Field IO
+> timeField = Field Nothing (Out.NamedScalarType string) mempty
+>
+> time :: Resolve IO
+> time = do
 >   t <- liftIO getCurrentTime
->   return $ show t
+>   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.
 
@@ -82,70 +102,51 @@ Next we define our query.
 > query2 = "{ time }"
 >
 > main2 :: IO ()
-> main2 = putStrLn =<< encode <$> graphql schema2 query2
+> 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 :: HashMap Text (NonEmpty (Schema.Resolver IO))
+> schema3 :: Schema IO
-> schema3 = HashMap.singleton "Query" $ hello :| [time]
+> schema3 = Schema
+>   { query = queryType3, mutation = Nothing, subscription = Nothing }
+>
+> queryType3 :: ObjectType IO
+> queryType3 = ObjectType "Query" Nothing [] $ HashMap.fromList
+>   [ ("hello", ValueResolver helloField hello)
+>   , ("time", ValueResolver timeField time)
+>   ]
 >
 > query3 :: Text
 > query3 = "query timeAndHello { time hello }"
 >
 > main3 :: IO ()
-> main3 = putStrLn =<< encode <$> graphql schema3 query3
+> 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.7.0.0
+version:             0.9.0.0
 synopsis:            Haskell GraphQL implementation
 description:
   This package provides a rudimentary parser for the
@@ -28,9 +28,13 @@ data-files:
 dependencies:
 - aeson
 - base >= 4.7 && < 5
+- conduit
 - containers
+- exceptions
+- hspec-expectations
 - megaparsec
 - parser-combinators
+- scientific
 - text
 - transformers
 - unordered-containers
@@ -38,8 +42,12 @@ dependencies:
 library:
   source-dirs: src
   other-modules:
+  - Language.GraphQL.Execute.Execution
+  - Language.GraphQL.Execute.Subscribe
   - Language.GraphQL.Execute.Transform
-  - Language.GraphQL.Type.Directive
+  - Language.GraphQL.Type.Definition
+  - Language.GraphQL.Type.Internal
+  - Language.GraphQL.Validate.Rules
 
 tests:
   tasty:
@@ -52,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,35 +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.List.NonEmpty (NonEmpty)
+import qualified Data.Aeson.Types as Aeson
-import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
+import qualified Data.Sequence as Seq
 import Data.Text (Text)
+import Language.GraphQL.AST
 import Language.GraphQL.Error
 import Language.GraphQL.Execute
-import Language.GraphQL.AST.Parser
+import qualified Language.GraphQL.Validate as Validate
-import qualified Language.GraphQL.Schema as Schema
+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.Resolver's.
+-- executed using the given 'Schema'.
-graphql :: Monad m
+graphql :: MonadCatch m
-    => HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers.
+    => 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
+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.Resolver's.
+-- 'Schema'.
-graphqlSubs :: Monad m
+graphqlSubs :: MonadCatch m
-    => HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers.
+    => Schema m -- ^ Resolvers.
-    -> Schema.Subs -- ^ 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,78 +0,0 @@
--- | This is the AST meant to be executed.
-module Language.GraphQL.AST.Core
-    ( Alias
-    , Arguments(..)
-    , Directive(..)
-    , Document
-    , Field(..)
-    , Fragment(..)
-    , Name
-    , Operation(..)
-    , Selection(..)
-    , TypeCondition
-    , Value(..)
-    ) where
-
-import Data.Int (Int32)
-import Data.HashMap.Strict (HashMap)
-import Data.List.NonEmpty (NonEmpty)
-import Data.Sequence (Seq)
-import Data.String (IsString(..))
-import Data.Text (Text)
-import Language.GraphQL.AST (Alias, Name, TypeCondition)
-
--- | GraphQL document is a non-empty list of operations.
-type Document = NonEmpty Operation
-
--- | GraphQL has 3 operation types: queries, mutations and subscribtions.
---
--- Currently only queries and mutations are supported.
-data Operation
-    = Query (Maybe Text) (Seq Selection)
-    | Mutation (Maybe Text) (Seq Selection)
-    deriving (Eq, Show)
-
--- | Single GraphQL field.
-data Field
-    = Field (Maybe Alias) Name Arguments (Seq Selection)
-    deriving (Eq, Show)
-
--- | 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
-
--- | Directive.
-data Directive = Directive Name Arguments
-    deriving (Eq, Show)
-
--- | Represents fragments and inline fragments.
-data Fragment
-    = Fragment TypeCondition (Seq Selection)
-    deriving (Eq, Show)
-
--- | Single selection element.
-data Selection
-    = SelectionFragment Fragment
-    | SelectionField Field
-    deriving (Eq, Show)
-
--- | Represents accordingly typed GraphQL values.
-data Value
-    = Int Int32
-    | Float Double -- ^ GraphQL Float is double precision
-    | String Text
-    | Boolean Bool
-    | Null
-    | Enum Name
-    | List [Value]
-    | Object (HashMap Name Value)
-    deriving (Eq, Show)
-
-instance IsString Value where
-    fromString = String . fromString

src/Language/GraphQL/AST/Document.hs

@@ -8,6 +8,7 @@ module Language.GraphQL.AST.Document
     ( Alias
     , Argument(..)
     , ArgumentsDefinition(..)
+    , ConstValue(..)
     , Definition(..)
     , Description(..)
     , Directive(..)
@@ -18,6 +19,7 @@ module Language.GraphQL.AST.Document
     , FragmentDefinition(..)
     , ImplementsInterfaces(..)
     , InputValueDefinition(..)
+    , Location(..)
     , Name
     , NamedType
     , NonNullType(..)
@@ -54,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.
@@ -61,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.
@@ -91,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
 
@@ -197,7 +203,7 @@ type TypeCondition = Name
 
 -- ** Input Values
 
--- | Input value.
+-- | Input value (literal or variable).
 data Value
     = Variable Name
     | Int Int32
@@ -207,18 +213,46 @@ data Value
     | Null
     | Enum Name
     | List [Value]
-    | Object [ObjectField]
+    | Object [ObjectField Value]
+    deriving (Eq, Show)
+
+-- | Constant input value.
+data ConstValue
+    = ConstInt Int32
+    | ConstFloat Double
+    | ConstString Text
+    | ConstBoolean Bool
+    | ConstNull
+    | ConstEnum Name
+    | ConstList [ConstValue]
+    | ConstObject [ObjectField ConstValue]
     deriving (Eq, Show)
 
 -- | Key-value pair.
 --
 -- A list of 'ObjectField's represents a GraphQL object type.
-data ObjectField = ObjectField Name Value deriving (Eq, Show)
+data ObjectField a = ObjectField Name a
+    deriving (Eq, Show)
 
 -- ** Variables
 
 -- | Variable definition.
-data VariableDefinition = VariableDefinition Name Type (Maybe Value)
+--
+-- Each operation can include a list of variables:
+--
+-- @
+-- query (protagonist: String = "Zarathustra") {
+--   getAuthor(protagonist: $protagonist)
+-- }
+-- @
+--
+-- This query defines an optional variable @protagonist@ of type @String@,
+-- its default value is "Zarathustra". If no default value is defined and no
+-- value is provided, a variable can still be @null@ if its type is nullable.
+--
+-- Variables are usually passed along with the query, but not in the query
+-- itself. They make queries reusable.
+data VariableDefinition = VariableDefinition Name Type (Maybe ConstValue)
     deriving (Eq, Show)
 
 -- ** Type References
@@ -445,7 +479,7 @@ instance Monoid ArgumentsDefinition where
 --
 -- The input type "Point2D" contains two value definitions: "x" and "y".
 data InputValueDefinition
-    = InputValueDefinition Description Name Type (Maybe Value) [Directive]
+    = InputValueDefinition Description Name Type (Maybe ConstValue) [Directive]
     deriving (Eq, Show)
 
 -- ** Unions

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
@@ -24,7 +25,6 @@ import Data.Text.Lazy.Builder (Builder)
 import qualified Data.Text.Lazy.Builder as Builder
 import Data.Text.Lazy.Builder.Int (decimal, hexadecimal)
 import Data.Text.Lazy.Builder.RealFloat (realFloat)
-import qualified Language.GraphQL.AST as Full
 import Language.GraphQL.AST.Document
 
 -- | Instructs the encoder whether the GraphQL document should be minified or
@@ -50,35 +50,38 @@ 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'Full.ExecutableDefinition' into a string.
+-- | Converts a t'ExecutableDefinition' into a string.
 definition :: Formatter -> ExecutableDefinition -> Lazy.Text
 definition formatter x
     | Pretty _ <- formatter = Lazy.Text.snoc (encodeDefinition x) '\n'
     | Minified <- formatter = encodeDefinition x
   where
-    encodeDefinition (Full.DefinitionOperation operation)
+    encodeDefinition (DefinitionOperation operation)
         = operationDefinition formatter operation
-    encodeDefinition (Full.DefinitionFragment fragment)
+    encodeDefinition (DefinitionFragment fragment)
         = fragmentDefinition formatter fragment
 
--- | Converts a 'Full.OperationDefinition into a string.
+-- | Converts a 'OperationDefinition into a string.
-operationDefinition :: Formatter -> Full.OperationDefinition -> Lazy.Text
+operationDefinition :: Formatter -> OperationDefinition -> Lazy.Text
-operationDefinition formatter (Full.SelectionSet sels)
+operationDefinition formatter = \case
-    = selectionSet formatter sels
+    SelectionSet sels -> selectionSet formatter sels
-operationDefinition formatter (Full.OperationDefinition Full.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 (Full.OperationDefinition Full.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 Full.Query or Full.Mutation into a string.
+-- | Converts a Query or Mutation into a string.
 node :: Formatter ->
-    Maybe Full.Name ->
+    Maybe Name ->
-    [Full.VariableDefinition] ->
+    [VariableDefinition] ->
-    [Full.Directive] ->
+    [Directive] ->
-    Full.SelectionSet ->
+    SelectionSet ->
     Lazy.Text
 node formatter name vars dirs sels
     = Lazy.Text.fromStrict (fold name)
@@ -87,31 +90,31 @@ node formatter name vars dirs sels
     <> eitherFormat formatter " " mempty
     <> selectionSet formatter sels
 
-variableDefinitions :: Formatter -> [Full.VariableDefinition] -> Lazy.Text
+variableDefinitions :: Formatter -> [VariableDefinition] -> Lazy.Text
 variableDefinitions formatter
     = parensCommas formatter $ variableDefinition formatter
 
-variableDefinition :: Formatter -> Full.VariableDefinition -> Lazy.Text
+variableDefinition :: Formatter -> VariableDefinition -> Lazy.Text
-variableDefinition formatter (Full.VariableDefinition var ty dv)
+variableDefinition formatter (VariableDefinition var ty defaultValue')
     = variable var
     <> eitherFormat formatter ": " ":"
     <> type' ty
-    <> maybe mempty (defaultValue formatter) dv
+    <> maybe mempty (defaultValue formatter) defaultValue'
 
-defaultValue :: Formatter -> Full.Value -> Lazy.Text
+defaultValue :: Formatter -> ConstValue -> Lazy.Text
 defaultValue formatter val
     = eitherFormat formatter " = " "="
-    <> value formatter val
+    <> value formatter (fromConstValue val)
 
-variable :: Full.Name -> Lazy.Text
+variable :: Name -> Lazy.Text
 variable var = "$" <> Lazy.Text.fromStrict var
 
-selectionSet :: Formatter -> Full.SelectionSet -> Lazy.Text
+selectionSet :: Formatter -> SelectionSet -> Lazy.Text
 selectionSet formatter
     = bracesList formatter (selection formatter)
     . NonEmpty.toList
 
-selectionSetOpt :: Formatter -> Full.SelectionSetOpt -> Lazy.Text
+selectionSetOpt :: Formatter -> SelectionSetOpt -> Lazy.Text
 selectionSetOpt formatter = bracesList formatter $ selection formatter
 
 indentSymbol :: Lazy.Text
@@ -120,14 +123,14 @@ indentSymbol = "  "
 indent :: (Integral a) => a -> Lazy.Text
 indent indentation = Lazy.Text.replicate (fromIntegral indentation) indentSymbol
 
-selection :: Formatter -> Full.Selection -> Lazy.Text
+selection :: Formatter -> Selection -> Lazy.Text
 selection formatter = Lazy.Text.append indent' . encodeSelection
   where
-    encodeSelection (Full.Field alias name args directives' selections) =
+    encodeSelection (Field alias name args directives' selections) =
         field incrementIndent alias name args directives' selections
-    encodeSelection (Full.InlineFragment typeCondition directives' selections) =
+    encodeSelection (InlineFragment typeCondition directives' selections) =
         inlineFragment incrementIndent typeCondition directives' selections
-    encodeSelection (Full.FragmentSpread name directives') =
+    encodeSelection (FragmentSpread name directives') =
         fragmentSpread incrementIndent name directives'
     incrementIndent
         | Pretty indentation <- formatter = Pretty $ indentation + 1
@@ -139,13 +142,13 @@ selection formatter = Lazy.Text.append indent' . encodeSelection
 colon :: Formatter -> Lazy.Text
 colon formatter = eitherFormat formatter ": " ":"
 
--- | Converts Full.Field into a string
+-- | Converts Field into a string
 field :: Formatter ->
-    Maybe Full.Name ->
+    Maybe Name ->
-    Full.Name ->
+    Name ->
-    [Full.Argument] ->
+    [Argument] ->
-    [Full.Directive] ->
+    [Directive] ->
-    [Full.Selection] ->
+    [Selection] ->
     Lazy.Text
 field formatter alias name args dirs set
     = optempty prependAlias (fold alias)
@@ -158,27 +161,27 @@ field formatter alias name args dirs set
     selectionSetOpt' = (eitherFormat formatter " " "" <>)
         . selectionSetOpt formatter
 
-arguments :: Formatter -> [Full.Argument] -> Lazy.Text
+arguments :: Formatter -> [Argument] -> Lazy.Text
 arguments formatter = parensCommas formatter $ argument formatter
 
-argument :: Formatter -> Full.Argument -> Lazy.Text
+argument :: Formatter -> Argument -> Lazy.Text
-argument formatter (Full.Argument name value')
+argument formatter (Argument name value')
     = Lazy.Text.fromStrict name
     <> colon formatter
     <> value formatter value'
 
 -- * Fragments
 
-fragmentSpread :: Formatter -> Full.Name -> [Full.Directive] -> Lazy.Text
+fragmentSpread :: Formatter -> Name -> [Directive] -> Lazy.Text
 fragmentSpread formatter name directives'
     = "..." <> Lazy.Text.fromStrict name
     <> optempty (directives formatter) directives'
 
 inlineFragment ::
     Formatter ->
-    Maybe Full.TypeCondition ->
+    Maybe TypeCondition ->
-    [Full.Directive] ->
+    [Directive] ->
-    Full.SelectionSet ->
+    SelectionSet ->
     Lazy.Text
 inlineFragment formatter tc dirs sels = "... on "
     <> Lazy.Text.fromStrict (fold tc)
@@ -186,8 +189,8 @@ inlineFragment formatter tc dirs sels = "... on "
     <> eitherFormat formatter " " mempty
     <> selectionSet formatter sels
 
-fragmentDefinition :: Formatter -> Full.FragmentDefinition -> Lazy.Text
+fragmentDefinition :: Formatter -> FragmentDefinition -> Lazy.Text
-fragmentDefinition formatter (Full.FragmentDefinition name tc dirs sels)
+fragmentDefinition formatter (FragmentDefinition name tc dirs sels)
     = "fragment " <> Lazy.Text.fromStrict name
     <> " on " <> Lazy.Text.fromStrict tc
     <> optempty (directives formatter) dirs
@@ -196,26 +199,39 @@ fragmentDefinition formatter (Full.FragmentDefinition name tc dirs sels)
 
 -- * Miscellaneous
 
--- | Converts a 'Full.Directive' into a string.
+-- | Converts a 'Directive' into a string.
-directive :: Formatter -> Full.Directive -> Lazy.Text
+directive :: Formatter -> Directive -> Lazy.Text
-directive formatter (Full.Directive name args)
+directive formatter (Directive name args)
     = "@" <> Lazy.Text.fromStrict name <> optempty (arguments formatter) args
 
-directives :: Formatter -> [Full.Directive] -> Lazy.Text
+directives :: Formatter -> [Directive] -> Lazy.Text
 directives Minified = spaces (directive Minified)
 directives formatter = Lazy.Text.cons ' ' . spaces (directive formatter)
 
--- | Converts a 'Full.Value' into a string.
+-- | Converts a 'Value' into a string.
-value :: Formatter -> Full.Value -> Lazy.Text
+value :: Formatter -> Value -> Lazy.Text
-value _ (Full.Variable x) = variable x
+value _ (Variable x) = variable x
-value _ (Full.Int x) = Builder.toLazyText $ decimal x
+value _ (Int x) = Builder.toLazyText $ decimal x
-value _ (Full.Float x) = Builder.toLazyText $ realFloat x
+value _ (Float x) = Builder.toLazyText $ realFloat x
-value _ (Full.Boolean  x) = booleanValue x
+value _ (Boolean  x) = booleanValue x
-value _ Full.Null = "null"
+value _ Null = "null"
-value formatter (Full.String string) = stringValue formatter string
+value formatter (String string) = stringValue formatter string
-value _ (Full.Enum x) = Lazy.Text.fromStrict x
+value _ (Enum x) = Lazy.Text.fromStrict x
-value formatter (Full.List x) = listValue formatter x
+value formatter (List x) = listValue formatter x
-value formatter (Full.Object x) = objectValue formatter x
+value formatter (Object x) = objectValue formatter x
+
+fromConstValue :: ConstValue -> Value
+fromConstValue (ConstInt x) = Int x
+fromConstValue (ConstFloat x) = Float x
+fromConstValue (ConstBoolean  x) = Boolean x
+fromConstValue ConstNull = Null
+fromConstValue (ConstString string) = String string
+fromConstValue (ConstEnum x) = Enum x
+fromConstValue (ConstList x) = List $ fromConstValue <$> x
+fromConstValue (ConstObject x) = Object $ fromConstObjectField <$> x
+  where
+    fromConstObjectField (ObjectField key value') =
+        ObjectField key $ fromConstValue value'
 
 booleanValue :: Bool -> Lazy.Text
 booleanValue True  = "true"
@@ -242,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'
@@ -271,10 +288,10 @@ escape char'
   where
     unicode prefix = mappend (Builder.fromString prefix) . (hexadecimal . ord)
 
-listValue :: Formatter -> [Full.Value] -> Lazy.Text
+listValue :: Formatter -> [Value] -> Lazy.Text
 listValue formatter = bracketsCommas formatter $ value formatter
 
-objectValue :: Formatter -> [Full.ObjectField] -> Lazy.Text
+objectValue :: Formatter -> [ObjectField Value] -> Lazy.Text
 objectValue formatter = intercalate $ objectField formatter
   where
     intercalate f
@@ -282,22 +299,22 @@ objectValue formatter = intercalate $ objectField formatter
         . Lazy.Text.intercalate (eitherFormat formatter ", " ",")
         . fmap f
 
-objectField :: Formatter -> Full.ObjectField -> Lazy.Text
+objectField :: Formatter -> ObjectField Value -> Lazy.Text
-objectField formatter (Full.ObjectField name value') =
+objectField formatter (ObjectField name value') =
     Lazy.Text.fromStrict name <> colon formatter <> value formatter value'
 
--- | Converts a 'Full.Type' a type into a string.
+-- | Converts a 'Type' a type into a string.
-type' :: Full.Type -> Lazy.Text
+type' :: Type -> Lazy.Text
-type' (Full.TypeNamed   x) = Lazy.Text.fromStrict x
+type' (TypeNamed   x) = Lazy.Text.fromStrict x
-type' (Full.TypeList    x) = listType x
+type' (TypeList    x) = listType x
-type' (Full.TypeNonNull x) = nonNullType x
+type' (TypeNonNull x) = nonNullType x
 
-listType :: Full.Type -> Lazy.Text
+listType :: Type -> Lazy.Text
 listType x = brackets (type' x)
 
-nonNullType :: Full.NonNullType -> Lazy.Text
+nonNullType :: NonNullType -> Lazy.Text
-nonNullType (Full.NonNullTypeNamed x) = Lazy.Text.fromStrict x <> "!"
+nonNullType (NonNullTypeNamed x) = Lazy.Text.fromStrict x <> "!"
-nonNullType (Full.NonNullTypeList  x) = listType x <> "!"
+nonNullType (NonNullTypeList  x) = listType x <> "!"
 
 -- * Internal
 

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

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,6 +409,7 @@ inlineFragment = InlineFragment
     <*> optional typeCondition
     <*> directives
     <*> selectionSet
+    <?> "InlineFragment"
 
 fragmentDefinition :: Parser FragmentDefinition
 fragmentDefinition = FragmentDefinition
@@ -392,48 +418,65 @@ fragmentDefinition = FragmentDefinition
     <*> typeCondition
     <*> directives
     <*> 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     <$> listValue
+    <|> List <$> brackets (some value)
-    <|> Object   <$> objectValue
+    <|> Object <$> braces (some $ objectField value)
-    <?> "value error!"
+    <?> "Value"
-  where
+
+constValue :: Parser ConstValue
+constValue = ConstFloat <$> try float
+    <|> ConstInt <$> integer
+    <|> ConstBoolean <$> booleanValue
+    <|> ConstNull <$ nullValue
+    <|> ConstString <$> stringValue
+    <|> ConstEnum <$> try enumValue
+    <|> ConstList <$> brackets (some constValue)
+    <|> ConstObject <$> braces (some $ objectField constValue)
+    <?> "Value"
+
 booleanValue :: Parser Bool
 booleanValue = True  <$ symbol "true"
     <|> False <$ symbol "false"
-
+    <?> "BooleanValue"
-    listValue :: Parser [Value]
-    listValue = brackets $ some value
-
-    objectValue :: Parser [ObjectField]
-    objectValue = braces $ some objectField
 
 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"
 
-objectField :: Parser ObjectField
+stringValue :: Parser Text
-objectField = ObjectField <$> name <* colon <*> value
+stringValue = blockString <|> string <?> "StringValue"
 
--- * Variables
+nullValue :: Parser Text
+nullValue = symbol "null" <?> "NullValue"
+
+objectField :: Parser a -> Parser (ObjectField a)
+objectField valueParser = ObjectField
+    <$> name
+    <* colon
+    <*> valueParser
+    <?> "ObjectField"
 
 variableDefinitions :: Parser [VariableDefinition]
 variableDefinitions = listOptIn parens variableDefinition
+    <?> "VariableDefinitions"
 
 variableDefinition :: Parser VariableDefinition
 variableDefinition = VariableDefinition
@@ -444,12 +487,10 @@ variableDefinition = VariableDefinition
     <?> "VariableDefinition"
 
 variable :: Parser Name
-variable = dollar *> name
+variable = dollar *> name <?> "Variable"
 
-defaultValue :: Parser (Maybe Value)
+defaultValue :: Parser (Maybe ConstValue)
-defaultValue = optional (equals *> value) <?> "DefaultValue"
+defaultValue = optional (equals *> constValue) <?> "DefaultValue"
-
--- * Input Types
 
 type' :: Parser Type
 type' = try (TypeNonNull <$> nonNullType)
@@ -460,20 +501,17 @@ type' = try (TypeNonNull <$> nonNullType)
 nonNullType :: Parser NonNullType
 nonNullType = NonNullTypeNamed <$> name <* 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,21 +7,29 @@
 module Language.GraphQL.Error
     ( parseError
     , CollectErrsT
+    , Error(..)
+    , Resolution(..)
+    , ResolverException(..)
+    , Response(..)
+    , ResponseEventStream
     , addErr
     , addErrMsg
     , runCollectErrs
-    , runAppendErrs
     , singleError
     ) where
 
-import qualified Data.Aeson as Aeson
+import Conduit
+import Control.Exception (Exception(..))
+import Control.Monad.Trans.State (StateT, modify, runStateT)
+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 Control.Monad.Trans.Class (lift)
+import Language.GraphQL.AST (Location(..), Name)
-import Control.Monad.Trans.State ( StateT
+import Language.GraphQL.Execute.Coerce
-                                 , modify
+import Language.GraphQL.Type.Schema
-                                 , runStateT
+import Prelude hiding (null)
-                                 )
 import Text.Megaparsec
     ( ParseErrorBundle(..)
     , PosState(..)
@@ -30,59 +40,87 @@ import Text.Megaparsec
     , unPos
     )
 
+-- | Executor context.
+data Resolution m = Resolution
+    { 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 [Aeson.Value] m
+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 (v :)
+addErr v = modify appender
+  where
+    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.
-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
 
--- | Appends the given list of errors to the current list of errors.
+-- | @GraphQL@ error.
-appendErrs :: Monad m => [Aeson.Value] -> CollectErrsT m ()
+data Error = Error
-appendErrs errs = modify (errs ++)
+    { 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.
-runCollectErrs :: Monad m => CollectErrsT m Aeson.Value -> m Aeson.Value
+runCollectErrs :: (Monad m, Serialize a)
-runCollectErrs res = do
+    => HashMap Name (Type m)
-    (dat, errs) <- runStateT res []
+    -> CollectErrsT m a
-    if null errs
+    -> m (Response a)
-       then return $ Aeson.object [("data", dat)]
+runCollectErrs types' res = do
-       else return $ Aeson.object [("data", dat), ("errors", Aeson.toJSON $ reverse errs)]
+    (dat, Resolution{..}) <- runStateT res
-
+        $ Resolution{ errors = Seq.empty, types = types' }
--- | Runs the given computation, collecting the errors and appending them
+    pure $ Response dat errors
---   to the previous list of errors.
-runAppendErrs :: Monad m => CollectErrsT m a -> CollectErrsT m a
-runAppendErrs f = do
-    (v, errs) <- lift $ runStateT f []
-    appendErrs errs
-    return v

src/Language/GraphQL/Execute.hs

@@ -3,37 +3,22 @@
 -- | 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.List.NonEmpty (NonEmpty(..))
-import qualified Data.List.NonEmpty as NonEmpty
 import Data.HashMap.Strict (HashMap)
-import qualified Data.HashMap.Strict as HashMap
+import Data.Sequence (Seq(..))
 import Data.Text (Text)
-import qualified Data.Text as Text
+import Language.GraphQL.AST.Document (Document, Name)
-import Language.GraphQL.AST.Document
+import Language.GraphQL.Execute.Coerce
-import qualified Language.GraphQL.AST.Core as AST.Core
+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.Schema as Schema
+import qualified Language.GraphQL.Type.Definition as Definition
-
+import qualified Language.GraphQL.Type.Out as Out
--- | The substitution is applied to the document, and the resolvers are applied
+import Language.GraphQL.Type.Schema
--- 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
-    => HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers.
-    -> Schema.Subs -- ^ Variable substitution function.
-    -> Document -- @GraphQL@ document.
-    -> m Aeson.Value
-execute schema subs doc =
-    maybe transformError (document schema Nothing)
-        $ Transform.document subs doc
-  where
-    transformError = return $ singleError "Schema transformation error."
 
 -- | 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
@@ -41,46 +26,38 @@ execute schema subs doc =
 --
 -- Returns the result of the query against the schema wrapped in a /data/
 -- field, or errors wrapped in an /errors/ field.
-executeWithName :: Monad m
+execute :: (MonadCatch m, VariableValue a, Serialize b)
-    => HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers
+    => Schema m -- ^ Resolvers.
-    -> Text -- ^ Operation name.
+    -> Maybe Text -- ^ Operation name.
-    -> Schema.Subs -- ^ 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 name subs doc =
+execute schema operationName subs document =
-    maybe transformError (document schema $ Just name)
+    case Transform.document schema operationName subs document of
-        $ Transform.document subs doc
+        Left queryError -> pure
-  where
+            $ Right
-    transformError = return $ singleError "Schema transformation error."
+            $ singleError
+            $ Transform.queryError queryError
+        Right transformed -> executeRequest transformed
 
-document :: Monad m
+executeRequest :: (MonadCatch m, Serialize a)
-    => HashMap Text (NonEmpty (Schema.Resolver m))
+    => Transform.Document m
-    -> Maybe Text
+    -> m (Either (ResponseEventStream m a) (Response a))
-    -> AST.Core.Document
+executeRequest (Transform.Document types' rootObjectType operation)
-    -> m Aeson.Value
+    | (Transform.Query _ fields) <- operation =
-document schema Nothing (op :| []) = operation schema op
+        Right <$> executeOperation types' rootObjectType fields
-document schema (Just name) operations = case NonEmpty.dropWhile matchingName operations of
+    | (Transform.Mutation _ fields) <- operation =
-    [] -> return $ singleError
+        Right <$> executeOperation types' rootObjectType fields
-        $ Text.unwords ["Operation", name, "couldn't be found in the document."]
+    | (Transform.Subscription _ fields) <- operation
-    (op:_)  -> operation schema op
+        = either (Right . singleError) Left
-  where
+        <$> Subscribe.subscribe types' rootObjectType fields
-    matchingName (AST.Core.Query (Just name') _) = name == name'
-    matchingName (AST.Core.Mutation (Just name') _) = name == name'
-    matchingName _ = False
-document _ _ _ = return $ singleError "Missing operation name."
 
-operation :: Monad m
+-- This is actually executeMutation, but we don't distinguish between queries
-    => HashMap Text (NonEmpty (Schema.Resolver m))
+-- and mutations yet.
-    -> AST.Core.Operation
+executeOperation :: (MonadCatch m, Serialize a)
-    -> m Aeson.Value
+    => HashMap Name (Type m)
-operation schema = schemaOperation
+    -> Out.ObjectType m
-  where
+    -> Seq (Transform.Selection m)
-    runResolver fields = runCollectErrs
+    -> m (Response a)
-        . flip Schema.resolve fields
+executeOperation types' objectType fields =
-        . Schema.resolversToMap
+    runCollectErrs types' $ executeSelectionSet Definition.Null objectType fields
-    resolve fields queryType = maybe lookupError (runResolver fields)
-        $ HashMap.lookup queryType schema
-    lookupError = pure
-        $ singleError "Root operation type couldn't be found in the schema."
-    schemaOperation (AST.Core.Query _ fields) = resolve fields "Query"
-    schemaOperation (AST.Core.Mutation _ fields) = resolve fields "Mutation"

src/Language/GraphQL/Execute/Coerce.hs

@@ -0,0 +1,230 @@
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ViewPatterns #-}
+
+-- | Types and functions used for input and result coercion.
+module Language.GraphQL.Execute.Coerce
+    ( Output(..)
+    , Serialize(..)
+    , VariableValue(..)
+    , coerceInputLiteral
+    , matchFieldValues
+    ) where
+
+import qualified Data.Aeson as Aeson
+import Data.Int (Int32)
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
+import Data.Map.Strict (Map)
+import Data.String (IsString(..))
+import Data.Text (Text)
+import qualified Data.Text.Lazy as Text.Lazy
+import qualified Data.Text.Lazy.Builder as Text.Builder
+import qualified Data.Text.Lazy.Builder.Int as Text.Builder
+import Data.Scientific (toBoundedInteger, toRealFloat)
+import Language.GraphQL.AST (Name)
+import qualified Language.GraphQL.Type as Type
+import qualified Language.GraphQL.Type.In as In
+import qualified Language.GraphQL.Type.Out as Out
+
+-- | Since variables are passed separately from the query, in an independent
+-- format, they should be first coerced to the internal representation used by
+-- this implementation.
+class VariableValue a where
+    -- | Only a basic, format-specific, coercion must be done here. Type
+    -- correctness or nullability shouldn't be validated here, they will be
+    -- validated later. The type information is provided only as a hint.
+    --
+    -- For example @GraphQL@ prohibits the coercion from a 't:Float' to an
+    -- 't:Int', but @JSON@ doesn't have integers, so whole numbers should be
+    -- coerced to 't:Int` when receiving variables as a JSON object. The same
+    -- holds for 't:Enum'. There are formats that support enumerations, @JSON@
+    -- doesn't, so the type information is given and 'coerceVariableValue' can
+    -- check that an 't:Enum' is expected and treat the given value
+    -- appropriately. Even checking whether this value is a proper member of the
+    -- corresponding 't:Enum' type isn't required here, since this can be
+    -- checked independently.
+    --
+    -- Another example is an @ID@. @GraphQL@ explicitly allows to coerce
+    -- integers and strings to @ID@s, so if an @ID@ is received as an integer,
+    -- it can be left as is and will be coerced later.
+    --
+    -- If a value cannot be coerced without losing information, 'Nothing' should
+    -- be returned, the coercion will fail then and the query won't be executed.
+    coerceVariableValue
+        :: In.Type -- ^ Expected type (variable type given in the query).
+        -> a -- ^ Variable value being coerced.
+        -> Maybe Type.Value -- ^ Coerced value on success, 'Nothing' otherwise.
+
+instance VariableValue Aeson.Value where
+    coerceVariableValue _ Aeson.Null = Just Type.Null
+    coerceVariableValue (In.ScalarBaseType scalarType) value
+        | (Aeson.String stringValue) <- value = Just $ Type.String stringValue
+        | (Aeson.Bool booleanValue) <- value = Just $ Type.Boolean booleanValue
+        | (Aeson.Number numberValue) <- value
+        , (Type.ScalarType "Float" _) <- scalarType =
+            Just $ Type.Float $ toRealFloat numberValue
+        | (Aeson.Number numberValue) <- value = -- ID or Int
+            Type.Int <$> toBoundedInteger numberValue
+    coerceVariableValue (In.EnumBaseType _) (Aeson.String stringValue) =
+        Just $ Type.Enum stringValue
+    coerceVariableValue (In.InputObjectBaseType objectType) value
+        | (Aeson.Object objectValue) <- value = do
+            let (In.InputObjectType _ _ inputFields) = objectType
+            (newObjectValue, resultMap) <- foldWithKey objectValue inputFields
+            if HashMap.null newObjectValue
+                then Just $ Type.Object resultMap
+                else Nothing
+      where
+        foldWithKey objectValue = HashMap.foldrWithKey matchFieldValues'
+            $ Just (objectValue, HashMap.empty)
+        matchFieldValues' _ _ Nothing = Nothing
+        matchFieldValues' fieldName inputField (Just (objectValue, resultMap)) =
+            let (In.InputField _ fieldType _) = inputField
+                insert = flip (HashMap.insert fieldName) resultMap
+                newObjectValue = HashMap.delete fieldName objectValue
+             in case HashMap.lookup fieldName objectValue of
+                    Just variableValue -> do
+                        coerced <- coerceVariableValue fieldType variableValue
+                        pure (newObjectValue, insert coerced)
+                    Nothing -> Just (objectValue, resultMap)
+    coerceVariableValue (In.ListBaseType listType) value
+        | (Aeson.Array arrayValue) <- value =
+            Type.List <$> foldr foldVector (Just []) arrayValue
+        | otherwise = coerceVariableValue listType value
+      where
+        foldVector _ Nothing = Nothing
+        foldVector variableValue (Just list) = do
+            coerced <- coerceVariableValue listType variableValue
+            pure $ coerced : list 
+    coerceVariableValue _ _ = Nothing
+
+-- | Looks up a value by name in the given map, coerces it and inserts into the
+-- result map. If the coercion fails, returns 'Nothing'. If the value isn't
+-- given, but a default value is known, inserts the default value into the
+-- result map. Otherwise it fails with 'Nothing' if the Input Type is a
+-- Non-Nullable type, or returns the unchanged, original map.
+matchFieldValues :: forall a
+    . (In.Type -> a -> Maybe Type.Value)
+    -> HashMap Name a
+    -> Name
+    -> In.Type
+    -> Maybe Type.Value
+    -> Maybe (HashMap Name Type.Value)
+    -> Maybe (HashMap Name Type.Value)
+matchFieldValues coerce values' fieldName type' defaultValue resultMap =
+    case HashMap.lookup fieldName values' of
+        Just variableValue -> coerceRuntimeValue $ coerce type' variableValue
+        Nothing
+            | Just value <- defaultValue ->
+                HashMap.insert fieldName value <$> resultMap
+            | Nothing <- defaultValue
+            , In.isNonNullType type' -> Nothing
+            | otherwise -> resultMap
+  where
+    coerceRuntimeValue (Just Type.Null)
+        | In.isNonNullType type' = Nothing
+    coerceRuntimeValue coercedValue =
+        HashMap.insert fieldName <$> coercedValue <*> resultMap
+
+-- | Coerces operation arguments according to the input coercion rules for the
+-- corresponding types.
+coerceInputLiteral :: In.Type -> Type.Value -> Maybe Type.Value
+coerceInputLiteral (In.isNonNullType -> False) Type.Null = Just Type.Null
+coerceInputLiteral (In.ScalarBaseType type') value
+    | (Type.String stringValue) <- value
+    , (Type.ScalarType "String" _) <- type' = Just $ Type.String stringValue
+    | (Type.Boolean booleanValue) <- value
+    , (Type.ScalarType "Boolean" _) <- type' = Just $ Type.Boolean booleanValue
+    | (Type.Int intValue) <- value
+    , (Type.ScalarType "Int" _) <- type' = Just $ Type.Int intValue
+    | (Type.Float floatValue) <- value
+    , (Type.ScalarType "Float" _) <- type' = Just $ Type.Float floatValue
+    | (Type.Int intValue) <- value
+    , (Type.ScalarType "Float" _) <- type' =
+        Just $ Type.Float $ fromIntegral intValue
+    | (Type.String stringValue) <- value
+    , (Type.ScalarType "ID" _) <- type' = Just $ Type.String stringValue
+    | (Type.Int intValue) <- value
+    , (Type.ScalarType "ID" _) <- type' = Just $ decimal intValue
+  where
+    decimal = Type.String
+        . Text.Lazy.toStrict
+        . Text.Builder.toLazyText
+        . Text.Builder.decimal
+coerceInputLiteral (In.EnumBaseType type') (Type.Enum enumValue)
+    | member enumValue type' = Just $ Type.Enum enumValue
+  where
+    member value (Type.EnumType _ _ members) = HashMap.member value members
+coerceInputLiteral (In.InputObjectBaseType type') (Type.Object values) = 
+    let (In.InputObjectType _ _ inputFields) = type'
+     in Type.Object
+            <$> HashMap.foldrWithKey (matchFieldValues' values) (Just HashMap.empty) inputFields
+  where
+    matchFieldValues' values' fieldName (In.InputField _ inputFieldType defaultValue) =
+        matchFieldValues coerceInputLiteral values' fieldName inputFieldType defaultValue
+coerceInputLiteral (In.ListBaseType listType) (Type.List list) =
+    Type.List <$> traverse (coerceInputLiteral listType) list
+coerceInputLiteral (In.ListBaseType listType) singleton =
+    wrapSingleton listType singleton
+  where
+      wrapSingleton (In.ListBaseType listType') singleton' =
+          Type.List <$> sequence [wrapSingleton listType' singleton']
+      wrapSingleton listType' singleton' =
+          Type.List <$> sequence [coerceInputLiteral listType' singleton']
+coerceInputLiteral _ _ = Nothing
+
+-- | 'Serialize' describes how a @GraphQL@ value should be serialized.
+class Serialize a where
+    -- | Serializes a @GraphQL@ value according to the given serialization
+    -- format.
+    --
+    -- Type infomration is given as a hint, e.g. if you need to know what type
+    -- is being serialized to serialize it properly. Don't do any validation for
+    -- @GraphQL@ built-in types here.
+    --
+    -- If the value cannot be serialized without losing information, return
+    -- 'Nothing' — it will cause a field error.
+    serialize :: forall m
+        . Out.Type m -- ^ Expected output type.
+        -> Output a -- ^ The value to be serialized.
+        -> Maybe a -- ^ Serialized value on success or 'Nothing'.
+    -- | __null__ representation in the given serialization format.
+    null :: a
+
+-- | Intermediate type used to serialize a @GraphQL@ value.
+--
+-- The serialization is done during the execution, and 'Output' contains
+-- already serialized data (in 'List' and 'Object') as well as the new layer
+-- that has to be serialized in the current step. So 'Output' is parameterized
+-- by the serialization format.
+data Output a
+    = Int Int32
+    | Float Double
+    | String Text
+    | Boolean Bool
+    | Enum Name
+    | List [a]
+    | Object (Map Name a)
+    deriving (Eq, Show)
+
+instance forall a. IsString (Output a) where
+    fromString = String . fromString
+
+instance Serialize Aeson.Value where
+    serialize (Out.ScalarBaseType scalarType) value
+        | Type.ScalarType "Int" _ <- scalarType
+        , Int int <- value = Just $ Aeson.toJSON int
+        | Type.ScalarType "Float" _ <- scalarType
+        , Float float <- value = Just $ Aeson.toJSON float
+        | Type.ScalarType "String" _ <- scalarType
+        , String string <- value = Just $ Aeson.String string
+        | Type.ScalarType "ID" _ <- scalarType
+        , String string <- value = Just $ Aeson.String string
+        | Type.ScalarType "Boolean" _ <- scalarType
+        , Boolean boolean <- value = Just $ Aeson.Bool boolean
+    serialize _ (Enum enum) = Just $ Aeson.String enum
+    serialize _ (List list) = Just $ Aeson.toJSON list
+    serialize _ (Object object) = Just $ Aeson.toJSON object
+    serialize _ _ = Nothing
+    null = Aeson.Null

src/Language/GraphQL/Execute/Execution.hs

@@ -0,0 +1,241 @@
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module Language.GraphQL.Execute.Execution
+    ( coerceArgumentValues
+    , collectFields
+    , executeSelectionSet
+    ) where
+
+import Control.Monad.Catch (Exception(..), MonadCatch(..))
+import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.Reader (runReaderT)
+import Control.Monad.Trans.State (gets)
+import Data.List.NonEmpty (NonEmpty(..))
+import Data.Map.Strict (Map)
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
+import qualified Data.Map.Strict as Map
+import Data.Maybe (fromMaybe)
+import Data.Sequence (Seq(..))
+import qualified Data.Text as Text
+import Language.GraphQL.AST (Name)
+import Language.GraphQL.Error
+import Language.GraphQL.Execute.Coerce
+import qualified Language.GraphQL.Execute.Transform as Transform
+import qualified Language.GraphQL.Type as Type
+import qualified Language.GraphQL.Type.In as In
+import qualified Language.GraphQL.Type.Out as Out
+import Language.GraphQL.Type.Internal
+import Language.GraphQL.Type.Schema
+import Prelude hiding (null)
+
+resolveFieldValue :: MonadCatch m
+    => Type.Value
+    -> Type.Subs
+    -> Type.Resolve m
+    -> CollectErrsT m Type.Value
+resolveFieldValue result args resolver =
+    catch (lift $ runReaderT resolver context) handleFieldError
+  where
+    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
+    -> Seq (Transform.Selection m)
+    -> Map Name (NonEmpty (Transform.Field m))
+collectFields objectType = foldl forEach Map.empty
+  where
+    forEach groupedFields (Transform.SelectionField field) =
+        let responseKey = aliasOrName field
+         in Map.insertWith (<>) responseKey (field :| []) groupedFields
+    forEach groupedFields (Transform.SelectionFragment selectionFragment)
+        | Transform.Fragment fragmentType fragmentSelectionSet <- selectionFragment
+        , doesFragmentTypeApply fragmentType objectType =
+            let fragmentGroupedFieldSet = collectFields objectType fragmentSelectionSet
+             in Map.unionWith (<>) groupedFields fragmentGroupedFieldSet
+        | otherwise = groupedFields
+
+aliasOrName :: forall m. Transform.Field m -> Name
+aliasOrName (Transform.Field alias name _ _) = fromMaybe name alias
+
+resolveAbstractType :: Monad m
+    => AbstractType m
+    -> Type.Subs
+    -> CollectErrsT m (Maybe (Out.ObjectType m))
+resolveAbstractType abstractType values'
+    | Just (Type.String typeName) <- HashMap.lookup "__typename" values' = do
+        types' <- gets types
+        case HashMap.lookup typeName types' of
+            Just (ObjectType objectType) ->
+                if instanceOf objectType abstractType
+                    then pure $ Just objectType
+                    else pure Nothing
+            _ -> pure Nothing
+    | otherwise = pure Nothing
+
+doesFragmentTypeApply :: forall m
+    . CompositeType m
+    -> Out.ObjectType m
+    -> Bool
+doesFragmentTypeApply (CompositeObjectType fragmentType) objectType =
+    fragmentType == objectType
+doesFragmentTypeApply (CompositeInterfaceType fragmentType) objectType =
+    instanceOf objectType $ AbstractInterfaceType fragmentType
+doesFragmentTypeApply (CompositeUnionType fragmentType) objectType =
+    instanceOf objectType $ AbstractUnionType fragmentType
+
+instanceOf :: forall m. Out.ObjectType m -> AbstractType m -> Bool
+instanceOf objectType (AbstractInterfaceType interfaceType) =
+    let Out.ObjectType _ _ interfaces _ = objectType
+     in foldr go False interfaces
+  where
+    go objectInterfaceType@(Out.InterfaceType _ _ interfaces _) acc =
+        acc || foldr go (interfaceType == objectInterfaceType) interfaces
+instanceOf objectType (AbstractUnionType unionType) =
+    let Out.UnionType _ _ members = unionType
+     in foldr go False members
+  where
+    go unionMemberType acc = acc || objectType == unionMemberType
+
+executeField :: (MonadCatch m, Serialize a)
+    => Out.Resolver m
+    -> Type.Value
+    -> NonEmpty (Transform.Field m)
+    -> CollectErrsT m a
+executeField fieldResolver prev fields
+    | Out.ValueResolver fieldDefinition resolver <- fieldResolver =
+        executeField' fieldDefinition resolver
+    | Out.EventStreamResolver fieldDefinition resolver _ <- fieldResolver =
+        executeField' fieldDefinition resolver
+  where
+    executeField' fieldDefinition resolver = do
+        let Out.Field _ fieldType argumentDefinitions = fieldDefinition
+        let (Transform.Field _ _ arguments' _ :| []) = fields
+        case coerceArgumentValues argumentDefinitions arguments' of
+            Nothing -> addErrMsg "Argument coercing failed."
+            Just argumentValues -> do
+                answer <- resolveFieldValue prev argumentValues resolver
+                completeValue fieldType fields answer
+
+completeValue :: (MonadCatch m, Serialize a)
+    => Out.Type m
+    -> NonEmpty (Transform.Field m)
+    -> Type.Value
+    -> CollectErrsT m a
+completeValue (Out.isNonNullType -> False) _ Type.Null = pure null
+completeValue outputType@(Out.ListBaseType listType) fields (Type.List list)
+    = traverse (completeValue listType fields) list
+    >>= coerceResult outputType . List
+completeValue outputType@(Out.ScalarBaseType _) _ (Type.Int int) =
+    coerceResult outputType $ Int int
+completeValue outputType@(Out.ScalarBaseType _) _ (Type.Boolean boolean) =
+    coerceResult outputType $ Boolean boolean
+completeValue outputType@(Out.ScalarBaseType _) _ (Type.Float float) =
+    coerceResult outputType $ Float float
+completeValue outputType@(Out.ScalarBaseType _) _ (Type.String string) =
+    coerceResult outputType $ String string
+completeValue outputType@(Out.EnumBaseType enumType) _ (Type.Enum enum) =
+    let Type.EnumType _ _ enumMembers = enumType
+     in if HashMap.member enum enumMembers
+        then coerceResult outputType $ Enum enum
+        else addErrMsg "Value completion failed."
+completeValue (Out.ObjectBaseType objectType) fields result =
+    executeSelectionSet result objectType $ mergeSelectionSets fields
+completeValue (Out.InterfaceBaseType interfaceType) fields result
+    | Type.Object objectMap <- result = do
+        let abstractType = AbstractInterfaceType interfaceType
+        concreteType <- resolveAbstractType abstractType objectMap
+        case concreteType of
+            Just objectType -> executeSelectionSet result objectType
+                $ mergeSelectionSets fields
+            Nothing -> addErrMsg "Value completion failed."
+completeValue (Out.UnionBaseType unionType) fields result
+    | Type.Object objectMap <- result = do
+        let abstractType = AbstractUnionType unionType
+        concreteType <- resolveAbstractType abstractType objectMap
+        case concreteType of
+            Just objectType -> executeSelectionSet result objectType
+                $ mergeSelectionSets fields
+            Nothing -> addErrMsg "Value completion failed."
+completeValue _ _ _ = addErrMsg "Value completion failed."
+
+mergeSelectionSets :: MonadCatch m
+    => NonEmpty (Transform.Field m)
+    -> Seq (Transform.Selection m)
+mergeSelectionSets = foldr forEach mempty
+  where
+    forEach (Transform.Field _ _ _ fieldSelectionSet) selectionSet =
+        selectionSet <> fieldSelectionSet
+
+coerceResult :: (MonadCatch m, Serialize a)
+    => Out.Type m
+    -> Output a
+    -> CollectErrsT m a
+coerceResult outputType result
+    | Just serialized <- serialize outputType result = pure serialized
+    | 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 :: (MonadCatch m, Serialize a)
+    => Type.Value
+    -> Out.ObjectType m
+    -> Seq (Transform.Selection m)
+    -> CollectErrsT m a
+executeSelectionSet result objectType@(Out.ObjectType _ _ _ resolvers) selectionSet = do
+    let fields = collectFields objectType selectionSet
+    resolvedValues <- Map.traverseMaybeWithKey forEach fields
+    coerceResult (Out.NonNullObjectType objectType) $ Object resolvedValues
+  where
+    forEach _ fields@(field :| _) =
+        let Transform.Field _ name _ _ = field
+         in traverse (tryResolver fields) $ lookupResolver name
+    lookupResolver = flip HashMap.lookup resolvers
+    tryResolver fields resolver =
+        executeField resolver result fields >>= lift . pure
+
+coerceArgumentValues
+    :: HashMap Name In.Argument
+    -> HashMap Name Transform.Input
+    -> Maybe Type.Subs
+coerceArgumentValues argumentDefinitions argumentValues =
+    HashMap.foldrWithKey forEach (pure mempty) argumentDefinitions
+  where
+    forEach variableName (In.Argument _ variableType defaultValue) =
+        matchFieldValues coerceArgumentValue argumentValues variableName variableType defaultValue
+    coerceArgumentValue inputType (Transform.Int integer) =
+        coerceInputLiteral inputType (Type.Int integer)
+    coerceArgumentValue inputType (Transform.Boolean boolean) =
+        coerceInputLiteral inputType (Type.Boolean boolean)
+    coerceArgumentValue inputType (Transform.String string) =
+        coerceInputLiteral inputType (Type.String string)
+    coerceArgumentValue inputType (Transform.Float float) =
+        coerceInputLiteral inputType (Type.Float float)
+    coerceArgumentValue inputType (Transform.Enum enum) =
+        coerceInputLiteral inputType (Type.Enum enum)
+    coerceArgumentValue inputType Transform.Null
+        | In.isNonNullType inputType = Nothing
+        | otherwise = coerceInputLiteral inputType Type.Null
+    coerceArgumentValue (In.ListBaseType inputType) (Transform.List list) =
+        let coerceItem = coerceInputLiteral inputType
+         in Type.List <$> traverse coerceItem list
+    coerceArgumentValue (In.InputObjectBaseType inputType) (Transform.Object object)
+        | In.InputObjectType _ _ inputFields <- inputType = 
+            let go = forEachField object
+                resultMap = HashMap.foldrWithKey go (pure mempty) inputFields
+             in Type.Object <$> resultMap
+    coerceArgumentValue _ (Transform.Variable variable) = pure variable
+    coerceArgumentValue _ _ = Nothing
+    forEachField object variableName (In.InputField _ variableType defaultValue) =
+        matchFieldValues coerceArgumentValue object variableName variableType defaultValue

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

@@ -1,125 +1,362 @@
 {-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TupleSections #-}
 
--- | After the document is parsed, before getting executed the AST is
+-- | After the document is parsed, before getting executed, the AST is
---   transformed into a similar, simpler AST. This module is responsible for
+-- transformed into a similar, simpler AST. Performed transformations include:
---   this transformation.
+--
+--   * Replacing variables with their values.
+--   * Inlining fragments. Some fragments can be completely eliminated and
+--   replaced by the selection set they represent. Invalid (recursive and
+--   non-existing) fragments are skipped. The most fragments are inlined, so the
+--   executor doesn't have to perform additional lookups later.
+--   * Evaluating directives (@\@include@ and @\@skip@).
+--
+-- This module is also responsible for smaller rewrites that touch only parts of
+-- the original AST.
 module Language.GraphQL.Execute.Transform
-    ( document
+    ( Document(..)
+    , Field(..)
+    , Fragment(..)
+    , Input(..)
+    , Operation(..)
+    , QueryError(..)
+    , Selection(..)
+    , document
+    , queryError
     ) where
 
-import Control.Arrow (first)
 import Control.Monad (foldM, unless)
 import Control.Monad.Trans.Class (lift)
-import Control.Monad.Trans.Reader (ReaderT, asks, runReaderT)
+import Control.Monad.Trans.State (State, evalStateT, gets, modify)
-import Control.Monad.Trans.State (StateT, evalStateT, gets, modify)
+import Data.Foldable (find)
+import Data.Functor.Identity (Identity(..))
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
+import Data.Int (Int32)
+import Data.Maybe (fromMaybe)
+import Data.List.NonEmpty (NonEmpty(..))
 import qualified Data.List.NonEmpty as NonEmpty
 import Data.Sequence (Seq, (<|), (><))
+import Data.Text (Text)
+import qualified Data.Text as Text
 import qualified Language.GraphQL.AST as Full
-import qualified Language.GraphQL.AST.Core as Core
+import Language.GraphQL.AST (Name)
-import Language.GraphQL.AST.Document (Definition(..), Document)
+import qualified Language.GraphQL.Execute.Coerce as Coerce
-import qualified Language.GraphQL.Schema as Schema
+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
 
--- | Associates a fragment name with a list of 'Core.Field's.
+-- | Associates a fragment name with a list of 'Field's.
-data Replacement = Replacement
+data Replacement m = Replacement
-    { fragments :: HashMap Core.Name Core.Fragment
+    { fragments :: HashMap Full.Name (Fragment m)
-    , fragmentDefinitions :: HashMap Full.Name Full.FragmentDefinition
+    , fragmentDefinitions :: FragmentDefinitions
+    , variableValues :: Type.Subs
+    , types :: HashMap Full.Name (Type m)
     }
 
-type TransformT a = StateT Replacement (ReaderT Schema.Subs Maybe) a
+type FragmentDefinitions = HashMap Full.Name Full.FragmentDefinition
 
-liftJust :: forall a. a -> TransformT a
+-- | Represents fragments and inline fragments.
-liftJust = lift . lift . Just
+data Fragment m
+    = Fragment (CompositeType m) (Seq (Selection m))
+
+-- | Single selection element.
+data Selection m
+    = SelectionFragment (Fragment m)
+    | SelectionField (Field m)
+
+-- | GraphQL has 3 operation types: queries, mutations and subscribtions.
+--
+-- Currently only queries and mutations are supported.
+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
+    (Maybe Full.Name) Full.Name (HashMap Full.Name Input) (Seq (Selection m))
+
+-- | Contains the operation to be executed along with its root type.
+data Document m = Document
+    (HashMap Full.Name (Type m)) (Out.ObjectType m) (Operation m)
+
+data OperationDefinition = OperationDefinition
+    Full.OperationType
+    (Maybe Full.Name)
+    [Full.VariableDefinition]
+    [Full.Directive]
+    Full.SelectionSet
+
+-- | Query error types.
+data QueryError
+    = OperationNotFound Text
+    | OperationNameRequired
+    | CoercionError
+    | TransformationError
+    | EmptyDocument
+    | UnsupportedRootOperation
+
+data Input
+    = Int Int32
+    | Float Double
+    | String Text
+    | Boolean Bool
+    | Null
+    | Enum Name
+    | List [Type.Value]
+    | Object (HashMap Name Input)
+    | Variable Type.Value
+    deriving (Eq, Show)
+
+queryError :: QueryError -> Text
+queryError (OperationNotFound operationName) = Text.unwords
+    ["Operation", operationName, "couldn't be found in the document."]
+queryError OperationNameRequired = "Missing operation name."
+queryError CoercionError = "Coercion error."
+queryError TransformationError = "Schema transformation error."
+queryError EmptyDocument =
+    "The document doesn't contain any executable operations."
+queryError UnsupportedRootOperation =
+    "Root operation type couldn't be found in the schema."
+
+getOperation
+    :: Maybe Full.Name
+    -> NonEmpty OperationDefinition
+    -> Either QueryError OperationDefinition
+getOperation Nothing (operation' :| []) = pure operation'
+getOperation Nothing _ = Left OperationNameRequired
+getOperation (Just operationName) operations
+    | Just operation' <- find matchingName operations = pure operation'
+    | otherwise = Left $ OperationNotFound operationName
+  where
+    matchingName (OperationDefinition _ name _ _ _) =
+        name == Just operationName
+
+lookupInputType
+    :: Full.Type
+    -> HashMap.HashMap Full.Name (Type m)
+    -> Maybe In.Type
+lookupInputType (Full.TypeNamed name) types =
+    case HashMap.lookup name types of
+        Just (ScalarType scalarType) ->
+            Just $ In.NamedScalarType scalarType
+        Just (EnumType enumType) ->
+            Just $ In.NamedEnumType enumType
+        Just (InputObjectType objectType) ->
+            Just $ In.NamedInputObjectType objectType
+        _ -> Nothing
+lookupInputType (Full.TypeList list) types
+    = In.ListType
+    <$> lookupInputType list types
+lookupInputType (Full.TypeNonNull (Full.NonNullTypeNamed nonNull)) types  =
+    case HashMap.lookup nonNull types of
+        Just (ScalarType scalarType) ->
+            Just $ In.NonNullScalarType scalarType
+        Just (EnumType enumType) ->
+            Just $ In.NonNullEnumType enumType
+        Just (InputObjectType objectType) ->
+            Just $ In.NonNullInputObjectType objectType
+        _ -> Nothing
+lookupInputType (Full.TypeNonNull (Full.NonNullTypeList nonNull)) types
+    = In.NonNullListType
+    <$> lookupInputType nonNull types
+
+coerceVariableValues :: Coerce.VariableValue a
+    => forall m
+    . HashMap Full.Name (Type m)
+    -> OperationDefinition
+    -> HashMap.HashMap Full.Name a
+    -> Either QueryError Type.Subs
+coerceVariableValues types operationDefinition variableValues =
+    let OperationDefinition _ _ variableDefinitions _ _ = operationDefinition
+     in maybe (Left CoercionError) Right
+        $ foldr forEach (Just HashMap.empty) variableDefinitions
+  where
+    forEach variableDefinition coercedValues = do
+        let Full.VariableDefinition variableName variableTypeName defaultValue =
+                variableDefinition
+        let defaultValue' = constValue <$> defaultValue
+        variableType <- lookupInputType variableTypeName types
+
+        Coerce.matchFieldValues
+            coerceVariableValue'
+            variableValues
+            variableName
+            variableType
+            defaultValue'
+            coercedValues
+    coerceVariableValue' variableType value'
+        = Coerce.coerceVariableValue variableType value'
+        >>= Coerce.coerceInputLiteral variableType
+
+constValue :: Full.ConstValue -> Type.Value
+constValue (Full.ConstInt i) = Type.Int i
+constValue (Full.ConstFloat f) = Type.Float f
+constValue (Full.ConstString x) = Type.String x
+constValue (Full.ConstBoolean b) = Type.Boolean b
+constValue Full.ConstNull = Type.Null
+constValue (Full.ConstEnum e) = Type.Enum e
+constValue (Full.ConstList l) = Type.List $ constValue <$> l
+constValue (Full.ConstObject o) =
+    Type.Object $ HashMap.fromList $ constObjectField <$> o
+  where
+    constObjectField (Full.ObjectField key value') = (key, constValue value')
 
 -- | Rewrites the original syntax tree into an intermediate representation used
 -- for query execution.
-document :: Schema.Subs -> Document -> Maybe Core.Document
+document :: Coerce.VariableValue a
-document subs document' =
+    => forall m
-    flip runReaderT subs
+    . Schema m
-        $ evalStateT (collectFragments >> operations operationDefinitions)
+    -> Maybe Full.Name
-        $ Replacement HashMap.empty fragmentTable
+    -> HashMap Full.Name a
+    -> Full.Document
+    -> Either QueryError (Document m)
+document schema operationName subs ast = do
+    let referencedTypes = collectReferencedTypes schema
+
+    (operations, fragmentTable) <- defragment ast
+    chosenOperation <- getOperation operationName operations
+    coercedValues <- coerceVariableValues referencedTypes chosenOperation subs
+
+    let replacement = Replacement
+            { fragments = HashMap.empty
+            , fragmentDefinitions = fragmentTable
+            , variableValues = coercedValues
+            , types = referencedTypes
+            }
+    case chosenOperation of
+        OperationDefinition Full.Query _ _ _ _ ->
+            pure $ Document referencedTypes (query schema)
+                $ operation chosenOperation replacement
+        OperationDefinition Full.Mutation _ _ _ _
+            | 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
+    :: Full.Document
+    -> Either QueryError (NonEmpty OperationDefinition, FragmentDefinitions)
+defragment ast =
+    let (operations, fragmentTable) = foldr defragment' ([], HashMap.empty) ast
+        nonEmptyOperations = NonEmpty.nonEmpty operations
+        emptyDocument = Left EmptyDocument
+     in (, fragmentTable) <$> maybe emptyDocument Right nonEmptyOperations
   where
-    (fragmentTable, operationDefinitions) = foldr defragment mempty document'
+    defragment' definition (operations, fragments')
-    defragment (ExecutableDefinition (Full.DefinitionOperation definition)) acc =
+        | (Full.ExecutableDefinition executable _) <- definition
-        (definition :) <$> acc
+        , (Full.DefinitionOperation operation') <- executable =
-    defragment (ExecutableDefinition (Full.DefinitionFragment definition)) acc =
+            (transform operation' : operations, fragments')
-        let (Full.FragmentDefinition name _ _ _) = definition
+        | (Full.ExecutableDefinition executable _) <- definition
-         in first (HashMap.insert name definition) acc
+        , (Full.DefinitionFragment fragment) <- executable
-    defragment _ acc = acc
+        , (Full.FragmentDefinition name _ _ _) <- fragment =
+            (operations, HashMap.insert name fragment fragments')
+    defragment' _ acc = acc
+    transform = \case
+        Full.OperationDefinition type' name variables directives' selections ->
+            OperationDefinition type' name variables directives' selections
+        Full.SelectionSet selectionSet ->
+            OperationDefinition Full.Query Nothing mempty mempty selectionSet
 
 -- * Operation
 
-operations :: [Full.OperationDefinition] -> TransformT Core.Document
+operation :: OperationDefinition -> Replacement m -> Operation m
-operations operations' = do
+operation operationDefinition replacement
-    coreOperations <- traverse operation operations'
+    = runIdentity
-    lift . lift $ NonEmpty.nonEmpty coreOperations
+    $ evalStateT (collectFragments >> transform operationDefinition) replacement
-
+  where
-operation :: Full.OperationDefinition -> TransformT Core.Operation
+    transform (OperationDefinition Full.Query name _ _ sels) =
-operation (Full.SelectionSet sels)
+        Query name <$> appendSelection sels
-    = operation $ Full.OperationDefinition Full.Query mempty mempty mempty sels
+    transform (OperationDefinition Full.Mutation name _ _ sels) =
-operation (Full.OperationDefinition Full.Query name _vars _dirs sels)
+        Mutation name <$> appendSelection sels
-    = Core.Query name <$> appendSelection sels
+    transform (OperationDefinition Full.Subscription name _ _ sels) =
-operation (Full.OperationDefinition Full.Mutation name _vars _dirs sels)
+        Subscription name <$> appendSelection sels
-    = Core.Mutation name <$> appendSelection sels
 
 -- * Selection
 
-selection ::
+selection
-    Full.Selection ->
+    :: Full.Selection
-    TransformT (Either (Seq Core.Selection) Core.Selection)
+    ->  State (Replacement m) (Either (Seq (Selection m)) (Selection m))
 selection (Full.Field alias name arguments' directives' selections) =
-    maybe (Left mempty) (Right . Core.SelectionField) <$> do
+    maybe (Left mempty) (Right . SelectionField) <$> do
-        fieldArguments <- arguments arguments'
+        fieldArguments <- foldM go HashMap.empty arguments'
         fieldSelections <- appendSelection selections
-        fieldDirectives <- Directive.selection <$> directives directives'
+        fieldDirectives <- Definition.selection <$> directives directives'
-        let field' = Core.Field alias name fieldArguments fieldSelections
+        let field' = Field alias name fieldArguments fieldSelections
         pure $ field' <$ fieldDirectives
-selection (Full.FragmentSpread name directives') =
-    maybe (Left mempty) (Right . Core.SelectionFragment) <$> do
-        spreadDirectives <- Directive.selection <$> directives directives'
-        fragments' <- gets fragments
-        fragment <- maybe lookupDefinition liftJust (HashMap.lookup name fragments')
-        pure $ fragment <$ spreadDirectives
   where
-    lookupDefinition = do
+    go arguments (Full.Argument name' value') =
+        inputField arguments name' value'
+
+selection (Full.FragmentSpread name directives') =
+    maybe (Left mempty) (Right . SelectionFragment) <$> do
+        spreadDirectives <- Definition.selection <$> directives directives'
+        fragments' <- gets fragments
+
         fragmentDefinitions' <- gets fragmentDefinitions
-        found <- lift . lift $ HashMap.lookup name fragmentDefinitions'
+        case HashMap.lookup name fragments' of
-        fragmentDefinition found
+            Just definition -> lift $ pure $ definition <$ spreadDirectives
+            Nothing
+                | Just definition <- HashMap.lookup name fragmentDefinitions' -> do
+                    fragDef <- fragmentDefinition definition
+                    case fragDef of
+                        Just fragment -> lift $ pure $ fragment <$ spreadDirectives
+                        _ -> lift $ pure  Nothing
+                | otherwise -> lift $ pure  Nothing
 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
             fragmentSelectionSet <- appendSelection selections
-            pure $ maybe Left selectionFragment type' fragmentSelectionSet
+
+            case type' of
+                Nothing -> pure $ Left fragmentSelectionSet
+                Just typeName -> do
+                    typeCondition' <- lookupTypeCondition typeName
+                    case typeCondition' of
+                        Just typeCondition -> pure $
+                            selectionFragment typeCondition fragmentSelectionSet
+                        Nothing -> pure $ Left mempty
   where
     selectionFragment typeName = Right
-        . Core.SelectionFragment
+        . SelectionFragment
-        . Core.Fragment typeName
+        . Fragment typeName
 
-appendSelection ::
+appendSelection :: Traversable t
-    Traversable t =>
+    => t Full.Selection
-    t Full.Selection ->
+    ->  State (Replacement m) (Seq (Selection m))
-    TransformT (Seq Core.Selection)
 appendSelection = foldM go mempty
   where
     go acc sel = append acc <$> selection sel
     append acc (Left list) = list >< acc
     append acc (Right one) = one <| acc
 
-directives :: [Full.Directive] -> TransformT [Core.Directive]
+directives :: [Full.Directive] ->  State (Replacement m) [Definition.Directive]
 directives = traverse directive
   where
-    directive (Full.Directive directiveName directiveArguments) =
+    directive (Full.Directive directiveName directiveArguments)
-        Core.Directive directiveName <$> arguments directiveArguments
+        = Definition.Directive directiveName . Type.Arguments
+        <$> foldM go HashMap.empty directiveArguments
+    go arguments (Full.Argument name value') = do
+        substitutedValue <- value value'
+        return $ HashMap.insert name substitutedValue arguments
 
 -- * Fragment replacement
 
 -- | Extract fragment definitions into a single 'HashMap'.
-collectFragments :: TransformT ()
+collectFragments ::  State (Replacement m) ()
 collectFragments = do
     fragDefs <- gets fragmentDefinitions
     let nextValue = head $ HashMap.elems fragDefs
@@ -127,41 +364,79 @@ collectFragments = do
         _ <- fragmentDefinition nextValue
         collectFragments
 
-fragmentDefinition ::
+lookupTypeCondition :: Full.Name -> State (Replacement m) (Maybe (CompositeType m))
-    Full.FragmentDefinition ->
+lookupTypeCondition type' = do
-    TransformT Core.Fragment
+    types' <- gets types
+    case HashMap.lookup type' types' of
+        Just (ObjectType objectType) ->
+            lift $ pure $ Just $ CompositeObjectType objectType
+        Just (UnionType unionType) ->
+            lift $ pure $ Just $ CompositeUnionType unionType
+        Just (InterfaceType interfaceType) ->
+            lift $ pure $ Just $ CompositeInterfaceType interfaceType
+        _ -> lift $ pure Nothing
+
+fragmentDefinition
+    :: Full.FragmentDefinition
+    ->  State (Replacement m) (Maybe (Fragment m))
 fragmentDefinition (Full.FragmentDefinition name type' _ selections) = do
     modify deleteFragmentDefinition
     fragmentSelection <- appendSelection selections
-    let newValue = Core.Fragment type' fragmentSelection
+    compositeType <- lookupTypeCondition type'
+
+    case compositeType of
+        Just compositeType' -> do
+            let newValue = Fragment compositeType' fragmentSelection
             modify $ insertFragment newValue
-    liftJust newValue
+            lift $ pure $ Just newValue
+        _ -> lift $ pure Nothing
   where
-    deleteFragmentDefinition (Replacement fragments' fragmentDefinitions') =
+    deleteFragmentDefinition replacement@Replacement{..} =
-        Replacement fragments' $ HashMap.delete name fragmentDefinitions'
+        let newDefinitions = HashMap.delete name fragmentDefinitions
-    insertFragment newValue (Replacement fragments' fragmentDefinitions') =
+         in replacement{ fragmentDefinitions = newDefinitions }
-        let newFragments = HashMap.insert name newValue fragments'
+    insertFragment newValue replacement@Replacement{..} =
-         in Replacement newFragments fragmentDefinitions'
+        let newFragments = HashMap.insert name newValue fragments
+         in replacement{ fragments = newFragments }
 
-arguments :: [Full.Argument] -> TransformT Core.Arguments
+value :: forall m. Full.Value -> State (Replacement m) Type.Value
-arguments = fmap Core.Arguments . foldM go HashMap.empty
+value (Full.Variable name) =
+    gets (fromMaybe Type.Null . HashMap.lookup name . variableValues)
+value (Full.Int int) = pure $ Type.Int int
+value (Full.Float float) = pure $ Type.Float float
+value (Full.String string) = pure $ Type.String string
+value (Full.Boolean boolean) = pure $ Type.Boolean boolean
+value Full.Null = pure Type.Null
+value (Full.Enum enum) = pure $ Type.Enum enum
+value (Full.List list) = Type.List <$> traverse value list
+value (Full.Object object) =
+    Type.Object . HashMap.fromList <$> traverse objectField object
   where
-    go arguments' (Full.Argument name value') = do
-        substitutedValue <- value value'
-        return $ HashMap.insert name substitutedValue arguments'
-
-value :: Full.Value -> TransformT Core.Value
-value (Full.Variable name) = lift (asks $ HashMap.lookup name) >>= lift . lift
-value (Full.Int i) = pure $ Core.Int i
-value (Full.Float f) = pure $ Core.Float f
-value (Full.String x) = pure $ Core.String x
-value (Full.Boolean b) = pure $ Core.Boolean b
-value Full.Null = pure   Core.Null
-value (Full.Enum e) = pure $ Core.Enum e
-value (Full.List l) =
-    Core.List <$> traverse value l
-value (Full.Object o) =
-    Core.Object . HashMap.fromList <$> traverse objectField o
-
-objectField :: Full.ObjectField -> TransformT (Core.Name, Core.Value)
     objectField (Full.ObjectField name value') = (name,) <$> value value'
+
+input :: forall m. Full.Value -> State (Replacement m) (Maybe Input)
+input (Full.Variable name) =
+    gets (fmap Variable . HashMap.lookup name . variableValues)
+input (Full.Int int) = pure $ pure $ Int int
+input (Full.Float float) = pure $ pure $ Float float
+input (Full.String string) = pure $ pure $ String string
+input (Full.Boolean boolean) = pure $ pure $ Boolean boolean
+input Full.Null = pure $ pure Null
+input (Full.Enum enum) = pure $ pure $ Enum enum
+input (Full.List list) = pure . List <$> traverse value list
+input (Full.Object object) = do
+    objectFields <- foldM objectField HashMap.empty object
+    pure $ pure $ Object objectFields
+  where
+    objectField resultMap (Full.ObjectField name value') =
+        inputField resultMap name value'
+
+inputField :: forall m
+    . HashMap Full.Name Input
+    -> Full.Name
+    -> Full.Value
+    -> State (Replacement m) (HashMap Full.Name Input)
+inputField resultMap name value' = do
+    objectFieldValue <-  input value'
+    case objectFieldValue of
+        Just fieldValue -> pure $ HashMap.insert name fieldValue resultMap
+        Nothing -> pure resultMap

src/Language/GraphQL/Schema.hs

@@ -1,138 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
--- | This module provides a representation of a @GraphQL@ Schema in addition to
--- functions for defining and manipulating schemas.
-module Language.GraphQL.Schema
-    ( Resolver(..)
-    , Subs
-    , object
-    , resolve
-    , resolversToMap
-    , scalar
-    , wrappedObject
-    , wrappedScalar
-    -- * AST Reexports
-    , Field
-    , Value(..)
-    ) where
-
-import Control.Monad.Trans.Class (lift)
-import Control.Monad.Trans.Except (runExceptT)
-import Control.Monad.Trans.Reader (runReaderT)
-import Data.Foldable (fold, toList)
-import Data.Maybe (fromMaybe)
-import qualified Data.Aeson as Aeson
-import Data.HashMap.Strict (HashMap)
-import qualified Data.HashMap.Strict as HashMap
-import Data.Sequence (Seq)
-import Data.Text (Text)
-import qualified Data.Text as T
-import Language.GraphQL.AST.Core
-import Language.GraphQL.Error
-import Language.GraphQL.Trans
-import qualified Language.GraphQL.Type as Type
-
--- | 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'.
-data Resolver m = Resolver
-    Text -- ^ Name
-    (Field -> CollectErrsT m Aeson.Object) -- ^ Resolver
-
--- | Converts resolvers to a map.
-resolversToMap
-    :: (Foldable f, Functor f)
-    => f (Resolver m)
-    -> HashMap Text (Field -> CollectErrsT m Aeson.Object)
-resolversToMap = HashMap.fromList . toList . fmap toKV
-  where
-    toKV (Resolver name f) = (name, f)
-
--- | Contains variables for the query. The key of the map is a variable name,
---   and the value is the variable value.
-type Subs = HashMap Name Value
-
--- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's.
-object :: Monad m => Name -> ActionT m [Resolver m] -> Resolver m
-object name f = Resolver name $ resolveFieldValue f resolveRight
-  where
-    resolveRight fld@(Field _ _ _ flds) resolver
-        = withField (resolve (resolversToMap resolver) flds) fld
-
--- | Like 'object' but can be null or a list of objects.
-wrappedObject ::
-    Monad m =>
-    Name ->
-    ActionT m (Type.Wrapping [Resolver m]) ->
-    Resolver m
-wrappedObject name f = Resolver name $ resolveFieldValue f resolveRight
-  where
-    resolveRight fld@(Field _ _ _ sels) resolver
-        = withField (traverse (resolveMap sels) resolver) fld
-    resolveMap = flip (resolve . resolversToMap)
-
--- | A scalar represents a primitive value, like a string or an integer.
-scalar :: (Monad m, Aeson.ToJSON a) => Name -> ActionT m a -> Resolver m
-scalar name f = Resolver name $ resolveFieldValue f resolveRight
-  where
-    resolveRight fld result = withField (return result) fld
-
--- | Like 'scalar' but can be null or a list of scalars.
-wrappedScalar ::
-    (Monad m, Aeson.ToJSON a) =>
-    Name ->
-    ActionT m (Type.Wrapping a) ->
-    Resolver m
-wrappedScalar name f = Resolver name $ resolveFieldValue f resolveRight
-  where
-    resolveRight fld (Type.Named result) = withField (return result) fld
-    resolveRight fld Type.Null
-        = return $ HashMap.singleton (aliasOrName fld) Aeson.Null
-    resolveRight fld (Type.List result) = withField (return result) fld
-
-resolveFieldValue ::
-    Monad m =>
-    ActionT m a ->
-    (Field -> a -> CollectErrsT m Aeson.Object) ->
-    Field ->
-    CollectErrsT m (HashMap Text Aeson.Value)
-resolveFieldValue f resolveRight fld@(Field _ _ args _) = do
-    result <- lift $ reader . runExceptT . runActionT $ f
-    either resolveLeft (resolveRight fld) result
-      where
-        reader = flip runReaderT $ Context {arguments=args}
-        resolveLeft err = do
-            _ <- addErrMsg err
-            return $ HashMap.singleton (aliasOrName fld) Aeson.Null
-
--- | Helper function to facilitate error handling and result emitting.
-withField :: (Monad m, Aeson.ToJSON a)
-    => CollectErrsT m a -> Field -> CollectErrsT m (HashMap Text Aeson.Value)
-withField v fld
-    = HashMap.singleton (aliasOrName fld) . Aeson.toJSON <$> runAppendErrs v
-
--- | Takes a list of 'Resolver's and a list of 'Field's and applies each
---   'Resolver' to each 'Field'. Resolves into a value containing the
---   resolved 'Field', or a null value and error information.
-resolve :: Monad m
-    => HashMap Text (Field -> CollectErrsT m Aeson.Object)
-    -> Seq Selection
-    -> CollectErrsT m Aeson.Value
-resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers
-  where
-    resolveTypeName f = do
-        value <- f $ Field Nothing "__typename" mempty mempty
-        return $ HashMap.lookupDefault "" "__typename" value
-    tryResolvers (SelectionField fld@(Field _ name _ _))
-        = fromMaybe (errmsg fld) $ HashMap.lookup name resolvers <*> Just fld
-    tryResolvers (SelectionFragment (Fragment typeCondition selections')) = do
-        that <- traverse resolveTypeName $ HashMap.lookup "__typename" resolvers
-        if maybe True (Aeson.String typeCondition ==) that
-            then fmap fold . traverse tryResolvers $ selections'
-            else return mempty
-    errmsg fld@(Field _ name _ _) = do
-        addErrMsg $ T.unwords ["field", name, "not resolved."]
-        return $ HashMap.singleton (aliasOrName fld) Aeson.Null
-
-aliasOrName :: Field -> Text
-aliasOrName (Field alias name _ _) = fromMaybe name alias

src/Language/GraphQL/Trans.hs

@@ -1,64 +0,0 @@
--- | Monad transformer stack used by the @GraphQL@ resolvers.
-module Language.GraphQL.Trans
-    ( ActionT(..)
-    , Context(..)
-    , argument
-    ) 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.Core
-import Prelude hiding (lookup)
-
--- | Resolution context holds resolver arguments.
-newtype Context = Context
-    { arguments :: Arguments
-    }
-
--- | 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 'Value.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,55 +1,26 @@
--- | Definitions for @GraphQL@ input types.
+{- 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
-    ( Wrapping(..)
+    ( 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
 
-import Data.Aeson as Aeson (ToJSON, toJSON)
+import Language.GraphQL.Type.Definition
-import qualified Data.Aeson as Aeson
+import Language.GraphQL.Type.Schema (Schema(..))
-
+import qualified Language.GraphQL.Type.In as In
--- | GraphQL distinguishes between "wrapping" and "named" types. Each wrapping
+import qualified Language.GraphQL.Type.Out as Out
---   type can wrap other wrapping or named types. Wrapping types are lists and
---   Non-Null types (named types are nullable by default).
---
---   This 'Wrapping' type doesn\'t reflect this distinction exactly but it is
---   used in the resolvers to take into account that the returned value can be
---   nullable or an (arbitrary nested) list.
-data Wrapping a
-    = List [Wrapping a] -- ^ Arbitrary nested list
-    | Named a -- ^ Named type without further wrapping
-    | Null -- ^ Null
-    deriving (Eq, Show)
-
-instance Functor Wrapping where
-    fmap f (List list) = List $ fmap (fmap f) list
-    fmap f (Named named) = Named $ f named
-    fmap _ Null = Null
-
-instance Foldable Wrapping where
-    foldr f acc (List list) = foldr (flip $ foldr f) acc list
-    foldr f acc (Named named) = f named acc
-    foldr _ acc Null = acc
-
-instance Traversable Wrapping where
-    traverse f (List list) = List <$> traverse (traverse f) list
-    traverse f (Named named) = Named <$> f named
-    traverse _ Null = pure Null
-
-instance Applicative Wrapping where
-    pure = Named
-    Null <*> _ = Null
-    _ <*> Null = Null
-    (Named f) <*> (Named x) = Named $ f x
-    (List fs) <*> (List xs) = List $ (<*>) <$> fs <*> xs
-    (Named f) <*> list = f <$> list
-    (List fs) <*> named = List $ (<*> named) <$> fs
-
-instance Monad Wrapping where
-    return = pure
-    Null >>= _ = Null
-    (Named x) >>= f = f x
-    (List xs) >>= f = List $ fmap (>>= f) xs
-
-instance ToJSON a => ToJSON (Wrapping a) where
-    toJSON (List list) = toJSON list
-    toJSON (Named named) = toJSON named
-    toJSON Null = Aeson.Null

src/Language/GraphQL/Type/Definition.hs

@@ -0,0 +1,175 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Types that can be used as both input and output types.
+module Language.GraphQL.Type.Definition
+    ( Arguments(..)
+    , Directive(..)
+    , EnumType(..)
+    , EnumValue(..)
+    , ScalarType(..)
+    , Subs
+    , Value(..)
+    , boolean
+    , 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 (Name)
+import Prelude hiding (id)
+
+-- | Represents accordingly typed GraphQL values.
+data Value
+    = Int Int32
+    | Float Double -- ^ GraphQL Float is double precision.
+    | String Text
+    | Boolean Bool
+    | Null
+    | Enum Name
+    | List [Value] -- ^ Arbitrary nested list.
+    | Object (HashMap Name Value)
+    deriving (Eq, Show)
+
+instance IsString Value where
+    fromString = String . fromString
+
+-- | Contains variables for the query. The key of the map is a variable name,
+-- 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
+-- Enums) .
+data ScalarType = ScalarType Name (Maybe Text)
+
+instance Eq ScalarType where
+    (ScalarType this _) == (ScalarType that _) = this == that
+
+-- | Enum type definition.
+--
+-- Some leaf values of requests and input values are Enums. GraphQL serializes
+-- Enum values as strings, however internally Enums can be represented by any
+-- kind of type, often integers.
+data EnumType = EnumType Name (Maybe Text) (HashMap Name EnumValue)
+
+instance Eq EnumType where
+    (EnumType this _ _) == (EnumType that _ _) = this == that
+
+-- | Enum value is a single member of an 'EnumType'.
+newtype EnumValue = EnumValue (Maybe Text)
+
+-- | The @String@ scalar type represents textual data, represented as UTF-8
+-- character sequences. The String type is most often used by GraphQL to
+-- represent free-form human-readable text.
+string :: ScalarType
+string = ScalarType "String" (Just description)
+  where
+    description =
+        "The `String` scalar type represents textual data, represented as \
+        \UTF-8 character sequences. The String type is most often used by \
+        \GraphQL to represent free-form human-readable text."
+
+-- | The @Boolean@ scalar type represents @true@ or @false@.
+boolean :: ScalarType
+boolean = ScalarType "Boolean" (Just description)
+  where
+    description = "The `Boolean` scalar type represents `true` or `false`."
+
+-- | The @Int@ scalar type represents non-fractional signed whole numeric
+-- values. Int can represent values between \(-2^{31}\) and \(2^{31 - 1}\).
+int :: ScalarType
+int = ScalarType "Int" (Just description)
+  where
+    description =
+        "The `Int` scalar type represents non-fractional signed whole numeric \
+        \values. Int can represent values between -(2^31) and 2^31 - 1."
+
+-- | The @Float@ scalar type represents signed double-precision fractional
+-- values as specified by
+-- [IEEE 754](https://en.wikipedia.org/wiki/IEEE_floating_point).
+float :: ScalarType
+float = ScalarType "Float" (Just description)
+  where
+    description =
+        "The `Float` scalar type represents signed double-precision fractional \
+        \values as specified by \
+        \[IEEE 754](https://en.wikipedia.org/wiki/IEEE_floating_point)."
+
+-- | The @ID@ scalar type represents a unique identifier, often used to refetch
+-- an object or as key for a cache. The ID type appears in a 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.
+id :: ScalarType
+id = ScalarType "ID" (Just description)
+  where
+    description =
+        "The `ID` scalar type represents a unique identifier, often used to \
+        \refetch an object or as key for a cache. The ID type appears in a \
+        \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,50 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Language.GraphQL.Type.Directive
-    ( selection
-    ) where
-
-import qualified Data.HashMap.Strict as HashMap
-import Language.GraphQL.AST.Core
-
--- | 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/In.hs

@@ -0,0 +1,101 @@
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ViewPatterns #-}
+
+-- | Input types and values.
+--
+-- This module is intended to be imported qualified, to avoid name clashes
+-- with 'Language.GraphQL.Type.Out'.
+module Language.GraphQL.Type.In
+    ( Argument(..)
+    , InputField(..)
+    , InputObjectType(..)
+    , Type(..)
+    , isNonNullType
+    , pattern EnumBaseType
+    , pattern ListBaseType
+    , pattern InputObjectBaseType
+    , pattern ScalarBaseType
+    ) where
+
+import Data.HashMap.Strict (HashMap)
+import Data.Text (Text)
+import Language.GraphQL.AST.Document (Name)
+import Language.GraphQL.Type.Definition
+
+-- | Single field of an 'InputObjectType'.
+data InputField = InputField (Maybe Text) Type (Maybe Value)
+
+-- | Input object type definition.
+--
+-- An input object defines a structured collection of fields which may be
+-- supplied to a field argument.
+data InputObjectType = InputObjectType
+    Name (Maybe Text) (HashMap Name InputField)
+
+instance Eq InputObjectType where
+    (InputObjectType this _ _) == (InputObjectType that _ _) = this == that
+
+-- | These types may be used as input types for arguments and directives.
+--
+-- GraphQL distinguishes between "wrapping" and "named" types. Each wrapping
+-- type can wrap other wrapping or named types. Wrapping types are lists and
+-- Non-Null types (named types are nullable by default).
+data Type
+    = NamedScalarType ScalarType
+    | NamedEnumType EnumType
+    | NamedInputObjectType InputObjectType
+    | ListType Type
+    | NonNullScalarType ScalarType
+    | NonNullEnumType EnumType
+    | NonNullInputObjectType InputObjectType
+    | NonNullListType Type
+    deriving Eq
+
+-- | Field argument definition.
+data Argument = Argument (Maybe Text) Type (Maybe Value)
+
+-- | Matches either 'NamedScalarType' or 'NonNullScalarType'.
+pattern ScalarBaseType :: ScalarType -> Type
+pattern ScalarBaseType scalarType <- (isScalarType -> Just scalarType)
+
+-- | Matches either 'NamedEnumType' or 'NonNullEnumType'.
+pattern EnumBaseType :: EnumType -> Type
+pattern EnumBaseType enumType <- (isEnumType -> Just enumType)
+
+-- | Matches either 'NamedInputObjectType' or 'NonNullInputObjectType'.
+pattern InputObjectBaseType :: InputObjectType -> Type
+pattern InputObjectBaseType objectType <- (isInputObjectType -> Just objectType)
+
+-- | Matches either 'ListType' or 'NonNullListType'.
+pattern ListBaseType :: Type -> Type
+pattern ListBaseType listType <- (isListType -> Just listType)
+
+{-# COMPLETE EnumBaseType, ListBaseType, InputObjectBaseType, ScalarBaseType #-}
+
+isScalarType :: Type -> Maybe ScalarType
+isScalarType (NamedScalarType inputType) = Just inputType
+isScalarType (NonNullScalarType inputType) = Just inputType
+isScalarType _ = Nothing
+
+isInputObjectType :: Type -> Maybe InputObjectType
+isInputObjectType (NamedInputObjectType inputType) = Just inputType
+isInputObjectType (NonNullInputObjectType inputType) = Just inputType
+isInputObjectType _ = Nothing
+
+isEnumType :: Type -> Maybe EnumType
+isEnumType (NamedEnumType inputType) = Just inputType
+isEnumType (NonNullEnumType inputType) = Just inputType
+isEnumType _ = Nothing
+
+isListType :: Type -> Maybe Type
+isListType (ListType inputType) = Just inputType
+isListType (NonNullListType inputType) = Just inputType
+isListType _ = Nothing
+
+-- | Checks whether the given input type is a non-null type.
+isNonNullType :: Type -> Bool
+isNonNullType (NonNullScalarType _) = True
+isNonNullType (NonNullEnumType _) = True
+isNonNullType (NonNullInputObjectType _) = True
+isNonNullType (NonNullListType _) = True
+isNonNullType _ = False

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

@@ -0,0 +1,212 @@
+{- 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, 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
+    ( Context(..)
+    , Field(..)
+    , InterfaceType(..)
+    , ObjectType(..)
+    , Resolve
+    , Subscribe
+    , Resolver(..)
+    , SourceEventStream
+    , Type(..)
+    , UnionType(..)
+    , argument
+    , isNonNullType
+    , pattern EnumBaseType
+    , pattern InterfaceBaseType
+    , pattern ListBaseType
+    , pattern ObjectBaseType
+    , pattern ScalarBaseType
+    , 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.Type.Definition
+import qualified Language.GraphQL.Type.In as In
+
+-- | Object type definition.
+--
+-- Almost all of the GraphQL types you define will be object types. Object
+-- types have a name, but most importantly describe their fields.
+data ObjectType m = ObjectType
+    Name (Maybe Text) [InterfaceType m] (HashMap Name (Resolver m))
+
+instance forall a. Eq (ObjectType a) where
+    (ObjectType this _ _ _) == (ObjectType that _ _ _) = this == that
+
+-- | Interface Type Definition.
+--
+-- When a field can return one of a heterogeneous set of types, a Interface type
+-- is used to describe what types are possible, and what fields are in common
+-- across all types.
+data InterfaceType m = InterfaceType
+    Name (Maybe Text) [InterfaceType m] (HashMap Name (Field m))
+
+instance forall a. Eq (InterfaceType a) where
+    (InterfaceType this _ _ _) == (InterfaceType that _ _ _) = this == that
+
+-- | Union Type Definition.
+--
+-- When a field can return one of a heterogeneous set of types, a Union type is
+-- used to describe what types are possible.
+data UnionType m = UnionType Name (Maybe Text) [ObjectType m]
+
+instance forall a. Eq (UnionType a) where
+    (UnionType this _ _) == (UnionType that _ _) = this == that
+
+-- | Output object field definition.
+data Field m = Field
+    (Maybe Text) -- ^ Description.
+    (Type m) -- ^ Field type.
+    (HashMap Name In.Argument) -- ^ Arguments.
+
+-- | These types may be used as output types as the result of fields.
+--
+-- GraphQL distinguishes between "wrapping" and "named" types. Each wrapping
+-- type can wrap other wrapping or named types. Wrapping types are lists and
+-- Non-Null types (named types are nullable by default).
+data Type m
+    = NamedScalarType ScalarType
+    | NamedEnumType EnumType
+    | NamedObjectType (ObjectType m)
+    | NamedInterfaceType (InterfaceType m)
+    | NamedUnionType (UnionType m)
+    | ListType (Type m)
+    | NonNullScalarType ScalarType
+    | NonNullEnumType EnumType
+    | NonNullObjectType (ObjectType m)
+    | NonNullInterfaceType (InterfaceType m)
+    | NonNullUnionType (UnionType m)
+    | NonNullListType (Type m)
+    deriving Eq
+
+-- | Matches either 'NamedScalarType' or 'NonNullScalarType'.
+pattern ScalarBaseType :: forall m. ScalarType -> Type m
+pattern ScalarBaseType scalarType <- (isScalarType -> Just scalarType)
+
+-- | Matches either 'NamedEnumType' or 'NonNullEnumType'.
+pattern EnumBaseType :: forall m. EnumType -> Type m
+pattern EnumBaseType enumType <- (isEnumType -> Just enumType)
+
+-- | Matches either 'NamedObjectType' or 'NonNullObjectType'.
+pattern ObjectBaseType :: forall m. ObjectType m -> Type m
+pattern ObjectBaseType objectType <- (isObjectType -> Just objectType)
+
+-- | Matches either 'NamedInterfaceType' or 'NonNullInterfaceType'.
+pattern InterfaceBaseType :: forall m. InterfaceType m -> Type m
+pattern InterfaceBaseType interfaceType <-
+    (isInterfaceType -> Just interfaceType)
+
+-- | Matches either 'NamedUnionType' or 'NonNullUnionType'.
+pattern UnionBaseType :: forall m. UnionType m -> Type m
+pattern UnionBaseType unionType <- (isUnionType -> Just unionType)
+
+-- | Matches either 'ListType' or 'NonNullListType'.
+pattern ListBaseType :: forall m. Type m -> Type m
+pattern ListBaseType listType <- (isListType -> Just listType)
+
+{-# COMPLETE ScalarBaseType
+    , EnumBaseType
+    , ObjectBaseType
+    , ListBaseType
+    , InterfaceBaseType
+    , UnionBaseType
+    #-}
+
+isScalarType :: forall m. Type m -> Maybe ScalarType
+isScalarType (NamedScalarType outputType) = Just outputType
+isScalarType (NonNullScalarType outputType) = Just outputType
+isScalarType _ = Nothing
+
+isObjectType :: forall m. Type m -> Maybe (ObjectType m)
+isObjectType (NamedObjectType outputType) = Just outputType
+isObjectType (NonNullObjectType outputType) = Just outputType
+isObjectType _ = Nothing
+
+isEnumType :: forall m. Type m -> Maybe EnumType
+isEnumType (NamedEnumType outputType) = Just outputType
+isEnumType (NonNullEnumType outputType) = Just outputType
+isEnumType _ = Nothing
+
+isInterfaceType :: forall m. Type m -> Maybe (InterfaceType m)
+isInterfaceType (NamedInterfaceType interfaceType) = Just interfaceType
+isInterfaceType (NonNullInterfaceType interfaceType) = Just interfaceType
+isInterfaceType _ = Nothing
+
+isUnionType :: forall m. Type m -> Maybe (UnionType m)
+isUnionType (NamedUnionType unionType) = Just unionType
+isUnionType (NonNullUnionType unionType) = Just unionType
+isUnionType _ = Nothing
+
+isListType :: forall m. Type m -> Maybe (Type m)
+isListType (ListType outputType) = Just outputType
+isListType (NonNullListType outputType) = Just outputType
+isListType _ = Nothing
+
+-- | Checks whether the given output type is a non-null type.
+isNonNullType :: forall m. Type m -> Bool
+isNonNullType (NonNullScalarType _) = True
+isNonNullType (NonNullEnumType _) = True
+isNonNullType (NonNullObjectType _) = True
+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

@@ -0,0 +1,33 @@
+-- | This module provides a representation of a @GraphQL@ Schema in addition to
+-- functions for defining and manipulating schemas.
+module Language.GraphQL.Type.Schema
+    ( Schema(..)
+    , Type(..)
+    ) where
+
+import qualified Language.GraphQL.Type.Definition as Definition
+import qualified Language.GraphQL.Type.In as In
+import qualified Language.GraphQL.Type.Out as Out
+
+-- | These are all of the possible kinds of types.
+data Type m
+    = ScalarType Definition.ScalarType
+    | EnumType Definition.EnumType
+    | ObjectType (Out.ObjectType m)
+    | InputObjectType In.InputObjectType
+    | InterfaceType (Out.InterfaceType m)
+    | UnionType (Out.UnionType 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.
+--
+--   __Note:__ When the schema is constructed, by default only the types that
+--   are reachable by traversing the root types are included, other types must
+--   be explicitly referenced.
+data Schema m = Schema
+    { query :: Out.ObjectType m
+    , mutation :: Maybe (Out.ObjectType m)
+    , subscription :: Maybe (Out.ObjectType m)
+    }

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-15.12
+resolver: lts-16.6
 
 packages:
 - .

tests/Language/GraphQL/AST/ParserSpec.hs

@@ -8,7 +8,7 @@ import Data.List.NonEmpty (NonEmpty(..))
 import Language.GraphQL.AST.Document
 import Language.GraphQL.AST.Parser
 import Test.Hspec (Spec, describe, it)
-import Test.Hspec.Megaparsec (shouldParse, shouldSucceedOn)
+import Test.Hspec.Megaparsec (shouldParse, shouldFailOn, shouldSucceedOn)
 import Text.Megaparsec (parse)
 import Text.RawString.QQ (r)
 
@@ -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 :| [])
 
@@ -142,3 +143,29 @@ spec = describe "Parser" $ do
               isHiddenLocally: Boolean
             }
         |]
+
+    it "rejects variables in DefaultValue" $
+        parse document "" `shouldFailOn` [r|
+            query ($book: String = "Zarathustra", $author: String = $book) {
+              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/Execute/CoerceSpec.hs

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

tests/Language/GraphQL/ExecuteSpec.hs

@@ -0,0 +1,113 @@
+{- 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.Conduit
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
+import Language.GraphQL.AST (Name)
+import Language.GraphQL.AST.Parser (document)
+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, context, describe, it, shouldBe)
+import Text.Megaparsec (parse)
+
+schema :: Schema (Either SomeException)
+schema = Schema
+    { query = queryType
+    , mutation = Nothing
+    , subscription = Just subscriptionType
+    }
+
+queryType :: Out.ObjectType (Either SomeException)
+queryType = Out.ObjectType "Query" Nothing []
+    $ HashMap.singleton "philosopher" 
+    $ ValueResolver philosopherField
+    $ pure $ Type.Object mempty
+  where
+    philosopherField =
+        Out.Field Nothing (Out.NonNullObjectType philosopherType) HashMap.empty
+
+philosopherType :: Out.ObjectType (Either SomeException)
+philosopherType = Out.ObjectType "Philosopher" Nothing []
+    $ HashMap.fromList resolvers
+  where
+    resolvers =
+        [ ("firstName", ValueResolver firstNameField firstNameResolver)
+        , ("lastName", ValueResolver lastNameField lastNameResolver)
+        ]
+    firstNameField =
+        Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
+    firstNameResolver = pure $ Type.String "Friedrich"
+    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
+        context "Query" $ do
+            it "skips unknown fields" $
+                let data'' = Aeson.object
+                        [ "philosopher" .= Aeson.object
+                            [ "firstName" .= ("Friedrich" :: String)
+                            ]
+                        ]
+                    expected = Response data'' mempty
+                    execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)
+                    Right (Right actual) = either (pure . parseError) execute'
+                        $ parse document "" "{ philosopher { firstName surname } }"
+                in actual `shouldBe` expected
+            it "merges selections" $
+                let data'' = Aeson.object
+                        [ "philosopher" .= Aeson.object
+                            [ "firstName" .= ("Friedrich" :: String)
+                            , "lastName" .= ("Nietzsche" :: String)
+                            ]
+                        ]
+                    expected = Response data'' mempty
+                    execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)
+                    Right (Right actual) = either (pure . parseError) execute'
+                        $ parse document "" "{ philosopher { firstName } philosopher { lastName } }"
+                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/Type/OutSpec.hs

@@ -0,0 +1,14 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Language.GraphQL.Type.OutSpec
+    ( spec
+    ) where
+
+import Language.GraphQL.Type
+import Test.Hspec (Spec, describe, it, shouldBe)
+
+spec :: Spec
+spec =
+    describe "Value" $
+        it "supports overloaded strings" $
+            let nietzsche = "Goldstaub abblasen." :: Value
+             in nietzsche `shouldBe` String "Goldstaub abblasen."

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,68 +1,73 @@
+{- This Source Code Form is subject to the terms of the Mozilla Public License,
+   v. 2.0. If a copy of the MPL was not distributed with this file, You can
+   obtain one at https://mozilla.org/MPL/2.0/. -}
+
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
 module Test.DirectiveSpec
     ( spec
     ) where
 
-import Data.Aeson (Value, object, (.=))
+import Data.Aeson (object, (.=))
-import Data.HashMap.Strict (HashMap)
+import qualified Data.Aeson as Aeson
 import qualified Data.HashMap.Strict as HashMap
-import Data.List.NonEmpty (NonEmpty(..))
-import Data.Text (Text)
 import Language.GraphQL
-import qualified Language.GraphQL.Schema as Schema
+import Language.GraphQL.Type
-import Test.Hspec (Spec, describe, it, shouldBe)
+import qualified Language.GraphQL.Type.Out as Out
+import Test.Hspec (Spec, describe, it)
+import Test.Hspec.GraphQL
 import Text.RawString.QQ (r)
 
-experimentalResolver :: HashMap Text (NonEmpty (Schema.Resolver IO))
+experimentalResolver :: Schema IO
-experimentalResolver = HashMap.singleton "Query"
+experimentalResolver = Schema
-    $ Schema.scalar "experimentalField" (pure (5 :: Int)) :| []
+    { query = queryType, mutation = Nothing, subscription = Nothing }
+  where
+    queryType = Out.ObjectType "Query" Nothing []
+        $ HashMap.singleton "experimentalField"
+        $ Out.ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
+        $ pure $ Int 5
 
-emptyObject :: Value
+emptyObject :: Aeson.Object
-emptyObject = object
+emptyObject = HashMap.singleton "data" $ object []
-    [ "data" .= object []
-    ]
 
 spec :: Spec
 spec =
     describe "Directive executor" $ do
         it "should be able to @skip fields" $ do
-            let query = [r|
+            let sourceQuery = [r|
               {
                 experimentalField @skip(if: true)
               }
             |]
 
-            actual <- graphql experimentalResolver query
+            actual <- graphql experimentalResolver sourceQuery
-            actual `shouldBe` emptyObject
+            actual `shouldResolveTo` emptyObject
 
         it "should not skip fields if @skip is false" $ do
-            let query = [r|
+            let sourceQuery = [r|
               {
                 experimentalField @skip(if: false)
               }
             |]
-                expected = object
+                expected = HashMap.singleton "data"
-                    [ "data" .= object
+                    $ object
                         [ "experimentalField" .= (5 :: Int)
                         ]
-                    ]
+            actual <- graphql experimentalResolver sourceQuery
-
+            actual `shouldResolveTo` expected
-            actual <- graphql experimentalResolver query
-            actual `shouldBe` expected
 
         it "should skip fields if @include is false" $ do
-            let query = [r|
+            let sourceQuery = [r|
               {
                 experimentalField @include(if: false)
               }
             |]
 
-            actual <- graphql experimentalResolver query
+            actual <- graphql experimentalResolver sourceQuery
-            actual `shouldBe` emptyObject
+            actual `shouldResolveTo` emptyObject
 
         it "should be able to @skip a fragment spread" $ do
-            let query = [r|
+            let sourceQuery = [r|
               {
                 ...experimentalFragment @skip(if: true)
               }
@@ -72,11 +77,11 @@ spec =
               }
             |]
 
-            actual <- graphql experimentalResolver query
+            actual <- graphql experimentalResolver sourceQuery
-            actual `shouldBe` emptyObject
+            actual `shouldResolveTo` emptyObject
 
         it "should be able to @skip an inline fragment" $ do
-            let query = [r|
+            let sourceQuery = [r|
               {
                 ... on ExperimentalType @skip(if: true) {
                   experimentalField
@@ -84,5 +89,5 @@ spec =
               }
             |]
 
-            actual <- graphql experimentalResolver query
+            actual <- graphql experimentalResolver sourceQuery
-            actual `shouldBe` emptyObject
+            actual `shouldResolveTo` emptyObject

tests/Test/FragmentSpec.hs

@@ -1,35 +1,37 @@
+{- 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 (Value(..), object, (.=))
+import Data.Aeson ((.=))
+import qualified Data.Aeson as Aeson
 import qualified Data.HashMap.Strict as HashMap
-import Data.List.NonEmpty (NonEmpty(..))
 import Data.Text (Text)
 import Language.GraphQL
-import qualified Language.GraphQL.Schema as Schema
+import Language.GraphQL.Type
-import Test.Hspec ( Spec
+import qualified Language.GraphQL.Type.Out as Out
-                  , describe
+import Test.Hspec (Spec, describe, it)
-                  , it
+import Test.Hspec.GraphQL
-                  , shouldBe
-                  , shouldSatisfy
-                  , shouldNotSatisfy
-                  )
 import Text.RawString.QQ (r)
 
-size :: Schema.Resolver IO
+size :: (Text, Value)
-size = Schema.scalar "size" $ return ("L" :: Text)
+size = ("size", String "L")
 
-circumference :: Schema.Resolver IO
+circumference :: (Text, Value)
-circumference = Schema.scalar "circumference" $ return (60 :: Int)
+circumference = ("circumference", Int 60)
 
-garment :: Text -> Schema.Resolver IO
+garment :: Text -> (Text, Value)
-garment typeName = Schema.object "garment" $ return
+garment typeName =
+    ("garment",  Object $ HashMap.fromList
         [ if typeName == "Hat" then circumference else size
-    , Schema.scalar "__typename" $ return typeName
+        , ("__typename", String typeName)
         ]
+    )
 
 inlineQuery :: Text
 inlineQuery = [r|{
@@ -43,37 +45,72 @@ inlineQuery = [r|{
   }
 }|]
 
-hasErrors :: Value -> Bool
+shirtType :: Out.ObjectType IO
-hasErrors (Object object') = HashMap.member "errors" object'
+shirtType = Out.ObjectType "Shirt" Nothing []
-hasErrors _ = True
+    $ HashMap.fromList
+        [ ("size", sizeFieldType)
+        , ("circumference", circumferenceFieldType)
+        ]
+
+hatType :: Out.ObjectType IO
+hatType = Out.ObjectType "Hat" Nothing []
+    $ HashMap.fromList
+        [ ("size", sizeFieldType)
+        , ("circumference", circumferenceFieldType)
+        ]
+
+circumferenceFieldType :: Out.Resolver IO
+circumferenceFieldType
+    = Out.ValueResolver (Out.Field Nothing (Out.NamedScalarType int) mempty)
+    $ pure $ snd circumference
+
+sizeFieldType :: Out.Resolver IO
+sizeFieldType
+    = Out.ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
+    $ pure $ snd size
+
+toSchema :: Text -> (Text, Value) -> Schema IO
+toSchema t (_, resolve) = Schema
+    { query = queryType, mutation = Nothing, subscription = Nothing }
+  where
+    unionMember = if t == "Hat" then hatType else shirtType
+    typeNameField = Out.Field Nothing (Out.NamedScalarType string) mempty
+    garmentField = Out.Field Nothing (Out.NamedObjectType unionMember) mempty
+    queryType =
+        case t of
+            "circumference" -> hatType
+            "size" -> shirtType
+            _ -> Out.ObjectType "Query" Nothing []
+                $ HashMap.fromList
+                    [ ("garment", ValueResolver garmentField (pure resolve))
+                    , ("__typename", ValueResolver typeNameField (pure $ String "Shirt"))
+                    ]
 
 spec :: Spec
 spec = do
     describe "Inline fragment executor" $ do
         it "chooses the first selection if the type matches" $ do
-            actual <- graphql (HashMap.singleton "Query" $ garment "Hat" :| []) inlineQuery
+            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 (HashMap.singleton "Query" $ garment "Shirt" :| []) inlineQuery
+            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 query = [r|{
+            let sourceQuery = [r|{
               garment {
                 circumference
                 ... {
@@ -81,32 +118,29 @@ spec = do
                 }
               }
             }|]
-                resolvers = Schema.object "garment" $ return [circumference,  size]
+                resolvers = ("garment", Object $ HashMap.fromList [circumference,  size])
 
-            actual <- graphql (HashMap.singleton "Query" $ resolvers :| []) query
+            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 query = [r|{
+            let sourceQuery = [r|{
               ... {
                 size
               }
             }|]
-
+             in graphql (toSchema "size" size) `shouldResolve` sourceQuery
-            actual <- graphql (HashMap.singleton "Query" $ size :| []) query
-            actual `shouldNotSatisfy` hasErrors
 
     describe "Fragment spread executor" $ do
         it "evaluates fragment spreads" $ do
-            let query = [r|
+            let sourceQuery = [r|
               {
                 ...circumferenceFragment
               }
@@ -116,16 +150,15 @@ spec = do
               }
             |]
 
-            actual <- graphql (HashMap.singleton "Query" $ circumference :| []) query
+            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 query = [r|
+            let sourceQuery = [r|
               {
                 garment {
                   ...circumferenceFragment
@@ -141,18 +174,18 @@ spec = do
               }
             |]
 
-            actual <- graphql (HashMap.singleton "Query" $ garment "Hat" :| []) query
+            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 query = [r|
+            let expected = HashMap.singleton "data" $ Aeson.object []
+                sourceQuery = [r|
               {
                 ...circumferenceFragment
               }
@@ -162,11 +195,11 @@ spec = do
               }
             |]
 
-            actual <- graphql (HashMap.singleton "Query" $ circumference :| []) query
+            actual <- graphql (toSchema "circumference" circumference) sourceQuery
-            actual `shouldSatisfy` hasErrors
+            actual `shouldResolveTo` expected
 
         it "considers type condition" $ do
-            let query = [r|
+            let sourceQuery = [r|
               {
                 garment {
                   ...circumferenceFragment
@@ -180,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 <- graphql (HashMap.singleton "Query" $ garment "Hat" :| []) query
+            actual `shouldResolveTo` expected
-            actual `shouldBe` expected

tests/Test/RootOperationSpec.hs

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

tests/Test/StarWars/Data.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Test.StarWars.Data
     ( Character
+    , StarWarsException(..)
     , appearsIn
     , artoo
     , getDroid
@@ -11,18 +12,18 @@ module Test.StarWars.Data
     , getHuman
     , id_
     , homePlanet
-    , name
+    , name_
     , secretBackstory
     , 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 qualified Language.GraphQL.Type as Type
+import Language.GraphQL.Error
+import Language.GraphQL.Type
 
 -- * Data
 -- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsData.js
@@ -55,9 +56,9 @@ id_ :: Character -> ID
 id_ (Left  x) = _id_ . _droidChar $ x
 id_ (Right x) = _id_ . _humanChar $ x
 
-name :: Character -> Text
+name_ :: Character -> Text
-name (Left  x) = _name . _droidChar $ x
+name_ (Left  x) = _name . _droidChar $ x
-name (Right x) = _name . _humanChar $ x
+name_ (Right x) = _name . _humanChar $ x
 
 friends :: Character -> [ID]
 friends (Left  x) = _friends . _droidChar $ x
@@ -67,8 +68,20 @@ appearsIn :: Character -> [Int]
 appearsIn (Left  x) = _appearsIn . _droidChar $ x
 appearsIn (Right x) = _appearsIn . _humanChar $ x
 
-secretBackstory :: Character -> ActionT Identity Text
+data StarWarsException = SecretBackstory | InvalidArguments
-secretBackstory = const $ 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")
@@ -162,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
@@ -173,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
@@ -184,8 +197,8 @@ getDroid' _      = empty
 getFriends :: Character -> [Character]
 getFriends char = catMaybes $ liftA2 (<|>) getDroid getHuman <$> friends char
 
-getEpisode :: Int -> Maybe (Type.Wrapping Text)
+getEpisode :: Int -> Maybe Text
-getEpisode 4 = pure $ Type.Named "NEWHOPE"
+getEpisode 4 = pure "NEW_HOPE"
-getEpisode 5 = pure $ Type.Named "EMPIRE"
+getEpisode 5 = pure "EMPIRE"
-getEpisode 6 = pure $ Type.Named "JEDI"
+getEpisode 6 = pure "JEDI"
 getEpisode _ = empty

tests/Test/StarWars/QuerySpec.hs

@@ -6,11 +6,9 @@ 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
-import Language.GraphQL.Schema (Subs)
 import Text.RawString.QQ (r)
 import Test.Hspec.Expectations (Expectation, shouldBe)
 import Test.Hspec (Spec, describe, it)
@@ -78,7 +76,7 @@ spec = describe "Star Wars Query Tests" $ do
             , "friends" .= [
                   Aeson.object [
                       "name" .= ("Luke Skywalker" :: Text)
-                    , "appearsIn" .= ["NEWHOPE","EMPIRE","JEDI" :: Text]
+                    , "appearsIn" .= ["NEW_HOPE", "EMPIRE", "JEDI" :: Text]
                     , "friends" .= [
                           Aeson.object [hanName]
                         , Aeson.object [leiaName]
@@ -88,7 +86,7 @@ spec = describe "Star Wars Query Tests" $ do
                     ]
                 , Aeson.object [
                       hanName
-                    , "appearsIn" .= [ "NEWHOPE","EMPIRE","JEDI" :: Text]
+                    , "appearsIn" .= ["NEW_HOPE", "EMPIRE", "JEDI" :: Text]
                     , "friends" .=
                         [ Aeson.object [lukeName]
                         , Aeson.object [leiaName]
@@ -97,7 +95,7 @@ spec = describe "Star Wars Query Tests" $ do
                     ]
                 , Aeson.object [
                       leiaName
-                    , "appearsIn" .= [ "NEWHOPE","EMPIRE","JEDI" :: Text]
+                    , "appearsIn" .= ["NEW_HOPE", "EMPIRE", "JEDI" :: Text]
                     , "friends" .=
                         [ Aeson.object [lukeName]
                         , Aeson.object [hanName]
@@ -358,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 :: Subs -> Text -> Aeson.Value -> Expectation
+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

@@ -1,66 +1,154 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 module Test.StarWars.Schema
-    ( character
+    ( schema
-    , droid
-    , hero
-    , human
-    , schema
     ) where
 
-import Control.Monad.Trans.Except (throwE)
+import Control.Monad.Catch (MonadThrow(..), SomeException)
-import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.Reader (asks)
-import Data.Functor.Identity (Identity)
-import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
-import Data.List.NonEmpty (NonEmpty(..))
 import Data.Maybe (catMaybes)
 import Data.Text (Text)
-import qualified Language.GraphQL.Schema as Schema
+import Language.GraphQL.Type
-import Language.GraphQL.Trans
+import qualified Language.GraphQL.Type.In as In
-import qualified Language.GraphQL.Type as Type
+import qualified Language.GraphQL.Type.Out as Out
 import Test.StarWars.Data
+import Prelude hiding (id)
 
 -- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js
 
-schema :: HashMap Text (NonEmpty (Schema.Resolver Identity))
+schema :: Schema (Either SomeException)
-schema = HashMap.singleton "Query" $ hero :| [human, droid]
+schema = Schema
+    { query = queryType
+    , mutation = Nothing
+    , subscription = Nothing
+    }
+  where
+    queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList
+        [ ("hero", heroFieldResolver)
+        , ("human", humanFieldResolver)
+        , ("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
 
-hero :: Schema.Resolver Identity
+heroObject :: Out.ObjectType (Either SomeException)
-hero = Schema.object "hero" $ do
+heroObject = Out.ObjectType "Human" Nothing [] $ HashMap.fromList
+    [ ("id", idFieldType)
+    , ("name", nameFieldType)
+    , ("friends", friendsFieldType)
+    , ("appearsIn", appearsInField)
+    , ("homePlanet", homePlanetFieldType)
+    , ("secretBackstory", secretBackstoryFieldType)
+    , ("__typename", typenameFieldType)
+    ]
+  where
+    homePlanetFieldType
+      = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
+      $ idField "homePlanet"
+
+droidObject :: Out.ObjectType (Either SomeException)
+droidObject = Out.ObjectType "Droid" Nothing [] $ HashMap.fromList
+    [ ("id", idFieldType)
+    , ("name", nameFieldType)
+    , ("friends", friendsFieldType)
+    , ("appearsIn", appearsInField)
+    , ("primaryFunction", primaryFunctionFieldType)
+    , ("secretBackstory", secretBackstoryFieldType)
+    , ("__typename", typenameFieldType)
+    ]
+  where
+    primaryFunctionFieldType
+        = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
+        $ idField "primaryFunction"
+
+typenameFieldType :: Resolver (Either SomeException)
+typenameFieldType
+    = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
+    $ idField "__typename"
+
+idFieldType :: Resolver (Either SomeException)
+idFieldType
+    = ValueResolver (Out.Field Nothing (Out.NamedScalarType id) mempty)
+    $ idField "id"
+
+nameFieldType :: Resolver (Either SomeException)
+nameFieldType
+    = ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
+    $ idField "name"
+
+friendsFieldType :: Resolver (Either SomeException)
+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 :: Resolver (Either SomeException)
+secretBackstoryFieldType = ValueResolver field secretBackstory
+  where
+    field = Out.Field Nothing (Out.NamedScalarType string) mempty
+
+idField :: Text -> Resolve (Either SomeException)
+idField f = do
+    v <- asks values
+    let (Object v') = v
+    pure $ v' HashMap.! f
+
+episodeEnum :: EnumType
+episodeEnum = EnumType "Episode" (Just description)
+    $ HashMap.fromList [newHope, empire, jedi]
+  where
+    description = "One of the films in the Star Wars Trilogy"
+    newHope = ("NEW_HOPE", EnumValue $ Just "Released in 1977.")
+    empire = ("EMPIRE", EnumValue $ Just "Released in 1980.")
+    jedi = ("JEDI", EnumValue $ Just "Released in 1983.")
+
+hero :: Resolve (Either SomeException)
+hero = do
   episode <- argument "episode"
-  character $ case episode of
+  pure $ character $ case episode of
-      Schema.Enum "NEWHOPE" -> getHero 4
+      Enum "NEW_HOPE" -> getHero 4
-      Schema.Enum "EMPIRE" -> getHero 5
+      Enum "EMPIRE" -> getHero 5
-      Schema.Enum "JEDI" -> getHero 6
+      Enum "JEDI" -> getHero 6
       _ -> artoo
 
-human :: Schema.Resolver Identity
+human :: Resolve (Either SomeException)
-human = Schema.wrappedObject "human" $ do
+human = do
     id' <- argument "id"
     case id' of
-        Schema.String i -> do
+        String i -> pure $ maybe Null character $ getHuman i >>= Just
-            humanCharacter <- lift $ return $ getHuman i >>= Just
+        _ -> throwM InvalidArguments
-            case humanCharacter of
-                Nothing -> return Type.Null
-                Just e -> Type.Named <$> character e
-        _ -> ActionT $ throwE "Invalid arguments."
 
-droid :: Schema.Resolver Identity
+droid :: Resolve (Either SomeException)
-droid = Schema.object "droid" $ do
+droid = do
     id' <- argument "id"
     case id' of
-        Schema.String i -> character =<< getDroid i
+        String i -> pure $ maybe Null character $ getDroid i >>= Just
-        _ -> ActionT $ throwE "Invalid arguments."
+        _ -> throwM InvalidArguments
 
-character :: Character -> ActionT Identity [Schema.Resolver Identity]
+character :: Character -> Value
-character char = return
+character char = Object $ HashMap.fromList
-    [ Schema.scalar "id" $ return $ id_ char
+    [ ("id", String $ id_ char)
-    , Schema.scalar "name" $ return $ name char
+    , ("name", String $ name_ char)
-    , Schema.wrappedObject "friends"
+    , ("friends", List $ character <$> getFriends char)
-        $ traverse character $ Type.List $ Type.Named <$> getFriends char
+    , ("appearsIn", List $ Enum <$> catMaybes (getEpisode <$> appearsIn char))
-    , Schema.wrappedScalar "appearsIn" $ return . Type.List
+    , ("homePlanet", String $ either mempty homePlanet char)
-        $ catMaybes (getEpisode <$> appearsIn char)
+    , ("__typename", String $ typeName char)
-    , Schema.scalar "secretBackstory" $ secretBackstory char
-    , Schema.scalar "homePlanet" $ return $ either mempty homePlanet char
-    , Schema.scalar "__typename" $ return $ typeName char
     ]