-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

module Michelson.Parser.Lexer
  ( lexeme
  , mSpace
  , symbol
  , symbol'
  , word
  , word'
  , string'
  , parens
  , braces
  , brackets
  , brackets'
  , semicolon
  , comma
  , varID
  ) where

import Data.Char (isDigit, isLower, toLower)
import qualified Data.Text as T
import Text.Megaparsec (MonadParsec, Tokens, between, satisfy)
import Text.Megaparsec.Char (lowerChar, space, space1, string)
import qualified Text.Megaparsec.Char.Lexer as L

import Michelson.Parser.Types (Parser)
import qualified Michelson.Untyped as U

-- Lexing
lexeme :: Parser a -> Parser a
lexeme :: Parser a -> Parser a
lexeme = ReaderT LetEnv (Parsec CustomParserException Text) ()
-> Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
L.lexeme ReaderT LetEnv (Parsec CustomParserException Text) ()
mSpace

mSpace :: Parser ()
mSpace :: ReaderT LetEnv (Parsec CustomParserException Text) ()
mSpace = ReaderT LetEnv (Parsec CustomParserException Text) ()
-> ReaderT LetEnv (Parsec CustomParserException Text) ()
-> ReaderT LetEnv (Parsec CustomParserException Text) ()
-> ReaderT LetEnv (Parsec CustomParserException Text) ()
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> m () -> m () -> m ()
L.space ReaderT LetEnv (Parsec CustomParserException Text) ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space1
  (Tokens Text
-> ReaderT LetEnv (Parsec CustomParserException Text) ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Tokens s -> m ()
L.skipLineComment "#")
  (Tokens Text
-> Tokens Text
-> ReaderT LetEnv (Parsec CustomParserException Text) ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Tokens s -> Tokens s -> m ()
L.skipBlockComment "/*" "*/" ReaderT LetEnv (Parsec CustomParserException Text) ()
-> ReaderT LetEnv (Parsec CustomParserException Text) ()
-> ReaderT LetEnv (Parsec CustomParserException Text) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReaderT LetEnv (Parsec CustomParserException Text) ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space ReaderT LetEnv (Parsec CustomParserException Text) ()
-> ReaderT LetEnv (Parsec CustomParserException Text) ()
-> ReaderT LetEnv (Parsec CustomParserException Text) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReaderT LetEnv (Parsec CustomParserException Text) (Maybe ())
-> ReaderT LetEnv (Parsec CustomParserException Text) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT LetEnv (Parsec CustomParserException Text) ()
-> ReaderT LetEnv (Parsec CustomParserException Text) (Maybe ())
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ReaderT LetEnv (Parsec CustomParserException Text) ()
semicolon))


symbol :: Tokens Text -> Parser ()
symbol :: Tokens Text
-> ReaderT LetEnv (Parsec CustomParserException Text) ()
symbol = ReaderT LetEnv (Parsec CustomParserException Text) Text
-> ReaderT LetEnv (Parsec CustomParserException Text) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT LetEnv (Parsec CustomParserException Text) Text
 -> ReaderT LetEnv (Parsec CustomParserException Text) ())
-> (Text
    -> ReaderT LetEnv (Parsec CustomParserException Text) Text)
