From 5390c4ca1e7e6bcf36dbe5e773c1355dd4b65939 Mon Sep 17 00:00:00 2001
From: Danny Navarro <j@dannynavarro.net>
Date: Sat, 28 Jan 2017 14:15:14 -0300
Subject: [PATCH 01/11] Split AST in 2

One AST is meant to be a target parser and tries to adhere as much as possible
to the spec. The other is a simplified version of that AST meant for execution.

Also newtypes have been replaced by type synonyms and NonEmpty lists are being
used where it makes sense.
---
 Data/GraphQL/AST.hs           | 143 +++++++++++-----------
 Data/GraphQL/AST/Core.hs      |  10 +-
 Data/GraphQL/Encoder.hs       |  73 +++++------
 Data/GraphQL/Execute.hs       |  39 +++---
 Data/GraphQL/Parser.hs        | 223 +++++++++++++++++-----------------
 Data/GraphQL/Schema.hs        |  59 ++++-----
 graphql.cabal                 |   5 +-
 tests/Test/StarWars/Schema.hs |  10 +-
 tests/tasty.hs                |   6 +-
 9 files changed, 281 insertions(+), 287 deletions(-)

diff --git a/Data/GraphQL/AST.hs b/Data/GraphQL/AST.hs
index 58ae20d..8a7bbea 100644
--- a/Data/GraphQL/AST.hs
+++ b/Data/GraphQL/AST.hs
@@ -1,11 +1,13 @@
 -- | This module defines an abstract syntax tree for the @GraphQL@ language based on
 --   <https://facebook.github.io/graphql/ Facebook's GraphQL Specification>.
+--
+-- Target AST for Parser.
 
 module Data.GraphQL.AST where
 
 import Data.Int (Int32)
-import Data.String (IsString(fromString))
-import Data.Text (Text, pack)
+import Data.List.NonEmpty (NonEmpty)
+import Data.Text (Text)
 
 -- * Name
 
@@ -13,116 +15,117 @@ type Name = Text
 
 -- * Document
 
-newtype Document = Document [Definition] deriving (Eq,Show)
+type Document = NonEmpty Definition
+
+-- * Operations
 
 data Definition = DefinitionOperation OperationDefinition
                 | DefinitionFragment  FragmentDefinition
                   deriving (Eq,Show)
 
-data OperationDefinition = Query    Node
-                         | Mutation Node
+data OperationDefinition = OperationSelectionSet SelectionSet
+                         | OperationDefinition   OperationType
+                                                 Name
+                                                 VariableDefinitions
+                                                 Directives
+                                                 SelectionSet
                            deriving (Eq,Show)
 
-data Node = Node Name [VariableDefinition] [Directive] SelectionSet
-            deriving (Eq,Show)
+data OperationType = Query | Mutation deriving (Eq,Show)
 
-data VariableDefinition = VariableDefinition Variable Type (Maybe DefaultValue)
-                          deriving (Eq,Show)
+-- * SelectionSet
 
-newtype Variable = Variable Name deriving (Eq,Show)
+type SelectionSet = NonEmpty Selection
 
-instance IsString Variable where
-    fromString = Variable . pack
+type SelectionSetOpt = [Selection]
 
-type SelectionSet = [Selection]
-
-data Selection = SelectionField Field
+data Selection = SelectionField          Field
                | SelectionFragmentSpread FragmentSpread
                | SelectionInlineFragment InlineFragment
                  deriving (Eq,Show)
 
--- | A 'SelectionSet' is primarily composed of 'Field's. A 'Field' describes one
---   discrete piece of information available to request within a 'SelectionSet'.
---
---   Some 'Field's describe complex data or relationships to other data. In
---   order to further explore this data, a 'Field' may itself contain a
---   'SelectionSet', allowing for deeply nested requests. All @GraphQL@ operations
---   must specify their 'Selection's down to 'Field's which return scalar values to
---   ensure an unambiguously shaped response.
---
---   <https://facebook.github.io/graphql/#sec-Language.Query-Document.Fields Field Specification>
-data Field = Field Alias Name [Argument] [Directive] SelectionSet
+-- * Field
+
+data Field = Field (Maybe Alias) Name Arguments Directives SelectionSetOpt
              deriving (Eq,Show)
 
 type Alias = Name
 
--- | 'Field's are conceptually functions which return values, and occasionally accept
---   'Argument's which alter their behavior. These 'Argument's often map directly to
---   function arguments within a @GraphQL@ server’s implementation.
---
---   <https://facebook.github.io/graphql/#sec-Language.Query-Document.Arguments Argument Specification>
+-- * Arguments
+
+type Arguments = [Argument]
+
 data Argument = Argument Name Value deriving (Eq,Show)
 
 -- * Fragments
 
-data FragmentSpread = FragmentSpread Name [Directive]
+data FragmentSpread = FragmentSpread Name Directives deriving (Eq,Show)
+
+data InlineFragment = InlineFragment (Maybe TypeCondition) Directives SelectionSet
                       deriving (Eq,Show)
 
-data InlineFragment =
-    InlineFragment TypeCondition [Directive] SelectionSet
-    deriving (Eq,Show)
-
 data FragmentDefinition =
-    FragmentDefinition Name TypeCondition [Directive] SelectionSet
-    deriving (Eq,Show)
+  FragmentDefinition FragmentName TypeCondition Directives SelectionSet
+  deriving (Eq,Show)
 
-type TypeCondition = NamedType
+type FragmentName = Name
 
--- * Values
+type TypeCondition = Name
+
+-- Input Values
 
--- | 'Field' and 'Directive' 'Arguments' accept input values of various literal
---   primitives; input values can be scalars, enumeration values, lists, or input
---   objects.
---
---   If not defined as constant (for example, in 'DefaultValue'), input values
---   can be specified as a 'Variable'. List and inputs objects may also contain
---   'Variable's (unless defined to be constant).
---
---   <https://facebook.github.io/graphql/#sec-Input-Values Input Value Specification>
 data Value = ValueVariable Variable
-           | ValueInt Int32
-           -- GraphQL Float is double precison
-           | ValueFloat Double
-           | ValueBoolean Bool
-           | ValueString Text
-           | ValueEnum Name
+           | ValueInt IntValue
+           | ValueFloat FloatValue
+           | ValueString StringValue
+           | ValueBoolean BooleanValue
+           | ValueNull
+           | ValueEnum EnumValue
            | ValueList ListValue
            | ValueObject ObjectValue
              deriving (Eq,Show)
 
-newtype ListValue = ListValue [Value] deriving (Eq,Show)
+type IntValue = Int32
 
-newtype ObjectValue = ObjectValue [ObjectField] deriving (Eq,Show)
+-- GraphQL Float is double precison
+type FloatValue = Double
+
+type StringValue = Text
+
+type BooleanValue = Bool
+
+type EnumValue = Name
+
+type ListValue = [Value]
+
+type ObjectValue = [ObjectField]
 
 data ObjectField = ObjectField Name Value deriving (Eq,Show)
 
+-- * Variables
+
+type VariableDefinitions = [VariableDefinition]
+
+data VariableDefinition = VariableDefinition Variable Type (Maybe DefaultValue)
+                          deriving (Eq,Show)
+
+type Variable = Name
+
 type DefaultValue = Value
 
--- * Directives
+-- * Input Types
 
-data Directive = Directive Name [Argument] deriving (Eq,Show)
-
--- * Type Reference
-
-data Type = TypeNamed NamedType
-          | TypeList ListType
+data Type = TypeNamed   Name
+          | TypeList    Type
           | TypeNonNull NonNullType
             deriving (Eq,Show)
 
-newtype NamedType = NamedType Name deriving (Eq,Show)
-
-newtype ListType = ListType Type deriving (Eq,Show)
-
-data NonNullType = NonNullTypeNamed NamedType
-                 | NonNullTypeList  ListType
+data NonNullType = NonNullTypeNamed Name
+                 | NonNullTypeList  Type
                    deriving (Eq,Show)
+
+-- * Directives
+
+type Directives = [Directive]
+
+data Directive = Directive Name [Argument] deriving (Eq,Show)
diff --git a/Data/GraphQL/AST/Core.hs b/Data/GraphQL/AST/Core.hs
index 2ca3928..b5698c6 100644
--- a/Data/GraphQL/AST/Core.hs
+++ b/Data/GraphQL/AST/Core.hs
@@ -6,15 +6,17 @@ import Data.List.NonEmpty (NonEmpty)
 
 import Data.Text (Text)
 
-newtype Name = Name Text deriving (Eq,Show)
+type Name = Text
 
-newtype Document = Document (NonEmpty Operation) deriving (Eq,Show)
+type Document = NonEmpty Operation
 
-data Operation = Query (NonEmpty Field)
+data Operation = Query    (NonEmpty Field)
                | Mutation (NonEmpty Field)
                  deriving (Eq,Show)
 
-data Field = Field Name [Argument] [Field] deriving (Eq,Show)
+data Field = Field (Maybe Alias) Name [Argument] [Field] deriving (Eq,Show)
+
+type Alias = Name
 
 data Argument = Argument Name Value deriving (Eq,Show)
 
diff --git a/Data/GraphQL/Encoder.hs b/Data/GraphQL/Encoder.hs
index 0cf878e..083a31d 100644
--- a/Data/GraphQL/Encoder.hs
+++ b/Data/GraphQL/Encoder.hs
@@ -2,7 +2,9 @@
 -- | This module defines a printer for the @GraphQL@ language.
 module Data.GraphQL.Encoder where
 
+import Data.Foldable (fold)
 import Data.Monoid ((<>))
+import qualified Data.List.NonEmpty as NonEmpty (toList)
 
 import Data.Text (Text, cons, intercalate, pack, snoc)
 
@@ -10,24 +12,26 @@ import Data.GraphQL.AST
 
 -- * Document
 
--- TODO: Use query shorthand
 document :: Document -> Text
-document (Document defs) = (`snoc` '\n') . mconcat $ definition <$> defs
+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 (Query    n) = "query "    <> node n
-operationDefinition (Mutation n) = "mutation " <> node n
+operationDefinition (OperationSelectionSet sels) = selectionSet sels
+operationDefinition (OperationDefinition Query    name vars dirs sels) =
+  "query " <> node name vars dirs sels
+operationDefinition (OperationDefinition Mutation name vars dirs sels) =
+  "mutation " <> node name vars dirs sels
 
-node :: Node -> Text
-node (Node name vds ds ss) =
+node :: Name -> VariableDefinitions -> Directives -> SelectionSet -> Text
+node name vars dirs sels =
        name
-    <> optempty variableDefinitions vds
-    <> optempty directives ds
-    <> selectionSet ss
+    <> optempty variableDefinitions vars
+    <> optempty directives dirs
+    <> selectionSet sels
 
 variableDefinitions :: [VariableDefinition] -> Text
 variableDefinitions = parensCommas variableDefinition
@@ -40,10 +44,13 @@ defaultValue :: DefaultValue -> Text
 defaultValue val = "=" <> value val
 
 variable :: Variable -> Text
