-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

-- TODO [#712]: Remove this next major release
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

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

import Prelude hiding (try)

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

import Morley.Michelson.Parser.Types (Parser, Parser')
import Morley.Michelson.Untyped qualified as U

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

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

spaces :: Parser le ()
spaces :: Parser' le ()
spaces =
  (Parser' le ()
mandatorySpaceOrComment Parser' le () -> Parser' le () -> Parser' le ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser' le ()
forall le. Parser le ()
mSpace)
  Parser' le () -> Parser' le () -> Parser' le ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Tokens Text] -> Parser' le ()
hasFollowingDelimiter [Tokens Text
"}", Tokens Text
"{", Tokens Text
"]", Tokens Text
")", Tokens Text
"|", Tokens Text
",", Tokens Text
";", Tokens Text
":", Tokens Text
"."]
  Parser' le () -> Parser' le () -> Parser' le ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser' le ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof
  where
    mandatorySpaceOrComment :: Parser' le ()
mandatorySpaceOrComment = Parser' le () -> Parser' le ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
hidden (Parser' le ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space1 Parser' le () -> Parser' le () -> Parser' le ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tokens Text -> Tokens Text -> Parser' le ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Tokens s -> Tokens s -> m ()
L.skipBlockComment Tokens Text
"/*" Tokens Text
"*/")
    hasFollowingDelimiter :: [Tokens Text] -> Parser' le ()
hasFollowingDelimiter = Parser' le () -> Parser' le ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
hidden (Parser' le () -> Parser' le ())
-> ([Tokens Text] -> Parser' le ())
-> [Tokens Text]
-> Parser' le ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Parser' le ()] -> Parser' le ()
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice ([Parser' le ()] -> Parser' le ())
-> ([Tokens Text] -> [Parser' le ()])
-> [Tokens Text]
-> Parser' le ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tokens Text -> Parser' le ()) -> [Tokens Text] -> [Parser' le ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (ReaderT le (Parsec CustomParserException Text) (Tokens Text)
-> Parser' le ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT le (Parsec CustomParserException Text) (Tokens Text)
 -> Parser' le ())
-> (Tokens Text
    -> ReaderT le (Parsec CustomParserException Text) (Tokens Text))
-> Tokens Text
-> Parser' le ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT le (Parsec CustomParserException Text) (Tokens Text)
-> ReaderT le (Parsec CustomParserException Text) (Tokens Text)
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead (ReaderT le (Parsec CustomParserException Text) (Tokens Text)
 -> ReaderT le (Parsec CustomParserException Text) (Tokens Text))
-> (Tokens Text
    -> ReaderT le (Parsec CustomParserException Text) (Tokens Text))
-> Tokens Text
-> ReaderT le (Parsec CustomParserException Text) (Tokens Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tokens Text
-> ReaderT le (Parsec CustomParserException Text) (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string)

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

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

symbol1 :: Tokens Text -> Parser le ()
symbol1 :: Tokens Text -> Parser le ()
symbol1 = Parser' le () -> Parser' le ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser' le () -> Parser' le ())
-> (Text -> Parser' le ()) -> Text -> Parser' le ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT le (Parsec CustomParserException Text) Text
-> Parser' le ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT le (Parsec CustomParserException Text) Text
 -> Parser' le ())
-> (Text -> ReaderT le (Parsec CustomParserException Text) Text)
-> Text
-> Parser' le ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser' le ()
-> Tokens Text
-> ReaderT le (Parsec CustomParserException Text) (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> Tokens s -> m (Tokens s)
L.symbol Parser' le ()
forall le. Parser le ()
spaces

symbol1' :: Text -> Parser le ()
symbol1' :: Text -> Parser le ()
symbol1' Text
str = Tokens Text -> Parser le ()
forall le. Tokens Text -> Parser le ()
symbol1 Text
Tokens Text
str Parser' le () -> Parser' le () -> Parser' le ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tokens Text -> Parser le ()
forall le. Tokens Text -> Parser le ()
symbol1 ((Char -> Char) -> Text -> Text
T.map Char -> Char
toLower Text
str)

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

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

string' :: Text -> Parser le Text
string' :: Text -> Parser le Text
string' Text
str = Tokens Text
-> ReaderT le (Parsec CustomParserException Text) (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Text
Tokens Text
str ReaderT le (Parsec CustomParserException Text) Text
-> ReaderT le (Parsec CustomParserException Text) Text
-> ReaderT le (Parsec CustomParserException Text) Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tokens Text
-> ReaderT le (Parsec CustomParserException Text) (Tokens Text)
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 le a -> Parser le a
parens :: Parser le a -> Parser le a
parens = ReaderT le (Parsec CustomParserException Text) ()
-> ReaderT le (Parsec CustomParserException Text) ()
-> ReaderT le (Parsec CustomParserException Text) a
-> ReaderT le (Parsec CustomParserException Text) a
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Tokens Text -> Parser le ()
forall le. Tokens Text -> Parser le ()
symbol Tokens Text
"(") (Tokens Text -> Parser le ()
forall le. Tokens Text -> Parser le ()
symbol Tokens Text
")")

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

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

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

semicolon :: Parser le ()
semicolon :: Parser' le ()
semicolon = Tokens Text -> Parser le ()
forall le. Tokens Text -> Parser le ()
symbol Tokens Text
";"

comma :: Parser le ()
comma :: Parser' le ()
comma = Tokens Text -> Parser le ()
forall le. Tokens Text -> Parser le ()
symbol Tokens Text
","

varID :: Parser le U.Var
varID :: Parser' le Var
varID = Parser le Var -> Parser le Var
forall le a. Parser le a -> Parser le a
lexeme (Parser le Var -> Parser le Var) -> Parser le Var -> Parser le Var
forall a b. (a -> b) -> a -> b
$ do
  Char
v <- ReaderT le (Parsec CustomParserException Text) Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
lowerChar
  [Char]
vs <- ReaderT le (Parsec CustomParserException Text) Char
-> ReaderT le (Parsec CustomParserException Text) [Char]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ReaderT le (Parsec CustomParserException Text) Char
forall le. Parser' le 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' le Char
    lowerAlphaNumChar :: Parser' le Char
lowerAlphaNumChar = (Token Text -> Bool)
-> ReaderT le (Parsec CustomParserException Text) (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy (\Token Text
x -> Char -> Bool
isLower Char
Token Text
x Bool -> Bool -> Bool
forall a. Boolean a => a -> a -> a
|| Char -> Bool
isDigit Char
Token Text
x)