graphql/src/Language/GraphQL/Parser.hs

187 lines
5.3 KiB
Haskell
Raw Normal View History

{-# LANGUAGE LambdaCase #-}
2019-06-21 10:44:58 +02:00
{-# LANGUAGE OverloadedStrings #-}
2019-07-14 05:58:05 +02:00
module Language.GraphQL.Parser
( document
) where
2019-06-21 10:44:58 +02:00
import Control.Applicative ( Alternative(..)
, optional
)
import Data.List.NonEmpty (NonEmpty(..))
import Language.GraphQL.AST
import Language.GraphQL.Lexer
2019-06-21 10:44:58 +02:00
import Text.Megaparsec ( lookAhead
, option
, try
, (<?>)
)
-- | Parser for the GraphQL documents.
document :: Parser Document
2019-07-22 05:50:00 +02:00
document = unicodeBOM >> spaceConsumer >> lexeme (manyNE definition)
definition :: Parser Definition
definition = DefinitionOperation <$> operationDefinition
<|> DefinitionFragment <$> fragmentDefinition
<?> "definition error!"
operationDefinition :: Parser OperationDefinition
operationDefinition = OperationSelectionSet <$> selectionSet
<|> OperationDefinition <$> operationType
2017-02-04 00:08:40 +01:00
<*> optional name
<*> opt variableDefinitions
<*> opt directives
<*> selectionSet
<?> "operationDefinition error"
operationType :: Parser OperationType
2019-06-21 10:44:58 +02:00
operationType = Query <$ symbol "query"
<|> Mutation <$ symbol "mutation"
<?> "operationType error"
-- * SelectionSet
selectionSet :: Parser SelectionSet
selectionSet = braces $ manyNE selection
selectionSetOpt :: Parser SelectionSetOpt
2019-06-21 10:44:58 +02:00
selectionSetOpt = braces $ some selection
selection :: Parser Selection
selection = SelectionField <$> field
2019-06-21 10:44:58 +02:00
<|> try (SelectionFragmentSpread <$> fragmentSpread)
<|> SelectionInlineFragment <$> inlineFragment
<?> "selection error!"
-- * Field
field :: Parser Field
field = Field <$> optional alias
<*> name
<*> opt arguments
<*> opt directives
<*> opt selectionSetOpt
alias :: Parser Alias
2019-06-21 10:44:58 +02:00
alias = try $ name <* colon
-- * Arguments
arguments :: Parser Arguments
2019-06-21 10:44:58 +02:00
arguments = parens $ some argument
argument :: Parser Argument
2019-06-21 10:44:58 +02:00
argument = Argument <$> name <* colon <*> value
-- * Fragments
fragmentSpread :: Parser FragmentSpread
2019-06-21 10:44:58 +02:00
fragmentSpread = FragmentSpread <$ spread
<*> fragmentName
<*> opt directives
inlineFragment :: Parser InlineFragment
2019-06-21 10:44:58 +02:00
inlineFragment = InlineFragment <$ spread
<*> optional typeCondition
<*> opt directives
<*> selectionSet
fragmentDefinition :: Parser FragmentDefinition
fragmentDefinition = FragmentDefinition
2019-06-21 10:44:58 +02:00
<$ symbol "fragment"
<*> name
<*> typeCondition
<*> opt directives
<*> selectionSet
fragmentName :: Parser FragmentName
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 = ValueVariable <$> variable
2019-06-21 10:44:58 +02:00
<|> ValueFloat <$> try float
<|> ValueInt <$> integer
<|> ValueBoolean <$> booleanValue
2019-06-21 10:44:58 +02:00
<|> ValueNull <$ symbol "null"
<|> ValueString <$> string
<|> ValueString <$> blockString
<|> ValueEnum <$> try enumValue
2015-09-18 14:55:59 +02:00
<|> ValueList <$> listValue
<|> ValueObject <$> objectValue
<?> "value error!"
where
booleanValue :: Parser Bool
2019-06-21 10:44:58 +02:00
booleanValue = True <$ symbol "true"
<|> False <$ symbol "false"
enumValue :: Parser Name
2019-06-21 10:44:58 +02:00
enumValue = but (symbol "true") *> but (symbol "false") *> but (symbol "null") *> name
listValue :: Parser [Value]
2019-06-21 10:44:58 +02:00
listValue = brackets $ some value
objectValue :: Parser [ObjectField]
2019-06-21 10:44:58 +02:00
objectValue = braces $ some objectField
objectField :: Parser ObjectField
2019-06-21 10:44:58 +02:00
objectField = ObjectField <$> name <* symbol ":" <*> value
-- * Variables
variableDefinitions :: Parser VariableDefinitions
2019-06-21 10:44:58 +02:00
variableDefinitions = parens $ some variableDefinition
variableDefinition :: Parser VariableDefinition
variableDefinition = VariableDefinition <$> variable
2019-06-21 10:44:58 +02:00
<* colon
<*> type_
<*> optional defaultValue
2019-07-18 05:10:02 +02:00
variable :: Parser Name
2019-06-21 10:44:58 +02:00
variable = dollar *> name
2019-07-18 05:10:02 +02:00
defaultValue :: Parser Value
2019-06-21 10:44:58 +02:00
defaultValue = equals *> value
-- * Input Types
type_ :: Parser Type
2019-06-21 10:44:58 +02:00
type_ = try (TypeNamed <$> name <* but "!")
<|> TypeList <$> brackets type_
<|> TypeNonNull <$> nonNullType
<?> "type_ error!"
nonNullType :: Parser NonNullType
2019-06-21 10:44:58 +02:00
nonNullType = NonNullTypeNamed <$> name <* bang
<|> NonNullTypeList <$> brackets type_ <* bang
<?> "nonNullType error!"
-- * Directives
directives :: Parser Directives
2019-06-21 10:44:58 +02:00
directives = some directive
directive :: Parser Directive
directive = Directive
2019-06-21 10:44:58 +02:00
<$ at
<*> name
<*> opt arguments
-- * Internal
opt :: Monoid a => Parser a -> Parser a
opt = option mempty
-- 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 ()
manyNE :: Alternative f => f a -> f (NonEmpty a)
manyNE p = (:|) <$> p <*> many p