Parse repeatable directive definitions

This commit is contained in:
Eugen Wissner 2024-08-27 10:51:01 +02:00
parent 4b5e25a4d8
commit b40d8a7e1e
Signed by: belka
GPG Key ID: A27FDC1E8EE902C0
6 changed files with 53 additions and 45 deletions

View File

@ -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).

View File

@ -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

View File

@ -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)

View File

@ -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"

View File

@ -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

View File

@ -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 {