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

-- | 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 qualified Text.Megaparsec.Char.Lexer as L

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

extInstr :: Parser [ParsedOp] -> Parser ParsedUExtInstr
extInstr :: Parser [ParsedOp] -> Parser ParsedUExtInstr
extInstr Parser [ParsedOp]
opsParser = String -> Parser ParsedUExtInstr -> Parser ParsedUExtInstr
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"morley instruction" (Parser ParsedUExtInstr -> Parser ParsedUExtInstr)
-> Parser ParsedUExtInstr -> Parser ParsedUExtInstr
forall a b. (a -> b) -> a -> b
$ [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' Tokens Text
"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 Parser [ParsedOp]
opsParser =
  Tokens Text
-> (TestAssert ParsedOp -> ParsedUExtInstr)
-> Parser (TestAssert ParsedOp -> ParsedUExtInstr)
forall a. Tokens Text -> a -> Parser a
word' Tokens Text
"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' Tokens Text
"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 Parser [ParsedOp]
opsParser = do
  Text
n <- Parser Text -> Parser Text
forall a. Parser a -> Parser a
lexeme (String -> Text
forall a. ToText a => a -> Text
toText (String -> Text)
-> ReaderT LetEnv (Parsec CustomParserException Text) String
-> 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) 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 [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 Tokens Text
"\""
  let validChar :: Parser Text
validChar = String -> Text
forall a. ToText a => a -> Text
toText (String -> Text)
-> ReaderT LetEnv (Parsec CustomParserException Text) String
-> 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) 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 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 Tokens Text
"\""
  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 Tokens Text
"%"
  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 Tokens Text
"'[" 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 Tokens Text
"]" 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 Tokens Text
"..." 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 Tokens Text
"]" 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 Tokens Text
"," 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 = (Ty -> TyVar
U.TyCon (Ty -> TyVar)
-> ReaderT LetEnv (Parsec CustomParserException Text) Ty
-> Parser TyVar
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT LetEnv (Parsec CustomParserException Text) Ty
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)