Try all extension parsers

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

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

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

stack.yaml

@@ -1,4 +1,4 @@
-resolver: lts-14.21
+resolver: lts-14.22
 
 packages:
 - .

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 ()) ""

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
+            }
+        |]