{-# 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
    , 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)

-- | Standard parser.
-- Accepts the type of the parsed token.
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
',')

-- | Parser that skips comments and meaningless characters, whitespaces and
-- commas.
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

-- | Parser for comments.
comment :: Parser ()
comment :: Parser ()
comment = forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Tokens s -> m ()
Lexer.skipLineComment Tokens Text
"#"

-- | Lexeme definition which ignores whitespaces and commas.
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 definition which ignores whitespaces and commas.
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

-- | Parser for "!".
bang :: Parser T.Text
bang :: ParsecT Void Text Identity Text
bang = Text -> ParsecT Void Text Identity Text
symbol Text
"!"

-- | Parser for "$".
dollar :: Parser T.Text
dollar :: ParsecT Void Text Identity Text
dollar = Text -> ParsecT Void Text Identity Text
symbol Text
"$"

-- | Parser for "@".
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
"@"

-- | Parser for "&".
amp :: Parser T.Text
amp :: ParsecT Void Text Identity Text
amp = Text -> ParsecT Void Text Identity Text
symbol Text
"&"

-- | Parser for ":".
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
":"

-- | Parser for "=".
equals :: Parser T.Text
equals :: ParsecT Void Text Identity Text
equals = Text -> ParsecT Void Text Identity Text
symbol Text
"="

-- | Parser for the spread operator (...).
spread :: Parser T.Text
spread :: ParsecT Void Text Identity Text
spread = Text -> ParsecT Void Text Identity Text
symbol Text
"..."

-- | Parser for "|".
pipe :: Parser T.Text
pipe :: ParsecT Void Text Identity Text
pipe = Text -> ParsecT Void Text Identity Text
symbol Text
"|"

-- | Parser for an expression between "(" and ")".
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
")")

-- | Parser for an expression between "[" and "]".
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
"]")

-- | Parser for an expression between "{" and "}".
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
"}")

-- | Parser for strings.
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

-- | Parser for block strings.
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

-- | Parser for integers.
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"

-- | Parser for floating-point numbers.
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"

-- | Parser for names (/[_A-Za-z][_0-9A-Za-z]*/).
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

-- | Parser for the "Byte Order Mark".
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'

-- | Parses "extend" followed by a 'symbol'. It is used by schema extensions.
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