-- 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 :: Parser ParsedOp -> Parser Macro
macro opParser :: Parser ParsedOp
opParser =
      Tokens Text
-> (NonEmpty [ParsedOp] -> Macro)
-> Parser (NonEmpty [ParsedOp] -> Macro)
forall a. Tokens Text -> a -> Parser a
word' "CASE" NonEmpty [ParsedOp] -> Macro
CASE Parser (NonEmpty [ParsedOp] -> Macro)
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (NonEmpty [ParsedOp])
-> Parser Macro
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReaderT LetEnv (Parsec CustomParserException Text) [ParsedOp]
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (NonEmpty [ParsedOp])
forall (f :: * -> *) a. Alternative f => f a -> f (NonEmpty a)
someNE ReaderT LetEnv (Parsec CustomParserException Text) [ParsedOp]
ops
  Parser Macro -> Parser Macro -> Parser Macro
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Parser ()
symbol' "TAG" Parser () -> Parser Macro -> Parser Macro
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Macro
tagMac
  Parser Macro -> Parser Macro -> Parser Macro
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Parser ()
symbol' "ACCESS" Parser () -> Parser Macro -> Parser Macro
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Macro
accessMac
  Parser Macro -> Parser Macro -> Parser Macro
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> Parser ()
symbol' "SET " Parser () -> Parser Macro -> Parser Macro
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Macro
setMac
  Parser Macro -> Parser Macro -> Parser Macro
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tokens Text
-> (NonEmpty [ParsedOp] -> Macro)
-> Parser (NonEmpty [ParsedOp] -> Macro)
forall a. Tokens Text -> a -> Parser a
word' "CONSTRUCT" NonEmpty [ParsedOp] -> Macro
CONSTRUCT Parser (NonEmpty [ParsedOp] -> Macro)
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (NonEmpty [ParsedOp])
-> Parser Macro
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReaderT LetEnv (Parsec CustomParserException Text) [ParsedOp]
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (NonEmpty [ParsedOp])
forall (f :: * -> *) a. Alternative f => f a -> f (NonEmpty a)
someNE ReaderT LetEnv (Parsec CustomParserException Text) [ParsedOp]
ops
  Parser Macro -> Parser Macro -> Parser Macro
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tokens Text
-> ([ParsedOp] -> Macro) -> Parser ([ParsedOp] -> Macro)
forall a. Tokens Text -> a -> Parser a
word' "VIEW" [ParsedOp] -> Macro
VIEW Parser ([ParsedOp] -> Macro)
-> ReaderT LetEnv (Parsec CustomParserException Text) [ParsedOp]
-> Parser Macro
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReaderT LetEnv (Parsec CustomParserException Text) [ParsedOp]
ops
  Parser Macro -> Parser Macro -> Parser Macro
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tokens Text
-> ([ParsedOp] -> Macro) -> Parser ([ParsedOp] -> Macro)
forall a. Tokens Text -> a -> Parser a
word' "VOID" [ParsedOp] -> Macro
VOID Parser ([ParsedOp] -> Macro)
-> ReaderT LetEnv (Parsec CustomParserException Text) [ParsedOp]
-> Parser Macro
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReaderT LetEnv (Parsec CustomParserException Text) [ParsedOp]
ops
  Parser Macro -> Parser Macro -> Parser Macro
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tokens Text
-> (ParsedInstr -> VarAnn -> Macro)
-> Parser (ParsedInstr -> VarAnn -> Macro)
forall a. Tokens Text -> a -> Parser a
word' "CMP" ParsedInstr -> VarAnn -> Macro
CMP Parser (ParsedInstr -> VarAnn -> Macro)
-> ReaderT LetEnv (Parsec CustomParserException Text) ParsedInstr
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (VarAnn -> Macro)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReaderT LetEnv (Parsec CustomParserException Text) ParsedInstr
cmpOp ReaderT
  LetEnv (Parsec CustomParserException Text) (VarAnn -> Macro)
