Macro.hs

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

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

-- | Parsing of built-in Michelson macros.

module Morley.Michelson.Parser.Macro
  ( macro
  -- * These are handled separately to have better error messages
  , duupMac
  , pairMac
  , ifCmpMac
  , mapCadrMac
  , cadrMac
  , carnMac
  , cdrnMac
  ) where

import Prelude hiding (note, try)

import Text.Megaparsec (customFailure, label, notFollowedBy, skipMany, try)
import Text.Megaparsec.Char.Lexer (decimal)
import Unsafe qualified (fromIntegral)

import Morley.Michelson.Macro
  (CadrStruct(..), Macro(..), PairStruct(..), ParsedOp(..), UnpairStruct(..))
import Morley.Michelson.Macro qualified as Macro
import Morley.Michelson.Parser.Annotations
import Morley.Michelson.Parser.Error
import Morley.Michelson.Parser.Helpers
import Morley.Michelson.Parser.Instr
import Morley.Michelson.Parser.Lexer
import Morley.Michelson.Parser.Type
import Morley.Michelson.Parser.Types (Parser, Parser', assertLetEnv)
import Morley.Michelson.Untyped (T(..), Ty(..), noAnn)
import Morley.Util.Positive

macro :: Parser' le ParsedOp -> Parser le Macro
macro opParser = label "macro"
   $ setCadrMac
  <|> (word' "CASE" CASE <* assertLetEnv) <*> someNE ops
  <|> (symbol1' "TAG" <* assertLetEnv) *> tagMac
  <|> (symbol1' "ACCESS" <* assertLetEnv) *> accessMac
  <|> (symbol1' "SET" <* assertLetEnv) *> setMac
  <|> (word' "CONSTRUCT" CONSTRUCT <* assertLetEnv) <*> someNE ops
  <|> (word' "VIEW_" VIEW_ <* assertLetEnv) <*> ops
  <|> (word' "VOID" VOID <* assertLetEnv) <*> ops
  <|> (string' "CMP" >> return CMP <*> cmpOp <*> noteDef)
  <|> word' "IF_SOME" IF_SOME <*> ops <*> ops
  <|> word' "IF_RIGHT" IF_RIGHT <*> ops <*> ops
  <|> word' "FAIL" FAIL
  <|> (string' "ASSERT_CMP" >> return ASSERT_CMP <*> cmpOp)
  <|> word' "ASSERT_NONE" ASSERT_NONE
  <|> word' "ASSERT_SOME" ASSERT_SOME
  <|> word' "ASSERT_LEFT" ASSERT_LEFT
  <|> word' "ASSERT_RIGHT" ASSERT_RIGHT
  <|> (string' "ASSERT_" >> return ASSERTX <*> cmpOp)
  <|> word' "ASSERT" ASSERT
  <|> do string' "DI"; n <- num "I"; symbol1' "P"; DIIP (n + 1) <$> ops
  <|> unpairMac
  where
   ops = ops' opParser
   num str = Unsafe.fromIntegral @Int @Word . length <$> some (string' str)

duupMac :: Parser le Macro
duupMac = do string' "DU"; n <- num "U"; symbol1' "P"; DUUP (n + 1) <$> noteDef
  where
    num str = Unsafe.fromIntegral @Int @Word . length <$> some (string' str)

pairMacInner :: Parser le PairStruct
pairMacInner = do
  string' "P"
  l <- (string' "A" $> F noAnn) <|> pairMacInner
  r <- (string' "I" $> F noAnn) <|> pairMacInner
  return $ P l r

pairMac :: Parser le Macro
pairMac = do
  a <- pairMacInner
  symbol1' "R"
  (tn, vn, fns) <- permute3Def noteDef note (some note)
  let ps = Macro.mapPairLeaves fns a
  return $ PAPAIR ps tn vn

unpairMacInner :: Parser le UnpairStruct
unpairMacInner = do
  string' "P"
  l <- (string' "A" $> UF) <|> unpairMacInner
  r <- (string' "I" $> UF) <|> unpairMacInner
  return $ UP l r

unpairMac :: Parser le Macro
unpairMac = do
  string' "UN"
  a <- unpairMacInner
  symbol1' "R"
  skipMany $ (void noteF) <|> (void noteV)
  return $ UNPAPAIR a

cadrMac :: Parser le Macro
cadrMac = lexeme $ do
  string' "C"
  a <- some $ try $ cadrInner <* notFollowedBy (string' "R")
  b <- cadrInner
  symbol1' "R"
  (vn, fn) <- notesVF
  return $ CADR (a ++ pure b) vn fn

cadrInner :: Parser le CadrStruct
cadrInner = (string' "A" $> A) <|> (string' "D" $> D)

carnMac :: Parser le Macro
carnMac = symbol1' "CAR" *> (CARN <$> noteDef <*> lexeme decimal)

cdrnMac :: Parser le Macro
cdrnMac = symbol1' "CDR" *> (CDRN <$> noteDef <*> lexeme decimal)

{-# ANN module ("HLint: ignore Reduce duplication" :: Text) #-}
setCadrMac :: Parser le Macro
setCadrMac = do
  string' "SET_C"
  a <- some cadrInner
  symbol1' "R"
  (v, f) <- notesVF
  return $ SET_CADR a v f

mapCadrMac :: Parser le ParsedOp -> Parser le Macro
mapCadrMac opParser = do
  string' "MAP_C"
  a <- some cadrInner
  symbol1' "R"
  (v, f) <- notesVF
  MAP_CADR a v f <$> ops' opParser

ifCmpMac :: Parser le ParsedOp -> Parser le Macro
ifCmpMac opParser = string' "IFCMP" >> return
  IFCMP <*> cmpOp <*> noteDef <*> ops' opParser <*> ops' opParser

tagMac :: Parser le Macro
tagMac = do
  idx <- decimal
  spaces
  ty <- type_
  let utys = unrollUnion ty []
  when (Unsafe.fromIntegral @Natural @Int idx >= length utys) $
    customFailure $ WrongTagArgs idx (lengthNE utys)
  return $ TAG idx utys
  where
  unrollUnion ty =
    case ty of
      Ty (TOr _ _ l r) _ -> unrollUnion l . toList . unrollUnion r
      _ -> (ty :|)

accessMac :: Parser le Macro
accessMac = do
  idx <- decimal
  spaces
  size <- positive
  when (idx >= unPositive size) $
    customFailure $ WrongAccessArgs idx size
  return $ ACCESS idx size

setMac :: Parser le Macro
setMac = do
  idx <- decimal
  spaces
  size <- positive
  when (idx >= unPositive size) $
    customFailure $ WrongSetArgs idx size
  return $ SET idx size