{-# OPTIONS_GHC -Wno-deprecations #-}
module Morley.Michelson.Parser.Ext
( extInstr
, stackType
, printComment
) where
import Prelude hiding (try)
import Text.Megaparsec (choice, label, satisfy, try)
import Text.Megaparsec.Char (alphaNumChar, string)
import Text.Megaparsec.Char.Lexer qualified as L
import Morley.Michelson.Macro (ParsedOp(..), ParsedUExtInstr)
import Morley.Michelson.Parser.Lexer
import Morley.Michelson.Parser.Type
import Morley.Michelson.Parser.Types (LetEnv, Parser')
import Morley.Michelson.Untyped qualified as U
extInstr :: Parser' LetEnv [ParsedOp] -> Parser' LetEnv ParsedUExtInstr
extInstr :: Parser' LetEnv [ParsedOp] -> Parser' LetEnv ParsedUExtInstr
extInstr Parser' LetEnv [ParsedOp]
opsParser = do
String
-> Parser' LetEnv ParsedUExtInstr -> Parser' LetEnv ParsedUExtInstr
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"morley instruction" (Parser' LetEnv ParsedUExtInstr -> Parser' LetEnv ParsedUExtInstr)
-> Parser' LetEnv ParsedUExtInstr -> Parser' LetEnv ParsedUExtInstr
forall a b. (a -> b) -> a -> b
$ [Parser' LetEnv ParsedUExtInstr] -> Parser' LetEnv ParsedUExtInstr
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [Parser' LetEnv ParsedUExtInstr
stackOp, Parser' LetEnv [ParsedOp] -> Parser' LetEnv ParsedUExtInstr
testAssertOp Parser' LetEnv [ParsedOp]
opsParser, Parser' LetEnv ParsedUExtInstr
printOp]
stackOp :: Parser' LetEnv ParsedUExtInstr
stackOp :: Parser' LetEnv ParsedUExtInstr
stackOp = Tokens Text
-> (StackTypePattern -> ParsedUExtInstr)
-> Parser LetEnv (StackTypePattern -> ParsedUExtInstr)
forall a le. Tokens Text -> a -> Parser le a
word' Tokens Text
"STACKTYPE" StackTypePattern -> ParsedUExtInstr
forall op. StackTypePattern -> ExtInstrAbstract op
U.STACKTYPE Parser' LetEnv (StackTypePattern -> ParsedUExtInstr)
-> ReaderT
LetEnv (Parsec CustomParserException Text) StackTypePattern
-> Parser' LetEnv ParsedUExtInstr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReaderT LetEnv (Parsec CustomParserException Text) StackTypePattern
stackType
testAssertOp :: Parser' LetEnv [ParsedOp] -> Parser' LetEnv ParsedUExtInstr
testAssertOp :: Parser' LetEnv [ParsedOp] -> Parser' LetEnv ParsedUExtInstr
testAssertOp Parser' LetEnv [ParsedOp]
opsParser =
Tokens Text
-> (TestAssert ParsedOp -> ParsedUExtInstr)
-> Parser LetEnv (TestAssert ParsedOp -> ParsedUExtInstr)
forall a le. Tokens Text -> a -> Parser le a
word' Tokens Text
"TEST_ASSERT" TestAssert ParsedOp -> ParsedUExtInstr
forall op. TestAssert op -> ExtInstrAbstract op
U.UTEST_ASSERT Parser' LetEnv (TestAssert ParsedOp -> ParsedUExtInstr)
-> ReaderT
LetEnv (Parsec CustomParserException Text) (TestAssert ParsedOp)
-> Parser' LetEnv ParsedUExtInstr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser' LetEnv [ParsedOp]
-> ReaderT
LetEnv (Parsec CustomParserException Text) (TestAssert ParsedOp)
testAssert Parser' LetEnv [ParsedOp]
opsParser
printOp :: Parser' LetEnv ParsedUExtInstr
printOp :: Parser' LetEnv ParsedUExtInstr
printOp = Tokens Text
-> (PrintComment -> ParsedUExtInstr)
-> Parser LetEnv (PrintComment -> ParsedUExtInstr)
forall a le. Tokens Text -> a -> Parser le a
word' Tokens Text
"PRINT" PrintComment -> ParsedUExtInstr
forall op. PrintComment -> ExtInstrAbstract op
U.UPRINT Parser' LetEnv (PrintComment -> ParsedUExtInstr)
-> ReaderT LetEnv (Parsec CustomParserException Text) PrintComment
-> Parser' LetEnv ParsedUExtInstr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReaderT LetEnv (Parsec CustomParserException Text) PrintComment
printComment
testAssert :: Parser' LetEnv [ParsedOp] -> Parser' LetEnv (U.TestAssert ParsedOp)
testAssert :: Parser' LetEnv [ParsedOp]
-> ReaderT
LetEnv (Parsec CustomParserException Text) (TestAssert ParsedOp)
testAssert Parser' LetEnv [ParsedOp]
opsParser = do
Text
n <- Parser LetEnv Text -> Parser LetEnv Text
forall le a. Parser le a -> Parser le a
lexeme (String -> Text
forall a. ToText a => a -> Text
toText (String -> Text)
-> ReaderT LetEnv (Parsec CustomParserException Text) String
-> Parser' LetEnv Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT LetEnv (Parsec CustomParserException Text) Char
-> ReaderT LetEnv (Parsec CustomParserException Text) String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ReaderT LetEnv (Parsec CustomParserException Text) Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
alphaNumChar)
PrintComment
c <- ReaderT LetEnv (Parsec CustomParserException Text) PrintComment
printComment
[ParsedOp]
o <- Parser' LetEnv [ParsedOp]
opsParser
return $ Text -> PrintComment -> [ParsedOp] -> TestAssert ParsedOp
forall op. Text -> PrintComment -> [op] -> TestAssert op
U.TestAssert Text
n PrintComment
c [ParsedOp]
o
printComment :: Parser' LetEnv U.PrintComment
= do
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
"\""
let validChar :: Parser' LetEnv Text
validChar = String -> Text
forall a. ToText a => a -> Text
toText (String -> Text)
-> ReaderT LetEnv (Parsec CustomParserException Text) String
-> Parser' LetEnv Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT LetEnv (Parsec CustomParserException Text) Char
-> ReaderT LetEnv (Parsec CustomParserException Text) String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ((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 (\Token Text
x -> Char
Token Text
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'%' Bool -> Bool -> Bool
forall a. Boolean a => a -> a -> a
&& Char
Token Text
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'"'))
[Either Text StackRef]
c <- ReaderT
LetEnv (Parsec CustomParserException Text) (Either Text StackRef)
-> ReaderT
LetEnv (Parsec CustomParserException Text) [Either Text StackRef]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (StackRef -> Either Text StackRef
forall a b. b -> Either a b
Right (StackRef -> Either Text StackRef)
-> ReaderT LetEnv (Parsec CustomParserException Text) StackRef
-> ReaderT
LetEnv (Parsec CustomParserException Text) (Either Text StackRef)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT LetEnv (Parsec CustomParserException Text) StackRef
stackRef ReaderT
LetEnv (Parsec CustomParserException Text) (Either Text StackRef)
-> ReaderT
LetEnv (Parsec CustomParserException Text) (Either Text StackRef)
-> ReaderT
LetEnv (Parsec CustomParserException Text) (Either Text StackRef)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Either Text StackRef
forall a b. a -> Either a b
Left (Text -> Either Text StackRef)
-> Parser' LetEnv Text
-> ReaderT
LetEnv (Parsec CustomParserException Text) (Either Text StackRef)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser' LetEnv Text
validChar)
Tokens Text -> Parser LetEnv ()
forall le. Tokens Text -> Parser le ()
symbol Tokens Text
"\""
return $ [Either Text StackRef] -> PrintComment
U.PrintComment [Either Text StackRef]
c
stackRef :: Parser' LetEnv U.StackRef
stackRef :: ReaderT LetEnv (Parsec CustomParserException Text) StackRef
stackRef = do
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
"%"
Natural
n <- Parser LetEnv Natural -> Parser LetEnv Natural
forall le a. Parser le a -> Parser le a
brackets' Parser LetEnv Natural
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
L.decimal
return $ Natural -> StackRef
U.StackRef Natural
n
stackType :: Parser' LetEnv U.StackTypePattern
stackType :: ReaderT LetEnv (Parsec CustomParserException Text) StackTypePattern
stackType = do
Tokens Text -> Parser LetEnv ()
forall le. Tokens Text -> Parser le ()
symbol Tokens Text
"'[" Parser' LetEnv ()
-> ReaderT
LetEnv (Parsec CustomParserException Text) StackTypePattern
-> ReaderT
LetEnv (Parsec CustomParserException Text) StackTypePattern
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (ReaderT LetEnv (Parsec CustomParserException Text) StackTypePattern
emptyStk ReaderT LetEnv (Parsec CustomParserException Text) StackTypePattern
-> ReaderT
LetEnv (Parsec CustomParserException Text) StackTypePattern
-> ReaderT
LetEnv (Parsec CustomParserException Text) StackTypePattern
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReaderT LetEnv (Parsec CustomParserException Text) StackTypePattern
stkCons ReaderT LetEnv (Parsec CustomParserException Text) StackTypePattern
-> ReaderT
LetEnv (Parsec CustomParserException Text) StackTypePattern
-> ReaderT
LetEnv (Parsec CustomParserException Text) StackTypePattern
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReaderT LetEnv (Parsec CustomParserException Text) StackTypePattern
stkRest)
where
emptyStk :: ReaderT LetEnv (Parsec CustomParserException Text) StackTypePattern
emptyStk = ReaderT LetEnv (Parsec CustomParserException Text) StackTypePattern
-> ReaderT
LetEnv (Parsec CustomParserException Text) StackTypePattern
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ReaderT
LetEnv (Parsec CustomParserException Text) StackTypePattern
-> ReaderT
LetEnv (Parsec CustomParserException Text) StackTypePattern)
-> ReaderT
LetEnv (Parsec CustomParserException Text) StackTypePattern
-> ReaderT
LetEnv (Parsec CustomParserException Text) StackTypePattern
forall a b. (a -> b) -> a -> b
$ Tokens Text -> Parser LetEnv ()
forall le. Tokens Text -> Parser le ()
symbol Tokens Text
"]" Parser' LetEnv ()
-> StackTypePattern
-> ReaderT
LetEnv (Parsec CustomParserException Text) StackTypePattern
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> StackTypePattern
U.StkEmpty
stkRest :: ReaderT LetEnv (Parsec CustomParserException Text) StackTypePattern
stkRest = ReaderT LetEnv (Parsec CustomParserException Text) StackTypePattern
-> ReaderT
LetEnv (Parsec CustomParserException Text) StackTypePattern
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ReaderT
LetEnv (Parsec CustomParserException Text) StackTypePattern
-> ReaderT
LetEnv (Parsec CustomParserException Text) StackTypePattern)
-> ReaderT
LetEnv (Parsec CustomParserException Text) StackTypePattern
-> ReaderT
LetEnv (Parsec CustomParserException Text) StackTypePattern
forall a b. (a -> b) -> a -> b
$ Tokens Text -> Parser LetEnv ()
forall le. Tokens Text -> Parser le ()
symbol Tokens Text
"..." Parser' LetEnv ()
-> ReaderT
LetEnv (Parsec CustomParserException Text) StackTypePattern
-> ReaderT
LetEnv (Parsec CustomParserException Text) StackTypePattern
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Tokens Text -> Parser LetEnv ()
forall le. Tokens Text -> Parser le ()
symbol Tokens Text
"]" Parser' LetEnv ()
-> StackTypePattern
-> ReaderT
LetEnv (Parsec CustomParserException Text) StackTypePattern
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> StackTypePattern
U.StkRest
stkCons :: ReaderT LetEnv (Parsec CustomParserException Text) StackTypePattern
stkCons = ReaderT LetEnv (Parsec CustomParserException Text) StackTypePattern
-> ReaderT
LetEnv (Parsec CustomParserException Text) StackTypePattern
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ReaderT
LetEnv (Parsec CustomParserException Text) StackTypePattern
-> ReaderT
LetEnv (Parsec CustomParserException Text) StackTypePattern)
-> ReaderT
LetEnv (Parsec CustomParserException Text) StackTypePattern
-> ReaderT
LetEnv (Parsec CustomParserException Text) StackTypePattern
forall a b. (a -> b) -> a -> b
$ do
TyVar
t <- Parser' LetEnv TyVar
tyVar
StackTypePattern
s <- (Tokens Text -> Parser LetEnv ()
forall le. Tokens Text -> Parser le ()
symbol Tokens Text
"," Parser' LetEnv ()
-> ReaderT
LetEnv (Parsec CustomParserException Text) StackTypePattern
-> ReaderT
LetEnv (Parsec CustomParserException Text) StackTypePattern
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ReaderT LetEnv (Parsec CustomParserException Text) StackTypePattern
stkCons ReaderT LetEnv (Parsec CustomParserException Text) StackTypePattern
-> ReaderT
LetEnv (Parsec CustomParserException Text) StackTypePattern
-> ReaderT
LetEnv (Parsec CustomParserException Text) StackTypePattern
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReaderT LetEnv (Parsec CustomParserException Text) StackTypePattern
stkRest) ReaderT LetEnv (Parsec CustomParserException Text) StackTypePattern
-> ReaderT
LetEnv (Parsec CustomParserException Text) StackTypePattern
-> ReaderT
LetEnv (Parsec CustomParserException Text) StackTypePattern
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReaderT LetEnv (Parsec CustomParserException Text) StackTypePattern
emptyStk
return $ TyVar -> StackTypePattern -> StackTypePattern
U.StkCons TyVar
t StackTypePattern
s
tyVar :: Parser' LetEnv U.TyVar
tyVar :: Parser' LetEnv TyVar
tyVar = (Ty -> TyVar
U.TyCon (Ty -> TyVar)
-> ReaderT LetEnv (Parsec CustomParserException Text) Ty
-> Parser' LetEnv TyVar
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT LetEnv (Parsec CustomParserException Text) Ty
forall le. Parser le Ty
type_) Parser' LetEnv TyVar
-> Parser' LetEnv TyVar -> Parser' LetEnv TyVar
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Var -> TyVar
U.VarID (Var -> TyVar)
-> ReaderT LetEnv (Parsec CustomParserException Text) Var
-> Parser' LetEnv TyVar
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT LetEnv (Parsec CustomParserException Text) Var
forall le. Parser le Var
varID)