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

-- | Parsing of built-in Michelson macros.

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

import Prelude hiding (note, try)

import Data.Default (Default(..))
import Text.Megaparsec (choice, label, skipMany)
import Text.Megaparsec.Char (string)
import Text.Megaparsec.Char.Lexer (decimal)

import Morley.Michelson.Macro
  (CadrStruct(..), Macro(..), PairStruct(..), ParsedOp(..), ParsedSeq, UnpairStruct(..))
import Morley.Michelson.Macro qualified as Macro
import Morley.Michelson.Parser.Annotations
import Morley.Michelson.Parser.Instr qualified as Instr
import Morley.Michelson.Parser.Lexer
import Morley.Michelson.Parser.Types (Parser)
import Morley.Michelson.Untyped (noAnn)

data AllowAnnotations = ForbidAnnotations | AllowAnnotations

annWithDef :: Default a => AllowAnnotations -> Parser a -> Parser a
annWithDef :: forall a. Default a => AllowAnnotations -> Parser a -> Parser a
annWithDef AllowAnnotations
allow Parser a
p = case AllowAnnotations
allow of
  AllowAnnotations
AllowAnnotations -> Parser a
p
  AllowAnnotations
ForbidAnnotations -> a -> Parser a
forall a. a -> ParsecT CustomParserException Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
forall a. Default a => a
def

cmpOp :: AllowAnnotations -> Parser Macro.ParsedInstr
cmpOp :: AllowAnnotations -> Parser ParsedInstr
cmpOp = Parser VarAnn -> Parser ParsedInstr
Instr.cmpOp (Parser VarAnn -> Parser ParsedInstr)
-> (AllowAnnotations -> Parser VarAnn)
-> AllowAnnotations
-> Parser ParsedInstr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AllowAnnotations -> Parser VarAnn -> Parser VarAnn)
-> Parser VarAnn -> AllowAnnotations -> Parser VarAnn
forall a b c. (a -> b -> c) -> b -> a -> c
flip AllowAnnotations -> Parser VarAnn -> Parser VarAnn
forall a. Default a => AllowAnnotations -> Parser a -> Parser a
annWithDef Parser VarAnn
forall tag. KnownAnnTag tag => Parser (Annotation tag)
noteDef

-- | Macros consisting of a single token are allowed in more contexts than other
-- macros.
singleTokenMacro
  :: AllowAnnotations
  -- ^ Whether we allow annotations. When used for parsing a single token, this
  -- is obviously disabled. Enabled when reused in the general context, e.g. in 'macro'.
  -> Parser Macro
singleTokenMacro :: AllowAnnotations -> Parser Macro
singleTokenMacro AllowAnnotations
allowAnns = [Parser Macro] -> Parser Macro
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
  [ AllowAnnotations -> Parser Macro
setCadrMac AllowAnnotations
allowAnns
  , Tokens Text
-> ParsecT CustomParserException Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"CMP" ParsecT CustomParserException Text Identity (Tokens Text)
-> Parser Macro -> Parser Macro
forall a b.
ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity b
-> ParsecT CustomParserException Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (ParsedInstr -> Macro
CMP (ParsedInstr -> Macro) -> Parser ParsedInstr -> Parser Macro
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AllowAnnotations -> Parser ParsedInstr
cmpOp AllowAnnotations
allowAnns)
  , Tokens Text -> Macro -> Parser Macro
forall a. Tokens Text -> a -> Parser a
word Text
Tokens Text
"FAIL" Macro
FAIL
  , Tokens Text
-> ParsecT CustomParserException Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"ASSERT_CMP" ParsecT CustomParserException Text Identity (Tokens Text)
-> Parser Macro -> Parser Macro
forall a b.
ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity b
-> ParsecT CustomParserException Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (ParsedInstr -> Macro
ASSERT_CMP (ParsedInstr -> Macro) -> Parser ParsedInstr -> Parser Macro
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AllowAnnotations -> Parser ParsedInstr
cmpOp AllowAnnotations
allowAnns)
  , Tokens Text -> Macro -> Parser Macro
forall a. Tokens Text -> a -> Parser a
word Text
Tokens Text
"ASSERT_NONE" Macro
ASSERT_NONE
  , Tokens Text -> Macro -> Parser Macro
forall a. Tokens Text -> a -> Parser a
word Text
Tokens Text
"ASSERT_SOME" Macro
ASSERT_SOME
  , Tokens Text -> Macro -> Parser Macro
forall a. Tokens Text -> a -> Parser a
word Text
Tokens Text
"ASSERT_LEFT" Macro
ASSERT_LEFT
  , Tokens Text -> Macro -> Parser Macro
forall a. Tokens Text -> a -> Parser a
word Text
Tokens Text
"ASSERT_RIGHT" Macro
ASSERT_RIGHT
  , Tokens Text
-> ParsecT CustomParserException Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"ASSERT_" ParsecT CustomParserException Text Identity (Tokens Text)
-> Parser Macro -> Parser Macro
forall a b.
ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity b
-> ParsecT CustomParserException Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (ParsedInstr -> Macro
ASSERTX (ParsedInstr -> Macro) -> Parser ParsedInstr -> Parser Macro
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AllowAnnotations -> Parser ParsedInstr
cmpOp AllowAnnotations
allowAnns)
  , Tokens Text -> Macro -> Parser Macro
forall a. Tokens Text -> a -> Parser a
word Text
Tokens Text
"ASSERT" Macro
ASSERT
  , AllowAnnotations -> Parser Macro
unpairMac AllowAnnotations
allowAnns
  ]

