-- 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) = "" build (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