Parse complete TypeSystemDefinition

6 files changed, 78 insertions, 21 deletions

diff --git a/CHANGELOG.md b/CHANGELOG.md
index 21d2ef4..d48c39f 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -9,7 +9,7 @@ and this project adheres to
 ## [Unreleased]
 ### Added
 - AST for the GraphQL schema.
-- Parser for the SchemaDefinition and TypeDefinition.
+- Parser for the TypeSystemDefinition.
 - `Trans.argument`.
 
 ### Changed
diff --git a/src/Language/GraphQL/AST/Document.hs b/src/Language/GraphQL/AST/Document.hs
index 9b156b2..9348a45 100644
--- a/src/Language/GraphQL/AST/Document.hs
+++ b/src/Language/GraphQL/AST/Document.hs
@@ -248,7 +248,7 @@ data TypeSystemDefinition
     = SchemaDefinition [Directive] OperationTypeDefinitions
     | TypeDefinition TypeDefinition
     | DirectiveDefinition
-        Description Name ArgumentsDefinition DirectiveLocation
+        Description Name ArgumentsDefinition (NonEmpty DirectiveLocation)
     deriving (Eq, Show)
 
 -- ** Type System Extensions
diff --git a/src/Language/GraphQL/AST/Lexer.hs b/src/Language/GraphQL/AST/Lexer.hs
index 1cb3363..c2ed35c 100644
--- a/src/Language/GraphQL/AST/Lexer.hs
+++ b/src/Language/GraphQL/AST/Lexer.hs
@@ -51,6 +51,7 @@ import Text.Megaparsec ( Parsec
                        )
 import Text.Megaparsec.Char (char, digitChar, space1)
 import qualified Text.Megaparsec.Char.Lexer as Lexer
+import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.Lazy as TL
 
@@ -87,8 +88,8 @@ dollar :: Parser T.Text
 dollar = symbol "$"
 
 -- | Parser for "@".
-at :: Parser Char
-at = char '@'
+at :: Parser Text
+at = symbol "@"
 
 -- | Parser for "&".
 amp :: Parser T.Text
diff --git a/src/Language/GraphQL/AST/Parser.hs b/src/Language/GraphQL/AST/Parser.hs
index bb8a273..b969b35 100644
--- a/src/Language/GraphQL/AST/Parser.hs
+++ b/src/Language/GraphQL/AST/Parser.hs
@@ -9,7 +9,14 @@ module Language.GraphQL.AST.Parser
 import Control.Applicative (Alternative(..), optional)
 import Control.Applicative.Combinators (sepBy1)
 import qualified Control.Applicative.Combinators.NonEmpty as NonEmpty
+import Data.List.NonEmpty (NonEmpty)
 import Data.Text (Text)
+import qualified Language.GraphQL.AST.DirectiveLocation as Directive
+import Language.GraphQL.AST.DirectiveLocation
+    ( DirectiveLocation
+    , ExecutableDirectiveLocation
+    , TypeSystemDirectiveLocation
+    )
 import Language.GraphQL.AST.Document
 import Language.GraphQL.AST.Lexer
 import Text.Megaparsec (lookAhead, option, try, (<?>))
@@ -33,8 +40,50 @@ executableDefinition = DefinitionOperation <$> operationDefinition
 typeSystemDefinition :: Parser TypeSystemDefinition
 typeSystemDefinition = schemaDefinition
     <|> TypeDefinition <$> typeDefinition
+    <|> directiveDefinition
     <?> "TypeSystemDefinition"
 
+directiveDefinition :: Parser TypeSystemDefinition
+directiveDefinition = DirectiveDefinition
+    <$> description
+    <* symbol "directive"
+    <* at
+    <*> name
+    <*> argumentsDefinition
+    <* symbol "on"
+    <*> directiveLocations
+
+directiveLocations :: Parser (NonEmpty DirectiveLocation)
+directiveLocations = optional pipe
+    *> directiveLocation `NonEmpty.sepBy1` pipe
+
+directiveLocation :: Parser DirectiveLocation
+directiveLocation
+    = Directive.ExecutableDirectiveLocation <$> executableDirectiveLocation
+    <|> Directive.TypeSystemDirectiveLocation <$> typeSystemDirectiveLocation
+
+executableDirectiveLocation :: Parser ExecutableDirectiveLocation
+executableDirectiveLocation = Directive.Query <$ symbol "QUERY"
+    <|> Directive.Mutation <$ symbol "MUTATION"
+    <|> Directive.Subscription <$ symbol "SUBSCRIPTION"
+    <|> Directive.Field <$ symbol "FIELD"
+    <|> Directive.FragmentDefinition <$ "FRAGMENT_DEFINITION"
+    <|> Directive.FragmentSpread <$ "FRAGMENT_SPREAD"
+    <|> Directive.InlineFragment <$ "INLINE_FRAGMENT"
+
+typeSystemDirectiveLocation :: Parser TypeSystemDirectiveLocation
+typeSystemDirectiveLocation = Directive.Schema <$ symbol "SCHEMA"
+    <|> Directive.Scalar <$ symbol "SCALAR"
+    <|> Directive.Object <$ symbol "OBJECT"
+    <|> Directive.FieldDefinition <$ symbol "FIELD_DEFINITION"
+    <|> Directive.ArgumentDefinition <$ symbol "ARGUMENT_DEFINITION"
+    <|> Directive.Interface <$ symbol "INTERFACE"
+    <|> Directive.Union <$ symbol "UNION"
+    <|> Directive.Enum <$ symbol "ENUM"
+    <|> Directive.EnumValue <$ symbol "ENUM_VALUE"
+    <|> Directive.InputObject <$ symbol "INPUT_OBJECT"
+    <|> Directive.InputFieldDefinition <$ symbol "INPUT_FIELD_DEFINITION"
+
 typeDefinition :: Parser TypeDefinition
 typeDefinition = scalarTypeDefinition
     <|> objectTypeDefinition