-- | This includes all macros consisting of a single token, i.e. also the
-- specially-handled ones, like @PAIIR@, @CADR@, etc, but not @DUUP@, as it's
-- always represented as @DUPN@ and thus behaves like a primitive.
allSingleTokenMacros :: Parser Macro
allSingleTokenMacros :: Parser Macro
allSingleTokenMacros = String -> Parser Macro -> Parser Macro
forall a.
String
-> ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"single-token macro" (Parser Macro -> Parser Macro) -> Parser Macro -> Parser Macro
forall a b. (a -> b) -> a -> b
$ [Parser Macro] -> Parser Macro
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
  [ AllowAnnotations -> Parser Macro
singleTokenMacro AllowAnnotations
ForbidAnnotations
  , AllowAnnotations -> Parser Macro
pairMac' AllowAnnotations
ForbidAnnotations
  , AllowAnnotations -> Parser Macro
cadrMac' AllowAnnotations
ForbidAnnotations
  ]

-- | Includes all macros, also the specially-handled ones. Macros are allowed in
-- more contexts than instructions, so sometimes it's unambiguous.
--
-- Notably @DUUP@ and @DIIP@ are excluded, as they're always represented by a
-- single instruction and thus behave more like a primitive.
allMacros :: Parser (ParsedSeq ParsedOp) -> Parser Macro
allMacros :: Parser (ParsedSeq ParsedOp) -> Parser Macro
allMacros Parser (ParsedSeq ParsedOp)
ops = String -> Parser Macro -> Parser Macro
forall a.
String
-> ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"macro" (Parser Macro -> Parser Macro) -> Parser Macro -> Parser Macro
forall a b. (a -> b) -> a -> b
$ [Parser Macro] -> Parser Macro
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
  [ Parser (ParsedSeq ParsedOp) -> Parser Macro
macro Parser (ParsedSeq ParsedOp)
ops
  , Parser Macro
pairMac
  , Parser Macro
carnMac
  , Parser Macro
cdrnMac
  , Parser Macro
cadrMac
  , Parser (ParsedSeq ParsedOp) -> Parser Macro
ifCmpMac Parser (ParsedSeq ParsedOp)
ops
  , Parser (ParsedSeq ParsedOp) -> Parser Macro
mapCadrMac Parser (ParsedSeq ParsedOp)
ops
  , Parser (ParsedSeq ParsedOp) -> Parser Macro
ifX Parser (ParsedSeq ParsedOp)
ops
  ]

macro :: Parser (ParsedSeq ParsedOp) -> Parser Macro
macro :: Parser (ParsedSeq ParsedOp) -> Parser Macro
macro Parser (ParsedSeq ParsedOp)
ops = String -> Parser Macro -> Parser Macro
forall a.
String
-> ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"macro"
   (Parser Macro -> Parser Macro) -> Parser Macro -> Parser Macro
forall a b. (a -> b) -> a -> b
$  AllowAnnotations -> Parser Macro
singleTokenMacro AllowAnnotations
AllowAnnotations
  Parser Macro -> Parser Macro -> Parser Macro
