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

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

module Michelson.Parser.Ext
  ( extInstr
  , stackType

  -- * For tests
  , printComment
  ) where

import Prelude hiding (try)

import Text.Megaparsec (choice, satisfy, try)
import Text.Megaparsec.Char (alphaNumChar, string)
import qualified Text.Megaparsec.Char.Lexer as L

import Michelson.Macro (ParsedOp(..), ParsedUExtInstr)
import Michelson.Parser.Lexer
import Michelson.Parser.Type
import Michelson.Parser.Types (Parser)
import qualified Michelson.Untyped as U

extInstr :: Parser [ParsedOp] -> Parser ParsedUExtInstr
extInstr :: Parser [ParsedOp] -> Parser ParsedUExtInstr
extInstr opsParser :: Parser [ParsedOp]
opsParser = [Parser ParsedUExtInstr] -> Parser ParsedUExtInstr
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [Parser ParsedUExtInstr
stackOp, Parser [ParsedOp] -> Parser ParsedUExtInstr
testAssertOp Parser [ParsedOp]
opsParser, Parser ParsedUExtInstr
printOp]

stackOp :: Parser ParsedUExtInstr
stackOp :: Parser ParsedUExtInstr
stackOp = Tokens Text
-> (StackTypePattern -> ParsedUExtInstr)
-> Parser (StackTypePattern -> ParsedUExtInstr)
forall a. Tokens Text -> a -> Parser a
word' "STACKTYPE" StackTypePattern -> ParsedUExtInstr
forall op. StackTypePattern -> ExtInstrAbstract op
U.STACKTYPE Parser (StackTypePattern -> ParsedUExtInstr)
-> ReaderT
     LetEnv (Parsec CustomParserException Text) StackTypePattern
-> Parser ParsedUExtInstr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReaderT LetEnv (Parsec CustomParserException Text) StackTypePattern
stackType

testAssertOp :: Parser [ParsedOp] -> Parser ParsedUExtInstr
testAssertOp :: Parser [ParsedOp] -> Parser ParsedUExtInstr
testAssertOp opsParser :: Parser [ParsedOp]
opsParser =
  Tokens Text
-> (TestAssert ParsedOp -> ParsedUExtInstr)
-> Parser (TestAssert ParsedOp -> ParsedUExtInstr)
forall a. Tokens Text -> a -> Parser a
word' "TEST_ASSERT" TestAssert ParsedOp -> ParsedUExtInstr
forall op. TestAssert op -> ExtInstrAbstract op
U.UTEST_ASSERT Parser (TestAssert ParsedOp -> ParsedUExtInstr)
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (TestAssert ParsedOp)
-> Parser ParsedUExtInstr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser [ParsedOp]
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (TestAssert ParsedOp)
testAssert Parser [ParsedOp]
opsParser

printOp :: Parser ParsedUExtInstr
printOp :: Parser ParsedUExtInstr
printOp = Tokens Text
-> (PrintComment -> ParsedUExtInstr)
-> Parser (PrintComment -> ParsedUExtInstr)
forall a. Tokens Text -> a -> Parser a
word' "PRINT" PrintComment -> ParsedUExtInstr
forall op. PrintComment -> ExtInstrAbstract op
U.UPRINT Parser (PrintComment -> ParsedUExtInstr)
-> ReaderT LetEnv (Parsec CustomParserException Text) PrintComment
-> Parser ParsedUExtInstr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReaderT LetEnv (Parsec CustomParserException Text) PrintComment
printComment

testAssert :: Parser [ParsedOp] -> Parser (U.TestAssert ParsedOp)
testAssert :: Parser [ParsedOp]
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (TestAssert ParsedOp)
testAssert opsParser :: Parser [ParsedOp]
opsParser = do
  Text
n <- Parser Text -> Parser Text
forall a. Parser a -> Parser a
lexeme ([Char] -> Text
forall a. ToText a => a -> Text
toText ([Char] -> Text)
-> ReaderT LetEnv (Parsec CustomParserException Text) [Char]
-> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT LetEnv (Parsec CustomParserException Text) Char
-> ReaderT LetEnv (Parsec CustomParserException Text) [Char]
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 [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 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 "\""
  let validChar :: Parser Text
validChar = [Char] -> Text
forall a. ToText a => a -> Text
toText ([Char] -> Text)
-> ReaderT LetEnv (Parsec CustomParserException Text) [Char]
-> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT LetEnv (Parsec CustomParserException Text) Char
-> ReaderT LetEnv (Parsec CustomParserException Text) [Char]
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 (\x :: Token Text
x -> Char
Token Text
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '%' Bool -> Bool -> Bool
&& Char
Token Text
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '"'))
  [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 Text
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (Either Text StackRef)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
validChar)
  Tokens Text -> Parser ()
symbol "\""
  return $ [Either Text StackRef] -> PrintComment
U.PrintComment [Either Text StackRef]
c

stackRef :: Parser 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 "%"
  Natural
n <- Parser Natural -> Parser Natural
forall a. Parser a -> Parser a
brackets' Parser 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 U.StackTypePattern
stackType :: ReaderT LetEnv (Parsec CustomParserException Text) StackTypePattern
stackType = Tokens Text -> Parser ()
symbol "'[" Parser ()
-> 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 ()
symbol "]" Parser ()
-> 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 ()
symbol "..." Parser ()
-> 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 ()
symbol "]" Parser ()
-> 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 TyVar
tyVar
      StackTypePattern
s <- (Tokens Text -> Parser ()
symbol "," Parser ()
-> 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 U.TyVar
tyVar :: Parser TyVar
tyVar = (Type -> TyVar
U.TyCon (Type -> TyVar)
-> ReaderT LetEnv (Parsec CustomParserException Text) Type
-> Parser TyVar
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT LetEnv (Parsec CustomParserException Text) Type
type_) Parser TyVar -> Parser TyVar -> Parser 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 TyVar
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT LetEnv (Parsec CustomParserException Text) Var
varID)