Parse repeatable directive definitions

CHANGELOG.md

@@ -9,7 +9,7 @@ and this project adheres to
 ## [Unreleased]
 ### Changed
 - `Schema.Directive` is extended to contain a boolean argument, representing
-  repeatable directives.
+  repeatable directives. The parser can parse repeatable directive definitions.
 
 ### Fixed
 - `gql` quasi quoter recognizeds all GraphQL line endings (CR, LF and CRLF).

src/Language/GraphQL/AST/Document.hs

@@ -405,7 +405,7 @@ data TypeSystemDefinition
     = SchemaDefinition [Directive] (NonEmpty OperationTypeDefinition)
     | TypeDefinition TypeDefinition
     | DirectiveDefinition
-        Description Name ArgumentsDefinition (NonEmpty DirectiveLocation)
+        Description Name ArgumentsDefinition Bool (NonEmpty DirectiveLocation)
     deriving (Eq, Show)
 
 -- ** Type System Extensions

src/Language/GraphQL/AST/Encoder.hs

@@ -159,11 +159,12 @@ typeSystemDefinition formatter = \case
             <> optempty (directives formatter) operationDirectives
             <> bracesList formatter (operationTypeDefinition formatter) (NonEmpty.toList operationTypeDefinitions')
     Full.TypeDefinition typeDefinition' -> typeDefinition formatter typeDefinition'
-    Full.DirectiveDefinition description' name' arguments' locations
+    Full.DirectiveDefinition description' name' arguments' repeatable locations
         -> description formatter description'
         <> "@"
         <> Lazy.Text.fromStrict name'
         <> argumentsDefinition formatter arguments'
+        <> (if repeatable then " repeatable" else mempty)
         <> " on"
         <> pipeList formatter (directiveLocation <$> locations)
 

src/Language/GraphQL/AST/Parser.hs

@@ -27,6 +27,7 @@ import Text.Megaparsec
     , unPos
     , (<?>)
     )
+import Data.Maybe (isJust)
 
 -- | Parser for the GraphQL documents.
 document :: Parser Full.Document
@@ -82,6 +83,7 @@ directiveDefinition description' = Full.DirectiveDefinition description'
     <* at
     <*> name
     <*> argumentsDefinition
+    <*> (isJust <$> optional (symbol "repeatable"))
     <* symbol "on"
     <*> directiveLocations
     <?> "DirectiveDefinition"

src/Language/GraphQL/Validate.hs

@@ -200,7 +200,7 @@ typeSystemDefinition context rule = \case
         directives context rule schemaLocation directives'
     Full.TypeDefinition typeDefinition' ->
         typeDefinition context rule typeDefinition'
-    Full.DirectiveDefinition _ _ arguments' _ ->
+    Full.DirectiveDefinition _ _ arguments' _ _ ->
         argumentsDefinition context rule arguments'
 
 typeDefinition :: forall m. Validation m -> ApplyRule m Full.TypeDefinition

tests/Language/GraphQL/AST/ParserSpec.hs

@@ -12,7 +12,12 @@ import qualified Language.GraphQL.AST.DirectiveLocation as DirLoc
 import Language.GraphQL.AST.Parser
 import Language.GraphQL.TH
 import Test.Hspec (Spec, describe, it, context)
-import Test.Hspec.Megaparsec (shouldParse, shouldFailOn, shouldSucceedOn)
+import Test.Hspec.Megaparsec
+    ( shouldParse
+    , shouldFailOn
+    , parseSatisfies
+    , shouldSucceedOn
+    )
 import Text.Megaparsec (parse)
 import Test.QuickCheck (property, NonEmptyList (..), mapSize)
 import Language.GraphQL.AST.Arbitrary
@@ -143,22 +148,20 @@ spec = describe "Parser" $ do
         |]
 
     it "parses two minimal directive definitions" $
