Parse ObjectDefinition

CHANGELOG.md

@@ -9,6 +9,7 @@ and this project adheres to
 ## [Unreleased]
 ### Added
 - AST for the GraphQL schema.
+- Parser for the SchemaDefinition
 - `Trans.argument`.
 
 ### Changed

src/Language/GraphQL/AST/Document.hs

@@ -5,11 +5,17 @@
 module Language.GraphQL.AST.Document
     ( Alias
     , Argument(..)
+    , ArgumentsDefinition(..)
     , Definition(ExecutableDefinition, TypeSystemDefinition)
+    , Description(..)
     , Directive(..)
     , Document
     , ExecutableDefinition(..)
+    , FieldDefinition(..)
     , FragmentDefinition(..)
+    , ImplementsInterfaces(..)
+    , ImplementsInterfacesOpt(..)
+    , InputValueDefinition(..)
     , Name
     , NonNullType(..)
     , ObjectField(..)
@@ -22,6 +28,7 @@ module Language.GraphQL.AST.Document
     , SelectionSetOpt
     , Type(..)
     , TypeCondition
+    , TypeDefinition(..)
     , TypeSystemDefinition(..)
     , Value(..)
     , VariableDefinition(..)
@@ -302,13 +309,27 @@ newtype ImplementsInterfaces = ImplementsInterfaces (NonEmpty NamedType)
 newtype ImplementsInterfacesOpt = ImplementsInterfacesOpt [NamedType]
     deriving (Eq, Show)
 
+instance Semigroup ImplementsInterfacesOpt where
+    (ImplementsInterfacesOpt xs) <> (ImplementsInterfacesOpt ys) =
+        ImplementsInterfacesOpt $ xs <> ys
+
+instance Monoid ImplementsInterfacesOpt where
+    mempty = ImplementsInterfacesOpt []
+
 data FieldDefinition
-    = FieldDefinition Description Name ArgumentsDefinition Type
+    = FieldDefinition Description Name ArgumentsDefinition Type [Directive]
     deriving (Eq, Show)
 
 newtype ArgumentsDefinition = ArgumentsDefinition [InputValueDefinition]
     deriving (Eq, Show)
 
+instance Semigroup ArgumentsDefinition where
+    (ArgumentsDefinition xs) <> (ArgumentsDefinition ys) =
+        ArgumentsDefinition $ xs <> ys
+
+instance Monoid ArgumentsDefinition where
+    mempty = ArgumentsDefinition []
+
 data InputValueDefinition
     = InputValueDefinition Description Name Type (Maybe Value) [Directive]
     deriving (Eq, Show)

src/Language/GraphQL/AST/Lexer.hs

@@ -28,15 +28,8 @@ module Language.GraphQL.AST.Lexer
     , unicodeBOM
     ) where
 
