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

@@ -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.List.NonEmpty (NonEmpty)
-import Data.Text (Text, pack)
+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
+data OperationDefinition = OperationSelectionSet SelectionSet
-                         | Mutation Node
+                         | OperationDefinition   OperationType
+                                                 Name
+                                                 VariableDefinitions
+                                                 Directives
+                                                 SelectionSet
                            deriving (Eq,Show)
 
-data Node = Node Name [VariableDefinition] [Directive] SelectionSet
+data OperationType = Query | Mutation deriving (Eq,Show)
-            deriving (Eq,Show)
 
-data VariableDefinition = VariableDefinition Variable Type (Maybe DefaultValue)
+-- * SelectionSet
-                          deriving (Eq,Show)
 
-newtype Variable = Variable Name deriving (Eq,Show)
+type SelectionSet = NonEmpty Selection
 
-instance IsString Variable where
+type SelectionSetOpt = [Selection]
-    fromString = Variable . pack
 
-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
+-- * Field
---   discrete piece of information available to request within a 'SelectionSet'.
+
---
+data Field = Field (Maybe Alias) Name Arguments Directives SelectionSetOpt
---   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
              deriving (Eq,Show)
 
 type Alias = Name
 
--- | 'Field's are conceptually functions which return values, and occasionally accept
+-- * Arguments
---   'Argument's which alter their behavior. These 'Argument's often map directly to
+
---   function arguments within a @GraphQL@ server’s implementation.
+type Arguments = [Argument]
---
+
---   <https://facebook.github.io/graphql/#sec-Language.Query-Document.Arguments Argument Specification>
 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
+  FragmentDefinition FragmentName TypeCondition Directives SelectionSet
-    deriving (Eq,Show)
+  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
+           | ValueInt IntValue
-           -- GraphQL Float is double precison
+           | ValueFloat FloatValue
-           | ValueFloat Double
+           | ValueString StringValue
-           | ValueBoolean Bool
+           | ValueBoolean BooleanValue
-           | ValueString Text
+           | ValueNull
-           | ValueEnum Name
+           | 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)
+data Type = TypeNamed   Name
-
+          | TypeList    Type
--- * Type Reference
-
-data Type = TypeNamed NamedType
-          | TypeList ListType
           | TypeNonNull NonNullType
             deriving (Eq,Show)
 
-newtype NamedType = NamedType Name deriving (Eq,Show)
+data NonNullType = NonNullTypeNamed Name
-
+                 | NonNullTypeList  Type
-newtype ListType = ListType Type deriving (Eq,Show)
-
-data NonNullType = NonNullTypeNamed NamedType
-                 | NonNullTypeList  ListType
                    deriving (Eq,Show)
+
+-- * Directives
+
+type Directives = [Directive]
+
+data Directive = Directive Name [Argument] deriving (Eq,Show)

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)
 

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 (OperationSelectionSet sels) = selectionSet sels
-operationDefinition (Mutation n) = "mutation " <> node n
+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 :: Name -> VariableDefinitions -> Directives -> SelectionSet -> Text
-node (Node name vds ds ss) =
+node name vars dirs sels =
        name
-    <> optempty variableDefinitions vds
+    <> optempty variableDefinitions vars
-    <> optempty directives ds
+    <> optempty directives dirs
-    <> selectionSet ss
+    <> 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) =
+field (Field alias name args dirs selso) =
-       optempty (`snoc` ':') alias
+       optempty (`snoc` ':') (fold alias)
     <> name
     <> optempty arguments args
-    <> optempty directives ds
+    <> optempty directives dirs
-    <> optempty selectionSet ss
+    <> 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) =
+inlineFragment (InlineFragment tc dirs sels) =
-    "... on " <> tc
+    "... on " <> fold tc
-              <> optempty directives ds
+              <> directives dirs
-              <> optempty selectionSet ss
+              <> 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
+                <> optempty directives dirs
-                <> selectionSet ss
+                <> 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_ (TypeNamed   x) = x
-type_ (TypeList x) = listType x
+type_ (TypeList    x) = listType x
 type_ (TypeNonNull x) = nonNullType x
 
-namedType :: NamedType -> Text
+listType :: Type -> Text
-namedType (NamedType name) = name
+listType x = brackets (type_ x)
-
-listType :: ListType -> Text
-listType (ListType ty) = brackets (type_ ty)
 
 nonNullType :: NonNullType -> Text
