Macro.hs

-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

-- | 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 qualified Unsafe (fromIntegral)

import Morley.Michelson.Macro
  (CadrStruct(..), Macro(..), PairStruct(..), ParsedOp(..), UnpairStruct(..))
import qualified Morley.Michelson.Macro 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)
import Morley.Michelson.Untyped (T(..), Ty(..), noAnn)
import Morley.Util.Positive

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

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

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

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

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

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

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

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

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

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

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

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

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

tagMac :: Parser Macro
tagMac = do
  idx <- decimal
  mSpace
  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 Macro
accessMac = do
  idx <- decimal
  mSpace
  size <- positive
  when (idx >= unPositive size) $
    customFailure $ WrongAccessArgs idx size
  return $ ACCESS idx size

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