Instr.hs

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

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

-- | Parsing of Michelson instructions.

module Morley.Michelson.Parser.Instr
  ( primInstr
  , ops'
  -- * These are handled separately to have better error messages
  , mapOp
  , pairOp
  , unpairOp
  , pairNOp
  , cmpOp
  , dupOp
  , carOp
  , cdrOp
  , viewOp
  ) where

import Prelude hiding (EQ, GT, LT, many, note, some, try)

import Text.Megaparsec (choice, label, notFollowedBy, try)
import Text.Megaparsec.Char.Lexer qualified as L

import Morley.Michelson.Let (LetValue(..))
import Morley.Michelson.Macro (ParsedInstr, ParsedOp(..))
import Morley.Michelson.Parser.Annotations
import Morley.Michelson.Parser.Common
import Morley.Michelson.Parser.Lexer
import Morley.Michelson.Parser.Type
import Morley.Michelson.Parser.Types (LetEnv, Parser, Parser', letValues, withLetEnv)
import Morley.Michelson.Parser.Value
import Morley.Michelson.Untyped

-- | Parser for primitive Michelson instruction (no macros and extensions).
primInstr :: Parser' le (Contract' ParsedOp) -> Parser' le ParsedOp -> Parser le ParsedInstr
primInstr contractParser opParser = label "primitive instruction" $ choice
  [ dropOp, swapOp, digOp, dugOp, pushOp opParser, someOp, noneOp, unitOp
  , ifNoneOp opParser, leftOp, rightOp, ifLeftOp opParser, nilOp
  , consOp, ifConsOp opParser, sizeOp, emptySetOp, emptyMapOp, emptyBigMapOp, iterOp opParser
  , memOp, getAndUpdateOp, getOp, updateOp, loopLOp opParser, loopOp opParser
  , lambdaOp opParser, execOp, applyOp, dipOp opParser, failWithOp, castOp, renameOp, levelOp
  , concatOp, packOp, unpackOp, sliceOp, isNatOp, addressOp, selfAddressOp, addOp, subOp
  , subMutezOp, mulOp, edivOp, absOp, negOp, lslOp, lsrOp, orOp, andOp, xorOp, notOp
  , compareOp, eqOp, neqOp, ltOp, leOp, gtOp, geOp, intOp, viewOp, selfOp, contractOp
  , transferTokensOp, setDelegateOp
  , createContractOp contractParser, implicitAccountOp, nowOp, amountOp
  , balanceOp, checkSigOp, sha256Op, sha512Op, blake2BOp, hashKeyOp, pairingCheckOp
  , sourceOp, senderOp, chainIdOp, sha3Op, keccakOp, neverOp
  , votingPowerOp, totalVotingPowerOp, try unpairNOp
  , unpairOp
  , ticketOp, readTicketOp, splitTicketOp, joinTicketsOp
  , openChestOp
  , saplingEmptyStateOp, saplingVerifyUpdateOp
  ]

-- | Parse a sequence of instructions.
ops' :: Parser' le ParsedOp -> Parser le [ParsedOp]
ops' opParser = (braces $ parseSeq) <|> (pure <$> opParser)
  where
    parseSeq =
      do{ op <- opParser
        ; let separator = case op of
                Seq _ _ -> void (optional semicolon)
                _       -> semicolon
        ; do{ _ <- separator
            ; ops <- parseSeq
            ; return (op:ops)
            }
           <|> return [op]
      }
      <|> return []


-- Control Structures

failWithOp :: Parser le ParsedInstr
failWithOp = word' "FAILWITH" FAILWITH

loopOp :: Parser' le ParsedOp -> Parser le ParsedInstr
loopOp opParser = word' "LOOP" LOOP <*> ops' opParser

loopLOp :: Parser' le ParsedOp -> Parser le ParsedInstr
loopLOp opParser = word' "LOOP_LEFT" LOOP_LEFT <*> ops' opParser

