From e8b82122c646ba159146c986cc8983d66f790142 Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Tue, 28 Jan 2020 11:08:28 +0100 Subject: [PATCH] Try all extension parsers --- src/Language/GraphQL/AST/Document.hs | 2 +- src/Language/GraphQL/AST/Lexer.hs | 16 +++++++- src/Language/GraphQL/AST/Parser.hs | 51 ++++++++++-------------- stack.yaml | 2 +- tests/Language/GraphQL/AST/LexerSpec.hs | 7 +++- tests/Language/GraphQL/AST/ParserSpec.hs | 7 ++++ 6 files changed, 48 insertions(+), 37 deletions(-) diff --git a/src/Language/GraphQL/AST/Document.hs b/src/Language/GraphQL/AST/Document.hs index 9de16c0..8048cf0 100644 --- a/src/Language/GraphQL/AST/Document.hs +++ b/src/Language/GraphQL/AST/Document.hs @@ -267,7 +267,7 @@ data OperationTypeDefinition data SchemaExtension = SchemaOperationExtension [Directive] (NonEmpty OperationTypeDefinition) - | SchemaDirectiveExtension (NonEmpty Directive) + | SchemaDirectivesExtension (NonEmpty Directive) deriving (Eq, Show) -- ** Descriptions diff --git a/src/Language/GraphQL/AST/Lexer.hs b/src/Language/GraphQL/AST/Lexer.hs index e119303..0ba55e3 100644 --- a/src/Language/GraphQL/AST/Lexer.hs +++ b/src/Language/GraphQL/AST/Lexer.hs @@ -33,9 +33,12 @@ import Control.Applicative (Alternative(..), liftA2) import Data.Char (chr, digitToInt, isAsciiLower, isAsciiUpper, ord) import Data.Foldable (foldl') import Data.List (dropWhileEnd) +import qualified Data.List.NonEmpty as NonEmpty +import Data.List.NonEmpty (NonEmpty(..)) import Data.Proxy (Proxy(..)) import Data.Void (Void) import Text.Megaparsec ( Parsec + , () , between , chunk , chunkToTokens @@ -220,5 +223,14 @@ unicodeBOM :: Parser () unicodeBOM = optional (char '\xfeff') >> pure () -- | Parses "extend" followed by a 'symbol'. It is used by schema extensions. -extend :: Text -> Parser () -extend token = symbol "extend" *> symbol token >> pure () +extend :: forall a. Text -> String -> NonEmpty (Parser a) -> Parser a +extend token extensionLabel parsers + = foldr combine headParser (NonEmpty.tail parsers) + extensionLabel + where + headParser = tryExtension $ NonEmpty.head parsers + combine current accumulated = accumulated <|> tryExtension current + tryExtension extensionParser = try + $ symbol "extend" + *> symbol token + *> extensionParser \ No newline at end of file diff --git a/src/Language/GraphQL/AST/Parser.hs b/src/Language/GraphQL/AST/Parser.hs index 204a3ea..3449903 100644 --- a/src/Language/GraphQL/AST/Parser.hs +++ b/src/Language/GraphQL/AST/Parser.hs @@ -9,7 +9,7 @@ module Language.GraphQL.AST.Parser import Control.Applicative (Alternative(..), optional) import Control.Applicative.Combinators (sepBy1) import qualified Control.Applicative.Combinators.NonEmpty as NonEmpty -import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty (NonEmpty(..)) import Data.Text (Text) import qualified Language.GraphQL.AST.DirectiveLocation as Directive import Language.GraphQL.AST.DirectiveLocation @@ -118,11 +118,8 @@ scalarTypeDefinition = ScalarTypeDefinition "ScalarTypeDefinition" scalarTypeExtension :: Parser TypeExtension -scalarTypeExtension = ScalarTypeExtension - <$ extend "scalar" - <*> name - <*> NonEmpty.some directive - "ScalarTypeExtension" +scalarTypeExtension = extend "scalar" "ScalarTypeExtension" + $ (ScalarTypeExtension <$> name <*> NonEmpty.some directive) :| [] objectTypeDefinition :: Parser TypeDefinition objectTypeDefinition = ObjectTypeDefinition @@ -135,11 +132,11 @@ objectTypeDefinition = ObjectTypeDefinition "ObjectTypeDefinition" objectTypeExtension :: Parser TypeExtension -objectTypeExtension = extend "type" - >> try fieldsDefinitionExtension - <|> try directivesExtension - <|> implementsInterfacesExtension - "ObjectTypeExtension" +objectTypeExtension = extend "type" "ObjectTypeExtension" + $ fieldsDefinitionExtension :| + [ directivesExtension + , implementsInterfacesExtension + ] where fieldsDefinitionExtension = ObjectTypeFieldsDefinitionExtension <$> name @@ -169,10 +166,8 @@ unionTypeDefinition = UnionTypeDefinition "UnionTypeDefinition" unionTypeExtension :: Parser TypeExtension -unionTypeExtension = extend "union" - >> try unionMemberTypesExtension - <|> directivesExtension - "UnionTypeExtension" +unionTypeExtension = extend "union" "UnionTypeExtension" + $ unionMemberTypesExtension :| [directivesExtension] where unionMemberTypesExtension = UnionTypeUnionMemberTypesExtension <$> name @@ -202,10 +197,8 @@ interfaceTypeDefinition = InterfaceTypeDefinition "InterfaceTypeDefinition" interfaceTypeExtension :: Parser TypeExtension -interfaceTypeExtension = extend "interface" - >> try fieldsDefinitionExtension - <|> directivesExtension - "InterfaceTypeExtension" +interfaceTypeExtension = extend "interface" "InterfaceTypeExtension" + $ fieldsDefinitionExtension :| [directivesExtension] where fieldsDefinitionExtension = InterfaceTypeFieldsDefinitionExtension <$> name @@ -225,10 +218,8 @@ enumTypeDefinition = EnumTypeDefinition "EnumTypeDefinition" enumTypeExtension :: Parser TypeExtension -enumTypeExtension = extend "enum" - >> try enumValuesDefinitionExtension - <|> directivesExtension - "EnumTypeExtension" +enumTypeExtension = extend "enum" "EnumTypeExtension" + $ enumValuesDefinitionExtension :| [directivesExtension] where enumValuesDefinitionExtension = EnumTypeEnumValuesDefinitionExtension <$> name @@ -248,10 +239,8 @@ inputObjectTypeDefinition = InputObjectTypeDefinition "InputObjectTypeDefinition" inputObjectTypeExtension :: Parser TypeExtension -inputObjectTypeExtension = extend "input" - >> try inputFieldsDefinitionExtension - <|> directivesExtension - "InputObjectTypeExtension" +inputObjectTypeExtension = extend "input" "InputObjectTypeExtension" + $ inputFieldsDefinitionExtension :| [directivesExtension] where inputFieldsDefinitionExtension = InputObjectTypeInputFieldsDefinitionExtension <$> name @@ -314,11 +303,11 @@ operationTypeDefinitions :: Parser (NonEmpty OperationTypeDefinition) operationTypeDefinitions = braces $ NonEmpty.some operationTypeDefinition schemaExtension :: Parser SchemaExtension -schemaExtension = extend "schema" - >> try schemaOperationExtension - <|> SchemaDirectiveExtension <$> NonEmpty.some directive - "SchemaExtension" +schemaExtension = extend "schema" "SchemaExtension" + $ schemaOperationExtension :| [directivesExtension] where + directivesExtension = SchemaDirectivesExtension + <$> NonEmpty.some directive schemaOperationExtension = SchemaOperationExtension <$> directives <*> operationTypeDefinitions diff --git a/stack.yaml b/stack.yaml index 1d1e93e..3faeb3c 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-14.21 +resolver: lts-14.22 packages: - . diff --git a/tests/Language/GraphQL/AST/LexerSpec.hs b/tests/Language/GraphQL/AST/LexerSpec.hs index 4938b0f..0b4cb31 100644 --- a/tests/Language/GraphQL/AST/LexerSpec.hs +++ b/tests/Language/GraphQL/AST/LexerSpec.hs @@ -88,9 +88,12 @@ spec = describe "Lexer" $ do it "lexes ampersand" $ parse amp "" "&" `shouldParse` "&" it "lexes schema extensions" $ - parse (extend "schema") "" `shouldSucceedOn` "extend schema" + parseExtend "schema" `shouldSucceedOn` "extend schema" it "fails if the given token doesn't match" $ - parse (extend "schema") "" `shouldFailOn` "extend shema" + parseExtend "schema" `shouldFailOn` "extend shema" + +parseExtend :: Text -> (Text -> Either (ParseErrorBundle Text Void) ()) +parseExtend extension = parse (extend extension "" $ pure $ pure ()) "" runBetween :: (Parser () -> Parser ()) -> Text -> Either (ParseErrorBundle Text Void) () runBetween parser = parse (parser $ pure ()) "" diff --git a/tests/Language/GraphQL/AST/ParserSpec.hs b/tests/Language/GraphQL/AST/ParserSpec.hs index f06f6c1..4fae5b1 100644 --- a/tests/Language/GraphQL/AST/ParserSpec.hs +++ b/tests/Language/GraphQL/AST/ParserSpec.hs @@ -135,3 +135,10 @@ spec = describe "Parser" $ do $ OperationTypeDefinition Query "Query" :| [] query = [r|extend schema @newDirective { query: Query }|] in parse document "" query `shouldParse` (testSchemaExtension :| []) + + it "parses an object extension" $ + parse document "" `shouldSucceedOn` [r| + extend type Story { + isHiddenLocally: Boolean + } + |] \ No newline at end of file