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

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

-- | Parsing logic for extra instructions (Morley extensions)

module Morley.Michelson.Parser.Ext
  ( extInstr
  , stackType

  -- * For tests
  , 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
printComment :: ReaderT LetEnv (Parsec CustomParserException Text) PrintComment
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)