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

-- | Parsing of built-in Michelson macros.

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

import Prelude hiding (note, try)

import Text.Megaparsec (customFailure, notFollowedBy, try)
import Text.Megaparsec.Char.Lexer (decimal)

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

macro :: Parser ParsedOp -> Parser Macro
macro opParser =
      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
  <|> cadrMac
  <|> setCadrMac
  where
   ops = ops' opParser
   num str = fromIntegral . length <$> some (string' str)

dupNMac :: Parser Macro
dupNMac = do symbol' "DUP"; DUUP <$> lexeme decimal <*> noteDef

duupMac :: Parser Macro
duupMac = do string' "DU"; n <- num "U"; symbol' "P"; DUUP (n + 1) <$> noteDef
  where
    num str = fromIntegral . 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

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

unpairMac :: Parser Macro
unpairMac = do
  string' "UN"
  a <- upairMacInner
  symbol' "R"
  (vns, fns) <- permute2Def (some note) (some note)
  return $ UNPAIR (Macro.mapUnpairLeaves (padAnnotations vns fns) a)
  where
    padAnnotations []       []       = []
    padAnnotations []       (f : fs) = (noAnn, f) : padAnnotations [] fs
    padAnnotations (v : vs) []       = (v, noAnn) : padAnnotations vs []
    padAnnotations (v : vs) (f : fs) = (v, f    ) : padAnnotations vs fs

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)

{-# 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 (fromIntegral idx >= length utys) $
    customFailure $ WrongTagArgs idx (lengthNE utys)
  return $ TAG idx utys
  where
  unrollUnion ty =
    case ty of
      Type (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