forall a.
ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tokens Text
-> (ParsedSeq ParsedOp -> ParsedSeq ParsedOp -> Macro)
-> Parser (ParsedSeq ParsedOp -> ParsedSeq ParsedOp -> Macro)
forall a. Tokens Text -> a -> Parser a
word Text
Tokens Text
"IF_SOME" ParsedSeq ParsedOp -> ParsedSeq ParsedOp -> Macro
IF_SOME Parser (ParsedSeq ParsedOp -> ParsedSeq ParsedOp -> Macro)
-> Parser (ParsedSeq ParsedOp)
-> ParsecT
     CustomParserException Text Identity (ParsedSeq ParsedOp -> Macro)
forall a b.
ParsecT CustomParserException Text Identity (a -> b)
-> ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (ParsedSeq ParsedOp)
ops ParsecT
  CustomParserException Text Identity (ParsedSeq ParsedOp -> Macro)
-> Parser (ParsedSeq ParsedOp) -> Parser Macro
forall a b.
ParsecT CustomParserException Text Identity (a -> b)
-> ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (ParsedSeq ParsedOp)
ops
  Parser Macro -> Parser Macro -> Parser Macro
forall a.
ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tokens Text
-> (ParsedSeq ParsedOp -> ParsedSeq ParsedOp -> Macro)
-> Parser (ParsedSeq ParsedOp -> ParsedSeq ParsedOp -> Macro)
forall a. Tokens Text -> a -> Parser a
word Text
Tokens Text
"IF_RIGHT" ParsedSeq ParsedOp -> ParsedSeq ParsedOp -> Macro
IF_RIGHT Parser (ParsedSeq ParsedOp -> ParsedSeq ParsedOp -> Macro)
-> Parser (ParsedSeq ParsedOp)
-> ParsecT
     CustomParserException Text Identity (ParsedSeq ParsedOp -> Macro)
forall a b.
ParsecT CustomParserException Text Identity (a -> b)
-> ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (ParsedSeq ParsedOp)
ops ParsecT
  CustomParserException Text Identity (ParsedSeq ParsedOp -> Macro)
-> Parser (ParsedSeq ParsedOp) -> Parser Macro
forall a b.
ParsecT CustomParserException Text Identity (a -> b)
-> ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (ParsedSeq ParsedOp)
ops

-- | This might look strange, but at the time of writing, reference
-- implementation requires braced argument to @DIIP@, even if the argument is a
-- macro. Thus, @DIP 2 FAIL@ is fine, but @DIIP FAIL@ is a syntax error.
diipMac :: Parser [ParsedOp] -> Parser Macro
diipMac :: Parser [ParsedOp] -> Parser Macro
diipMac Parser [ParsedOp]
ops =
  (Tokens Text
-> ParsecT CustomParserException Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"DI" ParsecT CustomParserException Text Identity (Tokens Text)
-> ParsecT
     CustomParserException Text Identity (ParsedSeq ParsedOp -> Macro)
-> ParsecT
     CustomParserException Text Identity (ParsedSeq ParsedOp -> Macro)
forall a b.
ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity b
-> ParsecT CustomParserException Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Word -> ParsedSeq ParsedOp -> Macro
DIIP (Word -> ParsedSeq ParsedOp -> Macro)
-> (Word -> Word) -> Word -> ParsedSeq ParsedOp -> Macro
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Word
forall a. Enum a => a -> a
succ (Word -> ParsedSeq ParsedOp -> Macro)
-> ParsecT CustomParserException Text Identity Word
-> ParsecT
     CustomParserException Text Identity (ParsedSeq ParsedOp -> Macro)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> ParsecT CustomParserException Text Identity Word
num Text
"I") ParsecT
  CustomParserException Text Identity (ParsedSeq ParsedOp -> Macro)
-> ParsecT CustomParserException Text Identity ()
-> ParsecT
     CustomParserException Text Identity (ParsedSeq ParsedOp -> Macro)
forall a b.
ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity b
-> ParsecT CustomParserException Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Tokens Text -> ParsecT CustomParserException Text Identity ()
symbol1 Text
Tokens Text
"P") ParsecT
  CustomParserException Text Identity (ParsedSeq ParsedOp -> Macro)
