Release 0.6.0.0

The Reader contains a Name/Value hashmap, which will contain resolver
arguments.

CHANGELOG.md

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

package.yaml

@@ -1,5 +1,5 @@
 name:                graphql
-version:             0.5.1.0
+version:             0.6.0.0
 synopsis:            Haskell GraphQL implementation
 description:
   This package provides a rudimentary parser for the
@@ -28,6 +28,7 @@ data-files:
 dependencies:
 - aeson
 - base >= 4.7 && < 5
+- containers
 - megaparsec
 - text
 - transformers
@@ -35,6 +36,8 @@ dependencies:
 
 library:
   source-dirs: src
+  other-modules:
+    - Language.GraphQL.AST.Transform
 
 tests:
   tasty:

src/Language/GraphQL.hs

@@ -10,7 +10,7 @@ import Data.List.NonEmpty (NonEmpty)
 import qualified Data.Text as T
 import Language.GraphQL.Error
 import Language.GraphQL.Execute
-import Language.GraphQL.Parser
+import Language.GraphQL.AST.Parser
 import qualified Language.GraphQL.Schema as Schema
 import Text.Megaparsec (parse)
 

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,22 +24,23 @@ 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
-                                 , TypeCondition
-                                 )
 
 -- * Document
 
 -- | GraphQL document.
 type Document = NonEmpty Definition
 
+-- | Name
+type Name = Text
+
+-- | Directive.
+data Directive = Directive Name [Argument] deriving (Eq, Show)
+
 -- * Operations
 
 -- | Top-level definition of a document, either an operation or a fragment.
@@ -68,7 +66,7 @@ data OperationType = Query | Mutation deriving (Eq, Show)
 
 -- * Selections
 
--- | "Top-level" selection, selection on a operation.
+-- | "Top-level" selection, selection on an operation or fragment.
 type SelectionSet = NonEmpty Selection
 
 -- | Field selection.
@@ -83,18 +81,56 @@ data Selection
 
 -- * Field
 
