module Data.GraphQL.Parser where
import Prelude hiding (takeWhile)
import Control.Applicative ((<|>), empty, many, optional)
import Control.Monad (when)
import Data.Char
import Data.Text (Text, pack)
import Data.Attoparsec.Text
( Parser
, (<?>)
, anyChar
, decimal
, double
, endOfLine
, many1
, manyTill
, option
, peekChar
, satisfy
, sepBy1
, signed
)
import Data.GraphQL.AST
name :: Parser Name
name = tok $ pack <$> many1 (satisfy isAlphaNum)
document :: Parser Document
document = whiteSpace
*> (Document <$> many1 definition)
<|> (Document . pure
. DefinitionOperation
. Query mempty empty empty
<$> selectionSet)
<?> "document error!"
definition :: Parser Definition
definition = DefinitionOperation <$> operationDefinition
<|> DefinitionFragment <$> fragmentDefinition
<|> DefinitionType <$> typeDefinition
<?> "definition error!"
operationDefinition :: Parser OperationDefinition
operationDefinition =
op Query "query"
<|> op Mutation "mutation"
<?> "operationDefinition error!"
where
op f n = f <$ tok n <*> tok name
<*> optempty variableDefinitions
<*> optempty directives
<*> selectionSet
variableDefinitions :: Parser [VariableDefinition]
variableDefinitions = parens (many1 variableDefinition)
variableDefinition :: Parser VariableDefinition
variableDefinition =
VariableDefinition <$> variable
<* tok ":"
<*> type_
<*> optional defaultValue
defaultValue :: Parser DefaultValue
defaultValue = tok "=" *> value
variable :: Parser Variable
variable = Variable <$ tok "$" <*> name
selectionSet :: Parser SelectionSet
selectionSet = braces $ many1 selection
selection :: Parser Selection
selection = SelectionField <$> field
<|> SelectionInlineFragment <$> inlineFragment
<|> SelectionFragmentSpread <$> fragmentSpread
<?> "selection error!"
field :: Parser Field
field = Field <$> optempty alias
<*> name
<*> optempty arguments
<*> optempty directives
<*> optempty selectionSet
alias :: Parser Alias
alias = name <* tok ":"
arguments :: Parser [Argument]
arguments = parens $ many1 argument
argument :: Parser Argument
argument = Argument <$> name <* tok ":" <*> value
fragmentSpread :: Parser FragmentSpread
fragmentSpread = FragmentSpread
<$ tok "..."
<*> name
<*> optempty directives
inlineFragment :: Parser InlineFragment
inlineFragment = InlineFragment
<$ tok "..."
<* tok "on"
<*> typeCondition
<*> optempty directives
<*> selectionSet
fragmentDefinition :: Parser FragmentDefinition
fragmentDefinition = FragmentDefinition
<$ tok "fragment"
<*> name
<* tok "on"
<*> typeCondition
<*> optempty directives
<*> selectionSet
typeCondition :: Parser TypeCondition
typeCondition = namedType
value :: Parser Value
value = ValueVariable <$> variable
<|> ValueInt <$> tok (signed decimal)
<|> ValueFloat <$> tok (signed double)
<|> ValueBoolean <$> bool
<|> ValueString <$> quotes name
<|> ValueEnum <$> name
<|> ValueList <$> listValue
<|> ValueObject <$> objectValue
listValue :: Parser ListValue
listValue = ListValue <$> brackets (many value)
objectValue :: Parser ObjectValue
objectValue = ObjectValue <$> braces (many objectField)
objectField :: Parser ObjectField
objectField = ObjectField <$> name <* tok ":" <*> value
bool :: Parser Bool
bool = True <$ tok "true"
<|> False <$ tok "false"
directives :: Parser [Directive]
directives = many1 directive
directive :: Parser Directive
directive = Directive
<$ tok "@"
<*> name
<*> optempty arguments
type_ :: Parser Type
type_ = TypeNamed <$> namedType
<|> TypeList <$> listType
<|> TypeNonNull <$> nonNullType
namedType :: Parser NamedType
namedType = NamedType <$> name
listType :: Parser ListType
listType = ListType <$> brackets type_
nonNullType :: Parser NonNullType
nonNullType = NonNullTypeNamed <$> namedType <* tok "!"
<|> NonNullTypeList <$> listType <* tok "!"
typeDefinition :: Parser TypeDefinition
typeDefinition =
TypeDefinitionObject <$> objectTypeDefinition
<|> TypeDefinitionInterface <$> interfaceTypeDefinition
<|> TypeDefinitionUnion <$> unionTypeDefinition
<|> TypeDefinitionScalar <$> scalarTypeDefinition
<|> TypeDefinitionEnum <$> enumTypeDefinition
<|> TypeDefinitionInputObject <$> inputObjectTypeDefinition
<|> TypeDefinitionTypeExtension <$> typeExtensionDefinition
<?> "typeDefinition error!"
objectTypeDefinition :: Parser ObjectTypeDefinition
objectTypeDefinition = ObjectTypeDefinition
<$ tok "type"
<*> name
<*> optempty interfaces
<*> fieldDefinitions
<?> "objectTypeDefinition error!"
interfaces :: Parser Interfaces
interfaces = tok "implements" *> many1 namedType
fieldDefinitions :: Parser [FieldDefinition]
fieldDefinitions = braces $ many1 fieldDefinition
fieldDefinition :: Parser FieldDefinition
fieldDefinition = FieldDefinition
<$> name
<*> optempty argumentsDefinition
<* tok ":"
<*> type_
argumentsDefinition :: Parser ArgumentsDefinition
argumentsDefinition = inputValueDefinitions
inputValueDefinitions :: Parser [InputValueDefinition]
inputValueDefinitions = parens $ many1 inputValueDefinition
inputValueDefinition :: Parser InputValueDefinition
inputValueDefinition = InputValueDefinition
<$> name
<* tok ":"
<*> type_
<*> optional defaultValue
interfaceTypeDefinition :: Parser InterfaceTypeDefinition
interfaceTypeDefinition = InterfaceTypeDefinition
<$ tok "interface"
<*> name
<*> fieldDefinitions
unionTypeDefinition :: Parser UnionTypeDefinition
unionTypeDefinition = UnionTypeDefinition
<$ tok "union"
<*> name
<* tok "="
<*> unionMembers
unionMembers :: Parser [NamedType]
unionMembers = namedType `sepBy1` tok "|"
scalarTypeDefinition :: Parser ScalarTypeDefinition
scalarTypeDefinition = ScalarTypeDefinition
<$ tok "scalar"
<*> name
enumTypeDefinition :: Parser EnumTypeDefinition
enumTypeDefinition = EnumTypeDefinition
<$ tok "enum"
<*> name
<*> enumValueDefinitions
enumValueDefinitions :: Parser [EnumValueDefinition]
enumValueDefinitions = braces $ many1 enumValueDefinition
enumValueDefinition :: Parser EnumValueDefinition
enumValueDefinition = EnumValueDefinition <$> name
inputObjectTypeDefinition :: Parser InputObjectTypeDefinition
inputObjectTypeDefinition = InputObjectTypeDefinition
<$ tok "input"
<*> name
<*> inputValueDefinitions
typeExtensionDefinition :: Parser TypeExtensionDefinition
typeExtensionDefinition = TypeExtensionDefinition
<$ tok "extend"
<*> objectTypeDefinition
tok :: Parser a -> Parser a
tok p = p <* whiteSpace
parens :: Parser a -> Parser a
parens = between "(" ")"
braces :: Parser a -> Parser a
braces = between "{" "}"
quotes :: Parser a -> Parser a
quotes = between "\"" "\""
brackets :: Parser a -> Parser a
brackets = between "[" "]"
between :: Parser Text -> Parser Text -> Parser a -> Parser a
between open close p = tok open *> p <* tok close
optempty :: Monoid a => Parser a -> Parser a
optempty = option mempty
whiteSpace :: Parser ()
whiteSpace = peekChar >>= \case
Just c -> if isSpace c || c == ','
then anyChar *> whiteSpace
else when (c == '#') $ manyTill anyChar endOfLine *> whiteSpace
_ -> return ()