execOp :: Parser le ParsedInstr
execOp = word' "EXEC" EXEC <*> noteDef

applyOp :: Parser le ParsedInstr
applyOp = word' "APPLY" APPLY <*> noteDef

-- Parses both `DIP` and `DIP n`.
dipOp :: Parser' le ParsedOp -> Parser le ParsedInstr
dipOp opParser = parseWithOptionalParameter "DIP" DIPN DIP <*> ops' opParser

-- Helper for instructions which have optional numeric non-negative parameter.
parseWithOptionalParameter :: Text -> (Word -> instr) -> instr -> Parser le instr
parseWithOptionalParameter instrName constructorWithParam constructorNoParam =
  symbol1' instrName *>
  (try (constructorWithParam <$> lexeme L.decimal) <|> pure constructorNoParam)

-- Stack Operations

-- Parses both `DROP` and `DROP n`.
dropOp :: Parser le ParsedInstr
dropOp = parseWithOptionalParameter "DROP" DROPN DROP

dupOp :: Parser le ParsedInstr
dupOp = do
  symbol1' "DUP"
  varAnn <- noteDef
  optional (lexeme L.decimal) <&> maybe (DUP varAnn) (DUPN varAnn)

swapOp :: Parser le ParsedInstr
swapOp = word' "SWAP" SWAP

digOp :: Parser le ParsedInstr
digOp = word' "DIG" DIG <*> lexeme L.decimal

dugOp :: Parser le ParsedInstr
dugOp = word' "DUG" DUG <*> lexeme L.decimal