-> ReaderT LetEnv (Parsec CustomParserException Text) VarAnn
-> Parser Macro
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReaderT LetEnv (Parsec CustomParserException Text) VarAnn
forall tag. KnownAnnTag tag => Parser (Annotation tag)
noteDef
  Parser Macro -> Parser Macro -> Parser Macro
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tokens Text
-> ([ParsedOp] -> [ParsedOp] -> Macro)
-> Parser ([ParsedOp] -> [ParsedOp] -> Macro)
forall a. Tokens Text -> a -> Parser a
word' "IF_SOME" [ParsedOp] -> [ParsedOp] -> Macro
IF_SOME Parser ([ParsedOp] -> [ParsedOp] -> Macro)
-> ReaderT LetEnv (Parsec CustomParserException Text) [ParsedOp]
-> Parser ([ParsedOp] -> Macro)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReaderT LetEnv (Parsec CustomParserException Text) [ParsedOp]
ops Parser ([ParsedOp] -> Macro)
-> ReaderT LetEnv (Parsec CustomParserException Text) [ParsedOp]
-> Parser Macro
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReaderT LetEnv (Parsec CustomParserException Text) [ParsedOp]
ops
  Parser Macro -> Parser Macro -> Parser Macro
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tokens Text
-> ([ParsedOp] -> [ParsedOp] -> Macro)
-> Parser ([ParsedOp] -> [ParsedOp] -> Macro)
forall a. Tokens Text -> a -> Parser a
word' "IF_RIGHT" [ParsedOp] -> [ParsedOp] -> Macro
IF_RIGHT Parser ([ParsedOp] -> [ParsedOp] -> Macro)
-> ReaderT LetEnv (Parsec CustomParserException Text) [ParsedOp]
-> Parser ([ParsedOp] -> Macro)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReaderT LetEnv (Parsec CustomParserException Text) [ParsedOp]
ops Parser ([ParsedOp] -> Macro)
-> ReaderT LetEnv (Parsec CustomParserException Text) [ParsedOp]
-> Parser Macro
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReaderT LetEnv (Parsec CustomParserException Text) [ParsedOp]
ops
  Parser Macro -> Parser Macro -> Parser Macro
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tokens Text -> Macro -> Parser Macro
forall a. Tokens Text -> a -> Parser a
word' "FAIL" Macro
FAIL
  Parser Macro -> Parser Macro -> Parser Macro
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tokens Text
-> (ParsedInstr -> Macro) -> Parser (ParsedInstr -> Macro)
forall a. Tokens Text -> a -> Parser a
word' "ASSERT_CMP" ParsedInstr -> Macro
ASSERT_CMP Parser (ParsedInstr -> Macro)
-> ReaderT LetEnv (Parsec CustomParserException Text) ParsedInstr
-> Parser Macro
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReaderT LetEnv (Parsec CustomParserException Text) ParsedInstr
cmpOp
  Parser Macro -> Parser Macro -> Parser Macro
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tokens Text -> Macro -> Parser Macro
forall a. Tokens Text -> a -> Parser a
word' "ASSERT_NONE" Macro
ASSERT_NONE
  Parser Macro -> Parser Macro -> Parser Macro
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tokens Text -> Macro -> Parser Macro
forall a. Tokens Text -> a -> Parser a
word' "ASSERT_SOME" Macro
ASSERT_SOME
  Parser Macro -> Parser Macro -> Parser Macro
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tokens Text -> Macro -> Parser Macro
forall a. Tokens Text -> a -> Parser a
word' "ASSERT_LEFT" Macro
ASSERT_LEFT
  Parser Macro -> Parser Macro -> Parser Macro
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tokens Text -> Macro -> Parser Macro
forall a. Tokens Text -> a -> Parser a
word' "ASSERT_RIGHT" Macro
ASSERT_RIGHT
  Parser Macro -> Parser Macro -> Parser Macro
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tokens Text
-> (ParsedInstr -> Macro) -> Parser (ParsedInstr -> Macro)
forall a. Tokens Text -> a -> Parser a
word' "ASSERT_" ParsedInstr -> Macro
ASSERTX Parser (ParsedInstr -> Macro)
-> ReaderT LetEnv (Parsec CustomParserException Text) ParsedInstr
-> Parser Macro
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReaderT LetEnv (Parsec CustomParserException Text) ParsedInstr
cmpOp
  Parser Macro -> Parser Macro -> Parser Macro
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tokens Text -> Macro -> Parser Macro
forall a. Tokens Text -> a -> Parser a
word' "ASSERT" Macro
ASSERT
  Parser Macro -> Parser Macro -> Parser Macro
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> do Text -> ReaderT LetEnv (Parsec CustomParserException Text) Text
forall e s (f :: * -> *).
(MonadParsec e s f, Tokens s ~ Text) =>
Text -> f Text
string' "DI"; Word
n <- Text -> ReaderT LetEnv (Parsec CustomParserException Text) Word
forall (f :: * -> *) b e s.
(Num b, MonadParsec e s f, Tokens s ~ Text) =>
Text -> f b
num "I"; Text -> Parser ()
symbol' "P"; Word -> [ParsedOp] -> Macro
DIIP (Word
n Word -> Word -> Word
forall a. Num a => a -> a -> a
+ 1) ([ParsedOp] -> Macro)
-> ReaderT LetEnv (Parsec CustomParserException Text) [ParsedOp]
-> Parser Macro
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT LetEnv (Parsec CustomParserException Text) [ParsedOp]
ops
  Parser Macro -> Parser Macro -> Parser Macro
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Macro
unpairMac
  Parser Macro -> Parser Macro -> Parser Macro
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Macro
cadrMac
  Parser Macro -> Parser Macro -> Parser Macro
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Macro
setCadrMac
  where
   ops :: ReaderT LetEnv (Parsec CustomParserException Text) [ParsedOp]
