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.
This commit is contained in:
@ -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
|
||||
|
||||
277
src/Language/GraphQL/AST/Encoder.hs
Normal file
277
src/Language/GraphQL/AST/Encoder.hs
Normal file
@ -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
|
||||
228
src/Language/GraphQL/AST/Lexer.hs
Normal file
228
src/Language/GraphQL/AST/Lexer.hs
Normal file
@ -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 ()
|
||||
188
src/Language/GraphQL/AST/Parser.hs
Normal file
188
src/Language/GraphQL/AST/Parser.hs
Normal file
@ -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
|
||||
@ -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
|
||||
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.ObjectField
|
||||
objectField subs (Full.ObjectField n v) = Core.ObjectField n <$> value subs v
|
||||
objectField :: Schema.Subs -> Full.ObjectField -> Maybe (Core.Name, Core.Value)
|
||||
objectField subs (Full.ObjectField n v) = (n,) <$> value subs v
|
||||
|
||||
appendSelectionOpt ::
|
||||
Traversable t =>
|
||||
|
||||
Reference in New Issue
Block a user