Release 0.7.0.0

Fixes #33 .

.ghci

@@ -1,2 +0,0 @@
-import Data.Attoparsec.Text
-import qualified Data.Text.IO as TIO

.gitignore

@@ -1 +1,14 @@
+# Stack
 .stack-work/
+/stack.yaml.lock
+
+# Cabal
+/dist/
+/dist-newstyle/
+.cabal-sandbox/
+cabal.sandbox.config
+cabal.project.local
+/graphql.cabal
+
+# GHC
+*.hi

.travis.yml

@@ -1,79 +0,0 @@
-# This file has been generated -- see https://github.com/hvr/multi-ghc-travis
-language: c
-sudo: false
-
-cache:
-  directories:
-    - $HOME/.cabsnap
-    - $HOME/.cabal/packages
-
-before_cache:
-  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log
-  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar
-
-matrix:
-  include:
-    - env: CABALVER=1.18 GHCVER=7.8.4
-      compiler: ": #GHC 7.8.4"
-      addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4], sources: [hvr-ghc]}}
-    - env: CABALVER=1.22 GHCVER=7.10.2
-      compiler: ": #GHC 7.10.2"
-      addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2], sources: [hvr-ghc]}}
-
-before_install:
- - unset CC
- - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
-
-install:
- - cabal --version
- - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"
- - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ];
-   then
-     zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz >
-          $HOME/.cabal/packages/hackage.haskell.org/00-index.tar;
-   fi
- - travis_retry cabal update -v
- - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
- - cabal install --only-dependencies --enable-tests --enable-benchmarks --dry -v > installplan.txt
- - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt
-
-# check whether current requested install-plan matches cached package-db snapshot
- - if diff -u installplan.txt $HOME/.cabsnap/installplan.txt;
-   then
-     echo "cabal build-cache HIT";
-     rm -rfv .ghc;
-     cp -a $HOME/.cabsnap/ghc $HOME/.ghc;
-     cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/;
-   else
-     echo "cabal build-cache MISS";
-     rm -rf $HOME/.cabsnap;
-     mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin;
-     cabal install --only-dependencies --enable-tests --enable-benchmarks;
-   fi
- 
-# snapshot package-db on cache miss
- - if [ ! -d $HOME/.cabsnap ];
-   then
-      echo "snapshotting package-db to build-cache";
-      mkdir $HOME/.cabsnap;
-      cp -a $HOME/.ghc $HOME/.cabsnap/ghc;
-      cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/;
-   fi
-
-# Here starts the actual work to be performed for the package under test;
-# any command which exits with a non-zero exit code causes the build to fail.
-script:
- - if [ -f configure.ac ]; then autoreconf -i; fi
- - cabal configure --enable-tests --enable-benchmarks -v2  # -v2 provides useful information for debugging
- - cabal build   # this builds all libraries and executables (including tests/benchmarks)
- - cabal test
- - cabal check
- - cabal sdist   # tests that a source-distribution can be generated
-
-# Check that the resulting source distribution can be built & installed.
-# If there are no other `.tar.gz` files in `dist`, this can be even simpler:
-# `cabal install --force-reinstalls dist/*-*.tar.gz`
- - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz &&
-   (cd dist && cabal install --force-reinstalls "$SRC_TGZ")
-
-# EOF

CHANGELOG.md

@@ -1,6 +1,188 @@
-# Change Log
+# Changelog
 All notable changes to this project will be documented in this file.
 
