Unpack.hs

{- | Module, carrying logic of @UNPACK@ instruction.

This is nearly symmetric to adjacent Pack.hs module.

When implementing this the following sources were used:

* https://pastebin.com/8gfXaRvp

* https://gitlab.com/tezos/tezos/blob/master/src/proto_alpha/lib_protocol/script_ir_translator.ml#L2501

* https://github.com/tezbridge/tezbridge-crypto/blob/master/src/PsddFKi3/codec.js#L513

-}
module Michelson.Interpret.Unpack
  ( UnpackError (..)
  , unpackValue
  , unpackValue'
  ) where

import Prelude hiding (EQ, Ordering(..), get)

import Control.Monad.Except (throwError)
import Data.Binary (Get)
import qualified Data.Binary.Get as Get
import qualified Data.Bits as Bits
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import Data.Constraint (Dict(..))
import Data.Default (def)
import qualified Data.Kind as Kind
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Singletons (SingI(..))
import Data.Typeable ((:~:)(..))
import Fmt (Buildable, build, fmt, hexF, pretty, (+|), (+||), (|+), (||+))
import Text.Hex (encodeHex)

import Michelson.Text
import Michelson.TypeCheck
  (HST(..), SomeHST(..), SomeInstr(..), SomeInstrOut(..), TCError(..), TypeCheckEnv(..))
import Michelson.TypeCheck.Helpers (ensureDistinctAsc, eqHST1)
import Michelson.TypeCheck.Instr (typeCheckList)
import Michelson.Typed (RemFail(..), Sing(..), starNotes)
import qualified Michelson.Typed as T
import Michelson.Typed.EntryPoints
import Michelson.Typed.Scope
  (BigMapPresence(..), ContractPresence(..), OpPresence(..), UnpackedValScope, bigMapAbsense,
  checkBigMapPresence, checkContractTypePresence, checkOpPresence, contractTypeAbsense, opAbsense)
import Michelson.Untyped
import Tezos.Address (Address(..), ContractHash(..), parseAddress)
import Tezos.Core
import Tezos.Crypto
  (KeyHash(..), KeyHashTag(..), PublicKey(..), keyHashLengthBytes, mkSignature, parseKeyHash,
  parsePublicKey, parseSignature, signatureLengthBytes)
import qualified Tezos.Crypto.Ed25519 as Ed25519
import qualified Tezos.Crypto.P256 as P256
import qualified Tezos.Crypto.Secp256k1 as Secp256k1

----------------------------------------------------------------------------
-- Helpers
----------------------------------------------------------------------------

-- | Any decoding error.
newtype UnpackError = UnpackError { unUnpackError :: Text }
  deriving (Show, Eq)

instance Buildable UnpackError where
  build (UnpackError msg) = build msg

instance Exception UnpackError where
  displayException = pretty

-- | Alias for label attaching.
(?) :: Get a -> String -> Get a
(?) = flip Get.label
infix 0 ?

-- | Get a bytestring of the given length leaving no references to the
-- original data in serialized form.
getByteStringCopy :: Int -> Get ByteString
getByteStringCopy = fmap BS.copy . Get.getByteString

