graphql/Data/GraphQL/Parser.hs
2015-09-14 15:48:47 +02:00

323 lines
8.5 KiB
Haskell

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
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
-- XXX: Handle starting `_` and no number at the beginning:
-- https://facebook.github.io/graphql/#sec-Names
-- TODO: Use takeWhile1 instead for efficiency. With takeWhile1 there is no
-- parsing failure.
name :: Parser Name
name = tok $ pack <$> many1 (satisfy isAlphaNum)
-- * Document
document :: Parser Document
document = whiteSpace
*> (Document <$> many1 definition)
-- Try SelectionSet when no 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
-- Inline first to catch `on` case
<|> 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
-- * Fragments
fragmentSpread :: Parser FragmentSpread
-- TODO: Make sure it fails when `... on`.
-- See https://facebook.github.io/graphql/#FragmentSpread
fragmentSpread = FragmentSpread
<$ tok "..."
<*> name
<*> optempty directives
-- InlineFragment tried first in order to guard against 'on' keyword
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
-- * Values
-- This will try to pick the first type it can parse. If you are working with
-- explicit types use the `typedValue` parser.
value :: Parser Value
value = ValueVariable <$> variable
-- TODO: Handle arbitrary precision.
<|> ValueInt <$> tok (signed decimal)
<|> ValueFloat <$> tok (signed double)
<|> ValueBoolean <$> bool
-- TODO: Handle escape characters, unicode, etc
<|> ValueString <$> quotes name
-- `true` and `false` have been tried before
<|> ValueEnum <$> name
<|> ValueList <$> listValue
<|> ValueObject <$> objectValue
-- Notice it can be empty
listValue :: Parser ListValue
listValue = ListValue <$> brackets (many value)
-- Notice it can be empty
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
directives :: Parser [Directive]
directives = many1 directive
directive :: Parser Directive
directive = Directive
<$ tok "@"
<*> name
<*> optempty arguments
-- * Type Reference
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 "!"
-- * Type Definition
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
-- * Internal
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
-- `empty` /= `pure mempty` for `Parser`.
optempty :: Monoid a => Parser a -> Parser a
optempty = option mempty
-- ** WhiteSpace
--
whiteSpace :: Parser ()
whiteSpace = peekChar >>= \case
Just c -> if isSpace c || c == ','
then anyChar *> whiteSpace
else when (c == '#') $ manyTill anyChar endOfLine *> whiteSpace
_ -> return ()