Validate repeatable directives

src/Language/GraphQL/AST/DirectiveLocation.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE Safe #-}
 
--- | Various parts of a GraphQL document can be annotated with directives. 
+-- | Various parts of a GraphQL document can be annotated with directives.
 -- This module describes locations in a document where directives can appear.
 module Language.GraphQL.AST.DirectiveLocation
     ( DirectiveLocation(..)

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/AST/Encoder.hs

@@ -277,7 +277,7 @@ pipeList :: Foldable t => Formatter -> t Lazy.Text -> Lazy.Text
 pipeList Minified =  (" " <>) . Lazy.Text.intercalate " | " . toList
 pipeList (Pretty _) =  Lazy.Text.concat
     . fmap (("\n" <> indentSymbol <> "| ") <>)
-    . toList 
+    . toList
 
 enumValueDefinition :: Formatter -> Full.EnumValueDefinition -> Lazy.Text
 enumValueDefinition (Pretty _) enumValue =

src/Language/GraphQL/Execute/Coerce.hs

@@ -147,7 +147,7 @@ coerceInputLiteral (In.EnumBaseType type') (Type.Enum enumValue)
     | member enumValue type' = Just $ Type.Enum enumValue
   where
     member value (Type.EnumType _ _ members) = HashMap.member value members
-coerceInputLiteral (In.InputObjectBaseType type') (Type.Object values) = 
+coerceInputLiteral (In.InputObjectBaseType type') (Type.Object values) =
     let (In.InputObjectType _ _ inputFields) = type'
      in Type.Object
             <$> HashMap.foldrWithKey (matchFieldValues' values) (Just HashMap.empty) inputFields

src/Language/GraphQL/Validate.hs

@@ -283,7 +283,7 @@ operationDefinition rule context operation
     schema' = Validation.schema context
     queryRoot = Just $ Out.NamedObjectType $ Schema.query schema'
     types' = Schema.types schema'
-        
+
 typeToOut :: forall m. Schema.Type m -> Maybe (Out.Type m)
 typeToOut (Schema.ObjectType objectType) =
     Just $ Out.NamedObjectType objectType
@@ -403,7 +403,7 @@ arguments :: forall m
     -> Seq (Validation.RuleT m)
 arguments rule argumentTypes = foldMap forEach . Seq.fromList
   where
-    forEach argument'@(Full.Argument argumentName _ _) = 
+    forEach argument'@(Full.Argument argumentName _ _) =
        let argumentType = HashMap.lookup argumentName argumentTypes
         in argument rule argumentType argument'
 

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
-    $ const $ lift . filterDuplicates extract "directive"
+uniqueDirectiveNamesRule = DirectivesRule $ const $ \directives' -> do
+    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') =
-        (directiveName, location')
+    foldNonRepeatable  hashSet directiveName' (Schema.Directive _ _ False _) =
+        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 definitionSet = HashSet.fromList $ HashMap.keys definitions'
-    let difference = HashSet.difference directiveSet definitionSet
-    let undefined' = filter (definitionFilter difference) directives'
+    let directiveSet = HashSet.fromList $ fmap (getField @"name") directives'
+        definitionSet = HashSet.fromList $ HashMap.keys definitions'
+        difference = HashSet.difference directiveSet definitionSet
+        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
-    directiveName (Full.Directive directiveName' _ _) = directiveName'
-    makeError (Full.Directive directiveName' _ location') = Error
-        { message = errorMessage directiveName'
-        , locations = [location']
+        . getField @"name"
+    makeError Full.Directive{..} = Error
+        { message = errorMessage name
+        , locations = [location]
         }
     errorMessage directiveName' = concat
         [ "Unknown directive \"@"