{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE OverloadedStrings #-}
module Language.GraphQL.AST.Lexer
( Parser
, amp
, at
, bang
, blockString
, braces
, brackets
, colon
, dollar
, comment
, equals
, extend
, 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 qualified Data.List.NonEmpty as NonEmpty
import Data.List.NonEmpty (NonEmpty(..))
import Data.Proxy (Proxy(..))
import Data.Void (Void)
import Text.Megaparsec ( Parsec
, (<?>)
, between
, chunk
, chunkToTokens
, 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 Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Control.Monad (void)
type Parser = Parsec Void T.Text
ignoredCharacters :: Parser ()
ignoredCharacters :: Parser ()
ignoredCharacters = forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space1 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. MonadPlus m => m a -> m ()
skipSome (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
',')
spaceConsumer :: Parser ()
spaceConsumer :: Parser ()
spaceConsumer = forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> m () -> m () -> m ()
Lexer.space Parser ()
ignoredCharacters Parser ()
comment forall (f :: * -> *) a. Alternative f => f a
empty
comment :: Parser ()
= forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Tokens s -> m ()
Lexer.skipLineComment Tokens Text
"#"
lexeme :: forall a. Parser a -> Parser a
lexeme :: forall a. Parser a -> Parser a
lexeme = forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
Lexer.lexeme Parser ()
spaceConsumer
symbol :: T.Text -> Parser T.Text
symbol :: Text -> ParsecT Void Text Identity Text
symbol = forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> Tokens s -> m (Tokens s)
Lexer.symbol Parser ()
spaceConsumer
bang :: Parser T.Text
bang :: ParsecT Void Text Identity Text
bang = Text -> ParsecT Void Text Identity Text
symbol Text
"!"
dollar :: Parser T.Text
dollar :: ParsecT Void Text Identity Text
dollar = Text -> ParsecT Void Text Identity Text
symbol Text
"$"
at :: Parser ()
at :: Parser ()
at = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Text -> ParsecT Void Text Identity Text
symbol Text
"@"
amp :: Parser T.Text
amp :: ParsecT Void Text Identity Text
amp = Text -> ParsecT Void Text Identity Text
symbol Text
"&"
colon :: Parser ()
colon :: Parser ()
colon = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Text -> ParsecT Void Text Identity Text
symbol Text
":"
equals :: Parser T.Text
equals :: ParsecT Void Text Identity Text
equals = Text -> ParsecT Void Text Identity Text
symbol Text
"="
spread :: Parser T.Text
spread :: ParsecT Void Text Identity Text
spread = Text -> ParsecT Void Text Identity Text
symbol Text
"..."
pipe :: Parser T.Text
pipe :: ParsecT Void Text Identity Text
pipe = Text -> ParsecT Void Text Identity Text
symbol Text
"|"
parens :: forall a. Parser a -> Parser a
parens :: forall a. Parser a -> Parser a
parens = forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Text -> ParsecT Void Text Identity Text
symbol Text
"(") (Text -> ParsecT Void Text Identity Text
symbol Text
")")
brackets :: forall a. Parser a -> Parser a
brackets :: forall a. Parser a -> Parser a
brackets = forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Text -> ParsecT Void Text Identity Text
symbol Text
"[") (Text -> ParsecT Void Text Identity Text
symbol Text
"]")
braces :: forall a. Parser a -> Parser a
braces :: forall a. Parser a -> Parser a
braces = forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Text -> ParsecT Void Text Identity Text
symbol Text
"{") (Text -> ParsecT Void Text Identity Text
symbol Text
"}")
string :: Parser T.Text
string :: ParsecT Void Text Identity Text
string = forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between ParsecT Void Text Identity Text
"\"" ParsecT Void Text Identity Text
"\"" ParsecT Void Text Identity Text
stringValue forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
spaceConsumer
where
stringValue :: ParsecT Void Text Identity Text
stringValue = String -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ParsecT Void Text Identity Char
stringCharacter
stringCharacter :: ParsecT Void Text Identity Char
stringCharacter = forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
isStringCharacter1
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity Char
escapeSequence
isStringCharacter1 :: Char -> Bool
isStringCharacter1 = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Bool -> Bool -> Bool
(&&) Char -> Bool
isSourceCharacter Char -> Bool
isChunkDelimiter
blockString :: Parser T.Text
blockString :: ParsecT Void Text Identity Text
blockString = forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between ParsecT Void Text Identity Text
"\"\"\"" ParsecT Void Text Identity Text
"\"\"\"" ParsecT Void Text Identity Text
stringValue forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
spaceConsumer
where
stringValue :: ParsecT Void Text Identity Text
stringValue = do
[[Text]]
byLine <- forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
sepBy (forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ParsecT Void Text Identity (Tokens Text)
blockStringCharacter) ParsecT Void Text Identity Text
lineTerminator
let indentSize :: Int
indentSize = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr [Text] -> Int -> Int
countIndent Int
0 forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
tail [[Text]]
byLine
withoutIndent :: [[Text]]
withoutIndent = forall a. [a] -> a
head [[Text]]
byLine forall a. a -> [a] -> [a]
: (Int -> [Text] -> [Text]
removeIndent Int
indentSize forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> [a]
tail [[Text]]
byLine)
withoutEmptyLines :: [[Text]]
withoutEmptyLines = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall a. (a -> Bool) -> [a] -> [a]
dropWhile forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd [Text] -> Bool
removeEmptyLine [[Text]]
withoutIndent
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
"\n" forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Text]]
withoutEmptyLines
removeEmptyLine :: [Text] -> Bool
removeEmptyLine [] = Bool
True
removeEmptyLine [Text
x] = Text -> Bool
T.null Text
x Bool -> Bool -> Bool
|| Char -> Bool
isWhiteSpace (Text -> Char
T.head Text
x)
removeEmptyLine [Text]
_ = Bool
False
blockStringCharacter :: ParsecT Void Text Identity (Tokens Text)
blockStringCharacter
= forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P forall a. Maybe a
Nothing Char -> Bool
isWhiteSpace
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P forall a. Maybe a
Nothing Char -> Bool
isBlockStringCharacter1
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity (Tokens Text)
escapeTripleQuote
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens Text
"\"" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy (forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens Text
"\"\""))
escapeTripleQuote :: ParsecT Void Text Identity (Tokens Text)
escapeTripleQuote = forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens Text
"\\" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option (forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens Text
"\"\"")
isBlockStringCharacter1 :: Char -> Bool
isBlockStringCharacter1 = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Bool -> Bool -> Bool
(&&) Char -> Bool
isSourceCharacter Char -> Bool
isChunkDelimiter
countIndent :: [Text] -> Int -> Int
countIndent [] Int
acc = Int
acc
countIndent (Text
x:[Text]
_) Int
acc
| Text -> Bool
T.null Text
x = Int
acc
| Bool -> Bool
not (Char -> Bool
isWhiteSpace forall a b. (a -> b) -> a -> b
$ Text -> Char
T.head Text
x) = Int
acc
| Int
acc forall a. Eq a => a -> a -> Bool
== Int
0 = Text -> Int
T.length Text
x
| Bool
otherwise = forall a. Ord a => a -> a -> a
min Int
acc forall a b. (a -> b) -> a -> b
$ Text -> Int
T.length Text
x
removeIndent :: Int -> [Text] -> [Text]
removeIndent Int
_ [] = []
removeIndent Int
n (Text
x:[Text]
chunks) = Int -> Text -> Text
T.drop Int
n Text
x forall a. a -> [a] -> [a]
: [Text]
chunks
integer :: Integral a => Parser a
integer :: forall a. Integral a => Parser a
integer = forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m () -> m a -> m a
Lexer.signed (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (forall a. Parser a -> Parser a
lexeme forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
Lexer.decimal) forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"IntValue"
float :: Parser Double
float :: Parser Double
float = forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m () -> m a -> m a
Lexer.signed (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (forall a. Parser a -> Parser a
lexeme forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, RealFloat a) =>
m a
Lexer.float) forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"FloatValue"
name :: Parser T.Text
name :: ParsecT Void Text Identity Text
name = do
Char
firstLetter <- ParsecT Void Text Identity (Token Text)
nameFirstLetter
String
rest <- forall (f :: * -> *) a. Alternative f => f a -> f [a]
many forall a b. (a -> b) -> a -> b
$ ParsecT Void Text Identity (Token Text)
nameFirstLetter forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar
()
_ <- Parser ()
spaceConsumer
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> Text
TL.toStrict forall a b. (a -> b) -> a -> b
$ Char -> Text -> Text
TL.cons Char
firstLetter forall a b. (a -> b) -> a -> b
$ String -> Text
TL.pack String
rest
where
nameFirstLetter :: ParsecT Void Text Identity (Token Text)
nameFirstLetter = forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
isAsciiUpper forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
isAsciiLower forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'_'
isChunkDelimiter :: Char -> Bool
isChunkDelimiter :: Char -> Bool
isChunkDelimiter = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem [Char
'"', Char
'\\', Char
'\n', Char
'\r']
isWhiteSpace :: Char -> Bool
isWhiteSpace :: Char -> Bool
isWhiteSpace = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Bool -> Bool -> Bool
(||) (forall a. Eq a => a -> a -> Bool
== Char
' ') (forall a. Eq a => a -> a -> Bool
== Char
'\t')
lineTerminator :: Parser T.Text
lineTerminator :: ParsecT Void Text Identity Text
lineTerminator = forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens Text
"\r\n" forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens Text
"\n" forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens Text
"\r"
isSourceCharacter :: Char -> Bool
isSourceCharacter :: Char -> Bool
isSourceCharacter = forall {a}. (Ord a, Num a) => a -> Bool
isSourceCharacter' forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord
where
isSourceCharacter' :: a -> Bool
isSourceCharacter' a
code = a
code forall a. Ord a => a -> a -> Bool
>= a
0x0020
Bool -> Bool -> Bool
|| a
code forall a. Eq a => a -> a -> Bool
== a
0x0009
Bool -> Bool -> Bool
|| a
code forall a. Eq a => a -> a -> Bool
== a
0x000a
Bool -> Bool -> Bool
|| a
code forall a. Eq a => a -> a -> Bool
== a
0x000d
escapeSequence :: Parser Char
escapeSequence :: ParsecT Void Text Identity Char
escapeSequence = do
Token Text
_ <- forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'\\'
Char
escaped <- forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
oneOf [Char
'"', Char
'\\', Char
'/', Char
'b', Char
'f', Char
'n', Char
'r', Char
't', Char
'u']
case Char
escaped of
Char
'b' -> forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\b'
Char
'f' -> forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\f'
Char
'n' -> forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\n'
Char
'r' -> forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\r'
Char
't' -> forall (m :: * -> *) a. Monad m => a -> m a
return Char
'\t'
Char
'u' -> Int -> Char
chr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Int -> Char -> Int
step Int
0
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. Stream s => Proxy s -> Tokens s -> [Token s]
chunkToTokens (forall {k} (t :: k). Proxy t
Proxy :: Proxy T.Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> Int -> m (Tokens s)
takeP forall a. Maybe a
Nothing Int
4
Char
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Char
escaped
where
step :: Int -> Char -> Int
step Int
accumulator = (Int
accumulator forall a. Num a => a -> a -> a
* Int
16 forall a. Num a => a -> a -> a
+) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
digitToInt
unicodeBOM :: Parser ()
unicodeBOM :: Parser ()
unicodeBOM = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'\xfeff'
extend :: forall a. Text -> String -> NonEmpty (Parser a) -> Parser a
extend :: forall a. Text -> String -> NonEmpty (Parser a) -> Parser a
extend Text
token String
extensionLabel NonEmpty (Parser a)
parsers
= forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {a}.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
combine Parser a
headParser (forall a. NonEmpty a -> [a]
NonEmpty.tail NonEmpty (Parser a)
parsers)
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
extensionLabel
where
headParser :: Parser a
headParser = forall a. Parser a -> Parser a
tryExtension forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> a
NonEmpty.head NonEmpty (Parser a)
parsers
combine :: ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
combine ParsecT Void Text Identity a
current ParsecT Void Text Identity a
accumulated = ParsecT Void Text Identity a
accumulated forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. Parser a -> Parser a
tryExtension ParsecT Void Text Identity a
current
tryExtension :: ParsecT Void Text Identity a -> ParsecT Void Text Identity a
tryExtension ParsecT Void Text Identity a
extensionParser = forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try
forall a b. (a -> b) -> a -> b
$ Text -> ParsecT Void Text Identity Text
symbol Text
"extend"
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> ParsecT Void Text Identity Text
symbol Text
token
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity a
extensionParser