{-# LANGUAGE DeriveDataTypeable, DerivingStrategies #-}
module Michelson.Untyped.Instr
( InstrAbstract (..)
, Op (..)
, Instr
, ExpandedOp (..)
, ExpandedInstr
, ExtU
, InstrExtU
, ExpandedInstrExtU
, OriginationOperation (..)
, mkContractAddress
) where
import qualified Data.Aeson as Aeson
import qualified Data.ByteString.Lazy as BSL
import Data.Data (Data(..))
import qualified Data.Kind as K
import Fmt (Buildable(build), (+|), (|+))
import Prelude hiding (EQ, GT, LT)
import Text.PrettyPrint.Leijen.Text (braces, nest, (<$$>), (<+>))
import Michelson.Printer.Util (RenderDoc(..), buildRenderDoc, renderOpsList, spaces)
import Michelson.Untyped.Annotation (FieldAnn, TypeAnn, VarAnn)
import Michelson.Untyped.Contract (Contract(..))
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 InstrExtU = ExtU InstrAbstract Op
type Instr = InstrAbstract Op
newtype Op = Op {unOp :: Instr}
deriving stock (Generic)
deriving newtype (RenderDoc, Buildable)
deriving instance Eq (ExtU InstrAbstract Op) => Eq Op
deriving instance Show (ExtU InstrAbstract Op) => Show Op
type ExpandedInstrExtU = ExtU InstrAbstract ExpandedOp
type ExpandedInstr = InstrAbstract ExpandedOp
data ExpandedOp
= PrimEx ExpandedInstr
| SeqEx [ExpandedOp]
deriving stock (Generic)
deriving instance Eq ExpandedInstr => Eq ExpandedOp
deriving instance Show ExpandedInstr => Show ExpandedOp
deriving instance Data ExpandedInstr => Data ExpandedOp
instance RenderDoc ExpandedOp where
renderDoc (PrimEx i) = renderDoc i
renderDoc (SeqEx i) = renderOpsList True i
isRenderable =
\case PrimEx i -> isRenderable i
_ -> True
instance Buildable ExpandedOp where
build (PrimEx expandedInstr) = "<PrimEx: "+|expandedInstr|+">"
build (SeqEx expandedOps) = "<SeqEx: "+|expandedOps|+">"
type family ExtU (instr :: K.Type -> K.Type) :: K.Type -> K.Type
data InstrAbstract op
= EXT (ExtU InstrAbstract op)
| DROP
| DUP VarAnn
| SWAP
| PUSH VarAnn Type (Value op)
| SOME TypeAnn VarAnn FieldAnn
| NONE TypeAnn VarAnn FieldAnn 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]
| IF_RIGHT [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
| MAP VarAnn [op]
| ITER [op]
| MEM VarAnn
| GET VarAnn
| UPDATE
| IF [op] [op]
| LOOP [op]
| LOOP_LEFT [op]
| LAMBDA VarAnn Type Type [op]
| EXEC VarAnn
| DIP [op]
| FAILWITH
| CAST VarAnn Type
| RENAME VarAnn
| PACK VarAnn
| UNPACK VarAnn Type
| CONCAT VarAnn
| SLICE VarAnn
| ISNAT VarAnn
| ADD VarAnn
| SUB VarAnn
| MUL VarAnn
| EDIV VarAnn
| ABS VarAnn
| NEG
| 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
| CONTRACT VarAnn Type
| TRANSFER_TOKENS VarAnn
| SET_DELEGATE VarAnn
| CREATE_ACCOUNT VarAnn VarAnn
| CREATE_CONTRACT VarAnn VarAnn
| CREATE_CONTRACT2 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
deriving (Generic)
deriving instance (Eq op, Eq (ExtU InstrAbstract op)) => Eq (InstrAbstract op)
deriving instance (Show op, Show (ExtU InstrAbstract op)) => Show (InstrAbstract op)
deriving instance Functor (ExtU InstrAbstract) => Functor InstrAbstract
deriving instance (Data op, Data (ExtU InstrAbstract op)) => Data (InstrAbstract op)
instance (RenderDoc op) => RenderDoc (InstrAbstract op) where
renderDoc = \case
EXT _ -> ""
DROP -> "DROP"
DUP va -> "DUP" <+> renderDoc va
SWAP -> "SWAP"
PUSH va t v -> "PUSH" <+> renderDoc va <+> renderDoc t <+> renderDoc v
SOME ta va fa -> "SOME" <+> renderDoc ta <+> renderDoc va <+> renderDoc fa
NONE ta va fa t -> "NONE" <+> renderDoc ta <+> renderDoc va <+> renderDoc fa <+> renderDoc t
UNIT ta va -> "UNIT" <+> renderDoc ta <+> renderDoc va
IF_NONE x y -> "IF_NONE" <+> nest 9 (renderOps x) <$$> spaces 8 <> nest 9 (renderOps y)
PAIR ta va fa1 fa2 -> "PAIR" <+> renderDoc ta <+> renderDoc va <+> renderDoc fa1 <+> renderDoc fa2
CAR va fa -> "CAR" <+> renderDoc va <+> renderDoc fa
CDR va fa -> "CDR" <+> renderDoc va <+> renderDoc fa
LEFT ta va fa1 fa2 t -> "LEFT" <+> renderDoc ta <+> renderDoc va <+> renderDoc fa1 <+> renderDoc fa2 <+> renderDoc t
RIGHT ta va fa1 fa2 t -> "RIGHT" <+> renderDoc ta <+> renderDoc va <+> renderDoc fa1 <+> renderDoc fa2 <+> renderDoc t
IF_LEFT x y -> "IF_LEFT" <+> nest 9 (renderOps x) <$$> spaces 8 <> nest 9 (renderOps y)
IF_RIGHT x y -> "IF_RIGHT" <+> nest 10 (renderOps x) <$$> spaces 9 <> nest 10 (renderOps y)
NIL ta va t -> "NIL" <+> renderDoc ta <+> renderDoc va <+> renderDoc t
CONS va -> "CONS" <+> renderDoc va
IF_CONS x y -> "IF_CONS" <+> nest 9 (renderOps x) <$$> spaces 8 <> nest 9 (renderOps y)
SIZE va -> "SIZE" <+> renderDoc va
EMPTY_SET ta va t -> "EMPTY_SET" <+> renderDoc ta <+> renderDoc va <+> renderDoc t
EMPTY_MAP ta va c t -> "EMPTY_MAP" <+> renderDoc ta <+> renderDoc va <+> renderDoc c <+> renderDoc t
MAP va s -> "MAP" <+> renderDoc va <$$> spaces 4 <> nest 5 (renderOps s)
ITER s -> "ITER" <+> nest 6 (renderOps s)
MEM va -> "MEM" <+> renderDoc va
GET va -> "GET" <+> renderDoc va
UPDATE -> "UPDATE"
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" <+> renderDoc va <+> renderDoc t <+> renderDoc r <$$> spaces 7 <> nest 8 (renderOps s)
EXEC va -> "EXEC" <+> renderDoc va
DIP s -> "DIP" <+> nest 5 (renderOps s)
FAILWITH -> "FAILWITH"
CAST va t -> "CAST" <+> renderDoc va <+> renderDoc t
RENAME va -> "RENAME" <+> renderDoc va
PACK va -> "PACK" <+> renderDoc va
UNPACK va t -> "UNPACK" <+> renderDoc va <+> renderDoc t
CONCAT va -> "CONCAT" <+> renderDoc va
SLICE va -> "SLICE" <+> renderDoc va
ISNAT va -> "ISNAT" <+> renderDoc va
ADD va -> "ADD" <+> renderDoc va
SUB va -> "SUB" <+> renderDoc va
MUL va -> "MUL" <+> renderDoc va
EDIV va -> "EDIV" <+> renderDoc va
ABS va -> "ABS" <+> renderDoc va
NEG -> "NEG"
LSL va -> "LSL" <+> renderDoc va
LSR va -> "LSR" <+> renderDoc va
OR va -> "OR" <+> renderDoc va
AND va -> "AND" <+> renderDoc va
XOR va -> "XOR" <+> renderDoc va
NOT va -> "NOT" <+> renderDoc va
COMPARE va -> "COMPARE" <+> renderDoc va
EQ va -> "EQ" <+> renderDoc va
NEQ va -> "NEQ" <+> renderDoc va
LT va -> "LT" <+> renderDoc va
GT va -> "GT" <+> renderDoc va
LE va -> "LE" <+> renderDoc va
GE va -> "GE" <+> renderDoc va
INT va -> "INT" <+> renderDoc va
SELF va -> "SELF" <+> renderDoc va
CONTRACT va t -> "CONTRACT" <+> renderDoc va <+> renderDoc t
TRANSFER_TOKENS va -> "TRANSFER_TOKENS" <+> renderDoc va
SET_DELEGATE va -> "SET_DELEGATE" <+> renderDoc va
CREATE_ACCOUNT va1 va2 -> "CREATE_ACCOUNT" <+> renderDoc va1 <+> renderDoc va2
CREATE_CONTRACT va1 va2 -> "CREATE_CONTRACT" <+> renderDoc va1 <+> renderDoc va2
CREATE_CONTRACT2 va1 va2 contract -> "CREATE_CONTRACT" <+> renderDoc va1 <+> renderDoc va2 <$$> braces (renderDoc contract)
IMPLICIT_ACCOUNT va -> "IMPLICIT_ACCOUNT" <+> renderDoc va
NOW va -> "NOW" <+> renderDoc va
AMOUNT va -> "AMOUNT" <+> renderDoc va
BALANCE va -> "BALANCE" <+> renderDoc va
CHECK_SIGNATURE va -> "CHECK_SIGNATURE" <+> renderDoc va
SHA256 va -> "SHA256" <+> renderDoc va
SHA512 va -> "SHA512" <+> renderDoc va
BLAKE2B va -> "BLAKE2B" <+> renderDoc va
HASH_KEY va -> "HASH_KEY" <+> renderDoc va
STEPS_TO_QUOTA va -> "STEPS_TO_QUOTA" <+> renderDoc va
SOURCE va -> "SOURCE" <+> renderDoc va
SENDER va -> "SENDER" <+> renderDoc va
ADDRESS va -> "ADDRESS" <+> renderDoc va
where
renderOps = renderOpsList True
isRenderable = \case
EXT {} -> False
_ -> True
instance (RenderDoc op) => Buildable (InstrAbstract op) where
build = buildRenderDoc
data OriginationOperation = OriginationOperation
{ ooManager :: !KeyHash
, ooDelegate :: !(Maybe KeyHash)
, ooSpendable :: !Bool
, ooDelegatable :: !Bool
, ooBalance :: !Mutez
, ooStorage :: !(Value ExpandedOp)
, ooContract :: !(Contract ExpandedOp)
} deriving (Generic)
deriving instance Show ExpandedInstrExtU => Show OriginationOperation
mkContractAddress :: Aeson.ToJSON ExpandedInstrExtU => OriginationOperation -> Address
mkContractAddress = mkContractAddressRaw . BSL.toStrict . Aeson.encode
instance Aeson.ToJSON Instr => Aeson.ToJSON Op
instance Aeson.FromJSON Instr => Aeson.FromJSON Op
instance Aeson.ToJSON ExpandedInstr => Aeson.ToJSON ExpandedOp
instance Aeson.FromJSON ExpandedInstr => Aeson.FromJSON ExpandedOp
instance (Aeson.ToJSON op, Aeson.ToJSON (ExtU InstrAbstract op)) => Aeson.ToJSON (InstrAbstract op)
instance (Aeson.FromJSON op, Aeson.FromJSON (ExtU InstrAbstract op)) => Aeson.FromJSON (InstrAbstract op)
instance Aeson.FromJSON ExpandedOp => Aeson.FromJSON OriginationOperation
instance Aeson.ToJSON ExpandedOp => Aeson.ToJSON OriginationOperation