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

-- | Parsing of Michelson instructions.

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

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

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

import Morley.Michelson.Macro (ParsedInstr, ParsedOp(..), ParsedSeq(..))
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 (Parser)
import Morley.Michelson.Parser.Value
import Morley.Michelson.Untyped

-- | Parser for primitive Michelson instruction (no macros and extensions).
primInstr :: Parser (Contract' ParsedOp) -> Parser (ParsedSeq ParsedOp) -> Parser ParsedInstr
primInstr contractParser opsParser = label "primitive instruction" $ choice
  [ dropOp, swapOp, digOp, dugOp, pushOp opsParser, someOp, noneOp, unitOp
  , ifNoneOp opsParser, leftOp, rightOp, ifLeftOp opsParser, nilOp
  , consOp, ifConsOp opsParser, sizeOp, emptySetOp, emptyMapOp, emptyBigMapOp, iterOp opsParser
  , memOp, getAndUpdateOp, getOp, updateOp, loopLOp opsParser, loopOp opsParser
  , lambdaOp opsParser, execOp, applyOp, dipOp opsParser, 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, cmpOp noteDef, 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, ticketDeprecatedOp, readTicketOp, splitTicketOp, joinTicketsOp
  , openChestOp
  , saplingEmptyStateOp, saplingVerifyUpdateOp, minBlockTimeOp
  , emitOp
  , lambdaRecOp opsParser
  , natOp, bytesOp
  ]

-- Control Structures

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

loopOp :: Parser (ParsedSeq ParsedOp) -> Parser ParsedInstr
loopOp opsParser = word "LOOP" LOOP <*> opsParser

loopLOp :: Parser (ParsedSeq ParsedOp) -> Parser ParsedInstr
loopLOp opsParser = word "LOOP_LEFT" LOOP_LEFT <*> opsParser

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

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

-- Parses both `DIP` and `DIP n`.
dipOp :: Parser (ParsedSeq ParsedOp) -> Parser ParsedInstr
dipOp opsParser = parseWithOptionalParameter "DIP" DIPN DIP <*> opsParser

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

-- Stack Operations

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

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

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

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

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

pushOp :: Parser (ParsedSeq ParsedOp) -> Parser ParsedInstr
pushOp opsParser = do
  symbol1 "PUSH"
  v <- noteDef
  push' v
  where
    push' :: VarAnn -> Parser ParsedInstr
    push' v = PUSH v <$> type_ <*> value' opsParser

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

lambdaOp :: Parser (ParsedSeq ParsedOp) -> Parser ParsedInstr
lambdaOp opsParser =
  word "LAMBDA" LAMBDA <*> noteDef <*> type_ <*> type_ <*> opsParser

lambdaRecOp :: Parser (ParsedSeq ParsedOp) -> Parser ParsedInstr
lambdaRecOp opsParser =
  word "LAMBDA_REC" LAMBDA_REC <*> noteDef <*> type_ <*> type_ <*> opsParser

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

cmpOp :: Parser VarAnn -> Parser ParsedInstr
cmpOp ann = (eqOp <|> neqOp <|> ltOp <|> gtOp <|> leOp <|> gtOp <|> geOp) <*> ann

eqOp :: Parser (VarAnn -> ParsedInstr)
eqOp = word "EQ" EQ

neqOp :: Parser (VarAnn -> ParsedInstr)
neqOp = word "NEQ" NEQ

ltOp :: Parser (VarAnn -> ParsedInstr)
ltOp = word "LT" LT

gtOp :: Parser (VarAnn -> ParsedInstr)
gtOp = word "GT" GT

leOp :: Parser (VarAnn -> ParsedInstr)
leOp = word "LE" LE

geOp :: Parser (VarAnn -> ParsedInstr)
geOp = word "GE" GE

-- ad-hoc comparison

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

-- Operations on booleans

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

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

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

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

-- Operations on integers and natural numbers

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

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

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

minBlockTimeOp :: Parser ParsedInstr
minBlockTimeOp = word "MIN_BLOCK_TIME" MIN_BLOCK_TIME <*> many anyNote

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

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

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

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

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

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

-- Bitwise logical operators

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

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

-- Operations on string's

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

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

-- Operations on pairs
pairOp :: Parser 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 Word)

  return $ PAIR t v p q

unpairOp :: Parser 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 Word)

  return $ UNPAIR vn1 vn2 fn1 fn2

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

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

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

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

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

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

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

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

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

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

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

iterOp :: Parser (ParsedSeq ParsedOp) -> Parser ParsedInstr
iterOp opsParser = word "ITER" ITER <*> opsParser

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

mapOp :: Parser (ParsedSeq ParsedOp) -> Parser ParsedInstr
mapOp opsParser = word "MAP" MAP <*>  noteDef <*> opsParser

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

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

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

ifConsOp :: Parser (ParsedSeq ParsedOp) -> Parser ParsedInstr
ifConsOp opsParser = word "IF_CONS" IF_CONS <*> opsParser <*> opsParser

-- Operations on options

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

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

ifNoneOp :: Parser (ParsedSeq ParsedOp) -> Parser ParsedInstr
ifNoneOp opsParser = word "IF_NONE" IF_NONE <*> opsParser <*> opsParser

-- Operations on unions

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

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

ifLeftOp :: Parser (ParsedSeq ParsedOp) -> Parser ParsedInstr
ifLeftOp opsParser = word "IF_LEFT" IF_LEFT <*> opsParser <*> opsParser

-- Operations on contracts

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

-- Special Operations

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

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

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

-- Operations on bytes

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

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

-- Cryptographic Primitives

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

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

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

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

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

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

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

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

-- Type operations

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

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

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

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

natOp :: Parser ParsedInstr
natOp = word "NAT" NAT <*> noteDef

bytesOp :: Parser ParsedInstr
bytesOp = word "BYTES" BYTES <*> noteDef

-- Ticket Operations

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

ticketDeprecatedOp :: Parser ParsedInstr
ticketDeprecatedOp = word "TICKET_DEPRECATED" TICKET_DEPRECATED <*> noteDef

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

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

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

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

emitOp :: Parser ParsedInstr
emitOp = word "EMIT" (uncurry EMIT) <*> notesVF <*> optional type_