-- | Read a byte and match it against given value.
expectTag :: String -> Word8 -> Get ()
expectTag desc t =
  Get.label desc $ do
    t' <- Get.getWord8
    unless (t == t') $
      fail . fmt $ "Unexpected tag value (expected 0x" +| hexF t |+
                   ", but got 0x" +| hexF t' |+ ")"

-- | Fail with "unknown tag" error.
unknownTag :: String -> Word8 -> Get a
unknownTag desc tag =
  fail . fmt $ "Unknown " <> build desc <> " tag: 0x" <> hexF tag

-- | Read a byte describing the primitive going further and match it against
-- expected tag in the given conditions.
--
-- Aside of context description, you have to specify number of arguments which
-- given instruction accepts when written in Michelson. For instance, @PUSH@
-- accepts two arguments - type and value.
expectDescTag :: HasCallStack => String -> Word16 -> Get ()
expectDescTag desc argsNum =
  Get.label desc $ do
    tag <- Get.getWord8
    unless (tag == expected) $
      fail . fmt $ "Unexpected preliminary tag: 0x" <> hexF tag
  where
    expected = case argsNum of
      0 -> 0x03
      1 -> 0x05
      2 -> 0x07
      3 -> 0x08
      _ -> error "Bad arguments num"
      -- Intermediate values of tag are also used and designate that annotations
      -- are also attached to the packed data. But they are never produced by
      -- @PACK@, neither @UNPACK@ seem to expect them, so for now we pretend
      -- that annotations do not exist.

ensureEnd :: Get ()
ensureEnd =
  unlessM Get.isEmpty $ do
    remainder <- Get.getRemainingLazyByteString
    fail $ "Expected end of entry, unconsumed bytes \
           \(" +| length remainder |+ "): "
           +|| encodeHex (LBS.toStrict remainder) ||+ ""

-- | Like 'many', but doesn't backtrack if next entry failed to parse
-- yet there are some bytes to consume ahead.
--
-- This function exists primarily for better error messages.
manyForced :: Get a -> Get [a]
manyForced decode = do
  emp <- Get.isEmpty
  if emp
    then return []
    else (:) <$> decode <*> manyForced decode

-- | Describes how 'decodeWithTag' should decode tag-dependent data.
-- We expect bytes of such structure: 'tdTag' followed by a bytestring
-- of length 'tdLength'. This bytestring will be passed to 'tdConstructor'.
data TaggedDecoder a where
  TaggedDecoder :: Buildable err =>
    { tdTag :: !Word8
    , tdLength :: !Int
    , tdConstructor :: !(ByteString -> Either err a)
    } -> TaggedDecoder a

-- Common decoder for the case when packed data starts with a tag (1
-- byte) that specifies how to decode remaining data.
-- Usually in this case data is packed as bytes,
-- so the 'Int' argument passed here is the length of that bytestring.
-- See 'decodeAsBytes'.
-- Note that it differs from 'tdLength' because 'Int' argument
-- includes tag byte while 'tdLength' does not.
decodeWithTag :: String -> [TaggedDecoder a] -> Int -> Get a
decodeWithTag what decoders len =
  decodeWithTagSimple what . map (\td -> (tdTag td, tdToGet td)) $ decoders
  where
    tdToGet :: TaggedDecoder a -> Get a
    tdToGet TaggedDecoder {..}
      -- 1 byte here is used for tag.
      | tdLength + 1 /= len =
        fail $ "Wrong length of " +| what |+ ": " +| len |+ ""
      | otherwise = do
          bs <- getByteStringCopy tdLength
          case tdConstructor bs of
            Left err -> fail $ "Wrong " +| what |+ ": " +| err |+ ""
            Right res -> pure res

decodeWithTagSimple :: String -> [(Word8, Get a)] -> Get a
decodeWithTagSimple what decoders = Get.label what $ do
  tag <- Get.label (what <> " tag") Get.getWord8
  -- Number of decoders is usually small, so linear runtime lookup should be ok.
  case List.find ((tag ==) . fst) decoders of
    Nothing -> unknownTag what tag
    Just (_, decoder) -> decoder

----------------------------------------------------------------------------
-- Michelson serialisation
----------------------------------------------------------------------------

{- Implementation notes:

* We need to know which exact type we unpack to.
For instance, serialized signatures are indistinguishable from
plain serialized bytes, so if we want to return "Value" (typed or untyped),
we need to know currently expected type. The reference implementation does
the same.

* It occured to be easier to decode to typed values and untyped instructions.
When decoding lambda, we type check given instruction, and when decoding
@PUSH@ call we untype decoded value.
One may say that this gives unreasonable performance overhead, but with the
current definition of "Value" types (typed and untyped) we cannot avoid it
anyway, because when deserializing bytearray-like data (keys, signatures, ...),
we have to convert raw bytes to human-readable 'Text' and later parse them
to bytes back at type check stage.
We console ourselves that lambdas are rarely packed.

-}

-- | Deserialize bytes into the given value.
-- Suitable for @UNPACK@ operation only.
unpackValue
  :: (UnpackedValScope t)
  => LByteString -> Either UnpackError (T.Value t)
unpackValue bs =
  case Get.runGetOrFail unpackDecoder bs of
    Left (_remainder, _offset, err) -> Left . UnpackError $ toText err
    Right (_remainder, _offset, res) -> Right res

-- | Like 'unpackValue', for strict byte array.
unpackValue'
  :: (UnpackedValScope t)
  => ByteString -> Either UnpackError (T.Value t)
unpackValue' = unpackValue . LBS.fromStrict

-- | Overall value decoder we use in @UNPACK@.
unpackDecoder
  :: (UnpackedValScope t)
  => Get (T.Value t)
unpackDecoder =
  expectTag "Packed data start" 0x05 *> decodeValue <* ensureEnd

decodeValue
  :: forall t.
     (HasCallStack, UnpackedValScope t)
  => Get (T.Value t)
decodeValue = Get.label "Value" $
  case sing @t of
    STc _ ->
      T.VC <$> decodeCValue
    STKey -> T.VKey <$> asum
      [ decodeAsBytes $ decodeWithTag "key"
        [ TaggedDecoder 0x00 Ed25519.publicKeyLengthBytes
            (fmap PublicKeyEd25519 . Ed25519.mkPublicKey)
        , TaggedDecoder 0x01 Secp256k1.publicKeyLengthBytes
            (fmap PublicKeySecp256k1 . Secp256k1.mkPublicKey)
        , TaggedDecoder 0x02 P256.publicKeyLengthBytes
            (fmap PublicKeyP256 . P256.mkPublicKey)
        ]
      , decodeAsString parsePublicKey
      ]
    STUnit -> do
      expectDescTag "Unit" 0
      expectTag "Unit" 0x0B
      return T.VUnit
    STSignature -> T.VSignature <$> asum
      [ decodeAsBytes $ \_len -> do -- TODO [TM-329]: ignoring length is bad
          bs <- getByteStringCopy signatureLengthBytes
          case mkSignature bs of
            -- We expect it to succeed because the length is
            -- exactly 'signatureLengthBytes'.
            Nothing -> error "mkSignature failed"
            Just s -> pure s
      , decodeAsString parseSignature
      ]
    STChainId -> asum
      [ decodeAsBytes $ \_len -> do -- TODO [TM-329]: ignoring length is bad
          bs <- getByteStringCopy chainIdLength
          case mkChainId bs of
            Nothing -> fail $ "Wrong chain id format"
            Just s -> pure (T.VChainId s)
      , T.VChainId <$> decodeAsString parseChainId
      ]
    STOption _ -> do
      Get.getByteString 2 >>= \case
        "\x03\x06" -> pure (T.VOption Nothing)
        "\x05\x09" -> T.VOption . Just <$> decodeValue
        other -> fail $ "Unknown option tag: " <> show other
    STList _ -> do
      decodeAsList $ T.VList <$> manyForced decodeValue
    STSet _ -> do
      decodeAsList $ do
        vals <- manyForced decodeCValue
        either (fail . toString) pure $
          T.VSet . Set.fromDistinctAscList <$> ensureDistinctAsc id vals
    STPair lt _ ->
      case (checkOpPresence lt, checkBigMapPresence lt, checkContractTypePresence lt) of
        (OpAbsent, BigMapAbsent, ContractAbsent) -> do
          expectDescTag "Pair" 2
          expectTag "Pair" 0x07
          T.VPair ... (,) <$> decodeValue <*> decodeValue
    STOr lt _ ->
      case (checkOpPresence lt, checkBigMapPresence lt, checkContractTypePresence lt) of
        (OpAbsent, BigMapAbsent, ContractAbsent) -> do
          expectDescTag "Or" 1
          Get.getWord8 >>= \case
            0x05 -> T.VOr . Left <$> decodeValue
            0x08 -> T.VOr . Right <$> decodeValue
            other -> unknownTag "or constructor" other
    STLambda _ _ -> do
      uinstr <- decodeOps
      T.VLam <$> decodeTypeCheckLam uinstr
    STMap _ _ -> do
      T.VMap <$> decodeMap

decodeCValue :: forall ct. SingI ct => Get (T.CValue ct)
decodeCValue = case sing @ct of
  SCInt -> do
    expectTag "Int" 0x00
    T.CvInt <$> decodeInt
  SCNat -> do
    expectTag "Nat" 0x00
    T.CvNat <$> decodeInt
  SCString -> do
    expectTag "String" 0x01
    T.CvString <$> decodeString
  SCBytes -> do
    expectTag "Bytes" 0x0a
    T.CvBytes <$> decodeBytes
  SCMutez -> do
    expectTag "Mutez" 0x00
    mmutez <- mkMutez <$> decodeInt
    maybe (fail "Negative mutez") (pure . T.CvMutez) mmutez
  SCBool -> do
    expectDescTag "Bool" 0
    Get.getWord8 >>= \case
      0x0A -> pure (T.CvBool True)
      0x03 -> pure (T.CvBool False)
      other -> unknownTag "bool" other
  SCKeyHash -> T.CvKeyHash <$> asum
    [ decodeAsBytes $ decodeWithTag "key_hash" keyHashDecoders
    , decodeAsString parseKeyHash
    ]
  SCTimestamp -> do
    expectTag "Timestamp" 0x00
    T.CvTimestamp . timestampFromSeconds <$> decodeInt
  SCAddress ->
    T.CvAddress <$> decodeEpAddress

keyHashDecoders :: [TaggedDecoder KeyHash]
keyHashDecoders =
  [ TaggedDecoder @Void 0x00 keyHashLengthBytes (pure . KeyHash KeyHashEd25519)
  , TaggedDecoder @Void 0x01 keyHashLengthBytes (pure . KeyHash KeyHashSecp256k1)
  , TaggedDecoder @Void 0x02 keyHashLengthBytes (pure . KeyHash KeyHashP256)
  ]

-- | Read length of something (list, string, ...).
decodeLength :: Get Int
decodeLength = Get.label "Length" $ do
  len <- Get.getWord32be
  -- @martoon: I'm not sure whether returning 'Int' is valid here.
  -- Strictly speaking, it may be 'Word32', but there seems to be no easy way
  -- to check the reference implementation on that.
  -- One more reason to go with just 'Int' for now is that we need to be able to
  -- deserialize byte arrays, and 'BS.ByteString' keeps length of type 'Int'
  -- inside.
  let len' = fromIntegral @_ @Int len
  unless (fromIntegral len' == len && len' >= 0) $
    fail "Length overflow"
  return len'

decodeAsListRaw :: Get a -> Get a
decodeAsListRaw getElems = do
  l <- decodeLength ? "List length"
  Get.isolate l (getElems ? "List content")

-- | Given decoder for list content, get a whole list decoder.
decodeAsList :: Get a -> Get a
decodeAsList getElems = do
  expectTag "List" 0x02
  decodeAsListRaw getElems

decodeString :: Get MText
decodeString = do
  l <- decodeLength ? "String length"
  ss <- replicateM l Get.getWord8 ? "String content"
  ss' <- decodeUtf8' (BS.pack ss)
    & either (fail . show) pure
    ? "String UTF-8 decoding"
  mkMText ss'
    & either (fail . show) pure
    ? "Michelson string validity analysis"

decodeAsString :: Buildable e => (Text -> Either e a) -> Get a
decodeAsString parser = do
  expectTag "String" 0x01
  str <- decodeString
  either (fail . pretty) pure $ parser $ unMText str

decodeAsBytesRaw :: (Int -> Get a) -> Get a
decodeAsBytesRaw decode = do
  l <- decodeLength ? "Byte array length"
  decode l ? "Byte array content"

decodeAsBytes :: (Int -> Get a) -> Get a
decodeAsBytes decode = do
  expectTag "Bytes" 0x0A
  decodeAsBytesRaw decode

decodeBytes :: Get ByteString
decodeBytes = decodeAsBytesRaw getByteStringCopy

decodeMap
  :: (SingI k, UnpackedValScope v)
  => Get $ Map (T.CValue k) (T.Value v)
decodeMap = Get.label "Map" $
  decodeAsList $ do
    es <- manyForced $ do
      expectDescTag "Elt" 2
      expectTag "Elt" 0x04
      (,) <$> decodeCValue <*> decodeValue
    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
        -- TODO [TM-329]: ignoring length is bad
        addr <- getByteStringCopy 20
        expectTag "Contract address suffix" 0x00
        return $ ContractAddress (ContractHash addr)
      )
    ]
  , decodeAsString parseAddress
  ]

