Several improvements to the parser

- Add token combinator to simplify whitespace handling.
- Simplify whiteSpace parsers.
- Add `optempty` to handle pure mempty cases. `empty /= pure mempty`.
- Use `between` combinators for brackets, braces and parens.

This also includes small adjustments to the AST.
This commit is contained in:
Danny Navarro 2015-09-14 11:49:20 +02:00
parent b206079047
commit 62adfd89cd
2 changed files with 120 additions and 103 deletions

View File

@ -22,12 +22,12 @@ data OperationDefinition =
-- -- | Subscription Name [VariableDefinition] [Directive] SelectionSet
deriving (Eq,Show)
data VariableDefinition = VariableDefinition Variable Type DefaultValue
data VariableDefinition = VariableDefinition Variable Type (Maybe DefaultValue)
deriving (Eq,Show)
newtype Variable = Variable Name deriving (Eq,Show)
newtype SelectionSet = SelectionSet [Selection] deriving (Eq,Show)
type SelectionSet = [Selection]
data Selection = SelectionField Field
| SelectionFragmentSpread FragmentSpread
@ -118,7 +118,7 @@ data FieldDefinition = FieldDefinition Name ArgumentsDefinition Type
type ArgumentsDefinition = [InputValueDefinition]
data InputValueDefinition = InputValueDefinition Name Type DefaultValue
data InputValueDefinition = InputValueDefinition Name Type (Maybe DefaultValue)
deriving (Eq,Show)
data InterfaceTypeDefinition = InterfaceTypeDefinition Name [FieldDefinition]

View File

