diff options
Diffstat (limited to 'src/Language/GraphQL/AST/Parser.hs')
| -rw-r--r-- | src/Language/GraphQL/AST/Parser.hs | 218 |
1 files changed, 125 insertions, 93 deletions
diff --git a/src/Language/GraphQL/AST/Parser.hs b/src/Language/GraphQL/AST/Parser.hs index c18c36a..687d8f5 100644 --- a/src/Language/GraphQL/AST/Parser.hs +++ b/src/Language/GraphQL/AST/Parser.hs @@ -1,12 +1,13 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} -- | @GraphQL@ document parser. module Language.GraphQL.AST.Parser ( document ) where -import Control.Applicative (Alternative(..), optional) +import Control.Applicative (Alternative(..), liftA2, optional) import Control.Applicative.Combinators (sepBy1) import qualified Control.Applicative.Combinators.NonEmpty as NonEmpty import Data.List.NonEmpty (NonEmpty(..)) @@ -19,19 +20,47 @@ import Language.GraphQL.AST.DirectiveLocation ) import Language.GraphQL.AST.Document import Language.GraphQL.AST.Lexer -import Text.Megaparsec (lookAhead, option, try, (<?>)) +import Text.Megaparsec + ( SourcePos(..) + , getSourcePos + , lookAhead + , option + , try + , unPos + , (<?>) + ) -- | Parser for the GraphQL documents. document :: Parser Document document = unicodeBOM - >> spaceConsumer - >> lexeme (NonEmpty.some definition) + *> spaceConsumer + *> lexeme (NonEmpty.some definition) definition :: Parser Definition -definition = ExecutableDefinition <$> executableDefinition - <|> TypeSystemDefinition <$> typeSystemDefinition - <|> TypeSystemExtension <$> typeSystemExtension +definition = executableDefinition' + <|> typeSystemDefinition' + <|> typeSystemExtension' <?> "Definition" + where + executableDefinition' = do + location <- getLocation + definition' <- executableDefinition + pure $ ExecutableDefinition definition' location + typeSystemDefinition' = do + location <- getLocation + definition' <- typeSystemDefinition + pure $ TypeSystemDefinition definition' location + typeSystemExtension' = do + location <- getLocation + definition' <- typeSystemExtension + pure $ TypeSystemExtension definition' location + +getLocation :: Parser Location +getLocation = fromSourcePosition <$> getSourcePos + where + fromSourcePosition SourcePos{..} = + Location (wordFromPosition sourceLine) (wordFromPosition sourceColumn) + wordFromPosition = fromIntegral . unPos executableDefinition :: Parser ExecutableDefinition executableDefinition = DefinitionOperation <$> operationDefinition @@ -40,19 +69,22 @@ executableDefinition = DefinitionOperation <$> operationDefinition typeSystemDefinition :: Parser TypeSystemDefinition typeSystemDefinition = schemaDefinition - <|> TypeDefinition <$> typeDefinition - <|> directiveDefinition + <|> typeSystemDefinitionWithDescription <?> "TypeSystemDefinition" + where + typeSystemDefinitionWithDescription = description + >>= liftA2 (<|>) typeDefinition' directiveDefinition + typeDefinition' description' = TypeDefinition + <$> typeDefinition description' typeSystemExtension :: Parser TypeSystemExtension typeSystemExtension = SchemaExtension <$> schemaExtension <|> TypeExtension <$> typeExtension <?> "TypeSystemExtension" -directiveDefinition :: Parser TypeSystemDefinition -directiveDefinition = DirectiveDefinition - <$> description - <* symbol "directive" +directiveDefinition :: Description -> Parser TypeSystemDefinition +directiveDefinition description' = DirectiveDefinition description' + <$ symbol "directive" <* at <*> name <*> argumentsDefinition @@ -63,11 +95,13 @@ directiveDefinition = DirectiveDefinition directiveLocations :: Parser (NonEmpty DirectiveLocation) directiveLocations = optional pipe *> directiveLocation `NonEmpty.sepBy1` pipe + <?> "DirectiveLocations" directiveLocation :: Parser DirectiveLocation directiveLocation = Directive.ExecutableDirectiveLocation <$> executableDirectiveLocation <|> Directive.TypeSystemDirectiveLocation <$> typeSystemDirectiveLocation + <?> "DirectiveLocation" executableDirectiveLocation :: Parser ExecutableDirectiveLocation executableDirectiveLocation = Directive.Query <$ symbol "QUERY" @@ -77,6 +111,7 @@ executableDirectiveLocation = Directive.Query <$ symbol "QUERY" <|> Directive.FragmentDefinition <$ "FRAGMENT_DEFINITION" <|> Directive.FragmentSpread <$ "FRAGMENT_SPREAD" <|> Directive.InlineFragment <$ "INLINE_FRAGMENT" + <?> "ExecutableDirectiveLocation" typeSystemDirectiveLocation :: Parser TypeSystemDirectiveLocation typeSystemDirectiveLocation = Directive.Schema <$ symbol "SCHEMA" @@ -90,14 +125,15 @@ typeSystemDirectiveLocation = Directive.Schema <$ symbol "SCHEMA" <|> Directive.EnumValue <$ symbol "ENUM_VALUE" <|> Directive.InputObject <$ symbol "INPUT_OBJECT" <|> Directive.InputFieldDefinition <$ symbol "INPUT_FIELD_DEFINITION" - -typeDefinition :: Parser TypeDefinition -typeDefinition = scalarTypeDefinition - <|> objectTypeDefinition - <|> interfaceTypeDefinition - <|> unionTypeDefinition - <|> enumTypeDefinition - <|> inputObjectTypeDefinition + <?> "TypeSystemDirectiveLocation" + +typeDefinition :: Description -> Parser TypeDefinition +typeDefinition description' = scalarTypeDefinition description' + <|> objectTypeDefinition description' + <|> interfaceTypeDefinition description' + <|> unionTypeDefinition description' + <|> enumTypeDefinition description' + <|> inputObjectTypeDefinition description' <?> "TypeDefinition" typeExtension :: Parser TypeExtension @@ -109,10 +145,9 @@ typeExtension = scalarTypeExtension <|> inputObjectTypeExtension <?> "TypeExtension" -scalarTypeDefinition :: Parser TypeDefinition -scalarTypeDefinition = ScalarTypeDefinition - <$> description - <* symbol "scalar" +scalarTypeDefinition :: Description -> Parser TypeDefinition +scalarTypeDefinition description' = ScalarTypeDefinition description' + <$ symbol "scalar" <*> name <*> directives <?> "ScalarTypeDefinition" @@ -121,10 +156,9 @@ scalarTypeExtension :: Parser TypeExtension scalarTypeExtension = extend "scalar" "ScalarTypeExtension" $ (ScalarTypeExtension <$> name <*> NonEmpty.some directive) :| [] -objectTypeDefinition :: Parser TypeDefinition -objectTypeDefinition = ObjectTypeDefinition - <$> description - <* symbol "type" +objectTypeDefinition :: Description -> Parser TypeDefinition +objectTypeDefinition description' = ObjectTypeDefinition description' + <$ symbol "type" <*> name <*> option (ImplementsInterfaces []) (implementsInterfaces sepBy1) <*> directives @@ -153,13 +187,12 @@ objectTypeExtension = extend "type" "ObjectTypeExtension" description :: Parser Description description = Description - <$> optional (string <|> blockString) + <$> optional stringValue <?> "Description" -unionTypeDefinition :: Parser TypeDefinition -unionTypeDefinition = UnionTypeDefinition - <$> description - <* symbol "union" +unionTypeDefinition :: Description -> Parser TypeDefinition +unionTypeDefinition description' = UnionTypeDefinition description' + <$ symbol "union" <*> name <*> directives <*> option (UnionMemberTypes []) (unionMemberTypes sepBy1) @@ -187,10 +220,9 @@ unionMemberTypes sepBy' = UnionMemberTypes <*> name `sepBy'` pipe <?> "UnionMemberTypes" -interfaceTypeDefinition :: Parser TypeDefinition -interfaceTypeDefinition = InterfaceTypeDefinition - <$> description - <* symbol "interface" +interfaceTypeDefinition :: Description -> Parser TypeDefinition +interfaceTypeDefinition description' = InterfaceTypeDefinition description' + <$ symbol "interface" <*> name <*> directives <*> braces (many fieldDefinition) @@ -208,10 +240,9 @@ interfaceTypeExtension = extend "interface" "InterfaceTypeExtension" <$> name <*> NonEmpty.some directive -enumTypeDefinition :: Parser TypeDefinition -enumTypeDefinition = EnumTypeDefinition - <$> description - <* symbol "enum" +enumTypeDefinition :: Description -> Parser TypeDefinition +enumTypeDefinition description' = EnumTypeDefinition description' + <$ symbol "enum" <*> name <*> directives <*> listOptIn braces enumValueDefinition @@ -229,10 +260,9 @@ enumTypeExtension = extend "enum" "EnumTypeExtension" <$> name <*> NonEmpty.some directive -inputObjectTypeDefinition :: Parser TypeDefinition -inputObjectTypeDefinition = InputObjectTypeDefinition - <$> description - <* symbol "input" +inputObjectTypeDefinition :: Description -> Parser TypeDefinition +inputObjectTypeDefinition description' = InputObjectTypeDefinition description' + <$ symbol "input" <*> name <*> directives <*> listOptIn braces inputValueDefinition @@ -321,7 +351,7 @@ operationTypeDefinition = OperationTypeDefinition operationDefinition :: Parser OperationDefinition operationDefinition = SelectionSet <$> selectionSet <|> operationDefinition' - <?> "operationDefinition error" + <?> "OperationDefinition" where operationDefinition' = OperationDefinition <$> operationType @@ -333,23 +363,20 @@ operationDefinition = SelectionSet <$> selectionSet operationType :: Parser OperationType operationType = Query <$ symbol "query" <|> Mutation <$ symbol "mutation" - -- <?> Keep default error message - --- * SelectionSet + <|> Subscription <$ symbol "subscription" + <?> "OperationType" selectionSet :: Parser SelectionSet -selectionSet = braces $ NonEmpty.some selection +selectionSet = braces (NonEmpty.some selection) <?> "SelectionSet" selectionSetOpt :: Parser SelectionSetOpt -selectionSetOpt = listOptIn braces selection +selectionSetOpt = listOptIn braces selection <?> "SelectionSet" selection :: Parser Selection selection = field <|> try fragmentSpread <|> inlineFragment - <?> "selection error!" - --- * Field + <?> "Selection" field :: Parser Selection field = Field @@ -358,25 +385,23 @@ field = Field <*> arguments <*> directives <*> selectionSetOpt + <?> "Field" alias :: Parser Alias -alias = try $ name <* colon - --- * Arguments +alias = try (name <* colon) <?> "Alias" arguments :: Parser [Argument] -arguments = listOptIn parens argument +arguments = listOptIn parens argument <?> "Arguments" argument :: Parser Argument -argument = Argument <$> name <* colon <*> value - --- * Fragments +argument = Argument <$> name <* colon <*> value <?> "Argument" fragmentSpread :: Parser Selection fragmentSpread = FragmentSpread <$ spread <*> fragmentName <*> directives + <?> "FragmentSpread" inlineFragment :: Parser Selection inlineFragment = InlineFragment @@ -384,62 +409,74 @@ inlineFragment = InlineFragment <*> optional typeCondition <*> directives <*> selectionSet + <?> "InlineFragment" fragmentDefinition :: Parser FragmentDefinition fragmentDefinition = FragmentDefinition - <$ symbol "fragment" - <*> name - <*> typeCondition - <*> directives - <*> selectionSet + <$ symbol "fragment" + <*> name + <*> typeCondition + <*> directives + <*> selectionSet + <?> "FragmentDefinition" fragmentName :: Parser Name -fragmentName = but (symbol "on") *> name +fragmentName = but (symbol "on") *> name <?> "FragmentName" typeCondition :: Parser TypeCondition -typeCondition = symbol "on" *> name - --- * Input Values +typeCondition = symbol "on" *> name <?> "TypeCondition" value :: Parser Value value = Variable <$> variable <|> Float <$> try float <|> Int <$> integer <|> Boolean <$> booleanValue - <|> Null <$ symbol "null" - <|> String <$> blockString - <|> String <$> string + <|> Null <$ nullValue + <|> String <$> stringValue <|> Enum <$> try enumValue <|> List <$> brackets (some value) <|> Object <$> braces (some $ objectField value) - <?> "value error!" + <?> "Value" constValue :: Parser ConstValue constValue = ConstFloat <$> try float <|> ConstInt <$> integer <|> ConstBoolean <$> booleanValue - <|> ConstNull <$ symbol "null" - <|> ConstString <$> blockString - <|> ConstString <$> string + <|> ConstNull <$ nullValue + <|> ConstString <$> stringValue <|> ConstEnum <$> try enumValue <|> ConstList <$> brackets (some constValue) <|> ConstObject <$> braces (some $ objectField constValue) - <?> "value error!" + <?> "Value" booleanValue :: Parser Bool booleanValue = True <$ symbol "true" <|> False <$ symbol "false" + <?> "BooleanValue" enumValue :: Parser Name -enumValue = but (symbol "true") *> but (symbol "false") *> but (symbol "null") *> name +enumValue = but (symbol "true") + *> but (symbol "false") + *> but (symbol "null") + *> name + <?> "EnumValue" -objectField :: Parser a -> Parser (ObjectField a) -objectField valueParser = ObjectField <$> name <* colon <*> valueParser +stringValue :: Parser Text +stringValue = blockString <|> string <?> "StringValue" --- * Variables +nullValue :: Parser Text +nullValue = symbol "null" <?> "NullValue" + +objectField :: Parser a -> Parser (ObjectField a) +objectField valueParser = ObjectField + <$> name + <* colon + <*> valueParser + <?> "ObjectField" variableDefinitions :: Parser [VariableDefinition] variableDefinitions = listOptIn parens variableDefinition + <?> "VariableDefinitions" variableDefinition :: Parser VariableDefinition variableDefinition = VariableDefinition @@ -450,13 +487,11 @@ variableDefinition = VariableDefinition <?> "VariableDefinition" variable :: Parser Name -variable = dollar *> name +variable = dollar *> name <?> "Variable" defaultValue :: Parser (Maybe ConstValue) defaultValue = optional (equals *> constValue) <?> "DefaultValue" --- * Input Types - type' :: Parser Type type' = try (TypeNonNull <$> nonNullType) <|> TypeList <$> brackets type' @@ -465,21 +500,18 @@ type' = try (TypeNonNull <$> nonNullType) nonNullType :: Parser NonNullType nonNullType = NonNullTypeNamed <$> name <* bang - <|> NonNullTypeList <$> brackets type' <* bang - <?> "nonNullType error!" - --- * Directives + <|> NonNullTypeList <$> brackets type' <* bang + <?> "NonNullType" directives :: Parser [Directive] -directives = many directive +directives = many directive <?> "Directives" directive :: Parser Directive directive = Directive <$ at <*> name <*> arguments - --- * Internal + <?> "Directive" listOptIn :: (Parser [a] -> Parser [a]) -> Parser a -> Parser [a] listOptIn surround = option [] . surround . some |