-> Parser (ParsedSeq ParsedOp) -> Parser Macro
forall a b.
ParsecT CustomParserException Text Identity (a -> b)
-> ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ([ParsedOp] -> ParsedSeq ParsedOp
forall op. [op] -> ParsedSeq op
Macro.PSSequence ([ParsedOp] -> ParsedSeq ParsedOp)
-> Parser [ParsedOp] -> Parser (ParsedSeq ParsedOp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [ParsedOp]
ops)

num :: Text -> Parser Word
num :: Text -> ParsecT CustomParserException Text Identity Word
num Text
str = [Tokens Text] -> Word
forall i a.
(Integral i, Container a,
 DefaultToInt (IsIntSubType Length i) i) =>
a -> i
length ([Tokens Text] -> Word)
-> ParsecT CustomParserException Text Identity [Tokens Text]
-> ParsecT CustomParserException Text Identity Word
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT CustomParserException Text Identity (Tokens Text)
-> ParsecT CustomParserException Text Identity [Tokens Text]
forall a.
ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (Tokens Text
-> ParsecT CustomParserException Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Text
Tokens Text
str)

duupMac :: Parser Macro
duupMac :: Parser Macro
duupMac = AllowAnnotations -> Parser Macro
duupMac' AllowAnnotations
AllowAnnotations

duupMac' :: AllowAnnotations -> Parser Macro
duupMac' :: AllowAnnotations -> Parser Macro
duupMac' AllowAnnotations
allowAnns =
  (Tokens Text
-> ParsecT CustomParserException Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"DU" ParsecT CustomParserException Text Identity (Tokens Text)
-> ParsecT CustomParserException Text Identity (VarAnn -> Macro)
-> ParsecT CustomParserException Text Identity (VarAnn -> Macro)
forall a b.
ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity b
-> ParsecT CustomParserException Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Word -> VarAnn -> Macro
DUUP (Word -> VarAnn -> Macro)
-> (Word -> Word) -> Word -> VarAnn -> Macro
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Word
forall a. Enum a => a -> a
succ (Word -> VarAnn -> Macro)
-> ParsecT CustomParserException Text Identity Word
-> ParsecT CustomParserException Text Identity (VarAnn -> Macro)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> ParsecT CustomParserException Text Identity Word
num Text
"U") ParsecT CustomParserException Text Identity (VarAnn -> Macro)
-> ParsecT CustomParserException Text Identity ()
-> ParsecT CustomParserException Text Identity (VarAnn -> Macro)
forall a b.
ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity b
-> ParsecT CustomParserException Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Tokens Text -> ParsecT CustomParserException Text Identity ()
symbol1 Text
Tokens Text
"P") ParsecT CustomParserException Text Identity (VarAnn -> Macro)
-> Parser VarAnn -> Parser Macro
forall a b.
ParsecT CustomParserException Text Identity (a -> b)
-> ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AllowAnnotations -> Parser VarAnn -> Parser VarAnn
forall a. Default a => AllowAnnotations -> Parser a -> Parser a
annWithDef AllowAnnotations
allowAnns Parser VarAnn
forall tag. KnownAnnTag tag => Parser (Annotation tag)
noteDef

pairMacInner :: Parser PairStruct
pairMacInner :: Parser PairStruct
pairMacInner = do
  Tokens Text
-> ParsecT CustomParserException Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"P"
  PairStruct
l <- (Tokens Text
-> ParsecT CustomParserException Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"A" ParsecT CustomParserException Text Identity (Tokens Text)
-> PairStruct -> Parser PairStruct
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Annotation FieldTag -> PairStruct
F Annotation FieldTag
forall {k} (a :: k). Annotation a
noAnn) Parser PairStruct -> Parser PairStruct -> Parser PairStruct
forall a.
ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser PairStruct
pairMacInner
  PairStruct
r <- (Tokens Text
-> ParsecT CustomParserException Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"I" ParsecT CustomParserException Text Identity (Tokens Text)
-> PairStruct -> Parser PairStruct
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Annotation FieldTag -> PairStruct
F Annotation FieldTag
forall {k} (a :: k). Annotation a
noAnn) Parser PairStruct -> Parser PairStruct -> Parser PairStruct
forall a.
ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity a
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 = AllowAnnotations -> Parser Macro
pairMac' AllowAnnotations
AllowAnnotations