-variable (Variable name) = "$" <> name
+variable var = "$" <> var
 
 selectionSet :: SelectionSet -> Text
-selectionSet = bracesCommas selection
+selectionSet = bracesCommas selection . NonEmpty.toList
+
+selectionSetOpt :: SelectionSetOpt -> Text
+selectionSetOpt = bracesCommas selection
 
 selection :: Selection -> Text
 selection (SelectionField          x) = field x
@@ -51,12 +58,12 @@ selection (SelectionInlineFragment x) = inlineFragment x
 selection (SelectionFragmentSpread x) = fragmentSpread x
 
 field :: Field -> Text
-field (Field alias name args ds ss) =
-       optempty (`snoc` ':') alias
+field (Field alias name args dirs selso) =
+       optempty (`snoc` ':') (fold alias)
     <> name
     <> optempty arguments args
-    <> optempty directives ds
-    <> optempty selectionSet ss
+    <> optempty directives dirs
+    <> optempty selectionSetOpt selso
 
 arguments :: [Argument] -> Text
 arguments = parensCommas argument
@@ -71,26 +78,27 @@ fragmentSpread (FragmentSpread name ds) =
     "..." <> name <> optempty directives ds
 
 inlineFragment :: InlineFragment -> Text
-inlineFragment (InlineFragment (NamedType tc) ds ss) =
-    "... on " <> tc
-              <> optempty directives ds
-              <> optempty selectionSet ss
+inlineFragment (InlineFragment tc dirs sels) =
+    "... on " <> fold tc
+              <> directives dirs
+              <> selectionSet sels
 
 fragmentDefinition :: FragmentDefinition -> Text
-fragmentDefinition (FragmentDefinition name (NamedType tc) ds ss) =
+fragmentDefinition (FragmentDefinition name tc dirs sels) =
     "fragment " <> name <> " on " <> tc
-                <> optempty directives ds
-                <> selectionSet ss
+                <> optempty directives dirs
+                <> selectionSet sels
 
 -- * Values
 
 value :: Value -> Text
 value (ValueVariable x) = variable x
--- TODO: This will be replaced with `decimal` Buidler
+-- TODO: This will be replaced with `decimal` Builder
 value (ValueInt      x) = pack $ show x
--- TODO: This will be replaced with `decimal` Buidler
+-- 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
@@ -105,10 +113,10 @@ stringValue :: Text -> Text
 stringValue = quotes
 
 listValue :: ListValue -> Text
-listValue (ListValue vs) = bracketsCommas value vs
+listValue = bracketsCommas value
 
 objectValue :: ObjectValue -> Text
-objectValue (ObjectValue ofs) = bracesCommas objectField ofs
+objectValue = bracesCommas objectField
 
 objectField :: ObjectField -> Text
 objectField (ObjectField name v) = name <> ":" <> value v
@@ -124,18 +132,15 @@ directive (Directive name args) = "@" <> name <> optempty arguments args
 -- * Type Reference
 
 type_ :: Type -> Text
-type_ (TypeNamed (NamedType x)) = x
-type_ (TypeList x) = listType x
+type_ (TypeNamed   x) = x
+type_ (TypeList    x) = listType x
 type_ (TypeNonNull x) = nonNullType x
 
-namedType :: NamedType -> Text
-namedType (NamedType name) = name
-
-listType :: ListType -> Text
-listType (ListType ty) = brackets (type_ ty)
+listType :: Type -> Text
+listType x = brackets (type_ x)
 
 nonNullType :: NonNullType -> Text
-nonNullType (NonNullTypeNamed (NamedType x)) = x <> "!"
+nonNullType (NonNullTypeNamed x) = x <> "!"
 nonNullType (NonNullTypeList  x) = listType x <> "!"
 
 -- * Internal
diff --git a/Data/GraphQL/Execute.hs b/Data/GraphQL/Execute.hs
index a7e3c91..4dab56c 100644
--- a/Data/GraphQL/Execute.hs
+++ b/Data/GraphQL/Execute.hs
@@ -21,38 +21,37 @@ import Data.GraphQL.Error
 --   errors wrapped in an /errors/ field.
 execute :: Alternative f
   => Schema.Schema f -> Schema.Subs -> Document -> f Aeson.Value
-execute (Schema resolvs) subs doc = runCollectErrs res
-  where res = Schema.resolvers resolvs $ rootFields subs doc
+execute resolvers subs doc = undefined -- resolver resolvs $ rootFields subs doc
 
 -- | Takes a variable substitution function and a @GraphQL@ document.
 --   If the document contains one query (and no other definitions)
 --   it applies the substitution to the query's set of selections
 --   and then returns their fields.
-rootFields :: Schema.Subs -> Document -> [Field]
-rootFields subs (Document [DefinitionOperation (Query (Node _varDefs _ _ sels))]) =
-    Schema.fields $ substitute subs <$> sels
-rootFields _ _ = []
+-- rootFields :: Schema.Subs -> Document -> [Field]
+-- rootFields subs (Document [DefinitionOperation (Query (Node _varDefs _ _ sels))]) =
+--     Schema.fields $ substitute subs <$> sels
+-- rootFields _ _ = []
 
 -- | Takes a variable substitution function and a selection. If the
 --   selection is a field it applies the substitution to the field's
 --   arguments using 'subsArg', and recursively applies the substitution to
 --   the arguments of fields nested in the primary field.
-substitute :: Schema.Subs -> Selection -> Selection
-substitute subs (SelectionField (Field alias name args directives sels)) =
-    SelectionField $ Field
-      alias
-      name
-      -- TODO: Get rid of `catMaybes`, invalid arguments should raise an error
-      (catMaybes $ subsArg subs <$> args)
-      directives
-      (substitute subs <$> sels)
-substitute _ sel = sel
+-- substitute :: Schema.Subs -> Selection -> Selection
+-- substitute subs (SelectionField (Field alias name args directives sels)) =
+--     SelectionField $ Field
+--       alias
+--       name
+--       -- TODO: Get rid of `catMaybes`, invalid arguments should raise an error
+--       (catMaybes $ subsArg subs <$> args)
+--       directives
+--       (substitute subs <$> sels)
+-- substitute _ sel = sel
 
 -- TODO: Support different value types
 -- | Takes a variable substitution function and an argument. If the
 --   argument's value is a variable the substitution is applied to the
 --   variable's name.
-subsArg :: Schema.Subs -> Argument -> Maybe Argument
-subsArg subs (Argument n (ValueVariable (Variable v))) =
-    Argument n . ValueString <$> subs v
-subsArg _ arg = Just arg
+-- subsArg :: Schema.Subs -> Argument -> Maybe Argument
+-- subsArg subs (Argument n (ValueVariable (Variable v))) =
+--     Argument n . ValueString <$> subs v
+-- subsArg _ arg = Just arg
diff --git a/Data/GraphQL/Parser.hs b/Data/GraphQL/Parser.hs
index 2e72a3a..820a323 100644
--- a/Data/GraphQL/Parser.hs
+++ b/Data/GraphQL/Parser.hs
@@ -1,27 +1,31 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
 -- | This module defines a parser for @GraphQL@ request documents.
 module Data.GraphQL.Parser where
 
 import Prelude hiding (takeWhile)
 
-import Control.Applicative ((<|>), empty, many, optional)
+import Control.Applicative ((<|>), Alternative, empty, many, optional)
 import Control.Monad (when)
 import Data.Char (isDigit, isSpace)
 import Data.Foldable (traverse_)
+import Data.Monoid ((<>))
+import Data.List.NonEmpty (NonEmpty((:|)))
 import Data.Scientific (floatingOrInteger)
 
 import Data.Text (Text, append)
+import Data.Attoparsec.Combinator (lookAhead)
 import Data.Attoparsec.Text
   ( Parser
   , (<?>)
   , anyChar
-  , scientific
   , endOfLine
   , inClass
   , many1
   , manyTill
   , option
   , peekChar
+  , scientific
   , takeWhile
   , takeWhile1
   )
@@ -35,20 +39,12 @@ name = tok $ append <$> takeWhile1 isA_z
                     <*> takeWhile ((||) <$> isDigit <*> isA_z)
   where
     -- `isAlpha` handles many more Unicode Chars
-    isA_z =  inClass $ '_' : ['A'..'Z'] ++ ['a'..'z']
+    isA_z =  inClass $ '_' : ['A'..'Z'] <> ['a'..'z']
 
 -- * Document
 
 document :: Parser Document
-document = whiteSpace
-     *> (Document <$> many1 definition)
-    -- Try SelectionSet when no definition
-    <|> (Document . pure
-                  . DefinitionOperation
-                  . Query
-                  . Node mempty empty empty
-                <$> selectionSet)
-    <?> "document error!"
+document = whiteSpace *> manyNE definition
 
 definition :: Parser Definition
 definition = DefinitionOperation <$> operationDefinition
@@ -56,54 +52,48 @@ definition = DefinitionOperation <$> operationDefinition
          <?> "definition error!"
 
 operationDefinition :: Parser OperationDefinition
-operationDefinition =
-        Query    <$ tok "query"    <*> node
-    <|> Mutation <$ tok "mutation" <*> node
-    <?> "operationDefinition error!"
+operationDefinition = OperationSelectionSet <$> selectionSet
+                  <|> OperationDefinition   <$> operationType
+                                            <*> name
+                                            <*> opt variableDefinitions
+                                            <*> opt directives
+                                            <*> selectionSet
+                  <?> "operationDefinition error"
 
-node :: Parser Node
-node = Node <$> name
-            <*> optempty variableDefinitions
-            <*> optempty directives
-            <*> selectionSet
+operationType :: Parser OperationType
+operationType = Query    <$ tok "query"
+            <|> Mutation <$ tok "mutation"
+            <?> "operationType error"
 
-variableDefinitions :: Parser [VariableDefinition]
-variableDefinitions = parens (many1 variableDefinition)
-
-variableDefinition :: Parser VariableDefinition
-variableDefinition =
-    VariableDefinition <$> variable
-                       <*  tok ":"
-                       <*> type_
-                       <*> optional defaultValue
-
-defaultValue :: Parser DefaultValue
-defaultValue = tok "=" *> value
-
-variable :: Parser Variable
-variable = Variable <$ tok "$" <*> name
+-- * SelectionSet
 
 selectionSet :: Parser SelectionSet
-selectionSet = braces $ many1 selection
+selectionSet = braces $ manyNE selection
+
+selectionSetOpt :: Parser SelectionSetOpt
+selectionSetOpt = braces $ many1 selection
 
 selection :: Parser Selection
-selection = SelectionField <$> field
-            -- Inline first to catch `on` case
-        <|> SelectionInlineFragment <$> inlineFragment
+selection = SelectionField          <$> field
         <|> SelectionFragmentSpread <$> fragmentSpread
+        <|> SelectionInlineFragment <$> inlineFragment
         <?> "selection error!"
 