-import Control.Applicative ( Alternative(..)
+import Control.Applicative (Alternative(..), liftA2)
-                           , liftA2
+import Data.Char (chr, digitToInt, isAsciiLower, isAsciiUpper, ord)
-                           )
-import Data.Char ( chr
-                 , digitToInt
-                 , isAsciiLower
-                 , isAsciiUpper
-                 , ord
-                 )
 import Data.Foldable (foldl')
 import Data.List (dropWhileEnd)
 import Data.Proxy (Proxy(..))
@@ -56,10 +49,7 @@ import Text.Megaparsec ( Parsec
                        , takeWhile1P
                        , try
                        )
-import Text.Megaparsec.Char ( char
+import Text.Megaparsec.Char (char, digitChar, space1)
-                            , digitChar
-                            , space1
-                            )
 import qualified Text.Megaparsec.Char.Lexer as Lexer
 import qualified Data.Text as T
 import qualified Data.Text.Lazy as TL

src/Language/GraphQL/AST/Parser.hs

@@ -8,6 +8,7 @@ module Language.GraphQL.AST.Parser
 
 import Control.Applicative (Alternative(..), optional)
 import qualified Control.Applicative.Combinators.NonEmpty as NonEmpty
+import Control.Applicative.Combinators (sepBy)
 import Language.GraphQL.AST.Document
 import Language.GraphQL.AST.Lexer
 import Text.Megaparsec (lookAhead, option, try, (<?>))
@@ -30,6 +31,76 @@ executableDefinition = DefinitionOperation <$> operationDefinition
 
 typeSystemDefinition :: Parser TypeSystemDefinition
 typeSystemDefinition = schemaDefinition
+    <|> TypeDefinition <$> typeDefinition
+    <?> "TypeSystemDefinition"
+
+typeDefinition :: Parser TypeDefinition
+typeDefinition = scalarTypeDefinition
+    <|> objectTypeDefinition
+    <?> "TypeDefinition"
+
+scalarTypeDefinition :: Parser TypeDefinition
+scalarTypeDefinition = ScalarTypeDefinition
+    <$> description
+    <* symbol "scalar"
+    <*> name
+    <*> opt directives
+    <?> "ScalarTypeDefinition"
+
+objectTypeDefinition :: Parser TypeDefinition
+objectTypeDefinition = ObjectTypeDefinition
+    <$> description
+    <* symbol "type"
+    <*> name
+    <*> opt implementsInterfacesOpt
+    <*> opt directives
+    <*> braces (many fieldDefinition)
+    <?> "ObjectTypeDefinition"
+
+description :: Parser Description
+description = Description
+    <$> optional (string <|> blockString)
+    <?> "Description"
+
+{- TODO:
+    implementsInterfaces :: Parser ImplementsInterfaces
+implementsInterfaces = ImplementsInterfaces
+    <$ symbol "implements"
+    <* optional amp
+    <*> name `sepBy1` amp
+    <?> "ImplementsInterfaces" -}
+
+implementsInterfacesOpt :: Parser ImplementsInterfacesOpt
+implementsInterfacesOpt = ImplementsInterfacesOpt
+    <$ symbol "implements"
+    <* optional amp
+    <*> name `sepBy` amp
+    <?> "ImplementsInterfaces"
+
+inputValueDefinition :: Parser InputValueDefinition
+inputValueDefinition = InputValueDefinition
+    <$> description
+    <*> name
+    <* colon
+    <*> type'
+    <*> defaultValue
+    <*> opt directives
+    <?> "InputValueDefinition"
+
+argumentsDefinition :: Parser ArgumentsDefinition
+argumentsDefinition = ArgumentsDefinition
+    <$> parens (many inputValueDefinition)
+    <?> "ArgumentsDefinition"
+
+fieldDefinition :: Parser FieldDefinition
+fieldDefinition = FieldDefinition
+    <$> description
+    <*> name
+    <*> opt argumentsDefinition
+    <* colon
+    <*> type'
+    <*> opt directives
+    <?> "FieldDefinition"
 
 schemaDefinition :: Parser TypeSystemDefinition
 schemaDefinition = SchemaDefinition
@@ -157,7 +228,7 @@ value = Variable <$> variable
     objectValue = braces $ some objectField
 
 objectField :: Parser ObjectField
-objectField = ObjectField <$> name <* symbol ":" <*> value
+objectField = ObjectField <$> name <* colon <*> value
 
 -- * Variables
 
@@ -168,26 +239,27 @@ variableDefinition :: Parser VariableDefinition
 variableDefinition = VariableDefinition
     <$> variable
     <*  colon
-    <*> type_
+    <*> type'
-    <*> optional defaultValue
+    <*> defaultValue
+    <?> "VariableDefinition"
 
 variable :: Parser Name
 variable = dollar *> name
 
-defaultValue :: Parser Value
+defaultValue :: Parser (Maybe Value)
-defaultValue = equals *> value
+defaultValue = optional (equals *> value) <?> "DefaultValue"
 
 -- * Input Types
 
-type_ :: Parser Type
+type' :: Parser Type
-type_ = try (TypeNonNull <$> nonNullType)
+type' = try (TypeNonNull <$> nonNullType)
-    <|> TypeList <$> brackets type_
+    <|> TypeList <$> brackets type'
     <|> TypeNamed <$> name
-    <?> "type_ error!"
+    <?> "Type"
 
 nonNullType :: Parser NonNullType
 nonNullType = NonNullTypeNamed <$> name <* bang
-          <|> NonNullTypeList  <$> brackets type_  <* bang
+          <|> NonNullTypeList  <$> brackets type'  <* bang
           <?> "nonNullType error!"
 
 -- * Directives

tests/Language/GraphQL/AST/ParserSpec.hs

@@ -28,20 +28,44 @@ spec = describe "Parser" $ do
     it "accepts two required arguments" $
         parse document "" `shouldSucceedOn` [r|
             mutation auth($username: String!, $password: String!){
-                test
+              test
             }|]
 
     it "accepts two string arguments" $
         parse document "" `shouldSucceedOn` [r|
             mutation auth{
-                test(username: "username", password: "password")
+              test(username: "username", password: "password")
             }|]
 
     it "accepts two block string arguments" $
         parse document "" `shouldSucceedOn` [r|
             mutation auth{
-                test(username: """username""", password: """password""")
+              test(username: """username""", password: """password""")
             }|]
 
     it "parses minimal schema definition" $
         parse document "" `shouldSucceedOn` [r|schema { query: Query }|]
+
+    it "parses minimal scalar definition" $
+        parse document "" `shouldSucceedOn` [r|scalar Time|]
+
+    it "parses ImplementsInterfaces" $
+        parse document "" `shouldSucceedOn` [r|
+            type Person implements NamedEntity & ValuedEntity {
+              name: String
+            }
+        |]
+
+    it "parses a  type without ImplementsInterfaces" $
+        parse document "" `shouldSucceedOn` [r|
+            type Person {
+              name: String
+            }
+        |]
+
+    it "parses ArgumentsDefinition in an ObjectDefinition" $
+        parse document "" `shouldSucceedOn` [r|
+            type Person {
+              name(first: String, last: String): String
+            }
+        |]