ops = Parser ParsedOp
-> ReaderT LetEnv (Parsec CustomParserException Text) [ParsedOp]
ops' Parser ParsedOp
opParser
   num :: Text -> f b
num str :: Text
str = Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> b) -> ([Text] -> Int) -> [Text] -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Int
forall t. Container t => t -> Int
length ([Text] -> b) -> f [Text] -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f Text -> f [Text]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (Text -> f Text
forall e s (f :: * -> *).
(MonadParsec e s f, Tokens s ~ Text) =>
Text -> f Text
string' Text
str)

dupNMac :: Parser Macro
dupNMac :: Parser Macro
dupNMac = do Text -> Parser ()
symbol' "DUP"; Word -> VarAnn -> Macro
DUUP (Word -> VarAnn -> Macro)
-> ReaderT LetEnv (Parsec CustomParserException Text) Word
-> ReaderT
     LetEnv (Parsec CustomParserException Text) (VarAnn -> Macro)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT LetEnv (Parsec CustomParserException Text) Word
-> ReaderT LetEnv (Parsec CustomParserException Text) Word
forall a. Parser a -> Parser a
lexeme ReaderT LetEnv (Parsec CustomParserException Text) Word
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
decimal ReaderT
  LetEnv (Parsec CustomParserException Text) (VarAnn -> Macro)
-> ReaderT LetEnv (Parsec CustomParserException Text) VarAnn
-> Parser Macro
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReaderT LetEnv (Parsec CustomParserException Text) VarAnn
forall tag. KnownAnnTag tag => Parser (Annotation tag)
noteDef

duupMac :: Parser Macro
duupMac :: Parser Macro
duupMac = do Text -> ReaderT LetEnv (Parsec CustomParserException Text) Text
forall e s (f :: * -> *).
(MonadParsec e s f, Tokens s ~ Text) =>
Text -> f Text
string' "DU"; Word
n <- Text -> ReaderT LetEnv (Parsec CustomParserException Text) Word
forall (f :: * -> *) b e s.
(Num b, MonadParsec e s f, Tokens s ~ Text) =>
Text -> f b
num "U"; Text -> Parser ()
symbol' "P"; Word -> VarAnn -> Macro
DUUP (Word
n Word -> Word -> Word
forall a. Num a => a -> a -> a
+ 1) (VarAnn -> Macro)
-> ReaderT LetEnv (Parsec CustomParserException Text) VarAnn
-> Parser Macro
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT LetEnv (Parsec CustomParserException Text) VarAnn
forall tag. KnownAnnTag tag => Parser (Annotation tag)
noteDef
  where
    num :: Text -> f b