+-- * Field
+
 field :: Parser Field
-field = Field <$> optempty alias
+field = Field <$> optional alias
               <*> name
-              <*> optempty arguments
-              <*> optempty directives
-              <*> optempty selectionSet
+              <*> opt arguments
+              <*> opt directives
+              <*> opt selectionSetOpt
 
 alias :: Parser Alias
 alias = name <* tok ":"
 
-arguments :: Parser [Argument]
+-- * Arguments
+
+arguments :: Parser Arguments
 arguments = parens $ many1 argument
 
 argument :: Parser Argument
@@ -112,98 +102,103 @@ argument = Argument <$> name <* tok ":" <*> value
 -- * Fragments
 
 fragmentSpread :: Parser FragmentSpread
--- TODO: Make sure it fails when `... on`.
--- See https://facebook.github.io/graphql/#FragmentSpread
-fragmentSpread = FragmentSpread
-    <$  tok "..."
-    <*> name
-    <*> optempty directives
+fragmentSpread = FragmentSpread <$  tok "..."
+                                <*> fragmentName
+                                <*> opt directives
 
--- InlineFragment tried first in order to guard against 'on' keyword
 inlineFragment :: Parser InlineFragment
-inlineFragment = InlineFragment
-    <$  tok "..."
-    <*  tok "on"
-    <*> typeCondition
-    <*> optempty directives
-    <*> selectionSet
+inlineFragment = InlineFragment <$  tok "..."
+                                <*> optional typeCondition
+                                <*> opt directives
+                                <*> selectionSet
 
 fragmentDefinition :: Parser FragmentDefinition
 fragmentDefinition = FragmentDefinition
-    <$  tok "fragment"
-    <*> name
-    <*  tok "on"
-    <*> typeCondition
-    <*> optempty directives
-    <*> selectionSet
+                 <$  tok "fragment"
+                 <*> name
+                 <*> typeCondition
+                 <*> opt directives
+                 <*> selectionSet
+
+fragmentName :: Parser FragmentName
+fragmentName = but (tok "on") *> name
 
 typeCondition :: Parser TypeCondition
-typeCondition = namedType
+typeCondition = tok "on" *> name
 
--- * Values
+-- * Input Values
 
--- This will try to pick the first type it can parse. If you are working with
--- explicit types use the `typedValue` parser.
 value :: Parser Value
 value = ValueVariable <$> variable
-    -- TODO: Handle maxBound, Int32 in spec.
     <|> tok (either ValueFloat ValueInt . floatingOrInteger <$> scientific)
     <|> ValueBoolean  <$> booleanValue
+    <|> ValueNull     <$  tok "null"
     <|> ValueString   <$> stringValue
-    -- `true` and `false` have been tried before
-    <|> ValueEnum     <$> name
+    <|> ValueEnum     <$> enumValue
     <|> ValueList     <$> listValue
     <|> ValueObject   <$> objectValue
     <?> "value error!"
+  where
+    booleanValue :: Parser Bool
+    booleanValue = True  <$ tok "true"
+               <|> False <$ tok "false"
 
-booleanValue :: Parser Bool
-booleanValue = True  <$ tok "true"
-   <|> False <$ tok "false"
+    -- TODO: Escape characters. Look at `jsstring_` in aeson package.
+    stringValue :: Parser Text
+    stringValue = quotes (takeWhile (/= '"'))
 
--- TODO: Escape characters. Look at `jsstring_` in aeson package.
-stringValue :: Parser Text
-stringValue = quotes (takeWhile (/= '"'))
+    enumValue :: Parser Name
+    enumValue = but (tok "true") *> but (tok "false") *> but (tok "null") *> name
 
--- Notice it can be empty
-listValue :: Parser ListValue
-listValue = ListValue <$> brackets (many value)
+    listValue :: Parser [Value]
+    listValue = brackets $ many1 value
 
--- Notice it can be empty
-objectValue :: Parser ObjectValue
-objectValue = ObjectValue <$> braces (many objectField)
+    objectValue :: Parser [ObjectField]
+    objectValue = braces $ many1 objectField
 
 objectField :: Parser ObjectField
 objectField = ObjectField <$> name <* tok ":" <*> value
 
+-- * Variables
+
+variableDefinitions :: Parser VariableDefinitions
+variableDefinitions = parens $ many1 variableDefinition
+
+variableDefinition :: Parser VariableDefinition
+variableDefinition = VariableDefinition <$> variable
+                                        <*  tok ":"
+                                        <*> type_
+                                        <*> optional defaultValue
+
+variable :: Parser Variable
+variable = tok "$" *> name
+
+defaultValue :: Parser DefaultValue
+defaultValue = tok "=" *> value
+
+-- * Input Types
+
+type_ :: Parser Type
+type_ = TypeNamed   <$> name
+    <|> TypeList    <$> brackets type_
+    <|> TypeNonNull <$> nonNullType
+    <?> "type_ error!"
+
+nonNullType :: Parser NonNullType
+nonNullType = NonNullTypeNamed <$> name <* tok "!"
+          <|> NonNullTypeList  <$> brackets type_  <* tok "!"
+          <?> "nonNullType error!"
+
 -- * Directives
 
-directives :: Parser [Directive]
+directives :: Parser Directives
 directives = many1 directive
 
 directive :: Parser Directive
 directive = Directive
-    <$  tok "@"
-    <*> name
-    <*> optempty arguments
-
--- * Type Reference
-
-type_ :: Parser Type
-type_ = TypeList    <$> listType
-    <|> TypeNonNull <$> nonNullType
-    <|> TypeNamed   <$> namedType
-    <?> "type_ error!"
-
-namedType :: Parser NamedType
-namedType = NamedType <$> name
-
-listType :: Parser ListType
-listType = ListType <$> brackets type_
-
-nonNullType :: Parser NonNullType
-nonNullType = NonNullTypeNamed <$> namedType <* tok "!"
-          <|> NonNullTypeList  <$> listType  <* tok "!"
-          <?> "nonNullType error!"
+        <$  tok "@"
+        <*> name
+        <*> opt arguments
 
 -- * Internal
 
@@ -225,12 +220,18 @@ brackets = between "[" "]"
 between :: Parser Text -> Parser Text -> Parser a -> Parser a
 between open close p = tok open *> p <* tok close
 
--- `empty` /= `pure mempty` for `Parser`.
-optempty :: Monoid a => Parser a -> Parser a
-optempty = option mempty
+opt :: Monoid a => Parser a -> Parser a
+opt = option mempty
+
+-- Hack to reverse parser success
+but :: Parser a -> Parser ()
+but pn = False <$ lookAhead pn <|> pure True >>= \case
+  False -> empty
+  True  -> pure ()
+
+manyNE :: Alternative f => f a -> f (NonEmpty a)
+manyNE p = (:|) <$> p <*> many p
 
