Release 0.5.0.0

Fixes #2.

.gitignore

@@ -1 +1,10 @@
+# Stack
 .stack-work/
+/stack.yaml.lock
+
+# Cabal
+/dist/
+/dist-newstyle/
+.cabal-sandbox/
+cabal.sandbox.config
+cabal.project.local

CHANGELOG.md

@@ -1,6 +1,77 @@
 # Change Log
 All notable changes to this project will be documented in this file.
 
-## [0.1] - 2015-09-12
+## [0.5.0.0] - 2019-08-14
+### Added
+- `executeWithName` executes an operation with the given name.
+- Export `Language.GraphQL.Encoder.definition`,
+  `Language.GraphQL.Encoder.type'` and `Language.GraphQL.Encoder.directive`.
+- Export `Language.GraphQL.Encoder.value`. Escapes \ and " in strings now.
+
+### Changed
+- `Operation` includes now possible operation name which allows to support
+  documents with multiple operations.
+- `Language.GraphQL.Encoder.document` and other encoding functions take a
+  `Formatter` as argument to distinguish between minified and pretty printing.
+- All encoder functions return `Data.Text.Lazy`.
+
+### Removed
+- Unused `Language.GraphQL.Encoder.spaced`.
+
+## [0.4.0.0] - 2019-07-23
+### Added
+- Support for mutations.
+- Error handling (with monad transformers).
+- Nullable types.
+- Arbitrary nested lists support.
+- Potential BOM header parsing.
+
+### Changed
+- attoparsec is replaced with megaparsec.
+- The library is now under `Language.GraphQL` (instead of `Data.GraphQL`).
+- HUnit and tasty are replaced with Hspec.
+- `Alternative`/`MonadPlus` resolver constraints are replaced with `MonadIO`.
+
+### Removed
+- Duplicates from `Language.GraphQL.AST` already available in
+  `Language.GraphQL.AST.Core`.
+- All module exports are now explicit, so private and help functions aren't
+  exported anymore.
+
+## [0.3] - 2015-09-22
+### Changed
+- Exact match numeric types to spec.
+- Names follow now the spec.
+- AST slightly different for better readability or easier parsing.
+- Replace golden test for test to validate parsing/encoding.
+
+### Added
+- Parsing errors in all cases where `Alternative` is used.
+- GraphQL encoder.
+
+### Fixed
+- Expect braces `inputValueDefinitions` instead of parens when parsing.
+
+## [0.2.1] - 2015-09-16
+### Fixed
+- Include data files for golden tests in Cabal package.
+- Support for ghc-7.8.
+
+## [0.2] - 2015-09-14
+### Added
+- Rudimentary parser for `GraphQL` which successfully parses the sample file
+  `kitchen-sink.graphql` from `graphql-js` tests.
+- Golden test for `kitchen-sink.grahql` parsing.
+### Changed
+- Many optional data types in `GraphQl` didn't need to be wrapped in a `Maybe`.
+- Some `newtype`s became type synonyms for easier parsing.
+
+## 0.1 - 2015-09-12
 ### Added
 - Data types for the GraphQL language.