@ -2,9 +2,10 @@
module Data.GraphQL.Parser where
import Prelude hiding (takeWhile)
import Control.Applicative (Alternative, (<|>), empty, many)
import Control.Applicative (Alternative, (<|>), empty, many, optional)
import Data.Char
import Data.Text (Text)
import Data.Attoparsec.Text
( Parser
, (<?>)
@ -15,6 +16,7 @@ import Data.Attoparsec.Text
, isEndOfLine
, many1
, manyTill
, option
, satisfy
, sepBy
, sepBy1
@ -23,6 +25,7 @@ import Data.Attoparsec.Text
, skipWhile
, signed
, space
, takeTill
, takeWhile
, takeWhile1
)
@ -34,19 +37,18 @@ import Data.GraphQL.AST
-- XXX: Handle starting `_` and no number at the beginning:
-- https://facebook.github.io/graphql/#sec-Names
name :: Parser Name
name = takeWhile1 isAlphaNum
name = tok $ takeWhile1 isAlphaNum
-- * Document
document :: Parser Document
document = s *>
(Document <$> many1_ definition
document = whiteSpace *>
(Document <$> many1 definition)
-- Try SelectionSet when no definition
<|> Document <$> pure
<$> DefinitionOperation
<$> Query mempty empty empty
<|> (Document . pure
. DefinitionOperation
. Query mempty empty empty
<$> selectionSet)
<* s
<?> "document error!"
definition :: Parser Definition
@ -61,30 +63,29 @@ operationDefinition =
<|> op Mutation "mutation"
<?> "operationDefinition error!"
where
op f n = f <$ n <* s1 <*> name <* s1
<*> (variableDefinitions <* s <|> empty)
<*> directives <* s
op f n = f <$ tok n <*> tok name
<*> optempty variableDefinitions
<*> optempty directives
<*> selectionSet
variableDefinitions :: Parser [VariableDefinition]
variableDefinitions = "(" *> s *> many1_ variableDefinition <* s <* ")"
variableDefinitions = parens (many1 variableDefinition)
variableDefinition :: Parser VariableDefinition
variableDefinition =
VariableDefinition <$> variable <* s <* ":" <* s
<*> type_ <* s
<*> (defaultValue <|> empty)
VariableDefinition <$> variable
<* tok ":"
<*> type_
<*> optional defaultValue
defaultValue :: Parser DefaultValue
defaultValue = "=" *> s *> value
defaultValue = tok "=" *> value
-- In defense of good taste, I'm taking liberty of not allowing space between
-- '$' and the 'name' even though that's not in the spec.
variable :: Parser Variable
variable = Variable <$ "$" <*> name
variable = Variable <$ tok "$" <*> name
selectionSet :: Parser SelectionSet
selectionSet = "{" *> s *> (SelectionSet <$> many1_ selection) <* s <* "}"
selectionSet = braces $ many1 selection
selection :: Parser Selection
selection = SelectionField <$> field
@ -94,43 +95,47 @@ selection = SelectionField <$> field
<?> "selection error!"
field :: Parser Field
field = Field <$> (alias <* s1 <|> empty)
<*> name <* s
<*> (arguments <* s <|> empty)
<*> directives <* s
<*> selectionSet
<?> "field error!"
field = Field <$> optempty alias
<*> name
<*> optempty arguments
<*> optempty directives
<*> optempty selectionSet
alias :: Parser Alias
alias = name <* s <* ":"
alias = name <* tok ":"
arguments :: Parser [Argument]
arguments = "(" *> s *> many1_ argument <* s <* ")"
arguments = parens $ many1 argument
argument :: Parser Argument
argument = Argument <$> name <* s <* ":" <* s <*> value
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 <$ "..." <* s <*> name <* s1 <*> many_ directive
fragmentSpread = FragmentSpread
<$ tok "..."
<*> name
<*> optempty directives
-- InlineFragment tried first in order to guard against 'on' keyword
inlineFragment :: Parser InlineFragment
inlineFragment = InlineFragment <$ "..." <* s <* "on" <* s1
<*> typeCondition <* s
<*> directives <* s
inlineFragment = InlineFragment
<$ tok "..."
<* tok "on"
<*> typeCondition
<*> optempty directives
<*> selectionSet
fragmentDefinition :: Parser FragmentDefinition
fragmentDefinition =
FragmentDefinition <$ "fragment" <* s1
<*> name <* s
<* "on" <* s1
<*> typeCondition <* s
<*> directives <* s
fragmentDefinition = FragmentDefinition
<$ tok "fragment"
<*> name
<* tok "on"
<*> typeCondition
<*> optempty directives
<*> selectionSet
typeCondition :: Parser TypeCondition
@ -154,14 +159,14 @@ value = -- TODO: Handle arbitrary precision.
-- Notice it can be empty
listValue :: Parser ListValue
listValue = ListValue <$ "[" <* s <*> many_ value <* s <* "]"
listValue = ListValue <$> brackets (many value)
-- Notice it can be empty
objectValue :: Parser ObjectValue
objectValue = ObjectValue <$ "{" <* s <*> many_ objectField <* s <* "}"
objectValue = ObjectValue <$> braces (many objectField)
objectField :: Parser ObjectField
objectField = ObjectField <$> name <* s <* ":" <* s <*> value
objectField = ObjectField <$> name <* tok ":" <*> value
bool :: Parser Bool
bool = True <$ "true"
@ -170,10 +175,13 @@ bool = True <$ "true"
-- * Directives
directives :: Parser [Directive]
directives = many_ directive
directives = many1 directive
directive :: Parser Directive
directive = Directive <$ "@" <*> name <* s <*> arguments
directive = Directive
<$ tok "@"
<*> name
<*> optempty arguments
-- * Type Reference
@ -186,16 +194,14 @@ namedType :: Parser NamedType
namedType = NamedType <$> name
listType :: Parser ListType
listType = ListType <$ "[" <* s <*> type_ <* s <* "]"
listType = ListType <$> brackets type_
nonNullType :: Parser NonNullType
nonNullType = NonNullTypeNamed <$> namedType <* s <* "!"
<|> NonNullTypeList <$> listType <* s <* "!"
nonNullType = NonNullTypeNamed <$> namedType <* tok "!"
<|> NonNullTypeList <$> listType <* tok "!"
-- * Type Definition
-- TODO: what is Const Variable?
-- https://facebook.github.io/graphql/#Value
typeDefinition :: Parser TypeDefinition
typeDefinition =
TypeDefinitionObject <$> objectTypeDefinition
@ -209,102 +215,113 @@ typeDefinition =
objectTypeDefinition :: Parser ObjectTypeDefinition
objectTypeDefinition = ObjectTypeDefinition
<$ "type" <* s1
<*> name <* s1
<*> (interfaces <* s <|> empty)
<$ tok "type"
<*> name
<*> optempty interfaces
<*> fieldDefinitions
<?> "objectTypeDefinition error!"
interfaces :: Parser Interfaces
interfaces = "implements" *> s1 *> many1_ namedType
interfaces = tok "implements" *> many1 namedType
fieldDefinitions :: Parser [FieldDefinition]
fieldDefinitions = "{" *> s *> many1_ fieldDefinition <* s <* "}"
fieldDefinitions = braces $ many1 fieldDefinition
fieldDefinition :: Parser FieldDefinition
fieldDefinition = FieldDefinition
<$> name <* s
<*> (argumentsDefinition <* s <|> empty)
<* ":" <* s
<$> name
<*> optempty argumentsDefinition
<* tok ":"
<*> type_
argumentsDefinition :: Parser ArgumentsDefinition
argumentsDefinition = inputValueDefinitions
inputValueDefinitions :: Parser [InputValueDefinition]
inputValueDefinitions = "(" *> s *> many1_ inputValueDefinition <* s <* ")"
inputValueDefinitions = parens $ many1 inputValueDefinition
inputValueDefinition :: Parser InputValueDefinition
inputValueDefinition = InputValueDefinition
<$> name <* s
<* ":" <* s
<*> type_ <* s
<*> (value <|> empty)
<$> name
<* tok ":"
<*> type_
<*> optional defaultValue
interfaceTypeDefinition :: Parser InterfaceTypeDefinition
interfaceTypeDefinition = InterfaceTypeDefinition
<$ "interface" <* s1
<*> name <* s
<$ tok "interface"
<*> name
<*> fieldDefinitions
unionTypeDefinition :: Parser UnionTypeDefinition
unionTypeDefinition = UnionTypeDefinition
<$ "union" <* s1
<*> name <* s
<* "=" <* s
<$ tok "union"
<*> name
<* tok "="
<*> unionMembers
where
-- This should take care of standalone `NamedType`
unionMembers = namedType `sepBy1` (s *> "|" <* s)
unionMembers :: Parser [NamedType]
unionMembers = namedType `sepBy1` tok "|"
scalarTypeDefinition :: Parser ScalarTypeDefinition
scalarTypeDefinition = ScalarTypeDefinition <$ "scalar" <* s1 <*> name
scalarTypeDefinition = ScalarTypeDefinition
<$ tok "scalar"
<*> name
enumTypeDefinition :: Parser EnumTypeDefinition
enumTypeDefinition = EnumTypeDefinition
<$ "enum" <* s1
<*> name <* s
<$ tok "enum"
<*> name
<*> enumValueDefinitions
enumValueDefinitions :: Parser [EnumValueDefinition]
enumValueDefinitions = "{" *> s *> many1_ enumValueDefinition <* s <* "}"
enumValueDefinitions = braces $ many1 enumValueDefinition
enumValueDefinition :: Parser EnumValueDefinition
enumValueDefinition = EnumValueDefinition <$> name
inputObjectTypeDefinition :: Parser InputObjectTypeDefinition
inputObjectTypeDefinition = InputObjectTypeDefinition
<$ "input" <* s1
<*> name <* s
<$ tok "input"
<*> name
<*> inputValueDefinitions
typeExtensionDefinition :: Parser TypeExtensionDefinition
typeExtensionDefinition = TypeExtensionDefinition
<$ "extend" <* s1
<$ tok "extend"
<*> objectTypeDefinition
-- * Internal
many_ :: Parser a -> Parser [a]
many_ = flip sepBy space'
tok :: Parser a -> Parser a
tok p = p <* whiteSpace
many1_ :: Parser a -> Parser [a]
many1_ = flip sepBy1 space'
parens :: Parser a -> Parser a
parens = between "(" ")"
space' :: Parser Char
space' = satisfy isSpace'
braces :: Parser a -> Parser a
braces = between "{" "}"
s :: Parser ()
s = comments <|> skipWhile isSpace'
brackets :: Parser a -> Parser a
brackets = between "[" "]"
s1 :: Parser ()
s1 = comments <|> space' *> s
between :: Parser Text -> Parser Text -> Parser a -> Parser a
between open close p = tok open *> p <* tok close
isSpace' :: Char -> Bool
isSpace' c = isSpace c || ',' == c || isEndOfLine c
-- `empty` /= `pure mempty` for `Parser`.
optempty :: Monoid a => Parser a -> Parser a
optempty = option mempty
-- ** WhiteSpace
--
whiteSpace :: Parser ()
whiteSpace = comments
<|> skipWhile (\c -> isSpace c
|| ',' == c
|| isEndOfLine c)
comments :: Parser ()
comments = skipMany comment
comment :: Parser ()
comment = () <$ "#" <* manyTill anyChar endOfLine
comment :: Parser Text
comment = "#" *> takeTill isEndOfLine