diff options
Diffstat (limited to 'src/Language/GraphQL/AST')
| -rw-r--r-- | src/Language/GraphQL/AST/Core.hs | 19 | ||||
| -rw-r--r-- | src/Language/GraphQL/AST/Document.hs | 17 | ||||
| -rw-r--r-- | src/Language/GraphQL/AST/Encoder.hs | 37 | ||||
| -rw-r--r-- | src/Language/GraphQL/AST/Lexer.hs | 6 | ||||
| -rw-r--r-- | src/Language/GraphQL/AST/Parser.hs | 218 |
5 files changed, 160 insertions, 137 deletions
diff --git a/src/Language/GraphQL/AST/Core.hs b/src/Language/GraphQL/AST/Core.hs deleted file mode 100644 index 0fe3e03..0000000 --- a/src/Language/GraphQL/AST/Core.hs +++ /dev/null @@ -1,19 +0,0 @@ --- | This is the AST meant to be executed. -module Language.GraphQL.AST.Core - ( Arguments(..) - ) where - -import Data.HashMap.Strict (HashMap) -import Language.GraphQL.AST (Name) -import Language.GraphQL.Type.Definition - --- | Argument list. -newtype Arguments = Arguments (HashMap Name Value) - deriving (Eq, Show) - -instance Semigroup Arguments where - (Arguments x) <> (Arguments y) = Arguments $ x <> y - -instance Monoid Arguments where - mempty = Arguments mempty - diff --git a/src/Language/GraphQL/AST/Document.hs b/src/Language/GraphQL/AST/Document.hs index 430e92a..3394bfa 100644 --- a/src/Language/GraphQL/AST/Document.hs +++ b/src/Language/GraphQL/AST/Document.hs @@ -19,6 +19,7 @@ module Language.GraphQL.AST.Document , FragmentDefinition(..) , ImplementsInterfaces(..) , InputValueDefinition(..) + , Location(..) , Name , NamedType , NonNullType(..) @@ -55,6 +56,12 @@ import Language.GraphQL.AST.DirectiveLocation -- | Name. type Name = Text +-- | Error location, line and column. +data Location = Location + { line :: Word + , column :: Word + } deriving (Eq, Show) + -- ** Document -- | GraphQL document. @@ -62,9 +69,9 @@ type Document = NonEmpty Definition -- | All kinds of definitions that can occur in a GraphQL document. data Definition - = ExecutableDefinition ExecutableDefinition - | TypeSystemDefinition TypeSystemDefinition - | TypeSystemExtension TypeSystemExtension + = ExecutableDefinition ExecutableDefinition Location + | TypeSystemDefinition TypeSystemDefinition Location + | TypeSystemExtension TypeSystemExtension Location deriving (Eq, Show) -- | Top-level definition of a document, either an operation or a fragment. @@ -92,9 +99,7 @@ data OperationDefinition -- * mutation - a write operation followed by a fetch. -- * subscription - a long-lived request that fetches data in response to -- source events. --- --- Currently only queries and mutations are supported. -data OperationType = Query | Mutation deriving (Eq, Show) +data OperationType = Query | Mutation | Subscription deriving (Eq, Show) -- ** Selection Sets diff --git a/src/Language/GraphQL/AST/Encoder.hs b/src/Language/GraphQL/AST/Encoder.hs index 7fb0677..a0dac5b 100644 --- a/src/Language/GraphQL/AST/Encoder.hs +++ b/src/Language/GraphQL/AST/Encoder.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} -- | This module defines a minifier and a printer for the @GraphQL@ language. module Language.GraphQL.AST.Encoder @@ -49,7 +50,8 @@ document formatter defs | Minified <-formatter = Lazy.Text.snoc (mconcat encodeDocument) '\n' where encodeDocument = foldr executableDefinition [] defs - executableDefinition (ExecutableDefinition x) acc = definition formatter x : acc + executableDefinition (ExecutableDefinition x _) acc = + definition formatter x : acc executableDefinition _ acc = acc -- | Converts a t'ExecutableDefinition' into a string. @@ -65,12 +67,14 @@ definition formatter x -- | Converts a 'OperationDefinition into a string. operationDefinition :: Formatter -> OperationDefinition -> Lazy.Text -operationDefinition formatter (SelectionSet sels) - = selectionSet formatter sels -operationDefinition formatter (OperationDefinition Query name vars dirs sels) - = "query " <> node formatter name vars dirs sels -operationDefinition formatter (OperationDefinition Mutation name vars dirs sels) - = "mutation " <> node formatter name vars dirs sels +operationDefinition formatter = \case + SelectionSet sels -> selectionSet formatter sels + OperationDefinition Query name vars dirs sels -> + "query " <> node formatter name vars dirs sels + OperationDefinition Mutation name vars dirs sels -> + "mutation " <> node formatter name vars dirs sels + OperationDefinition Subscription name vars dirs sels -> + "subscription " <> node formatter name vars dirs sels -- | Converts a Query or Mutation into a string. node :: Formatter -> @@ -254,19 +258,20 @@ stringValue (Pretty indentation) string = char == '\t' || isNewline char || (char >= '\x0020' && char /= '\x007F') tripleQuote = Builder.fromText "\"\"\"" - start = tripleQuote <> Builder.singleton '\n' - end = Builder.fromLazyText (indent indentation) <> tripleQuote + newline = Builder.singleton '\n' strip = Text.dropWhile isWhiteSpace . Text.dropWhileEnd isWhiteSpace lines' = map Builder.fromText $ Text.split isNewline (Text.replace "\r\n" "\n" $ strip string) encoded [] = oneLine string encoded [_] = oneLine string - encoded lines'' = start <> transformLines lines'' <> end - transformLines = foldr ((\line acc -> line <> Builder.singleton '\n' <> acc) . transformLine) mempty - transformLine line = - if Lazy.Text.null (Builder.toLazyText line) - then line - else Builder.fromLazyText (indent (indentation + 1)) <> line + encoded lines'' = tripleQuote <> newline + <> transformLines lines'' + <> Builder.fromLazyText (indent indentation) <> tripleQuote + transformLines = foldr transformLine mempty + transformLine "" acc = newline <> acc + transformLine line' acc + = Builder.fromLazyText (indent (indentation + 1)) + <> line' <> newline <> acc escape :: Char -> Builder escape char' diff --git a/src/Language/GraphQL/AST/Lexer.hs b/src/Language/GraphQL/AST/Lexer.hs index 0ba55e3..17d3f9c 100644 --- a/src/Language/GraphQL/AST/Lexer.hs +++ b/src/Language/GraphQL/AST/Lexer.hs @@ -168,11 +168,11 @@ blockString = between "\"\"\"" "\"\"\"" stringValue <* spaceConsumer -- | Parser for integers. integer :: Integral a => Parser a -integer = Lexer.signed (pure ()) $ lexeme Lexer.decimal +integer = Lexer.signed (pure ()) (lexeme Lexer.decimal) <?> "IntValue" -- | Parser for floating-point numbers. float :: Parser Double -float = Lexer.signed (pure ()) $ lexeme Lexer.float +float = Lexer.signed (pure ()) (lexeme Lexer.float) <?> "FloatValue" -- | Parser for names (/[_A-Za-z][_0-9A-Za-z]*/). name :: Parser T.Text @@ -233,4 +233,4 @@ extend token extensionLabel parsers tryExtension extensionParser = try $ symbol "extend" *> symbol token - *> extensionParser
\ No newline at end of file + *> extensionParser diff --git a/src/Language/GraphQL/AST/Parser.hs b/src/Language/GraphQL/AST/Parser.hs index c18c36a..687d8f5 100644 --- a/src/Language/GraphQL/AST/Parser.hs +++ b/src/Language/GraphQL/AST/Parser.hs @@ -1,12 +1,13 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} -- | @GraphQL@ document parser. module Language.GraphQL.AST.Parser ( document ) where -import Control.Applicative (Alternative(..), optional) +import Control.Applicative (Alternative(..), liftA2, optional) import Control.Applicative.Combinators (sepBy1) import qualified Control.Applicative.Combinators.NonEmpty as NonEmpty import Data.List.NonEmpty (NonEmpty(..)) @@ -19,19 +20,47 @@ import Language.GraphQL.AST.DirectiveLocation ) import Language.GraphQL.AST.Document import Language.GraphQL.AST.Lexer -import Text.Megaparsec (lookAhead, option, try, (<?>)) +import Text.Megaparsec + ( SourcePos(..) + , getSourcePos + , lookAhead + , option + , try + , unPos + , (<?>) + ) -- | Parser for the GraphQL documents. document :: Parser Document document = unicodeBOM - >> spaceConsumer - >> lexeme (NonEmpty.some definition) + *> spaceConsumer + *> lexeme (NonEmpty.some definition) definition :: Parser Definition -definition = ExecutableDefinition <$> executableDefinition - <|> TypeSystemDefinition <$> typeSystemDefinition - <|> TypeSystemExtension <$> typeSystemExtension +definition = executableDefinition' + <|> typeSystemDefinition' + <|> typeSystemExtension' <?> "Definition" + where + executableDefinition' = do + location <- getLocation + definition' <- executableDefinition + pure $ ExecutableDefinition definition' location + typeSystemDefinition' = do + location <- getLocation + definition' <- typeSystemDefinition + pure $ TypeSystemDefinition definition' location + typeSystemExtension' = do + location <- getLocation + definition' <- typeSystemExtension + pure $ TypeSystemExtension definition' location + +getLocation :: Parser Location +getLocation = fromSourcePosition <$> getSourcePos + where + fromSourcePosition SourcePos{..} = + Location (wordFromPosition sourceLine) (wordFromPosition sourceColumn) + wordFromPosition = fromIntegral . unPos executableDefinition :: Parser ExecutableDefinition executableDefinition = DefinitionOperation <$> operationDefinition @@ -40,19 +69,22 @@ executableDefinition = DefinitionOperation <$> operationDefinition typeSystemDefinition :: Parser TypeSystemDefinition typeSystemDefinition = schemaDefinition - <|> TypeDefinition <$> typeDefinition - <|> directiveDefinition + <|> typeSystemDefinitionWithDescription <?> "TypeSystemDefinition" + where + typeSystemDefinitionWithDescription = description + >>= liftA2 (<|>) typeDefinition' directiveDefinition + typeDefinition' description' = TypeDefinition + <$> typeDefinition description' typeSystemExtension :: Parser TypeSystemExtension typeSystemExtension = SchemaExtension <$> schemaExtension <|> TypeExtension <$> typeExtension <?> "TypeSystemExtension" -directiveDefinition :: Parser TypeSystemDefinition -directiveDefinition = DirectiveDefinition - <$> description - <* symbol "directive" +directiveDefinition :: Description -> Parser TypeSystemDefinition +directiveDefinition description' = DirectiveDefinition description' + <$ symbol "directive" <* at <*> name <*> argumentsDefinition @@ -63,11 +95,13 @@ directiveDefinition = DirectiveDefinition directiveLocations :: Parser (NonEmpty DirectiveLocation) directiveLocations = optional pipe *> directiveLocation `NonEmpty.sepBy1` pipe + <?> "DirectiveLocations" directiveLocation :: Parser DirectiveLocation directiveLocation = Directive.ExecutableDirectiveLocation <$> executableDirectiveLocation <|> Directive.TypeSystemDirectiveLocation <$> typeSystemDirectiveLocation + <?> "DirectiveLocation" executableDirectiveLocation :: Parser ExecutableDirectiveLocation executableDirectiveLocation = Directive.Query <$ symbol "QUERY" @@ -77,6 +111,7 @@ executableDirectiveLocation = Directive.Query <$ symbol "QUERY" <|> Directive.FragmentDefinition <$ "FRAGMENT_DEFINITION" <|> Directive.FragmentSpread <$ "FRAGMENT_SPREAD" <|> Directive.InlineFragment <$ "INLINE_FRAGMENT" + <?> "ExecutableDirectiveLocation" typeSystemDirectiveLocation :: Parser TypeSystemDirectiveLocation typeSystemDirectiveLocation = Directive.Schema <$ symbol "SCHEMA" @@ -90,14 +125,15 @@ typeSystemDirectiveLocation = Directive.Schema <$ symbol "SCHEMA" <|> Directive.EnumValue <$ symbol "ENUM_VALUE" <|> Directive.InputObject <$ symbol "INPUT_OBJECT" <|> Directive.InputFieldDefinition <$ symbol "INPUT_FIELD_DEFINITION" - -typeDefinition :: Parser TypeDefinition -typeDefinition = scalarTypeDefinition - <|> objectTypeDefinition - <|> interfaceTypeDefinition - <|> unionTypeDefinition - <|> enumTypeDefinition - <|> inputObjectTypeDefinition + <?> "TypeSystemDirectiveLocation" + +typeDefinition :: Description -> Parser TypeDefinition +typeDefinition description' = scalarTypeDefinition description' + <|> objectTypeDefinition description' + <|> interfaceTypeDefinition description' + <|> unionTypeDefinition description' + <|> enumTypeDefinition description' + <|> inputObjectTypeDefinition description' <?> "TypeDefinition" typeExtension :: Parser TypeExtension @@ -109,10 +145,9 @@ typeExtension = scalarTypeExtension <|> inputObjectTypeExtension <?> "TypeExtension" -scalarTypeDefinition :: Parser TypeDefinition -scalarTypeDefinition = ScalarTypeDefinition - <$> description - <* symbol "scalar" +scalarTypeDefinition :: Description -> Parser TypeDefinition +scalarTypeDefinition description' = ScalarTypeDefinition description' + <$ symbol "scalar" <*> name <*> directives <?> "ScalarTypeDefinition" @@ -121,10 +156,9 @@ scalarTypeExtension :: Parser TypeExtension scalarTypeExtension = extend "scalar" "ScalarTypeExtension" $ (ScalarTypeExtension <$> name <*> NonEmpty.some directive) :| [] -objectTypeDefinition :: Parser TypeDefinition -objectTypeDefinition = ObjectTypeDefinition - <$> description - <* symbol "type" +objectTypeDefinition :: Description -> Parser TypeDefinition +objectTypeDefinition description' = ObjectTypeDefinition description' + <$ symbol "type" <*> name <*> option (ImplementsInterfaces []) (implementsInterfaces sepBy1) <*> directives @@ -153,13 +187,12 @@ objectTypeExtension = extend "type" "ObjectTypeExtension" description :: Parser Description description = Description - <$> optional (string <|> blockString) + <$> optional stringValue <?> "Description" -unionTypeDefinition :: Parser TypeDefinition -unionTypeDefinition = UnionTypeDefinition - <$> description - <* symbol "union" +unionTypeDefinition :: Description -> Parser TypeDefinition +unionTypeDefinition description' = UnionTypeDefinition description' + <$ symbol "union" <*> name <*> directives <*> option (UnionMemberTypes []) (unionMemberTypes sepBy1) @@ -187,10 +220,9 @@ unionMemberTypes sepBy' = UnionMemberTypes <*> name `sepBy'` pipe <?> "UnionMemberTypes" -interfaceTypeDefinition :: Parser TypeDefinition -interfaceTypeDefinition = InterfaceTypeDefinition - <$> description - <* symbol "interface" +interfaceTypeDefinition :: Description -> Parser TypeDefinition +interfaceTypeDefinition description' = InterfaceTypeDefinition description' + <$ symbol "interface" <*> name <*> directives <*> braces (many fieldDefinition) @@ -208,10 +240,9 @@ interfaceTypeExtension = extend "interface" "InterfaceTypeExtension" <$> name <*> NonEmpty.some directive -enumTypeDefinition :: Parser TypeDefinition -enumTypeDefinition = EnumTypeDefinition - <$> description - <* symbol "enum" +enumTypeDefinition :: Description -> Parser TypeDefinition +enumTypeDefinition description' = EnumTypeDefinition description' + <$ symbol "enum" <*> name <*> directives <*> listOptIn braces enumValueDefinition @@ -229,10 +260,9 @@ enumTypeExtension = extend "enum" "EnumTypeExtension" <$> name <*> NonEmpty.some directive -inputObjectTypeDefinition :: Parser TypeDefinition -inputObjectTypeDefinition = InputObjectTypeDefinition - <$> description - <* symbol "input" +inputObjectTypeDefinition :: Description -> Parser TypeDefinition +inputObjectTypeDefinition description' = InputObjectTypeDefinition description' + <$ symbol "input" <*> name <*> directives <*> listOptIn braces inputValueDefinition @@ -321,7 +351,7 @@ operationTypeDefinition = OperationTypeDefinition operationDefinition :: Parser OperationDefinition operationDefinition = SelectionSet <$> selectionSet <|> operationDefinition' - <?> "operationDefinition error" + <?> "OperationDefinition" where operationDefinition' = OperationDefinition <$> operationType @@ -333,23 +363,20 @@ operationDefinition = SelectionSet <$> selectionSet operationType :: Parser OperationType operationType = Query <$ symbol "query" <|> Mutation <$ symbol "mutation" - -- <?> Keep default error message - --- * SelectionSet + <|> Subscription <$ symbol "subscription" + <?> "OperationType" selectionSet :: Parser SelectionSet -selectionSet = braces $ NonEmpty.some selection +selectionSet = braces (NonEmpty.some selection) <?> "SelectionSet" selectionSetOpt :: Parser SelectionSetOpt -selectionSetOpt = listOptIn braces selection +selectionSetOpt = listOptIn braces selection <?> "SelectionSet" selection :: Parser Selection selection = field <|> try fragmentSpread <|> inlineFragment - <?> "selection error!" - --- * Field + <?> "Selection" field :: Parser Selection field = Field @@ -358,25 +385,23 @@ field = Field <*> arguments <*> directives <*> selectionSetOpt + <?> "Field" alias :: Parser Alias -alias = try $ name <* colon - --- * Arguments +alias = try (name <* colon) <?> "Alias" arguments :: Parser [Argument] -arguments = listOptIn parens argument +arguments = listOptIn parens argument <?> "Arguments" argument :: Parser Argument -argument = Argument <$> name <* colon <*> value - --- * Fragments +argument = Argument <$> name <* colon <*> value <?> "Argument" fragmentSpread :: Parser Selection fragmentSpread = FragmentSpread <$ spread <*> fragmentName <*> directives + <?> "FragmentSpread" inlineFragment :: Parser Selection inlineFragment = InlineFragment @@ -384,62 +409,74 @@ inlineFragment = InlineFragment <*> optional typeCondition <*> directives <*> selectionSet + <?> "InlineFragment" fragmentDefinition :: Parser FragmentDefinition fragmentDefinition = FragmentDefinition - <$ symbol "fragment" - <*> name - <*> typeCondition - <*> directives - <*> selectionSet + <$ symbol "fragment" + <*> name + <*> typeCondition + <*> directives + <*> selectionSet + <?> "FragmentDefinition" fragmentName :: Parser Name -fragmentName = but (symbol "on") *> name +fragmentName = but (symbol "on") *> name <?> "FragmentName" typeCondition :: Parser TypeCondition -typeCondition = symbol "on" *> name - --- * Input Values +typeCondition = symbol "on" *> name <?> "TypeCondition" value :: Parser Value value = Variable <$> variable <|> Float <$> try float <|> Int <$> integer <|> Boolean <$> booleanValue - <|> Null <$ symbol "null" - <|> String <$> blockString - <|> String <$> string + <|> Null <$ nullValue + <|> String <$> stringValue <|> Enum <$> try enumValue <|> List <$> brackets (some value) <|> Object <$> braces (some $ objectField value) - <?> "value error!" + <?> "Value" constValue :: Parser ConstValue constValue = ConstFloat <$> try float <|> ConstInt <$> integer <|> ConstBoolean <$> booleanValue - <|> ConstNull <$ symbol "null" - <|> ConstString <$> blockString - <|> ConstString <$> string + <|> ConstNull <$ nullValue + <|> ConstString <$> stringValue <|> ConstEnum <$> try enumValue <|> ConstList <$> brackets (some constValue) <|> ConstObject <$> braces (some $ objectField constValue) - <?> "value error!" + <?> "Value" booleanValue :: Parser Bool booleanValue = True <$ symbol "true" <|> False <$ symbol "false" + <?> "BooleanValue" enumValue :: Parser Name -enumValue = but (symbol "true") *> but (symbol "false") *> but (symbol "null") *> name +enumValue = but (symbol "true") + *> but (symbol "false") + *> but (symbol "null") + *> name + <?> "EnumValue" -objectField :: Parser a -> Parser (ObjectField a) -objectField valueParser = ObjectField <$> name <* colon <*> valueParser +stringValue :: Parser Text +stringValue = blockString <|> string <?> "StringValue" --- * Variables +nullValue :: Parser Text +nullValue = symbol "null" <?> "NullValue" + +objectField :: Parser a -> Parser (ObjectField a) +objectField valueParser = ObjectField + <$> name + <* colon + <*> valueParser + <?> "ObjectField" variableDefinitions :: Parser [VariableDefinition] variableDefinitions = listOptIn parens variableDefinition + <?> "VariableDefinitions" variableDefinition :: Parser VariableDefinition variableDefinition = VariableDefinition @@ -450,13 +487,11 @@ variableDefinition = VariableDefinition <?> "VariableDefinition" variable :: Parser Name -variable = dollar *> name +variable = dollar *> name <?> "Variable" defaultValue :: Parser (Maybe ConstValue) defaultValue = optional (equals *> constValue) <?> "DefaultValue" --- * Input Types - type' :: Parser Type type' = try (TypeNonNull <$> nonNullType) <|> TypeList <$> brackets type' @@ -465,21 +500,18 @@ type' = try (TypeNonNull <$> nonNullType) nonNullType :: Parser NonNullType nonNullType = NonNullTypeNamed <$> name <* bang - <|> NonNullTypeList <$> brackets type' <* bang - <?> "nonNullType error!" - --- * Directives + <|> NonNullTypeList <$> brackets type' <* bang + <?> "NonNullType" directives :: Parser [Directive] -directives = many directive +directives = many directive <?> "Directives" directive :: Parser Directive directive = Directive <$ at <*> name <*> arguments - --- * Internal + <?> "Directive" listOptIn :: (Parser [a] -> Parser [a]) -> Parser a -> Parser [a] listOptIn surround = option [] . surround . some |