diff options
Diffstat (limited to 'Data/GraphQL/Parser.hs')
| -rw-r--r-- | Data/GraphQL/Parser.hs | 107 |
1 files changed, 58 insertions, 49 deletions
diff --git a/Data/GraphQL/Parser.hs b/Data/GraphQL/Parser.hs index c999004..1f5b8e6 100644 --- a/Data/GraphQL/Parser.hs +++ b/Data/GraphQL/Parser.hs @@ -1,6 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE LambdaCase #-} module Data.GraphQL.Parser where import Prelude hiding (takeWhile) @@ -11,8 +10,10 @@ import Data.Monoid (Monoid, mempty) #endif import Control.Applicative ((<|>), empty, many, optional) import Control.Monad (when) -import Data.Char -import Data.Text (Text, pack) +import Data.Char (isDigit, isSpace) +import Data.Foldable (traverse_) + +import Data.Text (Text, append) import Data.Attoparsec.Text ( Parser , (<?>) @@ -20,25 +21,27 @@ import Data.Attoparsec.Text , decimal , double , endOfLine + , inClass , many1 , manyTill , option , peekChar - , satisfy , sepBy1 , signed + , takeWhile + , takeWhile1 ) 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) +name = tok $ append <$> takeWhile1 isA_z + <*> takeWhile ((||) <$> isDigit <*> isA_z) + where + -- `isAlpha` handles many more Unicode Chars + isA_z = inClass $ '_' : ['A'..'Z'] ++ ['a'..'z'] -- * Document @@ -48,7 +51,8 @@ document = whiteSpace -- Try SelectionSet when no definition <|> (Document . pure . DefinitionOperation - . Query mempty empty empty + . Query + . Node mempty empty empty <$> selectionSet) <?> "document error!" @@ -60,14 +64,15 @@ definition = DefinitionOperation <$> operationDefinition operationDefinition :: Parser OperationDefinition operationDefinition = - op Query "query" - <|> op Mutation "mutation" + Query <$ tok "query" <*> node + <|> Mutation <$ tok "mutation" <*> node <?> "operationDefinition error!" - where - op f n = f <$ tok n <*> tok name - <*> optempty variableDefinitions - <*> optempty directives - <*> selectionSet + +node :: Parser Node +node = Node <$> name + <*> optempty variableDefinitions + <*> optempty directives + <*> selectionSet variableDefinitions :: Parser [VariableDefinition] variableDefinitions = parens (many1 variableDefinition) @@ -148,16 +153,24 @@ typeCondition = namedType -- 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 + -- TODO: Handle maxBound, Int32 in spec. + <|> ValueInt <$> tok (signed decimal) + <|> ValueFloat <$> tok (signed double) + <|> ValueBoolean <$> booleanValue + <|> ValueString <$> stringValue -- `true` and `false` have been tried before - <|> ValueEnum <$> name - <|> ValueList <$> listValue - <|> ValueObject <$> objectValue + <|> ValueEnum <$> name + <|> ValueList <$> listValue + <|> ValueObject <$> objectValue + <?> "value error!" + +booleanValue :: Parser Bool +booleanValue = True <$ tok "true" + <|> False <$ tok "false" + +-- TODO: Escape characters. Look at `jsstring_` in aeson package. +stringValue :: Parser StringValue +stringValue = StringValue <$> quotes (takeWhile (/= '"')) -- Notice it can be empty listValue :: Parser ListValue @@ -170,10 +183,6 @@ 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] @@ -188,9 +197,10 @@ directive = Directive -- * Type Reference type_ :: Parser Type -type_ = TypeNamed <$> namedType - <|> TypeList <$> listType +type_ = TypeList <$> listType <|> TypeNonNull <$> nonNullType + <|> TypeNamed <$> namedType + <?> "type_ error!" namedType :: Parser NamedType namedType = NamedType <$> name @@ -201,6 +211,7 @@ listType = ListType <$> brackets type_ nonNullType :: Parser NonNullType nonNullType = NonNullTypeNamed <$> namedType <* tok "!" <|> NonNullTypeList <$> listType <* tok "!" + <?> "nonNullType error!" -- * Type Definition @@ -221,7 +232,6 @@ objectTypeDefinition = ObjectTypeDefinition <*> name <*> optempty interfaces <*> fieldDefinitions - <?> "objectTypeDefinition error!" interfaces :: Parser Interfaces interfaces = tok "implements" *> many1 namedType @@ -237,17 +247,7 @@ fieldDefinition = FieldDefinition <*> type_ argumentsDefinition :: Parser ArgumentsDefinition -argumentsDefinition = inputValueDefinitions - -inputValueDefinitions :: Parser [InputValueDefinition] -inputValueDefinitions = parens $ many1 inputValueDefinition - -inputValueDefinition :: Parser InputValueDefinition -inputValueDefinition = InputValueDefinition - <$> name - <* tok ":" - <*> type_ - <*> optional defaultValue +argumentsDefinition = parens $ many1 inputValueDefinition interfaceTypeDefinition :: Parser InterfaceTypeDefinition interfaceTypeDefinition = InterfaceTypeDefinition @@ -288,6 +288,16 @@ inputObjectTypeDefinition = InputObjectTypeDefinition <*> name <*> inputValueDefinitions +inputValueDefinitions :: Parser [InputValueDefinition] +inputValueDefinitions = braces $ many1 inputValueDefinition + +inputValueDefinition :: Parser InputValueDefinition +inputValueDefinition = InputValueDefinition + <$> name + <* tok ":" + <*> type_ + <*> optional defaultValue + typeExtensionDefinition :: Parser TypeExtensionDefinition typeExtensionDefinition = TypeExtensionDefinition <$ tok "extend" @@ -320,8 +330,7 @@ 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 () +whiteSpace = peekChar >>= traverse_ (\c -> + if isSpace c || c == ',' + then anyChar *> whiteSpace + else when (c == '#') $ manyTill anyChar endOfLine *> whiteSpace) |