543 lines
18 KiB
Haskell
543 lines
18 KiB
Haskell
{-# LANGUAGE ExplicitForAll #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
|
|
-- | @GraphQL@ document parser.
|
|
module Language.GraphQL.AST.Parser
|
|
( document
|
|
) where
|
|
|
|
import Control.Applicative (Alternative(..), liftA2, optional)
|
|
import Control.Applicative.Combinators (sepBy1)
|
|
import qualified Control.Applicative.Combinators.NonEmpty as NonEmpty
|
|
import Data.List.NonEmpty (NonEmpty(..))
|
|
import Data.Text (Text)
|
|
import qualified Language.GraphQL.AST.DirectiveLocation as Directive
|
|
import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation)
|
|
import qualified Language.GraphQL.AST.Document as Full
|
|
import Language.GraphQL.AST.Lexer
|
|
import Text.Megaparsec
|
|
( MonadParsec(..)
|
|
, SourcePos(..)
|
|
, getSourcePos
|
|
, lookAhead
|
|
, option
|
|
, try
|
|
, unPos
|
|
, (<?>)
|
|
)
|
|
|
|
-- | Parser for the GraphQL documents.
|
|
document :: Parser Full.Document
|
|
document = unicodeBOM
|
|
*> spaceConsumer
|
|
*> lexeme (NonEmpty.some definition)
|
|
|
|
definition :: Parser Full.Definition
|
|
definition = Full.ExecutableDefinition <$> executableDefinition
|
|
<|> typeSystemDefinition'
|
|
<|> typeSystemExtension'
|
|
<?> "Definition"
|
|
where
|
|
typeSystemDefinition' = do
|
|
location <- getLocation
|
|
definition' <- typeSystemDefinition
|
|
pure $ Full.TypeSystemDefinition definition' location
|
|
typeSystemExtension' = do
|
|
location <- getLocation
|
|
definition' <- typeSystemExtension
|
|
pure $ Full.TypeSystemExtension definition' location
|
|
|
|
getLocation :: Parser Full.Location
|
|
getLocation = fromSourcePosition <$> getSourcePos
|
|
where
|
|
fromSourcePosition SourcePos{..} =
|
|
Full.Location (wordFromPosition sourceLine) (wordFromPosition sourceColumn)
|
|
wordFromPosition = fromIntegral . unPos
|
|
|
|
executableDefinition :: Parser Full.ExecutableDefinition
|
|
executableDefinition = Full.DefinitionOperation <$> operationDefinition
|
|
<|> Full.DefinitionFragment <$> fragmentDefinition
|
|
<?> "ExecutableDefinition"
|
|
|
|
typeSystemDefinition :: Parser Full.TypeSystemDefinition
|
|
typeSystemDefinition = schemaDefinition
|
|
<|> typeSystemDefinitionWithDescription
|
|
<?> "TypeSystemDefinition"
|
|
where
|
|
typeSystemDefinitionWithDescription = description
|
|
>>= liftA2 (<|>) typeDefinition' directiveDefinition
|
|
typeDefinition' description' = Full.TypeDefinition
|
|
<$> typeDefinition description'
|
|
|
|
typeSystemExtension :: Parser Full.TypeSystemExtension
|
|
typeSystemExtension = Full.SchemaExtension <$> schemaExtension
|
|
<|> Full.TypeExtension <$> typeExtension
|
|
<?> "TypeSystemExtension"
|
|
|
|
directiveDefinition :: Full.Description -> Parser Full.TypeSystemDefinition
|
|
directiveDefinition description' = Full.DirectiveDefinition description'
|
|
<$ symbol "directive"
|
|
<* at
|
|
<*> name
|
|
<*> argumentsDefinition
|
|
<* symbol "on"
|
|
<*> directiveLocations
|
|
<?> "DirectiveDefinition"
|
|
|
|
directiveLocations :: Parser (NonEmpty DirectiveLocation)
|
|
directiveLocations = optional pipe
|
|
*> directiveLocation `NonEmpty.sepBy1` pipe
|
|
<?> "DirectiveLocations"
|
|
|
|
directiveLocation :: Parser DirectiveLocation
|
|
directiveLocation = e (Directive.Query <$ symbol "QUERY")
|
|
<|> e (Directive.Mutation <$ symbol "MUTATION")
|
|
<|> e (Directive.Subscription <$ symbol "SUBSCRIPTION")
|
|
<|> t (Directive.FieldDefinition <$ symbol "FIELD_DEFINITION")
|
|
<|> e (Directive.Field <$ symbol "FIELD")
|
|
<|> e (Directive.FragmentDefinition <$ "FRAGMENT_DEFINITION")
|
|
<|> e (Directive.FragmentSpread <$ "FRAGMENT_SPREAD")
|
|
<|> e (Directive.InlineFragment <$ "INLINE_FRAGMENT")
|
|
<|> t (Directive.Schema <$ symbol "SCHEMA")
|
|
<|> t (Directive.Scalar <$ symbol "SCALAR")
|
|
<|> t (Directive.Object <$ symbol "OBJECT")
|
|
<|> t (Directive.ArgumentDefinition <$ symbol "ARGUMENT_DEFINITION")
|
|
<|> t (Directive.Interface <$ symbol "INTERFACE")
|
|
<|> t (Directive.Union <$ symbol "UNION")
|
|
<|> t (Directive.EnumValue <$ symbol "ENUM_VALUE")
|
|
<|> t (Directive.Enum <$ symbol "ENUM")
|
|
<|> t (Directive.InputObject <$ symbol "INPUT_OBJECT")
|
|
<|> t (Directive.InputFieldDefinition <$ symbol "INPUT_FIELD_DEFINITION")
|
|
<?> "DirectiveLocation"
|
|
where
|
|
e = fmap Directive.ExecutableDirectiveLocation
|
|
t = fmap Directive.TypeSystemDirectiveLocation
|
|
|
|
typeDefinition :: Full.Description -> Parser Full.TypeDefinition
|
|
typeDefinition description' = scalarTypeDefinition description'
|
|
<|> objectTypeDefinition description'
|
|
<|> interfaceTypeDefinition description'
|
|
<|> unionTypeDefinition description'
|
|
<|> enumTypeDefinition description'
|
|
<|> inputObjectTypeDefinition description'
|
|
<?> "TypeDefinition"
|
|
|
|
typeExtension :: Parser Full.TypeExtension
|
|
typeExtension = scalarTypeExtension
|
|
<|> objectTypeExtension
|
|
<|> interfaceTypeExtension
|
|
<|> unionTypeExtension
|
|
<|> enumTypeExtension
|
|
<|> inputObjectTypeExtension
|
|
<?> "TypeExtension"
|
|
|
|
scalarTypeDefinition :: Full.Description -> Parser Full.TypeDefinition
|
|
scalarTypeDefinition description' = Full.ScalarTypeDefinition description'
|
|
<$ symbol "scalar"
|
|
<*> name
|
|
<*> directives
|
|
<?> "ScalarTypeDefinition"
|
|
|
|
scalarTypeExtension :: Parser Full.TypeExtension
|
|
scalarTypeExtension = extend "scalar" "ScalarTypeExtension"
|
|
$ (Full.ScalarTypeExtension <$> name <*> NonEmpty.some directive) :| []
|
|
|
|
objectTypeDefinition :: Full.Description -> Parser Full.TypeDefinition
|
|
objectTypeDefinition description' = Full.ObjectTypeDefinition description'
|
|
<$ symbol "type"
|
|
<*> name
|
|
<*> option (Full.ImplementsInterfaces []) (implementsInterfaces sepBy1)
|
|
<*> directives
|
|
<*> braces (many fieldDefinition)
|
|
<?> "ObjectTypeDefinition"
|
|
|
|
objectTypeExtension :: Parser Full.TypeExtension
|
|
objectTypeExtension = extend "type" "ObjectTypeExtension"
|
|
$ fieldsDefinitionExtension :|
|
|
[ directivesExtension
|
|
, implementsInterfacesExtension
|
|
]
|
|
where
|
|
fieldsDefinitionExtension = Full.ObjectTypeFieldsDefinitionExtension
|
|
<$> name
|
|
<*> option (Full.ImplementsInterfaces []) (implementsInterfaces sepBy1)
|
|
<*> directives
|
|
<*> braces (NonEmpty.some fieldDefinition)
|
|
directivesExtension = Full.ObjectTypeDirectivesExtension
|
|
<$> name
|
|
<*> option (Full.ImplementsInterfaces []) (implementsInterfaces sepBy1)
|
|
<*> NonEmpty.some directive
|
|
implementsInterfacesExtension = Full.ObjectTypeImplementsInterfacesExtension
|
|
<$> name
|
|
<*> implementsInterfaces NonEmpty.sepBy1
|
|
|
|
description :: Parser Full.Description
|
|
description = Full.Description
|
|
<$> optional stringValue
|
|
<?> "Description"
|
|
|
|
unionTypeDefinition :: Full.Description -> Parser Full.TypeDefinition
|
|
unionTypeDefinition description' = Full.UnionTypeDefinition description'
|
|
<$ symbol "union"
|
|
<*> name
|
|
<*> directives
|
|
<*> option (Full.UnionMemberTypes []) (unionMemberTypes sepBy1)
|
|
<?> "UnionTypeDefinition"
|
|
|
|
unionTypeExtension :: Parser Full.TypeExtension
|
|
unionTypeExtension = extend "union" "UnionTypeExtension"
|
|
$ unionMemberTypesExtension :| [directivesExtension]
|
|
where
|
|
unionMemberTypesExtension = Full.UnionTypeUnionMemberTypesExtension
|
|
<$> name
|
|
<*> directives
|
|
<*> unionMemberTypes NonEmpty.sepBy1
|
|
directivesExtension = Full.UnionTypeDirectivesExtension
|
|
<$> name
|
|
<*> NonEmpty.some directive
|
|
|
|
unionMemberTypes ::
|
|
Foldable t =>
|
|
(Parser Text -> Parser Text -> Parser (t Full.NamedType)) ->
|
|
Parser (Full.UnionMemberTypes t)
|
|
unionMemberTypes sepBy' = Full.UnionMemberTypes
|
|
<$ equals
|
|
<* optional pipe
|
|
<*> name `sepBy'` pipe
|
|
<?> "UnionMemberTypes"
|
|
|
|
interfaceTypeDefinition :: Full.Description -> Parser Full.TypeDefinition
|
|
interfaceTypeDefinition description' = Full.InterfaceTypeDefinition description'
|
|
<$ symbol "interface"
|
|
<*> name
|
|
<*> directives
|
|
<*> braces (many fieldDefinition)
|
|
<?> "InterfaceTypeDefinition"
|
|
|
|
interfaceTypeExtension :: Parser Full.TypeExtension
|
|
interfaceTypeExtension = extend "interface" "InterfaceTypeExtension"
|
|
$ fieldsDefinitionExtension :| [directivesExtension]
|
|
where
|
|
fieldsDefinitionExtension = Full.InterfaceTypeFieldsDefinitionExtension
|
|
<$> name
|
|
<*> directives
|
|
<*> braces (NonEmpty.some fieldDefinition)
|
|
directivesExtension = Full.InterfaceTypeDirectivesExtension
|
|
<$> name
|
|
<*> NonEmpty.some directive
|
|
|
|
enumTypeDefinition :: Full.Description -> Parser Full.TypeDefinition
|
|
enumTypeDefinition description' = Full.EnumTypeDefinition description'
|
|
<$ symbol "enum"
|
|
<*> name
|
|
<*> directives
|
|
<*> listOptIn braces enumValueDefinition
|
|
<?> "EnumTypeDefinition"
|
|
|
|
enumTypeExtension :: Parser Full.TypeExtension
|
|
enumTypeExtension = extend "enum" "EnumTypeExtension"
|
|
$ enumValuesDefinitionExtension :| [directivesExtension]
|
|
where
|
|
enumValuesDefinitionExtension = Full.EnumTypeEnumValuesDefinitionExtension
|
|
<$> name
|
|
<*> directives
|
|
<*> braces (NonEmpty.some enumValueDefinition)
|
|
directivesExtension = Full.EnumTypeDirectivesExtension
|
|
<$> name
|
|
<*> NonEmpty.some directive
|
|
|
|
inputObjectTypeDefinition :: Full.Description -> Parser Full.TypeDefinition
|
|
inputObjectTypeDefinition description' = Full.InputObjectTypeDefinition description'
|
|
<$ symbol "input"
|
|
<*> name
|
|
<*> directives
|
|
<*> listOptIn braces inputValueDefinition
|
|
<?> "InputObjectTypeDefinition"
|
|
|
|
inputObjectTypeExtension :: Parser Full.TypeExtension
|
|
inputObjectTypeExtension = extend "input" "InputObjectTypeExtension"
|
|
$ inputFieldsDefinitionExtension :| [directivesExtension]
|
|
where
|
|
inputFieldsDefinitionExtension = Full.InputObjectTypeInputFieldsDefinitionExtension
|
|
<$> name
|
|
<*> directives
|
|
<*> braces (NonEmpty.some inputValueDefinition)
|
|
directivesExtension = Full.InputObjectTypeDirectivesExtension
|
|
<$> name
|
|
<*> NonEmpty.some directive
|
|
|
|
enumValueDefinition :: Parser Full.EnumValueDefinition
|
|
enumValueDefinition = Full.EnumValueDefinition
|
|
<$> description
|
|
<*> enumValue
|
|
<*> directives
|
|
<?> "EnumValueDefinition"
|
|
|
|
implementsInterfaces ::
|
|
Foldable t =>
|
|
(Parser Text -> Parser Text -> Parser (t Full.NamedType)) ->
|
|
Parser (Full.ImplementsInterfaces t)
|
|
implementsInterfaces sepBy' = Full.ImplementsInterfaces
|
|
<$ symbol "implements"
|
|
<* optional amp
|
|
<*> name `sepBy'` amp
|
|
<?> "ImplementsInterfaces"
|
|
|
|
inputValueDefinition :: Parser Full.InputValueDefinition
|
|
inputValueDefinition = Full.InputValueDefinition
|
|
<$> description
|
|
<*> name
|
|
<* colon
|
|
<*> type'
|
|
<*> defaultValue
|
|
<*> directives
|
|
<?> "InputValueDefinition"
|
|
|
|
argumentsDefinition :: Parser Full.ArgumentsDefinition
|
|
argumentsDefinition = Full.ArgumentsDefinition
|
|
<$> listOptIn parens inputValueDefinition
|
|
<?> "ArgumentsDefinition"
|
|
|
|
fieldDefinition :: Parser Full.FieldDefinition
|
|
fieldDefinition = Full.FieldDefinition
|
|
<$> description
|
|
<*> name
|
|
<*> argumentsDefinition
|
|
<* colon
|
|
<*> type'
|
|
<*> directives
|
|
<?> "FieldDefinition"
|
|
|
|
schemaDefinition :: Parser Full.TypeSystemDefinition
|
|
schemaDefinition = Full.SchemaDefinition
|
|
<$ symbol "schema"
|
|
<*> directives
|
|
<*> operationTypeDefinitions
|
|
<?> "SchemaDefinition"
|
|
|
|
operationTypeDefinitions :: Parser (NonEmpty Full.OperationTypeDefinition)
|
|
operationTypeDefinitions = braces $ NonEmpty.some operationTypeDefinition
|
|
|
|
schemaExtension :: Parser Full.SchemaExtension
|
|
schemaExtension = extend "schema" "SchemaExtension"
|
|
$ schemaOperationExtension :| [directivesExtension]
|
|
where
|
|
directivesExtension = Full.SchemaDirectivesExtension
|
|
<$> NonEmpty.some directive
|
|
schemaOperationExtension = Full.SchemaOperationExtension
|
|
<$> directives
|
|
<*> operationTypeDefinitions
|
|
|
|
operationTypeDefinition :: Parser Full.OperationTypeDefinition
|
|
operationTypeDefinition = Full.OperationTypeDefinition
|
|
<$> operationType <* colon
|
|
<*> name
|
|
<?> "OperationTypeDefinition"
|
|
|
|
operationDefinition :: Parser Full.OperationDefinition
|
|
operationDefinition = shorthand
|
|
<|> operationDefinition'
|
|
<?> "OperationDefinition"
|
|
where
|
|
shorthand = do
|
|
location <- getLocation
|
|
selectionSet' <- selectionSet
|
|
pure $ Full.SelectionSet selectionSet' location
|
|
operationDefinition' = do
|
|
location <- getLocation
|
|
operationType' <- operationType
|
|
operationName <- optional name
|
|
variableDefinitions' <- variableDefinitions
|
|
directives' <- directives
|
|
selectionSet' <- selectionSet
|
|
pure $ Full.OperationDefinition
|
|
operationType'
|
|
operationName
|
|
variableDefinitions'
|
|
directives'
|
|
selectionSet'
|
|
location
|
|
|
|
operationType :: Parser Full.OperationType
|
|
operationType = Full.Query <$ symbol "query"
|
|
<|> Full.Mutation <$ symbol "mutation"
|
|
<|> Full.Subscription <$ symbol "subscription"
|
|
<?> "OperationType"
|
|
|
|
selectionSet :: Parser Full.SelectionSet
|
|
selectionSet = braces (NonEmpty.some selection) <?> "SelectionSet"
|
|
|
|
selectionSetOpt :: Parser Full.SelectionSetOpt
|
|
selectionSetOpt = listOptIn braces selection <?> "SelectionSet"
|
|
|
|
selection :: Parser Full.Selection
|
|
selection = Full.FieldSelection <$> field
|
|
<|> Full.FragmentSpreadSelection <$> try fragmentSpread
|
|
<|> Full.InlineFragmentSelection <$> inlineFragment
|
|
<?> "Selection"
|
|
|
|
field :: Parser Full.Field
|
|
field = label "Field" $ do
|
|
location <- getLocation
|
|
alias' <- optional alias
|
|
name' <- name
|
|
arguments' <- arguments
|
|
directives' <- directives
|
|
selectionSetOpt' <- selectionSetOpt
|
|
pure $ Full.Field alias' name' arguments' directives' selectionSetOpt' location
|
|
|
|
alias :: Parser Full.Name
|
|
alias = try (name <* colon) <?> "Alias"
|
|
|
|
arguments :: Parser [Full.Argument]
|
|
arguments = listOptIn parens argument <?> "Arguments"
|
|
|
|
argument :: Parser Full.Argument
|
|
argument = label "Argument" $ do
|
|
location <- getLocation
|
|
name' <- name
|
|
colon
|
|
value' <- valueNode value
|
|
pure $ Full.Argument name' value' location
|
|
|
|
fragmentSpread :: Parser Full.FragmentSpread
|
|
fragmentSpread = label "FragmentSpread" $ do
|
|
location <- getLocation
|
|
_ <- spread
|
|
fragmentName' <- fragmentName
|
|
directives' <- directives
|
|
pure $ Full.FragmentSpread fragmentName' directives' location
|
|
|
|
inlineFragment :: Parser Full.InlineFragment
|
|
inlineFragment = label "InlineFragment" $ do
|
|
location <- getLocation
|
|
_ <- spread
|
|
typeCondition' <- optional typeCondition
|
|
directives' <- directives
|
|
selectionSet' <- selectionSet
|
|
pure $ Full.InlineFragment typeCondition' directives' selectionSet' location
|
|
|
|
fragmentDefinition :: Parser Full.FragmentDefinition
|
|
fragmentDefinition = label "FragmentDefinition" $ do
|
|
location <- getLocation
|
|
_ <- symbol "fragment"
|
|
fragmentName' <- name
|
|
typeCondition' <- typeCondition
|
|
directives' <- directives
|
|
selectionSet' <- selectionSet
|
|
pure $ Full.FragmentDefinition
|
|
fragmentName' typeCondition' directives' selectionSet' location
|
|
|
|
fragmentName :: Parser Full.Name
|
|
fragmentName = but (symbol "on") *> name <?> "FragmentName"
|
|
|
|
typeCondition :: Parser Full.TypeCondition
|
|
typeCondition = symbol "on" *> name <?> "TypeCondition"
|
|
|
|
valueNode :: forall a. Parser a -> Parser (Full.Node a)
|
|
valueNode valueParser = do
|
|
location <- getLocation
|
|
value' <- valueParser
|
|
pure $ Full.Node value' location
|
|
|
|
value :: Parser Full.Value
|
|
value = Full.Variable <$> variable
|
|
<|> Full.Float <$> try float
|
|
<|> Full.Int <$> integer
|
|
<|> Full.Boolean <$> booleanValue
|
|
<|> Full.Null <$ nullValue
|
|
<|> Full.String <$> stringValue
|
|
<|> Full.Enum <$> try enumValue
|
|
<|> Full.List <$> brackets (some $ valueNode value)
|
|
<|> Full.Object <$> braces (some $ objectField $ valueNode value)
|
|
<?> "Value"
|
|
|
|
constValue :: Parser Full.ConstValue
|
|
constValue = Full.ConstFloat <$> try float
|
|
<|> Full.ConstInt <$> integer
|
|
<|> Full.ConstBoolean <$> booleanValue
|
|
<|> Full.ConstNull <$ nullValue
|
|
<|> Full.ConstString <$> stringValue
|
|
<|> Full.ConstEnum <$> try enumValue
|
|
<|> Full.ConstList <$> brackets (many $ valueNode constValue)
|
|
<|> Full.ConstObject <$> braces (many $ objectField $ valueNode constValue)
|
|
<?> "Value"
|
|
|
|
booleanValue :: Parser Bool
|
|
booleanValue = True <$ symbol "true"
|
|
<|> False <$ symbol "false"
|
|
<?> "BooleanValue"
|
|
|
|
enumValue :: Parser Full.Name
|
|
enumValue = but (symbol "true")
|
|
*> but (symbol "false")
|
|
*> but (symbol "null")
|
|
*> name
|
|
<?> "EnumValue"
|
|
|
|
stringValue :: Parser Text
|
|
stringValue = blockString <|> string <?> "StringValue"
|
|
|
|
nullValue :: Parser Text
|
|
nullValue = symbol "null" <?> "NullValue"
|
|
|
|
objectField :: forall a. Parser (Full.Node a) -> Parser (Full.ObjectField a)
|
|
objectField valueParser = label "ObjectField" $ do
|
|
location <- getLocation
|
|
fieldName <- name
|
|
colon
|
|
fieldValue <- valueParser
|
|
pure $ Full.ObjectField fieldName fieldValue location
|
|
|
|
variableDefinitions :: Parser [Full.VariableDefinition]
|
|
variableDefinitions = listOptIn parens variableDefinition
|
|
<?> "VariableDefinitions"
|
|
|
|
variableDefinition :: Parser Full.VariableDefinition
|
|
variableDefinition = label "VariableDefinition" $ do
|
|
location <- getLocation
|
|
variableName <- variable
|
|
colon
|
|
variableType <- type'
|
|
variableValue <- defaultValue
|
|
pure $ Full.VariableDefinition variableName variableType variableValue location
|
|
|
|
variable :: Parser Full.Name
|
|
variable = dollar *> name <?> "Variable"
|
|
|
|
defaultValue :: Parser (Maybe (Full.Node Full.ConstValue))
|
|
defaultValue = optional (equals *> valueNode constValue) <?> "DefaultValue"
|
|
|
|
type' :: Parser Full.Type
|
|
type' = try (Full.TypeNonNull <$> nonNullType)
|
|
<|> Full.TypeList <$> brackets type'
|
|
<|> Full.TypeNamed <$> name
|
|
<?> "Type"
|
|
|
|
nonNullType :: Parser Full.NonNullType
|
|
nonNullType = Full.NonNullTypeNamed <$> name <* bang
|
|
<|> Full.NonNullTypeList <$> brackets type' <* bang
|
|
<?> "NonNullType"
|
|
|
|
directives :: Parser [Full.Directive]
|
|
directives = many directive <?> "Directives"
|
|
|
|
directive :: Parser Full.Directive
|
|
directive = label "Directive" $ do
|
|
location <- getLocation
|
|
at
|
|
directiveName <- name
|
|
directiveArguments <- arguments
|
|
pure $ Full.Directive directiveName directiveArguments location
|
|
|
|
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
|
|
False -> empty
|
|
True -> pure ()
|