-        let directive nm loc =
-                TypeSystemDefinition
-                    (DirectiveDefinition
-                         (Description Nothing)
-                         nm
-                         (ArgumentsDefinition [])
-                         (loc :| []))
-            example1 =
-                directive "example1"
-                    (DirLoc.TypeSystemDirectiveLocation DirLoc.FieldDefinition)
-                    (Location {line = 1, column = 1})
-            example2 =
-                directive "example2"
-                    (DirLoc.ExecutableDirectiveLocation DirLoc.Field)
-                    (Location {line = 2, column = 1})
-            testSchemaExtension = example1 :| [ example2 ]
+        let directive name' loc = TypeSystemDefinition
+                $ DirectiveDefinition
+                    (Description Nothing)
+                    name'
+                    (ArgumentsDefinition [])
+                    False
+                    (loc :| [])
+            example1 = directive "example1"
+                (DirLoc.TypeSystemDirectiveLocation DirLoc.FieldDefinition)
+                (Location {line = 1, column = 1})
+            example2 = directive "example2"
+                (DirLoc.ExecutableDirectiveLocation DirLoc.Field)
+                (Location {line = 2, column = 1})
+            testSchemaExtension = example1 :| [example2]
             query = [gql|
               directive @example1 on FIELD_DEFINITION
               directive @example2 on FIELD
@@ -166,31 +169,26 @@ spec = describe "Parser" $ do
          in parse document "" query `shouldParse` testSchemaExtension
 
     it "parses a directive definition with a default empty list argument" $
-        let directive nm loc args =
-                TypeSystemDefinition
-                    (DirectiveDefinition
-                         (Description Nothing)
-                         nm
-                         (ArgumentsDefinition
-                              [ InputValueDefinition
-                                    (Description Nothing)
-                                    argName
-                                    argType
-                                    argValue
-                                    []
-                              | (argName, argType, argValue) <- args])
-                         (loc :| []))
-            defn =
-                directive "test"
-                    (DirLoc.TypeSystemDirectiveLocation DirLoc.FieldDefinition)
-                    [("foo",
-                      TypeList (TypeNamed "String"),
-                      Just
-                          $ Node (ConstList [])
-                          $ Location {line = 1, column = 33})]
-                    (Location {line = 1, column = 1})
+        let argumentValue = Just
+                $ Node (ConstList [])
+                $ Location{ line = 1, column = 33 }
+            loc = DirLoc.TypeSystemDirectiveLocation DirLoc.FieldDefinition
+            argumentValueDefinition = InputValueDefinition
+                (Description Nothing)
+                "foo"
+                (TypeList (TypeNamed "String"))
+                argumentValue
+                []
+            definition = DirectiveDefinition
+                (Description Nothing)
+                "test"
+                (ArgumentsDefinition [argumentValueDefinition] )
+                False
+                (loc :| [])
+            directive = TypeSystemDefinition definition
+                $ Location{ line = 1, column = 1 }
             query = [gql|directive @test(foo: [String] = []) on FIELD_DEFINITION|]
-         in parse document "" query `shouldParse` (defn :| [ ])
+         in parse document "" query `shouldParse` (directive :| [])
 
     it "parses schema extension with a new directive" $
         parse document "" `shouldSucceedOn`[gql|
@@ -210,6 +208,13 @@ spec = describe "Parser" $ do
             query = [gql|extend schema @newDirective { query: Query }|]
          in parse document "" query `shouldParse` (testSchemaExtension :| [])
 
+    it "parses a repeatable directive definition" $
+        let given = [gql|directive @test repeatable on FIELD_DEFINITION|]
+            isRepeatable (TypeSystemDefinition definition' _ :| [])
+                | DirectiveDefinition _ _ _ repeatable _ <- definition' = repeatable
+            isRepeatable _ = False
+         in parse document "" given `parseSatisfies` isRepeatable
+
     it "parses an object extension" $
         parse document "" `shouldSucceedOn` [gql|
             extend type Story {