Validate repeatable directives

CHANGELOG.md

@@ -10,6 +10,8 @@ and this project adheres to
 ### Changed
 - `Schema.Directive` is extended to contain a boolean argument, representing
   repeatable directives. The parser can parse repeatable directive definitions.
+  Validation allows repeatable directives.
+- `AST.Document.Directive` is a record.
 
 ### Fixed
 - `gql` quasi quoter recognizeds all GraphQL line endings (CR, LF and CRLF).

src/Language/GraphQL/AST/Document.hs

@@ -380,7 +380,11 @@ instance Show NonNullType where
 --
 -- Directives begin with "@", can accept arguments, and can be applied to the
 -- most GraphQL elements, providing additional information.
-data Directive = Directive Name [Argument] Location deriving (Eq, Show)
+data Directive = Directive
+    { name :: Name
+    , arguments :: [Argument]
+    , location :: Location
+    } deriving (Eq, Show)
 
 -- * Type System
 

src/Language/GraphQL/Validate/Rules.hs

@@ -533,11 +533,20 @@ uniqueArgumentNamesRule = ArgumentsRule fieldRule directiveRule
 -- used, the expected metadata or behavior becomes ambiguous, therefore only one
 -- of each directive is allowed per location.
 uniqueDirectiveNamesRule :: forall m. Rule m
-uniqueDirectiveNamesRule = DirectivesRule
+uniqueDirectiveNamesRule = DirectivesRule $ const $ \directives' -> do
-    $ const $ lift . filterDuplicates extract "directive"
+    definitions' <- asks $ Schema.directives . schema
+    let filterNonRepeatable = flip HashSet.member nonRepeatableSet
+            . getField @"name"
+        nonRepeatableSet =
+            HashMap.foldlWithKey foldNonRepeatable HashSet.empty definitions'
+    lift $ filterDuplicates extract "directive"
+        $ filter filterNonRepeatable directives'
   where
-    extract (Full.Directive directiveName _ location') =
+    foldNonRepeatable  hashSet directiveName' (Schema.Directive _ _ False _) =
-        (directiveName, location')
+        HashSet.insert directiveName' hashSet
+    foldNonRepeatable hashSet _ _ = hashSet
+    extract (Full.Directive directiveName' _ location') =
+        (directiveName', location')
 
 filterDuplicates :: forall a
     . (a -> (Text, Full.Location))
@@ -852,18 +861,18 @@ knownArgumentNamesRule = ArgumentsRule fieldRule directiveRule
 knownDirectiveNamesRule :: Rule m
 knownDirectiveNamesRule = DirectivesRule $ const $ \directives' -> do
     definitions' <- asks $ Schema.directives . schema
-    let directiveSet = HashSet.fromList $ fmap directiveName directives'
+    let directiveSet = HashSet.fromList $ fmap (getField @"name") directives'
-    let definitionSet = HashSet.fromList $ HashMap.keys definitions'
+        definitionSet = HashSet.fromList $ HashMap.keys definitions'
-    let difference = HashSet.difference directiveSet definitionSet
+        difference = HashSet.difference directiveSet definitionSet
-    let undefined' = filter (definitionFilter difference) directives'
+        undefined' = filter (definitionFilter difference) directives'
     lift $ Seq.fromList $ makeError <$> undefined'
   where
+    definitionFilter :: HashSet Full.Name -> Full.Directive -> Bool
     definitionFilter difference = flip HashSet.member difference
-        . directiveName
+        . getField @"name"
-    directiveName (Full.Directive directiveName' _ _) = directiveName'
+    makeError Full.Directive{..} = Error
-    makeError (Full.Directive directiveName' _ location') = Error
+        { message = errorMessage name
-        { message = errorMessage directiveName'
+        , locations = [location]
-        , locations = [location']
         }
     errorMessage directiveName' = concat
         [ "Unknown directive \"@"

tests/Language/GraphQL/AST/ParserSpec.hs

@@ -82,8 +82,8 @@ spec = describe "Parser" $ do
        it "accepts any arguments" $ mapSize (const 10) $ property $ \xs ->
             let
                 query' :: Text
-                arguments = map printArgument $ getNonEmpty (xs :: NonEmptyList (AnyArgument AnyValue))
+                arguments' = map printArgument $ getNonEmpty (xs :: NonEmptyList (AnyArgument AnyValue))
-                query' = "query(" <> Text.intercalate ", " arguments <> ")" in
+                query' = "query(" <> Text.intercalate ", " arguments' <> ")" in
             parse document "" `shouldSucceedOn` ("{ " <> query' <> " }")
 
     it "parses minimal schema definition" $

tests/Language/GraphQL/Validate/RulesSpec.hs

@@ -15,6 +15,8 @@ import Data.Text (Text)
 import qualified Language.GraphQL.AST as AST
 import Language.GraphQL.TH
 import Language.GraphQL.Type
+import qualified Language.GraphQL.Type.Schema as Schema
+import qualified Language.GraphQL.AST.DirectiveLocation as DirectiveLocation
 import qualified Language.GraphQL.Type.In as In
 import qualified Language.GraphQL.Type.Out as Out
 import Language.GraphQL.Validate
@@ -22,7 +24,9 @@ import Test.Hspec (Spec, context, describe, it, shouldBe, shouldContain)
 import Text.Megaparsec (parse, errorBundlePretty)
 
 petSchema :: Schema IO
-petSchema = schema queryType Nothing (Just subscriptionType) mempty
+petSchema = schema queryType Nothing (Just subscriptionType)
+    $ HashMap.singleton "repeat"
+    $ Schema.Directive Nothing mempty True [DirectiveLocation.ExecutableDirectiveLocation DirectiveLocation.Field]
 
 queryType :: ObjectType IO
 queryType = ObjectType "Query" Nothing [] $ HashMap.fromList
@@ -494,7 +498,7 @@ spec =
                         }
                  in validate queryString `shouldBe` [expected]
 
-        context "uniqueDirectiveNamesRule" $
+        context "uniqueDirectiveNamesRule" $ do
             it "rejects more than one directive per location" $
                 let queryString = [gql|
                   query ($foo: Boolean = true, $bar: Boolean = false) {
@@ -510,6 +514,16 @@ spec =
                         }
                  in validate queryString `shouldBe` [expected]
 
+            it "allows repeating repeatable directives" $
+                let queryString = [gql|
+                  query {
+                    dog @repeat @repeat {
+                      name
+                    }
+                  }
+                |]
+                 in validate queryString `shouldBe` []
+
         context "uniqueVariableNamesRule" $
             it "rejects duplicate variables" $
                 let queryString = [gql|