From d9a2937b55b3f9c55ac42b1968b62888d916dace Mon Sep 17 00:00:00 2001
From: Eugen Wissner <belka@caraus.de>
Date: Fri, 3 Jan 2020 07:20:48 +0100
Subject: [PATCH] Parse SchemaDefinition

---
 src/Language/GraphQL/AST/Document.hs     | 15 +++++----
 src/Language/GraphQL/AST/Parser.hs       | 41 ++++++++++++++++++------
 tests/Language/GraphQL/AST/ParserSpec.hs |  3 ++
 3 files changed, 44 insertions(+), 15 deletions(-)

diff --git a/src/Language/GraphQL/AST/Document.hs b/src/Language/GraphQL/AST/Document.hs
index b94b629..30ec897 100644
--- a/src/Language/GraphQL/AST/Document.hs
+++ b/src/Language/GraphQL/AST/Document.hs
@@ -5,7 +5,7 @@
 module Language.GraphQL.AST.Document
     ( Alias
     , Argument(..)
-    , Definition(ExecutableDefinition)
+    , Definition(ExecutableDefinition, TypeSystemDefinition)
     , Directive(..)
     , Document
     , ExecutableDefinition(..)
@@ -15,11 +15,14 @@ module Language.GraphQL.AST.Document
     , ObjectField(..)
     , OperationDefinition(..)
     , OperationType(..)
+    , OperationTypeDefinition(..)
+    , OperationTypeDefinitions
     , Selection(..)
     , SelectionSet
     , SelectionSetOpt
     , Type(..)
     , TypeCondition
+    , TypeSystemDefinition(..)
     , Value(..)
     , VariableDefinition(..)
     ) where
@@ -228,7 +231,7 @@ data Directive = Directive Name [Argument] deriving (Eq, Show)
 -- * Type System
 
 data TypeSystemDefinition
-    = SchemaDefinition [Directive] RootOperationTypeDefinitions
+    = SchemaDefinition [Directive] OperationTypeDefinitions
     | TypeDefinition TypeDefinition
     | DirectiveDefinition
         Description Name ArgumentsDefinition DirectiveLocation
@@ -243,14 +246,14 @@ data TypeSystemExtension
 
 -- ** Schema
 
-type RootOperationTypeDefinitions = NonEmpty RootOperationTypeDefinition
+type OperationTypeDefinitions = NonEmpty OperationTypeDefinition
 
-data RootOperationTypeDefinition
-    = RootOperationTypeDefinition OperationType NamedType
+data OperationTypeDefinition
+    = OperationTypeDefinition OperationType NamedType
     deriving (Eq, Show)
 
 data SchemaExtension
-    = SchemaOperationExtension [Directive] RootOperationTypeDefinitions
+    = SchemaOperationExtension [Directive] OperationTypeDefinitions
     | SchemaDirectiveExtension (NonEmpty Directive)
     deriving (Eq, Show)
 
diff --git a/src/Language/GraphQL/AST/Parser.hs b/src/Language/GraphQL/AST/Parser.hs
index d8b467a..8a5f67b 100644
--- a/src/Language/GraphQL/AST/Parser.hs
+++ b/src/Language/GraphQL/AST/Parser.hs
@@ -8,21 +8,44 @@ module Language.GraphQL.AST.Parser
 
 import Control.Applicative (Alternative(..), optional)
 import qualified Control.Applicative.Combinators.NonEmpty as NonEmpty
-import Language.GraphQL.AST
-import qualified Language.GraphQL.AST.Document as Document
+import Language.GraphQL.AST.Document
 import Language.GraphQL.AST.Lexer
 import Text.Megaparsec (lookAhead, option, try, (<?>))
 
 -- | Parser for the GraphQL documents.
-document :: Parser Document.Document
+document :: Parser Document
 document = unicodeBOM
     >> spaceConsumer
-    >> lexeme (NonEmpty.some $ Document.ExecutableDefinition <$> definition)
+    >> lexeme (NonEmpty.some definition)
 
-definition :: Parser ExecutableDefinition
-definition = DefinitionOperation <$> operationDefinition
-         <|> DefinitionFragment  <$> fragmentDefinition
-         <?> "definition error!"
+definition :: Parser Definition
+definition = ExecutableDefinition <$> executableDefinition
+    <|> TypeSystemDefinition <$> typeSystemDefinition
+    <?> "Definition"
+
+executableDefinition :: Parser ExecutableDefinition
+executableDefinition = DefinitionOperation <$> operationDefinition
+    <|> DefinitionFragment  <$> fragmentDefinition
+    <?> "ExecutableDefinition"
+
+typeSystemDefinition :: Parser TypeSystemDefinition
+typeSystemDefinition = schemaDefinition
+
+schemaDefinition :: Parser TypeSystemDefinition
+schemaDefinition = SchemaDefinition
+    <$ symbol "schema"
+    <*> opt directives
+    <*> operationTypeDefinitions
+    <?> "SchemaDefinition"
+
+operationTypeDefinitions :: Parser OperationTypeDefinitions
+operationTypeDefinitions  = braces $ manyNE operationTypeDefinition
+
+operationTypeDefinition :: Parser OperationTypeDefinition
+operationTypeDefinition = OperationTypeDefinition
+    <$> operationType <* colon
+    <*> name
+    <?> "OperationTypeDefinition"
 
 operationDefinition :: Parser OperationDefinition
 operationDefinition = SelectionSet <$> selectionSet
@@ -39,7 +62,7 @@ operationDefinition = SelectionSet <$> selectionSet
 operationType :: Parser OperationType
 operationType = Query <$ symbol "query"
     <|> Mutation <$ symbol "mutation"
-    <?> "operationType error"
+    -- <?> Keep default error message
 
 -- * SelectionSet
 
diff --git a/tests/Language/GraphQL/AST/ParserSpec.hs b/tests/Language/GraphQL/AST/ParserSpec.hs
index 420d3cf..c51fa57 100644
--- a/tests/Language/GraphQL/AST/ParserSpec.hs
+++ b/tests/Language/GraphQL/AST/ParserSpec.hs
@@ -42,3 +42,6 @@ spec = describe "Parser" $ do
             mutation auth{
                 test(username: """username""", password: """password""")
             }|]
+
+    it "parses minimal schema definition" $
+        parse document "" `shouldSucceedOn` [r|schema { query: Query }|]