From 73fc334bf8d7bd6d8b83143995844ca0968ceeda Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Sun, 3 Nov 2019 10:42:10 +0100 Subject: Move related modules to Language.GraphQL.AST Fixes #18. - `Language.GraphQL.Encoder` moved to `Language.GraphQL.AST.Encoder`. - `Language.GraphQL.Parser` moved to `Language.GraphQL.AST.Parser`. - `Language.GraphQL.Lexer` moved to `Language.GraphQL.AST.Lexer`. - All `Language.GraphQL.AST.Value` data constructor prefixes were removed. The module should be imported qualified. - All `Language.GraphQL.AST.Core.Value` data constructor prefixes were removed. The module should be imported qualified. - `Language.GraphQL.AST.Transform` is now isn't exposed publically anymore. --- src/Language/GraphQL.hs | 2 +- src/Language/GraphQL/AST.hs | 77 ++++++++-- src/Language/GraphQL/AST/Core.hs | 93 +++--------- src/Language/GraphQL/AST/Encoder.hs | 277 ++++++++++++++++++++++++++++++++++ src/Language/GraphQL/AST/Lexer.hs | 228 ++++++++++++++++++++++++++++ src/Language/GraphQL/AST/Parser.hs | 188 +++++++++++++++++++++++ src/Language/GraphQL/AST/Transform.hs | 30 ++-- src/Language/GraphQL/Encoder.hs | 277 ---------------------------------- src/Language/GraphQL/Lexer.hs | 228 ---------------------------- src/Language/GraphQL/Parser.hs | 188 ----------------------- src/Language/GraphQL/Schema.hs | 20 +-- src/Language/GraphQL/Type.hs | 6 +- 12 files changed, 802 insertions(+), 812 deletions(-) create mode 100644 src/Language/GraphQL/AST/Encoder.hs create mode 100644 src/Language/GraphQL/AST/Lexer.hs create mode 100644 src/Language/GraphQL/AST/Parser.hs delete mode 100644 src/Language/GraphQL/Encoder.hs delete mode 100644 src/Language/GraphQL/Lexer.hs delete mode 100644 src/Language/GraphQL/Parser.hs (limited to 'src/Language') diff --git a/src/Language/GraphQL.hs b/src/Language/GraphQL.hs index c33eb95..afce8aa 100644 --- a/src/Language/GraphQL.hs +++ b/src/Language/GraphQL.hs @@ -10,7 +10,7 @@ import Data.List.NonEmpty (NonEmpty) import qualified Data.Text as T import Language.GraphQL.Error import Language.GraphQL.Execute -import Language.GraphQL.Parser +import Language.GraphQL.AST.Parser import qualified Language.GraphQL.Schema as Schema import Text.Megaparsec (parse) diff --git a/src/Language/GraphQL/AST.hs b/src/Language/GraphQL/AST.hs index 29d7d80..b2feb4d 100644 --- a/src/Language/GraphQL/AST.hs +++ b/src/Language/GraphQL/AST.hs @@ -29,16 +29,15 @@ module Language.GraphQL.AST import Data.Int (Int32) import Data.List.NonEmpty (NonEmpty) import Data.Text (Text) -import Language.GraphQL.AST.Core ( Alias - , Name - , TypeCondition - ) -- * Document -- | GraphQL document. type Document = NonEmpty Definition +-- | Name +type Name = Text + -- | Directive. data Directive = Directive Name [Argument] deriving (Eq, Show) @@ -82,12 +81,56 @@ data Selection -- * Field --- | GraphQL field. +-- | Single GraphQL field. +-- +-- The only required property of a field is its name. Optionally it can also +-- have an alias, arguments or a list of subfields. +-- +-- Given the following query: +-- +-- @ +-- { +-- zuck: user(id: 4) { +-- id +-- name +-- } +-- } +-- @ +-- +-- * "user", "id" and "name" are field names. +-- * "user" has two subfields, "id" and "name". +-- * "zuck" is an alias for "user". "id" and "name" have no aliases. +-- * "id: 4" is an argument for "name". "id" and "name don't have any +-- arguments. data Field = Field (Maybe Alias) Name [Argument] [Directive] SelectionSetOpt deriving (Eq, Show) --- | Argument. +-- | 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 + +-- | 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) -- * Fragments @@ -107,15 +150,15 @@ data FragmentDefinition -- * Inputs -- | Input value. -data Value = ValueVariable Name - | ValueInt Int32 - | ValueFloat Double - | ValueString Text - | ValueBoolean Bool - | ValueNull - | ValueEnum Name - | ValueList [Value] - | ValueObject [ObjectField] +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. @@ -127,13 +170,15 @@ data ObjectField = ObjectField Name Value deriving (Eq, Show) data VariableDefinition = VariableDefinition Name Type (Maybe Value) deriving (Eq, Show) +-- | Type condition. +type TypeCondition = Name + -- | Type representation. data Type = TypeNamed Name | TypeList Type | TypeNonNull NonNullType deriving (Eq, Show) - -- | Helper type to represent Non-Null types and lists of such types. data NonNullType = NonNullTypeNamed Name | NonNullTypeList Type diff --git a/src/Language/GraphQL/AST/Core.hs b/src/Language/GraphQL/AST/Core.hs index a2a53be..2cdb122 100644 --- a/src/Language/GraphQL/AST/Core.hs +++ b/src/Language/GraphQL/AST/Core.hs @@ -6,7 +6,6 @@ module Language.GraphQL.AST.Core , Field(..) , Fragment(..) , Name - , ObjectField(..) , Operation(..) , Selection(..) , TypeCondition @@ -14,12 +13,11 @@ module Language.GraphQL.AST.Core ) where import Data.Int (Int32) +import Data.HashMap.Strict (HashMap) import Data.List.NonEmpty (NonEmpty) -import Data.String +import Data.String (IsString(..)) import Data.Text (Text) - --- | Name -type Name = Text +import Language.GraphQL.AST (Alias, Name, TypeCondition) -- | GraphQL document is a non-empty list of operations. type Document = NonEmpty Operation @@ -32,80 +30,12 @@ data Operation | Mutation (Maybe Text) (NonEmpty Selection) deriving (Eq, Show) --- | A single GraphQL field. --- --- Only required property of a field, is its name. Optionally it can also have --- an alias, arguments or a list of subfields. --- --- Given the following query: --- --- @ --- { --- zuck: user(id: 4) { --- id --- name --- } --- } --- @ --- --- * "user", "id" and "name" are field names. --- * "user" has two subfields, "id" and "name". --- * "zuck" is an alias for "user". "id" and "name" have no aliases. --- * "id: 4" is an argument for "name". "id" and "name don't have any --- arguments. +-- | Single GraphQL field. data Field = Field (Maybe Alias) Name [Argument] [Selection] deriving (Eq, Show) --- | 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 - -- | 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) --- | Represents accordingly typed GraphQL values. -data Value - = ValueInt Int32 - -- GraphQL Float is double precision - | ValueFloat Double - | ValueString Text - | ValueBoolean Bool - | ValueNull - | ValueEnum Name - | ValueList [Value] - | ValueObject [ObjectField] - deriving (Eq, Show) - -instance IsString Value where - fromString = ValueString . fromString - --- | Key-value pair. --- --- A list of 'ObjectField's represents a GraphQL object type. -data ObjectField = ObjectField Name Value deriving (Eq, Show) - --- | Type condition. -type TypeCondition = Name - -- | Represents fragments and inline fragments. data Fragment = Fragment TypeCondition (NonEmpty Selection) @@ -116,3 +46,18 @@ data Selection = SelectionFragment Fragment | SelectionField Field deriving (Eq, Show) + +-- | Represents accordingly typed GraphQL values. +data Value + = Int Int32 + | Float Double -- ^ GraphQL Float is double precision + | String Text + | Boolean Bool + | Null + | Enum Name + | List [Value] + | Object (HashMap Name Value) + deriving (Eq, Show) + +instance IsString Value where + fromString = String . fromString diff --git a/src/Language/GraphQL/AST/Encoder.hs b/src/Language/GraphQL/AST/Encoder.hs new file mode 100644 index 0000000..a8f6ca4 --- /dev/null +++ b/src/Language/GraphQL/AST/Encoder.hs @@ -0,0 +1,277 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ExplicitForAll #-} + +-- | This module defines a minifier and a printer for the @GraphQL@ language. +module Language.GraphQL.AST.Encoder + ( Formatter + , definition + , directive + , document + , minified + , pretty + , type' + , value + ) where + +import Data.Foldable (fold) +import Data.Monoid ((<>)) +import qualified Data.List.NonEmpty as NonEmpty (toList) +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as Text.Lazy +import Data.Text.Lazy.Builder (toLazyText) +import Data.Text.Lazy.Builder.Int (decimal) +import Data.Text.Lazy.Builder.RealFloat (realFloat) +import qualified Language.GraphQL.AST as Full + +-- | Instructs the encoder whether a GraphQL should be minified or pretty +-- printed. +-- +-- Use 'pretty' and 'minified' to construct the formatter. +data Formatter + = Minified + | Pretty Word + +-- | Constructs a formatter for pretty printing. +pretty :: Formatter +pretty = Pretty 0 + +-- | Constructs a formatter for minifying. +minified :: Formatter +minified = Minified + +-- | Converts a 'Document' into a string. +document :: Formatter -> Full.Document -> Text +document formatter defs + | Pretty _ <- formatter = Text.Lazy.intercalate "\n" encodeDocument + | Minified <-formatter = Text.Lazy.snoc (mconcat encodeDocument) '\n' + where + encodeDocument = NonEmpty.toList $ definition formatter <$> defs + +-- | Converts a 'Definition' into a string. +definition :: Formatter -> Full.Definition -> Text +definition formatter x + | Pretty _ <- formatter = Text.Lazy.snoc (encodeDefinition x) '\n' + | Minified <- formatter = encodeDefinition x + where + encodeDefinition (Full.DefinitionOperation operation) + = operationDefinition formatter operation + encodeDefinition (Full.DefinitionFragment fragment) + = fragmentDefinition formatter fragment + +operationDefinition :: Formatter -> Full.OperationDefinition -> Text +operationDefinition formatter (Full.OperationSelectionSet 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 + +node :: Formatter + -> Maybe Full.Name + -> [Full.VariableDefinition] + -> [Full.Directive] + -> Full.SelectionSet + -> Text +node formatter name vars dirs sels + = Text.Lazy.fromStrict (fold name) + <> optempty (variableDefinitions formatter) vars + <> optempty (directives formatter) dirs + <> eitherFormat formatter " " mempty + <> selectionSet formatter sels + +variableDefinitions :: Formatter -> [Full.VariableDefinition] -> Text +variableDefinitions formatter + = parensCommas formatter $ variableDefinition formatter + +variableDefinition :: Formatter -> Full.VariableDefinition -> Text +variableDefinition formatter (Full.VariableDefinition var ty dv) + = variable var + <> eitherFormat formatter ": " ":" + <> type' ty + <> maybe mempty (defaultValue formatter) dv + +defaultValue :: Formatter -> Full.Value -> Text +defaultValue formatter val + = eitherFormat formatter " = " "=" + <> value formatter val + +variable :: Full.Name -> Text +variable var = "$" <> Text.Lazy.fromStrict var + +selectionSet :: Formatter -> Full.SelectionSet -> Text +selectionSet formatter + = bracesList formatter (selection formatter) + . NonEmpty.toList + +selectionSetOpt :: Formatter -> Full.SelectionSetOpt -> Text +selectionSetOpt formatter = bracesList formatter $ selection formatter + +selection :: Formatter -> Full.Selection -> Text +selection formatter = Text.Lazy.append indent . f + where + f (Full.SelectionField x) = field incrementIndent x + f (Full.SelectionInlineFragment x) = inlineFragment incrementIndent x + f (Full.SelectionFragmentSpread x) = fragmentSpread incrementIndent x + incrementIndent + | Pretty n <- formatter = Pretty $ n + 1 + | otherwise = Minified + indent + | Pretty n <- formatter = Text.Lazy.replicate (fromIntegral $ n + 1) " " + | otherwise = mempty + +field :: Formatter -> Full.Field -> Text +field formatter (Full.Field alias name args dirs selso) + = optempty (`Text.Lazy.append` colon) (Text.Lazy.fromStrict $ fold alias) + <> Text.Lazy.fromStrict name + <> optempty (arguments formatter) args + <> optempty (directives formatter) dirs + <> selectionSetOpt' + where + colon = eitherFormat formatter ": " ":" + selectionSetOpt' + | null selso = mempty + | otherwise = eitherFormat formatter " " mempty <> selectionSetOpt formatter selso + +arguments :: Formatter -> [Full.Argument] -> Text +arguments formatter = parensCommas formatter $ argument formatter + +argument :: Formatter -> Full.Argument -> Text +argument formatter (Full.Argument name v) + = Text.Lazy.fromStrict name + <> eitherFormat formatter ": " ":" + <> value formatter v + +-- * Fragments + +fragmentSpread :: Formatter -> Full.FragmentSpread -> Text +fragmentSpread formatter (Full.FragmentSpread name ds) + = "..." <> Text.Lazy.fromStrict name <> optempty (directives formatter) ds + +inlineFragment :: Formatter -> Full.InlineFragment -> Text +inlineFragment formatter (Full.InlineFragment tc dirs sels) + = "... on " + <> Text.Lazy.fromStrict (fold tc) + <> directives formatter dirs + <> eitherFormat formatter " " mempty + <> selectionSet formatter sels + +fragmentDefinition :: Formatter -> Full.FragmentDefinition -> Text +fragmentDefinition formatter (Full.FragmentDefinition name tc dirs sels) + = "fragment " <> Text.Lazy.fromStrict name + <> " on " <> Text.Lazy.fromStrict tc + <> optempty (directives formatter) dirs + <> eitherFormat formatter " " mempty + <> selectionSet formatter sels + +-- * Miscellaneous + +-- | Converts a 'Directive' into a string. +directive :: Formatter -> Full.Directive -> Text +directive formatter (Full.Directive name args) + = "@" <> Text.Lazy.fromStrict name <> optempty (arguments formatter) args + +directives :: Formatter -> [Full.Directive] -> Text +directives formatter@(Pretty _) = Text.Lazy.cons ' ' . spaces (directive formatter) +directives Minified = spaces (directive Minified) + +-- | Converts a 'Value' into a string. +value :: Formatter -> Full.Value -> Text +value _ (Full.Variable x) = variable x +value _ (Full.Int x) = toLazyText $ decimal x +value _ (Full.Float x) = toLazyText $ realFloat x +value _ (Full.Boolean x) = booleanValue x +value _ Full.Null = mempty +value _ (Full.String x) = stringValue $ Text.Lazy.fromStrict x +value _ (Full.Enum x) = Text.Lazy.fromStrict x +value formatter (Full.List x) = listValue formatter x +value formatter (Full.Object x) = objectValue formatter x + +booleanValue :: Bool -> Text +booleanValue True = "true" +booleanValue False = "false" + +stringValue :: Text -> Text +stringValue + = quotes + . Text.Lazy.replace "\"" "\\\"" + . Text.Lazy.replace "\\" "\\\\" + +listValue :: Formatter -> [Full.Value] -> Text +listValue formatter = bracketsCommas formatter $ value formatter + +objectValue :: Formatter -> [Full.ObjectField] -> Text +objectValue formatter = intercalate $ objectField formatter + where + intercalate f + = braces + . Text.Lazy.intercalate (eitherFormat formatter ", " ",") + . fmap f + + +objectField :: Formatter -> Full.ObjectField -> Text +objectField formatter (Full.ObjectField name v) + = Text.Lazy.fromStrict name <> colon <> value formatter v + where + colon + | Pretty _ <- formatter = ": " + | Minified <- formatter = ":" + +-- | Converts a 'Type' a type into a string. +type' :: Full.Type -> Text +type' (Full.TypeNamed x) = Text.Lazy.fromStrict x +type' (Full.TypeList x) = listType x +type' (Full.TypeNonNull x) = nonNullType x + +listType :: Full.Type -> Text +listType x = brackets (type' x) + +nonNullType :: Full.NonNullType -> Text +nonNullType (Full.NonNullTypeNamed x) = Text.Lazy.fromStrict x <> "!" +nonNullType (Full.NonNullTypeList x) = listType x <> "!" + +-- * Internal + +between :: Char -> Char -> Text -> Text +between open close = Text.Lazy.cons open . (`Text.Lazy.snoc` close) + +parens :: Text -> Text +parens = between '(' ')' + +brackets :: Text -> Text +brackets = between '[' ']' + +braces :: Text -> Text +braces = between '{' '}' + +quotes :: Text -> Text +quotes = between '"' '"' + +spaces :: forall a. (a -> Text) -> [a] -> Text +spaces f = Text.Lazy.intercalate "\SP" . fmap f + +parensCommas :: forall a. Formatter -> (a -> Text) -> [a] -> Text +parensCommas formatter f + = parens + . Text.Lazy.intercalate (eitherFormat formatter ", " ",") + . fmap f + +bracketsCommas :: Formatter -> (a -> Text) -> [a] -> Text +bracketsCommas formatter f + = brackets + . Text.Lazy.intercalate (eitherFormat formatter ", " ",") + . fmap f + +bracesList :: forall a. Formatter -> (a -> Text) -> [a] -> Text +bracesList (Pretty intendation) f xs + = Text.Lazy.snoc (Text.Lazy.intercalate "\n" content) '\n' + <> (Text.Lazy.snoc $ Text.Lazy.replicate (fromIntegral intendation) " ") '}' + where + content = "{" : fmap f xs +bracesList Minified f xs = braces $ Text.Lazy.intercalate "," $ fmap f xs + +optempty :: (Eq a, Monoid a, Monoid b) => (a -> b) -> a -> b +optempty f xs = if xs == mempty then mempty else f xs + +eitherFormat :: forall a. Formatter -> a -> a -> a +eitherFormat (Pretty _) x _ = x +eitherFormat Minified _ x = x diff --git a/src/Language/GraphQL/AST/Lexer.hs b/src/Language/GraphQL/AST/Lexer.hs new file mode 100644 index 0000000..97a334c --- /dev/null +++ b/src/Language/GraphQL/AST/Lexer.hs @@ -0,0 +1,228 @@ +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | This module defines a bunch of small parsers used to parse individual +-- lexemes. +module Language.GraphQL.AST.Lexer + ( Parser + , amp + , at + , bang + , blockString + , braces + , brackets + , colon + , dollar + , comment + , equals + , integer + , float + , lexeme + , name + , parens + , pipe + , spaceConsumer + , spread + , string + , symbol + , unicodeBOM + ) where + +import Control.Applicative ( Alternative(..) + , liftA2 + ) +import Data.Char ( chr + , digitToInt + , isAsciiLower + , isAsciiUpper + , ord + ) +import Data.Foldable (foldl') +import Data.List (dropWhileEnd) +import Data.Proxy (Proxy(..)) +import Data.Void (Void) +import Text.Megaparsec ( Parsec + , between + , chunk + , chunkToTokens + , notFollowedBy + , oneOf + , option + , optional + , satisfy + , sepBy + , skipSome + , takeP + , takeWhile1P + , try + ) +import Text.Megaparsec.Char ( char + , digitChar + , space1 + ) +import qualified Text.Megaparsec.Char.Lexer as Lexer +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL + +-- | Standard parser. +-- Accepts the type of the parsed token. +type Parser = Parsec Void T.Text + +ignoredCharacters :: Parser () +ignoredCharacters = space1 <|> skipSome (char ',') + +-- | Parser that skips comments and meaningless characters, whitespaces and +-- commas. +spaceConsumer :: Parser () +spaceConsumer = Lexer.space ignoredCharacters comment empty + +-- | Parser for comments. +comment :: Parser () +comment = Lexer.skipLineComment "#" + +-- | Lexeme definition which ignores whitespaces and commas. +lexeme :: forall a. Parser a -> Parser a +lexeme = Lexer.lexeme spaceConsumer + +-- | Symbol definition which ignores whitespaces and commas. +symbol :: T.Text -> Parser T.Text +symbol = Lexer.symbol spaceConsumer + +-- | Parser for "!". +bang :: Parser Char +bang = char '!' + +-- | Parser for "$". +dollar :: Parser Char +dollar = char '$' + +-- | Parser for "@". +at :: Parser Char +at = char '@' + +-- | Parser for "&". +amp :: Parser T.Text +amp = symbol "&" + +-- | Parser for ":". +colon :: Parser T.Text +colon = symbol ":" + +-- | Parser for "=". +equals :: Parser T.Text +equals = symbol "=" + +-- | Parser for the spread operator (...). +spread :: Parser T.Text +spread = symbol "..." + +-- | Parser for "|". +pipe :: Parser T.Text +pipe = symbol "|" + +-- | Parser for an expression between "(" and ")". +parens :: forall a. Parser a -> Parser a +parens = between (symbol "(") (symbol ")") + +-- | Parser for an expression between "[" and "]". +brackets :: forall a. Parser a -> Parser a +brackets = between (symbol "[") (symbol "]") + +-- | Parser for an expression between "{" and "}". +braces :: forall a. Parser a -> Parser a +braces = between (symbol "{") (symbol "}") + +-- | Parser for strings. +string :: Parser T.Text +string = between "\"" "\"" stringValue + where + stringValue = T.pack <$> many stringCharacter + stringCharacter = satisfy isStringCharacter1 + <|> escapeSequence + isStringCharacter1 = liftA2 (&&) isSourceCharacter isChunkDelimiter + +-- | Parser for block strings. +blockString :: Parser T.Text +blockString = between "\"\"\"" "\"\"\"" stringValue + where + stringValue = do + byLine <- sepBy (many blockStringCharacter) lineTerminator + let indentSize = foldr countIndent 0 $ tail byLine + withoutIndent = head byLine : (removeIndent indentSize <$> tail byLine) + withoutEmptyLines = liftA2 (.) dropWhile dropWhileEnd removeEmptyLine withoutIndent + + return $ T.intercalate "\n" $ T.concat <$> withoutEmptyLines + removeEmptyLine [] = True + removeEmptyLine [x] = T.null x || isWhiteSpace (T.head x) + removeEmptyLine _ = False + blockStringCharacter + = takeWhile1P Nothing isWhiteSpace + <|> takeWhile1P Nothing isBlockStringCharacter1 + <|> escapeTripleQuote + <|> try (chunk "\"" <* notFollowedBy (chunk "\"\"")) + escapeTripleQuote = chunk "\\" >>= flip option (chunk "\"\"") + isBlockStringCharacter1 = liftA2 (&&) isSourceCharacter isChunkDelimiter + countIndent [] acc = acc + countIndent (x:_) acc + | T.null x = acc + | not (isWhiteSpace $ T.head x) = acc + | acc == 0 = T.length x + | otherwise = min acc $ T.length x + removeIndent _ [] = [] + removeIndent n (x:chunks) = T.drop n x : chunks + +-- | Parser for integers. +integer :: Integral a => Parser a +integer = Lexer.signed (pure ()) $ lexeme Lexer.decimal + +-- | Parser for floating-point numbers. +float :: Parser Double +float = Lexer.signed (pure ()) $ lexeme Lexer.float + +-- | Parser for names (/[_A-Za-z][_0-9A-Za-z]*/). +name :: Parser T.Text +name = do + firstLetter <- nameFirstLetter + rest <- many $ nameFirstLetter <|> digitChar + _ <- spaceConsumer + return $ TL.toStrict $ TL.cons firstLetter $ TL.pack rest + where + nameFirstLetter = satisfy isAsciiUpper <|> satisfy isAsciiLower <|> char '_' + +isChunkDelimiter :: Char -> Bool +isChunkDelimiter = flip notElem ['"', '\\', '\n', '\r'] + +isWhiteSpace :: Char -> Bool +isWhiteSpace = liftA2 (||) (== ' ') (== '\t') + +lineTerminator :: Parser T.Text +lineTerminator = chunk "\r\n" <|> chunk "\n" <|> chunk "\r" + +isSourceCharacter :: Char -> Bool +isSourceCharacter = isSourceCharacter' . ord + where + isSourceCharacter' code = code >= 0x0020 + || code == 0x0009 + || code == 0x000a + || code == 0x000d + +escapeSequence :: Parser Char +escapeSequence = do + _ <- char '\\' + escaped <- oneOf ['"', '\\', '/', 'b', 'f', 'n', 'r', 't', 'u'] + case escaped of + 'b' -> return '\b' + 'f' -> return '\f' + 'n' -> return '\n' + 'r' -> return '\r' + 't' -> return '\t' + 'u' -> chr . foldl' step 0 + . chunkToTokens (Proxy :: Proxy T.Text) + <$> takeP Nothing 4 + _ -> return escaped + where + step accumulator = (accumulator * 16 +) . digitToInt + +-- | Parser for the "Byte Order Mark". +unicodeBOM :: Parser () +unicodeBOM = optional (char '\xfeff') >> pure () diff --git a/src/Language/GraphQL/AST/Parser.hs b/src/Language/GraphQL/AST/Parser.hs new file mode 100644 index 0000000..a5b6681 --- /dev/null +++ b/src/Language/GraphQL/AST/Parser.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | @GraphQL@ document parser. +module Language.GraphQL.AST.Parser + ( document + ) where + +import Control.Applicative ( Alternative(..) + , optional + ) +import Data.List.NonEmpty (NonEmpty(..)) +import Language.GraphQL.AST +import Language.GraphQL.AST.Lexer +import Text.Megaparsec ( lookAhead + , option + , try + , () + ) + +-- | Parser for the GraphQL documents. +document :: Parser Document +document = unicodeBOM >> spaceConsumer >> lexeme (manyNE definition) + +definition :: Parser Definition +definition = DefinitionOperation <$> operationDefinition + <|> DefinitionFragment <$> fragmentDefinition + "definition error!" + +operationDefinition :: Parser OperationDefinition +operationDefinition = OperationSelectionSet <$> selectionSet + <|> OperationDefinition <$> operationType + <*> optional name + <*> opt variableDefinitions + <*> opt directives + <*> selectionSet + "operationDefinition error" + +operationType :: Parser OperationType +operationType = Query <$ symbol "query" + <|> Mutation <$ symbol "mutation" + "operationType error" + +-- * SelectionSet + +selectionSet :: Parser SelectionSet +selectionSet = braces $ manyNE selection + +selectionSetOpt :: Parser SelectionSetOpt +selectionSetOpt = braces $ some selection + +selection :: Parser Selection +selection = SelectionField <$> field + <|> try (SelectionFragmentSpread <$> fragmentSpread) + <|> SelectionInlineFragment <$> inlineFragment + "selection error!" + +-- * Field + +field :: Parser Field +field = Field <$> optional alias + <*> name + <*> opt arguments + <*> opt directives + <*> opt selectionSetOpt + +alias :: Parser Alias +alias = try $ name <* colon + +-- * Arguments + +arguments :: Parser [Argument] +arguments = parens $ some argument + +argument :: Parser Argument +argument = Argument <$> name <* colon <*> value + +-- * Fragments + +fragmentSpread :: Parser FragmentSpread +fragmentSpread = FragmentSpread <$ spread + <*> fragmentName + <*> opt directives + +inlineFragment :: Parser InlineFragment +inlineFragment = InlineFragment <$ spread + <*> optional typeCondition + <*> opt directives + <*> selectionSet + +fragmentDefinition :: Parser FragmentDefinition +fragmentDefinition = FragmentDefinition + <$ symbol "fragment" + <*> name + <*> typeCondition + <*> opt directives + <*> selectionSet + +fragmentName :: Parser Name +fragmentName = but (symbol "on") *> name + +typeCondition :: Parser TypeCondition +typeCondition = symbol "on" *> name + +-- * Input Values + +value :: Parser Value +value = Variable <$> variable + <|> Float <$> try float + <|> Int <$> integer + <|> Boolean <$> booleanValue + <|> Null <$ symbol "null" + <|> String <$> blockString + <|> String <$> string + <|> Enum <$> try enumValue + <|> List <$> listValue + <|> Object <$> objectValue + "value error!" + where + booleanValue :: Parser Bool + 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 + +objectField :: Parser ObjectField +objectField = ObjectField <$> name <* symbol ":" <*> value + +-- * Variables + +variableDefinitions :: Parser [VariableDefinition] +variableDefinitions = parens $ some variableDefinition + +variableDefinition :: Parser VariableDefinition +variableDefinition = VariableDefinition <$> variable + <* colon + <*> type_ + <*> optional defaultValue +variable :: Parser Name +variable = dollar *> name + +defaultValue :: Parser Value +defaultValue = equals *> value + +-- * Input Types + +type_ :: Parser Type +type_ = try (TypeNamed <$> name <* but "!") + <|> TypeList <$> brackets type_ + <|> TypeNonNull <$> nonNullType + "type_ error!" + +nonNullType :: Parser NonNullType +nonNullType = NonNullTypeNamed <$> name <* bang + <|> NonNullTypeList <$> brackets type_ <* bang + "nonNullType error!" + +-- * Directives + +directives :: Parser [Directive] +directives = some directive + +directive :: Parser Directive +directive = Directive + <$ at + <*> name + <*> opt arguments + +-- * Internal + +opt :: Monoid a => Parser a -> Parser a +opt = option mempty + +-- 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 diff --git a/src/Language/GraphQL/AST/Transform.hs b/src/Language/GraphQL/AST/Transform.hs index 107e1c6..ea90bab 100644 --- a/src/Language/GraphQL/AST/Transform.hs +++ b/src/Language/GraphQL/AST/Transform.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TupleSections #-} + -- | After the document is parsed, before getting executed the AST is -- transformed into a similar, simpler AST. This module is responsible for -- this transformation. @@ -113,20 +115,20 @@ argument :: Schema.Subs -> Full.Argument -> Maybe Core.Argument argument subs (Full.Argument n v) = Core.Argument n <$> value subs v value :: Schema.Subs -> Full.Value -> Maybe Core.Value -value subs (Full.ValueVariable n) = subs n -value _ (Full.ValueInt i) = pure $ Core.ValueInt i -value _ (Full.ValueFloat f) = pure $ Core.ValueFloat f -value _ (Full.ValueString x) = pure $ Core.ValueString x -value _ (Full.ValueBoolean b) = pure $ Core.ValueBoolean b -value _ Full.ValueNull = pure Core.ValueNull -value _ (Full.ValueEnum e) = pure $ Core.ValueEnum e -value subs (Full.ValueList l) = - Core.ValueList <$> traverse (value subs) l -value subs (Full.ValueObject o) = - Core.ValueObject <$> traverse (objectField subs) o - -objectField :: Schema.Subs -> Full.ObjectField -> Maybe Core.ObjectField -objectField subs (Full.ObjectField n v) = Core.ObjectField n <$> value subs v +value subs (Full.Variable n) = subs n +value _ (Full.Int i) = pure $ Core.Int i +value _ (Full.Float f) = pure $ Core.Float f +value _ (Full.String x) = pure $ Core.String x +value _ (Full.Boolean b) = pure $ Core.Boolean b +value _ Full.Null = pure Core.Null +value _ (Full.Enum e) = pure $ Core.Enum e +value subs (Full.List l) = + Core.List <$> traverse (value subs) l +value subs (Full.Object o) = + Core.Object . HashMap.fromList <$> traverse (objectField subs) o + +objectField :: Schema.Subs -> Full.ObjectField -> Maybe (Core.Name, Core.Value) +objectField subs (Full.ObjectField n v) = (n,) <$> value subs v appendSelectionOpt :: Traversable t => diff --git a/src/Language/GraphQL/Encoder.hs b/src/Language/GraphQL/Encoder.hs deleted file mode 100644 index b3ec655..0000000 --- a/src/Language/GraphQL/Encoder.hs +++ /dev/null @@ -1,277 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ExplicitForAll #-} - --- | This module defines a minifier and a printer for the @GraphQL@ language. -module Language.GraphQL.Encoder - ( Formatter - , definition - , directive - , document - , minified - , pretty - , type' - , value - ) where - -import Data.Foldable (fold) -import Data.Monoid ((<>)) -import qualified Data.List.NonEmpty as NonEmpty (toList) -import Data.Text.Lazy (Text) -import qualified Data.Text.Lazy as Text.Lazy -import Data.Text.Lazy.Builder (toLazyText) -import Data.Text.Lazy.Builder.Int (decimal) -import Data.Text.Lazy.Builder.RealFloat (realFloat) -import Language.GraphQL.AST - --- | Instructs the encoder whether a GraphQL should be minified or pretty --- printed. --- --- Use 'pretty' and 'minified' to construct the formatter. -data Formatter - = Minified - | Pretty Word - --- | Constructs a formatter for pretty printing. -pretty :: Formatter -pretty = Pretty 0 - --- | Constructs a formatter for minifying. -minified :: Formatter -minified = Minified - --- | Converts a 'Document' into a string. -document :: Formatter -> Document -> Text -document formatter defs - | Pretty _ <- formatter = Text.Lazy.intercalate "\n" encodeDocument - | Minified <-formatter = Text.Lazy.snoc (mconcat encodeDocument) '\n' - where - encodeDocument = NonEmpty.toList $ definition formatter <$> defs - --- | Converts a 'Definition' into a string. -definition :: Formatter -> Definition -> Text -definition formatter x - | Pretty _ <- formatter = Text.Lazy.snoc (encodeDefinition x) '\n' - | Minified <- formatter = encodeDefinition x - where - encodeDefinition (DefinitionOperation operation) - = operationDefinition formatter operation - encodeDefinition (DefinitionFragment fragment) - = fragmentDefinition formatter fragment - -operationDefinition :: Formatter -> OperationDefinition -> Text -operationDefinition formatter (OperationSelectionSet 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 - -node :: Formatter - -> Maybe Name - -> [VariableDefinition] - -> [Directive] - -> SelectionSet - -> Text -node formatter name vars dirs sels - = Text.Lazy.fromStrict (fold name) - <> optempty (variableDefinitions formatter) vars - <> optempty (directives formatter) dirs - <> eitherFormat formatter " " mempty - <> selectionSet formatter sels - -variableDefinitions :: Formatter -> [VariableDefinition] -> Text -variableDefinitions formatter - = parensCommas formatter $ variableDefinition formatter - -variableDefinition :: Formatter -> VariableDefinition -> Text -variableDefinition formatter (VariableDefinition var ty dv) - = variable var - <> eitherFormat formatter ": " ":" - <> type' ty - <> maybe mempty (defaultValue formatter) dv - -defaultValue :: Formatter -> Value -> Text -defaultValue formatter val - = eitherFormat formatter " = " "=" - <> value formatter val - -variable :: Name -> Text -variable var = "$" <> Text.Lazy.fromStrict var - -selectionSet :: Formatter -> SelectionSet -> Text -selectionSet formatter - = bracesList formatter (selection formatter) - . NonEmpty.toList - -selectionSetOpt :: Formatter -> SelectionSetOpt -> Text -selectionSetOpt formatter = bracesList formatter $ selection formatter - -selection :: Formatter -> Selection -> Text -selection formatter = Text.Lazy.append indent . f - where - f (SelectionField x) = field incrementIndent x - f (SelectionInlineFragment x) = inlineFragment incrementIndent x - f (SelectionFragmentSpread x) = fragmentSpread incrementIndent x - incrementIndent - | Pretty n <- formatter = Pretty $ n + 1 - | otherwise = Minified - indent - | Pretty n <- formatter = Text.Lazy.replicate (fromIntegral $ n + 1) " " - | otherwise = mempty - -field :: Formatter -> Field -> Text -field formatter (Field alias name args dirs selso) - = optempty (`Text.Lazy.append` colon) (Text.Lazy.fromStrict $ fold alias) - <> Text.Lazy.fromStrict name - <> optempty (arguments formatter) args - <> optempty (directives formatter) dirs - <> selectionSetOpt' - where - colon = eitherFormat formatter ": " ":" - selectionSetOpt' - | null selso = mempty - | otherwise = eitherFormat formatter " " mempty <> selectionSetOpt formatter selso - -arguments :: Formatter -> [Argument] -> Text -arguments formatter = parensCommas formatter $ argument formatter - -argument :: Formatter -> Argument -> Text -argument formatter (Argument name v) - = Text.Lazy.fromStrict name - <> eitherFormat formatter ": " ":" - <> value formatter v - --- * Fragments - -fragmentSpread :: Formatter -> FragmentSpread -> Text -fragmentSpread formatter (FragmentSpread name ds) - = "..." <> Text.Lazy.fromStrict name <> optempty (directives formatter) ds - -inlineFragment :: Formatter -> InlineFragment -> Text -inlineFragment formatter (InlineFragment tc dirs sels) - = "... on " - <> Text.Lazy.fromStrict (fold tc) - <> directives formatter dirs - <> eitherFormat formatter " " mempty - <> selectionSet formatter sels - -fragmentDefinition :: Formatter -> FragmentDefinition -> Text -fragmentDefinition formatter (FragmentDefinition name tc dirs sels) - = "fragment " <> Text.Lazy.fromStrict name - <> " on " <> Text.Lazy.fromStrict tc - <> optempty (directives formatter) dirs - <> eitherFormat formatter " " mempty - <> selectionSet formatter sels - --- * Miscellaneous - --- | Converts a 'Directive' into a string. -directive :: Formatter -> Directive -> Text -directive formatter (Directive name args) - = "@" <> Text.Lazy.fromStrict name <> optempty (arguments formatter) args - -directives :: Formatter -> [Directive] -> Text -directives formatter@(Pretty _) = Text.Lazy.cons ' ' . spaces (directive formatter) -directives Minified = spaces (directive Minified) - --- | Converts a 'Value' into a string. -value :: Formatter -> Value -> Text -value _ (ValueVariable x) = variable x -value _ (ValueInt x) = toLazyText $ decimal x -value _ (ValueFloat x) = toLazyText $ realFloat x -value _ (ValueBoolean x) = booleanValue x -value _ ValueNull = mempty -value _ (ValueString x) = stringValue $ Text.Lazy.fromStrict x -value _ (ValueEnum x) = Text.Lazy.fromStrict x -value formatter (ValueList x) = listValue formatter x -value formatter (ValueObject x) = objectValue formatter x - -booleanValue :: Bool -> Text -booleanValue True = "true" -booleanValue False = "false" - -stringValue :: Text -> Text -stringValue - = quotes - . Text.Lazy.replace "\"" "\\\"" - . Text.Lazy.replace "\\" "\\\\" - -listValue :: Formatter -> [Value] -> Text -listValue formatter = bracketsCommas formatter $ value formatter - -objectValue :: Formatter -> [ObjectField] -> Text -objectValue formatter = intercalate $ objectField formatter - where - intercalate f - = braces - . Text.Lazy.intercalate (eitherFormat formatter ", " ",") - . fmap f - - -objectField :: Formatter -> ObjectField -> Text -objectField formatter (ObjectField name v) - = Text.Lazy.fromStrict name <> colon <> value formatter v - where - colon - | Pretty _ <- formatter = ": " - | Minified <- formatter = ":" - --- | Converts a 'Type' a type into a string. -type' :: Type -> Text -type' (TypeNamed x) = Text.Lazy.fromStrict x -type' (TypeList x) = listType x -type' (TypeNonNull x) = nonNullType x - -listType :: Type -> Text -listType x = brackets (type' x) - -nonNullType :: NonNullType -> Text -nonNullType (NonNullTypeNamed x) = Text.Lazy.fromStrict x <> "!" -nonNullType (NonNullTypeList x) = listType x <> "!" - --- * Internal - -between :: Char -> Char -> Text -> Text -between open close = Text.Lazy.cons open . (`Text.Lazy.snoc` close) - -parens :: Text -> Text -parens = between '(' ')' - -brackets :: Text -> Text -brackets = between '[' ']' - -braces :: Text -> Text -braces = between '{' '}' - -quotes :: Text -> Text -quotes = between '"' '"' - -spaces :: forall a. (a -> Text) -> [a] -> Text -spaces f = Text.Lazy.intercalate "\SP" . fmap f - -parensCommas :: forall a. Formatter -> (a -> Text) -> [a] -> Text -parensCommas formatter f - = parens - . Text.Lazy.intercalate (eitherFormat formatter ", " ",") - . fmap f - -bracketsCommas :: Formatter -> (a -> Text) -> [a] -> Text -bracketsCommas formatter f - = brackets - . Text.Lazy.intercalate (eitherFormat formatter ", " ",") - . fmap f - -bracesList :: forall a. Formatter -> (a -> Text) -> [a] -> Text -bracesList (Pretty intendation) f xs - = Text.Lazy.snoc (Text.Lazy.intercalate "\n" content) '\n' - <> (Text.Lazy.snoc $ Text.Lazy.replicate (fromIntegral intendation) " ") '}' - where - content = "{" : fmap f xs -bracesList Minified f xs = braces $ Text.Lazy.intercalate "," $ fmap f xs - -optempty :: (Eq a, Monoid a, Monoid b) => (a -> b) -> a -> b -optempty f xs = if xs == mempty then mempty else f xs - -eitherFormat :: forall a. Formatter -> a -> a -> a -eitherFormat (Pretty _) x _ = x -eitherFormat Minified _ x = x diff --git a/src/Language/GraphQL/Lexer.hs b/src/Language/GraphQL/Lexer.hs deleted file mode 100644 index dc000b5..0000000 --- a/src/Language/GraphQL/Lexer.hs +++ /dev/null @@ -1,228 +0,0 @@ -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE OverloadedStrings #-} - --- | This module defines a bunch of small parsers used to parse individual --- lexemes. -module Language.GraphQL.Lexer - ( Parser - , amp - , at - , bang - , blockString - , braces - , brackets - , colon - , dollar - , comment - , equals - , integer - , float - , lexeme - , name - , parens - , pipe - , spaceConsumer - , spread - , string - , symbol - , unicodeBOM - ) where - -import Control.Applicative ( Alternative(..) - , liftA2 - ) -import Data.Char ( chr - , digitToInt - , isAsciiLower - , isAsciiUpper - , ord - ) -import Data.Foldable (foldl') -import Data.List (dropWhileEnd) -import Data.Proxy (Proxy(..)) -import Data.Void (Void) -import Text.Megaparsec ( Parsec - , between - , chunk - , chunkToTokens - , notFollowedBy - , oneOf - , option - , optional - , satisfy - , sepBy - , skipSome - , takeP - , takeWhile1P - , try - ) -import Text.Megaparsec.Char ( char - , digitChar - , space1 - ) -import qualified Text.Megaparsec.Char.Lexer as Lexer -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL - --- | Standard parser. --- Accepts the type of the parsed token. -type Parser = Parsec Void T.Text - -ignoredCharacters :: Parser () -ignoredCharacters = space1 <|> skipSome (char ',') - --- | Parser that skips comments and meaningless characters, whitespaces and --- commas. -spaceConsumer :: Parser () -spaceConsumer = Lexer.space ignoredCharacters comment empty - --- | Parser for comments. -comment :: Parser () -comment = Lexer.skipLineComment "#" - --- | Lexeme definition which ignores whitespaces and commas. -lexeme :: forall a. Parser a -> Parser a -lexeme = Lexer.lexeme spaceConsumer - --- | Symbol definition which ignores whitespaces and commas. -symbol :: T.Text -> Parser T.Text -symbol = Lexer.symbol spaceConsumer - --- | Parser for "!". -bang :: Parser Char -bang = char '!' - --- | Parser for "$". -dollar :: Parser Char -dollar = char '$' - --- | Parser for "@". -at :: Parser Char -at = char '@' - --- | Parser for "&". -amp :: Parser T.Text -amp = symbol "&" - --- | Parser for ":". -colon :: Parser T.Text -colon = symbol ":" - --- | Parser for "=". -equals :: Parser T.Text -equals = symbol "=" - --- | Parser for the spread operator (...). -spread :: Parser T.Text -spread = symbol "..." - --- | Parser for "|". -pipe :: Parser T.Text -pipe = symbol "|" - --- | Parser for an expression between "(" and ")". -parens :: forall a. Parser a -> Parser a -parens = between (symbol "(") (symbol ")") - --- | Parser for an expression between "[" and "]". -brackets :: forall a. Parser a -> Parser a -brackets = between (symbol "[") (symbol "]") - --- | Parser for an expression between "{" and "}". -braces :: forall a. Parser a -> Parser a -braces = between (symbol "{") (symbol "}") - --- | Parser for strings. -string :: Parser T.Text -string = between "\"" "\"" stringValue - where - stringValue = T.pack <$> many stringCharacter - stringCharacter = satisfy isStringCharacter1 - <|> escapeSequence - isStringCharacter1 = liftA2 (&&) isSourceCharacter isChunkDelimiter - --- | Parser for block strings. -blockString :: Parser T.Text -blockString = between "\"\"\"" "\"\"\"" stringValue - where - stringValue = do - byLine <- sepBy (many blockStringCharacter) lineTerminator - let indentSize = foldr countIndent 0 $ tail byLine - withoutIndent = head byLine : (removeIndent indentSize <$> tail byLine) - withoutEmptyLines = liftA2 (.) dropWhile dropWhileEnd removeEmptyLine withoutIndent - - return $ T.intercalate "\n" $ T.concat <$> withoutEmptyLines - removeEmptyLine [] = True - removeEmptyLine [x] = T.null x || isWhiteSpace (T.head x) - removeEmptyLine _ = False - blockStringCharacter - = takeWhile1P Nothing isWhiteSpace - <|> takeWhile1P Nothing isBlockStringCharacter1 - <|> escapeTripleQuote - <|> try (chunk "\"" <* notFollowedBy (chunk "\"\"")) - escapeTripleQuote = chunk "\\" >>= flip option (chunk "\"\"") - isBlockStringCharacter1 = liftA2 (&&) isSourceCharacter isChunkDelimiter - countIndent [] acc = acc - countIndent (x:_) acc - | T.null x = acc - | not (isWhiteSpace $ T.head x) = acc - | acc == 0 = T.length x - | otherwise = min acc $ T.length x - removeIndent _ [] = [] - removeIndent n (x:chunks) = T.drop n x : chunks - --- | Parser for integers. -integer :: Integral a => Parser a -integer = Lexer.signed (pure ()) $ lexeme Lexer.decimal - --- | Parser for floating-point numbers. -float :: Parser Double -float = Lexer.signed (pure ()) $ lexeme Lexer.float - --- | Parser for names (/[_A-Za-z][_0-9A-Za-z]*/). -name :: Parser T.Text -name = do - firstLetter <- nameFirstLetter - rest <- many $ nameFirstLetter <|> digitChar - _ <- spaceConsumer - return $ TL.toStrict $ TL.cons firstLetter $ TL.pack rest - where - nameFirstLetter = satisfy isAsciiUpper <|> satisfy isAsciiLower <|> char '_' - -isChunkDelimiter :: Char -> Bool -isChunkDelimiter = flip notElem ['"', '\\', '\n', '\r'] - -isWhiteSpace :: Char -> Bool -isWhiteSpace = liftA2 (||) (== ' ') (== '\t') - -lineTerminator :: Parser T.Text -lineTerminator = chunk "\r\n" <|> chunk "\n" <|> chunk "\r" - -isSourceCharacter :: Char -> Bool -isSourceCharacter = isSourceCharacter' . ord - where - isSourceCharacter' code = code >= 0x0020 - || code == 0x0009 - || code == 0x000a - || code == 0x000d - -escapeSequence :: Parser Char -escapeSequence = do - _ <- char '\\' - escaped <- oneOf ['"', '\\', '/', 'b', 'f', 'n', 'r', 't', 'u'] - case escaped of - 'b' -> return '\b' - 'f' -> return '\f' - 'n' -> return '\n' - 'r' -> return '\r' - 't' -> return '\t' - 'u' -> chr . foldl' step 0 - . chunkToTokens (Proxy :: Proxy T.Text) - <$> takeP Nothing 4 - _ -> return escaped - where - step accumulator = (accumulator * 16 +) . digitToInt - --- | Parser for the "Byte Order Mark". -unicodeBOM :: Parser () -unicodeBOM = optional (char '\xfeff') >> pure () diff --git a/src/Language/GraphQL/Parser.hs b/src/Language/GraphQL/Parser.hs deleted file mode 100644 index bbe1de7..0000000 --- a/src/Language/GraphQL/Parser.hs +++ /dev/null @@ -1,188 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} - --- | @GraphQL@ document parser. -module Language.GraphQL.Parser - ( document - ) where - -import Control.Applicative ( Alternative(..) - , optional - ) -import Data.List.NonEmpty (NonEmpty(..)) -import Language.GraphQL.AST -import Language.GraphQL.Lexer -import Text.Megaparsec ( lookAhead - , option - , try - , () - ) - --- | Parser for the GraphQL documents. -document :: Parser Document -document = unicodeBOM >> spaceConsumer >> lexeme (manyNE definition) - -definition :: Parser Definition -definition = DefinitionOperation <$> operationDefinition - <|> DefinitionFragment <$> fragmentDefinition - "definition error!" - -operationDefinition :: Parser OperationDefinition -operationDefinition = OperationSelectionSet <$> selectionSet - <|> OperationDefinition <$> operationType - <*> optional name - <*> opt variableDefinitions - <*> opt directives - <*> selectionSet - "operationDefinition error" - -operationType :: Parser OperationType -operationType = Query <$ symbol "query" - <|> Mutation <$ symbol "mutation" - "operationType error" - --- * SelectionSet - -selectionSet :: Parser SelectionSet -selectionSet = braces $ manyNE selection - -selectionSetOpt :: Parser SelectionSetOpt -selectionSetOpt = braces $ some selection - -selection :: Parser Selection -selection = SelectionField <$> field - <|> try (SelectionFragmentSpread <$> fragmentSpread) - <|> SelectionInlineFragment <$> inlineFragment - "selection error!" - --- * Field - -field :: Parser Field -field = Field <$> optional alias - <*> name - <*> opt arguments - <*> opt directives - <*> opt selectionSetOpt - -alias :: Parser Alias -alias = try $ name <* colon - --- * Arguments - -arguments :: Parser [Argument] -arguments = parens $ some argument - -argument :: Parser Argument -argument = Argument <$> name <* colon <*> value - --- * Fragments - -fragmentSpread :: Parser FragmentSpread -fragmentSpread = FragmentSpread <$ spread - <*> fragmentName - <*> opt directives - -inlineFragment :: Parser InlineFragment -inlineFragment = InlineFragment <$ spread - <*> optional typeCondition - <*> opt directives - <*> selectionSet - -fragmentDefinition :: Parser FragmentDefinition -fragmentDefinition = FragmentDefinition - <$ symbol "fragment" - <*> name - <*> typeCondition - <*> opt directives - <*> selectionSet - -fragmentName :: Parser Name -fragmentName = but (symbol "on") *> name - -typeCondition :: Parser TypeCondition -typeCondition = symbol "on" *> name - --- * Input Values - -value :: Parser Value -value = ValueVariable <$> variable - <|> ValueFloat <$> try float - <|> ValueInt <$> integer - <|> ValueBoolean <$> booleanValue - <|> ValueNull <$ symbol "null" - <|> ValueString <$> blockString - <|> ValueString <$> string - <|> ValueEnum <$> try enumValue - <|> ValueList <$> listValue - <|> ValueObject <$> objectValue - "value error!" - where - booleanValue :: Parser Bool - 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 - -objectField :: Parser ObjectField -objectField = ObjectField <$> name <* symbol ":" <*> value - --- * Variables - -variableDefinitions :: Parser [VariableDefinition] -variableDefinitions = parens $ some variableDefinition - -variableDefinition :: Parser VariableDefinition -variableDefinition = VariableDefinition <$> variable - <* colon - <*> type_ - <*> optional defaultValue -variable :: Parser Name -variable = dollar *> name - -defaultValue :: Parser Value -defaultValue = equals *> value - --- * Input Types - -type_ :: Parser Type -type_ = try (TypeNamed <$> name <* but "!") - <|> TypeList <$> brackets type_ - <|> TypeNonNull <$> nonNullType - "type_ error!" - -nonNullType :: Parser NonNullType -nonNullType = NonNullTypeNamed <$> name <* bang - <|> NonNullTypeList <$> brackets type_ <* bang - "nonNullType error!" - --- * Directives - -directives :: Parser [Directive] -directives = some directive - -directive :: Parser Directive -directive = Directive - <$ at - <*> name - <*> opt arguments - --- * Internal - -opt :: Monoid a => Parser a -> Parser a -opt = option mempty - --- 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 diff --git a/src/Language/GraphQL/Schema.hs b/src/Language/GraphQL/Schema.hs index d7e698b..44e9077 100644 --- a/src/Language/GraphQL/Schema.hs +++ b/src/Language/GraphQL/Schema.hs @@ -30,10 +30,10 @@ import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Text (Text) import qualified Data.Text as T +import Language.GraphQL.AST.Core import Language.GraphQL.Error import Language.GraphQL.Trans -import Language.GraphQL.Type -import Language.GraphQL.AST.Core +import qualified Language.GraphQL.Type as Type -- | Resolves a 'Field' into an @Aeson.@'Data.Aeson.Types.Object' with error -- information (if an error has occurred). @m@ is usually expected to be an @@ -58,7 +58,7 @@ objectA name f = Resolver name $ resolveFieldValue f resolveRight -- | Like 'object' but also taking 'Argument's and can be null or a list of objects. wrappedObjectA :: MonadIO m - => Name -> ([Argument] -> ActionT m (Wrapping [Resolver m])) -> Resolver m + => Name -> ([Argument] -> ActionT m (Type.Wrapping [Resolver m])) -> Resolver m wrappedObjectA name f = Resolver name $ resolveFieldValue f resolveRight where resolveRight fld@(Field _ _ _ sels) resolver @@ -66,7 +66,7 @@ wrappedObjectA name f = Resolver name $ resolveFieldValue f resolveRight -- | Like 'object' but can be null or a list of objects. wrappedObject :: MonadIO m - => Name -> ActionT m (Wrapping [Resolver m]) -> Resolver m + => Name -> ActionT m (Type.Wrapping [Resolver m]) -> Resolver m wrappedObject name = wrappedObjectA name . const -- | A scalar represents a primitive value, like a string or an integer. @@ -80,19 +80,19 @@ scalarA name f = Resolver name $ resolveFieldValue f resolveRight where resolveRight fld result = withField (return result) fld --- | Lika 'scalar' but also taking 'Argument's and can be null or a list of scalars. +-- | Like 'scalar' but also taking 'Argument's and can be null or a list of scalars. wrappedScalarA :: (MonadIO m, Aeson.ToJSON a) - => Name -> ([Argument] -> ActionT m (Wrapping a)) -> Resolver m + => Name -> ([Argument] -> ActionT m (Type.Wrapping a)) -> Resolver m wrappedScalarA name f = Resolver name $ resolveFieldValue f resolveRight where - resolveRight fld (Named result) = withField (return result) fld - resolveRight fld Null + resolveRight fld (Type.Named result) = withField (return result) fld + resolveRight fld Type.Null = return $ HashMap.singleton (aliasOrName fld) Aeson.Null - resolveRight fld (List result) = withField (return result) fld + resolveRight fld (Type.List result) = withField (return result) fld -- | Like 'scalar' but can be null or a list of scalars. wrappedScalar :: (MonadIO m, Aeson.ToJSON a) - => Name -> ActionT m (Wrapping a) -> Resolver m + => Name -> ActionT m (Type.Wrapping a) -> Resolver m wrappedScalar name = wrappedScalarA name . const resolveFieldValue :: MonadIO m diff --git a/src/Language/GraphQL/Type.hs b/src/Language/GraphQL/Type.hs index 3f91e50..c8a9997 100644 --- a/src/Language/GraphQL/Type.hs +++ b/src/Language/GraphQL/Type.hs @@ -1,11 +1,9 @@ --- | Definitions for @GraphQL@ type system. +-- | Definitions for @GraphQL@ input types. module Language.GraphQL.Type ( Wrapping(..) ) where -import Data.Aeson as Aeson ( ToJSON - , toJSON - ) +import Data.Aeson as Aeson (ToJSON, toJSON) import qualified Data.Aeson as Aeson -- | GraphQL distinguishes between "wrapping" and "named" types. Each wrapping -- cgit v1.2.3