diff options
Diffstat (limited to 'src/Language/GraphQL/AST')
| -rw-r--r-- | src/Language/GraphQL/AST/Core.hs | 12 | ||||
| -rw-r--r-- | src/Language/GraphQL/AST/DirectiveLocation.hs | 41 | ||||
| -rw-r--r-- | src/Language/GraphQL/AST/Document.hs | 486 | ||||
| -rw-r--r-- | src/Language/GraphQL/AST/Encoder.hs | 116 | ||||
| -rw-r--r-- | src/Language/GraphQL/AST/Lexer.hs | 42 | ||||
| -rw-r--r-- | src/Language/GraphQL/AST/Parser.hs | 435 |
6 files changed, 1001 insertions, 131 deletions
diff --git a/src/Language/GraphQL/AST/Core.hs b/src/Language/GraphQL/AST/Core.hs index 7ba4830..084ae21 100644 --- a/src/Language/GraphQL/AST/Core.hs +++ b/src/Language/GraphQL/AST/Core.hs @@ -1,7 +1,6 @@ -- | This is the AST meant to be executed. module Language.GraphQL.AST.Core ( Alias - , Argument(..) , Arguments(..) , Directive(..) , Document @@ -35,16 +34,19 @@ data Operation -- | Single GraphQL field. data Field - = Field (Maybe Alias) Name [Argument] (Seq Selection) + = Field (Maybe Alias) Name Arguments (Seq Selection) deriving (Eq, Show) --- | Single argument. -data Argument = Argument Name Value deriving (Eq, Show) - -- | 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 + -- | Directive. data Directive = Directive Name Arguments deriving (Eq, Show) diff --git a/src/Language/GraphQL/AST/DirectiveLocation.hs b/src/Language/GraphQL/AST/DirectiveLocation.hs new file mode 100644 index 0000000..5b7a36f --- /dev/null +++ b/src/Language/GraphQL/AST/DirectiveLocation.hs @@ -0,0 +1,41 @@ +-- | Various parts of a GraphQL document can be annotated with directives. +-- This module describes locations in a document where directives can appear. +module Language.GraphQL.AST.DirectiveLocation + ( DirectiveLocation(..) + , ExecutableDirectiveLocation(..) + , TypeSystemDirectiveLocation(..) + ) where + +-- | All directives can be splitted in two groups: directives used to annotate +-- various parts of executable definitions and the ones used in the schema +-- definition. +data DirectiveLocation + = ExecutableDirectiveLocation ExecutableDirectiveLocation + | TypeSystemDirectiveLocation TypeSystemDirectiveLocation + deriving (Eq, Show) + +-- | Where directives can appear in an executable definition, like a query. +data ExecutableDirectiveLocation + = Query + | Mutation + | Subscription + | Field + | FragmentDefinition + | FragmentSpread + | InlineFragment + deriving (Eq, Show) + +-- | Where directives can appear in a type system definition. +data TypeSystemDirectiveLocation + = Schema + | Scalar + | Object + | FieldDefinition + | ArgumentDefinition + | Interface + | Union + | Enum + | EnumValue + | InputObject + | InputFieldDefinition + deriving (Eq, Show) diff --git a/src/Language/GraphQL/AST/Document.hs b/src/Language/GraphQL/AST/Document.hs new file mode 100644 index 0000000..3b13691 --- /dev/null +++ b/src/Language/GraphQL/AST/Document.hs @@ -0,0 +1,486 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | This module defines an abstract syntax tree for the @GraphQL@ language. It +-- follows closely the structure given in the specification. Please refer to +-- <https://facebook.github.io/graphql/ Facebook's GraphQL Specification>. +-- for more information. +module Language.GraphQL.AST.Document + ( Alias + , Argument(..) + , ArgumentsDefinition(..) + , Definition(..) + , Description(..) + , Directive(..) + , Document + , EnumValueDefinition(..) + , ExecutableDefinition(..) + , FieldDefinition(..) + , FragmentDefinition(..) + , ImplementsInterfaces(..) + , InputValueDefinition(..) + , Name + , NamedType + , NonNullType(..) + , ObjectField(..) + , OperationDefinition(..) + , OperationType(..) + , OperationTypeDefinition(..) + , SchemaExtension(..) + , Selection(..) + , SelectionSet + , SelectionSetOpt + , Type(..) + , TypeCondition + , TypeDefinition(..) + , TypeExtension(..) + , TypeSystemDefinition(..) + , TypeSystemExtension(..) + , UnionMemberTypes(..) + , Value(..) + , VariableDefinition(..) + ) where + +import Data.Foldable (toList) +import Data.Int (Int32) +import Data.List.NonEmpty (NonEmpty) +import Data.Text (Text) +import qualified Data.Text as Text +import Language.GraphQL.AST.DirectiveLocation + +-- * Language + +-- ** Source Text + +-- | Name. +type Name = Text + +-- ** Document + +-- | GraphQL document. +type Document = NonEmpty Definition + +-- | All kinds of definitions that can occur in a GraphQL document. +data Definition + = ExecutableDefinition ExecutableDefinition + | TypeSystemDefinition TypeSystemDefinition + | TypeSystemExtension TypeSystemExtension + deriving (Eq, Show) + +-- | Top-level definition of a document, either an operation or a fragment. +data ExecutableDefinition + = DefinitionOperation OperationDefinition + | DefinitionFragment FragmentDefinition + deriving (Eq, Show) + +-- ** Operations + +-- | Operation definition. +data OperationDefinition + = SelectionSet SelectionSet + | OperationDefinition + OperationType + (Maybe Name) + [VariableDefinition] + [Directive] + SelectionSet + deriving (Eq, Show) + +-- | GraphQL has 3 operation types: +-- +-- * query - a read-only fetch. +-- * 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) + +-- ** Selection Sets + +-- | "Top-level" selection, selection on an operation or fragment. +type SelectionSet = NonEmpty Selection + +-- | Field selection. +type SelectionSetOpt = [Selection] + +-- | Selection is a single entry in a selection set. It can be a single field, +-- fragment spread or inline fragment. +-- +-- The only required property of a field is its name. Optionally it can also +-- have an alias, arguments, directives and a list of subfields. +-- +-- In the following query "user" is a field with two subfields, "id" and "name": +-- +-- @ +-- { +-- user { +-- id +-- name +-- } +-- } +-- @ +-- +-- A fragment spread refers to a fragment defined outside the operation and is +-- expanded at the execution time. +-- +-- @ +-- { +-- user { +-- ...userFragment +-- } +-- } +-- +-- fragment userFragment on UserType { +-- id +-- name +-- } +-- @ +-- +-- Inline fragments are similar but they don't have any name and the type +-- condition ("on UserType") is optional. +-- +-- @ +-- { +-- user { +-- ... on UserType { +-- id +-- name +-- } +-- } +-- @ +data Selection + = Field (Maybe Alias) Name [Argument] [Directive] SelectionSetOpt + | FragmentSpread Name [Directive] + | InlineFragment (Maybe TypeCondition) [Directive] SelectionSet + deriving (Eq, Show) + +-- ** Arguments + +-- | Single argument. +-- +-- @ +-- { +-- user(id: 4) { +-- name +-- } +-- } +-- @ +-- +-- Here "id" is an argument for the field "user" and its value is 4. +data Argument = Argument Name Value deriving (Eq,Show) + +-- ** Field Alias + +-- | Alternative field name. +-- +-- @ +-- { +-- smallPic: profilePic(size: 64) +-- bigPic: profilePic(size: 1024) +-- } +-- @ +-- +-- Here "smallPic" and "bigPic" are aliases for the same field, "profilePic", +-- used to distinquish between profile pictures with different arguments +-- (sizes). +type Alias = Name + +-- ** Fragments + +-- | Fragment definition. +data FragmentDefinition + = FragmentDefinition Name TypeCondition [Directive] SelectionSet + deriving (Eq, Show) + +-- | Type condition. +type TypeCondition = Name + +-- ** Input Values + +-- | Input value. +data Value + = Variable Name + | Int Int32 + | Float Double + | String Text + | Boolean Bool + | Null + | Enum Name + | List [Value] + | Object [ObjectField] + deriving (Eq, Show) + +-- | Key-value pair. +-- +-- A list of 'ObjectField's represents a GraphQL object type. +data ObjectField = ObjectField Name Value deriving (Eq, Show) + +-- ** Variables + +-- | Variable definition. +data VariableDefinition = VariableDefinition Name Type (Maybe Value) + deriving (Eq, Show) + +-- ** Type References + +-- | Type representation. +data Type + = TypeNamed Name + | TypeList Type + | TypeNonNull NonNullType + deriving (Eq, Show) + +-- | Represents type names. +type NamedType = Name + +-- | Helper type to represent Non-Null types and lists of such types. +data NonNullType + = NonNullTypeNamed Name + | NonNullTypeList Type + deriving (Eq, Show) + +-- ** Directives + +-- | Directive. +-- +-- Directives begin with "@", can accept arguments, and can be applied to the +-- most GraphQL elements, providing additional information. +data Directive = Directive Name [Argument] deriving (Eq, Show) + +-- * Type System + +-- | Type system can define a schema, a type or a directive. +-- +-- @ +-- schema { +-- query: Query +-- } +-- +-- directive @example on FIELD_DEFINITION +-- +-- type Query { +-- field: String @example +-- } +-- @ +-- +-- This example defines a custom directive "@example", which is applied to a +-- field definition of the type definition "Query". On the top the schema +-- is defined by taking advantage of the type "Query". +data TypeSystemDefinition + = SchemaDefinition [Directive] (NonEmpty OperationTypeDefinition) + | TypeDefinition TypeDefinition + | DirectiveDefinition + Description Name ArgumentsDefinition (NonEmpty DirectiveLocation) + deriving (Eq, Show) + +-- ** Type System Extensions + +-- | Extension for a type system definition. Only schema and type definitions +-- can be extended. +data TypeSystemExtension + = SchemaExtension SchemaExtension + | TypeExtension TypeExtension + deriving (Eq, Show) + +-- ** Schema + +-- | Root operation type definition. +-- +-- Defining root operation types is not required since they have defaults. So +-- the default query root type is "Query", and the default mutation root type +-- is "Mutation". But these defaults can be changed for a specific schema. In +-- the following code the query root type is changed to "MyQueryRootType", and +-- the mutation root type to "MyMutationRootType": +-- +-- @ +-- schema { +-- query: MyQueryRootType +-- mutation: MyMutationRootType +-- } +-- @ +data OperationTypeDefinition + = OperationTypeDefinition OperationType NamedType + deriving (Eq, Show) + +-- | Extension of the schema definition by further operations or directives. +data SchemaExtension + = SchemaOperationExtension [Directive] (NonEmpty OperationTypeDefinition) + | SchemaDirectivesExtension (NonEmpty Directive) + deriving (Eq, Show) + +-- ** Descriptions + +-- | GraphQL has built-in capability to document service APIs. Documentation +-- is a GraphQL string that precedes a particular definition and contains +-- Markdown. Any GraphQL definition can be documented this way. +-- +-- @ +-- """ +-- Supported languages. +-- """ +-- enum Language { +-- "English" +-- EN +-- +-- "Russian" +-- RU +-- } +-- @ +newtype Description = Description (Maybe Text) + deriving (Eq, Show) + +-- ** Types + +-- | Type definitions describe various user-defined types. +data TypeDefinition + = ScalarTypeDefinition Description Name [Directive] + | ObjectTypeDefinition + Description + Name + (ImplementsInterfaces []) + [Directive] + [FieldDefinition] + | InterfaceTypeDefinition Description Name [Directive] [FieldDefinition] + | UnionTypeDefinition Description Name [Directive] (UnionMemberTypes []) + | EnumTypeDefinition Description Name [Directive] [EnumValueDefinition] + | InputObjectTypeDefinition + Description Name [Directive] [InputValueDefinition] + deriving (Eq, Show) + +-- | Extensions for custom, already defined types. +data TypeExtension + = ScalarTypeExtension Name (NonEmpty Directive) + | ObjectTypeFieldsDefinitionExtension + Name (ImplementsInterfaces []) [Directive] (NonEmpty FieldDefinition) + | ObjectTypeDirectivesExtension + Name (ImplementsInterfaces []) (NonEmpty Directive) + | ObjectTypeImplementsInterfacesExtension + Name (ImplementsInterfaces NonEmpty) + | InterfaceTypeFieldsDefinitionExtension + Name [Directive] (NonEmpty FieldDefinition) + | InterfaceTypeDirectivesExtension Name (NonEmpty Directive) + | UnionTypeUnionMemberTypesExtension + Name [Directive] (UnionMemberTypes NonEmpty) + | UnionTypeDirectivesExtension Name (NonEmpty Directive) + | EnumTypeEnumValuesDefinitionExtension + Name [Directive] (NonEmpty EnumValueDefinition) + | EnumTypeDirectivesExtension Name (NonEmpty Directive) + | InputObjectTypeInputFieldsDefinitionExtension + Name [Directive] (NonEmpty InputValueDefinition) + | InputObjectTypeDirectivesExtension Name (NonEmpty Directive) + deriving (Eq, Show) + +-- ** Objects + +-- | Defines a list of interfaces implemented by the given object type. +-- +-- @ +-- type Business implements NamedEntity & ValuedEntity { +-- name: String +-- } +-- @ +-- +-- Here the object type "Business" implements two interfaces: "NamedEntity" and +-- "ValuedEntity". +newtype ImplementsInterfaces t = ImplementsInterfaces (t NamedType) + +instance Foldable t => Eq (ImplementsInterfaces t) where + (ImplementsInterfaces xs) == (ImplementsInterfaces ys) + = toList xs == toList ys + +instance Foldable t => Show (ImplementsInterfaces t) where + show (ImplementsInterfaces interfaces) = Text.unpack + $ Text.append "implements" + $ Text.intercalate " & " + $ toList interfaces + +-- | Definition of a single field in a type. +-- +-- @ +-- type Person { +-- name: String +-- picture(width: Int, height: Int): Url +-- } +-- @ +-- +-- "name" and "picture", including their arguments and types, are field +-- definitions. +data FieldDefinition + = FieldDefinition Description Name ArgumentsDefinition Type [Directive] + deriving (Eq, Show) + +-- | A list of values passed to a field. +-- +-- @ +-- type Person { +-- name: String +-- picture(width: Int, height: Int): Url +-- } +-- @ +-- +-- "Person" has two fields, "name" and "picture". "name" doesn't have any +-- arguments, so 'ArgumentsDefinition' contains an empty list. "picture" +-- contains definitions for 2 arguments: "width" and "height". +newtype ArgumentsDefinition = ArgumentsDefinition [InputValueDefinition] + deriving (Eq, Show) + +instance Semigroup ArgumentsDefinition where + (ArgumentsDefinition xs) <> (ArgumentsDefinition ys) = + ArgumentsDefinition $ xs <> ys + +instance Monoid ArgumentsDefinition where + mempty = ArgumentsDefinition [] + +-- | Defines an input value. +-- +-- * Input values can define field arguments, see 'ArgumentsDefinition'. +-- * They can also be used as field definitions in an input type. +-- +-- @ +-- input Point2D { +-- x: Float +-- y: Float +-- } +-- @ +-- +-- The input type "Point2D" contains two value definitions: "x" and "y". +data InputValueDefinition + = InputValueDefinition Description Name Type (Maybe Value) [Directive] + deriving (Eq, Show) + +-- ** Unions + +-- | List of types forming a union. +-- +-- @ +-- union SearchResult = Person | Photo +-- @ +-- +-- "Person" and "Photo" are member types of the union "SearchResult". +newtype UnionMemberTypes t = UnionMemberTypes (t NamedType) + +instance Foldable t => Eq (UnionMemberTypes t) where + (UnionMemberTypes xs) == (UnionMemberTypes ys) = toList xs == toList ys + +instance Foldable t => Show (UnionMemberTypes t) where + show (UnionMemberTypes memberTypes) = Text.unpack + $ Text.intercalate " | " + $ toList memberTypes + +-- ** Enums + +-- | Single value in an enum definition. +-- +-- @ +-- enum Direction { +-- NORTH +-- EAST +-- SOUTH +-- WEST +-- } +-- @ +-- +-- "NORTH, "EAST", "SOUTH", and "WEST" are value definitions of an enum type +-- definition "Direction". +data EnumValueDefinition = EnumValueDefinition Description Name [Directive] + deriving (Eq, Show) diff --git a/src/Language/GraphQL/AST/Encoder.hs b/src/Language/GraphQL/AST/Encoder.hs index 508212a..69f5599 100644 --- a/src/Language/GraphQL/AST/Encoder.hs +++ b/src/Language/GraphQL/AST/Encoder.hs @@ -15,7 +15,6 @@ module Language.GraphQL.AST.Encoder import Data.Char (ord) import Data.Foldable (fold) -import Data.Monoid ((<>)) import qualified Data.List.NonEmpty as NonEmpty import Data.Text (Text) import qualified Data.Text as Text @@ -26,6 +25,7 @@ import qualified Data.Text.Lazy.Builder as Builder import Data.Text.Lazy.Builder.Int (decimal, hexadecimal) import Data.Text.Lazy.Builder.RealFloat (realFloat) import qualified Language.GraphQL.AST as Full +import Language.GraphQL.AST.Document -- | Instructs the encoder whether the GraphQL document should be minified or -- pretty printed. @@ -43,16 +43,18 @@ pretty = Pretty 0 minified :: Formatter minified = Minified --- | Converts a 'Full.Document' into a string. -document :: Formatter -> Full.Document -> Lazy.Text +-- | Converts a Document' into a string. +document :: Formatter -> Document -> Lazy.Text document formatter defs | Pretty _ <- formatter = Lazy.Text.intercalate "\n" encodeDocument | Minified <-formatter = Lazy.Text.snoc (mconcat encodeDocument) '\n' where - encodeDocument = NonEmpty.toList $ definition formatter <$> defs + encodeDocument = foldr executableDefinition [] defs + executableDefinition (ExecutableDefinition x) acc = definition formatter x : acc + executableDefinition _ acc = acc --- | Converts a 'Full.Definition' into a string. -definition :: Formatter -> Full.Definition -> Lazy.Text +-- | Converts a t'Full.ExecutableDefinition' into a string. +definition :: Formatter -> ExecutableDefinition -> Lazy.Text definition formatter x | Pretty _ <- formatter = Lazy.Text.snoc (encodeDefinition x) '\n' | Minified <- formatter = encodeDefinition x @@ -62,14 +64,16 @@ definition formatter x encodeDefinition (Full.DefinitionFragment fragment) = fragmentDefinition formatter fragment +-- | Converts a 'Full.OperationDefinition into a string. operationDefinition :: Formatter -> Full.OperationDefinition -> Lazy.Text -operationDefinition formatter (Full.OperationSelectionSet sels) +operationDefinition formatter (Full.SelectionSet sels) = selectionSet formatter sels operationDefinition formatter (Full.OperationDefinition Full.Query name vars dirs sels) = "query " <> node formatter name vars dirs sels operationDefinition formatter (Full.OperationDefinition Full.Mutation name vars dirs sels) = "mutation " <> node formatter name vars dirs sels +-- | Converts a Full.Query or Full.Mutation into a string. node :: Formatter -> Maybe Full.Name -> [Full.VariableDefinition] -> @@ -110,17 +114,21 @@ selectionSet formatter selectionSetOpt :: Formatter -> Full.SelectionSetOpt -> Lazy.Text selectionSetOpt formatter = bracesList formatter $ selection formatter +indentSymbol :: Lazy.Text +indentSymbol = " " + indent :: (Integral a) => a -> Lazy.Text -indent indentation = Lazy.Text.replicate (fromIntegral indentation) " " +indent indentation = Lazy.Text.replicate (fromIntegral indentation) indentSymbol selection :: Formatter -> Full.Selection -> Lazy.Text selection formatter = Lazy.Text.append indent' . encodeSelection where - encodeSelection (Full.SelectionField field') = field incrementIndent field' - encodeSelection (Full.SelectionInlineFragment fragment) = - inlineFragment incrementIndent fragment - encodeSelection (Full.SelectionFragmentSpread spread) = - fragmentSpread incrementIndent spread + encodeSelection (Full.Field alias name args directives' selections) = + field incrementIndent alias name args directives' selections + encodeSelection (Full.InlineFragment typeCondition directives' selections) = + inlineFragment incrementIndent typeCondition directives' selections + encodeSelection (Full.FragmentSpread name directives') = + fragmentSpread incrementIndent name directives' incrementIndent | Pretty indentation <- formatter = Pretty $ indentation + 1 | otherwise = Minified @@ -131,8 +139,15 @@ selection formatter = Lazy.Text.append indent' . encodeSelection colon :: Formatter -> Lazy.Text colon formatter = eitherFormat formatter ": " ":" -field :: Formatter -> Full.Field -> Lazy.Text -field formatter (Full.Field alias name args dirs set) +-- | Converts Full.Field into a string +field :: Formatter -> + Maybe Full.Name -> + Full.Name -> + [Full.Argument] -> + [Full.Directive] -> + [Full.Selection] -> + Lazy.Text +field formatter alias name args dirs set = optempty prependAlias (fold alias) <> Lazy.Text.fromStrict name <> optempty (arguments formatter) args @@ -154,13 +169,18 @@ argument formatter (Full.Argument name value') -- * Fragments -fragmentSpread :: Formatter -> Full.FragmentSpread -> Lazy.Text -fragmentSpread formatter (Full.FragmentSpread name ds) - = "..." <> Lazy.Text.fromStrict name <> optempty (directives formatter) ds +fragmentSpread :: Formatter -> Full.Name -> [Full.Directive] -> Lazy.Text +fragmentSpread formatter name directives' + = "..." <> Lazy.Text.fromStrict name + <> optempty (directives formatter) directives' -inlineFragment :: Formatter -> Full.InlineFragment -> Lazy.Text -inlineFragment formatter (Full.InlineFragment tc dirs sels) - = "... on " +inlineFragment :: + Formatter -> + Maybe Full.TypeCondition -> + [Full.Directive] -> + Full.SelectionSet -> + Lazy.Text +inlineFragment formatter tc dirs sels = "... on " <> Lazy.Text.fromStrict (fold tc) <> directives formatter dirs <> eitherFormat formatter " " mempty @@ -191,7 +211,7 @@ value _ (Full.Variable x) = variable x value _ (Full.Int x) = Builder.toLazyText $ decimal x value _ (Full.Float x) = Builder.toLazyText $ realFloat x value _ (Full.Boolean x) = booleanValue x -value _ Full.Null = mempty +value _ Full.Null = "null" value formatter (Full.String string) = stringValue formatter string value _ (Full.Enum x) = Lazy.Text.fromStrict x value formatter (Full.List x) = listValue formatter x @@ -201,26 +221,40 @@ booleanValue :: Bool -> Lazy.Text booleanValue True = "true" booleanValue False = "false" +quote :: Builder.Builder +quote = Builder.singleton '\"' + +oneLine :: Text -> Builder +oneLine string = quote <> Text.foldr (mappend . escape) quote string + stringValue :: Formatter -> Text -> Lazy.Text stringValue Minified string = Builder.toLazyText - $ quote <> Text.foldr (mappend . escape') quote string - where - quote = Builder.singleton '\"' - escape' '\n' = Builder.fromString "\\n" - escape' char = escape char -stringValue (Pretty indentation) string = byStringType $ Text.lines string - where - byStringType [] = "\"\"" - byStringType [line] = Builder.toLazyText - $ quote <> Text.foldr (mappend . escape) quote line - byStringType lines' = "\"\"\"\n" - <> Lazy.Text.unlines (transformLine <$> lines') - <> indent indentation - <> "\"\"\"" - transformLine = (indent (indentation + 1) <>) - . Lazy.Text.fromStrict - . Text.replace "\"\"\"" "\\\"\"\"" - quote = Builder.singleton '\"' + $ quote <> Text.foldr (mappend . escape) quote string +stringValue (Pretty indentation) string = + if hasEscaped string + then stringValue Minified string + else Builder.toLazyText $ encoded lines' + where + isWhiteSpace char = char == ' ' || char == '\t' + isNewline char = char == '\n' || char == '\r' + hasEscaped = Text.any (not . isAllowed) + isAllowed char = + char == '\t' || isNewline char || (char >= '\x0020' && char /= '\x007F') + + tripleQuote = Builder.fromText "\"\"\"" + start = tripleQuote <> Builder.singleton '\n' + end = Builder.fromLazyText (indent indentation) <> tripleQuote + + 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 escape :: Char -> Builder escape char' @@ -228,7 +262,9 @@ escape char' | char' == '\"' = Builder.fromString "\\\"" | char' == '\b' = Builder.fromString "\\b" | char' == '\f' = Builder.fromString "\\f" + | char' == '\n' = Builder.fromString "\\n" | char' == '\r' = Builder.fromString "\\r" + | char' == '\t' = Builder.fromString "\\t" | char' < '\x0010' = unicode "\\u000" char' | char' < '\x0020' = unicode "\\u00" char' | otherwise = Builder.singleton char' diff --git a/src/Language/GraphQL/AST/Lexer.hs b/src/Language/GraphQL/AST/Lexer.hs index f95070c..0ba55e3 100644 --- a/src/Language/GraphQL/AST/Lexer.hs +++ b/src/Language/GraphQL/AST/Lexer.hs @@ -15,6 +15,7 @@ module Language.GraphQL.AST.Lexer , dollar , comment , equals + , extend , integer , float , lexeme @@ -28,20 +29,16 @@ module Language.GraphQL.AST.Lexer , unicodeBOM ) where -import Control.Applicative ( Alternative(..) - , liftA2 - ) -import Data.Char ( chr - , digitToInt - , isAsciiLower - , isAsciiUpper - , ord - ) +import Control.Applicative (Alternative(..), liftA2) +import Data.Char (chr, digitToInt, isAsciiLower, isAsciiUpper, ord) import Data.Foldable (foldl') import Data.List (dropWhileEnd) +import qualified Data.List.NonEmpty as NonEmpty +import Data.List.NonEmpty (NonEmpty(..)) import Data.Proxy (Proxy(..)) import Data.Void (Void) import Text.Megaparsec ( Parsec + , (<?>) , between , chunk , chunkToTokens @@ -56,11 +53,9 @@ import Text.Megaparsec ( Parsec , takeWhile1P , try ) -import Text.Megaparsec.Char ( char - , digitChar - , space1 - ) +import Text.Megaparsec.Char (char, digitChar, space1) import qualified Text.Megaparsec.Char.Lexer as Lexer +import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy as TL @@ -97,8 +92,8 @@ dollar :: Parser T.Text dollar = symbol "$" -- | Parser for "@". -at :: Parser Char -at = char '@' +at :: Parser Text +at = symbol "@" -- | Parser for "&". amp :: Parser T.Text @@ -134,7 +129,7 @@ braces = between (symbol "{") (symbol "}") -- | Parser for strings. string :: Parser T.Text -string = between "\"" "\"" stringValue <* spaceConsumer +string = between "\"" "\"" stringValue <* spaceConsumer where stringValue = T.pack <$> many stringCharacter stringCharacter = satisfy isStringCharacter1 @@ -143,7 +138,7 @@ string = between "\"" "\"" stringValue <* spaceConsumer -- | Parser for block strings. blockString :: Parser T.Text -blockString = between "\"\"\"" "\"\"\"" stringValue <* spaceConsumer +blockString = between "\"\"\"" "\"\"\"" stringValue <* spaceConsumer where stringValue = do byLine <- sepBy (many blockStringCharacter) lineTerminator @@ -226,3 +221,16 @@ escapeSequence = do -- | Parser for the "Byte Order Mark". unicodeBOM :: Parser () unicodeBOM = optional (char '\xfeff') >> pure () + +-- | Parses "extend" followed by a 'symbol'. It is used by schema extensions. +extend :: forall a. Text -> String -> NonEmpty (Parser a) -> Parser a +extend token extensionLabel parsers + = foldr combine headParser (NonEmpty.tail parsers) + <?> extensionLabel + where + headParser = tryExtension $ NonEmpty.head parsers + combine current accumulated = accumulated <|> tryExtension current + tryExtension extensionParser = try + $ symbol "extend" + *> symbol token + *> extensionParser
\ No newline at end of file diff --git a/src/Language/GraphQL/AST/Parser.hs b/src/Language/GraphQL/AST/Parser.hs index 1505615..3449903 100644 --- a/src/Language/GraphQL/AST/Parser.hs +++ b/src/Language/GraphQL/AST/Parser.hs @@ -6,63 +6,358 @@ module Language.GraphQL.AST.Parser ( document ) where -import Control.Applicative ( Alternative(..) - , optional - ) +import Control.Applicative (Alternative(..), optional) +import Control.Applicative.Combinators (sepBy1) +import qualified Control.Applicative.Combinators.NonEmpty as NonEmpty import Data.List.NonEmpty (NonEmpty(..)) -import Language.GraphQL.AST +import Data.Text (Text) +import qualified Language.GraphQL.AST.DirectiveLocation as Directive +import Language.GraphQL.AST.DirectiveLocation + ( DirectiveLocation + , ExecutableDirectiveLocation + , TypeSystemDirectiveLocation + ) +import Language.GraphQL.AST.Document import Language.GraphQL.AST.Lexer -import Text.Megaparsec ( lookAhead - , option - , try - , (<?>) - ) +import Text.Megaparsec (lookAhead, option, try, (<?>)) -- | Parser for the GraphQL documents. document :: Parser Document -document = unicodeBOM >> spaceConsumer >> lexeme (manyNE definition) +document = unicodeBOM + >> spaceConsumer + >> lexeme (NonEmpty.some definition) definition :: Parser Definition -definition = DefinitionOperation <$> operationDefinition - <|> DefinitionFragment <$> fragmentDefinition - <?> "definition error!" +definition = ExecutableDefinition <$> executableDefinition + <|> TypeSystemDefinition <$> typeSystemDefinition + <|> TypeSystemExtension <$> typeSystemExtension + <?> "Definition" + +executableDefinition :: Parser ExecutableDefinition +executableDefinition = DefinitionOperation <$> operationDefinition + <|> DefinitionFragment <$> fragmentDefinition + <?> "ExecutableDefinition" + +typeSystemDefinition :: Parser TypeSystemDefinition +typeSystemDefinition = schemaDefinition + <|> TypeDefinition <$> typeDefinition + <|> directiveDefinition + <?> "TypeSystemDefinition" + +typeSystemExtension :: Parser TypeSystemExtension +typeSystemExtension = SchemaExtension <$> schemaExtension + <|> TypeExtension <$> typeExtension + <?> "TypeSystemExtension" + +directiveDefinition :: Parser TypeSystemDefinition +directiveDefinition = DirectiveDefinition + <$> description + <* symbol "directive" + <* at + <*> name + <*> argumentsDefinition + <* symbol "on" + <*> directiveLocations + <?> "DirectiveDefinition" + +directiveLocations :: Parser (NonEmpty DirectiveLocation) +directiveLocations = optional pipe + *> directiveLocation `NonEmpty.sepBy1` pipe + +directiveLocation :: Parser DirectiveLocation +directiveLocation + = Directive.ExecutableDirectiveLocation <$> executableDirectiveLocation + <|> Directive.TypeSystemDirectiveLocation <$> typeSystemDirectiveLocation + +executableDirectiveLocation :: Parser ExecutableDirectiveLocation +executableDirectiveLocation = Directive.Query <$ symbol "QUERY" + <|> Directive.Mutation <$ symbol "MUTATION" + <|> Directive.Subscription <$ symbol "SUBSCRIPTION" + <|> Directive.Field <$ symbol "FIELD" + <|> Directive.FragmentDefinition <$ "FRAGMENT_DEFINITION" + <|> Directive.FragmentSpread <$ "FRAGMENT_SPREAD" + <|> Directive.InlineFragment <$ "INLINE_FRAGMENT" + +typeSystemDirectiveLocation :: Parser TypeSystemDirectiveLocation +typeSystemDirectiveLocation = Directive.Schema <$ symbol "SCHEMA" + <|> Directive.Scalar <$ symbol "SCALAR" + <|> Directive.Object <$ symbol "OBJECT" + <|> Directive.FieldDefinition <$ symbol "FIELD_DEFINITION" + <|> Directive.ArgumentDefinition <$ symbol "ARGUMENT_DEFINITION" + <|> Directive.Interface <$ symbol "INTERFACE" + <|> Directive.Union <$ symbol "UNION" + <|> Directive.Enum <$ symbol "ENUM" + <|> 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 + <?> "TypeDefinition" + +typeExtension :: Parser TypeExtension +typeExtension = scalarTypeExtension + <|> objectTypeExtension + <|> interfaceTypeExtension + <|> unionTypeExtension + <|> enumTypeExtension + <|> inputObjectTypeExtension + <?> "TypeExtension" + +scalarTypeDefinition :: Parser TypeDefinition +scalarTypeDefinition = ScalarTypeDefinition + <$> description + <* symbol "scalar" + <*> name + <*> directives + <?> "ScalarTypeDefinition" + +scalarTypeExtension :: Parser TypeExtension +scalarTypeExtension = extend "scalar" "ScalarTypeExtension" + $ (ScalarTypeExtension <$> name <*> NonEmpty.some directive) :| [] + +objectTypeDefinition :: Parser TypeDefinition +objectTypeDefinition = ObjectTypeDefinition + <$> description + <* symbol "type" + <*> name + <*> option (ImplementsInterfaces []) (implementsInterfaces sepBy1) + <*> directives + <*> braces (many fieldDefinition) + <?> "ObjectTypeDefinition" + +objectTypeExtension :: Parser TypeExtension +objectTypeExtension = extend "type" "ObjectTypeExtension" + $ fieldsDefinitionExtension :| + [ directivesExtension + , implementsInterfacesExtension + ] + where + fieldsDefinitionExtension = ObjectTypeFieldsDefinitionExtension + <$> name + <*> option (ImplementsInterfaces []) (implementsInterfaces sepBy1) + <*> directives + <*> braces (NonEmpty.some fieldDefinition) + directivesExtension = ObjectTypeDirectivesExtension + <$> name + <*> option (ImplementsInterfaces []) (implementsInterfaces sepBy1) + <*> NonEmpty.some directive + implementsInterfacesExtension = ObjectTypeImplementsInterfacesExtension + <$> name + <*> implementsInterfaces NonEmpty.sepBy1 + +description :: Parser Description +description = Description + <$> optional (string <|> blockString) + <?> "Description" + +unionTypeDefinition :: Parser TypeDefinition +unionTypeDefinition = UnionTypeDefinition + <$> description + <* symbol "union" + <*> name + <*> directives + <*> option (UnionMemberTypes []) (unionMemberTypes sepBy1) + <?> "UnionTypeDefinition" + +unionTypeExtension :: Parser TypeExtension +unionTypeExtension = extend "union" "UnionTypeExtension" + $ unionMemberTypesExtension :| [directivesExtension] + where + unionMemberTypesExtension = UnionTypeUnionMemberTypesExtension + <$> name + <*> directives + <*> unionMemberTypes NonEmpty.sepBy1 + directivesExtension = UnionTypeDirectivesExtension + <$> name + <*> NonEmpty.some directive + +unionMemberTypes :: + Foldable t => + (Parser Text -> Parser Text -> Parser (t NamedType)) -> + Parser (UnionMemberTypes t) +unionMemberTypes sepBy' = UnionMemberTypes + <$ equals + <* optional pipe + <*> name `sepBy'` pipe + <?> "UnionMemberTypes" + +interfaceTypeDefinition :: Parser TypeDefinition +interfaceTypeDefinition = InterfaceTypeDefinition + <$> description + <* symbol "interface" + <*> name + <*> directives + <*> braces (many fieldDefinition) + <?> "InterfaceTypeDefinition" + +interfaceTypeExtension :: Parser TypeExtension +interfaceTypeExtension = extend "interface" "InterfaceTypeExtension" + $ fieldsDefinitionExtension :| [directivesExtension] + where + fieldsDefinitionExtension = InterfaceTypeFieldsDefinitionExtension + <$> name + <*> directives + <*> braces (NonEmpty.some fieldDefinition) + directivesExtension = InterfaceTypeDirectivesExtension + <$> name + <*> NonEmpty.some directive + +enumTypeDefinition :: Parser TypeDefinition +enumTypeDefinition = EnumTypeDefinition + <$> description + <* symbol "enum" + <*> name + <*> directives + <*> listOptIn braces enumValueDefinition + <?> "EnumTypeDefinition" + +enumTypeExtension :: Parser TypeExtension +enumTypeExtension = extend "enum" "EnumTypeExtension" + $ enumValuesDefinitionExtension :| [directivesExtension] + where + enumValuesDefinitionExtension = EnumTypeEnumValuesDefinitionExtension + <$> name + <*> directives + <*> braces (NonEmpty.some enumValueDefinition) + directivesExtension = EnumTypeDirectivesExtension + <$> name + <*> NonEmpty.some directive + +inputObjectTypeDefinition :: Parser TypeDefinition +inputObjectTypeDefinition = InputObjectTypeDefinition + <$> description + <* symbol "input" + <*> name + <*> directives + <*> listOptIn braces inputValueDefinition + <?> "InputObjectTypeDefinition" + +inputObjectTypeExtension :: Parser TypeExtension +inputObjectTypeExtension = extend "input" "InputObjectTypeExtension" + $ inputFieldsDefinitionExtension :| [directivesExtension] + where + inputFieldsDefinitionExtension = InputObjectTypeInputFieldsDefinitionExtension + <$> name + <*> directives + <*> braces (NonEmpty.some inputValueDefinition) + directivesExtension = InputObjectTypeDirectivesExtension + <$> name + <*> NonEmpty.some directive + +enumValueDefinition :: Parser EnumValueDefinition +enumValueDefinition = EnumValueDefinition + <$> description + <*> enumValue + <*> directives + <?> "EnumValueDefinition" + +implementsInterfaces :: + Foldable t => + (Parser Text -> Parser Text -> Parser (t NamedType)) -> + Parser (ImplementsInterfaces t) +implementsInterfaces sepBy' = ImplementsInterfaces + <$ symbol "implements" + <* optional amp + <*> name `sepBy'` amp + <?> "ImplementsInterfaces" + +inputValueDefinition :: Parser InputValueDefinition +inputValueDefinition = InputValueDefinition + <$> description + <*> name + <* colon + <*> type' + <*> defaultValue + <*> directives + <?> "InputValueDefinition" + +argumentsDefinition :: Parser ArgumentsDefinition +argumentsDefinition = ArgumentsDefinition + <$> listOptIn parens inputValueDefinition + <?> "ArgumentsDefinition" + +fieldDefinition :: Parser FieldDefinition +fieldDefinition = FieldDefinition + <$> description + <*> name + <*> argumentsDefinition + <* colon + <*> type' + <*> directives + <?> "FieldDefinition" + +schemaDefinition :: Parser TypeSystemDefinition +schemaDefinition = SchemaDefinition + <$ symbol "schema" + <*> directives + <*> operationTypeDefinitions + <?> "SchemaDefinition" + +operationTypeDefinitions :: Parser (NonEmpty OperationTypeDefinition) +operationTypeDefinitions = braces $ NonEmpty.some operationTypeDefinition + +schemaExtension :: Parser SchemaExtension +schemaExtension = extend "schema" "SchemaExtension" + $ schemaOperationExtension :| [directivesExtension] + where + directivesExtension = SchemaDirectivesExtension + <$> NonEmpty.some directive + schemaOperationExtension = SchemaOperationExtension + <$> directives + <*> operationTypeDefinitions + +operationTypeDefinition :: Parser OperationTypeDefinition +operationTypeDefinition = OperationTypeDefinition + <$> operationType <* colon + <*> name + <?> "OperationTypeDefinition" operationDefinition :: Parser OperationDefinition -operationDefinition = OperationSelectionSet <$> selectionSet - <|> OperationDefinition <$> operationType - <*> optional name - <*> opt variableDefinitions - <*> opt directives - <*> selectionSet - <?> "operationDefinition error" +operationDefinition = SelectionSet <$> selectionSet + <|> operationDefinition' + <?> "operationDefinition error" + where + operationDefinition' + = OperationDefinition <$> operationType + <*> optional name + <*> variableDefinitions + <*> directives + <*> selectionSet operationType :: Parser OperationType operationType = Query <$ symbol "query" <|> Mutation <$ symbol "mutation" - <?> "operationType error" + -- <?> Keep default error message -- * SelectionSet selectionSet :: Parser SelectionSet -selectionSet = braces $ manyNE selection +selectionSet = braces $ NonEmpty.some selection selectionSetOpt :: Parser SelectionSetOpt -selectionSetOpt = braces $ some selection +selectionSetOpt = listOptIn braces selection selection :: Parser Selection -selection = SelectionField <$> field - <|> try (SelectionFragmentSpread <$> fragmentSpread) - <|> SelectionInlineFragment <$> inlineFragment - <?> "selection error!" +selection = field + <|> try fragmentSpread + <|> inlineFragment + <?> "selection error!" -- * Field -field :: Parser Field -field = Field <$> optional alias - <*> name - <*> opt arguments - <*> opt directives - <*> opt selectionSetOpt +field :: Parser Selection +field = Field + <$> optional alias + <*> name + <*> arguments + <*> directives + <*> selectionSetOpt alias :: Parser Alias alias = try $ name <* colon @@ -70,30 +365,32 @@ alias = try $ name <* colon -- * Arguments arguments :: Parser [Argument] -arguments = parens $ some argument +arguments = listOptIn parens argument argument :: Parser Argument argument = Argument <$> name <* colon <*> value -- * Fragments -fragmentSpread :: Parser FragmentSpread -fragmentSpread = FragmentSpread <$ spread - <*> fragmentName - <*> opt directives +fragmentSpread :: Parser Selection +fragmentSpread = FragmentSpread + <$ spread + <*> fragmentName + <*> directives -inlineFragment :: Parser InlineFragment -inlineFragment = InlineFragment <$ spread - <*> optional typeCondition - <*> opt directives - <*> selectionSet +inlineFragment :: Parser Selection +inlineFragment = InlineFragment + <$ spread + <*> optional typeCondition + <*> directives + <*> selectionSet fragmentDefinition :: Parser FragmentDefinition fragmentDefinition = FragmentDefinition <$ symbol "fragment" <*> name <*> typeCondition - <*> opt directives + <*> directives <*> selectionSet fragmentName :: Parser Name @@ -121,68 +418,68 @@ value = Variable <$> variable booleanValue = True <$ symbol "true" <|> False <$ symbol "false" - enumValue :: Parser Name - enumValue = but (symbol "true") *> but (symbol "false") *> but (symbol "null") *> name - listValue :: Parser [Value] listValue = brackets $ some value objectValue :: Parser [ObjectField] objectValue = braces $ some objectField +enumValue :: Parser Name +enumValue = but (symbol "true") *> but (symbol "false") *> but (symbol "null") *> name + objectField :: Parser ObjectField -objectField = ObjectField <$> name <* symbol ":" <*> value +objectField = ObjectField <$> name <* colon <*> value -- * Variables variableDefinitions :: Parser [VariableDefinition] -variableDefinitions = parens $ some variableDefinition +variableDefinitions = listOptIn parens variableDefinition variableDefinition :: Parser VariableDefinition -variableDefinition = VariableDefinition <$> variable - <* colon - <*> type_ - <*> optional defaultValue +variableDefinition = VariableDefinition + <$> variable + <* colon + <*> type' + <*> defaultValue + <?> "VariableDefinition" + variable :: Parser Name variable = dollar *> name -defaultValue :: Parser Value -defaultValue = equals *> value +defaultValue :: Parser (Maybe Value) +defaultValue = optional (equals *> value) <?> "DefaultValue" -- * Input Types -type_ :: Parser Type -type_ = try (TypeNonNull <$> nonNullType) - <|> TypeList <$> brackets type_ +type' :: Parser Type +type' = try (TypeNonNull <$> nonNullType) + <|> TypeList <$> brackets type' <|> TypeNamed <$> name - <?> "type_ error!" + <?> "Type" nonNullType :: Parser NonNullType nonNullType = NonNullTypeNamed <$> name <* bang - <|> NonNullTypeList <$> brackets type_ <* bang + <|> NonNullTypeList <$> brackets type' <* bang <?> "nonNullType error!" -- * Directives directives :: Parser [Directive] -directives = some directive +directives = many directive directive :: Parser Directive directive = Directive - <$ at - <*> name - <*> opt arguments + <$ at + <*> name + <*> arguments -- * Internal -opt :: Monoid a => Parser a -> Parser a -opt = option mempty +listOptIn :: (Parser [a] -> Parser [a]) -> Parser a -> Parser [a] +listOptIn surround = option [] . surround . some -- Hack to reverse parser success but :: Parser a -> Parser () but pn = False <$ lookAhead pn <|> pure True >>= \case False -> empty True -> pure () - -manyNE :: Alternative f => f a -> f (NonEmpty a) -manyNE p = (:|) <$> p <*> many p |