num str :: Text
str = Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> b) -> ([Text] -> Int) -> [Text] -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Int
forall t. Container t => t -> Int
length ([Text] -> b) -> f [Text] -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f Text -> f [Text]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (Text -> f Text
forall e s (f :: * -> *).
(MonadParsec e s f, Tokens s ~ Text) =>
Text -> f Text
string' Text
str)

pairMacInner :: Parser PairStruct
pairMacInner :: Parser PairStruct
pairMacInner = do
  Text -> ReaderT LetEnv (Parsec CustomParserException Text) Text
forall e s (f :: * -> *).
(MonadParsec e s f, Tokens s ~ Text) =>
Text -> f Text
string' "P"
  PairStruct
l <- (Text -> ReaderT LetEnv (Parsec CustomParserException Text) Text
forall e s (f :: * -> *).
(MonadParsec e s f, Tokens s ~ Text) =>
Text -> f Text
string' "A" ReaderT LetEnv (Parsec CustomParserException Text) Text
-> PairStruct -> Parser PairStruct
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> FieldAnn -> PairStruct
F FieldAnn
forall k (a :: k). Annotation a
noAnn) Parser PairStruct -> Parser PairStruct -> Parser PairStruct
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser PairStruct
pairMacInner
  PairStruct
r <- (Text -> ReaderT LetEnv (Parsec CustomParserException Text) Text
forall e s (f :: * -> *).
(MonadParsec e s f, Tokens s ~ Text) =>
Text -> f Text
string' "I" ReaderT LetEnv (Parsec CustomParserException Text) Text
-> PairStruct -> Parser PairStruct
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> FieldAnn -> PairStruct
F FieldAnn
forall k (a :: k). Annotation a
noAnn) Parser PairStruct -> Parser PairStruct -> Parser PairStruct
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser PairStruct
pairMacInner
  return $ PairStruct -> PairStruct -> PairStruct
P PairStruct
l PairStruct
r

pairMac :: Parser Macro
pairMac :: Parser Macro
pairMac = do
  PairStruct
a <- Parser PairStruct
pairMacInner
  Text -> Parser ()
symbol' "R"
  (tn :: Annotation TypeTag
tn, vn :: VarAnn
vn, fns :: [FieldAnn]
fns) <- ReaderT
  LetEnv (Parsec CustomParserException Text) (Annotation TypeTag)
-> ReaderT LetEnv (Parsec CustomParserException Text) VarAnn
-> ReaderT LetEnv (Parsec CustomParserException Text) [FieldAnn]
-> ReaderT
     LetEnv
     (Parsec CustomParserException Text)
     (Annotation TypeTag, VarAnn, [FieldAnn])
forall a b c (f :: * -> *).
(Default a, Default b, Default c, Monad f, Alternative f) =>
f a -> f b -> f c -> f (a, b, c)
permute3Def ReaderT
  LetEnv (Parsec CustomParserException Text) (Annotation TypeTag)
forall tag. KnownAnnTag tag => Parser (Annotation tag)
noteDef ReaderT LetEnv (Parsec CustomParserException Text) VarAnn
forall tag. KnownAnnTag tag => Parser (Annotation tag)
note (ReaderT LetEnv (Parsec CustomParserException Text) FieldAnn
-> ReaderT LetEnv (Parsec CustomParserException Text) [FieldAnn]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ReaderT LetEnv (Parsec CustomParserException Text) FieldAnn
forall tag. KnownAnnTag tag => Parser (Annotation tag)
note)
  let ps :: PairStruct
ps = [FieldAnn] -> PairStruct -> PairStruct
Macro.mapPairLeaves [FieldAnn]
fns PairStruct
a
  return $ PairStruct -> Annotation TypeTag -> VarAnn -> Macro
