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] ## [Unreleased]
### Changed ### Changed
- `Schema.Directive` is extended to contain a boolean argument, representing - `Schema.Directive` is extended to contain a boolean argument, representing
repeatable directives. repeatable directives. The parser can parse repeatable directive definitions.
### Fixed ### Fixed
- `gql` quasi quoter recognizeds all GraphQL line endings (CR, LF and CRLF). - `gql` quasi quoter recognizeds all GraphQL line endings (CR, LF and CRLF).

View File

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

View File

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

View File

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

View File

@ -200,7 +200,7 @@ typeSystemDefinition context rule = \case
directives context rule schemaLocation directives' directives context rule schemaLocation directives'
Full.TypeDefinition typeDefinition' -> Full.TypeDefinition typeDefinition' ->
typeDefinition context rule typeDefinition' typeDefinition context rule typeDefinition'
Full.DirectiveDefinition _ _ arguments' _ -> Full.DirectiveDefinition _ _ arguments' _ _ ->
argumentsDefinition context rule arguments' argumentsDefinition context rule arguments'
typeDefinition :: forall m. Validation m -> ApplyRule m Full.TypeDefinition 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.AST.Parser
import Language.GraphQL.TH import Language.GraphQL.TH
import Test.Hspec (Spec, describe, it, context) 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 Text.Megaparsec (parse)
import Test.QuickCheck (property, NonEmptyList (..), mapSize) import Test.QuickCheck (property, NonEmptyList (..), mapSize)
import Language.GraphQL.AST.Arbitrary import Language.GraphQL.AST.Arbitrary
@ -143,19 +148,17 @@ spec = describe "Parser" $ do
|] |]
it "parses two minimal directive definitions" $ it "parses two minimal directive definitions" $
let directive nm loc = let directive name' loc = TypeSystemDefinition
TypeSystemDefinition $ DirectiveDefinition
(DirectiveDefinition
(Description Nothing) (Description Nothing)
nm name'
(ArgumentsDefinition []) (ArgumentsDefinition [])
(loc :| [])) False
example1 = (loc :| [])
directive "example1" example1 = directive "example1"
(DirLoc.TypeSystemDirectiveLocation DirLoc.FieldDefinition) (DirLoc.TypeSystemDirectiveLocation DirLoc.FieldDefinition)
(Location {line = 1, column = 1}) (Location {line = 1, column = 1})
example2 = example2 = directive "example2"
directive "example2"
(DirLoc.ExecutableDirectiveLocation DirLoc.Field) (DirLoc.ExecutableDirectiveLocation DirLoc.Field)
(Location {line = 2, column = 1}) (Location {line = 2, column = 1})
testSchemaExtension = example1 :| [example2] testSchemaExtension = example1 :| [example2]
@ -166,31 +169,26 @@ spec = describe "Parser" $ do
in parse document "" query `shouldParse` testSchemaExtension in parse document "" query `shouldParse` testSchemaExtension
it "parses a directive definition with a default empty list argument" $ it "parses a directive definition with a default empty list argument" $
let directive nm loc args = let argumentValue = Just
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 []) $ Node (ConstList [])
$ Location {line = 1, column = 33})] $ Location{ line = 1, column = 33 }
(Location {line = 1, column = 1}) 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|] 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" $ it "parses schema extension with a new directive" $
parse document "" `shouldSucceedOn`[gql| parse document "" `shouldSucceedOn`[gql|
@ -210,6 +208,13 @@ spec = describe "Parser" $ do
query = [gql|extend schema @newDirective { query: Query }|] query = [gql|extend schema @newDirective { query: Query }|]
in parse document "" query `shouldParse` (testSchemaExtension :| []) 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" $ it "parses an object extension" $
parse document "" `shouldSucceedOn` [gql| parse document "" `shouldSucceedOn` [gql|
extend type Story { extend type Story {