--- ** WhiteSpace
---
 whiteSpace :: Parser ()
 whiteSpace = peekChar >>= traverse_ (\c ->
     if isSpace c || c == ','
diff --git a/Data/GraphQL/Schema.hs b/Data/GraphQL/Schema.hs
index b8668d9..2198362 100644
--- a/Data/GraphQL/Schema.hs
+++ b/Data/GraphQL/Schema.hs
@@ -3,7 +3,7 @@
 -- | This module provides a representation of a @GraphQL@ Schema in addition to
 --   functions for defining and manipulating Schemas.
 module Data.GraphQL.Schema
-  ( Schema(..)
+  ( Schema
   , Resolver
   , Subs
   , object
@@ -15,31 +15,31 @@ module Data.GraphQL.Schema
   , enum
   , enumA
   , resolvers
-  , fields
   -- * AST Reexports
   , Field
   , Argument(..)
   , Value(..)
   ) where
 
-import Data.Bifunctor (first)
-import Data.Monoid (Alt(Alt,getAlt))
 import Control.Applicative (Alternative((<|>), empty))
-import Data.Maybe (catMaybes)
+import Data.Bifunctor (first)
 import Data.Foldable (fold)
+import Data.List.NonEmpty (NonEmpty)
+import Data.Maybe (fromMaybe)
+import Data.Monoid (Alt(Alt,getAlt))
 
 import qualified Data.Aeson as Aeson
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
 import Data.Text (Text)
-import qualified Data.Text as T (null, unwords)
+import qualified Data.Text as T (unwords)
 
-import Data.GraphQL.AST
+import Data.GraphQL.AST.Core
 import Data.GraphQL.Error
 
 -- | A GraphQL schema.
 --   @f@ is usually expected to be an instance of 'Alternative'.
-data Schema f = Schema [Resolver f]
+type Schema f = NonEmpty (Resolver f)
 
 -- | Resolves a 'Field' into an @Aeson.@'Aeson.Object' with error information
 --   (or 'empty'). @f@ is usually expected to be an instance of 'Alternative'.
@@ -48,18 +48,16 @@ type Resolver f = Field -> CollectErrsT f Aeson.Object
 -- | Variable substitution function.
 type Subs = Text -> Maybe Text
 
--- | Create a named 'Resolver' from a list of 'Resolver's.
-object :: Alternative f => Text -> [Resolver f] -> Resolver f
+object :: Alternative f => Name -> [Resolver f] -> Resolver f
 object name resolvs = objectA name $ \case
-     [] -> resolvs
-     _  -> empty
+      [] -> resolvs
+      _  -> empty
 
 -- | Like 'object' but also taking 'Argument's.
 objectA
   :: Alternative f
-  => Text -> ([Argument] -> [Resolver f]) -> Resolver f
-objectA name f fld@(Field _ _ args _ sels) =
-    withField name (resolvers (f args) $ fields sels) fld
+  => Name -> ([Argument] -> [Resolver f]) -> Resolver f
+objectA name f fld@(Field _ _ args sels) = withField name (resolvers (f args) sels) fld
 
 -- | A scalar represents a primitive value, like a string or an integer.
 scalar :: (Alternative f, Aeson.ToJSON a) => Text -> a -> Resolver f
@@ -70,11 +68,10 @@ scalar name s = scalarA name $ \case
 -- | Like 'scalar' but also taking 'Argument's.
 scalarA
   :: (Alternative f, Aeson.ToJSON a)
-  => Text -> ([Argument] -> f a) -> Resolver f
-scalarA name f fld@(Field _ _ args _ []) = withField name (errWrap $ f args) fld
+  => Name -> ([Argument] -> f a) -> Resolver f
+scalarA name f fld@(Field _ _ args []) = withField name (errWrap $ f args) fld
 scalarA _ _ _ = empty
 
--- | Like 'object' but taking lists of 'Resolver's instead of a single list.
 array :: Alternative f => Text -> [[Resolver f]] -> Resolver f
 array name resolvs = arrayA name $ \case
     [] -> resolvs
@@ -84,8 +81,8 @@ array name resolvs = arrayA name $ \case
 arrayA
   :: Alternative f
   => Text -> ([Argument] -> [[Resolver f]]) -> Resolver f
-arrayA name f fld@(Field _ _ args _ sels) =
-     withField name (joinErrs $ traverse (flip resolvers $ fields sels) $ f args) fld
+arrayA name f fld@(Field _ _ args sels) =
+     withField name (joinErrs $ traverse (`resolvers` sels) $ f args) fld
 
 -- | Represents one of a finite set of possible values.
 --   Used in place of a 'scalar' when the possible responses are easily enumerable.
@@ -96,19 +93,19 @@ enum name enums = enumA name $ \case
 
 -- | Like 'enum' but also taking 'Argument's.
 enumA :: Alternative f => Text -> ([Argument] -> f [Text]) -> Resolver f
-enumA name f fld@(Field _ _ args _ []) = withField name (errWrap $ f args) fld
+enumA name f fld@(Field _ _ args []) = withField name (errWrap $ f args) fld
 enumA _ _ _ = empty
 
 -- | Helper function to facilitate 'Argument' handling.
 withField
   :: (Alternative f, Aeson.ToJSON a)
-  => Text -> CollectErrsT f a -> Field -> CollectErrsT f (HashMap Text Aeson.Value)
-withField name f (Field alias name' _ _ _) =
+  => Name -> CollectErrsT f a -> Field -> CollectErrsT f (HashMap Text Aeson.Value)
+withField name f (Field alias name' _ _) =
      if name == name'
         then fmap (first $ HashMap.singleton aliasOrName . Aeson.toJSON) f
         else empty
      where
-       aliasOrName = if T.null alias then name' else alias
+       aliasOrName = fromMaybe name' alias
 
 -- | Takes a list of 'Resolver's and a list of 'Field's and applies each
 --   'Resolver' to each 'Field'. Resolves into a value containing the
@@ -118,18 +115,8 @@ resolvers resolvs =
     fmap (first Aeson.toJSON . fold)
   . traverse (\fld -> getAlt (foldMap (Alt . ($ fld)) resolvs) <|> errmsg fld)
   where
-    errmsg (Field alias name _ _ _) = addErrMsg msg $ (errWrap . pure) val
+    errmsg (Field alias name _ _) = addErrMsg msg $ (errWrap . pure) val
        where
          val = HashMap.singleton aliasOrName Aeson.Null
          msg = T.unwords ["field", name, "not resolved."]
-         aliasOrName = if T.null alias then name else alias
-
--- | Checks whether the given 'Selection' contains a 'Field' and
---   returns the 'Field' if so, else returns 'Nothing'.
-field :: Selection -> Maybe Field
-field (SelectionField x) = Just x
-field _ = Nothing
-
--- | Returns a list of the 'Field's contained in the given 'SelectionSet'.
-fields :: SelectionSet -> [Field]
-fields = catMaybes . fmap field
+         aliasOrName = fromMaybe name alias
diff --git a/graphql.cabal b/graphql.cabal
index d330abd..0fec483 100644
--- a/graphql.cabal
+++ b/graphql.cabal
@@ -25,11 +25,12 @@ library
   ghc-options:         -Wall
   exposed-modules:     Data.GraphQL
                        Data.GraphQL.AST
-                       Data.GraphQL.Encoder
+                       Data.GraphQL.AST.Core
                        Data.GraphQL.Execute
+                       Data.GraphQL.Encoder
+                       Data.GraphQL.Error
                        Data.GraphQL.Schema
                        Data.GraphQL.Parser
-                       Data.GraphQL.Error
   build-depends:       aeson >= 0.7.0.3,
                        attoparsec >= 0.10.4.0,
                        base >= 4.7 && < 5,
diff --git a/tests/Test/StarWars/Schema.hs b/tests/Test/StarWars/Schema.hs
index ff79686..29c123e 100644
--- a/tests/Test/StarWars/Schema.hs
+++ b/tests/Test/StarWars/Schema.hs
@@ -1,15 +1,11 @@
-{-# LANGUAGE CPP #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 module Test.StarWars.Schema where
 
 import Control.Applicative (Alternative, empty)
+import Data.List.NonEmpty (NonEmpty((:|)))
 
-#if !MIN_VERSION_base(4,8,0)
-import Control.Applicative ((<$>))
-import Data.Traversable (traverse)
-#endif
-import Data.GraphQL.Schema
+import Data.GraphQL.Schema (Schema, Resolver, Argument(..), Value(..))
 import qualified Data.GraphQL.Schema as Schema
 
 import Test.StarWars.Data
@@ -18,7 +14,7 @@ import Test.StarWars.Data
 -- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js
 
 schema :: Alternative f => Schema f
-schema = Schema [hero, human, droid]
+schema = hero :| [human, droid]
 
 hero :: Alternative f => Resolver f
 hero = Schema.objectA "hero" $ \case
diff --git a/tests/tasty.hs b/tests/tasty.hs
index fa9bedf..aa8da50 100644
--- a/tests/tasty.hs
+++ b/tests/tasty.hs
@@ -18,10 +18,10 @@ import qualified Test.StarWars.QueryTests as SW
 import Paths_graphql (getDataFileName)
 
 main :: IO ()
-main = defaultMain . testGroup "Tests" . (: [SW.test]) =<< ksTest
+main = defaultMain . testGroup "Tests" . (: [SW.test]) =<< kitchenTest
 
-ksTest :: IO TestTree
-ksTest = testCase "Kitchen Sink"
+kitchenTest :: IO TestTree
+kitchenTest = testCase "Kitchen Sink"
      <$> (assertEqual "Encode" <$> expected <*> actual)
   where
     expected = Text.readFile

From 337b620717e0231c18925712f5c5401588bb9736 Mon Sep 17 00:00:00 2001
From: Danny Navarro <j@dannynavarro.net>
Date: Sun, 29 Jan 2017 11:11:30 -0300
Subject: [PATCH 02/11] Update .gitignore

---
 .gitignore | 4 ++++
 1 file changed, 4 insertions(+)

diff --git a/.gitignore b/.gitignore
index 5e97b3c..fd6e439 100644
--- a/.gitignore
+++ b/.gitignore
@@ -4,3 +4,7 @@ cabal.sandbox.config
 dist/
 TAGS
 .#*
+.DS_Store
+cabal.project.local
+dist-newstyle/
+dist-newstyle/

From f35e1f949ab3ee718ab773baf9f38ac411d49a28 Mon Sep 17 00:00:00 2001
From: Danny Navarro <j@dannynavarro.net>
Date: Sun, 29 Jan 2017 12:53:15 -0300
Subject: [PATCH 03/11] Define Schema using Core AST

Also, temporarily remove error reporting to simplify execution. This should be
restored once the new execution model is nailed.
---
 Data/GraphQL/Execute.hs       | 32 +++++++++++----
 Data/GraphQL/Schema.hs        | 74 +++++++++++++++++------------------
 tests/Test/StarWars/Schema.hs | 12 +++---
 3 files changed, 67 insertions(+), 51 deletions(-)

diff --git a/Data/GraphQL/Execute.hs b/Data/GraphQL/Execute.hs
index 4dab56c..561bf20 100644
--- a/Data/GraphQL/Execute.hs
+++ b/Data/GraphQL/Execute.hs
@@ -3,15 +3,23 @@
 module Data.GraphQL.Execute (execute) where
 
 import Control.Applicative (Alternative)
-import Data.Maybe (catMaybes)
+import qualified Data.List.NonEmpty as NE
+import Data.List.NonEmpty (NonEmpty((:|)))
 
 import qualified Data.Aeson as Aeson
 
-import Data.GraphQL.AST
-import Data.GraphQL.Schema (Schema(..))
+import qualified Data.GraphQL.AST as AST
+import qualified Data.GraphQL.AST.Core as AST.Core
+import Data.GraphQL.Schema (Schema)
 import qualified Data.GraphQL.Schema as Schema
 
-import Data.GraphQL.Error
+
+
+core :: Schema.Subs -> AST.Document -> AST.Core.Document
+core subs ((AST.DefinitionOperation opDef) :| []) = error "Not implemented yet"
+core _    ((AST.DefinitionFragment fragDef) :| []) =
+  error "Fragment definitions not supported yet"
+core _ _ = error "Multiple definitions not supported yet"
 
 -- | Takes a 'Schema', a variable substitution function ('Schema.Subs'), and a
 --   @GraphQL@ 'document'. The substitution is applied to the document using
@@ -19,9 +27,19 @@ import Data.GraphQL.Error
 --
 --   Returns the result of the query against the 'Schema' wrapped in a /data/ field, or
 --   errors wrapped in an /errors/ field.
-execute :: Alternative f
-  => Schema.Schema f -> Schema.Subs -> Document -> f Aeson.Value
-execute resolvers subs doc = undefined -- resolver resolvs $ rootFields subs doc
+execute
+  :: Alternative f
+  => Schema f -> Schema.Subs -> AST.Document -> f Aeson.Value
+execute schema subs doc = document schema $ core subs doc
+
+document :: Alternative f => Schema f -> AST.Core.Document -> f Aeson.Value
+document schema (op :| [])= operation schema op
+document _ _ = error "Multiple operations not supported yet"
+
+operation :: Alternative f => Schema f -> AST.Core.Operation -> f Aeson.Value
+operation schema (AST.Core.Query flds) =
+  Schema.resolve (NE.toList schema) (NE.toList flds)
+operation _ _ = error "Mutations not supported yet"
 
 -- | Takes a variable substitution function and a @GraphQL@ document.
 --   If the document contains one query (and no other definitions)
diff --git a/Data/GraphQL/Schema.hs b/Data/GraphQL/Schema.hs
index 2198362..aa25046 100644
--- a/Data/GraphQL/Schema.hs
+++ b/Data/GraphQL/Schema.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE LambdaCase #-}
 -- | This module provides a representation of a @GraphQL@ Schema in addition to
 --   functions for defining and manipulating Schemas.
@@ -14,15 +13,14 @@ module Data.GraphQL.Schema
   , arrayA
   , enum
   , enumA
-  , resolvers
+  , resolve
   -- * AST Reexports
   , Field
   , Argument(..)
   , Value(..)
   ) where
 
-import Control.Applicative (Alternative((<|>), empty))
-import Data.Bifunctor (first)
+import Control.Applicative (Alternative( empty))
 import Data.Foldable (fold)
 import Data.List.NonEmpty (NonEmpty)
 import Data.Maybe (fromMaybe)
@@ -32,10 +30,8 @@ import qualified Data.Aeson as Aeson
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
 import Data.Text (Text)
-import qualified Data.Text as T (unwords)
 
 import Data.GraphQL.AST.Core
-import Data.GraphQL.Error
 
 -- | A GraphQL schema.
 --   @f@ is usually expected to be an instance of 'Alternative'.
@@ -43,24 +39,31 @@ type Schema f = NonEmpty (Resolver f)
 
 -- | Resolves a 'Field' into an @Aeson.@'Aeson.Object' with error information
 --   (or 'empty'). @f@ is usually expected to be an instance of 'Alternative'.
-type Resolver f = Field -> CollectErrsT f Aeson.Object
+type Resolver f = Field -> f Aeson.Object
+
+type Resolvers f = [Resolver f]
+
+type Fields = [Field]
+
+type Arguments = [Argument]
 
 -- | Variable substitution function.
 type Subs = Text -> Maybe Text
 
-object :: Alternative f => Name -> [Resolver f] -> Resolver f
-object name resolvs = objectA name $ \case
-      [] -> resolvs
-      _  -> empty
+-- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's.
+object :: Alternative f => Name -> Resolvers f -> Resolver f
+object name resolvers = objectA name $ \case
+  [] -> resolvers
+  _  -> empty
 
 -- | Like 'object' but also taking 'Argument's.
 objectA
   :: Alternative f
-  => Name -> ([Argument] -> [Resolver f]) -> Resolver f
-objectA name f fld@(Field _ _ args sels) = withField name (resolvers (f args) sels) fld
+  => Name -> (Arguments -> Resolvers f) -> Resolver f
+objectA name f fld@(Field _ _ args flds) = withField name (resolve (f args) flds) fld
 
 -- | A scalar represents a primitive value, like a string or an integer.
-scalar :: (Alternative f, Aeson.ToJSON a) => Text -> a -> Resolver f
+scalar :: (Alternative f, Aeson.ToJSON a) => Name -> a -> Resolver f
 scalar name s = scalarA name $ \case
     [] -> pure s
     _  -> empty
@@ -68,21 +71,21 @@ scalar name s = scalarA name $ \case
 -- | Like 'scalar' but also taking 'Argument's.
 scalarA
   :: (Alternative f, Aeson.ToJSON a)
-  => Name -> ([Argument] -> f a) -> Resolver f
-scalarA name f fld@(Field _ _ args []) = withField name (errWrap $ f args) fld
+  => Name -> (Arguments -> f a) -> Resolver f
+scalarA name f fld@(Field _ _ args []) = withField name (f args) fld
 scalarA _ _ _ = empty
 
-array :: Alternative f => Text -> [[Resolver f]] -> Resolver f
-array name resolvs = arrayA name $ \case
-    [] -> resolvs
+array :: Alternative f => Name -> [Resolvers f] -> Resolver f
+array name resolvers = arrayA name $ \case
+    [] -> resolvers
     _  -> empty
 
 -- | Like 'array' but also taking 'Argument's.
 arrayA
   :: Alternative f
-  => Text -> ([Argument] -> [[Resolver f]]) -> Resolver f
+  => Text -> (Arguments -> [Resolvers f]) -> Resolver f
 arrayA name f fld@(Field _ _ args sels) =
-     withField name (joinErrs $ traverse (`resolvers` sels) $ f args) fld
+     withField name (traverse (`resolve` sels) $ f args) fld
 
 -- | Represents one of a finite set of possible values.
 --   Used in place of a 'scalar' when the possible responses are easily enumerable.
@@ -93,30 +96,25 @@ enum name enums = enumA name $ \case
 
 -- | Like 'enum' but also taking 'Argument's.
 enumA :: Alternative f => Text -> ([Argument] -> f [Text]) -> Resolver f
-enumA name f fld@(Field _ _ args []) = withField name (errWrap $ f args) fld
+enumA name f fld@(Field _ _ args []) = withField name (f args) fld
 enumA _ _ _ = empty
 
 -- | Helper function to facilitate 'Argument' handling.
 withField
   :: (Alternative f, Aeson.ToJSON a)
-  => Name -> CollectErrsT f a -> Field -> CollectErrsT f (HashMap Text Aeson.Value)
+  => Name -> f a -> Field -> f (HashMap Text Aeson.Value)
 withField name f (Field alias name' _ _) =
-     if name == name'
-        then fmap (first $ HashMap.singleton aliasOrName . Aeson.toJSON) f
-        else empty
-     where
-       aliasOrName = fromMaybe name' alias
+  if name == name'
+    then fmap (HashMap.singleton aliasOrName . Aeson.toJSON) f
+    else empty
+  where
+    aliasOrName = fromMaybe name alias
+
 
 -- | Takes a list of 'Resolver's and a list of 'Field's and applies each
 --   'Resolver' to each 'Field'. Resolves into a value containing the
 --   resolved 'Field', or a null value and error information.
-resolvers :: Alternative f => [Resolver f] -> [Field] -> CollectErrsT f Aeson.Value
-resolvers resolvs =
-    fmap (first Aeson.toJSON . fold)
-  . traverse (\fld -> getAlt (foldMap (Alt . ($ fld)) resolvs) <|> errmsg fld)
-  where
-    errmsg (Field alias name _ _) = addErrMsg msg $ (errWrap . pure) val
-       where
-         val = HashMap.singleton aliasOrName Aeson.Null
-         msg = T.unwords ["field", name, "not resolved."]
-         aliasOrName = fromMaybe name alias
+resolve :: Alternative f => Resolvers f -> Fields -> f Aeson.Value
+resolve resolvers =
+    fmap (Aeson.toJSON . fold)
+  . traverse (\fld -> getAlt (foldMap (Alt . ($ fld)) resolvers))
diff --git a/tests/Test/StarWars/Schema.hs b/tests/Test/StarWars/Schema.hs
index 29c123e..e816d63 100644
--- a/tests/Test/StarWars/Schema.hs
+++ b/tests/Test/StarWars/Schema.hs
@@ -19,7 +19,7 @@ schema = hero :| [human, droid]
 hero :: Alternative f => Resolver f
 hero = Schema.objectA "hero" $ \case
   [] -> character artoo
-  [Argument "episode" (ValueInt n)] -> character $ getHero (fromIntegral n)
+  [Argument "episode" (ValueInt n)] -> character . getHero $ fromIntegral n
   _ -> empty
 
 human :: Alternative f => Resolver f
@@ -34,10 +34,10 @@ droid = Schema.objectA "droid" $ \case
 
 character :: Alternative f => Character -> [Resolver f]
 character char =
-  [ Schema.scalar "id"        $ id_ char
-  , Schema.scalar "name"      $ name char
-  , Schema.array  "friends"   $ character <$> getFriends char
-  , Schema.enum   "appearsIn" . traverse getEpisode $ appearsIn char
+  [ Schema.scalar "id"              $ id_ char
+  , Schema.scalar "name"            $ name char
+  , Schema.array  "friends"         $ character <$> getFriends char
+  , Schema.enum   "appearsIn"       . traverse getEpisode $ appearsIn char
   , Schema.scalar "secretBackstory" $ secretBackstory char
-  , Schema.scalar "homePlanet" $ either mempty homePlanet char
+  , Schema.scalar "homePlanet"      $ either mempty homePlanet char
   ]

From 693b7d18dcd48525b10ce297f89b3b33fd020784 Mon Sep 17 00:00:00 2001
From: Danny Navarro <j@dannynavarro.net>
Date: Sun, 29 Jan 2017 18:44:03 -0300
Subject: [PATCH 04/11] Introduce Tranform module

In the Transform module the Full AST will converted to Core AST.

This commit also includes a partial implementation of Fragment replacement.
---
 Data/GraphQL/AST/Core.hs      |  3 +-
 Data/GraphQL/AST/Transform.hs | 86 +++++++++++++++++++++++++++++++++++
 Data/GraphQL/Execute.hs       | 11 +----
 Data/GraphQL/Schema.hs        |  2 +-
 graphql.cabal                 |  1 +
 5 files changed, 92 insertions(+), 11 deletions(-)
 create mode 100644 Data/GraphQL/AST/Transform.hs

diff --git a/Data/GraphQL/AST/Core.hs b/Data/GraphQL/AST/Core.hs
index b5698c6..3424d20 100644
--- a/Data/GraphQL/AST/Core.hs
+++ b/Data/GraphQL/AST/Core.hs
@@ -23,8 +23,9 @@ data Argument = Argument Name Value deriving (Eq,Show)
 data Value = ValueInt Int32
            -- GraphQL Float is double precision
            | ValueFloat Double
-           | ValueBoolean Bool
            | ValueString Text
+           | ValueBoolean Bool
+           | ValueNull
            | ValueEnum Name
            | ValueList [Value]
            | ValueObject [ObjectField]
diff --git a/Data/GraphQL/AST/Transform.hs b/Data/GraphQL/AST/Transform.hs
new file mode 100644
index 0000000..89a79e6
--- /dev/null
+++ b/Data/GraphQL/AST/Transform.hs
@@ -0,0 +1,86 @@
+module Data.GraphQL.AST.Transform where
+
+import Control.Applicative (empty)
+import Data.Bifunctor (first)
+import Data.Either (partitionEithers)
+import qualified Data.List.NonEmpty as NonEmpty
+-- import Data.List.NonEmpty (NonEmpty((:|)))
+import Data.Monoid (Alt(Alt,getAlt))
+import Data.Foldable (foldMap)
+
+import Data.Text (Text)
+
+import qualified Data.GraphQL.AST as Full
+import qualified Data.GraphQL.AST.Core as Core
+import qualified Data.GraphQL.Schema as Schema
+
+type Name = Text
+
+-- | Replaces a fragment name by a list of 'Field'. If the name doesn't match an
+--   empty list is returned.
+type Fragmenter = Name -> [Core.Field]
+
+document :: Schema.Subs -> Full.Document -> Core.Document
+document subs defs = operations subs fr ops
+  where
+    (fr, ops) = first foldFrags . partitionEithers . NonEmpty.toList $ defrag <$> defs
+
+    foldFrags :: [Fragmenter] -> Fragmenter
+    foldFrags fs n = getAlt $ foldMap (Alt . ($ n)) fs
+
+-- * Fragment replacement
+
+-- | Extract Fragments into a single Fragmenter function and a Operation
+--   Definition.
+defrag :: Full.Definition -> Either Fragmenter Full.OperationDefinition
+defrag (Full.DefinitionOperation op) = Right op
+defrag (Full.DefinitionFragment fragDef) = Left $ fragmentDefinition fragDef
+
+fragmentDefinition :: Full.FragmentDefinition -> Fragmenter
+fragmentDefinition (Full.FragmentDefinition name _tc _dirs sels) name' =
+  if name == name' then NonEmpty.toList (selection <$> sels) else empty
+
+selection :: Full.Selection -> Core.Field
+selection (Full.SelectionField _fld)       = field _fld
+selection (Full.SelectionFragmentSpread _) = error "Nested fragments not supported yet"
+selection (Full.SelectionInlineFragment _) =
+  error "Inline fragments within fragments not supported yet"
+
+field :: Full.Field -> Core.Field
+field (Full.Field a n args _ sels) =
+  Core.Field a n (argument <$> args) (selection <$> sels)
+
+argument :: Full.Argument -> Core.Argument
+argument (Full.Argument n v) = Core.Argument n (value v)
+
+value :: Full.Value -> Core.Value
+value (Full.ValueVariable _) = error "Variables within fragments not supported yet"
+value (Full.ValueInt      i) = Core.ValueInt i
+value (Full.ValueFloat    f) = Core.ValueFloat f
+value (Full.ValueString   x) = Core.ValueString x
+value (Full.ValueBoolean  b) = Core.ValueBoolean b
+value  Full.ValueNull        = Core.ValueNull
+value (Full.ValueEnum     e) = Core.ValueEnum e
+value (Full.ValueList     l) = Core.ValueList (value <$> l)
+value (Full.ValueObject   o) = Core.ValueObject (objectField <$> o)
+
+objectField :: Full.ObjectField -> Core.ObjectField
+objectField (Full.ObjectField n v) = Core.ObjectField n (value v)
+
+-- * Operation
+
+operations
+  :: Schema.Subs
+  -> Fragmenter
+  -> [Full.OperationDefinition]
+  -> Core.Document
+-- XXX: Replace `fromList` by proper error: at least a Query or Mutation
+-- operation must be present
+operations subs fr = NonEmpty.fromList . fmap (operation subs fr)
+
+operation
+  :: Schema.Subs
+  -> Fragmenter
+  -> Full.OperationDefinition
+  -> Core.Operation
+operation _subs _fr _op = undefined
diff --git a/Data/GraphQL/Execute.hs b/Data/GraphQL/Execute.hs
index 561bf20..869753a 100644
--- a/Data/GraphQL/Execute.hs
+++ b/Data/GraphQL/Execute.hs
@@ -10,17 +10,10 @@ import qualified Data.Aeson as Aeson
 
 import qualified Data.GraphQL.AST as AST
 import qualified Data.GraphQL.AST.Core as AST.Core
+import qualified Data.GraphQL.AST.Transform as Transform
 import Data.GraphQL.Schema (Schema)
 import qualified Data.GraphQL.Schema as Schema
 
-
-
-core :: Schema.Subs -> AST.Document -> AST.Core.Document
-core subs ((AST.DefinitionOperation opDef) :| []) = error "Not implemented yet"
-core _    ((AST.DefinitionFragment fragDef) :| []) =
-  error "Fragment definitions not supported yet"
-core _ _ = error "Multiple definitions not supported yet"
-
 -- | Takes a 'Schema', a variable substitution function ('Schema.Subs'), and a
 --   @GraphQL@ 'document'. The substitution is applied to the document using
 --  'rootFields', and the 'Schema''s resolvers are applied to the resulting fields.
@@ -30,7 +23,7 @@ core _ _ = error "Multiple definitions not supported yet"
 execute
   :: Alternative f
   => Schema f -> Schema.Subs -> AST.Document -> f Aeson.Value
-execute schema subs doc = document schema $ core subs doc
+execute schema subs doc = document schema $ Transform.document subs doc
 
 document :: Alternative f => Schema f -> AST.Core.Document -> f Aeson.Value
 document schema (op :| [])= operation schema op
diff --git a/Data/GraphQL/Schema.hs b/Data/GraphQL/Schema.hs
index aa25046..548c4eb 100644
--- a/Data/GraphQL/Schema.hs
+++ b/Data/GraphQL/Schema.hs
@@ -20,7 +20,7 @@ module Data.GraphQL.Schema
   , Value(..)
   ) where
 
-import Control.Applicative (Alternative( empty))
+import Control.Applicative (Alternative(empty))
 import Data.Foldable (fold)
 import Data.List.NonEmpty (NonEmpty)
 import Data.Maybe (fromMaybe)
diff --git a/graphql.cabal b/graphql.cabal
index 0fec483..f037e41 100644
--- a/graphql.cabal
+++ b/graphql.cabal
@@ -26,6 +26,7 @@ library
   exposed-modules:     Data.GraphQL
                        Data.GraphQL.AST
                        Data.GraphQL.AST.Core
+                       Data.GraphQL.AST.Transform
                        Data.GraphQL.Execute
                        Data.GraphQL.Encoder
                        Data.GraphQL.Error

From 8b09c8aa76cef5c56811a69aa0fd629186d9f9d9 Mon Sep 17 00:00:00 2001
From: Danny Navarro <j@dannynavarro.net>
Date: Fri, 3 Feb 2017 20:08:40 -0300
Subject: [PATCH 05/11] Make operation name optional

---
 Data/GraphQL/AST.hs     | 2 +-
 Data/GraphQL/Encoder.hs | 4 ++--
 Data/GraphQL/Parser.hs  | 2 +-
 3 files changed, 4 insertions(+), 4 deletions(-)

diff --git a/Data/GraphQL/AST.hs b/Data/GraphQL/AST.hs
index 8a7bbea..3378655 100644
--- a/Data/GraphQL/AST.hs
+++ b/Data/GraphQL/AST.hs
@@ -25,7 +25,7 @@ data Definition = DefinitionOperation OperationDefinition
 
 data OperationDefinition = OperationSelectionSet SelectionSet
                          | OperationDefinition   OperationType
-                                                 Name
+                                                 (Maybe Name)
                                                  VariableDefinitions
                                                  Directives
                                                  SelectionSet
diff --git a/Data/GraphQL/Encoder.hs b/Data/GraphQL/Encoder.hs
index 083a31d..924bdea 100644
--- a/Data/GraphQL/Encoder.hs
+++ b/Data/GraphQL/Encoder.hs
@@ -22,9 +22,9 @@ definition (DefinitionFragment  x) = fragmentDefinition x
 operationDefinition :: OperationDefinition -> Text
 operationDefinition (OperationSelectionSet sels) = selectionSet sels
 operationDefinition (OperationDefinition Query    name vars dirs sels) =
-  "query " <> node name vars dirs sels
+  "query " <> node (fold name) vars dirs sels
 operationDefinition (OperationDefinition Mutation name vars dirs sels) =
-  "mutation " <> node name vars dirs sels
+  "mutation " <> node (fold name) vars dirs sels
 
 node :: Name -> VariableDefinitions -> Directives -> SelectionSet -> Text
 node name vars dirs sels =
diff --git a/Data/GraphQL/Parser.hs b/Data/GraphQL/Parser.hs
index 820a323..0fb0ffc 100644
--- a/Data/GraphQL/Parser.hs
+++ b/Data/GraphQL/Parser.hs
@@ -54,7 +54,7 @@ definition = DefinitionOperation <$> operationDefinition
 operationDefinition :: Parser OperationDefinition
 operationDefinition = OperationSelectionSet <$> selectionSet
                   <|> OperationDefinition   <$> operationType
-                                            <*> name
+                                            <*> optional name
                                             <*> opt variableDefinitions
                                             <*> opt directives
                                             <*> selectionSet

From 4ab4660d364cc62c9e23d2cdc85abc3f7dc6dc8d Mon Sep 17 00:00:00 2001
From: Danny Navarro <j@dannynavarro.net>
Date: Fri, 3 Feb 2017 21:48:26 -0300
Subject: [PATCH 06/11] Initial implementation of AST.Full -> AST.Core

This focused mainly on fragments.
---
 Data/GraphQL.hs               |  4 +-
 Data/GraphQL/AST/Transform.hs | 70 ++++++++++++++++++++---------------
 Data/GraphQL/Execute.hs       |  6 +--
 3 files changed, 46 insertions(+), 34 deletions(-)

diff --git a/Data/GraphQL.hs b/Data/GraphQL.hs
index dd411e5..dfe9362 100644
--- a/Data/GraphQL.hs
+++ b/Data/GraphQL.hs
@@ -19,7 +19,7 @@ import Data.GraphQL.Error
 --   executed according to the given 'Schema'.
 --
 --   Returns the response as an @Aeson.@'Aeson.Value'.
-graphql :: Alternative m => Schema m -> Text -> m Aeson.Value
+graphql :: (Alternative m, Monad m) => Schema m -> Text -> m Aeson.Value
 graphql = flip graphqlSubs $ const Nothing
 
 -- | Takes a 'Schema', a variable substitution function and text
@@ -28,7 +28,7 @@ graphql = flip graphqlSubs $ const Nothing
 --   query and the query is then executed according to the given 'Schema'.
 --
 --   Returns the response as an @Aeson.@'Aeson.Value'.
-graphqlSubs :: Alternative m => Schema m -> Subs -> Text -> m Aeson.Value
+graphqlSubs :: (Alternative m, Monad m) => Schema m -> Subs -> Text -> m Aeson.Value
 graphqlSubs schema f =
     either parseError (execute schema f)
   . Attoparsec.parseOnly document
diff --git a/Data/GraphQL/AST/Transform.hs b/Data/GraphQL/AST/Transform.hs
index 89a79e6..3dac757 100644
--- a/Data/GraphQL/AST/Transform.hs
+++ b/Data/GraphQL/AST/Transform.hs
@@ -1,10 +1,11 @@
 module Data.GraphQL.AST.Transform where
 
 import Control.Applicative (empty)
+import Control.Monad ((<=<))
 import Data.Bifunctor (first)
 import Data.Either (partitionEithers)
 import qualified Data.List.NonEmpty as NonEmpty
--- import Data.List.NonEmpty (NonEmpty((:|)))
+import Data.Maybe (maybeToList)
 import Data.Monoid (Alt(Alt,getAlt))
 import Data.Foldable (foldMap)
 
@@ -20,7 +21,8 @@ type Name = Text
 --   empty list is returned.
 type Fragmenter = Name -> [Core.Field]
 
-document :: Schema.Subs -> Full.Document -> Core.Document
+-- TODO: Replace Maybe by Either CustomError
+document :: Schema.Subs -> Full.Document -> Maybe Core.Document
 document subs defs = operations subs fr ops
   where
     (fr, ops) = first foldFrags . partitionEithers . NonEmpty.toList $ defrag <$> defs
@@ -28,6 +30,34 @@ document subs defs = operations subs fr ops
     foldFrags :: [Fragmenter] -> Fragmenter
     foldFrags fs n = getAlt $ foldMap (Alt . ($ n)) fs
 
+-- * Operation
+
+operations
+  :: Schema.Subs
+  -> Fragmenter
+  -> [Full.OperationDefinition]
+  -> Maybe Core.Document
+operations subs fr = NonEmpty.nonEmpty <=< traverse (operation subs fr)
+
+operation
+  :: Schema.Subs
+  -> Fragmenter
+  -> Full.OperationDefinition
+  -> Maybe Core.Operation
+operation subs fr (Full.OperationSelectionSet sels) =
+  operation subs fr $ Full.OperationDefinition Full.Query empty empty empty sels
+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 fr) sels
+
+selection :: Fragmenter -> Full.Selection -> Maybe (Either [Core.Field] Core.Field)
+selection fr (Full.SelectionField _fld) = Right <$> field fr _fld
+selection fr (Full.SelectionFragmentSpread (Full.FragmentSpread n _dirs)) = Just . Left $ fr n
+selection _  (Full.SelectionInlineFragment _)  = error "Inline fragments not supported yet"
+
 -- * Fragment replacement
 
 -- | Extract Fragments into a single Fragmenter function and a Operation
@@ -38,17 +68,14 @@ defrag (Full.DefinitionFragment fragDef) = Left $ fragmentDefinition fragDef
 
 fragmentDefinition :: Full.FragmentDefinition -> Fragmenter
 fragmentDefinition (Full.FragmentDefinition name _tc _dirs sels) name' =
-  if name == name' then NonEmpty.toList (selection <$> sels) else empty
+  -- TODO: Support fragments within fragments. Fold instead of map.
+  if name == name'
+  then either id pure =<< maybeToList =<< NonEmpty.toList (selection mempty <$> sels)
+  else empty
 
-selection :: Full.Selection -> Core.Field
-selection (Full.SelectionField _fld)       = field _fld
-selection (Full.SelectionFragmentSpread _) = error "Nested fragments not supported yet"
-selection (Full.SelectionInlineFragment _) =
-  error "Inline fragments within fragments not supported yet"
-
-field :: Full.Field -> Core.Field
-field (Full.Field a n args _ sels) =
-  Core.Field a n (argument <$> args) (selection <$> sels)
+field :: Fragmenter -> Full.Field -> Maybe Core.Field
+field fr (Full.Field a n args _ sels) =
+    Core.Field a n (argument <$> args) <$> traverse (hush <=< selection fr) sels
 
 argument :: Full.Argument -> Core.Argument
 argument (Full.Argument n v) = Core.Argument n (value v)
@@ -67,20 +94,5 @@ value (Full.ValueObject   o) = Core.ValueObject (objectField <$> o)
 objectField :: Full.ObjectField -> Core.ObjectField
 objectField (Full.ObjectField n v) = Core.ObjectField n (value v)
 
--- * Operation
-
-operations
-  :: Schema.Subs
-  -> Fragmenter
-  -> [Full.OperationDefinition]
-  -> Core.Document
--- XXX: Replace `fromList` by proper error: at least a Query or Mutation
--- operation must be present
-operations subs fr = NonEmpty.fromList . fmap (operation subs fr)
-
-operation
-  :: Schema.Subs
-  -> Fragmenter
-  -> Full.OperationDefinition
-  -> Core.Operation
-operation _subs _fr _op = undefined
+hush :: Either a b -> Maybe b
+hush = either (const Nothing) Just
diff --git a/Data/GraphQL/Execute.hs b/Data/GraphQL/Execute.hs
index 869753a..52537a4 100644
--- a/Data/GraphQL/Execute.hs
+++ b/Data/GraphQL/Execute.hs
@@ -2,7 +2,7 @@
 --   according to a 'Schema'.
 module Data.GraphQL.Execute (execute) where
 
-import Control.Applicative (Alternative)
+import Control.Applicative (Alternative, empty)
 import qualified Data.List.NonEmpty as NE
 import Data.List.NonEmpty (NonEmpty((:|)))
 
@@ -21,9 +21,9 @@ import qualified Data.GraphQL.Schema as Schema
 --   Returns the result of the query against the 'Schema' wrapped in a /data/ field, or
 --   errors wrapped in an /errors/ field.
 execute
-  :: Alternative f
+  :: (Alternative f, Monad f)
   => Schema f -> Schema.Subs -> AST.Document -> f Aeson.Value
-execute schema subs doc = document schema $ Transform.document subs doc
+execute schema subs doc = document schema =<< maybe empty pure (Transform.document subs doc)
 
 document :: Alternative f => Schema f -> AST.Core.Document -> f Aeson.Value
 document schema (op :| [])= operation schema op

From e716bc57e786e1d9b733c3a2782fdf27007b3e23 Mon Sep 17 00:00:00 2001
From: Danny Navarro <j@dannynavarro.net>
Date: Fri, 10 Feb 2017 18:40:08 -0300
Subject: [PATCH 07/11] Wrap executed result in "data" object

---
 Data/GraphQL/Execute.hs | 5 ++++-
 1 file changed, 4 insertions(+), 1 deletion(-)

diff --git a/Data/GraphQL/Execute.hs b/Data/GraphQL/Execute.hs
index 52537a4..fe78323 100644
--- a/Data/GraphQL/Execute.hs
+++ b/Data/GraphQL/Execute.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
 -- | This module provides the function to execute a @GraphQL@ request --
 --   according to a 'Schema'.
 module Data.GraphQL.Execute (execute) where
@@ -7,6 +8,7 @@ import qualified Data.List.NonEmpty as NE
 import Data.List.NonEmpty (NonEmpty((:|)))
 
 import qualified Data.Aeson as Aeson
+import qualified Data.HashMap.Strict as HashMap
 
 import qualified Data.GraphQL.AST as AST
 import qualified Data.GraphQL.AST.Core as AST.Core
@@ -31,7 +33,8 @@ document _ _ = error "Multiple operations not supported yet"
 
 operation :: Alternative f => Schema f -> AST.Core.Operation -> f Aeson.Value
 operation schema (AST.Core.Query flds) =
-  Schema.resolve (NE.toList schema) (NE.toList flds)
+  Aeson.Object . HashMap.singleton "data"
+             <$> Schema.resolve (NE.toList schema) (NE.toList flds)
 operation _ _ = error "Mutations not supported yet"
 
 -- | Takes a variable substitution function and a @GraphQL@ document.

From b7a72591fd08df9df678e5e7db3304b5a2e75ae9 Mon Sep 17 00:00:00 2001
From: Danny Navarro <j@dannynavarro.net>
Date: Sun, 12 Feb 2017 15:19:13 -0300
Subject: [PATCH 08/11] Support variables in AST transformation

---
 Data/GraphQL/AST/Core.hs      |  4 ++
 Data/GraphQL/AST/Transform.hs | 83 ++++++++++++++++++++++-------------
 Data/GraphQL/Schema.hs        |  3 +-
 3 files changed, 57 insertions(+), 33 deletions(-)

diff --git a/Data/GraphQL/AST/Core.hs b/Data/GraphQL/AST/Core.hs
index 3424d20..f0c617c 100644
--- a/Data/GraphQL/AST/Core.hs
+++ b/Data/GraphQL/AST/Core.hs
@@ -3,6 +3,7 @@ module Data.GraphQL.AST.Core where
 
 import Data.Int (Int32)
 import Data.List.NonEmpty (NonEmpty)
+import Data.String
 
 import Data.Text (Text)
 
@@ -31,4 +32,7 @@ data Value = ValueInt Int32
            | ValueObject [ObjectField]
              deriving (Eq,Show)
 
+instance IsString Value where
+  fromString = ValueString . fromString
+
 data ObjectField = ObjectField Name Value deriving (Eq,Show)
diff --git a/Data/GraphQL/AST/Transform.hs b/Data/GraphQL/AST/Transform.hs
index 3dac757..d4b1150 100644
--- a/Data/GraphQL/AST/Transform.hs
+++ b/Data/GraphQL/AST/Transform.hs
@@ -4,10 +4,10 @@ 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.Maybe (maybeToList)
 import Data.Monoid (Alt(Alt,getAlt))
-import Data.Foldable (foldMap)
 
 import Data.Text (Text)
 
@@ -25,7 +25,11 @@ type Fragmenter = Name -> [Core.Field]
 document :: Schema.Subs -> Full.Document -> Maybe Core.Document
 document subs defs = operations subs fr ops
   where
-    (fr, ops) = first foldFrags . partitionEithers . NonEmpty.toList $ defrag <$> defs
+    (fr, ops) = first foldFrags
+              . partitionEithers
+              . NonEmpty.toList
+              $ defrag subs
+            <$> defs
 
     foldFrags :: [Fragmenter] -> Fragmenter
     foldFrags fs n = getAlt $ foldMap (Alt . ($ n)) fs
@@ -46,53 +50,70 @@ operation
   -> Maybe Core.Operation
 operation subs fr (Full.OperationSelectionSet sels) =
   operation subs fr $ Full.OperationDefinition Full.Query empty empty empty sels
-operation _subs fr (Full.OperationDefinition ot _n _vars _dirs 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 fr) sels
+    node = traverse (hush <=< selection subs fr) sels
 
-selection :: Fragmenter -> Full.Selection -> Maybe (Either [Core.Field] Core.Field)
-selection fr (Full.SelectionField _fld) = Right <$> field fr _fld
-selection fr (Full.SelectionFragmentSpread (Full.FragmentSpread n _dirs)) = Just . Left $ fr n
-selection _  (Full.SelectionInlineFragment _)  = error "Inline fragments not supported yet"
+selection
+  :: Schema.Subs
+  -> Fragmenter
+  -> Full.Selection
+  -> Maybe (Either [Core.Field] Core.Field)
+selection subs fr (Full.SelectionField fld) =
+  Right <$> field subs fr fld
+selection _    fr (Full.SelectionFragmentSpread (Full.FragmentSpread n _dirs)) =
+  Just . 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 :: Full.Definition -> Either Fragmenter Full.OperationDefinition
-defrag (Full.DefinitionOperation op) = Right op
-defrag (Full.DefinitionFragment fragDef) = Left $ fragmentDefinition fragDef
+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 :: Full.FragmentDefinition -> Fragmenter
-fragmentDefinition (Full.FragmentDefinition name _tc _dirs sels) name' =
+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 =<< maybeToList =<< NonEmpty.toList (selection mempty <$> sels)
+  then either id pure =<< maybeToList
+                      =<< NonEmpty.toList (selection subs mempty <$> sels)
   else empty
 
-field :: Fragmenter -> Full.Field -> Maybe Core.Field
-field fr (Full.Field a n args _ sels) =
-    Core.Field a n (argument <$> args) <$> traverse (hush <=< selection fr) sels
+field :: Schema.Subs -> Fragmenter -> Full.Field -> Maybe Core.Field
+field subs fr (Full.Field a n args _dirs sels) =
+      Core.Field a n (fold $ argument subs `traverse` args)
+  <$> traverse (hush <=< selection subs fr) sels
 
-argument :: Full.Argument -> Core.Argument
-argument (Full.Argument n v) = Core.Argument n (value v)
+argument :: Schema.Subs -> Full.Argument -> Maybe Core.Argument
+argument subs (Full.Argument n v) = Core.Argument n <$> value subs v
 
-value :: Full.Value -> Core.Value
-value (Full.ValueVariable _) = error "Variables within fragments not supported yet"
-value (Full.ValueInt      i) = Core.ValueInt i
-value (Full.ValueFloat    f) = Core.ValueFloat f
-value (Full.ValueString   x) = Core.ValueString x
-value (Full.ValueBoolean  b) = Core.ValueBoolean b
-value  Full.ValueNull        = Core.ValueNull
-value (Full.ValueEnum     e) = Core.ValueEnum e
-value (Full.ValueList     l) = Core.ValueList (value <$> l)
-value (Full.ValueObject   o) = Core.ValueObject (objectField <$> o)
+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 :: Full.ObjectField -> Core.ObjectField
-objectField (Full.ObjectField n v) = Core.ObjectField n (value v)
+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
diff --git a/Data/GraphQL/Schema.hs b/Data/GraphQL/Schema.hs
index 548c4eb..4acc4ac 100644
--- a/Data/GraphQL/Schema.hs
+++ b/Data/GraphQL/Schema.hs
@@ -48,7 +48,7 @@ type Fields = [Field]
 type Arguments = [Argument]
 
 -- | Variable substitution function.
-type Subs = Text -> Maybe Text
+type Subs = Name -> Maybe Value
 
 -- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's.
 object :: Alternative f => Name -> Resolvers f -> Resolver f
@@ -110,7 +110,6 @@ withField name f (Field alias name' _ _) =
   where
     aliasOrName = fromMaybe name alias
 
-
 -- | Takes a list of 'Resolver's and a list of 'Field's and applies each
 --   'Resolver' to each 'Field'. Resolves into a value containing the
 --   resolved 'Field', or a null value and error information.

From 39731ff2338d74bfabf9863fb5921e8f255858dd Mon Sep 17 00:00:00 2001
From: Danny Navarro <j@dannynavarro.net>
Date: Sun, 12 Feb 2017 15:31:56 -0300
Subject: [PATCH 09/11] Fix parsing of Named Types

---
 Data/GraphQL/Parser.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/Data/GraphQL/Parser.hs b/Data/GraphQL/Parser.hs
index 0fb0ffc..3b72104 100644
--- a/Data/GraphQL/Parser.hs
+++ b/Data/GraphQL/Parser.hs
@@ -179,7 +179,7 @@ defaultValue = tok "=" *> value
 -- * Input Types
 
 type_ :: Parser Type
-type_ = TypeNamed   <$> name
+type_ = TypeNamed   <$> name <* but "!"
     <|> TypeList    <$> brackets type_
     <|> TypeNonNull <$> nonNullType
     <?> "type_ error!"

From d2c138f8d16acadb8ae2ba410484d985dde1e37c Mon Sep 17 00:00:00 2001
From: Danny Navarro <j@dannynavarro.net>
Date: Sun, 19 Feb 2017 15:29:58 -0300
Subject: [PATCH 10/11] Add basic Fragment Support

Only field names are supported for now.
---
 Data/GraphQL/AST/Transform.hs     | 18 ++++++++++++++----
 Data/GraphQL/Execute.hs           |  2 +-
 tests/Test/StarWars/QueryTests.hs | 23 ++++++++++++-----------
 3 files changed, 27 insertions(+), 16 deletions(-)

diff --git a/Data/GraphQL/AST/Transform.hs b/Data/GraphQL/AST/Transform.hs
index d4b1150..b08014f 100644
--- a/Data/GraphQL/AST/Transform.hs
+++ b/Data/GraphQL/AST/Transform.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
 module Data.GraphQL.AST.Transform where
 
 import Control.Applicative (empty)
@@ -23,13 +24,13 @@ type Fragmenter = Name -> [Core.Field]
 
 -- TODO: Replace Maybe by Either CustomError
 document :: Schema.Subs -> Full.Document -> Maybe Core.Document
-document subs defs = operations subs fr ops
+document subs doc = operations subs fr ops
   where
     (fr, ops) = first foldFrags
               . partitionEithers
               . NonEmpty.toList
               $ defrag subs
-            <$> defs
+            <$> doc
 
     foldFrags :: [Fragmenter] -> Fragmenter
     foldFrags fs n = getAlt $ foldMap (Alt . ($ n)) fs
@@ -93,8 +94,17 @@ fragmentDefinition subs (Full.FragmentDefinition name _tc _dirs sels) name' =
 
 field :: Schema.Subs -> Fragmenter -> Full.Field -> Maybe Core.Field
 field subs fr (Full.Field a n args _dirs sels) =
-      Core.Field a n (fold $ argument subs `traverse` args)
-  <$> traverse (hush <=< selection subs fr) sels
+        Core.Field a n (fold $ argument subs `traverse` args)
+        -- TODO: hush should error when fragments are not defined in a field
+    <$> traverse (hush <=< selection subs fr) (foldr go empty sels)
+  where
+    go :: Full.Selection -> Full.SelectionSetOpt -> Full.SelectionSetOpt
+    go (Full.SelectionFragmentSpread (Full.FragmentSpread name _dirs)) acc =
+      (Full.SelectionField . full <$> fr name) ++ acc
+    go x acc = x : acc
+
+    full :: Core.Field -> Full.Field
+    full (Core.Field a' n' _args' _sels') = Full.Field a' n' empty empty []
 
 argument :: Schema.Subs -> Full.Argument -> Maybe Core.Argument
 argument subs (Full.Argument n v) = Core.Argument n <$> value subs v
diff --git a/Data/GraphQL/Execute.hs b/Data/GraphQL/Execute.hs
index fe78323..7609561 100644
--- a/Data/GraphQL/Execute.hs
+++ b/Data/GraphQL/Execute.hs
@@ -28,7 +28,7 @@ execute
 execute schema subs doc = document schema =<< maybe empty pure (Transform.document subs doc)
 
 document :: Alternative f => Schema f -> AST.Core.Document -> f Aeson.Value
-document schema (op :| [])= operation schema op
+document schema (op :| []) = operation schema op
 document _ _ = error "Multiple operations not supported yet"
 
 operation :: Alternative f => Schema f -> AST.Core.Operation -> f Aeson.Value
diff --git a/tests/Test/StarWars/QueryTests.hs b/tests/Test/StarWars/QueryTests.hs
index 85a15a9..0456f6b 100644
--- a/tests/Test/StarWars/QueryTests.hs
+++ b/tests/Test/StarWars/QueryTests.hs
@@ -140,17 +140,18 @@ test = testGroup "Star Wars Query Tests"
       $ object [ "data" .= object [
           "human" .= object [hanName]
         ]]
-    , testCase "Invalid ID" . testQueryParams
-        (\v -> if v == "id"
-                  then Just "Not a valid ID"
-                  else Nothing)
-        [r| query humanQuery($id: String!) {
-              human(id: $id) {
-                name
-              }
-            }
-        |] $ object ["data" .= object ["human" .= object ["name" .= Aeson.Null]],
-                     "errors" .= Aeson.toJSON [object ["message" .= ("field name not resolved." :: Text)]]]
+    -- TODO: Enable after Error handling restoration
+    -- , testCase "Invalid ID" . testQueryParams
+    --     (\v -> if v == "id"
+    --               then Just "Not a valid ID"
+    --               else Nothing)
+    --     [r| query humanQuery($id: String!) {
+    --           human(id: $id) {
+    --             name
+    --           }
+    --         }
+    --     |] $ object ["data" .= object ["human" .= object ["name" .= Aeson.Null]],
+    --                  "errors" .= Aeson.toJSON [object ["message" .= ("field name not resolved." :: Text)]]]
         -- TODO: This test is directly ported from `graphql-js`, however do we want
         -- to mimic the same behavior? Is this part of the spec? Once proper
         -- exceptions are implemented this test might no longer be meaningful.

From bada28ce24dcd0fcae95ebd7dd9a9ebb106e3842 Mon Sep 17 00:00:00 2001
From: Danny Navarro <j@dannynavarro.net>
Date: Sat, 25 Feb 2017 16:46:51 -0300
Subject: [PATCH 11/11] Simplify fragment substitution

---
 Data/GraphQL/AST/Transform.hs | 34 ++++++++++++++--------------------
 1 file changed, 14 insertions(+), 20 deletions(-)

diff --git a/Data/GraphQL/AST/Transform.hs b/Data/GraphQL/AST/Transform.hs
index b08014f..af55772 100644
--- a/Data/GraphQL/AST/Transform.hs
+++ b/Data/GraphQL/AST/Transform.hs
@@ -7,8 +7,7 @@ import Data.Bifunctor (first)
 import Data.Either (partitionEithers)
 import Data.Foldable (fold, foldMap)
 import qualified Data.List.NonEmpty as NonEmpty
-import Data.Maybe (maybeToList)
-import Data.Monoid (Alt(Alt,getAlt))
+import Data.Monoid (Alt(Alt,getAlt), (<>))
 
 import Data.Text (Text)
 
@@ -22,7 +21,7 @@ type Name = Text
 --   empty list is returned.
 type Fragmenter = Name -> [Core.Field]
 
--- TODO: Replace Maybe by Either CustomError
+-- TODO: Replace Maybe by MonadThrow with CustomError
 document :: Schema.Subs -> Full.Document -> Maybe Core.Document
 document subs doc = operations subs fr ops
   where
@@ -37,6 +36,7 @@ document subs doc = operations subs fr ops
 
 -- * Operation
 
+-- TODO: Replace Maybe by MonadThrow CustomError
 operations
   :: Schema.Subs
   -> Fragmenter
@@ -44,6 +44,7 @@ operations
   -> Maybe Core.Document
 operations subs fr = NonEmpty.nonEmpty <=< traverse (operation subs fr)
 
+-- TODO: Replace Maybe by MonadThrow CustomError
 operation
   :: Schema.Subs
   -> Fragmenter
@@ -57,17 +58,17 @@ operation subs fr (Full.OperationDefinition ot _n _vars _dirs sels) =
     Full.Query    -> Core.Query    <$> node
     Full.Mutation -> Core.Mutation <$> node
   where
-    node = traverse (hush <=< selection subs fr) sels
+    node = traverse (hush . selection subs fr) sels
 
 selection
   :: Schema.Subs
   -> Fragmenter
   -> Full.Selection
-  -> Maybe (Either [Core.Field] Core.Field)
+  -> Either [Core.Field] Core.Field
 selection subs fr (Full.SelectionField fld) =
-  Right <$> field subs fr fld
+  Right $ field subs fr fld
 selection _    fr (Full.SelectionFragmentSpread (Full.FragmentSpread n _dirs)) =
-  Just . Left $ fr n
+  Left $ fr n
 selection _ _  (Full.SelectionInlineFragment _)  =
   error "Inline fragments not supported yet"
 
@@ -88,23 +89,16 @@ 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 =<< maybeToList
-                      =<< NonEmpty.toList (selection subs mempty <$> sels)
+  then either id pure =<< NonEmpty.toList (selection subs mempty <$> sels)
   else empty
 
-field :: Schema.Subs -> Fragmenter -> Full.Field -> Maybe Core.Field
+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)
-        -- TODO: hush should error when fragments are not defined in a field
-    <$> traverse (hush <=< selection subs fr) (foldr go empty sels)
+    Core.Field a n (fold $ argument subs `traverse` args) (foldr go empty sels)
   where
-    go :: Full.Selection -> Full.SelectionSetOpt -> Full.SelectionSetOpt
-    go (Full.SelectionFragmentSpread (Full.FragmentSpread name _dirs)) acc =
-      (Full.SelectionField . full <$> fr name) ++ acc
-    go x acc = x : acc
-
-    full :: Core.Field -> Full.Field
-    full (Core.Field a' n' _args' _sels') = Full.Field a' n' empty empty []
+    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