diff options
Diffstat (limited to 'src/Language/GraphQL/AST')
| -rw-r--r-- | src/Language/GraphQL/AST/Core.hs | 93 | ||||
| -rw-r--r-- | src/Language/GraphQL/AST/Encoder.hs | 277 | ||||
| -rw-r--r-- | src/Language/GraphQL/AST/Lexer.hs | 228 | ||||
| -rw-r--r-- | src/Language/GraphQL/AST/Parser.hs | 188 | ||||
| -rw-r--r-- | src/Language/GraphQL/AST/Transform.hs | 30 |
5 files changed, 728 insertions, 88 deletions
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 => |