decodeEpAddress :: Get EpAddress
decodeEpAddress = do
  eaAddress <- decodeAddress
  refAnn <- decodeAnn
  eaEntryPoint <- epNameFromRefAnn refAnn
                & either (fail . pretty) pure
  return EpAddress{..}

-- | Read a numeric value.
decodeInt :: Num i => Get i
decodeInt = fromIntegral @Integer <$> loop 0 0 ? "Number"
  where
    loop !offset !acc = do
      byte <- Get.getWord8

      let hasCont = Bits.testBit byte 7
      let doCont shft = if hasCont then loop (shft + offset) else pure
      let addAndCont shft bytePayload =
            doCont shft $ acc + Bits.shiftL (fromIntegral bytePayload) offset

      let payload = Bits.clearBit byte 7
      if offset > 0
        then addAndCont 7 payload
        else do
          let sign = if Bits.testBit byte 6 then -1 else 1
          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.
     (Typeable inp, SingI inp, SingI out, Typeable out, MonadFail m)
  => [ExpandedOp]
  -> m (RemFail T.Instr '[inp] '[out])
decodeTypeCheckLam uinstr =
  either tcErrToFail pure . evaluatingState tcInitEnv . runExceptT $ do
    let inp = (sing @inp, starNotes, noAnn) ::& SNil
    _ :/ instr' <- typeCheckList uinstr inp
    case instr' of
      instr ::: out' ->
        case eqHST1 @out out' of
          Right Refl ->
            pure $ RfNormal instr
          Left err ->
                -- dummy types, we have no full information to build untyped
                -- 'T' anyway
            let tinp = Type TUnit noAnn
                tout = Type TUnit noAnn
            in throwError $
              TCFailedOnInstr (LAMBDA noAnn tinp tout uinstr) (SomeHST inp)
              "Unexpected lambda output type" def (Just err)
      AnyOutInstr instr ->
        return $ RfAlwaysFails instr
  where
    tcErrToFail err = fail $ "Type check failed: " +| err |+ ""
    tcInitEnv =
      -- In Tezos @UNPACK@ instruction does not depend on environment.
      --
      -- We initialize each of the fields as 'error' (rather than just defining
      -- the whole datatype as 'error') to make source of error more obvious
      -- if access to one of these fields is performed after all.
      TypeCheckEnv
      { tcExtFrames = error "runInstrImpl(UNPACK): tcExtFrames touched"
        --- ^ This is safe because @UNPACK@ never produces Ext instructions
      , tcContractParam = error "runInstrImpl(UNPACK): tcContractParam touched"
        --- ^ Used only in @SELF@ interpretation,
        ---   but there is no way for @SELF@ to appear in packed data
      , tcContracts = error "runInstrImpl(UNPACK): tcContracts touched"
        --- ^ Used only in typechecking of @contract@ values,
        ---   but it's not possible to unpack to ones.
      }

