Release 0.6.1.0

Fixes #10.

.gitignore

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

CHANGELOG.md

@@ -1,6 +1,115 @@
 # Change Log
 All notable changes to this project will be documented in this file.
 
+## [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.
@@ -53,6 +162,11 @@ All notable changes to this project will be documented in this file.
 ### Added
 - Data types for the GraphQL language.
 
+[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

README.md

@@ -4,25 +4,38 @@
 [![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 a parser for the GraphQL query language and allows
+GraphQL implementation in Haskell.
-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). Next releases should
-include:
 
-- [x] GraphQL AST
+This implementation is relatively low-level by design, it doesn't provide any
-- [x] Parser for the GraphQL language.
+mappings between the GraphQL types and Haskell's type system and avoids
-- [x] Printer for GraphQL. This is not pretty yet.
+compile-time magic. It focuses on flexibility instead, so other solutions can
-- [ ] GraphQL Schema AST.
+be built on top of it.
-- [ ] Parser for the GraphQL Schema language.
+
-- [ ] Printer for the GraphQL Schema language.
+## State of the work
-- [ ] Interpreter of GraphQL requests.
+
-- [ ] Utilities to define GraphQL types and schema.
+For now this only provides a parser and a printer for the GraphQL query
+language and allows to execute queries and mutations without the schema
+validation step. But the idea is to be a Haskell port of
+[`graphql-js`](https://github.com/graphql/graphql-js).
+
+For the list of currently missing features see issues marked as
+"[not implemented](https://github.com/caraus-ecms/graphql/labels/not%20implemented)".
+
+## Documentation
+
+API documentation is available through
+[hackage](https://hackage.haskell.org/package/graphql).
+
+You'll also find a small tutorial with some examples under
+[docs/tutorial](https://github.com/caraus-ecms/graphql/tree/master/docs/tutorial).
 
 ## Contact
 
 Suggestions, contributions and bug reports are welcome.
 
+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/).

docs/tutorial/tutorial.lhs

@@ -24,7 +24,6 @@ Since this file is a literate haskell file, we start by importing some dependenc
 > import Data.Time (getCurrentTime)
 >
 > import Language.GraphQL
-> import Language.GraphQL.Schema (Schema)
 > import qualified Language.GraphQL.Schema as Schema
 > import Language.GraphQL.Trans (ActionT(..))
 >
@@ -37,7 +36,7 @@ example from [graphql.js](https://github.com/graphql/graphql-js).
 
 First we build a GraphQL schema.
 
-> schema1 :: Schema IO
+> schema1 :: NonEmpty (Schema.Resolver IO)
 > schema1 = hello :| []
 >
 > hello :: Schema.Resolver IO
@@ -67,7 +66,7 @@ returning
 
 For this example, we're going to be using time.
 
-> schema2 :: Schema IO
+> schema2 :: NonEmpty (Schema.Resolver IO)
 > schema2 = time :| []
 >
 > time :: Schema.Resolver IO
@@ -127,7 +126,7 @@ This will fail
 
 Now that we have two resolvers, we can define a schema which uses them both.
 
-> schema3 :: Schema IO
+> schema3 :: NonEmpty (Schema.Resolver IO)
 > schema3 = hello :| [time]
 >
 > query3 :: Text

graphql.cabal

@@ -1,90 +0,0 @@
-cabal-version: 1.12
-
--- This file has been generated from package.yaml by hpack version 0.31.2.
---
--- see: https://github.com/sol/hpack
---
--- hash: dca80d6bcaa432cabc2499efc9f047c6f59546bc2ba75b35fed6efd694895598
-
-name:           graphql
-version:        0.4.0.0
-synopsis:       Haskell GraphQL implementation
-description:    This package provides a rudimentary parser for the <https://graphql.github.io/graphql-spec/June2018/ GraphQL> language.
-category:       Language
-homepage:       https://github.com/caraus-ecms/graphql#readme
-bug-reports:    https://github.com/caraus-ecms/graphql/issues
-author:         Danny Navarro <j@dannynavarro.net>,
-                Matthías Páll Gissurarson <mpg@mpg.is>,
-                Sólrún Halla Einarsdóttir <she@mpg.is>
-maintainer:     belka@caraus.de
-copyright:      (c) 2019 Eugen Wissner,
-                (c) 2015-2017 J. Daniel Navarro
-license:        BSD3
-license-file:   LICENSE
-build-type:     Simple
-extra-source-files:
-    CHANGELOG.md
-    README.md
-    LICENSE
-    docs/tutorial/tutorial.lhs
-data-files:
-    tests/data/kitchen-sink.graphql
-    tests/data/kitchen-sink.min.graphql
-
-source-repository head
-  type: git
-  location: https://github.com/caraus-ecms/graphql
-
-library
-  exposed-modules:
-      Language.GraphQL
-      Language.GraphQL.AST
-      Language.GraphQL.AST.Core
-      Language.GraphQL.AST.Transform
-      Language.GraphQL.Encoder
-      Language.GraphQL.Error
-      Language.GraphQL.Execute
-      Language.GraphQL.Lexer
-      Language.GraphQL.Parser
-      Language.GraphQL.Schema
-      Language.GraphQL.Trans
-      Language.GraphQL.Type
-  other-modules:
-      Paths_graphql
-  hs-source-dirs:
-      src
-  build-depends:
-      aeson
-    , base >=4.7 && <5
-    , megaparsec
-    , text
-    , transformers
-    , unordered-containers
-  default-language: Haskell2010
-
-test-suite tasty
-  type: exitcode-stdio-1.0
-  main-is: Spec.hs
-  other-modules:
-      Language.GraphQL.ErrorSpec
-      Language.GraphQL.LexerSpec
-      Language.GraphQL.ParserSpec
-      Test.KitchenSinkSpec
-      Test.StarWars.Data
-      Test.StarWars.QuerySpec
-      Test.StarWars.Schema
-      Paths_graphql
-  hs-source-dirs:
-      tests
-  ghc-options: -threaded -rtsopts -with-rtsopts=-N
-  build-depends:
-      aeson
-    , base >=4.7 && <5
-    , graphql
-    , hspec
-    , hspec-expectations
-    , megaparsec
-    , raw-strings-qq
-    , text
-    , transformers
-  default-language: Haskell2010

package.yaml

@@ -1,5 +1,5 @@
 name:                graphql
-version:             0.4.0.0
+version:             0.6.1.0
 synopsis:            Haskell GraphQL implementation
 description:
   This package provides a rudimentary parser for the
@@ -28,14 +28,17 @@ data-files:
 dependencies:
 - aeson
 - base >= 4.7 && < 5
+- containers
 - megaparsec
 - text
 - transformers
+- unordered-containers
 
 library:
   source-dirs: src
-  dependencies:
+  other-modules:
-  - unordered-containers
+  - Language.GraphQL.Execute.Transform
+  - Language.GraphQL.Type.Directive
 
 tests:
   tasty:
@@ -49,4 +52,5 @@ tests:
     - graphql
     - hspec
     - hspec-expectations
+    - hspec-megaparsec
     - raw-strings-qq

semaphoreci.sh

@@ -1,6 +1,7 @@
 #!/bin/bash
 
 STACK=$SEMAPHORE_CACHE_DIR/stack
+export STACK_ROOT=$SEMAPHORE_CACHE_DIR/.stack
 
 setup() {
 	if [ ! -e "$STACK" ]
@@ -19,7 +20,8 @@ test() {
 }
 
 test_docs() {
-	$STACK --no-terminal ghc -- -Wall -fno-code docs/tutorial/tutorial.lhs
+	$STACK --no-terminal ghc -- -Wall -Werror -fno-code docs/tutorial/tutorial.lhs
+	$STACK --no-terminal haddock --no-haddock-deps
 }
 
 setup_lint() {

src/Language/GraphQL.hs

@@ -5,32 +5,31 @@ module Language.GraphQL
     ) where
 
 import Control.Monad.IO.Class (MonadIO)
-import qualified Data.Text as T
-
 import qualified Data.Aeson as Aeson
+import Data.List.NonEmpty (NonEmpty)
+import qualified Data.Text as T
+import Language.GraphQL.Error
+import Language.GraphQL.Execute
+import Language.GraphQL.AST.Parser
+import qualified Language.GraphQL.Schema as Schema
 import Text.Megaparsec (parse)
 
-import Language.GraphQL.Execute
+-- | If the text parses correctly as a @GraphQL@ query the query is
-import Language.GraphQL.Parser
+-- executed using the given 'Schema.Resolver's.
-import Language.GraphQL.Schema
+graphql :: MonadIO m
-
+    => NonEmpty (Schema.Resolver m) -- ^ Resolvers.
-import Language.GraphQL.Error
+    -> T.Text -- ^ Text representing a @GraphQL@ request document.
-
+    -> m Aeson.Value -- ^ Response.
--- | Takes a 'Schema' and text representing a @GraphQL@ request document.
---   If the text parses correctly as a @GraphQL@ query the query is
---   executed according to the given 'Schema'.
---
---   Returns the response as an @Aeson.@'Aeson.Value'.
-graphql :: MonadIO m => Schema m -> T.Text -> m Aeson.Value
 graphql = flip graphqlSubs $ const Nothing
 
--- | Takes a 'Schema', a variable substitution function and text
+-- | If the text parses correctly as a @GraphQL@ query the substitution is
---   representing a @GraphQL@ request document.  If the text parses
+-- applied to the query and the query is then executed using to the given
---   correctly as a @GraphQL@ query the substitution is applied to the
+-- 'Schema.Resolver's.
---   query and the query is then executed according to the given 'Schema'.
+graphqlSubs :: MonadIO m
---
+    => NonEmpty (Schema.Resolver m) -- ^ Resolvers.
---   Returns the response as an @Aeson.@'Aeson.Value'.
+    -> Schema.Subs -- ^ Variable substitution function.
-graphqlSubs :: MonadIO m => Schema m -> Subs -> T.Text -> m Aeson.Value
+    -> T.Text -- ^ Text representing a @GraphQL@ request document.
-graphqlSubs schema f =
+    -> m Aeson.Value -- ^ Response.
-    either parseError (execute schema f)
+graphqlSubs schema f
+    = either parseError (execute schema f)
     . parse document ""

src/Language/GraphQL/AST.hs

@@ -5,14 +5,11 @@
 module Language.GraphQL.AST
     ( Alias
     , Argument(..)
-    , Arguments
     , Definition(..)
     , Directive(..)
-    , Directives
     , Document
     , Field(..)
     , FragmentDefinition(..)
-    , FragmentName
     , FragmentSpread(..)
     , InlineFragment(..)
     , Name
@@ -27,108 +24,162 @@ module Language.GraphQL.AST
     , TypeCondition
     , Value(..)
     , VariableDefinition(..)
-    , VariableDefinitions
     ) where
 
 import Data.Int (Int32)
 import Data.List.NonEmpty (NonEmpty)
 import Data.Text (Text)
-import Language.GraphQL.AST.Core ( Alias
-                                 , Name
-                                 )
 
 -- * Document
 
+-- | GraphQL document.
 type Document = NonEmpty Definition
 
+-- | Name
+type Name = Text
+
+-- | Directive.
+data Directive = Directive Name [Argument] deriving (Eq, Show)
+
 -- * Operations
 
-data Definition = DefinitionOperation OperationDefinition
+-- | Top-level definition of a document, either an operation or a fragment.
+data Definition
+    = DefinitionOperation OperationDefinition
     | DefinitionFragment FragmentDefinition
     deriving (Eq, Show)
 
-data OperationDefinition = OperationSelectionSet SelectionSet
+-- | Operation definition.
+data OperationDefinition
+    = OperationSelectionSet SelectionSet
     | OperationDefinition OperationType
                           (Maybe Name)
-                                                 VariableDefinitions
+                          [VariableDefinition]
-                                                 Directives
+                          [Directive]
                           SelectionSet
     deriving (Eq, Show)
 
+-- | GraphQL has 3 operation types: queries, mutations and subscribtions.
+--
+-- Currently only queries and mutations are supported.
 data OperationType = Query | Mutation deriving (Eq, Show)
 
--- * SelectionSet
+-- * Selections
 
+-- | "Top-level" selection, selection on an operation or fragment.
 type SelectionSet = NonEmpty Selection
 
+-- | Field selection.
 type SelectionSetOpt = [Selection]
 
-data Selection = SelectionField          Field
+-- | Single selection element.
+data Selection
+    = SelectionField Field
     | SelectionFragmentSpread FragmentSpread
     | SelectionInlineFragment InlineFragment
     deriving (Eq, Show)
 
 -- * Field
 
-data Field = Field (Maybe Alias) Name Arguments Directives SelectionSetOpt
+-- | Single GraphQL field.
+--
+-- The only required property of a field is its name. Optionally it can also
+-- have an alias, arguments or a list of subfields.
+--
+-- Given the following query:
+--
+-- @
+-- {
+--   zuck: user(id: 4) {
+--     id
+--     name
+--   }
+-- }
+-- @
+--
+-- * "user", "id" and "name" are field names.
+-- * "user" has two subfields, "id" and "name".
+-- * "zuck" is an alias for "user". "id" and "name" have no aliases.
+-- * "id: 4" is an argument for "user". "id" and "name" don't have any
+-- arguments.
+data Field
+    = Field (Maybe Alias) Name [Argument] [Directive] SelectionSetOpt
     deriving (Eq, Show)
 
--- * Arguments
+-- | Alternative field name.
-
+--
-type Arguments = [Argument]
+-- @
+-- {
+--   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
 
+-- | 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)
 
 -- * Fragments
 
-data FragmentSpread = FragmentSpread Name Directives deriving (Eq,Show)
+-- | Fragment spread.
+data FragmentSpread = FragmentSpread Name [Directive] deriving (Eq, Show)
 
-data InlineFragment = InlineFragment (Maybe TypeCondition) Directives SelectionSet
+-- | Inline fragment.
+data InlineFragment = InlineFragment (Maybe TypeCondition) [Directive] SelectionSet
                       deriving (Eq, Show)
 
-data FragmentDefinition =
+-- | Fragment definition.
-  FragmentDefinition FragmentName TypeCondition Directives SelectionSet
+data FragmentDefinition
+    = FragmentDefinition Name TypeCondition [Directive] SelectionSet
     deriving (Eq, Show)
 
-type FragmentName = Name
+-- * Inputs
 
-type TypeCondition = Name
+-- | Input value.
-
+data Value = Variable Name
--- * Input values
+           | Int Int32
-
+           | Float Double
-data Value = ValueVariable Name
+           | String Text
-           | ValueInt Int32
+           | Boolean Bool
-           | ValueFloat Double
+           | Null
-           | ValueString Text
+           | Enum Name
-           | ValueBoolean Bool
+           | List [Value]
-           | ValueNull
+           | Object [ObjectField]
-           | ValueEnum Name
-           | ValueList [Value]
-           | ValueObject [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.
-
-type VariableDefinitions = [VariableDefinition]
-
 data VariableDefinition = VariableDefinition Name Type (Maybe Value)
                           deriving (Eq, Show)
 
--- * Input types
+-- | Type condition.
+type TypeCondition = Name
 
+-- | Type representation.
 data Type = TypeNamed   Name
           | TypeList    Type
           | TypeNonNull NonNullType
             deriving (Eq, Show)
 
+-- | Helper type to represent Non-Null types and lists of such types.
 data NonNullType = NonNullTypeNamed Name
                  | NonNullTypeList  Type
                    deriving (Eq, Show)
-
--- * Directives
-
-type Directives = [Directive]
-
-data Directive = Directive Name [Argument] deriving (Eq,Show)

src/Language/GraphQL/AST/Core.hs

@@ -2,47 +2,75 @@
 module Language.GraphQL.AST.Core
     ( Alias
     , Argument(..)
+    , Arguments(..)
+    , Directive(..)
     , Document
     , Field(..)
+    , Fragment(..)
     , Name
-    , ObjectField(..)
     , Operation(..)
+    , Selection(..)
+    , TypeCondition
     , Value(..)
     ) where
 
 import Data.Int (Int32)
+import Data.HashMap.Strict (HashMap)
 import Data.List.NonEmpty (NonEmpty)
-import Data.String
+import Data.Sequence (Seq)
-
+import Data.String (IsString(..))
 import Data.Text (Text)
+import Language.GraphQL.AST (Alias, Name, TypeCondition)
 
--- | Name
+-- | GraphQL document is a non-empty list of operations.
-type Name = Text
-
 type Document = NonEmpty Operation
 
-data Operation = Query    (NonEmpty Field)
+-- | GraphQL has 3 operation types: queries, mutations and subscribtions.
-               | Mutation (NonEmpty Field)
+--
+-- Currently only queries and mutations are supported.
+data Operation
+    = Query (Maybe Text) (Seq Selection)
+    | Mutation (Maybe Text) (Seq Selection)
     deriving (Eq, Show)
 
-data Field = Field (Maybe Alias) Name [Argument] [Field] deriving (Eq,Show)
+-- | Single GraphQL field.
-
+data Field
-type Alias = Name
+    = Field (Maybe Alias) Name [Argument] (Seq Selection)
+    deriving (Eq, Show)
 
+-- | Single argument.
 data Argument = Argument Name Value deriving (Eq, Show)
 
-data Value = ValueInt Int32
+-- | Argument list.
-           -- GraphQL Float is double precision
+newtype Arguments = Arguments (HashMap Name Value)
-           | ValueFloat Double
+    deriving (Eq, Show)
-           | ValueString Text
+
-           | ValueBoolean Bool
+-- | Directive.
-           | ValueNull
+data Directive = Directive Name Arguments
-           | ValueEnum Name
+    deriving (Eq, Show)
-           | ValueList [Value]
+
-           | ValueObject [ObjectField]
+-- | 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 = ValueString . fromString
+    fromString = String . fromString
-
-data ObjectField = ObjectField Name Value deriving (Eq,Show)

src/Language/GraphQL/AST/Encoder.hs

@@ -0,0 +1,308 @@
+{-# 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 Data.Monoid ((<>))
+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
+
+-- | 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 'Full.Document' into a string.
+document :: Formatter -> Full.Document -> Lazy.Text
+document formatter defs
+    | Pretty _ <- formatter = Lazy.Text.intercalate "\n" encodeDocument
+    | Minified <-formatter = Lazy.Text.snoc (mconcat encodeDocument) '\n'
+  where
+    encodeDocument = NonEmpty.toList $ definition formatter <$> defs
+
+-- | Converts a 'Full.Definition' into a string.
+definition :: Formatter -> Full.Definition -> 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
+
+operationDefinition :: Formatter -> Full.OperationDefinition -> Lazy.Text
+operationDefinition formatter (Full.OperationSelectionSet 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
+
+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
+
+indent :: (Integral a) => a -> Lazy.Text
+indent indentation = Lazy.Text.replicate (fromIntegral indentation) "  "
+
+selection :: Formatter -> Full.Selection -> Lazy.Text
+selection formatter = Lazy.Text.append indent' . encodeSelection
+  where
+    encodeSelection (Full.SelectionField field') = field incrementIndent field'
+    encodeSelection (Full.SelectionInlineFragment fragment) =
+        inlineFragment incrementIndent fragment
+    encodeSelection (Full.SelectionFragmentSpread spread) =
+        fragmentSpread incrementIndent spread
+    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 ": " ":"
+
+field :: Formatter -> Full.Field -> Lazy.Text
+field formatter (Full.Field 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.FragmentSpread -> Lazy.Text
+fragmentSpread formatter (Full.FragmentSpread name ds)
+    = "..." <> Lazy.Text.fromStrict name <> optempty (directives formatter) ds
+
+inlineFragment :: Formatter -> Full.InlineFragment -> Lazy.Text
+inlineFragment formatter (Full.InlineFragment 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 = mempty
+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"
+
+stringValue :: Formatter -> Text -> Lazy.Text
+stringValue Minified string = Builder.toLazyText
+    $ quote <> Text.foldr (mappend . escape') quote string
+  where
+    quote = Builder.singleton '\"'
+    escape' '\n' = Builder.fromString "\\n"
+    escape' char = escape char
+stringValue (Pretty indentation) string = byStringType $ Text.lines string
+  where
+    byStringType [] = "\"\""
+    byStringType [line] = Builder.toLazyText
+        $ quote <> Text.foldr (mappend . escape) quote line
+    byStringType lines' = "\"\"\"\n"
+        <> Lazy.Text.unlines (transformLine <$> lines')
+        <> indent indentation
+        <> "\"\"\""
+    transformLine = (indent (indentation + 1) <>)
+        . Lazy.Text.fromStrict
+        . Text.replace "\"\"\"" "\\\"\"\""
+    quote = Builder.singleton '\"'
+
+escape :: Char -> Builder
+escape char'
+    | char' == '\\' = Builder.fromString "\\\\"
+    | char' == '\"' = Builder.fromString "\\\""
+    | char' == '\b' = Builder.fromString "\\b"
+    | char' == '\f' = Builder.fromString "\\f"
+    | char' == '\r' = Builder.fromString "\\r"
+    | 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

@@ -3,7 +3,7 @@
 
 -- | This module defines a bunch of small parsers used to parse individual
 --   lexemes.
-module Language.GraphQL.Lexer 
+module Language.GraphQL.AST.Lexer
     ( Parser
     , amp
     , at
@@ -71,6 +71,8 @@ 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
 
@@ -87,12 +89,12 @@ symbol :: T.Text -> Parser T.Text
 symbol = Lexer.symbol spaceConsumer
 
 -- | Parser for "!".
-bang :: Parser Char
+bang :: Parser T.Text
-bang = char '!'
+bang = symbol "!"
 
 -- | Parser for "$".
-dollar :: Parser Char
+dollar :: Parser T.Text
-dollar = char '$'
+dollar = symbol "$"
 
 -- | Parser for "@".
 at :: Parser Char
@@ -132,7 +134,7 @@ braces = between (symbol "{") (symbol "}")
 
 -- | Parser for strings.
 string :: Parser T.Text
-string = between "\"" "\"" stringValue
+string = between "\"" "\"" stringValue <* spaceConsumer 
   where
     stringValue = T.pack <$> many stringCharacter
     stringCharacter = satisfy isStringCharacter1
@@ -141,7 +143,7 @@ string = between "\"" "\"" stringValue
 
 -- | Parser for block strings.
 blockString :: Parser T.Text
-blockString = between "\"\"\"" "\"\"\"" stringValue
+blockString = between "\"\"\"" "\"\"\"" stringValue <* spaceConsumer 
   where
     stringValue = do
         byLine <- sepBy (many blockStringCharacter) lineTerminator

src/Language/GraphQL/AST/Parser.hs

@@ -1,6 +1,8 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
-module Language.GraphQL.Parser
+
+-- | @GraphQL@ document parser.
+module Language.GraphQL.AST.Parser
     ( document
     ) where
 
@@ -9,13 +11,14 @@ import Control.Applicative ( Alternative(..)
                            )
 import Data.List.NonEmpty (NonEmpty(..))
 import Language.GraphQL.AST
-import Language.GraphQL.Lexer
+import Language.GraphQL.AST.Lexer
 import Text.Megaparsec ( lookAhead
                        , option
                        , try
                        , (<?>)
                        )
 
+-- | Parser for the GraphQL documents.
 document :: Parser Document
 document = unicodeBOM >> spaceConsumer >> lexeme (manyNE definition)
 
@@ -66,7 +69,7 @@ alias = try $ name <* colon
 
 -- * Arguments
 
-arguments :: Parser Arguments
+arguments :: Parser [Argument]
 arguments = parens $ some argument
 
 argument :: Parser Argument
@@ -93,7 +96,7 @@ fragmentDefinition = FragmentDefinition
                  <*> opt directives
                  <*> selectionSet
 
-fragmentName :: Parser FragmentName
+fragmentName :: Parser Name
 fragmentName = but (symbol "on") *> name
 
 typeCondition :: Parser TypeCondition
@@ -102,16 +105,16 @@ typeCondition = symbol "on" *> name
 -- * Input Values
 
 value :: Parser Value
-value = ValueVariable <$> variable
+value = Variable <$> variable
-    <|> ValueFloat    <$> try float
+    <|> Float    <$> try float
-    <|> ValueInt      <$> integer
+    <|> Int      <$> integer
-    <|> ValueBoolean  <$> booleanValue
+    <|> Boolean  <$> booleanValue
-    <|> ValueNull     <$  symbol "null"
+    <|> Null     <$  symbol "null"
-    <|> ValueString   <$> string
+    <|> String   <$> blockString
-    <|> ValueString   <$> blockString
+    <|> String   <$> string
-    <|> ValueEnum     <$> try enumValue
+    <|> Enum     <$> try enumValue
-    <|> ValueList     <$> listValue
+    <|> List     <$> listValue
-    <|> ValueObject   <$> objectValue
+    <|> Object   <$> objectValue
     <?> "value error!"
   where
     booleanValue :: Parser Bool
@@ -132,7 +135,7 @@ objectField = ObjectField <$> name <* symbol ":" <*> value
 
 -- * Variables
 
-variableDefinitions :: Parser VariableDefinitions
+variableDefinitions :: Parser [VariableDefinition]
 variableDefinitions = parens $ some variableDefinition
 
 variableDefinition :: Parser VariableDefinition
@@ -149,9 +152,9 @@ defaultValue = equals *> value
 -- * Input Types
 
 type_ :: Parser Type
-type_ = try (TypeNamed <$> name <* but "!")
+type_ = try (TypeNonNull <$> nonNullType)
     <|> TypeList <$> brackets type_
-    <|> TypeNonNull    <$> nonNullType
+    <|> TypeNamed <$> name
     <?> "type_ error!"
 
 nonNullType :: Parser NonNullType
@@ -161,7 +164,7 @@ nonNullType = NonNullTypeNamed <$> name <* bang
 
 -- * Directives
 
-directives :: Parser Directives
+directives :: Parser [Directive]
 directives = some directive
 
 directive :: Parser Directive

src/Language/GraphQL/AST/Transform.hs

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

src/Language/GraphQL/Encoder.hs

@@ -1,180 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
--- | This module defines a printer for the @GraphQL@ language.
-module Language.GraphQL.Encoder
-    ( document
-    , spaced
-    ) where
-
-import Data.Foldable (fold)
-import Data.Monoid ((<>))
-import qualified Data.List.NonEmpty as NonEmpty (toList)
-import Data.Text (Text, cons, intercalate, pack, snoc)
-import Language.GraphQL.AST
-
--- * Document
-
-document :: Document -> Text
-document defs = (`snoc` '\n') . mconcat . NonEmpty.toList $ definition <$> defs
-
-definition :: Definition -> Text
-definition (DefinitionOperation x) = operationDefinition x
-definition (DefinitionFragment  x) = fragmentDefinition x
-
-operationDefinition :: OperationDefinition -> Text
-operationDefinition (OperationSelectionSet sels) = selectionSet sels
-operationDefinition (OperationDefinition Query    name vars dirs sels) =
-  "query " <> node (fold name) vars dirs sels
-operationDefinition (OperationDefinition Mutation name vars dirs sels) =
-  "mutation " <> node (fold name) vars dirs sels
-
-node :: Name -> VariableDefinitions -> Directives -> SelectionSet -> Text
-node name vars dirs sels =
-       name
-    <> optempty variableDefinitions vars
-    <> optempty directives dirs
-    <> selectionSet sels
-
-variableDefinitions :: [VariableDefinition] -> Text
-variableDefinitions = parensCommas variableDefinition
-
-variableDefinition :: VariableDefinition -> Text
-variableDefinition (VariableDefinition var ty dv) =
-    variable var <> ":" <> type_ ty <> maybe mempty defaultValue dv
-
-defaultValue :: Value -> Text
-defaultValue val = "=" <> value val
-
-variable :: Name -> Text
-variable var = "$" <> var
-
-selectionSet :: SelectionSet -> Text
-selectionSet = bracesCommas selection . NonEmpty.toList
-
-selectionSetOpt :: SelectionSetOpt -> Text
-selectionSetOpt = 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 dirs selso) =
-       optempty (`snoc` ':') (fold alias)
-    <> name
-    <> optempty arguments args
-    <> optempty directives dirs
-    <> optempty selectionSetOpt selso
-
-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 tc dirs sels) =
-    "... on " <> fold tc
-              <> directives dirs
-              <> selectionSet sels
-
-fragmentDefinition :: FragmentDefinition -> Text
-fragmentDefinition (FragmentDefinition name tc dirs sels) =
-    "fragment " <> name <> " on " <> tc
-                <> optempty directives dirs
-                <> selectionSet sels
-
--- * Values
-
-value :: Value -> Text
-value (ValueVariable x) = variable x
--- TODO: This will be replaced with `decimal` Builder
-value (ValueInt      x) = pack $ show x
--- TODO: This will be replaced with `decimal` Builder
-value (ValueFloat    x) = pack $ show x
-value (ValueBoolean  x) = booleanValue x
-value ValueNull         = mempty
-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 :: Text -> Text
-stringValue = quotes
-
-listValue :: [Value] -> Text
-listValue = bracketsCommas value
-
-objectValue :: [ObjectField] -> Text
-objectValue = bracesCommas objectField
-
-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   x) = x
-type_ (TypeList    x) = listType x
-type_ (TypeNonNull x) = nonNullType x
-
-listType :: Type -> Text
-listType x = brackets (type_ x)
-
-nonNullType :: NonNullType -> Text
-nonNullType (NonNullTypeNamed x) = x <> "!"
-nonNullType (NonNullTypeList  x) = listType x <> "!"
-
--- * 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

src/Language/GraphQL/Error.hs

@@ -1,5 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
+
+-- | Error handling.
 module Language.GraphQL.Error
     ( parseError
     , CollectErrsT

src/Language/GraphQL/Execute.hs

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

src/Language/GraphQL/Execute/Transform.hs

@@ -0,0 +1,184 @@
+{-# 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, ask, 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 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 -> Full.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 (Full.DefinitionOperation definition) acc =
+        (definition :) <$> acc
+    defragment (Full.DefinitionFragment definition) acc =
+        let (Full.FragmentDefinition name _ _ _) = definition
+         in first (HashMap.insert name definition) 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.OperationSelectionSet sels) =
+    operation $ Full.OperationDefinition Full.Query mempty mempty mempty sels
+-- TODO: Validate Variable definitions with substituter
+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.SelectionField field') =
+    maybe (Left mempty) (Right . Core.SelectionField) <$> field field'
+selection (Full.SelectionFragmentSpread fragment) =
+    maybe (Left mempty) (Right . Core.SelectionFragment)
+    <$> fragmentSpread fragment
+selection (Full.SelectionInlineFragment fragment) =
+    inlineFragment fragment
+
+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
+
+inlineFragment ::
+    Full.InlineFragment ->
+    TransformT (Either (Seq Core.Selection) Core.Selection)
+inlineFragment (Full.InlineFragment type' directives' selectionSet) = do
+    fragmentDirectives <- Directive.selection <$> directives directives'
+    case fragmentDirectives of
+        Nothing -> pure $ Left mempty
+        _ -> do
+            fragmentSelectionSet <- appendSelection selectionSet
+            pure $ maybe Left selectionFragment type' fragmentSelectionSet
+  where
+    selectionFragment typeName = Right
+        . Core.SelectionFragment
+        . Core.Fragment typeName
+
+fragmentSpread :: Full.FragmentSpread -> TransformT (Maybe Core.Fragment)
+fragmentSpread (Full.FragmentSpread name directives') = 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
+
+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'
+
+field :: Full.Field -> TransformT (Maybe Core.Field)
+field (Full.Field alias name arguments' directives' selections) = do
+    fieldArguments <- traverse argument arguments'
+    fieldSelections <- appendSelection selections
+    fieldDirectives <- Directive.selection <$> directives directives'
+    let field' = Core.Field alias name fieldArguments fieldSelections
+    pure $ field' <$ fieldDirectives
+
+arguments :: [Full.Argument] -> TransformT Core.Arguments
+arguments = fmap Core.Arguments . foldM go HashMap.empty
+  where
+    go arguments' argument' = do
+        (Core.Argument name value') <- argument argument'
+        return $ HashMap.insert name value' arguments'
+
+argument :: Full.Argument -> TransformT Core.Argument
+argument (Full.Argument n v) = Core.Argument n <$> value v
+
+value :: Full.Value -> TransformT Core.Value
+value (Full.Variable n) = do
+    substitute' <- lift ask
+    lift . lift $ substitute' n
+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

@@ -1,20 +1,15 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 -- | This module provides a representation of a @GraphQL@ Schema in addition to
---   functions for defining and manipulating Schemas.
+-- functions for defining and manipulating schemas.
 module Language.GraphQL.Schema
     ( Resolver
-    , Schema
     , Subs
     , object
     , objectA
     , scalar
     , scalarA
-    , enum
-    , enumA
     , resolve
-    , wrappedEnum
-    , wrappedEnumA
     , wrappedObject
     , wrappedObjectA
     , wrappedScalar
@@ -28,35 +23,27 @@ module Language.GraphQL.Schema
 import Control.Monad.IO.Class (MonadIO(..))
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.Except (runExceptT)
-import Data.Foldable ( find
+import Control.Monad.Trans.Reader (runReaderT)
-                     , fold
+import Data.Foldable (find, fold)
-                     )
-import Data.List.NonEmpty (NonEmpty)
 import Data.Maybe (fromMaybe)
 import qualified Data.Aeson as Aeson
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
+import Data.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 Language.GraphQL.Type
+import qualified Language.GraphQL.Type as Type
-import Language.GraphQL.AST.Core
 
--- | A GraphQL schema.
+-- | Resolves a 'Field' into an @Aeson.@'Data.Aeson.Types.Object' with error
---   @m@ is usually expected to be an instance of 'MonadIO'.
+--   information (if an error has occurred). @m@ is usually expected to be an
-type Schema m = NonEmpty (Resolver m)
+--   instance of 'MonadIO'.
-
--- | Resolves a 'Field' into an @Aeson.@'Aeson.Object' with error information
---   (or 'empty'). @m@ is usually expected to be an instance of 'MonadIO.
 data Resolver m = Resolver
     Text -- ^ Name
     (Field -> CollectErrsT m Aeson.Object) -- ^ Resolver
 
-type Fields = [Field]
-
-type Arguments = [Argument]
-
 -- | Variable substitution function.
 type Subs = Name -> Maybe Value
 
@@ -66,14 +53,14 @@ object name = objectA name . const
 
 -- | Like 'object' but also taking 'Argument's.
 objectA :: MonadIO m
-    => Name -> (Arguments -> ActionT m [Resolver m]) -> Resolver m
+    => Name -> ([Argument] -> ActionT m [Resolver m]) -> Resolver m
 objectA name f = Resolver name $ resolveFieldValue f resolveRight
   where
     resolveRight fld@(Field _ _ _ flds) resolver = withField (resolve resolver flds) fld
 
 -- | Like 'object' but also taking 'Argument's and can be null or a list of objects.
 wrappedObjectA :: MonadIO m
-    => Name -> (Arguments -> ActionT m (Wrapping [Resolver m])) -> Resolver m
+    => Name -> ([Argument] -> ActionT m (Type.Wrapping [Resolver m])) -> Resolver m
 wrappedObjectA name f = Resolver name $ resolveFieldValue f resolveRight
   where
     resolveRight fld@(Field _ _ _ sels) resolver
@@ -81,7 +68,7 @@ wrappedObjectA name f = Resolver name $ resolveFieldValue f resolveRight
 
 -- | Like 'object' but can be null or a list of objects.
 wrappedObject :: MonadIO m
-    => Name -> ActionT m (Wrapping [Resolver m]) -> Resolver m
+    => Name -> ActionT m (Type.Wrapping [Resolver m]) -> Resolver m
 wrappedObject name = wrappedObjectA name . const
 
 -- | A scalar represents a primitive value, like a string or an integer.
@@ -90,60 +77,36 @@ scalar name = scalarA name . const
 
 -- | Like 'scalar' but also taking 'Argument's.
 scalarA :: (MonadIO m, Aeson.ToJSON a)
-    => Name -> (Arguments -> ActionT m a) -> Resolver m
+    => Name -> ([Argument] -> ActionT m a) -> Resolver m
 scalarA name f = Resolver name $ resolveFieldValue f resolveRight
   where
     resolveRight fld result = withField (return result) fld
 
--- | Lika 'scalar' but also taking 'Argument's and can be null or a list of scalars.
+-- | Like 'scalar' but also taking 'Argument's and can be null or a list of scalars.
 wrappedScalarA :: (MonadIO m, Aeson.ToJSON a)
-    => Name -> (Arguments -> ActionT m (Wrapping a)) -> Resolver m
+    => Name -> ([Argument] -> ActionT m (Type.Wrapping a)) -> Resolver m
 wrappedScalarA name f = Resolver name $ resolveFieldValue f resolveRight
   where
-    resolveRight fld (Named result) = withField (return result) fld
+    resolveRight fld (Type.Named result) = withField (return result) fld
-    resolveRight fld Null
+    resolveRight fld Type.Null
         = return $ HashMap.singleton (aliasOrName fld) Aeson.Null
-    resolveRight fld (List result) = withField (return result) fld
+    resolveRight fld (Type.List result) = withField (return result) fld
 
 -- | Like 'scalar' but can be null or a list of scalars.
 wrappedScalar :: (MonadIO m, Aeson.ToJSON a)
-    => Name -> ActionT m (Wrapping a) -> Resolver m
+    => Name -> ActionT m (Type.Wrapping a) -> Resolver m
 wrappedScalar name = wrappedScalarA name . const
 
--- | Represents one of a finite set of possible values.
---   Used in place of a 'scalar' when the possible responses are easily enumerable.
-enum :: MonadIO m => Name -> ActionT m [Text] -> Resolver m
-enum name = enumA name . const
-
--- | Like 'enum' but also taking 'Argument's.
-enumA :: MonadIO m => Name -> (Arguments -> ActionT m [Text]) -> Resolver m
-enumA name f = Resolver name $ resolveFieldValue f resolveRight
-  where
-    resolveRight fld resolver = withField (return resolver) fld
-
--- | Like 'enum' but also taking 'Argument's and can be null or a list of enums.
-wrappedEnumA :: MonadIO m
-    => Name -> (Arguments -> ActionT m (Wrapping [Text])) -> Resolver m
-wrappedEnumA name f = Resolver name $ resolveFieldValue f resolveRight
-  where
-    resolveRight fld (Named resolver) = withField (return resolver) fld
-    resolveRight fld Null
-        = return $ HashMap.singleton (aliasOrName fld) Aeson.Null
-    resolveRight fld (List resolver) = withField (return resolver) fld
-
--- | Like 'enum' but can be null or a list of enums.
-wrappedEnum :: MonadIO m => Name -> ActionT m (Wrapping [Text]) -> Resolver m
-wrappedEnum name = wrappedEnumA name . const
-
 resolveFieldValue :: MonadIO m
     => ([Argument] -> ActionT m a)
     -> (Field -> a -> CollectErrsT m (HashMap Text Aeson.Value))
     -> Field
     -> CollectErrsT m (HashMap Text Aeson.Value)
 resolveFieldValue f resolveRight fld@(Field _ _ args _) = do
-    result <- lift $ runExceptT . runActionT $ f args
+    result <- lift $ reader . runExceptT . runActionT $ f args
     either resolveLeft (resolveRight fld) result
       where
+        reader = flip runReaderT $ Context mempty
         resolveLeft err = do
             _ <- addErrMsg err
             return $ HashMap.singleton (aliasOrName fld) Aeson.Null
@@ -158,11 +121,21 @@ withField v fld
 --   'Resolver' to each 'Field'. Resolves into a value containing the
 --   resolved 'Field', or a null value and error information.
 resolve :: MonadIO m
-    => [Resolver m] -> Fields -> CollectErrsT m Aeson.Value
+    => [Resolver m] -> Seq Selection -> CollectErrsT m Aeson.Value
 resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers
   where
-    tryResolvers fld = maybe (errmsg fld) (tryResolver fld) $ find (compareResolvers fld) resolvers
+    resolveTypeName (Resolver "__typename" f) = do
-    compareResolvers (Field _ name _ _) (Resolver name' _) = name == name'
+        value <- f $ Field Nothing "__typename" mempty mempty
+        return $ HashMap.lookupDefault "" "__typename" value
+    resolveTypeName _ = return ""
+    tryResolvers (SelectionField fld@(Field _ name _ _))
+        = maybe (errmsg fld) (tryResolver fld) $ find (compareResolvers name) resolvers
+    tryResolvers (SelectionFragment (Fragment typeCondition selections')) = do
+        that <- traverse resolveTypeName (find (compareResolvers "__typename") resolvers)
+        if maybe True (Aeson.String typeCondition ==) that
+            then fmap fold . traverse tryResolvers $ selections'
+            else return mempty
+    compareResolvers name (Resolver name' _) = name == name'
     tryResolver fld (Resolver _ resolver)  = resolver fld
     errmsg fld@(Field _ name _ _) = do
         addErrMsg $ T.unwords ["field", name, "not resolved."]

src/Language/GraphQL/Trans.hs

@@ -1,5 +1,7 @@
+-- | Monad transformer stack used by the @GraphQL@ resolvers.
 module Language.GraphQL.Trans
     ( ActionT(..)
+    , Context(Context)
     ) where
 
 import Control.Applicative (Alternative(..))
@@ -7,9 +9,19 @@ 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)
+import Data.HashMap.Strict (HashMap)
 import Data.Text (Text)
+import Language.GraphQL.AST.Core (Name, Value)
 
-newtype ActionT m a = ActionT { runActionT :: ExceptT Text m a }
+-- | Resolution context holds resolver arguments.
+newtype Context = Context (HashMap Name Value)
+
+-- | Monad transformer stack used by the resolvers to provide error handling
+--   and resolution context (resolver arguments).
+newtype ActionT m a = ActionT
+    { runActionT :: ExceptT Text (ReaderT Context m) a
+    }
 
 instance Functor m => Functor (ActionT m) where
     fmap f = ActionT . fmap f . runActionT
@@ -23,7 +35,7 @@ instance Monad m => Monad (ActionT m) where
     (ActionT action) >>= f = ActionT $ action >>= runActionT . f
 
 instance MonadTrans ActionT where
-    lift = ActionT . lift
+    lift = ActionT . lift . lift
 
 instance MonadIO m => MonadIO (ActionT m) where
     liftIO = lift . liftIO

src/Language/GraphQL/Type.hs

@@ -1,11 +1,9 @@
--- | Definitions for @GraphQL@ type system.
+-- | Definitions for @GraphQL@ input types.
 module Language.GraphQL.Type
     ( Wrapping(..)
     ) where
 
-import Data.Aeson as Aeson ( ToJSON
+import Data.Aeson as Aeson (ToJSON, toJSON)
-                           , toJSON
-                           )
 import qualified Data.Aeson as Aeson
 
 -- | GraphQL distinguishes between "wrapping" and "named" types. Each wrapping

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.yaml

@@ -1,6 +1,9 @@
-resolver: lts-13.29
+resolver: lts-14.18
+
 packages:
-- '.'
+- .
+
 extra-deps: []
 flags: {}
-extra-package-dbs: []
+
+pvp-bounds: both

stack.yaml.lock

@@ -1,12 +0,0 @@
-# This file was autogenerated by Stack.
-# You should not edit this file by hand.
-# For more information, please see the documentation at:
-#   https://docs.haskellstack.org/en/stable/lock_files
-
-packages: []
-snapshots:
-- completed:
-    size: 500539
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/13/29.yaml
-    sha256: 006398c5e92d1d64737b7e98ae4d63987c36808814504d1451f56ebd98093f75
-  original: lts-13.29

tests/Language/GraphQL/AST/EncoderSpec.hs

@@ -0,0 +1,46 @@
+{-# 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)
+import Text.RawString.QQ (r)
+
+spec :: Spec
+spec = do
+    describe "value" $ do
+        context "minified" $ do
+            it "escapes \\" $
+                value minified (String "\\") `shouldBe` "\"\\\\\""
+            it "escapes quotes" $
+                value minified (String "\"") `shouldBe` "\"\\\"\""
+            it "escapes backspace" $
+                value minified (String "a\bc") `shouldBe` "\"a\\bc\""
+            it "escapes Unicode" $
+                value minified (String "\0") `shouldBe` "\"\\u0000\""
+
+        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" $
+                value pretty (String "Line 1\nLine 2")
+                    `shouldBe` "\"\"\"\n  Line 1\n  Line 2\n\"\"\""
+            it "escapes \\ in short strings" $
+                value pretty (String "\\") `shouldBe` "\"\\\\\""
+
+    describe "definition" $
+        it "indents block strings in arguments" $
+            let arguments = [Argument "message" (String "line1\nline2")]
+                field = Field Nothing "field" arguments [] []
+                set = OperationSelectionSet $ pure $ SelectionField field
+                operation = DefinitionOperation set
+             in definition pretty operation `shouldBe` [r|{
+  field(message: """
+    line1
+    line2
+  """)
+}
+|]

tests/Language/GraphQL/AST/LexerSpec.hs

@@ -0,0 +1,92 @@
+{-# 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, 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` "&"
+
+runBetween :: (Parser () -> Parser ()) -> Text -> Either (ParseErrorBundle Text Void) ()
+runBetween parser = parse (parser $ pure ()) ""

tests/Language/GraphQL/AST/ParserSpec.hs

@@ -0,0 +1,44 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+module Language.GraphQL.AST.ParserSpec
+    ( spec
+    ) where
+
+import Language.GraphQL.AST.Parser
+import Test.Hspec (Spec, describe, it)
+import Test.Hspec.Megaparsec (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""")
+            }|]

tests/Language/GraphQL/LexerSpec.hs

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

tests/Language/GraphQL/ParserSpec.hs

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

tests/Test/DirectiveSpec.hs

@@ -0,0 +1,84 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+module Test.DirectiveSpec
+    ( spec
+    ) where
+
+import Data.Aeson (Value, object, (.=))
+import Data.List.NonEmpty (NonEmpty(..))
+import Language.GraphQL
+import qualified Language.GraphQL.Schema as Schema
+import Test.Hspec (Spec, describe, it, shouldBe)
+import Text.RawString.QQ (r)
+
+experimentalResolver :: Schema.Resolver IO
+experimentalResolver = 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 (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 (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 (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 (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 (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 (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 (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 (garment "Hat" :| []) query
+            actual `shouldBe` expected

tests/Test/KitchenSinkSpec.hs

@@ -1,29 +1,69 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
 module Test.KitchenSinkSpec
     ( spec
     ) where
 
 import qualified Data.Text.IO as Text.IO
-import qualified Language.GraphQL.Encoder as Encoder
+import qualified Data.Text.Lazy.IO as Text.Lazy.IO
-import qualified Language.GraphQL.Parser as Parser
+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
+import Test.Hspec (Spec, describe, it)
-                  , describe
+import Test.Hspec.Megaparsec (parseSatisfies)
-                  , it
+import Text.Megaparsec (parse)
-                  )
+import Text.RawString.QQ (r)
-import Test.Hspec.Expectations ( expectationFailure
-                               , shouldBe
-                               )
-import Text.Megaparsec ( errorBundlePretty
-                       , parse
-                       )
 
 spec :: Spec
-spec = describe "Kitchen Sink" $
+spec = describe "Kitchen Sink" $ do
-    it "prints the query" $ do
+    it "minifies the query" $ do
-        dataFileName <- getDataFileName "tests/data/kitchen-sink.min.graphql"
+        dataFileName <- getDataFileName "tests/data/kitchen-sink.graphql"
-        expected <- Text.IO.readFile dataFileName
+        minFileName <- getDataFileName "tests/data/kitchen-sink.min.graphql"
+        expected <- Text.Lazy.IO.readFile minFileName
 
-        either
+        shouldNormalize Encoder.minified dataFileName expected
-            (expectationFailure . errorBundlePretty)
+
-            (flip shouldBe expected . Encoder.document)
+    it "pretty prints the query" $ do
-            $ parse Parser.document dataFileName expected
+        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

@@ -26,6 +26,7 @@ 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
@@ -190,8 +191,8 @@ getDroid' _      = empty
 getFriends :: Character -> [Character]
 getFriends char = catMaybes $ liftA2 (<|>) getDroid getHuman <$> friends char
 
-getEpisode :: Alternative f => Int -> f Text
+getEpisode :: Int -> Maybe (Type.Wrapping Text)
-getEpisode 4 = pure "NEWHOPE"
+getEpisode 4 = pure $ Type.Named "NEWHOPE"
-getEpisode 5 = pure "EMPIRE"
+getEpisode 5 = pure $ Type.Named "EMPIRE"
-getEpisode 6 = pure "JEDI"
+getEpisode 6 = pure $ Type.Named "JEDI"
 getEpisode _ = empty

tests/Test/StarWars/Schema.hs

@@ -11,52 +11,48 @@ module Test.StarWars.Schema
 import Control.Monad.Trans.Except (throwE)
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.IO.Class (MonadIO(..))
-import Data.List.NonEmpty (NonEmpty((:|)))
+import Data.List.NonEmpty (NonEmpty(..))
-import Language.GraphQL.Schema ( Schema
+import Data.Maybe (catMaybes)
-                               , Resolver
-                               , Argument(..)
-                               , Value(..)
-                               )
 import qualified Language.GraphQL.Schema as Schema
 import Language.GraphQL.Trans
-import Language.GraphQL.Type
+import qualified Language.GraphQL.Type as Type
 import Test.StarWars.Data
 
--- * Schema
 -- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js
 
-schema :: MonadIO m => Schema m
+schema :: MonadIO m => NonEmpty (Schema.Resolver m)
 schema = hero :| [human, droid]
 
-hero :: MonadIO m => Resolver m
+hero :: MonadIO m => Schema.Resolver m
 hero = Schema.objectA "hero" $ \case
   [] -> character artoo
-  [Argument "episode" (ValueEnum "NEWHOPE")] -> character $ getHero 4
+  [Schema.Argument "episode" (Schema.Enum "NEWHOPE")] -> character $ getHero 4
-  [Argument "episode" (ValueEnum "EMPIRE" )] -> character $ getHero 5
+  [Schema.Argument "episode" (Schema.Enum "EMPIRE" )] -> character $ getHero 5
-  [Argument "episode" (ValueEnum "JEDI"   )] -> character $ getHero 6
+  [Schema.Argument "episode" (Schema.Enum "JEDI"   )] -> character $ getHero 6
   _ -> ActionT $ throwE "Invalid arguments."
 
-human :: MonadIO m => Resolver m
+human :: MonadIO m => Schema.Resolver m
 human = Schema.wrappedObjectA "human" $ \case
-  [Argument "id" (ValueString i)] -> do
+  [Schema.Argument "id" (Schema.String i)] -> do
       humanCharacter <- lift $ return $ getHuman i >>= Just
       case humanCharacter of
-        Nothing -> return Null
+        Nothing -> return Type.Null
-        Just e -> Named <$> character e
+        Just e -> Type.Named <$> character e
   _ -> ActionT $ throwE "Invalid arguments."
 
-droid :: MonadIO m => Resolver m
+droid :: MonadIO m => Schema.Resolver m
 droid = Schema.objectA "droid" $ \case
-   [Argument "id" (ValueString i)] -> character =<< liftIO (getDroid i)
+   [Schema.Argument "id" (Schema.String i)] -> character =<< liftIO (getDroid i)
    _ -> ActionT $ throwE "Invalid arguments."
 
-character :: MonadIO m => Character -> ActionT m [Resolver m]
+character :: MonadIO m => Character -> ActionT m [Schema.Resolver m]
 character char = return
     [ Schema.scalar "id" $ return $ id_ char
     , Schema.scalar "name" $ return $ name char
     , Schema.wrappedObject "friends"
-        $ traverse character $ List $ Named <$> getFriends char
+        $ traverse character $ Type.List $ Type.Named <$> getFriends char
-    , Schema.enum "appearsIn" $ return $ foldMap getEpisode $ appearsIn 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

@@ -11,7 +11,7 @@ query queryName($foo: ComplexType, $site: Site = MOBILE) {
     ... on User @defer {
       field2 {
         id,
-        alias: field1(first:10, after:$foo,) @include(if: $foo) {
+        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}