module Michelson.Untyped.Instr
( InstrAbstract (..)
, ExpandedOp (..)
, ExpandedInstr
, flattenExpandedOp
, OriginationOperation (..)
, mkContractAddress
) where
import Prelude hiding (EQ, GT, LT)
import qualified Data.Aeson as Aeson
import qualified Data.ByteString.Lazy as BSL
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 Michelson.ErrorPos (InstrCallStack)
import Michelson.Printer.Util
(RenderDoc(..), buildRenderDoc, doesntNeedParens, needsParens, renderOpsList, spaces)
import Michelson.Untyped.Annotation (Annotation, FieldAnn, TypeAnn, VarAnn, noAnn, renderWEAnn)
import Michelson.Untyped.Contract (Contract'(..))
import Michelson.Untyped.Ext (ExtInstrAbstract)
import Michelson.Untyped.Type (Comparable, Type)
import Michelson.Untyped.Value (Value'(..))
import Tezos.Address (Address, mkContractAddressRaw)
import Tezos.Core (Mutez)
import Tezos.Crypto (KeyHash)
type ExpandedInstr = InstrAbstract ExpandedOp
data ExpandedOp
= PrimEx ExpandedInstr
| SeqEx [ExpandedOp]
| WithSrcEx InstrCallStack ExpandedOp
deriving stock (Show, Eq, Data, Generic)
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|+">"
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
data InstrAbstract op
= EXT (ExtInstrAbstract op)
| DROPN Word
| DROP
| 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
| IF_CONS [op] [op]
| SIZE VarAnn
| EMPTY_SET TypeAnn VarAnn Comparable
| EMPTY_MAP TypeAnn VarAnn Comparable Type
| EMPTY_BIG_MAP TypeAnn VarAnn Comparable 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]
| 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
| STEPS_TO_QUOTA VarAnn
| SOURCE VarAnn
| SENDER VarAnn
| ADDRESS VarAnn
| CHAIN_ID VarAnn
deriving stock (Eq, Show, Functor, Data, Generic)
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" <+> renderAnnot ta <+> renderAnnot va
NONE ta va t -> "NONE" <+> renderAnnot ta <+> renderAnnot va <+> renderTy t
UNIT ta va -> "UNIT" <+> renderAnnot ta <+> renderAnnot va
IF_NONE x y -> "IF_NONE" <+> nest 9 (renderOps x) <$$> spaces 8 <> nest 9 (renderOps y)
PAIR ta va fa1 fa2 -> "PAIR" <+> renderAnnot ta <+> renderAnnot va <+> renderTwoAnnotations fa1 fa2
CAR va fa -> "CAR" <+> renderAnnot va <+> renderAnnot fa
CDR va fa -> "CDR" <+> renderAnnot va <+> renderAnnot fa
LEFT ta va fa1 fa2 t -> "LEFT" <+> renderAnnot ta <+> renderAnnot va <+> renderTwoAnnotations fa1 fa2 <+> renderTy t
RIGHT ta va fa1 fa2 t -> "RIGHT" <+> renderAnnot ta <+> renderAnnot va <+> renderTwoAnnotations fa1 fa2 <+> renderTy t
IF_LEFT x y -> "IF_LEFT" <+> nest 9 (renderOps x) <$$> spaces 8 <> nest 9 (renderOps y)
NIL ta va t -> "NIL" <+> renderAnnot ta <+> renderAnnot 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" <+> renderAnnot ta <+> renderAnnot va <+> renderComp t
EMPTY_MAP ta va c t -> "EMPTY_MAP" <+> renderAnnot ta <+> renderAnnot va <+> renderComp c <+> renderTy t
EMPTY_BIG_MAP ta va c t -> "EMPTY_BIG_MAP" <+> renderAnnot ta <+> renderAnnot 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 <+> renderTy t <+> renderTy r <$$> spaces 7 <> nest 8 (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 (3 + (length $ show @Text n)) (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" <+> renderAnnot ta <+> renderAnnot 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" <+> renderAnnot va <+> renderAnnot fa
CONTRACT va fa t -> "CONTRACT" <+> renderAnnot va <+> renderAnnot fa <+> 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" <+> renderTwoAnnotations 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
STEPS_TO_QUOTA va -> "STEPS_TO_QUOTA" <+> 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 @Comparable needsParens
renderOps = renderOpsList False
renderTwoAnnotations ann1 ann2 =
if (ann1 /= noAnn || ann2 /= noAnn)
then renderWEAnn ann1 <+> renderWEAnn ann2
else renderDoc doesntNeedParens ann1 <+> renderDoc doesntNeedParens ann2
renderAnnot :: RenderDoc (Annotation tag) => Annotation tag -> Doc
renderAnnot = renderDoc @(Annotation _) needsParens
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
data OriginationOperation = OriginationOperation
{ ooOriginator :: Address
, ooDelegate :: Maybe KeyHash
, ooBalance :: Mutez
, ooStorage :: Value' ExpandedOp
, ooContract :: Contract' ExpandedOp
} deriving stock (Show, Generic)
mkContractAddress :: OriginationOperation -> Address
mkContractAddress = mkContractAddressRaw . BSL.toStrict . Aeson.encode
instance Aeson.ToJSON ExpandedOp
instance Aeson.FromJSON ExpandedOp
instance Aeson.ToJSON op => Aeson.ToJSON (InstrAbstract op)
instance Aeson.FromJSON op => Aeson.FromJSON (InstrAbstract op)
instance Aeson.FromJSON OriginationOperation
instance Aeson.ToJSON OriginationOperation