+
+[0.5.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.4.0.0...v0.5.0.0
+[0.4.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.3...v0.4.0.0
+[0.3]: https://github.com/caraus-ecms/graphql/compare/v0.2.1...v0.3
+[0.2.1]: https://github.com/caraus-ecms/graphql/compare/v0.2...v0.2.1
+[0.2]: https://github.com/caraus-ecms/graphql/compare/v0.1...v0.2

Data/GraphQL.hs

@@ -1,140 +0,0 @@
-module Data.GraphQL where
-
-import Data.Text (Text)
-
--- * Name
-
-type Name = Text
-
--- * Document
-
-newtype Document = Document [Definition] deriving (Eq,Show)
-
-data Definition = DefinitionOperation OperationDefinition
-                | DefinitionFragment  FragmentDefinition
-                | DefinitionType      TypeDefinition
-                  deriving (Eq,Show)
-
-data OperationDefinition =
-    Query        (Maybe [VariableDefinition]) (Maybe [Directive]) SelectionSet
-  | Mutation     (Maybe [VariableDefinition]) (Maybe [Directive]) SelectionSet
-  | Subscription (Maybe [VariableDefinition]) (Maybe [Directive]) SelectionSet
-    deriving (Eq,Show)
-
-data VariableDefinition = VariableDefinition Variable Type (Maybe DefaultValue)
-                          deriving (Eq,Show)
-
-newtype Variable = Variable Name deriving (Eq,Show)
-
-newtype SelectionSet = SelectionSet [Selection] deriving (Eq,Show)
-
-data Selection = SelectionField Field
-               | SelectionFragmentSpread FragmentSpread
-               | SelectionInlineFragment InlineFragment
-                 deriving (Eq,Show)
-
-data Field = Field (Maybe Alias) Name (Maybe [Argument])
-                                      (Maybe [Directive])
-                                      (Maybe SelectionSet)
-             deriving (Eq,Show)
-
-type Alias = Name
-
-data Argument = Argument Name Value deriving (Eq,Show)
-
--- * Fragments
-
-data FragmentSpread = FragmentSpread Name (Maybe [Directive])
-                      deriving (Eq,Show)
-
-data InlineFragment =
-    InlineFragment TypeCondition (Maybe [Directive]) SelectionSet
-    deriving (Eq,Show)
-
-data FragmentDefinition =
-    FragmentDefinition Name TypeCondition (Maybe [Directive]) SelectionSet
-    deriving (Eq,Show)
-
-type TypeCondition = NamedType
-
--- * Values
-
-data Value = ValueVariable Variable
-           | ValueInt Int
-           | ValueFloat Float
-           | ValueString Text
-           | ValueBoolean Bool
-           | ValueEnum Name
-           | ValueList ListValue
-           | ValueObject ObjectValue
-             deriving (Eq,Show)
-
-newtype ListValue = ListValue [Value] deriving (Eq,Show)
-
-newtype ObjectValue = ObjectValue [ObjectField] deriving (Eq,Show)
-
-data ObjectField = ObjectField Name Value deriving (Eq,Show)
-
-type DefaultValue = Value
-
--- * Directives
-
-data Directive = Directive Name (Maybe [Argument]) deriving (Eq,Show)
-
--- * Type Reference
-
-data Type = TypeNamed NamedType
-          | TypeList ListType
-          | TypeNonNull NonNullType
-            deriving (Eq,Show)
-
-newtype NamedType = NamedType Name deriving (Eq,Show)
-
-newtype ListType = ListType Type deriving (Eq,Show)
-
-data NonNullType = NonNullTypeNamed NamedType
-                 | NonNullTypeList  ListType
-                   deriving (Eq,Show)
-
--- * Type definition
-
-data TypeDefinition = TypeDefinitionObject        ObjectTypeDefinition
-                    | TypeDefinitionInterface     InterfaceTypeDefinition
-                    | TypeDefinitionUnion         UnionTypeDefinition
-                    | TypeDefinitionScalar        ScalarTypeDefinition
-                    | TypeDefinitionEnum          EnumTypeDefinition
-                    | TypeDefinitionInputObject   InputObjectTypeDefinition
-                    | TypeDefinitionTypeExtension TypeExtensionDefinition
-                      deriving (Eq,Show)
-
-data ObjectTypeDefinition = ObjectTypeDefinition Name (Maybe Interfaces) [FieldDefinition]
-                            deriving (Eq,Show)
-
-type Interfaces = [NamedType]
-
-data FieldDefinition = FieldDefinition Name [InputValueDefinition]
-                       deriving (Eq,Show)
-
-data InputValueDefinition = InputValueDefinition Name Type (Maybe DefaultValue)
-                            deriving (Eq,Show)
-
-data InterfaceTypeDefinition = InterfaceTypeDefinition Name [FieldDefinition]
-                               deriving (Eq,Show)
-
-data UnionTypeDefinition = UnionTypeDefinition Name [NamedType]
-                           deriving (Eq,Show)
-
-data ScalarTypeDefinition = ScalarTypeDefinition Name
-                            deriving (Eq,Show)
-
-data EnumTypeDefinition = EnumTypeDefinition Name [EnumValueDefinition]
-                          deriving (Eq,Show)
-
-newtype EnumValueDefinition = EnumValueDefinition Name
-                              deriving (Eq,Show)
-
-data InputObjectTypeDefinition = InputObjectTypeDefinition Name [InputValueDefinition]
-                                 deriving (Eq,Show)
-
-newtype TypeExtensionDefinition = TypeExtensionDefinition ObjectTypeDefinition
-                                  deriving (Eq,Show)

LICENSE

@@ -1,4 +1,5 @@
-Copyright J. Daniel Navarro (c) 2015
+Copyright 2019 Eugen Wissner, Germany
+Copyright 2015-2017 J. Daniel Navarro
 
 All rights reserved.
 

README.md

@@ -1,22 +1,41 @@
 # 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)
+[![License](https://img.shields.io/badge/license-BSD--3--Clause-blue.svg)](https://raw.githubusercontent.com/caraus-ecms/graphql/master/LICENSE)
 
-For now this only provides the data types to represent the GraphQL AST,
-but the idea is to be a Haskell port of
-[`graphql-js`](https://github.com/graphql/graphql-js). Next releases
-should include:
+GraphQL implementation in Haskell.
 
-- [ ] Parser for the GraphQL language.
-- [ ] Data types for the GraphQL Schema language.
-- [ ] Parser for the GraphQL Schema language.
-- [ ] Interpreter of GraphQL requests.
-- [ ] Utilities to define GraphQL types and schema.
+This implementation is relatively low-level by design, it doesn't provide any
+mappings between the GraphQL types and Haskell's type system and avoids
+compile-time magic. It focuses on flexibility instead instead, so other
+solutions can be built on top of it.
+
+## State of the work
+
+For now this only provides a parser and a printer for the GraphQL query
+language and allows to execute queries and mutations without the schema
+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
+"[not implemented](https://github.com/caraus-ecms/graphql/labels/not%20implemented)".
+
+## Documentation
+
+API documentation is available through
+[hackage](https://hackage.haskell.org/package/graphql).
+
+You'll also find a small tutorial with some examples under
+[docs/tutorial](https://github.com/caraus-ecms/graphql/tree/master/docs/tutorial).
 
 ## Contact
 
 Suggestions, contributions and bug reports are welcome.
 
-Feel free to contact me, jdnavarro, on the #haskell channel on the
-[GraphQL Slack Server](https://graphql.slack.com). You can obtain an
+Should you have questions on usage, please open an issue and ask – this helps
+to write useful documentation.
+
+Feel free to contact on Slack in [#haskell on
+GraphQL](https://graphql.slack.com/messages/haskell/). You can obtain an
 invitation [here](https://graphql-slack.herokuapp.com/).

TODO

@@ -1,3 +0,0 @@
-- Data type accessors
-- Deal with Location
-- Deal with Strictness/unboxing

docs/tutorial/tutorial.lhs

@@ -0,0 +1,154 @@
+---
+title: GraphQL Haskell Tutorial
+---
+
+
+== Getting started ==
+
+Welcome to graphql-haskell!
+
+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.
+
+> {-# LANGUAGE OverloadedStrings #-}
+> {-# LANGUAGE LambdaCase #-}
+> module Main where
+>
+> import Control.Monad.IO.Class (liftIO)
+> import Control.Monad.Trans.Except (throwE)
+> import Data.Aeson (encode)
+> import Data.ByteString.Lazy.Char8 (putStrLn)
+> import Data.List.NonEmpty (NonEmpty(..))
+> import Data.Text (Text)
+> import Data.Time (getCurrentTime)
+>
+> import Language.GraphQL
+> import Language.GraphQL.Schema (Schema)
+> import qualified Language.GraphQL.Schema as Schema
+> import Language.GraphQL.Trans (ActionT(..))
+>
+> import Prelude hiding (putStrLn)
+
+=== First example ===
+
+Now, as our first example, we are going to look at the
+example from [graphql.js](https://github.com/graphql/graphql-js).
+
+First we build a GraphQL schema.
+
+> schema1 :: Schema IO
+> schema1 = hello :| []
+>
+> hello :: Schema.Resolver IO
+> hello = Schema.scalar "hello" (return ("it's me" :: Text))
+
+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
+
+This runs the query by fetching the one field defined,
+returning
+
+```{"data" : {"hello":"it's me"}}```
+
+
+
+=== Monadic actions ===
+
+For this example, we're going to be using time.
+
+> schema2 :: Schema IO
+> schema2 = time :| []
+>
+> time :: Schema.Resolver IO
+> time = Schema.scalarA "time" $ \case
+>   [] -> do t <- liftIO getCurrentTime
+>            return $ show t
+>   _ -> ActionT $ throwE "Invalid arguments."
+
+This defines a simple schema with one type and one field,
+which resolves to the current time.
+
+Next we define our query.
+
+> query2 :: Text
+> query2 = "{ time }"
+>
+> main2 :: IO ()
+> main2 = putStrLn =<< encode <$> graphql schema2 query2
+
+This runs the query, returning the current time
+
+```{"data": {"time":"2016-03-08 23:28:14.546899 UTC"}}```
+
+
+=== Errors ===
+
+Errors are handled according to the spec,
+with fields that cause erros being resolved to `null`,
+and an error being added to the error list.
+
+An example of this is the following query:
+
+> queryShouldFail :: Text
+> queryShouldFail = "{ boyhowdy }"
+
+Since there is no `boyhowdy` field in our schema, it will not resolve,
+and the query will fail, as we can see in the following example.
+
+> mainShouldFail :: IO ()
+> mainShouldFail = do
+>   success <- graphql schema1 query1
+>   putStrLn $ encode success
+>   putStrLn "This will fail"
+>   failure <- graphql schema1 queryShouldFail
+>   putStrLn $ encode failure
+>
+
+This outputs:
+
+```
+{"data": {"hello": "it's me"}}
+This will fail
+{"data": {"boyhowdy": null}, "errors":[{"message": "the field boyhowdy did not resolve."}]}
+```
+
+=== Combining resolvers ===
+
+Now that we have two resolvers, we can define a schema which uses them both.
+
+> schema3 :: Schema IO
+> schema3 = hello :| [time]
+>
+> query3 :: Text
+> query3 = "query timeAndHello { time hello }"
+>
+> main3 :: IO ()
+> main3 = putStrLn =<< encode <$> graphql schema3 query3
+
+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.
+
+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,
+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

graphql.cabal

@@ -1,27 +1,91 @@
-name:                graphql
-version:             0.1
-synopsis:            GraphQL Haskell implementation
-description:
-  For now this package provides the data types for the GraphQL language.
-  Further releases will cover more aspects of the GraphQL specification.
-homepage:            https://github.com/jdnavarro/graphql-haskell
-bug-reports:         https://github.com/jdnavarro/graphql-haskell/issues
-license:             BSD3
-license-file:        LICENSE
-author:              Danny Navarro
-maintainer:          j@dannynavarro.net
-copyright:           Copyright (C) 2015 J. Daniel Navarro
-category:            Web
-build-type:          Simple
-extra-source-files:  README.md CHANGELOG.md stack.yaml
-cabal-version:       >=1.10
+cabal-version: 1.12
 
-library
-  exposed-modules:     Data.GraphQL
-  build-depends:       base >= 4.7 && < 5,
-                       text >=0.11.3.1
-  default-language:    Haskell2010
+-- This file has been generated from package.yaml by hpack version 0.31.2.
+--
+-- see: https://github.com/sol/hpack
+--
+-- hash: 6598c2424405b7a92a4672ad7d1a4e8ad768ea47bf3ed0c3c5ae51bac8730301
+
+name:           graphql
+version:        0.5.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 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: git://github.com/jdnavarro/graphql-haskell.git
+  type: git
+  location: https://github.com/caraus-ecms/graphql
+
+library
+  exposed-modules:
+      Language.GraphQL
+      Language.GraphQL.AST
+      Language.GraphQL.AST.Core
+      Language.GraphQL.AST.Transform
+      Language.GraphQL.Encoder
+      Language.GraphQL.Error
+      Language.GraphQL.Execute
+      Language.GraphQL.Lexer
+      Language.GraphQL.Parser
+      Language.GraphQL.Schema
+      Language.GraphQL.Trans
+      Language.GraphQL.Type
+  other-modules:
+      Paths_graphql
+  hs-source-dirs:
+      src
+  build-depends:
+      aeson
+    , base >=4.7 && <5
+    , megaparsec
+    , text
+    , transformers
+    , unordered-containers
+  default-language: Haskell2010
+
+test-suite tasty
+  type: exitcode-stdio-1.0
+  main-is: Spec.hs
+  other-modules:
+      Language.GraphQL.EncoderSpec
+      Language.GraphQL.ErrorSpec
+      Language.GraphQL.LexerSpec
+      Language.GraphQL.ParserSpec
+      Test.KitchenSinkSpec
+      Test.StarWars.Data
+      Test.StarWars.QuerySpec
+      Test.StarWars.Schema
+      Paths_graphql
+  hs-source-dirs:
+      tests
+  ghc-options: -threaded -rtsopts -with-rtsopts=-N
+  build-depends:
+      aeson
+    , base >=4.7 && <5
+    , graphql
+    , hspec
+    , hspec-expectations
+    , megaparsec
+    , raw-strings-qq
+    , text
+    , transformers
+  default-language: Haskell2010

package.yaml

@@ -0,0 +1,52 @@
+name:                graphql
+version:             0.5.0.0
+synopsis:            Haskell GraphQL implementation
+description:
+  This package provides a rudimentary parser for the
+  <https://graphql.github.io/graphql-spec/June2018/ GraphQL> language.
+maintainer:          belka@caraus.de
+github:              caraus-ecms/graphql
+category:            Language
+copyright:
+- (c) 2019 Eugen Wissner
+- (c) 2015-2017 J. Daniel Navarro
+author:
+- Danny Navarro <j@dannynavarro.net>
+- Matthías Páll Gissurarson <mpg@mpg.is>
+- Sólrún Halla Einarsdóttir <she@mpg.is>
+
+extra-source-files:
+- CHANGELOG.md
+- README.md
+- LICENSE
+- docs/tutorial/tutorial.lhs
+
+data-files:
+- tests/data/*.graphql
+- tests/data/*.min.graphql
+
+dependencies:
+- aeson
+- base >= 4.7 && < 5
+- megaparsec
+- text
+- transformers
+
+library:
+  source-dirs: src
+  dependencies:
+  - unordered-containers
+
+tests:
+  tasty:
+    main: Spec.hs
+    source-dirs: tests
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    dependencies:
+    - graphql
+    - hspec
+    - hspec-expectations
+    - raw-strings-qq

semaphoreci.sh

@@ -0,0 +1,33 @@
+#!/bin/bash
+
+STACK=$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
+	$STACK --no-terminal setup
+}
+
+setup_test() {
+	$STACK --no-terminal test --only-snapshot
+}
+
+test() {
+	$STACK --no-terminal test --pedantic
+}
+
+test_docs() {
+	$STACK --no-terminal ghc -- -Wall -fno-code docs/tutorial/tutorial.lhs
+}
+
+setup_lint() {
+	$STACK --no-terminal install hlint
+}
+
+lint() {
+	$STACK --no-terminal exec hlint -- src tests
+}
+
+$1

src/Language/GraphQL.hs

@@ -0,0 +1,36 @@
+-- | This module provides the functions to parse and execute @GraphQL@ queries.
+module Language.GraphQL
+    ( graphql
+    , graphqlSubs
+    ) where
+
+import Control.Monad.IO.Class (MonadIO)
+import qualified Data.Text as T
+
+import qualified Data.Aeson as Aeson
+import Text.Megaparsec (parse)
+
+import Language.GraphQL.Execute
+import Language.GraphQL.Parser
+import Language.GraphQL.Schema
+
+import Language.GraphQL.Error
+
+-- | Takes a 'Schema' and text representing a @GraphQL@ request document.
+--   If the text parses correctly as a @GraphQL@ query the query is
+--   executed according to the given 'Schema'.
+--
+--   Returns the response as an @Aeson.@'Aeson.Value'.
+graphql :: MonadIO m => Schema m -> T.Text -> m Aeson.Value
+graphql = flip graphqlSubs $ const Nothing
+
+-- | Takes a 'Schema', a variable substitution function and text
+--   representing a @GraphQL@ request document.  If the text parses
+--   correctly as a @GraphQL@ query the substitution is applied to the
+--   query and the query is then executed according to the given 'Schema'.
+--
+--   Returns the response as an @Aeson.@'Aeson.Value'.
+graphqlSubs :: MonadIO m => Schema m -> Subs -> T.Text -> m Aeson.Value
+graphqlSubs schema f =
+    either parseError (execute schema f)
+    . parse document ""

src/Language/GraphQL/AST.hs

@@ -0,0 +1,134 @@
+-- | This module defines an abstract syntax tree for the @GraphQL@ language based on
+--   <https://facebook.github.io/graphql/ Facebook's GraphQL Specification>.
+--
+-- Target AST for Parser.
+module Language.GraphQL.AST
+    ( Alias
+    , Argument(..)
+    , Arguments
+    , Definition(..)
+    , Directive(..)
+    , Directives
+    , Document
+    , Field(..)
+    , FragmentDefinition(..)
+    , FragmentName
+    , FragmentSpread(..)
+    , InlineFragment(..)
+    , Name
+    , NonNullType(..)
+    , ObjectField(..)
+    , OperationDefinition(..)
+    , OperationType(..)
+    , Selection(..)
+    , SelectionSet
+    , SelectionSetOpt
+    , Type(..)
+    , TypeCondition
+    , Value(..)
+    , VariableDefinition(..)
+    , VariableDefinitions
+    ) where
+
+import Data.Int (Int32)
+import Data.List.NonEmpty (NonEmpty)
+import Data.Text (Text)
+import Language.GraphQL.AST.Core ( Alias
+                                 , Name
+                                 )
+
+-- * Document
+
+type Document = NonEmpty Definition
+
+-- * Operations
+
+data Definition = DefinitionOperation OperationDefinition
+                | DefinitionFragment  FragmentDefinition
+                  deriving (Eq,Show)
+
+data OperationDefinition = OperationSelectionSet SelectionSet
+                         | OperationDefinition   OperationType
+                                                 (Maybe Name)
+                                                 VariableDefinitions
+                                                 Directives
+                                                 SelectionSet
+                           deriving (Eq,Show)
+
+data OperationType = Query | Mutation deriving (Eq,Show)
+
+-- * SelectionSet
+
+type SelectionSet = NonEmpty Selection
+
+type SelectionSetOpt = [Selection]
+
+data Selection = SelectionField          Field
+               | SelectionFragmentSpread FragmentSpread
+               | SelectionInlineFragment InlineFragment
+                 deriving (Eq,Show)
+
+-- * Field
+
+data Field = Field (Maybe Alias) Name Arguments Directives SelectionSetOpt
+             deriving (Eq,Show)
+
+-- * Arguments
+
+type Arguments = [Argument]
+
+data Argument = Argument Name Value deriving (Eq,Show)
+
+-- * Fragments
+
+data FragmentSpread = FragmentSpread Name Directives deriving (Eq,Show)
+
+data InlineFragment = InlineFragment (Maybe TypeCondition) Directives SelectionSet
+                      deriving (Eq,Show)
+
+data FragmentDefinition =
+  FragmentDefinition FragmentName TypeCondition Directives SelectionSet
+  deriving (Eq,Show)
+
+type FragmentName = Name
+
+type TypeCondition = Name
+
+-- * Input values
+
+data Value = ValueVariable Name
+           | ValueInt Int32
+           | ValueFloat Double
+           | ValueString Text
+           | ValueBoolean Bool
+           | ValueNull
+           | ValueEnum Name
+           | ValueList [Value]
+           | ValueObject [ObjectField]
+           deriving (Eq, Show)
+
+data ObjectField = ObjectField Name Value deriving (Eq, Show)
+
+-- * Variables
+
+type VariableDefinitions = [VariableDefinition]
+
+data VariableDefinition = VariableDefinition Name Type (Maybe Value)
+                          deriving (Eq,Show)
+
+-- * Input types
+
+data Type = TypeNamed   Name
+          | TypeList    Type
+          | TypeNonNull NonNullType
+            deriving (Eq,Show)
+
+data NonNullType = NonNullTypeNamed Name
+                 | NonNullTypeList  Type
+                   deriving (Eq,Show)
+
+-- * Directives
+
+type Directives = [Directive]
+
+data Directive = Directive Name [Argument] deriving (Eq,Show)

src/Language/GraphQL/AST/Core.hs

@@ -0,0 +1,48 @@
+-- | This is the AST meant to be executed.
+module Language.GraphQL.AST.Core
+    ( Alias
+    , Argument(..)
+    , Document
+    , Field(..)
+    , Name
+    , ObjectField(..)
+    , Operation(..)
+    , Value(..)
+    ) where
+
+import Data.Int (Int32)
+import Data.List.NonEmpty (NonEmpty)
+import Data.String
+
+import Data.Text (Text)
+
+-- | Name
+type Name = Text
+
+type Document = NonEmpty Operation
+
+data Operation = Query (Maybe Text) (NonEmpty Field)
+               | Mutation (Maybe Text) (NonEmpty Field)
+                 deriving (Eq,Show)
+
+data Field = Field (Maybe Alias) Name [Argument] [Field] deriving (Eq,Show)
+
+type Alias = Name
+
+data Argument = Argument Name Value deriving (Eq,Show)
+
+data Value = ValueInt Int32
+           -- GraphQL Float is double precision
+           | ValueFloat Double
+           | ValueString Text
+           | ValueBoolean Bool
+           | ValueNull
+           | ValueEnum Name
+           | ValueList [Value]
+           | ValueObject [ObjectField]
+             deriving (Eq,Show)
+
+instance IsString Value where
+  fromString = ValueString . fromString
+
+data ObjectField = ObjectField Name Value deriving (Eq,Show)

src/Language/GraphQL/AST/Transform.hs

@@ -0,0 +1,119 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Language.GraphQL.AST.Transform
+    ( document
+    ) where
+
+import Control.Applicative (empty)
+import Control.Monad ((<=<))
+import Data.Bifunctor (first)
+import Data.Either (partitionEithers)
+import Data.Foldable (fold, foldMap)
+import qualified Data.List.NonEmpty as NonEmpty
+import Data.Monoid (Alt(Alt,getAlt), (<>))
+import qualified Language.GraphQL.AST as Full
+import qualified Language.GraphQL.AST.Core as Core
+import qualified Language.GraphQL.Schema as Schema
+
+-- | Replaces a fragment name by a list of 'Field'. If the name doesn't match an
+--   empty list is returned.
+type Fragmenter = Core.Name -> [Core.Field]
+
+-- TODO: Replace Maybe by MonadThrow with CustomError
+document :: Schema.Subs -> Full.Document -> Maybe Core.Document
+document subs doc = operations subs fr ops
+  where
+    (fr, ops) = first foldFrags
+              . partitionEithers
+              . NonEmpty.toList
+              $ defrag subs
+            <$> doc
+
+    foldFrags :: [Fragmenter] -> Fragmenter
+    foldFrags fs n = getAlt $ foldMap (Alt . ($ n)) fs
+
+-- * Operation
+
+-- TODO: Replace Maybe by MonadThrow CustomError
+operations
+  :: Schema.Subs
+  -> Fragmenter
+  -> [Full.OperationDefinition]
+  -> Maybe Core.Document
+operations subs fr = NonEmpty.nonEmpty <=< traverse (operation subs fr)
+
+operation
+  :: Schema.Subs
+  -> Fragmenter
+  -> Full.OperationDefinition
+  -> Maybe Core.Operation
+operation subs fr (Full.OperationSelectionSet sels) =
+  operation subs fr $ Full.OperationDefinition Full.Query empty empty empty sels
+-- TODO: Validate Variable definitions with substituter
+operation subs fr (Full.OperationDefinition operationType name _vars _dirs sels)
+    = case operationType of
+        Full.Query -> Core.Query name <$> node
+        Full.Mutation -> Core.Mutation name <$> node
+  where
+    node = traverse (hush . selection subs fr) sels
+
+selection
+  :: Schema.Subs
+  -> Fragmenter
+  -> Full.Selection
+  -> Either [Core.Field] Core.Field
+selection subs fr (Full.SelectionField fld) =
+  Right $ field subs fr fld
+selection _    fr (Full.SelectionFragmentSpread (Full.FragmentSpread n _dirs)) =
+  Left $ fr n
+selection _ _  (Full.SelectionInlineFragment _)  =
+  error "Inline fragments not supported yet"
+
+-- * Fragment replacement
+
+-- | Extract Fragments into a single Fragmenter function and a Operation
+--   Definition.
+defrag
+  :: Schema.Subs
+  -> Full.Definition
+  -> Either Fragmenter Full.OperationDefinition
+defrag _    (Full.DefinitionOperation op) =
+  Right op
+defrag subs (Full.DefinitionFragment fragDef) =
+  Left $ fragmentDefinition subs fragDef
+
+fragmentDefinition :: Schema.Subs -> Full.FragmentDefinition -> Fragmenter
+fragmentDefinition subs (Full.FragmentDefinition name _tc _dirs sels) name' =
+  -- TODO: Support fragments within fragments. Fold instead of map.
+  if name == name'
+  then either id pure =<< NonEmpty.toList (selection subs mempty <$> sels)
+  else empty
+
+field :: Schema.Subs -> Fragmenter -> Full.Field -> Core.Field
+field subs fr (Full.Field a n args _dirs sels) =
+    Core.Field a n (fold $ argument subs `traverse` args) (foldr go empty sels)
+  where
+    go :: Full.Selection -> [Core.Field] -> [Core.Field]
+    go (Full.SelectionFragmentSpread (Full.FragmentSpread name _dirs)) = (fr name <>)
+    go sel =  (either id pure (selection subs fr sel) <>)
+
+argument :: Schema.Subs -> Full.Argument -> Maybe Core.Argument
+argument subs (Full.Argument n v) = Core.Argument n <$> value subs v
+
+value :: Schema.Subs -> Full.Value -> Maybe Core.Value
+value subs (Full.ValueVariable n) = subs n
+value _    (Full.ValueInt      i) = pure $ Core.ValueInt i
+value _    (Full.ValueFloat    f) = pure $ Core.ValueFloat f
+value _    (Full.ValueString   x) = pure $ Core.ValueString x
+value _    (Full.ValueBoolean  b) = pure $ Core.ValueBoolean b
+value _     Full.ValueNull        = pure   Core.ValueNull
+value _    (Full.ValueEnum     e) = pure $ Core.ValueEnum e
+value subs (Full.ValueList     l) =
+  Core.ValueList   <$> traverse (value subs) l
+value subs (Full.ValueObject   o) =
+  Core.ValueObject <$> traverse (objectField subs) o
+
+objectField :: Schema.Subs -> Full.ObjectField -> Maybe Core.ObjectField
+objectField subs (Full.ObjectField n v) = Core.ObjectField n <$> value subs v
+
+hush :: Either a b -> Maybe b
+hush = either (const Nothing) Just

src/Language/GraphQL/Encoder.hs

@@ -0,0 +1,277 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ExplicitForAll #-}
+
+-- | This module defines a minifier and a printer for the @GraphQL@ language.
+module Language.GraphQL.Encoder
+    ( Formatter
+    , definition
+    , directive
+    , document
+    , minified
+    , pretty
+    , type'
+    , value
+    ) where
+
+import Data.Foldable (fold)
+import Data.Monoid ((<>))
+import qualified Data.List.NonEmpty as NonEmpty (toList)
+import Data.Text.Lazy (Text)
+import qualified Data.Text.Lazy as Text.Lazy
+import Data.Text.Lazy.Builder (toLazyText)
+import Data.Text.Lazy.Builder.Int (decimal)
+import Data.Text.Lazy.Builder.RealFloat (realFloat)
+import Language.GraphQL.AST
+
+-- | Instructs the encoder whether a GraphQL should be minified or pretty
+--   printed.
+--   
+--   Use 'pretty' and 'minified' to construct the formatter.
+data Formatter
+    = Minified
+    | Pretty Word
+
+-- Constructs a formatter for pretty printing.
+pretty :: Formatter
+pretty = Pretty 0
+
+-- Constructs a formatter for minifying.
+minified :: Formatter
+minified = Minified
+
+-- | Converts a 'Document' into a string.
+document :: Formatter -> Document -> Text
+document formatter defs
+    | Pretty _ <- formatter = Text.Lazy.intercalate "\n" encodeDocument
+    | Minified <-formatter = Text.Lazy.snoc (mconcat encodeDocument) '\n'
+  where
+    encodeDocument = NonEmpty.toList $ definition formatter <$> defs
+
+-- | Converts a 'Definition' into a string.
+definition :: Formatter -> Definition -> Text
+definition formatter x
+    | Pretty _ <- formatter = Text.Lazy.snoc (encodeDefinition x) '\n'
+    | Minified <- formatter = encodeDefinition x
+  where
+    encodeDefinition (DefinitionOperation operation)
+        = operationDefinition formatter operation
+    encodeDefinition (DefinitionFragment fragment)
+        = fragmentDefinition formatter fragment
+
+operationDefinition :: Formatter -> OperationDefinition -> Text
+operationDefinition formatter (OperationSelectionSet sels)
+    = selectionSet formatter sels
+operationDefinition formatter (OperationDefinition Query name vars dirs sels)
+    = "query " <> node formatter name vars dirs sels
+operationDefinition formatter (OperationDefinition Mutation name vars dirs sels)
+    = "mutation " <> node formatter name vars dirs sels
+
+node :: Formatter
+     -> Maybe Name
+     -> VariableDefinitions
+     -> Directives
+     -> SelectionSet
+     -> Text
+node formatter name vars dirs sels
+    = Text.Lazy.fromStrict (fold name)
+    <> optempty (variableDefinitions formatter) vars
+    <> optempty (directives formatter) dirs
+    <> eitherFormat formatter " " mempty
+    <> selectionSet formatter sels
+
+variableDefinitions :: Formatter -> [VariableDefinition] -> Text
+variableDefinitions formatter
+    = parensCommas formatter $ variableDefinition formatter
+
+variableDefinition :: Formatter -> VariableDefinition -> Text
+variableDefinition formatter (VariableDefinition var ty dv)
+    = variable var
+    <> eitherFormat formatter ": " ":"
+    <> type' ty
+    <> maybe mempty (defaultValue formatter) dv
+
+defaultValue :: Formatter -> Value -> Text
+defaultValue formatter val
+    = eitherFormat formatter " = " "="
+    <> value formatter val
+
+variable :: Name -> Text
+variable var = "$" <> Text.Lazy.fromStrict var
+
+selectionSet :: Formatter -> SelectionSet -> Text
+selectionSet formatter
+    = bracesList formatter (selection formatter)
+    . NonEmpty.toList
+
+selectionSetOpt :: Formatter -> SelectionSetOpt -> Text
+selectionSetOpt formatter = bracesList formatter $ selection formatter
+
+selection :: Formatter -> Selection -> Text
+selection formatter = Text.Lazy.append indent . f
+  where
+    f (SelectionField x) = field incrementIndent x
+    f (SelectionInlineFragment x) = inlineFragment incrementIndent x
+    f (SelectionFragmentSpread x) = fragmentSpread incrementIndent x
+    incrementIndent
+        | Pretty n <- formatter = Pretty $ n + 1
+        | otherwise = Minified
+    indent
+        | Pretty n <- formatter = Text.Lazy.replicate (fromIntegral $ n + 1) "  "
+        | otherwise = mempty
+
+field :: Formatter -> Field -> Text
+field formatter (Field alias name args dirs selso)
+    = optempty (`Text.Lazy.append` colon) (Text.Lazy.fromStrict $ fold alias)
+    <> Text.Lazy.fromStrict name
+    <> optempty (arguments formatter) args
+    <> optempty (directives formatter) dirs
+    <> selectionSetOpt'
+  where
+    colon = eitherFormat formatter ": " ":"
+    selectionSetOpt'
+        | null selso = mempty
+        | otherwise = eitherFormat formatter " " mempty <> selectionSetOpt formatter selso
+
+arguments :: Formatter -> [Argument] -> Text
+arguments formatter = parensCommas formatter $ argument formatter
+
+argument :: Formatter -> Argument -> Text
+argument formatter (Argument name v)
+    = Text.Lazy.fromStrict name
+    <> eitherFormat formatter ": " ":"
+    <> value formatter v
+
+-- * Fragments
+
+fragmentSpread :: Formatter -> FragmentSpread -> Text
+fragmentSpread formatter (FragmentSpread name ds)
+    = "..." <> Text.Lazy.fromStrict name <> optempty (directives formatter) ds
+
+inlineFragment :: Formatter -> InlineFragment -> Text
+inlineFragment formatter (InlineFragment tc dirs sels)
+    = "... on "
+    <> Text.Lazy.fromStrict (fold tc)
+    <> directives formatter dirs
+    <> eitherFormat formatter " " mempty
+    <> selectionSet formatter sels
+
+fragmentDefinition :: Formatter -> FragmentDefinition -> Text
+fragmentDefinition formatter (FragmentDefinition name tc dirs sels)
+    = "fragment " <> Text.Lazy.fromStrict name
+    <> " on " <> Text.Lazy.fromStrict tc
+    <> optempty (directives formatter) dirs
+    <> eitherFormat formatter " " mempty
+    <> selectionSet formatter sels
+
+-- * Miscellaneous
+
+-- | Converts a 'Directive' into a string.
+directive :: Formatter -> Directive -> Text
+directive formatter (Directive name args)
+    = "@" <> Text.Lazy.fromStrict name <> optempty (arguments formatter) args
+
+directives :: Formatter -> Directives -> Text
+directives formatter@(Pretty _) = Text.Lazy.cons ' ' . spaces (directive formatter)
+directives Minified = spaces (directive Minified)
+
+-- | Converts a 'Value' into a string.
+value :: Formatter -> Value -> Text
+value _ (ValueVariable x) = variable x
+value _ (ValueInt x) = toLazyText $ decimal x
+value _ (ValueFloat x) = toLazyText $ realFloat x
+value _ (ValueBoolean  x) = booleanValue x
+value _ ValueNull = mempty
+value _ (ValueString x) = stringValue $ Text.Lazy.fromStrict x
+value _ (ValueEnum x) = Text.Lazy.fromStrict x
+value formatter (ValueList x) = listValue formatter x
+value formatter (ValueObject x) = objectValue formatter x
+
+booleanValue :: Bool -> Text
+booleanValue True  = "true"
+booleanValue False = "false"
+
+stringValue :: Text -> Text
+stringValue
+    = quotes
+    . Text.Lazy.replace "\"" "\\\""
+    . Text.Lazy.replace "\\" "\\\\"
+
+listValue :: Formatter -> [Value] -> Text
+listValue formatter = bracketsCommas formatter $ value formatter
+
+objectValue :: Formatter -> [ObjectField] -> Text
+objectValue formatter = intercalate $ objectField formatter
+  where
+    intercalate f
+        = braces
+        . Text.Lazy.intercalate (eitherFormat formatter ", " ",")
+        . fmap f
+
+
+objectField :: Formatter -> ObjectField -> Text
+objectField formatter (ObjectField name v)
+    = Text.Lazy.fromStrict name <> colon <> value formatter v
+  where
+    colon
+      | Pretty _ <- formatter = ": "
+      | Minified <- formatter = ":"
+
+-- | Converts a 'Type' a type into a string.
+type' :: Type -> Text
+type' (TypeNamed   x) = Text.Lazy.fromStrict x
+type' (TypeList    x) = listType x
+type' (TypeNonNull x) = nonNullType x
+
+listType :: Type -> Text
+listType x = brackets (type' x)
+
+nonNullType :: NonNullType -> Text
+nonNullType (NonNullTypeNamed x) = Text.Lazy.fromStrict x <> "!"
+nonNullType (NonNullTypeList  x) = listType x <> "!"
+
+-- * Internal
+
+between :: Char -> Char -> Text -> Text
+between open close = Text.Lazy.cons open . (`Text.Lazy.snoc` close)
+
+parens :: Text -> Text
+parens = between '(' ')'
+
+brackets :: Text -> Text
+brackets = between '[' ']'
+
+braces :: Text -> Text
+braces = between '{' '}'
+
+quotes :: Text -> Text
+quotes = between '"' '"'
+
+spaces :: forall a. (a -> Text) -> [a] -> Text
+spaces f = Text.Lazy.intercalate "\SP" . fmap f
+
+parensCommas :: forall a. Formatter -> (a -> Text) -> [a] -> Text
+parensCommas formatter f
+    = parens
+    . Text.Lazy.intercalate (eitherFormat formatter ", " ",")
+    . fmap f
+
+bracketsCommas :: Formatter -> (a -> Text) -> [a] -> Text
+bracketsCommas formatter f
+    = brackets
+    . Text.Lazy.intercalate (eitherFormat formatter ", " ",")
+    . fmap f
+
+bracesList :: forall a. Formatter -> (a -> Text) -> [a] -> Text
+bracesList (Pretty intendation) f xs
+    = Text.Lazy.snoc (Text.Lazy.intercalate "\n" content) '\n'
+    <> (Text.Lazy.snoc $ Text.Lazy.replicate (fromIntegral intendation) "  ") '}'
+  where
+    content = "{" : fmap f xs
+bracesList Minified f xs = braces $ Text.Lazy.intercalate "," $ fmap f xs
+
+optempty :: (Eq a, Monoid a, Monoid b) => (a -> b) -> a -> b
+optempty f xs = if xs == mempty then mempty else f xs
+
+eitherFormat :: forall a. Formatter -> a -> a -> a
+eitherFormat (Pretty _) x _ = x
+eitherFormat Minified _ x = x

src/Language/GraphQL/Error.hs

@@ -0,0 +1,83 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+module Language.GraphQL.Error
+    ( parseError
+    , CollectErrsT
+    , addErr
+    , addErrMsg
+    , runCollectErrs
+    , runAppendErrs
+    , singleError
+    ) where
+
+import qualified Data.Aeson as Aeson
+import Data.Text (Text)
+import Data.Void (Void)
+import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.State ( StateT
+                                 , modify
+                                 , runStateT
+                                 )
+import Text.Megaparsec ( ParseErrorBundle(..)
+                       , SourcePos(..)
+                       , errorOffset
+                       , parseErrorTextPretty
+                       , reachOffset
+                       , unPos
+                       )
+
+-- | Wraps a parse error into a list of errors.
+parseError :: Applicative f => ParseErrorBundle Text Void -> f Aeson.Value
+parseError ParseErrorBundle{..}  =
+  pure $ Aeson.object [("errors", Aeson.toJSON $ fst $ foldl go ([], bundlePosState) bundleErrors)]
+  where
+    errorObject s SourcePos{..} = Aeson.object
+        [ ("message", Aeson.toJSON $ init $ parseErrorTextPretty s)
+        , ("line", Aeson.toJSON $ unPos sourceLine)
+        , ("column", Aeson.toJSON $ unPos sourceColumn)
+        ]
+    go (result, state) x =
+        let (sourcePosition, _, newState) = reachOffset (errorOffset x) state
+         in (errorObject x sourcePosition : result, newState)
+
+-- | A wrapper to pass error messages around.
+type CollectErrsT m = StateT [Aeson.Value] m
+
+-- | Adds an error to the list of errors.
+addErr :: Monad m => Aeson.Value -> CollectErrsT m ()
+addErr v = modify (v :)
+
+makeErrorMessage :: Text -> Aeson.Value
+makeErrorMessage s = Aeson.object [("message", Aeson.toJSON s)]
+
+-- | Constructs a response object containing only the error with the given
+--   message.
+singleError :: Text -> Aeson.Value
+singleError message = Aeson.object
+    [ ("errors", Aeson.toJSON [makeErrorMessage message])
+    ]
+
+-- | Convenience function for just wrapping an error message.
+addErrMsg :: Monad m => Text -> CollectErrsT m ()
+addErrMsg = addErr . makeErrorMessage
+
+-- | Appends the given list of errors to the current list of errors.
+appendErrs :: Monad m => [Aeson.Value] -> CollectErrsT m ()
+appendErrs errs = modify (errs ++)
+
+-- | 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 res = do
+    (dat, errs) <- runStateT res []
+    if null errs
+       then return $ Aeson.object [("data", dat)]
+       else return $ Aeson.object [("data", dat), ("errors", Aeson.toJSON $ reverse errs)]
+
+-- | Runs the given computation, collecting the errors and appending them
+--   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

@@ -0,0 +1,72 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | This module provides the function to execute a @GraphQL@ request --
+--   according to a 'Schema'.
+module Language.GraphQL.Execute
+    ( execute
+    , executeWithName
+    ) where
+
+import Control.Monad.IO.Class (MonadIO)
+import qualified Data.Aeson as Aeson
+import qualified Data.List.NonEmpty as NE
+import Data.List.NonEmpty (NonEmpty((:|)))
+import Data.Text (Text)
+import qualified Data.Text as Text
+import qualified Language.GraphQL.AST as AST
+import qualified Language.GraphQL.AST.Core as AST.Core
+import qualified Language.GraphQL.AST.Transform as Transform
+import Language.GraphQL.Error
+import Language.GraphQL.Schema (Schema)
+import qualified Language.GraphQL.Schema as Schema
+
+-- | Takes a 'Schema', a variable substitution function ('Schema.Subs'), and a
+--   @GraphQL@ 'document'. The substitution is applied to the document using
+--  'rootFields', and the 'Schema''s resolvers are applied to the resulting fields.
+--
+--   Returns the result of the query against the 'Schema' wrapped in a /data/ field, or
+--   errors wrapped in an /errors/ field.
+execute :: MonadIO m
+    => Schema m
+    -> Schema.Subs
+    -> AST.Document
+    -> m Aeson.Value
+execute schema subs doc =
+    maybe transformError (document schema Nothing) $ Transform.document subs doc
+  where
+    transformError = return $ singleError "Schema transformation error."
+
+-- | Takes a 'Schema', operation name, a variable substitution function ('Schema.Subs'),
+--   and a @GraphQL@ 'document'. The substitution is applied to the document using
+--  'rootFields', and the 'Schema''s resolvers are applied to the resulting fields.
+--
+--   Returns the result of the query against the 'Schema' wrapped in a /data/ field, or
+--   errors wrapped in an /errors/ field.
+executeWithName :: MonadIO m
+    => Schema m
+    -> Text
+    -> Schema.Subs
+    -> AST.Document
+    -> m Aeson.Value
+executeWithName schema name subs doc =
+    maybe transformError (document schema $ Just name) $ Transform.document subs doc
+  where
+    transformError = return $ singleError "Schema transformation error."
+
+document :: MonadIO m => Schema m -> Maybe Text -> AST.Core.Document -> m Aeson.Value
+document schema Nothing (op :| []) = operation schema op
+document schema (Just name) operations = case NE.dropWhile matchingName operations of
+    [] -> return $ singleError
+        $ Text.unwords ["Operation", name, "couldn't be found in the document."]
+    (op:_)  -> operation schema op
+  where
+    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 :: MonadIO m => Schema m -> AST.Core.Operation -> m Aeson.Value
+operation schema (AST.Core.Query _ flds)
+    = runCollectErrs (Schema.resolve (NE.toList schema) (NE.toList flds))
+operation schema (AST.Core.Mutation _ flds)
+    = runCollectErrs (Schema.resolve (NE.toList schema) (NE.toList flds))

src/Language/GraphQL/Lexer.hs

@@ -0,0 +1,226 @@
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | This module defines a bunch of small parsers used to parse individual
+--   lexemes.
+module Language.GraphQL.Lexer 
+    ( Parser
+    , amp
+    , at
+    , bang
+    , blockString
+    , braces
+    , brackets
+    , colon
+    , dollar
+    , comment
+    , equals
+    , integer
+    , float
+    , lexeme
+    , name
+    , parens
+    , pipe
+    , spaceConsumer
+    , spread
+    , string
+    , symbol
+    , unicodeBOM
+    ) where
+
+import Control.Applicative ( Alternative(..)
+                           , liftA2
+                           )
+import Data.Char ( chr
+                 , digitToInt
+                 , isAsciiLower
+                 , isAsciiUpper
+                 , ord
+                 )
+import Data.Foldable (foldl')
+import Data.List (dropWhileEnd)
+import Data.Proxy (Proxy(..))
+import Data.Void (Void)
+import Text.Megaparsec ( Parsec
+                       , between
+                       , chunk
+                       , chunkToTokens
+                       , notFollowedBy
+                       , oneOf
+                       , option
+                       , optional
+                       , satisfy
+                       , sepBy
+                       , skipSome
+                       , takeP
+                       , takeWhile1P
+                       , try
+                       )
+import Text.Megaparsec.Char ( char
+                            , digitChar
+                            , space1
+                            )
+import qualified Text.Megaparsec.Char.Lexer as Lexer
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as TL
+
+-- | Standard parser.
+-- Accepts the type of the parsed token.
+type Parser = Parsec Void T.Text
+
+ignoredCharacters :: Parser ()
+ignoredCharacters = space1 <|> skipSome (char ',')
+
+spaceConsumer :: Parser ()
+spaceConsumer = Lexer.space ignoredCharacters comment empty
+
+-- | Parser for comments.
+comment :: Parser ()
+comment = Lexer.skipLineComment "#"
+
+-- | Lexeme definition which ignores whitespaces and commas.
+lexeme :: forall a. Parser a -> Parser a
+lexeme = Lexer.lexeme spaceConsumer
+
+-- | Symbol definition which ignores whitespaces and commas.
+symbol :: T.Text -> Parser T.Text
+symbol = Lexer.symbol spaceConsumer
+
+-- | Parser for "!".
+bang :: Parser Char
+bang = char '!'
+
+-- | Parser for "$".
+dollar :: Parser Char
+dollar = char '$'
+
+-- | Parser for "@".
+at :: Parser Char
+at = char '@'
+
+-- | Parser for "&".
+amp :: Parser T.Text
+amp = symbol "&"
+
+-- | Parser for ":".
+colon :: Parser T.Text
+colon = symbol ":"
+
+-- | Parser for "=".
+equals :: Parser T.Text
+equals = symbol "="
+
+-- | Parser for the spread operator (...).
+spread :: Parser T.Text
+spread = symbol "..."
+
+-- | Parser for "|".
+pipe :: Parser T.Text
+pipe = symbol "|"
+
+-- | Parser for an expression between "(" and ")".
+parens :: forall a. Parser a -> Parser a
+parens = between (symbol "(") (symbol ")")
+
+-- | Parser for an expression between "[" and "]".
+brackets :: forall a. Parser a -> Parser a
+brackets = between (symbol "[") (symbol "]")
+
+-- | Parser for an expression between "{" and "}".
+braces :: forall a. Parser a -> Parser a
+braces = between (symbol "{") (symbol "}")
+
+-- | Parser for strings.
+string :: Parser T.Text
+string = between "\"" "\"" stringValue
+  where
+    stringValue = T.pack <$> many stringCharacter
+    stringCharacter = satisfy isStringCharacter1
+        <|> escapeSequence
+    isStringCharacter1 = liftA2 (&&) isSourceCharacter isChunkDelimiter
+
+-- | Parser for block strings.
+blockString :: Parser T.Text
+blockString = between "\"\"\"" "\"\"\"" stringValue
+  where
+    stringValue = do
+        byLine <- sepBy (many blockStringCharacter) lineTerminator
+        let indentSize = foldr countIndent 0 $ tail byLine
+            withoutIndent = head byLine : (removeIndent indentSize <$> tail byLine)
+            withoutEmptyLines = liftA2 (.) dropWhile dropWhileEnd removeEmptyLine withoutIndent
+
+        return $ T.intercalate "\n" $ T.concat <$> withoutEmptyLines
+    removeEmptyLine [] = True
+    removeEmptyLine [x] = T.null x || isWhiteSpace (T.head x)
+    removeEmptyLine _ = False
+    blockStringCharacter
+        = takeWhile1P Nothing isWhiteSpace
+        <|> takeWhile1P Nothing isBlockStringCharacter1
+        <|> escapeTripleQuote
+        <|> try (chunk "\"" <* notFollowedBy (chunk "\"\""))
+    escapeTripleQuote = chunk "\\" >>= flip option (chunk "\"\"")
+    isBlockStringCharacter1 = liftA2 (&&) isSourceCharacter isChunkDelimiter
+    countIndent [] acc = acc
+    countIndent (x:_) acc
+        | T.null x = acc
+        | not (isWhiteSpace $ T.head x) = acc
+        | acc == 0 = T.length x
+        | otherwise = min acc $ T.length x
+    removeIndent _ [] = []
+    removeIndent n (x:chunks) = T.drop n x : chunks
+
+-- | Parser for integers.
+integer :: Integral a => Parser a
+integer = Lexer.signed (pure ()) $ lexeme Lexer.decimal
+
+-- | Parser for floating-point numbers.
+float :: Parser Double
+float = Lexer.signed (pure ()) $ lexeme Lexer.float
+
+-- | Parser for names (/[_A-Za-z][_0-9A-Za-z]*/).
+name :: Parser T.Text
+name = do
+    firstLetter <- nameFirstLetter
+    rest <- many $ nameFirstLetter <|> digitChar
+    _ <- spaceConsumer
+    return $ TL.toStrict $ TL.cons firstLetter $ TL.pack rest
+      where
+        nameFirstLetter = satisfy isAsciiUpper <|> satisfy isAsciiLower <|> char '_'
+
+isChunkDelimiter :: Char -> Bool
+isChunkDelimiter = flip notElem ['"', '\\', '\n', '\r']
+
+isWhiteSpace :: Char -> Bool
+isWhiteSpace = liftA2 (||) (== ' ') (== '\t')
+
+lineTerminator :: Parser T.Text
+lineTerminator = chunk "\r\n" <|> chunk "\n" <|> chunk "\r"
+
+isSourceCharacter :: Char -> Bool
+isSourceCharacter = isSourceCharacter' . ord
+  where
+    isSourceCharacter' code = code >= 0x0020
+                           || code == 0x0009
+                           || code == 0x000a
+                           || code == 0x000d
+
+escapeSequence :: Parser Char
+escapeSequence = do
+    _ <- char '\\'
+    escaped <- oneOf ['"', '\\', '/', 'b', 'f', 'n', 'r', 't', 'u']
+    case escaped of
+        'b' -> return '\b'
+        'f' -> return '\f'
+        'n' -> return '\n'
+        'r' -> return '\r'
+        't' -> return '\t'
+        'u' -> chr . foldl' step 0
+                   . chunkToTokens (Proxy :: Proxy T.Text)
+                 <$> takeP Nothing 4
+        _ -> return escaped
+  where
+    step accumulator = (accumulator * 16 +) . digitToInt
+
+-- | Parser for the "Byte Order Mark".
+unicodeBOM :: Parser ()
+unicodeBOM = optional (char '\xfeff') >> pure ()

src/Language/GraphQL/Parser.hs

@@ -0,0 +1,185 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Language.GraphQL.Parser
+    ( document
+    ) where
+
+import Control.Applicative ( Alternative(..)
+                           , optional
+                           )
+import Data.List.NonEmpty (NonEmpty(..))
+import Language.GraphQL.AST
+import Language.GraphQL.Lexer
+import Text.Megaparsec ( lookAhead
+                       , option
+                       , try
+                       , (<?>)
+                       )
+
+document :: Parser Document
+document = unicodeBOM >> spaceConsumer >> lexeme (manyNE definition)
+
+definition :: Parser Definition
+definition = DefinitionOperation <$> operationDefinition
+         <|> DefinitionFragment  <$> fragmentDefinition
+         <?> "definition error!"
+
+operationDefinition :: Parser OperationDefinition
+operationDefinition = OperationSelectionSet <$> selectionSet
+                  <|> OperationDefinition   <$> operationType
+                                            <*> optional name
+                                            <*> opt variableDefinitions
+                                            <*> opt directives
+                                            <*> selectionSet
+                  <?> "operationDefinition error"
+
+operationType :: Parser OperationType
+operationType = Query <$ symbol "query"
+    <|> Mutation <$ symbol "mutation"
+    <?> "operationType error"
+
+-- * SelectionSet
+
+selectionSet :: Parser SelectionSet
+selectionSet = braces $ manyNE selection
+
+selectionSetOpt :: Parser SelectionSetOpt
+selectionSetOpt = braces $ some selection
+
+selection :: Parser Selection
+selection = SelectionField          <$> field
+        <|> try (SelectionFragmentSpread <$> fragmentSpread)
+        <|> SelectionInlineFragment <$> inlineFragment
+        <?> "selection error!"
+
+-- * Field
+
+field :: Parser Field
+field = Field <$> optional alias
+              <*> name
+              <*> opt arguments
+              <*> opt directives
+              <*> opt selectionSetOpt
+
+alias :: Parser Alias
+alias = try $ name <* colon
+
+-- * Arguments
+
+arguments :: Parser Arguments
+arguments = parens $ some argument
+
+argument :: Parser Argument
+argument = Argument <$> name <* colon <*> value
+
+-- * Fragments
+
+fragmentSpread :: Parser FragmentSpread
+fragmentSpread = FragmentSpread <$  spread
+                                <*> fragmentName
+                                <*> opt directives
+
+inlineFragment :: Parser InlineFragment
+inlineFragment = InlineFragment <$  spread
+                                <*> optional typeCondition
+                                <*> opt directives
+                                <*> selectionSet
+
+fragmentDefinition :: Parser FragmentDefinition
+fragmentDefinition = FragmentDefinition
+                 <$  symbol "fragment"
+                 <*> name
+                 <*> typeCondition
+                 <*> opt directives
+                 <*> selectionSet
+
+fragmentName :: Parser FragmentName
+fragmentName = but (symbol "on") *> name
+
+typeCondition :: Parser TypeCondition
+typeCondition = symbol "on" *> name
+
+-- * Input Values
+
+value :: Parser Value
+value = ValueVariable <$> variable
+    <|> ValueFloat    <$> try float
+    <|> ValueInt      <$> integer
+    <|> ValueBoolean  <$> booleanValue
+    <|> ValueNull     <$  symbol "null"
+    <|> ValueString   <$> string
+    <|> ValueString   <$> blockString
+    <|> ValueEnum     <$> try enumValue
+    <|> ValueList     <$> listValue
+    <|> ValueObject   <$> objectValue
+    <?> "value error!"
+  where
+    booleanValue :: Parser Bool
+    booleanValue = True  <$ symbol "true"
+               <|> False <$ symbol "false"
+
+    enumValue :: Parser Name
+    enumValue = but (symbol "true") *> but (symbol "false") *> but (symbol "null") *> name
+
+    listValue :: Parser [Value]
+    listValue = brackets $ some value
+
+    objectValue :: Parser [ObjectField]
+    objectValue = braces $ some objectField
+
+objectField :: Parser ObjectField
+objectField = ObjectField <$> name <* symbol ":" <*> value
+
+-- * Variables
+
+variableDefinitions :: Parser VariableDefinitions
+variableDefinitions = parens $ some variableDefinition
+
+variableDefinition :: Parser VariableDefinition
+variableDefinition = VariableDefinition <$> variable
+                                        <*  colon
+                                        <*> type_
+                                        <*> optional defaultValue
+variable :: Parser Name
+variable = dollar *> name
+
+defaultValue :: Parser Value
+defaultValue = equals *> value
+
+-- * Input Types
+
+type_ :: Parser Type
+type_ = try (TypeNamed <$> name <* but "!")
+    <|> TypeList       <$> brackets type_
+    <|> TypeNonNull    <$> nonNullType
+    <?> "type_ error!"
+
+nonNullType :: Parser NonNullType
+nonNullType = NonNullTypeNamed <$> name <* bang
+          <|> NonNullTypeList  <$> brackets type_  <* bang
+          <?> "nonNullType error!"
+
+-- * Directives
+
+directives :: Parser Directives
+directives = some directive
+
+directive :: Parser Directive
+directive = Directive
+        <$  at
+        <*> name
+        <*> opt arguments
+
+-- * Internal
+
+opt :: Monoid a => Parser a -> Parser a
+opt = option mempty
+
+-- Hack to reverse parser success
+but :: Parser a -> Parser ()
+but pn = False <$ lookAhead pn <|> pure True >>= \case
+    False -> empty
+    True  -> pure ()
+
+manyNE :: Alternative f => f a -> f (NonEmpty a)
+manyNE p = (:|) <$> p <*> many p

src/Language/GraphQL/Schema.hs

@@ -0,0 +1,172 @@
+{-# 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
+    , Schema
+    , Subs
+    , object
+    , objectA
+    , scalar
+    , scalarA
+    , enum
+    , enumA
+    , resolve
+    , wrappedEnum
+    , wrappedEnumA
+    , wrappedObject
+    , wrappedObjectA
+    , wrappedScalar
+    , wrappedScalarA
+    -- * AST Reexports
+    , Field
+    , Argument(..)
+    , Value(..)
+    ) where
+
+import Control.Monad.IO.Class (MonadIO(..))
+import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.Except (runExceptT)
+import Data.Foldable ( find
+                     , fold
+                     )
+import Data.List.NonEmpty (NonEmpty)
+import Data.Maybe (fromMaybe)
+import qualified Data.Aeson as Aeson
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
+import Data.Text (Text)
+import qualified Data.Text as T
+import Language.GraphQL.Error
+import Language.GraphQL.Trans
+import Language.GraphQL.Type
+import Language.GraphQL.AST.Core
+
+-- | A GraphQL schema.
+--   @m@ is usually expected to be an instance of 'MonadIO'.
+type Schema m = NonEmpty (Resolver m)
+
+-- | Resolves a 'Field' into an @Aeson.@'Aeson.Object' with error information
+--   (or 'empty'). @m@ is usually expected to be an instance of 'MonadIO.
+data Resolver m = Resolver
+    Text -- ^ Name
+    (Field -> CollectErrsT m Aeson.Object) -- ^ Resolver
+
+type Fields = [Field]
+
+type Arguments = [Argument]
+
+-- | Variable substitution function.
+type Subs = Name -> Maybe Value
+
+-- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's.
+object :: MonadIO m => Name -> ActionT m [Resolver m] -> Resolver m
+object name = objectA name . const
+
+-- | Like 'object' but also taking 'Argument's.
+objectA :: MonadIO m
+    => Name -> (Arguments -> ActionT m [Resolver m]) -> Resolver m
+objectA name f = Resolver name $ resolveFieldValue f resolveRight
+  where
+    resolveRight fld@(Field _ _ _ flds) resolver = withField (resolve resolver flds) fld
+
+-- | Like 'object' but also taking 'Argument's and can be null or a list of objects.
+wrappedObjectA :: MonadIO m
+    => Name -> (Arguments -> ActionT m (Wrapping [Resolver m])) -> Resolver m
+wrappedObjectA name f = Resolver name $ resolveFieldValue f resolveRight
+  where
+    resolveRight fld@(Field _ _ _ sels) resolver
+        = withField (traverse (`resolve` sels) resolver) fld
+
+-- | Like 'object' but can be null or a list of objects.
+wrappedObject :: MonadIO m
+    => Name -> ActionT m (Wrapping [Resolver m]) -> Resolver m
+wrappedObject name = wrappedObjectA name . const
+
+-- | A scalar represents a primitive value, like a string or an integer.
+scalar :: (MonadIO m, Aeson.ToJSON a) => Name -> ActionT m a -> Resolver m
+scalar name = scalarA name . const
+
+-- | Like 'scalar' but also taking 'Argument's.
+scalarA :: (MonadIO m, Aeson.ToJSON a)
+    => Name -> (Arguments -> ActionT m a) -> Resolver m
+scalarA name f = Resolver name $ resolveFieldValue f resolveRight
+  where
+    resolveRight fld result = withField (return result) fld
+
+-- | Lika 'scalar' but also taking 'Argument's and can be null or a list of scalars.
+wrappedScalarA :: (MonadIO m, Aeson.ToJSON a)
+    => Name -> (Arguments -> ActionT m (Wrapping a)) -> Resolver m
+wrappedScalarA name f = Resolver name $ resolveFieldValue f resolveRight
+  where
+    resolveRight fld (Named result) = withField (return result) fld
+    resolveRight fld Null
+        = return $ HashMap.singleton (aliasOrName fld) Aeson.Null
+    resolveRight fld (List result) = withField (return result) fld
+
+-- | Like 'scalar' but can be null or a list of scalars.
+wrappedScalar :: (MonadIO m, Aeson.ToJSON a)
+    => Name -> ActionT m (Wrapping a) -> Resolver m
+wrappedScalar name = wrappedScalarA name . const
+
+-- | Represents one of a finite set of possible values.
+--   Used in place of a 'scalar' when the possible responses are easily enumerable.
+enum :: MonadIO m => Name -> ActionT m [Text] -> Resolver m
+enum name = enumA name . const
+
+-- | Like 'enum' but also taking 'Argument's.
+enumA :: MonadIO m => Name -> (Arguments -> ActionT m [Text]) -> Resolver m
+enumA name f = Resolver name $ resolveFieldValue f resolveRight
+  where
+    resolveRight fld resolver = withField (return resolver) fld
+
+-- | Like 'enum' but also taking 'Argument's and can be null or a list of enums.
+wrappedEnumA :: MonadIO m
+    => Name -> (Arguments -> ActionT m (Wrapping [Text])) -> Resolver m
+wrappedEnumA name f = Resolver name $ resolveFieldValue f resolveRight
+  where
+    resolveRight fld (Named resolver) = withField (return resolver) fld
+    resolveRight fld Null
+        = return $ HashMap.singleton (aliasOrName fld) Aeson.Null
+    resolveRight fld (List resolver) = withField (return resolver) fld
+
+-- | Like 'enum' but can be null or a list of enums.
+wrappedEnum :: MonadIO m => Name -> ActionT m (Wrapping [Text]) -> Resolver m
+wrappedEnum name = wrappedEnumA name . const
+
+resolveFieldValue :: MonadIO m
+    => ([Argument] -> ActionT m a)
+    -> (Field -> a -> CollectErrsT m (HashMap Text Aeson.Value))
+    -> Field
+    -> CollectErrsT m (HashMap Text Aeson.Value)
+resolveFieldValue f resolveRight fld@(Field _ _ args _) = do
+    result <- lift $ runExceptT . runActionT $ f args
+    either resolveLeft (resolveRight fld) result
+      where
+        resolveLeft err = do
+            _ <- addErrMsg err
+            return $ HashMap.singleton (aliasOrName fld) Aeson.Null
+
+-- | Helper function to facilitate 'Argument' handling.
+withField :: (MonadIO 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 :: MonadIO m
+    => [Resolver m] -> Fields -> CollectErrsT m Aeson.Value
+resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers
+  where
+    tryResolvers fld = maybe (errmsg fld) (tryResolver fld) $ find (compareResolvers fld) resolvers
+    compareResolvers (Field _ name _ _) (Resolver name' _) = name == name'
+    tryResolver fld (Resolver _ resolver)  = resolver fld
+    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

@@ -0,0 +1,37 @@
+module Language.GraphQL.Trans
+    ( ActionT(..)
+    ) 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 Data.Text (Text)
+
+newtype ActionT m a = ActionT { runActionT :: ExceptT Text 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
+
+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 = (<|>)

src/Language/GraphQL/Type.hs

@@ -0,0 +1,57 @@
+-- | Definitions for @GraphQL@ type system.
+module Language.GraphQL.Type
+    ( Wrapping(..)
+    ) where
+
+import Data.Aeson as Aeson ( ToJSON
+                           , toJSON
+                           )
+import qualified Data.Aeson as Aeson
+
+-- | 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).
+--
+--   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

stack.yaml

@@ -1,5 +1,6 @@
-flags: {}
+resolver: lts-14.0
 packages:
 - '.'
 extra-deps: []
-resolver: lts-3.4
+flags: {}
+extra-package-dbs: []

tests/Language/GraphQL/EncoderSpec.hs

@@ -0,0 +1,21 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Language.GraphQL.EncoderSpec
+    ( spec
+    ) where
+
+import Language.GraphQL.AST ( Value(..))
+import Language.GraphQL.Encoder ( value
+                                , minified
+                                )
+import Test.Hspec ( Spec
+                  , describe
+                  , it
+                  , shouldBe
+                  )
+
+spec :: Spec
+spec = describe "value" $ do
+    it "escapes \\" $
+        value minified (ValueString "\\") `shouldBe` "\"\\\\\""
+    it "escapes quotes" $
+        value minified (ValueString "\"") `shouldBe` "\"\\\"\""

tests/Language/GraphQL/ErrorSpec.hs

@@ -0,0 +1,24 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Language.GraphQL.ErrorSpec
+    ( spec
+    ) where
+
+import qualified Data.Aeson as Aeson
+import Language.GraphQL.Error
+import Test.Hspec ( Spec
+                  , describe
+                  , it
+                  , shouldBe
+                  )
+
+spec :: Spec
+spec = describe "singleError" $
+    it "constructs an error with the given message" $
+        let expected = Aeson.object
+                [
+                    ("errors", Aeson.toJSON
+                        [ Aeson.object [("message", "Message.")]
+                        ]
+                    )
+                ]
+         in singleError "Message." `shouldBe` expected

tests/Language/GraphQL/LexerSpec.hs

@@ -0,0 +1,104 @@
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+module Language.GraphQL.LexerSpec
+    ( spec
+    ) where
+
+import Data.Either (isRight)
+import Data.Text (Text)
+import Data.Void (Void)
+import Language.GraphQL.Lexer
+import Test.Hspec ( Spec
+                  , context
+                  , describe
+                  , it
+                  , shouldBe
+                  , shouldSatisfy
+                  )
+import Text.Megaparsec ( ParseErrorBundle
+                       , parse
+                       )
+import Text.RawString.QQ (r)
+
+spec :: Spec
+spec = describe "Lexer" $ do
+    context "Reference tests" $ do
+        it "accepts BOM header" $
+            runParser unicodeBOM "\xfeff" `shouldSatisfy` isRight
+
+        it "lexes strings" $ do
+            runParser string [r|"simple"|] `shouldBe` Right "simple"
+            runParser string [r|" white space "|] `shouldBe` Right " white space "
+            runParser string [r|"quote \""|] `shouldBe` Right [r|quote "|]
+            runParser string [r|"escaped \n"|] `shouldBe` Right "escaped \n"
+            runParser string [r|"slashes \\ \/"|] `shouldBe` Right [r|slashes \ /|]
+            runParser string [r|"unicode \u1234\u5678\u90AB\uCDEF"|]
+                `shouldBe` Right "unicode ሴ噸邫췯"
+
+        it "lexes block string" $ do
+            runParser blockString [r|"""simple"""|] `shouldBe` Right "simple"
+            runParser blockString [r|""" white space """|]
+                `shouldBe` Right " white space "
+            runParser blockString [r|"""contains " quote"""|]
+                `shouldBe` Right [r|contains " quote|]
+            runParser blockString [r|"""contains \""" triplequote"""|]
+                `shouldBe` Right [r|contains """ triplequote|]
+            runParser blockString "\"\"\"multi\nline\"\"\"" `shouldBe` Right "multi\nline"
+            runParser blockString "\"\"\"multi\rline\r\nnormalized\"\"\""
+                `shouldBe` Right "multi\nline\nnormalized"
+            runParser blockString "\"\"\"multi\rline\r\nnormalized\"\"\""
+                `shouldBe` Right "multi\nline\nnormalized"
+            runParser blockString [r|"""unescaped \n\r\b\t\f\u1234"""|]
+                `shouldBe` Right [r|unescaped \n\r\b\t\f\u1234|]
+            runParser blockString [r|"""slashes \\ \/"""|]
+                `shouldBe` Right [r|slashes \\ \/|]
+            runParser blockString [r|"""
+
+                spans
+                  multiple
+                    lines
+
+                """|] `shouldBe` Right "spans\n  multiple\n    lines"
+
+        it "lexes numbers" $ do
+            runParser integer "4" `shouldBe` Right (4 :: Int)
+            runParser float "4.123" `shouldBe` Right 4.123
+            runParser integer "-4" `shouldBe` Right (-4 :: Int)
+            runParser integer "9" `shouldBe` Right (9 :: Int)
+            runParser integer "0" `shouldBe` Right (0 :: Int)
+            runParser float "-4.123" `shouldBe` Right (-4.123)
+            runParser float "0.123" `shouldBe` Right 0.123
+            runParser float "123e4" `shouldBe` Right 123e4
+            runParser float "123E4" `shouldBe` Right 123E4
+            runParser float "123e-4" `shouldBe` Right 123e-4
+            runParser float "123e+4" `shouldBe` Right 123e+4
+            runParser float "-1.123e4" `shouldBe` Right (-1.123e4)
+            runParser float "-1.123E4" `shouldBe` Right (-1.123E4)
+            runParser float "-1.123e-4" `shouldBe` Right (-1.123e-4)
+            runParser float "-1.123e+4" `shouldBe` Right (-1.123e+4)
+            runParser float "-1.123e4567" `shouldBe` Right (-1.123e4567)
+
+        it "lexes punctuation" $ do
+            runParser bang "!" `shouldBe` Right '!'
+            runParser dollar "$" `shouldBe` Right '$'
+            runBetween parens "()" `shouldSatisfy` isRight
+            runParser spread "..." `shouldBe` Right "..."
+            runParser colon ":" `shouldBe` Right ":"
+            runParser equals "=" `shouldBe` Right "="
+            runParser at "@" `shouldBe` Right '@'
+            runBetween brackets "[]" `shouldSatisfy` isRight
+            runBetween braces "{}" `shouldSatisfy` isRight
+            runParser pipe "|" `shouldBe` Right "|"
+
+    context "Implementation tests" $ do
+        it "lexes empty block strings" $
+            runParser blockString [r|""""""|] `shouldBe` Right ""
+        it "lexes ampersand" $
+            runParser amp "&" `shouldBe` Right "&"
+
+runParser :: forall a. Parser a -> Text -> Either (ParseErrorBundle Text Void) a
+runParser = flip parse ""
+
+runBetween :: (Parser () -> Parser ()) -> Text -> Either (ParseErrorBundle Text Void) ()
+runBetween parser = parse (parser $ pure ()) ""

tests/Language/GraphQL/ParserSpec.hs

@@ -0,0 +1,18 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Language.GraphQL.ParserSpec
+    ( spec
+    ) where
+
+import Data.Either (isRight)
+import Language.GraphQL.Parser (document)
+import Test.Hspec ( Spec
+                  , describe
+                  , it
+                  , shouldSatisfy
+                  )
+import Text.Megaparsec (parse)
+
+spec :: Spec
+spec = describe "Parser" $
+    it "accepts BOM header" $
+        parse document "" "\xfeff{foo}" `shouldSatisfy` isRight

tests/Spec.hs

@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

tests/Test/KitchenSinkSpec.hs

@@ -0,0 +1,76 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+module Test.KitchenSinkSpec
+    ( spec
+    ) where
+
+import qualified Data.Text.IO as Text.IO
+import qualified Data.Text.Lazy.IO as Text.Lazy.IO
+import qualified Language.GraphQL.Encoder as Encoder
+import qualified Language.GraphQL.Parser as Parser
+import Paths_graphql (getDataFileName)
+import Test.Hspec ( Spec
+                  , describe
+                  , it
+                  )
+import Test.Hspec.Expectations ( expectationFailure
+                               , shouldBe
+                               )
+import Text.Megaparsec ( errorBundlePretty
+                       , parse
+                       )
+import Text.RawString.QQ (r)
+
+spec :: Spec
+spec = describe "Kitchen Sink" $ do
+    it "minifies the query" $ do
+        dataFileName <- getDataFileName "tests/data/kitchen-sink.graphql"
+        minFileName <- getDataFileName "tests/data/kitchen-sink.min.graphql"
+        actual <- Text.IO.readFile dataFileName
+        expected <- Text.Lazy.IO.readFile minFileName
+
+        either
+            (expectationFailure . errorBundlePretty)
+            (flip shouldBe expected . Encoder.document Encoder.minified)
+            $ parse Parser.document dataFileName actual
+
+    it "pretty prints the query" $ do
+        dataFileName <- getDataFileName "tests/data/kitchen-sink.graphql"
+        actual <- Text.IO.readFile dataFileName
+        let expected = [r|query queryName($foo: ComplexType, $site: Site = MOBILE) {
+  whoever123is: node(id: [123, 456]) {
+    id
+    ... on User @defer {
+      field2 {
+        id
+        alias: field1(first: 10, after: $foo) @include(if: $foo) {
+          id
+          ...frag
+        }
+      }
+    }
+  }
+}
+
+mutation likeStory {
+  like(story: 123) @defer {
+    story {
+      id
+    }
+  }
+}
+
+fragment frag on Friend {
+  foo(size: $size, bar: $b, obj: {key: "value"})
+}
+
+{
+  unnamed(truthy: true, falsey: false)
+  query
+}
+|]
+
+        either
+            (expectationFailure . errorBundlePretty)
+            (flip shouldBe expected . Encoder.document Encoder.pretty)
+            $ parse Parser.document dataFileName actual

tests/Test/StarWars/Data.hs

@@ -0,0 +1,197 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Test.StarWars.Data
+    ( Character
+    , appearsIn
+    , artoo
+    , getDroid
+    , getDroid'
+    , getEpisode
+    , getFriends
+    , getHero
+    , getHeroIO
+    , getHuman
+    , id_
+    , homePlanet
+    , name
+    , secretBackstory
+    , typeName
+    ) where
+
+import Data.Monoid (mempty)
+import Control.Applicative ( Alternative(..)
+                           , liftA2 
+                           )
+import Control.Monad.IO.Class (MonadIO(..))
+import Control.Monad.Trans.Except (throwE)
+import Data.Maybe (catMaybes)
+import Data.Text (Text)
+import Language.GraphQL.Trans
+
+-- * Data
+-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsData.js
+
+-- ** Characters
+
+type ID = Text
+
+data CharCommon = CharCommon
+  { _id_        :: ID
+  , _name       :: Text
+  , _friends    :: [ID]
+  , _appearsIn  :: [Int]
+  } deriving (Show)
+
+
+data Human = Human
+  { _humanChar  :: CharCommon
+  , homePlanet :: Text
+  }
+
+data Droid = Droid
+  { _droidChar       :: CharCommon
+  , primaryFunction :: Text
+  }
+
+type Character = Either Droid Human
+
+id_ :: Character -> ID
+id_ (Left  x) = _id_ . _droidChar $ x
+id_ (Right x) = _id_ . _humanChar $ x
+
+name :: Character -> Text
+name (Left  x) = _name . _droidChar $ x
+name (Right x) = _name . _humanChar $ x
+
+friends :: Character -> [ID]
+friends (Left  x) = _friends . _droidChar $ x
+friends (Right x) = _friends . _humanChar $ x
+
+appearsIn :: Character -> [Int]
+appearsIn (Left  x) = _appearsIn . _droidChar $ x
+appearsIn (Right x) = _appearsIn . _humanChar $ x
+
+secretBackstory :: MonadIO m => Character -> ActionT m Text
+secretBackstory = const $ ActionT $ throwE "secretBackstory is secret."
+
+typeName :: Character -> Text
+typeName = either (const "Droid") (const "Human")
+
+luke :: Character
+luke = Right luke'
+
+luke' :: Human
+luke' = Human
+  { _humanChar = CharCommon
+      { _id_        = "1000"
+      , _name       = "Luke Skywalker"
+      , _friends    = ["1002","1003","2000","2001"]
+      , _appearsIn  = [4,5,6]
+      }
+  , homePlanet = "Tatooine"
+  }
+
+vader :: Human
+vader = Human
+  { _humanChar = CharCommon
+      { _id_        = "1001"
+      , _name       = "Darth Vader"
+      , _friends    = ["1004"]
+      , _appearsIn  = [4,5,6]
+      }
+  , homePlanet = "Tatooine"
+  }
+
+han :: Human
+han = Human
+  { _humanChar = CharCommon
+      { _id_        = "1002"
+      , _name       = "Han Solo"
+      , _friends    = ["1000","1003","2001" ]
+      , _appearsIn  = [4,5,6]
+      }
+  , homePlanet = mempty
+  }
+
+leia :: Human
+leia = Human
+  { _humanChar = CharCommon
+      { _id_        = "1003"
+      , _name       = "Leia Organa"
+      , _friends    = ["1000","1002","2000","2001"]
+      , _appearsIn  = [4,5,6]
+      }
+  , homePlanet = "Alderaan"
+  }
+
+tarkin :: Human
+tarkin = Human
+  { _humanChar = CharCommon
+    { _id_        = "1004"
+    , _name       = "Wilhuff Tarkin"
+    , _friends    = ["1001"]
+    , _appearsIn  = [4]
+    }
+  , homePlanet = mempty
+  }
+
+threepio :: Droid
+threepio = Droid
+  { _droidChar = CharCommon
+      { _id_ = "2000"
+      , _name = "C-3PO"
+      , _friends = ["1000","1002","1003","2001" ]
+      , _appearsIn = [ 4, 5, 6 ]
+      }
+  , primaryFunction = "Protocol"
+  }
+
+artoo :: Character
+artoo = Left artoo'
+
+artoo' :: Droid
+artoo' = Droid
+  { _droidChar = CharCommon
+      { _id_        = "2001"
+      , _name       = "R2-D2"
+      , _friends    = ["1000","1002","1003"]
+      , _appearsIn  = [4,5,6]
+      }
+  , primaryFunction = "Astrometch"
+  }
+
+-- ** Helper functions
+
+getHero :: Int -> Character
+getHero 5 = luke
+getHero _ = artoo
+
+getHeroIO :: Int -> IO Character
+getHeroIO = pure . getHero
+
+getHuman :: Alternative f => ID -> f Character
+getHuman = fmap Right . getHuman'
+
+getHuman' :: Alternative f => ID -> f Human
+getHuman' "1000" = pure luke'
+getHuman' "1001" = pure vader
+getHuman' "1002" = pure han
+getHuman' "1003" = pure leia
+getHuman' "1004" = pure tarkin
+getHuman' _      = empty
+
+getDroid :: Alternative f => ID -> f Character
+getDroid = fmap Left . getDroid'
+
+getDroid' :: Alternative f => ID -> f Droid
+getDroid' "2000" = pure threepio
+getDroid' "2001" = pure artoo'
+getDroid' _      = empty
+
+getFriends :: Character -> [Character]
+getFriends char = catMaybes $ liftA2 (<|>) getDroid getHuman <$> friends char
+
+getEpisode :: Alternative f => Int -> f Text
+getEpisode 4 = pure "NEWHOPE"
+getEpisode 5 = pure "EMPIRE"
+getEpisode 6 = pure "JEDI"
+getEpisode _ = empty

tests/Test/StarWars/QuerySpec.hs

@@ -0,0 +1,351 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+module Test.StarWars.QuerySpec
+    ( spec
+    ) where
+
+import qualified Data.Aeson as Aeson
+import Data.Aeson ( object
+                  , (.=)
+                  )
+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
+                  )
+import Test.StarWars.Schema
+
+-- * Test
+-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsQueryTests.js
+
+spec :: Spec
+spec = describe "Star Wars Query Tests" $ do
+    describe "Basic Queries" $ do
+      it "R2-D2 hero" $ testQuery
+        [r| query HeroNameQuery {
+            hero {
+                id
+            }
+            }
+        |]
+        $ object [ "data" .= object ["hero" .= object ["id" .= ("2001" :: Text)]]]
+      it "R2-D2 ID and friends" $ testQuery
+        [r| query HeroNameAndFriendsQuery {
+            hero {
+                id
+                name
+                friends {
+                name
+                }
+            }
+            }
+        |]
+        $ object [ "data" .= object [
+            "hero" .= object
+                [ "id" .= ("2001" :: Text)
+                , r2d2Name
+                , "friends" .=
+                    [ object [lukeName]
+                    , object [hanName]
+                    , object [leiaName]
+                    ]
+                ]
+        ]]
+
+    describe "Nested Queries" $ do
+      it "R2-D2 friends" $ testQuery
+        [r| query NestedQuery {
+              hero {
+                name
+                friends {
+                  name
+                  appearsIn
+                    friends {
+                      name
+                    }
+                }
+              }
+            }
+        |]
+        $ object [ "data" .= object [
+          "hero" .= object [
+              "name" .= ("R2-D2" :: Text)
+            , "friends" .= [
+                  object [
+                      "name" .= ("Luke Skywalker" :: Text)
+                    , "appearsIn" .= ["NEWHOPE","EMPIRE","JEDI" :: Text]
+                    , "friends" .= [
+                          object [hanName]
+                        , object [leiaName]
+                        , object [c3poName]
+                        , object [r2d2Name]
+                        ]
+                    ]
+                , object [
+                      hanName
+                    , "appearsIn" .= [ "NEWHOPE","EMPIRE","JEDI" :: Text]
+                    , "friends" .= [
+                          object [lukeName]
+                        , object [leiaName]
+                        , object [r2d2Name]
+                        ]
+                    ]
+                , object [
+                      leiaName
+                    , "appearsIn" .= [ "NEWHOPE","EMPIRE","JEDI" :: Text]
+                    , "friends" .= [
+                          object [lukeName]
+                        , object [hanName]
+                        , object [c3poName]
+                        , object [r2d2Name]
+                        ]
+                    ]
+                ]
+            ]
+        ]]
+      it "Luke ID" $ testQuery
+        [r| query FetchLukeQuery {
+              human(id: "1000") {
+                name
+              }
+            }
+        |]
+        $ object [ "data" .= object [
+          "human" .= object [lukeName]
+        ]]
+
+    it "Luke ID with variable" $ testQueryParams
+      (\v -> if v == "someId" then Just "1000" else Nothing)
+      [r| query FetchSomeIDQuery($someId: String!) {
+            human(id: $someId) {
+              name
+            }
+          }
+      |]
+      $ object [ "data" .= object [
+        "human" .= object [lukeName]
+      ]]
+    it "Han ID with variable" $ testQueryParams
+      (\v -> if v == "someId" then Just "1002" else Nothing)
+      [r| query FetchSomeIDQuery($someId: String!) {
+            human(id: $someId) {
+              name
+            }
+          }
+      |]
+      $ object [ "data" .= object [
+        "human" .= object [hanName]
+      ]]
+    it "Invalid ID" $ testQueryParams
+      (\v -> if v == "id" then Just "Not a valid ID" else Nothing)
+      [r| query humanQuery($id: String!) {
+            human(id: $id) {
+              name
+            }
+          }
+      |] $ object ["data" .= object ["human" .= Aeson.Null]]
+    it "Luke aliased" $ testQuery
+      [r| query FetchLukeAliased {
+            luke: human(id: "1000") {
+              name
+            }
+          }
+      |]
+      $ object [ "data" .= object [
+       "luke" .= object [lukeName]
+      ]]
+    it "R2-D2 ID and friends aliased" $ testQuery
+      [r| query HeroNameAndFriendsQuery {
+            hero {
+              id
+              name
+              friends {
+                friendName: name
+              }
+            }
+          }
+      |]
+      $ object [ "data" .= object [
+        "hero" .= object [
+            "id" .= ("2001" :: Text)
+          , r2d2Name
+          , "friends" .= [
+                object ["friendName" .= ("Luke Skywalker" :: Text)]
+              , object ["friendName" .= ("Han Solo" :: Text)]
+              , object ["friendName" .= ("Leia Organa" :: Text)]
+              ]
+          ]
+      ]]
+    it "Luke and Leia aliased" $ testQuery
+      [r| query FetchLukeAndLeiaAliased {
+            luke: human(id: "1000") {
+              name
+            }
+            leia: human(id: "1003") {
+              name
+            }
+          }
+      |]
+      $ object [ "data" .= object [
+        "luke" .= object [lukeName]
+      , "leia" .= object [leiaName]
+      ]]
+
+    describe "Fragments for complex queries" $ do
+      it "Aliases to query for duplicate content" $ testQuery
+        [r| query DuplicateFields {
+              luke: human(id: "1000") {
+                name
+                homePlanet
+              }
+              leia: human(id: "1003") {
+                name
+                homePlanet
+              }
+            }
+        |]
+        $ object [ "data" .= object [
+          "luke" .= object [lukeName, tatooine]
+        , "leia" .= object [leiaName, alderaan]
+        ]]
+      it "Fragment for duplicate content" $ testQuery
+        [r|  query UseFragment {
+              luke: human(id: "1000") {
+                ...HumanFragment
+              }
+              leia: human(id: "1003") {
+                ...HumanFragment
+              }
+            }
+            fragment HumanFragment on Human {
+              name
+              homePlanet
+            }
+        |]
+        $ object [ "data" .= object [
+          "luke" .= object [lukeName, tatooine]
+        , "leia" .= object [leiaName, alderaan]
+        ]]
+
+    describe "__typename" $ do
+      it "R2D2 is a Droid" $ testQuery
+        [r| query CheckTypeOfR2 {
+              hero {
+                __typename
+                name
+              }
+            }
+          |]
+        $ object ["data" .= object [
+            "hero" .= object ["__typename" .= ("Droid" :: Text), r2d2Name]
+        ]]
+      it "Luke is a human" $ testQuery
+        [r| query CheckTypeOfLuke {
+              hero(episode: EMPIRE) {
+                __typename
+                name
+              }
+            }
+          |]
+        $ object ["data" .= object [
+            "hero" .= object ["__typename" .= ("Human" :: Text), lukeName]
+        ]]
+
+    describe "Errors in resolvers" $ do
+        it "error on secretBackstory" $ testQuery
+          [r|
+            query HeroNameQuery {
+              hero {
+                name
+                  secretBackstory
+              }
+            }
+          |]
+          $ object
+              [ "data" .= object
+                  [ "hero" .= object
+                      [ "name" .= ("R2-D2" :: Text)
+                      , "secretBackstory" .= Aeson.Null
+                      ]
+                  ]
+              , "errors" .=
+                  [ object
+                      ["message" .= ("secretBackstory is secret." :: Text)]
+                  ]
+              ]
+        it "Error in a list" $ testQuery
+          [r| query HeroNameQuery {
+                hero {
+                  name
+                  friends {
+                    name
+                    secretBackstory
+                  }
+                }
+              }
+            |]
+          $ object ["data" .= object
+            [ "hero" .= object
+                [ "name" .= ("R2-D2" :: Text)
+                , "friends" .=
+                    [ object
+                        [ "name" .= ("Luke Skywalker" :: Text)
+                        , "secretBackstory" .= Aeson.Null
+                        ]
+                    , object
+                        [ "name" .= ("Han Solo" :: Text)
+                        , "secretBackstory" .= Aeson.Null
+                        ]
+                    , object
+                        [ "name" .= ("Leia Organa" :: Text)
+                        , "secretBackstory" .= Aeson.Null
+                        ]
+                    ]
+                ]
+            ]
+            , "errors" .=
+                [ object ["message" .= ("secretBackstory is secret." :: Text)]
+                , object ["message" .= ("secretBackstory is secret." :: Text)]
+                , object ["message" .= ("secretBackstory is secret." :: Text)]
+                ]
+            ]
+        it "error on secretBackstory with alias" $ testQuery
+          [r| query HeroNameQuery {
+                mainHero: hero {
+                  name
+                  story: secretBackstory
+                }
+              }
+            |]
+          $ object
+              [ "data" .= object
+                  [ "mainHero" .= object
+                      [ "name" .= ("R2-D2" :: Text)
+                      , "story" .= Aeson.Null
+                      ]
+                  ]
+              , "errors" .=
+                  [ object ["message" .= ("secretBackstory is secret." :: Text)]
+                  ]
+              ]
+
+  where
+    lukeName = "name" .= ("Luke Skywalker" :: Text)
+    leiaName = "name" .= ("Leia Organa" :: Text)
+    hanName = "name" .= ("Han Solo" :: Text)
+    r2d2Name = "name" .= ("R2-D2" :: Text)
+    c3poName = "name" .= ("C-3PO" :: Text)
+    tatooine = "homePlanet" .= ("Tatooine" :: Text)
+    alderaan = "homePlanet" .= ("Alderaan" :: Text)
+
+testQuery :: Text -> Aeson.Value -> Expectation
+testQuery q expected = graphql schema q >>= flip shouldBe expected
+
+testQueryParams :: Subs -> Text -> Aeson.Value -> Expectation
+testQueryParams f q expected = graphqlSubs schema f q >>= flip shouldBe expected

tests/Test/StarWars/Schema.hs

@@ -0,0 +1,63 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Test.StarWars.Schema
+    ( character
+    , droid
+    , hero
+    , human
+    , schema
+    ) where
+
+import Control.Monad.Trans.Except (throwE)
+import Control.Monad.Trans.Class (lift)
+import Control.Monad.IO.Class (MonadIO(..))
+import Data.List.NonEmpty (NonEmpty((:|)))
+import Language.GraphQL.Schema ( Schema
+                               , Resolver
+                               , Argument(..)
+                               , Value(..)
+                               )
+import qualified Language.GraphQL.Schema as Schema
+import Language.GraphQL.Trans
+import Language.GraphQL.Type
+import Test.StarWars.Data
+
+-- * Schema
+-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js
+
+schema :: MonadIO m => Schema m
+schema = hero :| [human, droid]
+
+hero :: MonadIO m => Resolver m
+hero = Schema.objectA "hero" $ \case
+  [] -> character artoo
+  [Argument "episode" (ValueEnum "NEWHOPE")] -> character $ getHero 4
+  [Argument "episode" (ValueEnum "EMPIRE" )] -> character $ getHero 5
+  [Argument "episode" (ValueEnum "JEDI"   )] -> character $ getHero 6
+  _ -> ActionT $ throwE "Invalid arguments."
+
+human :: MonadIO m => Resolver m
+human = Schema.wrappedObjectA "human" $ \case
+  [Argument "id" (ValueString i)] -> do
+      humanCharacter <- lift $ return $ getHuman i >>= Just
+      case humanCharacter of
+        Nothing -> return Null
+        Just e -> Named <$> character e
+  _ -> ActionT $ throwE "Invalid arguments."
+
+droid :: MonadIO m => Resolver m
+droid = Schema.objectA "droid" $ \case
+   [Argument "id" (ValueString i)] -> character =<< liftIO (getDroid i)
+   _ -> ActionT $ throwE "Invalid arguments."
+
+character :: MonadIO m => Character -> ActionT m [Resolver m]
+character char = return
+    [ Schema.scalar "id" $ return $ id_ char
+    , Schema.scalar "name" $ return $ name char
+    , Schema.wrappedObject "friends"
+        $ traverse character $ List $ Named <$> getFriends char
+    , Schema.enum "appearsIn" $ return $ foldMap getEpisode $ appearsIn char
+    , Schema.scalar "secretBackstory" $ secretBackstory char
+    , Schema.scalar "homePlanet" $ return $ either mempty homePlanet char
+    , Schema.scalar "__typename" $ return $ typeName char
+    ]

tests/data/kitchen-sink.graphql

@@ -0,0 +1,38 @@
+# Copyright (c) 2015, Facebook, Inc.
+# All rights reserved.
+#
+# This source code is licensed under the BSD-style license found in the
+# LICENSE file in the root directory of this source tree. An additional grant
+# of patent rights can be found in the PATENTS file in the same directory.
+
+query queryName($foo: ComplexType, $site: Site = MOBILE) {
+  whoever123is: node(id: [123, 456]) {
+    id, # Inline test comment
+    ... on User @defer {
+      field2 {
+        id,
+        alias: field1(first: 10, after: $foo) @include(if: $foo) {
+          id,
+          ...frag
+        }
+      }
+    }
+  }
+}
+
+mutation likeStory {
+  like(story: 123) @defer {
+    story {
+      id
+    }
+  }
+}
+
+fragment frag on Friend {
+  foo(size: $size, bar: $b, obj: {key: "value"})
+}
+
+{
+  unnamed(truthy: true, falsey: false),
+  query
+}

tests/data/kitchen-sink.min.graphql

@@ -0,0 +1 @@
+query queryName($foo:ComplexType,$site:Site=MOBILE){whoever123is:node(id:[123,456]){id,... on User@defer{field2{id,alias:field1(first:10,after:$foo)@include(if:$foo){id,...frag}}}}}mutation likeStory{like(story:123)@defer{story{id}}}fragment frag on Friend{foo(size:$size,bar:$b,obj:{key:"value"})}{unnamed(truthy:true,falsey:false),query}