graphql/src/Language/GraphQL/AST/Parser.hs

492 lines
14 KiB
Haskell
Raw Normal View History

{-# LANGUAGE LambdaCase #-}
2019-06-21 10:44:58 +02:00
{-# LANGUAGE OverloadedStrings #-}
-- | @GraphQL@ document parser.
module Language.GraphQL.AST.Parser
2019-07-14 05:58:05 +02:00
( document
) where
import Control.Applicative (Alternative(..), optional)
import Control.Applicative.Combinators (sepBy1)
import qualified Control.Applicative.Combinators.NonEmpty as NonEmpty
2020-01-28 11:08:28 +01:00
import Data.List.NonEmpty (NonEmpty(..))
2020-01-07 13:56:58 +01:00
import Data.Text (Text)
2020-01-15 20:20:50 +01:00
import qualified Language.GraphQL.AST.DirectiveLocation as Directive
import Language.GraphQL.AST.DirectiveLocation
( DirectiveLocation
, ExecutableDirectiveLocation
, TypeSystemDirectiveLocation
)
2020-01-03 07:20:48 +01:00
import Language.GraphQL.AST.Document
import Language.GraphQL.AST.Lexer
import Text.Megaparsec (lookAhead, option, try, (<?>))
-- | Parser for the GraphQL documents.
2020-01-03 07:20:48 +01:00
document :: Parser Document
document = unicodeBOM
>> spaceConsumer
2020-01-03 07:20:48 +01:00
>> lexeme (NonEmpty.some definition)
2020-01-03 07:20:48 +01:00
definition :: Parser Definition
definition = ExecutableDefinition <$> executableDefinition
<|> TypeSystemDefinition <$> typeSystemDefinition
2020-01-25 16:37:17 +01:00
<|> TypeSystemExtension <$> typeSystemExtension
2020-01-03 07:20:48 +01:00
<?> "Definition"
executableDefinition :: Parser ExecutableDefinition
executableDefinition = DefinitionOperation <$> operationDefinition
<|> DefinitionFragment <$> fragmentDefinition
<?> "ExecutableDefinition"
typeSystemDefinition :: Parser TypeSystemDefinition
typeSystemDefinition = schemaDefinition
2020-01-05 07:42:04 +01:00
<|> TypeDefinition <$> typeDefinition
2020-01-15 20:20:50 +01:00
<|> directiveDefinition
2020-01-05 07:42:04 +01:00
<?> "TypeSystemDefinition"
2020-01-25 16:37:17 +01:00
typeSystemExtension :: Parser TypeSystemExtension
typeSystemExtension = SchemaExtension <$> schemaExtension
<|> TypeExtension <$> typeExtension
2020-01-25 16:37:17 +01:00
<?> "TypeSystemExtension"
2020-01-15 20:20:50 +01:00
directiveDefinition :: Parser TypeSystemDefinition
directiveDefinition = DirectiveDefinition
<$> description
<* symbol "directive"
<* at
<*> name
<*> argumentsDefinition
<* symbol "on"
<*> directiveLocations
<?> "DirectiveDefinition"
2020-01-15 20:20:50 +01:00
directiveLocations :: Parser (NonEmpty DirectiveLocation)
directiveLocations = optional pipe
*> directiveLocation `NonEmpty.sepBy1` pipe
directiveLocation :: Parser DirectiveLocation
directiveLocation
= Directive.ExecutableDirectiveLocation <$> executableDirectiveLocation
<|> Directive.TypeSystemDirectiveLocation <$> typeSystemDirectiveLocation
executableDirectiveLocation :: Parser ExecutableDirectiveLocation
executableDirectiveLocation = Directive.Query <$ symbol "QUERY"
<|> Directive.Mutation <$ symbol "MUTATION"
<|> Directive.Subscription <$ symbol "SUBSCRIPTION"
<|> Directive.Field <$ symbol "FIELD"
<|> Directive.FragmentDefinition <$ "FRAGMENT_DEFINITION"
<|> Directive.FragmentSpread <$ "FRAGMENT_SPREAD"
<|> Directive.InlineFragment <$ "INLINE_FRAGMENT"
typeSystemDirectiveLocation :: Parser TypeSystemDirectiveLocation
typeSystemDirectiveLocation = Directive.Schema <$ symbol "SCHEMA"
<|> Directive.Scalar <$ symbol "SCALAR"
<|> Directive.Object <$ symbol "OBJECT"
<|> Directive.FieldDefinition <$ symbol "FIELD_DEFINITION"
<|> Directive.ArgumentDefinition <$ symbol "ARGUMENT_DEFINITION"
<|> Directive.Interface <$ symbol "INTERFACE"
<|> Directive.Union <$ symbol "UNION"
<|> Directive.Enum <$ symbol "ENUM"
<|> Directive.EnumValue <$ symbol "ENUM_VALUE"
<|> Directive.InputObject <$ symbol "INPUT_OBJECT"
<|> Directive.InputFieldDefinition <$ symbol "INPUT_FIELD_DEFINITION"
2020-01-05 07:42:04 +01:00
typeDefinition :: Parser TypeDefinition
typeDefinition = scalarTypeDefinition
<|> objectTypeDefinition
2020-01-11 08:32:25 +01:00
<|> interfaceTypeDefinition
2020-01-07 13:56:58 +01:00
<|> unionTypeDefinition
<|> enumTypeDefinition
<|> inputObjectTypeDefinition
2020-01-05 07:42:04 +01:00
<?> "TypeDefinition"
typeExtension :: Parser TypeExtension
typeExtension = scalarTypeExtension
<|> objectTypeExtension
<|> interfaceTypeExtension
<|> unionTypeExtension
<|> enumTypeExtension
<|> inputObjectTypeExtension
<?> "TypeExtension"
2020-01-05 07:42:04 +01:00
scalarTypeDefinition :: Parser TypeDefinition
scalarTypeDefinition = ScalarTypeDefinition
<$> description
<* symbol "scalar"
<*> name
2020-01-15 20:20:50 +01:00
<*> directives
2020-01-05 07:42:04 +01:00
<?> "ScalarTypeDefinition"
scalarTypeExtension :: Parser TypeExtension
2020-01-28 11:08:28 +01:00
scalarTypeExtension = extend "scalar" "ScalarTypeExtension"
$ (ScalarTypeExtension <$> name <*> NonEmpty.some directive) :| []
2020-01-05 07:42:04 +01:00
objectTypeDefinition :: Parser TypeDefinition
objectTypeDefinition = ObjectTypeDefinition
<$> description
<* symbol "type"
<*> name
2020-01-07 13:56:58 +01:00
<*> option (ImplementsInterfaces []) (implementsInterfaces sepBy1)
2020-01-15 20:20:50 +01:00
<*> directives
2020-01-05 07:42:04 +01:00
<*> braces (many fieldDefinition)
<?> "ObjectTypeDefinition"
objectTypeExtension :: Parser TypeExtension
2020-01-28 11:08:28 +01:00
objectTypeExtension = extend "type" "ObjectTypeExtension"
$ fieldsDefinitionExtension :|
[ directivesExtension
, implementsInterfacesExtension
]
where
fieldsDefinitionExtension = ObjectTypeFieldsDefinitionExtension
<$> name
<*> option (ImplementsInterfaces []) (implementsInterfaces sepBy1)
<*> directives
<*> braces (NonEmpty.some fieldDefinition)
directivesExtension = ObjectTypeDirectivesExtension
<$> name
<*> option (ImplementsInterfaces []) (implementsInterfaces sepBy1)
<*> NonEmpty.some directive
implementsInterfacesExtension = ObjectTypeImplementsInterfacesExtension
<$> name
<*> implementsInterfaces NonEmpty.sepBy1
2020-01-05 07:42:04 +01:00
description :: Parser Description
description = Description
<$> optional (string <|> blockString)
<?> "Description"
2020-01-07 13:56:58 +01:00
unionTypeDefinition :: Parser TypeDefinition
unionTypeDefinition = UnionTypeDefinition
<$> description
<* symbol "union"
<*> name
2020-01-15 20:20:50 +01:00
<*> directives
2020-01-07 13:56:58 +01:00
<*> option (UnionMemberTypes []) (unionMemberTypes sepBy1)
<?> "UnionTypeDefinition"
unionTypeExtension :: Parser TypeExtension
2020-01-28 11:08:28 +01:00
unionTypeExtension = extend "union" "UnionTypeExtension"
$ unionMemberTypesExtension :| [directivesExtension]
where
unionMemberTypesExtension = UnionTypeUnionMemberTypesExtension
<$> name
<*> directives
<*> unionMemberTypes NonEmpty.sepBy1
directivesExtension = UnionTypeDirectivesExtension
<$> name
<*> NonEmpty.some directive
2020-01-07 13:56:58 +01:00
unionMemberTypes ::
Foldable t =>
(Parser Text -> Parser Text -> Parser (t NamedType)) ->
Parser (UnionMemberTypes t)
unionMemberTypes sepBy' = UnionMemberTypes
<$ equals
<* optional pipe
<*> name `sepBy'` pipe
<?> "UnionMemberTypes"
2020-01-05 07:42:04 +01:00
2020-01-11 08:32:25 +01:00
interfaceTypeDefinition :: Parser TypeDefinition
interfaceTypeDefinition = InterfaceTypeDefinition
<$> description
<* symbol "interface"
<*> name
2020-01-15 20:20:50 +01:00
<*> directives
2020-01-11 08:32:25 +01:00
<*> braces (many fieldDefinition)
<?> "InterfaceTypeDefinition"
interfaceTypeExtension :: Parser TypeExtension
2020-01-28 11:08:28 +01:00
interfaceTypeExtension = extend "interface" "InterfaceTypeExtension"
$ fieldsDefinitionExtension :| [directivesExtension]
where
fieldsDefinitionExtension = InterfaceTypeFieldsDefinitionExtension
<$> name
<*> directives
<*> braces (NonEmpty.some fieldDefinition)
directivesExtension = InterfaceTypeDirectivesExtension
<$> name
<*> NonEmpty.some directive
enumTypeDefinition :: Parser TypeDefinition
enumTypeDefinition = EnumTypeDefinition
<$> description
<* symbol "enum"
<*> name
2020-01-15 20:20:50 +01:00
<*> directives
<*> listOptIn braces enumValueDefinition
<?> "EnumTypeDefinition"
enumTypeExtension :: Parser TypeExtension
2020-01-28 11:08:28 +01:00
enumTypeExtension = extend "enum" "EnumTypeExtension"
$ enumValuesDefinitionExtension :| [directivesExtension]
where
enumValuesDefinitionExtension = EnumTypeEnumValuesDefinitionExtension
<$> name
<*> directives
<*> braces (NonEmpty.some enumValueDefinition)
directivesExtension = EnumTypeDirectivesExtension
<$> name
<*> NonEmpty.some directive
inputObjectTypeDefinition :: Parser TypeDefinition
inputObjectTypeDefinition = InputObjectTypeDefinition
<$> description
<* symbol "input"
<*> name
2020-01-15 20:20:50 +01:00
<*> directives
<*> listOptIn braces inputValueDefinition
<?> "InputObjectTypeDefinition"
inputObjectTypeExtension :: Parser TypeExtension
2020-01-28 11:08:28 +01:00
inputObjectTypeExtension = extend "input" "InputObjectTypeExtension"
$ inputFieldsDefinitionExtension :| [directivesExtension]
where
inputFieldsDefinitionExtension = InputObjectTypeInputFieldsDefinitionExtension
<$> name
<*> directives
<*> braces (NonEmpty.some inputValueDefinition)
directivesExtension = InputObjectTypeDirectivesExtension
<$> name
<*> NonEmpty.some directive
enumValueDefinition :: Parser EnumValueDefinition
enumValueDefinition = EnumValueDefinition
<$> description
<*> enumValue
2020-01-15 20:20:50 +01:00
<*> directives
<?> "EnumValueDefinition"
2020-01-07 13:56:58 +01:00
implementsInterfaces ::
Foldable t =>
(Parser Text -> Parser Text -> Parser (t NamedType)) ->
Parser (ImplementsInterfaces t)
implementsInterfaces sepBy' = ImplementsInterfaces
2020-01-05 07:42:04 +01:00
<$ symbol "implements"
<* optional amp
2020-01-07 13:56:58 +01:00
<*> name `sepBy'` amp
2020-01-05 07:42:04 +01:00
<?> "ImplementsInterfaces"
inputValueDefinition :: Parser InputValueDefinition
inputValueDefinition = InputValueDefinition
<$> description
<*> name
<* colon
<*> type'
<*> defaultValue
2020-01-15 20:20:50 +01:00
<*> directives
2020-01-05 07:42:04 +01:00
<?> "InputValueDefinition"
argumentsDefinition :: Parser ArgumentsDefinition
argumentsDefinition = ArgumentsDefinition
2020-01-15 20:20:50 +01:00
<$> listOptIn parens inputValueDefinition
2020-01-05 07:42:04 +01:00
<?> "ArgumentsDefinition"
fieldDefinition :: Parser FieldDefinition
fieldDefinition = FieldDefinition
<$> description
<*> name
2020-01-15 20:20:50 +01:00
<*> argumentsDefinition
2020-01-05 07:42:04 +01:00
<* colon
<*> type'
2020-01-15 20:20:50 +01:00
<*> directives
2020-01-05 07:42:04 +01:00
<?> "FieldDefinition"
2020-01-03 07:20:48 +01:00
schemaDefinition :: Parser TypeSystemDefinition
schemaDefinition = SchemaDefinition
<$ symbol "schema"
2020-01-15 20:20:50 +01:00
<*> directives
2020-01-03 07:20:48 +01:00
<*> operationTypeDefinitions
<?> "SchemaDefinition"
2020-01-25 16:37:17 +01:00
operationTypeDefinitions :: Parser (NonEmpty OperationTypeDefinition)
operationTypeDefinitions = braces $ NonEmpty.some operationTypeDefinition
schemaExtension :: Parser SchemaExtension
2020-01-28 11:08:28 +01:00
schemaExtension = extend "schema" "SchemaExtension"
$ schemaOperationExtension :| [directivesExtension]
where
2020-01-28 11:08:28 +01:00
directivesExtension = SchemaDirectivesExtension
<$> NonEmpty.some directive
2020-01-25 16:37:17 +01:00
schemaOperationExtension = SchemaOperationExtension
<$> directives
<*> operationTypeDefinitions
2020-01-03 07:20:48 +01:00
operationTypeDefinition :: Parser OperationTypeDefinition
operationTypeDefinition = OperationTypeDefinition
<$> operationType <* colon
<*> name
<?> "OperationTypeDefinition"
operationDefinition :: Parser OperationDefinition
2019-12-28 07:07:58 +01:00
operationDefinition = SelectionSet <$> selectionSet
<|> operationDefinition'
<?> "operationDefinition error"
where
operationDefinition'
= OperationDefinition <$> operationType
<*> optional name
<*> variableDefinitions
<*> directives
2019-12-28 07:07:58 +01:00
<*> selectionSet
operationType :: Parser OperationType
2019-06-21 10:44:58 +02:00
operationType = Query <$ symbol "query"
<|> Mutation <$ symbol "mutation"
2020-01-03 07:20:48 +01:00
-- <?> Keep default error message
-- * SelectionSet
selectionSet :: Parser SelectionSet
selectionSet = braces $ NonEmpty.some selection
selectionSetOpt :: Parser SelectionSetOpt
selectionSetOpt = listOptIn braces selection
selection :: Parser Selection
selection = field
<|> try fragmentSpread
<|> inlineFragment
<?> "selection error!"
-- * Field
field :: Parser Selection
field = Field
<$> optional alias
<*> name
<*> arguments
<*> directives
<*> selectionSetOpt
alias :: Parser Alias
2019-06-21 10:44:58 +02:00
alias = try $ name <* colon
-- * Arguments
arguments :: Parser [Argument]
arguments = listOptIn parens argument
argument :: Parser Argument
2019-06-21 10:44:58 +02:00
argument = Argument <$> name <* colon <*> value
-- * Fragments
fragmentSpread :: Parser Selection
fragmentSpread = FragmentSpread
<$ spread
<*> fragmentName
<*> directives
inlineFragment :: Parser Selection
inlineFragment = InlineFragment
<$ spread
<*> optional typeCondition
<*> directives
<*> selectionSet
fragmentDefinition :: Parser FragmentDefinition
fragmentDefinition = FragmentDefinition
2019-06-21 10:44:58 +02:00
<$ symbol "fragment"
<*> name
<*> typeCondition
<*> directives
<*> selectionSet
fragmentName :: Parser Name
2019-06-21 10:44:58 +02:00
fragmentName = but (symbol "on") *> name
typeCondition :: Parser TypeCondition
2019-06-21 10:44:58 +02:00
typeCondition = symbol "on" *> name
-- * Input Values
value :: Parser Value
value = Variable <$> variable
2020-05-22 10:11:48 +02:00
<|> Float <$> try float
<|> Int <$> integer
<|> Boolean <$> booleanValue
<|> Null <$ symbol "null"
<|> String <$> blockString
<|> String <$> string
<|> Enum <$> try enumValue
<|> List <$> brackets (some value)
<|> Object <$> braces (some $ objectField value)
<?> "value error!"
2020-05-22 10:11:48 +02:00
constValue :: Parser ConstValue
constValue = ConstFloat <$> try float
<|> ConstInt <$> integer
<|> ConstBoolean <$> booleanValue
<|> ConstNull <$ symbol "null"
<|> ConstString <$> blockString
<|> ConstString <$> string
<|> ConstEnum <$> try enumValue
<|> ConstList <$> brackets (some constValue)
<|> ConstObject <$> braces (some $ objectField constValue)
<?> "value error!"
2020-05-22 10:11:48 +02:00
booleanValue :: Parser Bool
booleanValue = True <$ symbol "true"
<|> False <$ symbol "false"
enumValue :: Parser Name
enumValue = but (symbol "true") *> but (symbol "false") *> but (symbol "null") *> name
2020-05-22 10:11:48 +02:00
objectField :: Parser a -> Parser (ObjectField a)
objectField valueParser = ObjectField <$> name <* colon <*> valueParser
-- * Variables
variableDefinitions :: Parser [VariableDefinition]
variableDefinitions = listOptIn parens variableDefinition
variableDefinition :: Parser VariableDefinition
variableDefinition = VariableDefinition
<$> variable
<* colon
2020-01-05 07:42:04 +01:00
<*> type'
<*> defaultValue
<?> "VariableDefinition"
2019-07-18 05:10:02 +02:00
variable :: Parser Name
2019-06-21 10:44:58 +02:00
variable = dollar *> name
2020-05-22 10:11:48 +02:00
defaultValue :: Parser (Maybe ConstValue)
defaultValue = optional (equals *> constValue) <?> "DefaultValue"
-- * Input Types
2020-01-05 07:42:04 +01:00
type' :: Parser Type
type' = try (TypeNonNull <$> nonNullType)
<|> TypeList <$> brackets type'
2019-11-22 08:00:50 +01:00
<|> TypeNamed <$> name
2020-01-05 07:42:04 +01:00
<?> "Type"
nonNullType :: Parser NonNullType
2019-06-21 10:44:58 +02:00
nonNullType = NonNullTypeNamed <$> name <* bang
2020-01-05 07:42:04 +01:00
<|> NonNullTypeList <$> brackets type' <* bang
<?> "nonNullType error!"
-- * Directives
directives :: Parser [Directive]
directives = many directive
directive :: Parser Directive
directive = Directive
<$ at
<*> name
<*> arguments
-- * Internal
listOptIn :: (Parser [a] -> Parser [a]) -> Parser a -> Parser [a]
listOptIn surround = option [] . surround . some
-- Hack to reverse parser success
but :: Parser a -> Parser ()
but pn = False <$ lookAhead pn <|> pure True >>= \case
2019-06-21 10:44:58 +02:00
False -> empty
True -> pure ()