PAPAIR PairStruct
ps Annotation TypeTag
tn VarAnn
vn

upairMacInner :: Parser UnpairStruct
upairMacInner :: Parser UnpairStruct
upairMacInner = do
  Text -> ReaderT LetEnv (Parsec CustomParserException Text) Text
forall e s (f :: * -> *).
(MonadParsec e s f, Tokens s ~ Text) =>
Text -> f Text
string' "P"
  UnpairStruct
l <- (Text -> ReaderT LetEnv (Parsec CustomParserException Text) Text
forall e s (f :: * -> *).
(MonadParsec e s f, Tokens s ~ Text) =>
Text -> f Text
string' "A" ReaderT LetEnv (Parsec CustomParserException Text) Text
-> UnpairStruct -> Parser UnpairStruct
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (VarAnn, FieldAnn) -> UnpairStruct
UF (VarAnn
forall k (a :: k). Annotation a
noAnn, FieldAnn
forall k (a :: k). Annotation a
noAnn)) Parser UnpairStruct -> Parser UnpairStruct -> Parser UnpairStruct
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser UnpairStruct
upairMacInner
  UnpairStruct
r <- (Text -> ReaderT LetEnv (Parsec CustomParserException Text) Text
forall e s (f :: * -> *).
(MonadParsec e s f, Tokens s ~ Text) =>
Text -> f Text
string' "I" ReaderT LetEnv (Parsec CustomParserException Text) Text
-> UnpairStruct -> Parser UnpairStruct
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (VarAnn, FieldAnn) -> UnpairStruct
UF (VarAnn
forall k (a :: k). Annotation a
noAnn, FieldAnn
forall k (a :: k). Annotation a
noAnn)) Parser UnpairStruct -> Parser UnpairStruct -> Parser UnpairStruct
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser UnpairStruct
upairMacInner
  return $ UnpairStruct -> UnpairStruct -> UnpairStruct
UP UnpairStruct
l UnpairStruct
r

unpairMac :: Parser Macro
unpairMac :: Parser Macro
unpairMac = do
  Text -> ReaderT LetEnv (Parsec CustomParserException Text) Text
forall e s (f :: * -> *).
(MonadParsec e s f, Tokens s ~ Text) =>
Text -> f Text
string' "UN"
  UnpairStruct
a <- Parser UnpairStruct
upairMacInner
  Text -> Parser ()
symbol' "R"
  (vns :: [VarAnn]
vns, fns :: [FieldAnn]
fns) <- ReaderT LetEnv (Parsec CustomParserException Text) [VarAnn]
-> ReaderT LetEnv (Parsec CustomParserException Text) [FieldAnn]
-> ReaderT
     LetEnv (Parsec CustomParserException Text) ([VarAnn], [FieldAnn])
forall a b (f :: * -> *).
(Default a, Default b, Monad f, Alternative f) =>
f a -> f b -> f (a, b)
permute2Def (ReaderT LetEnv (Parsec CustomParserException Text) VarAnn
-> ReaderT LetEnv (Parsec CustomParserException Text) [VarAnn]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ReaderT LetEnv (Parsec CustomParserException Text) VarAnn
forall tag. KnownAnnTag tag => Parser (Annotation tag)
note) (ReaderT LetEnv (Parsec CustomParserException Text) FieldAnn
-> ReaderT LetEnv (Parsec CustomParserException Text) [FieldAnn]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ReaderT LetEnv (Parsec CustomParserException Text) FieldAnn
forall tag. KnownAnnTag tag => Parser (Annotation tag)
note)
  return $ UnpairStruct -> Macro
UNPAIR ([(VarAnn, FieldAnn)] -> UnpairStruct -> UnpairStruct
Macro.mapUnpairLeaves ([VarAnn] -> [FieldAnn] -> [(VarAnn, FieldAnn)]
forall a b. [a] -> [b] -> [(a, b)]
zip [VarAnn]
vns [FieldAnn]
fns) UnpairStruct
a)