-nonNullType (NonNullTypeNamed (NamedType x)) = x <> "!"
+nonNullType (NonNullTypeNamed x) = x <> "!"
 nonNullType (NonNullTypeList  x) = listType x <> "!"
 
 -- * Internal

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
+execute resolvers subs doc = undefined -- resolver resolvs $ rootFields subs doc
-  where res = Schema.resolvers 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 :: Schema.Subs -> Document -> [Field]
-rootFields subs (Document [DefinitionOperation (Query (Node _varDefs _ _ sels))]) =
+-- rootFields subs (Document [DefinitionOperation (Query (Node _varDefs _ _ sels))]) =
-    Schema.fields $ substitute subs <$> sels
+--     Schema.fields $ substitute subs <$> sels
-rootFields _ _ = []
+-- 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 :: Schema.Subs -> Selection -> Selection
-substitute subs (SelectionField (Field alias name args directives sels)) =
+-- substitute subs (SelectionField (Field alias name args directives sels)) =
-    SelectionField $ Field
+--     SelectionField $ Field
-      alias
+--       alias
-      name
+--       name
-      -- TODO: Get rid of `catMaybes`, invalid arguments should raise an error
+--       -- TODO: Get rid of `catMaybes`, invalid arguments should raise an error
-      (catMaybes $ subsArg subs <$> args)
+--       (catMaybes $ subsArg subs <$> args)
-      directives
+--       directives
-      (substitute subs <$> sels)
+--       (substitute subs <$> sels)
-substitute _ sel = sel
+-- 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 :: Schema.Subs -> Argument -> Maybe Argument
-subsArg subs (Argument n (ValueVariable (Variable v))) =
+-- subsArg subs (Argument n (ValueVariable (Variable v))) =
-    Argument n . ValueString <$> subs v
+--     Argument n . ValueString <$> subs v
-subsArg _ arg = Just arg
+-- subsArg _ arg = Just arg

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 = whiteSpace *> manyNE definition
-     *> (Document <$> many1 definition)
-    -- Try SelectionSet when no definition
-    <|> (Document . pure
-                  . DefinitionOperation
-                  . Query
-                  . Node mempty empty empty
-                <$> selectionSet)
-    <?> "document error!"
 
 definition :: Parser Definition
 definition = DefinitionOperation <$> operationDefinition
@@ -56,54 +52,48 @@ definition = DefinitionOperation <$> operationDefinition
          <?> "definition error!"
 
 operationDefinition :: Parser OperationDefinition
-operationDefinition =
+operationDefinition = OperationSelectionSet <$> selectionSet
-        Query    <$ tok "query"    <*> node
+                  <|> OperationDefinition   <$> operationType
-    <|> Mutation <$ tok "mutation" <*> node
+                                            <*> name
-    <?> "operationDefinition error!"
+                                            <*> opt variableDefinitions
+                                            <*> opt directives
+                                            <*> selectionSet
+                  <?> "operationDefinition error"
 
-node :: Parser Node
+operationType :: Parser OperationType
-node = Node <$> name
+operationType = Query    <$ tok "query"
-            <*> optempty variableDefinitions
+            <|> Mutation <$ tok "mutation"
-            <*> optempty directives
+            <?> "operationType error"
-            <*> selectionSet
 
-variableDefinitions :: Parser [VariableDefinition]
+-- * SelectionSet
-variableDefinitions = parens (many1 variableDefinition)
-
-variableDefinition :: Parser VariableDefinition
-variableDefinition =
-    VariableDefinition <$> variable
-                       <*  tok ":"
-                       <*> type_
-                       <*> optional defaultValue
-
-defaultValue :: Parser DefaultValue
-defaultValue = tok "=" *> value
-
-variable :: Parser Variable
-variable = Variable <$ tok "$" <*> name
 
 selectionSet :: Parser SelectionSet
-selectionSet = braces $ many1 selection
+selectionSet = braces $ manyNE selection
+
+selectionSetOpt :: Parser SelectionSetOpt
+selectionSetOpt = braces $ many1 selection
 
 selection :: Parser Selection
-selection = SelectionField <$> field
+selection = SelectionField          <$> field
-            -- Inline first to catch `on` case
-        <|> SelectionInlineFragment <$> inlineFragment
         <|> SelectionFragmentSpread <$> fragmentSpread
+        <|> SelectionInlineFragment <$> inlineFragment
         <?> "selection error!"
 
+-- * Field
+
 field :: Parser Field
-field = Field <$> optempty alias
+field = Field <$> optional alias
               <*> name
