Ext.hs

-- 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 opsParser = do
  label "morley instruction" $ choice [stackOp, testAssertOp opsParser, printOp]

stackOp :: Parser' LetEnv ParsedUExtInstr
stackOp = word' "STACKTYPE" U.STACKTYPE <*> stackType

testAssertOp :: Parser' LetEnv [ParsedOp] -> Parser' LetEnv ParsedUExtInstr
testAssertOp opsParser =
  word' "TEST_ASSERT" U.UTEST_ASSERT <*> testAssert opsParser

printOp :: Parser' LetEnv ParsedUExtInstr
printOp = word' "PRINT" U.UPRINT <*> printComment

testAssert :: Parser' LetEnv [ParsedOp] -> Parser' LetEnv (U.TestAssert ParsedOp)
testAssert opsParser = do
  n <- lexeme (toText <$> some alphaNumChar)
  c <- printComment
  o <- opsParser
  return $ U.TestAssert n c o

printComment :: Parser' LetEnv U.PrintComment
printComment = do
  string "\""
  let validChar = toText <$> some (satisfy (\x -> x /= '%' && x /= '"'))
  c <- many (Right <$> stackRef <|> Left <$> validChar)
  symbol "\""
  return $ U.PrintComment c

stackRef :: Parser' LetEnv U.StackRef
stackRef = do
  string "%"
  n <- brackets' L.decimal
  return $ U.StackRef n

stackType :: Parser' LetEnv U.StackTypePattern
stackType = do
  symbol "'[" >> (emptyStk <|> stkCons <|> stkRest)
  where
    emptyStk = try $ symbol "]" $> U.StkEmpty
    stkRest = try $ symbol "..." >> symbol "]" $> U.StkRest
    stkCons = try $ do
      t <- tyVar
      s <- (symbol "," >> stkCons <|> stkRest) <|> emptyStk
      return $ U.StkCons t s

tyVar :: Parser' LetEnv U.TyVar
tyVar = (U.TyCon <$> type_) <|> (U.VarID <$> varID)