pairMac' :: AllowAnnotations -> Parser Macro
pairMac' :: AllowAnnotations -> Parser Macro
pairMac' AllowAnnotations
allowAnns = do
  PairStruct
a <- Parser PairStruct
pairMacInner
  Tokens Text -> ParsecT CustomParserException Text Identity ()
symbol1 Text
Tokens Text
"R"
  (Annotation TypeTag
tn, VarAnn
vn, [Annotation FieldTag]
fns) <- AllowAnnotations
-> Parser (Annotation TypeTag, VarAnn, [Annotation FieldTag])
-> Parser (Annotation TypeTag, VarAnn, [Annotation FieldTag])
forall a. Default a => AllowAnnotations -> Parser a -> Parser a
annWithDef AllowAnnotations
allowAnns (Parser (Annotation TypeTag, VarAnn, [Annotation FieldTag])
 -> Parser (Annotation TypeTag, VarAnn, [Annotation FieldTag]))
-> Parser (Annotation TypeTag, VarAnn, [Annotation FieldTag])
-> Parser (Annotation TypeTag, VarAnn, [Annotation FieldTag])
forall a b. (a -> b) -> a -> b
$ ParsecT CustomParserException Text Identity (Annotation TypeTag)
-> Parser VarAnn
-> ParsecT
     CustomParserException Text Identity [Annotation FieldTag]
-> Parser (Annotation TypeTag, VarAnn, [Annotation FieldTag])
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 ParsecT CustomParserException Text Identity (Annotation TypeTag)
forall tag. KnownAnnTag tag => Parser (Annotation tag)
noteDef Parser VarAnn
forall tag. KnownAnnTag tag => Parser (Annotation tag)
note (ParsecT CustomParserException Text Identity (Annotation FieldTag)
-> ParsecT
     CustomParserException Text Identity [Annotation FieldTag]
forall a.
ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ParsecT CustomParserException Text Identity (Annotation FieldTag)
forall tag. KnownAnnTag tag => Parser (Annotation tag)
note)
  let ps :: PairStruct
ps = [Annotation FieldTag] -> PairStruct -> PairStruct
Macro.mapPairLeaves [Annotation FieldTag]
fns PairStruct
a
  return $ PairStruct -> Annotation TypeTag -> VarAnn -> Macro
PAPAIR PairStruct
ps Annotation TypeTag
tn VarAnn
vn

unpairMacInner :: Parser UnpairStruct
unpairMacInner :: Parser UnpairStruct
unpairMacInner = do
  Tokens Text
-> ParsecT CustomParserException Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"P"
  UnpairStruct
l <- (Tokens Text
-> ParsecT CustomParserException Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"A" ParsecT CustomParserException Text Identity (Tokens Text)
-> UnpairStruct -> Parser UnpairStruct
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> UnpairStruct
UF) Parser UnpairStruct -> Parser UnpairStruct -> Parser UnpairStruct
forall a.
ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser UnpairStruct
unpairMacInner
  UnpairStruct
r <- (Tokens Text
-> ParsecT CustomParserException Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"I" ParsecT CustomParserException Text Identity (Tokens Text)
-> UnpairStruct -> Parser UnpairStruct
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> UnpairStruct
UF) Parser UnpairStruct -> Parser UnpairStruct -> Parser UnpairStruct
forall a.
ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser UnpairStruct
unpairMacInner
  return $ UnpairStruct -> UnpairStruct -> UnpairStruct
UP UnpairStruct
l UnpairStruct
r

unpairMac :: AllowAnnotations -> Parser Macro
unpairMac :: AllowAnnotations -> Parser Macro
unpairMac AllowAnnotations
allowAnns =
  Tokens Text
-> ParsecT CustomParserException Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"UN" ParsecT CustomParserException Text Identity (Tokens Text)
-> Parser Macro -> Parser Macro
forall a b.
ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity b
-> ParsecT CustomParserException Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (UnpairStruct -> Macro
UNPAPAIR (UnpairStruct -> Macro) -> Parser UnpairStruct -> Parser Macro
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser UnpairStruct
unpairMacInner) Parser Macro
-> ParsecT CustomParserException Text Identity () -> Parser Macro
forall a b.
ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity b
-> ParsecT CustomParserException Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Tokens Text -> ParsecT CustomParserException Text Identity ()
symbol1 Text
Tokens Text
"R" Parser Macro
-> ParsecT CustomParserException Text Identity () -> Parser Macro
forall a b.
ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity b
-> ParsecT CustomParserException Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*
    AllowAnnotations
