morley-1.9: src/Michelson/Typed/Convert.hs
-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Michelson.Typed.Convert
( convertParamNotes
, convertContractCode
, convertContract
, instrToOps
, untypeValue
-- Helper for generating documentation
, sampleValueFromUntype
-- * Misc
, flattenEntrypoints
) where
import Data.Constraint (Dict(..))
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Singletons (Sing, demote)
import Fmt (Buildable(..), fmt, listF, pretty)
import Michelson.Text
import Michelson.Typed.Aliases
import Michelson.Typed.Annotation (Notes(..))
import Michelson.Typed.Entrypoints
import Michelson.Typed.Extract (fromUType, mkUType, toUType)
import Michelson.Typed.Instr as Instr
import Michelson.Typed.Scope
import Michelson.Typed.Sing (SingT(..), withSomeSingT)
import Michelson.Typed.T (T(..))
import Michelson.Typed.Value
import qualified Michelson.Untyped as U
import Tezos.Core (mformatChainId, parseChainId, timestampFromSeconds, unMutez, unsafeMkMutez)
import Tezos.Crypto
import Util.Peano
import Util.Typeable
convertParamNotes :: SingI cp => ParamNotes cp -> U.ParameterType
convertParamNotes (ParamNotes notes rootAnn) =
U.ParameterType (mkUType notes) rootAnn
convertContractCode
:: forall param store . (SingI param, SingI store)
=> ContractCode param store -> U.Contract
convertContractCode contract =
U.Contract
{ contractParameter = U.ParameterType (untypeDemoteT @param) U.noAnn
, contractStorage = untypeDemoteT @store
, contractCode = instrToOps contract
, entriesOrder = U.canonicalEntriesOrder
}
convertContract
:: forall param store . (SingI param, SingI store)
=> Contract param store -> U.Contract
convertContract fc =
let c = convertContractCode (cCode fc)
in c { U.contractParameter = convertParamNotes (cParamNotes fc)
, U.contractStorage = mkUType (cStoreNotes fc)
, U.entriesOrder = cEntriesOrder fc
}
-- | Convert a typed 'Val' to an untyped 'Value'.
--
-- For full isomorphism type of the given 'Val' should not contain
-- 'TOperation' - a compile error will be raised otherwise.
-- You can analyse its presence with 'checkOpPresence' function.
untypeValue ::
forall t . (SingI t, HasNoOp t)
=> Value' Instr t
-> U.Value
untypeValue val = case (val, sing @t) of
(VInt i, _) -> U.ValueInt i
(VNat i, _) -> U.ValueInt $ toInteger i
(VString s, _) -> U.ValueString s
(VBytes b, _) -> U.ValueBytes $ U.InternalByteString b
(VMutez m, _) -> U.ValueInt $ toInteger $ unMutez m
(VBool True, _) -> U.ValueTrue
(VBool False, _) -> U.ValueFalse
(VKeyHash h, _) -> U.ValueString $ mformatKeyHash h
(VTimestamp t, _) -> U.ValueString $ mkMTextUnsafe $ pretty t
(VAddress a, _) -> U.ValueString $ mformatEpAddress a
(VKey b, _) ->
U.ValueString $ mformatPublicKey b
(VUnit, _) ->
U.ValueUnit
(VSignature b, _) ->
U.ValueString $ mformatSignature b
(VChainId b, _) ->
U.ValueString $ mformatChainId b
(VOption (Just x), STOption _) ->
U.ValueSome (untypeValue x)
(VOption Nothing, STOption _) ->
U.ValueNone
(VList l, STList _) ->
vList U.ValueSeq $ map untypeValue l
(VSet s, STSet (st :: SingT st)) ->
case checkOpPresence st of
OpAbsent -> vList U.ValueSeq $ map (untypeValue @st) $ toList s
(VContract addr sepc, _) ->
U.ValueString . mformatEpAddress $ EpAddress addr (sepcName sepc)
(VPair (l, r), STPair lt _) ->
case checkOpPresence lt of
OpAbsent -> U.ValuePair (untypeValue l) (untypeValue r)
(VOr (Left x), STOr lt _) ->
case checkOpPresence lt of
OpAbsent -> U.ValueLeft (untypeValue x)
(VOr (Right x), STOr lt _) ->
case checkOpPresence lt of
OpAbsent -> U.ValueRight (untypeValue x)
(VLam (rfAnyInstr -> ops :: Instr '[inp] '[out]), _) ->
vList U.ValueLambda $ instrToOps ops
(VMap m, STMap kt vt) ->
case (checkOpPresence kt, checkOpPresence vt) of
(OpAbsent, OpAbsent) ->
vList U.ValueMap $ Map.toList m <&> \(k, v) ->
U.Elt (untypeValue k) (untypeValue v)
(VBigMap m, STBigMap kt vt) ->
case (checkOpPresence kt, checkOpPresence vt) of
(OpAbsent, OpAbsent) ->
vList U.ValueMap $ Map.toList m <&> \(k, v) ->
U.Elt (untypeValue k) (untypeValue v)
where
vList ctor = maybe U.ValueNil ctor . nonEmpty
untypeDemoteT :: forall (t :: T). SingI t => U.Type
untypeDemoteT = toUType $ demote @t
instrToOps :: HasCallStack => Instr inp out -> [U.ExpandedOp]
instrToOps = \case
Nop -> []
Seq i1 i2 -> instrToOps i1 <> instrToOps i2
Nested sq -> one $ U.SeqEx $ instrToOps sq
DocGroup _ sq -> instrToOps sq
Ext (ext :: ExtInstr inp) -> (U.PrimEx . U.EXT) <$> extInstrToOps ext
FrameInstr _ i -> instrToOps i
-- TODO [#283] After representation of locations is polished,
-- this place should be updated to pass it from typed to untyped ASTs.
WithLoc _ i -> instrToOps i
InstrWithNotes n i -> case i of
Nop -> instrToOps i
Seq _ _ -> instrToOps i
Nested _ -> instrToOps i
DocGroup _ _ -> instrToOps i
Ext _ -> instrToOps i
WithLoc _ i0 -> instrToOps (InstrWithNotes n i0)
InstrWithNotes _ _ -> instrToOps i
InstrWithVarNotes _ _ -> instrToOps i
-- For inner instruction, filter out values that we don't want to apply
-- annotations to and delegate it's conversion to this function itself.
-- If none of the above, convert a single instruction and copy annotations
-- to it.
_ -> [U.PrimEx $ handleInstrAnnotate i n]
InstrWithVarNotes n i -> case i of
Nop -> instrToOps i
Seq _ _ -> instrToOps i
Nested _ -> instrToOps i
DocGroup _ _ -> instrToOps i
Ext _ -> instrToOps i
WithLoc _ i0 -> instrToOps (InstrWithVarNotes n i0)
InstrWithNotes _ _ -> instrToOps i
InstrWithVarNotes _ _ -> instrToOps i
_ -> [U.PrimEx $ handleInstrVarNotes i n]
i -> [U.PrimEx $ handleInstr i]
where
handleInstrAnnotate
:: forall inp' out' . HasCallStack
=> Instr inp' out' -> PackedNotes out' -> U.ExpandedInstr
handleInstrAnnotate ins' (PackedNotes notes') = let
x = handleInstr ins' in addInstrNote x notes'
where
addInstrNote
:: forall t. (SingI t, HasCallStack)
=> U.ExpandedInstr -> Notes t -> U.ExpandedInstr
addInstrNote ins nte = case (sing @t, ins, nte) of
(_, U.PUSH va _ v, _) -> U.PUSH va (mkUType nte) v
(_, U.SOME _ va, NTOption ta _) -> U.SOME ta va
(STOption _, U.NONE _ va _, NTOption ta nt) -> U.NONE ta va (mkUType nt)
(_, U.UNIT _ va, NTUnit ta) -> U.UNIT ta va
(_, U.PAIR ta va f1 f2, _) -> U.PAIR ta va f1 f2
(_, U.CAR va f1, _) -> U.CAR va f1
(_, U.CDR va f1, _) -> U.CDR va f1
(STOr _ _, U.LEFT _ va _ _ _, NTOr ta f1 f2 _ n2) ->
U.LEFT ta va f1 f2 (mkUType n2)
(STOr _ _, U.RIGHT _ va _ _ _, NTOr ta f1 f2 n1 _) ->
U.RIGHT ta va f1 f2 (mkUType n1)
(STList _, U.NIL _ va _, NTList ta n) -> U.NIL ta va (mkUType n)
(STSet _, U.EMPTY_SET _ va _, NTSet ta1 n) ->
U.EMPTY_SET ta1 va (mkUType n)
(STMap _ _, U.EMPTY_MAP _ va _ _, NTMap ta1 k n) ->
U.EMPTY_MAP ta1 va (mkUType k) (mkUType n)
(STBigMap _ _, U.EMPTY_BIG_MAP _ va _ _, NTBigMap ta1 k n) ->
U.EMPTY_BIG_MAP ta1 va (mkUType k) (mkUType n)
(STLambda _ _, U.LAMBDA va _ _ ops, NTLambda _ n1 n2) ->
U.LAMBDA va (mkUType n1) (mkUType n2) ops
(_, U.CAST va _, n) -> U.CAST va (mkUType n)
(STOption _, U.UNPACK _ va _, NTOption ta nt) -> U.UNPACK ta va (mkUType nt)
(STOption (STContract _), U.CONTRACT va fa _, NTOption _ (NTContract _ nt)) ->
U.CONTRACT va fa (mkUType nt)
(_, U.CONTRACT va fa t, NTOption _ _) -> U.CONTRACT va fa t
(_, a@(U.APPLY {}), _) -> a
(_, a@(U.CHAIN_ID {}), _) -> a
(_, a@(U.EXT _), _) -> a
(_, a@(U.DROP), _) -> a
(_, a@(U.DROPN _), _) -> a
(_, a@(U.DUP _), _) -> a
(_, a@(U.SWAP), _) -> a
(_, a@(U.DIG {}), _) -> a
(_, a@(U.DUG {}), _) -> a
(_, a@(U.IF_NONE _ _), _) -> a
(_, a@(U.CONS _), _) -> a
(_, a@(U.IF_LEFT _ _), _) -> a
(_, a@(U.IF_CONS _ _), _) -> a
(_, a@(U.SIZE _), _) -> a
(_, a@(U.MAP _ _), _) -> a
(_, a@(U.ITER _), _) -> a
(_, a@(U.MEM _), _) -> a
(_, a@(U.GET _), _) -> a
(_, a@(U.UPDATE _), _) -> a
(_, a@(U.IF _ _), _) -> a
(_, a@(U.LOOP _), _) -> a
(_, a@(U.LOOP_LEFT _), _) -> a
(_, a@(U.EXEC _), _) -> a
(_, a@(U.DIP _), _) -> a
(_, a@(U.DIPN {}), _) -> a
(_, a@(U.FAILWITH), _) -> a
(_, a@(U.RENAME _), _) -> a
(_, a@(U.PACK _), _) -> a
(_, a@(U.CONCAT _), _) -> a
(_, a@(U.SLICE _), _) -> a
(_, a@(U.ISNAT _), _) -> a
(_, a@(U.ADD _), _) -> a
(_, a@(U.SUB _), _) -> a
(_, a@(U.MUL _), _) -> a
(_, a@(U.EDIV _), _) -> a
(_, a@(U.ABS _), _) -> a
(_, a@(U.NEG _), _) -> a
(_, a@(U.LSL _), _) -> a
(_, a@(U.LSR _), _) -> a
(_, a@(U.OR _), _) -> a
(_, a@(U.AND _), _) -> a
(_, a@(U.XOR _), _) -> a
(_, a@(U.NOT _), _) -> a
(_, a@(U.COMPARE _), _) -> a
(_, a@(U.EQ _), _) -> a
(_, a@(U.NEQ _), _) -> a
(_, a@(U.LT _), _) -> a
(_, a@(U.GT _), _) -> a
(_, a@(U.LE _), _) -> a
(_, a@(U.GE _), _) -> a
(_, a@(U.INT _), _) -> a
(_, a@(U.SELF _ _), _) -> a
(_, a@(U.TRANSFER_TOKENS _), _) -> a
(_, a@(U.SET_DELEGATE _), _) -> a
(_, a@(U.CREATE_CONTRACT {}), _) -> a
(_, a@(U.IMPLICIT_ACCOUNT _), _) -> a
(_, a@(U.NOW _), _) -> a
(_, a@(U.AMOUNT _), _) -> a
(_, a@(U.BALANCE _), _) -> a
(_, a@(U.CHECK_SIGNATURE _), _) -> a
(_, a@(U.SHA256 _), _) -> a
(_, a@(U.SHA512 _), _) -> a
(_, a@(U.BLAKE2B _), _) -> a
(_, a@(U.HASH_KEY _), _) -> a
(_, a@(U.SOURCE _), _) -> a
(_, a@(U.SENDER _), _) -> a
(_, a@(U.ADDRESS _), _) -> a
(_, b, c) -> error $ "addInstrNote: Unexpected instruction/annotation combination: " <> show (b, c)
handleInstrVarNotes :: forall inp' out' . HasCallStack
=> Instr inp' out' -> NonEmpty U.VarAnn -> U.ExpandedInstr
handleInstrVarNotes ins' varAnns =
let x = handleInstr ins' in addVarNotes x varAnns
where
addVarNotes
:: HasCallStack
=> U.ExpandedInstr -> NonEmpty U.VarAnn -> U.ExpandedInstr
addVarNotes ins varNotes = case varNotes of
va1 :| [va2] -> case ins of
U.CREATE_CONTRACT _ _ c -> U.CREATE_CONTRACT va1 va2 c
_ -> error $
"addVarNotes: Cannot add two var annotations to instr: " <> show ins
va :| [] -> case ins of
U.DUP _ -> U.DUP va
U.PUSH _ t v -> U.PUSH va t v
U.SOME ta _ -> U.SOME ta va
U.NONE ta _ t -> U.NONE ta va t
U.UNIT ta _ -> U.UNIT ta va
U.PAIR ta _ fa1 fa2 -> U.PAIR ta va fa1 fa2
U.CAR _ fa -> U.CAR va fa
U.CDR _ fa -> U.CDR va fa
U.LEFT ta _ fa1 fa2 t -> U.LEFT ta va fa1 fa2 t
U.RIGHT ta _ fa1 fa2 t -> U.RIGHT ta va fa1 fa2 t
U.NIL ta _ t -> U.NIL ta va t
U.CONS _ -> U.CONS va
U.SIZE _ -> U.SIZE va
U.EMPTY_SET ta _ c -> U.EMPTY_SET ta va c
U.EMPTY_MAP ta _ c t -> U.EMPTY_MAP ta va c t
U.EMPTY_BIG_MAP ta _ c t -> U.EMPTY_BIG_MAP ta va c t
U.MAP _ ops -> U.MAP va ops
U.MEM _ -> U.MEM va
U.GET _ -> U.GET va
U.UPDATE _ -> U.UPDATE va
U.LAMBDA _ t1 t2 ops -> U.LAMBDA va t1 t2 ops
U.EXEC _ -> U.EXEC va
U.APPLY _ -> U.APPLY va
U.CAST _ t -> U.CAST va t
U.RENAME _ -> U.RENAME va
U.PACK _ -> U.PACK va
U.UNPACK ta _ t -> U.UNPACK ta va t
U.CONCAT _ -> U.CONCAT va
U.SLICE _ -> U.SLICE va
U.ISNAT _ -> U.ISNAT va
U.ADD _ -> U.ADD va
U.SUB _ -> U.SUB va
U.MUL _ -> U.MUL va
U.EDIV _ -> U.EDIV va
U.ABS _ -> U.ABS va
U.NEG _ -> U.NEG va
U.LSL _ -> U.LSL va
U.LSR _ -> U.LSR va
U.OR _ -> U.OR va
U.AND _ -> U.AND va
U.XOR _ -> U.XOR va
U.NOT _ -> U.NOT va
U.COMPARE _ -> U.COMPARE va
U.EQ _ -> U.EQ va
U.NEQ _ -> U.NEQ va
U.LT _ -> U.LT va
U.GT _ -> U.GT va
U.LE _ -> U.LE va
U.GE _ -> U.GE va
U.INT _ -> U.INT va
U.SELF _ fa -> U.SELF va fa
U.CONTRACT _ fa t -> U.CONTRACT va fa t
U.TRANSFER_TOKENS _ -> U.TRANSFER_TOKENS va
U.SET_DELEGATE _ -> U.SET_DELEGATE va
U.CREATE_CONTRACT _ _ c -> U.CREATE_CONTRACT va U.noAnn c
U.IMPLICIT_ACCOUNT _ -> U.IMPLICIT_ACCOUNT va
U.NOW _ -> U.NOW va
U.AMOUNT _ -> U.AMOUNT va
U.BALANCE _ -> U.BALANCE va
U.CHECK_SIGNATURE _ -> U.CHECK_SIGNATURE va
U.SHA256 _ -> U.SHA256 va
U.SHA512 _ -> U.SHA512 va
U.BLAKE2B _ -> U.BLAKE2B va
U.HASH_KEY _ -> U.HASH_KEY va
U.SOURCE _ -> U.SOURCE va
U.SENDER _ -> U.SENDER va
U.ADDRESS _ -> U.ADDRESS va
U.CHAIN_ID _ -> U.CHAIN_ID va
_ -> error $
"addVarNotes: Cannot add single var annotation to instr: " <> (show ins)
_ -> error $
"addVarNotes: Trying to add more than two var annotations to instr: " <> (show ins)
handleInstr :: Instr inp out -> U.ExpandedInstr
handleInstr = \case
(WithLoc _ _) -> error "impossible"
(InstrWithNotes _ _) -> error "impossible"
(InstrWithVarNotes _ _) -> error "impossible"
(FrameInstr _ _) -> error "impossible"
(Seq _ _) -> error "impossible"
Nop -> error "impossible"
(Ext _) -> error "impossible"
(Nested _) -> error "impossible"
DocGroup{} -> error "impossible"
DROP -> U.DROP
(DROPN s) -> U.DROPN (fromIntegral $ peanoValSing s)
DUP -> U.DUP U.noAnn
SWAP -> U.SWAP
(DIG s) -> U.DIG (fromIntegral $ peanoValSing s)
(DUG s) -> U.DUG (fromIntegral $ peanoValSing s)
i@(PUSH val) | _ :: Instr inp1 (t ': s) <- i ->
let value = untypeValue val
in U.PUSH U.noAnn (untypeDemoteT @t) value
i@NONE | _ :: Instr inp1 ('TOption a ': inp1) <- i ->
U.NONE U.noAnn U.noAnn (untypeDemoteT @a)
SOME -> U.SOME U.noAnn U.noAnn
UNIT -> U.UNIT U.noAnn U.noAnn
(IF_NONE i1 i2) -> U.IF_NONE (instrToOps i1) (instrToOps i2)
AnnPAIR tn fn1 fn2 -> U.PAIR tn U.noAnn fn1 fn2
(AnnCAR fn) -> U.CAR U.noAnn fn
(AnnCDR fn) -> U.CDR U.noAnn fn
i@LEFT | _ :: Instr (a ': s) ('TOr a b ': s) <- i ->
U.LEFT U.noAnn U.noAnn U.noAnn U.noAnn (untypeDemoteT @b)
i@RIGHT | _ :: Instr (b ': s) ('TOr a b ': s) <- i ->
U.RIGHT U.noAnn U.noAnn U.noAnn U.noAnn (untypeDemoteT @a)
(IF_LEFT i1 i2) -> U.IF_LEFT (instrToOps i1) (instrToOps i2)
i@NIL | _ :: Instr s ('TList p ': s) <- i ->
U.NIL U.noAnn U.noAnn (untypeDemoteT @p)
CONS -> U.CONS U.noAnn
(IF_CONS i1 i2) -> U.IF_CONS (instrToOps i1) (instrToOps i2)
SIZE -> U.SIZE U.noAnn
i@EMPTY_SET | _ :: Instr s ('TSet e ': s) <- i ->
U.EMPTY_SET U.noAnn U.noAnn (U.Type (U.unwrapT $ untypeDemoteT @e) U.noAnn)
i@EMPTY_MAP | _ :: Instr s ('TMap a b ': s) <- i ->
U.EMPTY_MAP U.noAnn U.noAnn (U.Type (U.unwrapT $ untypeDemoteT @a) U.noAnn)
(untypeDemoteT @b)
i@EMPTY_BIG_MAP | _ :: Instr s ('TBigMap a b ': s) <- i ->
U.EMPTY_BIG_MAP U.noAnn U.noAnn (U.Type (U.unwrapT $ untypeDemoteT @a) U.noAnn)
(untypeDemoteT @b)
(MAP op) -> U.MAP U.noAnn $ instrToOps op
(ITER op) -> U.ITER $ instrToOps op
MEM -> U.MEM U.noAnn
GET -> U.GET U.noAnn
UPDATE -> U.UPDATE U.noAnn
(IF op1 op2) -> U.IF (instrToOps op1) (instrToOps op2)
(LOOP op) -> U.LOOP (instrToOps op)
(LOOP_LEFT op) -> U.LOOP_LEFT (instrToOps op)
i@(LAMBDA {}) | LAMBDA (VLam l) :: Instr s ('TLambda i o ': s) <- i ->
U.LAMBDA U.noAnn (untypeDemoteT @i) (untypeDemoteT @o) (instrToOps $ rfAnyInstr l)
EXEC -> U.EXEC U.noAnn
APPLY -> U.APPLY U.noAnn
(DIP op) -> U.DIP (instrToOps op)
(DIPN s op) ->
U.DIPN (fromIntegral $ peanoValSing s) (instrToOps op)
FAILWITH -> U.FAILWITH
i@CAST | _ :: Instr (a ': s) (a ': s) <- i ->
U.CAST U.noAnn (untypeDemoteT @a)
RENAME -> U.RENAME U.noAnn
PACK -> U.PACK U.noAnn
i@UNPACK
| _ :: Instr ('TBytes ': s) ('TOption a ': s) <- i ->
U.UNPACK U.noAnn U.noAnn (untypeDemoteT @a)
CONCAT -> U.CONCAT U.noAnn
CONCAT' -> U.CONCAT U.noAnn
SLICE -> U.SLICE U.noAnn
ISNAT -> U.ISNAT U.noAnn
ADD -> U.ADD U.noAnn
SUB -> U.SUB U.noAnn
MUL -> U.MUL U.noAnn
EDIV -> U.EDIV U.noAnn
ABS -> U.ABS U.noAnn
NEG -> U.NEG U.noAnn
LSL -> U.LSL U.noAnn
LSR -> U.LSR U.noAnn
OR -> U.OR U.noAnn
AND -> U.AND U.noAnn
XOR -> U.XOR U.noAnn
NOT -> U.NOT U.noAnn
COMPARE -> U.COMPARE U.noAnn
Instr.EQ -> U.EQ U.noAnn
NEQ -> U.NEQ U.noAnn
Instr.LT -> U.LT U.noAnn
Instr.GT -> U.GT U.noAnn
LE -> U.LE U.noAnn
GE -> U.GE U.noAnn
INT -> U.INT U.noAnn
SELF sepc ->
U.SELF U.noAnn (epNameToRefAnn $ sepcName sepc)
i@(CONTRACT nt epName)
| _ :: Instr ('TAddress ': s) ('TOption ('TContract p) ': s) <- i ->
let fa = epNameToRefAnn epName
in U.CONTRACT U.noAnn fa (mkUType nt)
TRANSFER_TOKENS -> U.TRANSFER_TOKENS U.noAnn
SET_DELEGATE -> U.SET_DELEGATE U.noAnn
i@(CREATE_CONTRACT contract)
| _ :: Instr
( 'TOption ('TKeyHash)
': 'TMutez
': g
': s)
('TOperation ': 'TAddress ': s) <- i ->
U.CREATE_CONTRACT U.noAnn U.noAnn (convertContract contract)
IMPLICIT_ACCOUNT -> U.IMPLICIT_ACCOUNT U.noAnn
NOW -> U.NOW U.noAnn
AMOUNT -> U.AMOUNT U.noAnn
BALANCE -> U.BALANCE U.noAnn
CHECK_SIGNATURE -> U.CHECK_SIGNATURE U.noAnn
SHA256 -> U.SHA256 U.noAnn
SHA512 -> U.SHA512 U.noAnn
BLAKE2B -> U.BLAKE2B U.noAnn
HASH_KEY -> U.HASH_KEY U.noAnn
SOURCE -> U.SOURCE U.noAnn
SENDER -> U.SENDER U.noAnn
ADDRESS -> U.ADDRESS U.noAnn
CHAIN_ID -> U.CHAIN_ID U.noAnn
untypeStackRef :: StackRef s -> U.StackRef
untypeStackRef (StackRef n) = U.StackRef (peanoVal n)
untypePrintComment :: PrintComment s -> U.PrintComment
untypePrintComment (PrintComment pc) = U.PrintComment $ map (second untypeStackRef) pc
extInstrToOps :: ExtInstr s -> [U.ExtInstrAbstract U.ExpandedOp]
extInstrToOps = \case
PRINT pc -> one $ U.UPRINT (untypePrintComment pc)
TEST_ASSERT (TestAssert nm pc i) ->
one $ U.UTEST_ASSERT $
U.TestAssert nm (untypePrintComment pc) (instrToOps i)
DOC_ITEM{} -> []
COMMENT_ITEM tp ->
case tp of
FunctionStarts name -> one $ U.UCOMMENT $ name <> " [user func starts]"
FunctionEnds name -> one $ U.UCOMMENT $ name <> " [user func ends]"
StatementStarts name -> one $ U.UCOMMENT $ name <> " [user stmt starts]"
StatementEnds name -> one $ U.UCOMMENT $ name <> " [user stmt ends]"
JustComment com -> one $ U.UCOMMENT com
StackTypeComment (Just stack) -> one $ U.UCOMMENT $ pretty (listF stack)
StackTypeComment Nothing -> one $ U.UCOMMENT $ fmt "any stack type"
-- It's an orphan instance, but it's better than checking all cases manually.
-- We can also move this convertion to the place where `Instr` is defined,
-- but then there will be a very large module (as we'll have to move a lot of
-- stuff as well).
instance Eq (Instr inp out) where
i1 == i2 = instrToOps i1 == instrToOps i2
instance Typeable s => Eq (TestAssert s) where
TestAssert name1 pattern1 instr1
==
TestAssert name2 pattern2 instr2
= and
[ name1 == name2
, pattern1 `eqParam1` pattern2
, instr1 `eqParam2` instr2
]
instance (SingI t, HasNoOp t) => Buildable (Value' Instr t) where
build = build . untypeValue
-- | Get 'sampleTypedValue' from untyped value.
--
-- Throw error if @U.Type@ contains @TOperation@.
sampleValueFromUntype :: HasCallStack => U.Type -> U.Value' U.ExpandedOp
sampleValueFromUntype ty = withSomeSingT (fromUType ty) $ \(_ :: Sing t) ->
case checkScope @(ParameterScope t) of
Left bt -> error $ "Scope error: " <> pretty bt
Right Dict -> untypeValue $ sampleTypedValue @t
-- | Sample values used for generating examples of entrypoint parameter in documentation.
sampleTypedValue :: forall t. (HasCallStack, ParameterScope t) => Value t
sampleTypedValue = case sing @t of
STInt -> VInt -1
STNat -> VNat 0
STString -> VString [mt|hello|]
STMutez -> VMutez (unsafeMkMutez 100)
STBool -> VBool True
STKey -> VKey samplePublicKey
STKeyHash -> VKeyHash $ hashKey samplePublicKey
STTimestamp -> VTimestamp $ timestampFromSeconds 1564142952
STBytes -> VBytes "\10"
STAddress -> VAddress $ sampleAddress
STUnit -> VUnit
STSignature -> VSignature $ sampleSignature
STChainId -> VChainId sampleChainId
STOption (_ :: Sing t2) -> VOption $ Just $ sampleTypedValue @t2
STList (_ :: Sing t2) -> VList [sampleTypedValue @t2]
STSet (s2 :: Sing t2) ->
case ( checkComparability s2
, checkNestedBigMapsPresence s2
) of
(CanBeCompared, NestedBigMapsAbsent) ->
VSet $ Set.fromList [sampleTypedValue @t2]
_ -> error $ "Error generating sample value: scope error"
STContract _ ->
VContract (eaAddress sampleAddress) $ SomeEpc epcCallRootUnsafe
STPair (s2 :: Sing t2) (s3 :: Sing t3) ->
case ( checkOpPresence s2
, checkNestedBigMapsPresence s2
, checkOpPresence s3
, checkNestedBigMapsPresence s3
) of
(OpAbsent, NestedBigMapsAbsent, OpAbsent, NestedBigMapsAbsent) ->
VPair (sampleTypedValue @t2, sampleTypedValue @t3)
STOr (s2 :: Sing t2) _ ->
case (checkNestedBigMapsPresence s2, checkOpPresence s2) of
(NestedBigMapsAbsent, OpAbsent) ->
VOr $ Left $ sampleTypedValue @t2
STMap (s2 :: Sing t2) (s3 :: Sing t3) ->
case ( checkNestedBigMapsPresence s2
, checkComparability s2
, checkOpPresence s2
, checkNestedBigMapsPresence s3
) of
(NestedBigMapsAbsent, CanBeCompared, OpAbsent, NestedBigMapsAbsent) ->
VMap $ Map.fromList [(sampleTypedValue @t2, sampleTypedValue @t3)]
_ -> error $ "Error generating sample value: scope error"
STBigMap (s2 :: Sing t2) (s3 :: Sing t3) ->
case ( checkNestedBigMapsPresence s2
, checkComparability s2
, checkOpPresence s2
, checkNestedBigMapsPresence s3
) of
(NestedBigMapsAbsent, CanBeCompared, OpAbsent, NestedBigMapsAbsent) ->
VBigMap $ Map.fromList [(sampleTypedValue @t2, sampleTypedValue @t3)]
_ -> error $ "Error generating sample value: scope error"
STLambda (_ :: Sing t2) (s3 :: Sing t3) ->
case ( checkNestedBigMapsPresence s3
, checkBigMapPresence s3
, checkContractTypePresence s3
, checkOpPresence s3
) of
(NestedBigMapsAbsent, BigMapAbsent, ContractAbsent, OpAbsent) ->
VLam $ RfNormal (DROP `Seq` PUSH (sampleTypedValue @t3))
_ -> VLam $ RfAlwaysFails (PUSH (VString [mt|lambda sample|]) `Seq` FAILWITH)
where
sampleAddress = unsafeParseEpAddress "KT1AEseqMV6fk2vtvQCVyA7ZCaxv7cpxtXdB"
samplePublicKey = fromRight (error "impossible") $ parsePublicKey
"edpkuwTWKgQNnhR5v17H2DYHbfcxYepARyrPGbf1tbMoGQAj8Ljr3V"
sampleSignature = fromRight (error "impossible") $ parseSignature
"edsigtrs8bK7vNfiR4Kd9dWasVa1bAWaQSu2ipnmLGZuwQa8ktCEMYVKqbWsbJ7zTS8dgYT9tiSUKorWCPFHosL5zPsiDwBQ6vb"
sampleChainId = fromRight (error "impossible") $ parseChainId "NetXUdfLh6Gm88t"
-- Misc
----------------------------------------------------------------------------
-- | Flatten a provided list of notes to a map of its entrypoints and its
-- corresponding utype. Please refer to 'mkEntrypointsMap' in regards to how
-- duplicate entrypoints are handled.
flattenEntrypoints :: SingI t => ParamNotes t -> Map EpName U.Type
flattenEntrypoints = U.mkEntrypointsMap . convertParamNotes