module Michelson.Macro
(
CadrStruct (..)
, PairStruct (..)
, Macro (..)
, LetMacro (..)
, ParsedValue
, ParsedInstr
, ParsedOp (..)
, ParsedUExtInstr
, expandContract
, expandValue
, mapLeaves
, expand
, expandList
, expandMacro
, expandPapair
, expandUnpapair
, expandCadr
, expandSetCadr
, expandMapCadr
) where
import Data.Aeson.TH (defaultOptions, deriveJSON)
import Data.Data (Data(..))
import qualified Data.Text as T
import Fmt (Buildable(build), genericF, (+|), (+||), (|+), (||+))
import qualified Text.PrettyPrint.Leijen.Text as PP (empty)
import Michelson.ErrorPos
import Michelson.Printer (RenderDoc(..))
import Michelson.Untyped
import Util.Generic
import Util.Positive
data LetMacro = LetMacro
{ lmName :: T.Text
, lmSig :: StackFn
, lmExpr :: [ParsedOp]
} deriving stock (Eq, Show, Data, Generic)
instance Buildable LetMacro where
build = genericF
data PairStruct
= F (VarAnn, FieldAnn)
| P PairStruct PairStruct
deriving stock (Eq, Show, Data, Generic)
instance Buildable PairStruct where
build = genericF
data CadrStruct
= A
| D
deriving stock (Eq, Show, Data, Generic)
instance Buildable CadrStruct where
build = genericF
data ParsedOp
= Prim ParsedInstr SrcPos
| Mac Macro SrcPos
| LMac LetMacro SrcPos
| Seq [ParsedOp] SrcPos
deriving stock (Eq, Show, Data, Generic)
instance RenderDoc ParsedOp where
renderDoc _ _ = PP.empty
instance Buildable ParsedOp where
build = \case
Prim parseInstr _ -> "<Prim: "+|parseInstr|+">"
Mac macro _ -> "<Mac: "+|macro|+">"
LMac letMacro _ -> "<LMac: "+|letMacro|+">"
Seq parsedOps _ -> "<Seq: "+|parsedOps|+">"
type ParsedUExtInstr = ExtInstrAbstract ParsedOp
type ParsedInstr = InstrAbstract ParsedOp
type ParsedValue = Value' ParsedOp
data Macro
= CASE (NonEmpty [ParsedOp])
| TAG Natural (NonEmpty Type)
| ACCESS Natural Positive
| SET Natural Positive
| CONSTRUCT (NonEmpty [ParsedOp])
| VIEW [ParsedOp]
| VOID [ParsedOp]
| CMP ParsedInstr VarAnn
| IFX ParsedInstr [ParsedOp] [ParsedOp]
| IFCMP ParsedInstr VarAnn [ParsedOp] [ParsedOp]
| FAIL
| PAPAIR PairStruct TypeAnn VarAnn
| UNPAIR PairStruct
| CADR [CadrStruct] VarAnn FieldAnn
| SET_CADR [CadrStruct] VarAnn FieldAnn
| MAP_CADR [CadrStruct] VarAnn FieldAnn [ParsedOp]
| DIIP Word [ParsedOp]
| DUUP Word VarAnn
| ASSERT
| ASSERTX ParsedInstr
| ASSERT_CMP ParsedInstr
| ASSERT_NONE
| ASSERT_SOME
| ASSERT_LEFT
| ASSERT_RIGHT
| IF_SOME [ParsedOp] [ParsedOp]
| IF_RIGHT [ParsedOp] [ParsedOp]
deriving stock (Eq, Show, Data, Generic)
instance Buildable Macro where
build = \case
TAG idx ty -> "<TAG: #"+||idx||+" from "+|toList ty|+""
CASE parsedInstrs -> "<CASE: "+|toList parsedInstrs|+">"
ACCESS idx size -> "<ACCESS: #"+||idx||+"/"+|size|+""
SET idx size -> "<SET: #"+||idx||+"/"+|size|+""
CONSTRUCT parsedInstrs -> "<CONSTRUCT: "+|toList parsedInstrs|+">"
VIEW code -> "<VIEW: "+|code|+">"
VOID code -> "<VOID: "+|code|+">"
CMP parsedInstr carAnn -> "<CMP: "+|parsedInstr|+", "+|carAnn|+">"
IFX parsedInstr parsedOps1 parsedOps2 -> "<IFX: "+|parsedInstr|+", "+|parsedOps1|+", "+|parsedOps2|+">"
IFCMP parsedInstr varAnn parsedOps1 parsedOps2 -> "<IFCMP: "+|parsedInstr|+", "+|varAnn|+", "+|parsedOps1|+", "+|parsedOps2|+">"
FAIL -> "FAIL"
PAPAIR pairStruct typeAnn varAnn -> "<PAPAIR: "+|pairStruct|+", "+|typeAnn|+", "+|varAnn|+">"
UNPAIR pairStruct -> "<UNPAIR: "+|pairStruct|+">"
CADR cadrStructs varAnn fieldAnn -> "<CADR: "+|cadrStructs|+", "+|varAnn|+", "+|fieldAnn|+">"
SET_CADR cadrStructs varAnn fieldAnn -> "<SET_CADR: "+|cadrStructs|+", "+|varAnn|+", "+|fieldAnn|+">"
MAP_CADR cadrStructs varAnn fieldAnn parsedOps -> "<MAP_CADR: "+|cadrStructs|+", "+|varAnn|+", "+|fieldAnn|+", "+|parsedOps|+">"
DIIP integer parsedOps -> "<DIIP: "+|integer|+", "+|parsedOps|+">"
DUUP integer varAnn -> "<DUUP: "+|integer|+", "+|varAnn|+">"
ASSERT -> "ASSERT"
ASSERTX parsedInstr -> "<ASSERTX: "+|parsedInstr|+">"
ASSERT_CMP parsedInstr -> "<ASSERT_CMP: "+|parsedInstr|+">"
ASSERT_NONE -> "ASSERT_NONE"
ASSERT_SOME -> "ASSERT_SOME"
ASSERT_LEFT -> "ASSERT_LEFT"
ASSERT_RIGHT -> "ASSERT_RIGHT"
IF_SOME parsedOps1 parsedOps2 -> "<IF_SOME: "+|parsedOps1|+", "+|parsedOps2|+">"
IF_RIGHT parsedOps1 parsedOps2 -> "<IF_RIGHT: "+|parsedOps1|+", "+|parsedOps2|+">"
expandList :: [ParsedOp] -> [ExpandedOp]
expandList = fmap (expand [])
expandContract :: Contract' ParsedOp -> Contract
expandContract Contract {..} = Contract para stor (expandList code)
expandValue :: ParsedValue -> Value
expandValue = \case
ValuePair l r -> ValuePair (expandValue l) (expandValue r)
ValueLeft x -> ValueLeft (expandValue x)
ValueRight x -> ValueRight (expandValue x)
ValueSome x -> ValueSome (expandValue x)
ValueNil -> ValueNil
ValueSeq valueList -> ValueSeq (map expandValue valueList)
ValueMap eltList -> ValueMap (map expandElt eltList)
ValueLambda opList ->
maybe ValueNil ValueLambda $
nonEmpty (expandList $ toList opList)
x -> fmap (expand []) x
expandElt :: Elt ParsedOp -> Elt ExpandedOp
expandElt (Elt l r) = Elt (expandValue l) (expandValue r)
expand :: LetCallStack -> ParsedOp -> ExpandedOp
expand cs = let ics pos = InstrCallStack cs pos in \case
(Mac (PAPAIR (P (F a) (F b)) t v) pos) ->
WithSrcEx (ics pos) $ PrimEx (PAIR t v (snd a) (snd b))
(Mac (DIIP n ops) pos) ->
WithSrcEx (ics pos) $ PrimEx (DIPN n (expand cs <$> ops))
(Mac m pos) -> WithSrcEx (ics pos) $ SeqEx $ expandMacro (ics pos) m
(Prim i pos) -> WithSrcEx (ics pos) $ PrimEx $ expand cs <$> i
(Seq s pos) -> WithSrcEx (ics pos) $ SeqEx $ expand cs <$> s
(LMac l pos) -> expandLetMac l
where
expandLetMac :: LetMacro -> ExpandedOp
expandLetMac LetMacro {..} =
let newCS = LetName lmName : cs in
let ics' = InstrCallStack newCS pos in
WithSrcEx ics' $ PrimEx . EXT . FN lmName lmSig $ expand newCS <$> lmExpr
expandMacro :: InstrCallStack -> Macro -> [ExpandedOp]
expandMacro p@InstrCallStack{icsCallStack=cs,icsSrcPos=macroPos} = \case
VIEW a -> expandMacro p (UNPAIR $ P (F (noAnn,noAnn)) (F (noAnn,noAnn))) ++
[ PrimEx (DIP $ expandMacro p $ DUUP 2 noAnn) ] ++
[ PrimEx $ PAIR noAnn noAnn noAnn noAnn ] ++
(expand cs <$> a) ++
[ PrimEx (DIP [PrimEx $ AMOUNT noAnn])
, PrimEx $ TRANSFER_TOKENS noAnn
, PrimEx $ NIL noAnn noAnn (Type TOperation noAnn)
, PrimEx $ SWAP
, PrimEx $ CONS noAnn
, PrimEx $ PAIR noAnn noAnn noAnn noAnn
]
VOID a -> expandMacro p (UNPAIR (P (F (noAnn,noAnn)) (F (noAnn,noAnn)))) ++
[ PrimEx SWAP
, PrimEx $ DIP $ expand cs <$> a
, PrimEx SWAP
, PrimEx $ EXEC noAnn
, PrimEx FAILWITH
]
CASE ops -> expandCase (map (expand cs) <$> ops)
TAG idx uty -> expandTag idx uty
ACCESS idx size -> expandAccess idx size
SET idx size -> expandSet idx size
CONSTRUCT ops -> expandConstruct (map (expand cs) <$> ops)
CMP i v -> [PrimEx (COMPARE v), xo i]
IFX i bt bf -> [xo i, PrimEx $ IF (xp bt) (xp bf)]
IFCMP i v bt bf -> PrimEx <$> [COMPARE v, expand cs <$> i, IF (xp bt) (xp bf)]
IF_SOME bt bf -> [PrimEx (IF_NONE (xp bf) (xp bt))]
IF_RIGHT bt bf -> [PrimEx (IF_LEFT (xp bf) (xp bt))]
FAIL -> PrimEx <$> [UNIT noAnn noAnn, FAILWITH]
ASSERT -> oprimEx $ IF [] (expandMacro p FAIL)
ASSERTX i -> [expand cs $ mac $ IFX i [] [mac FAIL]]
ASSERT_CMP i -> [expand cs $ mac $ IFCMP i noAnn [] [mac FAIL]]
ASSERT_NONE -> oprimEx $ IF_NONE [] (expandMacro p FAIL)
ASSERT_SOME -> oprimEx $ IF_NONE (expandMacro p FAIL) []
ASSERT_LEFT -> oprimEx $ IF_LEFT [] (expandMacro p FAIL)
ASSERT_RIGHT -> oprimEx $ IF_LEFT (expandMacro p FAIL) []
PAPAIR ps t v -> expandPapair p ps t v
UNPAIR ps -> expandUnpapair p ps
CADR c v f -> expandCadr p c v f
SET_CADR c v f -> expandSetCadr p c v f
MAP_CADR c v f ops -> expandMapCadr p c v f ops
DIIP {} -> error "expandMacro DIIP is unreachable"
DUUP 1 v -> oprimEx $ DUP v
DUUP 2 v -> PrimEx <$> [DIP [PrimEx $ DUP v], SWAP]
DUUP n v -> PrimEx <$> [DIPN (n - 1) [PrimEx $ DUP v], DIG n]
where
mac = flip Mac macroPos
oprimEx = one . PrimEx
xo = PrimEx . fmap (expand cs)
xp = fmap (expand cs)
expandPapair :: InstrCallStack -> PairStruct -> TypeAnn -> VarAnn -> [ExpandedOp]
expandPapair ics ps t v = case ps of
P (F a) (F b) -> [PrimEx $ PAIR t v (snd a) (snd b)]
P (F a) r -> PrimEx <$> [ DIP $ expandMacro ics (PAPAIR r noAnn noAnn)
, PAIR t v (snd a) noAnn]
P l (F b) -> expandMacro ics (PAPAIR l noAnn noAnn) ++
[PrimEx $ PAIR t v noAnn (snd b)]
P l r -> expandMacro ics (PAPAIR l noAnn noAnn) ++
[ PrimEx $ DIP $ expandMacro ics (PAPAIR r noAnn noAnn)
, PrimEx $ PAIR t v noAnn noAnn]
F _ -> []
expandUnpapair :: InstrCallStack -> PairStruct -> [ExpandedOp]
expandUnpapair ics = \case
P (F (v,f)) (F (w,g)) ->
PrimEx <$> [ DUP noAnn
, CAR v f
, DIP [PrimEx $ CDR w g]
]
P (F (v, f)) r ->
PrimEx <$> [ DUP noAnn
, CAR v f
, DIP (PrimEx (CDR noAnn noAnn) : expandMacro ics (UNPAIR r))
]
P l (F (v, f)) ->
map PrimEx [ DUP noAnn
, DIP [PrimEx $ CDR v f]
, CAR noAnn noAnn
] ++
expandMacro ics (UNPAIR l)
P l r ->
expandMacro ics unpairOne ++
[PrimEx $ DIP $ expandMacro ics $ UNPAIR r] ++
expandMacro ics (UNPAIR l)
F _ -> []
where
unpairOne = UNPAIR (P fn fn)
fn = F (noAnn, noAnn)
expandCadr :: InstrCallStack -> [CadrStruct] -> VarAnn -> FieldAnn -> [ExpandedOp]
expandCadr ics cs v f = case cs of
[] -> []
[A] -> [PrimEx $ CAR v f]
[D] -> [PrimEx $ CDR v f]
A:css -> PrimEx (CAR noAnn noAnn) : expandMacro ics (CADR css v f)
D:css -> PrimEx (CDR noAnn noAnn) : expandMacro ics (CADR css v f)
carNoAnn :: InstrAbstract op
carNoAnn = CAR noAnn noAnn
cdrNoAnn :: InstrAbstract op
cdrNoAnn = CDR noAnn noAnn
pairNoAnn :: VarAnn -> InstrAbstract op
pairNoAnn v = PAIR noAnn v noAnn noAnn
expandSetCadr :: InstrCallStack -> [CadrStruct] -> VarAnn -> FieldAnn -> [ExpandedOp]
expandSetCadr ics cs v f = PrimEx <$> case cs of
[] -> []
[A] -> [DUP noAnn, CAR noAnn f, DROP,
CDR (ann "%%") noAnn, SWAP, PAIR noAnn v f (ann "@")]
[D] -> [DUP noAnn, CDR noAnn f, DROP,
CAR (ann "%%") noAnn, PAIR noAnn v (ann "@") f]
A:css -> [DUP noAnn, DIP (PrimEx carNoAnn : expandMacro ics (SET_CADR css noAnn f)), cdrNoAnn, SWAP, pairNoAnn v]
D:css -> [DUP noAnn, DIP (PrimEx cdrNoAnn : expandMacro ics (SET_CADR css noAnn f)), carNoAnn, pairNoAnn v]
expandMapCadr :: InstrCallStack -> [CadrStruct] -> VarAnn -> FieldAnn -> [ParsedOp] -> [ExpandedOp]
expandMapCadr ics@InstrCallStack{icsCallStack=cls} cs v f ops = case cs of
[] -> []
[A] -> PrimEx <$> [DUP noAnn, cdrNoAnn, DIP [PrimEx $ CAR noAnn f, SeqEx (expand cls <$> ops)], SWAP, pairNoAnn v]
[D] -> concat [PrimEx <$> [DUP noAnn, CDR noAnn f], [SeqEx (expand cls <$> ops)], PrimEx <$> [SWAP, carNoAnn, pairNoAnn v]]
A:css -> PrimEx <$> [DUP noAnn, DIP (PrimEx carNoAnn : expandMacro ics (MAP_CADR css noAnn f ops)), cdrNoAnn, SWAP, pairNoAnn v]
D:css -> PrimEx <$> [DUP noAnn, DIP (PrimEx cdrNoAnn : expandMacro ics (MAP_CADR css noAnn f ops)), carNoAnn, pairNoAnn v]
expandCase :: NonEmpty [ExpandedOp] -> [ExpandedOp]
expandCase = mkGenericTree (\_ l r -> one . PrimEx $ IF_LEFT l r)
expandTag :: Natural -> NonEmpty Type -> [ExpandedOp]
expandTag idx unionTy =
reverse . fst $ mkGenericTree merge (([], ) <$> unionTy)
where
merge i (li, lt) (ri, rt) =
let ty = Type (TOr noAnn noAnn lt rt) noAnn
in if idx < i
then (PrimEx (LEFT noAnn noAnn noAnn noAnn rt) : li, ty)
else (PrimEx (RIGHT noAnn noAnn noAnn noAnn lt) : ri, ty)
expandAccess :: Natural -> Positive -> [ExpandedOp]
expandAccess idx size =
mkGenericTree merge (replicateNE size [])
where
merge i li ri =
if idx < i
then PrimEx (CAR noAnn noAnn) : li
else PrimEx (CDR noAnn noAnn) : ri
expandSet :: Natural -> Positive -> [ExpandedOp]
expandSet idx size =
PrimEx <$>
appEndo (mkGenericTree merge (replicateNE size base)) []
where
base = pre $ DIP [PrimEx DROP]
merge i li ri = mconcat $
if idx < i
then [ pre $ DIP
(map PrimEx [DUP n, DIP [PrimEx $ CDR n n], CAR n n])
, li
, pre $ PAIR n n n n
]
else [ pre $ DIP
(map PrimEx [DUP n, DIP [PrimEx $ CAR n n], CDR n n])
, ri
, pre $ SWAP
, pre $ PAIR n n n n
]
pre e = Endo (e :)
n = noAnn
expandConstruct :: NonEmpty [ExpandedOp] -> [ExpandedOp]
expandConstruct ctors =
appEndo (mkGenericTree merge $ map toBase ctors) []
where
toBase ops = Endo (ops ++)
merge _ li ri =
mconcat
[ li
, pre . PrimEx $ DIP (appEndo ri [])
, pre . PrimEx $ PAIR noAnn noAnn noAnn noAnn
]
pre e = Endo (e :)
mapLeaves :: [(VarAnn, FieldAnn)] -> PairStruct -> PairStruct
mapLeaves fs p = evalState (leavesST p) fs
leavesST :: PairStruct -> State [(VarAnn, FieldAnn)] PairStruct
leavesST = \case
(P l r) -> do
l' <- leavesST l
r' <- leavesST r
return $ P l' r'
(F _) -> do
f <- state getLeaf
return $ F f
where
getLeaf (a:as) = (a, as)
getLeaf _ = ((noAnn, noAnn), [])
deriveJSON defaultOptions ''ParsedOp
deriveJSON defaultOptions ''LetMacro
deriveJSON defaultOptions ''PairStruct
deriveJSON defaultOptions ''CadrStruct
deriveJSON defaultOptions ''Macro