-> ParsecT CustomParserException Text Identity ()
-> ParsecT CustomParserException Text Identity ()
forall a. Default a => AllowAnnotations -> Parser a -> Parser a
annWithDef AllowAnnotations
allowAnns (ParsecT CustomParserException Text Identity ()
-> ParsecT CustomParserException Text Identity ()
forall (m :: * -> *) a. MonadPlus m => m a -> m ()
skipMany (ParsecT CustomParserException Text Identity ()
 -> ParsecT CustomParserException Text Identity ())
-> ParsecT CustomParserException Text Identity ()
-> ParsecT CustomParserException Text Identity ()
forall a b. (a -> b) -> a -> b
$ ParsecT CustomParserException Text Identity (Annotation FieldTag)
-> ParsecT CustomParserException Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ParsecT CustomParserException Text Identity (Annotation FieldTag)
noteF ParsecT CustomParserException Text Identity ()
-> ParsecT CustomParserException Text Identity ()
-> ParsecT CustomParserException Text Identity ()
forall a.
ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser VarAnn -> ParsecT CustomParserException Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Parser VarAnn
noteV)

cadrMac :: Parser Macro
cadrMac :: Parser Macro
cadrMac = AllowAnnotations -> Parser Macro
cadrMac' AllowAnnotations
AllowAnnotations

cadrMac' :: AllowAnnotations -> Parser Macro
cadrMac' :: AllowAnnotations -> Parser Macro
cadrMac' AllowAnnotations
allowAnns = do
  Tokens Text
-> ParsecT CustomParserException Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"C"
  [CadrStruct]
as <- (:) (CadrStruct -> [CadrStruct] -> [CadrStruct])
-> ParsecT CustomParserException Text Identity CadrStruct
-> ParsecT
     CustomParserException Text Identity ([CadrStruct] -> [CadrStruct])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT CustomParserException Text Identity CadrStruct
cadrInner ParsecT
  CustomParserException Text Identity ([CadrStruct] -> [CadrStruct])
-> ParsecT CustomParserException Text Identity [CadrStruct]
-> ParsecT CustomParserException Text Identity [CadrStruct]
forall a b.
ParsecT CustomParserException Text Identity (a -> b)
-> ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT CustomParserException Text Identity CadrStruct
-> ParsecT CustomParserException Text Identity [CadrStruct]
forall a.
ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ParsecT CustomParserException Text Identity CadrStruct
cadrInner
  Tokens Text -> ParsecT CustomParserException Text Identity ()
symbol1 Text
Tokens Text
"R"
  (VarAnn
vn, Annotation FieldTag
fn) <- AllowAnnotations
-> Parser (VarAnn, Annotation FieldTag)
-> Parser (VarAnn, Annotation FieldTag)
forall a. Default a => AllowAnnotations -> Parser a -> Parser a
annWithDef AllowAnnotations
allowAnns Parser (VarAnn, Annotation FieldTag)
notesVF
  return $ [CadrStruct] -> VarAnn -> Annotation FieldTag -> Macro
CADR [CadrStruct]
as VarAnn
vn Annotation FieldTag
fn

cadrInner :: Parser CadrStruct
cadrInner :: ParsecT CustomParserException Text Identity CadrStruct
cadrInner = (Tokens Text
-> ParsecT CustomParserException Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"A" ParsecT CustomParserException Text Identity (Tokens Text)
-> CadrStruct
-> ParsecT CustomParserException Text Identity CadrStruct
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> CadrStruct
A) ParsecT CustomParserException Text Identity CadrStruct
-> ParsecT CustomParserException Text Identity CadrStruct
-> ParsecT CustomParserException Text Identity CadrStruct
forall a.
ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Tokens Text
-> ParsecT CustomParserException Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"D" ParsecT CustomParserException Text Identity (Tokens Text)
-> CadrStruct
-> ParsecT CustomParserException Text Identity CadrStruct
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> CadrStruct
D)