--- | GraphQL field.
+-- | 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.
+--
+-- @
+-- {
+--   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
 
--- | Argument list.
+-- | Single argument.
-{-# DEPRECATED Arguments "Use [Argument] instead" #-}
+--
-type Arguments = [Argument]
+-- @
-
+-- {
--- | 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
@@ -111,21 +147,18 @@ data FragmentDefinition
     = FragmentDefinition Name TypeCondition [Directive] SelectionSet
     deriving (Eq, Show)
 
-{-# DEPRECATED FragmentName "Use Name instead" #-}
+-- * Inputs
-type FragmentName = Name
-
--- * Input values
 
 -- | Input value.
-data Value = ValueVariable Name
+data Value = Variable Name
-           | ValueInt Int32
+           | Int Int32
-           | ValueFloat Double
+           | Float Double
-           | ValueString Text
+           | String Text
-           | ValueBoolean Bool
+           | Boolean Bool
-           | ValueNull
+           | Null
-           | ValueEnum Name
+           | Enum Name
-           | ValueList [Value]
+           | List [Value]
-           | ValueObject [ObjectField]
+           | Object [ObjectField]
            deriving (Eq, Show)
 
 -- | Key-value pair.
@@ -133,17 +166,12 @@ data Value = ValueVariable Name
 -- A list of 'ObjectField's represents a GraphQL object type.
 data ObjectField = ObjectField Name Value deriving (Eq, Show)
 
--- * Variables
-
--- | Variable definition list.
-{-# DEPRECATED VariableDefinitions "Use [VariableDefinition] instead" #-}
-type VariableDefinitions = [VariableDefinition]
-
 -- | Variable definition.
 data VariableDefinition = VariableDefinition Name Type (Maybe Value)
                           deriving (Eq, Show)
 
--- * Input types
+-- | Type condition.
+type TypeCondition = Name
 
 -- | Type representation.
 data Type = TypeNamed   Name
@@ -151,17 +179,7 @@ data Type = TypeNamed   Name
           | 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
-
--- | Directive list.
-{-# DEPRECATED Directives "Use [Directive] instead" #-}
-type Directives = [Directive]
-
--- | Directive.
-data Directive = Directive Name [Argument] deriving (Eq, Show)

src/Language/GraphQL/AST/Core.hs

@@ -6,7 +6,6 @@ module Language.GraphQL.AST.Core
     , Field(..)
     , Fragment(..)
     , Name
-    , ObjectField(..)
     , Operation(..)
     , Selection(..)
     , TypeCondition
@@ -14,12 +13,12 @@ module Language.GraphQL.AST.Core
     ) 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
-type Name = Text
 
 -- | GraphQL document is a non-empty list of operations.
 type Document = NonEmpty Operation
@@ -28,87 +27,21 @@ type Document = NonEmpty Operation
 --
 -- Currently only queries and mutations are supported.
 data Operation
-    = Query (Maybe Text) (NonEmpty Selection)
+    = Query (Maybe Text) (Seq Selection)
-    | Mutation (Maybe Text) (NonEmpty Selection)
+    | Mutation (Maybe Text) (Seq Selection)
     deriving (Eq, Show)
 
--- | A single GraphQL field.
+-- | Single GraphQL field.
---
+data Field
--- Only required property of a field, is its name. Optionally it can also have
+    = Field (Maybe Alias) Name [Argument] (Seq Selection)
--- an alias, arguments or a list of subfields.
+    deriving (Eq, Show)
---
--- 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 "name". "id" and "name don't have any
--- arguments.
-data Field = Field (Maybe Alias) Name [Argument] [Selection] deriving (Eq, Show)
-
--- | Alternative field name.
---
--- @
--- {
---   smallPic: profilePic(size: 64)
---   bigPic: profilePic(size: 1024)
--- }
--- @
---
--- Here "smallPic" and "bigPic" are aliases for the same field, "profilePic",
--- used to distinquish between profile pictures with different arguments
--- (sizes).
-type Alias = Name
 
 -- | 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)
 
--- | Represents accordingly typed GraphQL values.
-data Value
-    = ValueInt Int32
-    -- GraphQL Float is double precision
-    | ValueFloat Double
-    | ValueString Text
-    | ValueBoolean Bool
-    | ValueNull
-    | ValueEnum Name
-    | ValueList [Value]
-    | ValueObject [ObjectField]
-    deriving (Eq, Show)
-
-instance IsString Value where
-  fromString = ValueString . fromString
-
--- | Key-value pair.
---
--- A list of 'ObjectField's represents a GraphQL object type.
-data ObjectField = ObjectField Name Value deriving (Eq, Show)
-
--- | Type condition.
-type TypeCondition = Name
-
 -- | Represents fragments and inline fragments.
 data Fragment
-    = Fragment TypeCondition (NonEmpty Selection)
+    = Fragment TypeCondition (Seq Selection)
     deriving (Eq, Show)
 
 -- | Single selection element.
@@ -116,3 +49,18 @@ data Selection
     = SelectionFragment Fragment
     | SelectionField Field
     deriving (Eq, Show)
+
+-- | Represents accordingly typed GraphQL values.
+data Value
+    = Int Int32
+    | Float Double -- ^ GraphQL Float is double precision
+    | String Text
+    | Boolean Bool
+    | Null
+    | Enum Name
+    | List [Value]
+    | Object (HashMap Name Value)
+    deriving (Eq, Show)
+
+instance IsString Value where
+    fromString = String . fromString

src/Language/GraphQL/AST/Encoder.hs

@@ -2,7 +2,7 @@
 {-# LANGUAGE ExplicitForAll #-}
 
 -- | This module defines a minifier and a printer for the @GraphQL@ language.
-module Language.GraphQL.Encoder
+module Language.GraphQL.AST.Encoder
     ( Formatter
     , definition
     , directive
@@ -21,12 +21,12 @@ import qualified Data.Text.Lazy as Text.Lazy
 import Data.Text.Lazy.Builder (toLazyText)
 import Data.Text.Lazy.Builder.Int (decimal)
 import Data.Text.Lazy.Builder.RealFloat (realFloat)
-import Language.GraphQL.AST
+import qualified Language.GraphQL.AST as Full
 
--- | Instructs the encoder whether a GraphQL should be minified or pretty
+-- | Instructs the encoder whether the GraphQL document should be minified or
---   printed.
+--   pretty printed.
---   
+--
---   Use 'pretty' and 'minified' to construct the formatter.
+--   Use 'pretty' or 'minified' to construct the formatter.
 data Formatter
     = Minified
     | Pretty Word
@@ -39,38 +39,38 @@ pretty = Pretty 0
 minified :: Formatter
 minified = Minified
 
--- | Converts a 'Document' into a string.
+-- | Converts a 'Full.Document' into a string.
-document :: Formatter -> Document -> Text
+document :: Formatter -> Full.Document -> Text
 document formatter defs
     | Pretty _ <- formatter = Text.Lazy.intercalate "\n" encodeDocument
     | Minified <-formatter = Text.Lazy.snoc (mconcat encodeDocument) '\n'
   where
     encodeDocument = NonEmpty.toList $ definition formatter <$> defs
 
--- | Converts a 'Definition' into a string.
+-- | Converts a 'Full.Definition' into a string.
-definition :: Formatter -> Definition -> Text
+definition :: Formatter -> Full.Definition -> Text
 definition formatter x
     | Pretty _ <- formatter = Text.Lazy.snoc (encodeDefinition x) '\n'
     | Minified <- formatter = encodeDefinition x
   where
-    encodeDefinition (DefinitionOperation operation)
+    encodeDefinition (Full.DefinitionOperation operation)
         = operationDefinition formatter operation
-    encodeDefinition (DefinitionFragment fragment)
+    encodeDefinition (Full.DefinitionFragment fragment)
         = fragmentDefinition formatter fragment
 
-operationDefinition :: Formatter -> OperationDefinition -> Text
+operationDefinition :: Formatter -> Full.OperationDefinition -> Text
-operationDefinition formatter (OperationSelectionSet sels)
+operationDefinition formatter (Full.OperationSelectionSet sels)
     = selectionSet formatter sels
-operationDefinition formatter (OperationDefinition Query name vars dirs sels)
+operationDefinition formatter (Full.OperationDefinition Full.Query name vars dirs sels)
     = "query " <> node formatter name vars dirs sels
-operationDefinition formatter (OperationDefinition Mutation name vars dirs sels)
+operationDefinition formatter (Full.OperationDefinition Full.Mutation name vars dirs sels)
     = "mutation " <> node formatter name vars dirs sels
 
 node :: Formatter
-    -> Maybe Name
+    -> Maybe Full.Name
-    -> [VariableDefinition]
+    -> [Full.VariableDefinition]
-    -> [Directive]
+    -> [Full.Directive]
-    -> SelectionSet
+    -> Full.SelectionSet
     -> Text
 node formatter name vars dirs sels
     = Text.Lazy.fromStrict (fold name)
@@ -79,39 +79,39 @@ node formatter name vars dirs sels
     <> eitherFormat formatter " " mempty
     <> selectionSet formatter sels
 
-variableDefinitions :: Formatter -> [VariableDefinition] -> Text
+variableDefinitions :: Formatter -> [Full.VariableDefinition] -> Text
 variableDefinitions formatter
     = parensCommas formatter $ variableDefinition formatter
 
-variableDefinition :: Formatter -> VariableDefinition -> Text
+variableDefinition :: Formatter -> Full.VariableDefinition -> Text
-variableDefinition formatter (VariableDefinition var ty dv)
+variableDefinition formatter (Full.VariableDefinition var ty dv)
     = variable var
     <> eitherFormat formatter ": " ":"
     <> type' ty
     <> maybe mempty (defaultValue formatter) dv
 
-defaultValue :: Formatter -> Value -> Text
+defaultValue :: Formatter -> Full.Value -> Text
 defaultValue formatter val
     = eitherFormat formatter " = " "="
     <> value formatter val
 
-variable :: Name -> Text
+variable :: Full.Name -> Text
 variable var = "$" <> Text.Lazy.fromStrict var
 
-selectionSet :: Formatter -> SelectionSet -> Text
+selectionSet :: Formatter -> Full.SelectionSet -> Text
 selectionSet formatter
     = bracesList formatter (selection formatter)
     . NonEmpty.toList
 
-selectionSetOpt :: Formatter -> SelectionSetOpt -> Text
+selectionSetOpt :: Formatter -> Full.SelectionSetOpt -> Text
 selectionSetOpt formatter = bracesList formatter $ selection formatter
 
-selection :: Formatter -> Selection -> Text
+selection :: Formatter -> Full.Selection -> Text
 selection formatter = Text.Lazy.append indent . f
   where
-    f (SelectionField x) = field incrementIndent x
+    f (Full.SelectionField x) = field incrementIndent x
-    f (SelectionInlineFragment x) = inlineFragment incrementIndent x
+    f (Full.SelectionInlineFragment x) = inlineFragment incrementIndent x
-    f (SelectionFragmentSpread x) = fragmentSpread incrementIndent x
+    f (Full.SelectionFragmentSpread x) = fragmentSpread incrementIndent x
     incrementIndent
         | Pretty n <- formatter = Pretty $ n + 1
         | otherwise = Minified
@@ -119,8 +119,8 @@ selection formatter = Text.Lazy.append indent . f
         | Pretty n <- formatter = Text.Lazy.replicate (fromIntegral $ n + 1) "  "
         | otherwise = mempty
 
-field :: Formatter -> Field -> Text
+field :: Formatter -> Full.Field -> Text
-field formatter (Field alias name args dirs selso)
+field formatter (Full.Field alias name args dirs selso)
     = optempty (`Text.Lazy.append` colon) (Text.Lazy.fromStrict $ fold alias)
     <> Text.Lazy.fromStrict name
     <> optempty (arguments formatter) args
@@ -132,31 +132,31 @@ field formatter (Field alias name args dirs selso)
         | null selso = mempty
         | otherwise = eitherFormat formatter " " mempty <> selectionSetOpt formatter selso
 
-arguments :: Formatter -> [Argument] -> Text
+arguments :: Formatter -> [Full.Argument] -> Text
 arguments formatter = parensCommas formatter $ argument formatter
 
-argument :: Formatter -> Argument -> Text
+argument :: Formatter -> Full.Argument -> Text
-argument formatter (Argument name v)
+argument formatter (Full.Argument name v)
     = Text.Lazy.fromStrict name
     <> eitherFormat formatter ": " ":"
     <> value formatter v
 
 -- * Fragments
 
-fragmentSpread :: Formatter -> FragmentSpread -> Text
+fragmentSpread :: Formatter -> Full.FragmentSpread -> Text
-fragmentSpread formatter (FragmentSpread name ds)
+fragmentSpread formatter (Full.FragmentSpread name ds)
     = "..." <> Text.Lazy.fromStrict name <> optempty (directives formatter) ds
 
-inlineFragment :: Formatter -> InlineFragment -> Text
+inlineFragment :: Formatter -> Full.InlineFragment -> Text
-inlineFragment formatter (InlineFragment tc dirs sels)
+inlineFragment formatter (Full.InlineFragment tc dirs sels)
     = "... on "
     <> Text.Lazy.fromStrict (fold tc)
     <> directives formatter dirs
     <> eitherFormat formatter " " mempty
     <> selectionSet formatter sels
 
-fragmentDefinition :: Formatter -> FragmentDefinition -> Text
+fragmentDefinition :: Formatter -> Full.FragmentDefinition -> Text
-fragmentDefinition formatter (FragmentDefinition name tc dirs sels)
+fragmentDefinition formatter (Full.FragmentDefinition name tc dirs sels)
     = "fragment " <> Text.Lazy.fromStrict name
     <> " on " <> Text.Lazy.fromStrict tc
     <> optempty (directives formatter) dirs
@@ -165,26 +165,26 @@ fragmentDefinition formatter (FragmentDefinition name tc dirs sels)
 
 -- * Miscellaneous
 
--- | Converts a 'Directive' into a string.
+-- | Converts a 'Full.Directive' into a string.
-directive :: Formatter -> Directive -> Text
+directive :: Formatter -> Full.Directive -> Text
-directive formatter (Directive name args)
+directive formatter (Full.Directive name args)
     = "@" <> Text.Lazy.fromStrict name <> optempty (arguments formatter) args
 
-directives :: Formatter -> [Directive] -> Text
+directives :: Formatter -> [Full.Directive] -> Text
 directives formatter@(Pretty _) = Text.Lazy.cons ' ' . spaces (directive formatter)
 directives Minified = spaces (directive Minified)
 
--- | Converts a 'Value' into a string.
+-- | Converts a 'Full.Value' into a string.
-value :: Formatter -> Value -> Text
+value :: Formatter -> Full.Value -> Text
-value _ (ValueVariable x) = variable x
+value _ (Full.Variable x) = variable x
-value _ (ValueInt x) = toLazyText $ decimal x
+value _ (Full.Int x) = toLazyText $ decimal x
-value _ (ValueFloat x) = toLazyText $ realFloat x
+value _ (Full.Float x) = toLazyText $ realFloat x
-value _ (ValueBoolean  x) = booleanValue x
+value _ (Full.Boolean  x) = booleanValue x
-value _ ValueNull = mempty
+value _ Full.Null = mempty
-value _ (ValueString x) = stringValue $ Text.Lazy.fromStrict x
+value _ (Full.String x) = stringValue $ Text.Lazy.fromStrict x
-value _ (ValueEnum x) = Text.Lazy.fromStrict x
+value _ (Full.Enum x) = Text.Lazy.fromStrict x
-value formatter (ValueList x) = listValue formatter x
+value formatter (Full.List x) = listValue formatter x
-value formatter (ValueObject x) = objectValue formatter x
+value formatter (Full.Object x) = objectValue formatter x
 
 booleanValue :: Bool -> Text
 booleanValue True  = "true"
@@ -196,10 +196,10 @@ stringValue
     . Text.Lazy.replace "\"" "\\\""
     . Text.Lazy.replace "\\" "\\\\"
 
-listValue :: Formatter -> [Value] -> Text
+listValue :: Formatter -> [Full.Value] -> Text
 listValue formatter = bracketsCommas formatter $ value formatter
 
-objectValue :: Formatter -> [ObjectField] -> Text
+objectValue :: Formatter -> [Full.ObjectField] -> Text
 objectValue formatter = intercalate $ objectField formatter
   where
     intercalate f
@@ -208,26 +208,26 @@ objectValue formatter = intercalate $ objectField formatter
         . fmap f
 
 
-objectField :: Formatter -> ObjectField -> Text
+objectField :: Formatter -> Full.ObjectField -> Text
-objectField formatter (ObjectField name v)
+objectField formatter (Full.ObjectField name v)
     = Text.Lazy.fromStrict name <> colon <> value formatter v
   where
     colon
       | Pretty _ <- formatter = ": "
       | Minified <- formatter = ":"
 
--- | Converts a 'Type' a type into a string.
+-- | Converts a 'Full.Type' a type into a string.
-type' :: Type -> Text
+type' :: Full.Type -> Text
-type' (TypeNamed   x) = Text.Lazy.fromStrict x
+type' (Full.TypeNamed   x) = Text.Lazy.fromStrict x
-type' (TypeList    x) = listType x
+type' (Full.TypeList    x) = listType x
-type' (TypeNonNull x) = nonNullType x
+type' (Full.TypeNonNull x) = nonNullType x
 
-listType :: Type -> Text
+listType :: Full.Type -> Text
 listType x = brackets (type' x)
 
-nonNullType :: NonNullType -> Text
+nonNullType :: Full.NonNullType -> Text
-nonNullType (NonNullTypeNamed x) = Text.Lazy.fromStrict x <> "!"
+nonNullType (Full.NonNullTypeNamed x) = Text.Lazy.fromStrict x <> "!"
-nonNullType (NonNullTypeList  x) = listType x <> "!"
+nonNullType (Full.NonNullTypeList  x) = listType x <> "!"
 
 -- * Internal
 

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
@@ -89,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

src/Language/GraphQL/AST/Parser.hs

@@ -2,7 +2,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 -- | @GraphQL@ document parser.
-module Language.GraphQL.Parser
+module Language.GraphQL.AST.Parser
     ( document
     ) where
 
@@ -11,7 +11,7 @@ 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
@@ -105,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   <$> blockString
+    <|> String   <$> blockString
-    <|> ValueString   <$> string
+    <|> String   <$> string
-    <|> ValueEnum     <$> try enumValue
+    <|> Enum     <$> try enumValue
-    <|> ValueList     <$> listValue
+    <|> List     <$> listValue
-    <|> ValueObject   <$> objectValue
+    <|> Object   <$> objectValue
     <?> "value error!"
   where
     booleanValue :: Parser Bool
@@ -152,9 +152,9 @@ defaultValue = equals *> value
 -- * Input Types
 
 type_ :: Parser Type
-type_ = try (TypeNamed <$> name <* but "!")
+type_ = try (TypeNonNull <$> nonNullType)
-    <|> TypeList       <$> brackets type_
+    <|> TypeList <$> brackets type_
-    <|> TypeNonNull    <$> nonNullType
+    <|> TypeNamed <$> name
     <?> "type_ error!"
 
 nonNullType :: Parser NonNullType

src/Language/GraphQL/AST/Transform.hs

@@ -1,4 +1,5 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE ExplicitForAll #-}
 
 -- | After the document is parsed, before getting executed the AST is
 --   transformed into a similar, simpler AST. This module is responsible for
@@ -7,130 +8,143 @@ module Language.GraphQL.AST.Transform
     ( document
     ) where
 
-import Control.Applicative (empty)
+import Control.Arrow (first)
-import Data.Bifunctor (first)
+import Control.Monad (foldM, unless)
-import Data.Either (partitionEithers)
+import Control.Monad.Trans.Class (lift)
-import Data.Foldable (fold, foldMap)
+import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)
-import Data.List.NonEmpty (NonEmpty)
+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.Monoid (Alt(Alt,getAlt), (<>))
+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
 
--- | Replaces a fragment name by a list of 'Core.Field'. If the name doesn't
+-- | Associates a fragment name with a list of 'Core.Field's.
---   match an empty list is returned.
+data Replacement = Replacement
-type Fragmenter = Core.Name -> [Core.Field]
+    { fragments :: HashMap Core.Name (Seq Core.Selection)
+    , fragmentDefinitions :: HashMap Full.Name Full.FragmentDefinition
+    }
+
+type TransformT a = StateT Replacement (ReaderT Schema.Subs Maybe) a
 
 -- | Rewrites the original syntax tree into an intermediate representation used
 -- for query execution.
 document :: Schema.Subs -> Full.Document -> Maybe Core.Document
-document subs doc = operations subs fr ops
+document subs document' =
+    flip runReaderT subs
+        $ evalStateT (collectFragments >> operations operationDefinitions)
+        $ Replacement HashMap.empty fragmentTable
   where
-    (fr, ops) = first foldFrags
+    (fragmentTable, operationDefinitions) = foldr defragment mempty document'
-              . partitionEithers
+    defragment (Full.DefinitionOperation definition) acc =
-              . NonEmpty.toList
+        (definition :) <$> acc
-              $ defrag subs
+    defragment (Full.DefinitionFragment definition) acc =
-            <$> doc
+        let (Full.FragmentDefinition name _ _ _) = definition
-
+         in first (HashMap.insert name definition) acc
-    foldFrags :: [Fragmenter] -> Fragmenter
-    foldFrags fs n = getAlt $ foldMap (Alt . ($ n)) fs
 
 -- * Operation
 
 -- TODO: Replace Maybe by MonadThrow CustomError
-operations
+operations :: [Full.OperationDefinition] -> TransformT Core.Document
-  :: Schema.Subs
+operations operations' = do
-  -> Fragmenter
+    coreOperations <- traverse operation operations'
-  -> [Full.OperationDefinition]
+    lift . lift $ NonEmpty.nonEmpty coreOperations
-  -> Maybe Core.Document
-operations subs fr = NonEmpty.nonEmpty . fmap (operation subs fr)
 
-operation
+operation :: Full.OperationDefinition -> TransformT Core.Operation
-  :: Schema.Subs
+operation (Full.OperationSelectionSet sels) =
-  -> Fragmenter
+    operation $ Full.OperationDefinition Full.Query mempty mempty mempty sels
-  -> Full.OperationDefinition
-  -> 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 Full.Query name _vars _dirs sels) =
+operation (Full.OperationDefinition Full.Query name _vars _dirs sels) =
-    Core.Query name $ appendSelection subs fr sels
+    Core.Query name <$> appendSelection sels
-operation subs fr (Full.OperationDefinition Full.Mutation name _vars _dirs sels) =
+operation (Full.OperationDefinition Full.Mutation name _vars _dirs sels) =
-    Core.Mutation name $ appendSelection subs fr sels
+    Core.Mutation name <$> appendSelection sels
 
-selection
+selection ::
-  :: Schema.Subs
+    Full.Selection ->
-  -> Fragmenter
+    TransformT (Either (Seq Core.Selection) Core.Selection)
-  -> Full.Selection
+selection (Full.SelectionField fld) = Right . Core.SelectionField <$> field fld
-  -> Either [Core.Selection] Core.Selection
+selection (Full.SelectionFragmentSpread (Full.FragmentSpread name _)) = do
-selection subs fr (Full.SelectionField fld)
+    fragments' <- gets fragments
-    = Right $ Core.SelectionField $ field subs fr fld
+    Left <$> maybe lookupDefinition liftJust (HashMap.lookup name fragments')
-selection _ fr (Full.SelectionFragmentSpread (Full.FragmentSpread name _))
+  where
-    = Left $ Core.SelectionField <$> fr name
+    lookupDefinition :: TransformT (Seq Core.Selection)
-selection subs fr  (Full.SelectionInlineFragment fragment)
+    lookupDefinition = do
+        fragmentDefinitions' <- gets fragmentDefinitions
+        found <- lift . lift $ HashMap.lookup name fragmentDefinitions'
+        fragmentDefinition found
+selection (Full.SelectionInlineFragment fragment)
     | (Full.InlineFragment (Just typeCondition) _ selectionSet) <- fragment
         = Right
-        $ Core.SelectionFragment
+        . Core.SelectionFragment
-        $ Core.Fragment typeCondition
+        . Core.Fragment typeCondition
-        $ appendSelection subs fr selectionSet
+        <$> appendSelection selectionSet
     | (Full.InlineFragment Nothing _ selectionSet) <- fragment
-        = Left $ NonEmpty.toList $ appendSelection subs fr selectionSet
+        = Left <$> appendSelection selectionSet
 
 -- * Fragment replacement
 
--- | Extract Fragments into a single Fragmenter function and a Operation
+-- | Extract fragment definitions into a single 'HashMap'.
---   Definition.
+collectFragments :: TransformT ()
-defrag
+collectFragments = do
-  :: Schema.Subs
+    fragDefs <- gets fragmentDefinitions
-  -> Full.Definition
+    let nextValue = head $ HashMap.elems fragDefs
-  -> Either Fragmenter Full.OperationDefinition
+    unless (HashMap.null fragDefs) $ do
-defrag _    (Full.DefinitionOperation op) =
+        _ <- fragmentDefinition nextValue
-  Right op
+        collectFragments
-defrag subs (Full.DefinitionFragment fragDef) =
-  Left $ fragmentDefinition subs fragDef
 
-fragmentDefinition :: Schema.Subs -> Full.FragmentDefinition -> Fragmenter
+fragmentDefinition ::
-fragmentDefinition subs (Full.FragmentDefinition name _tc _dirs sels) name'
+    Full.FragmentDefinition ->
-    | name == name' = selection' <$> do
+    TransformT (Seq Core.Selection)
-        selections <- NonEmpty.toList $ selection subs mempty <$> sels
+fragmentDefinition (Full.FragmentDefinition name _tc _dirs selections) = do
-        either id pure selections
+    modify deleteFragmentDefinition
-    | otherwise = empty
+    newValue <- appendSelection selections
+    modify $ insertFragment newValue
+    liftJust newValue
   where
-    selection' (Core.SelectionField field') = field'
+    deleteFragmentDefinition (Replacement fragments' fragmentDefinitions') =
-    selection' _ = error "Fragments within fragments are not supported yet"
+        Replacement fragments' $ HashMap.delete name fragmentDefinitions'
+    insertFragment newValue (Replacement fragments' fragmentDefinitions') =
+        let newFragments = HashMap.insert name newValue fragments'
+         in Replacement newFragments fragmentDefinitions'
 
-field :: Schema.Subs -> Fragmenter -> Full.Field -> Core.Field
+field :: Full.Field -> TransformT Core.Field
-field subs fr (Full.Field a n args _dirs sels) =
+field (Full.Field a n args _dirs sels) = do
-    Core.Field a n (fold $ argument subs `traverse` args) (foldr go empty sels)
+    arguments <- traverse argument args
-  where
+    selection' <- appendSelection sels
-    go :: Full.Selection -> [Core.Selection] -> [Core.Selection]
+    return $ Core.Field a n arguments selection'
-    go (Full.SelectionFragmentSpread (Full.FragmentSpread name _dirs)) = ((Core.SelectionField <$> fr name) <>)
-    go sel = (either id pure (selection subs fr sel) <>)
 
-argument :: Schema.Subs -> Full.Argument -> Maybe Core.Argument
+argument :: Full.Argument -> TransformT Core.Argument
-argument subs (Full.Argument n v) = Core.Argument n <$> value subs v
+argument (Full.Argument n v) = Core.Argument n <$> value v
 
-value :: Schema.Subs -> Full.Value -> Maybe Core.Value
+value :: Full.Value -> TransformT Core.Value
-value subs (Full.ValueVariable n) = subs n
+value (Full.Variable n) = do
-value _    (Full.ValueInt      i) = pure $ Core.ValueInt i
+    substitute' <- lift ask
-value _    (Full.ValueFloat    f) = pure $ Core.ValueFloat f
+    lift . lift $ substitute' n
-value _    (Full.ValueString   x) = pure $ Core.ValueString x
+value (Full.Int i) = pure $ Core.Int i
-value _    (Full.ValueBoolean  b) = pure $ Core.ValueBoolean b
+value (Full.Float f) = pure $ Core.Float f
-value _     Full.ValueNull        = pure   Core.ValueNull
+value (Full.String x) = pure $ Core.String x
-value _    (Full.ValueEnum     e) = pure $ Core.ValueEnum e
+value (Full.Boolean b) = pure $ Core.Boolean b
-value subs (Full.ValueList     l) =
+value Full.Null = pure   Core.Null
-  Core.ValueList   <$> traverse (value subs) l
+value (Full.Enum e) = pure $ Core.Enum e
-value subs (Full.ValueObject   o) =
+value (Full.List l) =
-  Core.ValueObject <$> traverse (objectField subs) o
+    Core.List <$> traverse value l
+value (Full.Object o) =
+    Core.Object . HashMap.fromList <$> traverse objectField o
 
-objectField :: Schema.Subs -> Full.ObjectField -> Maybe Core.ObjectField
+objectField :: Full.ObjectField -> TransformT (Core.Name, Core.Value)
-objectField subs (Full.ObjectField n v) = Core.ObjectField n <$> value subs v
+objectField (Full.ObjectField n v) = (n,) <$> value v
 
 appendSelection ::
-    Schema.Subs ->
+    Traversable t =>
-    Fragmenter ->
+    t Full.Selection ->
-    NonEmpty Full.Selection ->
+    TransformT (Seq Core.Selection)
-    NonEmpty Core.Selection
+appendSelection = foldM go mempty
-appendSelection subs fr = NonEmpty.fromList
+  where
-    . foldr (either (++) (:) . selection subs fr) []
+    go acc sel = append acc <$> selection sel
+    append acc (Left list) = list >< acc
+    append acc (Right one) = one <| acc
+
+liftJust :: forall a. a -> TransformT a
+liftJust = lift . lift . Just

src/Language/GraphQL/Execute.hs

@@ -8,6 +8,7 @@ module Language.GraphQL.Execute
 
 import Control.Monad.IO.Class (MonadIO)
 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)
@@ -71,6 +72,6 @@ operation :: MonadIO m
     -> AST.Core.Operation
     -> m Aeson.Value
 operation schema (AST.Core.Query _ flds)
-    = runCollectErrs (Schema.resolve (NE.toList schema) (NE.toList flds))
+    = runCollectErrs (Schema.resolve (toList schema) flds)
 operation schema (AST.Core.Mutation _ flds)
-    = runCollectErrs (Schema.resolve (NE.toList schema) (NE.toList flds))
+    = runCollectErrs (Schema.resolve (toList schema) flds)

src/Language/GraphQL/Schema.hs

@@ -4,17 +4,12 @@
 -- 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,23 +23,19 @@ module Language.GraphQL.Schema
 import Control.Monad.IO.Class (MonadIO(..))
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.Except (runExceptT)
+import Control.Monad.Trans.Reader (runReaderT)
 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
-
-{-# DEPRECATED Schema "Use NonEmpty (Resolver m) instead" #-}
--- | A GraphQL schema.
---   @m@ is usually expected to be an instance of 'MonadIO'.
-type Schema m = NonEmpty (Resolver m)
 
 -- | Resolves a 'Field' into an @Aeson.@'Data.Aeson.Types.Object' with error
 --   information (if an error has occurred). @m@ is usually expected to be an
@@ -69,7 +60,7 @@ objectA name f = Resolver name $ resolveFieldValue f resolveRight
 
 -- | Like 'object' but also taking 'Argument's and can be null or a list of objects.
 wrappedObjectA :: MonadIO m
-    => Name -> ([Argument] -> 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
@@ -77,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.
@@ -91,54 +82,31 @@ 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 -> ([Argument] -> 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
 
-{-# DEPRECATED enum "Use scalar instead" #-}
-enum :: MonadIO m => Name -> ActionT m [Text] -> Resolver m
-enum name = enumA name . const
-
-{-# DEPRECATED enumA "Use scalarA instead" #-}
-enumA :: MonadIO m => Name -> ([Argument] -> ActionT m [Text]) -> Resolver m
-enumA name f = Resolver name $ resolveFieldValue f resolveRight
-  where
-    resolveRight fld resolver = withField (return resolver) fld
-
-{-# DEPRECATED wrappedEnumA "Use wrappedScalarA instead" #-}
-wrappedEnumA :: MonadIO m
-    => Name -> ([Argument] -> 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
-
-{-# DEPRECATED wrappedEnum "Use wrappedScalar instead" #-}
-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
@@ -153,7 +121,7 @@ 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] -> [Selection] -> CollectErrsT m Aeson.Value
+    => [Resolver m] -> Seq Selection -> CollectErrsT m Aeson.Value
 resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers
   where
     resolveTypeName (Resolver "__typename" f) = do

src/Language/GraphQL/Trans.hs

@@ -1,6 +1,7 @@
 -- | Monad transformer stack used by the @GraphQL@ resolvers.
 module Language.GraphQL.Trans
     ( ActionT(..)
+    , Context(Context)
     ) where
 
 import Control.Applicative (Alternative(..))
@@ -8,10 +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)
 
--- | Monad transformer stack used by the resolvers to provide error handling.
+-- | Resolution context holds resolver arguments.
-newtype ActionT m a = ActionT { runActionT :: ExceptT Text m a }
+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
@@ -25,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

stack.yaml

@@ -1,4 +1,4 @@
-resolver: lts-14.11
+resolver: lts-14.16
 
 packages:
 - .

tests/Language/GraphQL/AST/EncoderSpec.hs

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

tests/Language/GraphQL/AST/LexerSpec.hs

@@ -1,12 +1,12 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
-module Language.GraphQL.LexerSpec
+module Language.GraphQL.AST.LexerSpec
     ( spec
     ) where
 
 import Data.Text (Text)
 import Data.Void (Void)
-import Language.GraphQL.Lexer
+import Language.GraphQL.AST.Lexer
 import Test.Hspec (Spec, context, describe, it)
 import Test.Hspec.Megaparsec (shouldParse, shouldSucceedOn)
 import Text.Megaparsec (ParseErrorBundle, parse)
@@ -71,8 +71,8 @@ spec = describe "Lexer" $ do
             parse float "" "-1.123e4567" `shouldParse` (-1.123e4567)
 
         it "lexes punctuation" $ do
-            parse bang "" "!" `shouldParse` '!'
+            parse bang "" "!" `shouldParse` "!"
-            parse dollar "" "$" `shouldParse` '$'
+            parse dollar "" "$" `shouldParse` "$"
             runBetween parens `shouldSucceedOn` "()"
             parse spread "" "..." `shouldParse` "..."
             parse colon "" ":" `shouldParse` ":"

tests/Language/GraphQL/AST/ParserSpec.hs

@@ -1,10 +1,10 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
-module Language.GraphQL.ParserSpec
+module Language.GraphQL.AST.ParserSpec
     ( spec
     ) where
 
-import Language.GraphQL.Parser (document)
+import Language.GraphQL.AST.Parser
 import Test.Hspec (Spec, describe, it)
 import Test.Hspec.Megaparsec (shouldSucceedOn)
 import Text.Megaparsec (parse)
@@ -24,3 +24,9 @@ spec = describe "Parser" $ do
         parse document "" `shouldSucceedOn` [r|{
               hello(text: "Argument")
             }|]
+
+    it "accepts two required arguments" $
+        parse document "" `shouldSucceedOn` [r|
+            mutation auth($username: String!, $password: String!){
+                test
+            }|]

tests/Language/GraphQL/EncoderSpec.hs

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

tests/Test/FragmentSpec.hs

@@ -10,7 +10,13 @@ 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, shouldNotSatisfy)
+import Test.Hspec ( Spec
+                  , describe
+                  , it
+                  , shouldBe
+                  , shouldSatisfy
+                  , shouldNotSatisfy
+                  )
 import Text.RawString.QQ (r)
 
 size :: Schema.Resolver IO
@@ -37,6 +43,10 @@ inlineQuery = [r|{
   }
 }|]
 
+hasErrors :: Value -> Bool
+hasErrors (Object object') = HashMap.member "errors" object'
+hasErrors _ = True
+
 spec :: Spec
 spec = describe "Inline fragment executor" $ do
     it "chooses the first selection if the type matches" $ do
@@ -92,6 +102,63 @@ spec = describe "Inline fragment executor" $ do
 
         actual <- graphql (size :| []) query
         actual `shouldNotSatisfy` hasErrors
-      where
+
-        hasErrors (Object object') = HashMap.member "errors" object'
+    it "evaluates nested fragments" $ do
-        hasErrors _ = True
+        let query = [r|
+          {
+            ...circumferenceFragment
+          }
+
+          fragment circumferenceFragment on Hat {
+            circumference
+          }
+
+          fragment hatFragment on Hat {
+            ...circumferenceFragment
+          }
+        |]
+
+        actual <- graphql (circumference :| []) query
+        let expected = object
+                [ "data" .= object
+                    [ "circumference" .= (60 :: Int)
+                    ]
+                ]
+         in actual `shouldBe` expected
+
+    it "evaluates fragments defined in any order" $ do
+        let query = [r|
+          {
+            ...circumferenceFragment
+          }
+
+          fragment circumferenceFragment on Hat {
+            ...hatFragment
+          }
+
+          fragment hatFragment on Hat {
+            circumference
+          }
+        |]
+
+        actual <- graphql (circumference :| []) query
+        let expected = object
+                [ "data" .= object
+                    [ "circumference" .= (60 :: Int)
+                    ]
+                ]
+         in actual `shouldBe` expected
+
+    it "rejects recursive" $ do
+        let query = [r|
+          {
+            ...circumferenceFragment
+          }
+
+          fragment circumferenceFragment on Hat {
+            ...circumferenceFragment
+          }
+        |]
+
+        actual <- graphql (circumference :| []) query
+        actual `shouldSatisfy` hasErrors

tests/Test/KitchenSinkSpec.hs

@@ -7,8 +7,8 @@ module Test.KitchenSinkSpec
 import qualified Data.Text.IO as Text.IO
 import qualified Data.Text.Lazy.IO as Text.Lazy.IO
 import qualified Data.Text.Lazy as Lazy (Text)
-import qualified Language.GraphQL.Encoder as Encoder
+import qualified Language.GraphQL.AST.Encoder as Encoder
-import qualified Language.GraphQL.Parser as Parser
+import qualified Language.GraphQL.AST.Parser as Parser
 import Paths_graphql (getDataFileName)
 import Test.Hspec (Spec, describe, it)
 import Test.Hspec.Megaparsec (parseSatisfies)

tests/Test/StarWars/Data.hs

@@ -26,7 +26,7 @@ import Control.Monad.Trans.Except (throwE)
 import Data.Maybe (catMaybes)
 import Data.Text (Text)
 import Language.GraphQL.Trans
-import Language.GraphQL.Type
+import qualified Language.GraphQL.Type as Type
 
 -- * Data
 -- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsData.js
@@ -191,8 +191,8 @@ getDroid' _      = empty
 getFriends :: Character -> [Character]
 getFriends char = catMaybes $ liftA2 (<|>) getDroid getHuman <$> friends char
 
-getEpisode :: Int -> Maybe (Wrapping Text)
+getEpisode :: Int -> Maybe (Type.Wrapping Text)
-getEpisode 4 = pure $ Named "NEWHOPE"
+getEpisode 4 = pure $ Type.Named "NEWHOPE"
-getEpisode 5 = pure $ Named "EMPIRE"
+getEpisode 5 = pure $ Type.Named "EMPIRE"
-getEpisode 6 = pure $ Named "JEDI"
+getEpisode 6 = pure $ Type.Named "JEDI"
 getEpisode _ = empty

tests/Test/StarWars/Schema.hs

@@ -15,7 +15,7 @@ import Data.List.NonEmpty (NonEmpty(..))
 import Data.Maybe (catMaybes)
 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
 
 -- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js
@@ -26,23 +26,23 @@ schema = hero :| [human, droid]
 hero :: MonadIO m => Schema.Resolver m
 hero = Schema.objectA "hero" $ \case
   [] -> character artoo
-  [Schema.Argument "episode" (Schema.ValueEnum "NEWHOPE")] -> character $ getHero 4
+  [Schema.Argument "episode" (Schema.Enum "NEWHOPE")] -> character $ getHero 4
-  [Schema.Argument "episode" (Schema.ValueEnum "EMPIRE" )] -> character $ getHero 5
+  [Schema.Argument "episode" (Schema.Enum "EMPIRE" )] -> character $ getHero 5
-  [Schema.Argument "episode" (Schema.ValueEnum "JEDI"   )] -> character $ getHero 6
+  [Schema.Argument "episode" (Schema.Enum "JEDI"   )] -> character $ getHero 6
   _ -> ActionT $ throwE "Invalid arguments."
 
 human :: MonadIO m => Schema.Resolver m
 human = Schema.wrappedObjectA "human" $ \case
-  [Schema.Argument "id" (Schema.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 => Schema.Resolver m
 droid = Schema.objectA "droid" $ \case
-   [Schema.Argument "id" (Schema.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 [Schema.Resolver m]
@@ -50,8 +50,8 @@ 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.wrappedScalar "appearsIn" $ return . List
+    , Schema.wrappedScalar "appearsIn" $ return . Type.List
         $ catMaybes (getEpisode <$> appearsIn char)
     , Schema.scalar "secretBackstory" $ secretBackstory char
     , Schema.scalar "homePlanet" $ return $ either mempty homePlanet char