cadrMac :: Parser Macro
cadrMac :: Parser Macro
cadrMac = Parser Macro -> Parser Macro
forall a. Parser a -> Parser a
lexeme (Parser Macro -> Parser Macro) -> Parser Macro -> Parser Macro
forall a b. (a -> b) -> a -> b
$ do
  Text -> ReaderT LetEnv (Parsec CustomParserException Text) Text
forall e s (f :: * -> *).
(MonadParsec e s f, Tokens s ~ Text) =>
Text -> f Text
string' "C"
  [CadrStruct]
a <- ReaderT LetEnv (Parsec CustomParserException Text) CadrStruct
-> ReaderT LetEnv (Parsec CustomParserException Text) [CadrStruct]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (ReaderT LetEnv (Parsec CustomParserException Text) CadrStruct
 -> ReaderT LetEnv (Parsec CustomParserException Text) [CadrStruct])
-> ReaderT LetEnv (Parsec CustomParserException Text) CadrStruct
-> ReaderT LetEnv (Parsec CustomParserException Text) [CadrStruct]
forall a b. (a -> b) -> a -> b
$ ReaderT LetEnv (Parsec CustomParserException Text) CadrStruct
-> ReaderT LetEnv (Parsec CustomParserException Text) CadrStruct
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ReaderT LetEnv (Parsec CustomParserException Text) CadrStruct
 -> ReaderT LetEnv (Parsec CustomParserException Text) CadrStruct)
-> ReaderT LetEnv (Parsec CustomParserException Text) CadrStruct
-> ReaderT LetEnv (Parsec CustomParserException Text) CadrStruct
forall a b. (a -> b) -> a -> b
$ ReaderT LetEnv (Parsec CustomParserException Text) CadrStruct
cadrInner ReaderT LetEnv (Parsec CustomParserException Text) CadrStruct
-> Parser ()
-> ReaderT LetEnv (Parsec CustomParserException Text) CadrStruct
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReaderT LetEnv (Parsec CustomParserException Text) Text
-> Parser ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy (Text -> ReaderT LetEnv (Parsec CustomParserException Text) Text
forall e s (f :: * -> *).
(MonadParsec e s f, Tokens s ~ Text) =>
Text -> f Text
string' "R")
  CadrStruct
b <- ReaderT LetEnv (Parsec CustomParserException Text) CadrStruct
cadrInner
  Text -> Parser ()
symbol' "R"
  (vn :: VarAnn
vn, fn :: FieldAnn
fn) <- Parser (VarAnn, FieldAnn)
notesVF
  return $ [CadrStruct] -> VarAnn -> FieldAnn -> Macro
CADR ([CadrStruct]
a [CadrStruct] -> [CadrStruct] -> [CadrStruct]
forall a. [a] -> [a] -> [a]
++ CadrStruct -> [CadrStruct]
forall (f :: * -> *) a. Applicative f => a -> f a
pure CadrStruct
b) VarAnn
vn FieldAnn
fn

cadrInner :: Parser CadrStruct
cadrInner :: ReaderT LetEnv (Parsec CustomParserException Text) CadrStruct
cadrInner = (Text -> ReaderT LetEnv (Parsec CustomParserException Text) Text
forall e s (f :: * -> *).
(MonadParsec e s f, Tokens s ~ Text) =>
Text -> f Text
string' "A" ReaderT LetEnv (Parsec CustomParserException Text) Text
-> CadrStruct
-> ReaderT LetEnv (Parsec CustomParserException Text) CadrStruct
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> CadrStruct
A) ReaderT LetEnv (Parsec CustomParserException Text) CadrStruct
-> ReaderT LetEnv (Parsec CustomParserException Text) CadrStruct
-> ReaderT LetEnv (Parsec CustomParserException Text) CadrStruct
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Text -> ReaderT LetEnv (Parsec CustomParserException Text) Text
forall e s (f :: * -> *).
(MonadParsec e s f, Tokens s ~ Text) =>
Text -> f Text
string' "D" ReaderT LetEnv (Parsec CustomParserException Text) Text
-> CadrStruct
-> ReaderT LetEnv (Parsec CustomParserException Text) CadrStruct
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> CadrStruct
D)

