summaryrefslogtreecommitdiff
path: root/src/Language/GraphQL
diff options
context:
space:
mode:
Diffstat (limited to 'src/Language/GraphQL')
-rw-r--r--src/Language/GraphQL/AST/DirectiveLocation.hs2
-rw-r--r--src/Language/GraphQL/AST/Document.hs6
-rw-r--r--src/Language/GraphQL/AST/Encoder.hs2
-rw-r--r--src/Language/GraphQL/Execute/Coerce.hs2
-rw-r--r--src/Language/GraphQL/Validate.hs4
-rw-r--r--src/Language/GraphQL/Validate/Rules.hs35
6 files changed, 32 insertions, 19 deletions
diff --git a/src/Language/GraphQL/AST/DirectiveLocation.hs b/src/Language/GraphQL/AST/DirectiveLocation.hs
index d109666..600f931 100644
--- a/src/Language/GraphQL/AST/DirectiveLocation.hs
+++ b/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(..)
diff --git a/src/Language/GraphQL/AST/Document.hs b/src/Language/GraphQL/AST/Document.hs
index f695495..101cf78 100644
--- a/src/Language/GraphQL/AST/Document.hs
+++ b/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
diff --git a/src/Language/GraphQL/AST/Encoder.hs b/src/Language/GraphQL/AST/Encoder.hs
index afa30de..a1076e4 100644
--- a/src/Language/GraphQL/AST/Encoder.hs
+++ b/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 =
diff --git a/src/Language/GraphQL/Execute/Coerce.hs b/src/Language/GraphQL/Execute/Coerce.hs
index 54fc1c1..f67d74b 100644
--- a/src/Language/GraphQL/Execute/Coerce.hs
+++ b/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
diff --git a/src/Language/GraphQL/Validate.hs b/src/Language/GraphQL/Validate.hs
index ba00594..5feb85a 100644
--- a/src/Language/GraphQL/Validate.hs
+++ b/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'
diff --git a/src/Language/GraphQL/Validate/Rules.hs b/src/Language/GraphQL/Validate/Rules.hs
index c68cd61..3fef94d 100644
--- a/src/Language/GraphQL/Validate/Rules.hs
+++ b/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 \"@"