carnMac :: Parser Macro
carnMac :: Parser Macro
carnMac = Tokens Text -> ParsecT CustomParserException Text Identity ()
symbol1 Text
Tokens Text
"CAR" ParsecT CustomParserException Text Identity ()
-> Parser Macro -> Parser Macro
forall a b.
ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity b
-> ParsecT CustomParserException Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (VarAnn -> Word -> Macro
CARN (VarAnn -> Word -> Macro)
-> Parser VarAnn
-> ParsecT CustomParserException Text Identity (Word -> Macro)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser VarAnn
forall tag. KnownAnnTag tag => Parser (Annotation tag)
noteDef ParsecT CustomParserException Text Identity (Word -> Macro)
-> ParsecT CustomParserException Text Identity Word -> Parser Macro
forall a b.
ParsecT CustomParserException Text Identity (a -> b)
-> ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT CustomParserException Text Identity Word
-> ParsecT CustomParserException Text Identity Word
forall a. Parser a -> Parser a
lexeme ParsecT CustomParserException Text Identity Word
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
decimal)

cdrnMac :: Parser Macro
cdrnMac :: Parser Macro
cdrnMac = Tokens Text -> ParsecT CustomParserException Text Identity ()
symbol1 Text
Tokens Text
"CDR" ParsecT CustomParserException Text Identity ()
-> Parser Macro -> Parser Macro
forall a b.
ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity b
-> ParsecT CustomParserException Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (VarAnn -> Word -> Macro
CDRN (VarAnn -> Word -> Macro)
-> Parser VarAnn
-> ParsecT CustomParserException Text Identity (Word -> Macro)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser VarAnn
forall tag. KnownAnnTag tag => Parser (Annotation tag)
noteDef ParsecT CustomParserException Text Identity (Word -> Macro)
-> ParsecT CustomParserException Text Identity Word -> Parser Macro
forall a b.
ParsecT CustomParserException Text Identity (a -> b)
-> ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT CustomParserException Text Identity Word
-> ParsecT CustomParserException Text Identity Word
forall a. Parser a -> Parser a
lexeme ParsecT CustomParserException Text Identity Word
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
decimal)

