diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -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 ===== diff --git a/morley.cabal b/morley.cabal --- a/morley.cabal +++ b/morley.cabal @@ -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 diff --git a/src/Michelson/Interpret/Pack.hs b/src/Michelson/Interpret/Pack.hs --- a/src/Michelson/Interpret/Pack.hs +++ b/src/Michelson/Interpret/Pack.hs @@ -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 diff --git a/src/Michelson/Interpret/Unpack.hs b/src/Michelson/Interpret/Unpack.hs --- a/src/Michelson/Interpret/Unpack.hs +++ b/src/Michelson/Interpret/Unpack.hs @@ -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 diff --git a/src/Michelson/OpSize.hs b/src/Michelson/OpSize.hs --- a/src/Michelson/OpSize.hs +++ b/src/Michelson/OpSize.hs @@ -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 diff --git a/src/Michelson/Parser/Annotations.hs b/src/Michelson/Parser/Annotations.hs --- a/src/Michelson/Parser/Annotations.hs +++ b/src/Michelson/Parser/Annotations.hs @@ -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 diff --git a/src/Michelson/Parser/Instr.hs b/src/Michelson/Parser/Instr.hs --- a/src/Michelson/Parser/Instr.hs +++ b/src/Michelson/Parser/Instr.hs @@ -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 diff --git a/src/Michelson/TypeCheck/Instr.hs b/src/Michelson/TypeCheck/Instr.hs --- a/src/Michelson/TypeCheck/Instr.hs +++ b/src/Michelson/TypeCheck/Instr.hs @@ -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") diff --git a/src/Michelson/Typed/Convert.hs b/src/Michelson/Typed/Convert.hs --- a/src/Michelson/Typed/Convert.hs +++ b/src/Michelson/Typed/Convert.hs @@ -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 diff --git a/src/Michelson/Untyped/Instr.hs b/src/Michelson/Untyped/Instr.hs --- a/src/Michelson/Untyped/Instr.hs +++ b/src/Michelson/Untyped/Instr.hs @@ -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 diff --git a/src/Util/Test/Arbitrary.hs b/src/Util/Test/Arbitrary.hs --- a/src/Util/Test/Arbitrary.hs +++ b/src/Util/Test/Arbitrary.hs @@ -132,7 +132,7 @@ , CAST <$> arbitrary <*> arbitrary , RENAME <$> arbitrary , PACK <$> arbitrary - , UNPACK <$> arbitrary <*> arbitrary + , UNPACK <$> arbitrary <*> arbitrary <*> arbitrary , CONCAT <$> arbitrary , SLICE <$> arbitrary , ISNAT <$> arbitrary diff --git a/test/Test/Interpreter.hs b/test/Test/Interpreter.hs --- a/test/Test/Interpreter.hs +++ b/test/Test/Interpreter.hs @@ -344,7 +344,6 @@ dummyContractEnv () "" ] - -- TODO [TM-280] Move to separate module test_Entry_points_lookup :: IO [TestTree] test_Entry_points_lookup = diff --git a/test/Test/Serialization/Michelson.hs b/test/Test/Serialization/Michelson.hs --- a/test/Test/Serialization/Michelson.hs +++ b/test/Test/Serialization/Michelson.hs @@ -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