2 files changed, 465 insertions, 0 deletions
diff --git a/Data/GraphQL/AST.hs b/Data/GraphQL/AST.hs
new file mode 100644
index 0000000..0a09671
--- /dev/null
+++ b/Data/GraphQL/AST.hs
@@ -0,0 +1,143 @@
+module Data.GraphQL.AST where
+
+import Data.Text (Text)
+
+-- * Name
+
+type Name = Text
+
+-- * Document
+
+newtype Document = Document [Definition] deriving (Eq,Show)
+
+data Definition = DefinitionOperation OperationDefinition
+                | DefinitionFragment  FragmentDefinition
+                | DefinitionType      TypeDefinition
+                  deriving (Eq,Show)
+
+data OperationDefinition =
+    Query        Name [VariableDefinition] [Directive] SelectionSet
+  | Mutation     Name [VariableDefinition] [Directive] SelectionSet
+  -- Not official yet
+  -- -- | Subscription Name [VariableDefinition] [Directive] SelectionSet
+    deriving (Eq,Show)
+
+data VariableDefinition = VariableDefinition Variable Type (Maybe DefaultValue)
+                          deriving (Eq,Show)
+
+newtype Variable = Variable Name deriving (Eq,Show)
+
+type SelectionSet = [Selection]
+
+data Selection = SelectionField Field
+               | SelectionFragmentSpread FragmentSpread
+               | SelectionInlineFragment InlineFragment
+                 deriving (Eq,Show)
+
+data Field = Field Alias Name [Argument]
+                              [Directive]
+                              SelectionSet
+             deriving (Eq,Show)
+
+type Alias = Name
+
+data Argument = Argument Name Value deriving (Eq,Show)
+
+-- * Fragments
+
+data FragmentSpread = FragmentSpread Name [Directive]
+                      deriving (Eq,Show)
+
+data InlineFragment =
+    InlineFragment TypeCondition [Directive] SelectionSet
+    deriving (Eq,Show)
+
+data FragmentDefinition =
+    FragmentDefinition Name TypeCondition [Directive] SelectionSet
+    deriving (Eq,Show)
+
+type TypeCondition = NamedType
+
+-- * Values
+
+data Value = ValueVariable Variable
+           | ValueInt Int -- TODO: Should this be `Integer`?
+           | ValueFloat Double -- TODO: Should this be `Scientific`?
+           | ValueBoolean Bool
+           | ValueString Text
+           | ValueEnum Name
+           | ValueList ListValue
+           | ValueObject ObjectValue
+             deriving (Eq,Show)
+
+newtype ListValue = ListValue [Value] deriving (Eq,Show)
+
+newtype ObjectValue = ObjectValue [ObjectField] deriving (Eq,Show)
+
+data ObjectField = ObjectField Name Value deriving (Eq,Show)
+
+type DefaultValue = Value
+
+-- * Directives
+
+data Directive = Directive Name [Argument] deriving (Eq,Show)
+
+-- * Type Reference
+
+data Type = TypeNamed NamedType
+          | TypeList ListType
+          | 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
+                   deriving (Eq,Show)
+
+-- * Type definition
+
+data TypeDefinition = TypeDefinitionObject        ObjectTypeDefinition
+                    | TypeDefinitionInterface     InterfaceTypeDefinition
+                    | TypeDefinitionUnion         UnionTypeDefinition
+                    | TypeDefinitionScalar        ScalarTypeDefinition
+                    | TypeDefinitionEnum          EnumTypeDefinition
+                    | TypeDefinitionInputObject   InputObjectTypeDefinition
+                    | TypeDefinitionTypeExtension TypeExtensionDefinition
+                      deriving (Eq,Show)
+
+data ObjectTypeDefinition = ObjectTypeDefinition Name Interfaces [FieldDefinition]
+                            deriving (Eq,Show)
+
+type Interfaces = [NamedType]
+
+data FieldDefinition = FieldDefinition Name ArgumentsDefinition Type
+                       deriving (Eq,Show)
+
+type ArgumentsDefinition = [InputValueDefinition]
+
+data InputValueDefinition = InputValueDefinition Name Type (Maybe DefaultValue)
+                            deriving (Eq,Show)
+
+data InterfaceTypeDefinition = InterfaceTypeDefinition Name [FieldDefinition]
+                               deriving (Eq,Show)
+
+data UnionTypeDefinition = UnionTypeDefinition Name [NamedType]
+                           deriving (Eq,Show)
+
+data ScalarTypeDefinition = ScalarTypeDefinition Name
+                            deriving (Eq,Show)
+
+data EnumTypeDefinition = EnumTypeDefinition Name [EnumValueDefinition]
+                          deriving (Eq,Show)
+
+newtype EnumValueDefinition = EnumValueDefinition Name
+                              deriving (Eq,Show)
+
+data InputObjectTypeDefinition = InputObjectTypeDefinition Name [InputValueDefinition]
+                                 deriving (Eq,Show)
+
+newtype TypeExtensionDefinition = TypeExtensionDefinition ObjectTypeDefinition
+                                  deriving (Eq,Show)
diff --git a/Data/GraphQL/Parser.hs b/Data/GraphQL/Parser.hs
new file mode 100644
index 0000000..66d913d
--- /dev/null
+++ b/Data/GraphQL/Parser.hs
@@ -0,0 +1,322 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
+module Data.GraphQL.Parser where
+
+import Prelude hiding (takeWhile)
+import Control.Applicative ((<|>), empty, many, optional)
+import Control.Monad (when)
+import Data.Char
+
+import Data.Text (Text, pack)
+import Data.Attoparsec.Text
+  ( Parser
+  , (<?>)
+  , anyChar
+  , decimal
+  , double
+  , endOfLine
+  , many1
+  , manyTill
+  , option
+  , peekChar
+  , satisfy
+  , sepBy1
+  , signed
+  )
+
+import Data.GraphQL.AST
+
+-- * Name
+
+-- XXX: Handle starting `_` and no number at the beginning:
+-- https://facebook.github.io/graphql/#sec-Names
+-- TODO: Use takeWhile1 instead for efficiency. With takeWhile1 there is no
+-- parsing failure.
+name :: Parser Name
+name = tok $ pack <$> many1 (satisfy isAlphaNum)
+
+-- * Document
+
+document :: Parser Document
+document = whiteSpace
+     *> (Document <$> many1 definition)
+    -- Try SelectionSet when no definition
+    <|> (Document . pure
+                  . DefinitionOperation
+                  . Query mempty empty empty
+                <$> selectionSet)
+    <?> "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 <$ tok n <*> tok name
+                        <*> optempty variableDefinitions
+                        <*> optempty directives
+                        <*> selectionSet
+
+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 :: Parser SelectionSet
+selectionSet = braces $ many1 selection
+
+selection :: Parser Selection
+selection = SelectionField <$> field
+            -- Inline first to catch `on` case
+        <|> SelectionInlineFragment <$> inlineFragment
+        <|> SelectionFragmentSpread <$> fragmentSpread
+        <?> "selection error!"
+
+field :: Parser Field
+field = Field <$> optempty alias
+              <*> name
+              <*> optempty arguments
+              <*> optempty directives
+              <*> optempty selectionSet
+
+alias :: Parser Alias
+alias = name <* tok ":"
+
+arguments :: Parser [Argument]
+arguments = parens $ many1 argument
+
+argument :: Parser Argument
+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
+
+-- InlineFragment tried first in order to guard against 'on' keyword
+inlineFragment :: Parser InlineFragment
+inlineFragment = InlineFragment
+    <$  tok "..."
+    <*  tok "on"
+    <*> typeCondition
+    <*> optempty directives
+    <*> selectionSet
+
+fragmentDefinition :: Parser FragmentDefinition
+fragmentDefinition = FragmentDefinition
+    <$  tok "fragment"
+    <*> name
+    <*  tok "on"
+    <*> typeCondition
+    <*> optempty directives
+    <*> 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 = ValueVariable <$> variable
+        -- TODO: Handle arbitrary precision.
+    <|> ValueInt     <$> tok (signed decimal)
+    <|> ValueFloat   <$> tok (signed double)
+    <|> ValueBoolean <$> bool
+    -- TODO: Handle escape characters, unicode, etc
+    <|> ValueString  <$> quotes name
+    -- `true` and `false` have been tried before
+    <|> ValueEnum    <$> name
+    <|> ValueList    <$> listValue
+    <|> ValueObject  <$> objectValue
+
+-- Notice it can be empty
+listValue :: Parser ListValue
+listValue = ListValue <$> brackets (many value)
+
+-- Notice it can be empty
+objectValue :: Parser ObjectValue
+objectValue = ObjectValue <$> braces (many objectField)
+
+objectField :: Parser ObjectField
+objectField = ObjectField <$> name <* tok ":" <*> value
+
+bool :: Parser Bool
+bool = True  <$ tok "true"
+   <|> False <$ tok "false"
+
+-- * Directives
+
+directives :: Parser [Directive]
+directives = many1 directive
+
+directive :: Parser Directive
+directive = Directive
+    <$  tok "@"
+    <*> name
+    <*> optempty arguments
+
+-- * Type Reference
+
+type_ :: Parser Type
+type_ = TypeNamed   <$> namedType
+    <|> TypeList    <$> listType
+    <|> TypeNonNull <$> nonNullType
+
+namedType :: Parser NamedType
+namedType = NamedType <$> name
+
+listType :: Parser ListType
+listType = ListType <$> brackets type_
+
+nonNullType :: Parser NonNullType
+nonNullType = NonNullTypeNamed <$> namedType <* tok "!"
+          <|> NonNullTypeList  <$> listType  <* tok "!"
+
+-- * Type Definition
+
+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
+    <$  tok "type"
+    <*> name
+    <*> optempty interfaces
+    <*> fieldDefinitions
+    <?> "objectTypeDefinition error!"
+
+interfaces :: Parser Interfaces
+interfaces = tok "implements" *> many1 namedType
+
+fieldDefinitions :: Parser [FieldDefinition]
+fieldDefinitions = braces $ many1 fieldDefinition
+
+fieldDefinition :: Parser FieldDefinition
+fieldDefinition = FieldDefinition
+    <$> name
+    <*> optempty argumentsDefinition
+    <*  tok ":"
+    <*> type_
+
+argumentsDefinition :: Parser ArgumentsDefinition
+argumentsDefinition = inputValueDefinitions
+
+inputValueDefinitions :: Parser [InputValueDefinition]
+inputValueDefinitions = parens $ many1 inputValueDefinition
+
+inputValueDefinition :: Parser InputValueDefinition
+inputValueDefinition = InputValueDefinition
+    <$> name
+    <*  tok ":"
+    <*> type_
+    <*> optional defaultValue
+
+interfaceTypeDefinition :: Parser InterfaceTypeDefinition
+interfaceTypeDefinition = InterfaceTypeDefinition
+    <$  tok "interface"
+    <*> name
+    <*> fieldDefinitions
+
+unionTypeDefinition :: Parser UnionTypeDefinition
+unionTypeDefinition = UnionTypeDefinition
+    <$  tok "union"
+    <*> name
+    <*  tok "="
+    <*> unionMembers
+
+unionMembers :: Parser [NamedType]
+unionMembers = namedType `sepBy1` tok "|"
+
+scalarTypeDefinition :: Parser ScalarTypeDefinition
+scalarTypeDefinition = ScalarTypeDefinition
+    <$  tok "scalar"
+    <*> name
+
+enumTypeDefinition :: Parser EnumTypeDefinition
+enumTypeDefinition = EnumTypeDefinition
+    <$  tok "enum"
+    <*> name
+    <*> enumValueDefinitions
+
+enumValueDefinitions :: Parser [EnumValueDefinition]
+enumValueDefinitions = braces $ many1 enumValueDefinition
+
+enumValueDefinition :: Parser EnumValueDefinition
+enumValueDefinition = EnumValueDefinition <$> name
+
+inputObjectTypeDefinition :: Parser InputObjectTypeDefinition
+inputObjectTypeDefinition = InputObjectTypeDefinition
+    <$  tok "input"
+    <*> name
+    <*> inputValueDefinitions
+
+typeExtensionDefinition :: Parser TypeExtensionDefinition
+typeExtensionDefinition = TypeExtensionDefinition
+    <$  tok "extend"
+    <*> objectTypeDefinition
+
+-- * Internal
+
+tok :: Parser a -> Parser a
+tok p = p <* whiteSpace
+
+parens :: Parser a -> Parser a
+parens = between "(" ")"
+
+braces :: Parser a -> Parser a
+braces = between "{" "}"
+
+quotes :: Parser a -> Parser a
+quotes = between "\"" "\""
+
+brackets :: Parser a -> Parser a
+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
+
+-- ** WhiteSpace
+--
+whiteSpace :: Parser ()
+whiteSpace = peekChar >>= \case
+    Just c -> if isSpace c || c == ','
+              then anyChar *> whiteSpace
+              else when (c == '#') $ manyTill anyChar endOfLine *> whiteSpace
+    _ -> return ()