{-# ANN module ("HLint: ignore Reduce duplication" :: Text) #-}
setCadrMac :: AllowAnnotations -> Parser Macro
setCadrMac :: AllowAnnotations -> Parser Macro
setCadrMac AllowAnnotations
allowAnns = do
  Tokens Text
-> ParsecT CustomParserException Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"SET_C"
  [CadrStruct]
a <- ParsecT CustomParserException Text Identity CadrStruct
-> ParsecT CustomParserException Text Identity [CadrStruct]
forall a.
ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ParsecT CustomParserException Text Identity CadrStruct
cadrInner
  Tokens Text -> ParsecT CustomParserException Text Identity ()
symbol1 Text
Tokens Text
"R"
  (VarAnn
v, Annotation FieldTag
f) <- AllowAnnotations
-> Parser (VarAnn, Annotation FieldTag)
-> Parser (VarAnn, Annotation FieldTag)
forall a. Default a => AllowAnnotations -> Parser a -> Parser a
annWithDef AllowAnnotations
allowAnns Parser (VarAnn, Annotation FieldTag)
notesVF
  return $ [CadrStruct] -> VarAnn -> Annotation FieldTag -> Macro
SET_CADR [CadrStruct]
a VarAnn
v Annotation FieldTag
f

mapCadrMac :: Parser (ParsedSeq ParsedOp) -> Parser Macro
mapCadrMac :: Parser (ParsedSeq ParsedOp) -> Parser Macro
mapCadrMac Parser (ParsedSeq ParsedOp)
ops = do
  Tokens Text
-> ParsecT CustomParserException Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"MAP_C"
  [CadrStruct]
a <- ParsecT CustomParserException Text Identity CadrStruct
-> ParsecT CustomParserException Text Identity [CadrStruct]
forall a.
ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ParsecT CustomParserException Text Identity CadrStruct
cadrInner
  Tokens Text -> ParsecT CustomParserException Text Identity ()
symbol1 Text
Tokens Text
"R"
  (VarAnn
v, Annotation FieldTag
f) <- Parser (VarAnn, Annotation FieldTag)
notesVF
  [CadrStruct]
-> VarAnn -> Annotation FieldTag -> ParsedSeq ParsedOp -> Macro
MAP_CADR [CadrStruct]
a VarAnn
v Annotation FieldTag
f (ParsedSeq ParsedOp -> Macro)
-> Parser (ParsedSeq ParsedOp) -> Parser Macro
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (ParsedSeq ParsedOp)
ops

ifCmpMac :: Parser (ParsedSeq ParsedOp) -> Parser Macro
ifCmpMac :: Parser (ParsedSeq ParsedOp) -> Parser Macro
ifCmpMac Parser (ParsedSeq ParsedOp)
ops = Tokens Text
-> ParsecT CustomParserException Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"IFCMP" ParsecT CustomParserException Text Identity (Tokens Text)
-> (ParsedInstr
    -> ParsedSeq ParsedOp -> ParsedSeq ParsedOp -> Macro)
-> ParsecT
     CustomParserException
     Text
     Identity
     (ParsedInstr -> ParsedSeq ParsedOp -> ParsedSeq ParsedOp -> Macro)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ParsedInstr -> ParsedSeq ParsedOp -> ParsedSeq ParsedOp -> Macro
IFCMP ParsecT
  CustomParserException
  Text
  Identity
  (ParsedInstr -> ParsedSeq ParsedOp -> ParsedSeq ParsedOp -> Macro)
-> Parser ParsedInstr
-> Parser (ParsedSeq ParsedOp -> ParsedSeq ParsedOp -> Macro)
forall a b.
ParsecT CustomParserException Text Identity (a -> b)
-> ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AllowAnnotations -> Parser ParsedInstr
cmpOp AllowAnnotations
ForbidAnnotations Parser (ParsedSeq ParsedOp -> ParsedSeq ParsedOp -> Macro)
-> Parser (ParsedSeq ParsedOp)
-> ParsecT
     CustomParserException Text Identity (ParsedSeq ParsedOp -> Macro)
forall a b.
ParsecT CustomParserException Text Identity (a -> b)
-> ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (ParsedSeq ParsedOp)
ops ParsecT
  CustomParserException Text Identity (ParsedSeq ParsedOp -> Macro)
-> Parser (ParsedSeq ParsedOp) -> Parser Macro
forall a b.
ParsecT CustomParserException Text Identity (a -> b)
-> ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (ParsedSeq ParsedOp)
ops

ifX :: Parser (ParsedSeq ParsedOp) -> Parser Macro
ifX :: Parser (ParsedSeq ParsedOp) -> Parser Macro
ifX Parser (ParsedSeq ParsedOp)
ops = Tokens Text -> ParsecT CustomParserException Text Identity ()
symbol Text
Tokens Text
"IF" ParsecT CustomParserException Text Identity ()
-> (ParsedInstr
    -> ParsedSeq ParsedOp -> ParsedSeq ParsedOp -> Macro)
-> ParsecT
     CustomParserException
     Text
     Identity
     (ParsedInstr -> ParsedSeq ParsedOp -> ParsedSeq ParsedOp -> Macro)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ParsedInstr -> ParsedSeq ParsedOp -> ParsedSeq ParsedOp -> Macro
IFX ParsecT
  CustomParserException
  Text
  Identity
  (ParsedInstr -> ParsedSeq ParsedOp -> ParsedSeq ParsedOp -> Macro)
-> Parser ParsedInstr
-> Parser (ParsedSeq ParsedOp -> ParsedSeq ParsedOp -> Macro)
forall a b.
ParsecT CustomParserException Text Identity (a -> b)
-> ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> AllowAnnotations -> Parser ParsedInstr
cmpOp AllowAnnotations
ForbidAnnotations Parser (ParsedSeq ParsedOp -> ParsedSeq ParsedOp -> Macro)
-> Parser (ParsedSeq ParsedOp)
-> ParsecT
     CustomParserException Text Identity (ParsedSeq ParsedOp -> Macro)
forall a b.
ParsecT CustomParserException Text Identity (a -> b)
-> ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (ParsedSeq ParsedOp)
ops ParsecT
  CustomParserException Text Identity (ParsedSeq ParsedOp -> Macro)
-> Parser (ParsedSeq ParsedOp) -> Parser Macro
forall a b.
ParsecT CustomParserException Text Identity (a -> b)
-> ParsecT CustomParserException Text Identity a
-> ParsecT CustomParserException Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (ParsedSeq ParsedOp)
ops