Validate single root field in subscriptions

3 files changed, 36 insertions, 30 deletions

diff --git a/src/Language/GraphQL/AST/Document.hs b/src/Language/GraphQL/AST/Document.hs
index 3394bfa..f60ddda 100644
--- a/src/Language/GraphQL/AST/Document.hs
+++ b/src/Language/GraphQL/AST/Document.hs
@@ -69,7 +69,7 @@ type Document = NonEmpty Definition
 
 -- | All kinds of definitions that can occur in a GraphQL document.
 data Definition
-    = ExecutableDefinition ExecutableDefinition Location
+    = ExecutableDefinition ExecutableDefinition
     | TypeSystemDefinition TypeSystemDefinition Location
     | TypeSystemExtension TypeSystemExtension Location
     deriving (Eq, Show)
@@ -84,13 +84,14 @@ data ExecutableDefinition
 
 -- | Operation definition.
 data OperationDefinition
-    = SelectionSet SelectionSet
+    = SelectionSet SelectionSet Location
     | OperationDefinition
         OperationType
         (Maybe Name)
         [VariableDefinition]
         [Directive]
         SelectionSet
+        Location
     deriving (Eq, Show)
 
 -- | GraphQL has 3 operation types:
@@ -195,7 +196,7 @@ type Alias = Name
 
 -- | Fragment definition.
 data FragmentDefinition
-    = FragmentDefinition Name TypeCondition [Directive] SelectionSet
+    = FragmentDefinition Name TypeCondition [Directive] SelectionSet Location
     deriving (Eq, Show)
 
 -- | Type condition.
diff --git a/src/Language/GraphQL/AST/Encoder.hs b/src/Language/GraphQL/AST/Encoder.hs
index a0dac5b..ba89d36 100644
--- a/src/Language/GraphQL/AST/Encoder.hs
+++ b/src/Language/GraphQL/AST/Encoder.hs
@@ -50,8 +50,8 @@ document formatter defs
     | Minified <-formatter = Lazy.Text.snoc (mconcat encodeDocument) '\n'
   where
     encodeDocument = foldr executableDefinition [] defs
-    executableDefinition (ExecutableDefinition x _) acc =
-        definition formatter x : acc
+    executableDefinition (ExecutableDefinition executableDefinition') acc =
+        definition formatter executableDefinition' : acc
     executableDefinition _ acc = acc
 
 -- | Converts a t'ExecutableDefinition' into a string.
@@ -68,12 +68,12 @@ definition formatter x
 -- | Converts a 'OperationDefinition into a string.
 operationDefinition :: Formatter -> OperationDefinition -> Lazy.Text
 operationDefinition formatter = \case
-    SelectionSet sels -> selectionSet formatter sels
-    OperationDefinition Query name vars dirs sels ->
+    SelectionSet sels _ -> selectionSet formatter sels
+    OperationDefinition Query name vars dirs sels _ ->
         "query " <> node formatter name vars dirs sels
-    OperationDefinition Mutation name vars dirs sels ->
+    OperationDefinition Mutation name vars dirs sels _ ->
         "mutation " <> node formatter name vars dirs sels
-    OperationDefinition Subscription name vars dirs sels ->
+    OperationDefinition Subscription name vars dirs sels _ ->
         "subscription " <> node formatter name vars dirs sels
 
 -- | Converts a Query or Mutation into a string.
@@ -190,7 +190,7 @@ inlineFragment formatter tc dirs sels = "... on "
     <> selectionSet formatter sels
 
 fragmentDefinition :: Formatter -> FragmentDefinition -> Lazy.Text
-fragmentDefinition formatter (FragmentDefinition name tc dirs sels)
+fragmentDefinition formatter (FragmentDefinition name tc dirs sels _)
     = "fragment " <> Lazy.Text.fromStrict name
     <> " on " <> Lazy.Text.fromStrict tc
     <> optempty (directives formatter) dirs
diff --git a/src/Language/GraphQL/AST/Parser.hs b/src/Language/GraphQL/AST/Parser.hs
index 687d8f5..7bc51cb 100644
--- a/src/Language/GraphQL/AST/Parser.hs
+++ b/src/Language/GraphQL/AST/Parser.hs
@@ -21,7 +21,8 @@ import Language.GraphQL.AST.DirectiveLocation
 import Language.GraphQL.AST.Document
 import Language.GraphQL.AST.Lexer
 import Text.Megaparsec
-    ( SourcePos(..)
+    ( MonadParsec(..)
+    , SourcePos(..)
     , getSourcePos
     , lookAhead
     , option
@@ -37,15 +38,11 @@ document = unicodeBOM
     *> lexeme (NonEmpty.some definition)
 
 definition :: Parser Definition
-definition = executableDefinition'
+definition = ExecutableDefinition <$> executableDefinition
     <|> typeSystemDefinition'
     <|> typeSystemExtension'
     <?> "Definition"
   where
-    executableDefinition' = do
-        location <- getLocation
-        definition' <- executableDefinition
-        pure $ ExecutableDefinition definition' location
     typeSystemDefinition' = do
         location <- getLocation
         definition' <- typeSystemDefinition
@@ -349,16 +346,22 @@ operationTypeDefinition = OperationTypeDefinition
     <?> "OperationTypeDefinition"
 
 operationDefinition :: Parser OperationDefinition
-operationDefinition = SelectionSet <$> selectionSet
+operationDefinition = shorthand
     <|> operationDefinition'
     <?> "OperationDefinition"
   where
-    operationDefinition'
-        = OperationDefinition <$> operationType
-        <*> optional name
-        <*> variableDefinitions
-        <*> directives
-        <*> selectionSet
+    shorthand = do
+        location <- getLocation
+        selectionSet' <- selectionSet
+        pure $ SelectionSet selectionSet' location
+    operationDefinition' = do
+        location <- getLocation
+        operationType' <- operationType
+        operationName <- optional name
+        variableDefinitions' <- variableDefinitions
+        directives' <- directives
+        selectionSet' <- selectionSet
+        pure $ OperationDefinition operationType' operationName variableDefinitions' directives' selectionSet' location
 
 operationType :: Parser OperationType
 operationType = Query <$ symbol "query"
@@ -412,13 +415,15 @@ inlineFragment = InlineFragment
     <?> "InlineFragment"
 
 fragmentDefinition :: Parser FragmentDefinition
-fragmentDefinition = FragmentDefinition
-    <$  symbol "fragment"
-    <*> name
-    <*> typeCondition
-    <*> directives
-    <*> selectionSet
-    <?> "FragmentDefinition"
+fragmentDefinition =  label "FragmentDefinition" $ do
+    location <- getLocation
+    _ <- symbol "fragment"
+    fragmentName' <- name
+    typeCondition' <- typeCondition
+    directives' <- directives
+    selectionSet' <- selectionSet
+    pure $ FragmentDefinition
+        fragmentName' typeCondition' directives' selectionSet' location
 
 fragmentName :: Parser Name
 fragmentName = but (symbol "on") *> name <?> "FragmentName"