{-# OPTIONS_GHC -fno-warn-orphans #-}
module Michelson.Typed.Convert
( convertContract
, instrToOps
, unsafeValToValue
, valToOpOrValue
, Conversible (..)
, ConversibleExt
) where
import qualified Data.Map as Map
import Data.Singletons (SingI(sing))
import Michelson.Typed.CValue
import Michelson.Typed.Extract (toUType)
import Michelson.Typed.Instr as Instr
import Michelson.Typed.Sing (fromSingCT, fromSingT)
import Michelson.Typed.T (CT(..), T(..))
import Michelson.Typed.Value
import qualified Michelson.Untyped as Un
import Tezos.Address (formatAddress)
import Tezos.Core (unMutez)
import Tezos.Crypto (formatKeyHash, formatPublicKey, formatSignature)
class Conversible ext1 ext2 where
convert :: ext1 -> ext2
type ConversibleExt = Conversible (ExtT Instr) (Un.ExtU Un.InstrAbstract Un.ExpandedOp)
convertContract
:: forall param store . (SingI param, SingI store, ConversibleExt)
=> Contract param store -> Un.UntypedContract
convertContract contract =
Un.Contract
{ para = toUType $ fromSingT (sing @param)
, stor = toUType $ fromSingT (sing @store)
, code = instrToOps contract
}
unsafeValToValue :: (ConversibleExt, HasCallStack) => Val Instr t -> Un.UntypedValue
unsafeValToValue = fromMaybe (error err) . valToOpOrValue
where
err =
"unexpected unsafeValToValue call trying to convert VOp to untyped Value"
valToOpOrValue ::
forall t . ConversibleExt
=> Val Instr t
-> Maybe Un.UntypedValue
valToOpOrValue = \case
VC cVal -> Just $ cValToValue cVal
VKey b -> Just $ Un.ValueString $ formatPublicKey b
VUnit -> Just $ Un.ValueUnit
VSignature b -> Just $ Un.ValueString $ formatSignature b
VOption (Just x) -> Un.ValueSome <$> valToOpOrValue x
VOption Nothing -> Just $ Un.ValueNone
VList l -> valueList Un.ValueSeq <$> mapM valToOpOrValue l
VSet s -> Just $ valueList Un.ValueSeq $ map cValToValue $ toList s
VOp _op -> Nothing
VContract b -> Just $ Un.ValueString $ formatAddress b
VPair (l, r) -> Un.ValuePair <$> valToOpOrValue l <*> valToOpOrValue r
VOr (Left x) -> Un.ValueLeft <$> valToOpOrValue x
VOr (Right x) -> Un.ValueRight <$> valToOpOrValue x
VLam ops ->
Just $ maybe Un.ValueNil Un.ValueLambda $
nonEmpty (instrToOps ops)
VMap m ->
fmap (valueList Un.ValueMap) . forM (Map.toList m) $ \(k, v) ->
Un.Elt (cValToValue k) <$> valToOpOrValue v
VBigMap m ->
fmap (valueList Un.ValueMap) . forM (Map.toList m) $ \(k, v) ->
Un.Elt (cValToValue k) <$> valToOpOrValue v
where
valueList ctor = maybe Un.ValueNil ctor . nonEmpty
cValToValue :: CVal t -> Un.UntypedValue
cValToValue cVal = case cVal of
CvInt i -> Un.ValueInt i
CvNat i -> Un.ValueInt $ toInteger i
CvString s -> Un.ValueString s
CvBytes b -> Un.ValueBytes $ Un.InternalByteString b
CvMutez m -> Un.ValueInt $ toInteger $ unMutez m
CvBool True -> Un.ValueTrue
CvBool False -> Un.ValueFalse
CvKeyHash h -> Un.ValueString $ formatKeyHash h
CvTimestamp t -> Un.ValueString $ show t
CvAddress a -> Un.ValueString $ formatAddress a
instrToOps :: ConversibleExt => Instr inp out -> [Un.ExpandedOp]
instrToOps instr = case instr of
Nested sq -> one $ Un.SeqEx $ instrToOps sq
i -> Un.PrimEx <$> handleInstr i
where
handleInstr :: Instr inp out -> [Un.ExpandedInstr]
handleInstr (Seq i1 i2) = handleInstr i1 <> handleInstr i2
handleInstr Nop = []
handleInstr (Ext nop) = [Un.EXT $ convert nop]
handleInstr (Nested _) = error "impossible"
handleInstr DROP = [Un.DROP]
handleInstr DUP = [Un.DUP Un.noAnn]
handleInstr SWAP = [Un.SWAP]
handleInstr i@(PUSH val) = handle i
where
handle :: Instr inp1 (t ': s) -> [Un.ExpandedInstr]
handle (PUSH _ :: Instr inp1 (t ': s)) =
let value = unsafeValToValue val
in [Un.PUSH Un.noAnn (toUType $ fromSingT (sing @t)) value]
handle _ = error "unexcepted call"
handleInstr i@NONE = handle i
where
handle :: Instr inp1 ('TOption a ': inp1) -> [Un.ExpandedInstr]
handle (NONE :: Instr inp1 ('TOption a ': inp1)) =
[Un.NONE Un.noAnn Un.noAnn Un.noAnn (toUType $ fromSingT (sing @a))]
handle _ = error "unexcepted call"
handleInstr SOME = [Un.SOME Un.noAnn Un.noAnn Un.noAnn]
handleInstr UNIT = [Un.UNIT Un.noAnn Un.noAnn]
handleInstr (IF_NONE i1 i2) = [Un.IF_NONE (instrToOps i1) (instrToOps i2)]
handleInstr PAIR = [Un.PAIR Un.noAnn Un.noAnn Un.noAnn Un.noAnn]
handleInstr CAR = [Un.CAR Un.noAnn Un.noAnn]
handleInstr CDR = [Un.CDR Un.noAnn Un.noAnn]
handleInstr i@LEFT = handle i
where
handle :: Instr (a ': s) ('TOr a b ': s) -> [Un.ExpandedInstr]
handle (LEFT :: Instr (a ': s) ('TOr a b ': s)) =
[Un.LEFT Un.noAnn Un.noAnn Un.noAnn Un.noAnn (toUType $ fromSingT (sing @b))]
handle _ = error "unexcepted call"
handleInstr i@(RIGHT) = handle i
where
handle :: Instr (b ': s) ('TOr a b ': s) -> [Un.ExpandedInstr]
handle (RIGHT :: Instr (b ': s) ('TOr a b ': s)) =
[Un.RIGHT Un.noAnn Un.noAnn Un.noAnn Un.noAnn (toUType $ fromSingT (sing @a))]
handle _ = error "unexcepted call"
handleInstr (IF_LEFT i1 i2) = [Un.IF_LEFT (instrToOps i1) (instrToOps i2)]
handleInstr (IF_RIGHT i1 i2) = [Un.IF_RIGHT (instrToOps i1) (instrToOps i2)]
handleInstr i@(NIL) = handle i
where
handle :: Instr s ('TList p ': s) -> [Un.ExpandedInstr]
handle (NIL :: Instr s ('TList p ': s)) =
[Un.NIL Un.noAnn Un.noAnn (toUType $ fromSingT (sing @p))]
handle _ = error "unexcepted call"
handleInstr CONS = [Un.CONS Un.noAnn]
handleInstr (IF_CONS i1 i2) = [Un.IF_CONS (instrToOps i1) (instrToOps i2)]
handleInstr SIZE = [Un.SIZE Un.noAnn]
handleInstr i@EMPTY_SET = handle i
where
handle :: Instr s ('TSet e ': s) -> [Un.ExpandedInstr]
handle (EMPTY_SET :: Instr s ('TSet e ': s)) =
[Un.EMPTY_SET Un.noAnn Un.noAnn (Un.Comparable (fromSingCT (sing @e)) Un.noAnn)]
handle _ = error "unexcepted call"
handleInstr i@EMPTY_MAP = handle i
where
handle :: Instr s ('TMap a b ': s) -> [Un.ExpandedInstr]
handle (EMPTY_MAP :: Instr s ('TMap a b ': s)) =
[Un.EMPTY_MAP Un.noAnn Un.noAnn (Un.Comparable (fromSingCT (sing @a)) Un.noAnn)
(toUType $ fromSingT (sing @b))
]
handle _ = error "unexcepted call"
handleInstr (MAP op) = [Un.MAP Un.noAnn $ instrToOps op]
handleInstr (ITER op) = [Un.ITER $ instrToOps op]
handleInstr MEM = [Un.MEM Un.noAnn]
handleInstr GET = [Un.GET Un.noAnn]
handleInstr UPDATE = [Un.UPDATE]
handleInstr (IF op1 op2) = [Un.IF (instrToOps op1) (instrToOps op2)]
handleInstr (LOOP op) = [Un.LOOP (instrToOps op)]
handleInstr (LOOP_LEFT op) = [Un.LOOP_LEFT (instrToOps op)]
handleInstr i@(LAMBDA l) = handle i
where
handle :: Instr s ('TLambda i o ': s) -> [Un.ExpandedInstr]
handle (LAMBDA _ :: Instr s ('TLambda i o ': s)) =
[Un.LAMBDA Un.noAnn (toUType $ fromSingT (sing @i))
(toUType $ fromSingT (sing @i)) (convertLambdaBody l)
]
handle _ = error "unexcepted call"
convertLambdaBody :: Val Instr ('TLambda i o) -> [Un.ExpandedOp]
convertLambdaBody (VLam ops) = instrToOps ops
handleInstr EXEC = [Un.EXEC Un.noAnn]
handleInstr (DIP op) = [Un.DIP (instrToOps op)]
handleInstr FAILWITH = [Un.FAILWITH]
handleInstr i@(CAST) = handle i
where
handle :: Instr (a ': s) (a ': s) -> [Un.ExpandedInstr]
handle (CAST :: Instr (a ': s) (a ': s)) =
[Un.CAST Un.noAnn (toUType $ fromSingT (sing @a))]
handle _ = error "unexcepted call"
handleInstr RENAME = [Un.RENAME Un.noAnn]
handleInstr PACK = [Un.PACK Un.noAnn]
handleInstr i@(UNPACK) = handle i
where
handle :: Instr ('Tc 'CBytes ': s) ('TOption a ': s) -> [Un.ExpandedInstr]
handle (UNPACK :: Instr ('Tc 'CBytes ': s) ('TOption a ': s)) =
[Un.UNPACK Un.noAnn (toUType $ fromSingT (sing @a))]
handle _ = error "unexcepted call"
handleInstr CONCAT = [Un.CONCAT Un.noAnn]
handleInstr CONCAT' = [Un.CONCAT Un.noAnn]
handleInstr SLICE = [Un.SLICE Un.noAnn]
handleInstr ISNAT = [Un.ISNAT Un.noAnn]
handleInstr ADD = [Un.ADD Un.noAnn]
handleInstr SUB = [Un.SUB Un.noAnn]
handleInstr MUL = [Un.MUL Un.noAnn]
handleInstr EDIV = [Un.EDIV Un.noAnn]
handleInstr ABS = [Un.ABS Un.noAnn]
handleInstr NEG = [Un.NEG]
handleInstr LSL = [Un.LSL Un.noAnn]
handleInstr LSR = [Un.LSR Un.noAnn]
handleInstr OR = [Un.OR Un.noAnn]
handleInstr AND = [Un.AND Un.noAnn]
handleInstr XOR = [Un.XOR Un.noAnn]
handleInstr NOT = [Un.NOT Un.noAnn]
handleInstr COMPARE = [Un.COMPARE Un.noAnn]
handleInstr Instr.EQ = [Un.EQ Un.noAnn]
handleInstr NEQ = [Un.NEQ Un.noAnn]
handleInstr Instr.LT = [Un.LT Un.noAnn]
handleInstr Instr.GT = [Un.GT Un.noAnn]
handleInstr LE = [Un.LE Un.noAnn]
handleInstr GE = [Un.GE Un.noAnn]
handleInstr INT = [Un.INT Un.noAnn]
handleInstr SELF = [Un.SELF Un.noAnn]
handleInstr i@CONTRACT = handle i
where
handle :: Instr ('Tc 'CAddress ': s) ('TOption ('TContract p) ': s)
-> [Un.ExpandedInstr]
handle (CONTRACT :: Instr ('Tc 'CAddress ': s) ('TOption ('TContract p) ': s)) =
[Un.CONTRACT Un.noAnn (toUType $ fromSingT (sing @p))]
handle _ = error "unexcepted call"
handleInstr TRANSFER_TOKENS = [Un.TRANSFER_TOKENS Un.noAnn]
handleInstr SET_DELEGATE = [Un.SET_DELEGATE Un.noAnn]
handleInstr CREATE_ACCOUNT = [Un.CREATE_ACCOUNT Un.noAnn Un.noAnn]
handleInstr CREATE_CONTRACT = [Un.CREATE_CONTRACT Un.noAnn Un.noAnn]
handleInstr i@(CREATE_CONTRACT2 _) = handle i
where
handle :: Instr ('Tc 'CKeyHash ': 'TOption ('Tc 'CKeyHash)
': 'Tc 'CBool ': 'Tc 'CBool ': 'Tc 'CMutez ': g ': s)
('TOperation ': 'Tc 'CAddress ': s) -> [Un.ExpandedInstr]
handle (CREATE_CONTRACT2 ops :: Instr ('Tc 'CKeyHash
': 'TOption ('Tc 'CKeyHash)
': 'Tc 'CBool ': 'Tc 'CBool ': 'Tc 'CMutez ': g ': s)
('TOperation ': 'Tc 'CAddress ': s)) =
case ops of
(code :: Instr '[ 'TPair p g ] '[ 'TPair ('TList 'TOperation) g ]) ->
let contract = Un.Contract (toUType $ fromSingT (sing @p))
(toUType $ fromSingT (sing @g)) (instrToOps code) in
[Un.CREATE_CONTRACT2 Un.noAnn Un.noAnn contract]
handle _ = error "unexcepted call"
handleInstr IMPLICIT_ACCOUNT = [Un.IMPLICIT_ACCOUNT Un.noAnn]
handleInstr NOW = [Un.NOW Un.noAnn]
handleInstr AMOUNT = [Un.AMOUNT Un.noAnn]
handleInstr BALANCE = [Un.BALANCE Un.noAnn]
handleInstr CHECK_SIGNATURE = [Un.CHECK_SIGNATURE Un.noAnn]
handleInstr SHA256 = [Un.SHA256 Un.noAnn]
handleInstr SHA512 = [Un.SHA512 Un.noAnn]
handleInstr BLAKE2B = [Un.BLAKE2B Un.noAnn]
handleInstr HASH_KEY = [Un.HASH_KEY Un.noAnn]
handleInstr STEPS_TO_QUOTA = [Un.STEPS_TO_QUOTA Un.noAnn]
handleInstr SOURCE = [Un.SOURCE Un.noAnn]
handleInstr SENDER = [Un.SENDER Un.noAnn]
handleInstr ADDRESS = [Un.ADDRESS Un.noAnn]
instance (ConversibleExt, Eq Un.ExpandedInstrExtU) => Eq (Instr inp out) where
i1 == i2 = instrToOps i1 == instrToOps i2