pushOp :: forall le. Parser' le ParsedOp -> Parser le ParsedInstr
pushOp opParser = do
  symbol1' "PUSH"
  v <- noteDef
  (try $ withLetEnv $ pushLet v) <|> (push' v)
  where
    pushLet :: VarAnn -> Parser' LetEnv ParsedInstr
    pushLet v = do
      lvs <- asks letValues
      lv <- mkLetVal lvs
      return $ PUSH v (lvSig lv) (lvVal lv)
    push' :: VarAnn -> Parser le ParsedInstr
    push' v = PUSH v <$> type_ <*> value' opParser

unitOp :: Parser le ParsedInstr
unitOp = do symbol1' "UNIT"; (t, v) <- notesTV; return $ UNIT t v

lambdaOp :: Parser' le ParsedOp -> Parser le ParsedInstr
lambdaOp opParser =
  word' "LAMBDA" LAMBDA <*> noteDef <*> type_ <*> type_ <*> ops' opParser

neverOp :: Parser le ParsedInstr
neverOp = word' "NEVER" NEVER
-- Generic comparison

cmpOp :: Parser le ParsedInstr
cmpOp = eqOp <|> neqOp <|> ltOp <|> gtOp <|> leOp <|> gtOp <|> geOp

eqOp :: Parser le ParsedInstr
eqOp = word' "EQ" EQ <*> noteDef

neqOp :: Parser le ParsedInstr
neqOp = word' "NEQ" NEQ <*> noteDef

ltOp :: Parser le ParsedInstr
ltOp = word' "LT" LT <*> noteDef

gtOp :: Parser le ParsedInstr
gtOp = word' "GT" GT <*> noteDef

leOp :: Parser le ParsedInstr
leOp = word' "LE" LE <*> noteDef

geOp :: Parser le ParsedInstr
geOp = word' "GE" GE <*> noteDef

-- ad-hoc comparison

compareOp :: Parser le ParsedInstr
compareOp = word' "COMPARE" COMPARE <*> noteDef

-- Operations on booleans

orOp :: Parser le ParsedInstr
orOp = word' "OR"  OR <*> noteDef

andOp :: Parser le ParsedInstr
andOp = word' "AND" AND <*> noteDef

xorOp :: Parser le ParsedInstr
xorOp = word' "XOR" XOR <*> noteDef

notOp :: Parser le ParsedInstr
notOp = word' "NOT" NOT <*> noteDef

-- Operations on integers and natural numbers

addOp :: Parser le ParsedInstr
addOp = word' "ADD" ADD <*> noteDef

saplingEmptyStateOp :: Parser le ParsedInstr
saplingEmptyStateOp = word' "SAPLING_EMPTY_STATE" SAPLING_EMPTY_STATE <*> noteDef <*> lexeme L.decimal

saplingVerifyUpdateOp :: Parser le ParsedInstr
saplingVerifyUpdateOp = word' "SAPLING_VERIFY_UPDATE" SAPLING_VERIFY_UPDATE <*> noteDef

subOp :: Parser le ParsedInstr
subOp = word' "SUB" SUB <*> noteDef

subMutezOp :: Parser le ParsedInstr
subMutezOp = word' "SUB_MUTEZ" SUB_MUTEZ <*> noteDef

mulOp :: Parser le ParsedInstr
mulOp = word' "MUL" MUL <*> noteDef

edivOp :: Parser le ParsedInstr
edivOp = word' "EDIV" EDIV <*> noteDef

absOp :: Parser le ParsedInstr
absOp = word' "ABS" ABS <*> noteDef

negOp :: Parser le ParsedInstr
negOp = word' "NEG" NEG <*> noteDef

-- Bitwise logical operators

lslOp :: Parser le ParsedInstr
lslOp = word' "LSL" LSL <*> noteDef

lsrOp :: Parser le ParsedInstr
lsrOp = word' "LSR" LSR <*> noteDef

-- Operations on string's

concatOp :: Parser le ParsedInstr
concatOp = word' "CONCAT" CONCAT <*> noteDef

sliceOp :: Parser le ParsedInstr
sliceOp = word' "SLICE" SLICE <*> noteDef

-- Operations on pairs
pairOp :: Parser le ParsedInstr
pairOp = do
  symbol1' "PAIR"
  (t, v, (p, q)) <- notesTVF2Def

  -- Make sure this is a `PAIR` instruction,
  -- and not a `PAIR n` instruction.
  notFollowedBy (lexeme L.decimal :: Parser le Word)

  return $ PAIR t v p q

unpairOp :: Parser le ParsedInstr
unpairOp = do
  symbol1' "UNPAIR"
  ((vn1, vn2), (fn1, fn2)) <- notesVVFF

  -- Make sure this is an `UNPAIR` instruction,
  -- and not an `UNPAIR n` instruction.
  notFollowedBy (lexeme L.decimal :: Parser le Word)

  return $ UNPAIR vn1 vn2 fn1 fn2

pairNOp :: Parser le ParsedInstr
pairNOp = do
  symbol1' "PAIR"
  PAIRN
    <$> noteDef
    <*> lexeme L.decimal

unpairNOp :: Parser le ParsedInstr
unpairNOp =
  word' "UNPAIR" UNPAIRN <*> lexeme L.decimal

carOp :: Parser le ParsedInstr
carOp = do symbol1' "CAR"; (v, f) <- notesVF; return $ CAR v f

cdrOp :: Parser le ParsedInstr
cdrOp = do symbol1' "CDR"; (v, f) <- notesVF; return $ CDR v f

-- Operations on collections (sets, maps, lists)

emptySetOp :: Parser le ParsedInstr
emptySetOp = do symbol1' "EMPTY_SET"; (t, v) <- notesTV;
                EMPTY_SET t v <$> type_

emptyMapOp :: Parser le ParsedInstr
emptyMapOp = do symbol1' "EMPTY_MAP"; (t, v) <- notesTV; a <- type_;
                EMPTY_MAP t v a <$> type_

emptyBigMapOp :: Parser le ParsedInstr
emptyBigMapOp = do symbol1' "EMPTY_BIG_MAP"; (t, v) <- notesTV; a <- type_;
                   EMPTY_BIG_MAP t v a <$> type_

memOp :: Parser le ParsedInstr
memOp = word' "MEM" MEM <*> noteDef

updateOp :: Parser le ParsedInstr
updateOp = do
  symbol1' "UPDATE"
  varAnn <- noteDef
  ix <- optional (lexeme L.decimal)
  pure $ maybe (UPDATE varAnn) (UPDATEN varAnn) ix

getAndUpdateOp :: Parser le ParsedInstr
getAndUpdateOp = word' "GET_AND_UPDATE" GET_AND_UPDATE <*> noteDef

iterOp :: Parser' le ParsedOp -> Parser le ParsedInstr
iterOp opParser = word' "ITER" ITER <*> ops' opParser

sizeOp :: Parser le ParsedInstr
sizeOp = word' "SIZE" SIZE <*> noteDef

mapOp :: Parser' le ParsedOp -> Parser le ParsedInstr
mapOp opParser = word' "MAP" MAP <*>  noteDef <*> ops' opParser

getOp :: Parser le ParsedInstr
getOp = do
  symbol1' "GET"
  varAnn <- noteDef
  ix <- optional (lexeme L.decimal)
  pure $ maybe (GET varAnn) (GETN varAnn) ix

nilOp :: Parser le ParsedInstr
nilOp = do symbol1' "NIL"; (t, v) <- notesTV; NIL t v <$> type_

consOp :: Parser le ParsedInstr
consOp = word' "CONS" CONS <*> noteDef

ifConsOp :: Parser' le ParsedOp -> Parser le ParsedInstr
ifConsOp opParser = word' "IF_CONS" IF_CONS <*> ops' opParser <*> ops' opParser

-- Operations on options

someOp :: Parser le ParsedInstr
someOp = do symbol1' "SOME"; (t, v) <- notesTV; return $ SOME t v

noneOp :: Parser le ParsedInstr
noneOp = do symbol1' "NONE"; (t, v) <- notesTV; NONE t v <$> type_

ifNoneOp :: Parser' le ParsedOp -> Parser le ParsedInstr
ifNoneOp opParser = word' "IF_NONE" IF_NONE <*> ops' opParser <*> ops' opParser

-- Operations on unions

leftOp :: Parser le ParsedInstr
leftOp = do symbol1' "LEFT"; (t, v, (f, f')) <- notesTVF2Def;
               LEFT t v f f' <$> type_