-> Text
-> ReaderT LetEnv (Parsec CustomParserException Text) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT LetEnv (Parsec CustomParserException Text) ()
-> Tokens Text
-> ReaderT LetEnv (Parsec CustomParserException Text) (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> Tokens s -> m (Tokens s)
L.symbol ReaderT LetEnv (Parsec CustomParserException Text) ()
mSpace

symbol' :: Text -> Parser ()
symbol' :: Text -> ReaderT LetEnv (Parsec CustomParserException Text) ()
symbol' str :: Text
str = Tokens Text
-> ReaderT LetEnv (Parsec CustomParserException Text) ()
symbol Text
Tokens Text
str ReaderT LetEnv (Parsec CustomParserException Text) ()
-> ReaderT LetEnv (Parsec CustomParserException Text) ()
-> ReaderT LetEnv (Parsec CustomParserException Text) ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tokens Text
-> ReaderT LetEnv (Parsec CustomParserException Text) ()
symbol ((Char -> Char) -> Text -> Text
T.map Char -> Char
toLower Text
str)

word :: Tokens Text -> a -> Parser a
word :: Tokens Text -> a -> Parser a
word str :: Tokens Text
str val :: a
val = Tokens Text
-> ReaderT LetEnv (Parsec CustomParserException Text) ()
symbol Tokens Text
str ReaderT LetEnv (Parsec CustomParserException Text) ()
-> a -> Parser a
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> a
val

word' :: Tokens Text -> a -> Parser a
word' :: Tokens Text -> a -> Parser a
word' str :: Tokens Text
str val :: a
val = Text -> ReaderT LetEnv (Parsec CustomParserException Text) ()
symbol' Text
Tokens Text
str ReaderT LetEnv (Parsec CustomParserException Text) ()
-> a -> Parser a
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> a
val

string' :: (MonadParsec e s f, Tokens s ~ Text) => Text -> f Text
string' :: Text -> f Text
string' str :: Text
str = Tokens s -> f (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Text
Tokens s
str f Text -> f Text -> f Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tokens s -> f (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string ((Char -> Char) -> Text -> Text
T.map Char -> Char
toLower Text
str)

parens :: Parser a -> Parser a
parens :: Parser a -> Parser a
parens = ReaderT LetEnv (Parsec CustomParserException Text) ()
-> ReaderT LetEnv (Parsec CustomParserException Text) ()
-> Parser a
-> Parser a
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Tokens Text
-> ReaderT LetEnv (Parsec CustomParserException Text) ()
symbol "(") (Tokens Text
-> ReaderT LetEnv (Parsec CustomParserException Text) ()
symbol ")")

braces :: Parser a -> Parser a
braces :: Parser a -> Parser a
braces = ReaderT LetEnv (Parsec CustomParserException Text) ()
-> ReaderT LetEnv (Parsec CustomParserException Text) ()
-> Parser a
-> Parser a
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Tokens Text
-> ReaderT LetEnv (Parsec CustomParserException Text) ()
symbol "{") (Tokens Text
-> ReaderT LetEnv (Parsec CustomParserException Text) ()
symbol "}")

brackets :: Parser a -> Parser a
brackets :: Parser a -> Parser a
brackets = ReaderT LetEnv (Parsec CustomParserException Text) ()
-> ReaderT LetEnv (Parsec CustomParserException Text) ()
-> Parser a
-> Parser a
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Tokens Text
-> ReaderT LetEnv (Parsec CustomParserException Text) ()
symbol "[") (Tokens Text
-> ReaderT LetEnv (Parsec CustomParserException Text) ()
symbol "]")

brackets' :: Parser a -> Parser a
brackets' :: Parser a -> Parser a
brackets' = ReaderT LetEnv (Parsec CustomParserException Text) Text
-> ReaderT LetEnv (Parsec CustomParserException Text) Text
-> Parser a
-> Parser a
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Tokens Text
-> ReaderT LetEnv (Parsec CustomParserException Text) (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string "[") (Tokens Text
-> ReaderT LetEnv (Parsec CustomParserException Text) (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string "]")

semicolon :: Parser ()
semicolon :: ReaderT LetEnv (Parsec CustomParserException Text) ()
semicolon = Tokens Text
-> ReaderT LetEnv (Parsec CustomParserException Text) ()
symbol ";"

comma :: Parser ()
comma :: ReaderT LetEnv (Parsec CustomParserException Text) ()
comma = Tokens Text
-> ReaderT LetEnv (Parsec CustomParserException Text) ()
symbol ","

varID :: Parser U.Var
varID :: Parser Var
varID = Parser Var -> Parser Var
forall a. Parser a -> Parser a
lexeme (Parser Var -> Parser Var) -> Parser Var -> Parser Var
forall a b. (a -> b) -> a -> b
$ do
  Char
v <- ReaderT LetEnv (Parsec CustomParserException Text) Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
lowerChar
  [Char]
vs <- ReaderT LetEnv (Parsec CustomParserException Text) Char
-> ReaderT LetEnv (Parsec CustomParserException Text) [Char]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ReaderT LetEnv (Parsec CustomParserException Text) Char
lowerAlphaNumChar
  return $ Text -> Var
U.Var ([Char] -> Text
forall a. ToText a => a -> Text
toText (Char
vChar -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
vs))
  where
    lowerAlphaNumChar :: Parser Char
    lowerAlphaNumChar :: ReaderT LetEnv (Parsec CustomParserException Text) Char
lowerAlphaNumChar = (Token Text -> Bool)
-> ReaderT LetEnv (Parsec CustomParserException Text) (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy (\x :: Token Text
x -> Char -> Bool
isLower Char
Token Text
x Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
Token Text
x)