morley 0.4.0 → 0.5.0
raw patch · 13 files changed
+781/−183 lines, 13 filesdep ~morley-preludePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: morley-prelude
API changes (from Hackage documentation)
+ Michelson.Parser.Annotations: noteV2 :: Parser (VarAnn, VarAnn)
+ Michelson.Parser.Annotations: noteV2Def :: Parser (VarAnn, VarAnn)
+ Michelson.Parser.Annotations: notesTF :: Parser (TypeAnn, FieldAnn)
+ Michelson.Parser.Annotations: notesTVF2Def :: Parser (TypeAnn, VarAnn, (FieldAnn, FieldAnn))
- Michelson.Untyped.Instr: UNPACK :: VarAnn -> Type -> InstrAbstract op
+ Michelson.Untyped.Instr: UNPACK :: TypeAnn -> VarAnn -> Type -> InstrAbstract op
Files
- CHANGES.md +7/−0
- morley.cabal +3/−3
- src/Michelson/Interpret/Pack.hs +115/−14
- src/Michelson/Interpret/Unpack.hs +385/−154
- src/Michelson/OpSize.hs +1/−1
- src/Michelson/Parser/Annotations.hs +16/−0
- src/Michelson/Parser/Instr.hs +1/−1
- src/Michelson/TypeCheck/Instr.hs +2/−2
- src/Michelson/Typed/Convert.hs +2/−2
- src/Michelson/Untyped/Instr.hs +2/−2
- src/Util/Test/Arbitrary.hs +1/−1
- test/Test/Interpreter.hs +0/−1
- test/Test/Serialization/Michelson.hs +246/−2
CHANGES.md view
@@ -1,3 +1,10 @@+0.5.0+=====++* Require `morley-prelude` to be ≥ 0.3.0 to make Hackage happy.+* [!156](https://gitlab.com/morley-framework/morley/merge_requests/156)+ Consider annotations in PACK and UNPACK.+ 0.4.0 =====
morley.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 341e0aff6cea56ed81fb3488e1f28073f9d4b8ee8f16cb92cd8da89994761071+-- hash: 5cb09b97dea538abe6a7a84bd871ff992f36744a8f7d30d468791c1452f17e06 name: morley-version: 0.4.0+version: 0.5.0 synopsis: Developer tools for the Michelson Language description: A library to make writing smart contracts in Michelson — the smart contract language of the Tezos blockchain — pleasant and effective. category: Language@@ -212,7 +212,7 @@ , lens , megaparsec >=7.0.0 , memory- , morley-prelude+ , morley-prelude >=0.3.0 , mtl , named , parser-combinators >=1.0.0
src/Michelson/Interpret/Pack.hs view
@@ -19,10 +19,11 @@ import qualified Data.ByteArray as ByteArray import qualified Data.ByteString.Lazy as LBS import qualified Data.Map as Map-import Data.Singletons (SingI(..))+import Data.Singletons (SingI(..), demote) import Michelson.Text import Michelson.Typed+import Michelson.Untyped.Annotation (FieldAnn, TypeAnn, noAnn, renderWEAnn) import Tezos.Address (Address(..), ContractHash(..)) import Tezos.Core (ChainId(..), Mutez(..), timestampToSeconds) import Tezos.Crypto (KeyHash(..), KeyHashTag(..), PublicKey(..), signatureToBytes)@@ -174,7 +175,8 @@ -- | Encode an instruction. encodeInstr :: forall inp out. Instr inp out -> LByteString encodeInstr = \case- InstrWithNotes _ a -> encodeInstr a+ InstrWithNotes n a ->+ encodeNotedInstr a n FrameInstr _ i -> encodeInstr i Seq a b ->@@ -211,10 +213,10 @@ "\x07\x2f" <> encodeInstrs a <> encodeInstrs b PAIR -> "\x03\x42"- (AnnCAR _) ->- "\x03\x16"- (AnnCDR _) ->- "\x03\x17"+ (AnnCAR fn) ->+ encodeWithAnns [] [fn] "\x03\x16"+ (AnnCDR fn) ->+ encodeWithAnns [] [fn] "\x03\x17" LEFT | _ :: Proxy ('TOr l r ': s) <- Proxy @out -> "\x05\x33" <> encodeT' @r RIGHT | _ :: Proxy ('TOr l r ': s) <- Proxy @out ->@@ -254,7 +256,7 @@ LAMBDA (v :: Value ('TLambda i o)) -> "\x09\x31" <> encodeAsList (encodeT' @i <> encodeT' @o <> encodeValue v) <>- encodeLength 0 -- @martoon: dunno where does it come from+ encodeLength 0 -- encoding of a Variable Annotation (that we don't support) EXEC -> "\x03\x26" APPLY ->@@ -323,18 +325,17 @@ "\x03\x30" SELF -> error "SELF should not appear in lambda"- -- TODO [TM-336]: encode annotation here- CONTRACT _ _ | _ :: Proxy ('TOption ('TContract t) ': s) <- Proxy @out ->- "\x05\x55" <> encodeT' @t+ CONTRACT ns ep | _ :: Proxy ('TOption ('TContract t) ': s) <- Proxy @out ->+ encodeWithAnns [] [epNameToRefAnn ep] $ "\x05\x55" <> encodeNotedT' @t ns TRANSFER_TOKENS -> "\x03\x4d" SET_DELEGATE -> "\x03\x4e"- CREATE_CONTRACT (FullContract instr _ _)+ CREATE_CONTRACT (FullContract instr np ng) | _ :: Instr '[ 'TPair p g ] '[ 'TPair ('TList 'TOperation) g ] <- instr -> let contents =- [ "\x05\x00" <> encodeT' @p- , "\x05\x01" <> encodeT' @g+ [ "\x05\x00" <> encodeNotedT' @p (unParamNotes np)+ , "\x05\x01" <> encodeNotedT' @g ng , "\x05\x02" <> encodeInstrs instr ] -- TODO [TM-96] These ^ should be encoded in the same order in which@@ -369,6 +370,106 @@ CHAIN_ID -> "\x03\x75" +-- | Iff there are non-empty annotations it increments the value's tag and+-- appends the encoded annotations.+encodeWithAnns :: [TypeAnn] -> [FieldAnn] -> LByteString -> LByteString+encodeWithAnns tns fns encodedInput+ | null encodedInput = encodedInput+ | null annsList = encodedInput+ | otherwise = inputIncrem <> encodedAnns+ where+ trimEndNoAnn a lst = if null lst && a == noAnn then [] else a : lst+ tnsText = map (show . renderWEAnn) $ foldr trimEndNoAnn [] tns+ fnsText = map (show . renderWEAnn) $ foldr trimEndNoAnn [] fns+ annsList = tnsText <> fnsText+ encodedAnns = encodeAsList . encodeUtf8 $ unwords annsList+ inputIncrem = (1 + LBS.head encodedInput) `LBS.cons` LBS.tail encodedInput++-- | Encode an instruction with Annotations+encodeNotedInstr :: forall inp out. Instr inp out -> PackedNotes out -> LByteString+encodeNotedInstr a (PackedNotes n _) = case (a, Proxy @out, n) of+ (SOME, _, NTOption tn _ns) ->+ encodeWithAnns [tn] [] $ encodeInstr a+ (NONE, _ :: Proxy ('TOption t ': s), NTOption tn ns) ->+ encodeWithAnns [tn] [] $ "\x05\x3e" <> encodeNotedT' @t ns+ (UNIT, _, NTUnit tn) ->+ encodeWithAnns [tn] [] $ encodeInstr a+ (PAIR, _, NTPair tn fn1 fn2 _ns1 _ns2) ->+ encodeWithAnns [tn] [fn1, fn2] $ encodeInstr a+ (LEFT, _ :: Proxy ('TOr l r ': s), NTOr tn fn1 fn2 _ns1 ns2) ->+ encodeWithAnns [tn] [fn1, fn2] $ "\x05\x33" <> encodeNotedT' @r ns2+ (RIGHT, _ :: Proxy ('TOr l r ': s), NTOr tn fn1 fn2 ns1 _ns2) ->+ encodeWithAnns [tn] [fn1, fn2] $ "\x05\x44" <> encodeNotedT' @l ns1+ (NIL, _ :: Proxy ('TList t ': s), NTList tn ns) ->+ encodeWithAnns [tn] [] $ "\x05\x3d" <> encodeNotedT' @t ns+ (EMPTY_SET, _ :: Proxy ('TSet t ': s), NTSet tn1 tn2) ->+ encodeWithAnns [tn1] [] $ "\x05\x24" <> encodeNotedT' @('Tc t) (NTc tn2)+ (EMPTY_MAP, _ :: Proxy ('TMap k v ': s), NTMap tn1 tn2 ns) ->+ encodeWithAnns [tn1] [] $+ "\x07\x23" <> encodeNotedT' @('Tc k) (NTc tn2) <> encodeNotedT' @v ns+ (EMPTY_BIG_MAP, _ :: Proxy ('TBigMap k v ': s), NTBigMap tn1 tn2 ns) ->+ encodeWithAnns [tn1] [] $+ "\x07\x72" <> encodeNotedT' @('Tc k) (NTc tn2) <> encodeNotedT' @v ns+ (PUSH (v :: Value t), _, NTc tn) ->+ "\x07\x43" <> encodeNotedT' @t (NTc tn) <> encodeValue v+ (LAMBDA (v :: Value ('TLambda i o)), _, NTLambda _tn ns1 ns2) ->+ "\x09\x31" <>+ encodeAsList (encodeNotedT' @i ns1 <> encodeNotedT' @o ns2 <> encodeValue v) <>+ encodeLength 0 -- encoding of a Variable Annotation (that we don't support)+ (CAST, _ :: Proxy (t ': s), NTc tn) ->+ "\x05\x57" <> encodeNotedT' @t (NTc tn)+ (UNPACK, _ :: Proxy ('TOption t ': s), NTOption tn ns) ->+ encodeWithAnns [tn] [] $ "\x05\x0d" <> encodeNotedT' @t ns+ -- NOTE: `CONTRACT` may be part of an `InstrWithNotes` with `NTOption`, but is+ -- taken care of in `encodeInstr` anyway (because it contains the note itself)+ _ -> encodeInstr a++encodeNotedT' :: forall (t :: T). SingI t => Notes t -> LByteString+encodeNotedT' = encodeNotedST (sing @t) noAnn++-- Note: to encode field annotations we have to accept them as an additional+-- parameter because they are stored in the parent's `Notes t`, e.g. see STPair.+encodeNotedST :: Sing t -> FieldAnn -> Notes t -> LByteString+encodeNotedST st fn n = case (st, n) of+ (STc ct, NTc tn) ->+ encodeCTWithAnns (fromSingCT ct) tn fn+ (STKey, NTKey tn) ->+ encodeWithAnns [tn] [fn] $ "\x03\x5c"+ (STUnit, NTUnit tn) ->+ encodeWithAnns [tn] [fn] $ "\x03\x6c"+ (STSignature, NTSignature tn) ->+ encodeWithAnns [tn] [fn] $ "\x03\x67"+ (STChainId, NTChainId tn) ->+ encodeWithAnns [tn] [fn] $ "\x03\x74"+ (STOption a, NTOption tn ns) ->+ encodeWithAnns [tn] [fn] $ "\x05\x63" <> encodeNotedST a noAnn ns+ (STList a, NTList tn ns) ->+ encodeWithAnns [tn] [fn] $ "\x05\x5f" <> encodeNotedST a noAnn ns+ (STSet a, NTSet tn1 tn2) ->+ encodeWithAnns [tn1] [fn] $ "\x05\x66" <> encodeCTWithAnns (fromSingCT a) tn2 noAnn+ (STOperation, NTOperation tn) ->+ encodeWithAnns [tn] [fn] $ "\x03\x6d"+ (STContract a, NTContract tn ns) ->+ encodeWithAnns [tn] [fn] $ "\x05\x5a" <> encodeNotedST a noAnn ns+ (STPair a b, NTPair tn fn1 fn2 ns1 ns2) ->+ encodeWithAnns [tn] [fn] $+ "\x07\x65" <> encodeNotedST a fn1 ns1 <> encodeNotedST b fn2 ns2+ (STOr a b, NTOr tn fn1 fn2 ns1 ns2) ->+ encodeWithAnns [tn] [fn] $+ "\x07\x64" <> encodeNotedST a fn1 ns1 <> encodeNotedST b fn2 ns2+ (STLambda a r, NTLambda tn ns1 ns2) ->+ encodeWithAnns [tn] [fn] $+ "\x07\x5e" <> encodeNotedST a noAnn ns1 <> encodeNotedST r noAnn ns2+ (STMap k v, NTMap tn1 tn2 ns) ->+ encodeWithAnns [tn1] [fn] $+ "\x07\x60" <> encodeCTWithAnns (fromSingCT k) tn2 noAnn <> encodeNotedST v noAnn ns+ (STBigMap k v, NTBigMap tn1 tn2 ns) ->+ encodeWithAnns [tn1] [fn] $+ "\x07\x61" <> encodeCTWithAnns (fromSingCT k) tn2 noAnn <> encodeNotedST v noAnn ns++encodeCTWithAnns :: CT -> TypeAnn -> FieldAnn -> LByteString+encodeCTWithAnns ct tn fn = encodeWithAnns [tn] [fn] $ encodeCT ct+ encodeT :: T -> LByteString encodeT = \case Tc ct -> encodeCT ct@@ -388,7 +489,7 @@ TBigMap k v -> "\x07\x61" <> encodeCT k <> encodeT v encodeT' :: forall (t :: T). SingI t => LByteString-encodeT' = encodeT (fromSingT $ sing @t)+encodeT' = encodeT (demote @t) encodeCT :: CT -> LByteString encodeCT = ("\x03" <>) . \case
src/Michelson/Interpret/Unpack.hs view
@@ -36,6 +36,8 @@ import Fmt (Buildable, build, fmt, hexF, pretty, (+|), (+||), (|+), (||+)) import Text.Hex (encodeHex) +import Michelson.Parser (ParserException(..), Parser, parseNoEnv)+import qualified Michelson.Parser.Annotations as PA import Michelson.Text import Michelson.TypeCheck (HST(..), SomeHST(..), SomeInstr(..), SomeInstrOut(..), TCError(..), TypeCheckEnv(..))@@ -48,7 +50,7 @@ (BigMapPresence(..), ContractPresence(..), OpPresence(..), UnpackedValScope, bigMapAbsense, checkBigMapPresence, checkContractTypePresence, checkOpPresence, contractTypeAbsense, opAbsense) import Michelson.Untyped-import Tezos.Address (Address(..), ContractHash(..), parseAddress)+import Tezos.Address (Address(..), ContractHash(..)) import Tezos.Core import Tezos.Crypto (KeyHash(..), KeyHashTag(..), PublicKey(..), keyHashLengthBytes, mkSignature, parseKeyHash,@@ -407,29 +409,35 @@ either (fail . toString) pure $ Map.fromDistinctAscList <$> ensureDistinctAsc fst es -decodeAddress :: Get Address-decodeAddress = Get.label "Address" $ asum- -- 1 byte is spent on tag specified here (0x00 or 0x01), so we subtract it.- [ decodeAsBytes $ \(pred -> lenNoTag) -> decodeWithTagSimple "address"- [ (0x00, KeyAddress <$>- decodeWithTag "key_hash inside address" keyHashDecoders lenNoTag)- , (0x01, Get.label "Contract addres" $ do+decodeEpAddress :: Get EpAddress+decodeEpAddress = Get.label "Address" $ asum+ [ do+ expectTag "Bytes" 0x0A+ decodeAsBytesRaw $ \l -> (Get.getWord8 ? "Address tag") >>= \case+ 0x00 -> Get.label "Plain address" $ do+ eaAddress <- KeyAddress <$>+ decodeWithTag "key_hash inside address" keyHashDecoders+ (min (l - 1) (keyHashLengthBytes + 1))+ eaEntryPoint <- decodeEpName (l - keyHashLengthBytes - 2)+ return EpAddress{..}+ 0x01 -> Get.label "Contract address" $ do -- TODO [TM-329]: ignoring length is bad- addr <- getByteStringCopy 20+ eaAddress <- ContractAddress . ContractHash <$>+ getByteStringCopy keyHashLengthBytes expectTag "Contract address suffix" 0x00- return $ ContractAddress (ContractHash addr)- )- ]- , decodeAsString parseAddress+ eaEntryPoint <- decodeEpName (l - keyHashLengthBytes - 2)+ return EpAddress{..}+ other -> unknownTag "address" other+ , decodeAsString parseEpAddress ] -decodeEpAddress :: Get EpAddress-decodeEpAddress = do- eaAddress <- decodeAddress- refAnn <- decodeAnn- eaEntryPoint <- epNameFromRefAnn refAnn- & either (fail . pretty) pure- return EpAddress{..}+decodeEpName :: Int -> Get EpName+decodeEpName l = do+ ss <- replicateM l Get.getWord8 ? "EpName' String content"+ s <- decodeUtf8' (BS.pack ss)+ & either (fail . show) pure+ ? "EpName' String UTF-8 decoding"+ either (fail . pretty) pure $ epNameFromRefAnn (ann s) -- | Read a numeric value. decodeInt :: Num i => Get i@@ -451,11 +459,6 @@ let upayload = Bits.clearBit payload 6 (sign *) <$> addAndCont 6 upayload --- | For @UNPACK@ we do not consider annotations at all.--- If they start matter for other purposes some day, remove this function.-decodeAnn :: forall (t :: Kind.Type). Get (Annotation t)-decodeAnn = pure noAnn- -- | Type check instruction occured from a lambda. decodeTypeCheckLam :: forall inp out m.@@ -507,123 +510,226 @@ case (pretag, tag) of (0x03, 0x20) -> pure $ DROP (0x05, 0x20) -> DROPN <$> (expectTag "'DROP n' parameter" 0x00 *> decodeInt)- (0x03, 0x21) -> pure $ DUP noAnn+ (0x03, 0x21) -> DUP <$> decodeNoAnn (0x03, 0x4C) -> pure $ SWAP (0x05, 0x70) -> DIG <$> (expectTag "'DIG n' parameter" 0x00 *> decodeInt) (0x05, 0x71) -> DUG <$> (expectTag "'DUG n' parameter" 0x00 *> decodeInt) (0x07, 0x43) -> do- an :: VarAnn <- decodeAnn- typ <- decodeType- T.withSomeSingT (T.fromUType typ) $ \(st :: Sing t) ->- case (opAbsense st, bigMapAbsense st, contractTypeAbsense st) of- (Nothing, _, _) -> fail "Operation type cannot appear in PUSH"- (_, Nothing, _) -> fail "BigMap type cannot appear in PUSH"- (_, _, Nothing) -> fail "'contract' type cannot appear in PUSH"- (Just Dict, Just Dict, Just Dict) -> do- tval <- decodeValue @t- return $ PUSH an typ (T.untypeValue tval)- (0x03, 0x46) -> SOME <$> decodeAnn <*> decodeAnn- (0x05, 0x3E) -> NONE <$> decodeAnn <*> decodeAnn <*> decodeType- (0x03, 0x4F) -> UNIT <$> decodeAnn <*> decodeAnn+ (typ, val) <- decodePushVal+ an <- decodeNoAnn+ return $ PUSH an typ val+ (0x03, 0x46) -> SOME <$> decodeNoAnn <*> decodeNoAnn+ (0x05, 0x3E) -> NONE <$> decodeNoAnn <*> decodeNoAnn <*> decodeType+ (0x03, 0x4F) -> UNIT <$> decodeNoAnn <*> decodeNoAnn (0x07, 0x2F) -> IF_NONE <$> decodeOps <*> decodeOps- (0x03, 0x42) -> PAIR <$> decodeAnn <*> decodeAnn <*> decodeAnn <*> decodeAnn- (0x03, 0x16) -> CAR <$> decodeAnn <*> decodeAnn- (0x03, 0x17) -> CDR <$> decodeAnn <*> decodeAnn- (0x05, 0x33) -> LEFT <$> decodeAnn <*> decodeAnn <*> decodeAnn <*> decodeAnn+ (0x03, 0x42) -> PAIR <$> decodeNoAnn <*> decodeNoAnn <*> decodeNoAnn <*> decodeNoAnn+ (0x03, 0x16) -> CAR <$> decodeNoAnn <*> decodeNoAnn+ (0x03, 0x17) -> CDR <$> decodeNoAnn <*> decodeNoAnn+ (0x05, 0x33) -> LEFT <$> decodeNoAnn <*> decodeNoAnn <*> decodeNoAnn <*> decodeNoAnn <*> decodeType- (0x05, 0x44) -> RIGHT <$> decodeAnn <*> decodeAnn <*> decodeAnn <*> decodeAnn+ (0x05, 0x44) -> RIGHT <$> decodeNoAnn <*> decodeNoAnn <*> decodeNoAnn <*> decodeNoAnn <*> decodeType (0x07, 0x2E) -> IF_LEFT <$> decodeOps <*> decodeOps- (0x05, 0x3D) -> NIL <$> decodeAnn <*> decodeAnn <*> decodeType- (0x03, 0x1B) -> CONS <$> decodeAnn+ (0x05, 0x3D) -> NIL <$> decodeNoAnn <*> decodeNoAnn <*> decodeType+ (0x03, 0x1B) -> CONS <$> decodeNoAnn (0x07, 0x2D) -> IF_CONS <$> decodeOps <*> decodeOps- (0x03, 0x45) -> SIZE <$> decodeAnn- (0x05, 0x24) -> EMPTY_SET <$> decodeAnn <*> decodeAnn <*> decodeComparable- (0x07, 0x23) -> EMPTY_MAP <$> decodeAnn <*> decodeAnn <*> decodeComparable+ (0x03, 0x45) -> SIZE <$> decodeNoAnn+ (0x05, 0x24) -> EMPTY_SET <$> decodeNoAnn <*> decodeNoAnn <*> decodeComparable+ (0x07, 0x23) -> EMPTY_MAP <$> decodeNoAnn <*> decodeNoAnn <*> decodeComparable <*> decodeType- (0x07, 0x72) -> EMPTY_BIG_MAP <$> decodeAnn <*> decodeAnn <*> decodeComparable+ (0x07, 0x72) -> EMPTY_BIG_MAP <$> decodeNoAnn <*> decodeNoAnn <*> decodeComparable <*> decodeType- (0x05, 0x38) -> MAP <$> decodeAnn <*> decodeOps+ (0x05, 0x38) -> MAP <$> decodeNoAnn <*> decodeOps (0x05, 0x52) -> ITER <$> decodeOps- (0x03, 0x39) -> MEM <$> decodeAnn- (0x03, 0x29) -> GET <$> decodeAnn- (0x03, 0x50) -> UPDATE <$> decodeAnn+ (0x03, 0x39) -> MEM <$> decodeNoAnn+ (0x03, 0x29) -> GET <$> decodeNoAnn+ (0x03, 0x50) -> UPDATE <$> decodeNoAnn (0x07, 0x2C) -> IF <$> decodeOps <*> decodeOps (0x05, 0x34) -> LOOP <$> decodeOps (0x05, 0x53) -> LOOP_LEFT <$> decodeOps (0x09, 0x31) -> do- res <- decodeAsListRaw $- LAMBDA <$> decodeAnn <*> decodeType <*> decodeType <*> decodeOps- void decodeLength- return res- (0x03, 0x26) -> EXEC <$> decodeAnn- (0x03, 0x73) -> APPLY <$> decodeAnn+ (ti, to, ops) <- decodeAsListRaw $+ (,,) <$> decodeType <*> decodeType <*> decodeOps+ vAnn <- decodeVAnnDef+ return $ LAMBDA vAnn ti to ops+ (0x03, 0x26) -> EXEC <$> decodeNoAnn+ (0x03, 0x73) -> APPLY <$> decodeNoAnn (0x05, 0x1F) -> DIP <$> decodeOps (0x07, 0x1F) -> DIPN <$> (expectTag "'DIP n' parameter" 0x00 *> decodeInt) <*> decodeOps (0x03, 0x27) -> pure FAILWITH- (0x05, 0x57) -> CAST <$> decodeAnn <*> decodeType- (0x03, 0x58) -> RENAME <$> decodeAnn- (0x03, 0x0C) -> PACK <$> decodeAnn- (0x05, 0x0D) -> UNPACK <$> decodeAnn <*> decodeType- (0x03, 0x1A) -> CONCAT <$> decodeAnn- (0x03, 0x6F) -> SLICE <$> decodeAnn- (0x03, 0x56) -> ISNAT <$> decodeAnn- (0x03, 0x12) -> ADD <$> decodeAnn- (0x03, 0x4B) -> SUB <$> decodeAnn- (0x03, 0x3A) -> MUL <$> decodeAnn- (0x03, 0x22) -> EDIV <$> decodeAnn- (0x03, 0x11) -> ABS <$> decodeAnn- (0x03, 0x3B) -> NEG <$> decodeAnn- (0x03, 0x35) -> LSL <$> decodeAnn- (0x03, 0x36) -> LSR <$> decodeAnn- (0x03, 0x41) -> OR <$> decodeAnn- (0x03, 0x14) -> AND <$> decodeAnn- (0x03, 0x51) -> XOR <$> decodeAnn- (0x03, 0x3F) -> NOT <$> decodeAnn- (0x03, 0x19) -> COMPARE <$> decodeAnn- (0x03, 0x25) -> EQ <$> decodeAnn- (0x03, 0x3C) -> NEQ <$> decodeAnn- (0x03, 0x37) -> LT <$> decodeAnn- (0x03, 0x2A) -> GT <$> decodeAnn- (0x03, 0x32) -> LE <$> decodeAnn- (0x03, 0x28) -> GE <$> decodeAnn- (0x03, 0x30) -> INT <$> decodeAnn- -- TODO [TM-336]: consider field annotation here and lookup for entrypoint- (0x05, 0x55) -> CONTRACT <$> decodeAnn <*> decodeAnn <*> decodeType- (0x03, 0x4D) -> TRANSFER_TOKENS <$> decodeAnn- (0x03, 0x4E) -> SET_DELEGATE <$> decodeAnn- (0x05, 0x1D) ->- decodeAsList $ do- an1 <- decodeAnn- an2 <- decodeAnn- expectTag "Pre contract parameter" 0x05- expectTag "Contract parameter" 0x00- p <- decodeType- expectTag "Pre contract storage" 0x05- expectTag "Contract storage" 0x01- s <- decodeType- expectTag "Pre contract code" 0x05- expectTag "Contract code" 0x02- c <- decodeOps- return $ CREATE_CONTRACT an1 an2 (Contract p s c)- (0x03, 0x1E) -> IMPLICIT_ACCOUNT <$> decodeAnn- (0x03, 0x40) -> NOW <$> decodeAnn- (0x03, 0x13) -> AMOUNT <$> decodeAnn- (0x03, 0x15) -> BALANCE <$> decodeAnn- (0x03, 0x18) -> CHECK_SIGNATURE <$> decodeAnn- (0x03, 0x0F) -> SHA256 <$> decodeAnn- (0x03, 0x10) -> SHA512 <$> decodeAnn- (0x03, 0x0E) -> BLAKE2B <$> decodeAnn- (0x03, 0x2B) -> HASH_KEY <$> decodeAnn- (0x03, 0x4A) -> STEPS_TO_QUOTA <$> decodeAnn- (0x03, 0x47) -> SOURCE <$> decodeAnn- (0x03, 0x48) -> SENDER <$> decodeAnn- (0x03, 0x54) -> ADDRESS <$> decodeAnn- (0x03, 0x75) -> CHAIN_ID <$> decodeAnn+ (0x05, 0x57) -> CAST <$> decodeNoAnn <*> decodeType+ (0x03, 0x58) -> RENAME <$> decodeNoAnn+ (0x03, 0x0C) -> PACK <$> decodeNoAnn+ (0x05, 0x0D) -> UNPACK <$> decodeNoAnn <*> decodeNoAnn <*> decodeType+ (0x03, 0x1A) -> CONCAT <$> decodeNoAnn+ (0x03, 0x6F) -> SLICE <$> decodeNoAnn+ (0x03, 0x56) -> ISNAT <$> decodeNoAnn+ (0x03, 0x12) -> ADD <$> decodeNoAnn+ (0x03, 0x4B) -> SUB <$> decodeNoAnn+ (0x03, 0x3A) -> MUL <$> decodeNoAnn+ (0x03, 0x22) -> EDIV <$> decodeNoAnn+ (0x03, 0x11) -> ABS <$> decodeNoAnn+ (0x03, 0x3B) -> NEG <$> decodeNoAnn+ (0x03, 0x35) -> LSL <$> decodeNoAnn+ (0x03, 0x36) -> LSR <$> decodeNoAnn+ (0x03, 0x41) -> OR <$> decodeNoAnn+ (0x03, 0x14) -> AND <$> decodeNoAnn+ (0x03, 0x51) -> XOR <$> decodeNoAnn+ (0x03, 0x3F) -> NOT <$> decodeNoAnn+ (0x03, 0x19) -> COMPARE <$> decodeNoAnn+ (0x03, 0x25) -> EQ <$> decodeNoAnn+ (0x03, 0x3C) -> NEQ <$> decodeNoAnn+ (0x03, 0x37) -> LT <$> decodeNoAnn+ (0x03, 0x2A) -> GT <$> decodeNoAnn+ (0x03, 0x32) -> LE <$> decodeNoAnn+ (0x03, 0x28) -> GE <$> decodeNoAnn+ (0x03, 0x30) -> INT <$> decodeNoAnn+ (0x05, 0x55) -> CONTRACT <$> decodeNoAnn <*> decodeNoAnn <*> decodeType+ (0x03, 0x4D) -> TRANSFER_TOKENS <$> decodeNoAnn+ (0x03, 0x4E) -> SET_DELEGATE <$> decodeNoAnn+ (0x05, 0x1D) -> do+ contract <- decodeContract+ CREATE_CONTRACT <$> decodeNoAnn <*> decodeNoAnn <*> pure contract+ (0x03, 0x1E) -> IMPLICIT_ACCOUNT <$> decodeNoAnn+ (0x03, 0x40) -> NOW <$> decodeNoAnn+ (0x03, 0x13) -> AMOUNT <$> decodeNoAnn+ (0x03, 0x15) -> BALANCE <$> decodeNoAnn+ (0x03, 0x18) -> CHECK_SIGNATURE <$> decodeNoAnn+ (0x03, 0x0F) -> SHA256 <$> decodeNoAnn+ (0x03, 0x10) -> SHA512 <$> decodeNoAnn+ (0x03, 0x0E) -> BLAKE2B <$> decodeNoAnn+ (0x03, 0x2B) -> HASH_KEY <$> decodeNoAnn+ (0x03, 0x4A) -> STEPS_TO_QUOTA <$> decodeNoAnn+ (0x03, 0x47) -> SOURCE <$> decodeNoAnn+ (0x03, 0x48) -> SENDER <$> decodeNoAnn+ (0x03, 0x54) -> ADDRESS <$> decodeNoAnn+ (0x03, 0x75) -> CHAIN_ID <$> decodeNoAnn+ -- Instructions with annotations from here on+ (0x04, 0x21) -> DUP <$> decodeVAnn+ (0x08, 0x43) -> do+ (typ, val) <- decodePushVal+ an <- decodeVAnn+ return $ PUSH an typ val+ (0x04, 0x46) -> decodeWithTVAnns SOME+ (0x06, 0x3E) -> do+ t <- decodeType+ decodeWithTVAnns NONE <*> pure t+ (0x04, 0x4F) -> decodeWithTVAnns UNIT+ (0x04, 0x42) -> decodeWithTVF2Anns PAIR+ (0x04, 0x16) -> decodeWithVFAnns CAR+ (0x04, 0x17) -> decodeWithVFAnns CDR+ (0x06, 0x33) -> do+ t <- decodeType+ decodeWithTVF2Anns LEFT <*> pure t+ (0x06, 0x44) -> do+ t <- decodeType+ decodeWithTVF2Anns RIGHT <*> pure t+ (0x06, 0x3D) -> do+ t <- decodeType+ decodeWithTVAnns NIL <*> pure t+ (0x04, 0x1B) -> CONS <$> decodeVAnn+ (0x04, 0x45) -> SIZE<$> decodeVAnn+ (0x06, 0x24) -> do+ c <- decodeComparable+ decodeWithTVAnns EMPTY_SET <*> pure c+ (0x08, 0x23) -> do+ c <- decodeComparable+ t <- decodeType+ decodeWithTVAnns EMPTY_MAP <*> pure c <*> pure t+ (0x08, 0x72) -> do+ c <- decodeComparable+ t <- decodeType+ decodeWithTVAnns EMPTY_BIG_MAP <*> pure c <*> pure t+ (0x06, 0x38) -> do+ o <- decodeOps+ MAP <$> decodeVAnn <*> pure o+ (0x04, 0x39) -> MEM <$> decodeVAnn+ (0x04, 0x29) -> GET <$> decodeVAnn+ (0x04, 0x50) -> UPDATE <$> decodeVAnn+ (0x04, 0x26) -> EXEC <$> decodeVAnn+ (0x04, 0x73) -> APPLY <$> decodeVAnn+ (0x06, 0x57) -> do+ t <- decodeType+ CAST <$> decodeVAnn <*> pure t+ (0x04, 0x58) -> RENAME <$> decodeVAnn+ (0x04, 0x0C) -> PACK <$> decodeVAnn+ (0x06, 0x0D) -> do+ t <- decodeType+ decodeWithTVAnns UNPACK <*> pure t+ (0x04, 0x1A) -> CONCAT <$> decodeVAnn+ (0x04, 0x6F) -> SLICE <$> decodeVAnn+ (0x04, 0x56) -> ISNAT <$> decodeVAnn+ (0x04, 0x12) -> ADD <$> decodeVAnn+ (0x04, 0x4B) -> SUB <$> decodeVAnn+ (0x04, 0x3A) -> MUL <$> decodeVAnn+ (0x04, 0x22) -> EDIV <$> decodeVAnn+ (0x04, 0x11) -> ABS <$> decodeVAnn+ (0x04, 0x3B) -> NEG <$> decodeVAnn+ (0x04, 0x35) -> LSL <$> decodeVAnn+ (0x04, 0x36) -> LSR <$> decodeVAnn+ (0x04, 0x41) -> OR <$> decodeVAnn+ (0x04, 0x14) -> AND <$> decodeVAnn+ (0x04, 0x51) -> XOR <$> decodeVAnn+ (0x04, 0x3F) -> NOT <$> decodeVAnn+ (0x04, 0x19) -> COMPARE <$> decodeVAnn+ (0x04, 0x25) -> EQ <$> decodeVAnn+ (0x04, 0x3C) -> NEQ <$> decodeVAnn+ (0x04, 0x37) -> LT <$> decodeVAnn+ (0x04, 0x2A) -> GT <$> decodeVAnn+ (0x04, 0x32) -> LE <$> decodeVAnn+ (0x04, 0x28) -> GE <$> decodeVAnn+ (0x04, 0x30) -> INT <$> decodeVAnn+ (0x06, 0x55) -> do+ t <- decodeType+ decodeWithVFAnns CONTRACT <*> pure t+ (0x04, 0x4D) -> TRANSFER_TOKENS <$> decodeVAnn+ (0x04, 0x4E) -> SET_DELEGATE <$> decodeVAnn+ (0x06, 0x1D) -> do+ contract <- decodeContract+ decodeWithV2Anns CREATE_CONTRACT <*> pure contract+ (0x04, 0x1E) -> IMPLICIT_ACCOUNT <$> decodeVAnn+ (0x04, 0x40) -> NOW <$> decodeVAnn+ (0x04, 0x13) -> AMOUNT <$> decodeVAnn+ (0x04, 0x15) -> BALANCE <$> decodeVAnn+ (0x04, 0x18) -> CHECK_SIGNATURE <$> decodeVAnn+ (0x04, 0x0F) -> SHA256 <$> decodeVAnn+ (0x04, 0x10) -> SHA512 <$> decodeVAnn+ (0x04, 0x0E) -> BLAKE2B <$> decodeVAnn+ (0x04, 0x2B) -> HASH_KEY <$> decodeVAnn+ (0x04, 0x4A) -> STEPS_TO_QUOTA <$> decodeVAnn+ (0x04, 0x47) -> SOURCE <$> decodeVAnn+ (0x04, 0x48) -> SENDER <$> decodeVAnn+ (0x04, 0x54) -> ADDRESS <$> decodeVAnn+ (0x04, 0x75) -> CHAIN_ID <$> decodeVAnn (other1, other2) -> fail $ "Unknown instruction tag: 0x" +| hexF other1 |+ hexF other2 |+ "" +decodePushVal :: Get (Type, Value)+decodePushVal = do+ typ <- decodeType+ T.withSomeSingT (T.fromUType typ) $ \(st :: Sing t) ->+ case (opAbsense st, bigMapAbsense st, contractTypeAbsense st) of+ (Nothing, _, _) -> fail "Operation type cannot appear in PUSH"+ (_, Nothing, _) -> fail "BigMap type cannot appear in PUSH"+ (_, _, Nothing) -> fail "'contract' type cannot appear in PUSH"+ (Just Dict, Just Dict, Just Dict) -> do+ tval <- decodeValue @t+ pure $ (typ, T.untypeValue tval)++decodeContract :: Get Contract+decodeContract = decodeAsList $ do+ expectTag "Pre contract parameter" 0x05+ expectTag "Contract parameter" 0x00+ p <- decodeType+ expectTag "Pre contract storage" 0x05+ expectTag "Contract storage" 0x01+ s <- decodeType+ expectTag "Pre contract code" 0x05+ expectTag "Contract code" 0x02+ c <- decodeOps+ pure (Contract p s c)+ decodeOp :: Get ExpandedOp decodeOp = Get.label "Op" $ do tag <- Get.lookAhead Get.getWord8@@ -635,50 +741,175 @@ decodeOps = decodeAsList $ manyForced decodeOp decodeComparable :: Get Comparable-decodeComparable = Get.label "Comparable primitive type" $- Comparable <$> decodeCT <*> decodeAnn+decodeComparable = do+ (ct, tAnn, fAnn) <- decodeCTWithAnns+ if fAnn == noAnn+ then pure $ Comparable ct tAnn+ else fail "This Comparable should not have a Field annotation" -decodeCT :: Get CT-decodeCT = Get.label "CT" $ do+decodeType :: Get Type+decodeType = do+ (t, tAnn, fAnn) <- decodeTWithAnns+ if fAnn == noAnn+ then pure $ Type t tAnn+ else fail "This Type should not have a Field annotation"++decodeCTWithAnns :: Get (CT, TypeAnn, FieldAnn)+decodeCTWithAnns = Get.label "Comparable primitive type" $ do pretag <- Get.getWord8 ? "Pre simple comparable type tag" tag <- Get.getWord8 ? "Simple comparable type tag"- case (pretag, tag) of- (0x03, 0x5B) -> pure CInt- (0x03, 0x62) -> pure CNat- (0x03, 0x68) -> pure CString- (0x03, 0x69) -> pure CBytes- (0x03, 0x6A) -> pure CMutez- (0x03, 0x59) -> pure CBool- (0x03, 0x5D) -> pure CKeyHash- (0x03, 0x6B) -> pure CTimestamp- (0x03, 0x6E) -> pure CAddress- (other1, other2) -> fail $ "Unknown primitive tag: 0x" +|- hexF other1 |+ hexF other2 |+ ""+ let failMessage = "Unknown primitive tag: 0x" +| hexF pretag |+ hexF tag |+ ""+ ct <- case tag of+ 0x5B -> pure CInt+ 0x62 -> pure CNat+ 0x68 -> pure CString+ 0x69 -> pure CBytes+ 0x6A -> pure CMutez+ 0x59 -> pure CBool+ 0x5D -> pure CKeyHash+ 0x6B -> pure CTimestamp+ 0x6E -> pure CAddress+ _ -> fail failMessage+ case pretag of+ 0x03 -> (ct,,) <$> decodeNoAnn <*> decodeNoAnn+ 0x04 -> decodeWithTFAnns (ct,,)+ _ -> fail failMessage -decodeT :: Get T-decodeT = Get.label "T" $- doDecode <|> (Tc <$> decodeCT)+decodeTWithAnns :: Get (T, TypeAnn, FieldAnn)+decodeTWithAnns = doDecode <|> decodeTc ? "Type" where+ decodeTc = do+ (ct, tAnn, fAnn) <- decodeCTWithAnns+ pure ((Tc ct), tAnn, fAnn) doDecode = do pretag <- Get.getWord8 ? "Pre complex type tag" tag <- Get.getWord8 ? "Complex type tag" case (pretag, tag) of- (0x03, 0x5C) -> pure TKey- (0x03, 0x6C) -> pure TUnit- (0x03, 0x67) -> pure TSignature- (0x03, 0x74) -> pure TChainId- (0x05, 0x63) -> TOption <$> decodeType- (0x05, 0x5F) -> TList <$> decodeType- (0x05, 0x66) -> TSet <$> decodeComparable- (0x03, 0x6D) -> pure TOperation- (0x05, 0x5A) -> TContract <$> decodeType- (0x07, 0x65) -> TPair <$> decodeAnn <*> decodeAnn <*> decodeType <*> decodeType- (0x07, 0x64) -> TOr <$> decodeAnn <*> decodeAnn <*> decodeType <*> decodeType- (0x07, 0x5E) -> TLambda <$> decodeType <*> decodeType- (0x07, 0x60) -> TMap <$> decodeComparable <*> decodeType- (0x07, 0x61) -> TBigMap <$> decodeComparable <*> decodeType+ (0x03, 0x5C) ->+ (,,) <$> pure TKey <*> decodeNoAnn <*> decodeNoAnn+ (0x03, 0x6C) ->+ (,,) <$> pure TUnit <*> decodeNoAnn <*> decodeNoAnn+ (0x03, 0x67) ->+ (,,) <$> pure TSignature <*> decodeNoAnn <*> decodeNoAnn+ (0x03, 0x74) ->+ (,,) <$> pure TChainId <*> decodeNoAnn <*> decodeNoAnn+ (0x05, 0x63) ->+ (,,) <$> (TOption <$> decodeType) <*> decodeNoAnn <*> decodeNoAnn+ (0x05, 0x5F) ->+ (,,) <$> (TList <$> decodeType) <*> decodeNoAnn <*> decodeNoAnn+ (0x05, 0x66) ->+ (,,) <$> (TSet <$> decodeComparable) <*> decodeNoAnn <*> decodeNoAnn+ (0x03, 0x6D) ->+ (,,) <$> pure TOperation <*> decodeNoAnn <*> decodeNoAnn+ (0x05, 0x5A) ->+ (,,) <$> (TContract <$> decodeType) <*> decodeNoAnn <*> decodeNoAnn+ (0x07, 0x65) -> do+ t <- decodeTPair+ (,,) <$> pure t <*> decodeNoAnn <*> decodeNoAnn+ (0x07, 0x64) -> do+ t <- decodeTOr+ (,,) <$> pure t <*> decodeNoAnn <*> decodeNoAnn+ (0x07, 0x5E) ->+ (,,) <$> (TLambda <$> decodeType <*> decodeType) <*> decodeNoAnn <*> decodeNoAnn+ (0x07, 0x60) ->+ (,,) <$> (TMap <$> decodeComparable <*> decodeType) <*> decodeNoAnn <*> decodeNoAnn+ (0x07, 0x61) ->+ (,,) <$> (TBigMap <$> decodeComparable <*> decodeType) <*> decodeNoAnn <*> decodeNoAnn+ -- T with annotations from here on+ (0x04, 0x5C) -> decodeWithTFAnns (TKey,,)+ (0x04, 0x6C) -> decodeWithTFAnns (TUnit,,)+ (0x04, 0x67) -> decodeWithTFAnns (TSignature,,)+ (0x04, 0x74) -> decodeWithTFAnns (TChainId,,)+ (0x06, 0x63) -> do+ t <- TOption <$> decodeType+ decodeWithTFAnns (t,,)+ (0x06, 0x5F) -> do+ t <- TList <$> decodeType+ decodeWithTFAnns (t,,)+ (0x06, 0x66) -> do+ t <- TSet <$> decodeComparable+ decodeWithTFAnns (t,,)+ (0x04, 0x6D) -> decodeWithTFAnns (TOperation,,)+ (0x06, 0x5A) -> do+ t <- TContract <$> decodeType+ decodeWithTFAnns (t,,)+ (0x08, 0x65) -> do+ t <- decodeTPair+ decodeWithTFAnns (t,,)+ (0x08, 0x64) -> do+ t <- decodeTOr+ decodeWithTFAnns (t,,)+ (0x08, 0x5E) -> do+ t <- TLambda <$> decodeType <*> decodeType+ decodeWithTFAnns (t,,)+ (0x08, 0x60) -> do+ t <- TMap <$> decodeComparable <*> decodeType+ decodeWithTFAnns (t,,)+ (0x08, 0x61) -> do+ t <- TBigMap <$> decodeComparable <*> decodeType+ decodeWithTFAnns (t,,) (other1, other2) -> fail $ "Unknown primitive tag: 0x" +| hexF other1 |+ hexF other2 |+ "" -decodeType :: Get Type-decodeType = Type <$> decodeT <*> decodeAnn ? "Type"+decodeTPair :: Get T+decodeTPair = do+ (t1, tAnn1, fAnn1) <- decodeTWithAnns+ (t2, tAnn2, fAnn2) <- decodeTWithAnns+ pure $ TPair fAnn1 fAnn2 (Type t1 tAnn1) (Type t2 tAnn2)++decodeTOr :: Get T+decodeTOr = do+ (t1, tAnn1, fAnn1) <- decodeTWithAnns+ (t2, tAnn2, fAnn2) <- decodeTWithAnns+ pure $ TOr fAnn1 fAnn2 (Type t1 tAnn1) (Type t2 tAnn2)++----------------------------------------------------------------------------+-- Annotations+----------------------------------------------------------------------------++-- | Utility function to fill a constructor with an empty annotation+decodeNoAnn :: forall (t :: Kind.Type). Get (Annotation t)+decodeNoAnn = pure noAnn++-- | Decodes an annotations' string and uses the provided `Parser` to parse+-- untyped annotations from it. This has to produce at least one annotation+-- (Annotations' String parsing will fail otherwise)+decodeAnns :: Parser a -> Get a+decodeAnns annsParser = do+ l <- decodeLength ? "Annotations' String length"+ ss <- replicateM l Get.getWord8 ? "Annotations'String content"+ s <- decodeUtf8' (BS.pack ss)+ & either (fail . show) pure+ ? "Annotations' String UTF-8 decoding"+ either (fail . displayException . ParserException) pure $ parseNoEnv annsParser "" s++decodeVAnn :: Get VarAnn+decodeVAnn = decodeAnns PA.noteV++decodeVAnnDef :: Get VarAnn+decodeVAnnDef = decodeAnns PA.noteVDef++decodeWithTVAnns :: (TypeAnn -> VarAnn -> a) -> Get a+decodeWithTVAnns f = do+ (tAnn, vAnn) <- decodeAnns PA.notesTV+ pure $ f tAnn vAnn++decodeWithTVF2Anns :: (TypeAnn -> VarAnn -> FieldAnn -> FieldAnn -> a) -> Get a+decodeWithTVF2Anns f = do+ (tAnn, vAnn, (fAnn1, fAnn2)) <- decodeAnns PA.notesTVF2Def+ pure $ f tAnn vAnn fAnn1 fAnn2++decodeWithTFAnns :: (TypeAnn -> FieldAnn -> a) -> Get a+decodeWithTFAnns f = do+ (tAnn, fAnn) <- decodeAnns PA.notesTF+ pure $ f tAnn fAnn++decodeWithV2Anns :: (VarAnn -> VarAnn -> a) -> Get a+decodeWithV2Anns f = do+ (vAnn1, vAnn2) <- decodeAnns PA.noteV2Def+ pure $ f vAnn1 vAnn2++decodeWithVFAnns :: (VarAnn -> FieldAnn -> a) -> Get a+decodeWithVFAnns f = do+ (vAnn, fAnn) <- decodeAnns PA.notesVF+ pure $ f vAnn fAnn
src/Michelson/OpSize.hs view
@@ -94,7 +94,7 @@ CAST va t -> annsOpSize va <> typeOpSize t RENAME va -> annsOpSize va PACK va -> annsOpSize va- UNPACK va t -> annsOpSize va <> typeOpSize t+ UNPACK ta va t -> annsOpSize ta va <> typeOpSize t CONCAT va -> annsOpSize va SLICE va -> annsOpSize va ISNAT va -> annsOpSize va
src/Michelson/Parser/Annotations.hs view
@@ -2,11 +2,15 @@ ( noteV , noteF , noteFDef+ , noteV2+ , noteV2Def , noteTDef , noteVDef , notesTVF , notesTVF2+ , notesTVF2Def , notesTV+ , notesTF , notesVF , fieldType , permute2Def@@ -57,6 +61,12 @@ noteF2 :: Parser (U.FieldAnn, U.FieldAnn) noteF2 = do a <- noteF; b <- noteF; return (a, b) +noteV2 :: Parser (U.VarAnn, U.VarAnn)+noteV2 = do a <- noteV; b <- noteV; return (a, b)++noteV2Def :: Parser (U.VarAnn, U.VarAnn)+noteV2Def = permute2Def noteV noteV+ noteTDef :: Parser U.TypeAnn noteTDef = parseDef noteT @@ -69,8 +79,14 @@ notesTVF2 :: Parser (U.TypeAnn, U.VarAnn, (U.FieldAnn, U.FieldAnn)) notesTVF2 = permute3Def noteT noteV noteF2 +notesTVF2Def :: Parser (U.TypeAnn, U.VarAnn, (U.FieldAnn, U.FieldAnn))+notesTVF2Def = permute3Def noteT noteV (permute2Def noteF noteF)+ notesTV :: Parser (U.TypeAnn, U.VarAnn) notesTV = permute2Def noteT noteV++notesTF :: Parser (U.TypeAnn, U.FieldAnn)+notesTF = permute2Def noteT noteF notesVF :: Parser (U.VarAnn, U.FieldAnn) notesVF = permute2Def noteV noteF
src/Michelson/Parser/Instr.hs view
@@ -327,7 +327,7 @@ packOp = do void $ symbol' "PACK"; PACK <$> noteVDef unpackOp :: Parser ParsedInstr-unpackOp = do symbol' "UNPACK"; v <- noteVDef; UNPACK v <$> type_+unpackOp = do symbol' "UNPACK"; (t, v) <- notesTV; UNPACK t v <$> type_ -- Cryptographic Primitives
src/Michelson/TypeCheck/Instr.hs view
@@ -571,9 +571,9 @@ typeCheckInstr (U.RENAME vn) i@((at, an, _) ::& rs) = pure $ i :/ RENAME ::: ((at, an, vn) ::& rs) -typeCheckInstr instr@(U.UNPACK vn mt) i@((STc SCBytes, _, _) ::& rs) =+typeCheckInstr instr@(U.UNPACK tn vn mt) i@((STc SCBytes, _, _) ::& rs) = withUType mt $ \(t :: Sing t, tns :: Notes t) -> do- let ns = NTOption def tns+ let ns = NTOption tn tns proofOp <- maybe (typeCheckInstrErr instr (SomeHST i) "Operation cannot appear in serialized data")
src/Michelson/Typed/Convert.hs view
@@ -175,7 +175,7 @@ (STLambda sp sq, U.LAMBDA va _ _ ops, NTLambda _ n1 n2) -> U.LAMBDA va (mkUType sp n1) (mkUType sq n2) ops (_, U.CAST va _, n) -> U.CAST va (mkUType s n)- (STOption sp, U.UNPACK va _, NTOption _ nt) -> U.UNPACK va (mkUType sp nt)+ (STOption sp, U.UNPACK _ va _, NTOption ta nt) -> U.UNPACK ta va (mkUType sp nt) (STOption (STContract sp), U.CONTRACT va fa _, NTOption _ (NTContract _ nt)) -> U.CONTRACT va fa (mkUType sp nt) (_, U.CONTRACT va fa t, NTOption _ _) -> U.CONTRACT va fa t@@ -315,7 +315,7 @@ handleInstr PACK = U.PACK U.noAnn handleInstr i@UNPACK | _ :: Instr ('Tc 'CBytes ': s) ('TOption a ': s) <- i =- U.UNPACK U.noAnn (toUType $ fromSingT (sing @a))+ U.UNPACK U.noAnn U.noAnn (toUType $ fromSingT (sing @a)) handleInstr CONCAT = U.CONCAT U.noAnn handleInstr CONCAT' = U.CONCAT U.noAnn handleInstr SLICE = U.SLICE U.noAnn
src/Michelson/Untyped/Instr.hs view
@@ -147,7 +147,7 @@ | CAST VarAnn Type | RENAME VarAnn | PACK VarAnn- | UNPACK VarAnn Type+ | UNPACK TypeAnn VarAnn Type | CONCAT VarAnn | SLICE VarAnn | ISNAT VarAnn@@ -237,7 +237,7 @@ CAST va t -> "CAST" <+> renderAnnot va <+> renderTy t RENAME va -> "RENAME" <+> renderAnnot va PACK va -> "PACK" <+> renderAnnot va- UNPACK va t -> "UNPACK" <+> renderAnnot va <+> renderTy t+ 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
src/Util/Test/Arbitrary.hs view
@@ -132,7 +132,7 @@ , CAST <$> arbitrary <*> arbitrary , RENAME <$> arbitrary , PACK <$> arbitrary- , UNPACK <$> arbitrary <*> arbitrary+ , UNPACK <$> arbitrary <*> arbitrary <*> arbitrary , CONCAT <$> arbitrary , SLICE <$> arbitrary , ISNAT <$> arbitrary
test/Test/Interpreter.hs view
@@ -344,7 +344,6 @@ dummyContractEnv () "" ] - -- TODO [TM-280] Move to separate module test_Entry_points_lookup :: IO [TestTree] test_Entry_points_lookup =
test/Test/Serialization/Michelson.hs view
@@ -58,6 +58,7 @@ typesTest unpackNegTest+ unpackVarAnnTest readableUnpackTest stripOptional0x :: Text -> Text@@ -120,8 +121,25 @@ => String -> [(Text, Text)] -> Spec-parsePackSpec name suites =- forM_ @[_] allTestMethods $ \(TestMethod mname method) ->+parsePackSpec name suites = parseVLamSpec @inp @out name allTestMethods suites++parseUnpackOnlySpec+ :: forall (inp :: T) (out :: T).+ (Each [Typeable, SingI] [inp, out], HasCallStack)+ => String+ -> [(Text, Text)]+ -> Spec+parseUnpackOnlySpec name suites = parseVLamSpec @inp @out name unpackTestMethods suites++parseVLamSpec+ :: forall (inp :: T) (out :: T).+ (Each [Typeable, SingI] [inp, out], HasCallStack)+ => String+ -> [TestMethod ('TLambda inp out)]+ -> [(Text, Text)]+ -> Spec+parseVLamSpec name testMethods suites =+ forM_ @[_] testMethods $ \(TestMethod mname method) -> describe mname $ describe name $ forM_ suites $ \(codeText, packed) -> it (truncateName $ toString codeText) $ do@@ -487,6 +505,8 @@ ~: "0x05020000000f034f05710001051f02000000020320" , "UNIT; DROP" ~: "0x050200000004034f0320"+ , "UNIT :u; DROP"+ ~: "0x05020000000a044f000000023a750320" , "UNIT; DROP 1" ~: "0x050200000006034f05200001" , "DROP 0"@@ -497,22 +517,50 @@ ~: "0x0502000000160743035b00010346072f020000000002000000020320" , "PUSH int 1; SOME; IF_SOME {DROP} {}" ~: "0x05020000001b0743035b00010346020000000e072f020000000002000000020320"+ , "PUSH int 1; SOME :s; IF_SOME {DROP} {}"+ ~: "0x0502000000210743035b00010446000000023a73020000000e072f020000000\+ \002000000020320" , "NONE int; DROP" ~: "0x050200000006053e035b0320"+ , "NONE :n int; DROP"+ ~: "0x05020000000c063e035b000000023a6e0320" , "PUSH int 1; PAIR; CAR" ~: "0x05020000000a0743035b000103420316"+ , "PUSH int 1; PAIR :p; CAR"+ ~: "0x0502000000100743035b00010442000000023a700316"+ , "PUSH int 1; PAIR % %o; CAR"+ ~: "0x0502000000120743035b00010442000000042520256f0316"+ , "PUSH int 1; PAIR %o %; CAR"+ ~: "0x0502000000100743035b0001044200000002256f0316"+ , "PUSH int 1; PAIR %o; CAR"+ ~: "0x0502000000100743035b0001044200000002256f0316"+ , "PUSH int 1; PAIR :p %l %r; CAR"+ ~: "0x0502000000160743035b00010442000000083a7020256c2025720316"+ , "PUSH int 1; PAIR %l %r; CAR %l"+ ~: "0x0502000000190743035b0001044200000005256c202572041600000002256c"+ , "PUSH int 1; PAIR %l %r; CDR %r"+ ~: "0x0502000000190743035b0001044200000005256c2025720417000000022572" , "LEFT unit; IF_LEFT {} { DROP; PUSH int 1 }" ~: "0x0502000000180533036c072e0200000000020000000803200743035b0001"+ , "LEFT :lu %l %r unit; IF_LEFT {} { DROP; PUSH int 1 }"+ ~: "0x0502000000250633036c000000093a6c7520256c202572072e0200000000020\+ \000000803200743035b0001" , "RIGHT unit; IF_RIGHT {} { DROP; PUSH int 1 }" ~: "0x05020000001d0544036c0200000014072e020000000803200743035b00010200000000" , "DUP; NIL int; SWAP; CONS; SIZE; DROP" ~: "0x05020000000e0321053d035b034c031b03450320" , "NIL int; IF_CONS { DROP; DROP } {}" ~: "0x050200000014053d035b072d0200000004032003200200000000"+ , "NIL :ni int; IF_CONS { DROP; DROP } {}"+ ~: "0x05020000001b063d035b000000033a6e69072d0200000004032003200200000000" , "EMPTY_SET int; ITER { DROP }" ~: "0x05020000000d0524035b055202000000020320"+ , "EMPTY_SET :si int; ITER { DROP }"+ ~: "0x0502000000140624035b000000033a7369055202000000020320" , "EMPTY_MAP int unit; MAP {}; DROP" ~: "0x05020000000f0723035b036c053802000000000320"+ , "EMPTY_MAP :miu int unit; MAP {}; DROP"+ ~: "0x0502000000170823035b036c000000043a6d6975053802000000000320" , "EMPTY_MAP int unit; PUSH int 1; MEM; DROP" ~: "0x0502000000100723035b036c0743035b000103390320" , "EMPTY_MAP int unit; PUSH int 1; GET; DROP"@@ -521,6 +569,8 @@ ~: "0x0502000000140723035b036c053e036c0743035b000103500320" , "EMPTY_BIG_MAP int unit; PUSH int 1; GET; DROP" ~: "0x0502000000100772035b036c0743035b000103290320"+ , "EMPTY_BIG_MAP :bmiu int unit; PUSH int 1; GET; DROP"+ ~: "0x0502000000190872035b036c000000053a626d69750743035b000103290320" , "PUSH bool True; IF {} {}" ~: "0x05020000001207430359030a072c02000000000200000000" , "PUSH bool True; LOOP { PUSH bool False }"@@ -550,6 +600,8 @@ ~: "0x0502000000020358" , "DUP; PACK; UNPACK unit; DROP" ~: "0x05020000000a0321030c050d036c0320"+ , "DUP; PACK; UNPACK :uu unit; DROP"+ ~: "0x0502000000110321030c060d036c000000033a75750320" , "PUSH string \"\"; DUP; CONCAT; DROP" ~: "0x05020000000f0743036801000000000321031a0320" , "NIL string; CONCAT; DROP"@@ -630,6 +682,8 @@ parsePackSpec @('Tc 'CAddress) @'TUnit "instrs address-related" [ "CONTRACT unit; DROP; PUSH unit Unit" ~: "0x05020000000c0555036c03200743036c030b"+ , "CONTRACT %entrypnt unit; DROP; PUSH unit Unit"+ ~: "0x0502000000190655036c0000000925656e747279706e7403200743036c030b" ] parsePackSpec @('TContract 'TUnit) @'TUnit "instrs contract-related"@@ -653,6 +707,17 @@ ~: "0x05020000003f0346051f020000000c0743036c030b0743036a0005051d020000\ \00190500036c0501036c0502020000000a0320034f053d036d0342032003200743\ \036c030b"+ , "SOME; DIP{ PUSH int 1; PUSH mutez 5 }; \+ \ CREATE_CONTRACT{ \+ \ parameter (int :p); \+ \ storage (int :s); \+ \ code { DROP; PUSH int 10; NIL operation; PAIR } \+ \ }; \+ \ DROP; DROP; PUSH unit Unit \+ \"+ ~: "0x05020000004f0346051f020000000c0743035b00010743036a0005051d020000\+ \00290500045b000000023a700501045b000000023a730502020000000e03200743\+ \035b000a053d036d0342032003200743036c030b" , "IMPLICIT_ACCOUNT; DROP; PUSH unit Unit" ~: "0x05020000000a031e03200743036c030b" ]@@ -677,6 +742,9 @@ parsePackSpec @'TUnit @'TUnit "types" [ lambdaWrap "int" ~: "0x050200000015093100000009035b035b0200000000000000000320"+ , lambdaWrap "int :i"+ ~: "0x050200000021093100000015045b000000023a69045b000000023a690200000\+ \000000000000320" , lambdaWrap "nat" ~: "0x050200000015093100000009036203620200000000000000000320" , lambdaWrap "string"@@ -705,16 +773,39 @@ ~: "0x05020000001909310000000d0563036c0563036c0200000000000000000320" , lambdaWrap "set int" ~: "0x05020000001909310000000d0566035b0566035b0200000000000000000320"+ , lambdaWrap "set :s int"+ ~: "0x0502000000250931000000190666035b000000023a730666035b000000023a7\+ \30200000000000000000320"+ , lambdaWrap "set :s (int :i)"+ ~: "0x0502000000310931000000250666045b000000023a69000000023a730666045\+ \b000000023a69000000023a730200000000000000000320" , lambdaWrap "operation" ~: "0x050200000015093100000009036d036d0200000000000000000320" , lambdaWrap "contract unit" ~: "0x05020000001909310000000d055a036c055a036c0200000000000000000320" , lambdaWrap "pair unit int" ~: "0x05020000001d0931000000110765036c035b0765036c035b0200000000000000000320"+ , lambdaWrap "pair :point (int %x) (int %y)"+ ~: "0x05020000004909310000003d0865045b000000022578045b000000022579000\+ \000063a706f696e740865045b000000022578045b000000022579000000063a70\+ \6f696e740200000000000000000320"+ , lambdaWrap "pair :point3d (pair :point (int %x) (int %y)) (int %z)"+ ~: "0x05020000007509310000006908650865045b000000022578045b00000002257\+ \9000000063a706f696e74045b00000002257a000000083a706f696e7433640865\+ \0865045b000000022578045b000000022579000000063a706f696e74045b00000\+ \002257a000000083a706f696e7433640200000000000000000320" , lambdaWrap "or unit int" ~: "0x05020000001d0931000000110764036c035b0764036c035b0200000000000000000320"+ , lambdaWrap "or (unit :u %l) (int :i %r)"+ ~: "0x0502000000410931000000350764046c000000053a7520256c045b000000053\+ \a692025720764046c000000053a7520256c045b000000053a6920257202000000\+ \00000000000320" , lambdaWrap "lambda unit int" ~: "0x05020000001d093100000011075e036c035b075e036c035b0200000000000000000320"+ , lambdaWrap "lambda :l (unit :n) (int :t)"+ ~: "0x050200000041093100000035085e046c000000023a6e045b000000023a74000\+ \000023a6c085e046c000000023a6e045b000000023a74000000023a6c02000000\+ \00000000000320" , lambdaWrap "map int unit" ~: "0x05020000001d0931000000110760035b036c0760035b036c0200000000000000000320" , lambdaWrap "big_map int unit"@@ -748,6 +839,159 @@ "0x0502000000060743035b0005" -- {PUSH int 5} unpackNegSpec @('TLambda 'TUnit 'TKey) "Lambda empty output stack size" "0x0502000000020320" -- {DROP}++unpackVarAnnTest :: Spec+unpackVarAnnTest = do+ describe "Unpack instructions with Variable Annotations" $ do+ parseUnpackOnlySpec @('Tc 'CInt) @('Tc 'CInt) "VarAnn instr"+ [ "DUP @dp; SWAP; DROP"+ ~: "0x05020000000d042100000003406470034c0320"+ , "UNIT @un; DROP"+ ~: "0x05020000000b044f0000000340756e0320"+ , "NONE @nn int; DROP"+ ~: "0x05020000000d063e035b00000003406e6e0320"+ , "PUSH @vn int 1; PAIR @vpn; CAR @vn"+ ~: "0x0502000000200843035b00010000000340766e0442000000044076706e0416\+ \0000000340766e"+ , "PUSH int 1; PAIR; CDR @dr"+ ~: "0x0502000000110743035b00010342041700000003406472"+ , "LEFT @ll unit; IF_LEFT {} { DROP; PUSH int 1 }"+ ~: "0x05020000001f0633036c00000003406c6c072e020000000002000000080320\+ \0743035b0001"+ , "RIGHT @rl unit; IF_RIGHT {} { DROP; PUSH int 1 }"+ ~: "0x0502000000240644036c0000000340726c0200000014072e02000000080320\+ \0743035b00010200000000"+ , "DUP; NIL @al int; SWAP; CONS @dl; SIZE @sl; DROP"+ ~: "0x0502000000230321063d035b0000000340616c034c041b0000000340646c04\+ \450000000340736c0320"+ , "EMPTY_SET :si @si int; ITER { DROP }"+ ~: "0x0502000000180624035b000000073a736920407369055202000000020320"+ , "EMPTY_MAP @em :miu int unit; MAP @dm {}; DROP"+ ~: "0x0502000000220823035b036c0000000840656d203a6d697506380200000000\+ \0000000340646d0320"+ , "EMPTY_MAP @sm int unit; PUSH int 1; MEM @mmm; DROP"+ ~: "0x05020000001f0823035b036c0000000340736d0743035b0001043900000004406d6d6d0320"+ , "EMPTY_MAP int unit; NONE unit; PUSH int 1; UPDATE @ups; DROP"+ ~: "0x05020000001c0723035b036c053e036c0743035b0001045000000004407570730320"+ , "EMPTY_BIG_MAP int unit; PUSH int 1; GET @gg; DROP"+ ~: "0x0502000000170772035b036c0743035b00010429000000034067670320"+ , "LAMBDA @lii int int { PUSH int 1; DROP }; SWAP; EXEC"+ ~: "0x050200000023093100000011035b035b02000000080743035b000103200000\+ \0004406c6969034c0326"+ , "PUSH string \"\"; DUP; CONCAT @c; DROP"+ ~: "0x0502000000150743036801000000000321041a0000000240630320"+ , "PUSH int 1; PUSH int 2; ADD @a; DROP"+ ~: "0x0502000000160743035b00010743035b000204120000000240610320"+ , "PUSH int 1; PUSH int 2; SUB @s; DROP"+ ~: "0x0502000000160743035b00010743035b0002044b0000000240730320"+ , "PUSH int 1; PUSH int 2; MUL @m; DROP"+ ~: "0x0502000000160743035b00010743035b0002043a00000002406d0320"+ , "PUSH int 1; PUSH int 2; EDIV @edv; DROP"+ ~: "0x0502000000180743035b00010743035b0002042200000004406564760320"+ , "PUSH int 1; ABS @a; DROP"+ ~: "0x0502000000100743035b000104110000000240610320"+ , "PUSH int 1; NEG @n; DROP"+ ~: "0x0502000000100743035b0001043b00000002406e0320"+ , "PUSH nat 1; PUSH nat 2; LSL @ll; DROP"+ ~: "0x050200000017074303620001074303620002043500000003406c6c0320"+ , "PUSH nat 1; PUSH nat 2; LSR @lr; DROP"+ ~: "0x050200000017074303620001074303620002043600000003406c720320"+ , "PUSH nat 1; PUSH nat 2; OR @o; DROP"+ ~: "0x050200000016074303620001074303620002044100000002406f0320"+ , "PUSH nat 1; PUSH nat 2; XOR @x; DROP"+ ~: "0x05020000001607430362000107430362000204510000000240780320"+ , "PUSH int 1; NOT @n; DROP"+ ~: "0x0502000000100743035b0001043f00000002406e0320"+ , "PUSH nat 1; PUSH nat 2; COMPARE @cp; DROP"+ ~: "0x0502000000170743036200010743036200020419000000034063700320"+ , "PUSH int 1; EQ @e; DROP"+ ~: "0x0502000000100743035b000104250000000240650320"+ , "PUSH int 1; NEQ @ne; DROP"+ ~: "0x0502000000110743035b0001043c00000003406e650320"+ , "PUSH int 1; LT @l; DROP"+ ~: "0x0502000000100743035b0001043700000002406c0320"+ , "PUSH int 1; GT @g; DROP"+ ~: "0x0502000000100743035b0001042a0000000240670320"+ , "PUSH int 1; LE @e; DROP"+ ~: "0x0502000000100743035b000104320000000240650320"+ , "PUSH int 1; GE @g; DROP"+ ~: "0x0502000000100743035b000104280000000240670320"+ , "PUSH int 1; ISNAT @i; DROP"+ ~: "0x0502000000100743035b000104560000000240690320"+ , "PUSH nat 1; INT @i; DROP"+ ~: "0x05020000001007430362000104300000000240690320"+ , "NOW @n; DROP"+ ~: "0x05020000000a044000000002406e0320"+ , "AMOUNT @a; DROP"+ ~: "0x05020000000a04130000000240610320"+ , "BALANCE @b; DROP"+ ~: "0x05020000000a04150000000240620320"+ , "PUSH bytes 0x; BLAKE2B @b2b; DROP"+ ~: "0x050200000015074303690a00000000040e00000004406232620320"+ , "STEPS_TO_QUOTA @sq; DROP"+ ~: "0x05020000000b044a000000034073710320"+ , "SOURCE @src; DROP"+ ~: "0x05020000000c044700000004407372630320"+ , "SENDER @s; DROP"+ ~: "0x05020000000a04480000000240730320"+ , "CHAIN_ID @cid; DROP"+ ~: "0x05020000000c047500000004406369640320"+ , "CAST @c int"+ ~: "0x05020000000a0657035b000000024063"+ , "RENAME @r"+ ~: "0x0502000000080458000000024072"+ ]++ parseUnpackOnlySpec @('Tc 'CAddress) @'TUnit "VarAnn instrs address-related"+ [ "CONTRACT @c unit; DROP; PUSH unit Unit"+ ~: "0x0502000000120655036c00000002406303200743036c030b"+ ]++ parseUnpackOnlySpec @('TContract 'TUnit) @'TUnit "VarAnn instrs contract-related"+ [ "ADDRESS @a; DROP; PUSH unit Unit"+ ~: "0x050200000010045400000002406103200743036c030b"+ ]++ parseUnpackOnlySpec @('Tc 'CKeyHash) @'TUnit "VarAnn instrs key-hash-related"+ [ "SOME; SET_DELEGATE @d; DROP; PUSH unit Unit"+ ~: "0x0502000000120346044e00000002406403200743036c030b"+ , "SOME; DIP{ PUSH int 1; PUSH mutez 5 }; \+ \ CREATE_CONTRACT @ez { \+ \ parameter (int :p); \+ \ storage (int :s); \+ \ code { DROP; PUSH int 10; NIL operation; PAIR } \+ \ }; \+ \ DROP; DROP; PUSH unit Unit \+ \"+ ~: "0x0502000000560346051f020000000c0743035b00010743036a0005061d02000\+ \000290500045b000000023a700501045b000000023a730502020000000e032007\+ \43035b000a053d036d03420000000340657a032003200743036c030b"+ , "SOME; DIP{ PUSH int 1; PUSH mutez 5 }; \+ \ CREATE_CONTRACT @ez @pz { \+ \ parameter (int :p); \+ \ storage (int :s); \+ \ code { DROP; PUSH int 10; NIL operation; PAIR } \+ \ }; \+ \ DROP; DROP; PUSH unit Unit \+ \"+ ~: "0x05020000005a0346051f020000000c0743035b00010743036a0005061d02000\+ \000290500045b000000023a700501045b000000023a730502020000000e032007\+ \43035b000a053d036d03420000000740657a2040707a032003200743036c030b"+ , "IMPLICIT_ACCOUNT @i; DROP; PUSH unit Unit"+ ~: "0x050200000010041e00000002406903200743036c030b"+ ]++ parseUnpackOnlySpec @'TKey @('Tc 'CKeyHash) "VarAnn instrs public-key-related"+ [ "HASH_KEY @h"+ ~: "0x050200000008042b000000024068"+ ]++ parseUnpackOnlySpec @('TPair 'TSignature 'TKey) @('Tc 'CBool) "VarAnn instrs public-key-related"+ [ "DIP{ PUSH bytes 0x }; DUP; DIP {CAR}; CDR; CHECK_SIGNATURE @c"+ ~: "0x050200000025051f0200000009074303690a000000000321051f0200000002\+ \031603170418000000024063"+ ]+ readableUnpackTest :: Spec readableUnpackTest = do