-- | Parsing of Michelson instructions.

module Michelson.Parser.Instr
  ( primInstr
  , ops'
  -- * These are handled separately to have better error messages
  , mapOp
  , pairOp
  , cmpOp
  ) where

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

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

import Michelson.Let (LetValue(..))
import Michelson.Macro (ParsedInstr, ParsedOp(..))
import Michelson.Parser.Annotations
import Michelson.Parser.Lexer
import Michelson.Parser.Type
import Michelson.Parser.Types (Parser, letValues)
import Michelson.Parser.Value
import Michelson.Untyped

-- | Parser for primitive Michelson instruction (no macros and extensions).
primInstr :: Parser (Contract' ParsedOp) -> Parser ParsedOp -> Parser ParsedInstr
primInstr contractParser opParser = choice
  [ dropOp, dupOp, swapOp, digOp, dugOp, pushOp opParser, someOp, noneOp, unitOp
  , ifNoneOp opParser, carOp, cdrOp, leftOp, rightOp, ifLeftOp opParser, nilOp
  , consOp, ifConsOp opParser, sizeOp, emptySetOp, emptyMapOp, emptyBigMapOp, iterOp opParser
  , memOp, getOp, updateOp, loopLOp opParser, loopOp opParser
  , lambdaOp opParser, execOp, applyOp, dipOp opParser, failWithOp, castOp, renameOp
  , concatOp, packOp, unpackOp, sliceOp, isNatOp, addressOp, addOp, subOp
  , mulOp, edivOp, absOp, negOp, lslOp, lsrOp, orOp, andOp, xorOp, notOp
  , compareOp, eqOp, neqOp, ltOp, leOp, gtOp, geOp, intOp, selfOp, contractOp
  , transferTokensOp, setDelegateOp
  , createContractOp contractParser, implicitAccountOp, nowOp, amountOp
  , balanceOp, checkSigOp, sha256Op, sha512Op, blake2BOp, hashKeyOp
  , stepsToQuotaOp, sourceOp, senderOp, chainIdOp
  ]

-- | Parse a sequence of instructions.
ops' :: Parser ParsedOp -> Parser [ParsedOp]
ops' opParser = (braces $ sepEndBy opParser semicolon) <|> (pure <$> opParser)

-- Control Structures

failWithOp :: Parser ParsedInstr
failWithOp = do symbol' "FAILWITH"; return FAILWITH

loopOp :: Parser ParsedOp -> Parser ParsedInstr
loopOp opParser = do void $ symbol' "LOOP"; LOOP <$> ops' opParser

loopLOp :: Parser ParsedOp -> Parser ParsedInstr
loopLOp opParser = do void $ symbol' "LOOP_LEFT"; LOOP_LEFT <$> ops' opParser

execOp :: Parser ParsedInstr
execOp = do void $ symbol' "EXEC"; EXEC <$> noteDef

applyOp :: Parser ParsedInstr
applyOp = do void $ symbol' "APPLY"; APPLY <$> noteDef

-- Parses both `DIP` and `DIP n`.
dipOp :: Parser ParsedOp -> Parser 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 instr
parseWithOptionalParameter instrName constructorWithParam constructorNoParam =
  symbol' 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 void $ symbol' "DUP"; DUP <$> noteDef

swapOp :: Parser ParsedInstr
swapOp = do symbol' "SWAP"; return SWAP;

digOp :: Parser ParsedInstr
digOp = symbol' "DIG" *> (DIG <$> lexeme L.decimal)

dugOp :: Parser ParsedInstr
dugOp = symbol' "DUG" *> (DUG <$> lexeme L.decimal)

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

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

lambdaOp :: Parser ParsedOp -> Parser ParsedInstr
lambdaOp opParser =
  symbol' "LAMBDA" *>
  (LAMBDA <$> noteDef <*> type_ <*> type_ <*> ops' opParser)

-- Generic comparison

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

eqOp :: Parser ParsedInstr
eqOp = do void $ symbol' "EQ"; EQ <$> noteDef

neqOp :: Parser ParsedInstr
neqOp = do void $ symbol' "NEQ"; NEQ <$> noteDef

ltOp :: Parser ParsedInstr
ltOp = do void $ symbol' "LT"; LT <$> noteDef

gtOp :: Parser ParsedInstr
gtOp = do void $ symbol' "GT"; GT <$> noteDef

leOp :: Parser ParsedInstr
leOp = do void $ symbol' "LE"; LE <$> noteDef

geOp :: Parser ParsedInstr
geOp = do void $ symbol' "GE"; GE <$> noteDef

-- ad-hoc comparison

compareOp :: Parser ParsedInstr
compareOp = do void $ symbol' "COMPARE"; COMPARE <$> noteDef

-- Operations on booleans

orOp :: Parser ParsedInstr
orOp = do void $ symbol' "OR";  OR <$> noteDef

andOp :: Parser ParsedInstr
andOp = do void $ symbol' "AND"; AND <$> noteDef

xorOp :: Parser ParsedInstr
xorOp = do void $ symbol' "XOR"; XOR <$> noteDef

notOp :: Parser ParsedInstr
notOp = do void $ symbol' "NOT"; NOT <$> noteDef

-- Operations on integers and natural numbers

addOp :: Parser ParsedInstr
addOp = do void $ symbol' "ADD"; ADD <$> noteDef

subOp :: Parser ParsedInstr
subOp = do void $ symbol' "SUB"; SUB <$> noteDef

mulOp :: Parser ParsedInstr
mulOp = do void $ symbol' "MUL"; MUL <$> noteDef

edivOp :: Parser ParsedInstr
edivOp = do void $ symbol' "EDIV";EDIV <$> noteDef

absOp :: Parser ParsedInstr
absOp = do void $ symbol' "ABS"; ABS <$> noteDef

negOp :: Parser ParsedInstr
negOp = do void $ symbol' "NEG"; NEG <$> noteDef

-- Bitwise logical operators

lslOp :: Parser ParsedInstr
lslOp = do void $ symbol' "LSL"; LSL <$> noteDef

lsrOp :: Parser ParsedInstr
lsrOp = do void $ symbol' "LSR"; LSR <$> noteDef

-- Operations on string's

concatOp :: Parser ParsedInstr
concatOp = do void $ symbol' "CONCAT"; CONCAT <$> noteDef

sliceOp :: Parser ParsedInstr
sliceOp = do void $ symbol' "SLICE"; SLICE <$> noteDef

-- Operations on pairs
pairOp :: Parser ParsedInstr
pairOp = do symbol' "PAIR"; (t, v, (p, q)) <- notesTVF2; return $ PAIR t v p q

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

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

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

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

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

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

memOp :: Parser ParsedInstr
memOp = do void $ symbol' "MEM"; MEM <$> noteDef

updateOp :: Parser ParsedInstr
updateOp = do void $ symbol' "UPDATE"; UPDATE <$> noteDef

iterOp :: Parser ParsedOp -> Parser ParsedInstr
iterOp opParser = do void $ symbol' "ITER"; ITER <$> ops' opParser

sizeOp :: Parser ParsedInstr
sizeOp = do void $ symbol' "SIZE"; SIZE <$> noteDef

mapOp :: Parser ParsedOp -> Parser ParsedInstr
mapOp opParser = do symbol' "MAP"; v <- noteDef; MAP v <$> ops' opParser

getOp :: Parser ParsedInstr
getOp = do void $ symbol' "GET"; GET <$> noteDef

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

consOp :: Parser ParsedInstr
consOp = do
  try . lexeme $ do
    void $ string' "CONS"
    notFollowedBy (string' "T")
  CONS <$> noteDef

ifConsOp :: Parser ParsedOp -> Parser ParsedInstr
ifConsOp opParser =
  symbol' "IF_CONS" *>
  (IF_CONS <$> ops' opParser <*> ops' opParser)

-- Operations on options

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

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

ifNoneOp :: Parser ParsedOp -> Parser ParsedInstr
ifNoneOp opParser =
  symbol' "IF_NONE" *>
  (IF_NONE <$> ops' opParser <*> ops' opParser)

-- Operations on unions

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

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

ifLeftOp :: Parser ParsedOp -> Parser ParsedInstr
ifLeftOp opParser = do
  symbol' "IF_LEFT"
  a <- ops' opParser
  IF_LEFT a <$> ops' opParser

-- Operations on contracts

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

transferTokensOp :: Parser ParsedInstr
transferTokensOp = do void $ symbol' "TRANSFER_TOKENS"; TRANSFER_TOKENS <$> noteDef

setDelegateOp :: Parser ParsedInstr
setDelegateOp = do void $ symbol' "SET_DELEGATE"; SET_DELEGATE <$> noteDef

balanceOp :: Parser ParsedInstr
balanceOp = do void $ symbol' "BALANCE"; BALANCE <$> noteDef

contractOp :: Parser ParsedInstr
contractOp = do void $ symbol' "CONTRACT"; CONTRACT <$> noteDef <*> noteDef <*> type_

sourceOp :: Parser ParsedInstr
sourceOp = do void $ symbol' "SOURCE"; SOURCE <$> noteDef

senderOp :: Parser ParsedInstr
senderOp = do void $ symbol' "SENDER"; SENDER <$> noteDef

amountOp :: Parser ParsedInstr
amountOp = do void $ symbol' "AMOUNT"; AMOUNT <$> noteDef

implicitAccountOp :: Parser ParsedInstr
implicitAccountOp = do void $ symbol' "IMPLICIT_ACCOUNT"; IMPLICIT_ACCOUNT <$> noteDef

selfOp :: Parser ParsedInstr
selfOp = do void $ symbol' "SELF"; SELF <$> noteDef <*> noteDef

addressOp :: Parser ParsedInstr
addressOp = do void $ symbol' "ADDRESS"; ADDRESS <$> noteDef

-- Special Operations

nowOp :: Parser ParsedInstr
nowOp = do void $ symbol' "NOW"; NOW <$> noteDef

stepsToQuotaOp :: Parser ParsedInstr
stepsToQuotaOp = do void $ symbol' "STEPS_TO_QUOTA"; STEPS_TO_QUOTA <$> noteDef

chainIdOp :: Parser ParsedInstr
chainIdOp = do void $ symbol' "CHAIN_ID"; CHAIN_ID <$> noteDef

-- Operations on bytes

packOp :: Parser ParsedInstr
packOp = do void $ symbol' "PACK"; PACK <$> noteDef

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

-- Cryptographic Primitives

checkSigOp :: Parser ParsedInstr
checkSigOp = do void $ symbol' "CHECK_SIGNATURE"; CHECK_SIGNATURE <$> noteDef

blake2BOp :: Parser ParsedInstr
blake2BOp = do void $ symbol' "BLAKE2B"; BLAKE2B <$> noteDef

sha256Op :: Parser ParsedInstr
sha256Op = do void $ symbol' "SHA256"; SHA256 <$> noteDef

sha512Op :: Parser ParsedInstr
sha512Op = do void $ symbol' "SHA512"; SHA512 <$> noteDef

hashKeyOp :: Parser ParsedInstr
hashKeyOp = do void $ symbol' "HASH_KEY"; HASH_KEY <$> noteDef

-- Type operations

castOp :: Parser ParsedInstr
castOp = do void $ symbol' "CAST"; CAST <$> noteDef <*> type_;

renameOp :: Parser ParsedInstr
renameOp = do void $ symbol' "RENAME"; RENAME <$> noteDef

isNatOp :: Parser ParsedInstr
isNatOp = do void $ symbol' "ISNAT"; ISNAT <$> noteDef

intOp :: Parser ParsedInstr
intOp = do void $ symbol' "INT"; INT <$> noteDef