summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--CHANGELOG.md1
-rw-r--r--src/Language/GraphQL/AST/Document.hs23
-rw-r--r--src/Language/GraphQL/AST/Lexer.hs16
-rw-r--r--src/Language/GraphQL/AST/Parser.hs92
-rw-r--r--tests/Language/GraphQL/AST/ParserSpec.hs30
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
+ }
+ |]
generated by cgit v1.2.3 (git 2.26.2) at 2026-06-26 22:14:36 +0000