morley-1.7.0: src/Michelson/Untyped/Instr.hs
-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ
-- | Michelson instructions in untyped model.
module Michelson.Untyped.Instr
( InstrAbstract (..)
, ExpandedOp (..)
, ExpandedInstr
, flattenExpandedOp
-- * Contract's address
, OperationHash (..)
) where
import Prelude hiding (EQ, GT, LT)
import Data.Aeson.TH (deriveJSON)
import Data.Data (Data(..))
import Fmt (Buildable(build), (+|), (|+))
import Generics.SYB (everywhere, mkT)
import Text.PrettyPrint.Leijen.Text
(Doc, align, braces, enclose, indent, line, nest, space, text, (<$$>), (<+>))
import qualified Text.Show
import Michelson.ErrorPos (InstrCallStack)
import Michelson.Printer.Util
(RenderDoc(..), buildRenderDoc, doesntNeedParens, needsParens, printDocS, renderOpsList, spaces)
import Michelson.Untyped.Annotation
(Annotation, FieldAnn, KnownAnnTag, TypeAnn, VarAnn, fullAnnSet, singleAnnSet)
import Michelson.Untyped.Contract (Contract'(..))
import Michelson.Untyped.Ext (ExtInstrAbstract)
import Michelson.Untyped.Type (Type)
import Michelson.Untyped.Value (Value'(..))
import Tezos.Address (OperationHash(..))
import Util.Aeson
-------------------------------------
-- Types after macroexpander
-------------------------------------
type ExpandedInstr = InstrAbstract ExpandedOp
data ExpandedOp
= PrimEx ExpandedInstr
| SeqEx [ExpandedOp]
| WithSrcEx InstrCallStack ExpandedOp
deriving stock (Show, Eq, Data, Generic)
instance NFData ExpandedOp
instance RenderDoc ExpandedOp where
renderDoc pn (WithSrcEx _ op) = renderDoc pn op
renderDoc pn (PrimEx i) = renderDoc pn i
renderDoc _ (SeqEx i) = renderOpsList False i
isRenderable =
\case PrimEx i -> isRenderable i
WithSrcEx _ op -> isRenderable op
_ -> True
instance Buildable ExpandedOp where
build (WithSrcEx _ op) = build op
build (PrimEx expandedInstr) = "<PrimEx: "+|expandedInstr|+">"
build (SeqEx expandedOps) = "<SeqEx: "+|expandedOps|+">"
-- | Flatten all 'SeqEx' in 'ExpandedOp'. This function is mostly for
-- testing. It returns instructions with the same logic, but they are
-- not strictly equivalent, because they are serialized differently
-- (grouping instructions into sequences affects the way they are
-- PACK'ed).
flattenExpandedOp :: ExpandedOp -> [ExpandedInstr]
flattenExpandedOp =
\case
PrimEx i -> [flattenInstr i]
SeqEx ops -> concatMap flattenExpandedOp ops
WithSrcEx _ op -> flattenExpandedOp op
where
flattenInstr :: ExpandedInstr -> ExpandedInstr
flattenInstr = everywhere (mkT flattenOps)
flattenOps :: [ExpandedOp] -> [ExpandedOp]
flattenOps [] = []
flattenOps (SeqEx s : xs) = s ++ flattenOps xs
flattenOps (x@(PrimEx _) : xs) = x : flattenOps xs
flattenOps (WithSrcEx _ op : xs) = op : flattenOps xs
-------------------------------------
-- Abstract instruction
-------------------------------------
-- | Michelson instruction with abstract parameter `op`. This
-- parameter is necessary, because at different stages of our pipeline
-- it will be different. Initially it can contain macros and
-- non-flattened instructions, but then it contains only vanilla
-- Michelson instructions.
data InstrAbstract op
= EXT (ExtInstrAbstract op)
| DROPN Word
-- ^ "DROP n" instruction.
-- Note: reference implementation permits int16 here.
-- Negative numbers are parsed successfully there, but rejected later.
-- Morley is more permissive, so we use 'Word' here,
-- i. e. permit more positive numbers. We do not permit negative numbers
-- at type level.
-- In practice, probably nobody will ever have numbers greater than ≈1000
-- here, at least due to gas limits.
-- Same reasoning applies to other instructions which have a numeric
-- parameter representing number of elements on stack.
| DROP
-- ^ 'DROP' is essentially as special case for 'DROPN', but we need
-- both because they are packed differently.
| DUP VarAnn
| SWAP
| DIG Word
| DUG Word
| PUSH VarAnn Type (Value' op)
| SOME TypeAnn VarAnn
| NONE TypeAnn VarAnn Type
| UNIT TypeAnn VarAnn
| IF_NONE [op] [op]
| PAIR TypeAnn VarAnn FieldAnn FieldAnn
| CAR VarAnn FieldAnn
| CDR VarAnn FieldAnn
| LEFT TypeAnn VarAnn FieldAnn FieldAnn Type
| RIGHT TypeAnn VarAnn FieldAnn FieldAnn Type
| IF_LEFT [op] [op]
| NIL TypeAnn VarAnn Type
| CONS VarAnn -- TODO add TypeNote param
| IF_CONS [op] [op]
| SIZE VarAnn
| EMPTY_SET TypeAnn VarAnn Type
| EMPTY_MAP TypeAnn VarAnn Type Type
| EMPTY_BIG_MAP TypeAnn VarAnn Type Type
| MAP VarAnn [op]
| ITER [op]
| MEM VarAnn
| GET VarAnn
| UPDATE VarAnn
| IF [op] [op]
| LOOP [op]
| LOOP_LEFT [op]
| LAMBDA VarAnn Type Type [op]
-- TODO check on alphanet whether we can pass TypeNote
| EXEC VarAnn
| APPLY VarAnn
| DIP [op]
| DIPN Word [op]
| FAILWITH
| CAST VarAnn Type
| RENAME VarAnn
| PACK VarAnn
| UNPACK TypeAnn VarAnn Type
| CONCAT VarAnn
| SLICE VarAnn
| ISNAT VarAnn
| ADD VarAnn
| SUB VarAnn
| MUL VarAnn
| EDIV VarAnn
| ABS VarAnn
| NEG VarAnn
| LSL VarAnn
| LSR VarAnn
| OR VarAnn
| AND VarAnn
| XOR VarAnn
| NOT VarAnn
| COMPARE VarAnn
| EQ VarAnn
| NEQ VarAnn
| LT VarAnn
| GT VarAnn
| LE VarAnn
| GE VarAnn
| INT VarAnn
| SELF VarAnn FieldAnn
| CONTRACT VarAnn FieldAnn Type
| TRANSFER_TOKENS VarAnn
| SET_DELEGATE VarAnn
| CREATE_CONTRACT VarAnn VarAnn (Contract' op)
| IMPLICIT_ACCOUNT VarAnn
| NOW VarAnn
| AMOUNT VarAnn
| BALANCE VarAnn
| CHECK_SIGNATURE VarAnn
| SHA256 VarAnn
| SHA512 VarAnn
| BLAKE2B VarAnn
| HASH_KEY VarAnn
| SOURCE VarAnn
| SENDER VarAnn
| ADDRESS VarAnn
| CHAIN_ID VarAnn
deriving stock (Eq, Functor, Data, Generic)
instance RenderDoc (InstrAbstract op) => Show (InstrAbstract op) where
show = printDocS True . renderDoc doesntNeedParens
instance NFData op => NFData (InstrAbstract op)
instance (RenderDoc op) => RenderDoc (InstrAbstract op) where
renderDoc pn = \case
EXT extInstr -> renderDoc pn extInstr
DROP -> "DROP"
DROPN n -> "DROP" <+> text (show n)
DUP va -> "DUP" <+> renderAnnot va
SWAP -> "SWAP"
DIG n -> "DIG" <+> text (show n)
DUG n -> "DUG" <+> text (show n)
PUSH va t v -> "PUSH" <+> renderAnnot va <+> renderTy t <+> renderDoc needsParens v
SOME ta va -> "SOME" <+> renderAnnots [ta] [] [va]
NONE ta va t -> "NONE" <+> renderAnnots [ta] [] [va] <+> renderTy t
UNIT ta va -> "UNIT" <+> renderAnnots [ta] [] [va]
IF_NONE x y -> "IF_NONE" <+> nest 9 (renderOps x) <$$> spaces 8 <> nest 9 (renderOps y)
PAIR ta va fa1 fa2 -> "PAIR" <+> renderAnnots [ta] [fa1, fa2] [va]
CAR va fa -> "CAR" <+> renderAnnots [] [fa] [va]
CDR va fa -> "CDR" <+> renderAnnots [] [fa] [va]
LEFT ta va fa1 fa2 t -> "LEFT" <+> renderAnnots [ta] [fa1, fa2] [va] <+> renderTy t
RIGHT ta va fa1 fa2 t -> "RIGHT" <+> renderAnnots [ta] [fa1, fa2] [va] <+> renderTy t
IF_LEFT x y -> "IF_LEFT" <+> nest 9 (renderOps x) <$$> spaces 8 <> nest 9 (renderOps y)
NIL ta va t -> "NIL" <+> renderAnnots [ta] [] [va] <+> renderTy t
CONS va -> "CONS" <+> renderAnnot va
IF_CONS x y -> "IF_CONS" <+> nest 9 (renderOps x) <$$> spaces 8 <> nest 9 (renderOps y)
SIZE va -> "SIZE" <+> renderAnnot va
EMPTY_SET ta va t -> "EMPTY_SET" <+> renderAnnots [ta] [] [va] <+> renderComp t
EMPTY_MAP ta va c t -> "EMPTY_MAP" <+> renderAnnots [ta] [] [va] <+> renderComp c <+> renderTy t
EMPTY_BIG_MAP ta va c t -> "EMPTY_BIG_MAP" <+> renderAnnots [ta] [] [va] <+> renderComp c <+> renderTy t
MAP va s -> "MAP" <+> renderAnnot va <$$> spaces 4 <> nest 5 (renderOps s)
ITER s -> "ITER" <+> nest 6 (renderOps s)
MEM va -> "MEM" <+> renderAnnot va
GET va -> "GET" <+> renderAnnot va
UPDATE va -> "UPDATE" <+> renderAnnot va
IF x y -> "IF" <+> nest 4 (renderOps x) <$$> spaces 3 <> nest 4 (renderOps y)
LOOP s -> "LOOP" <+> nest 6 (renderOps s)
LOOP_LEFT s -> "LOOP_LEFT" <+> nest 11 (renderOps s)
LAMBDA va t r s -> "LAMBDA" <+> renderAnnot va <$$> (spaces 2 <> renderTy t) <$$> (spaces 2 <> renderTy r) <$$> spaces 2 <> nest 3 (renderOps s)
EXEC va -> "EXEC" <+> renderAnnot va
APPLY va -> "APPLY" <+> renderAnnot va
DIP s -> "DIP" <+> nest 5 (renderOps s)
DIPN n s -> "DIP" <+> text (show n) <> line <> indent 4 (renderOps s)
FAILWITH -> "FAILWITH"
CAST va t -> "CAST" <+> renderAnnot va <+> renderTy t
RENAME va -> "RENAME" <+> renderAnnot va
PACK va -> "PACK" <+> renderAnnot va
UNPACK ta va t -> "UNPACK" <+> renderAnnots [ta] [] [va] <+> renderTy t
CONCAT va -> "CONCAT" <+> renderAnnot va
SLICE va -> "SLICE" <+> renderAnnot va
ISNAT va -> "ISNAT" <+> renderAnnot va
ADD va -> "ADD" <+> renderAnnot va
SUB va -> "SUB" <+> renderAnnot va
MUL va -> "MUL" <+> renderAnnot va
EDIV va -> "EDIV" <+> renderAnnot va
ABS va -> "ABS" <+> renderAnnot va
NEG va -> "NEG" <+> renderAnnot va
LSL va -> "LSL" <+> renderAnnot va
LSR va -> "LSR" <+> renderAnnot va
OR va -> "OR" <+> renderAnnot va
AND va -> "AND" <+> renderAnnot va
XOR va -> "XOR" <+> renderAnnot va
NOT va -> "NOT" <+> renderAnnot va
COMPARE va -> "COMPARE" <+> renderAnnot va
EQ va -> "EQ" <+> renderAnnot va
NEQ va -> "NEQ" <+> renderAnnot va
LT va -> "LT" <+> renderAnnot va
GT va -> "GT" <+> renderAnnot va
LE va -> "LE" <+> renderAnnot va
GE va -> "GE" <+> renderAnnot va
INT va -> "INT" <+> renderAnnot va
SELF va fa -> "SELF" <+> renderAnnots [] [fa] [va]
CONTRACT va fa t -> "CONTRACT" <+> renderAnnots [] [fa] [va] <+> renderTy t
TRANSFER_TOKENS va -> "TRANSFER_TOKENS" <+> renderAnnot va
SET_DELEGATE va -> "SET_DELEGATE" <+> renderAnnot va
CREATE_CONTRACT va1 va2 contract -> let
body = enclose space space $ align $ (renderDoc doesntNeedParens contract)
in "CREATE_CONTRACT" <+> renderAnnots [] [] [va1, va2] <$$> (indent 2 $ braces $ body)
IMPLICIT_ACCOUNT va -> "IMPLICIT_ACCOUNT" <+> renderAnnot va
NOW va -> "NOW" <+> renderAnnot va
AMOUNT va -> "AMOUNT" <+> renderAnnot va
BALANCE va -> "BALANCE" <+> renderAnnot va
CHECK_SIGNATURE va -> "CHECK_SIGNATURE" <+> renderAnnot va
SHA256 va -> "SHA256" <+> renderAnnot va
SHA512 va -> "SHA512" <+> renderAnnot va
BLAKE2B va -> "BLAKE2B" <+> renderAnnot va
HASH_KEY va -> "HASH_KEY" <+> renderAnnot va
SOURCE va -> "SOURCE" <+> renderAnnot va
SENDER va -> "SENDER" <+> renderAnnot va
ADDRESS va -> "ADDRESS" <+> renderAnnot va
CHAIN_ID va -> "CHAIN_ID" <+> renderAnnot va
where
renderTy = renderDoc @Type needsParens
renderComp = renderDoc @Type needsParens
renderOps = renderOpsList False
renderAnnot :: KnownAnnTag tag => Annotation tag -> Doc
renderAnnot = renderDoc doesntNeedParens . singleAnnSet
renderAnnots :: [TypeAnn] -> [FieldAnn] -> [VarAnn] -> Doc
renderAnnots ts fs vs = renderDoc doesntNeedParens $ fullAnnSet ts fs vs
isRenderable = \case
EXT extInstr -> isRenderable extInstr
_ -> True
instance (RenderDoc op, Buildable op) => Buildable (InstrAbstract op) where
build = \case
EXT ext -> build ext
mi -> buildRenderDoc mi
----------------------------------------------------------------------------
-- JSON serialization
----------------------------------------------------------------------------
deriveJSON morleyAesonOptions ''ExpandedOp
deriveJSON morleyAesonOptions ''InstrAbstract