@@ -49,7 +98,7 @@ scalarTypeDefinition = ScalarTypeDefinition
     <$> description
     <* symbol "scalar"
     <*> name
-    <*> opt directives
+    <*> directives
     <?> "ScalarTypeDefinition"
 
 objectTypeDefinition :: Parser TypeDefinition
@@ -58,7 +107,7 @@ objectTypeDefinition = ObjectTypeDefinition
     <* symbol "type"
     <*> name
     <*> option (ImplementsInterfaces []) (implementsInterfaces sepBy1)
-    <*> opt directives
+    <*> directives
     <*> braces (many fieldDefinition)
     <?> "ObjectTypeDefinition"
 
@@ -72,7 +121,7 @@ unionTypeDefinition = UnionTypeDefinition
     <$> description
     <* symbol "union"
     <*> name
-    <*> opt directives
+    <*> directives
     <*> option (UnionMemberTypes []) (unionMemberTypes sepBy1)
     <?> "UnionTypeDefinition"
 
@@ -91,7 +140,7 @@ interfaceTypeDefinition = InterfaceTypeDefinition
     <$> description
     <* symbol "interface"
     <*> name
-    <*> opt directives
+    <*> directives
     <*> braces (many fieldDefinition)
     <?> "InterfaceTypeDefinition"
 
@@ -100,28 +149,28 @@ enumTypeDefinition = EnumTypeDefinition
     <$> description
     <* symbol "enum"
     <*> name
-    <*> opt directives
-    <*> opt enumValuesDefinition
+    <*> directives
+    <*> enumValuesDefinition
     <?> "EnumTypeDefinition"
   where
-    enumValuesDefinition = braces (some enumValueDefinition)
+    enumValuesDefinition = listOptIn braces enumValueDefinition
 
 inputObjectTypeDefinition :: Parser TypeDefinition
 inputObjectTypeDefinition = InputObjectTypeDefinition
     <$> description
     <* symbol "input"
     <*> name
-    <*> opt directives
-    <*> opt inputFieldsDefinition
+    <*> directives
+    <*> inputFieldsDefinition
     <?> "InputObjectTypeDefinition"
   where
-    inputFieldsDefinition = braces (some inputValueDefinition)
+    inputFieldsDefinition = listOptIn braces inputValueDefinition
 
 enumValueDefinition :: Parser EnumValueDefinition
 enumValueDefinition = EnumValueDefinition
     <$> description
     <*> enumValue
-    <*> opt directives
+    <*> directives
     <?> "EnumValueDefinition"
 
 implementsInterfaces ::
@@ -141,28 +190,28 @@ inputValueDefinition = InputValueDefinition
     <* colon
     <*> type'
     <*> defaultValue
-    <*> opt directives
+    <*> directives
     <?> "InputValueDefinition"
 
 argumentsDefinition :: Parser ArgumentsDefinition
 argumentsDefinition = ArgumentsDefinition
-    <$> parens (many inputValueDefinition)
+    <$> listOptIn parens inputValueDefinition
     <?> "ArgumentsDefinition"
 
 fieldDefinition :: Parser FieldDefinition
 fieldDefinition = FieldDefinition
     <$> description
     <*> name
-    <*> opt argumentsDefinition
+    <*> argumentsDefinition
     <* colon
     <*> type'
-    <*> opt directives
+    <*> directives
     <?> "FieldDefinition"
 
 schemaDefinition :: Parser TypeSystemDefinition
 schemaDefinition = SchemaDefinition
     <$ symbol "schema"
-    <*> opt directives
+    <*> directives
     <*> operationTypeDefinitions
     <?> "SchemaDefinition"
   where
diff --git a/tests/Language/GraphQL/AST/LexerSpec.hs b/tests/Language/GraphQL/AST/LexerSpec.hs
index a0acb9f..402ed02 100644
--- a/tests/Language/GraphQL/AST/LexerSpec.hs
+++ b/tests/Language/GraphQL/AST/LexerSpec.hs
@@ -77,7 +77,7 @@ spec = describe "Lexer" $ do
             parse spread "" "..." `shouldParse` "..."
             parse colon "" ":" `shouldParse` ":"
             parse equals "" "=" `shouldParse` "="
-            parse at "" "@" `shouldParse` '@'
+            parse at "" "@" `shouldParse` "@"
             runBetween brackets `shouldSucceedOn` "[]"
             runBetween braces `shouldSucceedOn` "{}"
             parse pipe "" "|" `shouldParse` "|"
diff --git a/tests/Language/GraphQL/AST/ParserSpec.hs b/tests/Language/GraphQL/AST/ParserSpec.hs
index e561863..2e55389 100644
--- a/tests/Language/GraphQL/AST/ParserSpec.hs
+++ b/tests/Language/GraphQL/AST/ParserSpec.hs
@@ -109,3 +109,10 @@ spec = describe "Parser" $ do
               y: Float
             }
         |]
+
+    it "parses minimal input enum definition with an optional pipe" $
+        parse document "" `shouldSucceedOn` [r|
+            directive @example on
+              | FIELD
+              | FRAGMENT_SPREAD
+        |]