Add GraphQL parser

WIP: This parser just type checks, it hasn't even been tested manually.
Check new tasks in the TODO file and the TODO comments in the code for
more gotchas.

3 files changed, 308 insertions, 1 deletions

diff --git a/Data/GraphQL/Parser.hs b/Data/GraphQL/Parser.hs
new file mode 100644
index 0000000..db6091b
--- /dev/null
+++ b/Data/GraphQL/Parser.hs
@@ -0,0 +1,298 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Data.GraphQL.Parser where
+
+import Prelude hiding (takeWhile)
+import Control.Applicative (Alternative, (<|>), empty, many)
+import Data.Char
+
+import Data.Attoparsec.Text.Lazy
+  ( Parser
+  , (<?>)
+  , anyChar
+  , decimal
+  , double
+  , isEndOfLine
+  , many1
+  , manyTill
+  , satisfy
+  , sepBy
+  , sepBy1
+  , skipSpace
+  , skipWhile
+  , signed
+  , space
+  , takeWhile
+  , takeWhile1
+  )
+
+import Data.GraphQL.AST
+
+-- * Name
+
+-- XXX: Handle starting `_` and no number at the beginning:
+-- https://facebook.github.io/graphql/#sec-Names
+name :: Parser Name
+name = takeWhile1 isAlphaNum
+
+-- * Document
+
+document :: Parser Document
+document = s *>
+    (Document <$> many1_ definition
+             -- Try SelectionSet when no definition
+              <|> Document <$> pure
+                           <$> DefinitionOperation
+                           <$> Query mempty empty empty
+                           <$> selectionSet)
+    <*  s
+    <?> "document error!"
+
+definition :: Parser Definition
+definition = DefinitionOperation <$> operationDefinition
+         <|> DefinitionFragment  <$> fragmentDefinition
+         <|> DefinitionType      <$> typeDefinition
+         <?> "definition error!"
+
+operationDefinition :: Parser OperationDefinition
+operationDefinition =
+        op Query "query"
+    <|> op Mutation "mutation"
+    <?> "operationDefinition error!"
+  where
+    op f n = f <$ n <* s1 <*> name <* s1
+                          <*> (variableDefinitions <* s <|> empty)
+                          <*> directives <* s
+                          <*> selectionSet
+
+variableDefinitions :: Parser [VariableDefinition]
+variableDefinitions = "(" *> s *> many1_ variableDefinition <* s <* ")"
+
+variableDefinition :: Parser VariableDefinition
+variableDefinition =
+    VariableDefinition <$> variable <* s <*  ":" <* s
+                       <*> type_ <* s
+                       <*> value
+
+ -- In defense of good taste, I'm taking liberty of not allowing space between
+ -- '$' and the 'name' even though that's not in the spec.
+variable :: Parser Variable
+variable = Variable <$ "$" <*> name
+
+selectionSet :: Parser SelectionSet
+selectionSet = "{" *> s *> (SelectionSet <$> many1_ selection) <* s <* "}"
+
+selection :: Parser Selection
+selection = SelectionField <$> field
+            -- Inline first to catch `on` case
+        <|> SelectionInlineFragment <$> inlineFragment
+        <|> SelectionFragmentSpread <$> fragmentSpread
+        <?> "selection error!"
+
+field :: Parser Field
+field = Field <$> (alias <* s1 <|> empty)
+              <*> name <* s
+              <*> (arguments <* s <|> empty)
+              <*> directives <* s
+              <*> selectionSet
+              <?> "field error!"
+
+alias :: Parser Alias
+alias = name <* s <* ":"
+
+arguments :: Parser [Argument]
+arguments = "(" *> s *> many1_ argument <* s <* ")"
+
+argument :: Parser Argument
+argument = Argument <$> name <* s <* ":" <* s <*> value
+
+-- * Fragments
+
+fragmentSpread :: Parser FragmentSpread
+-- TODO: Make sure it fails when `... on`.
+-- See https://facebook.github.io/graphql/#FragmentSpread
+fragmentSpread = FragmentSpread <$ "..." <* s <*> name <* s1 <*> many_ directive
+
+-- InlineFragment tried first in order to guard against 'on' keyword
+inlineFragment :: Parser InlineFragment
+inlineFragment = InlineFragment <$ "..." <* s <* "on" <* s1
+             <*> typeCondition <* s
+             <*> directives <* s
+             <*> selectionSet
+
+fragmentDefinition :: Parser FragmentDefinition
+fragmentDefinition =
+    FragmentDefinition <$  "fragment" <* s1
+                       <*> name <* s
+                       <*  "on" <* s1
+                       <*> typeCondition <* s
+                       <*> directives <* s
+                       <*> selectionSet
+
+typeCondition :: Parser TypeCondition
+typeCondition = namedType
+
+-- * Values
+
+-- This will try to pick the first type it can parse. If you are working with
+--   explicit types use the `typedValue` parser.
+value :: Parser Value
+value = -- TODO: Handle arbitrary precision.
+        ValueInt     <$> signed decimal
+    <|> ValueFloat   <$> signed double
+    <|> ValueBoolean <$> bool
+    -- TODO: Handle escape characters, unicode, etc
+    <|> ValueString <$ "\"" <*> takeWhile isAlphaNum <* "\""
+    -- `true` and `false` have been tried before
+    <|> ValueEnum <$> name
+    <|> ValueList <$> listValue
+    <|> ValueObject <$> objectValue
+
+-- Notice it can be empty
+listValue :: Parser ListValue
+listValue = ListValue <$ "[" <* s <*> many_ value <* s <* "]"
+
+-- Notice it can be empty
+objectValue :: Parser ObjectValue
+objectValue = ObjectValue <$ "{" <* s <*> many_ objectField <* s <* "}"
+
+objectField :: Parser ObjectField
+objectField = ObjectField <$> name <* s <* ":" <* s <*> value
+
+bool :: Parser Bool
+bool = True  <$ "true"
+   <|> False <$ "false"
+
+-- * Directives
+
+directives :: Parser [Directive]
+directives = many_ directive
+
+directive :: Parser Directive
+directive = Directive <$ "@" <*> name <* s <*> arguments
+
+-- * Type Reference
+
+type_ :: Parser Type
+type_ = TypeNamed   <$> namedType
+    <|> TypeList    <$> listType
+    <|> TypeNonNull <$> nonNullType
+
+namedType :: Parser NamedType
+namedType = NamedType <$> name
+
+listType :: Parser ListType
+listType = ListType <$ "[" <* s <*> type_ <* s <* "]"
+
+nonNullType :: Parser NonNullType
+nonNullType = NonNullTypeNamed <$> namedType <* s <* "!"
+          <|> NonNullTypeList  <$> listType  <* s <* "!"
+
+-- * Type Definition
+
+-- TODO: what is Const Variable?
+-- https://facebook.github.io/graphql/#Value
+typeDefinition :: Parser TypeDefinition
+typeDefinition =
+        TypeDefinitionObject        <$> objectTypeDefinition
+    <|> TypeDefinitionInterface     <$> interfaceTypeDefinition
+    <|> TypeDefinitionUnion         <$> unionTypeDefinition
+    <|> TypeDefinitionScalar        <$> scalarTypeDefinition
+    <|> TypeDefinitionEnum          <$> enumTypeDefinition
+    <|> TypeDefinitionInputObject   <$> inputObjectTypeDefinition
+    <|> TypeDefinitionTypeExtension <$> typeExtensionDefinition
+    <?> "typeDefinition error!"
+
+objectTypeDefinition :: Parser ObjectTypeDefinition
+objectTypeDefinition = ObjectTypeDefinition
+    <$  "type" <* s1
+    <*> name <* s1
+    <*> (interfaces <* s <|> empty)
+    <*> fieldDefinitions
+    <?> "objectTypeDefinition error!"
+
+interfaces :: Parser Interfaces
+interfaces = "implements" *> s1 *> many1_ namedType
+
+fieldDefinitions :: Parser [FieldDefinition]
+fieldDefinitions = "{" *> s *> many1_ fieldDefinition <* s <* "}"
+
+fieldDefinition :: Parser FieldDefinition
+fieldDefinition = FieldDefinition
+    <$> name <* s
+    <*> (argumentsDefinition <* s <|> empty)
+    <*  ":" <* s
+    <*> type_
+
+argumentsDefinition :: Parser ArgumentsDefinition
+argumentsDefinition = inputValueDefinitions
+
+inputValueDefinitions :: Parser [InputValueDefinition]
+inputValueDefinitions = "(" *> s *> many1_ inputValueDefinition <* s <* ")"
+
+inputValueDefinition :: Parser InputValueDefinition
+inputValueDefinition = InputValueDefinition
+    <$> name <* s
+    <*  ":" <* s
+    <*> type_ <* s
+    <*> (value <|> empty)
+
+interfaceTypeDefinition :: Parser InterfaceTypeDefinition
+interfaceTypeDefinition = InterfaceTypeDefinition
+    <$  "interface" <* s1
+    <*> name <* s
+    <*> fieldDefinitions
+
+unionTypeDefinition :: Parser UnionTypeDefinition
+unionTypeDefinition = UnionTypeDefinition
+    <$  "union" <* s1
+    <*> name <* s
+    <*> unionMembers
+  where
+    -- This should take care of standalone `NamedType`
+    unionMembers = namedType `sepBy1` (s *> "|" <* s)
+
+scalarTypeDefinition :: Parser ScalarTypeDefinition
+scalarTypeDefinition = ScalarTypeDefinition <$  "scalar" <* s1 <*> name
+
+enumTypeDefinition :: Parser EnumTypeDefinition
+enumTypeDefinition = EnumTypeDefinition
+    <$  "enum" <* s1
+    <*> name <* s
+    <*> enumValueDefinitions
+
+enumValueDefinitions :: Parser [EnumValueDefinition]
+enumValueDefinitions = "{" *> s *> many1_ enumValueDefinition <* s <* "}"
+
+enumValueDefinition :: Parser EnumValueDefinition
+enumValueDefinition = EnumValueDefinition <$> name
+
+inputObjectTypeDefinition :: Parser InputObjectTypeDefinition
+inputObjectTypeDefinition = InputObjectTypeDefinition
+    <$  "input" <* s1
+    <*> name <* s
+    <*> inputValueDefinitions
+
+typeExtensionDefinition :: Parser TypeExtensionDefinition
+typeExtensionDefinition = TypeExtensionDefinition
+    <$  "extend" <* s1
+    <*> objectTypeDefinition
+
+-- * Internal
+
+many_ :: Parser a -> Parser [a]
+many_ = flip sepBy space'
+
+many1_ :: Parser a -> Parser [a]
+many1_ = flip sepBy1 space'
+
+space' :: Parser Char
+space' = satisfy isSpace'
+
+s :: Parser ()
+s = skipWhile isSpace'
+
+s1 :: Parser ()
+s1 = space' *> s
+
+isSpace' :: Char -> Bool
+isSpace' c = isSpace c || ',' == c || isEndOfLine c
diff --git a/TODO b/TODO
index 6002a0a..ec125a1 100644
--- a/TODO
+++ b/TODO
@@ -1,3 +1,10 @@
+## AST
 - Data type accessors
 - Deal with Location
 - Deal with Strictness/unboxing
+
+## Parser
+- Guard `type_` and `value` match when used together
+- Tests!
+- Simplify unnecessary `newtypes` with type synonyms
+- Handle errors
diff --git a/graphql.cabal b/graphql.cabal
index 2319318..98914ed 100644
--- a/graphql.cabal
+++ b/graphql.cabal
@@ -18,8 +18,10 @@ cabal-version:       >=1.10
 
 library
   exposed-modules:     Data.GraphQL.AST
+                       Data.GraphQL.Parser
   build-depends:       base >= 4.7 && < 5,
-                       text >=0.11.3.1
+                       text >=0.11.3.1,
+                       attoparsec >=0.10.4.0
   default-language:    Haskell2010
 
 source-repository head