{-# ANN module ("HLint: ignore Reduce duplication" :: Text) #-}
setCadrMac :: Parser Macro
setCadrMac :: Parser Macro
setCadrMac = do
  Text -> ReaderT LetEnv (Parsec CustomParserException Text) Text
forall e s (f :: * -> *).
(MonadParsec e s f, Tokens s ~ Text) =>
Text -> f Text
string' "SET_C"
  [CadrStruct]
a <- ReaderT LetEnv (Parsec CustomParserException Text) CadrStruct
-> ReaderT LetEnv (Parsec CustomParserException Text) [CadrStruct]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ReaderT LetEnv (Parsec CustomParserException Text) CadrStruct
cadrInner
  Text -> Parser ()
symbol' "R"
  (v :: VarAnn
v, f :: FieldAnn
f) <- Parser (VarAnn, FieldAnn)
notesVF
  return $ [CadrStruct] -> VarAnn -> FieldAnn -> Macro
SET_CADR [CadrStruct]
a VarAnn
v FieldAnn
f

mapCadrMac :: Parser ParsedOp -> Parser Macro
mapCadrMac :: Parser ParsedOp -> Parser Macro
mapCadrMac opParser :: Parser ParsedOp
opParser = do
  Text -> ReaderT LetEnv (Parsec CustomParserException Text) Text
forall e s (f :: * -> *).
(MonadParsec e s f, Tokens s ~ Text) =>
Text -> f Text
string' "MAP_C"
  [CadrStruct]
a <- ReaderT LetEnv (Parsec CustomParserException Text) CadrStruct
-> ReaderT LetEnv (Parsec CustomParserException Text) [CadrStruct]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ReaderT LetEnv (Parsec CustomParserException Text) CadrStruct
cadrInner
  Text -> Parser ()
symbol' "R"
  (v :: VarAnn
v, f :: FieldAnn
f) <- Parser (VarAnn, FieldAnn)
notesVF
  [CadrStruct] -> VarAnn -> FieldAnn -> [ParsedOp] -> Macro
MAP_CADR [CadrStruct]
a VarAnn
v FieldAnn
f ([ParsedOp] -> Macro)
-> ReaderT LetEnv (Parsec CustomParserException Text) [ParsedOp]
-> Parser Macro
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ParsedOp
-> ReaderT LetEnv (Parsec CustomParserException Text) [ParsedOp]
ops' Parser ParsedOp
opParser

ifCmpMac :: Parser ParsedOp -> Parser Macro
ifCmpMac :: Parser ParsedOp -> Parser Macro
ifCmpMac opParser :: Parser ParsedOp
opParser =
  Tokens Text
-> (ParsedInstr -> VarAnn -> [ParsedOp] -> [ParsedOp] -> Macro)
-> Parser
     (ParsedInstr -> VarAnn -> [ParsedOp] -> [ParsedOp] -> Macro)
forall a. Tokens Text -> a -> Parser a
word' "IFCMP" ParsedInstr -> VarAnn -> [ParsedOp] -> [ParsedOp] -> Macro
IFCMP Parser (ParsedInstr -> VarAnn -> [ParsedOp] -> [ParsedOp] -> Macro)
-> ReaderT LetEnv (Parsec CustomParserException Text) ParsedInstr
-> ReaderT
     LetEnv
     (Parsec CustomParserException Text)
     (VarAnn -> [ParsedOp] -> [ParsedOp] -> Macro)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReaderT LetEnv (Parsec CustomParserException Text) ParsedInstr
cmpOp ReaderT
  LetEnv
  (Parsec CustomParserException Text)
  (VarAnn -> [ParsedOp] -> [ParsedOp] -> Macro)
-> ReaderT LetEnv (Parsec CustomParserException Text) VarAnn
-> Parser ([ParsedOp] -> [ParsedOp] -> Macro)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReaderT LetEnv (Parsec CustomParserException Text) VarAnn
forall tag. KnownAnnTag tag => Parser (Annotation tag)
noteDef Parser ([ParsedOp] -> [ParsedOp] -> Macro)
-> ReaderT LetEnv (Parsec CustomParserException Text) [ParsedOp]
-> Parser ([ParsedOp] -> Macro)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ParsedOp
-> ReaderT LetEnv (Parsec CustomParserException Text) [ParsedOp]
ops' Parser ParsedOp
opParser Parser ([ParsedOp] -> Macro)
-> ReaderT LetEnv (Parsec CustomParserException Text) [ParsedOp]
-> Parser Macro
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ParsedOp
-> ReaderT LetEnv (Parsec CustomParserException Text) [ParsedOp]
ops' Parser ParsedOp
opParser

tagMac :: Parser Macro
tagMac :: Parser Macro
tagMac = do
  Natural
idx <- ReaderT LetEnv (Parsec CustomParserException Text) Natural
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
decimal
  Parser ()
mSpace
  Type
ty <- Parser Type
type_
  let utys :: NonEmpty Type
utys = Type -> [Type] -> NonEmpty Type
unrollUnion Type
ty []
  Bool -> Parser () -> Parser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= NonEmpty Type -> Int
forall t. Container t => t -> Int
length NonEmpty Type
utys) (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$
    CustomParserException -> Parser ()
forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
customFailure (CustomParserException -> Parser ())
-> CustomParserException -> Parser ()
forall a b. (a -> b) -> a -> b
$ Natural -> Positive -> CustomParserException
WrongTagArgs Natural
idx (NonEmpty Type -> Positive
forall a. NonEmpty a -> Positive
lengthNE NonEmpty Type
utys)
  return $ Natural -> NonEmpty Type -> Macro
TAG Natural
idx NonEmpty Type
utys
  where
  unrollUnion :: Type -> [Type] -> NonEmpty Type
unrollUnion ty :: Type
ty =
    case Type
ty of
      Type (TOr _ _ l :: Type
l r :: Type
r) _ -> Type -> [Type] -> NonEmpty Type
unrollUnion Type
l ([Type] -> NonEmpty Type)
-> ([Type] -> [Type]) -> [Type] -> NonEmpty Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Type -> [Type]
forall t. Container t => t -> [Element t]
toList (NonEmpty Type -> [Type])
-> ([Type] -> NonEmpty Type) -> [Type] -> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> [Type] -> NonEmpty Type
unrollUnion Type
r
      _ -> (Type
ty Type -> [Type] -> NonEmpty Type
forall a. a -> [a] -> NonEmpty a
:|)

accessMac :: Parser Macro
accessMac :: Parser Macro
accessMac = do
  Natural
idx <- ReaderT LetEnv (Parsec CustomParserException Text) Natural
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
decimal
  Parser ()
mSpace
  Positive
size <- Parser Positive
positive
  Bool -> Parser () -> Parser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Natural
idx Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
>= Positive -> Natural
unPositive Positive
size) (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$
    CustomParserException -> Parser ()
forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
customFailure (CustomParserException -> Parser ())
-> CustomParserException -> Parser ()
forall a b. (a -> b) -> a -> b
$ Natural -> Positive -> CustomParserException
WrongAccessArgs Natural
idx Positive
size
  return $ Natural -> Positive -> Macro
ACCESS Natural
idx Positive
size

setMac :: Parser Macro
setMac :: Parser Macro
setMac = do
  Natural
idx <- ReaderT LetEnv (Parsec CustomParserException Text) Natural
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
decimal
  Parser ()
mSpace
  Positive
size <- Parser Positive
positive
  Bool -> Parser () -> Parser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Natural
idx Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
>= Positive -> Natural
unPositive Positive
size) (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$
    CustomParserException -> Parser ()
forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
customFailure (CustomParserException -> Parser ())
-> CustomParserException -> Parser ()
forall a b. (a -> b) -> a -> b
$ Natural -> Positive -> CustomParserException
WrongSetArgs Natural
idx Positive
size
  return $ Natural -> Positive -> Macro
SET Natural
idx Positive
size