-              <*> optempty arguments
+              <*> opt arguments
-              <*> optempty directives
+              <*> opt directives
-              <*> optempty selectionSet
+              <*> 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`.
+fragmentSpread = FragmentSpread <$  tok "..."
--- See https://facebook.github.io/graphql/#FragmentSpread
+                                <*> fragmentName
-fragmentSpread = FragmentSpread
+                                <*> opt directives
-    <$  tok "..."
-    <*> name
-    <*> optempty directives
 
--- InlineFragment tried first in order to guard against 'on' keyword
 inlineFragment :: Parser InlineFragment
-inlineFragment = InlineFragment
+inlineFragment = InlineFragment <$  tok "..."
-    <$  tok "..."
+                                <*> optional typeCondition
-    <*  tok "on"
+                                <*> opt directives
-    <*> typeCondition
+                                <*> selectionSet
-    <*> optempty directives
-    <*> selectionSet
 
 fragmentDefinition :: Parser FragmentDefinition
 fragmentDefinition = FragmentDefinition
-    <$  tok "fragment"
+                 <$  tok "fragment"
-    <*> name
+                 <*> name
-    <*  tok "on"
+                 <*> typeCondition
-    <*> typeCondition
+                 <*> opt directives
-    <*> optempty directives
+                 <*> selectionSet
-    <*> 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     <$> enumValue
-    <|> ValueEnum     <$> name
     <|> ValueList     <$> listValue
     <|> ValueObject   <$> objectValue
     <?> "value error!"
+  where
+    booleanValue :: Parser Bool
+    booleanValue = True  <$ tok "true"
+               <|> False <$ tok "false"
 
-booleanValue :: Parser Bool
+    -- TODO: Escape characters. Look at `jsstring_` in aeson package.
-booleanValue = True  <$ tok "true"
+    stringValue :: Parser Text
-   <|> False <$ tok "false"
+    stringValue = quotes (takeWhile (/= '"'))
 
--- TODO: Escape characters. Look at `jsstring_` in aeson package.
+    enumValue :: Parser Name
-stringValue :: Parser Text
+    enumValue = but (tok "true") *> but (tok "false") *> but (tok "null") *> name
-stringValue = quotes (takeWhile (/= '"'))
 
--- Notice it can be empty
+    listValue :: Parser [Value]
-listValue :: Parser ListValue
+    listValue = brackets $ many1 value
-listValue = ListValue <$> brackets (many value)
 
--- Notice it can be empty
+    objectValue :: Parser [ObjectField]
-objectValue :: Parser ObjectValue
+    objectValue = braces $ many1 objectField
-objectValue = ObjectValue <$> braces (many 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 "@"
+        <$  tok "@"
-    <*> name
+        <*> name
-    <*> optempty arguments
+        <*> opt 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!"
 
 -- * 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`.
+opt :: Monoid a => Parser a -> Parser a
-optempty :: Monoid a => Parser a -> Parser a
+opt = option mempty
-optempty = 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 == ','

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 => Name -> [Resolver f] -> Resolver f
-object :: Alternative f => Text -> [Resolver f] -> Resolver f
 object name resolvs = objectA name $ \case
-     [] -> resolvs
+      [] -> resolvs
-     _  -> empty
+      _  -> empty
 
 -- | Like 'object' but also taking 'Argument's.
 objectA
   :: Alternative f
-  => Text -> ([Argument] -> [Resolver f]) -> Resolver f
+  => Name -> ([Argument] -> [Resolver f]) -> Resolver f
-objectA name f fld@(Field _ _ args _ sels) =
+objectA name f fld@(Field _ _ args sels) = withField name (resolvers (f args) sels) fld
-    withField name (resolvers (f args) $ fields 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
+  => Name -> ([Argument] -> f a) -> Resolver f
-scalarA name f fld@(Field _ _ args _ []) = withField name (errWrap $ f args) fld
+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) =
+arrayA name f fld@(Field _ _ args sels) =
-     withField name (joinErrs $ traverse (flip resolvers $ fields sels) $ f args) fld
+     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)
+  => Name -> CollectErrsT f a -> Field -> CollectErrsT f (HashMap Text Aeson.Value)
-withField name f (Field alias name' _ _ _) =
+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
+         aliasOrName = fromMaybe name 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

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,

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 Data.GraphQL.Schema (Schema, Resolver, Argument(..), Value(..))
-import Control.Applicative ((<$>))
-import Data.Traversable (traverse)
-#endif
-import Data.GraphQL.Schema
 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

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
+kitchenTest :: IO TestTree
-ksTest = testCase "Kitchen Sink"
+kitchenTest = testCase "Kitchen Sink"
      <$> (assertEqual "Encode" <$> expected <*> actual)
   where
     expected = Text.readFile