rightOp :: Parser le ParsedInstr
rightOp = do symbol1' "RIGHT"; (t, v, (f, f')) <- notesTVF2Def;
               RIGHT t v f f' <$> type_

ifLeftOp :: Parser' le ParsedOp -> Parser le ParsedInstr
ifLeftOp opParser = word' "IF_LEFT" IF_LEFT <*> ops' opParser <*> ops' opParser

-- Operations on contracts

createContractOp :: Parser le (Contract' ParsedOp) -> Parser le ParsedInstr
createContractOp contractParser =
  word' "CREATE_CONTRACT" CREATE_CONTRACT
    <*> noteDef <*> noteDef <*> braces contractParser

transferTokensOp :: Parser le ParsedInstr
transferTokensOp = word' "TRANSFER_TOKENS" TRANSFER_TOKENS <*> noteDef

setDelegateOp :: Parser le ParsedInstr
setDelegateOp = word' "SET_DELEGATE" SET_DELEGATE <*> noteDef

balanceOp :: Parser le ParsedInstr
balanceOp = word' "BALANCE" BALANCE <*> noteDef

contractOp :: Parser le ParsedInstr
contractOp = word' "CONTRACT" CONTRACT <*> noteDef <*> noteDef <*> type_

sourceOp :: Parser le ParsedInstr
sourceOp = word' "SOURCE" SOURCE <*> noteDef

senderOp :: Parser le ParsedInstr
senderOp = word' "SENDER" SENDER <*> noteDef

amountOp :: Parser le ParsedInstr
amountOp = word' "AMOUNT" AMOUNT <*> noteDef

votingPowerOp :: Parser le ParsedInstr
votingPowerOp = word' "VOTING_POWER" VOTING_POWER <*> noteDef

totalVotingPowerOp :: Parser le ParsedInstr
totalVotingPowerOp = word' "TOTAL_VOTING_POWER" TOTAL_VOTING_POWER <*> noteDef

implicitAccountOp :: Parser le ParsedInstr
implicitAccountOp = word' "IMPLICIT_ACCOUNT" IMPLICIT_ACCOUNT <*> noteDef

viewOp :: Parser le ParsedInstr
viewOp =
  -- @VIEW_@ A1 macro should not be parsed by this
  word' "VIEW" VIEW <*> noteDef <*> viewName_ <*> type_

selfOp :: Parser le ParsedInstr
selfOp = word' "SELF" SELF <*> noteDef <*> noteDef

addressOp :: Parser le ParsedInstr
addressOp = word' "ADDRESS" ADDRESS <*> noteDef

selfAddressOp :: Parser le ParsedInstr
selfAddressOp = word' "SELF_ADDRESS" SELF_ADDRESS <*> noteDef

-- Special Operations

nowOp :: Parser le ParsedInstr
nowOp = word' "NOW" NOW <*> noteDef

levelOp :: Parser le ParsedInstr
levelOp = word' "LEVEL" LEVEL <*> noteDef

chainIdOp :: Parser le ParsedInstr
chainIdOp = word' "CHAIN_ID" CHAIN_ID <*> noteDef

-- Operations on bytes

packOp :: Parser le ParsedInstr
packOp = word' "PACK" PACK <*> noteDef

unpackOp :: Parser le ParsedInstr
unpackOp = do symbol1' "UNPACK"; (t, v) <- notesTV; UNPACK t v <$> type_

-- Cryptographic Primitives

checkSigOp :: Parser le ParsedInstr
checkSigOp = word' "CHECK_SIGNATURE" CHECK_SIGNATURE <*> noteDef

blake2BOp :: Parser le ParsedInstr
blake2BOp = word' "BLAKE2B" BLAKE2B <*> noteDef

sha256Op :: Parser le ParsedInstr
sha256Op = word' "SHA256" SHA256 <*> noteDef

sha512Op :: Parser le ParsedInstr
sha512Op = word' "SHA512" SHA512 <*> noteDef

sha3Op :: Parser le ParsedInstr
sha3Op = word' "SHA3" SHA3 <*> noteDef

keccakOp :: Parser le ParsedInstr
keccakOp = word' "KECCAK" KECCAK <*> noteDef

hashKeyOp :: Parser le ParsedInstr
hashKeyOp = word' "HASH_KEY" HASH_KEY <*> noteDef

pairingCheckOp :: Parser le ParsedInstr
pairingCheckOp = word' "PAIRING_CHECK" PAIRING_CHECK <*> noteDef

-- Type operations

castOp :: Parser le ParsedInstr
castOp = word' "CAST" CAST <*> noteDef <*> type_

renameOp :: Parser le ParsedInstr
renameOp = word' "RENAME" RENAME <*> noteDef

isNatOp :: Parser le ParsedInstr
isNatOp = word' "ISNAT" ISNAT <*> noteDef

intOp :: Parser le ParsedInstr
intOp = word' "INT" INT <*> noteDef

-- Ticket Operations

ticketOp :: Parser le ParsedInstr
ticketOp = word' "TICKET" TICKET <*> noteDef

readTicketOp :: Parser le ParsedInstr
readTicketOp = word' "READ_TICKET" READ_TICKET <*> noteDef

splitTicketOp :: Parser le ParsedInstr
splitTicketOp = word' "SPLIT_TICKET" SPLIT_TICKET <*> noteDef

joinTicketsOp :: Parser le ParsedInstr
joinTicketsOp = word' "JOIN_TICKETS" JOIN_TICKETS <*> noteDef

openChestOp :: Parser le ParsedInstr
openChestOp = word' "OPEN_CHEST" OPEN_CHEST <*> noteDef