diff options
Diffstat (limited to 'Data')
| -rw-r--r-- | Data/GraphQL/AST.hs (renamed from Data/GraphQL.hs) | 37 | ||||
| -rw-r--r-- | Data/GraphQL/Parser.hs | 322 |
2 files changed, 342 insertions, 17 deletions
diff --git a/Data/GraphQL.hs b/Data/GraphQL/AST.hs index d878022..0a09671 100644 --- a/Data/GraphQL.hs +++ b/Data/GraphQL/AST.hs @@ -1,4 +1,4 @@ -module Data.GraphQL where +module Data.GraphQL.AST where import Data.Text (Text) @@ -16,9 +16,10 @@ data Definition = DefinitionOperation OperationDefinition deriving (Eq,Show) data OperationDefinition = - Query (Maybe [VariableDefinition]) (Maybe [Directive]) SelectionSet - | Mutation (Maybe [VariableDefinition]) (Maybe [Directive]) SelectionSet - | Subscription (Maybe [VariableDefinition]) (Maybe [Directive]) SelectionSet + Query Name [VariableDefinition] [Directive] SelectionSet + | Mutation Name [VariableDefinition] [Directive] SelectionSet + -- Not official yet + -- -- | Subscription Name [VariableDefinition] [Directive] SelectionSet deriving (Eq,Show) data VariableDefinition = VariableDefinition Variable Type (Maybe DefaultValue) @@ -26,16 +27,16 @@ data VariableDefinition = VariableDefinition Variable Type (Maybe DefaultValue) newtype Variable = Variable Name deriving (Eq,Show) -newtype SelectionSet = SelectionSet [Selection] deriving (Eq,Show) +type SelectionSet = [Selection] data Selection = SelectionField Field | SelectionFragmentSpread FragmentSpread | SelectionInlineFragment InlineFragment deriving (Eq,Show) -data Field = Field (Maybe Alias) Name (Maybe [Argument]) - (Maybe [Directive]) - (Maybe SelectionSet) +data Field = Field Alias Name [Argument] + [Directive] + SelectionSet deriving (Eq,Show) type Alias = Name @@ -44,15 +45,15 @@ data Argument = Argument Name Value deriving (Eq,Show) -- * Fragments -data FragmentSpread = FragmentSpread Name (Maybe [Directive]) +data FragmentSpread = FragmentSpread Name [Directive] deriving (Eq,Show) data InlineFragment = - InlineFragment TypeCondition (Maybe [Directive]) SelectionSet + InlineFragment TypeCondition [Directive] SelectionSet deriving (Eq,Show) data FragmentDefinition = - FragmentDefinition Name TypeCondition (Maybe [Directive]) SelectionSet + FragmentDefinition Name TypeCondition [Directive] SelectionSet deriving (Eq,Show) type TypeCondition = NamedType @@ -60,10 +61,10 @@ type TypeCondition = NamedType -- * Values data Value = ValueVariable Variable - | ValueInt Int - | ValueFloat Float - | ValueString Text + | ValueInt Int -- TODO: Should this be `Integer`? + | ValueFloat Double -- TODO: Should this be `Scientific`? | ValueBoolean Bool + | ValueString Text | ValueEnum Name | ValueList ListValue | ValueObject ObjectValue @@ -79,7 +80,7 @@ type DefaultValue = Value -- * Directives -data Directive = Directive Name (Maybe [Argument]) deriving (Eq,Show) +data Directive = Directive Name [Argument] deriving (Eq,Show) -- * Type Reference @@ -107,14 +108,16 @@ data TypeDefinition = TypeDefinitionObject ObjectTypeDefinition | TypeDefinitionTypeExtension TypeExtensionDefinition deriving (Eq,Show) -data ObjectTypeDefinition = ObjectTypeDefinition Name (Maybe Interfaces) [FieldDefinition] +data ObjectTypeDefinition = ObjectTypeDefinition Name Interfaces [FieldDefinition] deriving (Eq,Show) type Interfaces = [NamedType] -data FieldDefinition = FieldDefinition Name [InputValueDefinition] +data FieldDefinition = FieldDefinition Name ArgumentsDefinition Type deriving (Eq,Show) +type ArgumentsDefinition = [InputValueDefinition] + data InputValueDefinition = InputValueDefinition Name Type (Maybe DefaultValue) deriving (Eq,Show) diff --git a/Data/GraphQL/Parser.hs b/Data/GraphQL/Parser.hs new file mode 100644 index 0000000..66d913d --- /dev/null +++ b/Data/GraphQL/Parser.hs @@ -0,0 +1,322 @@ +{-# 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 () |