From 8efb08fda157770afb836537b27c2cd55042b706 Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Sun, 5 Jan 2020 07:42:04 +0100 Subject: [PATCH] Parse ObjectDefinition --- CHANGELOG.md | 1 + src/Language/GraphQL/AST/Document.hs | 23 +++++- src/Language/GraphQL/AST/Lexer.hs | 16 +---- src/Language/GraphQL/AST/Parser.hs | 92 +++++++++++++++++++++--- tests/Language/GraphQL/AST/ParserSpec.hs | 30 +++++++- 5 files changed, 135 insertions(+), 27 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 2700497..59b8105 100644 --- a/CHANGELOG.md +++ b/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 diff --git a/src/Language/GraphQL/AST/Document.hs b/src/Language/GraphQL/AST/Document.hs index 30ec897..619a6f3 100644 --- a/src/Language/GraphQL/AST/Document.hs +++ b/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) diff --git a/src/Language/GraphQL/AST/Lexer.hs b/src/Language/GraphQL/AST/Lexer.hs index 80370d4..1cb3363 100644 --- a/src/Language/GraphQL/AST/Lexer.hs +++ b/src/Language/GraphQL/AST/Lexer.hs @@ -28,15 +28,8 @@ module Language.GraphQL.AST.Lexer , unicodeBOM ) where -import Control.Applicative ( Alternative(..) - , liftA2 - ) -import Data.Char ( chr - , digitToInt - , isAsciiLower - , isAsciiUpper - , ord - ) +import Control.Applicative (Alternative(..), liftA2) +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 - , digitChar - , space1 - ) +import Text.Megaparsec.Char (char, digitChar, space1) import qualified Text.Megaparsec.Char.Lexer as Lexer import qualified Data.Text as T import qualified Data.Text.Lazy as TL diff --git a/src/Language/GraphQL/AST/Parser.hs b/src/Language/GraphQL/AST/Parser.hs index 8a5f67b..a851a66 100644 --- a/src/Language/GraphQL/AST/Parser.hs +++ b/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_ - <*> optional defaultValue + <*> type' + <*> defaultValue + "VariableDefinition" variable :: Parser Name variable = dollar *> name -defaultValue :: Parser Value -defaultValue = equals *> value +defaultValue :: Parser (Maybe Value) +defaultValue = optional (equals *> value) "DefaultValue" -- * Input Types -type_ :: Parser Type -type_ = try (TypeNonNull <$> nonNullType) - <|> TypeList <$> brackets type_ +type' :: Parser Type +type' = try (TypeNonNull <$> nonNullType) + <|> 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 diff --git a/tests/Language/GraphQL/AST/ParserSpec.hs b/tests/Language/GraphQL/AST/ParserSpec.hs index c51fa57..8d6b576 100644 --- a/tests/Language/GraphQL/AST/ParserSpec.hs +++ b/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 + } + |]