+The format is based on
+[Keep a Changelog](https://keepachangelog.com/en/1.0.0/),
+and this project adheres to
+[Haskell Package Versioning Policy](https://pvp.haskell.org/).
+
+## [Unreleased]
+
+## [0.7.0.0] - 2020-05-11
+### Fixed
+- Result of null encoding
+- Block strings encoding
+- Result of tab and newline encoding
+
+### Added
+- AST for the GraphQL schema.
+- Type system definition parser.
+- `Trans.argument`.
+- Schema extension parser.
+- Contributing guidelines.
+- `Schema.resolversToMap` (intended for to be used internally).
+
+### Changed
+- Rename `AST.Definition` into `AST.Document.ExecutableDefinition`.
+  `AST.Document.TypeSystemDefinition` and `AST.Document.TypeSystemExtension`
+  can also be definitions.
+- Move all AST data to `AST.Document` and reexport them.
+- Rename `AST.OperationSelectionSet` to `AST.Document.SelectionSet`.
+- Make `Schema.Subs` a `Data.HashMap.Strict` (was a function
+  `key -> Maybe value` before).
+- Make `AST.Lexer.at` a text (symbol) parser. It was a char before and is
+  `symbol "@"` now.
+- Replace `MonadIO` with a plain `Monad`. Since the tests don't use IO,
+  set the inner monad to `Identity`.
+- `NonEmpty (Resolver m)` is now `HashMap Text (NonEmpty (Resolver m))`. Root
+  operation type can be any type, therefore a hashmap is needed. Since types
+  cannot be empty, we save the list of resolvers in the type as a non-empty
+  list. Currently only "Query" and "Mutation" are supported as types. For more
+  schema support is required. The executor checks now if the type in the query
+  matches the type of the provided root resolvers.
+
+### Removed
+- `AST.Field`, `AST.InlineFragment` and `AST.FragmentSpread`.
+  These types are only used in `AST.Selection` and `AST.Selection` contains now
+  3 corresponding data constructors, `Field`, `InlineFragment` and
+  `FragmentSpread`, instead of separate types. It simplifies pattern matching
+  and doesn't make the code less typesafe.
+- `Schema.scalarA`.
+- `Schema.wrappedScalarA`.
+- `Schema.wrappedObjectA`.
+- `Schema.objectA`.
+- `AST.Argument`. Replaced with `AST.Arguments` which holds all arguments as a
+  key/value map.
+
+## [0.6.1.0] - 2019-12-23
+### Fixed
+- Parsing multiple string arguments, such as
+  `login(username: "username", password: "password")` would fail on the comma
+  due to strings not having a space consumer.
+- Fragment spread is evaluated based on the `__typename` resolver. If the
+  resolver is missing, it is assumed that the type condition is satisfied (all
+  fragments are included).
+- Escaping characters during encoding.
+
+### Added
+- Directive support (@skip and @include).
+- Pretifying multi-line string arguments as block strings.
+
+## [0.6.0.0] - 2019-11-27
+### Changed
+- `Language.GraphQL.Encoder` moved to `Language.GraphQL.AST.Encoder`.
+- `Language.GraphQL.Parser` moved to `Language.GraphQL.AST.Parser`.
+- `Language.GraphQL.Lexer` moved to `Language.GraphQL.AST.Lexer`.
+- All `Language.GraphQL.AST.Value` data constructor prefixes were removed. The
+  module should be imported qualified.
+- All `Language.GraphQL.AST.Core.Value` data constructor prefixes were removed.
+  The module should be imported qualified.
+- `Language.GraphQL.AST.Core.Object` is now just a HashMap.
+- `Language.GraphQL.AST.Transform` is isn't exposed publically anymore.
+- `Language.GraphQL.Schema.resolve` accepts a selection `Seq` (`Data.Sequence`)
+  instead of a list. Selections are stored as sequences internally as well.
+- Add a reader instance to the resolver's monad stack. The Reader contains
+  a Name/Value hashmap, which will contain resolver arguments.
+
+### Added
+- Nested fragment support.
+
+### Fixed
+- Consume ignored tokens after `$` and `!`. I mistakenly assumed that
+  `$variable` is a single token, same as `Type!` is a single token. This is not
+  the case, for example `Variable` is defined as `$ Name`, so these are two
+  tokens, therefore whitespaces and commas after `$` and `!` should be
+  consumed.
+
+### Improved
+- `Language.GraphQL.AST.Parser.type_`: Try type parsers in a variable
+  definition in a different order to avoid using `but`.
+
+### Removed
+- `Language.GraphQL.AST.Arguments`. Use `[Language.GraphQL.AST.Argument]`
+  instead.
+- `Language.GraphQL.AST.Directives`. Use `[Language.GraphQL.AST.Directives]`
+  instead.
+- `Language.GraphQL.AST.VariableDefinitions`. Use
+  `[Language.GraphQL.AST.VariableDefinition]` instead.
+- `Language.GraphQL.AST.FragmentName`. Use `Language.GraphQL.AST.Name` instead.
+- `Language.GraphQL.Execute.Schema` - It was a resolver list, not a schema.
+- `Language.GraphQL.Schema`: `enum`, `enumA`, `wrappedEnum` and `wrappedEnumA`.
+  Use `scalar`, `scalarA`, `wrappedScalar` and `wrappedScalarA` instead.
+
+
+## [0.5.1.0] - 2019-10-22
+### Deprecated
+- `Language.GraphQL.AST.Arguments`. Use `[Language.GraphQL.AST.Argument]`
+  instead.
+- `Language.GraphQL.AST.Directives`. Use `[Language.GraphQL.AST.Directives]`
+  instead.
+- `Language.GraphQL.AST.VariableDefinitions`. Use
+  `[Language.GraphQL.AST.VariableDefinition]` instead.
+
+### Added
+- Module documentation.
+- Inline fragment support.
+
+### Fixed
+- Top-level fragments.
+- Fragment for execution is chosen based on the type.
+
+## [0.5.0.1] - 2019-09-10
+### Added
+- Minimal documentation for all public symbols.
+
+### Deprecated
+- `Language.GraphQL.AST.FragmentName`. Replaced with Language.GraphQL.AST.Name.
+- `Language.GraphQL.Execute.Schema` - It is not a schema (at least not a
+  complete one), but a resolver list, and the resolvers should be provided by
+  the user separately, because the schema can originate from a GraphQL
+  document. `Schema` name should be free to provide a data type for the real
+  schema later.
+- `Language.GraphQL.Schema`: `enum`, `enumA`, `wrappedEnum` and `wrappedEnumA`.
+  There are actually only two generic types in GraphQL: Scalars and objects.
+  Enum is a scalar value.
+
+### Fixed
+- Parsing block string values.
+
+## [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.
@@ -33,6 +215,14 @@ All notable changes to this project will be documented in this file.
 ### Added
 - Data types for the GraphQL language.
 
-[0.3]: https://github.com/jdnavarro/graphql-haskell/compare/v0.2.1...v0.3
-[0.2.1]: https://github.com/jdnavarro/graphql-haskell/compare/v0.2...v0.2.1
-[0.2]: https://github.com/jdnavarro/graphql-haskell/compare/v0.1...v0.2
+[Unreleased]: https://github.com/caraus-ecms/graphql/compare/v0.6.1.0...HEAD
+[0.7.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.6.1.0...v0.7.0.0
+[0.6.1.0]: https://github.com/caraus-ecms/graphql/compare/v0.6.0.0...v0.6.1.0
+[0.6.0.0]: https://github.com/caraus-ecms/graphql/compare/v0.5.1.0...v0.6.0.0
+[0.5.1.0]: https://github.com/caraus-ecms/graphql/compare/v0.5.0.1...v0.5.1.0
+[0.5.0.1]: https://github.com/caraus-ecms/graphql/compare/v0.5.0.0...v0.5.0.1
+[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

CONTRIBUTING.md

@@ -0,0 +1,31 @@
+# Contributing guidelines
+
+## Testing
+
+To ensure all code changes adhere to existing code quality standards, some
+automatic checks can be run locally.
+
+Ensure that the code builds without warnings and passes the tests:
+
+```sh
+stack test --pedantic
+```
+
+And also run the linter on your code:
+
+```sh
+stack build hlint
+stack exec hlint -- src tests
+```
+
+Build the documentation and check if you get any warnings:
+
+```sh
+stack haddock
+```
+
+Validate that literate Haskell (tutorials) files compile without any warnings:
+
+```sh
+stack ghc -- -Wall -fno-code docs/tutorial/*.lhs
+```

Data/GraphQL/AST.hs

@@ -1,147 +0,0 @@
-module Data.GraphQL.AST where
-
-import Data.Int (Int32)
-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    Node
-                         | Mutation Node
-                           deriving (Eq,Show)
-
-data Node = Node Name [VariableDefinition] [Directive] SelectionSet
-            deriving (Eq,Show)
-
-data VariableDefinition = VariableDefinition Variable Type (Maybe DefaultValue)
-                          deriving (Eq,Show)
-
-newtype Variable = Variable Name deriving (Eq,Show)
-
-type SelectionSet = [Selection]
-
-data Selection = SelectionField Field
-               | SelectionFragmentSpread FragmentSpread
-               | SelectionInlineFragment InlineFragment
-                 deriving (Eq,Show)
-
-data Field = Field Alias Name [Argument]
-                              [Directive]
-                              SelectionSet
-             deriving (Eq,Show)
-
-type Alias = Name
-
-data Argument = Argument Name Value deriving (Eq,Show)
-
--- * Fragments
-
-data FragmentSpread = FragmentSpread Name [Directive]
-                      deriving (Eq,Show)
-
-data InlineFragment =
-    InlineFragment TypeCondition [Directive] SelectionSet
-    deriving (Eq,Show)
-
-data FragmentDefinition =
-    FragmentDefinition Name TypeCondition [Directive] SelectionSet
-    deriving (Eq,Show)
-
-type TypeCondition = NamedType
-
--- * Values
-
-data Value = ValueVariable Variable
-           | ValueInt Int32
-           -- GraphQL Float is double precison
-           | ValueFloat Double
-           | ValueBoolean Bool
-           | ValueString StringValue
-           | ValueEnum Name
-           | ValueList ListValue
-           | ValueObject ObjectValue
-             deriving (Eq,Show)
-
-newtype StringValue = StringValue Text 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 [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 Interfaces [FieldDefinition]
-                            deriving (Eq,Show)
-
-type Interfaces = [NamedType]
-
-data FieldDefinition = FieldDefinition Name ArgumentsDefinition Type
-                       deriving (Eq,Show)
-
-type ArgumentsDefinition = [InputValueDefinition]
-
-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)

Data/GraphQL/Encoder.hs

@@ -1,246 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE OverloadedStrings #-}
-module Data.GraphQL.Encoder where
-
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative ((<$>))
-import Data.Monoid (Monoid, mconcat, mempty)
-#endif
-import Data.Monoid ((<>))
-
-import Data.Text (Text, cons, intercalate, pack, snoc)
-
-import Data.GraphQL.AST
-
--- * Document
-
--- TODO: Use query shorthand
-document :: Document -> Text
-document (Document defs) = (`snoc` '\n') . mconcat $ definition <$> defs
-
-definition :: Definition -> Text
-definition (DefinitionOperation x) = operationDefinition x
-definition (DefinitionFragment  x) = fragmentDefinition x
-definition (DefinitionType      x) = typeDefinition x
-
-operationDefinition :: OperationDefinition -> Text
-operationDefinition (Query    n) = "query "    <> node n
-operationDefinition (Mutation n) = "mutation " <> node n
-
-node :: Node -> Text
-node (Node name vds ds ss) =
-       name
-    <> optempty variableDefinitions vds
-    <> optempty directives ds
-    <> selectionSet ss
-
-variableDefinitions :: [VariableDefinition] -> Text
-variableDefinitions = parensCommas variableDefinition
-
-variableDefinition :: VariableDefinition -> Text
-variableDefinition (VariableDefinition var ty dv) =
-    variable var <> ":" <> type_ ty <> maybe mempty defaultValue dv
-
-defaultValue :: DefaultValue -> Text
-defaultValue val = "=" <> value val
-
-variable :: Variable -> Text
-variable (Variable name) = "$" <> name
-
-selectionSet :: SelectionSet -> Text
-selectionSet = bracesCommas selection
-
-selection :: Selection -> Text
-selection (SelectionField          x) = field x
-selection (SelectionInlineFragment x) = inlineFragment x
-selection (SelectionFragmentSpread x) = fragmentSpread x
-
-field :: Field -> Text
-field (Field alias name args ds ss) =
-       optempty (`snoc` ':') alias
-    <> name
-    <> optempty arguments args
-    <> optempty directives ds
-    <> optempty selectionSet ss
-
-arguments :: [Argument] -> Text
-arguments = parensCommas argument
-
-argument :: Argument -> Text
-argument (Argument name v) = name <> ":" <> value v
-
--- * Fragments
-
-fragmentSpread :: FragmentSpread -> Text
-fragmentSpread (FragmentSpread name ds) =
-    "..." <> name <> optempty directives ds
-
-inlineFragment :: InlineFragment -> Text
-inlineFragment (InlineFragment (NamedType tc) ds ss) =
-    "... on " <> tc
-              <> optempty directives ds
-              <> optempty selectionSet ss
-
-fragmentDefinition :: FragmentDefinition -> Text
-fragmentDefinition (FragmentDefinition name (NamedType tc) ds ss) =
-    "fragment " <> name <> " on " <> tc
-                <> optempty directives ds
-                <> selectionSet ss
-
--- * Values
-
-value :: Value -> Text
-value (ValueVariable x) = variable x
--- TODO: This will be replaced with `decimal` Buidler
-value (ValueInt      x) = pack $ show x
--- TODO: This will be replaced with `decimal` Buidler
-value (ValueFloat    x) = pack $ show x
-value (ValueBoolean  x) = booleanValue x
-value (ValueString   x) = stringValue x
-value (ValueEnum     x) = x
-value (ValueList     x) = listValue x
-value (ValueObject   x) = objectValue x
-
-booleanValue :: Bool -> Text
-booleanValue True  = "true"
-booleanValue False = "false"
-
--- TODO: Escape characters
-stringValue :: StringValue -> Text
-stringValue (StringValue v) = quotes v
-
-listValue :: ListValue -> Text
-listValue (ListValue vs) = bracketsCommas value vs
-
-objectValue :: ObjectValue -> Text
-objectValue (ObjectValue ofs) = bracesCommas objectField ofs
-
-objectField :: ObjectField -> Text
-objectField (ObjectField name v) = name <> ":" <> value v
-
--- * Directives
-
-directives :: [Directive] -> Text
-directives = spaces directive
-
-directive :: Directive -> Text
-directive (Directive name args) = "@" <> name <> optempty arguments args
-
--- * Type Reference
-
-type_ :: Type -> Text
-type_ (TypeNamed (NamedType x)) = x
-type_ (TypeList x) = listType x
-type_ (TypeNonNull x) = nonNullType x
-
-namedType :: NamedType -> Text
-namedType (NamedType name) = name
-
-listType :: ListType -> Text
-listType (ListType ty) = brackets (type_ ty)
-
-nonNullType :: NonNullType -> Text
-nonNullType (NonNullTypeNamed (NamedType x)) = x <> "!"
-nonNullType (NonNullTypeList  x) = listType x <> "!"
-
-typeDefinition :: TypeDefinition -> Text
-typeDefinition (TypeDefinitionObject        x) = objectTypeDefinition x
-typeDefinition (TypeDefinitionInterface     x) = interfaceTypeDefinition x
-typeDefinition (TypeDefinitionUnion         x) = unionTypeDefinition x
-typeDefinition (TypeDefinitionScalar        x) = scalarTypeDefinition x
-typeDefinition (TypeDefinitionEnum          x) = enumTypeDefinition x
-typeDefinition (TypeDefinitionInputObject   x) = inputObjectTypeDefinition x
-typeDefinition (TypeDefinitionTypeExtension x) = typeExtensionDefinition x
-
-objectTypeDefinition :: ObjectTypeDefinition -> Text
-objectTypeDefinition (ObjectTypeDefinition name ifaces fds) =
-    "type " <> name
-            <> optempty (spaced . interfaces) ifaces
-            <> optempty fieldDefinitions fds
-
-interfaces :: Interfaces -> Text
-interfaces = ("implements " <>) . spaces namedType
-
-fieldDefinitions :: [FieldDefinition] -> Text
-fieldDefinitions = bracesCommas fieldDefinition
-
-fieldDefinition :: FieldDefinition -> Text
-fieldDefinition (FieldDefinition name args ty) =
-    name <> optempty argumentsDefinition args
-         <> ":"
-         <> type_ ty
-
-argumentsDefinition :: ArgumentsDefinition -> Text
-argumentsDefinition = parensCommas inputValueDefinition
-
-interfaceTypeDefinition :: InterfaceTypeDefinition -> Text
-interfaceTypeDefinition (InterfaceTypeDefinition name fds) =
-    "interface " <> name <> fieldDefinitions fds
-
-unionTypeDefinition :: UnionTypeDefinition -> Text
-unionTypeDefinition (UnionTypeDefinition name ums) =
-    "union " <> name <> "=" <> unionMembers ums
-
-unionMembers :: [NamedType] -> Text
-unionMembers = intercalate "|" . fmap namedType
-
-scalarTypeDefinition :: ScalarTypeDefinition -> Text
-scalarTypeDefinition (ScalarTypeDefinition name) = "scalar " <> name
-
-enumTypeDefinition :: EnumTypeDefinition -> Text
-enumTypeDefinition (EnumTypeDefinition name evds) =
-    "enum " <> name
-            <> bracesCommas enumValueDefinition evds
-
-enumValueDefinition :: EnumValueDefinition -> Text
-enumValueDefinition (EnumValueDefinition name) = name
-
-inputObjectTypeDefinition :: InputObjectTypeDefinition -> Text
-inputObjectTypeDefinition (InputObjectTypeDefinition name ivds) =
-    "input " <> name <> inputValueDefinitions ivds
-
-inputValueDefinitions :: [InputValueDefinition] -> Text
-inputValueDefinitions = bracesCommas inputValueDefinition
-
-inputValueDefinition :: InputValueDefinition -> Text
-inputValueDefinition (InputValueDefinition name ty dv) =
-    name <> ":" <> type_ ty <> maybe mempty defaultValue dv
-
-typeExtensionDefinition :: TypeExtensionDefinition -> Text
-typeExtensionDefinition (TypeExtensionDefinition otd) =
-    "extend " <> objectTypeDefinition otd
-
--- * Internal
-
-spaced :: Text -> Text
-spaced = cons '\SP'
-
-between :: Char -> Char -> Text -> Text
-between open close = cons open . (`snoc` close)
-
-parens :: Text -> Text
-parens = between '(' ')'
-
-brackets :: Text -> Text
-brackets = between '[' ']'
-
-braces :: Text -> Text
-braces = between '{' '}'
-
-quotes :: Text -> Text
-quotes = between '"' '"'
-
-spaces :: (a -> Text) -> [a] -> Text
-spaces f = intercalate "\SP" . fmap f
-
-parensCommas :: (a -> Text) -> [a] -> Text
-parensCommas f = parens . intercalate "," . fmap f
-
-bracketsCommas :: (a -> Text) -> [a] -> Text
-bracketsCommas f = brackets . intercalate "," . fmap f
-
-bracesCommas :: (a -> Text) -> [a] -> Text
-bracesCommas f = braces . intercalate "," . fmap f
-
-optempty :: (Eq a, Monoid a, Monoid b) => (a -> b) -> a -> b
-optempty f xs = if xs == mempty then mempty else f xs

Data/GraphQL/Parser.hs

@@ -1,336 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE OverloadedStrings #-}
-module Data.GraphQL.Parser where
-
-import Prelude hiding (takeWhile)
-
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative ((<$>), (<*>), (*>), (<*), (<$), pure)
-import Data.Monoid (Monoid, mempty)
-#endif
-import Control.Applicative ((<|>), empty, many, optional)
-import Control.Monad (when)
-import Data.Char (isDigit, isSpace)
-import Data.Foldable (traverse_)
-
-import Data.Text (Text, append)
-import Data.Attoparsec.Text
-  ( Parser
-  , (<?>)
-  , anyChar
-  , decimal
-  , double
-  , endOfLine
-  , inClass
-  , many1
-  , manyTill
-  , option
-  , peekChar
-  , sepBy1
-  , signed
-  , takeWhile
-  , takeWhile1
-  )
-
-import Data.GraphQL.AST
-
--- * Name
-
-name :: Parser Name
-name = tok $ append <$> takeWhile1 isA_z
-                    <*> takeWhile ((||) <$> isDigit <*> isA_z)
-  where
-    -- `isAlpha` handles many more Unicode Chars
-    isA_z =  inClass $ '_' : ['A'..'Z'] ++ ['a'..'z']
-
--- * Document
-
-document :: Parser Document
-document = whiteSpace
-     *> (Document <$> many1 definition)
-    -- Try SelectionSet when no definition
-    <|> (Document . pure
-                  . DefinitionOperation
-                  . Query
-                  . Node mempty empty empty
-                <$> selectionSet)
-    <?> "document error!"
-
-definition :: Parser Definition
-definition = DefinitionOperation <$> operationDefinition
-         <|> DefinitionFragment  <$> fragmentDefinition
-         <|> DefinitionType      <$> typeDefinition
-         <?> "definition error!"
-
-operationDefinition :: Parser OperationDefinition
-operationDefinition =
-        Query    <$ tok "query"    <*> node
-    <|> Mutation <$ tok "mutation" <*> node
-    <?> "operationDefinition error!"
-
-node :: Parser Node
-node = Node <$> name
-            <*> optempty variableDefinitions
-            <*> optempty directives
-            <*> selectionSet
-
-variableDefinitions :: Parser [VariableDefinition]
-variableDefinitions = parens (many1 variableDefinition)
-
-variableDefinition :: Parser VariableDefinition
-variableDefinition =
-    VariableDefinition <$> variable
-                       <*  tok ":"
-                       <*> type_
-                       <*> optional defaultValue
-
-defaultValue :: Parser DefaultValue
-defaultValue = tok "=" *> value
-
-variable :: Parser Variable
-variable = Variable <$ tok "$" <*> name
-
-selectionSet :: Parser SelectionSet
-selectionSet = braces $ many1 selection
-
-selection :: Parser Selection
-selection = SelectionField <$> field
-            -- Inline first to catch `on` case
-        <|> SelectionInlineFragment <$> inlineFragment
-        <|> SelectionFragmentSpread <$> fragmentSpread
-        <?> "selection error!"
-
-field :: Parser Field
-field = Field <$> optempty alias
-              <*> name
-              <*> optempty arguments
-              <*> optempty directives
-              <*> optempty selectionSet
-
-alias :: Parser Alias
-alias = name <* tok ":"
-
-arguments :: Parser [Argument]
-arguments = parens $ many1 argument
-
-argument :: Parser Argument
-argument = Argument <$> name <* tok ":" <*> value
-
--- * Fragments
-
-fragmentSpread :: Parser FragmentSpread
--- TODO: Make sure it fails when `... on`.
--- See https://facebook.github.io/graphql/#FragmentSpread
-fragmentSpread = FragmentSpread
-    <$  tok "..."
-    <*> name
-    <*> optempty directives
-
--- InlineFragment tried first in order to guard against 'on' keyword
-inlineFragment :: Parser InlineFragment
-inlineFragment = InlineFragment
-    <$  tok "..."
-    <*  tok "on"
-    <*> typeCondition
-    <*> optempty directives
-    <*> selectionSet
-
-fragmentDefinition :: Parser FragmentDefinition
-fragmentDefinition = FragmentDefinition
-    <$  tok "fragment"
-    <*> name
-    <*  tok "on"
-    <*> typeCondition
-    <*> optempty directives
-    <*> selectionSet
-
-typeCondition :: Parser TypeCondition
-typeCondition = namedType
-
--- * Values
-
--- This will try to pick the first type it can parse. If you are working with
--- explicit types use the `typedValue` parser.
-value :: Parser Value
-value = ValueVariable <$> variable
-    -- TODO: Handle maxBound, Int32 in spec.
-    <|> ValueInt      <$> tok (signed decimal)
-    <|> ValueFloat    <$> tok (signed double)
-    <|> ValueBoolean  <$> booleanValue
-    <|> ValueString   <$> stringValue
-    -- `true` and `false` have been tried before
-    <|> ValueEnum     <$> name
-    <|> ValueList     <$> listValue
-    <|> ValueObject   <$> objectValue
-    <?> "value error!"
-
-booleanValue :: Parser Bool
-booleanValue = True  <$ tok "true"
-   <|> False <$ tok "false"
-
--- TODO: Escape characters. Look at `jsstring_` in aeson package.
-stringValue :: Parser StringValue
-stringValue = StringValue <$> quotes (takeWhile (/= '"'))
-
--- Notice it can be empty
-listValue :: Parser ListValue
-listValue = ListValue <$> brackets (many value)
-
--- Notice it can be empty
-objectValue :: Parser ObjectValue
-objectValue = ObjectValue <$> braces (many objectField)
-
-objectField :: Parser ObjectField
-objectField = ObjectField <$> name <* tok ":" <*> value
-
--- * Directives
-
-directives :: Parser [Directive]
-directives = many1 directive
-
-directive :: Parser Directive
-directive = Directive
-    <$  tok "@"
-    <*> name
-    <*> optempty arguments
-
--- * Type Reference
-
-type_ :: Parser Type
-type_ = TypeList    <$> listType
-    <|> TypeNonNull <$> nonNullType
-    <|> TypeNamed   <$> namedType
-    <?> "type_ error!"
-
-namedType :: Parser NamedType
-namedType = NamedType <$> name
-
-listType :: Parser ListType
-listType = ListType <$> brackets type_
-
-nonNullType :: Parser NonNullType
-nonNullType = NonNullTypeNamed <$> namedType <* tok "!"
-          <|> NonNullTypeList  <$> listType  <* tok "!"
-          <?> "nonNullType error!"
-
--- * Type Definition
-
-typeDefinition :: Parser TypeDefinition
-typeDefinition =
-        TypeDefinitionObject        <$> objectTypeDefinition
-    <|> TypeDefinitionInterface     <$> interfaceTypeDefinition
-    <|> TypeDefinitionUnion         <$> unionTypeDefinition
-    <|> TypeDefinitionScalar        <$> scalarTypeDefinition
-    <|> TypeDefinitionEnum          <$> enumTypeDefinition
-    <|> TypeDefinitionInputObject   <$> inputObjectTypeDefinition
-    <|> TypeDefinitionTypeExtension <$> typeExtensionDefinition
-    <?> "typeDefinition error!"
-
-objectTypeDefinition :: Parser ObjectTypeDefinition
-objectTypeDefinition = ObjectTypeDefinition
-    <$  tok "type"
-    <*> name
-    <*> optempty interfaces
-    <*> fieldDefinitions
-
-interfaces :: Parser Interfaces
-interfaces = tok "implements" *> many1 namedType
-
-fieldDefinitions :: Parser [FieldDefinition]
-fieldDefinitions = braces $ many1 fieldDefinition
-
-fieldDefinition :: Parser FieldDefinition
-fieldDefinition = FieldDefinition
-    <$> name
-    <*> optempty argumentsDefinition
-    <*  tok ":"
-    <*> type_
-
-argumentsDefinition :: Parser ArgumentsDefinition
-argumentsDefinition = parens $ many1 inputValueDefinition
-
-interfaceTypeDefinition :: Parser InterfaceTypeDefinition
-interfaceTypeDefinition = InterfaceTypeDefinition
-    <$  tok "interface"
-    <*> name
-    <*> fieldDefinitions
-
-unionTypeDefinition :: Parser UnionTypeDefinition
-unionTypeDefinition = UnionTypeDefinition
-    <$  tok "union"
-    <*> name
-    <*  tok "="
-    <*> unionMembers
-
-unionMembers :: Parser [NamedType]
-unionMembers = namedType `sepBy1` tok "|"
-
-scalarTypeDefinition :: Parser ScalarTypeDefinition
-scalarTypeDefinition = ScalarTypeDefinition
-    <$  tok "scalar"
-    <*> name
-
-enumTypeDefinition :: Parser EnumTypeDefinition
-enumTypeDefinition = EnumTypeDefinition
-    <$  tok "enum"
-    <*> name
-    <*> enumValueDefinitions
-
-enumValueDefinitions :: Parser [EnumValueDefinition]
-enumValueDefinitions = braces $ many1 enumValueDefinition
-
-enumValueDefinition :: Parser EnumValueDefinition
-enumValueDefinition = EnumValueDefinition <$> name
-
-inputObjectTypeDefinition :: Parser InputObjectTypeDefinition
-inputObjectTypeDefinition = InputObjectTypeDefinition
-    <$  tok "input"
-    <*> name
-    <*> inputValueDefinitions
-
-inputValueDefinitions :: Parser [InputValueDefinition]
-inputValueDefinitions = braces $ many1 inputValueDefinition
-
-inputValueDefinition :: Parser InputValueDefinition
-inputValueDefinition = InputValueDefinition
-    <$> name
-    <*  tok ":"
-    <*> type_
-    <*> optional defaultValue
-
-typeExtensionDefinition :: Parser TypeExtensionDefinition
-typeExtensionDefinition = TypeExtensionDefinition
-    <$  tok "extend"
-    <*> objectTypeDefinition
-
--- * Internal
-
-tok :: Parser a -> Parser a
-tok p = p <* whiteSpace
-
-parens :: Parser a -> Parser a
-parens = between "(" ")"
-
-braces :: Parser a -> Parser a
-braces = between "{" "}"
-
-quotes :: Parser a -> Parser a
-quotes = between "\"" "\""
-
-brackets :: Parser a -> Parser a
-brackets = between "[" "]"
-
-between :: Parser Text -> Parser Text -> Parser a -> Parser a
-between open close p = tok open *> p <* tok close
-
--- `empty` /= `pure mempty` for `Parser`.
-optempty :: Monoid a => Parser a -> Parser a
-optempty = option mempty
-
--- ** WhiteSpace
---
-whiteSpace :: Parser ()
-whiteSpace = peekChar >>= traverse_ (\c ->
-    if isSpace c || c == ','
-       then anyChar *> whiteSpace
-       else when (c == '#') $ manyTill anyChar endOfLine *> whiteSpace)

LICENSE

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

README.md

@@ -1,28 +1,48 @@
 # Haskell GraphQL
 
 [![Hackage Version](https://img.shields.io/hackage/v/graphql.svg)](https://hackage.haskell.org/package/graphql)
-[![Build Status](https://img.shields.io/travis/jdnavarro/graphql-haskell.svg)](https://travis-ci.org/jdnavarro/graphql-haskell)
+[![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.
 
-- [x] GraphQL AST
-- [x] Parser for the GraphQL language. See TODO for limitations.
-- [x] Printer for GraphQL. This is not pretty yet.
-- [ ] GraphQL Schema AST.
-- [ ] Parser for the GraphQL Schema language.
-- [ ] Printer 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, so other solutions can
+be built on top of it.
 
-See the TODO file for more concrete tasks.
+## 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).
+
+## Further information
+
+- [Contributing guidelines](CONTRIBUTING.md).
+- [Changelog](CHANGELOG.md) – this one contains the most recent changes; 
+  individual changelogs for specific versions can be found on
+  [Hackage](https://hackage.haskell.org/package/graphql).
 
 ## Contact
 
 Suggestions, contributions and bug reports are welcome.
 
+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,21 +0,0 @@
-## AST
-- Docs
-- Simplify unnecessary `newtypes` with type synonyms
-- Simplify wrapper type constructors. Some types can be just constructors.
-- Data type accessors
-- Deal with strictness/unboxing
-- Deal with location
-
-## Parser
-- Docs
-- Handle escape characters in string literals
-- Guard for `on` in `FragmentSpread`
-- Handle `[Const]` grammar parameter. Need examples
-- Handle `maxBound` Int values.
-- Diagnostics. Perhaps port to `parsers` and use `trifecta` for diagnostics,
-  and `attoparsec` for performance.
-- Optimize `whiteSpace`, perhaps front the main parser with a lexer.
-
-## Printer
-- Add pretty printer.
-- Docs

docs/tutorial/tutorial.lhs

@@ -0,0 +1,151 @@
+---
+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 #-}
+> module Main where
+>
+> import Control.Monad.IO.Class (liftIO)
+> import Data.Aeson (encode)
+> import Data.ByteString.Lazy.Char8 (putStrLn)
+> import Data.HashMap.Strict (HashMap)
+> import qualified Data.HashMap.Strict as HashMap
+> import Data.List.NonEmpty (NonEmpty(..))
+> import Data.Text (Text)
+> import Data.Time (getCurrentTime)
+>
+> import Language.GraphQL
+> import qualified Language.GraphQL.Schema as Schema
+>
+> 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 :: HashMap Text (NonEmpty (Schema.Resolver IO))
+> schema1 = HashMap.singleton "Query" $ 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 :: HashMap Text (NonEmpty (Schema.Resolver IO))
+> schema2 = HashMap.singleton "Query" $ time :| []
+>
+> time :: Schema.Resolver IO
+> time = Schema.scalar "time" $ do
+>   t <- liftIO getCurrentTime
+>   return $ show t
+
+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 :: HashMap Text (NonEmpty (Schema.Resolver IO))
+> schema3 = HashMap.singleton "Query" $ 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,48 +0,0 @@
-name:                graphql
-version:             0.3
-synopsis:            Haskell GraphQL implementation
-description:
-  This package provides a rudimentary parser for the
-  <https://facebook.github.io/graphql/ GraphQL> language.
-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
-cabal-version:       >=1.10
-tested-with:         GHC == 7.8.4, GHC == 7.10.2
-extra-source-files:  README.md CHANGELOG.md stack.yaml
-data-files:          tests/data/*.graphql
-                     tests/data/*.min.graphql
-
-library
-  default-language:    Haskell2010
-  ghc-options:         -Wall
-  exposed-modules:     Data.GraphQL.AST
-                       Data.GraphQL.Encoder
-                       Data.GraphQL.Parser
-  build-depends:       base >=4.7 && < 5,
-                       text >=0.11.3.1,
-                       attoparsec >=0.10.4.0
-
-test-suite tasty
-  default-language:    Haskell2010
-  type:                exitcode-stdio-1.0
-  hs-source-dirs:      tests
-  main-is:             tasty.hs
-  ghc-options:         -Wall
-  other-modules:       Paths_graphql
-  build-depends:       base >=4.6 && <5,
-                       text >=0.11.3.1,
-                       attoparsec >=0.10.4.0,
-                       tasty >=0.10,
-                       tasty-hunit >=0.9,
-                       graphql
-
-source-repository head
-  type:     git
-  location: git://github.com/jdnavarro/graphql-haskell.git

package.yaml

@@ -0,0 +1,58 @@
+name:                graphql
+version:             0.7.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-2020 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
+- containers
+- megaparsec
+- parser-combinators
+- text
+- transformers
+- unordered-containers
+
+library:
+  source-dirs: src
+  other-modules:
+  - Language.GraphQL.Execute.Transform
+  - Language.GraphQL.Type.Directive
+
+tests:
+  tasty:
+    main: Spec.hs
+    source-dirs: tests
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    dependencies:
+    - graphql
+    - hspec
+    - hspec-expectations
+    - hspec-megaparsec
+    - QuickCheck
+    - raw-strings-qq

semaphoreci.sh

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

src/Language/GraphQL.hs

@@ -0,0 +1,35 @@
+-- | This module provides the functions to parse and execute @GraphQL@ queries.
+module Language.GraphQL
+    ( graphql
+    , graphqlSubs
+    ) where
+
+import qualified Data.Aeson as Aeson
+import Data.List.NonEmpty (NonEmpty)
+import Data.HashMap.Strict (HashMap)
+import Data.Text (Text)
+import Language.GraphQL.Error
+import Language.GraphQL.Execute
+import Language.GraphQL.AST.Parser
+import qualified Language.GraphQL.Schema as Schema
+import Text.Megaparsec (parse)
+
+-- | If the text parses correctly as a @GraphQL@ query the query is
+-- executed using the given 'Schema.Resolver's.
+graphql :: Monad m
+    => HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers.
+    -> Text -- ^ Text representing a @GraphQL@ request document.
+    -> m Aeson.Value -- ^ Response.
+graphql = flip graphqlSubs mempty
+
+-- | If the text parses correctly as a @GraphQL@ query the substitution is
+-- applied to the query and the query is then executed using to the given
+-- 'Schema.Resolver's.
+graphqlSubs :: Monad m
+    => HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers.
+    -> Schema.Subs -- ^ Variable substitution function.
+    -> Text -- ^ Text representing a @GraphQL@ request document.
+    -> m Aeson.Value -- ^ Response.
+graphqlSubs schema f
+    = either parseError (execute schema f)
+    . parse document ""

src/Language/GraphQL/AST.hs

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

src/Language/GraphQL/AST/Core.hs

@@ -0,0 +1,78 @@
+-- | This is the AST meant to be executed.
+module Language.GraphQL.AST.Core
+    ( Alias
+    , Arguments(..)
+    , Directive(..)
+    , Document
+    , Field(..)
+    , Fragment(..)
+    , Name
+    , Operation(..)
+    , Selection(..)
+    , TypeCondition
+    , Value(..)
+    ) where
+
+import Data.Int (Int32)
+import Data.HashMap.Strict (HashMap)
+import Data.List.NonEmpty (NonEmpty)
+import Data.Sequence (Seq)
+import Data.String (IsString(..))
+import Data.Text (Text)
+import Language.GraphQL.AST (Alias, Name, TypeCondition)
+
+-- | GraphQL document is a non-empty list of operations.
+type Document = NonEmpty Operation
+
+-- | GraphQL has 3 operation types: queries, mutations and subscribtions.
+--
+-- Currently only queries and mutations are supported.
+data Operation
+    = Query (Maybe Text) (Seq Selection)
+    | Mutation (Maybe Text) (Seq Selection)
+    deriving (Eq, Show)
+
+-- | Single GraphQL field.
+data Field
+    = Field (Maybe Alias) Name Arguments (Seq Selection)
+    deriving (Eq, Show)
+
+-- | Argument list.
+newtype Arguments = Arguments (HashMap Name Value)
+    deriving (Eq, Show)
+
+instance Semigroup Arguments where
+    (Arguments x) <> (Arguments y) = Arguments $ x <> y
+
+instance Monoid Arguments where
+    mempty = Arguments mempty
+
+-- | Directive.
+data Directive = Directive Name Arguments
+    deriving (Eq, Show)
+
+-- | Represents fragments and inline fragments.
+data Fragment
+    = Fragment TypeCondition (Seq Selection)
+    deriving (Eq, Show)
+
+-- | Single selection element.
+data Selection
+    = SelectionFragment Fragment
+    | SelectionField Field
+    deriving (Eq, Show)
+
+-- | Represents accordingly typed GraphQL values.
+data Value
+    = Int Int32
+    | Float Double -- ^ GraphQL Float is double precision
+    | String Text
+    | Boolean Bool
+    | Null
+    | Enum Name
+    | List [Value]
+    | Object (HashMap Name Value)
+    deriving (Eq, Show)
+
+instance IsString Value where
+    fromString = String . fromString

src/Language/GraphQL/AST/DirectiveLocation.hs

@@ -0,0 +1,41 @@
+-- | Various parts of a GraphQL document can be annotated with directives. 
+--   This module describes locations in a document where directives can appear.
+module Language.GraphQL.AST.DirectiveLocation
+    ( DirectiveLocation(..)
+    , ExecutableDirectiveLocation(..)
+    , TypeSystemDirectiveLocation(..)
+    ) where
+
+-- | All directives can be splitted in two groups: directives used to annotate
+--   various parts of executable definitions and the ones used in the schema
+--   definition.
+data DirectiveLocation
+    = ExecutableDirectiveLocation ExecutableDirectiveLocation
+    | TypeSystemDirectiveLocation TypeSystemDirectiveLocation
+    deriving (Eq, Show)
+
+-- | Where directives can appear in an executable definition, like a query.
+data ExecutableDirectiveLocation
+    = Query
+    | Mutation
+    | Subscription
+    | Field
+    | FragmentDefinition
+    | FragmentSpread
+    | InlineFragment
+    deriving (Eq, Show)
+
+-- | Where directives can appear in a type system definition.
+data TypeSystemDirectiveLocation
+    = Schema
+    | Scalar
+    | Object
+    | FieldDefinition
+    | ArgumentDefinition
+    | Interface
+    | Union
+    | Enum
+    | EnumValue
+    | InputObject
+    | InputFieldDefinition
+    deriving (Eq, Show)

src/Language/GraphQL/AST/Document.hs

@@ -0,0 +1,486 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | This module defines an abstract syntax tree for the @GraphQL@ language. It
+-- follows closely the structure given in the specification. Please refer to
+-- <https://facebook.github.io/graphql/ Facebook's GraphQL Specification>.
+-- for more information.
+module Language.GraphQL.AST.Document
+    ( Alias
+    , Argument(..)
+    , ArgumentsDefinition(..)
+    , Definition(..)
+    , Description(..)
+    , Directive(..)
+    , Document
+    , EnumValueDefinition(..)
+    , ExecutableDefinition(..)
+    , FieldDefinition(..)
+    , FragmentDefinition(..)
+    , ImplementsInterfaces(..)
+    , InputValueDefinition(..)
+    , Name
+    , NamedType
+    , NonNullType(..)
+    , ObjectField(..)
+    , OperationDefinition(..)
+    , OperationType(..)
+    , OperationTypeDefinition(..)
+    , SchemaExtension(..)
+    , Selection(..)
+    , SelectionSet
+    , SelectionSetOpt
+    , Type(..)
+    , TypeCondition
+    , TypeDefinition(..)
+    , TypeExtension(..)
+    , TypeSystemDefinition(..)
+    , TypeSystemExtension(..)
+    , UnionMemberTypes(..)
+    , Value(..)
+    , VariableDefinition(..)
+    ) where
+
+import Data.Foldable (toList)
+import Data.Int (Int32)
+import Data.List.NonEmpty (NonEmpty)
+import Data.Text (Text)
+import qualified Data.Text as Text
+import Language.GraphQL.AST.DirectiveLocation
+
+-- * Language
+
+-- ** Source Text
+
+-- | Name.
+type Name = Text
+
+-- ** Document
+
+-- | GraphQL document.
+type Document = NonEmpty Definition
+
+-- | All kinds of definitions that can occur in a GraphQL document.
+data Definition
+    = ExecutableDefinition ExecutableDefinition
+    | TypeSystemDefinition TypeSystemDefinition
+    | TypeSystemExtension TypeSystemExtension
+    deriving (Eq, Show)
+
+-- | Top-level definition of a document, either an operation or a fragment.
+data ExecutableDefinition
+    = DefinitionOperation OperationDefinition
+    | DefinitionFragment FragmentDefinition
+    deriving (Eq, Show)
+
+-- ** Operations
+
+-- | Operation definition.
+data OperationDefinition
+    = SelectionSet SelectionSet
+    | OperationDefinition
+        OperationType
+        (Maybe Name)
+        [VariableDefinition]
+        [Directive]
+        SelectionSet
+    deriving (Eq, Show)
+
+-- | GraphQL has 3 operation types:
+--
+-- * query - a read-only fetch.
+-- * mutation - a write operation followed by a fetch.
+-- * subscription - a long-lived request that fetches data in response to
+-- source events.
+--
+-- Currently only queries and mutations are supported.
+data OperationType = Query | Mutation deriving (Eq, Show)
+
+-- ** Selection Sets
+
+-- | "Top-level" selection, selection on an operation or fragment.
+type SelectionSet = NonEmpty Selection
+
+-- | Field selection.
+type SelectionSetOpt = [Selection]
+
+-- | Selection is a single entry in a selection set. It can be a single field,
+-- fragment spread or inline fragment.
+--
+-- The only required property of a field is its name. Optionally it can also
+-- have an alias, arguments, directives and a list of subfields.
+--
+-- In the following query "user" is a field with two subfields, "id" and "name":
+--
+-- @
+-- {
+--   user {
+--     id
+--     name
+--   }
+-- }
+-- @
+--
+-- A fragment spread refers to a fragment defined outside the operation and is
+-- expanded at the execution time.
+--
+-- @
+-- {
+--   user {
+--     ...userFragment
+--   }
+-- }
+--
+-- fragment userFragment on UserType {
+--   id
+--   name
+-- }
+-- @
+--
+-- Inline fragments are similar but they don't have any name and the type
+-- condition ("on UserType") is optional.
+--
+-- @
+-- {
+--   user {
+--     ... on UserType {
+--       id
+--       name
+--     }
+-- }
+-- @
+data Selection
+    = Field (Maybe Alias) Name [Argument] [Directive] SelectionSetOpt
+    | FragmentSpread Name [Directive]
+    | InlineFragment (Maybe TypeCondition) [Directive] SelectionSet
+    deriving (Eq, Show)
+
+-- ** Arguments
+
+-- | Single argument.
+--
+-- @
+-- {
+--   user(id: 4) {
+--     name
+--   }
+-- }
+-- @
+--
+--  Here "id" is an argument for the field "user" and its value is 4.
+data Argument = Argument Name Value deriving (Eq,Show)
+
+-- ** Field Alias
+
+-- | Alternative field name.
+--
+-- @
+-- {
+--   smallPic: profilePic(size: 64)
+--   bigPic: profilePic(size: 1024)
+-- }
+-- @
+--
+-- Here "smallPic" and "bigPic" are aliases for the same field, "profilePic",
+-- used to distinquish between profile pictures with different arguments
+-- (sizes).
+type Alias = Name
+
+-- ** Fragments
+
+-- | Fragment definition.
+data FragmentDefinition
+    = FragmentDefinition Name TypeCondition [Directive] SelectionSet
+    deriving (Eq, Show)
+
+-- | Type condition.
+type TypeCondition = Name
+
+-- ** Input Values
+
+-- | Input value.
+data Value
+    = Variable Name
+    | Int Int32
+    | Float Double
+    | String Text
+    | Boolean Bool
+    | Null
+    | Enum Name
+    | List [Value]
+    | Object [ObjectField]
+    deriving (Eq, Show)
+
+-- | Key-value pair.
+--
+--   A list of 'ObjectField's represents a GraphQL object type.
+data ObjectField = ObjectField Name Value deriving (Eq, Show)
+
+-- ** Variables
+
+-- | Variable definition.
+data VariableDefinition = VariableDefinition Name Type (Maybe Value)
+    deriving (Eq, Show)
+
+-- ** Type References
+
+-- | Type representation.
+data Type
+    = TypeNamed Name
+    | TypeList Type
+    | TypeNonNull NonNullType
+    deriving (Eq, Show)
+
+-- | Represents type names.
+type NamedType = Name
+
+-- | Helper type to represent Non-Null types and lists of such types.
+data NonNullType
+    = NonNullTypeNamed Name
+    | NonNullTypeList Type
+    deriving (Eq, Show)
+
+-- ** Directives
+
+-- | Directive.
+--
+-- Directives begin with "@", can accept arguments, and can be applied to the
+-- most GraphQL elements, providing additional information.
+data Directive = Directive Name [Argument] deriving (Eq, Show)
+
+-- * Type System
+
+-- | Type system can define a schema, a type or a directive.
+--
+-- @
+-- schema {
+--   query: Query
+-- }
+--
+-- directive @example on FIELD_DEFINITION
+--
+-- type Query {
+--   field: String @example
+-- }
+-- @
+--
+-- This example defines a custom directive "@example", which is applied to a
+-- field definition of the type definition "Query". On the top the schema
+-- is defined by taking advantage of the type "Query".
+data TypeSystemDefinition
+    = SchemaDefinition [Directive] (NonEmpty OperationTypeDefinition)
+    | TypeDefinition TypeDefinition
+    | DirectiveDefinition
+        Description Name ArgumentsDefinition (NonEmpty DirectiveLocation)
+    deriving (Eq, Show)
+
+-- ** Type System Extensions
+
+-- | Extension for a type system definition. Only schema and type definitions
+-- can be extended.
+data TypeSystemExtension
+    = SchemaExtension SchemaExtension
+    | TypeExtension TypeExtension
+    deriving (Eq, Show)
+
+-- ** Schema
+
+-- | Root operation type definition.
+--
+-- Defining root operation types is not required since they have defaults. So
+-- the default query root type is "Query", and the default mutation root type
+-- is "Mutation". But these defaults can be changed for a specific schema. In
+-- the following code the query root type is changed to "MyQueryRootType", and
+-- the mutation root type to "MyMutationRootType":
+--
+-- @
+-- schema {
+--   query: MyQueryRootType
+--   mutation: MyMutationRootType
+-- }
+-- @
+data OperationTypeDefinition
+    = OperationTypeDefinition OperationType NamedType
+    deriving (Eq, Show)
+
+-- | Extension of the schema definition by further operations or directives.
+data SchemaExtension
+    = SchemaOperationExtension [Directive] (NonEmpty OperationTypeDefinition)
+    | SchemaDirectivesExtension (NonEmpty Directive)
+    deriving (Eq, Show)
+
+-- ** Descriptions
+
+-- | GraphQL has built-in capability to document service APIs. Documentation
+-- is a GraphQL string that precedes a particular definition and contains
+-- Markdown. Any GraphQL definition can be documented this way.
+--
+-- @
+-- """
+-- Supported languages.
+-- """
+-- enum Language {
+--   "English"
+--   EN
+--
+--   "Russian"
+--   RU
+-- }
+-- @
+newtype Description = Description (Maybe Text)
+    deriving (Eq, Show)
+
+-- ** Types
+
+-- | Type definitions describe various user-defined types.
+data TypeDefinition
+    = ScalarTypeDefinition Description Name [Directive]
+    | ObjectTypeDefinition
+        Description
+        Name
+        (ImplementsInterfaces [])
+        [Directive]
+        [FieldDefinition]
+    | InterfaceTypeDefinition Description Name [Directive] [FieldDefinition]
+    | UnionTypeDefinition Description Name [Directive] (UnionMemberTypes [])
+    | EnumTypeDefinition Description Name [Directive] [EnumValueDefinition]
+    | InputObjectTypeDefinition
+        Description Name [Directive] [InputValueDefinition]
+    deriving (Eq, Show)
+
+-- | Extensions for custom, already defined types.
+data TypeExtension
+    = ScalarTypeExtension Name (NonEmpty Directive)
+    | ObjectTypeFieldsDefinitionExtension
+        Name (ImplementsInterfaces []) [Directive] (NonEmpty FieldDefinition)
+    | ObjectTypeDirectivesExtension
+        Name (ImplementsInterfaces []) (NonEmpty Directive)
+    | ObjectTypeImplementsInterfacesExtension
+        Name (ImplementsInterfaces NonEmpty)
+    | InterfaceTypeFieldsDefinitionExtension
+        Name [Directive] (NonEmpty FieldDefinition)
+    | InterfaceTypeDirectivesExtension Name (NonEmpty Directive)
+    | UnionTypeUnionMemberTypesExtension
+        Name [Directive] (UnionMemberTypes NonEmpty)
+    | UnionTypeDirectivesExtension Name (NonEmpty Directive)
+    | EnumTypeEnumValuesDefinitionExtension
+        Name [Directive] (NonEmpty EnumValueDefinition)
+    | EnumTypeDirectivesExtension Name (NonEmpty Directive)
+    | InputObjectTypeInputFieldsDefinitionExtension
+        Name [Directive] (NonEmpty InputValueDefinition)
+    | InputObjectTypeDirectivesExtension Name (NonEmpty Directive)
+    deriving (Eq, Show)
+
+-- ** Objects
+
+-- | Defines a list of interfaces implemented by the given object type.
+--
+-- @
+-- type Business implements NamedEntity & ValuedEntity {
+--   name: String
+-- }
+-- @
+--
+-- Here the object type "Business" implements two interfaces: "NamedEntity" and
+-- "ValuedEntity".
+newtype ImplementsInterfaces t = ImplementsInterfaces (t NamedType)
+
+instance Foldable t => Eq (ImplementsInterfaces t) where
+    (ImplementsInterfaces xs) == (ImplementsInterfaces ys)
+        = toList xs == toList ys
+
+instance Foldable t => Show (ImplementsInterfaces t) where
+    show (ImplementsInterfaces interfaces) = Text.unpack
+        $ Text.append "implements"
+        $ Text.intercalate " & "
+        $ toList interfaces
+
+-- | Definition of a single field in a type.
+--
+-- @
+-- type Person {
+--   name: String
+--   picture(width: Int, height: Int): Url
+-- }
+-- @
+--
+-- "name" and "picture", including their arguments and types, are field
+-- definitions.
+data FieldDefinition
+    = FieldDefinition Description Name ArgumentsDefinition Type [Directive]
+    deriving (Eq, Show)
+
+-- | A list of values passed to a field.
+--
+-- @
+-- type Person {
+--   name: String
+--   picture(width: Int, height: Int): Url
+-- }
+-- @
+--
+-- "Person" has two fields, "name" and "picture". "name" doesn't have any
+-- arguments, so 'ArgumentsDefinition' contains an empty list. "picture"
+-- contains definitions for 2 arguments: "width" and "height".
+newtype ArgumentsDefinition = ArgumentsDefinition [InputValueDefinition]
+    deriving (Eq, Show)
+
+instance Semigroup ArgumentsDefinition where
+    (ArgumentsDefinition xs) <> (ArgumentsDefinition ys) =
+        ArgumentsDefinition $ xs <> ys
+
+instance Monoid ArgumentsDefinition where
+    mempty = ArgumentsDefinition []
+
+-- | Defines an input value.
+--
+-- * Input values can define field arguments, see 'ArgumentsDefinition'.
+-- * They can also be used as field definitions in an input type.
+--
+-- @
+-- input Point2D {
+--   x: Float
+--   y: Float
+-- }
+-- @
+--
+-- The input type "Point2D" contains two value definitions: "x" and "y".
+data InputValueDefinition
+    = InputValueDefinition Description Name Type (Maybe Value) [Directive]
+    deriving (Eq, Show)
+
+-- ** Unions
+
+-- | List of types forming a union.
+--
+-- @
+-- union SearchResult = Person | Photo
+-- @
+--
+-- "Person" and "Photo" are member types of the union "SearchResult".
+newtype UnionMemberTypes t = UnionMemberTypes (t NamedType)
+
+instance Foldable t => Eq (UnionMemberTypes t) where
+    (UnionMemberTypes xs) == (UnionMemberTypes ys) = toList xs == toList ys
+
+instance Foldable t => Show (UnionMemberTypes t) where
+    show (UnionMemberTypes memberTypes) = Text.unpack
+        $ Text.intercalate " | "
+        $ toList memberTypes
+
+-- ** Enums
+
+-- | Single value in an enum definition.
+--
+-- @
+-- enum Direction {
+--   NORTH
+--   EAST
+--   SOUTH
+--   WEST
+-- }
+-- @
+--
+-- "NORTH, "EAST", "SOUTH", and "WEST" are value definitions of an enum type
+-- definition "Direction".
+data EnumValueDefinition = EnumValueDefinition Description Name [Directive]
+    deriving (Eq, Show)

src/Language/GraphQL/AST/Encoder.hs

@@ -0,0 +1,344 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ExplicitForAll #-}
+
+-- | This module defines a minifier and a printer for the @GraphQL@ language.
+module Language.GraphQL.AST.Encoder
+    ( Formatter
+    , definition
+    , directive
+    , document
+    , minified
+    , pretty
+    , type'
+    , value
+    ) where
+
+import Data.Char (ord)
+import Data.Foldable (fold)
+import qualified Data.List.NonEmpty as NonEmpty
+import Data.Text (Text)
+import qualified Data.Text as Text
+import qualified Data.Text.Lazy as Lazy (Text)
+import qualified Data.Text.Lazy as Lazy.Text
+import Data.Text.Lazy.Builder (Builder)
+import qualified Data.Text.Lazy.Builder as Builder
+import Data.Text.Lazy.Builder.Int (decimal, hexadecimal)
+import Data.Text.Lazy.Builder.RealFloat (realFloat)
+import qualified Language.GraphQL.AST as Full
+import Language.GraphQL.AST.Document
+
+-- | Instructs the encoder whether the GraphQL document should be minified or
+--   pretty printed.
+--
+--   Use 'pretty' or '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 -> Lazy.Text
+document formatter defs
+    | Pretty _ <- formatter = Lazy.Text.intercalate "\n" encodeDocument
+    | Minified <-formatter = Lazy.Text.snoc (mconcat encodeDocument) '\n'
+  where
+    encodeDocument = foldr executableDefinition [] defs
+    executableDefinition (ExecutableDefinition x) acc = definition formatter x : acc
+    executableDefinition _ acc = acc
+
+-- | Converts a t'Full.ExecutableDefinition' into a string.
+definition :: Formatter -> ExecutableDefinition -> Lazy.Text
+definition formatter x
+    | Pretty _ <- formatter = Lazy.Text.snoc (encodeDefinition x) '\n'
+    | Minified <- formatter = encodeDefinition x
+  where
+    encodeDefinition (Full.DefinitionOperation operation)
+        = operationDefinition formatter operation
+    encodeDefinition (Full.DefinitionFragment fragment)
+        = fragmentDefinition formatter fragment
+
+-- | Converts a 'Full.OperationDefinition into a string.
+operationDefinition :: Formatter -> Full.OperationDefinition -> Lazy.Text
+operationDefinition formatter (Full.SelectionSet sels)
+    = selectionSet formatter sels
+operationDefinition formatter (Full.OperationDefinition Full.Query name vars dirs sels)
+    = "query " <> node formatter name vars dirs sels
+operationDefinition formatter (Full.OperationDefinition Full.Mutation name vars dirs sels)
+    = "mutation " <> node formatter name vars dirs sels
+
+-- | Converts a Full.Query or Full.Mutation into a string.
+node :: Formatter ->
+    Maybe Full.Name ->
+    [Full.VariableDefinition] ->
+    [Full.Directive] ->
+    Full.SelectionSet ->
+    Lazy.Text
+node formatter name vars dirs sels
+    = Lazy.Text.fromStrict (fold name)
+    <> optempty (variableDefinitions formatter) vars
+    <> optempty (directives formatter) dirs
+    <> eitherFormat formatter " " mempty
+    <> selectionSet formatter sels
+
+variableDefinitions :: Formatter -> [Full.VariableDefinition] -> Lazy.Text
+variableDefinitions formatter
+    = parensCommas formatter $ variableDefinition formatter
+
+variableDefinition :: Formatter -> Full.VariableDefinition -> Lazy.Text
+variableDefinition formatter (Full.VariableDefinition var ty dv)
+    = variable var
+    <> eitherFormat formatter ": " ":"
+    <> type' ty
+    <> maybe mempty (defaultValue formatter) dv
+
+defaultValue :: Formatter -> Full.Value -> Lazy.Text
+defaultValue formatter val
+    = eitherFormat formatter " = " "="
+    <> value formatter val
+
+variable :: Full.Name -> Lazy.Text
+variable var = "$" <> Lazy.Text.fromStrict var
+
+selectionSet :: Formatter -> Full.SelectionSet -> Lazy.Text
+selectionSet formatter
+    = bracesList formatter (selection formatter)
+    . NonEmpty.toList
+
+selectionSetOpt :: Formatter -> Full.SelectionSetOpt -> Lazy.Text
+selectionSetOpt formatter = bracesList formatter $ selection formatter
+
+indentSymbol :: Lazy.Text
+indentSymbol = "  "
+
+indent :: (Integral a) => a -> Lazy.Text
+indent indentation = Lazy.Text.replicate (fromIntegral indentation) indentSymbol
+
+selection :: Formatter -> Full.Selection -> Lazy.Text
+selection formatter = Lazy.Text.append indent' . encodeSelection
+  where
+    encodeSelection (Full.Field alias name args directives' selections) =
+        field incrementIndent alias name args directives' selections
+    encodeSelection (Full.InlineFragment typeCondition directives' selections) =
+        inlineFragment incrementIndent typeCondition directives' selections
+    encodeSelection (Full.FragmentSpread name directives') =
+        fragmentSpread incrementIndent name directives'
+    incrementIndent
+        | Pretty indentation <- formatter = Pretty $ indentation + 1
+        | otherwise = Minified
+    indent'
+        | Pretty indentation <- formatter = indent $ indentation + 1
+        | otherwise = ""
+
+colon :: Formatter -> Lazy.Text
+colon formatter = eitherFormat formatter ": " ":"
+
+-- | Converts Full.Field into a string
+field :: Formatter ->
+    Maybe Full.Name ->
+    Full.Name ->
+    [Full.Argument] ->
+    [Full.Directive] ->
+    [Full.Selection] ->
+    Lazy.Text
+field formatter alias name args dirs set
+    = optempty prependAlias (fold alias)
+    <> Lazy.Text.fromStrict name
+    <> optempty (arguments formatter) args
+    <> optempty (directives formatter) dirs
+    <> optempty selectionSetOpt' set
+  where
+    prependAlias aliasName = Lazy.Text.fromStrict aliasName <>  colon formatter
+    selectionSetOpt' = (eitherFormat formatter " " "" <>)
+        . selectionSetOpt formatter
+
+arguments :: Formatter -> [Full.Argument] -> Lazy.Text
+arguments formatter = parensCommas formatter $ argument formatter
+
+argument :: Formatter -> Full.Argument -> Lazy.Text
+argument formatter (Full.Argument name value')
+    = Lazy.Text.fromStrict name
+    <> colon formatter
+    <> value formatter value'
+
+-- * Fragments
+
+fragmentSpread :: Formatter -> Full.Name -> [Full.Directive] -> Lazy.Text
+fragmentSpread formatter name directives'
+    = "..." <> Lazy.Text.fromStrict name
+    <> optempty (directives formatter) directives'
+
+inlineFragment ::
+    Formatter ->
+    Maybe Full.TypeCondition ->
+    [Full.Directive] ->
+    Full.SelectionSet ->
+    Lazy.Text
+inlineFragment formatter tc dirs sels = "... on "
+    <> Lazy.Text.fromStrict (fold tc)
+    <> directives formatter dirs
+    <> eitherFormat formatter " " mempty
+    <> selectionSet formatter sels
+
+fragmentDefinition :: Formatter -> Full.FragmentDefinition -> Lazy.Text
+fragmentDefinition formatter (Full.FragmentDefinition name tc dirs sels)
+    = "fragment " <> Lazy.Text.fromStrict name
+    <> " on " <> Lazy.Text.fromStrict tc
+    <> optempty (directives formatter) dirs
+    <> eitherFormat formatter " " mempty
+    <> selectionSet formatter sels
+
+-- * Miscellaneous
+
+-- | Converts a 'Full.Directive' into a string.
+directive :: Formatter -> Full.Directive -> Lazy.Text
+directive formatter (Full.Directive name args)
+    = "@" <> Lazy.Text.fromStrict name <> optempty (arguments formatter) args
+
+directives :: Formatter -> [Full.Directive] -> Lazy.Text
+directives Minified = spaces (directive Minified)
+directives formatter = Lazy.Text.cons ' ' . spaces (directive formatter)
+
+-- | Converts a 'Full.Value' into a string.
+value :: Formatter -> Full.Value -> Lazy.Text
+value _ (Full.Variable x) = variable x
+value _ (Full.Int x) = Builder.toLazyText $ decimal x
+value _ (Full.Float x) = Builder.toLazyText $ realFloat x
+value _ (Full.Boolean  x) = booleanValue x
+value _ Full.Null = "null"
+value formatter (Full.String string) = stringValue formatter string
+value _ (Full.Enum x) = Lazy.Text.fromStrict x
+value formatter (Full.List x) = listValue formatter x
+value formatter (Full.Object x) = objectValue formatter x
+
+booleanValue :: Bool -> Lazy.Text
+booleanValue True  = "true"
+booleanValue False = "false"
+
+quote :: Builder.Builder
+quote = Builder.singleton '\"'
+
+oneLine :: Text -> Builder
+oneLine string = quote <> Text.foldr (mappend . escape) quote string
+
+stringValue :: Formatter -> Text -> Lazy.Text
+stringValue Minified string = Builder.toLazyText
+    $ quote <> Text.foldr (mappend . escape) quote string
+stringValue (Pretty indentation) string =
+  if hasEscaped string
+  then stringValue Minified string
+  else Builder.toLazyText $ encoded lines'
+    where
+      isWhiteSpace char = char == ' ' || char == '\t'
+      isNewline char = char == '\n' || char == '\r'
+      hasEscaped = Text.any (not . isAllowed)
+      isAllowed char =
+          char == '\t' || isNewline char || (char >= '\x0020' && char /= '\x007F')
+
+      tripleQuote = Builder.fromText "\"\"\""
+      start = tripleQuote <> Builder.singleton '\n'
+      end = Builder.fromLazyText (indent indentation) <> tripleQuote
+
+      strip = Text.dropWhile isWhiteSpace . Text.dropWhileEnd isWhiteSpace
+      lines' = map Builder.fromText $ Text.split isNewline (Text.replace "\r\n" "\n" $ strip string)
+      encoded [] = oneLine string
+      encoded [_] = oneLine string
+      encoded lines'' = start <> transformLines lines'' <> end
+      transformLines = foldr ((\line acc -> line <> Builder.singleton '\n' <> acc) . transformLine) mempty
+      transformLine line =
+        if Lazy.Text.null (Builder.toLazyText line)
+        then line
+        else Builder.fromLazyText (indent (indentation + 1)) <> line
+
+escape :: Char -> Builder
+escape char'
+    | char' == '\\' = Builder.fromString "\\\\"
+    | char' == '\"' = Builder.fromString "\\\""
+    | char' == '\b' = Builder.fromString "\\b"
+    | char' == '\f' = Builder.fromString "\\f"
+    | char' == '\n' = Builder.fromString "\\n"
+    | char' == '\r' = Builder.fromString "\\r"
+    | char' == '\t' = Builder.fromString "\\t"
+    | char' < '\x0010' = unicode  "\\u000" char'
+    | char' < '\x0020' = unicode "\\u00" char'
+    | otherwise = Builder.singleton char'
+  where
+    unicode prefix = mappend (Builder.fromString prefix) . (hexadecimal . ord)
+
+listValue :: Formatter -> [Full.Value] -> Lazy.Text
+listValue formatter = bracketsCommas formatter $ value formatter
+
+objectValue :: Formatter -> [Full.ObjectField] -> Lazy.Text
+objectValue formatter = intercalate $ objectField formatter
+  where
+    intercalate f
+        = braces
+        . Lazy.Text.intercalate (eitherFormat formatter ", " ",")
+        . fmap f
+
+objectField :: Formatter -> Full.ObjectField -> Lazy.Text
+objectField formatter (Full.ObjectField name value') =
+    Lazy.Text.fromStrict name <> colon formatter <> value formatter value'
+
+-- | Converts a 'Full.Type' a type into a string.
+type' :: Full.Type -> Lazy.Text
+type' (Full.TypeNamed   x) = Lazy.Text.fromStrict x
+type' (Full.TypeList    x) = listType x
+type' (Full.TypeNonNull x) = nonNullType x
+
+listType :: Full.Type -> Lazy.Text
+listType x = brackets (type' x)
+
+nonNullType :: Full.NonNullType -> Lazy.Text
+nonNullType (Full.NonNullTypeNamed x) = Lazy.Text.fromStrict x <> "!"
+nonNullType (Full.NonNullTypeList  x) = listType x <> "!"
+
+-- * Internal
+
+between :: Char -> Char -> Lazy.Text -> Lazy.Text
+between open close = Lazy.Text.cons open . (`Lazy.Text.snoc` close)
+
+parens :: Lazy.Text -> Lazy.Text
+parens = between '(' ')'
+
+brackets :: Lazy.Text -> Lazy.Text
+brackets = between '[' ']'
+
+braces :: Lazy.Text -> Lazy.Text
+braces = between '{' '}'
+
+spaces :: forall a. (a -> Lazy.Text) -> [a] -> Lazy.Text
+spaces f = Lazy.Text.intercalate "\SP" . fmap f
+
+parensCommas :: forall a. Formatter -> (a -> Lazy.Text) -> [a] -> Lazy.Text
+parensCommas formatter f
+    = parens
+    . Lazy.Text.intercalate (eitherFormat formatter ", " ",")
+    . fmap f
+
+bracketsCommas :: Formatter -> (a -> Lazy.Text) -> [a] -> Lazy.Text
+bracketsCommas formatter f
+    = brackets
+    . Lazy.Text.intercalate (eitherFormat formatter ", " ",")
+    . fmap f
+
+bracesList :: forall a. Formatter -> (a -> Lazy.Text) -> [a] -> Lazy.Text
+bracesList (Pretty intendation) f xs
+    = Lazy.Text.snoc (Lazy.Text.intercalate "\n" content) '\n'
+    <> (Lazy.Text.snoc $ Lazy.Text.replicate (fromIntegral intendation) "  ") '}'
+  where
+    content = "{" : fmap f xs
+bracesList Minified f xs = braces $ Lazy.Text.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/AST/Lexer.hs

@@ -0,0 +1,236 @@
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | This module defines a bunch of small parsers used to parse individual
+--   lexemes.
+module Language.GraphQL.AST.Lexer
+    ( Parser
+    , amp
+    , at
+    , bang
+    , blockString
+    , braces
+    , brackets
+    , colon
+    , dollar
+    , comment
+    , equals
+    , extend
+    , 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 qualified Data.List.NonEmpty as NonEmpty
+import Data.List.NonEmpty (NonEmpty(..))
+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 Data.Text (Text)
+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 ',')
+
+-- | Parser that skips comments and meaningless characters, whitespaces and
+-- commas.
+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 T.Text
+bang = symbol "!"
+
+-- | Parser for "$".
+dollar :: Parser T.Text
+dollar = symbol "$"
+
+-- | Parser for "@".
+at :: Parser Text
+at = symbol "@"
+
+-- | 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 <* spaceConsumer
+  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 <* spaceConsumer
+  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 ()
+
+-- | Parses "extend" followed by a 'symbol'. It is used by schema extensions.
+extend :: forall a. Text -> String -> NonEmpty (Parser a) -> Parser a
+extend token extensionLabel parsers
+    = foldr combine headParser (NonEmpty.tail parsers)
+    <?> extensionLabel
+  where
+    headParser = tryExtension $ NonEmpty.head parsers
+    combine current accumulated = accumulated <|> tryExtension current
+    tryExtension extensionParser = try
+        $ symbol "extend"
+        *> symbol token
+        *> extensionParser

src/Language/GraphQL/AST/Parser.hs

@@ -0,0 +1,485 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | @GraphQL@ document parser.
+module Language.GraphQL.AST.Parser
+    ( document
+    ) where
+
+import Control.Applicative (Alternative(..), optional)
+import Control.Applicative.Combinators (sepBy1)
+import qualified Control.Applicative.Combinators.NonEmpty as NonEmpty
+import Data.List.NonEmpty (NonEmpty(..))
+import Data.Text (Text)
+import qualified Language.GraphQL.AST.DirectiveLocation as Directive
+import Language.GraphQL.AST.DirectiveLocation
+    ( DirectiveLocation
+    , ExecutableDirectiveLocation
+    , TypeSystemDirectiveLocation
+    )
+import Language.GraphQL.AST.Document
+import Language.GraphQL.AST.Lexer
+import Text.Megaparsec (lookAhead, option, try, (<?>))
+
+-- | Parser for the GraphQL documents.
+document :: Parser Document
+document = unicodeBOM
+    >> spaceConsumer
+    >> lexeme (NonEmpty.some definition)
+
+definition :: Parser Definition
+definition = ExecutableDefinition <$> executableDefinition
+    <|> TypeSystemDefinition <$> typeSystemDefinition
+    <|> TypeSystemExtension <$> typeSystemExtension
+    <?> "Definition"
+
+executableDefinition :: Parser ExecutableDefinition
+executableDefinition = DefinitionOperation <$> operationDefinition
+    <|> DefinitionFragment  <$> fragmentDefinition
+    <?> "ExecutableDefinition"
+
+typeSystemDefinition :: Parser TypeSystemDefinition
+typeSystemDefinition = schemaDefinition
+    <|> TypeDefinition <$> typeDefinition
+    <|> directiveDefinition
+    <?> "TypeSystemDefinition"
+
+typeSystemExtension :: Parser TypeSystemExtension
+typeSystemExtension = SchemaExtension <$> schemaExtension
+    <|> TypeExtension <$> typeExtension
+    <?> "TypeSystemExtension"
+
+directiveDefinition :: Parser TypeSystemDefinition
+directiveDefinition = DirectiveDefinition
+    <$> description
+    <* symbol "directive"
+    <* at
+    <*> name
+    <*> argumentsDefinition
+    <* symbol "on"
+    <*> directiveLocations
+    <?> "DirectiveDefinition"
+
+directiveLocations :: Parser (NonEmpty DirectiveLocation)
+directiveLocations = optional pipe
+    *> directiveLocation `NonEmpty.sepBy1` pipe
+
+directiveLocation :: Parser DirectiveLocation
+directiveLocation
+    = Directive.ExecutableDirectiveLocation <$> executableDirectiveLocation
+    <|> Directive.TypeSystemDirectiveLocation <$> typeSystemDirectiveLocation
+
+executableDirectiveLocation :: Parser ExecutableDirectiveLocation
+executableDirectiveLocation = Directive.Query <$ symbol "QUERY"
+    <|> Directive.Mutation <$ symbol "MUTATION"
+    <|> Directive.Subscription <$ symbol "SUBSCRIPTION"
+    <|> Directive.Field <$ symbol "FIELD"
+    <|> Directive.FragmentDefinition <$ "FRAGMENT_DEFINITION"
+    <|> Directive.FragmentSpread <$ "FRAGMENT_SPREAD"
+    <|> Directive.InlineFragment <$ "INLINE_FRAGMENT"
+
+typeSystemDirectiveLocation :: Parser TypeSystemDirectiveLocation
+typeSystemDirectiveLocation = Directive.Schema <$ symbol "SCHEMA"
+    <|> Directive.Scalar <$ symbol "SCALAR"
+    <|> Directive.Object <$ symbol "OBJECT"
+    <|> Directive.FieldDefinition <$ symbol "FIELD_DEFINITION"
+    <|> Directive.ArgumentDefinition <$ symbol "ARGUMENT_DEFINITION"
+    <|> Directive.Interface <$ symbol "INTERFACE"
+    <|> Directive.Union <$ symbol "UNION"
+    <|> Directive.Enum <$ symbol "ENUM"
+    <|> Directive.EnumValue <$ symbol "ENUM_VALUE"
+    <|> Directive.InputObject <$ symbol "INPUT_OBJECT"
+    <|> Directive.InputFieldDefinition <$ symbol "INPUT_FIELD_DEFINITION"
+
+typeDefinition :: Parser TypeDefinition
+typeDefinition = scalarTypeDefinition
+    <|> objectTypeDefinition
+    <|> interfaceTypeDefinition
+    <|> unionTypeDefinition
+    <|> enumTypeDefinition
+    <|> inputObjectTypeDefinition
+    <?> "TypeDefinition"
+
+typeExtension :: Parser TypeExtension
+typeExtension = scalarTypeExtension
+    <|> objectTypeExtension
+    <|> interfaceTypeExtension
+    <|> unionTypeExtension
+    <|> enumTypeExtension
+    <|> inputObjectTypeExtension
+    <?> "TypeExtension"
+
+scalarTypeDefinition :: Parser TypeDefinition
+scalarTypeDefinition = ScalarTypeDefinition
+    <$> description
+    <* symbol "scalar"
+    <*> name
+    <*> directives
+    <?> "ScalarTypeDefinition"
+
+scalarTypeExtension :: Parser TypeExtension
+scalarTypeExtension = extend "scalar" "ScalarTypeExtension"
+    $ (ScalarTypeExtension <$> name <*> NonEmpty.some directive) :| []
+
+objectTypeDefinition :: Parser TypeDefinition
+objectTypeDefinition = ObjectTypeDefinition
+    <$> description
+    <* symbol "type"
+    <*> name
+    <*> option (ImplementsInterfaces []) (implementsInterfaces sepBy1)
+    <*> directives
+    <*> braces (many fieldDefinition)
+    <?> "ObjectTypeDefinition"
+
+objectTypeExtension :: Parser TypeExtension
+objectTypeExtension = extend "type" "ObjectTypeExtension"
+    $ fieldsDefinitionExtension :|
+        [ directivesExtension
+        , implementsInterfacesExtension
+        ]
+  where
+    fieldsDefinitionExtension = ObjectTypeFieldsDefinitionExtension
+        <$> name
+        <*> option (ImplementsInterfaces []) (implementsInterfaces sepBy1)
+        <*> directives
+        <*> braces (NonEmpty.some fieldDefinition)
+    directivesExtension = ObjectTypeDirectivesExtension
+        <$> name
+        <*> option (ImplementsInterfaces []) (implementsInterfaces sepBy1)
+        <*> NonEmpty.some directive
+    implementsInterfacesExtension = ObjectTypeImplementsInterfacesExtension
+        <$> name
+        <*> implementsInterfaces NonEmpty.sepBy1
+
+description :: Parser Description
+description = Description
+    <$> optional (string <|> blockString)
+    <?> "Description"
+
+unionTypeDefinition :: Parser TypeDefinition
+unionTypeDefinition = UnionTypeDefinition
+    <$> description
+    <* symbol "union"
+    <*> name
+    <*> directives
+    <*> option (UnionMemberTypes []) (unionMemberTypes sepBy1)
+    <?> "UnionTypeDefinition"
+
+unionTypeExtension :: Parser TypeExtension
+unionTypeExtension = extend "union" "UnionTypeExtension"
+    $ unionMemberTypesExtension :| [directivesExtension]
+  where
+    unionMemberTypesExtension = UnionTypeUnionMemberTypesExtension
+        <$> name
+        <*> directives
+        <*> unionMemberTypes NonEmpty.sepBy1
+    directivesExtension = UnionTypeDirectivesExtension
+        <$> name
+        <*> NonEmpty.some directive
+
+unionMemberTypes ::
+    Foldable t =>
+    (Parser Text -> Parser Text -> Parser (t NamedType)) ->
+    Parser (UnionMemberTypes t)
+unionMemberTypes sepBy' = UnionMemberTypes
+    <$ equals
+    <* optional pipe
+    <*> name `sepBy'` pipe
+    <?> "UnionMemberTypes"
+
+interfaceTypeDefinition :: Parser TypeDefinition
+interfaceTypeDefinition = InterfaceTypeDefinition
+    <$> description
+    <* symbol "interface"
+    <*> name
+    <*> directives
+    <*> braces (many fieldDefinition)
+    <?> "InterfaceTypeDefinition"
+
+interfaceTypeExtension :: Parser TypeExtension
+interfaceTypeExtension = extend "interface" "InterfaceTypeExtension"
+    $ fieldsDefinitionExtension :| [directivesExtension]
+  where
+    fieldsDefinitionExtension = InterfaceTypeFieldsDefinitionExtension
+        <$> name
+        <*> directives
+        <*> braces (NonEmpty.some fieldDefinition)
+    directivesExtension = InterfaceTypeDirectivesExtension
+        <$> name
+        <*> NonEmpty.some directive
+
+enumTypeDefinition :: Parser TypeDefinition
+enumTypeDefinition = EnumTypeDefinition
+    <$> description
+    <* symbol "enum"
+    <*> name
+    <*> directives
+    <*> listOptIn braces enumValueDefinition
+    <?> "EnumTypeDefinition"
+
+enumTypeExtension :: Parser TypeExtension
+enumTypeExtension = extend "enum" "EnumTypeExtension"
+    $ enumValuesDefinitionExtension :| [directivesExtension]
+  where
+    enumValuesDefinitionExtension = EnumTypeEnumValuesDefinitionExtension
+        <$> name
+        <*> directives
+        <*> braces (NonEmpty.some enumValueDefinition)
+    directivesExtension = EnumTypeDirectivesExtension
+        <$> name
+        <*> NonEmpty.some directive
+
+inputObjectTypeDefinition :: Parser TypeDefinition
+inputObjectTypeDefinition = InputObjectTypeDefinition
+    <$> description
+    <* symbol "input"
+    <*> name
+    <*> directives
+    <*> listOptIn braces inputValueDefinition
+    <?> "InputObjectTypeDefinition"
+
+inputObjectTypeExtension :: Parser TypeExtension
+inputObjectTypeExtension = extend "input" "InputObjectTypeExtension"
+    $ inputFieldsDefinitionExtension :| [directivesExtension]
+  where
+    inputFieldsDefinitionExtension = InputObjectTypeInputFieldsDefinitionExtension
+        <$> name
+        <*> directives
+        <*> braces (NonEmpty.some inputValueDefinition)
+    directivesExtension = InputObjectTypeDirectivesExtension
+        <$> name
+        <*> NonEmpty.some directive
+
+enumValueDefinition :: Parser EnumValueDefinition
+enumValueDefinition = EnumValueDefinition
+    <$> description
+    <*> enumValue
+    <*> directives
+    <?> "EnumValueDefinition"
+
+implementsInterfaces ::
+    Foldable t =>
+    (Parser Text -> Parser Text -> Parser (t NamedType)) ->
+    Parser (ImplementsInterfaces t)
+implementsInterfaces sepBy' = ImplementsInterfaces
+    <$ symbol "implements"
+    <* optional amp
+    <*> name `sepBy'` amp
+    <?> "ImplementsInterfaces"
+
+inputValueDefinition :: Parser InputValueDefinition
+inputValueDefinition = InputValueDefinition
+    <$> description
+    <*> name
+    <* colon
+    <*> type'
+    <*> defaultValue
+    <*> directives
+    <?> "InputValueDefinition"
+
+argumentsDefinition :: Parser ArgumentsDefinition
+argumentsDefinition = ArgumentsDefinition
+    <$> listOptIn parens inputValueDefinition
+    <?> "ArgumentsDefinition"
+
+fieldDefinition :: Parser FieldDefinition
+fieldDefinition = FieldDefinition
+    <$> description
+    <*> name
+    <*> argumentsDefinition
+    <* colon
+    <*> type'
+    <*> directives
+    <?> "FieldDefinition"
+
+schemaDefinition :: Parser TypeSystemDefinition
+schemaDefinition = SchemaDefinition
+    <$ symbol "schema"
+    <*> directives
+    <*> operationTypeDefinitions
+    <?> "SchemaDefinition"
+
+operationTypeDefinitions :: Parser (NonEmpty OperationTypeDefinition)
+operationTypeDefinitions = braces $ NonEmpty.some operationTypeDefinition
+
+schemaExtension :: Parser SchemaExtension
+schemaExtension = extend "schema" "SchemaExtension"
+    $ schemaOperationExtension :| [directivesExtension]
+  where
+    directivesExtension = SchemaDirectivesExtension
+        <$> NonEmpty.some directive
+    schemaOperationExtension = SchemaOperationExtension
+        <$> directives
+        <*> operationTypeDefinitions
+
+operationTypeDefinition :: Parser OperationTypeDefinition
+operationTypeDefinition = OperationTypeDefinition
+    <$> operationType <* colon
+    <*> name
+    <?> "OperationTypeDefinition"
+
+operationDefinition :: Parser OperationDefinition
+operationDefinition = SelectionSet <$> selectionSet
+    <|> operationDefinition'
+    <?> "operationDefinition error"
+  where
+    operationDefinition'
+        = OperationDefinition <$> operationType
+        <*> optional name
+        <*> variableDefinitions
+        <*> directives
+        <*> selectionSet
+
+operationType :: Parser OperationType
+operationType = Query <$ symbol "query"
+    <|> Mutation <$ symbol "mutation"
+    -- <?> Keep default error message
+
+-- * SelectionSet
+
+selectionSet :: Parser SelectionSet
+selectionSet = braces $ NonEmpty.some selection
+
+selectionSetOpt :: Parser SelectionSetOpt
+selectionSetOpt = listOptIn braces selection
+
+selection :: Parser Selection
+selection = field
+    <|> try fragmentSpread
+    <|> inlineFragment
+    <?> "selection error!"
+
+-- * Field
+
+field :: Parser Selection
+field = Field
+    <$> optional alias
+    <*> name
+    <*> arguments
+    <*> directives
+    <*> selectionSetOpt
+
+alias :: Parser Alias
+alias = try $ name <* colon
+
+-- * Arguments
+
+arguments :: Parser [Argument]
+arguments = listOptIn parens argument
+
+argument :: Parser Argument
+argument = Argument <$> name <* colon <*> value
+
+-- * Fragments
+
+fragmentSpread :: Parser Selection
+fragmentSpread = FragmentSpread
+    <$ spread
+    <*> fragmentName
+    <*> directives
+
+inlineFragment :: Parser Selection
+inlineFragment = InlineFragment
+    <$ spread
+    <*> optional typeCondition
+    <*> directives
+    <*> selectionSet
+
+fragmentDefinition :: Parser FragmentDefinition
+fragmentDefinition = FragmentDefinition
+                 <$  symbol "fragment"
+                 <*> name
+                 <*> typeCondition
+                 <*> directives
+                 <*> selectionSet
+
+fragmentName :: Parser Name
+fragmentName = but (symbol "on") *> name
+
+typeCondition :: Parser TypeCondition
+typeCondition = symbol "on" *> name
+
+-- * Input Values
+
+value :: Parser Value
+value = Variable <$> variable
+    <|> Float    <$> try float
+    <|> Int      <$> integer
+    <|> Boolean  <$> booleanValue
+    <|> Null     <$  symbol "null"
+    <|> String   <$> blockString
+    <|> String   <$> string
+    <|> Enum     <$> try enumValue
+    <|> List     <$> listValue
+    <|> Object   <$> objectValue
+    <?> "value error!"
+  where
+    booleanValue :: Parser Bool
+    booleanValue = True  <$ symbol "true"
+               <|> False <$ symbol "false"
+
+    listValue :: Parser [Value]
+    listValue = brackets $ some value
+
+    objectValue :: Parser [ObjectField]
+    objectValue = braces $ some objectField
+
+enumValue :: Parser Name
+enumValue = but (symbol "true") *> but (symbol "false") *> but (symbol "null") *> name
+
+objectField :: Parser ObjectField
+objectField = ObjectField <$> name <* colon <*> value
+
+-- * Variables
+
+variableDefinitions :: Parser [VariableDefinition]
+variableDefinitions = listOptIn parens variableDefinition
+
+variableDefinition :: Parser VariableDefinition
+variableDefinition = VariableDefinition
+    <$> variable
+    <*  colon
+    <*> type'
+    <*> defaultValue
+    <?> "VariableDefinition"
+
+variable :: Parser Name
+variable = dollar *> name
+
+defaultValue :: Parser (Maybe Value)
+defaultValue = optional (equals *> value) <?> "DefaultValue"
+
+-- * Input Types
+
+type' :: Parser Type
+type' = try (TypeNonNull <$> nonNullType)
+    <|> TypeList <$> brackets type'
+    <|> TypeNamed <$> name
+    <?> "Type"
+
+nonNullType :: Parser NonNullType
+nonNullType = NonNullTypeNamed <$> name <* bang
+          <|> NonNullTypeList  <$> brackets type'  <* bang
+          <?> "nonNullType error!"
+
+-- * Directives
+
+directives :: Parser [Directive]
+directives = many directive
+
+directive :: Parser Directive
+directive = Directive
+    <$  at
+    <*> name
+    <*> arguments
+
+-- * Internal
+
+listOptIn :: (Parser [a] -> Parser [a]) -> Parser a -> Parser [a]
+listOptIn surround = option [] . surround . some
+
+-- Hack to reverse parser success
+but :: Parser a -> Parser ()
+but pn = False <$ lookAhead pn <|> pure True >>= \case
+    False -> empty
+    True  -> pure ()

src/Language/GraphQL/Error.hs

@@ -0,0 +1,88 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+-- | Error handling.
+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(..)
+    , PosState(..)
+    , 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 (_, newState) = reachOffset (errorOffset x) state
+            sourcePosition = pstateSourcePos newState
+         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,86 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | This module provides functions to execute a @GraphQL@ request.
+module Language.GraphQL.Execute
+    ( execute
+    , executeWithName
+    ) where
+
+import qualified Data.Aeson as Aeson
+import Data.List.NonEmpty (NonEmpty(..))
+import qualified Data.List.NonEmpty as NonEmpty
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
+import Data.Text (Text)
+import qualified Data.Text as Text
+import Language.GraphQL.AST.Document
+import qualified Language.GraphQL.AST.Core as AST.Core
+import qualified Language.GraphQL.Execute.Transform as Transform
+import Language.GraphQL.Error
+import qualified Language.GraphQL.Schema as Schema
+
+-- | The substitution is applied to the document, and the resolvers are applied
+-- to the resulting fields.
+--
+-- Returns the result of the query against the schema wrapped in a /data/
+-- field, or errors wrapped in an /errors/ field.
+execute :: Monad m
+    => HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers.
+    -> Schema.Subs -- ^ Variable substitution function.
+    -> Document -- @GraphQL@ document.
+    -> m Aeson.Value
+execute schema subs doc =
+    maybe transformError (document schema Nothing)
+        $ Transform.document subs doc
+  where
+    transformError = return $ singleError "Schema transformation error."
+
+-- | The substitution is applied to the document, and the resolvers are applied
+-- to the resulting fields. The operation name can be used if the document
+-- defines multiple root operations.
+--
+-- Returns the result of the query against the schema wrapped in a /data/
+-- field, or errors wrapped in an /errors/ field.
+executeWithName :: Monad m
+    => HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers
+    -> Text -- ^ Operation name.
+    -> Schema.Subs -- ^ Variable substitution function.
+    -> Document -- ^ @GraphQL@ 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 :: Monad m
+    => HashMap Text (NonEmpty (Schema.Resolver m))
+    -> Maybe Text
+    -> AST.Core.Document
+    -> m Aeson.Value
+document schema Nothing (op :| []) = operation schema op
+document schema (Just name) operations = case NonEmpty.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 :: Monad m
+    => HashMap Text (NonEmpty (Schema.Resolver m))
+    -> AST.Core.Operation
+    -> m Aeson.Value
+operation schema = schemaOperation
+  where
+    runResolver fields = runCollectErrs
+        . flip Schema.resolve fields
+        . Schema.resolversToMap
+    resolve fields queryType = maybe lookupError (runResolver fields)
+        $ HashMap.lookup queryType schema
+    lookupError = pure
+        $ singleError "Root operation type couldn't be found in the schema."
+    schemaOperation (AST.Core.Query _ fields) = resolve fields "Query"
+    schemaOperation (AST.Core.Mutation _ fields) = resolve fields "Mutation"

src/Language/GraphQL/Execute/Transform.hs

@@ -0,0 +1,167 @@
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE TupleSections #-}
+
+-- | After the document is parsed, before getting executed the AST is
+--   transformed into a similar, simpler AST. This module is responsible for
+--   this transformation.
+module Language.GraphQL.Execute.Transform
+    ( document
+    ) where
+
+import Control.Arrow (first)
+import Control.Monad (foldM, unless)
+import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.Reader (ReaderT, asks, runReaderT)
+import Control.Monad.Trans.State (StateT, evalStateT, gets, modify)
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
+import qualified Data.List.NonEmpty as NonEmpty
+import Data.Sequence (Seq, (<|), (><))
+import qualified Language.GraphQL.AST as Full
+import qualified Language.GraphQL.AST.Core as Core
+import Language.GraphQL.AST.Document (Definition(..), Document)
+import qualified Language.GraphQL.Schema as Schema
+import qualified Language.GraphQL.Type.Directive as Directive
+
+-- | Associates a fragment name with a list of 'Core.Field's.
+data Replacement = Replacement
+    { fragments :: HashMap Core.Name Core.Fragment
+    , fragmentDefinitions :: HashMap Full.Name Full.FragmentDefinition
+    }
+
+type TransformT a = StateT Replacement (ReaderT Schema.Subs Maybe) a
+
+liftJust :: forall a. a -> TransformT a
+liftJust = lift . lift . Just
+
+-- | Rewrites the original syntax tree into an intermediate representation used
+-- for query execution.
+document :: Schema.Subs -> Document -> Maybe Core.Document
+document subs document' =
+    flip runReaderT subs
+        $ evalStateT (collectFragments >> operations operationDefinitions)
+        $ Replacement HashMap.empty fragmentTable
+  where
+    (fragmentTable, operationDefinitions) = foldr defragment mempty document'
+    defragment (ExecutableDefinition (Full.DefinitionOperation definition)) acc =
+        (definition :) <$> acc
+    defragment (ExecutableDefinition (Full.DefinitionFragment definition)) acc =
+        let (Full.FragmentDefinition name _ _ _) = definition
+         in first (HashMap.insert name definition) acc
+    defragment _ acc = acc
+
+-- * Operation
+
+operations :: [Full.OperationDefinition] -> TransformT Core.Document
+operations operations' = do
+    coreOperations <- traverse operation operations'
+    lift . lift $ NonEmpty.nonEmpty coreOperations
+
+operation :: Full.OperationDefinition -> TransformT Core.Operation
+operation (Full.SelectionSet sels)
+    = operation $ Full.OperationDefinition Full.Query mempty mempty mempty sels
+operation (Full.OperationDefinition Full.Query name _vars _dirs sels)
+    = Core.Query name <$> appendSelection sels
+operation (Full.OperationDefinition Full.Mutation name _vars _dirs sels)
+    = Core.Mutation name <$> appendSelection sels
+
+-- * Selection
+
+selection ::
+    Full.Selection ->
+    TransformT (Either (Seq Core.Selection) Core.Selection)
+selection (Full.Field alias name arguments' directives' selections) =
+    maybe (Left mempty) (Right . Core.SelectionField) <$> do
+        fieldArguments <- arguments arguments'
+        fieldSelections <- appendSelection selections
+        fieldDirectives <- Directive.selection <$> directives directives'
+        let field' = Core.Field alias name fieldArguments fieldSelections
+        pure $ field' <$ fieldDirectives
+selection (Full.FragmentSpread name directives') =
+    maybe (Left mempty) (Right . Core.SelectionFragment) <$> do
+        spreadDirectives <- Directive.selection <$> directives directives'
+        fragments' <- gets fragments
+        fragment <- maybe lookupDefinition liftJust (HashMap.lookup name fragments')
+        pure $ fragment <$ spreadDirectives
+  where
+    lookupDefinition = do
+        fragmentDefinitions' <- gets fragmentDefinitions
+        found <- lift . lift $ HashMap.lookup name fragmentDefinitions'
+        fragmentDefinition found
+selection (Full.InlineFragment type' directives' selections) = do
+    fragmentDirectives <- Directive.selection <$> directives directives'
+    case fragmentDirectives of
+        Nothing -> pure $ Left mempty
+        _ -> do
+            fragmentSelectionSet <- appendSelection selections
+            pure $ maybe Left selectionFragment type' fragmentSelectionSet
+  where
+    selectionFragment typeName = Right
+        . Core.SelectionFragment
+        . Core.Fragment typeName
+
+appendSelection ::
+    Traversable t =>
+    t Full.Selection ->
+    TransformT (Seq Core.Selection)
+appendSelection = foldM go mempty
+  where
+    go acc sel = append acc <$> selection sel
+    append acc (Left list) = list >< acc
+    append acc (Right one) = one <| acc
+
+directives :: [Full.Directive] -> TransformT [Core.Directive]
+directives = traverse directive
+  where
+    directive (Full.Directive directiveName directiveArguments) =
+        Core.Directive directiveName <$> arguments directiveArguments
+
+-- * Fragment replacement
+
+-- | Extract fragment definitions into a single 'HashMap'.
+collectFragments :: TransformT ()
+collectFragments = do
+    fragDefs <- gets fragmentDefinitions
+    let nextValue = head $ HashMap.elems fragDefs
+    unless (HashMap.null fragDefs) $ do
+        _ <- fragmentDefinition nextValue
+        collectFragments
+
+fragmentDefinition ::
+    Full.FragmentDefinition ->
+    TransformT Core.Fragment
+fragmentDefinition (Full.FragmentDefinition name type' _ selections) = do
+    modify deleteFragmentDefinition
+    fragmentSelection <- appendSelection selections
+    let newValue = Core.Fragment type' fragmentSelection
+    modify $ insertFragment newValue
+    liftJust newValue
+  where
+    deleteFragmentDefinition (Replacement fragments' fragmentDefinitions') =
+        Replacement fragments' $ HashMap.delete name fragmentDefinitions'
+    insertFragment newValue (Replacement fragments' fragmentDefinitions') =
+        let newFragments = HashMap.insert name newValue fragments'
+         in Replacement newFragments fragmentDefinitions'
+
+arguments :: [Full.Argument] -> TransformT Core.Arguments
+arguments = fmap Core.Arguments . foldM go HashMap.empty
+  where
+    go arguments' (Full.Argument name value') = do
+        substitutedValue <- value value'
+        return $ HashMap.insert name substitutedValue arguments'
+
+value :: Full.Value -> TransformT Core.Value
+value (Full.Variable name) = lift (asks $ HashMap.lookup name) >>= lift . lift
+value (Full.Int i) = pure $ Core.Int i
+value (Full.Float f) = pure $ Core.Float f
+value (Full.String x) = pure $ Core.String x
+value (Full.Boolean b) = pure $ Core.Boolean b
+value Full.Null = pure   Core.Null
+value (Full.Enum e) = pure $ Core.Enum e
+value (Full.List l) =
+    Core.List <$> traverse value l
+value (Full.Object o) =
+    Core.Object . HashMap.fromList <$> traverse objectField o
+
+objectField :: Full.ObjectField -> TransformT (Core.Name, Core.Value)
+objectField (Full.ObjectField name value') = (name,) <$> value value'

src/Language/GraphQL/Schema.hs

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

src/Language/GraphQL/Trans.hs

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

src/Language/GraphQL/Type.hs

@@ -0,0 +1,55 @@
+-- | Definitions for @GraphQL@ input types.
+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

src/Language/GraphQL/Type/Directive.hs

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

stack-7.10.yaml

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

stack-7.8.yaml

@@ -1,5 +0,0 @@
-flags: {}
-packages:
-- '.'
-extra-deps: []
-resolver: lts-2.22

stack.yaml

@@ -1 +0,0 @@
-stack-7.10.yaml

stack.yaml

@@ -0,0 +1,9 @@
+resolver: lts-15.12
+
+packages:
+- .
+
+extra-deps: []
+flags: {}
+
+pvp-bounds: both

tests/Language/GraphQL/AST/EncoderSpec.hs

@@ -0,0 +1,133 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+module Language.GraphQL.AST.EncoderSpec
+    ( spec
+    ) where
+
+import Language.GraphQL.AST
+import Language.GraphQL.AST.Encoder
+import Test.Hspec (Spec, context, describe, it, shouldBe, shouldStartWith, shouldEndWith, shouldNotContain)
+import Test.QuickCheck (choose, oneof, forAll)
+import Text.RawString.QQ (r)
+import Data.Text.Lazy (cons, toStrict, unpack)
+
+spec :: Spec
+spec = do
+    describe "value" $ do
+        context "null value" $ do
+            let testNull formatter = value formatter Null `shouldBe` "null"
+            it "minified" $ testNull minified
+            it "pretty" $ testNull pretty
+
+        context "minified" $ do
+            it "escapes \\" $
+                value minified (String "\\") `shouldBe` "\"\\\\\""
+            it "escapes double quotes" $
+                value minified (String "\"") `shouldBe` "\"\\\"\""
+            it "escapes \\f" $
+                value minified (String "\f") `shouldBe` "\"\\f\""
+            it "escapes \\n" $
+                value minified (String "\n") `shouldBe` "\"\\n\""
+            it "escapes \\r" $
+                value minified (String "\r") `shouldBe` "\"\\r\""
+            it "escapes \\t" $
+                value minified (String "\t") `shouldBe` "\"\\t\""
+            it "escapes backspace" $
+                value minified (String "a\bc") `shouldBe` "\"a\\bc\""
+            context "escapes Unicode for chars less than 0010" $ do
+                it "Null" $ value minified (String "\x0000") `shouldBe` "\"\\u0000\""
+                it "bell" $ value minified (String "\x0007") `shouldBe` "\"\\u0007\""
+            context "escapes Unicode for char less than 0020" $ do
+                it "DLE" $ value minified (String "\x0010") `shouldBe` "\"\\u0010\""
+                it "EM" $ value minified (String "\x0019") `shouldBe` "\"\\u0019\""
+            context "encodes without escape" $ do
+                it "space" $ value minified (String "\x0020") `shouldBe` "\" \""
+                it "~" $ value minified (String "\x007E") `shouldBe` "\"~\""
+
+        context "pretty" $ do
+            it "uses strings for short string values" $
+                value pretty (String "Short text") `shouldBe` "\"Short text\""
+            it "uses block strings for text with new lines, with newline symbol" $
+                value pretty (String "Line 1\nLine 2")
+                    `shouldBe` [r|"""
+  Line 1
+  Line 2
+"""|]
+            it "uses block strings for text with new lines, with CR symbol" $
+                value pretty (String "Line 1\rLine 2")
+                    `shouldBe` [r|"""
+  Line 1
+  Line 2
+"""|]
+            it "uses block strings for text with new lines, with CR symbol followed by newline" $
+                value pretty (String "Line 1\r\nLine 2")
+                    `shouldBe` [r|"""
+  Line 1
+  Line 2
+"""|]
+            it "encodes as one line string if has escaped symbols" $ do
+                let
+                  genNotAllowedSymbol = oneof
+                    [ choose ('\x0000', '\x0008')
+                    , choose ('\x000B', '\x000C')
+                    , choose ('\x000E', '\x001F')
+                    , pure '\x007F'
+                    ]
+
+                forAll genNotAllowedSymbol $ \x -> do
+                    let
+                      rawValue = "Short \n" <> cons x "text"
+                      encoded = value pretty (String $ toStrict rawValue)
+                    shouldStartWith (unpack encoded) "\""
+                    shouldEndWith (unpack encoded) "\""
+                    shouldNotContain (unpack encoded) "\"\"\""
+
+            it "Hello world" $ value pretty (String "Hello,\n  World!\n\nYours,\n  GraphQL.")
+              `shouldBe` [r|"""
+  Hello,
+    World!
+
+  Yours,
+    GraphQL.
+"""|]
+
+            it "has only newlines" $ value pretty (String "\n") `shouldBe` [r|"""
+
+
+"""|]
+            it "has newlines and one symbol at the begining" $
+              value pretty (String "a\n\n") `shouldBe` [r|"""
+  a
+
+
+"""|]
+            it "has newlines and one symbol at the end" $
+              value pretty (String "\n\na") `shouldBe` [r|"""
+
+
+  a
+"""|]
+            it "has newlines and one symbol in the middle" $
+              value pretty (String "\na\n") `shouldBe` [r|"""
+
+  a
+
+"""|]
+            it "skip trailing whitespaces" $ value pretty (String "  Short\ntext    ")
+              `shouldBe` [r|"""
+  Short
+  text
+"""|]
+
+    describe "definition" $
+        it "indents block strings in arguments" $
+            let arguments = [Argument "message" (String "line1\nline2")]
+                field = Field Nothing "field" arguments [] []
+                operation = DefinitionOperation $ SelectionSet $ pure field
+             in definition pretty operation `shouldBe` [r|{
+  field(message: """
+    line1
+    line2
+  """)
+}
+|]

tests/Language/GraphQL/AST/LexerSpec.hs

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

tests/Language/GraphQL/AST/ParserSpec.hs

@@ -0,0 +1,144 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+module Language.GraphQL.AST.ParserSpec
+    ( spec
+    ) where
+
+import Data.List.NonEmpty (NonEmpty(..))
+import Language.GraphQL.AST.Document
+import Language.GraphQL.AST.Parser
+import Test.Hspec (Spec, describe, it)
+import Test.Hspec.Megaparsec (shouldParse, shouldSucceedOn)
+import Text.Megaparsec (parse)
+import Text.RawString.QQ (r)
+
+spec :: Spec
+spec = describe "Parser" $ do
+    it "accepts BOM header" $
+        parse document "" `shouldSucceedOn` "\xfeff{foo}"
+
+    it "accepts block strings as argument" $
+        parse document "" `shouldSucceedOn` [r|{
+              hello(text: """Argument""")
+            }|]
+
+    it "accepts strings as argument" $
+        parse document "" `shouldSucceedOn` [r|{
+              hello(text: "Argument")
+            }|]
+
+    it "accepts two required arguments" $
+        parse document "" `shouldSucceedOn` [r|
+            mutation auth($username: String!, $password: String!){
+              test
+            }|]
+
+    it "accepts two string arguments" $
+        parse document "" `shouldSucceedOn` [r|
+            mutation auth{
+              test(username: "username", password: "password")
+            }|]
+
+    it "accepts two block string arguments" $
+        parse document "" `shouldSucceedOn` [r|
+            mutation auth{
+              test(username: """username""", password: """password""")
+            }|]
+
+    it "parses minimal schema definition" $
+        parse document "" `shouldSucceedOn` [r|schema { query: Query }|]
+
+    it "parses minimal scalar definition" $
+        parse document "" `shouldSucceedOn` [r|scalar Time|]
+
+    it "parses ImplementsInterfaces" $
+        parse document "" `shouldSucceedOn` [r|
+            type Person implements NamedEntity & ValuedEntity {
+              name: String
+            }
+        |]
+
+    it "parses a  type without ImplementsInterfaces" $
+        parse document "" `shouldSucceedOn` [r|
+            type Person {
+              name: String
+            }
+        |]
+
+    it "parses ArgumentsDefinition in an ObjectDefinition" $
+        parse document "" `shouldSucceedOn` [r|
+            type Person {
+              name(first: String, last: String): String
+            }
+        |]
+
+    it "parses minimal union type definition" $
+        parse document "" `shouldSucceedOn` [r|
+            union SearchResult = Photo | Person
+        |]
+
+    it "parses minimal interface type definition" $
+        parse document "" `shouldSucceedOn` [r|
+            interface NamedEntity {
+              name: String
+            }
+        |]
+
+    it "parses minimal enum type definition" $
+        parse document "" `shouldSucceedOn` [r|
+            enum Direction {
+              NORTH
+              EAST
+              SOUTH
+              WEST
+            }
+        |]
+
+    it "parses minimal enum type definition" $
+        parse document "" `shouldSucceedOn` [r|
+            enum Direction {
+              NORTH
+              EAST
+              SOUTH
+              WEST
+            }
+        |]
+
+    it "parses minimal input object type definition" $
+        parse document "" `shouldSucceedOn` [r|
+            input Point2D {
+              x: Float
+              y: Float
+            }
+        |]
+
+    it "parses minimal input enum definition with an optional pipe" $
+        parse document "" `shouldSucceedOn` [r|
+            directive @example on
+              | FIELD
+              | FRAGMENT_SPREAD
+        |]
+
+    it "parses schema extension with a new directive" $
+        parse document "" `shouldSucceedOn`[r|
+            extend schema @newDirective
+        |]
+
+    it "parses schema extension with an operation type definition" $
+        parse document "" `shouldSucceedOn` [r|extend schema { query: Query }|]
+
+    it "parses schema extension with an operation type and directive" $
+        let newDirective = Directive "newDirective" []
+            testSchemaExtension = TypeSystemExtension
+                $ SchemaExtension
+                $ SchemaOperationExtension [newDirective]
+                $ OperationTypeDefinition Query "Query" :| []
+            query = [r|extend schema @newDirective { query: Query }|]
+         in parse document "" query `shouldParse` (testSchemaExtension :| [])
+
+    it "parses an object extension" $
+        parse document "" `shouldSucceedOn` [r|
+            extend type Story {
+              isHiddenLocally: Boolean
+            }
+        |]

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/Spec.hs

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

tests/Test/DirectiveSpec.hs

@@ -0,0 +1,88 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+module Test.DirectiveSpec
+    ( spec
+    ) where
+
+import Data.Aeson (Value, object, (.=))
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
+import Data.List.NonEmpty (NonEmpty(..))
+import Data.Text (Text)
+import Language.GraphQL
+import qualified Language.GraphQL.Schema as Schema
+import Test.Hspec (Spec, describe, it, shouldBe)
+import Text.RawString.QQ (r)
+
+experimentalResolver :: HashMap Text (NonEmpty (Schema.Resolver IO))
+experimentalResolver = HashMap.singleton "Query"
+    $ Schema.scalar "experimentalField" (pure (5 :: Int)) :| []
+
+emptyObject :: Value
+emptyObject = object
+    [ "data" .= object []
+    ]
+
+spec :: Spec
+spec =
+    describe "Directive executor" $ do
+        it "should be able to @skip fields" $ do
+            let query = [r|
+              {
+                experimentalField @skip(if: true)
+              }
+            |]
+
+            actual <- graphql experimentalResolver query
+            actual `shouldBe` emptyObject
+
+        it "should not skip fields if @skip is false" $ do
+            let query = [r|
+              {
+                experimentalField @skip(if: false)
+              }
+            |]
+                expected = object
+                    [ "data" .= object
+                        [ "experimentalField" .= (5 :: Int)
+                        ]
+                    ]
+
+            actual <- graphql experimentalResolver query
+            actual `shouldBe` expected
+
+        it "should skip fields if @include is false" $ do
+            let query = [r|
+              {
+                experimentalField @include(if: false)
+              }
+            |]
+
+            actual <- graphql experimentalResolver query
+            actual `shouldBe` emptyObject
+
+        it "should be able to @skip a fragment spread" $ do
+            let query = [r|
+              {
+                ...experimentalFragment @skip(if: true)
+              }
+
+              fragment experimentalFragment on ExperimentalType {
+                experimentalField
+              }
+            |]
+
+            actual <- graphql experimentalResolver query
+            actual `shouldBe` emptyObject
+
+        it "should be able to @skip an inline fragment" $ do
+            let query = [r|
+              {
+                ... on ExperimentalType @skip(if: true) {
+                  experimentalField
+                }
+              }
+            |]
+
+            actual <- graphql experimentalResolver query
+            actual `shouldBe` emptyObject

tests/Test/FragmentSpec.hs

@@ -0,0 +1,191 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+module Test.FragmentSpec
+    ( spec
+    ) where
+
+import Data.Aeson (Value(..), object, (.=))
+import qualified Data.HashMap.Strict as HashMap
+import Data.List.NonEmpty (NonEmpty(..))
+import Data.Text (Text)
+import Language.GraphQL
+import qualified Language.GraphQL.Schema as Schema
+import Test.Hspec ( Spec
+                  , describe
+                  , it
+                  , shouldBe
+                  , shouldSatisfy
+                  , shouldNotSatisfy
+                  )
+import Text.RawString.QQ (r)
+
+size :: Schema.Resolver IO
+size = Schema.scalar "size" $ return ("L" :: Text)
+
+circumference :: Schema.Resolver IO
+circumference = Schema.scalar "circumference" $ return (60 :: Int)
+
+garment :: Text -> Schema.Resolver IO
+garment typeName = Schema.object "garment" $ return
+    [ if typeName == "Hat" then circumference else size
+    , Schema.scalar "__typename" $ return typeName
+    ]
+
+inlineQuery :: Text
+inlineQuery = [r|{
+  garment {
+    ... on Hat {
+      circumference
+    }
+    ... on Shirt {
+      size
+    }
+  }
+}|]
+
+hasErrors :: Value -> Bool
+hasErrors (Object object') = HashMap.member "errors" object'
+hasErrors _ = True
+
+spec :: Spec
+spec = do
+    describe "Inline fragment executor" $ do
+        it "chooses the first selection if the type matches" $ do
+            actual <- graphql (HashMap.singleton "Query" $ garment "Hat" :| []) inlineQuery
+            let expected = object
+                    [ "data" .= object
+                        [ "garment" .= object
+                            [ "circumference" .= (60 :: Int)
+                            ]
+                        ]
+                    ]
+             in actual `shouldBe` expected
+
+        it "chooses the last selection if the type matches" $ do
+            actual <- graphql (HashMap.singleton "Query" $ garment "Shirt" :| []) inlineQuery
+            let expected = object
+                    [ "data" .= object
+                        [ "garment" .= object
+                            [ "size" .= ("L" :: Text)
+                            ]
+                        ]
+                    ]
+             in actual `shouldBe` expected
+
+        it "embeds inline fragments without type" $ do
+            let query = [r|{
+              garment {
+                circumference
+                ... {
+                  size
+                }
+              }
+            }|]
+                resolvers = Schema.object "garment" $ return [circumference,  size]
+
+            actual <- graphql (HashMap.singleton "Query" $ resolvers :| []) query
+            let expected = object
+                    [ "data" .= object
+                        [ "garment" .= object
+                            [ "circumference" .= (60 :: Int)
+                            , "size" .= ("L" :: Text)
+                            ]
+                        ]
+                    ]
+             in actual `shouldBe` expected
+
+        it "evaluates fragments on Query" $ do
+            let query = [r|{
+              ... {
+                size
+              }
+            }|]
+
+            actual <- graphql (HashMap.singleton "Query" $ size :| []) query
+            actual `shouldNotSatisfy` hasErrors
+
+    describe "Fragment spread executor" $ do
+        it "evaluates fragment spreads" $ do
+            let query = [r|
+              {
+                ...circumferenceFragment
+              }
+
+              fragment circumferenceFragment on Hat {
+                circumference
+              }
+            |]
+
+            actual <- graphql (HashMap.singleton "Query" $ circumference :| []) query
+            let expected = object
+                    [ "data" .= object
+                        [ "circumference" .= (60 :: Int)
+                        ]
+                    ]
+             in actual `shouldBe` expected
+
+        it "evaluates nested fragments" $ do
+            let query = [r|
+              {
+                garment {
+                  ...circumferenceFragment
+                }
+              }
+
+              fragment circumferenceFragment on Hat {
+                ...hatFragment
+              }
+
+              fragment hatFragment on Hat {
+                circumference
+              }
+            |]
+
+            actual <- graphql (HashMap.singleton "Query" $ garment "Hat" :| []) query
+            let expected = object
+                    [ "data" .= object
+                        [ "garment" .= object
+                            [ "circumference" .= (60 :: Int)
+                            ]
+                        ]
+                    ]
+             in actual `shouldBe` expected
+
+        it "rejects recursive fragments" $ do
+            let query = [r|
+              {
+                ...circumferenceFragment
+              }
+
+              fragment circumferenceFragment on Hat {
+                ...circumferenceFragment
+              }
+            |]
+
+            actual <- graphql (HashMap.singleton "Query" $ circumference :| []) query
+            actual `shouldSatisfy` hasErrors
+
+        it "considers type condition" $ do
+            let query = [r|
+              {
+                garment {
+                  ...circumferenceFragment
+                  ...sizeFragment
+                }
+              }
+              fragment circumferenceFragment on Hat {
+                circumference
+              }
+              fragment sizeFragment on Shirt {
+                size
+              }
+            |]
+                expected = object
+                    [ "data" .= object
+                        [ "garment" .= object
+                            [ "circumference" .= (60 :: Int)
+                            ]
+                        ]
+                    ]
+            actual <- graphql (HashMap.singleton "Query" $ garment "Hat" :| []) query
+            actual `shouldBe` expected

tests/Test/KitchenSinkSpec.hs

@@ -0,0 +1,69 @@
+{-# 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 Data.Text.Lazy as Lazy (Text)
+import qualified Language.GraphQL.AST.Encoder as Encoder
+import qualified Language.GraphQL.AST.Parser as Parser
+import Paths_graphql (getDataFileName)
+import Test.Hspec (Spec, describe, it)
+import Test.Hspec.Megaparsec (parseSatisfies)
+import Text.Megaparsec (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"
+        expected <- Text.Lazy.IO.readFile minFileName
+
+        shouldNormalize Encoder.minified dataFileName expected
+
+    it "pretty prints the query" $ do
+        dataFileName <- getDataFileName "tests/data/kitchen-sink.graphql"
+        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
+}
+|]
+
+        shouldNormalize Encoder.pretty dataFileName expected
+
+shouldNormalize :: Encoder.Formatter -> FilePath -> Lazy.Text -> IO ()
+shouldNormalize formatter dataFileName expected = do
+    actual <- Text.IO.readFile dataFileName
+    parse Parser.document dataFileName actual `parseSatisfies` condition
+      where
+        condition = (expected ==) . Encoder.document formatter

tests/Test/StarWars/Data.hs

@@ -0,0 +1,191 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Test.StarWars.Data
+    ( Character
+    , appearsIn
+    , artoo
+    , getDroid
+    , getDroid'
+    , getEpisode
+    , getFriends
+    , getHero
+    , getHuman
+    , id_
+    , homePlanet
+    , name
+    , secretBackstory
+    , typeName
+    ) where
+
+import Data.Functor.Identity (Identity)
+import Control.Applicative (Alternative(..), liftA2)
+import Control.Monad.Trans.Except (throwE)
+import Data.Maybe (catMaybes)
+import Data.Text (Text)
+import Language.GraphQL.Trans
+import qualified Language.GraphQL.Type as Type
+
+-- * 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 :: Character -> ActionT Identity 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
+
+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 :: Int -> Maybe (Type.Wrapping Text)
+getEpisode 4 = pure $ Type.Named "NEWHOPE"
+getEpisode 5 = pure $ Type.Named "EMPIRE"
+getEpisode 6 = pure $ Type.Named "JEDI"
+getEpisode _ = empty

tests/Test/StarWars/QuerySpec.hs

@@ -0,0 +1,365 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+module Test.StarWars.QuerySpec
+    ( spec
+    ) where
+
+import qualified Data.Aeson as Aeson
+import Data.Aeson ((.=))
+import Data.Functor.Identity (Identity(..))
+import qualified Data.HashMap.Strict as HashMap
+import Data.Text (Text)
+import Language.GraphQL
+import Language.GraphQL.Schema (Subs)
+import Text.RawString.QQ (r)
+import Test.Hspec.Expectations (Expectation, shouldBe)
+import Test.Hspec (Spec, describe, it)
+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
+            }
+            }
+        |]
+        $ Aeson.object
+            [ "data" .= Aeson.object
+                [ "hero" .= Aeson.object ["id" .= ("2001" :: Text)]
+                ]
+            ]
+      it "R2-D2 ID and friends" $ testQuery
+        [r| query HeroNameAndFriendsQuery {
+            hero {
+                id
+                name
+                friends {
+                name
+                }
+            }
+            }
+        |]
+        $ Aeson.object [ "data" .= Aeson.object [
+            "hero" .= Aeson.object
+                [ "id" .= ("2001" :: Text)
+                , r2d2Name
+                , "friends" .=
+                    [ Aeson.object [lukeName]
+                    , Aeson.object [hanName]
+                    , Aeson.object [leiaName]
+                    ]
+                ]
+        ]]
+
+    describe "Nested Queries" $ do
+      it "R2-D2 friends" $ testQuery
+        [r| query NestedQuery {
+              hero {
+                name
+                friends {
+                  name
+                  appearsIn
+                    friends {
+                      name
+                    }
+                }
+              }
+            }
+        |]
+        $ Aeson.object [ "data" .= Aeson.object [
+          "hero" .= Aeson.object [
+              "name" .= ("R2-D2" :: Text)
+            , "friends" .= [
+                  Aeson.object [
+                      "name" .= ("Luke Skywalker" :: Text)
+                    , "appearsIn" .= ["NEWHOPE","EMPIRE","JEDI" :: Text]
+                    , "friends" .= [
+                          Aeson.object [hanName]
+                        , Aeson.object [leiaName]
+                        , Aeson.object [c3poName]
+                        , Aeson.object [r2d2Name]
+                        ]
+                    ]
+                , Aeson.object [
+                      hanName
+                    , "appearsIn" .= [ "NEWHOPE","EMPIRE","JEDI" :: Text]
+                    , "friends" .=
+                        [ Aeson.object [lukeName]
+                        , Aeson.object [leiaName]
+                        , Aeson.object [r2d2Name]
+                        ]
+                    ]
+                , Aeson.object [
+                      leiaName
+                    , "appearsIn" .= [ "NEWHOPE","EMPIRE","JEDI" :: Text]
+                    , "friends" .=
+                        [ Aeson.object [lukeName]
+                        , Aeson.object [hanName]
+                        , Aeson.object [c3poName]
+                        , Aeson.object [r2d2Name]
+                        ]
+                    ]
+                ]
+            ]
+        ]]
+      it "Luke ID" $ testQuery
+        [r| query FetchLukeQuery {
+              human(id: "1000") {
+                name
+              }
+            }
+        |]
+        $ Aeson.object [ "data" .= Aeson.object
+            [ "human" .= Aeson.object [lukeName]
+            ]]
+
+    it "Luke ID with variable" $ testQueryParams
+      (HashMap.singleton "someId" "1000")
+      [r| query FetchSomeIDQuery($someId: String!) {
+            human(id: $someId) {
+              name
+            }
+          }
+      |]
+      $ Aeson.object [ "data" .= Aeson.object [
+        "human" .= Aeson.object [lukeName]
+      ]]
+    it "Han ID with variable" $ testQueryParams
+      (HashMap.singleton "someId" "1002")
+      [r| query FetchSomeIDQuery($someId: String!) {
+            human(id: $someId) {
+              name
+            }
+          }
+      |]
+      $ Aeson.object [ "data" .= Aeson.object [
+        "human" .= Aeson.object [hanName]
+      ]]
+    it "Invalid ID" $ testQueryParams
+      (HashMap.singleton "id" "Not a valid ID")
+      [r| query humanQuery($id: String!) {
+            human(id: $id) {
+              name
+            }
+          }
+      |] $ Aeson.object ["data" .= Aeson.object ["human" .= Aeson.Null]]
+    it "Luke aliased" $ testQuery
+      [r| query FetchLukeAliased {
+            luke: human(id: "1000") {
+              name
+            }
+          }
+      |]
+      $ Aeson.object [ "data" .= Aeson.object [
+       "luke" .= Aeson.object [lukeName]
+      ]]
+    it "R2-D2 ID and friends aliased" $ testQuery
+      [r| query HeroNameAndFriendsQuery {
+            hero {
+              id
+              name
+              friends {
+                friendName: name
+              }
+            }
+          }
+      |]
+      $ Aeson.object [ "data" .= Aeson.object [
+        "hero" .= Aeson.object [
+            "id" .= ("2001" :: Text)
+          , r2d2Name
+          , "friends" .=
+              [ Aeson.object ["friendName" .= ("Luke Skywalker" :: Text)]
+              , Aeson.object ["friendName" .= ("Han Solo" :: Text)]
+              , Aeson.object ["friendName" .= ("Leia Organa" :: Text)]
+              ]
+          ]
+      ]]
+    it "Luke and Leia aliased" $ testQuery
+      [r| query FetchLukeAndLeiaAliased {
+            luke: human(id: "1000") {
+              name
+            }
+            leia: human(id: "1003") {
+              name
+            }
+          }
+      |]
+      $ Aeson.object [ "data" .= Aeson.object
+        [ "luke" .= Aeson.object [lukeName]
+        , "leia" .= Aeson.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
+              }
+            }
+        |]
+        $ Aeson.object [ "data" .= Aeson.object [
+          "luke" .= Aeson.object [lukeName, tatooine]
+        , "leia" .= Aeson.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
+            }
+        |]
+        $ Aeson.object [ "data" .= Aeson.object [
+          "luke" .= Aeson.object [lukeName, tatooine]
+        , "leia" .= Aeson.object [leiaName, alderaan]
+        ]]
+
+    describe "__typename" $ do
+      it "R2D2 is a Droid" $ testQuery
+        [r| query CheckTypeOfR2 {
+              hero {
+                __typename
+                name
+              }
+            }
+          |]
+        $ Aeson.object ["data" .= Aeson.object [
+            "hero" .= Aeson.object
+                [ "__typename" .= ("Droid" :: Text)
+                , r2d2Name
+                ]
+        ]]
+      it "Luke is a human" $ testQuery
+        [r| query CheckTypeOfLuke {
+              hero(episode: EMPIRE) {
+                __typename
+                name
+              }
+            }
+          |]
+        $ Aeson.object ["data" .= Aeson.object [
+            "hero" .= Aeson.object
+                [ "__typename" .= ("Human" :: Text)
+                , lukeName
+                ]
+        ]]
+
+    describe "Errors in resolvers" $ do
+        it "error on secretBackstory" $ testQuery
+          [r|
+            query HeroNameQuery {
+              hero {
+                name
+                  secretBackstory
+              }
+            }
+          |]
+          $ Aeson.object
+              [ "data" .= Aeson.object
+                  [ "hero" .= Aeson.object
+                      [ "name" .= ("R2-D2" :: Text)
+                      , "secretBackstory" .= Aeson.Null
+                      ]
+                  ]
+              , "errors" .=
+                  [ Aeson.object
+                      ["message" .= ("secretBackstory is secret." :: Text)]
+                  ]
+              ]
+        it "Error in a list" $ testQuery
+          [r| query HeroNameQuery {
+                hero {
+                  name
+                  friends {
+                    name
+                    secretBackstory
+                  }
+                }
+              }
+            |]
+          $ Aeson.object ["data" .= Aeson.object
+            [ "hero" .= Aeson.object
+                [ "name" .= ("R2-D2" :: Text)
+                , "friends" .=
+                    [ Aeson.object
+                        [ "name" .= ("Luke Skywalker" :: Text)
+                        , "secretBackstory" .= Aeson.Null
+                        ]
+                    , Aeson.object
+                        [ "name" .= ("Han Solo" :: Text)
+                        , "secretBackstory" .= Aeson.Null
+                        ]
+                    , Aeson.object
+                        [ "name" .= ("Leia Organa" :: Text)
+                        , "secretBackstory" .= Aeson.Null
+                        ]
+                    ]
+                ]
+            ]
+            , "errors" .=
+                [ Aeson.object
+                    [ "message" .= ("secretBackstory is secret." :: Text)
+                    ]
+                , Aeson.object
+                    [ "message" .= ("secretBackstory is secret." :: Text)
+                    ]
+                , Aeson.object
+                    [ "message" .= ("secretBackstory is secret." :: Text)
+                    ]
+                ]
+            ]
+        it "error on secretBackstory with alias" $ testQuery
+          [r| query HeroNameQuery {
+                mainHero: hero {
+                  name
+                  story: secretBackstory
+                }
+              }
+            |]
+          $ Aeson.object
+              [ "data" .= Aeson.object
+                  [ "mainHero" .= Aeson.object
+                      [ "name" .= ("R2-D2" :: Text)
+                      , "story" .= Aeson.Null
+                      ]
+                  ]
+              , "errors" .=
+                  [ Aeson.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 = runIdentity (graphql schema q) `shouldBe` expected
+
+testQueryParams :: Subs -> Text -> Aeson.Value -> Expectation
+testQueryParams f q expected =
+    runIdentity (graphqlSubs schema f q) `shouldBe` expected

tests/Test/StarWars/Schema.hs

@@ -0,0 +1,66 @@
+{-# 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 Data.Functor.Identity (Identity)
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
+import Data.List.NonEmpty (NonEmpty(..))
+import Data.Maybe (catMaybes)
+import Data.Text (Text)
+import qualified Language.GraphQL.Schema as Schema
+import Language.GraphQL.Trans
+import qualified Language.GraphQL.Type as Type
+import Test.StarWars.Data
+
+-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js
+
+schema :: HashMap Text (NonEmpty (Schema.Resolver Identity))
+schema = HashMap.singleton "Query" $ hero :| [human, droid]
+
+hero :: Schema.Resolver Identity
+hero = Schema.object "hero" $ do
+  episode <- argument "episode"
+  character $ case episode of
+      Schema.Enum "NEWHOPE" -> getHero 4
+      Schema.Enum "EMPIRE" -> getHero 5
+      Schema.Enum "JEDI" -> getHero 6
+      _ -> artoo
+
+human :: Schema.Resolver Identity
+human = Schema.wrappedObject "human" $ do
+    id' <- argument "id"
+    case id' of
+        Schema.String i -> do
+            humanCharacter <- lift $ return $ getHuman i >>= Just
+            case humanCharacter of
+                Nothing -> return Type.Null
+                Just e -> Type.Named <$> character e
+        _ -> ActionT $ throwE "Invalid arguments."
+
+droid :: Schema.Resolver Identity
+droid = Schema.object "droid" $ do
+    id' <- argument "id"
+    case id' of
+        Schema.String i -> character =<< getDroid i
+        _ -> ActionT $ throwE "Invalid arguments."
+
+character :: Character -> ActionT Identity [Schema.Resolver Identity]
+character char = return
+    [ Schema.scalar "id" $ return $ id_ char
+    , Schema.scalar "name" $ return $ name char
+    , Schema.wrappedObject "friends"
+        $ traverse character $ Type.List $ Type.Named <$> getFriends char
+    , Schema.wrappedScalar "appearsIn" $ return . Type.List
+        $ catMaybes (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

@@ -7,11 +7,11 @@
 
 query queryName($foo: ComplexType, $site: Site = MOBILE) {
   whoever123is: node(id: [123, 456]) {
-    id , # Inline test comment
+    id, # Inline test comment
     ... on User @defer {
       field2 {
-        id ,
-        alias: field1(first:10, after:$foo,) @include(if: $foo) {
+        id,
+        alias: field1(first: 10, after: $foo) @include(if: $foo) {
           id,
           ...frag
         }

tests/data/kitchen-sink.min.graphql

@@ -1 +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"})}
+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}

tests/tasty.hs

@@ -1,28 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE OverloadedStrings #-}
-module Main where
-
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative ((<$>), (<*>))
-#endif
-
-import Data.Attoparsec.Text (parseOnly)
-import qualified Data.Text.IO as Text
-import Test.Tasty (defaultMain)
-import Test.Tasty.HUnit
-
-import qualified Data.GraphQL.Parser as Parser
-import qualified Data.GraphQL.Encoder as Encoder
-
-import Paths_graphql (getDataFileName)
-
-main :: IO ()
-main = defaultMain =<< testCase "Kitchen Sink"
-                   <$> (assertEqual "Encode" <$> expected <*> actual)
-  where
-    expected = Text.readFile
-           =<< getDataFileName "tests/data/kitchen-sink.min.graphql"
-
-    actual = either (error "Parsing error!") Encoder.document
-         <$> parseOnly Parser.document
-         <$> expected