decodeInstr :: Get ExpandedInstr
decodeInstr = Get.label "Instruction" $ do
  pretag <- Get.getWord8 ? "Pre instr tag"
  tag <- Get.getWord8 ? "Instr tag"
  case (pretag, tag) of
    (0x03, 0x20) -> pure $ DROP
    (0x05, 0x20) -> DROPN <$> (expectTag "'DROP n' parameter" 0x00 *> decodeInt)
    (0x03, 0x21) -> pure $ DUP noAnn
    (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
    (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
                         <*> decodeType
    (0x05, 0x44) -> RIGHT <$> decodeAnn <*> decodeAnn <*> decodeAnn <*> decodeAnn
                          <*> decodeType
    (0x07, 0x2E) -> IF_LEFT <$> decodeOps  <*> decodeOps
    (0x05, 0x3D) -> NIL <$> decodeAnn <*> decodeAnn <*> decodeType
    (0x03, 0x1B) -> CONS <$> decodeAnn
    (0x07, 0x2D) -> IF_CONS <$> decodeOps  <*> decodeOps
    (0x03, 0x45) -> SIZE <$> decodeAnn
    (0x05, 0x24) -> EMPTY_SET <$> decodeAnn <*> decodeAnn <*> decodeComparable
    (0x07, 0x23) -> EMPTY_MAP <$> decodeAnn <*> decodeAnn <*> decodeComparable
                              <*> decodeType
    (0x07, 0x72) -> EMPTY_BIG_MAP <$> decodeAnn <*> decodeAnn <*> decodeComparable
                                  <*> decodeType
    (0x05, 0x38) -> MAP <$> decodeAnn <*> decodeOps
    (0x05, 0x52) -> ITER <$> decodeOps
    (0x03, 0x39) -> MEM <$> decodeAnn
    (0x03, 0x29) -> GET <$> decodeAnn
    (0x03, 0x50) -> UPDATE <$> decodeAnn
    (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
    (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
    (other1, other2) -> fail $ "Unknown instruction tag: 0x" +|
                        hexF other1 |+ hexF other2 |+ ""

decodeOp :: Get ExpandedOp
decodeOp = Get.label "Op" $ do
  tag <- Get.lookAhead Get.getWord8
  if tag == 0x02
    then SeqEx <$> decodeOps ? "Ops seq"
    else PrimEx <$> decodeInstr ? "One op"

decodeOps :: Get [ExpandedOp]
decodeOps = decodeAsList $ manyForced decodeOp

decodeComparable :: Get Comparable
decodeComparable = Get.label "Comparable primitive type" $
  Comparable <$> decodeCT <*> decodeAnn

decodeCT :: Get CT
decodeCT = Get.label "CT" $ 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 |+ ""

decodeT :: Get T
decodeT = Get.label "T" $
  doDecode <|> (Tc <$> decodeCT)
  where
    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
        (other1, other2) -> fail $ "Unknown primitive tag: 0x" +|
                            hexF other1 |+ hexF other2 |+ ""

decodeType :: Get Type
decodeType = Type <$> decodeT <*> decodeAnn ? "Type"