Macro.hs

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

-- | 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 (label, notFollowedBy, skipMany, try)
import Text.Megaparsec.Char (string)
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.Instr
import Morley.Michelson.Parser.Lexer
import Morley.Michelson.Parser.Types (Parser)
import Morley.Michelson.Untyped (noAnn)

macro :: Parser ParsedOp -> Parser Macro
macro opParser = label "macro"
   $ setCadrMac
  <|> (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 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 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
  symbol1 "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
  symbol1 "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
  symbol1 "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 = symbol1 "CAR" *> (CARN <$> noteDef <*> lexeme decimal)

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

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

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

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