diff --git a/CHANGES.md b/CHANGES.md
--- a/CHANGES.md
+++ b/CHANGES.md
@@ -2,6 +2,91 @@
 ==========
 <!-- Append new entries here -->
 
+1.15.0
+======
+* [!878](https://gitlab.com/morley-framework/morley/-/merge_requests/878)
+  + Fixed behavior of `packValue` to match the `tezos-client hash data`
+    behavior.
+  + Pair conversion in `instance ToExpression Untyped.Value` always produces
+    `ExpressionPrim` instead `ExpressionSeq`. Optimization of right-combed pairs
+    moved to `Michelson.Typed.Convert` and depends on `UntypingOptions`.
+* [!880](https://gitlab.com/morley-framework/morley/-/merge_requests/880)
+  + Fixed loss of type annotations in serialization of right-combed pairs.
+* [!795](https://gitlab.com/morley-framework/morley/-/merge_requests/795)
+  + Changed typecheck exception messages.
+  +  Changed Buildable instances for several datatypes to be based on
+     RenderDoc instances.
+  + Changed the regexp in scripts/regenerate-gold-files-for-verbose-typechecking.sh
+    so it does not ommit extra space in .gold files on MacOS.
+* [!863](https://gitlab.com/morley-framework/morley/-/merge_requests/863)
+  + Removed conversion from variable anotations to field anontations in
+    `PAIRN` instruction.
+* [!856](https://gitlab.com/morley-framework/morley/-/merge_requests/856)
+  + Removed `Typeable` constrains from singletons generated by `T`.
+  + Added the `Util.Sing` module with functions that allow equality comparison
+    using `SDecide`.
+* [!858](https://gitlab.com/morley-framework/morley/-/merge_requests/858)
+  + Added `SomeStorage` type.
+  + Modified `runContract` to return `SomeStorage`.
+* [!833](https://gitlab.com/morley-framework/morley/-/merge_requests/833)
+  + Fixed `ContainsBigMap` and `ContainsNestedBigMaps` instances for `TContract`.
+  + Added `Data` instance to `BigMap` and `BigMapId`.
+  + Added `requireEqT`, `castM` and `gcastM` to `Util.Typeable`.
+* [!859](https://gitlab.com/morley-framework/morley/-/merge_requests/859)
+  + Added `BigMapId` type.
+  + Added ID to `VBigMap` and `BigMap`.
+  + Updated interpreter to assign a unique big_map ID to each big_map, and
+    keep track of how many big_maps have been created with a `BigMapCounter`.
+  + Deleted `dfsValue`.
+  + Renamed `dfsModifyValue` and `dfsFoldValue` to `dfsMapValue` and `dfsFoldMapValue`.
+  + Added `dfsTraverseValue` and `dfsFoldMapValueM`.
+* [!840](https://gitlab.com/morley-framework/morley/-/merge_requests/840)
+  + Changed behaviour of deserializer: it fails if the expression contains
+    more annotations than expected instead of ignoring them.
+  + Changed behaviour of serializer: it uses list notation for all pair
+    values, not just for right-combed ones.
+* [!816](https://gitlab.com/morley-framework/morley/-/merge_requests/816)
+  + Removed the `SingI` and `KnownPeano` constraints by introducting the
+    `PeanoNatural` data type.
+  + The similar updates for `SingT`. Removed the `SingI` constraints in the
+    constructors of `SingT`
+* [!855](https://gitlab.com/morley-framework/morley/-/merge_requests/855)
+  + Fix custom error arguments comparison in nettest by converting them
+    to `Value t` before checking for equality.
+* [!830](https://gitlab.com/morley-framework/morley/-/merge_requests/830)
+  + Added the contract's address to some of the `ExecutorError'`
+    constructors: `EEIllTypedParameter` and `EEUnexpectedParameterType`.
+* [!820](https://gitlab.com/morley-framework/morley/-/merge_requests/820)
+  + Moved functions for contract importing (like `importContract`) from cleveland.
+  + Added functions for values importing (`readValue`, `importValue` and others).
+* [!832](https://gitlab.com/morley-framework/morley/-/merge_requests/832)
+  + Add tickets feature.
+  + Add dupable restriction to `DUP`-like instructions.
+* [!838](https://gitlab.com/morley-framework/morley/-/merge_requests/838)
+  + All unsafe functions and data constructors now contain "unsafe" word
+    at prefix position. E.g `UnsafeUParam`, `unsafeParseKeyHash`.
+* [!828](https://gitlab.com/morley-framework/morley/-/merge_requests/828)
+  + Fix bug in serialization of instructions with variable annotations:
+    `EMPTY_SET`, `EMPTY_MAP`, `PUSH`, `LAMBDA`, `CAST`, `CONTRACT`.
+* [!770](https://gitlab.com/morley-framework/morley/-/merge_requests/770)
+  + Added `Fn` meta-instruction to support Morley's typed stack function in
+    typed form.
+  + Added `STACKTYPE` as a typed `ExtInstr`.
+* [!822](https://gitlab.com/morley-framework/morley/-/merge_requests/822)
+  + Add new `edo` instruction: `UNPAIR`.
+  + Rename `UNPAIR` macro to `UNPAPAIR`.
+  + Expand `UNPAPAIR` macros to `UNPAIR` instructions.
+  + The `Seq` constructor can now be used as a right-associative operator.
+  + Optimize `DUP; CAR; DIP { CDR }` to `UNPAIR`
+  + Optimize `DUP; CDR; DIP { CAR }` to `UNPAIR; SWAP`
+* [!825](https://gitlab.com/morley-framework/morley/-/merge_requests/825)
+  + Fix bug in morley executable's `repl` command: consume the entire input
+    when parsing an instruction.
+  + Fix bug in the handling of special annotations for `CAR`/`CDR`.
+  + Fix bug in parsing of `PAIR` instructions with exactly 1 field ann.
+  + Preserve `CAR`/`CDR`'s original annotations when converting them back to
+    michelson/binary/json.
+
 1.14.0
 ======
 * [!799](https://gitlab.com/morley-framework/morley/-/merge_requests/799)
diff --git a/app/Main.hs b/app/Main.hs
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -6,14 +6,13 @@
   ( main
   ) where
 
-import Data.Default (def)
 import qualified Data.Text.Lazy.IO.Utf8 as Utf8 (writeFile)
 import Data.Version (showVersion)
 import Fmt (pretty)
 import Named (arg, argF, (!))
 import Options.Applicative
-  (command, execParser, footerDoc, fullDesc, header, help, helper, info, infoOption, long,
-  progDesc, short, subparser, switch)
+  (execParser, footerDoc, fullDesc, header, help, helper, info, infoOption, long, progDesc, short,
+  subparser, switch)
 import qualified Options.Applicative as Opt
 import Options.Applicative.Help.Pretty (Doc, linebreak)
 import Paths_morley (version)
@@ -23,16 +22,17 @@
 import Michelson.Printer (printSomeContract, printUntypedContract)
 import Michelson.Runtime (TxData(..), originateContract, prepareContract, runContract, transfer)
 import Michelson.Runtime.GState (genesisAddress)
-import Michelson.TypeCheck (tcVerbose, typeCheckContract)
-import Michelson.TypeCheck.Types (SomeContract(..), mapSomeContract)
-import Michelson.Typed (Contract(..))
+import Michelson.TypeCheck (tcVerbose, typeCheckContract, typeCheckingWith)
+import qualified Michelson.TypeCheck as TypeCheck
+import Michelson.TypeCheck.Types (mapSomeContract)
+import Michelson.Typed (Contract(..), SomeContract(..))
 import qualified Michelson.Untyped as U
 import Morley.CLI
 import REPL
 import Tezos.Address (Address)
 import Tezos.Core (Mutez, Timestamp(..), unsafeMkMutez)
 import Tezos.Crypto
-import Util.CLI (outputOption)
+import Util.CLI (mkCommandParser, outputOption)
 import Util.Main (wrapMain)
 import Util.Named
 
@@ -62,12 +62,13 @@
 
 data TypeCheckOptions = TypeCheckOptions
   { tcoContractFile :: Maybe FilePath
-  , tcoVerbose      :: Bool
+  , tcoTcOptions    :: TypeCheck.TypeCheckOptions
   }
 
 data RunOptions = RunOptions
   { roContractFile :: Maybe FilePath
   , roDBPath :: FilePath
+  , roTcOptions :: TypeCheck.TypeCheckOptions
   , roStorageValue :: U.Value
   , roTxData :: TxData
   , roVerbose :: Bool
@@ -81,6 +82,7 @@
 data OriginateOptions = OriginateOptions
   { ooContractFile :: Maybe FilePath
   , ooDBPath :: FilePath
+  , ooTcOptions :: TypeCheck.TypeCheckOptions
   , ooOriginator :: Address
   , ooDelegate :: Maybe KeyHash
   , ooStorageValue :: U.Value
@@ -90,6 +92,7 @@
 
 data TransferOptions = TransferOptions
   { toDBPath :: FilePath
+  , toTcOptions :: TypeCheck.TypeCheckOptions
   , toDestination :: Address
   , toTxData :: TxData
   , toNow :: Maybe Timestamp
@@ -110,11 +113,6 @@
   analyzeSubCmd <>
   replSubCmd
   where
-    mkCommandParser commandName parser desc =
-      command commandName $
-      info (helper <*> parser) $
-      progDesc desc
-
     typecheckSubCmd =
       mkCommandParser "typecheck"
         (TypeCheck <$> typeCheckOptions) $
@@ -175,10 +173,19 @@
       long "dry-run" <>
       help "Do not write updated DB to DB file"
 
+    typeCheckOptionsOption :: Opt.Parser TypeCheck.TypeCheckOptions
+    typeCheckOptionsOption = do
+      tcVerbose <- verboseFlag
+      tcStrict <- fmap not . switch $
+        long "typecheck-lax" <>
+        help "Whether actions permitted in `tezos-client run` but forbidden in \
+             \e.g. `tezos-client originate` should be allowed here"
+      return TypeCheck.TypeCheckOptions{..}
+
     typeCheckOptions :: Opt.Parser TypeCheckOptions
     typeCheckOptions = TypeCheckOptions
       <$> optional contractFileOption
-      <*> verboseFlag
+      <*> typeCheckOptionsOption
 
     defaultBalance :: Mutez
     defaultBalance = unsafeMkMutez 4000000
@@ -197,6 +204,7 @@
       RunOptions
         <$> optional contractFileOption
         <*> dbPathOption
+        <*> typeCheckOptionsOption
         <*> valueOption Nothing (#name .! "storage")
             (#help .! "Initial storage of a running contract")
         <*> txDataOption
@@ -213,6 +221,7 @@
       OriginateOptions
         <$> optional contractFileOption
         <*> dbPathOption
+        <*> typeCheckOptionsOption
         <*> addressOption (Just genesisAddress)
             (#name .! "originator") (#help .! "Contract's originator")
         <*> optional
@@ -228,6 +237,7 @@
     transferOptions :: Opt.Parser TransferOptions
     transferOptions = do
       toDBPath <- dbPathOption
+      toTcOptions <- typeCheckOptionsOption
       toDestination <-
         addressOption Nothing
         (#name .! "to") (#help .! "Destination address")
@@ -239,6 +249,13 @@
       toDryRun <- dryRunFlag
       pure TransferOptions {..}
 
+-- | Most permitting options, when we don't care much about typechecking.
+laxTcOptions :: TypeCheck.TypeCheckOptions
+laxTcOptions = TypeCheck.TypeCheckOptions
+  { TypeCheck.tcVerbose = False
+  , TypeCheck.tcStrict = False
+  }
+
 ----------------------------------------------------------------------------
 -- Actual main
 ----------------------------------------------------------------------------
@@ -270,24 +287,29 @@
       Optimize OptimizeOptions{..} -> do
         untypedContract <- prepareContract optoContractFile
         checkedContract <-
-          either throwM pure $ typeCheckContract untypedContract def
+          either throwM pure . typeCheckingWith laxTcOptions $
+            typeCheckContract untypedContract
         let optimizedContract = mapSomeContract optimize checkedContract
         let write = maybe putStrLn Utf8.writeFile optoOutput
         write $ printSomeContract optoSingleLine optimizedContract
       Analyze AnalyzeOptions{..} -> do
         untypedContract <- prepareContract aoContractFile
         SomeContract contract <-
-          either throwM pure $ typeCheckContract untypedContract def
+          either throwM pure . typeCheckingWith laxTcOptions $
+            typeCheckContract untypedContract
         putTextLn $ pretty $ analyze (cCode contract)
       TypeCheck TypeCheckOptions{..} -> do
         morleyContract <- prepareContract tcoContractFile
-        contract <- either throwM pure
-          $ typeCheckContract morleyContract def{ tcVerbose = tcoVerbose }
-        when tcoVerbose (putStrLn $ printSomeContract False contract)
+        -- At the moment of writing, 'tcStrict' option does not change anything
+        -- because it affects only values parsing; but this may change
+        contract <- either throwM pure . typeCheckingWith tcoTcOptions
+          $ typeCheckContract morleyContract
+        when (TypeCheck.tcVerbose tcoTcOptions) $
+          putStrLn $ printSomeContract False contract
         putTextLn "Contract is well-typed"
       Run RunOptions {..} -> do
         michelsonContract <- prepareContract roContractFile
-        void $ runContract roNow roLevel roMaxSteps roInitBalance roDBPath roStorageValue michelsonContract roTxData
+        void $ runContract roNow roLevel roMaxSteps roInitBalance roDBPath roTcOptions roStorageValue michelsonContract roTxData
           ! #verbose roVerbose
           ! #dryRun (not roWrite)
       Originate OriginateOptions {..} -> do
@@ -295,6 +317,7 @@
         addr <-
           originateContract
             ooDBPath
+            ooTcOptions
             ooOriginator
             ooDelegate
             ooBalance
@@ -303,7 +326,7 @@
             ! #verbose ooVerbose
         putTextLn $ "Originated contract " <> pretty addr
       Transfer TransferOptions {..} -> do
-        transfer toNow toLevel toMaxSteps toDBPath toDestination toTxData
+        transfer toNow toLevel toMaxSteps toDBPath toTcOptions toDestination toTxData
           ! #verbose toVerbose
           ! #dryRun toDryRun
       REPL -> runRepl
diff --git a/app/REPL.hs b/app/REPL.hs
--- a/app/REPL.hs
+++ b/app/REPL.hs
@@ -21,7 +21,6 @@
 import qualified Data.ByteString.Lazy as BSL
 import Data.List (stripPrefix)
 import Data.Text (strip)
-import Data.Typeable (cast)
 import Data.Vinyl (Rec(..))
 import Fmt (pretty)
 import System.Console.Haskeline
@@ -29,18 +28,21 @@
 
 import Michelson.Interpret (interpretInstr)
 import Michelson.Macro (ParsedOp, expandList)
-import Michelson.Parser (errorBundlePretty, ops, parseExpandValue, type_)
+import Michelson.Parser (errorBundlePretty, ops, parseExpandValue, parseNoEnv, type_)
 import Michelson.Parser.Types (noLetEnv)
 import Michelson.Printer (printDoc, printTypedValue)
 import Michelson.Printer.Util (doesntNeedParens)
 import Michelson.Runtime.Dummy
-import Michelson.TypeCheck (SomeInstr(..), SomeInstrOut(..), getWTP, runTypeCheckIsolated)
+import Michelson.TypeCheck
+  (SomeInstr(..), SomeInstrOut(..), TypeCheckOptions(..), getWTP, runTypeCheckIsolated,
+  typeCheckingWith)
 import Michelson.TypeCheck.Instr (typeCheckList, typeCheckParameter)
 import Michelson.TypeCheck.Types (HST(..), NotWellTyped(..))
 import qualified Michelson.Typed as T
 import qualified Michelson.Untyped as U
+import Util.Sing (castSing)
 
-data SomeStack = forall t. Typeable t => SomeStack
+data SomeStack = forall t. T.SingI t => SomeStack
   { stValues :: (Rec T.Value t)
   , stTypes :: HST t
   }
@@ -95,8 +97,9 @@
     Right parsedOps -> do
       let expandedOps = expandList parsedOps
       lift get >>= \case
-        SomeStack {..} -> case cast stTypes of
-          Just hstInp -> case runTypeCheckIsolated $ typeCheckList expandedOps hstInp of
+        SomeStack {..} -> case castSing stTypes of
+          Just hstInp -> case typeCheckingWith tcOptions . runTypeCheckIsolated $
+                                typeCheckList expandedOps hstInp of
             Right someInstr -> do
               case someInstr of
                 _ :/ (instr ::: hstOut)-> case interpretInstr dummyContractEnv instr stValues of
@@ -127,26 +130,32 @@
 emptyStack = SomeStack RNil SNil
 
 parseInstructions :: Text -> Either Text [ParsedOp]
-parseInstructions src = let
-  codeParser = runReaderT ops noLetEnv
-  in case parse codeParser "" src of
+parseInstructions src =
+  case parseNoEnv ops "" src of
     Right p -> Right p
     Left err -> Left (toText $ errorBundlePretty err)
 
+tcOptions :: TypeCheckOptions
+tcOptions = TypeCheckOptions
+  { tcVerbose = False
+  , tcStrict = False
+  }
+
 -- helpers
 
 addValueToHST
-  :: forall t xs. Typeable xs
+  :: forall t xs. T.SingI xs
   => T.Value t
   -> HST xs
-  -> Either Text (T.Dict (Typeable (t ': xs)), HST (t ': xs))
+  -> Either Text (T.Dict (T.SingI (t ': xs)), HST (t ': xs))
 addValueToHST v hstIn = case T.valueTypeSanity v of
   T.Dict -> case getWTP @t of
     Right wtpDict -> Right (T.Dict, (T.starNotes @t, wtpDict, U.noAnn) ::&  hstIn)
-    Left (NotWellTyped t) -> let
+    Left (NotWellTyped t cause) -> let
       U.Ty t' tann = T.toUType t
       in Left $ "Value of type '" <> (renderT t' (U.fullAnnSet [tann] [] []))
-                <> "' is not well typed in the provided Value."
+                <> "' is not well typed in the provided Value because it "
+                <> pretty cause <> "."
 
 renderType :: T.SingI t => T.Notes t -> U.VarAnn -> Text
 renderType notes vann = let
@@ -200,7 +209,7 @@
     buildStack (Right (SomeStack stk hst)) (txVal, txTyp) = case
       (parseExpandValue txVal, parse (runReaderT type_ noLetEnv) "" txTyp) of
         (Right val, Right typ) ->
-          case typeCheckParameter mempty typ val of
+          case typeCheckingWith tcOptions $ typeCheckParameter mempty typ val of
             Right (T.SomeValue tVal) ->
               case addValueToHST tVal hst of
                 Right (T.Dict, newHst) -> Right $ SomeStack (tVal :& stk) newHst
diff --git a/morley.cabal b/morley.cabal
--- a/morley.cabal
+++ b/morley.cabal
@@ -5,7 +5,7 @@
 -- see: https://github.com/sol/hpack
 
 name:           morley
-version:        1.14.0
+version:        1.15.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
@@ -66,6 +66,7 @@
       Michelson.Runtime
       Michelson.Runtime.Dummy
       Michelson.Runtime.GState
+      Michelson.Runtime.Import
       Michelson.Runtime.TxData
       Michelson.Text
       Michelson.TypeCheck
@@ -85,6 +86,7 @@
       Michelson.Typed.Convert
       Michelson.Typed.Doc
       Michelson.Typed.Entrypoints
+      Michelson.Typed.Existential
       Michelson.Typed.Extract
       Michelson.Typed.Haskell
       Michelson.Typed.Haskell.Compatibility
@@ -149,7 +151,9 @@
       Util.Named
       Util.Num
       Util.Peano
+      Util.PeanoNatural
       Util.Positive
+      Util.Sing
       Util.Text
       Util.TH
       Util.Type
@@ -230,7 +234,6 @@
       aeson
     , base-noprelude >=4.7 && <5
     , bytestring
-    , data-default
     , fmt
     , haskeline
     , megaparsec >=7.0.0
diff --git a/src/Michelson/Doc.hs b/src/Michelson/Doc.hs
--- a/src/Michelson/Doc.hs
+++ b/src/Michelson/Doc.hs
@@ -321,17 +321,17 @@
     "Doc items section: " <> show (typeRep $ Proxy @d) <>
     " / " <> show (length ds) <> " item(s)"
 
-appendDocSectionUnsafe
+unsafeAppendDocSection
   :: HasCallStack
   => DocSection -> DocSection -> DocSection
-appendDocSectionUnsafe (DocSection ls) (DocSection rs) =
-  DocSection $ appendDocSectionUnsafeImpl ls (toList rs)
+unsafeAppendDocSection (DocSection ls) (DocSection rs) =
+  DocSection $ unsafeAppendDocSectionImpl ls (toList rs)
 
-appendDocSectionUnsafeImpl
+unsafeAppendDocSectionImpl
   :: forall d1 d2.
      (Typeable d1, Typeable d2, HasCallStack)
   => NonEmpty d1 -> [d2] -> NonEmpty d1
-appendDocSectionUnsafeImpl (l :| ls) rs =
+unsafeAppendDocSectionImpl (l :| ls) rs =
   let rs' = rs <&> \r -> cast r ?: onTypeMismatch
   in l :| ls <> rs'
   where
@@ -496,14 +496,14 @@
     { cdContents =
         M.merge
           M.preserveMissing M.preserveMissing
-          (M.zipWithMatched $ \_k l r -> appendDocSectionUnsafe l r)
+          (M.zipWithMatched $ \_k l r -> unsafeAppendDocSection l r)
           (cdContents cd1) (cdContents cd2)
     , cdDefinitions =
         M.merge
           M.preserveMissing M.preserveMissing
           (M.zipWithMatched $ \_k (DocSection ls) (DocSection rs) ->
              let removeDups = filter $ not . (`isDefinedIn` cdDefinitionIds cd1) . deItem
-             in DocSection $ appendDocSectionUnsafeImpl ls (removeDups $ toList rs)
+             in DocSection $ unsafeAppendDocSectionImpl ls (removeDups $ toList rs)
           )
           (cdDefinitions cd1) (cdDefinitions cd2)
     , cdDefinitionsSet =
diff --git a/src/Michelson/ErrorPos.hs b/src/Michelson/ErrorPos.hs
--- a/src/Michelson/ErrorPos.hs
+++ b/src/Michelson/ErrorPos.hs
@@ -18,9 +18,13 @@
 import Data.Default (Default(..))
 import qualified Data.Text as T
 import Fmt (Buildable (..))
+import Michelson.Printer.Util (RenderDoc (..), renderAnyBuildable)
+import Text.PrettyPrint.Leijen.Text
 
+
 import Util.Aeson
 
+
 newtype Pos = Pos {unPos :: Word}
   deriving stock (Eq, Ord, Show, Generic, Data)
 
@@ -61,6 +65,13 @@
   { icsCallStack :: LetCallStack
   , icsSrcPos    :: SrcPos
   } deriving stock (Eq, Ord, Show, Generic, Data)
+
+instance RenderDoc InstrCallStack where
+  renderDoc _ InstrCallStack{icsCallStack, icsSrcPos = SrcPos (Pos row) (Pos col)} =
+    "Error occurred on line" <+> (renderAnyBuildable (row + 1)) <+> "char" <+> (renderAnyBuildable (col + 1))
+    <> case icsCallStack of
+         [] -> "."
+         _ -> " inside these let defenitions:" <+> (list $ fmap (text . show) icsCallStack) <> "."
 
 instance NFData InstrCallStack
 
diff --git a/src/Michelson/FailPattern.hs b/src/Michelson/FailPattern.hs
--- a/src/Michelson/FailPattern.hs
+++ b/src/Michelson/FailPattern.hs
@@ -15,25 +15,19 @@
   , typicalFailWithTag
   , isTypicalFailWith
   , modifyTypicalFailWith
-
-  , ConstantScope'
   ) where
 
+import Data.Singletons (withSingI)
+
 import Michelson.Text (MText)
 import Michelson.Typed
 
--- | We need this class to pass it to 'SomeConstrainedValue'.
--- 'ConstantScope' is needed because we push a value and 'Typeable' is
--- needed for 'FAILWITH'.
-class (Typeable a, ConstantScope a) => ConstantScope' a
-instance (Typeable a, ConstantScope a) => ConstantScope' a
-
 -- | This data type captures typical ways to use `FAILWITH` instruction.
 -- Each constructor corresponds to a usage pattern.
 data TypicalFailWith
   = FailWithString MText
   -- ^ Push a constant string and fail with it.
-  | FailWithConstantPair MText (SomeConstrainedValue ConstantScope')
+  | FailWithConstantPair MText (SomeConstrainedValue ConstantScope)
   -- ^ Push a constant pair where the first item is a string and the
   -- second one is an arbitrary constant. Fail afterwards.
   | FailWithStackValue MText
@@ -75,7 +69,7 @@
   | VPair (VString str, secondItem) <- v =
       -- We need to pattern match to deduce `singI` for second item of the pair.
       case sing @t of
-        STPair {} -> Just (FailWithConstantPair str (SomeConstrainedValue secondItem))
+        STPair l r -> withSingI l $ withSingI r $ Just (FailWithConstantPair str (SomeConstrainedValue secondItem))
   | otherwise = Nothing
 
 -- | If given instruction ends with a typical 'FAILWITH' usage, modify
@@ -83,7 +77,7 @@
 -- return any value, not necessarily a string.
 modifyTypicalFailWith
   :: HasCallStack
-  => (MText -> SomeConstrainedValue ConstantScope')
+  => (MText -> SomeConstrainedValue ConstantScope)
   -> Instr inp out
   -> Instr inp out
 modifyTypicalFailWith f = modifyTypicalFailWith' . linearizeLeft
@@ -103,7 +97,7 @@
               | _ :: Value a <- v
               , _ :: Instr (b ': s) ('TPair a b ': s) <- i1 ->
                 case sing @('TPair a b) of
-                  STPair {} -> case isStringValue v of
+                  STPair l r -> withSingI l $ withSingI r $ case isStringValue v of
                     Just (f -> SomeConstrainedValue v') ->
                       PUSH v' `Seq` PAIR `Seq` FAILWITH
                     Nothing ->
@@ -112,7 +106,7 @@
               | _ :: Value a <- v
               , _ :: Instr s0 ('TPair a b ': s) <- i1 ->
                 case sing @('TPair a b) of
-                  STPair {} -> Seq i0 $ case isStringValue v of
+                  STPair l r -> withSingI l $ withSingI r $ Seq i0 $ case isStringValue v of
                     Just (f -> SomeConstrainedValue v') ->
                       PUSH v' `Seq` PAIR `Seq` FAILWITH
                     Nothing ->
@@ -123,7 +117,7 @@
         i -> i
 
     onPush ::
-      (HasCallStack, Typeable v, ConstantScope v) => Value v -> Instr inp out
+      (HasCallStack, ConstantScope v) => Value v -> Instr inp out
     onPush v = case isTypicalErrorConstant v of
       Just (FailWithString (f -> SomeConstrainedValue v')) -> PUSH v' `Seq` FAILWITH
       Just (FailWithConstantPair (f -> SomeConstrainedValue v') (SomeConstrainedValue arg)) ->
diff --git a/src/Michelson/Interpret.hs b/src/Michelson/Interpret.hs
--- a/src/Michelson/Interpret.hs
+++ b/src/Michelson/Interpret.hs
@@ -37,16 +37,16 @@
   , initInterpreterState
   , handleContractReturn
   , runInstrImpl
+  , assignBigMapIds
   ) where
 
 import Prelude hiding (EQ, GT, LT)
 
-import Control.Lens (makeLensesFor)
+import Control.Lens (makeLensesFor, traverseOf, (<<+=))
 import Control.Monad.Except (MonadError, throwError)
 import Data.Default (Default(..))
 import qualified Data.Map as Map
 import qualified Data.Set as Set
-import Data.Singletons (Sing)
 import Data.Vinyl (Rec(..), (<+>))
 import Data.Vinyl.Recursive (rmap)
 import Fmt (Buildable(build), Builder, blockListF, prettyLn)
@@ -57,18 +57,72 @@
 import Michelson.TypeCheck (SomeParamType(..), TcOriginatedContracts, matchTypes)
 import Michelson.Typed hiding (Branch(..))
 import qualified Michelson.Typed as T
-import Michelson.Typed.Origination (OriginationOperation(..), mkOriginationOperationHash)
-import Michelson.Untyped.Annotation (annQ)
+import Michelson.Typed.Origination
+  (OperationHash(..), OriginationOperation(..), mkContractAddress, mkOriginationOperationHash)
 import qualified Michelson.Untyped as U
-import Tezos.Address (Address(..), GlobalCounter(..), OriginationIndex(..), mkContractAddress)
+import Michelson.Untyped.Annotation (annQ)
+import Tezos.Address (Address(..), GlobalCounter(..), OriginationIndex(..))
 import Tezos.Core (ChainId, Mutez, Timestamp)
 import Tezos.Crypto (KeyHash, blake2b, checkSignature, hashKey, keccak, sha256, sha3, sha512)
 import Tezos.Crypto.BLS12381 (checkPairing)
-import Util.Peano (LongerThan, Peano, SingNat(SS, SZ))
+import Util.Peano (LongerThan, Peano)
+import Util.PeanoNatural (PeanoNatural(..))
+import Util.Sing (eqParamSing)
 import Util.TH
 import Util.Type
 import Util.Typeable
 
+-- | Morley logs for interpreter state that are stored in reverse order.
+newtype MorleyLogs = MorleyLogs [Text]
+  deriving stock (Eq, Show, Generic)
+  deriving newtype Default
+
+pickMorleyLogs :: MorleyLogs -> [Text]
+pickMorleyLogs (MorleyLogs logs) = reverse logs
+
+instance Buildable MorleyLogs where
+  build = blockListF . pickMorleyLogs
+
+instance NFData MorleyLogs
+
+noMorleyLogs :: MorleyLogs
+noMorleyLogs = MorleyLogs []
+
+newtype RemainingSteps = RemainingSteps Word64
+  deriving stock (Show, Generic)
+  deriving newtype (Eq, Ord, Buildable, Num)
+
+instance NFData RemainingSteps
+
+data InterpreterState = InterpreterState
+  { isMorleyLogs :: MorleyLogs
+  , isRemainingSteps :: RemainingSteps
+  , isOriginationNonce :: OriginationIndex
+  , isBigMapCounter :: BigMapCounter
+  } deriving stock (Show, Generic)
+
+instance NFData InterpreterState
+makeLensesFor
+  [ ("isMorleyLogs", "isMorleyLogsL")
+  , ("isBigMapCounter", "isBigMapCounterL")
+  ]
+  ''InterpreterState
+
+data StkEl t = StkEl
+  { seValue :: Value t
+  , seVarAnn :: U.VarAnn
+  , seNotes :: Notes t
+  } deriving stock (Eq, Show)
+
+makeLensesFor
+  [ ("seValue", "seValueL")
+  , ("seVarAnn", "seVarAnnL")
+  ]
+  ''StkEl
+
+starNotesStkEl :: forall t. Value t -> StkEl t
+starNotesStkEl v = StkEl v U.noAnn $ withValueTypeSanity v $ starNotes @t
+
 -- | Environment for contract execution.
 data ContractEnv = ContractEnv
   { ceNow :: Timestamp
@@ -92,7 +146,7 @@
   -- ^ Distribution of voting power.
   , ceChainId :: ChainId
   -- ^ Identifier of the current chain.
-  , ceOperationHash :: Maybe U.OperationHash
+  , ceOperationHash :: Maybe OperationHash
   -- ^ Hash of the currently executed operation, required for
   -- correct contract address computation in 'CREATE_CONTRACT' instruction.
   , ceGlobalCounter :: GlobalCounter
@@ -105,7 +159,7 @@
 -- | Represents @[FAILED]@ state of a Michelson program. Contains
 -- value that was on top of the stack when @FAILWITH@ was called.
 data MichelsonFailed where
-  MichelsonFailedWith :: (KnownT t, ConstantScope t) => T.Value t -> MichelsonFailed
+  MichelsonFailedWith :: (SingI t, ConstantScope t) => T.Value t -> MichelsonFailed
   MichelsonArithError
     :: (Typeable n, Typeable m, Typeable instr)
     => ArithError (Value' instr n) (Value' instr m) -> MichelsonFailed
@@ -115,7 +169,7 @@
 deriving stock instance Show MichelsonFailed
 
 instance Eq MichelsonFailed where
-  MichelsonFailedWith v1 == MichelsonFailedWith v2 = v1 `eqParam1` v2
+  MichelsonFailedWith v1 == MichelsonFailedWith v2 = v1 `eqParamSing` v2
   MichelsonFailedWith _ == _ = False
   MichelsonArithError ae1 == MichelsonArithError ae2 = ae1 `eqParam2` ae2
   MichelsonArithError _ == _ = False
@@ -170,22 +224,6 @@
   , iurNewState = st
   }
 
--- | Morley logs for interpreter state that are stored in reverse order.
-newtype MorleyLogs = MorleyLogs [Text]
-  deriving stock (Eq, Show, Generic)
-  deriving newtype Default
-
-pickMorleyLogs :: MorleyLogs -> [Text]
-pickMorleyLogs (MorleyLogs logs) = reverse logs
-
-instance Buildable MorleyLogs where
-  build = blockListF . pickMorleyLogs
-
-instance NFData MorleyLogs
-
-noMorleyLogs :: MorleyLogs
-noMorleyLogs = MorleyLogs []
-
 type ContractReturn st =
   (Either MichelsonFailed ([Operation], T.Value st), InterpreterState)
 
@@ -226,7 +264,7 @@
   -> T.Value st
   -> T.Notes st
   -> Rec StkEl (ContractInp param st)
-mkInitStack param T.ParamNotesUnsafe{..} st stNotes = StkEl
+mkInitStack param T.UnsafeParamNotes{..} st stNotes = StkEl
   (T.VPair (param, st))
   U.noAnn
   (T.NTPair U.noAnn (U.convAnn pnRootAnn) U.noAnn [annQ|parameter|] [annQ|storage|] pnNotes stNotes)
@@ -241,13 +279,14 @@
   -> EntrypointCallT cp arg
   -> T.Value arg
   -> T.Value st
+  -> BigMapCounter
   -> ContractEnv
   -> ContractReturn st
-interpret contract epc param initSt env =
-  interpret' contract epc param initSt env (initInterpreterState env)
+interpret contract epc param initSt bmCounter env =
+  interpret' contract epc param initSt env (initInterpreterState bmCounter env)
 
-initInterpreterState :: ContractEnv -> InterpreterState
-initInterpreterState env = InterpreterState def (ceMaxSteps env) (OriginationIndex 0)
+initInterpreterState :: BigMapCounter -> ContractEnv -> InterpreterState
+initInterpreterState bmCounter env = InterpreterState def (ceMaxSteps env) (OriginationIndex 0) bmCounter
 
 -- | Interpret an instruction in vacuum, putting no extra contraints on
 -- its execution.
@@ -278,25 +317,12 @@
       { isMorleyLogs = MorleyLogs []
       , isRemainingSteps = 9999999999
       , isOriginationNonce = OriginationIndex 0
+      , isBigMapCounter = 0
       }
 
 data SomeItStack where
   SomeItStack :: T.ExtInstr inp -> Rec StkEl inp -> SomeItStack
 
-newtype RemainingSteps = RemainingSteps Word64
-  deriving stock (Show, Generic)
-  deriving newtype (Eq, Ord, Buildable, Num)
-
-instance NFData RemainingSteps
-
-data InterpreterState = InterpreterState
-  { isMorleyLogs :: MorleyLogs
-  , isRemainingSteps :: RemainingSteps
-  , isOriginationNonce :: OriginationIndex
-  } deriving stock (Show, Generic)
-
-instance NFData InterpreterState
-
 type EvalOp a =
   ExceptT MichelsonFailed
     (ReaderT ContractEnv
@@ -337,15 +363,6 @@
   , MonadError MichelsonFailed m
   )
 
-data StkEl t = StkEl
-  { seValue :: Value t
-  , seVarAnn :: U.VarAnn
-  , seNotes :: Notes t
-  } deriving stock (Eq, Show)
-
-starNotesStkEl :: forall t. Value t -> StkEl t
-starNotesStkEl v = StkEl v U.noAnn $ withValueTypeSanity v $ starNotes @t
-
 type InstrRunner m =
   forall inp out.
      Instr inp out
@@ -361,6 +378,8 @@
 runInstr i@(InstrWithVarAnns _ _i1) r = runInstrImpl runInstr i r
 runInstr i@Nop r = runInstrImpl runInstr i r
 runInstr i@(Nested _) r = runInstrImpl runInstr i r
+runInstr i@(DocGroup _ _i1) r = runInstrImpl runInstr i r
+runInstr i@(Fn _ _ _i1) r = runInstrImpl runInstr i r
 runInstr i r = do
   rs <- isRemainingSteps <$> getInterpreterState
   if rs == 0
@@ -373,7 +392,7 @@
 runInstrNoGas = runInstrImpl runInstrNoGas
 
 -- | Function to interpret Michelson instruction(s) against given stack.
-runInstrImpl :: EvalM m => InstrRunner m -> InstrRunner m
+runInstrImpl :: forall m. EvalM m => InstrRunner m -> InstrRunner m
 runInstrImpl runner (Seq i1 i2) r = runner i1 r >>= \r' -> runner i2 r'
 runInstrImpl runner (WithLoc _ i) r = runner i r
 runInstrImpl runner (InstrWithNotes (_ :: Proxy rest) notes instr) inp = do
@@ -401,11 +420,13 @@
 runInstrImpl runner (Ext nop) r = r <$ interpretExt runner (SomeItStack nop r)
 runInstrImpl runner (Nested sq) r = runner sq r
 runInstrImpl runner (DocGroup _ sq) r = runInstrImpl runner sq r
+runInstrImpl runner (Fn _ _ i) r = runner i r
 runInstrImpl _ DROP (_ :& r) = pure $ r
-runInstrImpl runner (DROPN s) stack =
-  case s of
-    SZ -> pure stack
-    SS s' -> case stack of
+runInstrImpl runner (DROPN n) stack =
+  case n of
+    Zero    -> pure stack
+    Succ s' -> case stack of
+      (_ :& r) -> runInstrImpl runner (DROPN s') r
       -- Note: we intentionally do not use `runner` to recursively
       -- interpret `DROPN` here.
       -- All these recursive calls together correspond to a single
@@ -413,35 +434,38 @@
       -- This recursion is implementation detail of `DROPN`.
       -- The same reasoning applies to other instructions parameterized
       -- by a natural number like 'DIPN'.
-      (_ :& r) -> runInstrImpl runner (DROPN s') r
-runInstrImpl _ DUP (a :& r) = pure $ a :& a :& r
-runInstrImpl _ (DUPN nSing) stack = pure $ go nSing stack
+runInstrImpl _ DUP (stkEl :& r) = do
+  -- If we're duplicating a big_map, or a value containing big_map(s), we need to generate new big_map ID(s).
+  duplicateStkEl <- traverseOf seValueL assignBigMapIds' stkEl
+  pure $ duplicateStkEl :& stkEl :& r
+runInstrImpl _ (DUPN s) stack = go s stack
   where
     go :: forall (n :: Peano) inp out a. ConstraintDUPN n inp out a
-       => Sing n -> Rec StkEl inp -> Rec StkEl out
-    go = curry \case
-      -- Discard variable annotations. This is consistent with tezos-client.
-      (SS SZ, i@(StkEl a _ n :& _)) -> StkEl a U.noAnn n :& i
-      (SS s@(SS _), b :& r) -> case go s r of
+       => PeanoNatural n -> Rec StkEl inp -> m (Rec StkEl out)
+    go (Succ Zero) stk@(stkEl :& _) = do
+        -- If we're duplicating a big_map, or a value containing big_map(s), we need to generate new big_map ID(s).
+        duplicateStkEl <- traverseOf seValueL assignBigMapIds' stkEl
+        -- Discard variable annotations. This is consistent with tezos-client.
+        pure $ (duplicateStkEl & seVarAnnL .~ U.noAnn) :& stk
+    go (Succ n@(Succ _)) (b :& r) =
+      go n r <&> \case
         (a :& resTail) -> a :& b :& resTail
 runInstrImpl _ SWAP (a :& b :& r) = pure $ b :& a :& r
-runInstrImpl _ (DIG nSing0) input0 =
-  pure $ go nSing0 input0
+runInstrImpl _ (DIG s) input0 =
+  pure $ go s input0
   where
     go :: forall (n :: Peano) inp out a. ConstraintDIG n inp out a
-       => Sing n -> Rec StkEl inp -> Rec StkEl out
-    go = curry \case
-      (SZ, stack) -> stack
-      (SS nSing, b :& r) -> case go nSing r of
-        (a :& resTail) -> a :& b :& resTail
-runInstrImpl _ (DUG nSing0) input0 =
-  pure $ go nSing0 input0
+       => PeanoNatural n -> Rec StkEl inp -> Rec StkEl out
+    go Zero stack = stack
+    go (Succ n') (b :& r) = case go n' r of
+      (a :& resTail) -> a :& b :& resTail
+runInstrImpl _ (DUG s) input0 =
+  pure $ go s input0
   where
     go :: forall (n :: Peano) inp out a. ConstraintDUG n inp out a
-       => Sing n -> Rec StkEl inp -> Rec StkEl out
-    go = curry \case
-      (SZ, stack) -> stack
-      (SS s', a :& b :& r) -> b :& go s' (a :& r)
+       => PeanoNatural n -> Rec StkEl inp -> Rec StkEl out
+    go Zero stack = stack
+    go (Succ n') (a :& b :& r) = b :& go n' (a :& r)
 runInstrImpl _ SOME ((seValue -> a) :& r) =
   withValueTypeSanity a $
     pure $ starNotesStkEl (VOption (Just a)) :& r
@@ -455,28 +479,30 @@
 runInstrImpl _ NEVER inp = case inp of {}
 runInstrImpl _ (AnnPAIR{}) ((StkEl a _ _) :& (StkEl b _ _) :& r) =
   pure $ starNotesStkEl (VPair (a, b)) :& r
-runInstrImpl _ (PAIRN nSing) stack = pure $ go nSing stack
+runInstrImpl _ (AnnUNPAIR{}) ((StkEl (VPair (a, b)) _ _) :& r) =
+  pure $ starNotesStkEl a :& starNotesStkEl b :& r
+runInstrImpl _ (PAIRN s) stack = pure $ go s stack
   where
-    go :: forall n inp. ConstraintPairN n inp => Sing n -> Rec StkEl inp -> Rec StkEl (PairN n inp)
-    go (SS (SS SZ)) (StkEl a _ _ :& StkEl b _ _ :& r) =
+    go :: forall n inp. ConstraintPairN n inp => PeanoNatural n -> Rec StkEl inp -> Rec StkEl (PairN n inp)
+    go (Succ (Succ Zero)) (StkEl a _ _ :& StkEl b _ _ :& r) =
       -- if n=2
       starNotesStkEl (VPair (a, b)) :& r
-    go (SS n@(SS (SS _))) (StkEl a _ _ :& r@(_ :& _ :& _)) =
+    go (Succ n@(Succ (Succ _))) (StkEl a _ _ :& r@(_ :& _ :& _)) =
       -- if n>2
       case go n r of
         StkEl combed _ _ :& r' ->
             starNotesStkEl (VPair (a, combed)) :& r'
-runInstrImpl _ (UNPAIRN nSing) (StkEl pair0 _ pairNotes0 :& r) = do
-  pure $ go nSing pair0 pairNotes0 <+> r
+runInstrImpl _ (UNPAIRN s) (StkEl pair0 _ pairNotes0 :& r) = do
+  pure $ go s pair0 pairNotes0 <+> r
   where
     go
       :: forall n pair. ConstraintUnpairN n pair
-      => Sing n -> Value pair -> Notes pair
+      => PeanoNatural n -> Value pair -> Notes pair
       -> Rec StkEl (UnpairN n pair)
     go n pair pairNotes =
       case (n, pair, pairNotes) of
         -- if n=2
-        (SS (SS SZ), VPair (a, b), NTPair _ aFieldAnn bFieldAnn _ _ aNotes bNotes) ->
+        (Succ (Succ Zero), VPair (a, b), NTPair _ aFieldAnn bFieldAnn _ _ aNotes bNotes) ->
           -- @UNPAIR n@ converts field annotations into var annotations.
           --
           -- > /* [ @pair pair (int %aa) (int %bb) (int %cc) (int %dd) ] */ ;
@@ -492,11 +518,11 @@
             :& StkEl b (U.convAnn @U.FieldTag @U.VarTag bFieldAnn) bNotes
             :& RNil
         -- if n>2
-        (SS n'@(SS (SS _)), VPair (a, b@(VPair _)), NTPair _ aFieldAnn _ _ _ aNotes bNotes) ->
+        (Succ n'@(Succ (Succ _)), VPair (a, b@(VPair _)), NTPair _ aFieldAnn _ _ _ aNotes bNotes) ->
           StkEl a (U.convAnn @U.FieldTag @U.VarTag aFieldAnn) aNotes
             :& go n' b bNotes
-runInstrImpl _ (AnnCAR _) (StkEl (VPair (a, _b)) _ _ :& r) = pure $ starNotesStkEl a :& r
-runInstrImpl _ (AnnCDR _) (StkEl (VPair (_a, b)) _ _ :& r) = pure $ starNotesStkEl b :& r
+runInstrImpl _ (AnnCAR _ _) (StkEl (VPair (a, _b)) _ _ :& r) = pure $ starNotesStkEl a :& r
+runInstrImpl _ (AnnCDR _ _) (StkEl (VPair (_a, b)) _ _ :& r) = pure $ starNotesStkEl b :& r
 runInstrImpl _ (AnnLEFT nt nf1 nf2) ((StkEl a _ na) :& r) =
   withValueTypeSanity a $
     pure $ StkEl (VOr $ Left a) U.noAnn (NTOr nt nf1 nf2 na starNotes) :& r
@@ -515,7 +541,9 @@
 runInstrImpl _ SIZE (a :& r) = pure $ starNotesStkEl (VNat $ (fromInteger . toInteger) $ evalSize $ seValue a) :& r
 runInstrImpl _ EMPTY_SET r = pure $ starNotesStkEl (VSet Set.empty) :& r
 runInstrImpl _ EMPTY_MAP r = pure $ starNotesStkEl (VMap Map.empty) :& r
-runInstrImpl _ EMPTY_BIG_MAP r = pure $ starNotesStkEl (VBigMap Map.empty) :& r
+runInstrImpl _ EMPTY_BIG_MAP r = do
+  bigMap <- assignBigMapIds' $ VBigMap Nothing Map.empty
+  pure $ starNotesStkEl bigMap :& r
 runInstrImpl runner (MAP (code :: Instr (MapOpInp c ': s) (b ': s))) (StkEl a vn n :& r) = do
   -- Evaluation must preserve all stack modifications that @MAP@'s does.
   (newStack, newList) <- foldlM (\(curStack, curList) (val :: StkEl (MapOpInp c)) -> do
@@ -532,27 +560,27 @@
     (Nothing, _) -> pure r
 runInstrImpl _ MEM (a :& b :& r) = pure $ starNotesStkEl (VBool (evalMem (seValue a) (seValue b))) :& r
 runInstrImpl _ GET (a :& b :& r) = pure $ starNotesStkEl (VOption (evalGet (seValue a) (seValue b))) :& r
-runInstrImpl _ (GETN index0) (StkEl pair _ _ :& r) = do
-  pure $ starNotesStkEl (go index0 pair) :& r
+runInstrImpl _ (GETN s) (StkEl pair _ _ :& r) = do
+  pure $ starNotesStkEl (go s pair) :& r
   where
     go
       :: forall ix a. ConstraintGetN ix a
-      => Sing ix -> Value a
+      => PeanoNatural ix -> Value a
       -> Value (GetN ix a)
-    go SZ           a                  = a
-    go (SS SZ)      (VPair (left, _))  = left
-    go (SS (SS n')) (VPair (_, right)) = go n' right
+    go Zero            a                   = a
+    go (Succ Zero)      (VPair (left, _))  = left
+    go (Succ (Succ n')) (VPair (_, right)) = go n' right
 runInstrImpl _ UPDATE (a :& b :& StkEl c _ _ :& r) =
   pure $ starNotesStkEl (evalUpd (seValue a) (seValue b) c) :& r
-runInstrImpl _ (UPDATEN index0) (StkEl (val :: Value val) _ _  :& StkEl pair _ _ :& r) = do
-  pure $ starNotesStkEl (go index0 pair) :& r
+runInstrImpl _ (UPDATEN s) (StkEl (val :: Value val) _ _  :& StkEl pair _ _ :& r) = do
+  pure $ starNotesStkEl (go s pair) :& r
   where
     go
       :: forall ix pair. ConstraintUpdateN ix pair
-      => Sing ix -> Value pair -> Value (UpdateN ix val pair)
-    go SZ           _                      = val
-    go (SS SZ)      (VPair (_, right))     = VPair (val, right)
-    go (SS (SS n')) (VPair (left, right))  = VPair (left, go n' right)
+      => PeanoNatural ix -> Value pair -> Value (UpdateN ix val pair)
+    go Zero             _                      = val
+    go (Succ Zero)      (VPair (_, right))     = VPair (val, right)
+    go (Succ (Succ n')) (VPair (left, right))  = VPair (left, go n' right)
 runInstrImpl _ GET_AND_UPDATE (StkEl key _ _ :& StkEl valMb _ _ :& StkEl collection _ _ :& r) =
   pure $
     starNotesStkEl (VOption (evalGet key collection))
@@ -582,8 +610,8 @@
   pure $ a :& res
 runInstrImpl runner (DIPN s i) stack =
   case s of
-    SZ -> runner i stack
-    SS s' -> case stack of
+    Zero -> runner i stack
+    Succ s' -> case stack of
       (a :& r) -> (a :&) <$> runInstrImpl runner (DIPN s' i) r
 runInstrImpl _ FAILWITH (a :& _) = throwError $ MichelsonFailedWith (seValue a)
 runInstrImpl _ CAST (StkEl a _ _ :& r) = pure $ starNotesStkEl a :& r
@@ -750,7 +778,28 @@
 runInstrImpl _ SELF_ADDRESS r = do
   ContractEnv{..} <- ask
   pure $ starNotesStkEl (VAddress $ EpAddress ceSelf DefEpName) :& r
-
+runInstrImpl _ TICKET (StkEl dat _ _ :& StkEl (VNat am) _ _ :& r) = do
+  ContractEnv{..} <- ask
+  pure $ starNotesStkEl (VTicket ceSelf dat am) :& r
+runInstrImpl _ READ_TICKET (te@(StkEl (VTicket addr dat am) _ _) :& r) = do
+  pure $
+    starNotesStkEl
+      (VPair (VAddress (EpAddress addr DefEpName), (VPair (dat, VNat am))))
+    :& te :& r
+runInstrImpl _ SPLIT_TICKET
+    (StkEl tv@(VTicket addr dat am) _ _ :&
+     StkEl (VPair (VNat am1, VNat am2)) _ _ :& r) = do
+  let result = withValueTypeSanity tv $ VOption do
+        guard (am1 + am2 == am)
+        return $ VPair (VTicket addr dat am1, VTicket addr dat am2)
+  pure $ starNotesStkEl result :& r
+runInstrImpl _ JOIN_TICKETS
+  (StkEl (VPair (tv1@(VTicket addr1 dat1 am1), VTicket addr2 dat2 am2)) _ _ :& r) = do
+  let result = withValueTypeSanity tv1 $ VOption do
+        guard (addr1 == addr2)
+        guard (dat1 == dat2)
+        return $ VTicket addr1 dat1 (am1 + am2)
+  pure $ starNotesStkEl result :& r
 
 -- | Evaluates an arithmetic operation and either fails or proceeds.
 runArithOp
@@ -771,7 +820,7 @@
 runUnpack bs =
   -- TODO [TM-80] Gas consumption here should depend on unpacked data size
   -- and size of resulting expression, errors would also spend some (all equally).
-  -- Fortunatelly, the inner decoding logic does not need to know anything about gas use.
+  -- Fortunately, the inner decoding logic does not need to know anything about gas use.
   unpackValue' bs
 
 createOrigOp
@@ -810,6 +859,7 @@
 
 interpretExt _ (SomeItStack T.DOC_ITEM{} _) = pass
 interpretExt _ (SomeItStack T.COMMENT_ITEM{} _) = pass
+interpretExt _ (SomeItStack T.STACKTYPE{} _) = pass
 
 -- | Access given stack reference (in CPS style).
 withStackElem
@@ -823,10 +873,27 @@
   where
     loop
       :: forall s (n :: Peano). (LongerThan s n)
-      => (Rec StkEl s, Sing n) -> a
+      => (Rec StkEl s, PeanoNatural n) -> a
     loop = \case
-      (e :& _, SZ) -> cont e
-      (_ :& es, SS n) -> loop (es, n)
+      (e :& _, Zero) -> cont e
+      (_ :& es, Succ n) -> loop (es, n)
 
+assignBigMapIds' :: EvalM m => Value t -> m (Value t)
+assignBigMapIds' val = do
+  bigMapCounter0 <- view isBigMapCounterL <$> getInterpreterState
+  let (storageWithIds, bigMapCounter1) = runState (assignBigMapIds val) bigMapCounter0
+  modifyInterpreterState (set isBigMapCounterL bigMapCounter1)
+  pure storageWithIds
+
+-- | All big_maps stored in a chain have a globally unique ID.
+--
+-- We use this function to assign a new ID whenever a big_map is created.
+assignBigMapIds :: MonadState BigMapCounter m => Value t -> m (Value t)
+assignBigMapIds =
+  dfsTraverseValue \case
+    VBigMap _ vBigMap -> do
+      bigMapId <- bigMapCounter <<+= 1
+      pure $ VBigMap (Just bigMapId) vBigMap
+    v -> pure v
+
 (deriveGADTNFData ''MichelsonFailed)
-makeLensesFor [("isMorleyLogs", "isMorleyLogsL")] ''InterpreterState
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
@@ -6,588 +6,39 @@
 --
 -- This is nearly symmetric to adjacent Unpack.hs module.
 module Michelson.Interpret.Pack
-  ( packCode'
-  , packT'
-  , packValue
+  ( packValue
   , packValue'
   , packValuePrefix
-    -- * Serializers used in morley-client
-  , encodeValue'
-  , encodeValue
-  , packNotedT'
-    -- * Internals
-  , encodeIntPayload
-  , encodeKeyHashRaw
-  , encodeEpAddress
+  , toBinary
+  , toBinary'
   ) where
 
 import Prelude hiding (EQ, GT, LT)
 
-import qualified Data.Binary.Put as Bi
-import qualified Data.ByteArray as ByteArray
-import qualified Data.ByteString.Lazy as LBS
-import qualified Data.Map as Map
-import Data.Singletons (Sing, demote)
-import Data.Vinyl (Rec(..))
-import Util.Type (type (++))
-
-import Michelson.Interpret.Utils
-import Michelson.Text
 import Michelson.Typed
-import Michelson.Untyped.Annotation
-  (Annotation(..), FieldAnn, TypeAnn, VarAnn, fullAnnSet, isNoAnnSet, noAnn)
-import Tezos.Address (Address(..), ContractHash(..))
-import Tezos.Core (ChainId(..), Mutez(..), timestampToSeconds)
-import Tezos.Crypto (KeyHash(..), KeyHashTag(..), PublicKey(..), signatureToBytes)
-import qualified Tezos.Crypto.BLS12381 as BLS
-import qualified Tezos.Crypto.Ed25519 as Ed25519
-import qualified Tezos.Crypto.P256 as P256
-import qualified Tezos.Crypto.Secp256k1 as Secp256k1
-import Util.Peano (peanoValSing)
+import Morley.Micheline.Binary (encodeExpression, encodeExpression')
+import Morley.Micheline.Class (ToExpression(..))
 
--- | Prefix prepended to the binary representation of a value.
-packValuePrefix :: IsString s => s
-packValuePrefix = "\x05"
+-- | Generic serializer.
+toBinary :: ToExpression a => a -> LByteString
+toBinary = encodeExpression . toExpression
 
+-- | Same as 'toBinary', for strict bytestring.
+toBinary' :: ToExpression a => a -> ByteString
+toBinary' = encodeExpression' . toExpression
+
 -- | Serialize a value given to @PACK@ instruction.
 packValue :: PackedValScope t => Value t -> LByteString
-packValue x = packValuePrefix <> encodeValue x
+packValue x =
+  let uval = untypeValueHashable x
+  in packValuePrefix <> (encodeExpression $ toExpression uval)
 
 -- | Same as 'packValue', for strict bytestring.
 packValue' :: PackedValScope t => Value t -> ByteString
-packValue' = LBS.toStrict . packValue
-
-encodeValue' :: (SingI t, HasNoOp t) => Value t -> ByteString
-encodeValue' = LBS.toStrict . encodeValue
-
-packT' :: forall (t :: T). SingI t => ByteString
-packT' = LBS.toStrict $ encodeT' @t
-
-packCode' :: Instr inp out -> ByteString
-packCode' = LBS.toStrict . encodeInstrs
-
--- | Generic serializer.
---
--- We don't require @HasNoBigMap@ constraint here since the big_map serialization
--- is only prohibited in @PACK@ instructions, however, we still want to be able to
--- serialize big_map e.g. in order to transform typed value to low-level Micheline
--- representation.
--- TODO: Serialize chain operations properly as well since they actually also have
--- byte representation.
-encodeValue :: forall t. (SingI t, HasNoOp t) => Value t -> LByteString
-encodeValue val = case (val, sing @t) of
-  (VKey s, _) -> encodeBytes' $ case s of
-    PublicKeyEd25519 pk -> "\x00" <> Ed25519.publicKeyToBytes pk
-    PublicKeySecp256k1 pk -> "\x01" <> Secp256k1.publicKeyToBytes pk
-    PublicKeyP256 pk -> "\x02" <> P256.publicKeyToBytes pk
-  (VUnit, _) -> "\x03\x0b"
-  (VSignature x, _) -> encodeBytes' $ signatureToBytes x
-  (VChainId x, _) ->
-    encodeBytes' $ ByteArray.convert (unChainId x)
-  (VOption (Just x), STOption _) -> "\x05\x09" <> encodeValue x
-  (VOption Nothing, _) -> "\x03\x06"
-  (VList xs, STList _) -> encodeList encodeValue xs
-  (VSet xs, (STSet (st :: Sing st))) -> case checkOpPresence st of
-    OpAbsent -> encodeList encodeValue (toList xs)
-  (VContract addr sepc, _) -> encodeEpAddress $ EpAddress addr (sepcName sepc)
-  (VPair (v1, v2), STPair l _) ->
-    case checkOpPresence l of
-      OpAbsent -> "\x07\x07" <> encodeValue v1 <> encodeValue v2
-  (VOr (Left v), STOr l _) ->
-    case checkOpPresence l of
-      OpAbsent -> "\x05\x05" <> encodeValue v
-  (VOr (Right v), STOr l _) ->
-    case checkOpPresence l of
-      OpAbsent-> "\x05\x08" <> encodeValue v
-  (VLam lam, _) -> encodeInstrs $ rfAnyInstr lam
-  (VMap m, STMap sk _) -> case checkOpPresence sk of
-    OpAbsent -> encodeMap m
-  (VBigMap m, STBigMap sk _) -> case checkOpPresence sk of
-    OpAbsent -> encodeMap m
-  (VInt x, STInt) -> encodeNumeric x
-  (VNat x, STNat) -> encodeNumeric x
-  (VString text, STString) -> encodeString text
-  (VBytes bytes, STBytes) -> encodeBytes' bytes
-  (VMutez x, STMutez) -> encodeNumeric (unMutez x)
-  (VBool True, STBool) -> "\x03\x0a"
-  (VBool False, STBool) -> "\x03\x03"
-  (VKeyHash kh, STKeyHash) -> encodeBytes $ encodeKeyHashRaw kh
-  (VBls12381Fr v, STBls12381Fr) -> encodeBytes' $ BLS.toMichelsonBytes v
-  (VBls12381G1 v, STBls12381G1) -> encodeBytes' $ BLS.toMichelsonBytes v
-  (VBls12381G2 v, STBls12381G2) -> encodeBytes' $ BLS.toMichelsonBytes v
-  (VTimestamp x, STTimestamp) -> encodeNumeric (timestampToSeconds @Integer x)
-  (VAddress addr, STAddress) -> encodeEpAddress addr
-
-encodeLength :: Int -> LByteString
-encodeLength = Bi.runPut . Bi.putWord32be . fromIntegral
-
--- | Lift encoded list content to an entire encoded list.
-encodeAsList :: LByteString -> LByteString
-encodeAsList bs = encodeLength (length bs) <> bs
-
--- | Encode a list-like structure.
-encodeList :: (a -> LByteString) -> [a] -> LByteString
-encodeList encodeElem l = "\x02" <> encodeAsList (LBS.concat $ map encodeElem l)
-
--- | Encode a text.
-encodeString :: MText -> LByteString
-encodeString text = "\x01" <> encodeAsList (encodeUtf8 $ unMText text)
-
--- | Encode some raw data.
-encodeBytes :: LByteString -> LByteString
-encodeBytes bs =
-  "\x0a" <> encodeAsList bs
-
--- | Version of 'encodeBytes' that accepts a strict bytestring.
-encodeBytes' :: ByteString -> LByteString
-encodeBytes' = encodeBytes . LBS.fromStrict
-
-encodeEpName :: EpName -> LByteString
-encodeEpName = encodeUtf8 . unAnnotation . epNameToRefAnn . canonicalize
-  where
-    canonicalize :: EpName -> EpName
-    canonicalize (EpNameUnsafe "default") = DefEpName
-    canonicalize epName                   = epName
-
--- | Encode some map.
-encodeMap :: (SingI v, HasNoOp v, SingI k, HasNoOp k) => Map (Value k) (Value v) -> LByteString
-encodeMap m =
-  encodeList (\(k, v) -> "\x07\x04" <> encodeValue k <> encodeValue v) (Map.toList m)
-
-encodeKeyHashRaw :: KeyHash -> LByteString
-encodeKeyHashRaw kh = (<> LBS.fromStrict (khBytes kh)) $
-  case khTag kh of
-    KeyHashEd25519 -> "\x00"
-    KeyHashSecp256k1 -> "\x01"
-    KeyHashP256 -> "\x02"
-
-encodeAddress :: Address -> LByteString
-encodeAddress = \case
-  KeyAddress keyHash ->
-    "\x00" <> (encodeKeyHashRaw keyHash)
-  ContractAddress (ContractHash address) ->
-    "\x01" <> LBS.fromStrict address <> "\x00"
-
-encodeEpAddress :: EpAddress -> LByteString
-encodeEpAddress (EpAddress addr epName) =
-  encodeBytes $ encodeAddress addr <> encodeEpName epName
-
--- | Encode contents of a given number.
-encodeIntPayload :: Integer -> LByteString
-encodeIntPayload = LBS.pack . toList . encodeZarithNumber
-
--- | Encode an int-like value.
-encodeNumeric :: Integral i => i -> LByteString
-encodeNumeric i = "\x00" <> encodeIntPayload (fromIntegral i)
-
--- | Encode a code block.
-encodeInstrs :: Instr inp out -> LByteString
-encodeInstrs = encodeList id . one . encodeInstr
-
--- | Encode an instruction.
-encodeInstr :: forall inp out. Instr inp out -> LByteString
-encodeInstr = \case
-  WithLoc _ i ->
-    encodeInstr i
-  InstrWithNotes proxy notes instr ->
-    encodeNotedInstr proxy instr notes []
-  InstrWithVarNotes varNotes a -> case a of
-    AnnLEFT{} | _ :: Proxy ('TOr l r ': s) <- Proxy @out ->
-      encodeVarNotedInstr a varNotes (encodeT' @r)
-    AnnRIGHT{} | _ :: Proxy ('TOr l r ': s) <- Proxy @out ->
-      encodeVarNotedInstr a varNotes (encodeT' @l)
-    _ -> encodeVarNotedInstr a varNotes ""
-  InstrWithVarAnns _ a ->
-    encodeInstr a
-  FrameInstr _ i ->
-    encodeInstr i
-  Seq a b ->
-    encodeInstr a <> encodeInstr b
-  Nop ->
-    mempty
-  Nested i ->
-    encodeInstrs i
-  DocGroup _ i ->
-    encodeInstrs i
-  Ext _ ->
-    ""
-  DROP ->
-    "\x03\x20"
-  DROPN s ->
-    "\x05\x20" <> encodeNumeric (peanoValSing s)
-  DUP ->
-    "\x03\x21"
-  DUPN s ->
-    "\x05\x21" <> encodeNumeric (peanoValSing s)
-  SWAP ->
-    "\x03\x4c"
-  DIG s ->
-    "\x05\x70" <> encodeNumeric (peanoValSing s)
-  DUG s ->
-    "\x05\x71" <> encodeNumeric (peanoValSing s)
-  PUSH (a :: Value t) ->
-    "\x07\x43" <> encodeT' @t <> encodeValue a
-  SOME ->
-    "\x03\x46"
-  NONE | _ :: Proxy ('TOption t ': s) <- Proxy @out ->
-    "\x05\x3e" <> encodeT' @t
-  UNIT ->
-    "\x03\x4f"
-  IF_NONE a b ->
-    "\x07\x2f" <> encodeInstrs a <> encodeInstrs b
-  AnnPAIR tn fn1 fn2 ->
-    encodeWithAnns [tn] [fn1, fn2] [] "\x03\x42"
-  PAIRN n ->
-    "\x05\x42" <> encodeNumeric (peanoValSing n)
-  UNPAIRN n ->
-    "\x05\x7a" <> encodeNumeric (peanoValSing n)
-  (AnnCAR fn) ->
-    encodeWithAnns [] [fn] [] "\x03\x16"
-  (AnnCDR fn) ->
-    encodeWithAnns [] [fn] [] "\x03\x17"
-  (AnnLEFT tn fn1 fn2) | _ :: Proxy ('TOr l r ': s) <- Proxy @out ->
-    encodeWithAnns [tn] [fn1, fn2] [] $ "\x05\x33" <> encodeT' @r
-  (AnnRIGHT tn fn1 fn2) | _ :: Proxy ('TOr l r ': s) <- Proxy @out ->
-    encodeWithAnns [tn] [fn1, fn2] [] $ "\x05\x44" <> encodeT' @l
-  IF_LEFT a b ->
-    "\x07\x2e" <> encodeInstrs a <> encodeInstrs b
-  NIL | _ :: Proxy ('TList t ': s) <- Proxy @out ->
-    "\x05\x3d" <> encodeT' @t
-  CONS ->
-    "\x03\x1b"
-  IF_CONS a b ->
-    "\x07\x2d" <> encodeInstrs a <> encodeInstrs b
-  SIZE ->
-    "\x03\x45"
-  EMPTY_SET | _ :: Proxy ('TSet t ': s) <- Proxy @out ->
-    "\x05\x24" <> encodeT' @t
-  EMPTY_MAP | _ :: Proxy ('TMap k v ': s) <- Proxy @out ->
-    "\x07\x23" <> encodeT' @k <> encodeT' @v
-  EMPTY_BIG_MAP | _ :: Proxy ('TBigMap k v ': s) <- Proxy @out ->
-    "\x07\x72" <> encodeT' @k <> encodeT' @v
-  MAP a ->
-    "\x05\x38" <> encodeInstrs a
-  ITER a ->
-    "\x05\x52" <> encodeInstrs a
-  MEM ->
-    "\x03\x39"
-  GET ->
-    "\x03\x29"
-  GETN n ->
-    "\x05\x29" <> encodeNumeric (peanoValSing n)
-  UPDATE ->
-    "\x03\x50"
-  UPDATEN n ->
-    "\x05\x50" <> encodeNumeric (peanoValSing n)
-  GET_AND_UPDATE ->
-    "\x03\x8c"
-  IF a b ->
-    "\x07\x2c" <> encodeInstrs a <> encodeInstrs b
-  LOOP a ->
-    "\x05\x34" <> encodeInstrs a
-  LOOP_LEFT a ->
-    "\x05\x53" <> encodeInstrs a
-  LAMBDA (v :: Value ('TLambda i o)) ->
-    "\x09\x31" <>
-    encodeAsList (encodeT' @i <> encodeT' @o <> encodeValue v) <>
-    encodeLength 0  -- encoding of a Variable Annotation (that we don't support)
-  EXEC ->
-    "\x03\x26"
-  APPLY ->
-    "\x03\x73"
-  DIP a ->
-    "\x05\x1f" <> encodeInstrs a
-  DIPN s a ->
-    "\x07\x1f" <> encodeNumeric (peanoValSing s) <> encodeInstrs a
-  FAILWITH ->
-    "\x03\x27"
-  CAST | _ :: Proxy (t ': s) <- Proxy @out ->
-    "\x05\x57" <> encodeT' @t
-  RENAME ->
-    "\x03\x58"
-  PACK ->
-    "\x03\x0c"
-  UNPACK | _ :: Proxy ('TOption t ': s) <- Proxy @out ->
-    "\x05\x0d" <> encodeT' @t
-  CONCAT ->
-    "\x03\x1a"
-  CONCAT' ->
-    "\x03\x1a"
-  SLICE ->
-    "\x03\x6f"
-  ISNAT ->
-    "\x03\x56"
-  ADD ->
-    "\x03\x12"
-  SUB ->
-    "\x03\x4b"
-  MUL ->
-    "\x03\x3a"
-  EDIV ->
-    "\x03\x22"
-  ABS ->
-    "\x03\x11"
-  NEG ->
-    "\x03\x3b"
-  LSL ->
-    "\x03\x35"
-  LSR ->
-    "\x03\x36"
-  OR ->
-    "\x03\x41"
-  AND ->
-    "\x03\x14"
-  XOR ->
-    "\x03\x51"
-  NOT ->
-    "\x03\x3f"
-  COMPARE ->
-    "\x03\x19"
-  EQ ->
-    "\x03\x25"
-  NEQ ->
-    "\x03\x3c"
-  LT ->
-    "\x03\x37"
-  GT ->
-    "\x03\x2a"
-  LE ->
-    "\x03\x32"
-  GE ->
-    "\x03\x28"
-  INT ->
-    "\x03\x30"
-  SELF sepc ->
-    case sepcName sepc of
-      DefEpName ->  "\x03\x49"
-      epName -> encodeWithAnns [] [epNameToRefAnn epName] [] "\x03\x49"
-  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 contract@Contract{..}
-    | _ :: Instr '[ 'TPair p g ] '[ 'TPair ('TList 'TOperation) g ] <- cCode ->
-    let contents = mapEntriesOrdered contract
-            (\np -> "\x05\x00" <> encodeParamNotes' @p np)
-            (\ng -> "\x05\x01" <> encodeNotedT' @g ng)
-            (\instr -> "\x05\x02" <> encodeInstrs instr)
-    in "\x05\x1d" <> encodeList id contents
-  IMPLICIT_ACCOUNT ->
-   "\x03\x1e"
-  NOW ->
-   "\x03\x40"
-  AMOUNT ->
-   "\x03\x13"
-  BALANCE ->
-   "\x03\x15"
-  VOTING_POWER ->
-   "\x03\x7b"
-  TOTAL_VOTING_POWER ->
-   "\x03\x7c"
-  CHECK_SIGNATURE ->
-   "\x03\x18"
-  SHA256 ->
-   "\x03\x0f"
-  SHA512 ->
-   "\x03\x10"
-  BLAKE2B ->
-   "\x03\x0e"
-  SHA3 ->
-   "\x03\x7e"
-  KECCAK ->
-   "\x03\x7d"
-  HASH_KEY ->
-   "\x03\x2b"
-  PAIRING_CHECK ->
-   "\x03\x7f"
-  SOURCE ->
-   "\x03\x47"
-  SENDER ->
-   "\x03\x48"
-  ADDRESS ->
-   "\x03\x54"
-  CHAIN_ID ->
-   "\x03\x75"
-  LEVEL ->
-   "\x03\x76"
-  SELF_ADDRESS ->
-   "\x03\x77"
-  NEVER ->
-   "\x03\x79"
-
-
--- | Iff there are non-empty annotations it increments the value's tag and
--- appends the encoded annotations.
-encodeWithAnns :: [TypeAnn] -> [FieldAnn] -> [VarAnn] -> LByteString -> LByteString
-encodeWithAnns tns fns vns encodedInput
-  | null encodedInput = encodedInput
-  | isNoAnnSet annSet = encodedInput
-  | otherwise = inputIncrem <> encodedAnns
-  where
-    annSet = fullAnnSet tns fns vns
-    encodedAnns = encodeAsList . encodeUtf8 $ show @Text annSet
-    inputIncrem = (1 + LBS.head encodedInput) `LBS.cons` LBS.tail encodedInput
-
--- | Encode an instruction with variable annotations
-encodeVarNotedInstr :: Instr inp out -> NonEmpty VarAnn -> LByteString -> LByteString
-encodeVarNotedInstr i vns'@(toList -> vns) encodedType = case i of
-  InstrWithNotes proxy n a -> encodeNotedInstr proxy a n vns
-  InstrWithVarAnns _ a -> encodeInstr $ InstrWithVarNotes vns' a
-  -- AnnPAIR, AnnCAR, AnnCDR and AnnLEFT, AnnRIGHT are checked here because
-  -- their cases on `encodeInstr` increment them to \x04 and to \x05 respectively
-  -- when they have a field annotation, but they would also get increment due to
-  -- variable annotations, resulting in incorrect \x05 and \x06 codes respectively.
-  AnnPAIR tn fn1 fn2 -> encodeWithAnns [tn] [fn1, fn2] vns "\x03\x42"
-  AnnCAR fn -> encodeWithAnns [] [fn] vns "\x03\x16"
-  AnnCDR fn -> encodeWithAnns [] [fn] vns "\x03\x17"
-  AnnLEFT tn fn1 fn2 -> encodeWithAnns [tn] [fn1, fn2] vns $ "\x05\x33" <> encodedType
-  AnnRIGHT tn fn1 fn2 -> encodeWithAnns [tn] [fn1, fn2] vns $ "\x05\x44" <> encodedType
-  _ -> encodeWithAnns [] [] vns $ encodeInstr i
-
--- | Encode an instruction with Annotations
-encodeNotedInstr
-  :: forall inp out topElems rest.
-     out ~ (topElems ++ rest)
-  => Proxy rest -> Instr inp out -> Rec Notes topElems -> [VarAnn] -> LByteString
-encodeNotedInstr proxy instr notes vns = case (instr, Proxy @out, notes) of
-  (WithLoc _ instr', _, _) ->
-    encodeNotedInstr proxy instr' notes vns
-  (SOME, _, NTOption tn _ns :& _) ->
-    encodeWithAnns [tn] [] vns $ encodeInstr instr
-  (NONE, _ :: Proxy ('TOption t ': s), NTOption tn ns :& _) ->
-    encodeWithAnns [tn] [] vns $ "\x05\x3e" <> encodeNotedT' @t ns
-  (UNIT, _, NTUnit tn :& _) ->
-    encodeWithAnns [tn] [] vns $ encodeInstr instr
-  (NIL, _ :: Proxy ('TList t ': s), NTList tn ns :& _) ->
-    encodeWithAnns [tn] [] vns $ "\x05\x3d" <> encodeNotedT' @t ns
-  (EMPTY_SET, _ :: Proxy ('TSet t ': s), NTSet tn ns :& _) ->
-    encodeWithAnns [tn] [] vns $ "\x05\x24" <> encodeNotedT' @t ns
-  (EMPTY_MAP, _ :: Proxy ('TMap k v ': s), NTMap tn1 nk ns :& _) ->
-    encodeWithAnns [tn1] [] vns $
-      "\x07\x23" <> encodeNotedT' @k nk <> encodeNotedT' @v ns
-  (EMPTY_BIG_MAP, _ :: Proxy ('TBigMap k v ': s), NTBigMap tn1 nk ns :& _) ->
-    encodeWithAnns [tn1] [] vns $
-      "\x07\x72" <> encodeNotedT' @k nk <> encodeNotedT' @v ns
-  (PUSH (v :: Value t), _, tn :& _) ->
-    "\x07\x43" <> encodeNotedT' @t 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), tn :& _) ->
-    "\x05\x57" <> encodeNotedT' @t tn
-  (UNPACK, _ :: Proxy ('TOption t ': s), NTOption tn ns :& _) ->
-    encodeWithAnns [tn] [] vns $ "\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 instr
-
-packNotedT' :: forall (t :: T). SingI t => Notes t -> ByteString
-packNotedT' = LBS.toStrict . encodeNotedT'
-
-encodeNotedT' :: forall (t :: T). SingI t => Notes t -> LByteString
-encodeNotedT' = encodeNotedST (sing @t) noAnn
-
-encodeParamNotes' ::
-  forall (t :: T). SingI t => ParamNotes t -> LByteString
-encodeParamNotes' ParamNotesUnsafe{..} = encodeNotedST (sing @t) pnRootAnn pnNotes
-
--- 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
-  (STInt, NTInt tn) ->
-    encodeWithAnns [tn] [fn] [] $ encodeT (fromSingT st)
-  (STNat, NTNat tn) ->
-    encodeWithAnns [tn] [fn] [] $ encodeT (fromSingT st)
-  (STString, NTString tn) ->
-    encodeWithAnns [tn] [fn] [] $ encodeT (fromSingT st)
-  (STBytes, NTBytes tn) ->
-    encodeWithAnns [tn] [fn] [] $ encodeT (fromSingT st)
-  (STMutez, NTMutez tn) ->
-    encodeWithAnns [tn] [fn] [] $ encodeT (fromSingT st)
-  (STBool, NTBool tn) ->
-    encodeWithAnns [tn] [fn] [] $ encodeT (fromSingT st)
-  (STKeyHash, NTKeyHash tn) ->
-    encodeWithAnns [tn] [fn] [] $ encodeT (fromSingT st)
-  (STBls12381Fr, NTBls12381Fr tn) ->
-    encodeWithAnns [tn] [fn] [] $ encodeT (fromSingT st)
-  (STBls12381G1, NTBls12381G1 tn) ->
-    encodeWithAnns [tn] [fn] [] $ encodeT (fromSingT st)
-  (STBls12381G2, NTBls12381G2 tn) ->
-    encodeWithAnns [tn] [fn] [] $ encodeT (fromSingT st)
-  (STTimestamp, NTTimestamp tn) ->
-    encodeWithAnns [tn] [fn] [] $ encodeT (fromSingT st)
-  (STAddress, NTAddress tn) ->
-    encodeWithAnns [tn] [fn] [] $ encodeT (fromSingT st)
-
-  (STKey, NTKey tn) ->
-    encodeWithAnns [tn] [fn] [] $ "\x03\x5c"
-  (STUnit, NTUnit tn) ->
-    encodeWithAnns [tn] [fn] [] $ "\x03\x6c"
-  (STNever, NTNever tn) ->
-    encodeWithAnns [tn] [fn] [] $ "\x03\x78"
-  (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 tn ns) ->
-    encodeWithAnns [tn] [fn] [] $ "\x05\x66" <> encodeNotedST a noAnn ns
-  (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 _vn1 _vn2 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 tn nk nv) ->
-    encodeWithAnns [tn] [fn] [] $
-      "\x07\x60" <> encodeNotedST k noAnn nk <> encodeNotedST v noAnn nv
-  (STBigMap k v, NTBigMap tn nk nv) ->
-    encodeWithAnns [tn] [fn] [] $
-      "\x07\x61" <> encodeNotedST k noAnn nk <> encodeNotedST v noAnn nv
-
-encodeT :: T -> LByteString
-encodeT = \case
-  TKey  -> "\x03\x5c"
-  TUnit -> "\x03\x6c"
-  TNever -> "\x03\x78"
-  TSignature -> "\x03\x67"
-  TChainId -> "\x03\x74"
-  TOption t -> "\x05\x63" <> encodeT t
-  TList t -> "\x05\x5f" <> encodeT t
-  TSet t -> "\x05\x66" <> encodeT t
-  TOperation -> "\x03\x6d"
-  TContract t -> "\x05\x5a" <> encodeT t
-  TPair a b -> "\x07\x65" <> encodeT a <> encodeT b
-  TOr a b -> "\x07\x64" <> encodeT a <> encodeT b
-  TLambda a r -> "\x07\x5e" <> encodeT a <> encodeT r
-  TMap k v -> "\x07\x60" <> encodeT k <> encodeT v
-  TBigMap k v -> "\x07\x61" <> encodeT k <> encodeT v
-  TInt -> "\x03" <> "\x5b"
-  TNat -> "\x03" <> "\x62"
-  TString -> "\x03" <> "\x68"
-  TBytes -> "\x03" <> "\x69"
-  TMutez -> "\x03" <> "\x6a"
-  TBool -> "\x03" <> "\x59"
-  TKeyHash -> "\x03" <> "\x5d"
-  TBls12381Fr -> "\x03" <> "\x82"
-  TBls12381G1 -> "\x03" <> "\x80"
-  TBls12381G2 -> "\x03" <> "\x81"
-  TTimestamp -> "\x03" <> "\x6b"
-  TAddress -> "\x03" <> "\x6e"
+packValue' x =
+  let uval = untypeValueHashable x
+  in packValuePrefix <> (encodeExpression' $ toExpression uval)
 
-encodeT' :: forall (t :: T). SingI t => LByteString
-encodeT' = encodeT (demote @t)
+-- | Prefix prepended to the binary representation of a value.
+packValuePrefix :: IsString s => s
+packValuePrefix = "\x05"
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
@@ -17,119 +17,25 @@
 -}
 module Michelson.Interpret.Unpack
   ( UnpackError (..)
-  , unpackValue
-  , unpackValue'
   , unpackInstr'
-
-  -- * Internals
-  , decodeContract
-  , decodeType
+  , unpackUValue'
+  , 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.Map as Map
-import qualified Data.Set as Set
-import Data.Singletons (Sing, SingI(..))
-import Data.Typeable ((:~:)(..))
-import Fmt (Buildable, Builder, fmt, hexF, padLeftF, pretty, (+|), (|+))
+import Fmt (pretty)
 
-import Michelson.Parser (Parser, ParserException(..), parseNoEnv)
-import qualified Michelson.Parser.Annotations as PA
-import Michelson.Text
-import Michelson.TypeCheck
-  (HST(..), SomeHST(..), SomeInstr(..), SomeInstrOut(..), TCError(..), TypeCheckEnv(..),
-  TypeCheckMode(..), TypeContext(..), withWTPm)
-import Michelson.TypeCheck.Helpers (ensureDistinctAsc, eqHST1)
-import Michelson.TypeCheck.Instr (typeCheckList)
-import Michelson.Typed (KnownT, RemFail(..), SingT(..), starNotes)
+import Michelson.Typed (UnpackedValScope)
 import qualified Michelson.Typed as T
-import Michelson.Typed.Entrypoints
-import Michelson.Typed.Scope (UnpackedValScope)
 import Michelson.Untyped
-import Tezos.Core
-import Tezos.Crypto hiding (sign)
-import qualified Tezos.Crypto.BLS12381 as BLS
+import qualified Michelson.Untyped as U
+import Morley.Micheline.Binary (eitherDecodeExpression)
+import Morley.Micheline.Class (FromExpression(..))
 import Util.Binary
-import Util.Num
 
-----------------------------------------------------------------------------
--- Helpers
-----------------------------------------------------------------------------
-
--- | Alias for label attaching.
-(?) :: Get a -> String -> Get a
-(?) = flip Get.label
-infix 0 ?
-
--- | Displays bytes sequence.
-bytesF :: [Word8] -> Builder
-bytesF bs = "0x" <> foldMap (padLeftF 2 '0' . hexF) bs
-
--- | 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 " +| bytesF [t] |+
-                   ", but got " +| bytesF [t'] |+ ")"
-
-
--- | 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: " <> bytesF [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.
-
--- | Read a byte indicating the number of arguments/annotations of
--- the primitive that follows it.
-decodeDescTag :: String -> Get Word8
-decodeDescTag desc =
-  Get.label desc
-    Get.getWord8
-
--- | 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
-
-----------------------------------------------------------------------------
--- Michelson serialisation
-----------------------------------------------------------------------------
-
 {- Implementation notes:
 
 * We need to know which exact type we unpack to.
@@ -152,823 +58,27 @@
 
 -- | Deserialize bytes into the given value.
 -- Suitable for @UNPACK@ operation only.
-unpackValue
-  :: (UnpackedValScope t)
-  => LByteString -> Either UnpackError (T.Value t)
-unpackValue = launchGet (finalizeDecoder decodeValue)
-
--- | Like 'unpackValue', for strict byte array.
 unpackValue'
-  :: (UnpackedValScope t)
+  :: forall t. (UnpackedValScope t)
   => ByteString -> Either UnpackError (T.Value t)
-unpackValue' = unpackValue . LBS.fromStrict
+unpackValue' = unpackImpl @(T.Value t)
+  where
+    _reallyNeedThisConstraint = Dict @(UnpackedValScope t)
 
 -- | Deserialize an instruction into the given value.
 unpackInstr' :: ByteString -> Either UnpackError [ExpandedOp]
-unpackInstr' = launchGet (finalizeDecoder decodeOps) . LBS.fromStrict
-
--- | Turn composable decoder into a final decoder which will be run over data.
-finalizeDecoder :: Get a -> Get a
-finalizeDecoder decoder =
-  expectTag "Packed data start" 0x05 *> decoder <* ensureEnd
-
-decodeValue
-  :: forall t.
-     (HasCallStack, UnpackedValScope t)
-  => Get (T.Value t)
-decodeValue = Get.label "Value" $
-  case sing @t of
-    STKey -> T.VKey <$> decodeAsBytesOrString
-      ( decodeWithTag "key" keyDecoders
-      , parsePublicKey
-      )
-    STUnit -> do
-      expectDescTag "Unit" 0
-      expectTag "Unit" 0x0B
-      return T.VUnit
-    STSignature -> T.VSignature <$> decodeAsBytesOrString
-      ( decodeBytesLikeMaybe "signature wrong size" mkSignature
-      , parseSignature
-      )
-    STChainId -> T.VChainId <$> decodeAsBytesOrString
-      ( decodeBytesLikeMaybe "chain_id wrong size" mkChainId
-      , 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 (st :: Sing st) -> withComparable st $ do
-      decodeAsList $ do
-        vals <- withUnpackedValueScope @st $ manyForced decodeValue
-        either (fail . toString) pure $
-          T.VSet . Set.fromDistinctAscList <$> ensureDistinctAsc id vals
-
-    STPair (_:: Sing lt) (r :: Sing rt) -> do
-      withUnpackedValueScope @rt $ do
-        decodeDescTag "Pair" >>= \case
-          0x07 -> do
-            -- "Normal" pair notation, e.g. `Pair 1 2` or `Pair 1 (Pair 2 3)`
-            expectTag "Pair" 0x07
-            T.VPair ... (,) <$> decodeValue <*> decodeValue
-          0x09 -> do
-            -- Right-combed notation, e.g. `Pair 1 2 3`
-            expectTag "Pair" 0x07
-
-            -- Find out how many bytes it took to encode the pair's elements, and decode them.
-            elemLen <- decodeLength ? "Right-combed pair length"
-            val <- Get.isolate elemLen (go @lt @rt r) ? "Right-combed pair elements"
-
-            -- Find out how many bytes it took to encode the pair's annotations - there should be no annotations.
-            (decodeLength ? "Right-combed pair annotations' length") >>= \case
-              0 -> pass
-              _ -> fail "Cannot decode values with annotations"
-            pure val
-          0x02 -> do
-            -- List notation, e.g. `{ 1 ; 2 ; 3 }`
-            elemLen <- decodeLength ? "Right-combed pair length"
-            Get.isolate elemLen (go @lt @rt r) ? "Right-combed pair elements"
-          tag -> fail . fmt $ "Unexpected preliminary tag: 0x" <> hexF tag
-      where
-        go :: forall l r. (UnpackedValScope l, UnpackedValScope r) => Sing r -> Get (T.Value ('T.TPair l r))
-        go singR =
-          case singR of
-            -- If there are more pairs to the right of the right-combed pair, decode them.
-            STPair (_ :: Sing rl) (singRR :: Sing rr) -> do
-              withUnpackedValueScope @rr $ do
-                T.VPair ... (,) <$> decodeValue @l <*> go @rl @rr singRR
-            _ ->
-              T.VPair ... (,) <$> decodeValue @l <*> decodeValue @r
-    STOr (_ :: Sing lt) _ ->
-      withUnpackedValueScope @lt $ do
-        expectDescTag "Or" 1
-        Get.getWord8 >>= \case
-          0x05 -> T.VOr . Left <$> decodeValue
-          0x08 -> T.VOr . Right <$> decodeValue
-          other -> unknownTag "or constructor" other
-    STLambda (_ :: Sing t1) (_ :: Sing t2) -> do
-      uinstr <- decodeOps
-      withWTPm @t2 $
-        withWTPm @t1 (T.VLam <$> decodeTypeCheckLam uinstr)
-    STMap (st :: Sing st) (_ :: Sing sv) ->
-      withUnpackedValueScope @st $
-        withComparable st $ T.VMap <$> decodeMap
-
-    STInt -> T.VInt <$> decodeTaggedInt "Int"
-    STNat -> T.VNat <$> decodeTaggedInt "Nat"
-    STString -> do
-      expectTag "String" 0x01
-      T.VString <$> decodeString
-    STBytes -> do
-      expectTag "Bytes" 0x0a
-      T.VBytes <$> decodeBytes
-    STMutez -> do
-      mmutez <- mkMutez <$> decodeTaggedInt "Mutez"
-      maybe (fail "Negative mutez") (pure . T.VMutez) mmutez
-    STBool -> do
-      expectDescTag "Bool" 0
-      Get.getWord8 >>= \case
-        0x0A -> pure (T.VBool True)
-        0x03 -> pure (T.VBool False)
-        other -> unknownTag "bool" other
-    STKeyHash -> T.VKeyHash <$> decodeAsBytesOrString
-      ( decodeWithTag "key_hash" keyHashDecoders
-      , parseKeyHash
-      )
-    STBls12381Fr -> fmap T.VBls12381Fr $
-      Get.label "bls12_381_fr" $ Get.getWord8 >>= \case
-        0x0A -> decodeBls12Bytes
-        0x00 -> fromInteger <$> decodeInt
-        other -> unknownTag "bytes or int" other
-    STBls12381G1 -> do
-      expectTag "Bls12381G1 bytes" 0x0A
-      T.VBls12381G1 <$> decodeBls12Bytes
-    STBls12381G2 -> do
-      expectTag "Bls12381G2 bytes" 0x0A
-      T.VBls12381G2 <$> decodeBls12Bytes
-    STTimestamp -> Get.label "Timestamp" $ Get.getWord8 >>= \case
-      0x00 -> do
-        T.VTimestamp . timestampFromSeconds <$> decodeInt
-      0x01 -> do
-        str <- decodeString
-        maybe (fail $ toString $ "failed to parse timestamp from " <> unMText str)
-          (pure . T.VTimestamp) $ parseTimestamp $ unMText str
-      other -> unknownTag "int or string" other
-    STAddress ->
-      T.VAddress <$> decodeAsBytesOrString
-      ( decodeBytesLike "EpAddress" parseEpAddressRaw
-      , parseEpAddress
-      )
-    STNever -> fail $ "cannot decode to `never` type"
-
-
-withUnpackedValueScope
-  :: forall a v m. (KnownT a, MonadFail m)
-  => (T.UnpackedValScope a => m v)
-  -> m v
-withUnpackedValueScope act = case T.checkScope @(T.UnpackedValScope a) of
-  Right Dict -> act
-  _ -> fail "Unpackable value is required here"
-
-withComparable
-  :: forall a v m. (MonadFail m)
-  => Sing a
-  -> (T.Comparable a => m v)
-  -> m v
-withComparable a act = case T.getComparableProofS a of
-  Just Dict -> act
-  Nothing -> fail "Comparable type is required here"
-
--- | 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.
-  fromIntegralChecked len
-    & either (fail . toString) pure
-    ? "Length"
-
-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"
-
-decodeAsBytesRaw :: (Int -> Get a) -> Get a
-decodeAsBytesRaw decode = do
-  l <- decodeLength ? "Byte array length"
-  decode l
-
-decodeAsBytesOrString :: Buildable e => (Get a, Text -> Either e a) -> Get a
-decodeAsBytesOrString (bytesDecoder, strParser) =
-  Get.getWord8 >>= \case
-    0x01 -> do
-      str <- decodeString
-      either (fail . pretty) pure $ strParser $ unMText str
-    0x0A -> do
-      decodeAsBytesRaw $ \l ->
-        Get.isolate l bytesDecoder ? "Binary content"
-    other -> unknownTag "text or string" other
-
-
-decodeBytesLikeMaybe
-  :: String -> (ByteString -> Maybe a) -> Get a
-decodeBytesLikeMaybe onErr constructor = do
-  bs <- getRemainingByteStringCopy
-  case constructor bs of
-    Nothing -> fail onErr
-    Just res -> pure res
-
-decodeBytes :: Get ByteString
-decodeBytes =
-  decodeAsBytesRaw $ Get.label "Bytes payload" . getByteStringCopy
-
-decodeBls12Bytes :: BLS.CurveObject a => Get a
-decodeBls12Bytes = do
-  bs <- decodeBytes
-  BLS.fromMichelsonBytes bs
-    & either (fail . pretty) pure
-
-decodeMap
-  :: forall k v.(UnpackedValScope k, UnpackedValScope v)
-  => Get $ Map (T.Value k) (T.Value v)
-decodeMap = withComparable (sing @k) $ Get.label "Map" $
-  decodeAsList $ do
-    es <- manyForced $ do
-      expectDescTag "Elt" 2
-      expectTag "Elt" 0x04
-      (,) <$> decodeValue <*> decodeValue
-    either (fail . toString) pure $
-      Map.fromDistinctAscList <$> ensureDistinctAsc fst es
-
--- | An integral expression always appears tagged with 0x00.
--- This function reads the tag, discards it, and reads the int that follows it.
-decodeTaggedInt :: (Integral i, Bits.Bits i) => String -> Get i
-decodeTaggedInt label =
-  expectTag label 0x00 *> decodeInt
-
--- | Read a numeric value.
-decodeInt :: (Integral i, Bits.Bits i) => Get i
-decodeInt = (Bits.toIntegralSized @Integer <$> loop 0 0 ? "Number")
-            >>= maybe (fail "Value doesn't satisfy type ranges") pure
-  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
-
--- | Type check instruction occurred from a lambda.
-decodeTypeCheckLam
-  :: forall inp out m.
-     (T.WellTyped inp, T.WellTyped out, MonadFail m)
-  => [ExpandedOp]
-  -> m (RemFail T.Instr '[inp] '[out])
-decodeTypeCheckLam uinstr =
-  either tcErrToFail pure . run $ do
-    let inp = (starNotes, Dict, 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 = Ty TUnit noAnn
-                tout = Ty TUnit noAnn
-            in throwError $
-              TCFailedOnInstr (LAMBDA noAnn tinp tout uinstr) (SomeHST inp) def
-              (Just LambdaCode) (Just err)
-      AnyOutInstr instr ->
-        return $ RfAlwaysFails instr
-  where
-    run = evaluatingState tcInitEnv . runExceptT . usingReaderT def
-    tcErrToFail err = fail $ "Type check failed: " +| err |+ ""
-    tcInitEnv =
-      TypeCheckEnv
-      { tcExtFrames = error "runInstrImpl(UNPACK): tcExtFrames touched"
-        --- ^ This is safe because @UNPACK@ never produces Ext instructions
-      , tcMode = TypeCheckPack
-      }
-
-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 <$> decodeTaggedInt "'DROP n' parameter"
-    (0x03, 0x21) -> DUP <$> decodeNoAnn
-    (0x05, 0x21) -> DUPN <$> decodeNoAnn <*> (expectTag "'DUP n' parameter" 0x00 *> decodeInt)
-    (0x03, 0x4C) -> pure $ SWAP
-    (0x05, 0x70) -> DIG <$> decodeTaggedInt "'DIG n' parameter"
-    (0x05, 0x71) -> DUG <$> decodeTaggedInt "'DUG n' parameter"
-    (0x07, 0x43) -> do
-      (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 <$> decodeNoAnn <*> decodeNoAnn <*> decodeNoAnn <*> decodeNoAnn
-    (0x05, 0x42) -> do
-      n <- decodeTaggedInt "'PAIR n' parameter"
-      varAnn <- decodeNoAnn
-      pure $ PAIRN varAnn n
-    (0x05, 0x7a) -> UNPAIRN <$> decodeTaggedInt "'UNPAIR n' parameter"
-    (0x03, 0x16) -> CAR <$> decodeNoAnn <*> decodeNoAnn
-    (0x03, 0x17) -> CDR <$> decodeNoAnn <*> decodeNoAnn
-    (0x05, 0x33) -> LEFT <$> decodeNoAnn <*> decodeNoAnn <*> decodeNoAnn <*> decodeNoAnn
-                         <*> decodeType
-    (0x05, 0x44) -> RIGHT <$> decodeNoAnn <*> decodeNoAnn <*> decodeNoAnn <*> decodeNoAnn
-                          <*> decodeType
-    (0x07, 0x2E) -> IF_LEFT <$> decodeOps  <*> decodeOps
-    (0x05, 0x3D) -> NIL <$> decodeNoAnn <*> decodeNoAnn <*> decodeType
-    (0x03, 0x1B) -> CONS <$> decodeNoAnn
-    (0x07, 0x2D) -> IF_CONS <$> decodeOps  <*> decodeOps
-    (0x03, 0x45) -> SIZE <$> decodeNoAnn
-    (0x05, 0x24) -> EMPTY_SET <$> decodeNoAnn <*> decodeNoAnn <*> decodeComparable
-    (0x07, 0x23) -> EMPTY_MAP <$> decodeNoAnn <*> decodeNoAnn <*> decodeComparable
-                              <*> decodeType
-    (0x07, 0x72) -> EMPTY_BIG_MAP <$> decodeNoAnn <*> decodeNoAnn <*> decodeComparable
-                                  <*> decodeType
-    (0x05, 0x38) -> MAP <$> decodeNoAnn <*> decodeOps
-    (0x05, 0x52) -> ITER <$> decodeOps
-    (0x03, 0x39) -> MEM <$> decodeNoAnn
-    (0x03, 0x29) -> GET <$> decodeNoAnn
-    (0x05, 0x29) -> GETN <$> decodeNoAnn <*> decodeTaggedInt "'GET n' parameter"
-    (0x03, 0x50) -> UPDATE <$> decodeNoAnn
-    (0x05, 0x50) -> UPDATEN <$> decodeNoAnn <*> decodeTaggedInt "'UPDATE n' parameter"
-    (0x03, 0x8c) -> GET_AND_UPDATE <$> decodeNoAnn
-    (0x07, 0x2C) -> IF <$> decodeOps  <*> decodeOps
-    (0x05, 0x34) -> LOOP <$> decodeOps
-    (0x05, 0x53) -> LOOP_LEFT <$> decodeOps
-    (0x09, 0x31) -> do
-      (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 <$> decodeTaggedInt "'DIP n' parameter" <*> decodeOps
-    (0x03, 0x27) -> pure FAILWITH
-    (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, 0x7b) -> VOTING_POWER <$> decodeNoAnn
-    (0x03, 0x7c) -> TOTAL_VOTING_POWER <$> decodeNoAnn
-    (0x03, 0x18) -> CHECK_SIGNATURE <$> decodeNoAnn
-    (0x03, 0x0F) -> SHA256 <$> decodeNoAnn
-    (0x03, 0x10) -> SHA512 <$> decodeNoAnn
-    (0x03, 0x0E) -> BLAKE2B <$> decodeNoAnn
-    (0x03, 0x7E) -> SHA3 <$> decodeNoAnn
-    (0x03, 0x7D) -> KECCAK <$> decodeNoAnn
-    (0x03, 0x2B) -> HASH_KEY <$> decodeNoAnn
-    (0x03, 0x7F) -> PAIRING_CHECK <$> decodeNoAnn
-    (0x03, 0x47) -> SOURCE <$> decodeNoAnn
-    (0x03, 0x48) -> SENDER <$> decodeNoAnn
-    (0x03, 0x49) -> SELF <$> decodeNoAnn <*> decodeNoAnn
-    (0x03, 0x54) -> ADDRESS <$> decodeNoAnn
-    (0x03, 0x75) -> CHAIN_ID <$> decodeNoAnn
-    (0x03, 0x76) -> LEVEL <$> decodeNoAnn
-    (0x03, 0x77) -> SELF_ADDRESS <$> decodeNoAnn
-    (0x03, 0x79) -> pure $ NEVER
-    -- Instructions with annotations from here on
-    (0x04, 0x21) -> DUP <$> decodeVAnn
-    (0x06, 0x21) -> flip DUPN <$> (expectTag "'DUP n' parameter" 0x00 *> decodeInt) <*> 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
-    (0x06, 0x42) -> do
-      n <- decodeTaggedInt "'PAIR n' parameter"
-      varAnn <- decodeVAnn
-      pure $ PAIRN varAnn n
-    (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
-    (0x06, 0x29) -> do
-      n <- decodeTaggedInt "'GET n' parameter"
-      varAnn <- decodeVAnn
-      pure $ GETN varAnn n
-    (0x04, 0x50) -> UPDATE <$> decodeVAnn
-    (0x06, 0x50) -> do
-      n <- decodeTaggedInt "'UPDATE n' parameter"
-      varAnn <- decodeVAnn
-      pure $ UPDATEN varAnn n
-    (0x04, 0x8c) -> GET_AND_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, 0x7b) -> VOTING_POWER <$> decodeVAnn
-    (0x04, 0x7c) -> TOTAL_VOTING_POWER <$> decodeVAnn
-    (0x04, 0x18) -> CHECK_SIGNATURE <$> decodeVAnn
-    (0x04, 0x0F) -> SHA256 <$> decodeVAnn
-    (0x04, 0x10) -> SHA512 <$> decodeVAnn
-    (0x04, 0x0E) -> BLAKE2B <$> decodeVAnn
-    (0x04, 0x7E) -> SHA3 <$> decodeVAnn
-    (0x04, 0x7D) -> KECCAK <$> decodeVAnn
-    (0x04, 0x2B) -> HASH_KEY <$> decodeVAnn
-    (0x04, 0x7F) -> PAIRING_CHECK <$> decodeVAnn
-    (0x04, 0x47) -> SOURCE <$> decodeVAnn
-    (0x04, 0x48) -> SENDER <$> decodeVAnn
-    (0x04, 0x49) -> decodeWithVFAnns SELF
-    (0x04, 0x54) -> ADDRESS <$> decodeVAnn
-    (0x04, 0x75) -> CHAIN_ID <$> decodeVAnn
-    (0x04, 0x76) -> LEVEL <$> decodeVAnn
-    (0x04, 0x77) -> SELF_ADDRESS <$> decodeVAnn
-    (other1, other2) -> fail $ "Unknown instruction tag: " +|
-                        bytesF [other1, other2]
-
-decodePushVal :: Get (Ty, Value)
-decodePushVal = do
-  typ <- decodeType
-  T.withSomeSingT (T.fromUType typ) $ \(_ :: Sing t) ->
-    case T.checkScope @(T.ConstantScope t) of
-      Left bt -> fail $ "Type can not appear in PUSH because it " <> pretty bt
-      Right Dict -> do
-        tval <- decodeValue @t
-        pure $ (typ, T.untypeValue tval)
-
-decodeContract :: Get Contract
-decodeContract = decodeAsList $ do
-  result <- contractTuple
-  case orderContractBlock result of
-    Just contract' -> do
-      pure contract'
-    Nothing ->
-      fail "Duplicate contract field."
-  where
-    decodeParamsBlock = CBParam <$> do
-      expectTag "Pre contract parameter" 0x05
-      expectTag "Contract parameter" 0x00
-      (t, ta, root) <- decodeTWithAnns
-      pure $ ParameterType (Ty t ta) root
-    decodeStorageBlock = CBStorage <$> do
-      expectTag "Pre contract storage" 0x05
-      expectTag "Contract storage" 0x01
-      decodeType
-    decodeCodeBlock = CBCode <$> do
-      expectTag "Pre contract code" 0x05
-      expectTag "Contract code" 0x02
-      decodeOps
-
-    contractBlock = decodeParamsBlock <|> decodeStorageBlock <|> decodeCodeBlock
-
-    contractTuple = do
-      result1 <- contractBlock
-      result2 <- contractBlock
-      result3 <- contractBlock
-      pure (result1, result2, result3)
-
-
-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 Ty
-decodeComparable = do
-  (ct, tAnn, fAnn) <- decodeComparableTWithAnns
-  if fAnn == noAnn
-    then pure $ Ty ct tAnn
-    else fail "This Comparable should not have a Field annotation"
-
-decodeType :: Get Ty
-decodeType = do
-  (t, tAnn, fAnn) <- decodeTWithAnns
-  if fAnn == noAnn
-    then pure $ Ty t tAnn
-    else fail "This Type should not have a Field annotation"
-
-decodeComparableTWithAnns :: Get (T, TypeAnn, FieldAnn)
-decodeComparableTWithAnns = Get.label "Comparable primitive type" $ do
-  pretag <- Get.getWord8 ? "Pre simple comparable type tag"
-  tag <- Get.getWord8 ? "Simple comparable type tag"
-  let failMessage = "Unknown primitive tag: " +| bytesF [pretag, tag]
-  ct <- case tag of
-    0x6C -> pure TUnit
-    0x5B -> pure TInt
-    0x62 -> pure TNat
-    0x68 -> pure TString
-    0x69 -> pure TBytes
-    0x6A -> pure TMutez
-    0x59 -> pure TBool
-    0x5C -> pure TKey
-    0x5D -> pure TKeyHash
-    0x67 -> pure TSignature
-    0x6B -> pure TTimestamp
-    0x6E -> pure TAddress
-    0x74 -> pure TChainId
-    0x63 -> TOption <$> decodeType
-    0x65 ->
-      case pretag of
-        0x07 -> decodeTPair
-        0x08 -> decodeTPair
-        0x09 -> decodeTPairN
-        _ -> fail failMessage
-    0x64 -> decodeTOr
-    _ -> fail failMessage
-  case pretag of
-    0x03 -> (ct,,) <$> decodeNoAnn <*> decodeNoAnn
-    0x04 -> decodeWithTFAnns (ct,,)
-    0x05 ->
-      case tag of
-        0x63 -> (ct,,) <$> decodeNoAnn <*> decodeNoAnn
-        _    -> decodeWithTFAnns (ct,,)
-    0x06 -> decodeWithTFAnns (ct,,)
-    0x07 -> (ct,,) <$> decodeNoAnn <*> decodeNoAnn
-    0x08 -> decodeWithTFAnns (ct,,)
-    0x09 -> decodeWithTFAnns (ct,,)
-    _ -> fail failMessage
-
-{-# ANN decodeTWithAnns ("HLint: ignore Redundant <$>" :: Text) #-}
-decodeTWithAnns :: Get (T, TypeAnn, FieldAnn)
-decodeTWithAnns = doDecode <|> decodeComparableTWithAnns ? "Type"
-  where
-    doDecode = do
-      pretag <- Get.getWord8 ? "Pre complex type tag"
-      tag <- Get.getWord8 ? "Complex type tag"
-      case (pretag, tag) of
-        (0x03, 0x5C) ->
-          (,,) <$> pure TKey <*> decodeNoAnn <*> decodeNoAnn
-        (0x03, 0x6C) ->
-          (,,) <$> pure TUnit <*> decodeNoAnn <*> decodeNoAnn
-        (0x03, 0x78) ->
-          (,,) <$> pure TNever <*> decodeNoAnn <*> decodeNoAnn
-        (0x03, 0x67) ->
-          (,,) <$> pure TSignature <*> decodeNoAnn <*> decodeNoAnn
-        (0x03, 0x74) ->
-          (,,) <$> pure TChainId <*> decodeNoAnn <*> decodeNoAnn
-        (0x03, 0x82) ->
-          (,,) <$> pure TBls12381Fr <*> decodeNoAnn <*> decodeNoAnn
-        (0x03, 0x80) ->
-          (,,) <$> pure TBls12381G1 <*> decodeNoAnn <*> decodeNoAnn
-        (0x03, 0x81) ->
-          (,,) <$> pure TBls12381G2 <*> 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, 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, 0x78) -> decodeWithTFAnns (TNever,,)
-        (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, 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: " +|
-                            bytesF [other1, other2]
-
--- | "Normal" pair notation, e.g. `pair int int` or `pair int (pair int int)`
---
--- The pair type doesn't really carry its nested variable annotations, except
--- during execution. For this reason, they don't get decoded here and these
--- variable annotations fields will be empty. See !763 for more context.
-decodeTPair :: Get T
-decodeTPair = do
-  (t1, tAnn1, fAnn1) <- decodeTWithAnns
-  (t2, tAnn2, fAnn2) <- decodeTWithAnns
-  pure $ TPair fAnn1 fAnn2 noAnn noAnn (Ty t1 tAnn1) (Ty t2 tAnn2)
-
--- | Right-combed notation, e.g. `pair int int int`
---
--- Just like 'decodeTPair', nested variable annotations are not decoded, as they
--- exist only during execution. See !763 for more context.
-decodeTPairN :: Get T
-decodeTPairN = do
-  -- Find out how many bytes it took to encode the pair's fields, and decode them.
-  fieldsLen <- decodeLength ? "'pair' number of type arguments"
-  fields <- Get.isolate fieldsLen (manyForced decodeTWithAnns) ? "'pair' type arguments"
-  go fields
-  where
-    go :: [(T, TypeAnn, FieldAnn)] -> Get T
-    go = \case
-      [] -> fail "The 'pair' type expects at least 2 type arguments, but 0 were given."
-      [(t, _, _)] -> fail $ "The 'pair' type expects at least 2 type arguments, but only 1 was given: '" <> pretty t <> "'."
-      [(t1, tAnn1, fAnn1), (t2, tAnn2, fAnn2)] ->
-        pure $ TPair fAnn1 fAnn2 noAnn noAnn (Ty t1 tAnn1) (Ty t2 tAnn2)
-      (t1, t1Ann1, fAnn1) : fields -> do
-        rightCombedT <- go fields
-        pure $ TPair fAnn1 noAnn noAnn noAnn (Ty t1 t1Ann1) (Ty rightCombedT noAnn)
-
-decodeTOr :: Get T
-decodeTOr = do
-  (t1, tAnn1, fAnn1) <- decodeTWithAnns
-  (t2, tAnn2, fAnn2) <- decodeTWithAnns
-  pure $ TOr fAnn1 fAnn2 (Ty t1 tAnn1) (Ty t2 tAnn2)
-
-----------------------------------------------------------------------------
--- Annotations
-----------------------------------------------------------------------------
-
--- | Utility function to fill a constructor with an empty annotation
-decodeNoAnn :: forall (t :: 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.noteDef
-
-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
+unpackInstr' = unpackImpl @([ExpandedOp])
 
-decodeWithV2Anns :: (VarAnn -> VarAnn -> a) -> Get a
-decodeWithV2Anns f = do
-  (vAnn1, vAnn2) <- decodeAnns PA.noteV2Def
-  pure $ f vAnn1 vAnn2
+-- | Deserialize bytes into 'Untyped.Value'.
+unpackUValue' :: ByteString -> Either UnpackError U.Value
+unpackUValue' = unpackImpl @U.Value
 
-decodeWithVFAnns :: (VarAnn -> FieldAnn -> a) -> Get a
-decodeWithVFAnns f = do
-  (vAnn, fAnn) <- decodeAnns PA.notesVF
-  pure $ f vAnn fAnn
+unpackImpl :: forall t. (FromExpression t)
+           => ByteString
+           -> Either UnpackError t
+unpackImpl bs = do
+  (tag, bs') <- maybeToRight (UnpackError "Empty bytes") (BS.uncons bs)
+  when (tag /= 0x05) . Left . UnpackError $
+    "Unexpected tag: '" <> (show tag) <> "'. '0x05' tag expected."
+  expr <- eitherDecodeExpression bs'
+  either (Left . UnpackError . pretty) Right $ fromExpression @t expr
diff --git a/src/Michelson/Macro.hs b/src/Michelson/Macro.hs
--- a/src/Michelson/Macro.hs
+++ b/src/Michelson/Macro.hs
@@ -25,7 +25,6 @@
 
     -- * For parsing
   , mapPairLeaves
-  , mapUnpairLeaves
 
     -- * Internals exported for tests
   , expand
@@ -74,7 +73,7 @@
   build = genericF
 
 data UnpairStruct
-  = UF (VarAnn, FieldAnn)
+  = UF
   | UP UnpairStruct UnpairStruct
   deriving stock (Eq, Show, Data, Generic)
 
@@ -139,7 +138,7 @@
   | IFCMP ParsedInstr VarAnn [ParsedOp] [ParsedOp]
   | FAIL
   | PAPAIR PairStruct TypeAnn VarAnn
-  | UNPAIR UnpairStruct
+  | UNPAPAIR UnpairStruct
   | CADR [CadrStruct] VarAnn FieldAnn
   | CARN VarAnn Word
   | CDRN VarAnn Word
@@ -172,7 +171,7 @@
     IFCMP parsedInstr varAnn parsedOps1 parsedOps2 -> "<IFCMP: "+|parsedInstr|+", "+|varAnn|+", "+|parsedOps1|+", "+|parsedOps2|+">"
     FAIL -> "FAIL"
     PAPAIR pairStruct typeAnn varAnn -> "<PAPAIR: "+|pairStruct|+", "+|typeAnn|+", "+|varAnn|+">"
-    UNPAIR pairStruct -> "<UNPAIR: "+|pairStruct|+">"
+    UNPAPAIR pairStruct -> "<UNPAPAIR: "+|pairStruct|+">"
     CADR cadrStructs varAnn fieldAnn -> "<CADR: "+|cadrStructs|+", "+|varAnn|+", "+|fieldAnn|+">"
     CARN varAnn idx -> "<CAR: #"+||idx||+","+||varAnn||+">"
     CDRN varAnn idx -> "<CDR: #"+||idx||+","+||varAnn||+">"
@@ -248,9 +247,9 @@
 
 expandMacro :: InstrCallStack -> Macro -> [ExpandedOp]
 expandMacro p@InstrCallStack{icsCallStack=cs,icsSrcPos=macroPos} = \case
-  VIEW a             -> expandMacro p (UNPAIR $ UP (UF (noAnn, noAnn)) (UF (noAnn, noAnn))) ++
-                        [ PrimEx (DIP $ oprimEx $ DUPN noAnn 2) ] ++
-                        [ PrimEx $ PAIR noAnn noAnn noAnn noAnn ] ++
+  VIEW a             -> [ PrimEx (UNPAIR noAnn noAnn noAnn noAnn)
+                        , PrimEx (DIP $ oprimEx $ DUPN noAnn 2)
+                        , PrimEx $ PAIR noAnn noAnn noAnn noAnn ] ++
                         (expand cs <$> a) ++
                         [ PrimEx (DIP [PrimEx $ AMOUNT noAnn])
                         , PrimEx $ TRANSFER_TOKENS noAnn
@@ -259,8 +258,8 @@
                         , PrimEx $ CONS noAnn
                         , PrimEx $ PAIR noAnn noAnn noAnn noAnn
                         ]
-  VOID a             -> expandMacro p (UNPAIR (UP (UF (noAnn, noAnn)) (UF (noAnn, noAnn)))) ++
-                        [ PrimEx SWAP
+  VOID a             -> [ PrimEx (UNPAIR noAnn noAnn noAnn noAnn)
+                        , PrimEx SWAP
                         , PrimEx $ DIP $ expand cs <$> a
                         , PrimEx SWAP
                         , PrimEx $ EXEC noAnn
@@ -285,7 +284,7 @@
   ASSERT_LEFT        -> oprimEx $ IF_LEFT [] (expandMacro p FAIL)
   ASSERT_RIGHT       -> oprimEx $ IF_LEFT (expandMacro p FAIL) []
   PAPAIR ps t v      -> expandPapair p ps t v
-  UNPAIR ps          -> expandUnpapair p ps
+  UNPAPAIR ps        -> expandUnpapair p ps
   CADR c v f         -> expandCadr p c v f
   CARN v idx         -> [PrimEx (GETN v (2 * idx + 1))]
   CDRN v idx         -> [PrimEx (GETN v (2 * idx))]
@@ -301,50 +300,58 @@
     xo = PrimEx . fmap (expand cs)
     xp = fmap (expand cs)
 
--- the correctness of type-annotation expansion is currently untested, as these
--- expansions are not explicitly documented in the Michelson Specification
+-- | The macro expansion rules below were taken from: https://tezos.gitlab.io/008/michelson.html#syntactic-conveniences
+--
+-- The correctness of type-annotation expansion is currently untested, as these
+-- expansions are not explicitly documented in the Michelson Specification.
 expandPapair :: InstrCallStack -> PairStruct -> TypeAnn -> VarAnn -> [ExpandedOp]
 expandPapair ics ps t v = case ps of
   P (F a) (F b) -> [PrimEx $ PAIR t v a b]
+
+  -- > PA(\right)R / S => DIP ((\right)R) ; PAIR / S
   P (F a) r     -> PrimEx <$> [ DIP $ expandMacro ics (PAPAIR r noAnn noAnn)
                               , PAIR t v a noAnn]
+
+  -- > P(\left)IR / S => (\left)R ; PAIR / S
   P l     (F b) -> expandMacro ics (PAPAIR l noAnn noAnn) ++
                    [PrimEx $ PAIR t v noAnn b]
+
+  -- > P(\left)(\right)R =>  (\left)R ; DIP ((\right)R) ; PAIR / S
   P l     r     -> expandMacro ics (PAPAIR l noAnn noAnn) ++
                    [ PrimEx $ DIP $ expandMacro ics (PAPAIR r noAnn noAnn)
                    , PrimEx $ PAIR t v noAnn noAnn]
-  F _           -> [] -- Do nothing in this case.
+
   -- It's impossible from the structure of PairStruct and considered cases above,
   -- but if it accidentally happened let's just do nothing.
+  F _           -> []
 
+-- | The macro expansion rules below were taken from: https://tezos.gitlab.io/008/michelson.html#syntactic-conveniences
 expandUnpapair :: InstrCallStack -> UnpairStruct -> [ExpandedOp]
 expandUnpapair ics = \case
-  UP (UF (v,f)) (UF (w,g)) ->
-    PrimEx <$> [ DUP noAnn
-               , CAR v f
-               , DIP [PrimEx $ CDR w g]
-               ]
-  UP (UF (v, f)) r ->
-    PrimEx <$> [ DUP noAnn
-               , CAR v f
-               , DIP (PrimEx (CDR noAnn noAnn) : expandMacro ics (UNPAIR r))
+  UP UF UF ->
+    [ PrimEx (UNPAIR noAnn noAnn noAnn noAnn) ]
+
+  -- > UNPA(\right)R / S => UNPAIR ; DIP (UN(\right)R) / S
+  UP UF r ->
+    PrimEx <$> [ UNPAIR noAnn noAnn noAnn noAnn
+               , DIP (expandMacro ics (UNPAPAIR r))
                ]
-  UP l (UF (v, f)) ->
-    map PrimEx [ DUP noAnn
-               , DIP [PrimEx $ CDR v f]
-               , CAR noAnn noAnn
-               ] ++
-               expandMacro ics (UNPAIR l)
+
+  -- > UNP(\left)IR / S => UNPAIR ; UN(\left)R / S
+  UP l UF ->
+    PrimEx (UNPAIR noAnn noAnn noAnn noAnn)
+      : expandMacro ics (UNPAPAIR l)
+
+  -- > UNP(\left)(\right)R => UNPAIR ; DIP (UN(\right)R) ; UN(\left)R / S
   UP l r ->
-    expandMacro ics unpairOne ++
-    [PrimEx $ DIP $ expandMacro ics $ UNPAIR r] ++
-    expandMacro ics (UNPAIR l)
-  UF _  -> [] -- Do nothing in this case.
+    [ PrimEx (UNPAIR noAnn noAnn noAnn noAnn)
+    , PrimEx $ DIP $ expandMacro ics $ UNPAPAIR r
+    ] ++
+    expandMacro ics (UNPAPAIR l)
+
   -- It's impossible from the structure of UnpairStruct and considered cases above,
   -- but if it accidentally happened let's just do nothing.
-  where
-    unpairOne = UNPAIR (UP fn fn)
-    fn = UF (noAnn, noAnn)
+  UF -> []
 
 expandCadr :: InstrCallStack -> [CadrStruct] -> VarAnn -> FieldAnn -> [ExpandedOp]
 expandCadr ics cs v f = case cs of
@@ -455,22 +462,6 @@
     where
       getLeaf (a:as) = (a, as)
       getLeaf _      = (noAnn, [])
-
-mapUnpairLeaves :: [(VarAnn, FieldAnn)] -> UnpairStruct -> UnpairStruct
-mapUnpairLeaves fs p = evalState (unpairLeavesST p) fs
-
-unpairLeavesST :: UnpairStruct -> State [(VarAnn, FieldAnn)] UnpairStruct
-unpairLeavesST = \case
-  (UP l r) -> do
-    l' <- unpairLeavesST l
-    r' <- unpairLeavesST r
-    return $ UP l' r'
-  (UF _) -> do
-    f <- state getLeaf
-    return $ UF f
-    where
-      getLeaf (a:as) = (a, as)
-      getLeaf _      = ((noAnn, noAnn), [])
 
 deriveJSON morleyAesonOptions ''ParsedOp
 deriveJSON morleyAesonOptions ''LetMacro
diff --git a/src/Michelson/Optimizer.hs b/src/Michelson/Optimizer.hs
--- a/src/Michelson/Optimizer.hs
+++ b/src/Michelson/Optimizer.hs
@@ -46,7 +46,7 @@
 import Michelson.Typed.T
 import Michelson.Typed.Util (DfsSettings(..), dfsInstr)
 import Michelson.Typed.Value
-import Util.Peano (SingNat(..))
+import Util.PeanoNatural
 
 ----------------------------------------------------------------------------
 -- High level
@@ -98,6 +98,8 @@
 defaultRules =
   flattenSeqLHS
     `orSimpleRule` removeNesting
+    `orSimpleRule` removeExtStackType
+    `orSimpleRule` flattenFn
     `orSimpleRule` dipDrop2swapDrop
     `orSimpleRule` ifNopNop2Drop
     `orSimpleRule` nopIsNeutralForSeq
@@ -134,9 +136,20 @@
   Nested i -> Just i
   _        -> Nothing
 
+-- | STACKTYPE is currently a Nop and may safely be removed.
+removeExtStackType :: Rule
+removeExtStackType = \case
+  Ext (STACKTYPE{}) -> Just Nop
+  _                 -> Nothing
+
+flattenFn :: Rule
+flattenFn = \case
+  Fn _ _ i -> Just i
+  _        -> Nothing
+
 dipDrop2swapDrop :: Rule
 dipDrop2swapDrop = \case
-  DIP DROP -> Just $ Seq SWAP DROP
+  DIP DROP -> Just $ SWAP :# DROP
   _        -> Nothing
 
 ifNopNop2Drop :: Rule
@@ -146,99 +159,99 @@
 
 nopIsNeutralForSeq :: Rule
 nopIsNeutralForSeq = \case
-  Seq Nop i  -> Just i
-  Seq i Nop  -> Just i
+  Nop :# i   -> Just i
+  i   :# Nop -> Just i
   _          -> Nothing
 
 variousNops :: Rule
 variousNops = \case
-  Seq  SWAP    (Seq SWAP c) -> Just c
-  Seq (PUSH _) (Seq DROP c) -> Just c
-  Seq  DUP     (Seq DROP c) -> Just c
-  Seq  UNIT    (Seq DROP c) -> Just c
-  Seq  NOW     (Seq DROP c) -> Just c
-  Seq  SENDER  (Seq DROP c) -> Just c
-  Seq  EMPTY_MAP (Seq DROP c) -> Just c
-  Seq  EMPTY_SET (Seq DROP c) -> Just c
+  SWAP      :# SWAP :# c -> Just c
+  PUSH _    :# DROP :# c -> Just c
+  DUP       :# DROP :# c -> Just c
+  UNIT      :# DROP :# c -> Just c
+  NOW       :# DROP :# c -> Just c
+  SENDER    :# DROP :# c -> Just c
+  EMPTY_MAP :# DROP :# c -> Just c
+  EMPTY_SET :# DROP :# c -> Just c
 
-  Seq  SWAP         SWAP    -> Just Nop
-  Seq (PUSH _)      DROP    -> Just Nop
-  Seq  DUP          DROP    -> Just Nop
-  Seq  UNIT         DROP    -> Just Nop
-  Seq  NOW          DROP    -> Just Nop
-  Seq  SENDER       DROP    -> Just Nop
-  Seq  EMPTY_MAP   DROP    -> Just Nop
-  Seq  EMPTY_SET   DROP    -> Just Nop
-  _                         -> Nothing
+  SWAP      :# SWAP      -> Just Nop
+  PUSH _    :# DROP      -> Just Nop
+  DUP       :# DROP      -> Just Nop
+  UNIT      :# DROP      -> Just Nop
+  NOW       :# DROP      -> Just Nop
+  SENDER    :# DROP      -> Just Nop
+  EMPTY_MAP :# DROP      -> Just Nop
+  EMPTY_SET :# DROP      -> Just Nop
+  _                      -> Nothing
 
 dupSwap2dup :: Rule
 dupSwap2dup = \case
-  Seq DUP (Seq SWAP c) -> Just (Seq DUP c)
-  Seq DUP      SWAP    -> Just      DUP
-  _                    -> Nothing
+  DUP :# SWAP :# c -> Just (DUP :# c)
+  DUP :# SWAP      -> Just DUP
+  _                -> Nothing
 
 noDipNeeded :: Rule
 noDipNeeded = \case
   -- If we put a constant value on stack and then do something under it,
   -- we can do this "something" on original stack and then put that constant.
-  Seq (PUSH x) (Seq (DIP f) c) -> Just (Seq f (Seq (PUSH x) c))
-  Seq (PUSH x)      (DIP f)    -> Just (Seq f      (PUSH x))
-  Seq UNIT     (Seq (DIP f) c) -> Just (Seq f (Seq UNIT c))
-  Seq UNIT          (DIP f)    -> Just (Seq f      UNIT)
-  Seq NOW     (Seq (DIP f) c) -> Just (Seq f (Seq NOW c))
-  Seq NOW          (DIP f)    -> Just (Seq f      NOW)
-  Seq SENDER  (Seq (DIP f) c) -> Just (Seq f (Seq SENDER c))
-  Seq SENDER       (DIP f)    -> Just (Seq f      SENDER)
-  Seq EMPTY_MAP     (Seq (DIP f) c) -> Just (Seq f (Seq EMPTY_MAP c))
-  Seq EMPTY_MAP          (DIP f)    -> Just (Seq f      EMPTY_MAP)
-  Seq EMPTY_SET     (Seq (DIP f) c) -> Just (Seq f (Seq EMPTY_SET c))
-  Seq EMPTY_SET          (DIP f)    -> Just (Seq f      EMPTY_SET)
+  PUSH x    :# DIP f :# c -> Just $ f :# PUSH x :# c
+  PUSH x    :# DIP f      -> Just $ f :# PUSH x
+  UNIT      :# DIP f :# c -> Just $ f :# UNIT :# c
+  UNIT      :# DIP f      -> Just $ f :# UNIT
+  NOW       :# DIP f :# c -> Just $ f :# NOW :# c
+  NOW       :# DIP f      -> Just $ f :# NOW
+  SENDER    :# DIP f :# c -> Just $ f :# SENDER :# c
+  SENDER    :# DIP f      -> Just $ f :# SENDER
+  EMPTY_MAP :# DIP f :# c -> Just $ f :# EMPTY_MAP :# c
+  EMPTY_MAP :# DIP f      -> Just $ f :# EMPTY_MAP
+  EMPTY_SET :# DIP f :# c -> Just $ f :# EMPTY_SET :# c
+  EMPTY_SET :# DIP f      -> Just $ f :# EMPTY_SET
 
   -- If we do something ignoring top of the stack and then immediately
   -- drop top of the stack, we can drop that item in advance and
   -- not use 'DIP' at all.
-  Seq (DIP f) (Seq DROP c)     -> Just (Seq DROP (Seq f c))
-  Seq (DIP f) DROP             -> Just (Seq DROP f)
+  DIP f :# DROP :# c -> Just $ DROP :# f :# c
+  DIP f :# DROP         -> Just $ DROP :# f
 
-  _                            -> Nothing
+  _ -> Nothing
 
 branchShortCut :: Rule
 branchShortCut = \case
-  Seq LEFT  (Seq (IF_LEFT f _) c) -> Just (Seq f c)
-  Seq RIGHT (Seq (IF_LEFT _ f) c) -> Just (Seq f c)
-  Seq CONS  (Seq (IF_CONS f _) c) -> Just (Seq f c)
-  Seq NIL   (Seq (IF_CONS _ f) c) -> Just (Seq f c)
-  Seq NONE  (Seq (IF_NONE f _) c) -> Just (Seq f c)
-  Seq SOME  (Seq (IF_NONE _ f) c) -> Just (Seq f c)
+  LEFT  :# IF_LEFT f _ :# c -> Just (f :# c)
+  RIGHT :# IF_LEFT _ f :# c -> Just (f :# c)
+  CONS  :# IF_CONS f _ :# c -> Just (f :# c)
+  NIL   :# IF_CONS _ f :# c -> Just (f :# c)
+  NONE  :# IF_NONE f _ :# c -> Just (f :# c)
+  SOME  :# IF_NONE _ f :# c -> Just (f :# c)
 
-  Seq (PUSH (VBool True))  (Seq (IF f _) c) -> Just (Seq f c)
-  Seq (PUSH (VBool False)) (Seq (IF _ f) c) -> Just (Seq f c)
+  PUSH (VBool True)  :# IF f _ :# c -> Just (f :# c)
+  PUSH (VBool False) :# IF _ f :# c -> Just (f :# c)
 
-  Seq LEFT  (IF_LEFT f _) -> Just f
-  Seq RIGHT (IF_LEFT _ f) -> Just f
-  Seq CONS  (IF_CONS f _) -> Just f
-  Seq NIL   (IF_CONS _ f) -> Just f
-  Seq NONE  (IF_NONE f _) -> Just f
-  Seq SOME  (IF_NONE _ f) -> Just f
+  LEFT  :# IF_LEFT f _ -> Just f
+  RIGHT :# IF_LEFT _ f -> Just f
+  CONS  :# IF_CONS f _ -> Just f
+  NIL   :# IF_CONS _ f -> Just f
+  NONE  :# IF_NONE f _ -> Just f
+  SOME  :# IF_NONE _ f -> Just f
 
-  Seq (PUSH (VBool True))  (IF f _) -> Just f
-  Seq (PUSH (VBool False)) (IF _ f) -> Just f
+  PUSH (VBool True)  :# IF f _ -> Just f
+  PUSH (VBool False) :# IF _ f -> Just f
 
   _ -> Nothing
 
 compareWithZero :: Rule
 compareWithZero = \case
-  Seq (PUSH (VInt 0)) (Seq COMPARE (Seq EQ c)) -> Just          (Seq EQ c)
-  Seq (PUSH (VNat 0)) (Seq COMPARE (Seq EQ c)) -> Just (Seq INT (Seq EQ c))
-  Seq (PUSH (VInt 0)) (Seq COMPARE      EQ)    -> Just               EQ
-  Seq (PUSH (VNat 0)) (Seq COMPARE      EQ)    -> Just (Seq INT      EQ)
-  _                                            -> Nothing
+  PUSH (VInt 0) :# COMPARE :# EQ :# c -> Just $ EQ :# c
+  PUSH (VNat 0) :# COMPARE :# EQ :# c -> Just $ INT :# EQ :# c
+  PUSH (VInt 0) :# COMPARE :# EQ      -> Just $ EQ
+  PUSH (VNat 0) :# COMPARE :# EQ      -> Just $ INT :# EQ
+  _                                   -> Nothing
 
 simpleDrops :: Rule
 simpleDrops = \case
   -- DROP 0 is Nop
-  Seq (DROPN SZ) c -> Just c
-  DROPN SZ -> Just Nop
+  DROPN Zero :# c -> Just c
+  DROPN Zero -> Just Nop
 
   -- DROP 1 is DROP.
   -- @gromak: DROP seems to be cheaper (in my experiments it consumed 3 less gas).
@@ -251,8 +264,8 @@
   -- I will leave this note and rule here in hope that someone will manage to
   -- deal with this problem one day.
 
-  -- Seq (DROPN (SS SZ)) c -> Just (Seq DROP c)
-  -- DROPN (SS SZ) -> Just DROP
+  -- DROPN One :# c -> Just (DROP :# c)
+  -- DROPN One -> Just DROP
 
   _ -> Nothing
 
@@ -263,27 +276,27 @@
 -- 'MAP' as well (which is harder).
 internalNop :: Rule
 internalNop = \case
-  DIP Nop -> Just Nop
-  Seq (DIP Nop) c -> Just c
+  DIP Nop      -> Just Nop
+  DIP Nop :# c -> Just c
 
   _ -> Nothing
 
 simpleDips :: Rule
 simpleDips = \case
   -- DIP 0 is redundant
-  Seq (DIPN SZ i) c -> Just (Seq i c)
-  DIPN SZ i -> Just i
+  DIPN Zero i :# c -> Just (i :# c)
+  DIPN Zero i -> Just i
 
   -- @gromak: same situation as with `DROP 1` (see above).
-  -- Seq (DIPN (SS SZ) i) c -> Just (Seq (DIP i) c)
-  -- DIPN (SS SZ) i -> Just (DIP i)
+  -- DIPN One i :# c -> Just (DIP i :# c)
+  -- DIPN One i -> Just (DIP i)
 
   _ -> Nothing
 
 adjacentDips :: Rule
 adjacentDips = \case
-  Seq (DIP f) (DIP g) -> Just (DIP (Seq f g))
-  Seq (DIP f) (Seq (DIP g) c) -> Just (DIP (Seq f g) `Seq` c)
+  DIP f :# DIP g -> Just (DIP (f :# g))
+  DIP f :# DIP g :# c -> Just (DIP (f :# g) :# c)
 
   _ -> Nothing
 
@@ -293,18 +306,18 @@
 -- When @n@ is 2 it saves gas only.
 adjacentDrops :: Rule
 adjacentDrops = \case
-  Seq DROP DROP -> Just (DROPN (SS $ SS SZ))
-  Seq DROP (Seq DROP c) -> Just (DROPN (SS $ SS SZ) `Seq` c)
+  DROP :# DROP -> Just (DROPN Two)
+  DROP :# DROP :# c -> Just (DROPN Two :# c)
 
   -- Does not compile, need to do something smart
-  -- Seq (DROPN (SS (SS SZ))) DROP -> Just (DROPN (SS $ SS $ SS SZ))
+  -- DROPN Two :# DROP -> Just (DROPN (Succ Two))
 
   _ -> Nothing
 
 specificPush :: Rule
 specificPush = \case
-  push@PUSH{} -> optimizePush push
-  Seq (push@PUSH{}) c -> (`Seq` c) <$> optimizePush push
+  push@PUSH{}         -> optimizePush push
+  push@PUSH{} :# c -> (:# c) <$> optimizePush push
 
   _ -> Nothing
   where
@@ -323,33 +336,29 @@
 
 isSomeOnIf :: Rule
 isSomeOnIf = \case
-  Seq (IF (PUSH (VOption Just{})) (PUSH (VOption Nothing))) c -> case c of
-    Seq (IF_NONE (PUSH (VBool False)) (Seq DROP (PUSH (VBool True)))) s -> Just s
-    IF_NONE (PUSH (VBool False)) (Seq DROP (PUSH (VBool True))) -> Just Nop
+  IF (PUSH (VOption Just{})) (PUSH (VOption Nothing)) :# c -> case c of
+    IF_NONE (PUSH (VBool False)) (DROP :# PUSH (VBool True)) :# s -> Just s
+    IF_NONE (PUSH (VBool False)) (DROP :# PUSH (VBool True))      -> Just Nop
     _ -> Nothing
   _ -> Nothing
 
--- UNPAIR with continuation
-pattern UNPAIR_c
-  :: ()
-  => (i ~ ('TPair a b : s), i' ~ (a : b : s), o' ~ o)
-  => Instr i' o' -> Instr i o
-pattern UNPAIR_c c = Seq DUP (Seq CAR (Seq (DIP CDR) c))
-
 pairUnpair :: Rule
 pairUnpair = \case
-  Seq PAIR (UNPAIR_c c) -> Just c
-  Seq PAIR UNPAIR       -> Just Nop
+  PAIR :# UNPAIR :# c -> Just c
+  PAIR :# UNPAIR      -> Just Nop
 
-  UNPAIR_c (Seq PAIR c) -> Just c
-  UNPAIR_c      PAIR    -> Just Nop
+  UNPAIR :# PAIR :# c -> Just c
+  UNPAIR :# PAIR      -> Just Nop
 
   _ -> Nothing
 
 unpairMisc :: Rule
 unpairMisc = \case
-  Seq UNPAIR SWAP -> Just (DUP `Seq` CDR `Seq` DIP CAR)
-  Seq UNPAIR (Seq SWAP c) -> Just (DUP `Seq` CDR `Seq` DIP CAR `Seq` c)
+  DUP :# CAR :# DIP CDR      -> Just $ UNPAIR
+  DUP :# CAR :# DIP CDR :# c -> Just $ UNPAIR :# c
+
+  DUP :# CDR :# DIP CAR      -> Just $ UNPAIR :# SWAP
+  DUP :# CDR :# DIP CAR :# c -> Just $ UNPAIR :# SWAP :# c
   _ -> Nothing
 
 commuteArith ::
@@ -364,15 +373,15 @@
 
 swapBeforeCommutative :: Rule
 swapBeforeCommutative = \case
-  Seq SWAP (Seq i c) -> (`Seq` c) <$> commuteArith i
-  Seq SWAP i -> commuteArith i
+  SWAP :# i :# c -> (:# c) <$> commuteArith i
+  SWAP :# i -> commuteArith i
 
   _ -> Nothing
 
 pushPack :: Rule
 pushPack = \case
-  Seq (PUSH x) PACK -> Just (pushPacked x)
-  Seq (PUSH x) (Seq PACK c) -> Just (pushPacked x `Seq` c)
+  PUSH x :# PACK -> Just (pushPacked x)
+  PUSH x :# PACK :# c -> Just (pushPacked x :# c)
 
   _ -> Nothing
   where
diff --git a/src/Michelson/Parser.hs b/src/Michelson/Parser.hs
--- a/src/Michelson/Parser.hs
+++ b/src/Michelson/Parser.hs
@@ -20,6 +20,8 @@
   , parseNoEnv
   , parseValue
   , parseExpandValue
+  , parseValueFromFile
+  , parseExpandValueFromFile
 
   -- * For tests
   , codeEntry
@@ -46,8 +48,8 @@
 import qualified Language.Haskell.TH.Lift as TH
 import qualified Language.Haskell.TH.Quote as TH
 import Text.Megaparsec
-  (Parsec, choice, customFailure, eitherP, eof, errorBundlePretty, getSourcePos, lookAhead, parse,
-  try)
+  (Parsec, choice, customFailure, eitherP, eof, errorBundlePretty, getSourcePos, hidden, lookAhead,
+  parse, try)
 import Text.Megaparsec.Pos (SourcePos(..), unPos)
 
 import Michelson.ErrorPos (SrcPos(..), unsafeMkPos)
@@ -175,6 +177,15 @@
 -- | Parse untyped value from text which comes from something that is
 -- not a file (which is often the case). So we assume it does not need
 -- any parsing environment.
+--
+-- >>> parseValue "{PUSH int aaa}"
+-- Left 1:11:
+--   |
+-- 1 | {PUSH int aaa}
+--   |           ^^^^
+-- unexpected "aaa}"
+-- expecting value
+-- <BLANKLINE>
 parseValue :: Text -> Either ParserException ParsedValue
 parseValue = first ParserException . parseNoEnv value ""
 
@@ -182,6 +193,15 @@
 parseExpandValue :: Text -> Either ParserException U.Value
 parseExpandValue = fmap expandValue . parseValue
 
+-- | Like 'parseValue', but from text that comes from a file,
+-- for which we get the 'FilePath'.
+parseValueFromFile :: FilePath -> Text -> Either ParserException ParsedValue
+parseValueFromFile filePath = first ParserException . parseNoEnv value filePath -- TODO remove filPath?
+
+-- | Like 'parseValueFromFile', but also expands macros.
+parseExpandValueFromFile :: FilePath -> Text -> Either ParserException U.Value
+parseExpandValueFromFile filePath = fmap expandValue . parseValueFromFile filePath
+
 -- Primitive instruction
 ------------------
 
@@ -200,6 +220,15 @@
 bracewrappedOps :: Parser [ParsedOp]
 bracewrappedOps = lookAhead (symbol "{") *> ops
 
+-- |
+-- >>> first ParserException $ parseNoEnv parsedOp "" "{a}"
+-- Left 1:2:
+--   |
+-- 1 | {a}
+--   |  ^
+-- unexpected 'a'
+-- expecting '{', '}', macro, morley instruction, or primitive instruction
+-- <BLANKLINE>
 parsedOp :: Parser ParsedOp
 parsedOp = do
   lms <- asks letMacros
@@ -256,7 +285,8 @@
 -- Some of the operations and macros have the same prefixes in their names
 -- So this case should be handled separately
 primOrMac :: Parser ParsedOp
-primOrMac = (macWithPos (ifCmpMac parsedOp) <|> ifOrIfX)
+primOrMac = hidden
+   $  (macWithPos (ifCmpMac parsedOp) <|> ifOrIfX)
   <|> (macWithPos (mapCadrMac parsedOp) <|> primWithPos (mapOp parsedOp))
   <|> (try (primWithPos pairOp) <|> try (primWithPos pairNOp) <|> macWithPos pairMac)
   <|> (try (macWithPos duupMac) <|> primWithPos dupOp)
@@ -282,6 +312,16 @@
 --
 -- >>> [utypeQ| (int :a | nat :b) |]
 -- Ty (TOr % % (Ty TInt :a) (Ty TNat :b)) :
+--
+-- >>> [utypeQ|a|]
+-- <BLANKLINE>
+-- ...
+--   |
+-- 1 | a
+--   | ^
+-- unexpected 'a'
+-- expecting type
+-- ...
 utypeQ :: TH.QuasiQuoter
 utypeQ = parserToQuasiQuoter type_
 
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
@@ -9,8 +9,8 @@
   , noteDef
   , noteV2Def
   , notesTVF
-  , notesTVF2
   , notesTVF2Def
+  , notesVVFF
   , notesTV
   , notesTF
   , notesVF
@@ -37,14 +37,14 @@
 note = lexeme $ string (annPrefix @tag) >> (specialNote <|> note' <|> emptyNote)
   where
     -- TODO [#48] these are special annotations and should not always be accepted
-    specialVNote = mkAnnotationUnsafe <$> asum (map string specialVarAnns)
-    specialFNote = mkAnnotationUnsafe <$> string specialFieldAnn
+    specialVNote = unsafeMkAnnotation <$> asum (map string specialVarAnns)
+    specialFNote = unsafeMkAnnotation <$> string specialFieldAnn
     specialNote = specialVNote <|> specialFNote
     emptyNote = pure noAnn
     note' = do
       a <- satisfy isValidAnnStart
       b <- takeWhileP Nothing isValidAnnBodyChar
-      return . mkAnnotationUnsafe $ T.cons a b
+      return . unsafeMkAnnotation $ T.cons a b
 
 noteV :: Parser VarAnn
 noteV = note
@@ -55,20 +55,29 @@
 noteF :: Parser FieldAnn
 noteF = note
 
-noteF2 :: Parser (FieldAnn, FieldAnn)
-noteF2 = do a <- note; b <- note; return (a, b)
-
 noteV2Def :: Parser (VarAnn, VarAnn)
 noteV2Def = permute2Def note note
 
 notesTVF :: Parser (TypeAnn, VarAnn, FieldAnn)
 notesTVF = permute3Def note note note
 
-notesTVF2 :: Parser (TypeAnn, VarAnn, (FieldAnn, FieldAnn))
-notesTVF2 = permute3Def note note noteF2
-
 notesTVF2Def :: Parser (TypeAnn, VarAnn, (FieldAnn, FieldAnn))
 notesTVF2Def = permute3Def note note (permute2Def note note)
+
+-- | Parse 0/1/2 var anns and 0/1/2 field anns.
+-- It doesn't matter which come first, so long as annotations of the same type appear together.
+--
+-- E.g.:
+--
+-- * "" is valid
+-- * "%a" is valid
+-- * "%a @c" is valid
+-- * "%a %b @c @d" is valid
+-- * "@c @d %a %b" is valid
+-- * "@c %a %b @d" is not valid, because the two var anns are not "grouped" together.
+-- * "%a @c @d %b" is not valid, because the two fields anns are not "grouped" together.
+notesVVFF :: Parser ((VarAnn, VarAnn), (FieldAnn, FieldAnn))
+notesVVFF = permute2Def (liftA2 (,) note noteDef) (liftA2 (,) note noteDef)
 
 notesVF :: Parser (VarAnn, FieldAnn)
 notesVF = permute2Def note note
diff --git a/src/Michelson/Parser/Error.hs b/src/Michelson/Parser/Error.hs
--- a/src/Michelson/Parser/Error.hs
+++ b/src/Michelson/Parser/Error.hs
@@ -21,8 +21,7 @@
 import Util.Positive
 
 data CustomParserException
-  = UnknownTypeException
-  | StringLiteralException StringLiteralParserException
+  = StringLiteralException StringLiteralParserException
   | OddNumberBytesException
   | WrongTagArgs Natural Positive
   | WrongAccessArgs Natural Positive
@@ -34,7 +33,6 @@
 instance NFData CustomParserException
 
 instance ShowErrorComponent CustomParserException where
-  showErrorComponent UnknownTypeException = "unknown type"
   showErrorComponent (StringLiteralException e) = showErrorComponent e
   showErrorComponent OddNumberBytesException = "odd number bytes"
   showErrorComponent ExcessFieldAnnotation = "excess field annotation"
diff --git a/src/Michelson/Parser/Ext.hs b/src/Michelson/Parser/Ext.hs
--- a/src/Michelson/Parser/Ext.hs
+++ b/src/Michelson/Parser/Ext.hs
@@ -14,7 +14,7 @@
 
 import Prelude hiding (try)
 
-import Text.Megaparsec (choice, satisfy, try)
+import Text.Megaparsec (choice, label, satisfy, try)
 import Text.Megaparsec.Char (alphaNumChar, string)
 import qualified Text.Megaparsec.Char.Lexer as L
 
@@ -25,7 +25,7 @@
 import qualified Michelson.Untyped as U
 
 extInstr :: Parser [ParsedOp] -> Parser ParsedUExtInstr
-extInstr opsParser = choice [stackOp, testAssertOp opsParser, printOp]
+extInstr opsParser = label "morley instruction" $ choice [stackOp, testAssertOp opsParser, printOp]
 
 stackOp :: Parser ParsedUExtInstr
 stackOp = word' "STACKTYPE" U.STACKTYPE <*> stackType
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
@@ -10,6 +10,7 @@
   -- * These are handled separately to have better error messages
   , mapOp
   , pairOp
+  , unpairOp
   , pairNOp
   , cmpOp
   , dupOp
@@ -19,7 +20,7 @@
 
 import Prelude hiding (EQ, GT, LT, many, note, some, try)
 
-import Text.Megaparsec (choice, notFollowedBy, sepEndBy, try)
+import Text.Megaparsec (choice, label, notFollowedBy, sepEndBy, try)
 import qualified Text.Megaparsec.Char.Lexer as L
 
 import Michelson.Let (LetValue(..))
@@ -33,7 +34,7 @@
 
 -- | Parser for primitive Michelson instruction (no macros and extensions).
 primInstr :: Parser (Contract' ParsedOp) -> Parser ParsedOp -> Parser ParsedInstr
-primInstr contractParser opParser = choice
+primInstr contractParser opParser = label "primitive instruction" $ choice
   [ dropOp, swapOp, digOp, dugOp, pushOp opParser, someOp, noneOp, unitOp
   , ifNoneOp opParser, leftOp, rightOp, ifLeftOp opParser, nilOp
   , consOp, ifConsOp opParser, sizeOp, emptySetOp, emptyMapOp, emptyBigMapOp, iterOp opParser
@@ -47,6 +48,8 @@
   , balanceOp, checkSigOp, sha256Op, sha512Op, blake2BOp, hashKeyOp, pairingCheckOp
   , sourceOp, senderOp, chainIdOp, sha3Op, keccakOp, neverOp
   , votingPowerOp, totalVotingPowerOp, try unpairNOp
+  , unpairOp
+  , ticketOp, readTicketOp, splitTicketOp, joinTicketsOp
   ]
 
 -- | Parse a sequence of instructions.
@@ -203,11 +206,26 @@
 -- Operations on pairs
 pairOp :: Parser ParsedInstr
 pairOp = do
-  symbol' "PAIR";
-  (t, v, (p, q)) <- notesTVF2;
+  symbol' "PAIR"
+  (t, v, (p, q)) <- notesTVF2Def
+
+  -- Make sure this is a `PAIR` instruction,
+  -- and not a `PAIR n` instruction.
   notFollowedBy (lexeme L.decimal :: Parser Word)
+
   return $ PAIR t v p q
 
+unpairOp :: Parser ParsedInstr
+unpairOp = do
+  symbol' "UNPAIR"
+  ((vn1, vn2), (fn1, fn2)) <- notesVVFF
+
+  -- Make sure this is an `UNPAIR` instruction,
+  -- and not an `UNPAIR n` instruction.
+  notFollowedBy (lexeme L.decimal :: Parser Word)
+
+  return $ UNPAIR vn1 vn2 fn1 fn2
+
 pairNOp :: Parser ParsedInstr
 pairNOp = do
   symbol' "PAIR"
@@ -294,8 +312,6 @@
 
 -- Operations on unions
 
--- Using `notesTVF2Def` instead of `notesTVF2` allows for the second annotation
--- to be unspecified.
 leftOp :: Parser ParsedInstr
 leftOp = do symbol' "LEFT"; (t, v, (f, f')) <- notesTVF2Def;
                LEFT t v f f' <$> type_
@@ -411,3 +427,17 @@
 
 intOp :: Parser ParsedInstr
 intOp = word' "INT" INT <*> noteDef
+
+-- Ticket Operations
+
+ticketOp :: Parser ParsedInstr
+ticketOp = word' "TICKET" TICKET <*> noteDef
+
+readTicketOp :: Parser ParsedInstr
+readTicketOp = word' "READ_TICKET" READ_TICKET <*> noteDef
+
+splitTicketOp :: Parser ParsedInstr
+splitTicketOp = word' "SPLIT_TICKET" SPLIT_TICKET <*> noteDef
+
+joinTicketsOp :: Parser ParsedInstr
+joinTicketsOp = word' "JOIN_TICKETS" JOIN_TICKETS <*> noteDef
diff --git a/src/Michelson/Parser/Let.hs b/src/Michelson/Parser/Let.hs
--- a/src/Michelson/Parser/Let.hs
+++ b/src/Michelson/Parser/Let.hs
@@ -53,7 +53,7 @@
   semicolon
   local (addLet l) (letInner opParser) <|> return (addLet l env)
 
--- | add a Let to the environment in the correct place
+-- | Add a Let to the environment in the correct place
 addLet :: Let -> LetEnv -> LetEnv
 addLet l (LetEnv lms lvs lts) = case l of
   LetM lm -> LetEnv (Map.insert (lmName lm) lm lms) lvs lts
@@ -67,10 +67,12 @@
   , (LetT <$> letType)
   ]
 
--- | build a let name parser from a leading character parser
+-- | Build a let name parser from a leading character parser
 letName :: Parser Char -> Parser Text
 letName p = lexeme $ do
   v <- p
+  -- FIXME (#557): It is possible to define a let name such as "add3", but then
+  -- the parser doesn't recognize when it's used as an instruction.
   let validChar x = Char.isAscii x && (Char.isAlphaNum x || x == '\'' || x == '_')
   vs <- many (satisfy validChar)
   return $ toText (v:vs)
diff --git a/src/Michelson/Parser/Macro.hs b/src/Michelson/Parser/Macro.hs
--- a/src/Michelson/Parser/Macro.hs
+++ b/src/Michelson/Parser/Macro.hs
@@ -18,10 +18,10 @@
 
 import Prelude hiding (note, try)
 
-import Text.Megaparsec (customFailure, notFollowedBy, try)
+import Text.Megaparsec (customFailure, label, notFollowedBy, skipMany, try)
 import Text.Megaparsec.Char.Lexer (decimal)
 
-import Michelson.Macro (CadrStruct(..), Macro(..), PairStruct(..), UnpairStruct(..), ParsedOp(..))
+import Michelson.Macro (CadrStruct(..), Macro(..), PairStruct(..), ParsedOp(..), UnpairStruct(..))
 import qualified Michelson.Macro as Macro
 import Michelson.Parser.Annotations
 import Michelson.Parser.Error
@@ -35,8 +35,8 @@
 import Util.Positive
 
 macro :: Parser ParsedOp -> Parser Macro
-macro opParser =
-      word' "CASE" CASE <*> someNE ops
+macro opParser = label "macro"
+   $  word' "CASE" CASE <*> someNE ops
   <|> symbol' "TAG" *> tagMac
   <|> symbol' "ACCESS" *> accessMac
   <|> symbol' "SET " *> setMac
@@ -81,25 +81,20 @@
   let ps = Macro.mapPairLeaves fns a
   return $ PAPAIR ps tn vn
 
-upairMacInner :: Parser UnpairStruct
-upairMacInner = do
+unpairMacInner :: Parser UnpairStruct
+unpairMacInner = do
   string' "P"
-  l <- (string' "A" $> UF (noAnn, noAnn)) <|> upairMacInner
-  r <- (string' "I" $> UF (noAnn, noAnn)) <|> upairMacInner
+  l <- (string' "A" $> UF) <|> unpairMacInner
+  r <- (string' "I" $> UF) <|> unpairMacInner
   return $ UP l r
 
 unpairMac :: Parser Macro
 unpairMac = do
   string' "UN"
-  a <- upairMacInner
+  a <- unpairMacInner
   symbol' "R"
-  (vns, fns) <- permute2Def (some note) (some note)
-  return $ UNPAIR (Macro.mapUnpairLeaves (padAnnotations vns fns) a)
-  where
-    padAnnotations []       []       = []
-    padAnnotations []       (f : fs) = (noAnn, f) : padAnnotations [] fs
-    padAnnotations (v : vs) []       = (v, noAnn) : padAnnotations vs []
-    padAnnotations (v : vs) (f : fs) = (v, f    ) : padAnnotations vs fs
+  skipMany $ (void noteF) <|> (void noteV)
+  return $ UNPAPAIR a
 
 cadrMac :: Parser Macro
 cadrMac = lexeme $ do
diff --git a/src/Michelson/Parser/Type.hs b/src/Michelson/Parser/Type.hs
--- a/src/Michelson/Parser/Type.hs
+++ b/src/Michelson/Parser/Type.hs
@@ -15,7 +15,7 @@
 import Data.Default (Default, def)
 import qualified Data.Map as Map
 import Fmt (pretty)
-import Text.Megaparsec (choice, customFailure, sepBy)
+import Text.Megaparsec (choice, customFailure, label, sepBy)
 
 import Michelson.Let (LetType(..))
 import Michelson.Parser.Annotations
@@ -65,17 +65,16 @@
 
 typeInner
   :: Parser FieldAnn -> Parser (FieldAnn, Ty)
-typeInner fp = lexeme $ choice $ (\x -> x fp) <$>
+typeInner fp = label "type" $ lexeme $ choice $ (\x -> x fp) <$>
   [ t_int, t_nat, t_string, t_bytes, t_mutez, t_bool
   , t_keyhash, t_timestamp, t_address
   , t_key, t_unit, t_never, t_signature, t_chain_id
   , t_bls12381fr, t_bls12381g1, t_bls12381g2
   , t_option, t_list, t_set
-  , t_operation, t_contract, t_pair, t_or
+  , t_operation, t_contract, t_ticket, t_pair, t_or
   , t_lambda, t_map, t_big_map, t_view
   , t_void, t_letType
   , t_operator
-  , const (customFailure UnknownTypeException)
   ]
 
 ----------------------------------------------------------------------------
@@ -155,6 +154,13 @@
   (f, t) <- fieldType fp
   a <- type_
   return (f, Ty (TContract a) t)
+
+t_ticket :: (Default a) => Parser a -> Parser (a, Ty)
+t_ticket fp = do
+  symbol' "Ticket"
+  (f, t) <- fieldType fp
+  a <- type_
+  return (f, Ty (TTicket a) t)
 
 t_unit :: (Default a) => Parser a -> Parser (a, Ty)
 t_unit fp = do
diff --git a/src/Michelson/Parser/Value.hs b/src/Michelson/Parser/Value.hs
--- a/src/Michelson/Parser/Value.hs
+++ b/src/Michelson/Parser/Value.hs
@@ -20,7 +20,7 @@
 import qualified Data.Map as Map
 import qualified Text.Hex as Hex
 
-import Text.Megaparsec (anySingle, choice, customFailure, manyTill, satisfy, takeWhileP, try)
+import Text.Megaparsec (anySingle, choice, customFailure, label, manyTill, satisfy, takeWhileP, try)
 import Text.Megaparsec.Char (char, string)
 import qualified Text.Megaparsec.Char.Lexer as L
 
@@ -30,7 +30,7 @@
 import Michelson.Parser.Helpers
 import Michelson.Parser.Lexer
 import Michelson.Parser.Types (Parser, letValues)
-import Michelson.Text (isMChar, mkMTextUnsafe)
+import Michelson.Text (isMChar, unsafeMkMText)
 import qualified Michelson.Untyped as U
 
 -- | Parse untyped 'ParsedValue'. Take instruction parser as argument
@@ -41,7 +41,7 @@
     valueInner' = valueInner opParser
 
 valueInner :: Parser ParsedOp -> Parser ParsedValue
-valueInner opParser = choice $
+valueInner opParser = label "value" $ choice $
   [ stringLiteral, bytesLiteral, intLiteral, unitValue
   , trueValue, falseValue, pairValue opParser, leftValue opParser
   , rightValue opParser, someValue opParser, noneValue, nilValue
@@ -52,7 +52,7 @@
 seqOrLambda opParser = try (lambdaValue opParser) <|> seqValue opParser
 
 stringLiteral :: Parser ParsedValue
-stringLiteral = U.ValueString . mkMTextUnsafe . toText <$> do
+stringLiteral = U.ValueString . unsafeMkMText . toText <$> do
   _ <- try $ string "\""
   manyTill validChar (string "\"")
   where
diff --git a/src/Michelson/Preprocess.hs b/src/Michelson/Preprocess.hs
--- a/src/Michelson/Preprocess.hs
+++ b/src/Michelson/Preprocess.hs
@@ -42,12 +42,12 @@
      forall inp out.
      Bool
   -> (forall t. Value t -> Value t)
-  -- ^ Should transform only atomic values, 'dfsValue' will be applied to it.
+  -- ^ Should transform only atomic values, 'dfsMapValue' will be applied to it.
   -> Instr inp out
   -> Instr inp out
 transformConstants dsGoToValues f = fst . dfsInstr def{ dsGoToValues } step
   where
     step :: forall i o. Instr i o -> (Instr i o, ())
     step = (,()) . \case
-      PUSH v -> PUSH (dfsModifyValue f v)
+      PUSH v -> PUSH (dfsMapValue f v)
       i -> i
diff --git a/src/Michelson/Printer.hs b/src/Michelson/Printer.hs
--- a/src/Michelson/Printer.hs
+++ b/src/Michelson/Printer.hs
@@ -4,6 +4,7 @@
 
 module Michelson.Printer
   ( RenderDoc(..)
+  , renderAnyBuildable
   , printDoc
   , printUntypedContract
   , printTypedContractCode
@@ -17,8 +18,7 @@
 import Data.Singletons (SingI)
 import qualified Data.Text.Lazy as TL
 
-import Michelson.Printer.Util (RenderDoc(..), doesntNeedParens, printDoc)
-import Michelson.TypeCheck.Types (SomeContract(..))
+import Michelson.Printer.Util (RenderDoc(..), renderAnyBuildable, doesntNeedParens, printDoc)
 import qualified Michelson.Typed as T
 import qualified Michelson.Untyped as U
 
@@ -57,6 +57,6 @@
 
 -- | Convert 'SomeContract' into a textual representation which
 -- will be accepted by the OCaml reference client.
-printSomeContract :: Bool -> SomeContract -> TL.Text
-printSomeContract forceSingleLine (SomeContract fc) =
+printSomeContract :: Bool -> T.SomeContract -> TL.Text
+printSomeContract forceSingleLine (T.SomeContract fc) =
   printTypedContract forceSingleLine fc
diff --git a/src/Michelson/Printer/Util.hs b/src/Michelson/Printer/Util.hs
--- a/src/Michelson/Printer/Util.hs
+++ b/src/Michelson/Printer/Util.hs
@@ -11,9 +11,12 @@
   , renderOps
   , renderOpsList
   , renderOpsListNoBraces
+  , renderAnyBuildable
   , spaces
   , wrapInParens
   , buildRenderDoc
+  , buildRenderDocExtended
+  , renderDocList
 
     -- * Smart parentheses
   , RenderContext
@@ -23,12 +26,13 @@
   , assertParensNotNeeded
   ) where
 
+import Fmt (Buildable, pretty)
 import Control.Exception (assert)
 import qualified Data.Text.Lazy as LT
 import Data.Text.Lazy.Builder (Builder)
 import Text.PrettyPrint.Leijen.Text
   (Doc, SimpleDoc, align, braces, displayB, displayT, enclose, hcat, isEmpty, parens, punctuate,
-  renderOneLine, renderPretty, semi, space, vcat, (<+>))
+  renderOneLine, renderPretty, semi, space, text, vcat, (<+>), lbracket, rbracket, encloseSep)
 
 -- | Environment carried during recursive rendering.
 newtype RenderContext = RenderContext
@@ -55,6 +59,14 @@
   isRenderable :: a -> Bool
   isRenderable _ = True
 
+-- | Renders a list of 'RenderDoc' elements surrounded with square brackets,
+-- separated by a comma and a space.
+renderDocList :: RenderDoc a => RenderContext -> [a] -> Doc
+renderDocList context = encloseSep lbracket rbracket ", " . fmap (renderDoc context)
+
+renderAnyBuildable :: Buildable a => a -> Doc
+renderAnyBuildable = text . pretty
+
 -- | A new type that can wrap values so that the RenderDoc
 -- instances of the combined value can have a different
 -- behavior for the pretty printer.
@@ -106,6 +118,11 @@
 -- It's formatted the same way as `printDoc` formats docs.
 buildRenderDoc :: RenderDoc a => a -> Builder
 buildRenderDoc = printDocB True . renderDoc doesntNeedParens
+
+-- | Works as 'buildRenderDoc' above, but doesn't force the doc to be printed in one line
+buildRenderDocExtended :: RenderDoc a => a -> Builder
+buildRenderDocExtended = printDocB False . renderDoc doesntNeedParens
+
 
 -- | Here using a page width of 80 and a ribbon width of 1.0
 -- https://hackage.haskell.org/package/wl-pprint-1.2.1/docs/Text-PrettyPrint-Leijen.html
diff --git a/src/Michelson/Runtime.hs b/src/Michelson/Runtime.hs
--- a/src/Michelson/Runtime.hs
+++ b/src/Michelson/Runtime.hs
@@ -56,29 +56,28 @@
 import Data.Text.IO (getContents)
 import qualified Data.Text.IO.Utf8 as Utf8 (readFile)
 import Fmt (Buildable(build), blockListF, fmt, fmtLn, nameF, pretty, (+|), (|+))
-import Named ((:!), (:?), arg, argDef, defaults, (!))
+import Named (arg, argDef, defaults, (!), (:!), (:?))
 import Text.Megaparsec (parse)
 
-import Data.Singletons (demote)
-import Data.Typeable (gcast)
 import Michelson.Interpret
   (ContractEnv(..), InterpretError(..), InterpretResult(..), InterpreterState(..), MorleyLogs(..),
-  RemainingSteps(..), handleContractReturn, interpret)
+  RemainingSteps(..), assignBigMapIds, handleContractReturn, interpret)
 import qualified Michelson.Interpret.Pack as Pack
 import Michelson.Macro (ParsedOp, expandContract)
 import qualified Michelson.Parser as P
 import Michelson.Runtime.GState
 import Michelson.Runtime.TxData
 import Michelson.TypeCheck
-  (SomeContractAndStorage(..), TCError, typeCheckContractAndStorage, typeVerifyParameter)
 import Michelson.Typed
   (CreateContract(..), EntrypointCallT, EpAddress(..), EpName, Operation'(..), ParameterScope,
-  SomeValue'(..), TransferTokens(..), starNotes, starParamNotes, untypeValue)
+  SomeContractAndStorage(..), SomeStorage(..), SomeValue(..), TransferTokens(..), starNotes,
+  starParamNotes, untypeValue)
 import qualified Michelson.Typed as T
-import Michelson.Typed.Origination (OriginationOperation(..), mkOriginationOperationHash)
-import Michelson.Untyped (Contract, OperationHash(..))
+import Michelson.Typed.Origination
+  (OperationHash(..), OriginationOperation(..), mkContractAddress, mkOriginationOperationHash)
+import Michelson.Untyped (Contract)
 import qualified Michelson.Untyped as U
-import Tezos.Address (Address(..), OriginationIndex(..), mkContractAddress)
+import Tezos.Address (Address(..), OriginationIndex(..))
 import Tezos.Core
   (Mutez, Timestamp(..), getCurrentTime, unMutez, unsafeAddMutez, unsafeSubMutez, zeroMutez)
 import Tezos.Crypto (KeyHash, blake2b, parseKeyHash)
@@ -167,15 +166,17 @@
   -- ^ Sending 0tz towards an address.
   | EEFailedToApplyUpdates GStateUpdateError
   -- ^ Failed to apply updates to GState.
-  | EEIllTypedParameter TCError
+  | EEIllTypedParameter a TCError
   -- ^ Contract parameter is ill-typed.
-  | EEUnexpectedParameterType T.T T.T
+  | EEUnexpectedParameterType a T.T T.T
   -- ^ Contract parameter is well-typed, but its type does
   -- not match the entrypoint's type.
   | EEUnknownEntrypoint EpName
   -- ^ Specified entrypoint to run is not found.
   | EETransactionFromContract a Mutez
   -- ^ A transaction from an originated contract was attempted as a global operation.
+  | EEWrongParameterType a
+  -- ^ Type of parameter in transfer to an implicit account is not Unit.
   deriving stock (Show, Functor)
 
 instance (Buildable a) => Buildable (ExecutorError' a) where
@@ -195,14 +196,16 @@
       EEZeroTransaction addr ->
         "Transaction of 0ꜩ towards a key address " +| addr |+ " which has no code is prohibited"
       EEFailedToApplyUpdates err -> "Failed to update GState: " +| err |+ ""
-      EEIllTypedParameter err -> "The contract parameter is ill-typed: " +| err |+ ""
-      EEUnexpectedParameterType expectedT actualT ->
+      EEIllTypedParameter _ err -> "The contract parameter is ill-typed: " +| err |+ ""
+      EEUnexpectedParameterType _ actualT expectedT ->
         "The contract parameter is well-typed, but did not match the contract's entrypoint's type.\n" <>
         "Expected: " +| expectedT |+ "\n" <>
         "Got: " +| actualT |+ ""
       EEUnknownEntrypoint epName -> "The contract does not contain entrypoint '" +| epName |+ "'"
       EETransactionFromContract addr amount ->
         "Global transaction of funds (" +| amount |+ ") from an originated contract (" +| addr |+ ") is prohibited."
+      EEWrongParameterType addr ->
+        "Bad contract parameter for: " +| addr |+ ""
 
 type ExecutorError = ExecutorError' Address
 
@@ -243,6 +246,7 @@
 -- contract.
 originateContract
   :: FilePath
+  -> TypeCheckOptions
   -> Address
   -> Maybe KeyHash
   -> Mutez
@@ -250,8 +254,8 @@
   -> U.Contract
   -> "verbose" :! Bool
   -> IO Address
-originateContract dbPath originator delegate balance uStorage uContract verbose = do
-  origination <- either throwM pure $
+originateContract dbPath tcOpts originator delegate balance uStorage uContract verbose = do
+  origination <- either throwM pure . typeCheckingWith tcOpts $
     mkOrigination <$> typeCheckContractAndStorage uContract uStorage
   -- pass 100500 as maxSteps, because it doesn't matter for origination,
   -- as well as 'now'
@@ -274,22 +278,23 @@
   -> Word64
   -> Mutez
   -> FilePath
+  -> TypeCheckOptions
   -> U.Value
   -> U.Contract
   -> TxData
   -> "verbose" :! Bool
   -> "dryRun" :! Bool
-  -> IO U.Value
-runContract maybeNow maybeLevel maxSteps initBalance dbPath uStorage uContract txData
+  -> IO SomeStorage
+runContract maybeNow maybeLevel maxSteps initBalance dbPath tcOpts uStorage uContract txData
   verbose (arg #dryRun -> dryRun) = do
-  origination <- either throwM pure $
+  origination <- either throwM pure . typeCheckingWith tcOpts $
     mkOrigination <$> typeCheckContractAndStorage uContract uStorage
   (_, newSt) <- runExecutorMWithDB maybeNow maybeLevel dbPath (RemainingSteps maxSteps) verbose ! #dryRun dryRun $ do
     -- Here we are safe to bypass executeGlobalOperations for origination,
     -- since origination can't generate more operations.
     addr <- executeGlobalOrigination origination
     let transferOp = TransferOp addr txData
-    executeGlobalOperations [transferOp]
+    executeGlobalOperations tcOpts [transferOp]
     getContractStorage addr
   return newSt
   where
@@ -309,13 +314,13 @@
       , ooContract = contract
       }
 
-    getContractStorage :: Address -> ExecutorM U.Value
+    getContractStorage :: Address -> ExecutorM SomeStorage
     getContractStorage addr = do
       addrs <- use (esGState . gsAddressesL)
       case addrs ^. at addr of
         Nothing -> error $ pretty addr <> " is unknown"
         Just (ASSimple {}) -> error $ pretty addr <> " is a simple address"
-        Just (ASContract (ContractState{..})) -> return $ untypeValue csStorage
+        Just (ASContract (ContractState{..})) -> return $ SomeStorage csStorage
 
 -- | Send a transaction to given address with given parameters.
 transfer ::
@@ -323,14 +328,15 @@
   -> Maybe Natural
   -> Word64
   -> FilePath
+  -> TypeCheckOptions
   -> Address
   -> TxData
   -> "verbose" :! Bool
   -> "dryRun" :? Bool
   -> IO ()
-transfer maybeNow maybeLevel maxSteps dbPath destination txData verbose dryRun = do
+transfer maybeNow maybeLevel maxSteps dbPath tcOpts destination txData verbose dryRun = do
   void $ runExecutorMWithDB maybeNow maybeLevel dbPath (RemainingSteps maxSteps) verbose dryRun $
-    executeGlobalOperations [TransferOp destination txData]
+    executeGlobalOperations tcOpts [TransferOp destination txData]
 
 ----------------------------------------------------------------------------
 -- Executor
@@ -432,9 +438,10 @@
 
 -- | Execute a list of global operations, discarding their results.
 executeGlobalOperations
-  :: [ExecutorOp]
+  :: TypeCheckOptions
+  -> [ExecutorOp]
   -> ExecutorM ()
-executeGlobalOperations = mapM_ $ \op ->
+executeGlobalOperations tcOpts = mapM_ $ \op ->
   executeMany (#isGlobalOp .! True) [op]
   where
     -- | Execute a list of operations and additional operations they return, until there are none.
@@ -445,8 +452,8 @@
           case op of
             OriginateOp origination -> void $ executeOrigination isGlobalOp origination
             TransferOp addr txData -> do
-              moreOps <- executeTransfer isGlobalOp addr txData
-              executeMany (#isGlobalOp .! False) $ opsTail <> moreOps
+              moreOps <- executeTransfer isGlobalOp tcOpts addr txData
+              executeMany (#isGlobalOp .! False) $ moreOps <> opsTail
 
 -- | Execute a global origination operation.
 executeGlobalOrigination :: OriginationOperation -> ExecutorM Address
@@ -457,7 +464,7 @@
   :: "isGlobalOp" :! Bool
   -> OriginationOperation
   -> ExecutorM Address
-executeOrigination (arg #isGlobalOp -> isGlobalOp) origination = do
+executeOrigination (arg #isGlobalOp -> isGlobalOp) origination@(OriginationOperation _ _ bal st contract) = do
   when isGlobalOp $ do
     beginGlobalOperation
     assign esOperationHash $ mkOriginationOperationHash origination
@@ -466,9 +473,13 @@
 
   gs <- use esGState
   originationNonce <- use esOriginationNonce
-  let contractState =
-        case origination of
-          OriginationOperation _ _ bal st contract -> ContractState bal contract st
+
+  -- Add big_map IDS to storage
+  let bigMapCounter0 = gs ^. gsBigMapCounterL
+  let (storageWithIds, bigMapCounter1) = runState (assignBigMapIds st) bigMapCounter0
+
+  let contractState = ContractState bal contract storageWithIds
+
   let originatorAddress = ooOriginator origination
   originatorBalance <- case gsAddresses gs ^. at originatorAddress of
     Nothing -> throwError (EEUnknownManager originatorAddress)
@@ -482,10 +493,15 @@
   let
     address = mkContractAddress opHash (OriginationIndex originationNonce) (gsCounter gs)
     updates =
-      [ GSAddAddress address (ASContract contractState)
-      , GSSetBalance originatorAddress originatorBalance
-      , GSIncrementCounter
-      ]
+      catMaybes
+        [ Just $ GSAddAddress address (ASContract contractState)
+        , Just $ GSSetBalance originatorAddress originatorBalance
+        , Just $ GSIncrementCounter
+        , if bigMapCounter0 == bigMapCounter1
+            then Nothing
+            else Just $ GSSetBigMapCounter bigMapCounter1
+        ]
+
   case applyUpdates updates gs of
     Left _ ->
       throwError $ EEAlreadyOriginated address contractState
@@ -500,10 +516,11 @@
 -- | Execute a transfer operation.
 executeTransfer
   :: "isGlobalOp" :! Bool
+  -> TypeCheckOptions
   -> Address
   -> TxData
   -> ExecutorM [ExecutorOp]
-executeTransfer (arg #isGlobalOp -> isGlobalOp) addr txData = do
+executeTransfer (arg #isGlobalOp -> isGlobalOp) tcOpts addr txData = do
     when isGlobalOp $
       beginGlobalOperation
 
@@ -520,6 +537,9 @@
         isKeyAddress _ = False
     let isZeroTransfer = tdAmount txData == zeroMutez
 
+    when (badParamToImplicitAccount addr $ tdParameter txData) $
+      throwError $ EEWrongParameterType addr
+
     -- Transferring 0 XTZ to a key address is prohibited.
     when (isZeroTransfer && isKeyAddress addr) $
       throwError $ EEZeroTransaction addr
@@ -571,13 +591,15 @@
         -- we need to typecheck the parameter.
         typedParameter <-
           case tdParameter txData of
-            TxTypedParam (typedVal :: T.Value t) ->
-              maybe (throwError $ EEUnexpectedParameterType (demote @epArg) (demote @t)) pure $
-                gcast @t @epArg typedVal
+            TxTypedParam (typedVal :: T.Value t) -> do
+              T.castM @t @epArg typedVal (throwError ... EEUnexpectedParameterType addr)
             TxUntypedParam untypedVal ->
-              liftEither $ first EEIllTypedParameter $
+              liftEither $ first (EEIllTypedParameter addr) $ typeCheckingWith tcOpts $
                 typeVerifyParameter @epArg existingContracts untypedVal
 
+        let bigMapCounter0 = gs ^. gsBigMapCounterL
+        let (typedParameterWithIds, bigMapCounter1) = runState (assignBigMapIds typedParameter) bigMapCounter0
+
         -- I'm not entirely sure why we need to pattern match on `()` here,
         -- but, if we don't, we get a compiler error that I suspect is somehow related
         -- to the existential types we're matching on a few lines above.
@@ -588,7 +610,7 @@
         () <- when isGlobalOp $
           esOperationHash .= mkTransferOperationHash
             addr
-            typedParameter
+            typedParameterWithIds
             (tdEntrypoint txData)
             (tdAmount txData)
 
@@ -613,12 +635,17 @@
         iur@InterpretResult
           { iurOps = sideEffects
           , iurNewStorage = newValue
-          , iurNewState = InterpreterState _ newRemainingSteps _
+          , iurNewState = InterpreterState _ newRemainingSteps _ bigMapCounter2
           }
           <- liftEither $ first (EEInterpreterFailed addr) $
              handleContractReturn $
-                interpret csContract epc
-                typedParameter csStorage contractEnv
+                interpret
+                  csContract
+                  epc
+                  typedParameterWithIds
+                  csStorage
+                  bigMapCounter1
+                  contractEnv
         let
           updBalance
             | newBalance == csBalance = Nothing
@@ -626,9 +653,13 @@
           updStorage
             | SomeValue newValue == SomeValue csStorage = Nothing
             | otherwise = Just $ GSSetStorageValue addr newValue
+          updBigMapCounter
+            | bigMapCounter0 == bigMapCounter2 = Nothing
+            | otherwise = Just $ GSSetBigMapCounter bigMapCounter2
           updates = catMaybes
             [ updBalance
             , updStorage
+            , updBigMapCounter
             ]
         return (updates, sideEffects, Just iur, newRemainingSteps)
 
@@ -661,8 +692,8 @@
     packedOperation =
       BSL.toStrict $
         (runPut $ putWord64be $ unMutez amount)
-        <> Pack.encodeEpAddress (EpAddress to epName)
-        <> Pack.encodeValue param
+        <> (Pack.toBinary $ T.toVal (EpAddress to epName))
+        <> Pack.toBinary param
 
 -- The argument is the address of the contract that generated this operation.
 convertOp :: Address -> T.Operation -> Maybe ExecutorOp
@@ -701,3 +732,10 @@
 beginGlobalOperation = do
   esOriginationNonce .= 0
   esSourceAddress .= Nothing
+
+-- | Return True if address is an implicit account yet the param is not Unit.
+badParamToImplicitAccount :: Address -> TxParam -> Bool
+badParamToImplicitAccount (ContractAddress _) _                       = False
+badParamToImplicitAccount (KeyAddress _) (TxTypedParam T.VUnit)       = False
+badParamToImplicitAccount (KeyAddress _) (TxUntypedParam U.ValueUnit) = False
+badParamToImplicitAccount _ _                                         = True
diff --git a/src/Michelson/Runtime/Dummy.hs b/src/Michelson/Runtime/Dummy.hs
--- a/src/Michelson/Runtime/Dummy.hs
+++ b/src/Michelson/Runtime/Dummy.hs
@@ -9,12 +9,13 @@
   , dummyLevel
   , dummyMaxSteps
   , dummyVotingPowers
+  , dummyBigMapCounter
   , dummyContractEnv
   , dummyOrigination
   ) where
 
 import Michelson.Interpret (ContractEnv(..), RemainingSteps)
-import Michelson.Runtime.GState (dummyVotingPowers, genesisAddress)
+import Michelson.Runtime.GState (BigMapCounter, dummyVotingPowers, genesisAddress)
 import Michelson.Typed (ParameterScope, StorageScope)
 import qualified Michelson.Typed as T
 import Michelson.Typed.Origination (OriginationOperation(..))
@@ -35,6 +36,9 @@
 -- interpreter from working for eternity.
 dummyMaxSteps :: RemainingSteps
 dummyMaxSteps = 100500
+
+dummyBigMapCounter :: BigMapCounter
+dummyBigMapCounter = 0
 
 -- | Dummy 'ContractEnv' with some reasonable hardcoded values. You
 -- can override values you are interested in using record update
diff --git a/src/Michelson/Runtime/GState.hs b/src/Michelson/Runtime/GState.hs
--- a/src/Michelson/Runtime/GState.hs
+++ b/src/Michelson/Runtime/GState.hs
@@ -16,6 +16,8 @@
   , mkVotingPowers
   , mkVotingPowersFromMap
   , dummyVotingPowers
+  , BigMapCounter(..)
+  , bigMapCounter
 
   -- * GState
   , GState (..)
@@ -23,6 +25,7 @@
   , gsAddressesL
   , gsVotingPowersL
   , gsCounterL
+  , gsBigMapCounterL
   , genesisAddresses
   , genesisKeyHashes
   , genesisAddress
@@ -50,22 +53,24 @@
   , extractAllContracts
   ) where
 
-import Control.Lens (at)
+import Control.Lens (at, makeLenses)
 import Data.Aeson (FromJSON(..), ToJSON(..), object, withObject, (.:), (.=))
 import qualified Data.Aeson as Aeson
 import qualified Data.Aeson.Encode.Pretty as Aeson
 import Data.Aeson.TH (deriveJSON)
 import qualified Data.ByteString.Lazy as LBS
+import Data.Default (def)
 import Data.List.NonEmpty ((!!))
 import qualified Data.Map.Strict as Map
-import Data.Typeable ((:~:)(..), eqT)
+import Data.Type.Equality ((:~:)(..))
 import Fmt (Buildable(build), (+|), (|+), (||+))
 import System.IO.Error (IOError, isDoesNotExistError)
 
 import Michelson.TypeCheck
-  (SomeContractAndStorage(..), SomeParamType(..), TcOriginatedContracts,
-  typeCheckContractAndStorage)
+  (SomeParamType(..), TcOriginatedContracts,
+  typeCheckContractAndStorage, typeCheckingWith)
 import qualified Michelson.Typed as T
+import Michelson.Typed.Existential (SomeContractAndStorage(..))
 import Michelson.Typed.Scope
 import Michelson.Untyped (Contract, Value)
 import Tezos.Address (Address(..), ContractHash, GlobalCounter(..))
@@ -73,6 +78,7 @@
 import Tezos.Crypto
 import Util.Aeson
 import Util.Lens
+import Util.Sing (eqI)
 
 -- | State of a contract with code.
 data ContractState =
@@ -104,7 +110,7 @@
       (balance :: Mutez) <- o .: "balance"
       (uStorage :: Value) <- o .: "storage"
       (uContract :: Contract) <- o .: "contract"
-      case typeCheckContractAndStorage uContract uStorage of
+      case typeCheckingWith def $ typeCheckContractAndStorage uContract uStorage of
         Right (SomeContractAndStorage contract storage) ->
           pure $ ContractState balance contract storage
         Left err -> fail $ "Unable to parse `ContractState`: " <> (show err)
@@ -170,6 +176,17 @@
 mkVotingPowers :: [(KeyHash, Natural)] -> VotingPowers
 mkVotingPowers = mkVotingPowersFromMap . Map.fromListWith (+)
 
+-- | All big_maps stored in a chain have a globally unique ID.
+--
+-- We use this counter to keep track of how many big_maps have been created so far,
+-- and to generate new IDs whenever a new big_map is created.
+newtype BigMapCounter = BigMapCounter { _bigMapCounter :: Natural }
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NFData)
+  deriving newtype (ToJSON, FromJSON, Num, Buildable)
+
+makeLenses ''BigMapCounter
+
 -- | Persistent data passed to Morley contracts which can be updated
 -- as result of contract execution.
 data GState = GState
@@ -181,6 +198,7 @@
   -- ^ Voting power distribution.
   , gsCounter :: GlobalCounter
   -- ^ Ever increasing operation counter.
+  , gsBigMapCounter :: BigMapCounter
   } deriving stock (Show)
 
 makeLensesWith postfixLFields ''GState
@@ -252,6 +270,7 @@
     ]
   , gsVotingPowers = dummyVotingPowers
   , gsCounter = GlobalCounter 0
+  , gsBigMapCounter = BigMapCounter 0
   }
 
 data GStateParseError =
@@ -290,6 +309,7 @@
   GSSetStorageValue :: StorageScope st => Address -> T.Value st -> GStateUpdate
   GSSetBalance :: Address -> Mutez -> GStateUpdate
   GSIncrementCounter :: GStateUpdate
+  GSSetBigMapCounter :: BigMapCounter -> GStateUpdate
 
 deriving stock instance Show GStateUpdate
 
@@ -304,6 +324,8 @@
         "Set balance of address " +| addr |+ " to " +| balance |+ ""
       GSIncrementCounter ->
         "Increment internal counter after operation"
+      GSSetBigMapCounter inc ->
+        "Increment internal big_map counter by: " +| build inc
 
 data GStateUpdateError
   = GStateAddressExists Address
@@ -332,6 +354,7 @@
       setStorageValue addr newValue
     GSSetBalance addr newBalance -> setBalance addr newBalance
     GSIncrementCounter -> Right . over gsCounterL (+1)
+    GSSetBigMapCounter bmCounter -> Right . set gsBigMapCounterL bmCounter
 
 -- | Apply a list of 'GStateUpdate's to 'GState'.
 applyUpdates :: [GStateUpdate] -> GState -> Either GStateUpdateError GState
@@ -353,7 +376,7 @@
     modifier :: AddressState -> Either GStateUpdateError AddressState
     modifier (ASSimple _) = Left (GStateNotContract addr)
     modifier (ASContract (ContractState b c (_ :: T.Value st') )) = do
-      case (eqT @st @st') of
+      case eqI @st @st' of
         Just Refl -> Right $ ASContract $ ContractState b c newValue
         _ -> Left $ GStateStorageNotMatch addr
 
diff --git a/src/Michelson/Runtime/Import.hs b/src/Michelson/Runtime/Import.hs
new file mode 100644
--- /dev/null
+++ b/src/Michelson/Runtime/Import.hs
@@ -0,0 +1,205 @@
+-- SPDX-FileCopyrightText: 2020 Tocqueville Group
+--
+-- SPDX-License-Identifier: LicenseRef-MIT-TQ
+
+module Michelson.Runtime.Import
+  (
+    -- * Read, parse, typecheck contract
+    readContract
+  , readSomeContract
+  , readUntypedContract
+  , importContract
+  , importSomeContract
+  , importUntypedContract
+  , ImportContractError(..)
+
+    -- * Read, parse, typecheck value
+  , readValue
+  , importValue
+  , importSomeValue
+  , importUntypedValue
+  , ImportValueError (..)
+
+    -- * Generic helpers
+  , importUsing
+  ) where
+
+import Data.Default (def)
+import qualified Data.Text.IO.Utf8 as Utf8 (readFile)
+import Fmt (Buildable(build), pretty, unlinesF, (+|), (|+))
+
+import Michelson.Parser (parseExpandValueFromFile)
+import Michelson.Parser.Error (ParserException(..))
+import Michelson.Runtime (parseExpandContract)
+import Michelson.TypeCheck
+  (TCError, typeCheckContract, typeCheckTopLevelType, typeCheckingWith,
+  typeVerifyContract, typeVerifyTopLevelType)
+import Michelson.Typed (Contract(..), SingI, SomeContract(..), SomeValue, Value)
+import qualified Michelson.Untyped as U
+
+----------------------------------------------------------------------------
+-- Reading, parsing, typechecking contract
+----------------------------------------------------------------------------
+
+-- | Purely read an untyped contract from Michelson textual representation.
+--
+-- 'FilePath' is accepted solely as a hint for error messages.
+readUntypedContract
+  :: FilePath
+  -> Text
+  -> Either ImportContractError U.Contract
+readUntypedContract filePath txt = do
+  first (ICEParse filePath) $ parseExpandContract (Just filePath) txt
+
+-- | Purely read a typed contract from Michelson textual representation.
+readSomeContract
+  :: FilePath
+  -> Text
+  -> Either ImportContractError SomeContract
+readSomeContract filePath txt = do
+  contract <- readUntypedContract filePath txt
+  first (ICETypeCheck filePath) $
+    typeCheckingWith def $ typeCheckContract contract
+
+-- | Purely read a typed contract from Michelson textual representation,
+-- failing if parameter or storage types mismatch with the expected ones.
+readContract
+  :: forall cp st .
+     Each '[SingI] [cp, st]
+  => FilePath
+  -> Text
+  -> Either ImportContractError (Contract cp st)
+readContract filePath txt = do
+  contract <- readUntypedContract filePath txt
+  first (ICETypeCheck filePath) $
+    typeCheckingWith def $ typeVerifyContract contract
+
+-- | Read a thing from a file, using the provided parsing function.
+importUsing
+  :: (Exception e)
+  => (FilePath -> Text -> Either e a)
+  -> FilePath -> IO a
+importUsing readFn file =
+  either throwM pure . readFn file =<< Utf8.readFile file
+
+-- | Import untyped contract from a given file path.
+--
+-- This function reads file, and parses a contract.
+--
+-- This function may throw 'IOException' and 'ImportContractError'.
+importUntypedContract :: FilePath -> IO U.Contract
+importUntypedContract = importUsing readUntypedContract
+
+-- | Import contract from a given file path.
+--
+-- This function reads file, parses and type checks a contract.
+-- Within the typechecking we assume that no contracts are originated,
+-- otherwise a type checking error will be caused.
+--
+-- This function may throw 'IOException' and 'ImportContractError'.
+importContract
+  :: forall cp st .
+     Each '[SingI] [cp, st]
+  => FilePath -> IO (Contract cp st)
+importContract = importUsing readContract
+
+-- | Version of 'importContract' that doesn't require you to know
+-- contract's parameter and storage types.
+importSomeContract :: FilePath -> IO SomeContract
+importSomeContract = importUsing readSomeContract
+
+-- | Error type for 'importContract' function.
+data ImportContractError
+  = ICEParse FilePath ParserException
+  | ICETypeCheck FilePath TCError
+  deriving stock (Show, Eq)
+
+instance Buildable ImportContractError where
+  build =
+    \case
+      ICEParse filePath e -> unlinesF
+        [ "Error at " <> build filePath
+        , "Failed to parse the contract: " +| e |+ ""
+        ]
+      ICETypeCheck filePath e -> unlinesF
+        [ "Error at " <> build filePath
+        , "The contract is ill-typed: " +| e |+ ""
+        ]
+
+instance Exception ImportContractError where
+  displayException = pretty
+
+----------------------------------------------------------------------------
+-- Reading, parsing, typechecking value
+----------------------------------------------------------------------------
+
+-- | Purely read an untyped Michelson value from textual representation.
+--
+-- 'FilePath' is accepted solely as a hint for error messages.
+readUntypedValue
+  :: FilePath
+  -> Text
+  -> Either ImportValueError U.Value
+readUntypedValue filePath txt = do
+  first (IVEParse filePath) $ parseExpandValueFromFile filePath txt
+
+-- | Purely read a typed Michelson value from textual representation.
+--
+-- Expected type is provided explicitly.
+readSomeValue
+  :: U.Ty
+  -> FilePath
+  -> Text
+  -> Either ImportValueError SomeValue
+readSomeValue ty filePath txt = do
+  valueU <- readUntypedValue filePath txt
+  first (IVETypeCheck filePath) $
+    typeCheckingWith def $ typeCheckTopLevelType Nothing ty valueU
+
+-- | Purely read a typed Michelson value from textual representation.
+readValue
+  :: forall t. SingI t
+  => FilePath
+  -> Text
+  -> Either ImportValueError (Value t)
+readValue filePath txt = do
+  valueU <- readUntypedValue filePath txt
+  first (IVETypeCheck filePath) $
+    typeCheckingWith def $ typeVerifyTopLevelType Nothing valueU
+
+-- | Import an untyped value from a given file path.
+importUntypedValue :: FilePath -> IO U.Value
+importUntypedValue = importUsing readUntypedValue
+
+-- | Import a typed value from a given file path.
+--
+-- Expected type is provided explicitly.
+importSomeValue :: U.Ty -> FilePath -> IO SomeValue
+importSomeValue = importUsing . readSomeValue
+
+-- | Import a typed value from a given file path.
+importValue
+  :: forall t . SingI t
+  => FilePath -> IO (Value t)
+importValue = importUsing readValue
+
+-- | Error type for 'importValue' function.
+data ImportValueError
+  = IVEParse FilePath ParserException
+  | IVETypeCheck FilePath TCError
+  deriving stock (Show, Eq)
+
+instance Buildable ImportValueError where
+  build =
+    \case
+      IVEParse filePath e -> unlinesF
+        [ "Error at " <> build filePath
+        , "Failed to parse the value: " +| e |+ ""
+        ]
+      IVETypeCheck filePath e -> unlinesF
+        [ "Error at " <> build filePath
+        , "The value is ill-typed: " +| e |+ ""
+        ]
+
+instance Exception ImportValueError where
+  displayException = pretty
diff --git a/src/Michelson/Text.hs b/src/Michelson/Text.hs
--- a/src/Michelson/Text.hs
+++ b/src/Michelson/Text.hs
@@ -19,7 +19,7 @@
 module Michelson.Text
   ( MText (..)
   , mkMText
-  , mkMTextUnsafe
+  , unsafeMkMText
   , mkMTextCut
   , writeMText
   , takeMText
@@ -61,16 +61,16 @@
 -- * With QuasyQuotes when need to create a string literal.
 --
 -- >>> [mt|Some text|]
--- MTextUnsafe {unMText = "Some text"}
+-- UnsafeMText {unMText = "Some text"}
 --
 -- * With 'mkMText' when constructing from a runtime text value.
 --
--- * With 'mkMTextUnsafe' or 'MTextUnsafe' when absolutelly sure that
+-- * With 'unsafeMkMText' or 'UnsafeMText' when absolutelly sure that
 -- given string does not violate invariants.
 --
 -- * With 'mkMTextCut' when not sure about text contents and want
 -- to make it compliant with Michelson constraints.
-newtype MText = MTextUnsafe { unMText :: Text }
+newtype MText = UnsafeMText { unMText :: Text }
   deriving stock (Show, Eq, Ord, Data, Generic)
   deriving newtype (Semigroup, Monoid, Container, Buildable, Hashable)
 
@@ -93,7 +93,7 @@
 -- You can use e.g. @'\n'@ character directly in supplied argument,
 -- but attempt to use other bad characters like @'\r'@ will cause failure.
 mkMText :: Text -> Either Text MText
-mkMText txt = mapM checkMChar (toString txt) $> MTextUnsafe txt
+mkMText txt = mapM checkMChar (toString txt) $> UnsafeMText txt
   where
     checkMChar c
       | isMChar c || c == '\n' = pass
@@ -101,30 +101,30 @@
 
 -- | Contruct 'MText' from a Haskell text, failing if provided Haskell text
 -- is invalid Michelson string.
-mkMTextUnsafe :: HasCallStack => Text -> MText
-mkMTextUnsafe = either error id . mkMText
+unsafeMkMText :: HasCallStack => Text -> MText
+unsafeMkMText = either error id . mkMText
 
 -- | Construct 'MText' from a Haskell text, eliminating all characters which
 -- should not appear in Michelson strings.
 -- Characters which can be displayed normally via escaping are preserved.
 mkMTextCut :: Text -> MText
 mkMTextCut txt =
-  MTextUnsafe . toText . filter isAllowed $ toString txt
+  UnsafeMText . toText . filter isAllowed $ toString txt
   where
     isAllowed c = isMChar c || c == '\n'
 
 -- | Print 'MText' for Michelson code, with all unusual characters escaped.
 writeMText :: MText -> Text
-writeMText (MTextUnsafe t) = t
+writeMText (UnsafeMText t) = t
   & T.replace "\\" "\\\\"
   & T.replace "\n" "\\n"
   & T.replace "\"" "\\\""
 
 takeMText :: Int -> MText -> MText
-takeMText n (MTextUnsafe txt) = MTextUnsafe $ T.take n txt
+takeMText n (UnsafeMText txt) = UnsafeMText $ T.take n txt
 
 dropMText :: Int -> MText -> MText
-dropMText n (MTextUnsafe txt) = MTextUnsafe $ T.drop n txt
+dropMText n (UnsafeMText txt) = UnsafeMText $ T.drop n txt
 
 instance ToText MText where
   toText = unMText
@@ -159,11 +159,11 @@
   { TH.quoteExp = \s ->
       case qqMText s of
         Left err -> fail $ toString err
-        Right txt -> [e| MTextUnsafe (toText @String txt) |]
+        Right txt -> [e| UnsafeMText (toText @String txt) |]
   , TH.quotePat = \s ->
       case qqMText s of
         Left err -> fail $ toString err
-        Right txt -> [p| MTextUnsafe $(TH.litP $ TH.StringL txt) |]
+        Right txt -> [p| UnsafeMText $(TH.litP $ TH.StringL txt) |]
   , TH.quoteType = \_ ->
       fail "Cannot use this QuasiQuoter at type position"
   , TH.quoteDec = \_ ->
@@ -198,19 +198,19 @@
 -- We assume that no unicode characters are used in plain Haskell code,
 -- so unless special tricky manipulations are used this should be safe.
 symbolToMText :: forall name. KnownSymbol name => MText
-symbolToMText = mkMTextUnsafe $ symbolValT' @name
+symbolToMText = unsafeMkMText $ symbolValT' @name
 
 -- | Create a 'MText' from label.
 --
 -- We assume that no unicode characters are used in plain Haskell code,
 -- so unless special tricky manipulations are used this should be safe.
 labelToMText :: Label name -> MText
-labelToMText = mkMTextUnsafe . labelToText
+labelToMText = unsafeMkMText . labelToText
 
 -- | Leads first character of text to upper case.
 --
 -- For empty text this will throw an error.
 mtextHeadToUpper :: HasCallStack => MText -> MText
-mtextHeadToUpper (MTextUnsafe txt) = case T.uncons txt of
+mtextHeadToUpper (UnsafeMText txt) = case T.uncons txt of
   Nothing -> error "Empty text"
-  Just (c, cs) -> MTextUnsafe $ T.cons (C.toUpper c) cs
+  Just (c, cs) -> UnsafeMText $ T.cons (C.toUpper c) cs
diff --git a/src/Michelson/TypeCheck.hs b/src/Michelson/TypeCheck.hs
--- a/src/Michelson/TypeCheck.hs
+++ b/src/Michelson/TypeCheck.hs
@@ -11,9 +11,12 @@
   , typeCheckListNoExcept
   , typeCheckParameter
   , typeCheckStorage
+  , typeCheckTopLevelType
   , typeCheckValue
+  , typeVerifyContract
   , typeVerifyParameter
   , typeVerifyStorage
+  , typeVerifyTopLevelType
   , module E
   , module M
   , module T
diff --git a/src/Michelson/TypeCheck/Error.hs b/src/Michelson/TypeCheck/Error.hs
--- a/src/Michelson/TypeCheck/Error.hs
+++ b/src/Michelson/TypeCheck/Error.hs
@@ -6,6 +6,7 @@
 
 module Michelson.TypeCheck.Error
   ( TypeContext (..)
+  , TopLevelType (..)
   , TCTypeError (..)
   , TCError (..)
   , ExtError (..)
@@ -14,17 +15,19 @@
   , pairWithElems
   ) where
 
-import Fmt (Buildable(..), listF, pretty, unlinesF, (+|), (+||), (|+), (||+))
+import Fmt (Buildable(..), pretty, (+|), (|+), (||+))
+import Named ((:!), arg)
+import Prelude hiding ((<$>), empty)
+import Text.PrettyPrint.Leijen.Text hiding (pretty, bool)
 import qualified Text.Show (show)
 
-import Michelson.ErrorPos (InstrCallStack(..), Pos(..), SrcPos(..))
-import Michelson.Printer.Util (doesntNeedParens, printDocB, renderDoc)
+import Michelson.ErrorPos (InstrCallStack(..))
+import Michelson.Printer.Util (RenderDoc (..), renderAnyBuildable,
+  buildRenderDoc, buildRenderDocExtended, doesntNeedParens, renderDoc, renderDocList)
 import Michelson.TypeCheck.TypeCheckedOp (TypeCheckedOp)
 import Michelson.TypeCheck.Types (SomeHST(..))
 import qualified Michelson.Typed as T
 import Michelson.Typed.Annotation (AnnConvergeError(..))
-import Michelson.Typed.Extract (toUType)
-import Michelson.Typed.T (buildStack)
 import Michelson.Untyped (StackFn, Ty, Var)
 import qualified Michelson.Untyped as U
 import Tezos.Address (Address)
@@ -43,6 +46,7 @@
   | ArithmeticOperation
   | Iteration
   | Cast
+  | UnpairArgument
   | CarArgument
   | CdrArgument
   | If
@@ -50,11 +54,12 @@
   | ContainerKeyType
   | ContainerValueType
   | FailwithArgument
+  | TicketsJoin
   deriving stock (Show, Eq, Generic)
   deriving anyclass (NFData)
 
-instance Buildable TypeContext where
-  build = \case
+instance RenderDoc TypeContext where
+  renderDoc _ = \case
     LambdaArgument -> "argument to some lambda"
     LambdaCode -> "code in LAMBDA"
     DipCode -> "code in DIP"
@@ -65,6 +70,7 @@
     ArithmeticOperation -> "arguments to arithmetic operation"
     Iteration -> "iteration (ITER / MAP / etc) code"
     Cast -> "argument to CAST"
+    UnpairArgument -> "argument to UNPAIR"
     CarArgument -> "argument to CAR"
     CdrArgument -> "argument to CDR"
     If -> "conditional expression"
@@ -72,7 +78,25 @@
     ContainerKeyType -> "container key type"
     ContainerValueType -> "container value type"
     FailwithArgument -> "argument to FAILWITH"
+    TicketsJoin -> "join of two tickets"
 
+data TopLevelType
+  = TltParameterType
+  | TltStorageType
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NFData)
+
+instance Buildable TopLevelType where
+  build = buildRenderDoc
+
+instance RenderDoc TopLevelType where
+  renderDoc _ = \case
+    TltParameterType -> "parameter"
+    TltStorageType -> "storage"
+
+instance Buildable TypeContext where
+  build = buildRenderDoc
+
 -- | Data type that represents various errors
 -- which are related to type system.
 -- These errors are used to specify info about type check errors
@@ -96,6 +120,9 @@
   -- ^ Error that happens when actual types are different from the type that instruction expects.
   -- The param is an non-empty list of all expected stack types that the instruction would accept.
   -- Each expected stack types is represented as non-empty list as well.
+  | UnexpectedTopLevelType TopLevelType ("expected" :! T.T) ("got" :! T.T)
+  -- ^ Error that happens when the caller expected one top-level type, but
+  -- the contract has another type specified.
   | InvalidInstruction U.ExpandedInstr Text
   -- ^ Some instruction is invalid or used in an invalid way.
   -- For example, @PAIR 0@ or @PAIR 1@, or a @SELF@ instruction was used in a @LAMBDA@.
@@ -137,49 +164,59 @@
   deriving anyclass (NFData)
 
 instance Buildable TCTypeError where
-  build = \case
-    AnnError e -> build e
+  build = buildRenderDocExtended
+
+instance RenderDoc TCTypeError where
+  renderDoc context = \case
+    AnnError e -> renderAnyBuildable e
     TypeEqError type1 type2 ->
-      "Types not equal: " +| type1 |+ " /= " +| type2 |+ ""
+      "Types not equal:" <+> (renderDoc context type1) <+> "/=" <+> (renderDoc context type2)
     StackEqError st1 st2 ->
-      "Stacks not equal: " +| buildStack st1 |+ " /= " +| buildStack st2 |+ ""
+      "Stacks not equal:"<+> (renderDocList context st1) <+> "/=" <+> (renderDocList context st2)
     UnsupportedTypeForScope typ reason ->
-      "Type '" +| typ |+ "' is unsupported here because it "
-      +| reason |+ ""
+      "Type '" <> (renderDoc context typ) <> "' is unsupported here because it"
+      <+> (renderDoc context reason)
     NotNumericTypes t1 t2 ->
-      "Some of the types in an arithmetic operation are not numeric: "
-      +| t1 |+ " and " +| t2 |+ ""
+      "Some of the types in an arithmetic operation are not numeric:"
+      <+> (renderDoc context t1) <+> "and" <+> (renderDoc context t2)
     UnexpectedType (t :| ts) ->
-      "Wrong stack type for instruction, expect stack type to begin with " +|
-        ( intercalate " or "
-          $ fmap (\(x :| xs) -> "" +| listF (x:xs) |+ "")
+      "Wrong stack type for instruction, expect stack type to begin with " <+>
+        (cat $ punctuate "or"
+          $ fmap (\(x :| xs) -> list $ fmap (renderAnyBuildable) (x:xs))
           $ (t:ts)
-        ) |+ ""
-    InvalidInstruction instr reason -> unlinesF
-      [ "Invalid instruction " +| instr |+ ""
-      , "Reason: " <> reason
-      ]
+        )
+    UnexpectedTopLevelType tyDesc (arg #expected -> expected) (arg #got -> got) ->
+      "Unexpected" <+> renderDoc context tyDesc <+> "type:"
+      <$$> renderLargeType got
+      <$$> "Expected:"
+      <$$> renderLargeType expected
+    InvalidInstruction instr reason ->
+      "Invalid instruction" <+> (renderDoc context instr)
+      <$$> "Reason:" <+> textStrict reason
     InvalidValueType t ->
-      "Value type is never a valid `" +| t |+ "`"
+      "Value type is never a valid" <+> enclose "`" "`" (renderDoc context t)
     NotEnoughItemsOnStack ->
       "Not enough items on stack"
     UnknownContract addr ->
-      "Contract is not registered: " +| addr |+ ""
-    IllegalEntrypoint err -> build err
+      "Contract is not registered:" <+> (renderAnyBuildable addr)
+    IllegalEntrypoint err -> renderDoc context err
     EntrypointNotFound ep ->
-      "No such entrypoint '" +| ep |+ "'"
-    IllegalParamDecl err -> build err
+      "No such entrypoint" <+> enclose "`" "`" (renderAnyBuildable ep)
+    IllegalParamDecl err -> renderDoc context err
     NegativeNat -> "Natural number cannot be negative"
     MutezOverflow -> "Exceeds maximal value for mutez"
-    InvalidAddress e -> build e
-    InvalidKeyHash e -> build e
-    InvalidBls12381Object e -> build e
+    InvalidAddress e -> renderDoc context e
+    InvalidKeyHash e -> renderDoc context e
+    InvalidBls12381Object e -> renderDoc context e
     InvalidTimestamp -> "Is not a valid RFC3339 timestamp"
     CodeAlwaysFails ->
       "Cannot use a terminate instruction (like FAILWITH) as part of another \
       \instruction's body"
     EmptyCode -> "Code block is empty"
     AnyError -> "Some of the arguments have invalid types"
+    where
+      renderLargeType :: T.T -> Doc
+      renderLargeType = indent 2 . renderDoc doesntNeedParens . T.toUType
 
 -- | Type check error
 data TCError
@@ -194,42 +231,50 @@
 instance NFData TCError
 
 instance Buildable TCError where
-  build = \case
-    TCFailedOnInstr instr (SomeHST t) ics mbTCTypeContext mbTCTypeError ->
-      "Error checking expression "
-      +| instr |+ " against input stack type "
-      +| t |+ maybe "" (\c -> ". Error in " +| c |+ "") mbTCTypeContext
-      +| maybe ". " (\e -> ": " +| e |+ ". ") mbTCTypeError
-      +| buildCallStack ics
+  build = buildRenderDocExtended
+
+instance RenderDoc TCError where
+  renderDoc context = \case
+    TCFailedOnInstr instr (SomeHST t) ics mbTCTypeContext mbTCTypeError -> line
+      <> "Error checking expression:"
+      <> surroundWithNewLines (renderDoc context instr)
+      <> "against input stack type:"
+      <> surroundWithNewLines (renderDoc context t)
+      <> maybe "" (\c -> "Error in" <+> renderDoc context c) mbTCTypeContext
+      <> maybe "" (\e -> ":" <+> (renderDoc context e) <> "." <$$> line) mbTCTypeError
+      <> (renderDoc context ics)
     TCFailedOnValue v t custom ics mbTCTypeError ->
-      "Error checking value "
-      +| v |+ " against type "
-      +| toUType t |+ bool (": " +| custom |+ " ") "." (null custom)
-      +| (maybe "" (\e -> "\n" +| e |+ ".\n") mbTCTypeError)
-      +| buildCallStack ics
+      "Error checking value"
+      <$$> (renderDoc context v) <+> "against type"
+      <+> (renderDoc context t) <> (bool (":" <+> (renderAnyBuildable custom)) "." (null custom))
+      <+> (maybe "" (\e -> line <> (renderDoc context e) <> line) mbTCTypeError)
+      <+> (renderDoc context ics)
     TCContractError msg typeError ->
-      "Error occurred during contract typecheck: "
-      +|| msg ||+ (maybe "" (\e -> " " +| e |+ "") typeError)
+      "Error occurred during contract typecheck:"
+      <$$> (renderAnyBuildable msg) <> (maybe "" (\e -> " " <> (renderDoc context e)) typeError)
     TCUnreachableCode ics instrs ->
-      "Unreachable code: " +| buildTruncated 3 (toList instrs) |+ ". "
-      +| buildCallStack ics
+      "Unreachable code:" <$$> buildTruncated 3 (toList instrs) <> "."
+      <+> (renderDoc context ics)
     TCExtError (SomeHST t) ics e ->
-      "Error occurred during Morley extension typecheck: "
-      +| e |+ " on stack " +| t |+ ". "
-      +| buildCallStack ics
+      "Error occurred during Morley extension typecheck:" <>
+      (renderAnyBuildable e) <+> "on stack" <+> (renderDoc context t) <> "."
+      <+> (renderDoc context ics)
     TCIncompletelyTyped err contract ->
-      "\n"
-      +| printDocB False (renderDoc doesntNeedParens contract) |+ "\n"
-      +| build err
+      line
+      <> renderDoc doesntNeedParens contract
+      <$> renderDoc context err
     where
     buildTruncated k l
-      | null (drop k l) = build l
-      | otherwise = build (take k l) <> " ..."
-    buildCallStack InstrCallStack{icsCallStack, icsSrcPos = SrcPos (Pos line) (Pos col)} =
-      "Error occurred on line " +| line + 1 |+ " char " +| col + 1 |+ ""
-      +| case icsCallStack of
-           [] -> "."
-           _ -> " inside these let defenitions: " +| listF icsCallStack |+ "."
+      | null (drop k l) = renderDocList context l
+      | otherwise = (renderDocList context (take k l)) <> " ..."
+
+    -- | Helper to format a line using empty lines at the end and at the beginning,
+    -- and 4-space indents for the line itself
+    surroundWithNewLines :: Doc -> Doc
+    surroundWithNewLines l =
+      line
+      <$$> indent 4 l
+      <$$> line
 
 instance Show TCError where
   show = pretty
diff --git a/src/Michelson/TypeCheck/Ext.hs b/src/Michelson/TypeCheck/Ext.hs
--- a/src/Michelson/TypeCheck/Ext.hs
+++ b/src/Michelson/TypeCheck/Ext.hs
@@ -11,6 +11,7 @@
 import Control.Monad.Except (MonadError, liftEither, throwError)
 import Data.Constraint (Dict(..))
 import Data.Map.Lazy (insert, lookup)
+import Data.Singletons (SingI)
 import Data.Typeable ((:~:)(..))
 
 import Michelson.ErrorPos
@@ -25,7 +26,7 @@
   (ExpandedOp, StackFn, TyVar(..), Ty, Var, VarAnn, sfnInPattern, sfnOutPattern,
   sfnQuantifiedVars, varSet)
 import qualified Michelson.Untyped as U
-import Util.Peano (SingNat(SS, SZ))
+import Util.PeanoNatural (PeanoNatural(..))
 
 -- | Perform some, possibly throwing, action presumably making use of a supplied
 -- external instruction. In case of an error, return @IllTypedSeq@ wrapping the
@@ -40,7 +41,7 @@
   (pure . WellTypedSeq)
 
 typeCheckExt
-  :: forall s. Typeable s
+  :: forall s. SingI s
   => TcInstrHandler
   -> U.ExpandedExtInstr
   -> HST s
@@ -49,8 +50,8 @@
   instrPos <- ask
   case ext of
     U.STACKTYPE s -> workOnInstr ext $
-      liftExtError hst $ nopSomeInstr <$ checkStackType noBoundVars s hst
-    U.FN t sf op  -> checkFn tcInstr t sf op hst
+      liftExtError hst $ stackTypeSomeInstr s <$ checkStackType noBoundVars s hst
+    U.FN t sf op  -> checkFn tcInstr t sf op hst instrPos
     U.UPRINT pc   -> workOnInstr ext $
       verifyPrint pc <&> \tpc -> toSomeInstr (T.PRINT tpc)
     U.UTEST_ASSERT U.TestAssert{..} -> do
@@ -81,9 +82,9 @@
       T.PrintComment <$> traverse checkStRef pc
 
     toSomeInstr ext' = hst :/ T.Ext ext' ::: hst
-    nopSomeInstr = hst :/ T.Nop ::: hst
+    stackTypeSomeInstr s = hst :/ T.Ext (T.STACKTYPE s) ::: hst
 
-liftExtError :: Typeable s => HST s -> Either ExtError a -> TypeCheckInstr a
+liftExtError :: SingI s => HST s -> Either ExtError a -> TypeCheckInstr a
 liftExtError hst ei = do
   instrPos <- ask
   liftEither $ first (TCExtError (SomeHST hst) instrPos) ei
@@ -98,18 +99,19 @@
 -- | Executes function body, pushing @ExtFrame@ onto the state and checks
 -- the pattern in @FN@.
 checkFn
-  :: Typeable inp
+  :: SingI inp
   => TcInstrHandler
   -> Text
   -> StackFn
   -> [ExpandedOp]
   -> HST inp
+  -> InstrCallStack
   -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)
-checkFn tcInstr t sf body inp = do
+checkFn tcInstr t sf body inp loc = do
   guarding (con body) (checkStart inp) $ \vars ->
     preserving (typeCheckImplStripped tcInstr body inp) con $ \someI@(_ :/ instrAndOut) ->
       case instrAndOut of
-        _ ::: out -> checkEnd vars out $> someI
+        _ ::: out -> checkEnd vars out $> mapSomeInstr (T.WithLoc loc . T.Fn t sf) someI
         AnyOutInstr{} -> pure someI
   where
     checkStart hst = do
@@ -118,7 +120,7 @@
       tcExtFramesL %= (vars :)
       return vars
 
-    checkEnd :: Typeable out => BoundVars -> HST out -> TypeCheckInstr ()
+    checkEnd :: SingI out => BoundVars -> HST out -> TypeCheckInstr ()
     checkEnd vars out = liftExtError out $
       void $ checkStackType vars (sfnOutPattern sf) out
 
@@ -127,14 +129,14 @@
 
 -- | Check that a @StackTypePattern@ matches the type of the current stack
 checkStackType
-  :: Typeable xs
+  :: SingI xs
   => BoundVars
   -> U.StackTypePattern
   -> HST xs
   -> Either ExtError BoundVars
 checkStackType (BoundVars vars boundStkRest) s hst = go vars 0 s hst
   where
-    go :: Typeable xs => Map Var Ty -> Int -> U.StackTypePattern -> HST xs
+    go :: SingI xs => Map Var Ty -> Int -> U.StackTypePattern -> HST xs
        -> Either ExtError BoundVars
     go m _ U.StkRest sr = case boundStkRest of
       Nothing -> pure $ BoundVars m (Just $ SomeHST sr)
@@ -165,7 +167,7 @@
 --
 -- Fails when index is too large for the given stack.
 createStackRef
-  :: (MonadError TCError m, MonadReader InstrCallStack m, Typeable s)
+  :: (MonadError TCError m, MonadReader InstrCallStack m, SingI s)
   => Natural -> HST s -> m (T.StackRef s)
 createStackRef idx hst =
   case doCreate (hst, idx) of
@@ -179,7 +181,7 @@
     doCreate :: forall s. (HST s, Natural) -> Maybe (T.StackRef s)
     doCreate = \case
       (SNil, _) -> Nothing
-      ((_ ::& _), 0) -> Just (T.StackRef SZ)
+      ((_ ::& _), 0) -> Just (T.StackRef Zero)
       ((_ ::& st), i) -> do
         T.StackRef ns <- doCreate (st, i - 1)
-        return $ T.StackRef (SS ns)
+        return $ T.StackRef (Succ ns)
diff --git a/src/Michelson/TypeCheck/Helpers.hs b/src/Michelson/TypeCheck/Helpers.hs
--- a/src/Michelson/TypeCheck/Helpers.hs
+++ b/src/Michelson/TypeCheck/Helpers.hs
@@ -51,8 +51,8 @@
 import Data.Constraint (Dict(..), withDict)
 import Data.Default (def)
 import Data.Singletons (Sing, SingI(sing), demote)
+import Data.Singletons.Decide
 import qualified Data.Text as T
-import Data.Typeable (eqT, (:~:)(..))
 import Data.Vinyl (Rec(..))
 import Fmt ((+||), (||+))
 
@@ -63,15 +63,16 @@
 import Michelson.TypeCheck.Types
 import Michelson.Typed
   (BadTypeForScope(..), CommentType(StackTypeComment), Comparable, ExtInstr(COMMENT_ITEM),
-  Instr(..), KnownT, Notes(..), SingT(..), T(..), WellTyped, converge, getComparableProofS, notesT,
-  starNotes)
+  Instr(..), Notes(..), SingT(..), T(..), WellTyped, converge, getComparableProofS, notesT,
+  requireEq, starNotes)
 import Michelson.Typed.Annotation (AnnConvergeError, isStar)
 import Michelson.Typed.Arith (Add, ArithOp(..), Mul, Sub, UnaryArithOp(..))
 import Michelson.Typed.Polymorphic
   (ConcatOp, EDivOp(..), GetOp(..), MemOp(..), SizeOp, SliceOp, UpdOp(..))
-
 import qualified Michelson.Untyped as Un
-import Michelson.Untyped.Annotation (Annotation(..), FieldAnn, VarAnn, orAnn, annQ, mkAnnotationUnsafe, noAnn)
+import Michelson.Untyped.Annotation
+  (Annotation(..), FieldAnn, VarAnn, annQ, noAnn, orAnn, unsafeMkAnnotation)
+import Util.Sing (eqI)
 import Util.Type (onFirst)
 
 -- | Function which derives special annotations
@@ -100,7 +101,7 @@
     splitLastDot v = case unsnoc $ T.splitOn "." $ unAnnotation v of
       Nothing      -> def
       Just (_, "") -> (def, Un.convAnn v)
-      Just (vs, l) -> (foldMap mkAnnotationUnsafe vs, bool (mkAnnotationUnsafe l) def (l == "car" || l == "cdr"))
+      Just (vs, l) -> (foldMap unsafeMkAnnotation vs, bool (unsafeMkAnnotation l) def (l == "car" || l == "cdr"))
 
     commonPrefix :: VarAnn -> VarAnn -> VarAnn
     commonPrefix = curry \case
@@ -114,6 +115,9 @@
 deriveSpecialVN :: VarAnn -> FieldAnn -> VarAnn -> VarAnn -> VarAnn
 deriveSpecialVN vn elFn pairVN elVn
   | (unAnnotation vn) == "%" = Un.convAnn elFn
+  -- TODO [#534]:
+  -- In the `%%` branch, if the pair's field annotation (`elFn`) is empty, we should default it to "cdr"/"car".
+  -- See: <https://tezos.gitlab.io/008/michelson.html#automatic-variable-and-field-annotations-inferring>
   | (unAnnotation vn) == "%%" = pairVN <> Un.convAnn elFn
   | otherwise = vn `orAnn` elVn
 
@@ -163,11 +167,10 @@
 
 -- | Check whether the given stack types are equal.
 eqHST
-  :: forall as bs.
-      (Typeable as, Typeable bs)
+  :: forall as bs. (SingI as, SingI bs)
   => HST as -> HST bs -> Either TCTypeError (as :~: bs)
 eqHST (hst :: HST xs) (hst' :: HST ys) = do
-  case eqT @as @bs of
+  case eqI @as @bs of
     Nothing -> Left $ StackEqError (hstToTs hst) (hstToTs hst')
     Just Refl -> do
       void $ convergeHST hst hst' `onFirst` AnnError
@@ -176,12 +179,11 @@
 -- | Check whether the given stack has size 1 and its only element matches the
 -- given type. This function is a specialized version of `eqHST`.
 eqHST1
-  :: forall t st.
-      (Typeable st, WellTyped t)
+  :: forall t st. (SingI st, WellTyped t)
   => HST st -> Either TCTypeError (st :~: '[t])
 eqHST1 hst = do
   let hst' = sing @t -:& SNil
-  case eqT @'[t] @st of
+  case eqI @'[t] @st of
     Nothing -> Left $ StackEqError (hstToTs hst') (hstToTs hst)
     Just Refl -> Right Refl
 
@@ -203,13 +205,13 @@
     else Left $ "Entries are unordered (" +|| e1 ||+ " >= " +|| e2 ||+ ")"
   l -> Right l
 
--- | Function @eqType@ is a simple wrapper around @Data.Typeable.eqT@ suited
+-- | Function @eqType@ is a simple wrapper around @Data.Singletons.decideEquality@ suited
 -- for use within @Either TCTypeError a@ applicative.
 eqType
-  :: forall (a :: T) (b :: T).
-      (Each '[KnownT] [a, b])
+  :: forall (a :: T) (b :: T). (Each '[SingI] [a, b])
   => Either TCTypeError (a :~: b)
-eqType = maybe (Left $ TypeEqError (demote @a) (demote @b)) pure eqT
+eqType =
+  requireEq @a @b $ Left ... TypeEqError
 
 onTypeCheckInstrErr
   :: (MonadReader InstrCallStack m, MonadError TCError m)
@@ -247,14 +249,14 @@
   throwError $ TCFailedOnInstr instr hst pos mContext (Just err)
 
 onTypeCheckInstrAnnErr
-  :: (MonadReader InstrCallStack m, MonadError TCError m, Typeable ts)
+  :: (MonadReader InstrCallStack m, MonadError TCError m, SingI ts)
   => Un.ExpandedInstr -> HST ts -> Maybe TypeContext
   -> Either AnnConvergeError a -> m a
 onTypeCheckInstrAnnErr instr i mContext ei =
   onTypeCheckInstrErr instr (SomeHST i) mContext (ei `onFirst` AnnError)
 
 withCompareableCheck
-  :: forall a m v ts. (Typeable ts, MonadReader InstrCallStack m, MonadError TCError m)
+  :: forall a m v ts. (SingI ts, MonadReader InstrCallStack m, MonadError TCError m)
   => Sing a
   -> Un.ExpandedInstr
   -> HST ts
@@ -265,7 +267,7 @@
   Nothing -> typeCheckInstrErr instr (SomeHST i) $ Just ComparisonArguments
 
 typeCheckOpImpl
-  :: forall inp. Typeable inp
+  :: forall inp. SingI inp
   => TcInstrHandler
   -> Un.ExpandedOp
   -> HST inp
@@ -293,11 +295,11 @@
                   <&> mapSeq (addNotes . mapSomeInstr Nested)
 
     addNotes :: SomeInstr inp -> SomeInstr inp
-    addNotes (inp :/ i ::: out) = inp :/ wrapWithNotes inp out i ::: out
+    addNotes (inp :/ i ::: out) = inp :/ wrapWithNotes out i ::: out
     addNotes i = i
 
-    wrapWithNotes :: HST c -> HST d -> Instr c d -> Instr c d
-    wrapWithNotes inputStack outputStack instr = case instr of
+    wrapWithNotes :: HST d -> Instr c d -> Instr c d
+    wrapWithNotes outputStack instr = case instr of
       -- Abstractions for instructions:
       Nop -> instr'
       Seq _ _ -> instr'
@@ -306,6 +308,7 @@
       Ext _ -> instr'
       FrameInstr _ _ -> instr'
       WithLoc _ _ -> instr'
+      Fn {} -> instr'
       -- These three shouldn't happen, since annotations are added here.
       InstrWithNotes {} -> instr'
       InstrWithVarAnns _ _ -> instr'
@@ -329,6 +332,24 @@
       FAILWITH -> instr'
       NEVER -> instr'
 
+      -- These instructions technically may have one/two explicit var anns, BUT because they support special var anns,
+      -- the var anns are stored directly inside the instruction's constructor.
+      -- For this reason, they must NOT be wrapped in `InstrWithVarNotes`.
+      AnnCAR _ _ -> instr'
+      AnnCDR _ _ -> instr'
+      AnnUNPAIR{} ->
+        case outputStack of
+          (notes1, _, varAnn1) ::& (notes2, _, varAnn2) ::& _ ->
+            let withNotes
+                  | isStar notes1 && isStar notes2 = id
+                  | isStar notes2 = InstrWithNotes Proxy (notes1 :& RNil)
+                  | otherwise = InstrWithNotes Proxy (notes1 :& notes2 :& RNil)
+                withVarAnns
+                  | varAnn1 == def && varAnn2 == def = id
+                  | varAnn2 == def = InstrWithVarAnns $ Un.OneVarAnn varAnn1
+                  | otherwise = InstrWithVarAnns (Un.TwoVarAnns varAnn1 varAnn2)
+            in withNotes $ withVarAnns instr
+
       -- We purposefully don't wrap `UNPAIRN` in meta-instructions
       -- like `InstrWithNotes` and `InstrWithVarAnns`.
       -- See !769 for a lengthy explanation.
@@ -354,20 +375,6 @@
               withVarNotes' = if valVarAnn == Un.noAnn && mapVarAnn == Un.noAnn then id else InstrWithVarAnns $ Un.TwoVarAnns valVarAnn mapVarAnn
           in  withNotes . withVarNotes . withVarNotes' $ instr
 
-      -- Instructions that produce at most one note:
-      -- The cases for Ann{CAR,CDR} basically try to answer the question:
-      -- were the var annotations explicitly written or do they come from
-      -- unnesting nested annotations?
-      AnnCAR _ -> case (inputStack, outputStack) of
-        ((NTPair _ _ _ vn1 _vn2 _ _, _, _) ::& _, (_, _, vn) ::& _)
-          | vn  /= def && vn /= vn1 -> instr''
-          | vn1 == def -> instr''
-          | otherwise -> instr'
-      AnnCDR _ -> case (inputStack, outputStack) of
-        ((NTPair _ _ _ _vn1 vn2 _ _, _, _) ::& _, (_, _, vn) ::& _)
-          | vn  /= def && vn /= vn2 -> instr''
-          | vn2 == def -> instr''
-          | otherwise -> instr'
       DUP -> instr''
       DUPN _ -> instr''
       PUSH _ -> instr''
@@ -445,6 +452,10 @@
       SHA3 -> instr''
       KECCAK -> instr''
       PAIRING_CHECK -> instr''
+      TICKET -> instr''
+      READ_TICKET -> instr''
+      SPLIT_TICKET -> instr''
+      JOIN_TICKETS -> instr''
       where
         instr' = addNotesNoVarAnn outputStack instr
         instr'' = addNotesOneVarAnn outputStack instr
@@ -469,7 +480,7 @@
 -- | Like 'typeCheckImpl' but doesn't add a stack type comment after the
 -- sequence.
 typeCheckImplNoLastTypeComment
-  :: forall inp . Typeable inp
+  :: forall inp . SingI inp
   => TcInstrHandler
   -> [Un.ExpandedOp]
   -> HST inp
@@ -522,7 +533,7 @@
 -- | Like 'typeCheckImpl' but without the first and the last stack type
 -- comments. Useful to reduce duplication of stack type comments.
 typeCheckImplStripped
-  :: forall inp . Typeable inp
+  :: forall inp . SingI inp
   => TcInstrHandler
   -> [Un.ExpandedOp]
   -> HST inp
@@ -534,7 +545,7 @@
   continueTypeChecking tcInstr done ops
 
 typeCheckImpl
-  :: forall inp . Typeable inp
+  :: forall inp . SingI inp
   => TcInstrHandler
   -> [Un.ExpandedOp]
   -> HST inp
@@ -605,7 +616,7 @@
 -- | Check whether given types are structurally equal and annotations converge.
 matchTypes
   :: forall t1 t2.
-      (Each '[KnownT] [t1, t2])
+      (Each '[SingI] [t1, t2])
   => Notes t1 -> Notes t2 -> Either TCTypeError (t1 :~: t2, Notes t1)
 matchTypes n1 n2 = do
   Refl <- eqType @t1 @t2
@@ -620,8 +631,9 @@
 memImpl
   :: forall c memKey rs inp m .
     ( MemOp c
-    , KnownT (MemOpKey c)
+    , SingI (MemOpKey c)
     , inp ~ (memKey : c : rs)
+    , SingI rs
     , MonadReader InstrCallStack m
     , MonadError TCError m
     )
@@ -630,7 +642,7 @@
   -> VarAnn
   -> m (SomeInstr inp)
 memImpl cKeyNotes inputHST@(hst0 ::& _ ::& hstTail) varAnn =
-  case eqType @memKey  @(MemOpKey c) of
+  case eqType @memKey @(MemOpKey c) of
     Right Refl -> do
       _ <- onTypeCheckInstrAnnErr uInstr inputHST
         (Just ContainerKeyType) (converge memKeyNotes cKeyNotes)
@@ -644,9 +656,10 @@
 
 getImpl
   :: forall c getKey rs inp m .
-    ( GetOp c, KnownT (GetOpKey c)
+    ( GetOp c, SingI (GetOpKey c)
     , WellTyped (GetOpVal c)
     , inp ~ (getKey : c : rs)
+    , SingI rs
     , MonadReader InstrCallStack m
     , MonadError TCError m
     )
@@ -671,7 +684,8 @@
 updImpl
   :: forall c updKey updParams rs inp m .
     ( UpdOp c
-    , KnownT (UpdOpKey c), KnownT (UpdOpParams c)
+    , SingI (UpdOpKey c), SingI (UpdOpParams c)
+    , SingI rs
     , inp ~ (updKey : updParams : c : rs)
     , MonadReader InstrCallStack m
     , MonadError TCError m
@@ -703,9 +717,10 @@
 getUpdImpl
   :: forall c updKey updParams rs inp m .
     ( UpdOp c, GetOp c
-    , KnownT (UpdOpKey c)
-    , KnownT (GetOpVal c)
+    , SingI (UpdOpKey c)
+    , SingI (GetOpVal c)
     , inp ~ (updKey : updParams : c : rs)
+    , SingI rs
     , GetOpKey c ~ UpdOpKey c
     , UpdOpParams c ~ 'TOption (GetOpVal c)
     , MonadReader InstrCallStack m
@@ -744,7 +759,7 @@
   pure $ i :/ SIZE ::: ((starNotes, Dict, vn) ::& rs)
 
 sliceImpl
-  :: (SliceOp c, Typeable c, inp ~ ('TNat ': 'TNat ': c ': rs), Monad m)
+  :: (SliceOp c, inp ~ ('TNat ': 'TNat ': c ': rs), Monad m)
   => HST inp
   -> Un.VarAnn
   -> m (SomeInstr inp)
@@ -779,7 +794,6 @@
 arithImpl
   :: forall aop inp m n s t.
      ( ArithOp aop n m
-     , Typeable (ArithRes aop n m ': s)
      , WellTyped (ArithRes aop n m)
      , inp ~ (n ': m ': s)
      , MonadReader InstrCallStack t
@@ -799,9 +813,9 @@
 
 addImpl
   :: forall a b inp rs m.
-     ( Typeable rs
-     , Each '[KnownT] [a, b]
+     ( Each '[SingI] [a, b]
      , inp ~ (a ': b ': rs)
+     , SingI rs
      , MonadReader InstrCallStack m
      , MonadError TCError m
      )
@@ -826,8 +840,8 @@
 
 edivImpl
   :: forall a b inp rs m.
-     ( Typeable rs
-     , Each '[KnownT] [a, b]
+     ( SingI rs
+     , Each '[SingI] [a, b]
      , inp ~ (a ': b ': rs)
      , MonadReader InstrCallStack m
      , MonadError TCError m
@@ -868,9 +882,9 @@
 
 subImpl
   :: forall a b inp rs m.
-     ( Typeable rs
-     , Each '[KnownT] [a, b]
+     ( Each '[SingI] [a, b]
      , inp ~ (a ': b ': rs)
+     , SingI rs
      , MonadReader InstrCallStack m
      , MonadError TCError m
      )
@@ -892,9 +906,9 @@
 
 mulImpl
   :: forall a b inp rs m.
-     ( Typeable rs
-     , Each '[KnownT] [a, b]
+     ( Each '[SingI] [a, b]
      , inp ~ (a ': b ': rs)
+     , SingI rs
      , MonadReader InstrCallStack m
      , MonadError TCError m
      )
@@ -923,8 +937,7 @@
 -- | Helper function to construct instructions for unary arithmetic
 -- operations.
 unaryArithImpl
-  :: ( Typeable (UnaryArithRes aop n ': s)
-     , WellTyped (UnaryArithRes aop n)
+  :: ( WellTyped (UnaryArithRes aop n)
      , inp ~ (n ': s)
      , Monad t
      )
@@ -938,8 +951,7 @@
 -- | Helper function to construct instructions for unary arithmetic
 -- operations that should preserve annotations.
 unaryArithImplAnnotated
-  :: ( Typeable (UnaryArithRes aop n ': s)
-     , WellTyped (UnaryArithRes aop n)
+  :: ( WellTyped (UnaryArithRes aop n)
      , inp ~ (n ': s)
      , Monad t
      , n ~ UnaryArithRes aop n
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
@@ -36,9 +36,12 @@
     , typeCheckListNoExcept
     , typeCheckParameter
     , typeCheckStorage
+    , typeCheckTopLevelType
     , typeCheckValue
+    , typeVerifyContract
     , typeVerifyParameter
     , typeVerifyStorage
+    , typeVerifyTopLevelType
     ) where
 
 import Prelude hiding (EQ, GT, LT)
@@ -46,8 +49,10 @@
 import Control.Monad.Except (MonadError, catchError, liftEither, throwError)
 import Data.Default (def)
 import Data.Generics (everything, mkQ)
-import Data.Singletons (Sing, demote)
+import Data.Singletons (Sing, demote, withSingI, withSomeSing)
 import Data.Typeable ((:~:)(..))
+import Fmt (pretty)
+import Named ((!))
 
 import Michelson.ErrorPos
 import Michelson.TypeCheck.Error
@@ -63,38 +68,59 @@
 
 import Michelson.Typed hiding (Branch(..))
 import Util.Peano
+import Util.PeanoNatural
+import Util.Sing (SingI1(..))
 import Util.Type (onFirst, type (++))
 
 import qualified Michelson.Untyped as U
-import Michelson.Untyped.Annotation (FieldTag, VarAnn, VarTag, convAnn, orAnn, annQ)
+import Michelson.Untyped.Annotation (FieldTag, VarAnn, VarTag, annQ, convAnn, orAnn)
 
 -- | Type check a contract and verify that the given storage
 -- is of the type expected by the contract.
-typeCheckContractAndStorage :: U.Contract -> U.Value -> Either TCError SomeContractAndStorage
+typeCheckContractAndStorage
+  :: U.Contract -> U.Value -> TypeCheckResult SomeContractAndStorage
 typeCheckContractAndStorage uContract uStorage = do
-  SomeContract (contract@Contract{} :: Contract cp st) <- typeCheckContract uContract def
+  SomeContract (contract@Contract{} :: Contract cp st) <- typeCheckContract uContract
   storage <- typeVerifyStorage @st uStorage
-  Right $ SomeContractAndStorage contract storage
+  pure $ SomeContractAndStorage contract storage
 
 typeCheckContract
   :: U.Contract
-  -> TypeCheckOptions
-  -> Either TCError SomeContract
-typeCheckContract c options = do
-  paramType <- mkSomeParamType (U.contractParameter c)
-  runTypeCheck (TypeCheckContract paramType) options $ typeCheckContractImpl c
+  -> TypeCheckResult SomeContract
+typeCheckContract c = do
+  paramType <- liftEither $ mkSomeParamType (U.contractParameter c)
+  runTypeCheck (TypeCheckContract paramType) $ typeCheckContractImpl c
 
+typeVerifyContract
+  :: forall cp st.
+     (SingI cp, SingI st)
+  => U.Contract -> TypeCheckResult (Contract cp st)
+typeVerifyContract uContract = do
+  SomeContract tContract@(Contract{} :: Contract cp' st') <-
+    typeCheckContract uContract
+  Refl <- requireEq @cp' @cp (mkErr TltParameterType)
+  Refl <- requireEq @st' @st (mkErr TltParameterType)
+  return tContract
+  where
+    mkErr :: TopLevelType -> T -> T -> TypeCheckResult any
+    mkErr tyDesc got expected =
+      throwError $ TCContractError "error in contract type" $ Just $
+          UnexpectedTopLevelType tyDesc
+            ! #expected expected
+            ! #got got
+
 withWTP :: forall t a. SingI t => (WellTyped t => TypeCheck a) -> TypeCheck a
 withWTP fn = case getWTP @t of
   Right Dict -> fn
-  Left (NotWellTyped t) -> throwError $ TCContractError ("Not a well typed value: " <> show t) Nothing
+  Left (NotWellTyped t cause) -> throwError $ TCContractError
+    ("Not a well typed value: '" <> show t <> "' because it " <> pretty cause) Nothing
 
 withWTPInstr_ :: forall t a. SingI t => U.ExpandedInstr -> SomeHST -> (WellTyped t => TypeCheckInstr a) -> TypeCheckInstr a
 withWTPInstr_ v t fn = case getWTP @t of
   Right Dict -> fn
-  Left (NotWellTyped badType) -> do
+  Left (NotWellTyped badType cause) -> do
     loc <- ask
-    throwError $ TCFailedOnInstr v t loc Nothing (Just $ UnsupportedTypeForScope badType BtNotComparable)
+    throwError $ TCFailedOnInstr v t loc Nothing (Just $ UnsupportedTypeForScope badType cause)
 
 withWTPInstr'_
   :: forall t inp. SingI t
@@ -104,10 +130,10 @@
   -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)
 withWTPInstr'_ v t fn = case getWTP @t of
   Right Dict -> fn
-  Left (NotWellTyped badType) -> do
+  Left (NotWellTyped badType cause) -> do
     loc <- ask
     let err = TCFailedOnInstr v t loc Nothing
-              (Just $ UnsupportedTypeForScope badType BtNotComparable)
+              (Just $ UnsupportedTypeForScope badType cause)
     pure $ IllTypedSeq err [NonTypedInstr $ U.PrimEx v]
 
 typeCheckContractImpl
@@ -202,7 +228,7 @@
 --
 -- As a second argument, @typeCheckList@ accepts input stack type representation.
 typeCheckList
-  :: (Typeable inp)
+  :: (SingI inp)
   => [U.ExpandedOp]
   -> HST inp
   -> TypeCheck (SomeInstr inp)
@@ -215,7 +241,7 @@
 -- Types are checked along the way. It is necessary to embed well typed node as
 -- well as type checking errors into the tree.
 typeCheckListNoExcept
-  :: (Typeable inp)
+  :: (SingI inp)
   => [U.ExpandedOp] -> HST inp -> TypeCheckNoExcept (TypeCheckedSeq inp)
 typeCheckListNoExcept = usingReaderT def ... typeCheckImpl typeCheckInstr
 
@@ -239,19 +265,19 @@
 
 typeVerifyParameter
   :: SingI t
-  => TcOriginatedContracts -> U.Value -> Either TCError (Value t)
+  => TcOriginatedContracts -> U.Value -> TypeCheckResult (Value t)
 typeVerifyParameter originatedContracts = typeVerifyTopLevelType (Just originatedContracts)
 
 typeVerifyStorage
   :: SingI t
-  => U.Value -> Either TCError (Value t)
+  => U.Value -> TypeCheckResult (Value t)
 typeVerifyStorage = typeVerifyTopLevelType Nothing
 
 typeVerifyTopLevelType
   :: forall t. SingI t
-  => Maybe TcOriginatedContracts -> U.Value -> Either TCError (Value t)
+  => Maybe TcOriginatedContracts -> U.Value -> TypeCheckResult (Value t)
 typeVerifyTopLevelType mOriginatedContracts valueU =
-  runTypeCheck (TypeCheckValue (valueU, demote @t)) def $ usingReaderT def $
+  runTypeCheck (TypeCheckValue (valueU, demote @t)) $ usingReaderT def $
     typeCheckValImpl mOriginatedContracts typeCheckInstr valueU
 
 -- | Like 'typeCheckValue', but for values to be used as parameter.
@@ -259,47 +285,47 @@
 -- Also accepts a 'TcOriginatedContracts' in order to be able to type-check
 -- @contract p@ values (which can only be part of a parameter).
 typeCheckParameter
-  :: TcOriginatedContracts -> U.Ty -> U.Value -> Either TCError SomeValue
+  :: TcOriginatedContracts -> U.Ty -> U.Value -> TypeCheckResult SomeValue
 typeCheckParameter originatedContracts = typeCheckTopLevelType (Just originatedContracts)
 
 -- | Like 'typeCheckValue', but for values to be used as storage.
 typeCheckStorage
-  :: U.Ty -> U.Value -> Either TCError SomeValue
+  :: U.Ty -> U.Value -> TypeCheckResult SomeValue
 typeCheckStorage = typeCheckTopLevelType Nothing
 
 typeCheckTopLevelType
-  :: Maybe TcOriginatedContracts -> U.Ty -> U.Value -> Either TCError SomeValue
+  :: Maybe TcOriginatedContracts -> U.Ty -> U.Value -> TypeCheckResult SomeValue
 typeCheckTopLevelType mOriginatedContracts typeU valueU =
-  withSomeSingT (fromUType typeU) $ \(_ :: Sing t) ->
-    SomeValue <$> typeVerifyTopLevelType @t mOriginatedContracts valueU
+  withSomeSing (fromUType typeU) $ \(s :: Sing t) ->
+    withSingI s $ SomeValue <$> typeVerifyTopLevelType @t mOriginatedContracts valueU
 
 -- | Helper data type we use to typecheck DUPN.
 data TCDupNHelper inp where
   TCDupNHelper ::
     forall (n :: Peano) inp out a.
-    (Typeable out, ConstraintDUPN n inp out a) =>
-    Sing n -> HST out -> TCDupNHelper inp
+    (SingI out, ConstraintDUPN n inp out a, DupableScope a) =>
+    PeanoNatural n -> HST out -> TCDupNHelper inp
 
 -- | Helper data type we use to typecheck DROPN.
 data TCDropHelper inp where
   TCDropHelper ::
     forall (n :: Peano) inp out.
-    (Typeable out, SingI n, KnownPeano n, LongerOrSameLength inp n, Drop n inp ~ out) =>
-    Sing n -> HST out -> TCDropHelper inp
+    (SingI out, LongerOrSameLength inp n, Drop n inp ~ out) =>
+    PeanoNatural n -> HST out -> TCDropHelper inp
 
 -- | Helper data type we use to typecheck DIG.
 data TCDigHelper inp where
   TCDigHelper ::
     forall (n :: Peano) inp out a.
-    (Typeable out, ConstraintDIG n inp out a) =>
-    Sing n -> HST out -> TCDigHelper inp
+    (SingI out, ConstraintDIG n inp out a) =>
+    PeanoNatural n -> HST out -> TCDigHelper inp
 
 -- | Helper data type we use to typecheck DUG.
 data TCDugHelper inp where
   TCDugHelper ::
     forall (n :: Peano) inp out a.
-    (Typeable out, ConstraintDUG n inp out a) =>
-    Sing n -> HST out -> TCDugHelper inp
+    (SingI out, ConstraintDUG n inp out a) =>
+    PeanoNatural n -> HST out -> TCDugHelper inp
 
 -- | Helper data type we use to typecheck PAIRN.
 --
@@ -308,8 +334,8 @@
 data TCPairNHelper inp where
   TCPairNHelper ::
     forall (n :: Peano) (inp :: [T]).
-    (Typeable (PairN n inp), ConstraintPairN n inp) =>
-    Sing n -> HST (PairN n inp) -> TCPairNHelper inp
+    (SingI (PairN n inp), ConstraintPairN n inp) =>
+    PeanoNatural n -> HST (PairN n inp) -> TCPairNHelper inp
 
 -- | Helper data type we use to typecheck UNPAIRN.
 --
@@ -318,8 +344,8 @@
 data TCUnpairNHelper (inp :: [T]) where
   TCUnpairNHelper ::
     forall (n :: Peano) (a :: T) (b :: T) (rest :: [T]).
-    (Typeable (UnpairN n ('TPair a b) ++ rest), ConstraintUnpairN n ('TPair a b)) =>
-    Sing n -> HST (UnpairN n ('TPair a b) ++ rest) -> TCUnpairNHelper ('TPair a b : rest)
+    (SingI (UnpairN n ('TPair a b) ++ rest), ConstraintUnpairN n ('TPair a b)) =>
+    PeanoNatural n -> HST (UnpairN n ('TPair a b) ++ rest) -> TCUnpairNHelper ('TPair a b : rest)
 
 -- | Helper data type we use to typecheck GETN.
 --
@@ -328,8 +354,8 @@
 data TCGetNHelper (inp :: [T]) where
   TCGetNHelper ::
     forall (ix :: Peano) (pair :: T) (rest :: [T]).
-    (Typeable (GetN ix pair ': rest), ConstraintGetN ix pair) =>
-    Sing ix -> HST (GetN ix pair ': rest) -> TCGetNHelper (pair : rest)
+    (SingI (GetN ix pair ': rest), ConstraintGetN ix pair) =>
+    PeanoNatural ix -> HST (GetN ix pair ': rest) -> TCGetNHelper (pair : rest)
 
 -- | Helper data type we use to typecheck UPDATEN.
 --
@@ -338,8 +364,8 @@
 data TCUpdateNHelper (inp :: [T]) where
   TCUpdateNHelper ::
     forall (ix :: Peano) (val :: T) (pair :: T) (rest :: [T]).
-    (Typeable (UpdateN ix val pair ': rest), ConstraintUpdateN ix pair) =>
-    Sing ix -> HST (UpdateN ix val pair ': rest) -> TCUpdateNHelper (val : pair : rest)
+    (SingI (UpdateN ix val pair ': rest), ConstraintUpdateN ix pair) =>
+    PeanoNatural ix -> HST (UpdateN ix val pair ': rest) -> TCUpdateNHelper (val : pair : rest)
 
 -- | Helper function to convert a simple throwing typechecking action into a
 -- non-throwing one, embedding possible errors into the type checking tree.
@@ -353,7 +379,7 @@
 
 -- | Less verbose version of `lift ... typeCheckListNoExcept`.
 tcList
-  :: (Typeable inp)
+  :: (SingI inp)
   => [U.ExpandedOp] -> HST inp -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)
 tcList ops stack = lift $ typeCheckListNoExcept ops stack
 
@@ -383,19 +409,22 @@
     go nTotal inputHST <&> \case
       TCDropHelper s out -> inputHST :/ DROPN s ::: out
     where
-      go :: forall inp. Typeable inp
+      go :: forall inp. SingI inp
         => Word
         -> HST inp
         -> TypeCheckInstr (TCDropHelper inp)
       go = curry \case
-        (0, i) -> pure (TCDropHelper SZ i)
+        (0, i) -> pure (TCDropHelper Zero i)
 
         (_, SNil) -> notEnoughItemsOnStack'
 
         (n, (_ ::& iTail)) -> do
-          go (n - 1) iTail <&> \(TCDropHelper s out) -> TCDropHelper (SS s) out
+          go (n - 1) iTail <&> \(TCDropHelper s out) -> TCDropHelper (Succ s) out
 
-  (U.DUP vn1, a@(n, d, _vn2) ::& rs) -> workOnInstr uInstr $
+  (U.DUP vn1, a@(n :: Notes t, d, _vn2) ::& rs) -> workOnInstr uInstr $ do
+    Dict <-
+      onScopeCheckInstrErr @t uInstr (SomeHST inp) Nothing $
+      checkScope @(DupableScope t)
     pure (inp :/ DUP ::: ((n, d, vn1) ::& a ::& rs))
 
   (U.DUP _vn, SNil) -> notEnoughItemsOnStack
@@ -403,7 +432,7 @@
   (U.DUPN vn nTotal, inputHST) -> workOnInstr uInstr $
     go nTotal inputHST <&> \(TCDupNHelper s out) -> inputHST :/ DUPN s ::: out
     where
-      go :: forall inp. Typeable inp
+      go :: forall inp. SingI inp
         => Word
         -> HST inp
         -> TypeCheckInstr (TCDupNHelper inp)
@@ -415,11 +444,15 @@
 
         -- Don't bind whatever variable annotation is here because DUP n doesn't
         -- duplicate variable annotations. This is consistent with tezos-client.
-        (1, i@((an, dict, _) ::& _)) -> pure (TCDupNHelper (SS SZ) ((an, dict, vn) ::& i))
+        (1, i@((an :: Notes a, dict, _) ::& _)) -> do
+          Dict <-
+            onScopeCheckInstrErr @a uInstr (SomeHST inp) Nothing $
+            checkScope @(DupableScope a)
+          pure (TCDupNHelper One ((an, dict, vn) ::& i))
 
         (n, (b ::& iTail)) ->
-          go (n - 1) iTail <&> \(TCDupNHelper s@(SS _) (a ::& resTail)) ->
-            TCDupNHelper (SS s) (a ::& b ::& resTail)
+          go (n - 1) iTail <&> \(TCDupNHelper s@(Succ _) (a ::& resTail)) ->
+            TCDupNHelper (Succ s) (a ::& b ::& resTail)
 
   (U.SWAP, a ::& b ::& rs) -> workOnInstr uInstr $
     pure (inp :/ SWAP ::: (b ::& a ::& rs))
@@ -429,7 +462,7 @@
   (U.DIG nTotal, inputHST) -> workOnInstr uInstr $
     go nTotal inputHST <&> \(TCDigHelper s out) -> inputHST :/ DIG s ::: out
     where
-      go :: forall inp. Typeable inp
+      go :: forall inp. SingI inp
         => Word
         -> HST inp
         -> TypeCheckInstr (TCDigHelper inp)
@@ -437,25 +470,25 @@
         -- Even 'DIG 0' is invalid on empty stack (so it is not strictly `Nop`).
         (_, SNil) -> notEnoughItemsOnStack'
 
-        (0, i@(_ ::& _)) -> pure (TCDigHelper SZ i)
+        (0, i@(_ ::& _)) -> pure (TCDigHelper Zero i)
 
         (n, (b ::& iTail)) ->
           go (n - 1) iTail <&> \(TCDigHelper s (a ::& resTail)) ->
-            TCDigHelper (SS s) (a ::& b ::& resTail)
+            TCDigHelper (Succ s) (a ::& b ::& resTail)
 
   (U.DUG nTotal, inputHST) -> workOnInstr uInstr $
     go nTotal inputHST <&> \(TCDugHelper s out) -> inputHST :/ DUG s ::: out
     where
-      go :: forall inp. Typeable inp
+      go :: forall inp. SingI inp
         => Word
         -> HST inp
         -> TypeCheckInstr (TCDugHelper inp)
       go = curry \case
-        (0, i@(_ ::& _)) -> pure (TCDugHelper SZ i)
+        (0, i@(_ ::& _)) -> pure (TCDugHelper Zero i)
 
         (n, (a ::& b ::& iTail)) ->
           go (n - 1) (a ::& iTail) <&> \(TCDugHelper s resTail) ->
-            TCDugHelper (SS s) (b ::& resTail)
+            TCDugHelper (Succ s) (b ::& resTail)
 
         -- Two cases:
         -- 1. Input stack is empty.
@@ -499,7 +532,27 @@
       pure (inp :/ AnnPAIR tn pfn qfn ::: ((NTPair tn pfn' qfn' avn bvn an bn, Dict, vn') ::& rs))
 
   (U.PAIR {}, _) -> notEnoughItemsOnStack
+  (U.UNPAIR instrVn1 instrVn2 instrFn1 instrFn2, (NTPair _ fn1 fn2 vn1 vn2 n1 n2, Dict, vn) ::& rs) ->
+    workOnInstr uInstr $ do
+      -- We purposefully ignore the result of `convergeDestrAnns` here.
+      -- We're only interested in checking that the instruction's field ann matches the pair's field ann,
+      -- we don't need to "unify" them.
+      _ <- onTypeCheckInstrAnnErr uInstr inp (Just UnpairArgument) (convergeDestrAnns fn1 instrFn1)
+      _ <- onTypeCheckInstrAnnErr uInstr inp (Just UnpairArgument) (convergeDestrAnns fn2 instrFn2)
 
+      let vn1' = deriveSpecialVN instrVn1 fn1 vn vn1
+      let vn2' = deriveSpecialVN instrVn2 fn2 vn vn2
+      pure $
+        inp :/ AnnUNPAIR instrVn1 instrVn2 instrFn1 instrFn2 :::
+          ( (n1, Dict, vn1') ::&
+            (n2, Dict, vn2') ::&
+            rs
+          )
+
+  (U.UNPAIR {}, _ ::& _) ->
+    failWithErr $ UnexpectedType $ ("pair 'a 'b" :| []) :| []
+
+  (U.UNPAIR {}, _) -> notEnoughItemsOnStack
   (U.PAIRN varAnn nTotal, _) -> workOnInstr uInstr $ do
     go nTotal inp <&> \case
       TCPairNHelper s out -> inp :/ PAIRN s ::: addVarAnn out
@@ -511,32 +564,26 @@
               (InvalidInstruction uInstr "'PAIR n' expects n ≥ 2")
         | n == 2 =
             case hst of
-              (an :: Notes a, _, avn) ::& (bn :: Notes b, _, bvn) ::& hstTail -> do
+              (an :: Notes a, _, _) ::& (bn :: Notes b, _, _) ::& hstTail -> do
                 withWTPInstr @('TPair a b) $ do
-                  pure $ TCPairNHelper (SS (SS SZ)) $
-                    (mkNotes an bn avn bvn, Dict, U.noAnn) ::& hstTail
+                  pure $ TCPairNHelper Two $
+                    (mkNotes an bn, Dict, U.noAnn) ::& hstTail
               _ -> notEnoughItemsOnStack'
         | otherwise =
             case hst of
-              (an :: Notes a, _, avn) ::& hstTail@(_ ::& _ ::& _) -> do
+              (an :: Notes a, _, _) ::& hstTail@(_ ::& _ ::& _) -> do
                 go (n - 1) hstTail >>= \case
-                  TCPairNHelper nSing@(SS (SS _)) ((bn :: Notes b, _, bvn) ::& hstTail') -> do
+                  TCPairNHelper nSing@(Succ (Succ _)) ((bn :: Notes b, _, _) ::& hstTail') -> do
                     withWTPInstr @('TPair a b) $ do
-                      pure $ TCPairNHelper (SS nSing) $
-                        (mkNotes an bn avn bvn, Dict, U.noAnn) ::& hstTail'
+                      pure $ TCPairNHelper (Succ nSing) $
+                        (mkNotes an bn, Dict, U.noAnn) ::& hstTail'
               _ -> notEnoughItemsOnStack'
 
-      -- | @PAIR n@ instructions take the variable annotations of each
-      -- element in the stack and turn them into field annotations. E.g.:
-      --
-      -- > /* [ @bb nat : @aa nat ] */ ;
-      -- > PAIR 2
-      -- > /* [ pair (nat %bb) (nat %aa) ] */ ;
-      mkNotes :: forall a b. Notes a -> Notes b -> VarAnn -> VarAnn -> Notes ('TPair a b)
-      mkNotes an bn avn bvn =
+      mkNotes :: forall a b. Notes a -> Notes b -> Notes ('TPair a b)
+      mkNotes an bn =
         NTPair U.noAnn
-          (convAnn @VarTag @FieldTag avn) (convAnn @VarTag @FieldTag bvn)
           U.noAnn U.noAnn
+          U.noAnn U.noAnn
           an bn
 
       -- | If a @PAIR n@ instruction has a variable annotation,
@@ -563,7 +610,7 @@
         | n == 2 =
             case hst of
               (NTPair _ aFieldAnn bFieldAnn _ _ aNotes bNotes, Dict, _) ::& rest -> do
-                pure $ TCUnpairNHelper (SS (SS SZ)) $
+                pure $ TCUnpairNHelper Two $
                   (aNotes, Dict, convAnn @FieldTag @VarTag aFieldAnn)
                   ::& (bNotes, Dict, convAnn @FieldTag @VarTag bFieldAnn)
                   ::& rest
@@ -572,35 +619,34 @@
             case hst of
               (NTPair _ aFieldAnn _ _ _ aNotes bNotes, Dict, _) ::& rest -> do
                 go (n - 1) ((bNotes, Dict, U.noAnn) ::& rest) >>= \case
-                  TCUnpairNHelper nSing@(SS (SS _)) out -> do
-                    pure $ TCUnpairNHelper (SS nSing) $
+                  TCUnpairNHelper nSing@(Succ (Succ _)) out -> do
+                    pure $ TCUnpairNHelper (Succ nSing) $
                       (aNotes, Dict, convAnn @FieldTag @VarTag aFieldAnn) ::& out
               _ -> unexpectedType
 
       unexpectedType :: TypeCheckInstr a
       unexpectedType = failWithErr' $ UnexpectedType $ (pairWithElems nTotal :| []) :| []
 
-  (U.CAR vn fn, (STPair{}, NTPair pairTN pfn qfn pvn qvn (pns :: Notes p) (qns :: Notes q), _, pairVN) ::&+ rs) -> workOnInstr uInstr $ do
-    pfn' <- onTypeCheckInstrAnnErr uInstr inp (Just CarArgument) (convergeDestrAnns fn pfn)
-    withWTPInstr @p $
-      withWTPInstr @('TPair p q) $ do
-        let vn' = deriveSpecialVN vn pfn' pairVN pvn
-            i' = (NTPair pairTN pfn' qfn pvn qvn pns qns, Dict, pairVN) ::& rs
-        pure $ i' :/ AnnCAR fn ::: ((pns, Dict, vn') ::& rs)
+  (U.CAR vn fn, (STPair{}, NTPair _ pfn _ pvn _ pns _, Dict, pairVN) ::&+ rs) -> workOnInstr uInstr $ do
+    -- We purposefully ignore the result of `convergeDestrAnns` here.
+    -- We're only interested in checking that the instruction's field ann matches the pair's field ann,
+    -- we don't need to "unify" them.
+    _ <- onTypeCheckInstrAnnErr uInstr inp (Just CarArgument) (convergeDestrAnns fn pfn)
+    let vn' = deriveSpecialVN vn pfn pairVN pvn
+    pure $ inp :/ AnnCAR vn fn ::: ((pns, Dict, vn') ::& rs)
 
   (U.CAR _ _, _ ::& _) ->
     failWithErr $ UnexpectedType $ ("pair 'a 'b" :| []) :| []
 
   (U.CAR _ _, SNil) -> notEnoughItemsOnStack
 
-  (U.CDR vn fn, (STPair{}, NTPair pairTN pfn qfn pvn qvn (pns :: Notes p) (qns :: Notes q), _, pairVN) ::&+ rs) -> workOnInstr uInstr $ do
-    qfn' <- onTypeCheckInstrAnnErr uInstr inp (Just CdrArgument) (convergeDestrAnns fn qfn)
-
-    withWTPInstr @q $
-      withWTPInstr @('TPair p q) $ do
-        let vn' = deriveSpecialVN vn qfn' pairVN qvn
-            i' = (NTPair pairTN pfn qfn' pvn qvn pns qns, Dict, pairVN) ::& rs
-        pure $ i' :/ AnnCDR fn ::: ((qns, Dict, vn') ::& rs)
+  (U.CDR vn fn, (STPair{}, NTPair _ _ qfn _ qvn _ qns, Dict, pairVN) ::&+ rs) -> workOnInstr uInstr $ do
+    -- We purposefully ignore the result of `convergeDestrAnns` here.
+    -- We're only interested in checking that the instruction's field ann matches the pair's field ann,
+    -- we don't need to "unify" them.
+    _ <- onTypeCheckInstrAnnErr uInstr inp (Just CdrArgument) (convergeDestrAnns fn qfn)
+    let vn' = deriveSpecialVN vn qfn pairVN qvn
+    pure $ inp :/ AnnCDR vn fn ::: ((qns, Dict, vn') ::& rs)
 
   (U.CDR _ _, _ ::& _) ->
     failWithErr $ UnexpectedType $ ("pair 'a 'b" :| []) :| []
@@ -625,9 +671,9 @@
 
   (U.RIGHT {}, SNil) -> notEnoughItemsOnStack
 
-  (U.IF_LEFT mp mq, (STOr{}, ons, _, ovn) ::&+ rs) -> do
+  (U.IF_LEFT mp mq, (STOr lt rt, ons, _, ovn) ::&+ rs) -> do
     case deriveNsOr ons ovn of
-      (an :: Notes a, bn :: Notes b, avn, bvn) ->
+      (an :: Notes a, bn :: Notes b, avn, bvn) -> withSingI lt $ withSingI rt $
         withWTPInstr' @a $
           withWTPInstr' @b $ do
             let
@@ -700,12 +746,12 @@
         withWTPInstr @('TBigMap k v) $
           withCompareableCheck (notesSing ktn) uInstr inp $ i :/ EMPTY_BIG_MAP ::: ((STBigMap sing sing, NTBigMap tn ktn vns, Dict, vn) ::&+ i)
 
-  (U.MAP vn mp, (STList _, NTList _ (vns :: Notes t1), Dict, _vn) ::&+ _) -> do
+  (U.MAP vn mp, (STList l, NTList _ (vns :: Notes t1), Dict, _vn) ::&+ _) -> withSingI l $ do
     withWTPInstr' @t1 $
       mapImpl (U.MAP vn) vns uInstr mp inp
         (\(rn :: Notes t) hst -> withWTPInstr @t $ pure $ (NTList def rn, Dict, vn) ::& hst)
 
-  (U.MAP vn mp, (STMap{}, NTMap _ kns vns, Dict, _vn) ::&+ _) -> do
+  (U.MAP vn mp, (STMap k v, NTMap _ kns vns, Dict, _vn) ::&+ _) -> withSingI k $ withSingI v $ do
     case NTPair def def def def def kns vns of
       (pns :: Notes ('TPair k v1)) ->
         withWTPInstr' @('TPair k v1) $
@@ -720,15 +766,15 @@
 
   (U.MAP _ _, SNil) -> notEnoughItemsOnStack
 
-  (U.ITER is, (STSet (_ :: Sing t1), NTSet _ en, _, _) ::&+ _) -> do
+  (U.ITER is, (STSet (s :: Sing t1), NTSet _ en, _, _) ::&+ _) -> withSingI s $ do
     withWTPInstr' @t1 $
       iterImpl en uInstr is inp
 
-  (U.ITER is, (STList (_ :: Sing t1), NTList _ en, _, _) ::&+ _) -> do
+  (U.ITER is, (STList (l :: Sing t1), NTList _ en, _, _) ::&+ _) -> withSingI l $ do
     withWTPInstr' @t1 $
       iterImpl en uInstr is inp
 
-  (U.ITER is, (STMap _ _, NTMap _ kns vns, _, _) ::&+ _) -> do
+  (U.ITER is, (STMap k v, NTMap _ kns vns, _, _) ::&+ _) -> withSingI k $ withSingI v $ do
     case NTPair def def def def def kns vns of
       (en :: Notes ('TPair a b)) ->
         withWTPInstr' @('TPair a b) $ iterImpl en uInstr is inp
@@ -743,13 +789,15 @@
   (U.ITER _, SNil) -> notEnoughItemsOnStack
 
   (U.MEM varNotes,
-   _ ::& (STSet{}, NTSet _ notesK, _, _) ::&+ _) -> workOnInstr uInstr $
+   _ ::& (STSet s, NTSet _ notesK, _, _) ::&+ _) -> withSingI s $ workOnInstr uInstr $
     memImpl notesK inp varNotes
   (U.MEM varNotes,
-   _ ::& (STMap{}, NTMap _ notesK _, _, _) ::&+ _) -> workOnInstr uInstr $
+   _ ::& (STMap k v, NTMap _ notesK _, _, _) ::&+ _) ->
+    withSingI k $ withSingI v $ workOnInstr uInstr $
     memImpl notesK inp varNotes
   (U.MEM varNotes,
-   _ ::& (STBigMap{}, NTBigMap _ notesK _, _, _) ::&+ _) -> workOnInstr uInstr $
+   _ ::& (STBigMap k v, NTBigMap _ notesK _, _, _) ::&+ _) ->
+    withSingI k $ withSingI v $ workOnInstr uInstr $
     memImpl notesK inp varNotes
   (U.MEM _, _ ::& _ ::& _) ->
     failWithErr $ UnexpectedType
@@ -761,12 +809,12 @@
   (U.MEM _, _) -> notEnoughItemsOnStack
 
   (U.GET varNotes,
-   _ ::& (STMap{}, NTMap _ notesK (notesV :: Notes v), _, _) ::&+ _) ->
-    workOnInstr uInstr $ withWTPInstr @v $
+   _ ::& (STMap k v, NTMap _ notesK (notesV :: Notes v), _, _) ::&+ _) ->
+    withSingI k $ withSingI v $ workOnInstr uInstr $ withWTPInstr @v $
       getImpl notesK inp notesV varNotes
   (U.GET varNotes,
-   _ ::& (STBigMap{}, NTBigMap _ notesK (notesV :: Notes v), _, _) ::&+ _) ->
-    workOnInstr uInstr $ withWTPInstr @v $
+   _ ::& (STBigMap k v, NTBigMap _ notesK (notesV :: Notes v), _, _) ::&+ _) ->
+    withSingI k $ withSingI v $ workOnInstr uInstr $ withWTPInstr @v $
       getImpl notesK inp notesV varNotes
 
   (U.GET _, _ ::& _ ::& _) ->
@@ -785,23 +833,23 @@
     where
       go :: forall x xs. Word -> HST (x : xs) -> TypeCheckInstr (TCGetNHelper (x : xs))
       go 0 ((a, Dict, _) ::& rest) =
-        pure $ TCGetNHelper SZ ((a, Dict, getNVarAnn) ::& rest)
+        pure $ TCGetNHelper Zero ((a, Dict, getNVarAnn) ::& rest)
       go 1 ((NTPair _ _ _ _ _ leftNotes _, Dict, _) ::& rest) =
-        pure $ TCGetNHelper (SS SZ) $ (leftNotes, Dict, getNVarAnn) ::& rest
+        pure $ TCGetNHelper One $ (leftNotes, Dict, getNVarAnn) ::& rest
       go ix ((NTPair _ _ _ _ _ _ rightNotes, Dict, _) ::& rest) =
         go (ix - 2) ((rightNotes, Dict, U.noAnn) ::& rest) <&> \(TCGetNHelper ixSing out) ->
-          TCGetNHelper (SS (SS ixSing)) out
+          TCGetNHelper (Succ (Succ ixSing)) out
       go _ _ = failWithErr' $ UnexpectedType $ (pairWithNodeIndex ix0 :| []) :| []
 
   (U.UPDATE varAnn,
-   _ ::& _ ::& (STMap{}, (NTMap _ notesK (notesV :: Notes v)), _, _) ::&+ _) ->
-    workOnInstr uInstr $ updImpl notesK inp (NTOption U.noAnn notesV) varAnn
+   _ ::& _ ::& (STMap k v, (NTMap _ notesK (notesV :: Notes v)), _, _) ::&+ _) ->
+    withSingI k $ withSingI v $ workOnInstr uInstr $ updImpl notesK inp (NTOption U.noAnn notesV) varAnn
   (U.UPDATE varAnn,
-   _ ::& _ ::& (STBigMap{}, NTBigMap _ notesK (notesV :: Notes v), _, _) ::&+ _) ->
-    workOnInstr uInstr $ updImpl notesK inp (NTOption U.noAnn notesV) varAnn
+   _ ::& _ ::& (STBigMap k v, NTBigMap _ notesK (notesV :: Notes v), _, _) ::&+ _) ->
+    withSingI k $ withSingI v $ workOnInstr uInstr $ updImpl notesK inp (NTOption U.noAnn notesV) varAnn
   (U.UPDATE varAnn,
-   _ ::& _ ::& (STSet{}, NTSet _ (notesK :: Notes k), _, _) ::&+ _) ->
-    workOnInstr uInstr $ updImpl notesK inp (NTBool U.noAnn) varAnn
+   _ ::& _ ::& (STSet s, NTSet _ (notesK :: Notes k), _, _) ::&+ _) ->
+    withSingI s $ workOnInstr uInstr $ updImpl notesK inp (NTBool U.noAnn) varAnn
 
   (U.UPDATE _, _ ::& _ ::& _ ::& _) ->
     failWithErr $ UnexpectedType
@@ -819,27 +867,27 @@
     where
       go :: forall val pair rest. Word -> HST (val : pair : rest) -> TypeCheckInstr (TCUpdateNHelper (val : pair : rest))
       go 0 ((valNotes, Dict, _) ::& (_, _, _) ::& rest) =
-        pure $ TCUpdateNHelper SZ $
+        pure $ TCUpdateNHelper Zero $
           (valNotes, Dict, updateNVarAnn) ::& rest
       go 1 ((valNotes, Dict, _) ::& (NTPair pairTA leftFA rightFA leftVA rightVA _ rightNotes, Dict, _) ::& rest) =
-        pure $ TCUpdateNHelper (SS SZ) $
+        pure $ TCUpdateNHelper One $
           (NTPair pairTA leftFA rightFA leftVA rightVA valNotes rightNotes, Dict, updateNVarAnn) ::& rest
       go ix (val ::& (NTPair pairTA leftFA rightFA leftVA rightVA leftNotes rightNotes, Dict, _) ::& rest) =
         go (ix - 2) (val ::& (rightNotes, Dict, U.noAnn) ::& rest) <&>
           \(TCUpdateNHelper ixSing ((updatedRightNotes, Dict, _) ::& outRest)) ->
-            TCUpdateNHelper (SS (SS ixSing)) $
+            TCUpdateNHelper (Succ (Succ ixSing)) $
               (NTPair pairTA leftFA rightFA leftVA rightVA leftNotes updatedRightNotes, Dict, updateNVarAnn) ::& outRest
       go _ _ = failWithErr' $ UnexpectedType $ ("'val" :| [pairWithNodeIndex ix0]) :| []
   (U.UPDATEN _ _, _) -> notEnoughItemsOnStack
 
   (U.GET_AND_UPDATE varAnn,
-   _ ::& _ ::& (STMap{}, (NTMap _ notesK (notesV :: Notes v)), _, _) ::&+ _) ->
-    workOnInstr uInstr $
+   _ ::& _ ::& (STMap k v, (NTMap _ notesK (notesV :: Notes v)), _, _) ::&+ _) ->
+    withSingI k $ withSingI v $ workOnInstr uInstr $
       withWTPInstr @v $
         getUpdImpl notesK inp (NTOption U.noAnn notesV) varAnn
   (U.GET_AND_UPDATE varAnn,
-   _ ::& _ ::& (STBigMap{}, (NTBigMap _ notesK (notesV :: Notes v)), _, _) ::&+ _) ->
-    workOnInstr uInstr $
+   _ ::& _ ::& (STBigMap k v, (NTBigMap _ notesK (notesV :: Notes v)), _, _) ::&+ _) ->
+    withSingI k $ withSingI v $ workOnInstr uInstr $
       withWTPInstr @v $
         getUpdImpl notesK inp (NTOption U.noAnn notesV) varAnn
   (U.GET_AND_UPDATE _, _ ::& _ ::& _ ::& _) ->
@@ -907,12 +955,12 @@
         lamImpl (U.LAMBDA vn p1 p2) uInstr is vn ins ons i
 
   (U.EXEC vn, ((tn :: Notes t1), _, _)
-                              ::& ( STLambda _ _
+                              ::& ( STLambda v b
                                   , NTLambda _ (t1n :: Notes t1') (t2n :: Notes t2')
                                   , _
                                   , _
                                   )
-                              ::&+ rs) -> workOnInstr uInstr $ do
+                              ::&+ rs) -> withSingI v $ withSingI b $ workOnInstr uInstr $ do
     Refl <- onTypeCheckInstrErr uInstr (SomeHST inp) (Just LambdaArgument)
                   (eqType @t1 @t1')
     (Refl, _) <- errM $ matchTypes tn t1n
@@ -928,11 +976,11 @@
   (U.EXEC _, _) -> notEnoughItemsOnStack
 
   (U.APPLY vn, ((_ :: Notes a'), _, _)
-                  ::& ( STLambda (STPair _ _) _
+                  ::& ( STLambda (STPair lt rt) b
                       , NTLambda vann (NTPair _ _ _ _ _ (_ :: Notes a) (nb :: Notes b)) sc
                       , _
                       , _)
-                  ::&+ rs) -> workOnInstr uInstr $ do
+                  ::&+ rs) -> withSingI lt $ withSingI rt $ withSingI b $ workOnInstr uInstr $ do
     case NTLambda vann nb sc of
       (l2n :: Notes ('TLambda t1 t2)) -> withWTPInstr @('TLambda t1 t2) $ do
 
@@ -962,21 +1010,21 @@
       TCDipHelperErr err rest -> IllTypedSeq err rest
       TCDipHelperOk s subI out -> WellTypedSeq $ inputHST :/ DIPN s subI ::: out
     where
-      go :: forall inp. Typeable inp
+      go :: forall inp. SingI inp
         => Word
         -> HST inp
         -> TypeCheckInstrNoExcept (TCDipHelper inp)
       go n curHST = case (n, curHST) of
         (0, _) -> typeCheckDipBody (U.DIPN nTotal) uInstr instructions curHST
           (TCDipHelperErr)
-          (TCDipHelperOk SZ)
+          (TCDipHelperOk Zero)
         (_, SNil) -> do
           pos <- ask
           let err = TCFailedOnInstr uInstr (SomeHST inp) pos Nothing (Just NotEnoughItemsOnStack)
           pure $ TCDipHelperErr err [NonTypedInstr $ U.PrimEx uInstr]
         (_, hstHead ::& hstTail) ->
           go (n - 1) hstTail <&> \case
-          TCDipHelperOk s subI out -> TCDipHelperOk (SS s) subI (hstHead ::& out)
+          TCDipHelperOk s subI out -> TCDipHelperOk (Succ s) subI (hstHead ::& out)
           TCDipHelperErr err rest -> TCDipHelperErr err rest
 
   (u, v) -> case (u, v) of -- Workaround for not exceeding -fmax-pmcheck-iterations limit
@@ -1286,7 +1334,7 @@
 
     (U.TRANSFER_TOKENS vn, ((_ :: Notes p'), _, _)
       ::& (NTMutez{}, _, _)
-      ::& (STContract (_ :: Sing p), _, _, _) ::&+ rs) -> workOnInstr uInstr $ do
+      ::& (STContract (s :: Sing p), _, _, _) ::&+ rs) -> withSingI s $ workOnInstr uInstr $ do
       proofScope <- onScopeCheckInstrErr @p uInstr (SomeHST inp) (Just ContractParameter)
         $ checkScope @(ParameterScope p)
       case (eqType @p @p', proofScope) of
@@ -1434,6 +1482,40 @@
     (U.NEVER, (NTNever{}, _, _) ::& _) -> workOnInstr uInstr $
       pure $ inp :/ AnyOutInstr NEVER
 
+    (U.TICKET vn, (stVal :: Sing v, _, _, _) ::&+ (NTNat{}, _, _) ::& rs) -> workOnInstr uInstr $
+      withWTPInstr @v $
+      withCompareableCheck stVal uInstr inp $
+        inp :/ TICKET ::: ((starNotes, Dict, vn) ::& rs)
+    (U.TICKET _, _ ::& _ ::& _) ->
+      failWithErr $ UnexpectedType $ ("a'" :| ["nat"]) :| []
+    (U.TICKET _, _) -> notEnoughItemsOnStack
+
+    (U.READ_TICKET vn, ticket@(ntTicket@NTTicket{}, Dict, _) ::& rs) -> workOnInstr uInstr $
+      case notesSing ntTicket of
+        STTicket{} ->
+          pure $ inp :/ READ_TICKET ::: ((starNotes, Dict, vn) ::& ticket ::& rs)
+    (U.READ_TICKET _, _ ::& _) ->
+      failWithErr $ UnexpectedType $ ("ticket 'a" :| []) :| []
+    (U.READ_TICKET _, _) -> notEnoughItemsOnStack
+
+    (U.SPLIT_TICKET vn, (NTTicket{}, Dict, _) ::& (NTPair _ _ _ _ _ NTNat{} NTNat{}, _, _) ::& rs) ->
+      workOnInstr uInstr $
+        pure $ inp :/ SPLIT_TICKET ::: ((starNotes, Dict, vn) ::& rs)
+    (U.SPLIT_TICKET _, _ ::& _ ::& _) ->
+      failWithErr $ UnexpectedType $ ("pair nat nat" :| ["ticket 'a"]) :| []
+    (U.SPLIT_TICKET _, _) -> notEnoughItemsOnStack
+
+    (U.JOIN_TICKETS vn,
+       (STPair{}, NTPair _ _ _ _ _ nt1@NTTicket{} nt2@NTTicket{}, Dict, _) ::&+ rs) ->
+      workOnInstr uInstr $ do
+        (Refl, nt) <-
+          onTypeCheckInstrErr uInstr (SomeHST inp) (Just TicketsJoin) $
+            matchTypes nt1 nt2
+        pure $ inp :/ JOIN_TICKETS ::: ((NTOption U.noAnn nt, Dict, vn) ::& rs)
+    (U.JOIN_TICKETS _, _ ::& _) ->
+      failWithErr $ UnexpectedType $ ("pair (ticket 'a) (ticket 'a)" :| []) :| []
+    (U.JOIN_TICKETS _, _) -> notEnoughItemsOnStack
+
     -- Could not get rid of the catch all clause due to this warning:
     -- @
     -- Pattern match checker exceeded (2000000) iterations in
@@ -1469,7 +1551,7 @@
 -- value.
 genericIf
   :: forall bti bfi cond rs .
-    (Typeable bti, Typeable bfi)
+    (SingI bti, SingI bfi)
   => (forall s'.
         Instr bti s' ->
         Instr bfi s' ->
@@ -1502,17 +1584,17 @@
           pure $ AnyOutInstr (cons p q)
 
 mapImpl
-  :: forall c rs .
+  :: forall c rs.
     ( MapOp c
     , WellTyped (MapOpInp c)
-    , Typeable (MapOpRes c)
+    , SingI1 (MapOpRes c)
     )
   => ([TypeCheckedOp] -> TypeCheckedInstr)
   -> Notes (MapOpInp c)
   -> U.ExpandedInstr
   -> [U.ExpandedOp]
   -> HST (c ': rs)
-  -> (forall v' . (KnownT v') =>
+  -> (forall v'. (SingI v') =>
         Notes v' -> HST rs -> TypeCheckInstr (HST (MapOpRes c v' ': rs)))
   -> TypeCheckInstrNoExcept (TypeCheckedSeq (c ': rs))
 mapImpl cons vn instr mp i@(_ ::& rs) mkRes = do
@@ -1520,11 +1602,11 @@
     case subp of
       sub ::: subo ->
         case subo of
-          (bn, _, _bvn) ::& rs' -> do
+          (bn :: Notes v', _, _bvn) ::& rs' -> do
             Refl <- onTypeCheckInstrErr instr (SomeHST i) (Just Iteration)
               $ eqHST rs rs'
             x <- mkRes bn rs'
-            pure $ i :/ MAP sub ::: x
+            pure $ i :/ withSingI1 @(MapOpRes c) @v' (MAP sub ::: x)
           _ -> typeCheckInstrErr instr (SomeHST i) (Just Iteration)
       AnyOutInstr _ ->
         typeCheckInstrErr' instr (SomeHST i) (Just Iteration) CodeAlwaysFails
@@ -1555,7 +1637,7 @@
 lamImpl
   :: forall it ot ts .
     ( WellTyped it, WellTyped ot
-    , Typeable ts
+    , SingI ts
     )
   => ([TypeCheckedOp] -> TypeCheckedInstr)
   -> U.ExpandedInstr
@@ -1601,18 +1683,18 @@
 data TCDipHelper inp where
   TCDipHelperOk ::
     forall (n :: Peano) inp out s s'.
-    (Typeable out, ConstraintDIPN n inp out s s') =>
-    Sing n -> Instr s s' -> HST out -> TCDipHelper inp
+    (SingI out, ConstraintDIPN n inp out s s') =>
+    PeanoNatural n -> Instr s s' -> HST out -> TCDipHelper inp
   TCDipHelperErr :: TCError -> [IllTypedInstr] -> TCDipHelper inp
 
 typeCheckDipBody
-  :: Typeable inp
+  :: SingI inp
   => ([TypeCheckedOp] -> TypeCheckedInstr)
   -> U.ExpandedInstr
   -> [U.ExpandedOp]
   -> HST inp
   -> (TCError -> [IllTypedInstr] -> r)
-  -> (forall out. Typeable out => Instr inp out -> HST out -> r)
+  -> (forall out. SingI out => Instr inp out -> HST out -> r)
   -> TypeCheckInstrNoExcept r
 typeCheckDipBody cons mainInstr instructions inputHST onErr onOk = do
   listRes <- lift $ typeCheckListNoExcept instructions inputHST
diff --git a/src/Michelson/TypeCheck/TypeCheck.hs b/src/Michelson/TypeCheck/TypeCheck.hs
--- a/src/Michelson/TypeCheck/TypeCheck.hs
+++ b/src/Michelson/TypeCheck/TypeCheck.hs
@@ -5,16 +5,17 @@
 module Michelson.TypeCheck.TypeCheck
   ( TcInstrHandler
   , TcOriginatedContracts
-  , TcResult
   , TypeCheckEnv(..)
   , TypeCheckOptions(..)
   , TypeCheck
   , TypeCheckNoExcept
+  , TypeCheckResult
   , runTypeCheck
   , TypeCheckInstr
   , TypeCheckInstrNoExcept
   , runTypeCheckIsolated
   , runTypeCheckInstrIsolated
+  , typeCheckingWith
   , liftNoExcept
   , liftNoExcept'
   , throwingTCError
@@ -30,11 +31,12 @@
   , TypeCheckMode(..)
   , SomeParamType(..)
   , mkSomeParamType
-  , mkSomeParamTypeUnsafe
+  , unsafeMkSomeParamType
   ) where
 
 
-import Control.Monad.Except (throwError)
+import Control.Monad.Except (Except, mapExceptT, runExcept, throwError)
+import Control.Monad.Reader (mapReaderT)
 import Data.Default (Default(..))
 import Data.Singletons (Sing)
 import Fmt (Buildable, build, pretty)
@@ -47,6 +49,7 @@
   tcsEither)
 import Michelson.TypeCheck.Types
 import qualified Michelson.Typed as T
+import Michelson.Typed (SingI)
 import qualified Michelson.Untyped as U
 import Tezos.Address (ContractHash)
 import Util.Lens
@@ -62,6 +65,15 @@
   (ReaderT TypeCheckOptions
     (State TypeCheckEnv))
 
+-- | Monad for performing some typechecking operations with the same options.
+--
+-- Unlike 'TypeCheck' monad, this does not carry the context of intra-contract
+-- or intra-value typechecking.
+-- TODO [this MR]: probably come up with a better name? IntraTypeCheck?
+type TypeCheckResult =
+  (ReaderT TypeCheckOptions
+    (Except TCError))
+
 data SomeParamType = forall t. (T.ParameterScope t) =>
   SomeParamType (Sing t) (T.ParamNotes t)
 
@@ -80,14 +92,14 @@
 -- | Helper function means to provide a quick way for creating instance
 -- of @SomeParamType@ needed in test.
 someParamToParameterType :: SomeParamType -> U.ParameterType
-someParamToParameterType (SomeParamType s T.ParamNotesUnsafe{..}) =
+someParamToParameterType (SomeParamType s T.UnsafeParamNotes{..}) =
   U.ParameterType (T.AsUTypeExt s pnNotes) pnRootAnn
 
 -- | Construct @SomeParamType@ from @ParameterType@, mainly used in test.
-mkSomeParamTypeUnsafe :: HasCallStack => U.ParameterType -> SomeParamType
-mkSomeParamTypeUnsafe p =
+unsafeMkSomeParamType :: HasCallStack => U.ParameterType -> SomeParamType
+unsafeMkSomeParamType p =
   case mkSomeParamType p of
-    Right sp ->  sp
+    Right sp -> sp
     Left err -> error $ "Illegal type in parameter of env contract: " <> pretty err
 
 mkSomeParamType :: U.ParameterType -> Either TCError SomeParamType
@@ -118,19 +130,31 @@
   }
 
 data TypeCheckOptions = TypeCheckOptions
-  { tcVerbose :: Bool -- ^ Whether to add stack type comments after every
-                      -- instruction a la tezos-client.
+  { tcVerbose :: Bool
+    -- ^ Whether to add stack type comments after every
+    -- instruction a la tezos-client.
+  , tcStrict :: Bool
+    -- ^ Whether should we behave like in test run or real run
+    -- (real run is more strict).
+    --
+    -- @tezos-client run@'s behaviour can slightly differ from the behaviour
+    -- of @tezos-client originate@ and @tezos-client transfer@. For instance,
+    -- some values can be "forged" in test run, but not in a real one,
+    -- see: Note [Tickets forging].
+    --
+    -- Set this to @True@ when need to match the behaviour in the network,
+    -- and to @False@ if you prefer providing the user with some convenient
+    -- features.
   }
 
 instance Default TypeCheckOptions where
-  def = TypeCheckOptions{ tcVerbose = False }
+  def = TypeCheckOptions{ tcVerbose = False, tcStrict = True }
 
 makeLensesWith postfixLFields ''TypeCheckEnv
 
-runTypeCheck :: TypeCheckMode -> TypeCheckOptions -> TypeCheck a -> Either TCError a
-runTypeCheck mode options = evaluatingState (TypeCheckEnv [] mode)
-                          . runExceptT
-                          . usingReaderT options
+runTypeCheck :: TypeCheckMode -> TypeCheck a -> TypeCheckResult a
+runTypeCheck mode =
+  mapReaderT $ mapExceptT $ evaluatingStateT (TypeCheckEnv [] mode)
 
 -- | Run type checker as if it worked isolated from other world -
 -- no access to environment of the current contract is allowed.
@@ -140,10 +164,11 @@
 -- whatever we typecheck does not depend on the parameter type of the
 -- contract which is being typechecked (because there is no contract
 -- that we are typechecking).
-runTypeCheckIsolated :: TypeCheck a -> Either TCError a
-runTypeCheckIsolated = runTypeCheck TypeCheckTest def
+runTypeCheckIsolated :: TypeCheck a -> TypeCheckResult a
+runTypeCheckIsolated = runTypeCheck TypeCheckTest
 
-type TcResult inp = Either TCError (SomeInstr inp)
+typeCheckingWith :: TypeCheckOptions -> TypeCheckResult a -> Either TCError a
+typeCheckingWith options = runExcept . usingReaderT options
 
 type TypeCheckInstr =
   ReaderT InstrCallStack TypeCheck
@@ -152,7 +177,7 @@
   ReaderT InstrCallStack TypeCheckNoExcept
 
 -- | Similar to 'runTypeCheckIsolated', but for 'TypeCheckInstr.'
-runTypeCheckInstrIsolated :: TypeCheckInstr a -> Either TCError a
+runTypeCheckInstrIsolated :: TypeCheckInstr a -> TypeCheckResult a
 runTypeCheckInstrIsolated = runTypeCheckIsolated . flip runReaderT def
 
 liftNoExcept :: TypeCheckInstrNoExcept a -> TypeCheckInstr a
@@ -249,7 +274,7 @@
 -- have to be refactored too.
 -- Therefore, I am using ReaderT over TypeCheck.
 type TcInstrHandler
-   = forall inp. (Typeable inp, HasCallStack)
+   = forall inp. (SingI inp, HasCallStack)
       => U.ExpandedInstr
       -> HST inp
       -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)
diff --git a/src/Michelson/TypeCheck/TypeCheckedOp.hs b/src/Michelson/TypeCheck/TypeCheckedOp.hs
--- a/src/Michelson/TypeCheck/TypeCheckedOp.hs
+++ b/src/Michelson/TypeCheck/TypeCheckedOp.hs
@@ -11,12 +11,12 @@
   , someInstrToOp
   ) where
 
-import Data.Typeable (cast)
+import Data.Singletons (SingI)
 
 import Michelson.Printer.Util (RenderDoc(..), renderOpsListNoBraces)
 import Michelson.TypeCheck.Types (HST(..), SomeInstr(..), SomeInstrOut(..))
 import Michelson.Typed.Convert (instrToOps)
-import Michelson.Typed.Instr (Instr)
+import Michelson.Typed.Instr (Instr, castInstr)
 import Michelson.Untyped.Instr (ExpandedOp, InstrAbstract(..))
 import Util.TH (deriveGADTNFData)
 
@@ -26,13 +26,13 @@
 -- | Represents nodes of a partially typed operation tree.
 data TypeCheckedOp where
   -- | Constructs well-typed node.
-  WellTypedOp :: (Typeable inp, Typeable out) => Instr inp out -> TypeCheckedOp
+  WellTypedOp :: (SingI inp, SingI out) => Instr inp out -> TypeCheckedOp
   -- | Constructs ill-typed node which might in turn contain well-typed and
   -- non-typed operations.
   IllTypedOp :: IllTypedInstr -> TypeCheckedOp
 
 instance Eq TypeCheckedOp where
-  WellTypedOp i1 == WellTypedOp i2 = cast i1 == Just i2
+  WellTypedOp i1 == WellTypedOp i2 = castInstr i1 == Just i2
   IllTypedOp i1 == IllTypedOp i2 = i1 == i2
   _ == _ = False
 
@@ -55,7 +55,7 @@
   SNil -> go rest
   (::&){} -> go rest
   where
-    go :: forall inp. Typeable inp => SomeInstrOut inp -> TypeCheckedOp
+    go :: forall inp. SingI inp => SomeInstrOut inp -> TypeCheckedOp
     go (i ::: _) = WellTypedOp i
     go (AnyOutInstr i) = WellTypedOp (i @'[])
 
diff --git a/src/Michelson/TypeCheck/Types.hs b/src/Michelson/TypeCheck/Types.hs
--- a/src/Michelson/TypeCheck/Types.hs
+++ b/src/Michelson/TypeCheck/Types.hs
@@ -9,12 +9,11 @@
     , SomeHST (..)
     , SomeInstrOut (..)
     , SomeInstr (..)
-    , SomeContract (..)
-    , SomeContractAndStorage (..)
     , BoundVars (..)
     , TcExtFrames
     , NotWellTyped (..)
     , getWTP
+    , getWTP_
     , withWTPm
     , unsafeWithWTP
     , mapSomeContract
@@ -25,18 +24,21 @@
 
 import Data.Constraint (Dict(..))
 import qualified Data.Map.Lazy as Map
-import Data.Singletons (Sing, SingI(..), demote)
-import Fmt (Buildable(..), Builder, (+|), (|+), pretty)
+import Data.Singletons (Sing, SingI(..), demote, withSingI)
+import Fmt (Buildable(..), pretty)
 import Prelude hiding (EQ, GT, LT)
 import qualified Text.Show
+import Text.PrettyPrint.Leijen.Text hiding (pretty)
 
-import Michelson.Typed (ParameterScope, StorageScope, Notes(..), T(..), SingT(..), notesT, starNotes)
-import Michelson.Typed.Haskell.Value (WellTyped)
+
+import Michelson.Typed (Notes(..), SingT(..), SomeContract(..), T(..), notesT, starNotes)
 import qualified Michelson.Typed as T
+import Michelson.Typed.Haskell.Value (WellTyped)
 import Michelson.Typed.Instr
+import Michelson.Printer.Util
 import Michelson.Untyped (Ty, Var, noAnn)
 import Michelson.Untyped.Annotation (VarAnn)
-import Util.Typeable
+import Util.Sing (eqParamSing)
 
 -- | Data type holding type information for stack (Heterogeneous Stack Type).
 --
@@ -63,7 +65,7 @@
 -- Additionally constructor keeps 'SingI' constraint for the current type.
 data HST (ts :: [T])  where
   SNil :: HST '[]
-  (::&) :: (Typeable xs, T.KnownT x)
+  (::&) :: (T.SingI x, T.SingI xs)
         => (Notes x, Dict (WellTyped x), VarAnn)
         -> HST xs
         -> HST (x ': xs)
@@ -82,14 +84,16 @@
       showDo ((notesT -> t, Dict, _vn) ::& SNil) = show t
 
 instance Buildable (HST ts) where
-  build SNil = "[]"
-  build (r ::& rs) = "[ " +| showDo (r ::& rs) |+ " ]"
-    where
-      showDo :: HST (t ': ts_) -> Builder
-      showDo ((notesT -> t, Dict, _vn) ::& (b ::& c)) =
-          build t |+ ", " +| showDo (b ::& c)
-      showDo ((notesT -> t, Dict, _vn) ::& SNil) = build t
+  build = buildRenderDocExtended
 
+instance RenderDoc (HST ts) where
+  renderDoc _ SNil = "[]"
+  renderDoc context (r ::& rs) = "[" <+> doRender (r ::& rs) <+> "]"
+    where
+      doRender :: HST (t ': ts_) -> Doc
+      doRender ((notesT -> t, Dict, _vn) ::& (b ::& c)) =
+          renderDoc context t <> "," <+> doRender (b ::& c)
+      doRender ((notesT -> t, Dict, _vn) ::& SNil) = renderDoc context t
 infixr 7 ::&
 
 instance Eq (HST ts) where
@@ -100,7 +104,7 @@
 -- | Append a type to 'HST', assuming that notes and annotations
 -- for this type are unknown.
 (-:&)
-  :: (Typeable xs, WellTyped x)
+  :: (WellTyped x, SingI xs)
   => Sing x
   -> HST xs
   -> HST (x ': xs)
@@ -112,7 +116,7 @@
 pattern (::&+)
   :: ()
   => ( ys ~ (x ': xs)
-     , T.KnownT x, Typeable xs
+     , SingI x, SingI xs
      )
   => (Sing x, Notes x, Dict (WellTyped x), VarAnn)
   -> HST xs
@@ -122,14 +126,14 @@
 
 -- | No-argument type wrapper for @HST@ data type.
 data SomeHST where
-  SomeHST :: Typeable ts => HST ts -> SomeHST
+  SomeHST :: SingI ts => HST ts -> SomeHST
 
 deriving stock instance Show SomeHST
 instance NFData SomeHST where
   rnf (SomeHST h) = rnf h
 
 instance Eq SomeHST where
-  SomeHST hst1 == SomeHST hst2 = hst1 `eqParam1` hst2
+  SomeHST hst1 == SomeHST hst2 = hst1 `eqParamSing` hst2
 
 -- | This data type keeps part of type check result - instruction and
 -- corresponding output stack.
@@ -139,7 +143,7 @@
   -- Output stack type is wrapped inside the type and @Typeable@
   -- constraint is provided to allow convenient unwrapping.
   (:::)
-    :: (Typeable out)
+    :: SingI out
     => Instr inp out
     -> HST out
     -> SomeInstrOut inp
@@ -182,31 +186,12 @@
 instance Show (ExtInstr inp) => Show (SomeInstr inp) where
   show (inp :/ out) = show inp <> " -> " <> show out
 
-data SomeContract where
-  SomeContract :: Contract cp st -> SomeContract
-
-instance NFData SomeContract where
-  rnf (SomeContract c) = rnf c
-
 mapSomeContract ::
   (forall inp out. Instr inp out -> Instr inp out)
   -> SomeContract
   -> SomeContract
 mapSomeContract f (SomeContract fc) = SomeContract $ mapContractCode f fc
 
-deriving stock instance Show SomeContract
-
--- | Represents a typed contract & a storage value of the type expected by the contract.
-data SomeContractAndStorage where
-  SomeContractAndStorage
-    :: forall cp st.
-       (StorageScope st, ParameterScope cp)
-       => Contract cp st
-       -> T.Value st
-       -> SomeContractAndStorage
-
-deriving stock instance Show SomeContractAndStorage
-
 -- | Set of variables defined in a let-block.
 data BoundVars = BoundVars (Map Var Ty) (Maybe SomeHST)
 
@@ -217,12 +202,14 @@
 type TcExtFrames = [BoundVars]
 
 -- | Error type for when a value is not well-typed.
-data NotWellTyped = NotWellTyped T
+data NotWellTyped = NotWellTyped
+  { nwtBadType :: T
+  , nwtCause :: T.BadTypeForScope
+  }
 
 instance Buildable NotWellTyped where
-  build (NotWellTyped t) =
-    "Given type is not well typed because it has an non-comparable type in it: \
-    \'" <> (build t) <> "', where a comparable type is required"
+  build (NotWellTyped t c) =
+    "Given type is not well typed because '" <> (build t) <> "' " <> (build c)
 
 fromEDict :: Either e (Dict a) -> (a => Either e (Dict b)) -> Either e (Dict b)
 fromEDict ma b = ma >>= (\Dict -> b)
@@ -235,30 +222,62 @@
   STUnit -> Right Dict
   STSignature -> Right Dict
   STChainId -> Right Dict
-  STOption s -> fromEDict (getWTP_ s) (Right Dict)
-  STList s -> fromEDict (getWTP_ s) (Right Dict)
+  STOption s -> withSingI s $ fromEDict (getWTP_ s) (Right Dict)
+  STList s -> withSingI s $ fromEDict (getWTP_ s) (Right Dict)
   STSet (s :: Sing si) ->
+    withSingI s $
     fromEDict (getWTP_ s) $
     fromEDict
-        ( maybeToRight (NotWellTyped $ demote @si) $ T.getComparableProofS s
+        ( maybeToRight (NotWellTyped (demote @si) T.BtNotComparable) $ T.getComparableProofS s
         ) $ Right Dict
   STOperation  -> Right Dict
-  STContract s -> fromEDict (getWTP_ s) (Right Dict)
-  STPair s1 s2 -> fromEDict (getWTP_ s1) $ fromEDict (getWTP_ s2) $ Right Dict
-  STOr s1 s2 -> fromEDict (getWTP_ s1) $ fromEDict (getWTP_ s2) $ Right Dict
-  STLambda s1 s2 -> fromEDict (getWTP_ s1) $ fromEDict (getWTP_ s2) $ Right Dict
+  STContract (s :: Sing si) ->
+    withSingI s $ fromEDict (getWTP_ s) $
+    fromEDict
+        ( maybeToRight (NotWellTyped (demote @si) T.BtIsOperation) $ T.opAbsense s
+        ) $ Right Dict
+
+  STTicket (s :: Sing si) ->
+    withSingI s $ fromEDict (getWTP_ s) $
+    fromEDict
+        ( maybeToRight (NotWellTyped (demote @si) T.BtNotComparable) $ T.getComparableProofS s
+        ) $ Right Dict
+  STPair s1 s2 ->
+    withSingI s1 $
+    withSingI s2 $
+    fromEDict (getWTP_ s1) $
+    fromEDict (getWTP_ s2) $ Right Dict
+  STOr s1 s2 ->
+    withSingI s1 $
+    withSingI s2 $
+    fromEDict (getWTP_ s1) $
+    fromEDict (getWTP_ s2) $ Right Dict
+  STLambda s1 s2 ->
+    withSingI s1 $
+    withSingI s2 $
+    fromEDict (getWTP_ s1) $ fromEDict (getWTP_ s2) $ Right Dict
   STMap (s1 :: Sing si) s2 ->
+      withSingI s1 $
+      withSingI s2 $
       fromEDict (getWTP_ s1) $
       fromEDict (getWTP_ s2) $
       fromEDict
-        ( maybeToRight (NotWellTyped $ demote @si) $ T.getComparableProofS s1
+        ( maybeToRight (NotWellTyped (demote @si) T.BtNotComparable) $ T.getComparableProofS s1
         ) $ Right Dict
-  STBigMap (s1 :: Sing si) s2 ->
+  STBigMap (s1 :: Sing si) (s2 :: Sing si2) ->
+      withSingI s1 $
+      withSingI s2 $
       fromEDict (getWTP_ s1) $
       fromEDict (getWTP_ s2) $
       fromEDict
-        ( maybeToRight (NotWellTyped $ demote @si) $ T.getComparableProofS s1
-        ) $ Right Dict
+      ( maybeToRight (NotWellTyped (demote @si) T.BtNotComparable) $ T.getComparableProofS s1
+      ) $
+      fromEDict
+      ( maybeToRight (NotWellTyped (demote @si2) T.BtIsOperation) $ T.opAbsense s2
+      ) $
+      fromEDict
+      ( maybeToRight (NotWellTyped (demote @si2) T.BtHasBigMap) $ T.bigMapAbsense s2
+      ) $ Right Dict
   STInt -> Right Dict
   STNat -> Right Dict
   STString -> Right Dict
@@ -272,9 +291,10 @@
   STTimestamp -> Right Dict
   STAddress -> Right Dict
   STNever -> Right Dict
-  where
-    getWTP_ :: forall t1. SingI t1 => Sing t1 -> Either NotWellTyped (Dict (WellTyped t1))
-    getWTP_ _ = getWTP @t1
+
+-- | Version of 'getWTP' that accepts 'Sing' at term-level.
+getWTP_ :: forall t. Sing t -> Either NotWellTyped (Dict (WellTyped t))
+getWTP_ s = withSingI s $ getWTP @t
 
 -- | Given a type and an action that requires evidence that the type is well typed,
 --  generate the evidence and execute the action, or else fail with an error.
diff --git a/src/Michelson/TypeCheck/Value.hs b/src/Michelson/TypeCheck/Value.hs
--- a/src/Michelson/TypeCheck/Value.hs
+++ b/src/Michelson/TypeCheck/Value.hs
@@ -10,20 +10,23 @@
 import Control.Monad.Except (liftEither, throwError)
 import Data.Constraint (Dict(..))
 import Data.Default (def)
+import qualified Data.List.NonEmpty as NE
 import qualified Data.Map as M
 import qualified Data.Set as S
-import Data.Singletons (Sing, SingI(..), demote)
+import Data.Singletons (Sing, SingI(..), demote, fromSing, withSingI)
 import Data.Typeable ((:~:)(..))
+import Fmt (pretty)
 import Prelude hiding (EQ, GT, LT)
 
 import Michelson.Text
 import Michelson.TypeCheck.Error (TCError(..), TCTypeError(..))
 import Michelson.TypeCheck.Helpers
 import Michelson.TypeCheck.TypeCheck
-  (SomeParamType(..), TcInstrHandler, TcOriginatedContracts, TypeCheckInstr, throwingTCError)
+  (SomeParamType(..), TcInstrHandler, TcOriginatedContracts, TypeCheckInstr, TypeCheckOptions(..),
+  throwingTCError)
 import Michelson.TypeCheck.Types
 import Michelson.Typed
-  (EpAddress(..), KnownT, Notes(..), SingT(..), Value'(..), fromSingT, starNotes)
+  (EpAddress(..), Notes(..), SingT(..), Value'(..), starNotes)
 import qualified Michelson.Typed as T
 import qualified Michelson.Untyped as U
 import Tezos.Address (Address(..))
@@ -67,41 +70,41 @@
       (U.ValueInt i, STInt) -> pure $ T.VInt i
       (v@(U.ValueInt i), t@STNat)
         | i >= 0 -> pure $ VNat (fromInteger i)
-        | otherwise -> tcFailedOnValue v (fromSingT t) "" (Just NegativeNat)
+        | otherwise -> tcFailedOnValue v (fromSing t) "" (Just NegativeNat)
       (v@(U.ValueInt i), t@STMutez) -> case mkMutez $ fromInteger i of
         Just m -> pure $ VMutez m
-        Nothing -> tcFailedOnValue v (fromSingT t) "" (Just InvalidTimestamp)
+        Nothing -> tcFailedOnValue v (fromSing t) "" (Just InvalidTimestamp)
       (U.ValueString s, STString) -> pure $ VString s
       (v@(U.ValueString s), t@STAddress) -> case T.parseEpAddress (unMText s) of
         Right addr -> pure $ VAddress addr
-        Left err -> tcFailedOnValue v (fromSingT t) "" (Just $ InvalidAddress err)
+        Left err -> tcFailedOnValue v (fromSing t) "" (Just $ InvalidAddress err)
       (v@(U.ValueBytes b), t@STAddress) -> case T.parseEpAddressRaw (U.unInternalByteString b) of
         Right addr -> pure $ VAddress addr
-        Left err -> tcFailedOnValue v (fromSingT t) "" (Just $ InvalidAddress err)
+        Left err -> tcFailedOnValue v (fromSing t) "" (Just $ InvalidAddress err)
       (v@(U.ValueString s), t@STKeyHash) -> case parseKeyHash (unMText s)  of
         Right kHash -> pure $ VKeyHash kHash
-        Left err -> tcFailedOnValue v (fromSingT t) "" (Just $ InvalidKeyHash err)
+        Left err -> tcFailedOnValue v (fromSing t) "" (Just $ InvalidKeyHash err)
       (v@(U.ValueBytes b), t@STKeyHash) ->
         case parseKeyHashRaw (U.unInternalByteString b) of
           Right kHash -> pure $ VKeyHash kHash
-          Left err -> tcFailedOnValue v (fromSingT t) "" (Just $ InvalidKeyHash err)
+          Left err -> tcFailedOnValue v (fromSing t) "" (Just $ InvalidKeyHash err)
       (U.ValueInt i, STBls12381Fr) ->
         pure $ VBls12381Fr (fromIntegral i)
       (v@(U.ValueBytes b), t@STBls12381Fr) ->
         case BLS.fromMichelsonBytes (U.unInternalByteString b) of
           Right val -> pure $ VBls12381Fr val
-          Left err -> tcFailedOnValue v (fromSingT t) "" (Just $ InvalidBls12381Object err)
+          Left err -> tcFailedOnValue v (fromSing t) "" (Just $ InvalidBls12381Object err)
       (v@(U.ValueBytes b), t@STBls12381G1) ->
         case BLS.fromMichelsonBytes (U.unInternalByteString b) of
           Right val -> pure $ VBls12381G1 val
-          Left err -> tcFailedOnValue v (fromSingT t) "" (Just $ InvalidBls12381Object err)
+          Left err -> tcFailedOnValue v (fromSing t) "" (Just $ InvalidBls12381Object err)
       (v@(U.ValueBytes b), t@STBls12381G2) ->
         case BLS.fromMichelsonBytes (U.unInternalByteString b) of
           Right val -> pure $ VBls12381G2 val
-          Left err -> tcFailedOnValue v (fromSingT t) "" (Just $ InvalidBls12381Object err)
+          Left err -> tcFailedOnValue v (fromSing t) "" (Just $ InvalidBls12381Object err)
       (v@(U.ValueString s), t@STTimestamp) -> case parseTimestamp $ unMText s of
         Just tstamp -> pure $ VTimestamp tstamp
-        Nothing -> tcFailedOnValue v (fromSingT t) "" (Just InvalidTimestamp)
+        Nothing -> tcFailedOnValue v (fromSing t) "" (Just InvalidTimestamp)
       (U.ValueInt i, STTimestamp) -> pure $ VTimestamp (timestampFromSeconds i)
       (U.ValueBytes (U.InternalByteString s), STBytes) -> pure $ VBytes s
       (U.ValueTrue, STBool) -> pure $ VBool True
@@ -123,63 +126,119 @@
         pure $ VChainId ci
 
       (cv@(U.ValueString (T.parseEpAddress . unMText -> Right addr))
-        , STContract pc) -> typecheckContractValue cv addr pc
+        , STContract pc) -> withSingI pc $ typecheckContractValue cv addr pc
       (cv@(U.ValueBytes (T.parseEpAddressRaw . U.unInternalByteString -> Right addr))
-        , STContract pc) -> typecheckContractValue cv addr pc
+        , STContract pc) -> withSingI pc $ typecheckContractValue cv addr pc
 
+      (cv, s@(STTicket vt)) -> withSingI vt $ lift (asks tcStrict) >>= \case
+        -- Note [Tickets forging]
+        -- Normally, ticket values cannot be constructed manually (i.e. forged)
+        -- by design, and the only valid way to make a ticket is calling
+        -- @TICKET@ instruction.
+        --
+        -- However @tezos-client run@ adds an exception, it allows passing a
+        -- manually constructed ticket value as parameter or initial storage.
+        True ->
+          tcFailedOnValue cv (demote @tz)
+            "ticket values cannot be forged in real operations"
+            Nothing
+        False -> case cv of
+          U.ValuePair addrV (U.ValuePair datV amV) -> withComparable vt cv s $ do
+            addrValue <- doTypeCheckVal @'T.TAddress addrV
+            dat <- doTypeCheckVal datV
+            amountValue <- doTypeCheckVal @'T.TNat amV
+            case (addrValue, amountValue) of
+              (VAddress (EpAddress addr ep), VNat am) -> do
+                unless (U.isDefEpName ep) $
+                  tcFailedOnValue cv (demote @tz)
+                    "it is pointless to provide an address with entrypoint as a \
+                    \ticketer, we do not support that"
+                    Nothing
+                -- ↑ Tezos allows passing addresses with entrypoint, but it is
+                -- not possible to sanely work with them after that anyway,
+                -- since @TICKET@ instruction (the only valid way of constructing
+                -- tickets in real run) uses @SELF_ADDRESS@ result as ticketer.
+                return $ VTicket addr dat am
+          _ ->
+            tcFailedOnValue cv (demote @tz)
+              "ticket type expects a value of type `(pair address <data> nat)`"
+              Nothing
+
       (U.ValueUnit, STUnit) -> pure $ VUnit
-      (U.ValuePair ml mr, STPair _ _) -> do
+      (U.ValuePair ml mr, STPair lt rt) -> withSingI lt $ withSingI rt $ do
         l <- doTypeCheckVal ml
         r <- doTypeCheckVal mr
         pure $ VPair (l, r)
-      (U.ValueLeft ml, STOr{}) -> do
+      (U.ValueLeft ml, STOr lt rt) -> withSingI lt $ withSingI rt $ do
         l <- doTypeCheckVal ml
         pure $ VOr (Left l)
-      (U.ValueRight mr, STOr{}) -> do
+      (U.ValueRight mr, STOr lt rt) -> withSingI lt $ withSingI rt $ do
         r <- doTypeCheckVal mr
         pure $ VOr (Right r)
-      (U.ValueSome mv, STOption{}) -> do
+      (U.ValueSome mv, STOption op) -> withSingI op $ do
         v <- doTypeCheckVal mv
         pure $ VOption (Just v)
-      (U.ValueNone, STOption _) -> do
+      (U.ValueNone, STOption op) -> withSingI op $ do
         pure $ VOption Nothing
 
-      (U.ValueNil, STList _) ->
+      (U.ValueNil, STList l) -> withSingI l $
         pure $ T.VList []
 
-      (U.ValueSeq (toList -> mels), STList _) -> do
+      -- If ValueSeq contains at least 2 elements, it can be type checked as a
+      -- right combed pair.
+      (U.ValueSeq vals@(_ :| (_ : _)), STPair l r) ->
+        withSingI l $ withSingI r $ doTypeCheckVal $ seqToRightCombedPair vals
+
+      (U.ValueSeq (toList -> mels), STList l) -> withSingI l $ do
         els <- typeCheckValsImpl mels
         pure $ VList els
 
-      (U.ValueNil, STSet (s :: Sing st)) -> do
+      (U.ValueNil, STSet (s :: Sing st)) -> withSingI s $ do
         instrPos <- ask
         case T.getComparableProofS s of
           Just Dict -> pure (T.VSet S.empty)
           Nothing -> throwError $ TCFailedOnValue uvalue (demote @st) "Non comparable types are not allowed in Sets"
             instrPos (Just $ UnsupportedTypeForScope (demote @st) T.BtNotComparable)
 
-      (sq@(U.ValueSeq (toList -> mels)), s@(STSet (vt :: Sing st))) -> withComparable vt sq s $ do
+      (sq@(U.ValueSeq (toList -> mels)), s@(STSet (vt :: Sing st))) ->
+        withComparable vt sq s $ withSingI vt $ do
         instrPos <- ask
 
         els <- typeCheckValsImpl mels
         elsS <- liftEither $ S.fromDistinctAscList <$> ensureDistinctAsc id els
-                  `onFirst` \msg -> TCFailedOnValue sq (fromSingT vt) msg instrPos Nothing
+                  `onFirst` \msg -> TCFailedOnValue sq (fromSing vt) msg instrPos Nothing
         pure $ VSet elsS
 
-      (v@U.ValueNil, s@(STMap (st :: Sing st) _)) -> withComparable st v s $ pure $ T.VMap M.empty
+      (v@U.ValueNil, s@(STMap (st :: Sing st) vt)) ->
+        withSingI st $ withSingI vt $ withComparable st v s $ pure $ T.VMap M.empty
 
-      (sq@(U.ValueMap (toList -> mels)), s@(STMap (kt :: Sing st) _)) -> withComparable kt sq s $ do
+      (sq@(U.ValueMap (toList -> mels)), s@(STMap (kt :: Sing st) vt)) ->
+        withSingI kt $ withSingI vt $ withComparable kt sq s $ do
         keyOrderedElts <- typeCheckMapVal mels sq kt
         pure $ VMap (M.fromDistinctAscList keyOrderedElts)
 
-      (v@U.ValueNil, s@(STBigMap (st :: Sing st) _)) ->
-        withComparable st v s $ pure $ T.VBigMap M.empty
+      (v@U.ValueNil, s@(STBigMap (st1 :: Sing st) (st2 :: Sing st2))) ->
+        withSingI st1 $ withSingI st2 $ withComparable st1 v s $ withBigMapAbsence st2 v s $
+          pure $ VBigMap Nothing M.empty
 
-      (sq@(U.ValueMap (toList -> mels)), s@(STBigMap (kt :: Sing st) _)) -> withComparable kt sq s $ do
-        keyOrderedElts <- typeCheckMapVal mels sq kt
-        pure $ VBigMap (M.fromDistinctAscList keyOrderedElts)
+      (sq@(U.ValueMap (toList -> mels)), s@(STBigMap (kt :: Sing st) (vt :: Sing vt))) ->
+        withSingI kt $ withSingI vt $
+        withComparable kt sq s $ withBigMapAbsence vt sq s $ do
+          keyOrderedElts <- typeCheckMapVal mels sq kt
+          pure $ VBigMap Nothing (M.fromDistinctAscList keyOrderedElts)
 
-      (v, STLambda (_ :: Sing it) (_ :: Sing ot)) -> do
+      -- `{ {} }` can be typechecked either as `VLam` or `VList`.
+      (U.ValueLambda s, (STList l :: Sing st)) -> withSingI l $
+        case emptyLambdaAsList s of
+          Just xs -> doTypeCheckVal @st xs
+          Nothing -> tcFailedOnValue uvalue (demote @st) "" Nothing
+
+      (U.ValueSeq s, ((STLambda (i :: Sing inp) (o :: Sing out))) :: Sing l) ->
+        withSingI i $ withSingI o $ case emptyListAsLambda s of
+          Just xs -> doTypeCheckVal @l xs
+          Nothing -> tcFailedOnValue uvalue (demote @l) "" Nothing
+
+      (v, STLambda (var :: Sing it) (b :: Sing ot)) -> withSingI var $ withSingI b $ do
         mp <- case v of
           U.ValueNil       -> pure []
           U.ValueLambda mp -> pure $ toList mp
@@ -198,8 +257,39 @@
           AnyOutInstr lam ->
             pure $ VLam (T.RfAlwaysFails lam)
 
-      (v, t) -> tcFailedOnValue v (fromSingT t) "unknown value" Nothing
+      (v, t) -> tcFailedOnValue v (fromSing t) "unknown value" Nothing
 
+    seqToRightCombedPair :: (NonEmpty $ U.Value) -> U.Value
+    seqToRightCombedPair (x :| [y]) = U.ValuePair x y
+    seqToRightCombedPair (x :| xs) = U.ValuePair x $ seqToRightCombedPair (NE.fromList xs)
+
+    -- Converts a lambda containing only empty 'SeqEx's (possibly nested)
+    -- to a list of empty lists.
+    emptyLambdaAsList :: NonEmpty U.ExpandedOp -> Maybe U.Value
+    emptyLambdaAsList ops =
+      let
+        opToMaybeList :: U.ExpandedOp -> Maybe U.Value
+        opToMaybeList = \case
+          U.SeqEx []      -> Just U.ValueNil
+          U.SeqEx xs      -> U.ValueSeq . NE.fromList <$> traverse opToMaybeList xs
+          U.PrimEx {}     -> Nothing
+          U.WithSrcEx _ i -> opToMaybeList i
+      in
+        U.ValueSeq <$> traverse opToMaybeList ops
+
+    -- Converts a list containing only empty lists (possibly nested)
+    -- to a lambda of empty 'SeqEx's.
+    emptyListAsLambda :: NonEmpty U.Value -> Maybe U.Value
+    emptyListAsLambda ops =
+      let
+        listToMaybeOp :: U.Value -> Maybe U.ExpandedOp
+        listToMaybeOp = \case
+          U.ValueNil      -> Just $ U.SeqEx []
+          U.ValueSeq xs   -> U.SeqEx . toList <$> traverse listToMaybeOp xs
+          _               -> Nothing
+      in
+        U.ValueLambda <$> traverse listToMaybeOp ops
+
     withWTP
       :: forall t a. SingI t
       => U.Value
@@ -207,8 +297,8 @@
       -> TypeCheckInstr a
     withWTP uvalue fn = case getWTP @t of
       Right Dict -> fn
-      Left (NotWellTyped t) -> tcFailedOnValue uvalue (fromSingT $ sing @ty)
-                  ("Value is not well typed: " <> show t) Nothing
+      Left (NotWellTyped t cause) -> tcFailedOnValue uvalue (demote @ty)
+                  ("Value is not well typed: '" <> show t <> "' because it " <> pretty cause) Nothing
 
     typeCheckValsImpl
       :: forall t . (SingI t)
@@ -222,33 +312,33 @@
     -- It return list of pairs (key, value) with keys in ascending order
     -- so it is safe to call @fromDistinctAscList@ on returned list
     typeCheckMapVal
-      :: forall kt vt. (SingI kt, SingI vt)
+      :: forall kt vt. (SingI vt)
       => [U.Elt U.ExpandedOp]
       -> U.Value
       -> Sing kt
       -> TypeCheckInstr [(T.Value kt, T.Value vt)]
-    typeCheckMapVal mels sq kt = withComparable kt sq kt $ do
+    typeCheckMapVal mels sq kt = withSingI kt $ withComparable kt sq kt $ do
       instrPos <- ask
       ks <- typeCheckValsImpl @kt (map (\(U.Elt k _) -> k) mels)
       vals <- typeCheckValsImpl @vt (map (\(U.Elt _ v) -> v) mels)
       ksS <- liftEither $ ensureDistinctAsc id ks
-            `onFirst` \msg -> TCFailedOnValue sq (fromSingT kt) msg instrPos Nothing
+            `onFirst` \msg -> TCFailedOnValue sq (fromSing kt) msg instrPos Nothing
       pure $ zip ksS vals
 
     typecheckContractValue
-      :: forall cp tz. (Typeable cp, SingI cp, tz ~ 'T.TContract cp)
+      :: forall cp tz. (tz ~ 'T.TContract cp)
       => U.Value -> EpAddress -> Sing cp -> TypeCheckInstr (T.Value tz)
     typecheckContractValue cv (EpAddress addr epName) pc = do
 
       instrPos <- ask
-      let ensureTypeMatches :: forall t'. KnownT t' => TypeCheckInstr (cp :~: t')
+      let ensureTypeMatches :: forall t'. SingI t' => TypeCheckInstr (cp :~: t')
           ensureTypeMatches = liftEither @_ @TypeCheckInstr $
             first (TCFailedOnValue cv (demote @ty) "wrong contract parameter" instrPos . Just) $
-              eqType @cp @t'
+              (withSingI pc $ eqType @cp @t')
       let unsupportedType :: T.BadTypeForScope -> TCError
-          unsupportedType reason = TCFailedOnValue cv (fromSingT pc)
+          unsupportedType reason = TCFailedOnValue cv (fromSing pc)
             "Unsupported type in type argument of 'contract' type" instrPos $
-              Just $ UnsupportedTypeForScope (fromSingT pc) reason
+              Just $ UnsupportedTypeForScope (fromSing pc) reason
       case addr of
         KeyAddress _ -> do
           Refl <- ensureTypeMatches @'T.TUnit
@@ -280,4 +370,18 @@
   Nothing -> do
     instrPos <- ask
     liftEither . Left $
-      TCFailedOnValue uv (fromSingT t) "Require a comparable type here" instrPos Nothing
+      TCFailedOnValue uv (fromSing t) "Require a comparable type here" instrPos Nothing
+
+withBigMapAbsence
+  :: forall a (t :: T.T) ty. Sing a
+  -> U.Value
+  -> Sing t
+  -> (T.HasNoBigMap a => TypeCheckInstr ty)
+  -> TypeCheckInstr ty
+withBigMapAbsence s uv t act = case T.bigMapAbsense s of
+  Just Dict -> act
+  Nothing -> do
+    instrPos <- ask
+    liftEither . Left $
+      TCFailedOnValue uv (fromSing t) "Require a type which doesn't contain `big_map` here"
+        instrPos Nothing
diff --git a/src/Michelson/Typed.hs b/src/Michelson/Typed.hs
--- a/src/Michelson/Typed.hs
+++ b/src/Michelson/Typed.hs
@@ -12,6 +12,7 @@
 import Michelson.Typed.Convert as Exports
 import Michelson.Typed.Doc as Exports
 import Michelson.Typed.Entrypoints as Exports
+import Michelson.Typed.Existential as Exports
 import Michelson.Typed.Extract as Exports
 import Michelson.Typed.Haskell as Exports
 import Michelson.Typed.Instr as Exports
diff --git a/src/Michelson/Typed/Aliases.hs b/src/Michelson/Typed/Aliases.hs
--- a/src/Michelson/Typed/Aliases.hs
+++ b/src/Michelson/Typed/Aliases.hs
@@ -4,8 +4,6 @@
 
 module Michelson.Typed.Aliases
   ( Value
-  , SomeValue
-  , SomeConstrainedValue
   , Operation
   ) where
 
@@ -13,6 +11,4 @@
 import Michelson.Typed.Value
 
 type Value = Value' Instr
-type SomeValue = SomeValue' Instr
-type SomeConstrainedValue = SomeConstrainedValue' Instr
 type Operation = Operation' Instr
diff --git a/src/Michelson/Typed/Annotation.hs b/src/Michelson/Typed/Annotation.hs
--- a/src/Michelson/Typed/Annotation.hs
+++ b/src/Michelson/Typed/Annotation.hs
@@ -29,7 +29,7 @@
   , notesT
   ) where
 
-import Data.Singletons (Sing, SingI(..))
+import Data.Singletons (Sing, SingI(..), fromSing, withSingI)
 import Fmt (Buildable(..), (+|), (|+))
 import Text.PrettyPrint.Leijen.Text (Doc, (<+>))
 import qualified Text.Show
@@ -39,7 +39,8 @@
 import Michelson.Typed.Sing
 import Michelson.Typed.T (T(..))
 import Michelson.Untyped.Annotation
-  (Annotation, FieldAnn, TypeAnn, VarAnn, convergeVarAnns, fullAnnSet, noAnn, singleAnnSet, unifyAnn, unifyPairFieldAnn)
+  (Annotation, FieldAnn, TypeAnn, VarAnn, convergeVarAnns, fullAnnSet, noAnn, singleAnnSet,
+  unifyAnn, unifyPairFieldAnn)
 import Util.TH
 import Util.Typeable
 
@@ -58,6 +59,7 @@
   NTSet       :: TypeAnn -> Notes t -> Notes ('TSet t)
   NTOperation :: TypeAnn -> Notes 'TOperation
   NTContract  :: TypeAnn -> Notes t -> Notes ('TContract t)
+  NTTicket    :: TypeAnn -> Notes t -> Notes ('TTicket t)
   NTPair      :: TypeAnn -> FieldAnn -> FieldAnn
               -> VarAnn -> VarAnn
               -> Notes p -> Notes q -> Notes ('TPair p q)
@@ -114,6 +116,7 @@
     NTSet ta nt             -> "NTSet" <+> rendT ta <+> rendN nt
     NTOperation ta          -> "NTOperation" <+> rendT ta
     NTContract ta nt        -> "NTContract" <+> rendT ta <+> rendN nt
+    NTTicket ta nt          -> "NTTicket" <+> rendT ta <+> rendN nt
     NTPair ta fa1 fa2 va1 va2 np nq -> "NTPair" <+> rendTFV2 ta fa1 fa2 va1 va2 <+> rendN np <+> rendN nq
     NTOr ta fa1 fa2 np nq   -> "NTOr" <+> rendTF2 ta fa1 fa2 <+> rendN np <+> rendN nq
     NTLambda ta np nq       -> "NTLambda" <+> rendT ta <+> rendN np <+> rendN nq
@@ -141,7 +144,7 @@
 
 -- | Get term-level type of notes.
 notesT :: SingI t => Notes t -> T
-notesT = fromSingT . notesSing
+notesT = fromSing . notesSing
 
 -- | In memory of `NStar` constructor.
 --   Generates notes with no annotations.
@@ -165,15 +168,21 @@
   STSignature -> NTSignature noAnn
   STChainId -> NTChainId noAnn
   STOperation -> NTOperation noAnn
-  STSet _ -> NTSet noAnn starNotes
-  STList _ -> NTList noAnn starNotes
-  STOption _ -> NTOption noAnn starNotes
-  STContract _ -> NTContract noAnn starNotes
-  STMap _ _ -> NTMap noAnn starNotes starNotes
-  STBigMap _ _ -> NTBigMap noAnn starNotes starNotes
-  STPair _ _ -> NTPair noAnn noAnn noAnn noAnn noAnn starNotes starNotes
-  STOr _ _ -> NTOr noAnn noAnn noAnn starNotes starNotes
-  STLambda _ _ -> NTLambda noAnn starNotes starNotes
+  STSet t -> NTSet noAnn (withSingI t starNotes)
+  STList t -> NTList noAnn (withSingI t starNotes)
+  STOption t -> NTOption noAnn (withSingI t starNotes)
+  STContract t -> NTContract noAnn (withSingI t starNotes)
+  STTicket t -> NTTicket noAnn (withSingI t starNotes)
+  STMap t t' ->
+    NTMap noAnn (withSingI t starNotes) (withSingI t' starNotes)
+  STBigMap t t' ->
+    NTBigMap noAnn (withSingI t starNotes) (withSingI t' starNotes)
+  STPair t t' ->
+    NTPair noAnn noAnn noAnn noAnn noAnn (withSingI t starNotes) (withSingI t' starNotes)
+  STOr t t' ->
+    NTOr noAnn noAnn noAnn (withSingI t starNotes) (withSingI t' starNotes)
+  STLambda t t' ->
+    NTLambda noAnn (withSingI t starNotes) (withSingI t' starNotes)
 
 -- | Checks if no annotations are present.
 isStar :: SingI t => Notes t -> Bool
@@ -213,6 +222,8 @@
     NTOperation <$> convergeAnns a b
   (NTContract a n, NTContract b m) ->
     NTContract <$> convergeAnns a b <*> converge n m
+  (NTTicket a n, NTTicket b m) ->
+    NTTicket <$> convergeAnns a b <*> converge n m
   (NTPair a pF qF pV qV pN qN, NTPair b pG qG pW qW pM qM) ->
     NTPair <$> convergeAnns a b
            <*> convergeAnns pF pG <*> convergeAnns qF qG
@@ -251,6 +262,7 @@
   NTSet _ n1 -> NTSet nt n1
   NTOperation _ -> NTOperation nt
   NTContract _ n1 -> NTContract nt n1
+  NTTicket _ n1 -> NTTicket nt n1
   NTPair _ n1 n2 n3 n4 n5 n6 -> NTPair nt n1 n2 n3 n4 n5 n6
   NTOr _ n1 n2 n3 n4 -> NTOr nt n1 n2 n3 n4
   NTLambda _ n1 n2 -> NTLambda nt n1 n2
@@ -289,7 +301,7 @@
   => Annotation tag -> Annotation tag -> Either AnnConvergeError (Annotation tag)
 convergeAnns = convergeAnnsImpl unifyAnn
 
--- | Converge two field notes in CAR or CDR, given that one of them may be a
+-- | Converge two field notes in CAR, CDR or UNPAIR, given that one of them may be a
 -- special annotation.
 convergeDestrAnns :: FieldAnn -> FieldAnn -> Either AnnConvergeError FieldAnn
 convergeDestrAnns = convergeAnnsImpl unifyPairFieldAnn
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
@@ -9,8 +9,11 @@
   , convertContractCode
   , convertContract
   , instrToOps
+  , instrToOpsOptimized
   , untypeDemoteT
   , untypeValue
+  , untypeValueHashable
+  , untypeValueOptimized
 
   -- Helper for generating documentation
   , sampleTypedValue
@@ -19,9 +22,11 @@
   , flattenEntrypoints
   ) where
 
+import qualified Data.ByteArray as ByteArray
 import Data.Constraint (Dict(..))
+import Data.List.NonEmpty ((<|))
 import qualified Data.Map as Map
-import Data.Singletons (Sing, demote)
+import Data.Singletons (Sing, demote, withSingI)
 import Data.Vinyl (Rec(..))
 import Fmt (Buildable(..), Builder, blockListF, fmt, indentF, listF, pretty, unlinesF)
 
@@ -36,11 +41,18 @@
 import Michelson.Typed.T (T(..))
 import Michelson.Typed.Value
 import qualified Michelson.Untyped as U
-import Tezos.Core (mformatChainId, parseChainId, timestampFromSeconds, unMutez, unsafeMkMutez)
+import Michelson.Untyped.Annotation (Annotation(unAnnotation))
+import Tezos.Address (Address(..), ContractHash(..))
+import Tezos.Core
+  (ChainId(unChainId), mformatChainId, parseChainId, timestampFromSeconds, timestampToSeconds,
+  unMutez, unsafeMkMutez)
 import Tezos.Crypto
 import qualified Tezos.Crypto.BLS12381 as BLS
-import Util.Peano
-import Util.Typeable
+import qualified Tezos.Crypto.Ed25519 as Ed25519
+import qualified Tezos.Crypto.P256 as P256
+import qualified Tezos.Crypto.Secp256k1 as Secp256k1
+import Util.PeanoNatural (fromPeanoNatural)
+import Util.Sing (eqParamSing, eqParamSing2)
 
 convertParamNotes :: SingI cp => ParamNotes cp -> U.ParameterType
 convertParamNotes (ParamNotes notes rootAnn) =
@@ -57,26 +69,46 @@
     , entriesOrder = U.canonicalEntriesOrder
     }
 
-convertContract
-  :: forall param store . (SingI param, SingI store)
-  => Contract param store -> U.Contract
-convertContract fc =
+convertContract :: Contract param store -> U.Contract
+convertContract fc@Contract{} =
   let c = convertContractCode (cCode fc)
   in c { U.contractParameter = convertParamNotes (cParamNotes fc)
        , U.contractStorage = mkUType (cStoreNotes fc)
        , U.entriesOrder = cEntriesOrder fc
        }
 
+-- Note: if you change this type, check 'untypeValueImpl' wildcard patterns.
+data UntypingOptions
+  = Readable
+  -- ^ Convert value to human-readable representation
+  | Optimized
+  -- ^ Convert value to optimized representation
+  | Hashable
+  -- ^ Like 'Optimized', but without list notation for pairs.
+  -- Created to match 'tezos-client hash data' behavior for typed values.
+  -- See https://gitlab.com/morley-framework/morley/-/issues/611
+  deriving stock (Eq, Show)
+
+untypeValue :: (SingI t, HasNoOp t) => Value' Instr t -> U.Value
+untypeValue = untypeValueImpl Readable
+
+untypeValueHashable :: (SingI t, HasNoOp t) => Value' Instr t -> U.Value
+untypeValueHashable = untypeValueImpl Hashable
+
+untypeValueOptimized :: (SingI t, HasNoOp t) => Value' Instr t -> U.Value
+untypeValueOptimized = untypeValueImpl Optimized
+
 -- | Convert a typed 'Val' to an untyped 'Value'.
 --
 -- For full isomorphism type of the given 'Val' should not contain
 -- 'TOperation' - a compile error will be raised otherwise.
 -- You can analyse its presence with 'checkOpPresence' function.
-untypeValue ::
+untypeValueImpl ::
      forall t . (SingI t, HasNoOp t)
-  => Value' Instr t
+  => UntypingOptions
+  -> Value' Instr t
   -> U.Value
-untypeValue val = case (val, sing @t) of
+untypeValueImpl opts val = case (val, sing @t) of
   (VInt i, _) -> U.ValueInt i
   (VNat i, _) -> U.ValueInt $ toInteger i
   (VString s, _) -> U.ValueString s
@@ -84,106 +116,192 @@
   (VMutez m, _) -> U.ValueInt $ toInteger $ unMutez m
   (VBool True, _) -> U.ValueTrue
   (VBool False, _) -> U.ValueFalse
-  (VKeyHash h, _) -> U.ValueString $ mformatKeyHash h
-  -- Here we intentionally diverge from the reference implementation.
-  -- Tezos prints bls12_381_fr as bytes, but printing a number is more convenient
-  -- (numbers are shorter, and Tezos can parse numbers to bls12_381_fr)
-  (VBls12381Fr v, _) -> U.ValueInt $ toInteger v
-  (VBls12381G1 v, _) -> U.ValueBytes $ U.InternalByteString $ BLS.toMichelsonBytes v
-  (VBls12381G2 v, _) -> U.ValueBytes $ U.InternalByteString $ BLS.toMichelsonBytes v
-  (VTimestamp t, _) -> U.ValueString $ mkMTextUnsafe $ pretty t
-  (VAddress a, _) -> U.ValueString $ mformatEpAddress a
+  (VKeyHash h, _) ->
+    case opts of
+      Readable  -> U.ValueString $ mformatKeyHash h
+      _         -> U.ValueBytes $ U.InternalByteString $ keyHashToBytes h
+  (VBls12381Fr v, _) ->
+    case opts of
+      Readable  -> U.ValueInt $ toInteger v
+      _         -> U.ValueBytes . U.InternalByteString $ BLS.toMichelsonBytes v
+  (VBls12381G1 v, _) ->
+    U.ValueBytes . U.InternalByteString $ BLS.toMichelsonBytes v
+  (VBls12381G2 v, _) ->
+    U.ValueBytes . U.InternalByteString $ BLS.toMichelsonBytes v
+  (VTimestamp t, _) ->
+    case opts of
+      Readable   -> U.ValueString . unsafeMkMText $ pretty t
+      _          -> U.ValueInt $ timestampToSeconds t
+  (VAddress a, _) ->
+    case opts of
+      Readable  -> U.ValueString $ mformatEpAddress a
+      _         -> U.ValueBytes . U.InternalByteString  $ encodeEpAddress a
   (VKey b, _) ->
-    U.ValueString $ mformatPublicKey b
+    case opts of
+      Readable  -> U.ValueString $ mformatPublicKey b
+      _         -> U.ValueBytes . U.InternalByteString $ keyToBytes b
   (VUnit, _) ->
     U.ValueUnit
   (VSignature b, _) ->
-    U.ValueString $ mformatSignature b
+    case opts of
+      Readable  -> U.ValueString $ mformatSignature b
+      _         -> U.ValueBytes . U.InternalByteString $ signatureToBytes b
   (VChainId b, _) ->
-    U.ValueString $ mformatChainId b
+    case opts of
+      Readable  -> U.ValueString $ mformatChainId b
+      _         ->
+        U.ValueBytes . U.InternalByteString $ ByteArray.convert (unChainId b)
   (VOption (Just x), STOption _) ->
-    U.ValueSome (untypeValue x)
+    U.ValueSome (untypeValueImpl opts x)
   (VOption Nothing, STOption _) ->
     U.ValueNone
   (VList l, STList _) ->
-    vList U.ValueSeq $ map untypeValue l
+    vList U.ValueSeq $ map (untypeValueImpl opts) l
   (VSet s, STSet (st :: SingT st)) ->
     case checkOpPresence st of
-      OpAbsent -> vList U.ValueSeq $ map (untypeValue @st) $ toList s
+      OpAbsent -> vList U.ValueSeq $ map (untypeValueImpl @st opts) $ toList s
   (VContract addr sepc, _) ->
-    U.ValueString . mformatEpAddress $ EpAddress addr (sepcName sepc)
-
-  (VPair (l, r), STPair lt _) ->
+    case opts of
+      Readable  ->
+        U.ValueString . mformatEpAddress $ EpAddress addr (sepcName sepc)
+      _         -> U.ValueBytes . U.InternalByteString . encodeEpAddress $
+        EpAddress addr (sepcName sepc)
+  (VTicket s v a, _) ->
+    case valueTypeSanity v of
+      Dict ->
+        let us = untypeValueImpl opts $ VAddress (EpAddress s DefEpName)
+            uv = untypeValueImpl opts v
+            ua = untypeValueImpl opts $ VNat a
+        in case opts of
+          Optimized -> U.ValueSeq $ us :| [uv, ua]
+          _         -> U.ValuePair us (U.ValuePair uv ua)
+  p@(VPair (l, r), STPair lt rt) ->
+    withSingI lt $
+    withSingI rt $
     case checkOpPresence lt of
-      OpAbsent -> U.ValuePair (untypeValue l) (untypeValue r)
+      OpAbsent -> case opts of
+        Optimized -> U.ValueSeq $ pairToSeq p
+        _         -> U.ValuePair (untypeValueImpl opts l) (untypeValueImpl opts r)
 
   (VOr (Left x), STOr lt _) ->
     case checkOpPresence lt of
-      OpAbsent -> U.ValueLeft (untypeValue x)
+      OpAbsent -> U.ValueLeft (untypeValueImpl opts x)
 
   (VOr (Right x), STOr lt _) ->
     case checkOpPresence lt of
-      OpAbsent -> U.ValueRight (untypeValue x)
+      OpAbsent -> U.ValueRight (untypeValueImpl opts x)
 
   (VLam (rfAnyInstr -> ops :: Instr '[inp] '[out]), _) ->
-    vList U.ValueLambda $ instrToOps ops
+    vList U.ValueLambda $ instrToOpsImpl opts ops
 
   (VMap m, STMap kt vt) ->
     case (checkOpPresence kt, checkOpPresence vt) of
       (OpAbsent, OpAbsent) ->
         vList U.ValueMap $ Map.toList m <&> \(k, v) ->
-        U.Elt (untypeValue k) (untypeValue v)
+        U.Elt (untypeValueImpl opts k) (untypeValueImpl opts v)
 
-  (VBigMap m, STBigMap kt vt) ->
+  (VBigMap _ m, STBigMap kt vt) ->
     case (checkOpPresence kt, checkOpPresence vt) of
       (OpAbsent, OpAbsent) ->
         vList U.ValueMap $ Map.toList m <&> \(k, v) ->
-        U.Elt (untypeValue k) (untypeValue v)
+        U.Elt (untypeValueImpl opts k) (untypeValueImpl opts v)
   where
     vList ctor = maybe U.ValueNil ctor . nonEmpty
 
+    pairToSeq :: (SingI ty, HasNoOp ty)
+              => (Value ty, Sing ty)
+              -> NonEmpty U.Value
+    pairToSeq = \case
+      (VPair (a, b), STPair l r) -> withSingI l $ withSingI r $
+        case checkOpPresence l of
+          OpAbsent -> untypeValueImpl opts a <| pairToSeq (b, r)
+      (v, _) -> untypeValueImpl opts v :| []
+
+    keyHashToBytes :: KeyHash -> ByteString
+    keyHashToBytes kh = (<> (khBytes kh)) $
+      case khTag kh of
+        KeyHashEd25519 -> "\x00"
+        KeyHashSecp256k1 -> "\x01"
+        KeyHashP256 -> "\x02"
+
+    keyToBytes :: PublicKey -> ByteString
+    keyToBytes = \case
+      PublicKeyEd25519 pk -> "\x00" <> Ed25519.publicKeyToBytes pk
+      PublicKeySecp256k1 pk -> "\x01" <> Secp256k1.publicKeyToBytes pk
+      PublicKeyP256 pk -> "\x02" <> P256.publicKeyToBytes pk
+
+    encodeEpAddress :: EpAddress -> ByteString
+    encodeEpAddress (EpAddress addr epName) =
+      encodeAddress addr <> encodeEpName epName
+
+    encodeAddress :: Address -> ByteString
+    encodeAddress = \case
+      KeyAddress keyHash ->
+        "\x00" <> keyHashToBytes keyHash
+      ContractAddress (ContractHash address) ->
+        "\x01" <> address <> "\x00"
+
+    encodeEpName :: EpName -> ByteString
+    encodeEpName = encodeUtf8 . unAnnotation . epNameToRefAnn . canonicalize
+      where
+        canonicalize :: EpName -> EpName
+        canonicalize (UnsafeEpName "default") = DefEpName
+        canonicalize epName                   = epName
+
 untypeDemoteT :: forall (t :: T). SingI t => U.Ty
 untypeDemoteT = toUType $ demote @t
 
+instrToOpsOptimized :: HasCallStack => Instr inp out -> [U.ExpandedOp]
+instrToOpsOptimized = instrToOpsImpl Optimized
+
 instrToOps :: HasCallStack => Instr inp out -> [U.ExpandedOp]
-instrToOps = \case
+instrToOps = instrToOpsImpl Readable
+
+instrToOpsImpl :: HasCallStack
+               => UntypingOptions
+               -> Instr inp out
+               -> [U.ExpandedOp]
+instrToOpsImpl opts = \case
   Nop -> []
-  Seq i1 i2 -> instrToOps i1 <> instrToOps i2
+  Seq i1 i2 -> instrToOpsImpl opts i1 <> instrToOpsImpl opts i2
   Nested sq -> one $ U.SeqEx $ instrToOps sq
-  DocGroup _ sq -> instrToOps sq
+  DocGroup _ sq -> instrToOpsImpl opts sq
+  Fn t sfn i -> [U.PrimEx . U.EXT . U.FN t sfn $ instrToOps i]
   Ext (ext :: ExtInstr inp) -> (U.PrimEx . U.EXT) <$> extInstrToOps ext
-  FrameInstr _ i -> instrToOps i
+  FrameInstr _ i -> instrToOpsImpl opts i
   -- TODO [#283] After representation of locations is polished,
   -- this place should be updated to pass it from typed to untyped ASTs.
-  WithLoc _ i -> instrToOps i
-  InstrWithVarAnns _ i -> instrToOps i
+  WithLoc _ i -> instrToOpsImpl opts i
+  InstrWithVarAnns _ i -> instrToOpsImpl opts i
   InstrWithNotes proxy n i -> case i of
-    Nop -> instrToOps i
-    Seq _ _ -> instrToOps i
-    Nested _ -> instrToOps i
-    DocGroup _ _ -> instrToOps i
-    Ext _ -> instrToOps i
-    WithLoc _ i0 -> instrToOps (InstrWithNotes proxy n i0)
-    InstrWithNotes {} -> instrToOps i
+    Nop -> instrToOpsImpl opts i
+    Seq _ _ -> instrToOpsImpl opts i
+    Nested _ -> instrToOpsImpl opts i
+    DocGroup _ _ -> instrToOpsImpl opts i
+    Ext _ -> instrToOpsImpl opts i
+    WithLoc _ i0 -> instrToOpsImpl opts (InstrWithNotes proxy n i0)
+    InstrWithNotes {} -> instrToOpsImpl opts i
     -- For inner instruction, filter out values that we don't want to apply
     -- annotations to and delegate it's conversion to this function itself.
     -- If none of the above, convert a single instruction and copy annotations
     -- to it.
-    InstrWithVarNotes n0 (InstrWithVarAnns _ i0) -> instrToOps $ InstrWithNotes proxy n $ InstrWithVarNotes n0 i0
+    InstrWithVarNotes n0 (InstrWithVarAnns _ i0) ->
+      instrToOpsImpl opts $ InstrWithNotes proxy n $ InstrWithVarNotes n0 i0
     InstrWithVarNotes n0 i0 -> [U.PrimEx $ handleInstrAnnotateWithVarNotes i0 n n0]
-    InstrWithVarAnns _ _ -> instrToOps i
+    InstrWithVarAnns _ _ -> instrToOpsImpl opts i
     _ -> [U.PrimEx $ handleInstrAnnotate i n]
   InstrWithVarNotes n i -> case i of
-    Nop -> instrToOps i
-    Seq _ _ -> instrToOps i
-    Nested _ -> instrToOps i
-    DocGroup _ _ -> instrToOps i
-    Ext _ -> instrToOps i
-    WithLoc _ i0 -> instrToOps (InstrWithVarNotes n i0)
-    InstrWithNotes p0 n0 (InstrWithVarAnns _ i0) -> instrToOps $ InstrWithNotes p0 n0 $ InstrWithVarNotes n i0
+    Nop -> instrToOpsImpl opts i
+    Seq _ _ -> instrToOpsImpl opts i
+    Nested _ -> instrToOpsImpl opts i
+    DocGroup _ _ -> instrToOpsImpl opts i
+    Ext _ -> instrToOpsImpl opts i
+    WithLoc _ i0 -> instrToOpsImpl opts (InstrWithVarNotes n i0)
+    InstrWithNotes p0 n0 (InstrWithVarAnns _ i0) ->
+      instrToOpsImpl opts $ InstrWithNotes p0 n0 $ InstrWithVarNotes n i0
     InstrWithNotes _ n0 i0 -> [U.PrimEx $ handleInstrAnnotateWithVarNotes i0 n0 n]
-    InstrWithVarNotes _ _ -> instrToOps i
-    InstrWithVarAnns _ i0 -> instrToOps $ InstrWithVarNotes n i0
+    InstrWithVarNotes _ _ -> instrToOpsImpl opts i
+    InstrWithVarAnns _ i0 -> instrToOpsImpl opts $ InstrWithVarNotes n i0
     _ -> [U.PrimEx $ handleInstrVarNotes i n]
   i -> [U.PrimEx $ handleInstr i]
   where
@@ -213,41 +331,44 @@
         (U.SOME _ va, NTOption ta _ :& _) -> U.SOME ta va
         (U.NONE _ va _, (NTOption ta nt :: Notes t) :& _) ->
           case sing @t of
-            STOption {} -> U.NONE ta va (mkUType nt)
+            STOption t -> U.NONE ta va (withSingI t $ mkUType nt)
         (U.UNIT _ va, NTUnit ta :& _) -> U.UNIT ta va
-        (U.PAIR ta va f1 f2, _) -> U.PAIR ta va f1 f2
         (U.PAIRN va n, _) -> U.PAIRN va n
-        (U.CAR va f1, _) -> U.CAR va f1
-        (U.CDR va f1, _) -> U.CDR va f1
-        (U.LEFT _ va _ _ _, (NTOr ta f1 f2 _ n2 :: Notes t) :& _) ->
+        (U.LEFT ta va fa1 fa2 _, (NTOr _ _ _ _ n2 :: Notes t) :& _) ->
           case sing @t of
-            STOr {} -> U.LEFT ta va f1 f2 (mkUType n2)
-        (U.RIGHT _ va _ _ _, (NTOr ta f1 f2 n1 _ :: Notes t) :& _) ->
+            STOr _ rt ->
+              U.LEFT ta va fa1 fa2 (withSingI rt $ mkUType n2)
+        (U.RIGHT ta va fa1 fa2 _, (NTOr _ _ _ n1 _ :: Notes t) :& _) ->
           case sing @t of
-            STOr {} -> U.RIGHT ta va f1 f2 (mkUType n1)
+            STOr lt _ ->
+              U.RIGHT ta va fa1 fa2 (withSingI lt $ mkUType n1)
         (U.NIL _ va _, (NTList ta n :: Notes t) :& _) ->
           case sing @t of
-            STList {} -> U.NIL ta va (mkUType n)
+            STList l -> U.NIL ta va (withSingI l $ mkUType n)
         (U.EMPTY_SET _ va _, (NTSet ta1 n :: Notes t) :& _) ->
           case sing @t of
-            STSet {} -> U.EMPTY_SET ta1 va (mkUType n)
+            STSet s -> U.EMPTY_SET ta1 va (withSingI s $ mkUType n)
         (U.EMPTY_MAP _ va _ _, (NTMap ta1 k n :: Notes t) :& _) ->
           case sing @t of
-            STMap {} -> U.EMPTY_MAP ta1 va (mkUType k) (mkUType n)
+            STMap kt vt -> U.EMPTY_MAP ta1 va (withSingI kt $ mkUType k) (withSingI vt $ mkUType n)
         (U.EMPTY_BIG_MAP _ va _ _, (NTBigMap ta1 k n :: Notes t) :& _) ->
           case sing @t of
-            STBigMap {} -> U.EMPTY_BIG_MAP ta1 va (mkUType k) (mkUType n)
+            STBigMap kt vt -> U.EMPTY_BIG_MAP ta1 va (withSingI kt $ mkUType k) (withSingI vt $ mkUType n)
         (U.LAMBDA va _ _ ops, (NTLambda _ n1 n2 :: Notes t) :& _) ->
           case sing @t of
-            STLambda {} -> U.LAMBDA va (mkUType n1) (mkUType n2) ops
+            STLambda v b -> U.LAMBDA va (withSingI v $ mkUType n1) (withSingI b $ mkUType n2) ops
         (U.CAST va _, n :& _) -> U.CAST va (mkUType n)
         (U.UNPACK _ va _, (NTOption ta nt :: Notes t) :& _) ->
           case sing @t of
-            STOption {} -> U.UNPACK ta va (mkUType nt)
+            STOption op -> U.UNPACK ta va (withSingI op $ mkUType nt)
         (U.CONTRACT va fa _, (NTOption _ (NTContract _ nt :: Notes t) :: Notes t2) :& _) ->
           case sing @t2 of
-            STOption STContract {} -> U.CONTRACT va fa (mkUType nt)
+            STOption (STContract c) -> U.CONTRACT va fa (withSingI c $ mkUType nt)
         (U.CONTRACT va fa t, NTOption _ _ :& _) -> U.CONTRACT va fa t
+        (U.CAR {}, _) -> instr
+        (U.CDR {}, _) -> instr
+        (U.PAIR {}, _) -> instr
+        (U.UNPAIR {}, _) -> instr
         (U.APPLY {}, _) -> instr
         (U.CHAIN_ID {}, _) -> instr
         (U.EXT _, _) -> instr
@@ -326,6 +447,10 @@
         (U.ADDRESS _, _) -> instr
         (U.SELF_ADDRESS _, _) -> instr
         (U.NEVER, _) -> instr
+        (U.TICKET _, _) -> instr
+        (U.READ_TICKET _, _) -> instr
+        (U.SPLIT_TICKET _, _) -> instr
+        (U.JOIN_TICKETS _, _) -> instr
         _ -> error $ pretty $ unlinesF
           [ "addInstrNote: Unexpected instruction/annotation combination"
           , "Instruction:"
@@ -361,8 +486,6 @@
         U.UNIT ta _ -> U.UNIT ta va
         U.PAIR ta _ fa1 fa2 -> U.PAIR ta va fa1 fa2
         U.PAIRN _ n -> U.PAIRN va n
-        U.CAR _ fa -> U.CAR va fa
-        U.CDR _ fa -> U.CDR va fa
         U.LEFT ta _ fa1 fa2 t -> U.LEFT ta va fa1 fa2 t
         U.RIGHT ta _ fa1 fa2 t -> U.RIGHT ta va fa1 fa2 t
         U.NIL ta _ t -> U.NIL ta va t
@@ -432,6 +555,10 @@
         U.CHAIN_ID _ -> U.CHAIN_ID va
         U.LEVEL _ -> U.LEVEL va
         U.SELF_ADDRESS _ -> U.SELF_ADDRESS va
+        U.TICKET _ -> U.TICKET va
+        U.READ_TICKET _ -> U.READ_TICKET va
+        U.SPLIT_TICKET _ -> U.SPLIT_TICKET va
+        U.JOIN_TICKETS _ -> U.JOIN_TICKETS va
         _ -> error $
           "addVarNotes: Cannot add single var annotation to instr: " <> (show ins) <> " with " <> show va
       _ -> error $
@@ -449,35 +576,47 @@
       (Ext _) -> error "impossible"
       (Nested _) -> error "impossible"
       DocGroup{} -> error "impossible"
+      Fn t sfn i -> U.EXT . U.FN t sfn $ instrToOpsImpl opts i
       DROP -> U.DROP
-      (DROPN s) -> U.DROPN (fromIntegral $ peanoValSing s)
+      (DROPN s) -> U.DROPN (fromIntegral $ fromPeanoNatural s)
       DUP -> U.DUP U.noAnn
-      (DUPN s) -> U.DUPN U.noAnn (fromIntegral $ peanoValSing s)
+      (DUPN s) -> U.DUPN U.noAnn (fromIntegral $ fromPeanoNatural s)
       SWAP -> U.SWAP
-      (DIG s) -> U.DIG (fromIntegral $ peanoValSing s)
-      (DUG s) -> U.DUG (fromIntegral $ peanoValSing s)
+      (DIG s) -> U.DIG (fromIntegral $ fromPeanoNatural s)
+      (DUG s) -> U.DUG (fromIntegral $ fromPeanoNatural s)
       i@(PUSH val) | _ :: Instr inp1 (t ': s) <- i ->
-        let value = untypeValue val
+        let value = untypeValueImpl opts val
         in U.PUSH U.noAnn (untypeDemoteT @t) value
       i@NONE | _ :: Instr inp1 ('TOption a ': inp1) <- i ->
         U.NONE U.noAnn U.noAnn (untypeDemoteT @a)
       SOME -> U.SOME U.noAnn U.noAnn
       UNIT -> U.UNIT U.noAnn U.noAnn
-      (IF_NONE i1 i2) -> U.IF_NONE (instrToOps i1) (instrToOps i2)
+      (IF_NONE i1 i2) -> U.IF_NONE (instrToOpsImpl opts i1) (instrToOpsImpl opts i2)
+
+      -- `AnnUNPAIR` accepts special var anns, so it carries them inside its constructor,
+      -- so we can use them here to re-construct an untyped `U.UNPAIR`.
+      -- `AnnPAIR`, on the other hand, doesn't accept special var anns, so the var anns
+      -- are carried in the `InstrWithVarNotes` meta-instruction instead.
+      --
+      -- See: Note [Annotations - Exceptional scenarios] in `Michelson.Typed.Instr`
+      --
+      -- TODO [#580]
       AnnPAIR tn fn1 fn2 -> U.PAIR tn U.noAnn fn1 fn2
-      PAIRN n -> U.PAIRN U.noAnn (fromIntegral $ peanoValSing n)
-      UNPAIRN n -> U.UNPAIRN (fromIntegral $ peanoValSing n)
-      (AnnCAR fn) -> U.CAR U.noAnn fn
-      (AnnCDR fn) -> U.CDR U.noAnn fn
+      AnnUNPAIR vn1 vn2 fn1 fn2 -> U.UNPAIR vn1 vn2 fn1 fn2
+
+      PAIRN n -> U.PAIRN U.noAnn (fromIntegral $ fromPeanoNatural n)
+      UNPAIRN n -> U.UNPAIRN (fromIntegral $ fromPeanoNatural n)
+      (AnnCAR vn fn) -> U.CAR vn fn
+      (AnnCDR vn fn) -> U.CDR vn fn
       i@(AnnLEFT tn fn1 fn2) | _ :: Instr (a ': s) ('TOr a b ': s) <- i ->
         U.LEFT tn U.noAnn fn1 fn2 (untypeDemoteT @b)
       i@(AnnRIGHT tn fn1 fn2) | _ :: Instr (b ': s) ('TOr a b ': s) <- i ->
         U.RIGHT tn U.noAnn fn1 fn2 (untypeDemoteT @a)
-      (IF_LEFT i1 i2) -> U.IF_LEFT (instrToOps i1) (instrToOps i2)
+      (IF_LEFT i1 i2) -> U.IF_LEFT (instrToOpsImpl opts i1) (instrToOpsImpl opts i2)
       i@NIL | _ :: Instr s ('TList p ': s) <- i ->
         U.NIL U.noAnn U.noAnn (untypeDemoteT @p)
       CONS -> U.CONS U.noAnn
-      (IF_CONS i1 i2) -> U.IF_CONS (instrToOps i1) (instrToOps i2)
+      (IF_CONS i1 i2) -> U.IF_CONS (instrToOpsImpl opts i1) (instrToOpsImpl opts i2)
       SIZE -> U.SIZE U.noAnn
       i@EMPTY_SET | _ :: Instr s ('TSet e ': s) <- i ->
         U.EMPTY_SET U.noAnn U.noAnn (U.Ty (U.unwrapT $ untypeDemoteT @e) U.noAnn)
@@ -487,24 +626,24 @@
       i@EMPTY_BIG_MAP | _ :: Instr s ('TBigMap a b ': s) <- i ->
         U.EMPTY_BIG_MAP U.noAnn U.noAnn (U.Ty (U.unwrapT $ untypeDemoteT @a) U.noAnn)
           (untypeDemoteT @b)
-      (MAP op) -> U.MAP U.noAnn $ instrToOps op
-      (ITER op) -> U.ITER $ instrToOps op
+      (MAP op) -> U.MAP U.noAnn $ instrToOpsImpl opts op
+      (ITER op) -> U.ITER $ instrToOpsImpl opts op
       MEM -> U.MEM U.noAnn
       GET -> U.GET U.noAnn
-      GETN n -> U.GETN U.noAnn (fromIntegral $ peanoValSing n)
+      GETN n -> U.GETN U.noAnn (fromIntegral $ fromPeanoNatural n)
       UPDATE -> U.UPDATE U.noAnn
-      UPDATEN n -> U.UPDATEN U.noAnn (fromIntegral $ peanoValSing n)
+      UPDATEN n -> U.UPDATEN U.noAnn (fromIntegral $ fromPeanoNatural n)
       GET_AND_UPDATE -> U.GET_AND_UPDATE U.noAnn
-      (IF op1 op2) -> U.IF (instrToOps op1) (instrToOps op2)
-      (LOOP op) -> U.LOOP (instrToOps op)
-      (LOOP_LEFT op) -> U.LOOP_LEFT (instrToOps op)
+      (IF op1 op2) -> U.IF (instrToOpsImpl opts op1) (instrToOpsImpl opts op2)
+      (LOOP op) -> U.LOOP (instrToOpsImpl opts op)
+      (LOOP_LEFT op) -> U.LOOP_LEFT (instrToOpsImpl opts op)
       i@(LAMBDA {}) | LAMBDA (VLam l) :: Instr s ('TLambda i o ': s) <- i ->
-        U.LAMBDA U.noAnn (untypeDemoteT @i) (untypeDemoteT @o) (instrToOps $ rfAnyInstr l)
+        U.LAMBDA U.noAnn (untypeDemoteT @i) (untypeDemoteT @o) (instrToOpsImpl opts $ rfAnyInstr l)
       EXEC -> U.EXEC U.noAnn
       APPLY -> U.APPLY U.noAnn
-      (DIP op) -> U.DIP (instrToOps op)
+      (DIP op) -> U.DIP (instrToOpsImpl opts op)
       (DIPN s op) ->
-        U.DIPN (fromIntegral $ peanoValSing s) (instrToOps op)
+        U.DIPN (fromIntegral $ fromPeanoNatural s) (instrToOpsImpl opts op)
       FAILWITH -> U.FAILWITH
       i@CAST | _ :: Instr (a ': s) (a ': s) <- i ->
         U.CAST U.noAnn (untypeDemoteT @a)
@@ -574,9 +713,13 @@
       LEVEL -> U.LEVEL U.noAnn
       SELF_ADDRESS -> U.SELF_ADDRESS U.noAnn
       NEVER -> U.NEVER
+      TICKET -> U.TICKET U.noAnn
+      READ_TICKET -> U.READ_TICKET U.noAnn
+      SPLIT_TICKET -> U.SPLIT_TICKET U.noAnn
+      JOIN_TICKETS -> U.JOIN_TICKETS U.noAnn
 
 untypeStackRef :: StackRef s -> U.StackRef
-untypeStackRef (StackRef n) = U.StackRef (peanoVal n)
+untypeStackRef (StackRef n) = U.StackRef (fromPeanoNatural n)
 
 untypePrintComment :: PrintComment s -> U.PrintComment
 untypePrintComment (PrintComment pc) = U.PrintComment $ map (second untypeStackRef) pc
@@ -597,6 +740,7 @@
       JustComment com -> one $ U.UCOMMENT com
       StackTypeComment (Just stack) -> one $ U.UCOMMENT $ pretty (listF stack)
       StackTypeComment Nothing -> one $ U.UCOMMENT $ fmt "any stack type"
+  STACKTYPE s -> one $ U.STACKTYPE s
 
 -- It's an orphan instance, but it's better than checking all cases manually.
 -- We can also move this convertion to the place where `Instr` is defined,
@@ -605,14 +749,14 @@
 instance Eq (Instr inp out) where
   i1 == i2 = instrToOps i1 == instrToOps i2
 
-instance Typeable s => Eq (TestAssert s) where
+instance SingI s => Eq (TestAssert s) where
   TestAssert   name1 pattern1 instr1
     ==
     TestAssert name2 pattern2 instr2
     = and
     [ name1 == name2
-    , pattern1 `eqParam1` pattern2
-    , instr1 `eqParam2` instr2
+    , pattern1 `eqParamSing` pattern2
+    , instr1 `eqParamSing2` instr2
     ]
 
 instance (SingI t, HasNoOp t) => Buildable (Value' Instr t) where
@@ -644,44 +788,50 @@
     STOperation        -> Nothing
     STNever            -> Nothing
     STOption t ->
-      VOption . Just <$> sampleTypedValue t
+      withSingI t $ VOption . Just <$> sampleTypedValue t
     STList t ->
-      VList . one <$> sampleTypedValue t
-    STSet t -> do
+      withSingI t $ VList . one <$> sampleTypedValue t
+    STSet t -> withSingI t $ do
       Dict <- comparabilityPresence t
       VSet . one <$> sampleTypedValue t
-    STContract t -> do
+    STContract t -> withSingI t $ do
       Dict <- opAbsense t
       Dict <- nestedBigMapsAbsense t
-      pure . VContract (eaAddress sampleAddress) $ SomeEpc epcCallRootUnsafe
-    STPair t1 t2 -> do
+      pure . VContract (eaAddress sampleAddress) $ SomeEpc unsafeEpcCallRoot
+    STTicket t -> withSingI t $ do
+      cmpProof <- comparabilityPresence t
+      dat <- sampleTypedValue t
+      VNat amount <- sampleTypedValue STNat
+      case cmpProof of
+        Dict -> return $ VTicket (eaAddress sampleAddress) dat amount
+    STPair t1 t2 -> withSingI t1 $ withSingI t2 $ do
       val1 <- sampleTypedValue t1
       val2 <- sampleTypedValue t2
       pure $ VPair (val1, val2)
-    STOr tl tr -> asum
+    STOr tl tr -> withSingI tl $ withSingI tr $ asum
       [ VOr . Left <$> sampleTypedValue tl
       , VOr . Right <$> sampleTypedValue tr
       ]
-    STMap t1 t2 -> do
+    STMap t1 t2 -> withSingI t1 $ withSingI t2 $ do
       val1 <- sampleTypedValue t1
       val2 <- sampleTypedValue t2
       case checkComparability t1 of
         CanBeCompared -> pure $ VMap $ Map.fromList [(val1, val2)]
         CannotBeCompared -> Nothing
-    STBigMap t1 t2 -> do
+    STBigMap t1 t2 -> withSingI t1 $ withSingI t2 $ do
       val1 <- sampleTypedValue t1
       val2 <- sampleTypedValue t2
-      case checkComparability t1 of
-        CanBeCompared -> pure $ VBigMap $ Map.fromList [(val1, val2)]
-        CannotBeCompared -> Nothing
-    STLambda _ (t2 :: Sing t2) ->
+      case (checkComparability t1, bigMapAbsense t2) of
+        (CanBeCompared, Just Dict) -> pure $ VBigMap Nothing $ Map.fromList [(val1, val2)]
+        _                          -> Nothing
+    STLambda v (t2 :: Sing t2) -> withSingI v $ withSingI t2 $
       case checkScope @(ConstantScope t2) of
         Right Dict -> do
           val <- sampleTypedValue t2
           pure $ VLam $ RfNormal (DROP `Seq` PUSH val)
         _ -> pure $ VLam $ RfAlwaysFails (PUSH (VString [mt|lambda sample|]) `Seq` FAILWITH)
     where
-      sampleAddress =  unsafeParseEpAddress "KT1AEseqMV6fk2vtvQCVyA7ZCaxv7cpxtXdB"
+      sampleAddress = unsafeParseEpAddress "KT1AEseqMV6fk2vtvQCVyA7ZCaxv7cpxtXdB"
       samplePublicKey = fromRight (error "impossible") $ parsePublicKey
         "edpkuwTWKgQNnhR5v17H2DYHbfcxYepARyrPGbf1tbMoGQAj8Ljr3V"
       sampleSignature = fromRight (error "impossible") $ parseSignature
diff --git a/src/Michelson/Typed/Doc.hs b/src/Michelson/Typed/Doc.hs
--- a/src/Michelson/Typed/Doc.hs
+++ b/src/Michelson/Typed/Doc.hs
@@ -125,6 +125,13 @@
 instance ContainsUpdateableDoc (Instr inp out) where
   modifyDocEntirely = modifyInstrAllDoc
 
+instance ContainsDoc (Contract cp st) where
+  buildDocUnfinalized = buildDocUnfinalized . cCode
+
+instance ContainsUpdateableDoc (Contract cp st) where
+  modifyDocEntirely how contract =
+    contract{ cCode = modifyInstrAllDoc how (cCode contract) }
+
 -- | Leave only instructions related to documentation.
 --
 -- Generated documentation for resulting instruction remains the same, but
diff --git a/src/Michelson/Typed/Entrypoints.hs b/src/Michelson/Typed/Entrypoints.hs
--- a/src/Michelson/Typed/Entrypoints.hs
+++ b/src/Michelson/Typed/Entrypoints.hs
@@ -23,9 +23,9 @@
   , EpLiftSequence (..)
   , EntrypointCallT (..)
   , epcPrimitive
-  , epcCallRootUnsafe
+  , unsafeEpcCallRoot
   , SomeEntrypointCallT (..)
-  , sepcCallRootUnsafe
+  , unsafeSepcCallRoot
   , sepcPrimitive
   , sepcName
   , ForbidOr
@@ -47,15 +47,18 @@
 import Control.Monad.Except (throwError)
 import qualified Data.ByteString as BS
 import Data.Constraint (Dict(..))
+import Data.Singletons (withSingI)
 import qualified Data.List.NonEmpty as NE
 import qualified Data.Text as T
 import Fmt (Buildable(..), hexF, pretty, (+|), (|+))
+import Text.PrettyPrint.Leijen.Text ((<+>), int, squotes, punctuate, textStrict)
 
 import Michelson.Text
 import Michelson.Typed.Annotation
 import Michelson.Typed.Scope
 import Michelson.Typed.Sing
 import Michelson.Typed.T
+import Michelson.Printer.Util (RenderDoc(..), renderAnyBuildable, buildRenderDoc)
 import Michelson.Untyped.Annotation
 import Michelson.Untyped.Entrypoints
 import Tezos.Address
@@ -95,7 +98,7 @@
   let t = formatEpAddress ea
      -- Should be safe because set of characters allowed in annotations
      -- (and thus in 'EpName') is subset of characters allowed in Michelson strings.
-  in mkMTextUnsafe t
+  in unsafeMkMText t
 
 data ParseEpAddressError
   = ParseEpAddressBadAddress ParseAddressError
@@ -109,16 +112,19 @@
 instance NFData ParseEpAddressError
 
 instance Buildable ParseEpAddressError where
-  build = \case
-    ParseEpAddressBadAddress err -> build err
-    ParseEpAddressRawBadAddress err -> build err
+  build = buildRenderDoc
+
+instance RenderDoc ParseEpAddressError where
+  renderDoc context = \case
+    ParseEpAddressBadAddress err -> renderDoc context err
+    ParseEpAddressRawBadAddress err -> renderDoc context err
     ParseEpAddressBadEntryopint addr exception ->
-      "Invalid entrypoint given for raw adddress " <> hexF addr <>
-      " and failed with " <> build (show @Text exception)
-    ParseEpAddressBadRefAnn txt -> pretty $ "Invalid reference annotation: " <> txt
-    ParseEpAddressRefAnnError err -> build err
+      "Invalid entrypoint given for raw adddress" <+> (renderAnyBuildable $ hexF addr)<>
+      " and failed with" <+> (textStrict (show @Text exception))
+    ParseEpAddressBadRefAnn txt -> "Invalid reference annotation:" <+> (textStrict txt)
+    ParseEpAddressRefAnnError err -> renderDoc context err
     ParseEpAddressInvalidLength len ->
-      "Given raw entrypoint address has invalid length: " <> build len
+      "Given raw entrypoint address has invalid length:" <+> int len
 
 -- | Parse an address which can be suffixed with entrypoint name
 -- (e.g. "tz1faswCTDciRzE4oJ9jn2Vm2dvjeyA9fUzU%entrypoint").
@@ -176,19 +182,19 @@
 -- Following the Michelson specification, this type has the following invariants:
 -- 1. No entrypoint name is duplicated.
 -- 2. If @default@ entrypoint is explicitly assigned, no "arm" remains uncallable.
-data ParamNotes (t :: T) = ParamNotesUnsafe
+data ParamNotes (t :: T) = UnsafeParamNotes
   { pnNotes   :: Notes t
   , pnRootAnn :: RootAnn
   } deriving stock (Show, Eq, Generic)
     deriving anyclass (NFData)
 
 pattern ParamNotes :: Notes t -> RootAnn -> ParamNotes t
-pattern ParamNotes t f <- ParamNotesUnsafe t f
+pattern ParamNotes t f <- UnsafeParamNotes t f
 {-# COMPLETE ParamNotes #-}
 
 -- | Parameter without annotations.
 starParamNotes :: SingI t => ParamNotes t
-starParamNotes = ParamNotesUnsafe starNotes noAnn
+starParamNotes = UnsafeParamNotes starNotes noAnn
 
 -- | Coordinates of "arm" in Or tree, used solely in error messages.
 type ArmCoords = [ArmCoord]
@@ -198,10 +204,14 @@
 instance NFData ArmCoord
 
 instance Buildable ArmCoord where
-  build = \case
+  build = buildRenderDoc
+
+instance RenderDoc ArmCoord where
+  renderDoc _ = \case
     AcLeft -> "left"
     AcRight -> "right"
 
+
 -- | Errors specific to parameter type declaration (entrypoints).
 data ParamEpError
   = ParamEpDuplicatedNames (NonEmpty EpName)
@@ -211,20 +221,21 @@
 instance NFData ParamEpError
 
 instance Buildable ParamEpError where
-  build = \case
+  build = buildRenderDoc
+
+instance RenderDoc ParamEpError where
+  renderDoc context = \case
     ParamEpDuplicatedNames names -> mconcat
       [ "Duplicated entrypoint names: "
-      , mconcat . intersperse ", " $ map (surround "'" "'" . build) (toList names)
+      , mconcat $ punctuate ", " . map (squotes . renderAnyBuildable) $ toList names
       ]
     ParamEpUncallableArm arm -> mconcat
       [ "Due to presence of 'default' entrypoint, one of contract \"arms\" \
         \cannot be called: \""
-      , mconcat . intersperse " - " $ map build arm
+      , mconcat . intersperse " - " $ map (renderDoc context) arm
       , "\""
       , if length arm > 1 then " (in top-to-bottom order)" else ""
       ]
-    where
-    surround pre post builder = pre <> builder <> post
 
 -- | Check whether given notes are valid parameter notes.
 verifyParamNotes :: Notes t -> RootAnn -> Either ParamEpError ()
@@ -295,7 +306,7 @@
 
 -- | Construct 'ParamNotes' performing all necessary checks.
 mkParamNotes :: Notes t -> RootAnn -> Either ParamEpError (ParamNotes t)
-mkParamNotes nt fa = verifyParamNotes nt fa $> ParamNotesUnsafe nt fa
+mkParamNotes nt fa = verifyParamNotes nt fa $> UnsafeParamNotes nt fa
 
 ----------------------------------------------------------------------------
 -- Entrypoint logic
@@ -309,10 +320,10 @@
 data EpLiftSequence (arg :: T) (param :: T) where
   EplArgHere :: EpLiftSequence arg arg
   EplWrapLeft
-    :: (KnownT subparam, KnownT r)
+    :: (SingI subparam, SingI r)
     => EpLiftSequence arg subparam -> EpLiftSequence arg ('TOr subparam r)
   EplWrapRight
-    :: (KnownT l, KnownT subparam)
+    :: (SingI l, SingI subparam)
     => EpLiftSequence arg subparam -> EpLiftSequence arg ('TOr l subparam)
 
 deriving stock instance Eq (EpLiftSequence arg param)
@@ -350,8 +361,8 @@
 -- there is no explicit "default" one.
 --
 -- Validity of such operation is not ensured.
-epcCallRootUnsafe :: ParameterScope param => EntrypointCallT param param
-epcCallRootUnsafe = EntrypointCall
+unsafeEpcCallRoot :: ParameterScope param => EntrypointCallT param param
+unsafeEpcCallRoot = EntrypointCall
   { epcName = DefEpName
   , epcParamProxy = Proxy
   , epcLiftSequence = EplArgHere
@@ -362,7 +373,7 @@
   :: forall p.
      (ParameterScope p, ForbidOr p)
   => EntrypointCallT p p
-epcPrimitive = epcCallRootUnsafe
+epcPrimitive = unsafeEpcCallRoot
   where
   _requireNoOr = Dict @(ForbidOr p)
 
@@ -398,8 +409,8 @@
 -- there is no explicit "default" one.
 --
 -- Validity of such operation is not ensured.
-sepcCallRootUnsafe :: ParameterScope param => SomeEntrypointCallT param
-sepcCallRootUnsafe = SomeEpc epcCallRootUnsafe
+unsafeSepcCallRoot :: ParameterScope param => SomeEntrypointCallT param
+unsafeSepcCallRoot = SomeEpc unsafeEpcCallRoot
 
 -- | Call parameter which has no entrypoints, always safe.
 sepcPrimitive
@@ -427,7 +438,9 @@
   -> Maybe r
 withEpLiftSequence epName@(epNameToParamAnn -> epAnn) param cont =
   case (sing @param, param) of
-    (STOr lSing _, NTOr _ lFieldAnn rFieldAnn lNotes rNotes) ->
+    (STOr lSing rSing, NTOr _ lFieldAnn rFieldAnn lNotes rNotes) ->
+      withSingI lSing $
+      withSingI rSing $
       case (checkOpPresence lSing, checkNestedBigMapsPresence lSing) of
         (OpAbsent, NestedBigMapsAbsent) -> asum
           [ guard (lFieldAnn == epAnn) $> cont (lNotes, EplWrapLeft EplArgHere)
@@ -484,4 +497,4 @@
 
 -- | "Parameter" type of implicit account.
 tyImplicitAccountParam :: ParamNotes 'TUnit
-tyImplicitAccountParam = ParamNotesUnsafe starNotes noAnn
+tyImplicitAccountParam = UnsafeParamNotes starNotes noAnn
diff --git a/src/Michelson/Typed/Existential.hs b/src/Michelson/Typed/Existential.hs
new file mode 100644
--- /dev/null
+++ b/src/Michelson/Typed/Existential.hs
@@ -0,0 +1,79 @@
+-- SPDX-FileCopyrightText: 2021 Tocqueville Group
+--
+-- SPDX-License-Identifier: LicenseRef-MIT-TQ
+
+module Michelson.Typed.Existential
+  ( SomeConstant (..)
+  , SomeConstrainedValue (..)
+  , SomeContract (..)
+  , SomeContractAndStorage (..)
+  , SomeIsoValue (..)
+  , SomeValue (..)
+  , SomeStorage(..)
+  ) where
+
+import Fmt (Buildable(..))
+
+import Michelson.Typed.Aliases
+import Michelson.Typed.Convert ()
+import Michelson.Typed.Haskell.Value (KnownIsoT)
+import Michelson.Typed.Instr (Contract(..))
+import Michelson.Typed.Scope
+import Michelson.Typed.T (T(..))
+import Util.Sing (eqParamSing)
+
+data SomeConstrainedValue (c :: T -> Constraint) where
+  SomeConstrainedValue
+    :: forall (t :: T) (c :: T -> Constraint)
+    . (c t)
+    => Value t
+    -> SomeConstrainedValue c
+
+deriving stock instance Show (SomeConstrainedValue c)
+
+-- TODO
+-- @gromak: perhaps we should implement `SomeValue` in terms of
+-- `SomeConstrainedValue`, but it will require changing quite a lot of code,
+-- so it is postponed.
+
+data SomeValue where
+  SomeValue :: SingI t => Value t -> SomeValue
+
+deriving stock instance Show SomeValue
+
+instance Eq SomeValue where
+  SomeValue v1 == SomeValue v2 = v1 `eqParamSing` v2
+
+data SomeConstant where
+  SomeConstant :: (ConstantScope t, SingI t) => Value t -> SomeConstant
+
+instance Buildable SomeConstant where
+  build (SomeConstant v) = build v
+
+-- | Hides some Haskell value put in line with Michelson 'Value'.
+data SomeIsoValue where
+  SomeIsoValue :: (KnownIsoT a) => a -> SomeIsoValue
+
+data SomeContract where
+  SomeContract :: Contract cp st -> SomeContract
+
+instance NFData SomeContract where
+  rnf (SomeContract c) = rnf c
+
+deriving stock instance Show SomeContract
+
+-- | Represents a typed contract & a storage value of the type expected by the contract.
+data SomeContractAndStorage where
+  SomeContractAndStorage
+    :: forall cp st.
+       (StorageScope st, ParameterScope cp)
+       => Contract cp st
+       -> Value st
+       -> SomeContractAndStorage
+
+deriving stock instance Show SomeContractAndStorage
+
+data SomeStorage where
+  SomeStorage :: forall st. StorageScope st => Value st -> SomeStorage
+
+deriving stock instance Show SomeStorage
diff --git a/src/Michelson/Typed/Extract.hs b/src/Michelson/Typed/Extract.hs
--- a/src/Michelson/Typed/Extract.hs
+++ b/src/Michelson/Typed/Extract.hs
@@ -19,17 +19,17 @@
   , pattern AsUTypeExt
   ) where
 
-import Data.Singletons (Sing, SingI)
+import Data.Singletons (Sing, SingI, fromSing, withSingI)
 
 import Michelson.Typed.Annotation (Notes(..), notesSing)
-import Michelson.Typed.Sing (KnownT, SingT(..), fromSingT)
+import Michelson.Typed.Sing (SingT(..))
 import Michelson.Typed.T (T(..), toUType)
 import qualified Michelson.Untyped as Un
 
 {-# ANN module ("HLint: ignore Avoid lambda using `infix`" :: Text) #-}
 
 fromUType :: Un.Ty -> T
-fromUType ut = withUType ut (fromSingT . notesSing)
+fromUType ut = withUType ut (fromSing . notesSing)
 
 mkUType :: SingI x => Notes x -> Un.Ty
 mkUType notes = case (notesSing notes, notes) of
@@ -49,28 +49,50 @@
   (STUnit, NTUnit tn)             -> Un.Ty Un.TUnit tn
   (STSignature, NTSignature tn)   -> Un.Ty Un.TSignature tn
   (STChainId, NTChainId tn)       -> Un.Ty Un.TChainId tn
-  (STOption _, NTOption tn n)     -> Un.Ty (Un.TOption (mkUType n)) tn
-  (STList _, NTList tn n)         -> Un.Ty (Un.TList (mkUType n)) tn
-  (STSet _, NTSet tn n)           -> Un.Ty (Un.TSet (mkUType n)) tn
+  (STOption t, NTOption tn n)     -> Un.Ty (Un.TOption $ withSingI t $ mkUType n) tn
+  (STList t, NTList tn n)         -> Un.Ty (Un.TList $ withSingI t $ mkUType n) tn
+  (STSet t, NTSet tn n)           -> Un.Ty (Un.TSet $ withSingI t $ mkUType n) tn
   (STOperation, NTOperation tn)   -> Un.Ty Un.TOperation tn
   (STNever, NTNever tn)           -> Un.Ty Un.TNever tn
-  (STContract _, NTContract tn n) ->
-    Un.Ty (Un.TContract (mkUType n)) tn
-  (STPair _ _, NTPair tn fl fr vl vr nl nr) ->
-    Un.Ty (Un.TPair fl fr vl vr (mkUType nl) (mkUType nr)) tn
-  (STOr _ _, NTOr tn fl fr nl nr) ->
-    Un.Ty (Un.TOr fl fr (mkUType nl) (mkUType nr)) tn
-  (STLambda _ _, NTLambda tn np nq) ->
-    Un.Ty (Un.TLambda (mkUType np) (mkUType nq)) tn
-  (STMap _ _, NTMap tn nk nv) ->
-    Un.Ty (Un.TMap (mkUType nk) (mkUType nv)) tn
-  (STBigMap _ _, NTBigMap tn nk nv) ->
-    Un.Ty (Un.TBigMap (mkUType nk) (mkUType nv)) tn
+  (STContract t, NTContract tn n) ->
+    Un.Ty (Un.TContract $ withSingI t (mkUType n)) tn
+  (STTicket t, NTTicket tn n) ->
+      Un.Ty (Un.TTicket $ withSingI t (mkUType n)) tn
+  (STPair t t', NTPair tn fl fr vl vr nl nr) ->
+    Un.Ty
+    (Un.TPair fl fr vl vr
+    (withSingI t $ mkUType nl)
+    (withSingI t' $ mkUType nr))
+    tn
+  (STOr t t', NTOr tn fl fr nl nr) ->
+    Un.Ty
+    (Un.TOr fl fr
+    (withSingI t $ mkUType nl)
+    (withSingI t' $ mkUType nr))
+    tn
+  (STLambda t t', NTLambda tn np nq) ->
+    Un.Ty
+    (Un.TLambda
+    (withSingI t $ mkUType np)
+    (withSingI t' $ mkUType nq))
+    tn
+  (STMap t t', NTMap tn nk nv) ->
+    Un.Ty
+    (Un.TMap
+    (withSingI t $ mkUType nk)
+    (withSingI t' $ mkUType nv))
+    tn
+  (STBigMap t t', NTBigMap tn nk nv) ->
+    Un.Ty
+    (Un.TBigMap
+    (withSingI t $ mkUType nk)
+    (withSingI t' $ mkUType nv))
+    tn
 
 -- | Convert 'Un.Ty' to the isomorphic set of information from typed world.
 withUType
   :: Un.Ty
-  -> (forall t. KnownT t => Notes t -> r)
+  -> (forall t. SingI t => Notes t -> r)
   -> r
 withUType (Un.Ty ut tn) cont = case ut of
 
@@ -144,6 +166,10 @@
     \(notesContractT :: Notes contractT) ->
       cont (NTContract tn notesContractT)
 
+  Un.TTicket ticketT -> withUType ticketT $
+    \(notesTicketT :: Notes ticketT) ->
+      cont (NTTicket tn notesTicketT)
+
   Un.TPair la ra lv rv lt rt ->
     withUType lt $ \ln ->
       withUType rt $ \rn ->
@@ -170,7 +196,7 @@
         cont @('TBigMap _ _) (NTBigMap tn keyN valN)
 
 -- Helper datatype for 'AsUType'.
-data SomeTypedInfo = forall t. KnownT t => SomeTypedInfo (Notes t)
+data SomeTypedInfo = forall t. SingI t => SomeTypedInfo (Notes t)
 
 -- | Transparently represent untyped 'Ty' as wrapper over @Notes t@
 -- from typed world with @SingI t@ constraint.
@@ -181,13 +207,13 @@
 -- Note about constraints: pattern signatures usually require two constraints -
 -- one they require and another one which they provide. In our case we require
 -- nothing (thus first constraint is @()@) and provide some knowledge about @t@.
-pattern AsUType :: () => (KnownT t) => Notes t -> Un.Ty
+pattern AsUType :: () => (SingI t) => Notes t -> Un.Ty
 pattern AsUType notes <- ((\ut -> withUType ut SomeTypedInfo) -> SomeTypedInfo notes)
   where AsUType notes = mkUType notes
 {-# COMPLETE AsUType #-}
 
 -- | Similar to 'AsUType', but also gives 'Sing' for given type.
-pattern AsUTypeExt :: () => (KnownT t) => Sing t -> Notes t -> Un.Ty
+pattern AsUTypeExt :: () => (SingI t) => Sing t -> Notes t -> Un.Ty
 pattern AsUTypeExt sng notes <- AsUType notes@(notesSing -> sng)
   where AsUTypeExt _ notes = AsUType notes
 {-# COMPLETE AsUTypeExt #-}
diff --git a/src/Michelson/Typed/Haskell/Doc.hs b/src/Michelson/Typed/Haskell/Doc.hs
--- a/src/Michelson/Typed/Haskell/Doc.hs
+++ b/src/Michelson/Typed/Haskell/Doc.hs
@@ -29,13 +29,13 @@
   , poly2TypeDocMdReference
   , homomorphicTypeDocHaskellRep
   , concreteTypeDocHaskellRep
-  , concreteTypeDocHaskellRepUnsafe
+  , unsafeConcreteTypeDocHaskellRep
   , haskellAddNewtypeField
   , haskellRepNoFields
   , haskellRepStripFieldPrefix
   , homomorphicTypeDocMichelsonRep
   , concreteTypeDocMichelsonRep
-  , concreteTypeDocMichelsonRepUnsafe
+  , unsafeConcreteTypeDocMichelsonRep
 
   , DType (..)
   , DStorageType (..)
@@ -253,7 +253,7 @@
   -- For polymorhpic types consider using 'concreteTypeDocMichelsonRep' as implementation.
   typeDocMichelsonRep :: TypeDocMichelsonRep a
   default typeDocMichelsonRep
-    :: (SingI (ToT a), IsHomomorphic a)
+    :: (KnownIsoT a, IsHomomorphic a)
     => TypeDocMichelsonRep a
   typeDocMichelsonRep = homomorphicTypeDocMichelsonRep
 
@@ -512,17 +512,17 @@
      , HaveCommonTypeCtor b a
      )
   => TypeDocHaskellRep b
-concreteTypeDocHaskellRep = concreteTypeDocHaskellRepUnsafe @a
+concreteTypeDocHaskellRep = unsafeConcreteTypeDocHaskellRep @a
 
 -- | Version of 'concreteTypeDocHaskellRep' which does not ensure
 -- whether the type for which representation is built is any similar to
 -- the original type which you implement a 'TypeHasDoc' instance for.
-concreteTypeDocHaskellRepUnsafe
+unsafeConcreteTypeDocHaskellRep
   :: forall a b.
      ( Typeable a, GenericIsoValue a, GTypeHasDoc (G.Rep a)
      )
   => TypeDocHaskellRep b
-concreteTypeDocHaskellRepUnsafe _ descr = Just
+unsafeConcreteTypeDocHaskellRep _ descr = Just
   ( Just (DocTypeRepLHS . toText . showtype $ Proxy @a)
   , gTypeDocHaskellRep @(G.Rep a) descr
   )
@@ -567,7 +567,7 @@
 -- | Implement 'typeDocMichelsonRep' for homomorphic type.
 homomorphicTypeDocMichelsonRep
   :: forall a.
-     SingI (ToT a)
+     KnownIsoT a
   => TypeDocMichelsonRep a
 homomorphicTypeDocMichelsonRep _ =
   ( Nothing
@@ -579,21 +579,21 @@
 -- This function exists for the same reason as 'concreteTypeDocHaskellRep'.
 concreteTypeDocMichelsonRep
   :: forall a b.
-     (Typeable a, SingI (ToT a), HaveCommonTypeCtor b a)
+     (Typeable a, KnownIsoT a, HaveCommonTypeCtor b a)
   => TypeDocMichelsonRep b
 concreteTypeDocMichelsonRep _ =
   ( Just (DocTypeRepLHS . toText . showtype $ Proxy @a)
   , demote @(ToT a)
   )
 
--- | Version of 'concreteTypeDocHaskellRepUnsafe' which does not ensure
+-- | Version of 'unsafeConcreteTypeDocHaskellRep' which does not ensure
 -- whether the type for which representation is built is any similar to
 -- the original type which you implement a 'TypeHasDoc' instance for.
-concreteTypeDocMichelsonRepUnsafe
+unsafeConcreteTypeDocMichelsonRep
   :: forall a b.
-     (Typeable a, SingI (ToT a))
+     (Typeable a, KnownIsoT a)
   => TypeDocMichelsonRep b
-concreteTypeDocMichelsonRepUnsafe _ =
+unsafeConcreteTypeDocMichelsonRep _ =
   ( Just (DocTypeRepLHS . toText . showtype $ Proxy @a)
   , demote @(ToT a)
   )
@@ -812,10 +812,18 @@
   typeDocName _ = "Contract"
   typeDocMdReference = poly1TypeDocMdReference
   typeDocMdDescription = "Contract primitive with given type of parameter."
-  typeDocDependencies _ = [dTypeDep @cp]
+  typeDocDependencies _ = [dTypeDep @cp, dTypeDep @Integer]
   typeDocHaskellRep _ _ = Nothing
   typeDocMichelsonRep = concreteTypeDocMichelsonRep @(ContractRef Integer)
 
+instance PolyTypeHasDocC '[a] => TypeHasDoc (Ticket a) where
+  typeDocName _ = "Ticket"
+  typeDocMdReference = poly1TypeDocMdReference
+  typeDocMdDescription = "Ticket primitive."
+  typeDocDependencies _ = [dTypeDep @a, dTypeDep @MText]
+  typeDocHaskellRep _ _ = Nothing
+  typeDocMichelsonRep = concreteTypeDocMichelsonRep @(Ticket MText)
+
 instance (PolyCTypeHasDocC '[k], PolyTypeHasDocC '[v], Ord k) =>
          TypeHasDoc (Map k v) where
   typeDocName _ = "Map"
@@ -914,7 +922,7 @@
 
 instance ( TypeHasDoc (ApplyNamedFunctor f a)
          , KnownSymbol n
-         , SingI (ToT (ApplyNamedFunctor f Integer))
+         , KnownIsoT (ApplyNamedFunctor f Integer)
          , Typeable f, Typeable a
          ) =>
          TypeHasDoc (NamedF f a n) where
diff --git a/src/Michelson/Typed/Haskell/Instr/Product.hs b/src/Michelson/Typed/Haskell/Instr/Product.hs
--- a/src/Michelson/Typed/Haskell/Instr/Product.hs
+++ b/src/Michelson/Typed/Haskell/Instr/Product.hs
@@ -10,7 +10,7 @@
   ( InstrGetFieldC
   , InstrSetFieldC
   , InstrConstructC
-  , instrGetField
+  , instrToField
   , instrSetField
   , instrConstruct
   , instrConstructStack
@@ -110,12 +110,12 @@
 ----------------------------------------------------------------------------
 
 -- | Make an instruction which accesses given field of the given datatype.
-instrGetField
+instrToField
   :: forall dt name st.
      InstrGetFieldC dt name
   => Label name -> Instr (ToT dt ': st) (ToT (GetFieldType dt name) ': st)
-instrGetField _ =
-  gInstrGetField @name @(G.Rep dt) @(LnrBranch (GetNamed name dt))
+instrToField _ =
+  gInstrToField @name @(G.Rep dt) @(LnrBranch (GetNamed name dt))
     @(GetFieldType dt name)
 
 -- | Constraint for 'instrGetField'.
@@ -126,7 +126,7 @@
       (LnrFieldType (GetNamed name dt))
   )
 
-{- Note about bulkiness of `instrGetField` type signature:
+{- Note about bulkiness of `instrToField` type signature:
 
 Read this only if you are going to modify the signature qualitatively.
 
@@ -145,22 +145,22 @@
     (x :: Type -> Type)
     (path :: Path)
     (fieldTy :: Type) where
-  gInstrGetField
+  gInstrToField
     :: GIsoValue x
     => Instr (GValueType x ': s) (ToT fieldTy ': s)
 
 instance GInstrGet name x path f => GInstrGet name (G.M1 t i x) path f where
-  gInstrGetField = gInstrGetField @name @x @path @f
+  gInstrToField = gInstrToField @name @x @path @f
 
 instance (IsoValue f, ToT f ~ ToT f') =>
          GInstrGet name (G.Rec0 f) '[] f' where
-  gInstrGetField = Nop
+  gInstrToField = Nop
 
 instance (GInstrGet name x path f, GIsoValue y) => GInstrGet name (x :*: y) ('L ': path) f where
-  gInstrGetField = CAR `Seq` gInstrGetField @name @x @path @f
+  gInstrToField = CAR `Seq` gInstrToField @name @x @path @f
 
 instance (GInstrGet name y path f, GIsoValue x) => GInstrGet name (x :*: y) ('R ': path) f where
-  gInstrGetField = CDR `Seq` gInstrGetField @name @y @path @f
+  gInstrToField = CDR `Seq` gInstrToField @name @y @path @f
 
 -- Examples
 ----------------------------------------------------------------------------
@@ -168,10 +168,10 @@
 type MyType1 = ("int" :! Integer, "bytes" :! ByteString, "bytes2" :? ByteString)
 
 _getIntInstr1 :: Instr (ToT MyType1 ': s) (ToT Integer ': s)
-_getIntInstr1 = instrGetField @MyType1 #int
+_getIntInstr1 = instrToField @MyType1 #int
 
 _getTextInstr1 :: Instr (ToT MyType1 ': s) (ToT (Maybe ByteString) ': s)
-_getTextInstr1 = instrGetField @MyType1 #bytes2
+_getTextInstr1 = instrToField @MyType1 #bytes2
 
 data MyType2 = MyType2
   { getInt :: Integer
@@ -182,11 +182,11 @@
     deriving anyclass (IsoValue)
 
 _getIntInstr2 :: Instr (ToT MyType2 ': s) (ToT () ': s)
-_getIntInstr2 = instrGetField @MyType2 #getUnit
+_getIntInstr2 = instrToField @MyType2 #getUnit
 
 _getIntInstr2' :: Instr (ToT MyType2 ': s) (ToT Integer ': s)
 _getIntInstr2' =
-  instrGetField @MyType2 #getMyType1 `Seq` instrGetField @MyType1 #int
+  instrToField @MyType2 #getMyType1 `Seq` instrToField @MyType1 #int
 
 ----------------------------------------------------------------------------
 -- Value modification instruction
@@ -228,13 +228,13 @@
 
 instance (GInstrSetField name x path f, GIsoValue y) => GInstrSetField name (x :*: y) ('L ': path) f where
   gInstrSetField =
-    DIP (DUP `Seq` DIP CDR `Seq` CAR) `Seq`
+    DIP UNPAIR `Seq`
     gInstrSetField @name @x @path @f `Seq`
     PAIR
 
 instance (GInstrSetField name y path f, GIsoValue x) => GInstrSetField name (x :*: y) ('R ': path) f where
   gInstrSetField =
-    DIP (DUP `Seq` DIP CAR `Seq` CDR) `Seq`
+    DIP (UNPAIR `Seq` SWAP) `Seq`
     gInstrSetField @name @y @path @f `Seq`
     SWAP `Seq` PAIR
 
diff --git a/src/Michelson/Typed/Haskell/Instr/Sum.hs b/src/Michelson/Typed/Haskell/Instr/Sum.hs
--- a/src/Michelson/Typed/Haskell/Instr/Sum.hs
+++ b/src/Michelson/Typed/Haskell/Instr/Sum.hs
@@ -15,7 +15,7 @@
   , hsWrap
   , instrCase
   , (//->)
-  , instrUnwrapUnsafe
+  , unsafeInstrUnwrap
   , hsUnwrap
 
   , CaseClauseParam (..)
@@ -617,14 +617,14 @@
 -- Rules which apply to 'instrWrap' function work here as well.
 -- Although, unlike @instrWrap@, this function does not work for nullary
 -- constructors.
-instrUnwrapUnsafe
+unsafeInstrUnwrap
   :: forall dt name st.
      InstrUnwrapC dt name
   => Label name
   -> Instr (ToT dt ': st)
            (ToT (CtorOnlyField name dt) ': st)
-instrUnwrapUnsafe _ =
-  gInstrUnwrapUnsafe @(G.Rep dt) @(LnrBranch (GetNamed name dt))
+unsafeInstrUnwrap _ =
+  unsafeGInstrUnwrap @(G.Rep dt) @(LnrBranch (GetNamed name dt))
                                  @(CtorOnlyField name dt)
 
 type InstrUnwrapC dt name =
@@ -651,33 +651,33 @@
     (x :: Type -> Type)
     (path :: Path)
     (entryTy :: Type) where
-  gInstrUnwrapUnsafe
+  unsafeGInstrUnwrap
     :: GIsoValue x
     => Instr (GValueType x ': s) (ToT entryTy ': s)
   gHsUnwrap
     :: x p -> Maybe entryTy
 
 instance GInstrUnwrap x path e => GInstrUnwrap (G.D1 i x) path e where
-  gInstrUnwrapUnsafe = gInstrUnwrapUnsafe @x @path @e
+  unsafeGInstrUnwrap = unsafeGInstrUnwrap @x @path @e
   gHsUnwrap = gHsUnwrap @x @path @e . G.unM1
 
 instance (GInstrUnwrap x path e, GIsoValue y, SingI (GValueType y)) =>
          GInstrUnwrap (x :+: y) ('L ': path) e where
-  gInstrUnwrapUnsafe = IF_LEFT (gInstrUnwrapUnsafe @x @path @e) failWithWrongCtor
+  unsafeGInstrUnwrap = IF_LEFT (unsafeGInstrUnwrap @x @path @e) failWithWrongCtor
   gHsUnwrap = \case
     G.L1 x -> gHsUnwrap @x @path @e x
     G.R1 _ -> Nothing
 
 instance (GInstrUnwrap y path e, GIsoValue x, SingI (GValueType x)) =>
          GInstrUnwrap (x :+: y) ('R ': path) e where
-  gInstrUnwrapUnsafe = IF_LEFT failWithWrongCtor (gInstrUnwrapUnsafe @y @path @e)
+  unsafeGInstrUnwrap = IF_LEFT failWithWrongCtor (unsafeGInstrUnwrap @y @path @e)
   gHsUnwrap = \case
     G.R1 y -> gHsUnwrap @y @path @e y
     G.L1 _ -> Nothing
 
 instance (IsoValue e) =>
          GInstrUnwrap (G.C1 c (G.S1 i (G.Rec0 e))) '[ 'S] e where
-  gInstrUnwrapUnsafe = Nop
+  unsafeGInstrUnwrap = Nop
   gHsUnwrap = Just . G.unK1 . G.unM1 . G.unM1
 
 -- This is the case when a sum type is part of another sum type.
@@ -688,7 +688,7 @@
          , GIsoValue (G.Rep sub)
          ) =>
          GInstrUnwrap (G.C1 c (G.S1 i (G.Rec0 sub))) ('S ': x ': xs) e where
-  gInstrUnwrapUnsafe = gInstrUnwrapUnsafe @(G.Rep sub) @path @e
+  unsafeGInstrUnwrap = unsafeGInstrUnwrap @(G.Rep sub) @path @e
   gHsUnwrap = gHsUnwrap @(G.Rep sub) @path @e . G.from . G.unK1 . G.unM1 . G.unM1
 
 -- | Failure indicating that we expected value created with one constructor,
@@ -704,16 +704,16 @@
 ----------------------------------------------------------------------------
 
 _unwrapMyType :: Instr (ToT MyType ': s) (ToT Integer ': s)
-_unwrapMyType = instrUnwrapUnsafe @MyType #cMyCtor
+_unwrapMyType = unsafeInstrUnwrap @MyType #cMyCtor
 
 _unwrapMyCompoundType :: Instr (ToT MyCompoundType ': s) (ToT Integer ': s)
-_unwrapMyCompoundType = instrUnwrapUnsafe @MyCompoundType #cMyCtor
+_unwrapMyCompoundType = unsafeInstrUnwrap @MyCompoundType #cMyCtor
 
 _unwrapMyCompoundType2 :: Instr (ToT MyCompoundType ': s) (ToT Address ': s)
-_unwrapMyCompoundType2 = instrUnwrapUnsafe @MyCompoundType #cCompoundPart3
+_unwrapMyCompoundType2 = unsafeInstrUnwrap @MyCompoundType #cCompoundPart3
 
 _unwrapMyCompoundType3 :: Instr (ToT MyCompoundType ': s) (ToT Bool ': s)
-_unwrapMyCompoundType3 = instrUnwrapUnsafe @MyCompoundType #cWrapBool
+_unwrapMyCompoundType3 = unsafeInstrUnwrap @MyCompoundType #cWrapBool
 
 _unwrapMyCompoundType4 :: Instr (ToT MyCompoundType ': s) (ToT MyType' ': s)
-_unwrapMyCompoundType4 = instrUnwrapUnsafe @MyCompoundType #cCompoundPart4
+_unwrapMyCompoundType4 = unsafeInstrUnwrap @MyCompoundType #cCompoundPart4
diff --git a/src/Michelson/Typed/Haskell/LooseSum.hs b/src/Michelson/Typed/Haskell/LooseSum.hs
--- a/src/Michelson/Typed/Haskell/LooseSum.hs
+++ b/src/Michelson/Typed/Haskell/LooseSum.hs
@@ -19,14 +19,15 @@
   , LooseSumC
   ) where
 
-import Data.Typeable (TypeRep, cast, typeRep)
+import Data.Singletons
 import GHC.Generics ((:*:), (:+:))
 import qualified GHC.Generics as G
 
 import Michelson.Typed.Aliases
+import Michelson.Typed.Existential
 import Michelson.Typed.Haskell.Value
 import Michelson.Typed.T
-import Michelson.Typed.Value
+import Util.Sing (castSing)
 import Util.TypeLits
 
 -- | Possible outcomes of an attempt to construct a Haskell ADT value
@@ -36,7 +37,7 @@
     -- ^ Composed fine.
   | ComposeCtorNotFound
     -- ^ No constructor with such name.
-  | ComposeFieldTypeMismatch TypeRep TypeRep
+  | ComposeFieldTypeMismatch T T
     -- ^ Found required constructor, but type of data does not correspond
     -- to provided one.
   deriving stock (Functor)
@@ -104,7 +105,7 @@
   gExtractField = gExtractField . G.unM1
   gMakeField v = G.M1 <$> gMakeField @x v
 
-instance (Typeable a, IsoValue a) =>
+instance IsoValue a =>
          GAccessField (G.Rec0 a) where
   gExtractField = SomeValue . toVal . G.unK1
   gMakeField (SomeValue v) = G.K1 . fromVal <$> composeCast v
@@ -113,10 +114,10 @@
   gExtractField G.U1 = SomeValue $ toVal ()
   gMakeField (SomeValue v) = G.U1 <$ composeCast @_ @'TUnit v
 
-composeCast :: forall a b. (Typeable a, Typeable b) => Value a -> ComposeResult (Value b)
+composeCast :: forall a b. (SingI a, SingI b) => Value a -> ComposeResult (Value b)
 composeCast a =
-  case cast a of
-    Nothing -> ComposeFieldTypeMismatch (typeRep (Proxy @a)) (typeRep (Proxy @b))
+  case castSing a of
+    Nothing -> ComposeFieldTypeMismatch (demote @a) (demote @b)
     Just b -> ComposeOk b
 
 instance
diff --git a/src/Michelson/Typed/Haskell/Value.hs b/src/Michelson/Typed/Haskell/Value.hs
--- a/src/Michelson/Typed/Haskell/Value.hs
+++ b/src/Michelson/Typed/Haskell/Value.hs
@@ -9,15 +9,13 @@
   ( -- * Value conversions
     IsoValue (..)
   , KnownIsoT
-  , KnownT
   , GIsoValue (GValueType)
   , ToT'
-  , SomeIsoValue (..)
-  , AnyIsoValue (..)
   , GenericIsoValue
   , WellTyped
   , WellTypedIsoValue
   , WellTypedToT
+  , HasNoOpToT
 
   , Dict(..) -- * Re-exporting to use in tests.
 
@@ -27,7 +25,10 @@
   , ContractRef (..)
   , coerceContractRef
   , contractRefToAddr
-  , BigMap (..)
+  , Ticket (..)
+  , BigMapId(..)
+  , BigMap(..)
+  , mkBigMap
 
     -- * Stack conversion
   , ToTs
@@ -37,13 +38,15 @@
   , totsAppendLemma
   ) where
 
-import Data.Constraint (Dict(..), (:-)(..))
+import Data.Constraint (Dict(..))
+import Data.Data (Data)
 import Data.Default (Default(..))
+import Data.Foldable (Foldable(foldr))
 import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
 import Data.Vinyl.Core (Rec(..))
 import Fmt (Buildable(..), mapF)
-import GHC.Exts (IsList)
+import GHC.Exts as Exts (IsList(..))
 import GHC.Generics ((:*:)(..), (:+:)(..))
 import qualified GHC.Generics as G
 import Named (NamedF(..))
@@ -51,7 +54,7 @@
 import Michelson.Text
 import Michelson.Typed.Aliases
 import Michelson.Typed.Entrypoints
-import Michelson.Typed.Sing
+import Michelson.Typed.Scope
 import Michelson.Typed.T
 import Michelson.Typed.Value
 import Tezos.Address (Address)
@@ -63,7 +66,7 @@
 -- Complex values isomorphism
 ----------------------------------------------------------------------------
 
-type KnownIsoT a = KnownT (ToT a)
+type KnownIsoT a = SingI (ToT a)
 
 -- | Isomorphism between Michelson values and plain Haskell types.
 --
@@ -93,13 +96,6 @@
   ToT' (t :: T) = t
   ToT' (t :: Type) = ToT t
 
--- | Hides some Haskell value put in line with Michelson 'Value'.
-data SomeIsoValue where
-  SomeIsoValue :: (KnownIsoT a) => a -> SomeIsoValue
-
--- | Any Haskell value which can be converted to Michelson 'Value'.
-newtype AnyIsoValue = AnyIsoValue (forall a. IsoValue a => a)
-
 -- Instances
 ----------------------------------------------------------------------------
 
@@ -252,6 +248,9 @@
 type WellTypedToT a = WellTyped (ToT a)
 type WellTypedIsoValue a = (WellTyped (ToT a), IsoValue a)
 
+type HasNoOpToT a = HasNoOp (ToT a)
+type HasNoBigMapToT a = HasNoBigMap (ToT a)
+
 -- | Since @Contract@ name is used to designate contract code, lets call
 -- analogy of 'TContract' type as follows.
 --
@@ -264,10 +263,10 @@
   , crEntrypoint :: SomeEntrypointCall arg
   } deriving stock (Eq, Show)
 
-instance (WellTypedToT arg) => Buildable (ContractRef arg) where
+instance (IsoValue (ContractRef arg)) => Buildable (ContractRef arg) where
   build = buildVContract . toVal
 
-instance (WellTypedToT arg) => IsoValue (ContractRef arg) where
+instance (HasNoOpToT arg, WellTypedToT arg) => IsoValue (ContractRef arg) where
   type ToT (ContractRef arg) = 'TContract (ToT arg)
   toVal ContractRef{..} = VContract crAddress crEntrypoint
   fromVal (VContract addr epc) = ContractRef addr epc
@@ -279,20 +278,71 @@
 contractRefToAddr :: ContractRef cp -> EpAddress
 contractRefToAddr ContractRef{..} = EpAddress crAddress (sepcName crEntrypoint)
 
-newtype BigMap k v = BigMap { unBigMap :: Map k v }
-  deriving stock (Eq, Show)
-  deriving newtype (Default, Semigroup, Monoid, One, Container, IsList)
+-- | Ticket type.
+data Ticket (arg :: Type) = Ticket
+  { tTicketer :: Address
+  , tData :: arg
+  , tAmount :: Natural
+  } deriving stock (Eq, Show)
 
+instance (Comparable (ToT a), IsoValue a) => IsoValue (Ticket a) where
+  type ToT (Ticket a) = 'TTicket (ToT a)
+  toVal Ticket{..} = VTicket tTicketer (toVal tData) tAmount
+  fromVal (VTicket tTicketer dat tAmount) = Ticket{ tData = fromVal dat, .. }
+
+-- | Phantom type that represents the ID of a big_map with
+-- keys of type @k@ and values of type @v@.
+newtype BigMapId k v = BigMapId { unBigMapId :: Natural }
+  -- Note: we purposefully do not derive an `Eq` instance.
+  -- If we did, it would be possible for a @cleveland@ user to mistakenly
+  -- compare two big_map IDs, whilst being under the impression that they were
+  -- actually comparing the big_map's contents.
+  -- To avoid this confusion, we simply do not create an `Eq` instance.
+  -- For context, see: https://gitlab.com/morley-framework/morley/-/merge_requests/833#note_598577341
+  deriving stock (Show, Data)
+  deriving newtype (IsoValue, Buildable, Num)
+
+data BigMap k v = BigMap
+  { bmId :: Maybe (BigMapId k v)
+  , bmMap :: Map k v
+  }
+  deriving stock (Show, Generic, Data)
+  deriving anyclass (Default, Container)
+
+mkBigMap :: Ord k => [(k, v)] -> BigMap k v
+mkBigMap = Exts.fromList
+
+instance Ord k => Semigroup (BigMap k v) where
+  BigMap _ m1 <> BigMap _ m2 = BigMap Nothing (m1 <> m2)
+
+instance Foldable (BigMap k) where
+  foldr f z (BigMap _ bmMap) = Map.foldr f z bmMap
+
+instance One (BigMap k v) where
+  type OneItem (BigMap k v) = OneItem (Map k v)
+  one x = BigMap Nothing (one x)
+
+instance Ord k => IsList (BigMap k v) where
+  type Item (BigMap k v) = Item (Map k v)
+  fromList xs = BigMap Nothing (Exts.fromList xs)
+  toList (BigMap _ xs) = Exts.toList xs
+
 instance (Ord k, Buildable k, Buildable v) => Buildable (BigMap k v) where
   build = mapF
 
 instance
-  ( WellTypedToT k, WellTypedToT v, Comparable (ToT k)
-  , Ord k, IsoValue k, IsoValue v
+  ( Comparable (ToT k) , Ord k, IsoValue k
+  , IsoValue v, HasNoBigMapToT v, HasNoOpToT v
   ) => IsoValue (BigMap k v) where
   type ToT (BigMap k v) = 'TBigMap (ToT k) (ToT v)
-  toVal = VBigMap . Map.mapKeys toVal . Map.map toVal . unBigMap
-  fromVal (VBigMap x) = BigMap $ Map.map fromVal $ Map.mapKeys fromVal x
+  toVal (BigMap bmId bmMap) =
+    VBigMap
+      (unBigMapId <$> bmId)
+      (Map.mapKeys toVal $ Map.map toVal bmMap)
+  fromVal (VBigMap bmId x) =
+    BigMap
+      (BigMapId <$> bmId)
+      (Map.map fromVal $ Map.mapKeys fromVal x)
 
 -- Generic magic
 ----------------------------------------------------------------------------
@@ -308,7 +358,7 @@
 --
 -- In case an unbalanced tree is needed, the Generic instance can be derived by
 -- using the utilities in the 'Util.Generics' module.
-class KnownT (GValueType x) =>
+class SingI (GValueType x) =>
       GIsoValue (x :: Type -> Type) where
   type GValueType x :: T
   gToValue :: x p -> Value (GValueType x)
@@ -401,7 +451,7 @@
 -- illegal as per Michelson typing rule. Using this class, we inductively
 -- enforce that a type and all types it contains are well typed as per
 -- Michelson's rules.
-class (KnownT t, WellTypedSuperC t) => WellTyped (t :: T) where
+class (SingI t, WellTypedSuperC t) => WellTyped (t :: T) where
   -- | Constraints required for instance of a given type.
   type WellTypedSuperC t :: Constraint
   type WellTypedSuperC _ = ()
@@ -418,8 +468,10 @@
 instance (Comparable t, WellTyped t) => WellTyped ('TSet t) where
   type WellTypedSuperC ('TSet t) = (Comparable t, WellTyped t)
 instance WellTyped 'TOperation where
-instance WellTyped t => WellTyped ('TContract t) where
-  type WellTypedSuperC ('TContract t) = WellTyped t
+instance (WellTyped t, HasNoOp t) => WellTyped ('TContract t) where
+  type WellTypedSuperC ('TContract t) = (WellTyped t, HasNoOp t)
+instance (WellTyped t, Comparable t) => WellTyped ('TTicket t) where
+  type WellTypedSuperC ('TTicket t) = (WellTyped t, Comparable t)
 instance (WellTyped t1, WellTyped t2) => WellTyped ('TPair t1 t2) where
   type WellTypedSuperC ('TPair t1 t2) = (WellTyped t1, WellTyped t2)
 instance (WellTyped t1, WellTyped t2) => WellTyped ('TOr t1 t2) where
@@ -428,8 +480,10 @@
   type WellTypedSuperC ('TLambda t1 t2) = (WellTyped t1, WellTyped t2)
 instance (Comparable k, WellTyped k, WellTyped v) => WellTyped ('TMap k v) where
   type WellTypedSuperC ('TMap k v) = (Comparable k, WellTyped k, WellTyped v)
-instance (Comparable k, WellTyped k, WellTyped v) => WellTyped ('TBigMap k v) where
-  type WellTypedSuperC ('TBigMap k v) = (Comparable k, WellTyped k, WellTyped v)
+instance (Comparable k, WellTyped k, WellTyped v, HasNoBigMap v, HasNoOp v)
+         => WellTyped ('TBigMap k v) where
+  type WellTypedSuperC ('TBigMap k v) = ( Comparable k, WellTyped k, WellTyped v
+                                        , HasNoBigMap v, HasNoOp v)
 instance WellTyped 'TInt
 instance WellTyped 'TNat
 instance WellTyped 'TString
diff --git a/src/Michelson/Typed/Instr.hs b/src/Michelson/Typed/Instr.hs
--- a/src/Michelson/Typed/Instr.hs
+++ b/src/Michelson/Typed/Instr.hs
@@ -7,6 +7,8 @@
 -- | Module, containing data types for Michelson value.
 module Michelson.Typed.Instr
   ( Instr (..)
+  , castInstr
+  , pattern (:#)
   , ExtInstr (..)
   , CommentType (..)
   , StackRef (..)
@@ -45,6 +47,7 @@
 
 import Data.Default
 import Data.Singletons (Sing)
+import Data.Type.Equality ((:~:)(..))
 import Data.Vinyl (RMap, Rec(..), RecordToList, ReifyConstraint(..))
 import Fmt ((+||), (||+))
 import GHC.TypeNats (type (+))
@@ -58,19 +61,125 @@
 import Michelson.Typed.Entrypoints
 import Michelson.Typed.Polymorphic
 import Michelson.Typed.Scope
-import Michelson.Typed.Sing (KnownT)
 import Michelson.Typed.T (T(..))
 import Michelson.Typed.TypeLevel
   (CombedPairLeafCount, CombedPairLeafCountIsAtLeast, CombedPairNodeCount,
   CombedPairNodeIndexIsValid, IsPair)
 import Michelson.Typed.Value (Comparable, ContractInp, ContractOut, Value'(..))
 import Michelson.Untyped
-  (Annotation(..), EntriesOrder(..), FieldAnn, TypeAnn, VarAnn, VarAnns, entriesOrderToInt)
+  (Annotation(..), EntriesOrder(..), FieldAnn, StackFn, StackTypePattern, TypeAnn, VarAnn, VarAnns,
+  entriesOrderToInt)
 import Util.Peano
+import Util.PeanoNatural
+import Util.Sing (eqI)
 import Util.TH
 import Util.Type (If, KnownList, type (++))
 import Util.TypeLits (ErrorMessage(ShowType, Text, (:$$:), (:<>:)), TypeErrorUnless)
 
+{-
+Note [Annotations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+When typechecking a sequence of instructions:
+
+1. We'll typecheck an "untyped instruction" like `EMPTY_SET :ta @va unit`, producing:
+    * a "typed instruction" `EMPTY_SET :: Instr s (TSet TUnit : s)`, and
+    * an output stack with a `@va set :ta int` at the top.
+2. In `Michelson.TypeCheck.Helpers.wrapWithNotes`:
+    * if the original instruction had a var annotation (e.g. `SOME_INSTR @some_ann`),
+      then we wrap the "typed instruction" in `InstrWithVarNotes`.
+    * if the element at the top of the output stack has a var annotation,
+      we wrap it in `InstrWithVarAnns`.
+    * if the element at the top of the output stack has field/type anns,
+      we wrap it in `InstrWithNotes`
+        ```
+        InstrWithNotes Proxy (NTSet "ta" (NTUnit "")) $
+          InstrWithVarNotes (one "va") $
+            InstrWithVarAnns (OneVarAnn "va") $
+              EMPTY_SET
+        ```
+
+These "meta-instruction" wrappers are later used in the interpreter/serializer.
+
+The interpreter ('Michelson.Interpret'):
+  * Looks at the typed instruction (e.g. `EMPTY_SET`), and simply adds/removes/moves elements
+    in the stack, without caring about annotations.
+  * Looks at the `InstrWithNotes` and `InstrWithVarAnns` meta-instructions, and blindly
+    applies a series of annotations to the output stack, without caring about the underlying
+    instruction.
+
+The serializer ('Michelson.Interpret.Pack'):
+  * Looks at the `InstrWithNotes` and `InstrWithVarNotes` meta-instructions, and infers
+    that the original `EMPTY_SET` instruction must have had two explicit `:ta` and `@va` annotations.
+
+Notice that the interpreter does not care about the `InstrWithVarNotes` meta-instruction, and
+the serializer does not care about the `InstrWithVarAnns` meta-instruction.
+
+
+
+Note [Annotations - Exceptional scenarios]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+For the most part, this works without a hitch.
+However, `wrapWithNotes` makes the assumption that we can infer an instruction's
+original annotations by simply looking at the output stack, e.g.:
+
+> If after running an `EMPTY_SET` instruction we end up with a `@va set :ta int`
+> at the top of output stack, then we can infer that the `EMPTY_SET` instruction
+> had two `@va` and `:ta` annotations.
+
+Unfortunately, that assumption doesn't always hold.
+Here are some counter examples:
+
+* Special annotations.
+    These 3 `CAR` instructions will all put a `@p.a nat` at the top of the stack:
+
+    > PUSH @p (pair (nat %a) nat) (Pair 1 2);
+    > CAR @%%;
+
+    > PUSH (pair (nat %p.a) nat) (Pair 1 2);
+    > CAR @%;
+
+    > PUSH (pair (nat %p.a) nat) (Pair 1 2);
+    > CAR @p.a;
+
+    Therefore, it's impossible for `wrapWithNotes` to figure out what
+    CAR's original var annotation was.
+
+    This scenario affects all instructions that can take special annotations:
+    - PAIR, LEFT, RIGHT: accept special field anns
+    - UNPAIR, CAR, CDR: accept special var anns
+
+* Annotations that do not affect the output stack whatsoever.
+    For example, CAR may take a field annotation, but it's only used by the typechecker
+    to verify that the pair in the input stack has a matching field ann.
+
+    The following instructions will generate the exact same output stack,
+    with an un-annotated `nat` at the top.
+
+    > PUSH (pair (nat %a) nat) (Pair 1 2);
+    > CAR %a;
+
+    > PUSH (pair (nat %a) nat) (Pair 1 2);
+    > CAR;
+
+    Therefore, it's impossible for `wrapWithNotes` to figure out whether
+    CAR had a field annotation.
+
+    This scenario affects: UNPAIR, CAR, CDR.
+
+
+In situations like the above, where the instruction's annotations cannot be inferred from
+looking at the output stack, we have to save and store the instruction's annotations inside
+the typed instruction's constructor, instead of using meta-instructions.
+E.g.:
+
+> AnnCAR :: VarAnn -> FieldAnn -> Instr ('TPair a b ': s) (a ': s)
+
+TODO [#580]: address the assumptions mentioned above.
+
+-}
+
 -- This next comment is needed to run the doctest examples throughout this module.
 
 -- $setup
@@ -80,7 +189,7 @@
 -- | Constraint that is used in DUPN, we want to share it with
 -- typechecking code and eDSL code.
 type ConstraintDUPN' kind (n :: Peano) (inp :: [kind]) (out :: [kind]) (a :: kind) =
-  ( SingI n, KnownPeano n, RequireLongerOrSameLength inp n, n > 'Z ~ 'True
+  ( RequireLongerOrSameLength inp n, n > 'Z ~ 'True
   , inp ~ (Take (Decrement n) inp ++ (a ': Drop n inp))
   , out ~ (a ': inp)
   )
@@ -91,7 +200,7 @@
 -- typechecking code and eDSL code.
 type ConstraintDIPN' kind (n :: Peano) (inp :: [kind])
   (out :: [kind]) (s :: [kind]) (s' :: [kind]) =
-  ( SingI n, KnownPeano n, RequireLongerOrSameLength inp n
+  ( RequireLongerOrSameLength inp n
   , ((Take n inp) ++ s) ~ inp
   , ((Take n inp) ++ s') ~ out
   )
@@ -102,7 +211,7 @@
 -- typechecking code and eDSL code.
 type ConstraintDIG' kind (n :: Peano) (inp :: [kind])
   (out :: [kind]) (a :: kind) =
-  ( SingI n, KnownPeano n, RequireLongerThan inp n
+  ( RequireLongerThan inp n
   , inp ~ (Take n inp ++ (a ': Drop ('S n) inp))
   , out ~ (a ': Take n inp ++ Drop ('S n) inp)
   )
@@ -113,7 +222,7 @@
 -- typechecking code and eDSL code.
 type ConstraintDUG' kind (n :: Peano) (inp :: [kind])
   (out :: [kind]) (a :: kind) =
-  ( SingI n, KnownPeano n, RequireLongerThan out n
+  ( RequireLongerThan out n
   , inp ~ (a ': Drop ('S 'Z) inp)
   , out ~ (Take n (Drop ('S 'Z) inp) ++ (a ': Drop ('S n) inp))
   )
@@ -123,8 +232,6 @@
 type ConstraintPairN (n :: Peano) (inp :: [T]) =
   ( RequireLongerOrSameLength inp n
   , TypeErrorUnless (n >= ToPeano 2) ('Text "'PAIR n' expects n ≥ 2")
-  , SingI n
-  , KnownPeano n
   )
 
 type PairN (n :: Peano) (s :: [T]) = (RightComb (Take n s) ': Drop n s)
@@ -156,8 +263,6 @@
           ':<>: 'ShowType pair
         )
       )
-  , SingI n
-  , KnownPeano n
   )
 
 -- | Splits a right-combed pair into @n@ elements.
@@ -188,8 +293,6 @@
           ':<>: 'ShowType pair
         )
       )
-  , SingI ix
-  , KnownPeano ix
   )
 
 -- | Get the node at index @ix@ of a right-combed pair.
@@ -213,8 +316,6 @@
           ':<>: 'ShowType pair
         )
       )
-  , SingI ix
-  , KnownPeano ix
   )
 
 -- | Update the node at index @ix@ of a right-combed pair.
@@ -245,15 +346,14 @@
   -- TODO [#283]: replace this wrapper with something more clever and abstract.
   WithLoc :: InstrCallStack -> Instr a b -> Instr a b
 
-  -- | A wrapper for an instruction that also contains annotations for
-  -- some of top types on the result stack.
-  --
-  -- As of now, when converting from untyped representation,
-  -- we only preserve field annotations and type annotations in 'Notes'.
-  -- Variable annotations are preserved in 'InstrWithVarAnns'.
+  -- | A wrapper for instructions that, when interpreted, will
+  -- place field/type annotations on one or more of the elements at
+  -- the top of the stack.
   --
   -- This can wrap only instructions with at least one non-failing execution
   -- branch.
+  --
+  -- See: Note [Annotations]
   InstrWithNotes
     :: forall a (topElems :: [T]) (s :: [T]).
       ( RMap topElems
@@ -265,18 +365,18 @@
     => Proxy s -> Rec Notes topElems
     -> Instr a (topElems ++ s) -> Instr a (topElems ++ s)
 
-  -- | A wrapper for an instruction which produces variable annotations on the
-  -- top stack element(s). See also: 'InstrWithVarAnns'.
+  -- | A wrapper for instructions that have var annotations, e.g. `SOME_INSTR @ann1`.
+  --
+  -- This information is necessary for serializing the instruction back to json/binary.
+  --
+  -- See: Note [Annotations]
   InstrWithVarNotes :: NonEmpty VarAnn -> Instr a b -> Instr a b
 
-  -- | A wrapper for an instruction that also contains a variable annotation for
-  -- the top type on the result stack.
+  -- | A wrapper for instructions that, when interpreted, will
+  -- place var annotations on one or more of the elements at
+  -- the top of the stack.
   --
-  -- This differs from 'InstrWithVarNotes' in a subtle but significant way: that
-  -- constructor is only present on instructions which explicitly produce
-  -- variable annotations, while this constructor contains the annotation
-  -- associated to an instruction after every type-checking phase, in the same
-  -- manner as 'InstrWithNotes', which is useful during the interpreter phase.
+  -- See: Note [Annotations]
   InstrWithVarAnns :: VarAnns -> Instr a b -> Instr a b
 
   -- | Execute given instruction on truncated stack.
@@ -312,92 +412,100 @@
   Nested :: Instr inp out -> Instr inp out
   -- | Places documentation generated for given instruction under some group.
   -- This is not part of 'ExtInstr' because it does not behave like 'Nop';
-  -- instead, it inherits behaviour of instruction put within it.
+  -- instead, it inherits the behaviour of the instruction put within it.
   DocGroup :: DocGrouping -> Instr inp out -> Instr inp out
+  -- | Represents a typed stack function.
+  -- This is not part of 'ExtInstr' because it does not behave like 'Nop';
+  -- instead, it inherits the behaviour of the instruction put within it.
+  Fn :: Text -> StackFn -> Instr inp out -> Instr inp out
 
-  -- | Variants of CAR/CDR to retain field annotations as they relate to the input
-  -- stack, and hence won't be available from the annotation notes from
-  -- the result stack we pack with the instructions during type check.
-  AnnCAR :: FieldAnn -> Instr ('TPair a b ': s) (a ': s)
-  AnnCDR :: FieldAnn -> Instr ('TPair a b ': s) (b ': s)
+  -- | CAR and CDR's original annotations must be retained inside
+  -- the instruction's constructor.
+  -- See: Note [Annotations - Exceptional scenarios].
+  AnnCAR :: VarAnn -> FieldAnn -> Instr ('TPair a b ': s) (a ': s)
+  AnnCDR :: VarAnn -> FieldAnn -> Instr ('TPair a b ': s) (b ': s)
 
   -- Note that we can not merge DROP and DROPN into one instruction
   -- because they are packed differently.
   DROP :: Instr (a ': s) s
   DROPN
     :: forall (n :: Peano) s.
-    (SingI n, KnownPeano n, RequireLongerOrSameLength s n, NFData (Sing n))
-    => Sing n -> Instr s (Drop n s)
-  DUP :: Instr (a ': s) (a ': a ': s)
+    (RequireLongerOrSameLength s n, NFData (Sing n))
+    => PeanoNatural n -> Instr s (Drop n s)
+  DUP :: DupableScope a => Instr (a ': s) (a ': a ': s)
   DUPN
-    :: forall (n :: Peano) inp out a. (ConstraintDUPN n inp out a, NFData (Sing n))
-    => Sing n -> Instr inp out
+    :: forall (n :: Peano) inp out a. (ConstraintDUPN n inp out a, DupableScope a, NFData (Sing n))
+    => PeanoNatural n -> Instr inp out
   SWAP :: Instr (a ': b ': s) (b ': a ': s)
   DIG
     :: forall (n :: Peano) inp out a. (ConstraintDIG n inp out a, NFData (Sing n))
-    => Sing n -> Instr inp out
+    => PeanoNatural n -> Instr inp out
   DUG
     :: forall (n :: Peano) inp out a. (ConstraintDUG n inp out a, NFData (Sing n))
-    => Sing n -> Instr inp out
+    => PeanoNatural n -> Instr inp out
   PUSH
     :: forall t s . ConstantScope t
     => Value' Instr t -> Instr s (t ': s)
   SOME :: Instr (a ': s) ('TOption a ': s)
-  NONE :: forall a s . KnownT a => Instr s ('TOption a ': s)
+  NONE :: forall a s . SingI a => Instr s ('TOption a ': s)
   UNIT :: Instr s ('TUnit ': s)
   IF_NONE
     :: Instr s s'
     -> Instr (a ': s) s'
     -> Instr ('TOption a ': s) s'
-  -- | Annotations for PAIR instructions can be different from notes presented on the stack
-  -- in case of special field annotations, so we carry annotations for instruction
-  -- separately from notes.
+  -- | PAIR's original annotations must be retained inside
+  -- the instruction's constructor.
+  -- See: Note [Annotations - Exceptional scenarios].
   AnnPAIR :: TypeAnn -> FieldAnn -> FieldAnn -> Instr (a ': b ': s) ('TPair a b ': s)
+  -- | UNPAIR's original annotations must be retained inside
+  -- the instruction's constructor.
+  -- See: Note [Annotations - Exceptional scenarios].
+  AnnUNPAIR :: VarAnn -> VarAnn -> FieldAnn -> FieldAnn -> Instr ('TPair a b ': s) (a ': b ': s)
   -- |
-  -- >>> :t PAIRN (peanoSing @3) :: Instr '[ 'TInt, 'TUnit, 'TString ] _
+  -- >>> :t PAIRN (toPeanoNatural' @3) :: Instr '[ 'TInt, 'TUnit, 'TString ] _
   -- ...
   -- ...:: Instr
   -- ...    '[ 'TInt, 'TUnit, 'TString]
   -- ...    '[ 'TPair 'TInt ('TPair 'TUnit 'TString)]
   --
   --
-  -- >>> PAIRN (peanoSing @1) :: Instr '[ 'TInt, 'TInt ] _
+  -- >>> PAIRN (toPeanoNatural' @1) :: Instr '[ 'TInt, 'TInt ] _
   -- ...
   -- ... 'PAIR n' expects n ≥ 2
   -- ...
   --
-  -- >>> PAIRN (peanoSing @3) :: Instr '[ 'TInt, 'TInt ] _
+  -- >>> PAIRN (toPeanoNatural' @3) :: Instr '[ 'TInt, 'TInt ] _
   -- ...
   -- ... Expected stack with length >= 3
   -- ... Current stack has size of only 2:
   -- ...
   PAIRN
     :: forall n inp. ConstraintPairN n inp
-    => Sing n -> Instr inp (PairN n inp)
+    => PeanoNatural n -> Instr inp (PairN n inp)
   -- |
-  -- >>> :t UNPAIRN (peanoSing @3) :: Instr '[ 'TPair 'TInt ('TPair 'TUnit 'TString) ] _
+  -- >>> :t UNPAIRN (toPeanoNatural' @3) :: Instr '[ 'TPair 'TInt ('TPair 'TUnit 'TString) ] _
   -- ...
   -- ...:: Instr
   -- ...   '[ 'TPair 'TInt ('TPair 'TUnit 'TString)]
   -- ...   '[ 'TInt, 'TUnit, 'TString]
   --
-  -- >>> :t UNPAIRN (peanoSing @3) :: Instr '[ 'TPair 'TInt ('TPair 'TUnit ('TPair 'TString 'TNat)) ] _
+  -- >>> :t UNPAIRN (toPeanoNatural' @3) :: Instr '[ 'TPair 'TInt ('TPair 'TUnit ('TPair 'TString 'TNat)) ] _
   -- ...
   -- ...:: Instr
   -- ...   '[ 'TPair 'TInt ('TPair 'TUnit ('TPair 'TString 'TNat))]
   -- ...   '[ 'TInt, 'TUnit, 'TPair 'TString 'TNat]
   --
-  -- >>> UNPAIRN (peanoSing @1) :: Instr '[ 'TPair 'TInt 'TUnit ] _
+  -- >>> UNPAIRN (toPeanoNatural' @1) :: Instr '[ 'TPair 'TInt 'TUnit ] _
   -- ...
   -- ...'UNPAIR n' expects n ≥ 2
   -- ...
   --
-  -- >>> UNPAIRN (peanoSing @2) :: Instr '[ 'TInt, 'TUnit, 'TString ] _
+  -- >>> UNPAIRN (toPeanoNatural' @2) :: Instr '[ 'TInt, 'TUnit, 'TString ] _
   -- ...
   -- ...Expected a pair at the top of the stack, but found: 'TInt
   -- ...
   --
-  -- >>> UNPAIRN (peanoSing @3) :: Instr '[ 'TPair 'TInt 'TUnit ] _
+  -- >>> UNPAIRN (toPeanoNatural' @3) :: Instr '[ 'TPair 'TInt 'TUnit ] _
   -- ...
   -- ...'UNPAIR 3' expects a right-combed pair with at least 3 elements at the top of the stack,
   -- ...but the pair only contains 2 elements.
@@ -405,31 +513,35 @@
   UNPAIRN
     :: forall (n :: Peano) (pair :: T) (s :: [T]).
        ConstraintUnpairN n pair
-    => Sing n
+    => PeanoNatural n
     -> Instr (pair : s) (UnpairN n pair ++ s)
-  AnnLEFT :: KnownT b => TypeAnn -> FieldAnn -> FieldAnn -> Instr (a ': s) ('TOr a b ': s)
-  AnnRIGHT :: KnownT a => TypeAnn -> FieldAnn -> FieldAnn -> Instr (b ': s) ('TOr a b ': s)
+
+  -- | LEFT and RIGHT's original annotations must be retained inside
+  -- the instruction's constructor.
+  -- See: Note [Annotations - Exceptional scenarios].
+  AnnLEFT :: SingI b => TypeAnn -> FieldAnn -> FieldAnn -> Instr (a ': s) ('TOr a b ': s)
+  AnnRIGHT :: SingI a => TypeAnn -> FieldAnn -> FieldAnn -> Instr (b ': s) ('TOr a b ': s)
   IF_LEFT
     :: Instr (a ': s) s'
     -> Instr (b ': s) s'
     -> Instr ('TOr a b ': s) s'
-  NIL :: KnownT p => Instr s ('TList p ': s)
+  NIL :: SingI p => Instr s ('TList p ': s)
   CONS :: Instr (a ': 'TList a ': s) ('TList a ': s)
   IF_CONS
     :: Instr (a ': 'TList a ': s) s'
     -> Instr s s'
     -> Instr ('TList a ': s) s'
   SIZE :: SizeOp c => Instr (c ': s) ('TNat ': s)
-  EMPTY_SET :: (KnownT e, Comparable e) => Instr s ('TSet e ': s)
-  EMPTY_MAP :: (KnownT a, KnownT b, Comparable a) => Instr s ('TMap a b ': s)
-  EMPTY_BIG_MAP :: (KnownT a, KnownT b, Comparable a) => Instr s ('TBigMap a b ': s)
-  MAP :: (MapOp c, KnownT b)
+  EMPTY_SET :: (SingI e, Comparable e) => Instr s ('TSet e ': s)
+  EMPTY_MAP :: (SingI a, SingI b, Comparable a) => Instr s ('TMap a b ': s)
+  EMPTY_BIG_MAP :: (SingI a, SingI b, Comparable a, HasNoBigMap b) => Instr s ('TBigMap a b ': s)
+  MAP :: (MapOp c, SingI b)
       => Instr (MapOpInp c ': s) (b ': s)
       -> Instr (c ': s) (MapOpRes c b ': s)
   ITER :: IterOp c => Instr (IterOpEl c ': s) s -> Instr (c ': s) s
   MEM :: MemOp c => Instr (MemOpKey c ': c ': s) ('TBool ': s)
   GET
-    :: (GetOp c, KnownT (GetOpVal c))
+    :: (GetOp c, SingI (GetOpVal c))
     => Instr (GetOpKey c ': c ': s) ('TOption (GetOpVal c) ': s)
   -- | Get the node at index @ix@ of a right-combed pair.
   -- Nodes are 0-indexed, and are numbered in a breadth-first,
@@ -452,16 +564,16 @@
   -- >        /   \
   -- >      3       4
   --
-  -- >>> :t GETN (peanoSing @1) :: Instr '[ 'TPair 'TInt 'TUnit] _
+  -- >>> :t GETN (toPeanoNatural' @1) :: Instr '[ 'TPair 'TInt 'TUnit] _
   -- ...
   -- ...:: Instr '[ 'TPair 'TInt 'TUnit] '[ 'TInt]
   --
-  -- >>> GETN (peanoSing @1) :: Instr '[ 'TUnit ] _
+  -- >>> GETN (toPeanoNatural' @1) :: Instr '[ 'TUnit ] _
   -- ...
   -- ...Expected a pair at the top of the stack, but found: 'TUnit
   -- ...
   --
-  -- >>> GETN (peanoSing @3) :: Instr '[ 'TPair 'TInt 'TUnit ] _
+  -- >>> GETN (toPeanoNatural' @3) :: Instr '[ 'TPair 'TInt 'TUnit ] _
   -- ...
   -- ...'GET 3' expects a right-combed pair with at least 4 nodes at the top of the stack,
   -- ...but the pair only contains 3 nodes.
@@ -469,30 +581,30 @@
   --
   -- Note that @GET 0@ is just the identity function and works for all types (not just pairs).
   --
-  -- >>> :t GETN (peanoSing @0) :: Instr '[ 'TInt ] _
+  -- >>> :t GETN (toPeanoNatural' @0) :: Instr '[ 'TInt ] _
   -- ...
   -- ...:: Instr '[ 'TInt] '[ 'TInt]
   GETN
     :: forall (ix :: Peano) (pair :: T) (s :: [T]).
        ConstraintGetN ix pair
-    => Sing ix
+    => PeanoNatural ix
     -> Instr (pair : s) (GetN ix pair ': s)
   UPDATE
     :: UpdOp c
     => Instr (UpdOpKey c ': UpdOpParams c ': c ': s) (c ': s)
   -- | Update the node at index @ix@ of a right-combed pair.
   --
-  -- >>> :t UPDATEN (peanoSing @1) :: Instr '[ 'TString, 'TPair 'TInt 'TUnit] _
+  -- >>> :t UPDATEN (toPeanoNatural' @1) :: Instr '[ 'TString, 'TPair 'TInt 'TUnit] _
   -- ...
   -- ...:: Instr
   -- ...     '[ 'TString, 'TPair 'TInt 'TUnit] '[ 'TPair 'TString 'TUnit]
   --
-  -- >>> UPDATEN (peanoSing @1) :: Instr '[ 'TUnit, 'TInt ] _
+  -- >>> UPDATEN (toPeanoNatural' @1) :: Instr '[ 'TUnit, 'TInt ] _
   -- ...
   -- ...Expected the 2nd element of the stack to be a pair, but found: 'TInt
   -- ...
   --
-  -- >>> UPDATEN (peanoSing @3) :: Instr '[ 'TString, 'TPair 'TInt 'TUnit ] _
+  -- >>> UPDATEN (toPeanoNatural' @3) :: Instr '[ 'TString, 'TPair 'TInt 'TUnit ] _
   -- ...
   -- ...'UPDATE 3' expects the 2nd element of the stack to be a right-combed pair with at least 4 nodes,
   -- ...but the pair only contains 3 nodes.
@@ -500,16 +612,16 @@
   --
   -- Note that @UPDATE 0@ is equivalent to @DIP { DROP }@.
   --
-  -- >>> :t UPDATEN (peanoSing @0) :: Instr '[ 'TInt, 'TString ] _
+  -- >>> :t UPDATEN (toPeanoNatural' @0) :: Instr '[ 'TInt, 'TString ] _
   -- ...
   -- ...:: Instr '[ 'TInt, 'TString] '[ 'TInt]
   UPDATEN
     :: forall (ix :: Peano) (val :: T) (pair :: T) (s :: [T]).
        ConstraintUpdateN ix pair
-    => Sing ix
+    => PeanoNatural ix
     -> Instr (val : pair : s) (UpdateN ix val pair ': s)
   GET_AND_UPDATE
-    :: ( GetOp c, UpdOp c, KnownT (GetOpVal c)
+    :: ( GetOp c, UpdOp c, SingI (GetOpVal c)
        , UpdOpKey c ~ GetOpKey c
        )
     => Instr (UpdOpKey c ': UpdOpParams c ': c ': s) ('TOption (GetOpVal c) : c ': s)
@@ -521,28 +633,28 @@
   LOOP_LEFT
     :: Instr (a ': s) ('TOr a b ': s)
     -> Instr ('TOr a b ': s) (b ': s)
-  LAMBDA :: forall i o s . (KnownT i, KnownT o)
+  LAMBDA :: forall i o s . (SingI i, SingI o)
          => Value' Instr ('TLambda i o) -> Instr s ('TLambda i o ': s)
   EXEC :: Instr (t1 ': 'TLambda t1 t2 ': s) (t2 ': s)
   APPLY
-    :: forall a b c s . (ConstantScope a, KnownT b)
+    :: forall a b c s . (ConstantScope a, SingI b)
     => Instr (a ': 'TLambda ('TPair a b) c ': s) ('TLambda b c ': s)
   DIP :: Instr a c -> Instr (b ': a) (b ': c)
   DIPN
     :: forall (n :: Peano) inp out s s'. (ConstraintDIPN n inp out s s', (NFData (Sing n)))
-    => Sing n -> Instr s s' -> Instr inp out
+    => PeanoNatural n -> Instr s s' -> Instr inp out
   -- Since 008 it's prohibited to fail with non-packable values and with the
   -- 'Contract t' type values, which is equivalent to our @ConstantScope@ constraint.
   -- See https://gitlab.com/tezos/tezos/-/issues/1093#note_496066354 for more information.
-  FAILWITH :: (KnownT a, ConstantScope a) => Instr (a ': s) t
+  FAILWITH :: (SingI a, ConstantScope a) => Instr (a ': s) t
   CAST :: forall a s . SingI a => Instr (a ': s) (a ': s)
   RENAME :: Instr (a ': s) (a ': s)
   PACK :: PackedValScope a => Instr (a ': s) ('TBytes ': s)
-  UNPACK :: (UnpackedValScope a, KnownT a) => Instr ('TBytes ': s) ('TOption a ': s)
+  UNPACK :: (UnpackedValScope a, SingI a) => Instr ('TBytes ': s) ('TOption a ': s)
   CONCAT :: ConcatOp c => Instr (c ': c ': s) (c ': s)
   CONCAT' :: ConcatOp c => Instr ('TList c ': s) (c ': s)
   SLICE
-    :: (SliceOp c, KnownT c)
+    :: (SliceOp c, SingI c)
     => Instr ('TNat ': 'TNat ': c ': s) ('TOption c ': s)
   ISNAT :: Instr ('TInt ': s) ('TOption ('TNat) ': s)
   ADD
@@ -584,7 +696,7 @@
     :: UnaryArithOp Not n
     => Instr (n ': s) (UnaryArithRes Not n ': s)
   COMPARE
-    :: (Comparable n, KnownT n)
+    :: (Comparable n, SingI n)
     => Instr (n ': n ': s) ('TInt ': s)
   EQ
     :: UnaryArithOp Eq' n
@@ -656,7 +768,40 @@
   LEVEL :: Instr s ('TNat ': s)
   SELF_ADDRESS :: Instr s ('TAddress ': s)
   NEVER :: Instr ('TNever ': s) t
+  TICKET
+    :: (Comparable a)
+    => Instr (a ': 'TNat ': s) ('TTicket a ': s)
+  READ_TICKET
+    :: Instr ('TTicket a ': s)
+             (RightComb ['TAddress, a, 'TNat] ': 'TTicket a ': s)
+  SPLIT_TICKET
+    :: Instr ('TTicket a ': 'TPair 'TNat 'TNat ': s)
+             ('TOption ('TPair ('TTicket a) ('TTicket a)) ': s)
+  JOIN_TICKETS
+    :: Instr ('TPair ('TTicket a) ('TTicket a) ': s)
+             ('TOption ('TTicket a) ': s)
 
+castInstr
+  :: forall inp1 out1 inp2 out2.
+  ( SingI inp1
+  , SingI out1
+  , SingI inp2
+  , SingI out2
+  )
+  => Instr inp1 out1 -> Maybe (Instr inp2 out2)
+castInstr instr =
+  case (eqI @inp1 @inp2, eqI @out1 @out2) of
+    (Just Refl, Just Refl) -> Just instr
+    (_,_) -> Nothing
+
+-- | Right-associative operator for 'Seq'.
+--
+-- >>> show (DROP :# UNIT :# Nop) == show (DROP :# (UNIT :# Nop))
+-- True
+pattern (:#) :: Instr a b -> Instr b c -> Instr a c
+pattern a :# b = Seq a b
+infixr 8 :#
+
 deriving stock instance Show (Instr inp out)
 
 instance Semigroup (Instr s s) where
@@ -673,26 +818,26 @@
 --
 -- Note that internally GADT constructors are rewritten in the very same way.
 pattern CAR :: () => (i ~ ('TPair a b : s), o ~ (a : s)) => Instr i o
-pattern CAR = AnnCAR (AnnotationUnsafe "")
+pattern CAR = AnnCAR (UnsafeAnnotation "") (UnsafeAnnotation "")
 
 pattern CDR :: () => (i ~ ('TPair a b : s), o ~ (b : s)) => Instr i o
-pattern CDR = AnnCDR (AnnotationUnsafe "")
+pattern CDR = AnnCDR (UnsafeAnnotation "") (UnsafeAnnotation "")
 
 pattern UNPAIR :: () => (i ~ ('TPair a b : s), o ~ (a : b : s)) => Instr i o
-pattern UNPAIR = Seq DUP (Seq CAR (DIP CDR))
+pattern UNPAIR = AnnUNPAIR (UnsafeAnnotation "") (UnsafeAnnotation "") (UnsafeAnnotation "") (UnsafeAnnotation "")
 
 pattern PAIR :: () => (i ~ (a ': b ': s), o ~ ('TPair a b ': s)) => Instr i o
-pattern PAIR = AnnPAIR (AnnotationUnsafe "") (AnnotationUnsafe "") (AnnotationUnsafe "")
+pattern PAIR = AnnPAIR (UnsafeAnnotation "") (UnsafeAnnotation "") (UnsafeAnnotation "")
 
-pattern LEFT :: () => (KnownT b, i ~ (a ': s), o ~ ('TOr a b ': s)) => Instr i o
-pattern LEFT = AnnLEFT (AnnotationUnsafe "") (AnnotationUnsafe "") (AnnotationUnsafe "")
+pattern LEFT :: () => (SingI b, i ~ (a ': s), o ~ ('TOr a b ': s)) => Instr i o
+pattern LEFT = AnnLEFT (UnsafeAnnotation "") (UnsafeAnnotation "") (UnsafeAnnotation "")
 
-pattern RIGHT :: () => (KnownT a, i ~ (b ': s), o ~ ('TOr a b ': s)) => Instr i o
-pattern RIGHT = AnnRIGHT (AnnotationUnsafe "") (AnnotationUnsafe "") (AnnotationUnsafe "")
+pattern RIGHT :: () => (SingI a, i ~ (b ': s), o ~ ('TOr a b ': s)) => Instr i o
+pattern RIGHT = AnnRIGHT (UnsafeAnnotation "") (UnsafeAnnotation "") (UnsafeAnnotation "")
 
 data TestAssert (s :: [T]) where
   TestAssert
-    :: (Typeable out)
+    :: (SingI out)
     => Text
     -> PrintComment inp
     -> Instr inp ('TBool ': out)
@@ -706,24 +851,24 @@
 data StackRef (st :: [T]) where
   -- | Keeps 0-based index to a stack element counting from the top.
   StackRef
-    :: (KnownPeano idx, SingI idx, RequireLongerThan st idx)
-    => Sing (idx :: Peano) -> StackRef st
+    :: (RequireLongerThan st idx)
+    => PeanoNatural idx -> StackRef st
 
 instance NFData (StackRef st) where
   rnf (StackRef s) = rnf s
 
 instance Eq (StackRef st) where
-  StackRef snat1 == StackRef snat2 = peanoVal snat1 == peanoVal snat2
+  StackRef snat1 == StackRef snat2 = fromPeanoNatural snat1 == fromPeanoNatural snat2
 
 instance Show (StackRef st) where
-  show (StackRef snat) = "StackRef {" +|| peanoVal snat ||+ "}"
+  show (StackRef snat) = "StackRef {" +|| fromPeanoNatural snat ||+ "}"
 
 -- | Create a stack reference, performing checks at compile time.
 mkStackRef
   :: forall (gn :: GHC.Nat) st n.
-      (n ~ ToPeano gn, SingI n, KnownPeano n, RequireLongerThan st n)
+      (n ~ ToPeano gn, SingI (ToPeano gn), RequireLongerThan st n)
   => StackRef st
-mkStackRef = StackRef $ peanoSing @gn
+mkStackRef = StackRef $ toPeanoNatural' @gn
 
 -- | A print format with references into the stack
 newtype PrintComment (st :: [T]) = PrintComment
@@ -752,6 +897,7 @@
   | PRINT (PrintComment s)
   | DOC_ITEM SomeDocItem
   | COMMENT_ITEM CommentType
+  | STACKTYPE StackTypePattern
   deriving stock (Show, Generic)
 
 instance NFData (ExtInstr s)
diff --git a/src/Michelson/Typed/Origination.hs b/src/Michelson/Typed/Origination.hs
--- a/src/Michelson/Typed/Origination.hs
+++ b/src/Michelson/Typed/Origination.hs
@@ -5,18 +5,25 @@
 module Michelson.Typed.Origination
   ( OriginationOperation(..)
   , mkOriginationOperationHash
+
+  -- * Operation hashing
+  , OperationHash (..)
+  , mkContractAddress
+
   ) where
 
-import Data.Binary.Put (putWord64be, runPut)
+import Data.Binary.Put (putInt32be, putWord64be, runPut)
 import qualified Data.ByteString.Lazy as BSL
 
-import Michelson.Interpret.Pack (encodeKeyHashRaw, encodeValue', packCode')
+import Michelson.Interpret.Pack (toBinary')
 import Michelson.Typed.Aliases (Value)
+import Michelson.Typed.Haskell.Value (IsoValue(..))
 import Michelson.Typed.Instr (Contract(..), cCode)
 import Michelson.Typed.Scope (ParameterScope, StorageScope)
-import Tezos.Address (Address, OperationHash(..))
+import Tezos.Address
+  (Address(ContractAddress), ContractHash(..), GlobalCounter(..), OriginationIndex(..))
 import Tezos.Core (Mutez(..))
-import Tezos.Crypto (KeyHash, blake2b)
+import Tezos.Crypto (KeyHash, blake2b, blake2b160)
 
 -- | Data necessary to originate a contract.
 data OriginationOperation =
@@ -49,9 +56,9 @@
     -- and https://gitlab.com/tezos/tezos/-/blob/f57c50e3a657956d69a1699978de9873c98f0018/src/proto_006_PsCARTHA/lib_protocol/script_repr.ml#L68
     packedOperation =
       BSL.toStrict (runPut $ putWord64be $ unMutez ooBalance)
-      <> packMaybe (BSL.toStrict . encodeKeyHashRaw) ooDelegate
-      <> packCode' (cCode ooContract)
-      <> encodeValue' ooStorage
+      <> packMaybe (toBinary' . toVal) ooDelegate
+      <> toBinary' (cCode ooContract)
+      <> toBinary' ooStorage
 
     -- "optional" encoding in Tezos.
     --
@@ -59,3 +66,45 @@
     packMaybe :: (a -> ByteString) -> Maybe a -> ByteString
     packMaybe _ Nothing = "\255"
     packMaybe f (Just a) = "\0" <> f a
+
+----------------------------------------------------------------------------
+-- Operation hash
+----------------------------------------------------------------------------
+
+newtype OperationHash = OperationHash
+  { unOperationHash :: ByteString
+  }
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData)
+
+-- | Compute address of a contract from its origination operation, origination index and global counter.
+--
+-- However, in real Tezos encoding of the operation is more than just 'OriginationOperation'.
+-- There an Operation has several more meta-fields plus a big sum-type of all possible operations.
+--
+-- See here: https://gitlab.com/tezos/tezos/-/blob/f57c50e3a657956d69a1699978de9873c98f0018/src/proto_006_PsCARTHA/lib_protocol/operation_repr.ml#L78
+--
+-- What is important is that one (big) Operation may lead to origination of multiple contracts. That
+-- is why contract address is constructed from hash of the operation that originated and of index
+-- of the contract's origination in the execution of that operation.
+--
+-- In other words, contract hash is calculated as the blake2b160 (20-byte) hash of
+-- origination operation hash + int32 origination index + word64 global counter.
+--
+-- In Morley we do not yet support full encoding of Tezos Operations, therefore we choose
+-- to generate contract addresses in a simplified manner.
+--
+-- Namely, we encode 'OriginationOperation' as we can and concat it with the origination index
+-- and the global counter.
+-- Then we take 'blake2b160' hash of the resulting bytes and consider it to be the contract's
+-- address.
+mkContractAddress
+  :: OperationHash
+  -> OriginationIndex
+  -> GlobalCounter
+  -> Address
+mkContractAddress (OperationHash opHash) (OriginationIndex idx) (GlobalCounter counter) =
+  ContractAddress
+  $ ContractHash
+  $ blake2b160
+  $ opHash <> BSL.toStrict (runPut $ putInt32be idx >> putWord64be counter)
diff --git a/src/Michelson/Typed/Polymorphic.hs b/src/Michelson/Typed/Polymorphic.hs
--- a/src/Michelson/Typed/Polymorphic.hs
+++ b/src/Michelson/Typed/Polymorphic.hs
@@ -22,10 +22,10 @@
 import qualified Data.ByteString as B
 import qualified Data.Map as M
 import qualified Data.Set as S
+import Data.Singletons (SingI)
 
 import Michelson.Text
 import Michelson.Typed.Annotation
-import Michelson.Typed.Sing (KnownT)
 import Michelson.Typed.T (T(..))
 import Michelson.Typed.Value (Value'(..))
 import Michelson.Untyped.Annotation (noAnn)
@@ -43,14 +43,14 @@
   evalMem k (VMap m) = k `M.member` m
 instance MemOp ('TBigMap k v) where
   type MemOpKey ('TBigMap k v) = k
-  evalMem k (VBigMap m) = k `M.member` m
+  evalMem k (VBigMap _ m) = k `M.member` m
 
 class MapOp (c :: T) where
   type MapOpInp c :: T
   type MapOpRes c :: T -> T
   mapOpToList :: Value' instr c -> [Value' instr (MapOpInp c)]
   mapOpFromList
-    :: (KnownT b)
+    :: (SingI b)
     => Value' instr c -> [Value' instr b] -> Value' instr (MapOpRes c b)
   mapOpNotes :: Notes c -> Notes (MapOpInp c)
 instance MapOp ('TMap k v) where
@@ -121,10 +121,10 @@
 instance UpdOp ('TBigMap k v) where
   type UpdOpKey ('TBigMap k v) = k
   type UpdOpParams ('TBigMap k v) = 'TOption v
-  evalUpd k (VOption o) (VBigMap m) =
+  evalUpd k (VOption o) (VBigMap bmId m) =
     case o of
-      Just newV -> VBigMap $ M.insert k newV m
-      Nothing -> VBigMap $ M.delete k m
+      Just newV -> VBigMap bmId $ M.insert k newV m
+      Nothing -> VBigMap bmId $ M.delete k m
 instance UpdOp ('TSet a) where
   type UpdOpKey ('TSet a) = a
   type UpdOpParams ('TSet a) = 'TBool
@@ -140,7 +140,7 @@
 instance GetOp ('TBigMap k v) where
   type GetOpKey ('TBigMap k v) = k
   type GetOpVal ('TBigMap k v) = v
-  evalGet k (VBigMap m) = k `M.lookup` m
+  evalGet k (VBigMap _ m) = k `M.lookup` m
 instance GetOp ('TMap k v) where
   type GetOpKey ('TMap k v) = k
   type GetOpVal ('TMap k v) = v
diff --git a/src/Michelson/Typed/Scope.hs b/src/Michelson/Typed/Scope.hs
--- a/src/Michelson/Typed/Scope.hs
+++ b/src/Michelson/Typed/Scope.hs
@@ -38,6 +38,7 @@
 module Michelson.Typed.Scope
   ( -- * Scopes
     ConstantScope
+  , DupableScope
   , StorageScope
   , PackedValScope
   , ParameterScope
@@ -47,6 +48,7 @@
   , ProperParameterBetterErrors
   , ProperStorageBetterErrors
   , ProperConstantBetterErrors
+  , ProperDupableBetterErrors
   , ProperPackedValBetterErrors
   , ProperUnpackedValBetterErrors
   , ProperPrintedValBetterErrors
@@ -54,6 +56,7 @@
   , properParameterEvi
   , properStorageEvi
   , properConstantEvi
+  , properDupableEvi
   , properPackedValEvi
   , properUnpackedValEvi
   , properPrintedValEvi
@@ -68,11 +71,13 @@
   , HasNoNestedBigMaps
   , HasNoOp
   , HasNoContract
+  , HasNoTicket
   , ContainsBigMap
   , ContainsNestedBigMaps
 
   , ForbidOp
   , ForbidContract
+  , ForbidTicket
   , ForbidBigMap
   , ForbidNestedBigMaps
   , FailOnBigMapFound
@@ -81,10 +86,12 @@
 
   , OpPresence (..)
   , ContractPresence (..)
+  , TicketPresence (..)
   , BigMapPresence (..)
   , NestedBigMapsPresence (..)
   , checkOpPresence
   , checkContractTypePresence
+  , checkTicketPresence
   , checkBigMapPresence
   , checkNestedBigMapsPresence
   , opAbsense
@@ -101,19 +108,20 @@
   , SingI (..)
   ) where
 
-import Data.Constraint ((:-)(..), Dict(..), withDict, (\\))
+import Data.Constraint (Dict(..), withDict, (:-)(..), (\\))
 import Data.Singletons (Sing, SingI(..))
 import Data.Type.Bool (type (||))
 import Fmt (Buildable(..))
 import GHC.TypeLits (ErrorMessage(..), TypeError)
 
-import Michelson.Typed.Sing (KnownT, SingT(..))
+import Michelson.Typed.Sing (SingT(..))
 import Michelson.Typed.T (T(..))
+import Michelson.Printer.Util (RenderDoc(..), buildRenderDoc)
 
 ----------------------------------------------------------------------------
 -- Constraints
 ----------------------------------------------------------------------------
--- | Whether this type contains 'TOperation' type.
+-- | Whether a value of this type _may_ contain an operation.
 --
 -- In some scopes (constants, parameters, storage) appearing for operation type
 -- is prohibited.
@@ -127,7 +135,8 @@
   ContainsOp ('TList t) = ContainsOp t
   ContainsOp ('TSet t) = ContainsOp t
   ContainsOp 'TOperation = 'True
-  ContainsOp ('TContract t) = ContainsOp t
+  ContainsOp ('TContract _) = 'False
+  ContainsOp ('TTicket t) = ContainsOp t
   ContainsOp ('TPair a b) = ContainsOp a || ContainsOp b
   ContainsOp ('TOr a b) = ContainsOp a || ContainsOp b
   ContainsOp ('TLambda _ _) = 'False
@@ -135,7 +144,7 @@
   ContainsOp ('TBigMap k v) = ContainsOp k || ContainsOp v
   ContainsOp _ = 'False
 
--- | Whether this type contains 'TContract' type.
+-- | Whether a value of this type _may_ contain a @contract@ value.
 --
 -- In some scopes (constants, storage) appearing for contract type
 -- is prohibited.
@@ -157,7 +166,20 @@
   ContainsContract ('TBigMap _ v) = ContainsContract v
   ContainsContract _ = 'False
 
--- | Whether this type contains 'TBigMap' type.
+-- | Whether a value of this type _may_ contain a @ticket@ value.
+type family ContainsTicket (t :: T) :: Bool where
+  ContainsTicket ('TOption t) = ContainsTicket t
+  ContainsTicket ('TList t) = ContainsTicket t
+  ContainsTicket ('TSet _) = 'False
+  ContainsTicket ('TTicket _) = 'True
+  ContainsTicket ('TPair a b) = ContainsTicket a || ContainsTicket b
+  ContainsTicket ('TOr a b) = ContainsTicket a || ContainsTicket b
+  ContainsTicket ('TLambda _ _) = 'False
+  ContainsTicket ('TMap _ v) = ContainsTicket v
+  ContainsTicket ('TBigMap _ v) = ContainsTicket v
+  ContainsTicket _ = 'False
+
+-- | Whether a value of this type _may_ contain a @big_map@ value.
 type family ContainsBigMap (t :: T) :: Bool where
   ContainsBigMap 'TKey = 'False
   ContainsBigMap 'TUnit = 'False
@@ -167,7 +189,7 @@
   ContainsBigMap ('TList t) = ContainsBigMap t
   ContainsBigMap ('TSet _) = 'False
   ContainsBigMap 'TOperation = 'False
-  ContainsBigMap ('TContract t) = ContainsBigMap t
+  ContainsBigMap ('TContract _) = 'False
   ContainsBigMap ('TPair a b) = ContainsBigMap a || ContainsBigMap b
   ContainsBigMap ('TOr a b) = ContainsBigMap a || ContainsBigMap b
   ContainsBigMap ('TLambda _ _) = 'False
@@ -175,11 +197,11 @@
   ContainsBigMap ('TBigMap _ _) = 'True
   ContainsBigMap _ = 'False
 
--- | Whether this type contains a type with nested 'TBigMap's .
+-- | Whether a value of this type _may_ contain nested @big_map@s.
 --
--- Nested big_maps (i.e. big_map which contains another big_map inside of it's value type). Are
+-- Nested big_maps (i.e. big_map which contains another big_map inside of it's value type) are
 -- prohibited in all contexts. Some context such as PUSH, APPLY, PACK/UNPACK instructions are more
--- strict because they doesn't work with big_map at all.
+-- strict because they don't work with big_map at all.
 type family ContainsNestedBigMaps (t :: T) :: Bool where
   ContainsNestedBigMaps 'TKey = 'False
   ContainsNestedBigMaps 'TUnit = 'False
@@ -189,7 +211,7 @@
   ContainsNestedBigMaps ('TList t) = ContainsNestedBigMaps t
   ContainsNestedBigMaps ('TSet _) = 'False
   ContainsNestedBigMaps 'TOperation = 'False
-  ContainsNestedBigMaps ('TContract t) = ContainsNestedBigMaps t
+  ContainsNestedBigMaps ('TContract _) = 'False
   ContainsNestedBigMaps ('TPair a b) = ContainsNestedBigMaps a || ContainsNestedBigMaps b
   ContainsNestedBigMaps ('TOr a b) = ContainsNestedBigMaps a || ContainsNestedBigMaps b
   ContainsNestedBigMaps ('TLambda _ _) = 'False
@@ -197,18 +219,22 @@
   ContainsNestedBigMaps ('TBigMap _ v) = ContainsBigMap v
   ContainsNestedBigMaps _ = 'False
 
--- | Constraint which ensures that operation type does not appear in a given type.
+-- | Constraint which ensures that a value of type @t@ does not contain operations.
 --
 -- Not just a type alias in order to be able to partially apply it
 -- (e.g. in 'Each').
 class (ContainsOp t ~ 'False) => HasNoOp t
 instance (ContainsOp t ~ 'False) => HasNoOp t
 
--- | Constraint which ensures that contract type does not appear in a given type.
+-- | Constraint which ensures that a value of type @t@ does not contain @contract@ values.
 class (ContainsContract t ~ 'False) => HasNoContract t
 instance (ContainsContract t ~ 'False) => HasNoContract t
 
--- | Constraint which ensures that bigmap does not appear in a given type.
+-- | Constraint which ensures that a value of type @t@ does not contain @ticket@ values.
+class (ContainsTicket t ~ 'False) => HasNoTicket t
+instance (ContainsTicket t ~ 'False) => HasNoTicket t
+
+-- | Constraint which ensures that a value of type @t@ does not contain @big_map@ values.
 class (ContainsBigMap t ~ 'False) => HasNoBigMap t
 instance (ContainsBigMap t ~ 'False) => HasNoBigMap t
 
@@ -228,6 +254,12 @@
     TypeError ('Text "Type `contract` is not allowed in this scope")
   FailOnContractFound 'False = ()
 
+-- | Report a human-readable error about 'TTicket' at a wrong place.
+type family FailOnTicketFound (enabled :: Bool) :: Constraint where
+  FailOnTicketFound 'True =
+    TypeError ('Text "Type `ticket` is not allowed in this scope")
+  FailOnTicketFound 'False = ()
+
 -- | Report a human-readable error about 'TBigMap' at a wrong place.
 type family FailOnBigMapFound (enabled :: Bool) :: Constraint where
   FailOnBigMapFound 'True =
@@ -251,6 +283,8 @@
 
 type ForbidContract t = FailOnContractFound (ContainsContract t)
 
+type ForbidTicket t = FailOnTicketFound (ContainsTicket t)
+
 type ForbidBigMap t = FailOnBigMapFound (ContainsBigMap t)
 
 type ForbidNestedBigMaps t = FailOnNestedBigMapsFound (ContainsNestedBigMaps t)
@@ -317,29 +351,55 @@
   -> a
 forbiddenContractType = withDict $ forbiddenContractTypeEvi @t
 
--- | Whether the type contains 'TOperation', with proof.
+-- | Reify 'HasNoTicket' contraint from 'ForbidTicket'.
+forbiddenTicketTypeEvi
+  :: forall t. (SingI t, ForbidTicket t) :- HasNoTicket t
+forbiddenTicketTypeEvi = Sub $
+  case checkTicketPresence (sing @t) of
+    TicketAbsent -> Dict
+    TicketPresent -> error "impossible"
+
+-- | Whether a value of this type _may_ contain an operation.
 data OpPresence (t :: T)
   = ContainsOp t ~ 'True => OpPresent
+    -- ^ A value of type @t@ may or may not contain an operation.
   | ContainsOp t ~ 'False => OpAbsent
+    -- ^ A value of type @t@ cannot contain @big_map@ values.
 
+-- | Whether a value of this type _may_ contain a @contract@ value.
 data ContractPresence (t :: T)
   = ContainsContract t ~ 'True => ContractPresent
+    -- ^ A value of type @t@ may or may not contain a @contract@ value.
   | ContainsContract t ~ 'False => ContractAbsent
+    -- ^ A value of type @t@ cannot contain @contract@ values.
 
+-- | Whether a value of this type _may_ contain a @ticket@ value.
+data TicketPresence (t :: T)
+  = ContainsTicket t ~ 'True => TicketPresent
+    -- ^ A value of type @t@ may or may not contain a @ticket@ value.
+  | ContainsTicket t ~ 'False => TicketAbsent
+    -- ^ A value of type @t@ cannot contain @ticket@ values.
+
+-- | Whether a value of this type _may_ contain a @big_map@ value.
 data BigMapPresence (t :: T)
   = ContainsBigMap t ~ 'True => BigMapPresent
+    -- ^ A value of type @t@ may or may not contain a @big_map@ value.
   | ContainsBigMap t ~ 'False => BigMapAbsent
+    -- ^ A value of type @t@ cannot contain @big_map@ values.
 
+-- | Whether a value of this type _may_ contain nested @big_map@s.
 data NestedBigMapsPresence (t :: T)
   = ContainsNestedBigMaps t ~ 'True => NestedBigMapsPresent
+    -- ^ A value of type @t@ may or may not contain nested @big_map@s.
   | ContainsNestedBigMaps t ~ 'False => NestedBigMapsAbsent
+    -- ^ A value of type @t@ cannot contain nested @big_map@s.
 
 -- @rvem: IMO, generalization of OpPresence and BigMapPresence to
 -- TPresence is not worth it, due to the fact that
 -- it will require more boilerplate in checkTPresence implementation
 -- than it is already done in checkOpPresence and checkBigMapPresence
 
--- | Check at runtime whether the given type contains 'TOperation'.
+-- | Check at runtime whether a value of the given type _may_ contain an operation.
 checkOpPresence :: Sing (ty :: T) -> OpPresence ty
 checkOpPresence = \case
   -- This is a sad amount of boilerplate, but at least
@@ -361,7 +421,8 @@
     OpPresent -> OpPresent
     OpAbsent -> OpAbsent
   STOperation -> OpPresent
-  STContract t -> case checkOpPresence t of
+  STContract _ -> OpAbsent
+  STTicket t -> case checkOpPresence t of
     OpPresent -> OpPresent
     OpAbsent -> OpAbsent
   STPair a b -> case (checkOpPresence a, checkOpPresence b) of
@@ -395,7 +456,7 @@
   STAddress -> OpAbsent
   STNever -> OpAbsent
 
--- | Check at runtime whether the given type contains 'TContract'.
+-- | Check at runtime whether a value of the given type _may_ contain a @contract@ value.
 checkContractTypePresence :: Sing (ty :: T) -> ContractPresence ty
 checkContractTypePresence = \case
   STKey -> ContractAbsent
@@ -411,6 +472,7 @@
   STSet _ -> ContractAbsent
   STOperation -> ContractAbsent
   STContract _ -> ContractPresent
+  STTicket _ -> ContractAbsent  -- contract type is not allowed in tickets at all
   STPair a b -> case (checkContractTypePresence a, checkContractTypePresence b) of
     (ContractPresent, _) -> ContractPresent
     (_, ContractPresent) -> ContractPresent
@@ -440,7 +502,53 @@
   STAddress -> ContractAbsent
   STNever -> ContractAbsent
 
--- | Check at runtime whether the given type contains 'TBigMap'.
+-- | Check at runtime whether a value of the given type _may_ contain a @ticket@ value.
+checkTicketPresence :: Sing (ty :: T) -> TicketPresence ty
+checkTicketPresence = \case
+  STKey -> TicketAbsent
+  STSignature -> TicketAbsent
+  STChainId -> TicketAbsent
+  STUnit -> TicketAbsent
+  STOption t -> case checkTicketPresence t of
+    TicketPresent -> TicketPresent
+    TicketAbsent -> TicketAbsent
+  STList t -> case checkTicketPresence t of
+    TicketPresent -> TicketPresent
+    TicketAbsent -> TicketAbsent
+  STSet _ -> TicketAbsent
+  STOperation -> TicketAbsent
+  STContract _ -> TicketAbsent
+  STTicket _ -> TicketPresent
+  STPair a b -> case (checkTicketPresence a, checkTicketPresence b) of
+    (TicketPresent, _) -> TicketPresent
+    (_, TicketPresent) -> TicketPresent
+    (TicketAbsent, TicketAbsent) -> TicketAbsent
+  STOr a b -> case (checkTicketPresence a, checkTicketPresence b) of
+    (TicketPresent, _) -> TicketPresent
+    (_, TicketPresent) -> TicketPresent
+    (TicketAbsent, TicketAbsent) -> TicketAbsent
+  STLambda _ _ -> TicketAbsent
+  STMap _ v -> case checkTicketPresence v of
+    TicketPresent -> TicketPresent
+    TicketAbsent -> TicketAbsent
+  STBigMap _ v -> case checkTicketPresence v of
+    TicketPresent -> TicketPresent
+    TicketAbsent -> TicketAbsent
+  STInt -> TicketAbsent
+  STNat -> TicketAbsent
+  STString -> TicketAbsent
+  STBytes -> TicketAbsent
+  STMutez -> TicketAbsent
+  STBool -> TicketAbsent
+  STKeyHash -> TicketAbsent
+  STBls12381Fr -> TicketAbsent
+  STBls12381G1 -> TicketAbsent
+  STBls12381G2 -> TicketAbsent
+  STTimestamp -> TicketAbsent
+  STAddress -> TicketAbsent
+  STNever -> TicketAbsent
+
+-- | Check at runtime whether a value of the given type _may_ contain a @big_map@ value.
 checkBigMapPresence :: Sing (ty :: T) -> BigMapPresence ty
 checkBigMapPresence = \case
   -- More boilerplate to boilerplate god.
@@ -456,9 +564,8 @@
     BigMapAbsent -> BigMapAbsent
   STSet _ -> BigMapAbsent
   STOperation -> BigMapAbsent
-  STContract t -> case checkBigMapPresence t of
-    BigMapPresent -> BigMapPresent
-    BigMapAbsent -> BigMapAbsent
+  STContract _ -> BigMapAbsent
+  STTicket _ -> BigMapAbsent  -- big_maps are not allowed in tickets at all
   STPair a b -> case (checkBigMapPresence a, checkBigMapPresence b) of
     (BigMapPresent, _) -> BigMapPresent
     (_, BigMapPresent) -> BigMapPresent
@@ -487,7 +594,7 @@
   STAddress -> BigMapAbsent
   STNever -> BigMapAbsent
 
--- | Check at runtime whether the given type contains 'TBigMap'.
+-- | Check at runtime whether a value of the given type _may_ contain nested @big_map@s.
 checkNestedBigMapsPresence :: Sing (ty :: T) -> NestedBigMapsPresence ty
 checkNestedBigMapsPresence = \case
   -- More boilerplate to boilerplate god.
@@ -503,9 +610,8 @@
     NestedBigMapsAbsent -> NestedBigMapsAbsent
   STSet _ -> NestedBigMapsAbsent
   STOperation -> NestedBigMapsAbsent
-  STContract t -> case checkNestedBigMapsPresence t of
-    NestedBigMapsPresent -> NestedBigMapsPresent
-    NestedBigMapsAbsent -> NestedBigMapsAbsent
+  STContract _ -> NestedBigMapsAbsent
+  STTicket _ -> NestedBigMapsAbsent
   STPair a b -> case (checkNestedBigMapsPresence a, checkNestedBigMapsPresence b) of
     (NestedBigMapsPresent, _) -> NestedBigMapsPresent
     (_, NestedBigMapsPresent) -> NestedBigMapsPresent
@@ -535,25 +641,31 @@
   STAddress -> NestedBigMapsAbsent
   STNever -> NestedBigMapsAbsent
 
--- | Check at runtime that the given type does not contain 'TOperation'.
+-- | Check at runtime that a value of the given type cannot contain operations.
 opAbsense :: Sing (t :: T) -> Maybe (Dict $ HasNoOp t)
 opAbsense s = case checkOpPresence s of
   OpPresent -> Nothing
   OpAbsent -> Just Dict
 
--- | Check at runtime that the given type does not contain 'TContract'.
+-- | Check at runtime that a value of the given type cannot contain @contract@ values.
 contractTypeAbsense :: Sing (t :: T) -> Maybe (Dict $ HasNoContract t)
 contractTypeAbsense s = case checkContractTypePresence s of
   ContractPresent -> Nothing
   ContractAbsent -> Just Dict
 
--- | Check at runtime that the given type does not containt 'TBigMap'
+-- | Check at runtime that a value of the given type cannot contain @ticket@ values.
+ticketAbsense :: Sing (t :: T) -> Maybe (Dict $ HasNoTicket t)
+ticketAbsense s = case checkTicketPresence s of
+  TicketPresent -> Nothing
+  TicketAbsent -> Just Dict
+
+-- | Check at runtime that a value of the given type cannot containt @big_map@ values
 bigMapAbsense :: Sing (t :: T) -> Maybe (Dict $ HasNoBigMap t)
 bigMapAbsense s = case checkBigMapPresence s of
   BigMapPresent -> Nothing
   BigMapAbsent -> Just Dict
 
--- | Check at runtime that the given type does not contain nested 'TBigMap'
+-- | Check at runtime that a value of the given type cannot contain nested @big_map@s.
 nestedBigMapsAbsense :: Sing (t :: T) -> Maybe (Dict $ HasNoNestedBigMaps t)
 nestedBigMapsAbsense s = case checkNestedBigMapsPresence s of
   NestedBigMapsPresent -> Nothing
@@ -569,40 +681,49 @@
   | BtHasBigMap
   | BtHasNestedBigMap
   | BtHasContract
+  | BtHasTicket
   deriving stock (Show, Eq, Generic)
   deriving anyclass (NFData)
 
 instance Buildable BadTypeForScope where
-  build = \case
+  build = buildRenderDoc
+
+instance RenderDoc BadTypeForScope where
+  renderDoc _ = \case
     BtNotComparable -> "is not comparable"
     BtIsOperation -> "has 'operation' type"
     BtHasBigMap -> "has 'big_map'"
     BtHasNestedBigMap -> "has nested 'big_map'"
     BtHasContract -> "has 'contract' type"
+    BtHasTicket -> "has 'ticket' type"
 
 -- | Set of constraints that Michelson applies to parameters.
 --
 -- Not just a type alias in order to be able to partially apply it
-class (KnownT t, HasNoOp t, HasNoNestedBigMaps t) => ParameterScope t
-instance (KnownT t, HasNoOp t, HasNoNestedBigMaps t) => ParameterScope t
+class (SingI t, HasNoOp t, HasNoNestedBigMaps t) => ParameterScope t
+instance (SingI t, HasNoOp t, HasNoNestedBigMaps t) => ParameterScope t
 
 -- | Set of constraints that Michelson applies to contract storage.
 --
 -- Not just a type alias in order to be able to partially apply it
-class (KnownT t, HasNoOp t, HasNoNestedBigMaps t, HasNoContract t) => StorageScope t
-instance (KnownT t, HasNoOp t, HasNoNestedBigMaps t, HasNoContract t) => StorageScope t
+class (SingI t, HasNoOp t, HasNoNestedBigMaps t, HasNoContract t) => StorageScope t
+instance (SingI t, HasNoOp t, HasNoNestedBigMaps t, HasNoContract t) => StorageScope t
 
 -- | Set of constraints that Michelson applies to pushed constants.
 --
 -- Not just a type alias in order to be able to partially apply it
-class (SingI t, HasNoOp t, HasNoBigMap t, HasNoContract t) => ConstantScope t
-instance (SingI t, HasNoOp t, HasNoBigMap t, HasNoContract t) => ConstantScope t
+class (SingI t, HasNoOp t, HasNoBigMap t, HasNoContract t, HasNoTicket t) => ConstantScope t
+instance (SingI t, HasNoOp t, HasNoBigMap t, HasNoContract t, HasNoTicket t) => ConstantScope t
 
+-- | Alias for constraints which Michelson requires in @DUP@ instruction.
+class (SingI t, HasNoTicket t) => DupableScope t
+instance (SingI t, HasNoTicket t) => DupableScope t
+
 -- | Set of constraints that Michelson applies to packed values.
 --
 -- Not just a type alias in order to be able to partially apply it
-class (SingI t, HasNoOp t, HasNoBigMap t) => PackedValScope t
-instance (SingI t, HasNoOp t, HasNoBigMap t) => PackedValScope t
+class (SingI t, HasNoOp t, HasNoBigMap t, HasNoTicket t) => PackedValScope t
+instance (SingI t, HasNoOp t, HasNoBigMap t, HasNoTicket t) => PackedValScope t
 
 -- | Set of constraints that Michelson applies to unpacked values.
 --
@@ -633,34 +754,43 @@
   checkScope = maybeToRight BtHasNestedBigMap $ nestedBigMapsAbsense sing
 instance SingI t => CheckScope (HasNoContract t) where
   checkScope = maybeToRight BtHasContract $ contractTypeAbsense sing
+instance SingI t => CheckScope (HasNoTicket t) where
+  checkScope = maybeToRight BtHasTicket $ ticketAbsense sing
 
-instance KnownT t => CheckScope (ParameterScope t) where
+instance SingI t => CheckScope (ParameterScope t) where
   checkScope =
     (\Dict Dict -> Dict)
       <$> checkScope @(HasNoOp t)
       <*> checkScope @(HasNoNestedBigMaps t)
 
-instance KnownT t => CheckScope (StorageScope t) where
+instance SingI t => CheckScope (StorageScope t) where
   checkScope =
     (\Dict Dict Dict -> Dict)
       <$> checkScope @(HasNoOp t)
       <*> checkScope @(HasNoNestedBigMaps t)
       <*> checkScope @(HasNoContract t)
 
-instance KnownT t => CheckScope (ConstantScope t) where
+instance SingI t => CheckScope (ConstantScope t) where
   checkScope =
-    (\Dict Dict Dict -> Dict)
+    (\Dict Dict Dict Dict -> Dict)
       <$> checkScope @(HasNoOp t)
       <*> checkScope @(HasNoBigMap t)
       <*> checkScope @(HasNoContract t)
+      <*> checkScope @(HasNoTicket t)
 
-instance KnownT t => CheckScope (PackedValScope t) where
+instance SingI t => CheckScope (DupableScope t) where
   checkScope =
-    (\Dict Dict -> Dict)
+    (\Dict -> Dict)
+      <$> checkScope @(HasNoTicket t)
+
+instance SingI t => CheckScope (PackedValScope t) where
+  checkScope =
+    (\Dict Dict Dict -> Dict)
       <$> checkScope @(HasNoOp t)
       <*> checkScope @(HasNoBigMap t)
+      <*> checkScope @(HasNoTicket t)
 
-instance KnownT t => CheckScope (UnpackedValScope t) where
+instance SingI t => CheckScope (UnpackedValScope t) where
   checkScope =
     (\Dict Dict -> Dict)
       <$> checkScope @(PackedValScope t)
@@ -702,6 +832,9 @@
 instance SingI a => WithDeMorganScope HasNoContract 'TPair a b where
   withDeMorganScope = mkWithDeMorgan @HasNoContract @a
 
+instance SingI a => WithDeMorganScope HasNoTicket 'TPair a b where
+  withDeMorganScope = mkWithDeMorgan @HasNoTicket @a
+
 instance SingI a => WithDeMorganScope HasNoBigMap 'TPair a b where
   withDeMorganScope = mkWithDeMorgan @HasNoBigMap @a
 
@@ -714,6 +847,9 @@
 instance SingI a => WithDeMorganScope HasNoContract 'TOr a b where
   withDeMorganScope = mkWithDeMorgan @HasNoContract @a
 
+instance SingI a => WithDeMorganScope HasNoTicket 'TOr a b where
+  withDeMorganScope = mkWithDeMorgan @HasNoTicket @a
+
 instance SingI a => WithDeMorganScope HasNoBigMap 'TOr a b where
   withDeMorganScope = mkWithDeMorgan @HasNoBigMap @a
 
@@ -729,7 +865,7 @@
 instance
   ( WithDeMorganScope HasNoOp t a b
   , WithDeMorganScope HasNoNestedBigMaps t a b
-  , KnownT a, KnownT b
+  , SingI a, SingI b
   ) => WithDeMorganScope ParameterScope t a b where
   withDeMorganScope f =
     withDeMorganScope @HasNoOp @t @a @b $
@@ -739,7 +875,7 @@
   ( WithDeMorganScope HasNoOp t a b
   , WithDeMorganScope HasNoNestedBigMaps t a b
   , WithDeMorganScope HasNoContract t a b
-  , KnownT a, KnownT b
+  , SingI a, SingI b
   ) => WithDeMorganScope StorageScope t a b where
   withDeMorganScope f =
     withDeMorganScope @HasNoOp @t @a @b $
@@ -750,26 +886,30 @@
   ( WithDeMorganScope HasNoOp t a b
   , WithDeMorganScope HasNoBigMap t a b
   , WithDeMorganScope HasNoContract t a b
-  , KnownT a, KnownT b
+  , WithDeMorganScope HasNoTicket t a b
+  , SingI a, SingI b
   ) => WithDeMorganScope ConstantScope t a b where
   withDeMorganScope f =
     withDeMorganScope @HasNoOp @t @a @b $
     withDeMorganScope @HasNoBigMap @t @a @b $
-    withDeMorganScope @HasNoContract @t @a @b f
+    withDeMorganScope @HasNoContract @t @a @b $
+    withDeMorganScope @HasNoTicket @t @a @b f
 
 instance
   ( WithDeMorganScope HasNoOp t a b
   , WithDeMorganScope HasNoBigMap t a b
-  , KnownT a, KnownT b
+  , WithDeMorganScope HasNoTicket t a b
+  , SingI a, SingI b
   ) => WithDeMorganScope PackedValScope t a b where
   withDeMorganScope f =
     withDeMorganScope @HasNoOp @t @a @b $
-    withDeMorganScope @HasNoBigMap @t @a @b f
+    withDeMorganScope @HasNoBigMap @t @a @b $
+    withDeMorganScope @HasNoTicket @t @a @b f
 
 instance
   ( WithDeMorganScope PackedValScope t a b
   , WithDeMorganScope ConstantScope t a b
-  , KnownT a, KnownT b
+  , SingI a, SingI b
   ) => WithDeMorganScope UnpackedValScope t a b where
   withDeMorganScope f =
     withDeMorganScope @PackedValScope @t @a @b $
@@ -783,16 +923,19 @@
 -}
 
 type ProperParameterBetterErrors t =
-  (KnownT t, ForbidOp t, ForbidNestedBigMaps t)
+  (SingI t, ForbidOp t, ForbidNestedBigMaps t)
 
 type ProperStorageBetterErrors t =
-  (KnownT t, ForbidOp t, ForbidNestedBigMaps t, ForbidContract t)
+  (SingI t, ForbidOp t, ForbidNestedBigMaps t, ForbidContract t)
 
 type ProperConstantBetterErrors t =
-  (SingI t, ForbidOp t, ForbidBigMap t, ForbidContract t)
+  (SingI t, ForbidOp t, ForbidBigMap t, ForbidContract t, ForbidTicket t)
 
+type ProperDupableBetterErrors t =
+  (SingI t, ForbidTicket t)
+
 type ProperPackedValBetterErrors t =
-  (SingI t, ForbidOp t, ForbidBigMap t)
+  (SingI t, ForbidOp t, ForbidBigMap t, ForbidTicket t)
 
 type ProperUnpackedValBetterErrors t =
   (ProperPackedValBetterErrors t, ProperConstantBetterErrors t)
@@ -816,11 +959,17 @@
   Dict \\ forbiddenOpEvi @t
        \\ forbiddenBigMapEvi @t
        \\ forbiddenContractTypeEvi @t
+       \\ forbiddenTicketTypeEvi @t
 
+properDupableEvi :: forall t. ProperDupableBetterErrors t :- DupableScope t
+properDupableEvi = Sub $
+  Dict \\ forbiddenTicketTypeEvi @t
+
 properPackedValEvi :: forall t. ProperPackedValBetterErrors t :- PackedValScope t
 properPackedValEvi = Sub $
   Dict \\ forbiddenOpEvi @t
        \\ forbiddenBigMapEvi @t
+       \\ forbiddenTicketTypeEvi @t
 
 properUnpackedValEvi :: forall t. ProperUnpackedValBetterErrors t :- UnpackedValScope t
 properUnpackedValEvi = Sub $
diff --git a/src/Michelson/Typed/Sing.hs b/src/Michelson/Typed/Sing.hs
--- a/src/Michelson/Typed/Sing.hs
+++ b/src/Michelson/Typed/Sing.hs
@@ -2,6 +2,8 @@
 --
 -- SPDX-License-Identifier: LicenseRef-MIT-TQ
 
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# OPTIONS_GHC -Wno-unused-top-binds #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 -- | Module, providing singleton boilerplate for
@@ -14,224 +16,80 @@
 
 module Michelson.Typed.Sing
   ( SingT (..)
-  , KnownT
-  , withSomeSingT
-  , fromSingT
+  , castSingE
+  , castM
+  , eqP
+  , requireEq
   ) where
 
-import Data.Singletons (Sing, SingI(..), SingKind(..), SomeSing(..))
+import Data.Type.Equality ((:~:)(..))
+import Data.Singletons (Demote, KindOf, SingI(..), demote)
+import Data.Singletons.TH (genSingletons, singDecideInstance)
+import Data.Singletons.TH.Options (Options(..), defaultOptions, withOptions)
+import Language.Haskell.TH (Name, mkName, nameBase)
 
+import Fmt ((+||), (||+))
 import Michelson.Typed.T (T(..))
-
+import Util.Sing (SingI1(..), castSing, eqI)
 
--- | Instance of data family 'Sing' for 'T'.
--- Custom instance is implemented in order to inject 'Typeable'
--- constraint for some of constructors.
-data SingT :: T -> Type where
-  STKey :: SingT  'TKey
-  STUnit :: SingT  'TUnit
-  STSignature :: SingT  'TSignature
-  STChainId :: SingT  'TChainId
-  STOption :: KnownT a => Sing a -> SingT ( 'TOption a)
-  STList :: KnownT a => Sing a -> SingT ( 'TList a )
-  STSet :: KnownT a => Sing a -> SingT ( 'TSet a )
-  STOperation  :: SingT 'TOperation
-  STContract   :: (KnownT a)
-               => Sing a -> SingT ( 'TContract a )
-  STPair       :: (KnownT a, KnownT b)
-               => Sing a -> Sing b -> SingT ('TPair a b)
-  STOr         :: (KnownT a, KnownT b)
-               => Sing a -> Sing b -> SingT ('TOr a b)
-  STLambda     :: (KnownT a, KnownT b)
-               => Sing a -> Sing b -> SingT ('TLambda a b)
-  STMap        :: (KnownT a, KnownT b)
-               => Sing a -> Sing b -> SingT ('TMap a b)
-  STBigMap     :: (KnownT a, KnownT b)
-               => Sing a -> Sing b -> SingT ('TBigMap a b)
-  STInt :: SingT  'TInt
-  STNat :: SingT  'TNat
-  STString :: SingT  'TString
-  STBytes :: SingT  'TBytes
-  STMutez :: SingT  'TMutez
-  STBool :: SingT  'TBool
-  STKeyHash :: SingT  'TKeyHash
-  STBls12381Fr :: SingT  'TBls12381Fr
-  STBls12381G1 :: SingT  'TBls12381G1
-  STBls12381G2 :: SingT  'TBls12381G2
-  STTimestamp :: SingT  'TTimestamp
-  STAddress :: SingT  'TAddress
-  STNever :: SingT  'TNever
+-- | 'SingI' and 'SDecide' instances for the 'T' kind.
+$(let singPrefix, sPrefix :: Name -> Name
+      singPrefix nm = mkName ("Sing" ++ nameBase nm)
+      sPrefix nm = mkName ("S" ++ nameBase nm) in
 
-type instance Sing = SingT
+  withOptions defaultOptions{singledDataConName = sPrefix, singledDataTypeName = singPrefix} $
+  concat <$> sequence [genSingletons [''T], singDecideInstance ''T]
+  )
 
 ---------------------------------------------
--- Singleton-related helpers for T
+-- 'withSingI' usage
 --------------------------------------------
 
--- | 'Typeable' + 'SingI' constraints.
---
--- This restricts a type to be a constructible type of 'T' kind.
-class (Typeable t, SingI t) => KnownT (t :: T)
-instance (Typeable t, SingI t) => KnownT t
+-- | Previously, we were using 'SingI' constraints in 'SingT'
+-- constructors. That was not so optimal because we have been
+-- spending too much space at runtime. Instead of that, we process
+-- values of 'SingT' using the function 'withSingI' in those places
+-- where the 'SingI' constraint is required. 'withSingI' allows one
+-- to create the 'SingI' context for a given 'Sing'.
 
--- | Version of 'SomeSing' with 'Typeable' constraint,
--- specialized for use with 'T' kind.
-data SomeSingT where
-  SomeSingT :: forall (a :: T). (KnownT a)
-            => Sing a -> SomeSingT
+---------------------------------------------
+-- Singleton-related helpers for T
+----------------------------------------------
+instance SingI1 'TList where
+  withSingI1 x = x
 
--- | Version of 'withSomeSing' with 'Typeable' constraint
--- provided to processing function.
---
--- Required for not to erase these useful constraints when doing
--- conversion from value of type 'T' to its singleton representation.
-withSomeSingT
-  :: T
-  -> (forall (a :: T). (KnownT a) => Sing a -> r)
-  -> r
-withSomeSingT t f = (\(SomeSingT s) -> f s) (toSingT t)
+instance SingI k => SingI1 ('TMap k) where
+  withSingI1 x = x
 
--- | Version of 'fromSing' specialized for use with
--- @data instance Sing :: T -> Type@ which requires 'Typeable'
--- constraint for some of its constructors
-fromSingT :: Sing (a :: T) -> T
-fromSingT = \case
-  STKey -> TKey
-  STUnit -> TUnit
-  STSignature -> TSignature
-  STChainId -> TChainId
-  STOption t -> TOption (fromSingT t)
-  STList t -> TList (fromSingT t)
-  STSet t -> TSet (fromSingT t)
-  STOperation -> TOperation
-  STContract t -> TContract (fromSingT t)
-  STPair a b -> TPair (fromSingT a) (fromSingT b)
-  STOr a b -> TOr (fromSingT a) (fromSingT b)
-  STLambda a b -> TLambda (fromSingT a) (fromSingT b)
-  STMap a b -> TMap (fromSingT a) (fromSingT b)
-  STBigMap a b -> TBigMap (fromSingT a) (fromSingT b)
-  STInt -> TInt
-  STNat -> TNat
-  STString -> TString
-  STBytes -> TBytes
-  STMutez -> TMutez
-  STBool -> TBool
-  STKeyHash -> TKeyHash
-  STBls12381Fr -> TBls12381Fr
-  STBls12381G1 -> TBls12381G1
-  STBls12381G2 -> TBls12381G2
-  STTimestamp -> TTimestamp
-  STAddress -> TAddress
-  STNever -> TNever
+castSingE
+  :: forall (a :: T) (b :: T) t. (SingI a, SingI b)
+  => t a -> Either Text (t b)
+castSingE = maybeToRight errMsg . castSing
+  where
+    errMsg = "Type mismatch: expected " +|| demote @a ||+
+                               ", got " +|| demote @b ||+ ""
 
--- | Version of 'toSing' which creates 'SomeSingT'.
-toSingT :: T -> SomeSingT
-toSingT = \case
-  TKey -> SomeSingT STKey
-  TUnit -> SomeSingT STUnit
-  TSignature -> SomeSingT STSignature
-  TChainId -> SomeSingT STChainId
-  TOption t -> withSomeSingT t $ \tSing -> SomeSingT $ STOption tSing
-  TList t -> withSomeSingT t $ \tSing -> SomeSingT $ STList tSing
-  TSet ct -> withSomeSingT ct $ \ctSing -> SomeSingT $ STSet ctSing
-  TOperation -> SomeSingT STOperation
-  TContract t -> withSomeSingT t $ \tSing -> SomeSingT $ STContract tSing
-  TPair l r ->
-    withSomeSingT l $ \lSing ->
-    withSomeSingT r $ \rSing ->
-      SomeSingT $ STPair lSing rSing
-  TOr l r ->
-    withSomeSingT l $ \lSing ->
-    withSomeSingT r $ \rSing ->
-      SomeSingT $ STOr lSing rSing
-  TLambda l r ->
-    withSomeSingT l $ \lSing ->
-    withSomeSingT r $ \rSing ->
-      SomeSingT $ STLambda lSing rSing
-  TMap l r ->
-    withSomeSingT l $ \lSing ->
-    withSomeSingT r $ \rSing ->
-      SomeSingT $ STMap lSing rSing
-  TBigMap l r ->
-    withSomeSingT l $ \lSing ->
-    withSomeSingT r $ \rSing ->
-      SomeSingT $ STBigMap lSing rSing
-  TInt -> SomeSingT STInt
-  TNat -> SomeSingT STNat
-  TString -> SomeSingT STString
-  TBytes -> SomeSingT STBytes
-  TMutez -> SomeSingT STMutez
-  TBool -> SomeSingT STBool
-  TKeyHash -> SomeSingT STKeyHash
-  TBls12381Fr -> SomeSingT STBls12381Fr
-  TBls12381G1 -> SomeSingT STBls12381G1
-  TBls12381G2 -> SomeSingT STBls12381G2
-  TTimestamp -> SomeSingT STTimestamp
-  TAddress -> SomeSingT STAddress
-  TNever -> SomeSingT STNever
+-- | Monadic version of 'castSing'.
+-- Throws an error using the given function if the cast fails.
+castM
+  :: forall (a :: T) (b :: T) t m. (SingI a, SingI b, Monad m)
+  => t a
+  -> (forall x. Demote (KindOf a) -> Demote (KindOf b) -> m x)
+  -> m (t b)
+castM a throwErr =
+  requireEq @a @b throwErr <&> \Refl -> a
 
-instance SingKind T where
-  type Demote T = T
-  fromSing  = fromSingT
-  toSing t = case toSingT t of SomeSingT s -> SomeSing s
+-- | Monadic version of 'eqI'.
+-- Throws an error using the given function if the two types are not equal.
+requireEq
+  :: forall (a :: T) (b :: T) m. (SingI a, SingI b, Monad m)
+  => (forall x. Demote (KindOf a) -> Demote (KindOf b) -> m x)
+  -> m (a :~: b)
+requireEq throwErr =
+  case eqI @a @b of
+    Just p -> pure p
+    Nothing -> throwErr (demote @a) (demote @b)
 
-instance SingI  'TKey where
-  sing = STKey
-instance SingI  'TUnit where
-  sing = STUnit
-instance SingI  'TSignature where
-  sing = STSignature
-instance SingI  'TChainId where
-  sing = STChainId
-instance SingI  'TNever where
-  sing = STNever
-instance (KnownT a) => SingI ( 'TOption (a :: T)) where
-  sing = STOption sing
-instance (KnownT a) => SingI ( 'TList (a :: T)) where
-  sing = STList sing
-instance (KnownT a) => SingI ( 'TSet (a :: T)) where
-  sing = STSet sing
-instance SingI 'TOperation where
-  sing = STOperation
-instance (KnownT a) =>
-          SingI ( 'TContract (a :: T)) where
-  sing = STContract sing
-instance (KnownT a, KnownT b) =>
-          SingI ( 'TPair a b) where
-  sing = STPair sing sing
-instance (KnownT a, KnownT b) =>
-          SingI ( 'TOr a b) where
-  sing = STOr sing sing
-instance (KnownT a, KnownT b) =>
-          SingI ( 'TLambda a b) where
-  sing = STLambda sing sing
-instance (KnownT a, KnownT b) =>
-          SingI ( 'TMap a b) where
-  sing = STMap sing sing
-instance (KnownT a, KnownT b) =>
-          SingI ( 'TBigMap a b) where
-  sing = STBigMap sing sing
-instance SingI  'TInt where
-  sing = STInt
-instance SingI  'TNat where
-  sing = STNat
-instance SingI  'TString where
-  sing = STString
-instance SingI  'TBytes where
-  sing = STBytes
-instance SingI  'TMutez where
-  sing = STMutez
-instance SingI  'TBool where
-  sing = STBool
-instance SingI  'TKeyHash where
-  sing = STKeyHash
-instance SingI  'TBls12381Fr where
-  sing = STBls12381Fr
-instance SingI  'TBls12381G1 where
-  sing = STBls12381G1
-instance SingI  'TBls12381G2 where
-  sing = STBls12381G2
-instance SingI  'TTimestamp where
-  sing = STTimestamp
-instance SingI  'TAddress where
-  sing = STAddress
+-- | Version of 'eqI' that uses 'Proxy'
+eqP :: forall (a :: T) (b :: T). (SingI a, SingI b) => Proxy a -> Proxy b -> Maybe (a :~: b)
+eqP _ _ = eqI @a @b
diff --git a/src/Michelson/Typed/T.hs b/src/Michelson/Typed/T.hs
--- a/src/Michelson/Typed/T.hs
+++ b/src/Michelson/Typed/T.hs
@@ -13,6 +13,7 @@
 import Fmt (Buildable(..), Builder, listF)
 import qualified Michelson.Untyped.Annotation as Un
 import qualified Michelson.Untyped.Type as Un
+import Michelson.Printer.Util (RenderDoc (..))
 
 -- | Michelson language type with annotations stripped off.
 data T =
@@ -25,6 +26,7 @@
   | TSet T
   | TOperation
   | TContract T
+  | TTicket T
   | TPair T T
   | TOr T T
   | TLambda T T
@@ -74,6 +76,7 @@
     convert (TSet a) = Un.TSet $ Un.Ty (Un.unwrapT $ toUType a) Un.noAnn
     convert (TOperation) = Un.TOperation
     convert (TContract a) = Un.TContract (toUType a)
+    convert (TTicket a) = Un.TTicket (toUType a)
     convert (TPair a b) =
       Un.TPair Un.noAnn Un.noAnn Un.noAnn Un.noAnn (toUType a) (toUType b)
     convert (TOr a b) =
@@ -87,6 +90,9 @@
 
 instance Buildable T where
   build = build . toUType
+
+instance RenderDoc T where
+  renderDoc context = renderDoc context . toUType
 
 -- | Format type stack in a pretty way.
 buildStack :: [T] -> Builder
diff --git a/src/Michelson/Typed/Util.hs b/src/Michelson/Typed/Util.hs
--- a/src/Michelson/Typed/Util.hs
+++ b/src/Michelson/Typed/Util.hs
@@ -17,9 +17,10 @@
   , linearizeLeftDeep
 
   -- * Value analysis
-  , dfsValue
-  , dfsFoldValue
-  , dfsModifyValue
+  , dfsFoldMapValue
+  , dfsFoldMapValueM
+  , dfsMapValue
+  , dfsTraverseValue
   , isStringValue
   , isBytesValue
   , allAtomicValues
@@ -31,9 +32,9 @@
 
 import Prelude hiding (Ordering(..))
 
+import Control.Monad.Writer.Strict (execWriterT, runWriter, tell, writer)
 import Data.Constraint (Dict(..))
 import Data.Default (Default(..))
-import qualified Data.Foldable as F
 import qualified Data.Map as M
 import qualified Data.Set as S
 import qualified Text.Show
@@ -105,6 +106,7 @@
     FrameInstr p i1 -> recursion1 (FrameInstr p) i1
     Nested i1 -> recursion1 Nested i1
     DocGroup dg i1 -> recursion1 (DocGroup dg) i1
+    Fn t sfn i1 -> recursion1 (Fn t sfn) i1
     IF_NONE i1 i2 -> recursion2 IF_NONE i1 i2
     IF_LEFT i1 i2 -> recursion2 IF_LEFT i1 i2
     IF_CONS i1 i2 -> recursion2 IF_CONS i1 i2
@@ -129,13 +131,13 @@
             VLam lambda -> bimap (VLam . analyzeInstrFailure) Just $
               dfsInstr settings step (rfAnyInstr lambda)
             otherV -> (otherV, Nothing)
-        -- Note that @dfsValue@ does not respect 'CtorEffectsApp',
+        -- Note that @dfsTraverseValue@ does not respect 'CtorEffectsApp',
         -- so if we encounter a value that contains more than one lambda
         -- this function may misbehave.
         -- That's very unlikely in practice.
-        -- In #264 we will support this feature in @dfsValue@.
+        -- In #264 we will support this feature in @dfsTraverseValue@.
         let
-          (innerV, innerXMaybe) = dfsValue valueStep v
+          (innerV, innerXMaybe) = runWriter $ dfsTraverseValue (writer . valueStep) v
 
         innerX <- innerXMaybe
         let (outerI, outerX) = step $ PUSH innerV
@@ -168,6 +170,7 @@
     NONE{} -> step i
     UNIT{} -> step i
     AnnPAIR{} -> step i
+    AnnUNPAIR{} -> step i
     PAIRN{} -> step i
     UNPAIRN{} -> step i
     AnnLEFT{} -> step i
@@ -240,6 +243,10 @@
     LEVEL{} -> step i
     SELF_ADDRESS{} -> step i
     NEVER{} -> step i
+    TICKET{} -> step i
+    READ_TICKET{} -> step i
+    SPLIT_TICKET{} -> step i
+    JOIN_TICKETS{} -> step i
   where
     recursion1 ::
       forall a b c d. (Instr a b -> Instr c d) -> Instr a b -> (Instr c d, x)
@@ -328,6 +335,7 @@
     Ext e -> RfNormal (Ext e)
     Nested i -> Nested `rfMapAnyInstr` go i
     DocGroup g i -> DocGroup g `rfMapAnyInstr` go i
+    Fn t sfn i -> Fn t sfn `rfMapAnyInstr` go i
 
     IF_NONE l r -> rfMerge IF_NONE (go l) (go r)
     IF_LEFT l r -> rfMerge IF_LEFT (go l) (go r)
@@ -356,6 +364,7 @@
     i@NONE{} -> RfNormal i
     i@UNIT{} -> RfNormal i
     i@AnnPAIR{} -> RfNormal i
+    i@AnnUNPAIR{} -> RfNormal i
     i@PAIRN{} -> RfNormal i
     i@UNPAIRN{} -> RfNormal i
     i@AnnLEFT{} -> RfNormal i
@@ -429,6 +438,10 @@
     i@LEVEL -> RfNormal i
     i@SELF_ADDRESS -> RfNormal i
     NEVER -> RfAlwaysFails NEVER
+    i@TICKET -> RfNormal i
+    i@READ_TICKET -> RfNormal i
+    i@SPLIT_TICKET -> RfNormal i
+    i@JOIN_TICKETS -> RfNormal i
 
 -- | There are many ways to represent a sequence of more than 2 instructions.
 -- E. g. for @i1; i2; i3@ it can be @Seq i1 $ Seq i2 i3@ or @Seq (Seq i1 i2) i3@.
@@ -470,13 +483,21 @@
 ----------------------------------------------------------------------------
 
 -- | Traverse a value in depth-first order.
-dfsValue ::
-     forall t x.
-     Monoid x
-  => (forall t'. Value t' -> (Value t', x))
+dfsMapValue ::
+     forall t.
+     (forall t'. Value t' -> Value t')
   -> Value t
-  -> (Value t, x)
-dfsValue step i = case i of
+  -> Value t
+dfsMapValue step v = runIdentity $ dfsTraverseValue (pure . step) v
+
+-- | Traverse a value in depth-first order.
+dfsTraverseValue ::
+     forall t m.
+     (Monad m)
+  => (forall t'. Value t' -> m (Value t'))
+  -> Value t
+  -> m (Value t)
+dfsTraverseValue step i = case i of
   -- Atomic
   VKey{} -> step i
   VUnit -> step i
@@ -484,6 +505,7 @@
   VChainId{} -> step i
   VOp{} -> step i
   VContract{} -> step i
+  VTicket{} -> step i  -- cannot appear as constant in a contract
   VLam{} -> step i
   VInt{} -> step i
   VNat{} -> step i
@@ -502,81 +524,70 @@
   VOption mVal -> case mVal of
     Nothing -> step i
     Just val -> recursion1 (VOption . Just) val
-  VList vals ->
-    let
-      (vs, xs) = unzip $ map (dfsValue step) vals
-      (v, x) = step $ VList vs
-    in
-      (v, x <> F.fold xs)
-  VSet vals ->
-    let
-      (cs, cxs) =
-        S.foldr (\a (s, xs) -> let (c, x) = step a in (S.insert c s, x <> xs))
-        (S.empty, mempty) vals
-      (v, vx) = step (VSet cs)
-    in (v, vx <> cxs)
-  VPair (v1, v2) -> recursion2 (curry VPair) v1 v2
+  VList vals -> do
+    vs <- traverse (dfsTraverseValue step) vals
+    step $ VList vs
+  VSet vals -> do
+    cs <- S.fromList <$> traverse (dfsTraverseValue step) (S.toList vals)
+    step (VSet cs)
+  VPair (v1, v2) -> do
+    v1' <- dfsTraverseValue step v1
+    v2' <- dfsTraverseValue step v2
+    step $ VPair (v1', v2')
   VOr vEither -> case vEither of
     Left v -> recursion1 (VOr . Left) v
     Right v -> recursion1 (VOr . Right) v
   VMap vmap -> mapRecursion VMap vmap
-  VBigMap vmap -> mapRecursion VBigMap vmap
+  VBigMap bmId vmap -> mapRecursion (VBigMap bmId) vmap
   where
     recursion1 ::
          forall t'.
          (Value t' -> Value t)
       -> Value t'
-      -> (Value t, x)
-    recursion1 constructor i' =
-      let
-        (v, x) = dfsValue step i'
-        (v', x') = step $ constructor v
-      in
-        (v', x <> x')
-    recursion2 ::
-         forall t1 t2.
-         (Value t1 -> Value t2 -> Value t)
-      -> Value t1
-      -> Value t2
-      -> (Value t, x)
-    recursion2 constructor i1 i2 =
-      let
-        (v1, x1) = dfsValue step i1
-        (v2, x2) = dfsValue step i2
-        (v, x) = step $ constructor v1 v2
-      in
-        (v, x1 <> x2 <> x)
+      -> m (Value t)
+    recursion1 constructor v = do
+      v' <- dfsTraverseValue step v
+      step $ constructor v'
 
     mapRecursion
-      :: forall t' k. Comparable k
-      => (M.Map (Value k) (Value t') -> Value t)
-      -> M.Map (Value k) (Value t')
-      -> (Value t, x)
-    mapRecursion constructor vmap =
-      let
-        (ms, cxs) = M.foldrWithKey (\k a (m, xs) ->
-            let (c, cx) = step k
-                (v, vx) = dfsValue step a
-            in (M.insert c v m, vx <> cx <> xs)) (M.empty, mempty) vmap
-        (v', x') = step $ constructor ms
-      in
-        (v', cxs <> x')
+      :: forall k v. Comparable k
+      => (M.Map (Value k) (Value v) -> Value t)
+      -> M.Map (Value k) (Value v)
+      -> m (Value t)
+    mapRecursion constructor vmap = do
+      vmap' <-
+        M.fromList <$> forM (M.toList vmap) \(k, v) -> do
+          k' <- dfsTraverseValue step k
+          v' <- dfsTraverseValue step v
+          pure (k', v')
+      step $ constructor vmap'
 
--- | Specialization of 'dfsValue' for case when changing the value is
+-- | Specialization of 'dfsMapValue' for case when changing the value is
 -- not required.
-dfsFoldValue ::
+dfsFoldMapValue ::
   Monoid x =>
   (forall t'. Value t' -> x)
   -> Value t
   -> x
-dfsFoldValue f = snd . dfsValue (\v -> (v, f v))
+dfsFoldMapValue step v =
+  runIdentity $ dfsFoldMapValueM (pure . step) v
 
--- | Specialization of 'dfsValue' which only modifies given value.
-dfsModifyValue ::
-  (forall t'. Value t' -> Value t')
-  -> Value t
+-- | Specialization of 'dfsMapValue' for case when changing the value is
+-- not required.
+dfsFoldMapValueM
+  :: (Monoid x, Monad m)
+  => (forall t'. Value t' -> m x)
   -> Value t
-dfsModifyValue f = fst . dfsValue ((, ()) . f)
+  -> m x
+dfsFoldMapValueM step v = do
+  execWriterT $
+    dfsTraverseValue
+      (\val -> do
+          x <- lift $ step val
+          tell x
+          pure val
+      )
+      v
 
 -- | If value is a string, return the stored string.
 isStringValue :: Value t -> Maybe MText
@@ -597,7 +608,7 @@
 -- values in a list.
 allAtomicValues ::
   forall t a. (forall t'. Value t' -> Maybe a) -> Value t -> [a]
-allAtomicValues selector = dfsFoldValue (maybeToList . selector)
+allAtomicValues selector = dfsFoldMapValue (maybeToList . selector)
 
 
 --------------------------------------------------------------------------------
@@ -630,18 +641,19 @@
     => Instr s (st ': s)
     -> PushableStorageSplit s st
 
-  -- | The type of the storage and part of its value (here @bms@) contain one or
-  -- more @big_map@s. The instruction can take the non-pushable 'Value bms' and
-  -- reconstruct the original 'Value st' without using any 'EMPTY_BIG_MAP'.
+  -- | The type of the storage and part of its value (here @heavy@) contain one or
+  -- more @big_map@s or @ticket@s. The instruction can take the non-pushable
+  -- 'Value heavy' and reconstruct the original 'Value st' without using any
+  -- 'EMPTY_BIG_MAP'.
   PartlyPushableStorage
-    :: (StorageScope bms, StorageScope st)
-    => Value bms -> Instr (bms ': s) (st ': s)
+    :: (StorageScope heavy, StorageScope st)
+    => Value heavy -> Instr (heavy ': s) (st ': s)
     -> PushableStorageSplit s st
 
 -- | Splits the given storage 'Value' into a 'PushableStorageSplit'.
 --
 -- This is based off the fact that the only storages that cannot be directly
--- 'PUSH'ed are the ones that contain 'BigMap's.
+-- 'PUSH'ed are the ones that contain 'BigMap's and tickets.
 -- See difference between 'StorageScope' and 'ConstantScope'.
 --
 -- So what we do here is to create a 'Value' as small as possible with all the
@@ -670,9 +682,10 @@
   VBls12381G2{} -> ConstantStorage v
   VTimestamp{}  -> ConstantStorage v
   VAddress{}    -> ConstantStorage v
+  VTicket{}     -> PartlyPushableStorage v Nop
 
   -- Non-atomic
-  VOption (Nothing :: Maybe (Value tm)) -> case checkScope @(HasNoBigMap tm) of
+  VOption (Nothing :: Maybe (Value tm)) -> case checkScope @(ConstantScope tm) of
     Right Dict -> ConstantStorage $ VOption Nothing
     Left _     -> PushableValueStorage $ NONE
   VOption (Just jVal :: Maybe (Value tm)) -> case splitPushableStorage jVal of
@@ -680,7 +693,7 @@
     PushableValueStorage instr -> PushableValueStorage $ instr `Seq` SOME
     PartlyPushableStorage val instr -> PartlyPushableStorage val $ instr `Seq` SOME
 
-  VList (vals :: [Value tl]) -> case checkScope @(HasNoBigMap tl) of
+  VList (vals :: [Value tl]) -> case checkScope @(ConstantScope tl) of
     Right Dict -> ConstantStorage v
     Left _     ->
       -- Here we check that even tho the type contains big_maps, we actually
@@ -730,7 +743,7 @@
   VOr (Left orVal :: Either (Value t1) (Value t2)) ->
     withValueTypeSanity orVal $ withDeMorganScope @StorageScope @'T.TOr @t1 @t2 $
       case splitPushableStorage orVal of
-        ConstantStorage val -> case checkScope @(HasNoBigMap t2) of
+        ConstantStorage val -> case checkScope @(ConstantScope t2) of
           -- note: here we need to check for the opposite branch too
           Right Dict -> ConstantStorage v
           Left _ -> PushableValueStorage $ PUSH val `Seq` LEFT
@@ -739,7 +752,7 @@
   VOr (Right orVal :: Either (Value t1) (Value t2)) ->
     withValueTypeSanity orVal $ withDeMorganScope @StorageScope @'T.TOr @t1 @t2 $
       case splitPushableStorage orVal of
-        ConstantStorage val -> case checkScope @(HasNoBigMap t1) of
+        ConstantStorage val -> case checkScope @(ConstantScope t1) of
           -- note: here we need to check for the opposite branch too
           Right Dict -> ConstantStorage v
           Left _ -> PushableValueStorage $ PUSH val `Seq` RIGHT
@@ -754,7 +767,7 @@
       -- enforced in the type system as well, but it may have more
       -- downsides than it's worth accepting.
       error "impossible: all map keys should be PUSHable"
-    Right Dict -> case checkScope @(HasNoBigMap tv) of
+    Right Dict -> case checkScope @(ConstantScope tv) of
       Right Dict -> ConstantStorage v
       _ -> withDeMorganScope @HasNoOp @'T.TMap @tk @tv $
         -- Similarly as for lists, here we check that even tho the value type
@@ -771,4 +784,4 @@
         in  maybe (PartlyPushableStorage v Nop) PushableValueStorage $
               foldM handleMap EMPTY_MAP $ M.toList vMap
 
-  VBigMap _ -> PartlyPushableStorage v Nop
+  VBigMap _ _ -> PartlyPushableStorage v Nop
diff --git a/src/Michelson/Typed/Value.hs b/src/Michelson/Typed/Value.hs
--- a/src/Michelson/Typed/Value.hs
+++ b/src/Michelson/Typed/Value.hs
@@ -7,9 +7,7 @@
 -- | Module, containing data types for Michelson value.
 
 module Michelson.Typed.Value
-  ( SomeValue' (..)
-  , SomeConstrainedValue' (..)
-  , Comparability (..)
+  ( Comparability (..)
   , Comparable
   , ComparabilityScope
   , ContractInp1
@@ -38,21 +36,21 @@
   ) where
 
 import Data.Constraint (Dict(..), (\\))
-import Data.Singletons (Sing, SingI(..))
+import Data.Singletons (Sing)
 import Data.Type.Bool (type (&&))
 import Fmt (Buildable(build), Builder, (+|), (|+))
 import GHC.TypeLits (ErrorMessage(..), TypeError)
 
 import Michelson.Text (MText)
 import Michelson.Typed.Entrypoints
-import Michelson.Typed.Scope (BadTypeForScope(..), CheckScope(..), ParameterScope, StorageScope)
+import Michelson.Typed.Scope
 import Michelson.Typed.Sing
 import Michelson.Typed.T (T(..))
 import Tezos.Address (Address)
 import Tezos.Core (ChainId, Mutez, Timestamp)
 import Tezos.Crypto (Bls12381Fr, Bls12381G1, Bls12381G2, KeyHash, PublicKey, Signature)
+import Util.Sing (eqParamSing, eqParamSing3)
 import Util.TH
-import Util.Typeable
 
 -- | Data type, representing operation, list of which is returned
 -- by Michelson contract (according to calling convention).
@@ -82,11 +80,11 @@
 
 instance Eq (Operation' instr) where
   op1 == op2 = case (op1, op2) of
-    (OpTransferTokens tt1, OpTransferTokens tt2) -> eqParam1 tt1 tt2
+    (OpTransferTokens tt1, OpTransferTokens tt2) -> tt1 `eqParamSing` tt2
     (OpTransferTokens _, _) -> False
     (OpSetDelegate sd1, OpSetDelegate sd2) -> sd1 == sd2
     (OpSetDelegate _, _) -> False
-    (OpCreateContract cc1, OpCreateContract cc2) -> eqParam3 cc1 cc2
+    (OpCreateContract cc1, OpCreateContract cc2) -> cc1 `eqParamSing3` cc2
     (OpCreateContract _, _) -> False
 
 data TransferTokens instr p = TransferTokens
@@ -200,6 +198,7 @@
   IsComparable ('TSet _) = 'False
   IsComparable 'TOperation = 'False
   IsComparable ('TContract _) = 'False
+  IsComparable ('TTicket _) = 'False
   IsComparable ('TOr a b) = IsComparable a && IsComparable b
   IsComparable ('TLambda _ _) = 'False
   IsComparable ('TMap _ _) = 'False
@@ -255,7 +254,7 @@
 
 -- | Alias for comparable types.
 type ComparabilityScope t =
-  (KnownT t, Comparable t)
+  (SingI t, Comparable t)
 
 data Comparability t where
   CanBeCompared :: (Comparable t) => Comparability t
@@ -278,6 +277,7 @@
   STSet _ -> CannotBeCompared
   STOperation -> CannotBeCompared
   STContract _ -> CannotBeCompared
+  STTicket _ -> CannotBeCompared
   STLambda _ _ -> CannotBeCompared
   STMap _ _ -> CannotBeCompared
   STBigMap _ _ -> CannotBeCompared
@@ -307,7 +307,7 @@
 instance SingI t => CheckScope (Comparable t) where
   checkScope = maybeToRight BtNotComparable $ comparabilityPresence sing
 
-instance (KnownT t) => CheckScope (ComparabilityScope t) where
+instance (SingI t) => CheckScope (ComparabilityScope t) where
   checkScope =
     (\Dict -> Dict) <$> checkScope @(Comparable t)
 
@@ -323,31 +323,36 @@
   VChainId :: ChainId -> Value' instr 'TChainId
   VOption
     :: forall t instr.
-       (KnownT t)
+       (SingI t)
     => Maybe (Value' instr t) -> Value' instr ('TOption t)
   VList
     :: forall t instr.
-       (KnownT t)
+       (SingI t)
     => [Value' instr t] -> Value' instr ('TList t)
   VSet
     :: forall t instr.
-       (KnownT t, Comparable t)
+       (SingI t, Comparable t)
     => Set (Value' instr t) -> Value' instr ('TSet t)
   VOp
     :: Operation' instr -> Value' instr 'TOperation
   VContract
     :: forall arg instr.
-       Address -> SomeEntrypointCallT arg -> Value' instr ('TContract arg)
+       (SingI arg, HasNoOp arg)
+    => Address -> SomeEntrypointCallT arg -> Value' instr ('TContract arg)
+  VTicket
+    :: forall arg instr.
+       (Comparable arg)
+    => Address -> Value' instr arg -> Natural -> Value' instr ('TTicket arg)
   VPair
     :: forall l r instr.
        (Value' instr l, Value' instr r) -> Value' instr ('TPair l r)
   VOr
     :: forall l r instr.
-       (KnownT l, KnownT r)
+       (SingI l, SingI r)
     => Either (Value' instr l) (Value' instr r) -> Value' instr ('TOr l r)
   VLam
     :: forall inp out instr.
-       ( KnownT inp, KnownT out
+       ( SingI inp, SingI out
        , forall i o. Show (instr i o)
        , forall i o. Eq (instr i o)
        , forall i o. NFData (instr i o)
@@ -355,12 +360,14 @@
     => RemFail instr (inp ': '[]) (out ': '[]) -> Value' instr ('TLambda inp out)
   VMap
     :: forall k v instr.
-       (KnownT k, KnownT v, Comparable k)
+       (SingI k, SingI v, Comparable k)
     => Map (Value' instr k) (Value' instr v) -> Value' instr ('TMap k v)
   VBigMap
     :: forall k v instr.
-       (KnownT k, KnownT v, Comparable k)
-    => Map (Value' instr k) (Value' instr v) -> Value' instr ('TBigMap k v)
+       (SingI k, SingI v, Comparable k, HasNoBigMap v)
+    => Maybe Natural -- ^ The big_map's ID. This is only used in the interpreter.
+    -> Map (Value' instr k) (Value' instr v)
+    -> Value' instr ('TBigMap k v)
   VInt       :: Integer ->  Value' instr 'TInt
   VNat       :: Natural -> Value' instr 'TNat
   VString    :: MText -> Value' instr 'TString
@@ -389,28 +396,6 @@
 buildVContract = \case
   VContract addr epc -> "Contract " +| addr |+ " call " +| epc |+ ""
 
-data SomeValue' instr where
-  SomeValue :: KnownT t => Value' instr t -> SomeValue' instr
-
-deriving stock instance Show (SomeValue' instr)
-
-instance Eq (SomeValue' instr) where
-  SomeValue v1 == SomeValue v2 = v1 `eqParam1` v2
-
-data SomeConstrainedValue' instr (c :: T -> Constraint) where
-  SomeConstrainedValue
-    :: forall (t :: T) (c :: T -> Constraint) instr
-    . (c t)
-    => Value' instr t
-    -> SomeConstrainedValue' instr c
-
-deriving stock instance Show (SomeConstrainedValue' instr c)
-
--- TODO
--- @gromak: perhaps we should implement `SomeValue'` in terms of
--- `SomeConstrainedValue'`, but it will require changing quite a lot of code,
--- so it is postponed.
-
 -- | Turn 'EpLiftSequence' into actual function on 'Value's.
 compileEpLiftSequence
   :: EpLiftSequence arg param
@@ -437,7 +422,7 @@
 -- type family Any :: T where
 --   -- nothing here
 -- @
-valueTypeSanity :: Value' instr t -> Dict (KnownT t)
+valueTypeSanity :: Value' instr t -> Dict (SingI t)
 valueTypeSanity = \case
   VKey{} -> Dict
   VUnit{} -> Dict
@@ -448,6 +433,8 @@
   VSet{} -> Dict
   VOp{} -> Dict
   VContract _ (SomeEpc EntrypointCall{}) -> Dict
+  VTicket _ v _ -> case valueTypeSanity v of
+    Dict -> Dict
   VPair (l, r) -> case (valueTypeSanity l, valueTypeSanity r) of
     (Dict, Dict) -> Dict
   VOr{} -> Dict
@@ -468,14 +455,14 @@
   VAddress{} -> Dict
 
 -- | Provide a witness of that value's type is known.
-withValueTypeSanity :: Value' instr t -> (KnownT t => a) -> a
+withValueTypeSanity :: Value' instr t -> (SingI t => a) -> a
 withValueTypeSanity v a = case valueTypeSanity v of Dict -> a
 
 -- | Extended values comparison - it does not require 'Value's to be
 -- of the same type, only their content to match.
 eqValueExt :: Value' instr t1 -> Value' instr t2 -> Bool
 eqValueExt v1 v2 =
-  v1 `eqParam1` v2
+  v1 `eqParamSing` v2
     \\ valueTypeSanity v1
     \\ valueTypeSanity v2
 
diff --git a/src/Michelson/Untyped/Annotation.hs b/src/Michelson/Untyped/Annotation.hs
--- a/src/Michelson/Untyped/Annotation.hs
+++ b/src/Michelson/Untyped/Annotation.hs
@@ -11,13 +11,17 @@
   , pattern WithAnn
 
   -- * Annotation Set
-  , AnnotationSet
+  , AnnotationSet(..)
+  , annsCount
   , emptyAnnSet
+  , firstAnn
   , fullAnnSet
   , isNoAnnSet
   , minAnnSetSize
+  , secondAnn
   , singleAnnSet
   , singleGroupAnnSet
+  , minimizeAnnSet
 
   -- * Rendering
   , KnownAnnTag(..)
@@ -36,7 +40,7 @@
   , varAnnQ
   , fieldAnnQ
   , typeAnnQ
-  , mkAnnotationUnsafe
+  , unsafeMkAnnotation
   , mkAnnotation
   , specialVarAnns
   , specialFieldAnn
@@ -58,11 +62,11 @@
 import Data.Typeable (eqT, (:~:)(..))
 import Fmt (Buildable(build))
 import Instances.TH.Lift ()
+import qualified Language.Haskell.TH as TH
 import Language.Haskell.TH.Lift (deriveLift)
+import qualified Language.Haskell.TH.Quote as TH
 import Text.PrettyPrint.Leijen.Text (Doc, hsep, textStrict, (<+>))
 import qualified Text.Show
-import qualified Language.Haskell.TH as TH
-import qualified Language.Haskell.TH.Quote as TH
 
 import Michelson.Printer.Util (RenderDoc(..), buildRenderDoc, doesntNeedParens, printDocS)
 import Util.Aeson
@@ -73,13 +77,13 @@
 -- (except for the first character, here parametrized in the type `tag`) the
 -- allowed character set is the one matching the following regexp:
 -- @%|@%%|%@|[@:%][_0-9a-zA-Z][_0-9a-zA-Z\.%@]*
-newtype Annotation tag = AnnotationUnsafe { unAnnotation :: Text }
+newtype Annotation tag = UnsafeAnnotation { unAnnotation :: Text }
   deriving stock (Eq, Data, Functor, Generic)
 
 instance NFData (Annotation tag)
 
 pattern Annotation :: Text -> Annotation tag
-pattern Annotation ann <- AnnotationUnsafe ann
+pattern Annotation ann <- UnsafeAnnotation ann
 
 {-# COMPLETE Annotation :: Annotation #-}
 
@@ -169,6 +173,34 @@
 trimEndNoAnn :: [Annotation tag] -> [Annotation tag]
 trimEndNoAnn = foldr (\a lst -> if null lst && a == noAnn then [] else a : lst) []
 
+-- | Returns the number of annotations in 'AnnotationSet' for each type.
+annsCount :: AnnotationSet -> (Int, Int, Int)
+annsCount (AnnotationSet tas fas vas) = (length tas, length fas, length vas)
+
+-- | Returns the first annotation in a list of annotations of a specific type
+-- in 'AnnotationSet', or 'noAnn' if this list is empty.
+firstAnn :: (KnownAnnTag tag) => AnnotationSet -> Annotation tag
+firstAnn = getAnn (\case [] -> noAnn; a : _ -> a)
+
+-- | Returns the second annotation in a list of annotations of a specific type
+-- in 'AnnotationSet', or 'noAnn' if this list contains less than 2 elements.
+secondAnn :: (KnownAnnTag tag) => AnnotationSet -> Annotation tag
+secondAnn = getAnn (\case [] -> noAnn; [_] -> noAnn; _ : a : _ -> a)
+
+-- | Retrieves an annotation of a specific type from 'AnnotationSet' using
+-- the passed function.
+getAnn :: forall tag. (KnownAnnTag tag)
+       => ([Annotation tag] -> Annotation tag)
+       -> AnnotationSet
+       -> Annotation tag
+getAnn getter annSet = case eqT @tag @TypeTag of
+  Just Refl -> getter $ asTypes annSet
+  Nothing -> case eqT @tag @FieldTag of
+    Just Refl -> getter $ asFields annSet
+    Nothing -> case eqT @tag @VarTag of
+      Just Refl -> getter $ asVars annSet
+      Nothing -> error "Impossible"
+
 --------------------------------------------------------------------------------
 -- Rendering
 --------------------------------------------------------------------------------
@@ -232,26 +264,26 @@
 --------------------------------------------------------------------------------
 
 noAnn :: Annotation a
-noAnn = AnnotationUnsafe ""
+noAnn = UnsafeAnnotation ""
 
 -- | Makes an `Annotation` from its textual value, prefix (%/@/:) excluded
 -- Throws an error if the given `Text` contains invalid characters
-mkAnnotationUnsafe :: HasCallStack => Text -> Annotation a
-mkAnnotationUnsafe = either error id . mkAnnotation
+unsafeMkAnnotation :: HasCallStack => Text -> Annotation a
+unsafeMkAnnotation = either error id . mkAnnotation
 
 -- | Makes an `Annotation` from its textual value, prefix (%/@/:) excluded
 -- Returns a `Text` error message if the given `Text` contains invalid characters
 mkAnnotation :: Text -> Either Text (Annotation a)
 mkAnnotation text
   -- TODO [#48] these are special annotations and should not be always allowed
-  | text `elem` specialVarAnns = Right $ AnnotationUnsafe text
-  | text == specialFieldAnn = Right $ AnnotationUnsafe text
+  | text `elem` specialVarAnns = Right $ UnsafeAnnotation text
+  | text == specialFieldAnn = Right $ UnsafeAnnotation text
   | otherwise = do
     suffix <- case T.uncons text of
       Just (h, tl) | isValidAnnStart h -> Right tl
       Just (h, _) -> Left $ "Invalid first character: '" <> one h <> "'"
       _ -> Right ""
-    maybe (Right $ AnnotationUnsafe text) (\c -> Left $ "Invalid character: '" <> one c <> "'") $
+    maybe (Right $ UnsafeAnnotation text) (\c -> Left $ "Invalid character: '" <> one c <> "'") $
       T.find (not . isValidAnnBodyChar) suffix
 
 -- |
@@ -289,14 +321,14 @@
       case (mkAnnotation $ toText @String s) of
         Left err -> fail $ toString err
         Right _ -> case annTypeMb of
-          Nothing -> [e| (AnnotationUnsafe s) |]
-          Just annType -> [e| (AnnotationUnsafe s :: $(annType)) |]
+          Nothing -> [e| (UnsafeAnnotation s) |]
+          Just annType -> [e| (UnsafeAnnotation s :: $(annType)) |]
   , TH.quotePat = \s ->
        case (mkAnnotation $ toText @String s) of
          Left err -> fail $ toString err
          Right _ -> case annTypeMb of
-           Nothing -> [p| AnnotationUnsafe $(TH.litP $ TH.StringL s) |]
-           Just annType -> [p| (AnnotationUnsafe $(TH.litP $ TH.StringL s) :: $(annType)) |]
+           Nothing -> [p| UnsafeAnnotation $(TH.litP $ TH.StringL s) |]
+           Just annType -> [p| (UnsafeAnnotation $(TH.litP $ TH.StringL s) :: $(annType)) |]
   , TH.quoteType = \_ -> fail "Cannot use this QuasiQuoter at type position"
   , TH.quoteDec = \_  -> fail "Cannot use this QuasiQuoter at declaration position"
   }
@@ -332,8 +364,8 @@
 
 instance Semigroup VarAnn where
   Annotation a <> Annotation b
-    | a == "" || b == "" = AnnotationUnsafe $ a <> b
-    | otherwise          = AnnotationUnsafe $ a <> "." <> b
+    | a == "" || b == "" = UnsafeAnnotation $ a <> b
+    | otherwise          = UnsafeAnnotation $ a <> "." <> b
 
 instance Monoid VarAnn where
     mempty = noAnn
@@ -387,7 +419,7 @@
 ifAnnUnified a1 a2 = isJust $ a1 `unifyAnn` a2
 
 convAnn :: Annotation tag1 -> Annotation tag2
-convAnn (Annotation a) = AnnotationUnsafe a
+convAnn (Annotation a) = UnsafeAnnotation a
 
 pattern WithAnn :: Annotation tag -> Annotation tag
 pattern WithAnn ann <- ann@(Annotation (toString -> _:_))
diff --git a/src/Michelson/Untyped/Entrypoints.hs b/src/Michelson/Untyped/Entrypoints.hs
--- a/src/Michelson/Untyped/Entrypoints.hs
+++ b/src/Michelson/Untyped/Entrypoints.hs
@@ -19,10 +19,12 @@
 
 import Data.Aeson.TH (deriveJSON)
 import qualified Data.Map as Map
-import Fmt (Buildable(..), pretty, (+|), (|+))
+import Fmt (Buildable(..), pretty)
 
 import Michelson.Untyped.Annotation
 import Michelson.Untyped.Type
+import Michelson.Printer.Util (RenderDoc (..), renderAnyBuildable, buildRenderDoc)
+import Text.PrettyPrint.Leijen.Text ((<+>), enclose)
 import Util.Aeson
 import Util.CLI
 
@@ -53,7 +55,7 @@
 -- code. There is an
 -- [issue](https://gitlab.com/morley-framework/morley/-/issues/275) in our
 -- repo as well.
-newtype EpName = EpNameUnsafe { unEpName :: Text }
+newtype EpName = UnsafeEpName { unEpName :: Text }
   deriving stock (Show, Eq, Ord, Generic)
 
 instance NFData EpName
@@ -73,18 +75,18 @@
 -- for backwards compatibility and for the cases when you are sure that
 -- 'EpName' does not come from the @SELF@ instruction.
 pattern DefEpName :: EpName
-pattern DefEpName = EpNameUnsafe ""
+pattern DefEpName = UnsafeEpName ""
 
 -- | Check whether given 'EpName' refers to the default entrypoint.
 -- Unlike 'DefEpName' pattern, this function correctly handles all cases,
 -- including the @SELF@ instruction.
 isDefEpName :: EpName -> Bool
-isDefEpName epName = epName == DefEpName || epName == EpNameUnsafe "default"
+isDefEpName epName = epName == DefEpName || epName == UnsafeEpName "default"
 
 instance Buildable EpName where
   build = \case
     DefEpName -> "<default>"
-    EpNameUnsafe name -> build name
+    UnsafeEpName name -> build name
 
 -- | Make up 'EpName' from annotation in parameter type declaration.
 --
@@ -92,14 +94,14 @@
 epNameFromParamAnn :: FieldAnn -> Maybe EpName
 epNameFromParamAnn an@(Annotation a)
   | an == noAnn = Nothing
-  | a == "default" = Just (EpNameUnsafe "")
-  | otherwise = Just $ EpNameUnsafe a
+  | a == "default" = Just (UnsafeEpName "")
+  | otherwise = Just $ UnsafeEpName a
 
 -- | Turn entrypoint name into annotation for contract parameter declaration.
 epNameToParamAnn :: EpName -> FieldAnn
-epNameToParamAnn (EpNameUnsafe name)
+epNameToParamAnn (UnsafeEpName name)
   | name == "" = [annQ|default|]
-  | otherwise = mkAnnotationUnsafe name
+  | otherwise = unsafeMkAnnotation name
 
 data EpNameFromRefAnnError
   = InEpNameBadAnnotation FieldAnn
@@ -108,9 +110,12 @@
 instance NFData EpNameFromRefAnnError
 
 instance Buildable EpNameFromRefAnnError where
-  build = \case
+  build = buildRenderDoc
+
+instance RenderDoc EpNameFromRefAnnError where
+  renderDoc _ = \case
     InEpNameBadAnnotation (Annotation an) ->
-      "Invalid entrypoint reference `" +| an |+ "`"
+      "Invalid entrypoint reference" <+> (enclose "`" "`" $ renderAnyBuildable an)
 
 -- | Make up 'EpName' from annotation which is reference to an entrypoint.
 -- Note that it's more common for Michelson to prohibit explicit @default@
@@ -124,16 +129,16 @@
 epNameFromRefAnn :: FieldAnn -> Either EpNameFromRefAnnError EpName
 epNameFromRefAnn an@(Annotation a)
   | a == "default" = Left $ InEpNameBadAnnotation an
-  | otherwise = Right $ EpNameUnsafe a
+  | otherwise = Right $ UnsafeEpName a
 
 -- | Make up an 'EpName' from an annotation which is part of the
 -- @SELF@ instruction.
 epNameFromSelfAnn :: FieldAnn -> EpName
-epNameFromSelfAnn (Annotation a) = EpNameUnsafe a
+epNameFromSelfAnn (Annotation a) = UnsafeEpName a
 
 -- | Turn entrypoint name into annotation used as reference to entrypoint.
 epNameToRefAnn :: EpName -> FieldAnn
-epNameToRefAnn (EpNameUnsafe name) = mkAnnotationUnsafe name
+epNameToRefAnn (UnsafeEpName name) = unsafeMkAnnotation name
 
 -- | Make a valid entrypoint name from an arbitrary text. This
 -- function prohibits explicit @default@ entrypoint name which is
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
@@ -9,9 +9,6 @@
   , ExpandedOp (..)
   , ExpandedInstr
   , flattenExpandedOp
-
-  -- * Contract's address
-  , OperationHash (..)
   ) where
 
 import Prelude hiding (EQ, GT, LT)
@@ -33,7 +30,6 @@
 import Michelson.Untyped.Ext (ExtInstrAbstract)
 import Michelson.Untyped.Type (Ty)
 import Michelson.Untyped.Value (Value'(..))
-import Tezos.Address (OperationHash(..))
 import Util.Aeson
 
 -------------------------------------
@@ -121,6 +117,7 @@
   | UNIT              TypeAnn VarAnn
   | IF_NONE           [op] [op]
   | PAIR              TypeAnn VarAnn FieldAnn FieldAnn
+  | UNPAIR            VarAnn VarAnn FieldAnn FieldAnn
   | PAIRN             VarAnn Word
   | UNPAIRN           Word
   | CAR               VarAnn FieldAnn
@@ -205,6 +202,10 @@
   | LEVEL             VarAnn
   | SELF_ADDRESS      VarAnn
   | NEVER
+  | TICKET            VarAnn
+  | READ_TICKET       VarAnn
+  | SPLIT_TICKET      VarAnn
+  | JOIN_TICKETS      VarAnn
   deriving stock (Eq, Functor, Data, Generic)
 
 instance RenderDoc (InstrAbstract op) => Show (InstrAbstract op) where
@@ -242,6 +243,7 @@
     UNIT ta va              -> "UNIT" <+> renderAnnots [ta] [] [va]
     IF_NONE x y             -> "IF_NONE" <+> nest 9 (renderOps x) <$$> spaces 8 <> nest 9 (renderOps y)
     PAIR ta va fa1 fa2      -> "PAIR" <+> renderAnnots [ta] [fa1, fa2] [va]
+    UNPAIR va1 va2 fa1 fa2  -> "UNPAIR" <+> renderAnnots [] [fa1, fa2] [va1, va2]
     PAIRN va n              -> "PAIR" <+> renderAnnots [] [] [va] <+> text (show n)
     UNPAIRN n               -> "UNPAIR" <+> text (show n)
     CAR va fa               -> "CAR" <+> renderAnnots [] [fa] [va]
@@ -328,6 +330,10 @@
     LEVEL va                -> "LEVEL" <+> renderAnnot va
     SELF_ADDRESS va         -> "SELF_ADDRESS" <+> renderAnnot va
     NEVER                   -> "NEVER"
+    TICKET va               -> "TICKET" <+> renderAnnot va
+    READ_TICKET va          -> "READ_TICKET" <+> renderAnnot va
+    SPLIT_TICKET va         -> "SPLIT_TICKET" <+> renderAnnot va
+    JOIN_TICKETS va         -> "JOIN_TICKETS" <+> renderAnnot va
     where
       renderTy = renderDoc @Ty needsParens
       renderComp = renderDoc @Ty needsParens
diff --git a/src/Michelson/Untyped/OpSize.hs b/src/Michelson/Untyped/OpSize.hs
--- a/src/Michelson/Untyped/OpSize.hs
+++ b/src/Michelson/Untyped/OpSize.hs
@@ -79,6 +79,7 @@
   UNIT ta va -> annsOpSize ta va
   IF_NONE l r -> ifOpSize l r
   PAIR ta va fal far -> annsOpSize ta va fal far
+  UNPAIR va1 va2 fal far -> annsOpSize va1 va2 fal far
   PAIRN va n -> annsOpSize va <> stackDepthOpSize n
   UNPAIRN n -> stackDepthOpSize n
   CAR va fa -> annsOpSize va fa
@@ -164,6 +165,10 @@
   LEVEL va -> annsOpSize va
   SELF_ADDRESS va -> annsOpSize va
   NEVER -> mempty
+  TICKET va -> annsOpSize va
+  READ_TICKET va -> annsOpSize va
+  SPLIT_TICKET va -> annsOpSize va
+  JOIN_TICKETS va -> annsOpSize va
   where
     subcodeOpSize is = expandedInstrOpSize (SeqEx is)
     ifOpSize l r = expandedInstrOpSize (SeqEx l) <> expandedInstrOpSize (SeqEx r)
@@ -225,6 +230,7 @@
     TList a -> typeOpSize a
     TSet a -> innerOpSize a
     TOperation -> mempty
+    TTicket a -> typeOpSize a
     TContract a -> typeOpSize a
     -- Nested variable annotations don't use any extra operation size.
     TPair al ar _ _ l r -> typeOpSize' [al] l <> typeOpSize' [ar] r
diff --git a/src/Michelson/Untyped/Type.hs b/src/Michelson/Untyped/Type.hs
--- a/src/Michelson/Untyped/Type.hs
+++ b/src/Michelson/Untyped/Type.hs
@@ -46,7 +46,8 @@
   (Prettier(..), RenderContext, RenderDoc(..), addParens, buildRenderDoc, doesntNeedParens,
   needsParens, wrapInParens)
 import Michelson.Untyped.Annotation
-  (AnnotationSet, FieldAnn, RootAnn, TypeAnn, VarAnn, emptyAnnSet, fullAnnSet, noAnn, singleAnnSet)
+  (AnnotationSet, FieldAnn, RootAnn, TypeAnn, VarAnn, emptyAnnSet, fullAnnSet, noAnn,
+  pattern Annotation, singleAnnSet)
 import Util.Aeson
 
 -- Annotated type.
@@ -101,10 +102,17 @@
 renderType t forceSingleLine pn annSet =
   let annDoc = renderDoc doesntNeedParens annSet
       recRenderer t' annSet' = renderType t' forceSingleLine needsParens annSet'
-      renderBranches d1 d2 =
+      renderBranches :: [Doc] -> Doc
+      renderBranches ds =
         if forceSingleLine
-        then (d1 <+> d2)
-        else align $ softbreak <> (d1 <$> d2)
+        then foldl1 (<+>) ds
+        else align $ softbreak <> foldl1 (<$>) ds
+
+      collectBranches :: T ->  TypeAnn -> FieldAnn -> [Doc]
+      collectBranches (TPair fa1 fa2 va1 _ (Ty t1 ta1) (Ty t2 ta2)) _ (Annotation "")
+        = (recRenderer t1 $ (fullAnnSet [ta1] [fa1] [va1])) : collectBranches t2 ta2 fa2
+      collectBranches t' ta fa = [recRenderer t' $ fullAnnSet [ta] [fa] []]
+
   in
   case t of
     TInt              -> wrapInParens pn $ "int" :| [annDoc]
@@ -142,40 +150,58 @@
       addParens pn $
       "contract" <+> annDoc <+> recRenderer t1 (singleAnnSet ta1)
 
+    TTicket (Ty t1 ta1)   ->
+      addParens pn $
+      "ticket" <+> annDoc <+> recRenderer t1 (singleAnnSet ta1)
+
+    -- Optimize in comb pair rendering: `pair x y z` instead of `pair x (pair y z)`
+    -- Works only if there is no field annotation on nested pair
+    p@(TPair _ (Annotation "") _ _ (Ty _ _) (Ty (TPair {}) _)) ->
+       let branches = collectBranches p noAnn noAnn
+       in
+        addParens pn $
+          "pair" <+> annDoc <+>
+            renderBranches branches
+
     TPair fa1 fa2 va1 va2 (Ty t1 ta1) (Ty t2 ta2) ->
       addParens pn $
         "pair" <+> annDoc <+>
           renderBranches
-            (recRenderer t1 $ fullAnnSet [ta1] [fa1] [va1])
-            (recRenderer t2 $ fullAnnSet [ta2] [fa2] [va2])
+            [ recRenderer t1 $ fullAnnSet [ta1] [fa1] [va1]
+            , recRenderer t2 $ fullAnnSet [ta2] [fa2] [va2]
+            ]
 
     TOr fa1 fa2 (Ty t1 ta1) (Ty t2 ta2) ->
       addParens pn $
         "or" <+> annDoc <+>
           renderBranches
-            (recRenderer t1 $ fullAnnSet [ta1] [fa1] [])
-            (recRenderer t2 $ fullAnnSet [ta2] [fa2] [])
+            [ recRenderer t1 $ fullAnnSet [ta1] [fa1] []
+            , recRenderer t2 $ fullAnnSet [ta2] [fa2] []
+            ]
 
     TLambda (Ty t1 ta1) (Ty t2 ta2) ->
       addParens pn $
         "lambda" <+> annDoc <+>
           renderBranches
-            (recRenderer t1 $ singleAnnSet ta1)
-            (recRenderer t2 $ singleAnnSet ta2)
+            [ recRenderer t1 $ singleAnnSet ta1
+            , recRenderer t2 $ singleAnnSet ta2
+            ]
 
     TMap (Ty t1 ta1) (Ty t2 ta2) ->
       addParens pn $
         "map" <+> annDoc <+>
           renderBranches
-            (recRenderer t1 $ singleAnnSet ta1)
-            (recRenderer t2 $ singleAnnSet ta2)
+            [ recRenderer t1 $ singleAnnSet ta1
+            , recRenderer t2 $ singleAnnSet ta2
+            ]
 
     TBigMap (Ty t1 ta1) (Ty t2 ta2) ->
       addParens pn $
         "big_map" <+> annDoc <+>
           renderBranches
-            (recRenderer t1 $ singleAnnSet ta1)
-            (recRenderer t2 $ singleAnnSet ta2)
+            [ recRenderer t1 $ singleAnnSet ta1
+            , recRenderer t2 $ singleAnnSet ta2
+            ]
 
 instance Buildable Ty where
   build = buildRenderDoc
@@ -194,6 +220,7 @@
   | TSet Ty
   | TOperation
   | TContract Ty
+  | TTicket Ty
   | TPair FieldAnn FieldAnn VarAnn VarAnn Ty Ty
   | TOr FieldAnn FieldAnn Ty Ty
   | TLambda Ty Ty
diff --git a/src/Michelson/Untyped/Value.hs b/src/Michelson/Untyped/Value.hs
--- a/src/Michelson/Untyped/Value.hs
+++ b/src/Michelson/Untyped/Value.hs
@@ -10,11 +10,13 @@
   -- Internal types to avoid orphan instances
   , InternalByteString(..)
   , unInternalByteString
+  , linearizeRightCombValuePair
   ) where
 
 import Data.Aeson (FromJSON(..), ToJSON(..), withText)
 import Data.Aeson.TH (deriveJSON)
 import Data.Data (Data(..))
+import Data.List.NonEmpty ((<|))
 import Fmt (Buildable(build))
 import Text.Hex (decodeHex, encodeHex)
 import Text.PrettyPrint.Leijen.Text
@@ -39,7 +41,7 @@
   | ValueNone
   | ValueNil
   | ValueSeq     (NonEmpty $ Value' op)
-  -- ^ A sequence of elements: can be a list or a set.
+  -- ^ A sequence of elements: can be a list, a set or a pair.
   -- We can't distinguish lists and sets during parsing.
   | ValueMap     (NonEmpty $ Elt op)
   | ValueLambda  (NonEmpty op)
@@ -72,6 +74,9 @@
       ValueUnit      -> "Unit"
       ValueTrue      -> "True"
       ValueFalse     -> "False"
+      p@(ValuePair _ (ValuePair _ _))  ->
+        let encodedValues = linearizeRightCombValuePair p
+        in renderValuesList (renderDoc doesntNeedParens) encodedValues
       ValuePair l r  -> addParens pn $
                         "Pair" <+> renderDoc needsParens l <+> renderDoc needsParens r
       ValueLeft l    -> addParens pn $
@@ -84,6 +89,11 @@
       ValueSeq xs    -> renderValuesList (renderDoc doesntNeedParens) xs
       ValueMap xs    -> renderValuesList renderElt xs
       ValueLambda xs -> renderOps False xs
+
+-- | Converts `Pair a (Pair b c)` to `[a, b, c].`
+linearizeRightCombValuePair :: (Value' op) -> NonEmpty (Value' op)
+linearizeRightCombValuePair (ValuePair l r) = l <| linearizeRightCombValuePair r
+linearizeRightCombValuePair v = v :| []
 
 renderElt :: RenderDoc op => Elt op -> Doc
 renderElt (Elt k v) =
diff --git a/src/Morley/Micheline/Binary.hs b/src/Morley/Micheline/Binary.hs
--- a/src/Morley/Micheline/Binary.hs
+++ b/src/Morley/Micheline/Binary.hs
@@ -10,6 +10,7 @@
   ( decodeExpression
   , eitherDecodeExpression
   , encodeExpression
+  , encodeExpression'
   ) where
 
 import qualified Data.Binary.Builder as Bi
@@ -17,7 +18,6 @@
 import Data.Bits (Bits, bit, setBit, shift, testBit, zeroBits, (.&.), (.|.))
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as LBS
-import Data.Sequence (Seq((:<|)))
 import qualified Data.Sequence as Seq
 import qualified Data.Text.Encoding as TE
 
@@ -31,20 +31,24 @@
 -------------------------------------------------
 
 -- | Encode 'Expression' to 'ByteString'.
-encodeExpression :: Expression -> BS.ByteString
-encodeExpression = LBS.toStrict . Bi.toLazyByteString . buildExpr
+encodeExpression :: Expression -> LByteString
+encodeExpression = Bi.toLazyByteString . buildExpr
 
+-- | Same as 'encodeExpression', for strict bytestring.
+encodeExpression' :: Expression -> BS.ByteString
+encodeExpression' = LBS.toStrict . encodeExpression
+
 buildExpr :: Expression -> Bi.Builder
 buildExpr = \case
-  ExpressionSeq xs -> buildWord8 2 <> buildDynamic buildSeq (DynamicSize xs)
+  ExpressionSeq xs -> buildWord8 2 <> buildDynamic buildList (DynamicSize xs)
   ExpressionPrim (MichelinePrimAp prim args annots) -> case (args, annots) of
-    (Seq.Empty, Seq.Empty) -> buildWord8 3 <> buildPrim prim
-    (Seq.Empty, _) -> buildWord8 4 <> buildPrim prim <> buildAnnotationSeq annots
-    (arg1 :<| Seq.Empty, Seq.Empty) -> buildWord8 5 <> buildPrim prim <> buildExpr arg1
-    (arg1 :<| Seq.Empty, _) -> buildWord8 6 <> buildPrim prim <> buildExpr arg1 <> buildAnnotationSeq annots
-    (arg1 :<| (arg2 :<| Seq.Empty), Seq.Empty) -> buildWord8 7 <> buildPrim prim <> buildExpr arg1 <> buildExpr arg2
-    (arg1 :<| (arg2 :<| Seq.Empty), _) -> buildWord8 8 <> buildPrim prim <> buildExpr arg1 <> buildExpr arg2 <> buildAnnotationSeq annots
-    _ -> buildWord8 9 <> buildPrim prim <> buildDynamic buildSeq (DynamicSize args) <> buildAnnotationSeq annots
+    ([], []) -> buildWord8 3 <> buildPrim prim
+    ([], _) -> buildWord8 4 <> buildPrim prim <> buildAnnotationList annots
+    ([arg1], []) -> buildWord8 5 <> buildPrim prim <> buildExpr arg1
+    ([arg1], _) -> buildWord8 6 <> buildPrim prim <> buildExpr arg1 <> buildAnnotationList annots
+    ([arg1, arg2], []) -> buildWord8 7 <> buildPrim prim <> buildExpr arg1 <> buildExpr arg2
+    ([arg1, arg2], _) -> buildWord8 8 <> buildPrim prim <> buildExpr arg1 <> buildExpr arg2 <> buildAnnotationList annots
+    _ -> buildWord8 9 <> buildPrim prim <> buildDynamic buildList (DynamicSize args) <> buildAnnotationList annots
   ExpressionString x -> buildWord8 1 <> buildDynamic buildText (DynamicSize x)
   ExpressionInt x -> buildWord8 0 <> buildInteger x
   ExpressionBytes x -> buildWord8 10 <> buildDynamic buildByteString (DynamicSize x)
@@ -78,16 +82,16 @@
 buildText n =
   buildByteString $ TE.encodeUtf8 n
 
-buildSeq :: Seq Expression -> Bi.Builder
-buildSeq xs = foldMap buildExpr xs
+buildList :: [Expression] -> Bi.Builder
+buildList = foldMap buildExpr
 
 buildPrim :: MichelinePrimitive -> Bi.Builder
 buildPrim (MichelinePrimitive p) = case Seq.elemIndexL p michelsonPrimitive of
   Nothing -> error $ "unknown Michelson/Micheline primitive: " <> p
   Just ix -> buildWord8 (fromIntegral ix)
 
-buildAnnotationSeq :: Seq Annotation -> Bi.Builder
-buildAnnotationSeq seqAnn = buildDynamic buildText (DynamicSize $ unwords . toList . fmap annotToText $ seqAnn)
+buildAnnotationList :: [Annotation] -> Bi.Builder
+buildAnnotationList listAnn = buildDynamic buildText (DynamicSize $ unwords . fmap annotToText $ listAnn)
 
 -------------------------------------------------
 -- Decode
@@ -105,14 +109,14 @@
 getExpr = Bi.getWord8 >>= \case
   0 -> ExpressionInt <$> getInteger
   1 -> ExpressionString . unDynamicSize <$> (getDynamic getText)
-  2 -> ExpressionSeq . unDynamicSize <$> (getDynamic getSeq)
-  3 -> ExpressionPrim . (\pn -> MichelinePrimAp pn Seq.Empty Seq.Empty) <$> getPrim
-  4 -> ExpressionPrim <$> (flip MichelinePrimAp Seq.Empty <$> getPrim <*> getAnnotationSeq)
-  5 -> ExpressionPrim <$> (MichelinePrimAp <$> getPrim <*> (Seq.singleton <$> getExpr) <*> pure Seq.empty)
-  6 -> ExpressionPrim <$> (MichelinePrimAp <$> getPrim <*> (Seq.singleton <$> getExpr) <*> getAnnotationSeq)
-  7 -> ExpressionPrim <$> ((\n a -> MichelinePrimAp n a Seq.empty) <$> getPrim <*> Seq.replicateA 2 getExpr)
-  8 -> ExpressionPrim <$> (MichelinePrimAp <$> getPrim <*> Seq.replicateA 2 getExpr <*> getAnnotationSeq)
-  9 -> ExpressionPrim <$> (MichelinePrimAp <$> getPrim <*> (unDynamicSize <$> (getDynamic getSeq)) <*> getAnnotationSeq)
+  2 -> ExpressionSeq . unDynamicSize <$> (getDynamic getList)
+  3 -> ExpressionPrim . (\pn -> MichelinePrimAp pn [] []) <$> getPrim
+  4 -> ExpressionPrim <$> (flip MichelinePrimAp [] <$> getPrim <*> getAnnotationList)
+  5 -> ExpressionPrim <$> (MichelinePrimAp <$> getPrim <*> (one <$> getExpr) <*> pure [])
+  6 -> ExpressionPrim <$> (MichelinePrimAp <$> getPrim <*> (one <$> getExpr) <*> getAnnotationList)
+  7 -> ExpressionPrim <$> ((\n a -> MichelinePrimAp n a []) <$> getPrim <*> replicateM 2 getExpr)
+  8 -> ExpressionPrim <$> (MichelinePrimAp <$> getPrim <*> replicateM 2 getExpr <*> getAnnotationList)
+  9 -> ExpressionPrim <$> (MichelinePrimAp <$> getPrim <*> (unDynamicSize <$> (getDynamic getList)) <*> getAnnotationList)
   10 -> ExpressionBytes . unDynamicSize <$> (getDynamic getByteString)
   _ -> fail "invalid Micheline expression tag"
 
@@ -145,9 +149,8 @@
 getByteString =
   LBS.toStrict <$> Bi.getRemainingLazyByteString
 
-getSeq :: Bi.Get (Seq Expression)
-getSeq =
-   Seq.fromList <$> many getExpr
+getList :: Bi.Get [Expression]
+getList = many getExpr
 
 getPrim :: Bi.Get MichelinePrimitive
 getPrim =
@@ -155,5 +158,5 @@
     Nothing -> fail "unknown Michelson/Micheline opcode"
     Just str -> pure $ MichelinePrimitive str
 
-getAnnotationSeq :: Bi.Get (Seq Annotation)
-getAnnotationSeq = mapM annotFromText . Seq.fromList . words . unDynamicSize =<< (getDynamic getText)
+getAnnotationList :: Bi.Get [Annotation]
+getAnnotationList = mapM annotFromText . words . unDynamicSize =<< (getDynamic getText)
diff --git a/src/Morley/Micheline/Class.hs b/src/Morley/Micheline/Class.hs
--- a/src/Morley/Micheline/Class.hs
+++ b/src/Morley/Micheline/Class.hs
@@ -10,88 +10,301 @@
   , FromExpression (..)
   ) where
 
-import qualified Data.ByteString.Lazy as LBS
-import Data.Sequence (fromList, (|>))
-import Data.Singletons (Sing, SingI, SomeSing (..), toSing, withSingI)
-import Fmt (Buildable(..), pretty)
+import Control.Lens ((<>~))
+import Data.Bits (toIntegralSized)
+import Data.Default
+import Data.Singletons (SingI(..), demote)
+import Fmt (Buildable(..), indentF, pretty, unlinesF)
 
-import Michelson.Interpret.Pack (encodeValue', packCode', packNotedT', packT')
-import Michelson.Interpret.Unpack
-  (UnpackError, decodeContract, decodeType, unpackInstr', unpackValue')
+import Michelson.Text (mkMText, unMText)
+import Michelson.TypeCheck (TypeCheckMode(..), TypeCheckOptions(..), runTypeCheck, typeCheckingWith)
+import Michelson.TypeCheck.Instr (typeCheckValue)
 import Michelson.Typed
-  (pattern AsUType, Contract(..), HasNoOp, Instr(..), KnownT, Notes(..), T(..), Value, Value'(..),
-  fromUType, pnNotes, pnRootAnn, rfAnyInstr)
-import Michelson.Typed.Instr (mapEntriesOrdered)
-import Michelson.Typed.Scope (UnpackedValScope)
+  (Contract(..), HasNoOp, Instr, Notes(..), T(..), Value, Value'(..), fromUType, mkUType,
+  rfAnyInstr, toUType)
+import Michelson.Typed.Convert (convertContract, instrToOpsOptimized, untypeValueOptimized)
 import qualified Michelson.Untyped as Untyped
-import Michelson.Untyped.Annotation (RootAnn, noAnn)
-import Michelson.Untyped.Instr (ExpandedOp)
-import Morley.Micheline.Binary (decodeExpression, encodeExpression)
+import Michelson.Untyped.Annotation
+  (AnnotationSet(..), FieldAnn, FieldTag, RootAnn, TypeAnn, TypeTag, VarAnn, VarTag, annsCount,
+  emptyAnnSet, firstAnn, noAnn, secondAnn)
+import Michelson.Untyped.Contract (ContractBlock(..), orderContractBlock)
+import Michelson.Untyped.Instr (ExpandedInstr, ExpandedOp(..), InstrAbstract(..))
+import Michelson.Untyped.Type (Ty(..))
 import Morley.Micheline.Expression
-  (Annotation(..), Expression(..), MichelinePrimAp(..), MichelinePrimitive(..))
-import Util.Binary (launchGet)
+  (Annotation(..), Expression(..), MichelinePrimAp(..), _ExpressionPrim, isAnnotationField,
+  isAnnotationType, isAnnotationVariable, mkAnns, mpaAnnotsL, toAnnSet)
 
 -- | Type class that provides an ability to convert
 -- something to Micheline Expression.
 class ToExpression a where
   toExpression :: a -> Expression
 
+instance forall t . (SingI t, HasNoOp t) => ToExpression (Value t) where
+  toExpression = toExpression . untypeValueOptimized
+
+instance ToExpression Untyped.Value where
+  toExpression = \case
+    Untyped.ValueInt v -> ExpressionInt v
+    Untyped.ValueString s -> ExpressionString $ unMText s
+    Untyped.ValueBytes (Untyped.InternalByteString bs) -> ExpressionBytes bs
+    Untyped.ValueUnit -> PrimExpr "Unit" [] []
+    Untyped.ValueTrue -> PrimExpr "True" [] []
+    Untyped.ValueFalse -> PrimExpr "False" [] []
+    Untyped.ValuePair l r ->
+      PrimExpr "Pair" [toExpression l, toExpression r] []
+    Untyped.ValueLeft v -> PrimExpr "Left" [toExpression v] []
+    Untyped.ValueRight v -> PrimExpr "Right" [toExpression v] []
+    Untyped.ValueSome v -> PrimExpr "Some" [toExpression v] []
+    Untyped.ValueNone -> PrimExpr "None" [] []
+    Untyped.ValueNil -> ExpressionSeq []
+    Untyped.ValueSeq vs -> toExpression vs
+    Untyped.ValueMap elts -> toExpression $ eltToExpr <$> elts
+    Untyped.ValueLambda ops -> toExpression ops
+    where
+      eltToExpr :: Untyped.Elt ExpandedOp -> Expression
+      eltToExpr (Untyped.Elt l r) = PrimExpr "Elt"
+        [toExpression l, toExpression r] []
+
+
 instance ToExpression (Instr inp out) where
-  toExpression = decodeExpression . packCode'
+  toExpression = toExpression . instrToOpsOptimized
 
 instance ToExpression T where
-  toExpression t' | SomeSing (ts :: Sing t) <- toSing t' =
-    decodeExpression $ withSingI ts $ (packT' @t)
+  toExpression = toExpression . toUType
 
 instance SingI t => ToExpression (Notes t) where
-  toExpression = decodeExpression . packNotedT'
+  toExpression = toExpression . mkUType
 
-instance ToExpression Untyped.Ty where
-  toExpression (AsUType notes) = toExpression notes
+instance ToExpression Untyped.T where
+  toExpression = \case
+    Untyped.TKey -> PrimExpr "key" [] []
+    Untyped.TUnit -> PrimExpr "unit" [] []
+    Untyped.TSignature -> PrimExpr "signature" [] []
+    Untyped.TChainId -> PrimExpr "chain_id" [] []
+    Untyped.TOption arg -> PrimExpr "option" [toExpression arg] []
+    Untyped.TList arg -> PrimExpr "list" [toExpression arg] []
+    Untyped.TSet arg -> PrimExpr "set" [toExpression arg] []
+    Untyped.TOperation -> PrimExpr "operation" [] []
+    Untyped.TContract arg -> PrimExpr "contract" [toExpression arg] []
+    Untyped.TTicket arg -> PrimExpr "ticket" [toExpression arg] []
+    t@Untyped.TPair{} -> PrimExpr "pair"
+      (rightCombedPairToList (Ty t noAnn) (noAnn, noAnn)) []
+    Untyped.TOr fa1 fa2 l r ->
+      let exprL = addTrimmedAnns (toExpression l) [] [fa1] []
+          exprR = addTrimmedAnns (toExpression r) [] [fa2] []
+      in PrimExpr "or" [exprL, exprR] []
+    Untyped.TLambda inp out ->
+      PrimExpr "lambda" [toExpression inp, toExpression out] []
+    Untyped.TMap k v ->
+      PrimExpr "map" [toExpression k, toExpression v] []
+    Untyped.TBigMap k v ->
+      PrimExpr "big_map" [toExpression k, toExpression v] []
+    Untyped.TInt -> PrimExpr "int" [] []
+    Untyped.TNat -> PrimExpr "nat" [] []
+    Untyped.TString -> PrimExpr "string" [] []
+    Untyped.TBytes -> PrimExpr "bytes" [] []
+    Untyped.TMutez -> PrimExpr "mutez" [] []
+    Untyped.TBool -> PrimExpr "bool" [] []
+    Untyped.TKeyHash -> PrimExpr "key_hash" [] []
+    Untyped.TBls12381Fr -> PrimExpr "bls12_381_fr" [] []
+    Untyped.TBls12381G1 -> PrimExpr "bls12_381_g1" [] []
+    Untyped.TBls12381G2 -> PrimExpr "bls12_381_g2" [] []
+    Untyped.TTimestamp -> PrimExpr "timestamp" [] []
+    Untyped.TAddress -> PrimExpr "address" [] []
+    Untyped.TNever -> PrimExpr "never" [] []
 
-instance (SingI t, HasNoOp t) => ToExpression (Value t) where
-  toExpression = decodeExpression . encodeValue'
+    where
+      addAnns :: Expression -> [Annotation] -> Expression
+      addAnns e anns =
+        e & _ExpressionPrim . mpaAnnotsL <>~ anns
 
-instance ToExpression (Contract cp st) where
-  toExpression contract@Contract{} = ExpressionSeq $ fromList $ mapEntriesOrdered contract
-    (\param -> ExpressionPrim $
-        MichelinePrimAp (MichelinePrimitive "parameter")
-        (fromList [ addRootAnnToExpression (pnRootAnn param) $
-                    toExpression $ pnNotes param
-                  ])
-        (fromList [])
-    )
-    (\store -> ExpressionPrim $
-        MichelinePrimAp (MichelinePrimitive "storage")
-        (fromList [toExpression $ store])
-        (fromList [])
-    )
-    (\code -> ExpressionPrim $
-        MichelinePrimAp (MichelinePrimitive "code")
-        (fromList [toExpression code])
-        (fromList [])
-    )
+      rightCombedPairToList :: Ty -> (FieldAnn, VarAnn) -> [Expression]
+      rightCombedPairToList ty (fa, va) = case (ty, fa) of
+        (Ty (Untyped.TPair fa1 fa2 va1 va2 l r) (Untyped.Annotation ""), Untyped.Annotation "") ->
+          let annsL = mkAnns [] [fa1] [va1]
+              exprL = toExpression l `addAnns` annsL
+          in exprL : (rightCombedPairToList r (fa2, va2))
+        _ ->
+          let anns = mkAnns [] [fa] [va]
+          in one $ toExpression ty `addAnns` anns
+
+instance ToExpression Ty where
+  toExpression (Ty t ta) = addTrimmedAnns (toExpression t) [ta] [] []
+
+instance (ToExpression a) => ToExpression [a] where
+  toExpression xs = ExpressionSeq $ toExpression <$> xs
+
+instance (ToExpression a) => ToExpression (NonEmpty a) where
+  toExpression = toExpression . toList
+
+instance ToExpression Expression where
+  toExpression = id
+
+instance ToExpression ExpandedOp where
+  toExpression = \case
+    PrimEx instr   -> toExpression instr
+    SeqEx s        -> ExpressionSeq $ toExpression <$> s
+    WithSrcEx _ op -> toExpression op
+
+instance ToExpression ExpandedInstr where
+  toExpression = \case
+    PUSH va ty v -> PrimExpr "PUSH" [toExpression ty, toExpression v] $
+      mkAnns [] [] [va]
+    DROP -> PrimExpr "DROP" [] []
+    DROPN n -> PrimExpr "DROP" [wordToExpr n] []
+    DUP va -> PrimExpr "DUP" [] $ mkAnns [] [] [va]
+    DUPN va n -> PrimExpr "DUP" [wordToExpr n] $ mkAnns [] [] [va]
+    SWAP -> PrimExpr "SWAP" [] []
+    DIG n -> PrimExpr "DIG" [wordToExpr n] []
+    DUG n -> PrimExpr "DUG" [wordToExpr n] []
+    SOME ta va ->
+      PrimExpr "SOME" [] $ mkAnns [ta] [] [va]
+    NONE ta va ty -> PrimExpr "NONE" [toExpression ty] $ mkAnns [ta] [] [va]
+    UNIT ta va -> PrimExpr "UNIT" [] $ mkAnns [ta] [] [va]
+    IF_NONE ops1 ops2 ->
+      PrimExpr "IF_NONE" [toExpression ops1, toExpression ops2] []
+    PAIR ta va fa1 fa2 -> PrimExpr "PAIR" [] $ mkAnns [ta] [fa1, fa2] [va]
+    UNPAIR va1 va2 fa1 fa2 -> PrimExpr "UNPAIR" [] $
+      mkAnns [] [fa1, fa2] [va1, va2]
+    PAIRN va n -> PrimExpr "PAIR" [wordToExpr n] $ mkAnns [] [] [va]
+    UNPAIRN n -> PrimExpr "UNPAIR" [wordToExpr n] []
+    CAR va fa -> PrimExpr "CAR" [] $ mkAnns [] [fa] [va]
+    CDR va fa -> PrimExpr "CDR" [] $ mkAnns [] [fa] [va]
+    LEFT ta va fa1 fa2 ty -> PrimExpr "LEFT" [toExpression ty] $
+      mkAnns [ta] [fa1, fa2] [va]
+    RIGHT ta va fa1 fa2 ty -> PrimExpr "RIGHT" [toExpression ty] $
+      mkAnns [ta] [fa1, fa2] [va]
+    IF_LEFT ops1 ops2 ->
+      PrimExpr "IF_LEFT" [toExpression ops1, toExpression ops2] []
+    NIL ta va ty -> PrimExpr "NIL" [toExpression ty] $
+      mkAnns [ta] [] [va]
+    CONS va -> PrimExpr "CONS" [] $ mkAnns [] [] [va]
+    IF_CONS ops1 ops2 ->
+      PrimExpr "IF_CONS" [toExpression ops1, toExpression ops2] []
+    SIZE va -> PrimExpr "SIZE" [] $ mkAnns [] [] [va]
+    EMPTY_SET ta va ty -> PrimExpr "EMPTY_SET" [toExpression ty] $
+      mkAnns [ta] [] [va]
+    EMPTY_MAP ta va kty vty ->
+      PrimExpr "EMPTY_MAP" [toExpression kty, toExpression vty] $
+      mkAnns [ta] [] [va]
+    EMPTY_BIG_MAP ta va kty vty ->
+      PrimExpr "EMPTY_BIG_MAP" [toExpression kty, toExpression vty] $
+      mkAnns [ta] [] [va]
+    MAP va ops -> PrimExpr "MAP" [toExpression ops] $ mkAnns [] [] [va]
+    ITER ops -> PrimExpr "ITER" [toExpression ops] []
+    MEM va -> PrimExpr "MEM" [] $ mkAnns [] [] [va]
+    GET va -> PrimExpr "GET" [] $ mkAnns [] [] [va]
+    GETN va n -> PrimExpr "GET" [wordToExpr n] $ mkAnns [] [] [va]
+    UPDATE va -> PrimExpr "UPDATE" [] $ mkAnns [] [] [va]
+    UPDATEN va n -> PrimExpr "UPDATE" [wordToExpr n] $ mkAnns [] [] [va]
+    GET_AND_UPDATE va -> PrimExpr "GET_AND_UPDATE" [] $ mkAnns [] [] [va]
+    IF ops1 ops2 ->
+      PrimExpr "IF" [toExpression ops1, toExpression ops2] []
+    LOOP ops -> PrimExpr "LOOP" [toExpression ops] []
+    LOOP_LEFT ops -> PrimExpr "LOOP_LEFT" [toExpression ops] []
+    LAMBDA va tyin tyout ops ->
+      PrimExpr "LAMBDA" [ toExpression tyin
+                            , toExpression tyout
+                            , toExpression ops
+                            ] $ mkAnns [] [] [va]
+    EXEC va -> PrimExpr "EXEC" [] $ mkAnns [] [] [va]
+    APPLY va -> PrimExpr "APPLY" [] $ mkAnns [] [] [va]
+    DIP ops -> PrimExpr "DIP" [toExpression ops] []
+    DIPN n ops -> PrimExpr "DIP" [wordToExpr n, toExpression ops] []
+    FAILWITH -> PrimExpr "FAILWITH" [] []
+    CAST va ty -> PrimExpr "CAST" [toExpression ty] $ mkAnns [] [] [va]
+    RENAME va -> PrimExpr "RENAME" [] $ mkAnns [] [] [va]
+    PACK va -> PrimExpr "PACK" [] $ mkAnns [] [] [va]
+    UNPACK ta va ty -> PrimExpr "UNPACK" [toExpression ty] $
+      mkAnns [ta] [] [va]
+    CONCAT va -> PrimExpr "CONCAT" [] $ mkAnns [] [] [va]
+    SLICE va -> PrimExpr "SLICE" [] $ mkAnns [] [] [va]
+    ISNAT va -> PrimExpr "ISNAT" [] $ mkAnns [] [] [va]
+    ADD va -> PrimExpr "ADD" [] $ mkAnns [] [] [va]
+    SUB va -> PrimExpr "SUB" [] $ mkAnns [] [] [va]
+    MUL va -> PrimExpr "MUL" [] $ mkAnns [] [] [va]
+    EDIV va -> PrimExpr "EDIV" [] $ mkAnns [] [] [va]
+    ABS va -> PrimExpr "ABS" [] $ mkAnns [] [] [va]
+    NEG va -> PrimExpr "NEG" [] $ mkAnns [] [] [va]
+    LSL va -> PrimExpr "LSL" [] $ mkAnns [] [] [va]
+    LSR va -> PrimExpr "LSR" [] $ mkAnns [] [] [va]
+    OR va -> PrimExpr "OR" [] $ mkAnns [] [] [va]
+    AND va -> PrimExpr "AND" [] $ mkAnns [] [] [va]
+    XOR va -> PrimExpr "XOR" [] $ mkAnns [] [] [va]
+    NOT va -> PrimExpr "NOT" [] $ mkAnns [] [] [va]
+    COMPARE va -> PrimExpr "COMPARE" [] $ mkAnns [] [] [va]
+    Untyped.EQ va -> PrimExpr "EQ" [] $ mkAnns [] [] [va]
+    NEQ va -> PrimExpr "NEQ" [] $ mkAnns [] [] [va]
+    Untyped.LT va -> PrimExpr "LT" [] $ mkAnns [] [] [va]
+    Untyped.GT va -> PrimExpr "GT" [] $ mkAnns [] [] [va]
+    LE va -> PrimExpr "LE" [] $ mkAnns [] [] [va]
+    GE va -> PrimExpr "GE" [] $ mkAnns [] [] [va]
+    INT va -> PrimExpr "INT" [] $ mkAnns [] [] [va]
+    SELF va fa -> PrimExpr "SELF" [] $ mkAnns [] [fa] [va]
+    CONTRACT va fa ty -> PrimExpr "CONTRACT" [toExpression ty] $
+      mkAnns [] [fa] [va]
+    TRANSFER_TOKENS va -> PrimExpr "TRANSFER_TOKENS" [] $ mkAnns [] [] [va]
+    SET_DELEGATE va -> PrimExpr "SET_DELEGATE" [] $ mkAnns [] [] [va]
+    CREATE_CONTRACT va1 va2 c ->
+      PrimExpr "CREATE_CONTRACT" [toExpression c] $
+      mkAnns [] [] [va1, va2]
+    IMPLICIT_ACCOUNT va -> PrimExpr "IMPLICIT_ACCOUNT" [] $
+      mkAnns [] [] [va]
+    NOW va -> PrimExpr "NOW" [] $ mkAnns [] [] [va]
+    AMOUNT va -> PrimExpr "AMOUNT" [] $ mkAnns [] [] [va]
+    BALANCE va -> PrimExpr "BALANCE" [] $ mkAnns [] [] [va]
+    VOTING_POWER va -> PrimExpr "VOTING_POWER" [] $ mkAnns [] [] [va]
+    TOTAL_VOTING_POWER va -> PrimExpr "TOTAL_VOTING_POWER" [] $
+      mkAnns [] [] [va]
+    CHECK_SIGNATURE va -> PrimExpr "CHECK_SIGNATURE" [] $ mkAnns [] [] [va]
+    SHA256 va -> PrimExpr "SHA256" [] $ mkAnns [] [] [va]
+    SHA512 va -> PrimExpr "SHA512" [] $ mkAnns [] [] [va]
+    BLAKE2B va -> PrimExpr "BLAKE2B" [] $ mkAnns [] [] [va]
+    SHA3 va -> PrimExpr "SHA3" [] $ mkAnns [] [] [va]
+    KECCAK va -> PrimExpr "KECCAK" [] $ mkAnns [] [] [va]
+    HASH_KEY va -> PrimExpr "HASH_KEY" [] $ mkAnns [] [] [va]
+    PAIRING_CHECK va -> PrimExpr "PAIRING_CHECK" [] $ mkAnns [] [] [va]
+    SOURCE va -> PrimExpr "SOURCE" [] $ mkAnns [] [] [va]
+    SENDER va -> PrimExpr "SENDER" [] $ mkAnns [] [] [va]
+    ADDRESS va -> PrimExpr "ADDRESS" [] $ mkAnns [] [] [va]
+    CHAIN_ID va -> PrimExpr "CHAIN_ID" [] $ mkAnns [] [] [va]
+    LEVEL va -> PrimExpr "LEVEL" [] $ mkAnns [] [] [va]
+    SELF_ADDRESS va -> PrimExpr "SELF_ADDRESS" [] $ mkAnns [] [] [va]
+    TICKET va -> PrimExpr "TICKET" [] $ mkAnns [] [] [va]
+    READ_TICKET va -> PrimExpr "READ_TICKET" [] $ mkAnns [] [] [va]
+    SPLIT_TICKET va -> PrimExpr "SPLIT_TICKET" [] $ mkAnns [] [] [va]
+    JOIN_TICKETS va -> PrimExpr "JOIN_TICKETS" [] $ mkAnns [] [] [va]
+    NEVER -> PrimExpr "NEVER" [] []
+    EXT _ -> ExpressionSeq []
     where
-      addRootAnnToExpression :: HasCallStack =>
-        RootAnn -> Expression -> Expression
-      addRootAnnToExpression rootAnn expr = case expr of
-        ExpressionPrim p
-          | rootAnn /= noAnn -> ExpressionPrim p
-            { mpaAnnots = mpaAnnots p |> AnnotationField rootAnn
-            }
-          | otherwise -> expr
-        -- Currently this error can't happen because parameter type
-        -- must be a Micheline primitive. If it ever changes, we
-        -- would like to notice it ASAP and update this place.
-        _ -> error $ "parameter is not a primitive: " <> show expr
+      wordToExpr :: Word -> Expression
+      wordToExpr = toExpression @(Value 'TInt) . VInt . fromIntegral @Word @Integer
 
+instance ToExpression Untyped.Contract where
+  toExpression contract
+    = ExpressionSeq $ Untyped.mapEntriesOrdered contract
+          (\(Untyped.ParameterType ty rootAnn) -> PrimExpr "parameter"
+            [insertRootAnn (toExpression ty) rootAnn] [])
+          (\storage -> PrimExpr "storage" [toExpression storage] [])
+          (\code -> PrimExpr "code" [toExpression code] [])
+
+instance ToExpression (Contract cp st) where
+  toExpression = toExpression . convertContract
+
 -- | Errors that can happen when we convert an 'Expression' to our
 -- data type.
-data FromExpressionError = FromExpressionError UnpackError
+data FromExpressionError = FromExpressionError Expression Text
   deriving stock (Show, Eq)
 
 instance Buildable FromExpressionError where
-  build (FromExpressionError err) = build err
+  build (FromExpressionError expr err) =
+    unlinesF
+      [ "Failed to convert expression:"
+      , indentF 2 $ build expr
+      , ""
+      , "Error:"
+      , indentF 2 $ build err
+      ]
 
 instance Exception FromExpressionError where
   displayException = pretty
@@ -101,33 +314,621 @@
 class FromExpression a where
   fromExpression :: Expression -> Either FromExpressionError a
 
-instance UnpackedValScope t => FromExpression (Value t) where
-  -- | `05` is the prefix for serialized Michelson value.
-  fromExpression =
-    first FromExpressionError . unpackValue' . ("\05" <>) . encodeExpression
+instance (SingI t) => FromExpression (Value t) where
+  fromExpression expr =
+    case fromExpression @Untyped.Value expr of
+    Right uv -> case typeCheck uv of
+      Left tcErr -> Left $ FromExpressionError expr $
+        pretty $ unlinesF
+          [ "Failed to typecheck expression as a value of type:"
+          , indentF 2 $ build $ demote @t
+          , ""
+          , "Typechecker error:"
+          , indentF 2 $ build tcErr
+          ]
+      Right tv -> Right tv
+    Left e -> Left e
+    where
+      typeCheck uv = typeCheckingWith (TypeCheckOptions False False) $
+        (runTypeCheck $ TypeCheckValue (uv, demote @t)) $
+        usingReaderT def $
+        typeCheckValue uv
 
-instance FromExpression [ExpandedOp] where
-  fromExpression = first FromExpressionError . unpackInstr' . encodeExpression
+instance FromExpression Untyped.Value where
+  fromExpression e = case e of
+    ExpressionInt v -> pure $ Untyped.ValueInt v
+    ExpressionString s -> first (FromExpressionError e)
+      (Untyped.ValueString <$> mkMText s)
+    ExpressionBytes bs -> pure $ Untyped.ValueBytes $ Untyped.InternalByteString bs
+    PrimExpr "Unit" [] [] -> pure Untyped.ValueUnit
+    PrimExpr "True" [] [] -> pure Untyped.ValueTrue
+    PrimExpr "False" [] [] -> pure Untyped.ValueFalse
+    PrimExpr "Pair" [l, r] [] -> do
+      l' <- fromExpression l
+      r' <- fromExpression r
+      pure $ Untyped.ValuePair l' r'
+    PrimExpr "Pair" args [] ->
+      case (nonEmpty args) >>= forbidSingletonList of
+        Nothing -> Left $ FromExpressionError e
+          "Expected a pair with at least 2 arguments"
+        Just args' -> fromExpression $ seqToPairExpr args' "Pair"
+    PrimExpr "Left" [arg] [] -> do
+      arg' <- fromExpression arg
+      pure $ Untyped.ValueLeft arg'
+    PrimExpr "Right" [arg] [] -> do
+      arg' <- fromExpression arg
+      pure $ Untyped.ValueRight arg'
+    PrimExpr "Some" [arg] [] -> do
+      arg' <- fromExpression arg
+      pure $ Untyped.ValueSome arg'
+    PrimExpr "None" [] [] -> pure Untyped.ValueNone
+    ExpressionSeq [] -> pure Untyped.ValueNil
+    ExpressionSeq (h : t) ->
+      case fromExpression @Untyped.ExpandedOp h of
+      Right op -> do
+        ops <- traverse (fromExpression @Untyped.ExpandedOp) t
+        pure . Untyped.ValueLambda $ op :| ops
+      Left _ -> case exprToElt h of
+        Right elt -> do
+          elts <- traverse exprToElt t
+          pure . Untyped.ValueMap $ elt :| elts
+        Left _ -> case fromExpression h of
+          Left (FromExpressionError err _) -> Left $ FromExpressionError err
+            "Value, instruction or 'Elt' expression expected"
+          Right h' -> do
+            t' <- traverse fromExpression t
+            pure . Untyped.ValueSeq $ h' :| t'
+    _ -> Left $ FromExpressionError e "Expected a value"
+    where
+      exprToElt :: Expression -> Either FromExpressionError (Untyped.Elt ExpandedOp)
+      exprToElt ex = case ex of
+        PrimExpr "Elt" [l, r] [] -> do
+          l' <- fromExpression l
+          r' <- fromExpression r
+          pure $ Untyped.Elt l' r'
+        PrimExpr "Elt" _ [] -> Left $ FromExpressionError ex
+          "Expected 'Elt' expression with exactly 2 elements"
+        PrimExpr "Elt" _ _ -> Left $ FromExpressionError ex
+          "Expected 'Elt' expression without annotations"
+        _ -> Left $ FromExpressionError ex "Expected 'Elt' expression"
 
+instance (FromExpression a) => FromExpression [a] where
+  fromExpression = \case
+    ExpressionSeq exprs -> traverse fromExpression exprs
+    e -> Left $ FromExpressionError e "'ExpressionSeq' expected"
+
+instance FromExpression ExpandedOp where
+  fromExpression = \case
+    ExpressionSeq s -> SeqEx <$> traverse fromExpression s
+    e               -> PrimEx <$> fromExpression e
+
+instance FromExpression ExpandedInstr where
+  fromExpression e = let annSet = getAnnSet e in case e of
+    PrimExpr "DROP" [n] [] -> do
+      n' <- intExprToWord n
+      pure $ DROPN n'
+    PrimExpr "DROP" [] _ -> pure $ DROP
+    PrimExpr "DUP" [n] _ -> do
+      checkAnnsCount e annSet (0, 0, 1)
+      let va = firstAnn @VarTag annSet
+      n' <- intExprToWord n
+      pure $ DUPN va n'
+    PrimExpr "DUP" [] _ ->
+      let va = firstAnn @VarTag annSet
+      in checkAnnsCount e annSet (0, 0, 1) $> DUP va
+    PrimExpr "SWAP" [] [] -> pure $ SWAP
+    PrimExpr "DIG" [n] [] -> do
+      n' <- intExprToWord n
+      pure $ DIG $ n'
+    PrimExpr "DUG" [n] [] -> do
+      n' <- intExprToWord n
+      pure $ DUG n'
+    PrimExpr "PUSH" [t, v] _ -> do
+      checkAnnsCount e annSet (0, 0, 1)
+      let va = firstAnn @VarTag annSet
+      t' <- fromExpression @Ty t
+      v' <- fromExpression @Untyped.Value v
+      pure $ PUSH va t' v'
+    PrimExpr "SOME" [] _ ->
+      let ta = firstAnn @TypeTag annSet
+          va = firstAnn @VarTag annSet
+      in checkAnnsCount e annSet (1, 0, 1) $> SOME ta va
+    PrimExpr "NONE" [t] _ -> do
+      checkAnnsCount e annSet (1, 0, 1)
+      let ta = firstAnn @TypeTag annSet
+      let va = firstAnn @VarTag annSet
+      t' <- fromExpression @Ty t
+      pure $ NONE ta va t'
+    PrimExpr "UNIT" [] _ ->
+      let ta = firstAnn @TypeTag annSet
+          va = firstAnn @VarTag annSet
+      in checkAnnsCount e annSet (1, 0, 1) $> UNIT ta va
+    PrimExpr "IF_NONE" [ops1, ops2] [] -> do
+      ops1' <- fromExpression @([ExpandedOp]) ops1
+      ops2' <- fromExpression @([ExpandedOp]) ops2
+      pure $ IF_NONE ops1' ops2'
+    PrimExpr "PAIR" [] _ ->
+      let ta = firstAnn @TypeTag annSet
+          va = firstAnn @VarTag annSet
+          fa1 = firstAnn @FieldTag annSet
+          fa2 = secondAnn @FieldTag annSet
+      in (checkAnnsCount e annSet (1, 2, 1)) $> PAIR ta va fa1 fa2
+    PrimExpr "UNPAIR" [] _ ->
+      let va1 = firstAnn @VarTag annSet
+          va2 = secondAnn @VarTag annSet
+          fa1 = firstAnn @FieldTag annSet
+          fa2 = secondAnn @FieldTag annSet
+      in checkAnnsCount e annSet (0, 2, 2) $> UNPAIR va1 va2 fa1 fa2
+    PrimExpr "PAIR" [n] _ -> do
+      checkAnnsCount e annSet (0, 0, 1)
+      n' <- intExprToWord n
+      let va = firstAnn @VarTag annSet
+      pure $ PAIRN va n'
+    PrimExpr "UNPAIR" [n] [] -> do
+      n' <- intExprToWord n
+      pure $ UNPAIRN n'
+    PrimExpr "CAR" [] _ ->
+      let va = firstAnn @VarTag annSet
+          fa = firstAnn @FieldTag annSet
+      in checkAnnsCount e annSet (0, 1, 1) $> CAR va fa
+    PrimExpr "CDR" [] _ ->
+      let va = firstAnn @VarTag annSet
+          fa = firstAnn @FieldTag annSet
+      in checkAnnsCount e annSet (0, 1, 1) $> CDR va fa
+    PrimExpr "LEFT" [t] _ -> do
+      checkAnnsCount e annSet (1, 2, 1)
+      t' <- fromExpression @Ty t
+      let ta = firstAnn @TypeTag annSet
+      let va = firstAnn @VarTag annSet
+      let fa1 = firstAnn @FieldTag annSet
+      let fa2 = secondAnn @FieldTag annSet
+      pure $ LEFT ta va fa1 fa2 t'
+    PrimExpr "RIGHT" [t] _ -> do
+      checkAnnsCount e annSet (1, 2, 1)
+      t' <- fromExpression @Ty t
+      let ta = firstAnn @TypeTag annSet
+      let va = firstAnn @VarTag annSet
+      let fa1 = firstAnn @FieldTag annSet
+      let fa2 = secondAnn @FieldTag annSet
+      pure $ RIGHT ta va fa1 fa2 t'
+    PrimExpr "IF_LEFT" [ops1, ops2] [] -> do
+      ops1' <- fromExpression @([ExpandedOp]) ops1
+      ops2' <- fromExpression @([ExpandedOp]) ops2
+      pure $ IF_LEFT ops1' ops2'
+    PrimExpr "NIL" [t] _ -> do
+      checkAnnsCount e annSet (1, 0, 1)
+      t' <- fromExpression @Ty t
+      let va = firstAnn @VarTag annSet
+      let ta = firstAnn @TypeTag annSet
+      pure $ NIL ta va t'
+    PrimExpr "CONS" [] anns -> mkInstrWithVarAnn CONS anns
+    PrimExpr "IF_CONS" [ops1, ops2] [] -> do
+      ops1' <- fromExpression @([ExpandedOp]) ops1
+      ops2' <- fromExpression @([ExpandedOp]) ops2
+      pure $ IF_CONS ops1' ops2'
+    PrimExpr "SIZE" [] anns -> mkInstrWithVarAnn SIZE anns
+    PrimExpr "EMPTY_SET" [t] _ -> do
+      checkAnnsCount e annSet (1, 0, 1)
+      t' <- fromExpression @Ty t
+      let va = firstAnn @VarTag annSet
+      let ta = firstAnn @TypeTag annSet
+      pure $ EMPTY_SET ta va t'
+    PrimExpr "EMPTY_MAP" [kt, vt] _ -> do
+      checkAnnsCount e annSet (1, 0, 1)
+      kt' <- fromExpression @Ty kt
+      vt' <- fromExpression @Ty vt
+      let va = firstAnn @VarTag annSet
+      let ta = firstAnn @TypeTag annSet
+      pure $ EMPTY_MAP ta va kt' vt'
+    PrimExpr "EMPTY_BIG_MAP" [kt, vt] _ -> do
+      checkAnnsCount e annSet (1, 0, 1)
+      kt' <- fromExpression @Ty kt
+      vt' <- fromExpression @Ty vt
+      let va = firstAnn @VarTag annSet
+      let ta = firstAnn @TypeTag annSet
+      pure $ EMPTY_BIG_MAP ta va kt' vt'
+    PrimExpr "MAP" [ops] _ -> do
+      checkAnnsCount e annSet (0, 0, 1)
+      ops' <- fromExpression @([ExpandedOp]) ops
+      let va = firstAnn @VarTag annSet
+      pure $ MAP va ops'
+    PrimExpr "ITER" [ops] [] -> do
+      ops' <- fromExpression @([ExpandedOp]) ops
+      pure $ ITER ops'
+    PrimExpr "MEM" [] anns -> mkInstrWithVarAnn MEM anns
+    PrimExpr "GET" [] anns -> mkInstrWithVarAnn GET anns
+    PrimExpr "GET" [n] _ -> do
+      checkAnnsCount e annSet (0, 0, 1)
+      n' <- intExprToWord n
+      let va = firstAnn @VarTag annSet
+      pure $ GETN va n'
+    PrimExpr "UPDATE" [] anns -> mkInstrWithVarAnn UPDATE anns
+    PrimExpr "UPDATE" [n] _ -> do
+      checkAnnsCount e annSet (0, 0, 1)
+      n' <- intExprToWord n
+      let va = firstAnn @VarTag annSet
+      pure $ UPDATEN va n'
+    PrimExpr "GET_AND_UPDATE" [] anns ->
+      mkInstrWithVarAnn GET_AND_UPDATE anns
+    PrimExpr "IF" [ops1, ops2] [] -> do
+      ops1' <- fromExpression @([ExpandedOp]) ops1
+      ops2' <- fromExpression @([ExpandedOp]) ops2
+      pure $ IF ops1' ops2'
+    PrimExpr "LOOP" [ops] [] -> do
+      ops' <- fromExpression @([ExpandedOp]) ops
+      pure $ LOOP ops'
+    PrimExpr "LOOP_LEFT" [ops] [] -> do
+      ops' <- fromExpression @([ExpandedOp]) ops
+      pure $ LOOP_LEFT ops'
+    PrimExpr "LAMBDA" [inp, out, ops] _ -> do
+      checkAnnsCount e annSet (0, 0, 1)
+      inp' <- fromExpression @Ty inp
+      out' <- fromExpression @Ty out
+      ops' <- fromExpression @([ExpandedOp]) ops
+      let va = firstAnn @VarTag annSet
+      pure $ LAMBDA va inp' out' ops'
+    PrimExpr "EXEC" [] anns -> mkInstrWithVarAnn EXEC anns
+    PrimExpr "APPLY" [] anns -> mkInstrWithVarAnn APPLY anns
+    PrimExpr "DIP" [ops] [] -> do
+      ops' <- fromExpression @([ExpandedOp]) ops
+      pure $ DIP ops'
+    PrimExpr "DIP" [n, ops] [] -> do
+      n' <- intExprToWord n
+      ops' <- fromExpression @([ExpandedOp]) ops
+      pure $ DIPN n' ops'
+    PrimExpr "FAILWITH" [] [] -> pure FAILWITH
+    PrimExpr "CAST" [t] _ -> do
+      checkAnnsCount e annSet (0, 0, 1)
+      t' <- fromExpression @Ty t
+      let va = firstAnn @VarTag annSet
+      pure $ CAST va t'
+    PrimExpr "RENAME" [] anns -> mkInstrWithVarAnn RENAME anns
+    PrimExpr "PACK" [] anns -> mkInstrWithVarAnn PACK anns
+    PrimExpr "UNPACK" [t] _ -> do
+      checkAnnsCount e annSet (1, 0, 1)
+      t' <- fromExpression @Ty t
+      let ta = firstAnn @TypeTag annSet
+      let va = firstAnn @VarTag annSet
+      pure $ UNPACK ta va t'
+    PrimExpr "CONCAT" [] anns -> mkInstrWithVarAnn CONCAT anns
+    PrimExpr "SLICE" [] anns -> mkInstrWithVarAnn SLICE anns
+    PrimExpr "ISNAT" [] anns -> mkInstrWithVarAnn ISNAT anns
+    PrimExpr "ADD" [] anns -> mkInstrWithVarAnn ADD anns
+    PrimExpr "SUB" [] anns -> mkInstrWithVarAnn SUB anns
+    PrimExpr "MUL" [] anns -> mkInstrWithVarAnn MUL anns
+    PrimExpr "EDIV" [] anns -> mkInstrWithVarAnn EDIV anns
+    PrimExpr "ABS" [] anns -> mkInstrWithVarAnn ABS anns
+    PrimExpr "NEG" [] anns -> mkInstrWithVarAnn NEG anns
+    PrimExpr "LSL" [] anns -> mkInstrWithVarAnn LSL anns
+    PrimExpr "LSR" [] anns -> mkInstrWithVarAnn LSR anns
+    PrimExpr "OR" [] anns -> mkInstrWithVarAnn OR anns
+    PrimExpr "AND" [] anns -> mkInstrWithVarAnn AND anns
+    PrimExpr "XOR" [] anns -> mkInstrWithVarAnn XOR anns
+    PrimExpr "NOT" [] anns -> mkInstrWithVarAnn NOT anns
+    PrimExpr "COMPARE" [] anns -> mkInstrWithVarAnn COMPARE anns
+    PrimExpr "EQ" [] anns -> mkInstrWithVarAnn Untyped.EQ anns
+    PrimExpr "NEQ" [] anns -> mkInstrWithVarAnn NEQ anns
+    PrimExpr "LT" [] anns -> mkInstrWithVarAnn Untyped.LT anns
+    PrimExpr "GT" [] anns -> mkInstrWithVarAnn Untyped.GT anns
+    PrimExpr "LE" [] anns -> mkInstrWithVarAnn LE anns
+    PrimExpr "GE" [] anns -> mkInstrWithVarAnn GE anns
+    PrimExpr "INT" [] anns -> mkInstrWithVarAnn INT anns
+    PrimExpr "SELF" [] _ ->
+      let fa = firstAnn @FieldTag annSet
+          va = firstAnn @VarTag annSet
+      in checkAnnsCount e annSet (0, 1, 1) $> SELF va fa
+    PrimExpr "CONTRACT" [t] _ -> do
+      checkAnnsCount e annSet (0, 1, 1)
+      t' <- fromExpression @Ty t
+      let va = firstAnn @VarTag annSet
+      let fa = firstAnn @FieldTag annSet
+      pure $ CONTRACT va fa t'
+    PrimExpr "TRANSFER_TOKENS" [] anns ->
+      mkInstrWithVarAnn TRANSFER_TOKENS anns
+    PrimExpr "SET_DELEGATE" [] anns ->
+      mkInstrWithVarAnn SET_DELEGATE anns
+    PrimExpr "CREATE_CONTRACT" [c] _ -> do
+      checkAnnsCount e annSet (0, 0, 2)
+      c' <- fromExpression @Untyped.Contract c
+      let va1 = firstAnn @VarTag annSet
+      let va2 = secondAnn @VarTag annSet
+      pure $ CREATE_CONTRACT va1 va2 c'
+    PrimExpr "IMPLICIT_ACCOUNT" [] anns ->
+      mkInstrWithVarAnn IMPLICIT_ACCOUNT anns
+    PrimExpr "NOW" [] anns -> mkInstrWithVarAnn NOW anns
+    PrimExpr "AMOUNT" [] anns -> mkInstrWithVarAnn AMOUNT anns
+    PrimExpr "BALANCE" [] anns -> mkInstrWithVarAnn BALANCE anns
+    PrimExpr "VOTING_POWER" [] anns ->
+      mkInstrWithVarAnn VOTING_POWER anns
+    PrimExpr "TOTAL_VOTING_POWER" [] anns ->
+      mkInstrWithVarAnn TOTAL_VOTING_POWER anns
+    PrimExpr "CHECK_SIGNATURE" [] anns ->
+      mkInstrWithVarAnn CHECK_SIGNATURE anns
+    PrimExpr "SHA256" [] anns -> mkInstrWithVarAnn SHA256 anns
+    PrimExpr "SHA512" [] anns -> mkInstrWithVarAnn SHA512 anns
+    PrimExpr "BLAKE2B" [] anns -> mkInstrWithVarAnn BLAKE2B anns
+    PrimExpr "SHA3" [] anns -> mkInstrWithVarAnn SHA3 anns
+    PrimExpr "KECCAK" [] anns -> mkInstrWithVarAnn KECCAK anns
+    PrimExpr "HASH_KEY" [] anns -> mkInstrWithVarAnn HASH_KEY anns
+    PrimExpr "PAIRING_CHECK" [] anns ->
+      mkInstrWithVarAnn PAIRING_CHECK anns
+    PrimExpr "SOURCE" [] anns -> mkInstrWithVarAnn SOURCE anns
+    PrimExpr "SENDER" [] anns -> mkInstrWithVarAnn SENDER anns
+    PrimExpr "ADDRESS" [] anns -> mkInstrWithVarAnn ADDRESS anns
+    PrimExpr "CHAIN_ID" [] anns -> mkInstrWithVarAnn CHAIN_ID anns
+    PrimExpr "LEVEL" [] anns -> mkInstrWithVarAnn LEVEL anns
+    PrimExpr "SELF_ADDRESS" [] anns ->
+      mkInstrWithVarAnn SELF_ADDRESS anns
+    PrimExpr "NEVER" [] [] -> pure NEVER
+    PrimExpr "TICKET" [] anns -> mkInstrWithVarAnn TICKET anns
+    PrimExpr "READ_TICKET" [] anns ->
+      mkInstrWithVarAnn READ_TICKET anns
+    PrimExpr "SPLIT_TICKET" [] anns ->
+      mkInstrWithVarAnn SPLIT_TICKET anns
+    PrimExpr "JOIN_TICKETS" [] anns ->
+      mkInstrWithVarAnn JOIN_TICKETS anns
+    _ -> Left $ FromExpressionError e "Expected an instruction"
+
+    where
+      intExprToWord :: Expression -> Either FromExpressionError Word
+      intExprToWord n = do
+        v <- fromExpression @(Value 'TInt) n
+        case v of
+          VInt n' -> maybeToRight (FromExpressionError n "Value is out of bounds")
+            (toIntegralSized @Integer @Word n')
+
+      mkInstrWithVarAnn
+        :: (VarAnn -> ExpandedInstr)
+        -> [Annotation]
+        -> Either FromExpressionError ExpandedInstr
+      mkInstrWithVarAnn ctor anns =
+        let annSet = toAnnSet anns
+            va = firstAnn @VarTag annSet
+        in checkAnnsCount e annSet (0, 0, 1) $> ctor va
+
+      getAnnSet :: Expression -> AnnotationSet
+      getAnnSet = \case
+        PrimExpr _ _ anns -> toAnnSet anns
+        _                 -> emptyAnnSet
+
 instance FromExpression Untyped.Contract where
-  fromExpression =
-    first FromExpressionError . launchGet decodeContract .
-    LBS.fromStrict . encodeExpression
+  fromExpression blocks = case blocks of
+    ExpressionSeq [b1, b2, b3] -> do
+      b1' <- exprToCB b1
+      b2' <- exprToCB b2
+      b3' <- exprToCB b3
+      maybeToRight (FromExpressionError blocks fullErrorMsg)
+        (orderContractBlock (b1', b2', b3'))
+    expr -> Left $ FromExpressionError expr fullErrorMsg
+    where
+      exprToCB
+        :: Expression
+        -> Either FromExpressionError (ContractBlock ExpandedOp)
+      exprToCB e = case e of
+        PrimExpr "parameter" args anns -> mkCbParam e args anns
+        PrimExpr "storage"   args anns -> mkCBStorage e args anns
+        PrimExpr "code"      args anns -> mkCBCode e args anns
+        _                              -> Left $ FromExpressionError e fullErrorMsg
 
-instance FromExpression Untyped.Ty where
-  fromExpression =
-    first FromExpressionError .
-    launchGet decodeType .
-    LBS.fromStrict .
-    encodeExpression
+      mkCbParam
+        :: Expression
+        -> [Expression]
+        -> [Annotation]
+        -> Either FromExpressionError (ContractBlock ExpandedOp)
+      mkCbParam e args anns = case (args, anns) of
+        ([p], []) -> do
+          let annSet = toAnnSet (p ^. _ExpressionPrim . mpaAnnotsL)
+          let rootAnn = firstAnn @FieldTag annSet
+          unless (secondAnn @FieldTag annSet == noAnn) $
+            Left $ FromExpressionError p
+              "Expected parameter with at most 1 root annotation"
+          p' <- fromExpression @Ty
+            (p & _ExpressionPrim . mpaAnnotsL %~ filter (not . isAnnotationField))
+          pure $ CBParam $ Untyped.ParameterType p' rootAnn
+        _ -> Left $ FromExpressionError e
+          "Expected 'parameter' block without annotations and exactly 1 argument"
 
+      mkCBStorage
+        :: Expression
+        -> [Expression]
+        -> [Annotation]
+        -> Either FromExpressionError (ContractBlock ExpandedOp)
+      mkCBStorage e args anns = case (args, anns) of
+        ([s], []) -> do
+          s' <- fromExpression @Ty s
+          pure $ CBStorage s'
+        _ -> Left $ FromExpressionError e
+               "Expected 'storage' block without annotations and exactly 1 argument"
+
+      mkCBCode
+        :: Expression
+        -> [Expression]
+        -> [Annotation]
+        -> Either FromExpressionError (ContractBlock ExpandedOp)
+      mkCBCode e args anns = case (args, anns) of
+        ([ops], []) -> do
+          ops' <- fromExpression @([ExpandedOp]) ops
+          pure $ CBCode ops'
+        _ -> Left $ FromExpressionError e
+               "Expected 'code' block without annotations"
+
+      fullErrorMsg = "Expected contract expression to have exactly 3 " <>
+        "sub-expressions ('parameter', 'storage' and 'code')"
+
+
+instance FromExpression Untyped.T where
+  fromExpression e = case e of
+    PrimExpr "key" [] [] -> pure Untyped.TKey
+    PrimExpr "unit" [] [] -> pure Untyped.TUnit
+    PrimExpr "signature" [] [] -> pure Untyped.TSignature
+    PrimExpr "chain_id" [] [] -> pure Untyped.TChainId
+    PrimExpr "option" [arg] [] -> do
+      arg' <- fromExpression arg
+      pure $ Untyped.TOption arg'
+    PrimExpr "list" [arg] [] -> do
+      arg' <- fromExpression arg
+      pure $ Untyped.TList arg'
+    PrimExpr "set" [arg] [] -> do
+      arg' <- fromExpression arg
+      pure $ Untyped.TSet arg'
+    PrimExpr "operation" [] [] -> pure Untyped.TOperation
+    PrimExpr "contract" [arg] [] -> do
+      arg' <- fromExpression arg
+      pure $ Untyped.TContract arg'
+    PrimExpr "ticket" [arg] [] -> do
+      arg' <- fromExpression arg
+      pure $ Untyped.TTicket arg'
+    PrimExpr "or" [arg1, arg2] [] -> do
+      let as1 = toAnnSet $ arg1 ^. _ExpressionPrim . mpaAnnotsL
+      let as2 = toAnnSet $ arg2 ^. _ExpressionPrim . mpaAnnotsL
+      checkAnnsCount e as1 (1, 1, 0)
+      checkAnnsCount e as2 (1, 1, 0)
+      let fa1 = firstAnn @FieldTag as1
+      let fa2 = firstAnn @FieldTag as2
+      l <- fromExpression $ removeAnns arg1 isAnnotationField
+      r <- fromExpression $ removeAnns arg2 isAnnotationField
+      pure $ Untyped.TOr fa1 fa2 l r
+    PrimExpr "pair" [arg1, arg2] [] -> do
+      let as1 = toAnnSet $ arg1 ^. _ExpressionPrim . mpaAnnotsL
+      let as2 = toAnnSet $ arg2 ^. _ExpressionPrim . mpaAnnotsL
+      checkAnnsCount e as1 (1, 1, 1)
+      checkAnnsCount e as2 (1, 1, 1)
+      let fa1 = firstAnn @FieldTag as1
+      let fa2 = firstAnn @FieldTag as2
+      let va1 = firstAnn @VarTag as1
+      let va2 = firstAnn @VarTag as2
+      l <- fromExpression $ removeAnns arg1
+        (liftA2 (||) isAnnotationField isAnnotationVariable)
+      r <- fromExpression $ removeAnns arg2
+        (liftA2 (||) isAnnotationField isAnnotationVariable)
+      pure $ Untyped.TPair fa1 fa2 va1 va2 l r
+    PrimExpr "pair" args [] ->
+      case (nonEmpty args) >>= forbidSingletonList of
+        Nothing -> Left $ FromExpressionError e
+          "Expected a pair with at least 2 arguments"
+        Just args' -> fromExpression $ seqToPairExpr args' "pair"
+    PrimExpr "lambda" args [] -> mkDoubleParamType Untyped.TLambda args e
+      "Expected a lambda with input and output types"
+    PrimExpr "map" args [] -> mkDoubleParamType Untyped.TMap args e
+      "Expected a map with key and value types"
+    PrimExpr "big_map" args [] -> mkDoubleParamType Untyped.TBigMap args e
+      "Expected a big_map with key and value types"
+    PrimExpr "int" [] [] -> pure Untyped.TInt
+    PrimExpr "nat" [] [] -> pure Untyped.TNat
+    PrimExpr "string" [] [] -> pure Untyped.TString
+    PrimExpr "bytes" [] [] -> pure Untyped.TBytes
+    PrimExpr "mutez" [] [] -> pure Untyped.TMutez
+    PrimExpr "bool" [] [] -> pure Untyped.TBool
+    PrimExpr "key_hash" [] [] -> pure Untyped.TKeyHash
+    PrimExpr "bls12_381_fr" [] [] -> pure Untyped.TBls12381Fr
+    PrimExpr "bls12_381_g1" [] [] -> pure Untyped.TBls12381G1
+    PrimExpr "bls12_381_g2" [] [] -> pure Untyped.TBls12381G2
+    PrimExpr "timestamp" [] [] -> pure Untyped.TTimestamp
+    PrimExpr "address" [] [] -> pure Untyped.TAddress
+    PrimExpr "never" [] [] -> pure Untyped.TNever
+    _ -> Left $ FromExpressionError e "Expected a type"
+    where
+      mkDoubleParamType
+        :: (Ty -> Ty -> Untyped.T)
+        -> [Expression]
+        -> Expression
+        -> Text
+        -> Either FromExpressionError Untyped.T
+      mkDoubleParamType ctor args expr msg = do
+        case args of
+          [arg1, arg2] -> do
+            arg1' <- fromExpression arg1
+            arg2' <- fromExpression arg2
+            pure $ ctor arg1' arg2'
+          _ -> Left $ FromExpressionError expr msg
+
+      removeAnns :: Expression -> (Annotation -> Bool) -> Expression
+      removeAnns expr p =
+        expr & _ExpressionPrim . mpaAnnotsL %~ filter (not . p)
+
+instance FromExpression Ty where
+  fromExpression e = case e of
+    PrimExpr primName args anns -> do
+      let annSet = toAnnSet anns
+      let ta = firstAnn @TypeTag annSet
+      when (secondAnn @TypeTag annSet /= noAnn) $
+        Left $ FromExpressionError e
+          "Expected expression with at most 1 type annotation"
+      t <- fromExpression @Untyped.T $ PrimExpr primName args $ filter
+        (not . isAnnotationType) anns
+      pure $ Ty t ta
+    _ -> Left $ FromExpressionError e "Expected a type"
+
 instance FromExpression T where
   fromExpression =
     second fromUType . fromExpression @Untyped.Ty
 
 -- Note: we should generalize this to work for any instruction,
 -- not just lambdas (i.e. instructions with one input and one output).
-instance (KnownT inp, KnownT out) => FromExpression (Instr '[inp] '[out]) where
+instance (SingI inp, SingI out) => FromExpression (Instr '[inp] '[out]) where
   fromExpression expr =
     fromExpression @(Value ('TLambda inp out)) expr <&> \case
       VLam instr -> rfAnyInstr instr
+
+----------------------------------------------------------------------------
+-- Helpers
+----------------------------------------------------------------------------
+
+-- | Converts a sequence of expression to the right combed pair.
+seqToPairExpr :: NonEmpty Expression -> Text -> Expression
+seqToPairExpr e name = foldr1 (\x xs -> PrimExpr name [x, xs] []) e
+
+-- | Adds annotations to the expression, after removing empty annotations
+-- at the end of each list.
+addTrimmedAnns
+  :: Expression
+  -> [TypeAnn]
+  -> [FieldAnn]
+  -> [VarAnn]
+  -> Expression
+addTrimmedAnns e tas fas vas =
+  e & _ExpressionPrim . mpaAnnotsL <>~ mkAnns tas fas vas
+
+-- | Inserts the root annotation into the contract parameter.
+insertRootAnn :: HasCallStack => Expression -> RootAnn -> Expression
+insertRootAnn expr rootAnn = case expr of
+  ExpressionPrim p
+    -- The order of annotations is important iff there are
+    -- multiple annotations of the same kind or there are
+    -- other kinds of annotations in the list.
+    -- Prepending root field annotation is okay because
+    -- there can not be more than one root annotation.
+    | rootAnn /= noAnn -> ExpressionPrim p
+      { mpaAnnots = AnnotationField rootAnn : mpaAnnots p
+      }
+    | otherwise -> expr
+  -- Currently this error can't happen because parameter type
+  -- must be a Micheline primitive. If it ever changes, we
+  -- would like to notice it ASAP and update this place.
+  _ -> error $ "parameter is not a primitive: " <> show expr
+
+-- | Checks for a given expression that the number of annotations
+-- of each type in it doesn't exceed the specified threshold.
+checkAnnsCount
+  :: Expression
+  -> AnnotationSet
+  -> (Int, Int, Int)
+  -> Either FromExpressionError ()
+checkAnnsCount e annSet maxCount@(maxTas, maxFas, maxVas) =
+  let actualCount@(tasCnt, fasCnt, vasCnt) = annsCount annSet
+  in unless (actualCount <= maxCount) $
+    Left $ FromExpressionError e $ pretty $ unlinesF
+      [ "Expected at most"
+      , indentF 2 $ build maxTas <> " type annotations,"
+      , indentF 2 $ build maxFas <> " field annotations,"
+      , indentF 2 $ build maxVas <> " variable annotations"
+      , "but found:"
+      , indentF 2 $ build tasCnt <> " type annotations,"
+      , indentF 2 $ build fasCnt <> " field annotations,"
+      , indentF 2 $ build vasCnt <> " variable annotations."
+      ]
+
+forbidSingletonList :: NonEmpty a -> Maybe (NonEmpty a)
+forbidSingletonList = \case
+  _ :| [] -> Nothing
+  x       -> Just x
diff --git a/src/Morley/Micheline/Expression.hs b/src/Morley/Micheline/Expression.hs
--- a/src/Morley/Micheline/Expression.hs
+++ b/src/Morley/Micheline/Expression.hs
@@ -7,16 +7,34 @@
 -- | Module that defines Expression type, its related types
 -- and its JSON instance.
 module Morley.Micheline.Expression
-  ( Annotation(..)
-  , Expression(..)
+  ( Expression(.., PrimExpr)
   , MichelinePrimAp(..)
   , MichelinePrimitive(..)
   , michelsonPrimitive
+
+  , Annotation (..)
   , annotToText
   , annotFromText
+  , isAnnotationField
+  , isAnnotationType
+  , isAnnotationVariable
+  , isNoAnn
+  , mkAnns
+  , toAnnSet
+
+  -- * Prisms
+  , _ExpressionPrim
+  , _AnnotationField
+  , _AnnotationVariable
+  , _AnnotationType
+
+  -- * Lenses
+  , mpaAnnotsL
   ) where
 
 import Control.Lens (Plated)
+import Control.Lens.TH
+
 import Data.Aeson
   (FromJSON, ToJSON, object, parseJSON, toEncoding, toJSON, withObject, withText, (.!=), (.:),
   (.:?), (.=))
@@ -28,8 +46,10 @@
 import qualified Data.Text as T (uncons)
 import Fmt (Buildable(..), pretty, (+|), (|+))
 
+import qualified Michelson.Untyped as U
 import Michelson.Untyped.Annotation
-  (FieldAnn, FieldTag, KnownAnnTag(..), TypeAnn, TypeTag, VarAnn, VarTag, annPrefix, mkAnnotation)
+  (FieldAnn, FieldTag, KnownAnnTag(..), AnnotationSet(..), TypeAnn, TypeTag,
+  VarAnn, VarTag, annPrefix, mkAnnotation, minimizeAnnSet, fullAnnSet)
 import Morley.Micheline.Json (StringEncode(StringEncode, unStringEncode))
 import Tezos.Crypto (encodeBase58Check)
 import Util.ByteString (HexJSONByteString(..))
@@ -87,10 +107,14 @@
     -- JSON encoding compatibility.
   | ExpressionString Text
   | ExpressionBytes ByteString
-  | ExpressionSeq (Seq Expression)
+  | ExpressionSeq [Expression]
   | ExpressionPrim MichelinePrimAp
   deriving stock (Eq, Show, Data)
 
+pattern PrimExpr :: Text -> [Expression] -> [Annotation] -> Expression
+pattern PrimExpr primName args anns =
+  ExpressionPrim (MichelinePrimAp (MichelinePrimitive primName) args anns)
+
 instance Plated Expression
 
 instance Buildable Expression where
@@ -99,15 +123,13 @@
     ExpressionString s -> build s
     ExpressionBytes b ->
       build $ encodeBase58Check b
-    ExpressionSeq s -> "(" +| buildSeq build s |+ ")"
+    ExpressionSeq s -> "(" +| buildList build s |+ ")"
     ExpressionPrim (MichelinePrimAp (MichelinePrimitive text) s annots) ->
       text <> " " |+ "(" +|
-      buildSeq build s +| ") " +|
-      buildSeq (build . annotToText) annots
+      buildList build s +| ") " +|
+      buildList (build . annotToText) annots
     where
-      buildSeq buildElem =
-        mconcat . intersperse ", " . map
-        buildElem . toList
+      buildList buildElem = mconcat . intersperse ", " . map buildElem
 
 data Annotation
   = AnnotationType TypeAnn
@@ -117,21 +139,21 @@
 
 data MichelinePrimAp = MichelinePrimAp
   { mpaPrim :: MichelinePrimitive
-  , mpaArgs :: Seq Expression
-  , mpaAnnots :: Seq Annotation
+  , mpaArgs :: [Expression]
+  , mpaAnnots :: [Annotation]
   } deriving stock (Eq, Show, Data)
 
 instance FromJSON MichelinePrimAp where
   parseJSON = withObject "Prim" $ \v -> MichelinePrimAp
     <$> v .: "prim"
-    <*> v .:? "args" .!= mempty
-    <*> v .:? "annots" .!= mempty
+    <*> v .:? "args" .!= []
+    <*> v .:? "annots" .!= []
 
 instance ToJSON MichelinePrimAp where
   toJSON MichelinePrimAp {..} = object $ catMaybes
     [ Just ("prim" .= mpaPrim)
-    , if mpaArgs == mempty then Nothing else Just ("args" .= mpaArgs)
-    , if mpaAnnots == mempty then Nothing else Just ("annots" .= mpaAnnots)
+    , if null mpaArgs then Nothing else Just ("args" .= mpaArgs)
+    , if null mpaAnnots then Nothing else Just ("annots" .= mpaAnnots)
     ]
 
 annotFromText :: forall m. MonadFail m => Text -> m Annotation
@@ -156,6 +178,41 @@
   AnnotationVariable n -> pretty n
   AnnotationField n -> pretty n
 
+mkAnns :: [TypeAnn] -> [FieldAnn] -> [VarAnn] -> [Annotation]
+mkAnns tas fas vas =
+  let minAnnSet = minimizeAnnSet $ fullAnnSet tas fas vas
+  in (AnnotationType <$> asTypes minAnnSet) <>
+     (AnnotationField <$> asFields minAnnSet) <>
+     (AnnotationVariable <$> asVars minAnnSet)
+
+isAnnotationField :: Annotation -> Bool
+isAnnotationField = \case
+  AnnotationField _ -> True
+  _                 -> False
+
+isAnnotationVariable :: Annotation -> Bool
+isAnnotationVariable = \case
+  AnnotationVariable _ -> True
+  _                    -> False
+
+isAnnotationType :: Annotation -> Bool
+isAnnotationType = \case
+  AnnotationType _ -> True
+  _                -> False
+
+isNoAnn :: Annotation -> Bool
+isNoAnn = \case
+  AnnotationVariable (U.Annotation "") -> True
+  AnnotationField (U.Annotation "")    -> True
+  AnnotationType (U.Annotation "")     -> True
+  _                                    -> False
+
+toAnnSet :: [Annotation] -> AnnotationSet
+toAnnSet = foldMap $ \case
+  AnnotationType a     -> U.singleAnnSet a
+  AnnotationField a    -> U.singleAnnSet a
+  AnnotationVariable a -> U.singleAnnSet a
+
 instance FromJSON Annotation where
   parseJSON = withText "Annotation" annotFromText
 
@@ -182,3 +239,7 @@
   toEncoding (ExpressionString x) = Aeson.pairs (Aeson.pair "string" (toEncoding x))
   toEncoding (ExpressionInt x) = Aeson.pairs (Aeson.pair "int" (toEncoding $ StringEncode x))
   toEncoding (ExpressionBytes x) = Aeson.pairs (Aeson.pair "bytes" (toEncoding $ HexJSONByteString x))
+
+makePrisms ''Expression
+makePrisms ''Annotation
+makeLensesFor [("mpaAnnots", "mpaAnnotsL")] ''MichelinePrimAp
diff --git a/src/Tezos/Address.hs b/src/Tezos/Address.hs
--- a/src/Tezos/Address.hs
+++ b/src/Tezos/Address.hs
@@ -4,16 +4,16 @@
 
 -- | Address in Tezos.
 
+{-# LANGUAGE DeriveLift #-}
+
 module Tezos.Address
   ( ContractHash (..)
   , Address (..)
   , mkKeyAddress
   , detGenKeyAddress
 
-  , OperationHash (..)
   , OriginationIndex (..)
   , GlobalCounter(..)
-  , mkContractAddress
   , mkContractHashHack
 
   -- * Formatting
@@ -25,6 +25,7 @@
   , parseAddressRaw
   , parseContractHash
   , parseAddress
+  , ta
   , unsafeParseAddressRaw
   , unsafeParseAddress
   , unsafeParseContractHash
@@ -34,19 +35,25 @@
 import qualified Data.Aeson as Aeson
 import qualified Data.Aeson.Encoding as Aeson
 import qualified Data.Aeson.Types as AesonTypes
-import Data.Binary.Put (putInt32be, putWord64be, runPut)
 import qualified Data.ByteString as BS
-import qualified Data.ByteString.Lazy as BSL
+import Data.Text (strip)
 import Fmt (Buildable(build), hexF, pretty)
+import Instances.TH.Lift ()
+import qualified Language.Haskell.TH.Quote as TH
+import qualified Language.Haskell.TH.Syntax as TH
+import Language.Haskell.TH.Syntax (Lift)
+import Text.PrettyPrint.Leijen.Text ((<+>), backslash, dquotes, int, parens)
 
+import Michelson.Printer.Util (RenderDoc (..), buildRenderDoc, renderAnyBuildable)
 import Michelson.Text
 import Tezos.Crypto
 import Util.CLI
+import Util.TypeLits
 
 -- TODO: we should probably have a `Hash` type.
 -- | Hash of origination command for some contract.
 newtype ContractHash = ContractHash ByteString
-  deriving stock (Show, Eq, Ord, Generic)
+  deriving stock (Show, Eq, Ord, Generic, Lift)
 
 instance NFData ContractHash
 
@@ -63,7 +70,7 @@
   -- ^ `tz` address which is a hash of a public key.
   | ContractAddress ContractHash
   -- ^ `KT` address which corresponds to a callable contract.
-  deriving stock (Show, Eq, Ord, Generic)
+  deriving stock (Show, Eq, Ord, Generic, Lift)
 
 instance NFData Address
 
@@ -76,12 +83,6 @@
 detGenKeyAddress :: ByteString -> Address
 detGenKeyAddress = mkKeyAddress . toPublic . detSecretKey
 
-newtype OperationHash = OperationHash
-  { unOperationHash :: ByteString
-  }
-  deriving stock (Show, Eq, Ord, Generic)
-  deriving anyclass (NFData)
-
 -- | Represents the network's global counter.
 --
 -- When a new contract is created (either via a "global" origination operation or
@@ -118,38 +119,6 @@
   deriving stock (Show, Eq, Ord, Generic)
   deriving anyclass (NFData)
 
--- | Compute address of a contract from its origination operation, origination index and global counter.
---
--- However, in real Tezos encoding of the operation is more than just 'OriginationOperation'.
--- There an Operation has several more meta-fields plus a big sum-type of all possible operations.
---
--- See here: https://gitlab.com/tezos/tezos/-/blob/f57c50e3a657956d69a1699978de9873c98f0018/src/proto_006_PsCARTHA/lib_protocol/operation_repr.ml#L78
---
--- What is important is that one (big) Operation may lead to origination of multiple contracts. That
--- is why contract address is constructed from hash of the operation that originated and of index
--- of the contract's origination in the execution of that operation.
---
--- In other words, contract hash is calculated as the blake2b160 (20-byte) hash of
--- origination operation hash + int32 origination index + word64 global counter.
---
--- In Morley we do not yet support full encoding of Tezos Operations, therefore we choose
--- to generate contract addresses in a simplified manner.
---
--- Namely, we encode 'OriginationOperation' as we can and concat it with the origination index
--- and the global counter.
--- Then we take 'blake2b160' hash of the resulting bytes and consider it to be the contract's
--- address.
-mkContractAddress
-  :: OperationHash
-  -> OriginationIndex
-  -> GlobalCounter
-  -> Address
-mkContractAddress (OperationHash opHash) (OriginationIndex idx) (GlobalCounter counter) =
-  ContractAddress
-  $ ContractHash
-  $ blake2b160
-  $ opHash <> BSL.toStrict (runPut $ putInt32be idx >> putWord64be counter)
-
 -- | Create a dummy 'ContractHash' value by hashing given 'ByteString'.
 --
 -- Use in tests **only**.
@@ -176,7 +145,7 @@
     ContractAddress h -> formatContractHash h
 
 mformatAddress :: Address -> MText
-mformatAddress = mkMTextUnsafe . formatAddress
+mformatAddress = unsafeMkMText . formatAddress
 
 instance Buildable Address where
   build = build . formatAddress
@@ -192,16 +161,18 @@
 instance NFData ParseAddressError
 
 instance Buildable ParseAddressError where
-  build =
+  build = buildRenderDoc
+
+instance RenderDoc ParseAddressError where
+  renderDoc context =
     \case
       ParseAddressWrongBase58Check -> "Wrong base58check format"
       ParseAddressBothFailed pkErr contractErr ->
         mconcat
-        [ "Address is neither `KeyAddress` ("
-        , build pkErr
-        , "), nor `ContractAddress` ("
-        , build contractErr
-        , ")"
+        [ "Address is neither `KeyAddress` "
+        , parens $ renderDoc context pkErr
+        , ", nor `ContractAddress` "
+        , parens $ renderDoc context contractErr
         ]
 
 -- | Parse an address from its human-readable textual representation
@@ -226,16 +197,19 @@
 
 instance NFData ParseAddressRawError
 
-instance Buildable ParseAddressRawError where
-  build =
+instance RenderDoc ParseAddressRawError where
+  renderDoc _ =
     \case
       ParseAddressRawInvalidPrefix prefix ->
-        "Invalid prefix for raw address \"" <> hexF prefix <> "\" provided"
-      ParseAddressRawWrongSize addr -> "Given raw address " <>
-        hexF addr <> " has invalid length " <> show (length addr)
-      ParseAddressRawMalformedSeparator addr -> "Given raw address " <> hexF addr <>
-        " does not end with \"\\00\""
+        "Invalid prefix for raw address" <+> (dquotes $ renderAnyBuildable $ hexF prefix) <+> "provided"
+      ParseAddressRawWrongSize addr -> "Given raw address+" <+>
+        (renderAnyBuildable $ hexF addr) <+> "has invalid length" <+> int (length addr)
+      ParseAddressRawMalformedSeparator addr -> "Given raw address+" <+> (renderAnyBuildable $ hexF addr) <+>
+        "does not end with" <+> dquotes (backslash <> "00")
 
+instance Buildable ParseAddressRawError where
+  build = buildRenderDoc
+
 -- | Parse the given address in its raw byte form used by Tezos
 -- (e.g "01521139f84791537d54575df0c74a8084cc68861c00")) . Or fail otherwise
 -- if it's invalid.
@@ -275,15 +249,18 @@
 instance NFData ParseContractAddressError
 
 instance Buildable ParseContractAddressError where
-  build =
+  build = buildRenderDoc
+
+instance RenderDoc ParseContractAddressError where
+  renderDoc _ =
     \case
       ParseContractAddressWrongBase58Check ->
         "Wrong base58check format"
       ParseContractAddressWrongSize bs ->
-        "Wrong size for a contract address: " <> hexF bs <>
-        " (" <> build (length bs) <> ")"
+        "Wrong size for a contract address:" <+> (renderAnyBuildable $ hexF bs) <+>
+        (parens $ int (length bs))
       ParseContractAddressWrongPrefix prefix ->
-        "Invalid prefix \"" <> hexF prefix <> "\" provided"
+        "Invalid prefix" <+> (dquotes $ renderAnyBuildable $ hexF prefix) <+> "provided"
 
 parseContractHash :: Text -> Either ParseContractAddressError ContractHash
 parseContractHash text =
@@ -294,6 +271,32 @@
       Left ParseContractAddressWrongBase58Check
     Right bs | length bs == contractHashLengthBytes -> Right (ContractHash bs)
              | otherwise -> Left $ ParseContractAddressWrongSize bs
+
+-- | QuasyQuoter for constructing Tezos addresses.
+--
+-- Validity of result will be checked at compile time.
+ta :: TH.QuasiQuoter
+ta = TH.QuasiQuoter
+  { TH.quoteExp = \s ->
+      case parseAddress . strip $ toText s of
+        Left   err -> fail $ pretty err
+        Right addr -> TH.lift addr
+  , TH.quotePat = \_ ->
+      fail "Cannot use this QuasyQuotation at pattern position"
+  , TH.quoteType = \_ ->
+      fail "Cannot use this QuasyQuotation at type position"
+  , TH.quoteDec = \_ ->
+      fail "Cannot use this QuasyQuotation at declaration position"
+  }
+
+
+instance
+    TypeError ('Text "There is no instance defined for (IsString Address)" ':$$:
+               'Text "Consider using QuasiQuotes: `[ta|some text...|]`"
+              ) =>
+    IsString Address where
+  fromString = error "impossible"
+
 
 ----------------------------------------------------------------------------
 -- Unsafe
diff --git a/src/Tezos/Core.hs b/src/Tezos/Core.hs
--- a/src/Tezos/Core.hs
+++ b/src/Tezos/Core.hs
@@ -7,7 +7,7 @@
 module Tezos.Core
   (
     -- * Mutez
-    Mutez (unMutez)
+    Mutez (..)
   , mkMutez
   , mkMutez'
   , unsafeMkMutez
@@ -42,7 +42,7 @@
     -- * ChainId
   , ChainId (..)
   , mkChainId
-  , mkChainIdUnsafe
+  , unsafeMkChainId
   , dummyChainId
   , formatChainId
   , mformatChainId
@@ -77,19 +77,19 @@
 ----------------------------------------------------------------------------
 
 -- | Mutez is a wrapper over integer data type. 1 mutez is 1 token (μTz).
-newtype Mutez = Mutez
+newtype Mutez = UnsafeMutez
   { unMutez :: Word64
   } deriving stock (Show, Eq, Ord, Data, Generic)
     deriving newtype Enum
 
 instance Buildable Mutez where
-  build (Mutez w) = build w <> " μꜩ"
+  build (UnsafeMutez w) = build w <> " μꜩ"
 
 instance Bounded Mutez where
-  minBound = Mutez 0
+  minBound = UnsafeMutez 0
   -- 2⁶³ - 1
   -- This value was checked against the reference implementation.
-  maxBound = Mutez 9223372036854775807
+  maxBound = UnsafeMutez 9223372036854775807
 
 instance HasCLReader Mutez where
   getReader = maybe (readerError "Invalid mutez") pure . mkMutez =<< Opt.auto
@@ -100,7 +100,7 @@
 -- | Safely create 'Mutez' checking for overflow.
 mkMutez :: Word64 -> Maybe Mutez
 mkMutez n
-  | n <= unMutez maxBound = Just (Mutez n)
+  | n <= unMutez maxBound = Just (UnsafeMutez n)
   | otherwise = Nothing
 {-# INLINE mkMutez #-}
 
@@ -146,7 +146,7 @@
 -- subtrahend is greater than the minuend, and 'Just' otherwise.
 subMutez :: Mutez -> Mutez -> Maybe Mutez
 subMutez (unMutez -> a) (unMutez -> b)
-  | a >= b = Just (Mutez (a - b))
+  | a >= b = Just (UnsafeMutez (a - b))
   | otherwise = Nothing
 {-# INLINE subMutez #-}
 
@@ -159,7 +159,7 @@
 -- 'Nothing' in case of overflow.
 mulMutez :: Integral a => Mutez -> a -> Maybe Mutez
 mulMutez (unMutez -> a) b
-    | res <= toInteger (unMutez maxBound) = Just (Mutez (fromInteger res))
+    | res <= toInteger (unMutez maxBound) = Just (UnsafeMutez (fromInteger res))
     | otherwise = Nothing
   where
     res = toInteger a * toInteger b
@@ -181,7 +181,7 @@
   | otherwise = Just $ bimap toMutez' toMutez' (a `divMod` b)
   where
     toMutez' :: Integer -> Mutez
-    toMutez' = Mutez . fromInteger
+    toMutez' = UnsafeMutez . fromInteger
 
 -- | Convert mutez to signed number.
 --
@@ -190,10 +190,10 @@
 mutezToInt64 = fromIntegral . unMutez
 
 zeroMutez :: Mutez
-zeroMutez = Mutez minBound
+zeroMutez = UnsafeMutez minBound
 
 oneMutez :: Mutez
-oneMutez = Mutez 1
+oneMutez = UnsafeMutez 1
 
 -- |
 -- >>> putTextLn $ prettyTez (toMutez 420)
@@ -314,7 +314,7 @@
 -- Use case: multisig contract, for instance, now includes chain ID into
 -- signed data "in order to add extra replay protection between the main
 -- chain and the test chain".
-newtype ChainId = ChainIdUnsafe { unChainId :: ByteString }
+newtype ChainId = UnsafeChainId { unChainId :: ByteString }
   deriving stock (Show, Eq, Ord, Generic)
 
 instance NFData ChainId
@@ -322,16 +322,16 @@
 -- | Construct chain ID from raw bytes.
 mkChainId :: ByteString -> Maybe ChainId
 mkChainId bs =
-  guard (length bs == chainIdLength) $> ChainIdUnsafe bs
+  guard (length bs == chainIdLength) $> UnsafeChainId bs
 
 -- | Construct chain ID from raw bytes or fail otherwise.
 -- Expects exactly 4 bytes.
-mkChainIdUnsafe :: HasCallStack => ByteString -> ChainId
-mkChainIdUnsafe = fromMaybe (error "Bad chain id") . mkChainId
+unsafeMkChainId :: HasCallStack => ByteString -> ChainId
+unsafeMkChainId = fromMaybe (error "Bad chain id") . mkChainId
 
 -- | Identifier of a pseudo network.
 dummyChainId :: ChainId
-dummyChainId = ChainIdUnsafe "\0\0\0\0"
+dummyChainId = UnsafeChainId "\0\0\0\0"
 
 -- | Pretty print 'ChainId' as it is displayed e.g. in
 -- @tezos-client rpc get /chains/main/chain_id@ call.
@@ -341,7 +341,7 @@
 formatChainId (unChainId -> bs) = encodeBase58Check (chainIdPrefix <> bs)
 
 mformatChainId :: ChainId -> MText
-mformatChainId = mkMTextUnsafe . formatChainId
+mformatChainId = unsafeMkMText . formatChainId
 
 instance Buildable ChainId where
   build = build . formatChainId
diff --git a/src/Tezos/Crypto.hs b/src/Tezos/Crypto.hs
--- a/src/Tezos/Crypto.hs
+++ b/src/Tezos/Crypto.hs
@@ -32,6 +32,8 @@
 -- <https://gitlab.com/tezos/tezos/blob/c52ee69231c5ae4d9cec1f3c8aba0c3573922e2a/src/lib_crypto/base58.ml>)
 -- and checked manually. Existing tests confirm they are correct.
 
+{-# LANGUAGE DeriveLift #-}
+
 module Tezos.Crypto
   ( -- * Cryptographic primitive types
     PublicKey (..)
@@ -67,7 +69,7 @@
   , formatKeyHash
   , mformatKeyHash
   , parseKeyHash
-  , parseKeyHashUnsafe
+  , unsafeParseKeyHash
   , parseKeyHashRaw
   , keyHashLengthBytes
   , formatSecretKey
@@ -102,6 +104,8 @@
 import qualified Data.ByteString.Lazy as LBS
 import qualified Data.Text as T
 import Fmt (Buildable, build, hexF, pretty)
+import Instances.TH.Lift ()
+import Language.Haskell.TH.Syntax (Lift)
 
 import Michelson.Text
 import qualified Tezos.Crypto.BLS12381 as BLS12381
@@ -313,7 +317,7 @@
   PublicKeyP256 pk -> P256.formatPublicKey pk
 
 mformatPublicKey :: PublicKey -> MText
-mformatPublicKey = mkMTextUnsafe . formatPublicKey
+mformatPublicKey = unsafeMkMText . formatPublicKey
 
 instance Buildable PublicKey where
   build = build . formatPublicKey
@@ -340,7 +344,7 @@
   SignatureGeneric sig -> formatImpl genericSignatureTag sig
 
 mformatSignature :: Signature -> MText
-mformatSignature = mkMTextUnsafe . formatSignature
+mformatSignature = unsafeMkMText . formatSignature
 
 instance Buildable Signature where
   build = build . formatSignature
@@ -433,7 +437,7 @@
   = KeyHashEd25519
   | KeyHashSecp256k1
   | KeyHashP256
-  deriving stock (Show, Eq, Ord, Bounded, Enum, Generic)
+  deriving stock (Show, Eq, Ord, Bounded, Enum, Generic, Lift)
 
 instance NFData KeyHashTag
 
@@ -443,7 +447,7 @@
   -- ^ We store which curve was used because it affects formatting.
   , khBytes :: ByteString
   -- ^ Hash itself.
-  } deriving stock (Show, Eq, Ord, Generic)
+  } deriving stock (Show, Eq, Ord, Generic, Lift)
 
 instance NFData KeyHash
 
@@ -467,7 +471,7 @@
 formatKeyHash (KeyHash tag bytes) = formatImpl (keyHashTagBytes tag) bytes
 
 mformatKeyHash :: KeyHash -> MText
-mformatKeyHash = mkMTextUnsafe . formatKeyHash
+mformatKeyHash = unsafeMkMText . formatKeyHash
 
 instance Buildable KeyHash where
   build = build . formatKeyHash
@@ -485,8 +489,8 @@
 
   in firstRight $ map parse $ minBound :| [succ minBound ..]
 
-parseKeyHashUnsafe :: HasCallStack => Text -> KeyHash
-parseKeyHashUnsafe = either (error . pretty) id . parseKeyHash
+unsafeParseKeyHash :: HasCallStack => Text -> KeyHash
+unsafeParseKeyHash = either (error . pretty) id . parseKeyHash
 
 parseKeyHashRaw :: ByteString -> Either CryptoParseError KeyHash
 parseKeyHashRaw ba =
diff --git a/src/Tezos/Crypto/BLS12381.hs b/src/Tezos/Crypto/BLS12381.hs
--- a/src/Tezos/Crypto/BLS12381.hs
+++ b/src/Tezos/Crypto/BLS12381.hs
@@ -13,13 +13,13 @@
   , Bls12381G1
   , Bls12381G2
   , CurveObject (..)
-  , fromMichelsonBytesUnsafe
+  , unsafeFromMichelsonBytes
   , MultiplyPoint (..)
   , DeserializationError (..)
   , checkPairing
 
     -- * Playground
-  , readFromHexUnsafe
+  , unsafeReadFromHex
   , generateFrom
   , g1One
   , g2One
@@ -38,13 +38,16 @@
 import qualified Data.Curve.Weierstrass.BLS12381 as CW.BLS
 import qualified Data.Field.Galois as GF
 import qualified Data.Pairing.BLS12381 as BLS
-import Fmt (Buildable(..), pretty, (+|), (|+))
+import Fmt (Buildable(..), pretty)
 import Named (arg, type (:!), (!))
 import Text.Hex (decodeHex, encodeHex)
+import Text.PrettyPrint.Leijen.Text ((<+>), int, integer)
 import Util.Instances ()
 import Util.Named ()
 import Util.Num
 
+import Michelson.Printer.Util (RenderDoc (..), renderAnyBuildable, buildRenderDoc)
+
 -- | Methods common for all BLS12-381 primitives.
 class CurveObject a where
   -- | Representation of @0@, aka additive identity.
@@ -73,16 +76,16 @@
 generateFrom = evalRand generate . mkStdGen
 
 -- | Read a value from Michelson's bytes form assuming that it is correct.
-fromMichelsonBytesUnsafe :: (CurveObject a, HasCallStack) => ByteString -> a
-fromMichelsonBytesUnsafe = either (error . pretty) id . fromMichelsonBytes
+unsafeFromMichelsonBytes :: (CurveObject a, HasCallStack) => ByteString -> a
+unsafeFromMichelsonBytes = either (error . pretty) id . fromMichelsonBytes
 
 -- | Reads an object from hex string.
 --
 -- To be used only in playground and tests.
-readFromHexUnsafe :: (CurveObject a, HasCallStack) => String -> a
-readFromHexUnsafe hex =
+unsafeReadFromHex :: (CurveObject a, HasCallStack) => String -> a
+unsafeReadFromHex hex =
   let bs = decodeHex (toText hex) ?: error "bad hex"
-  in fromMichelsonBytesUnsafe bs
+  in unsafeFromMichelsonBytes bs
 
 -- | Multiplication operations on BLS12-381 objects.
 class MultiplyPoint scalar point where
@@ -188,19 +191,22 @@
   deriving anyclass (NFData)
 
 instance Buildable DeserializationError where
-  build = \case
+  build = buildRenderDoc
+
+instance RenderDoc DeserializationError where
+  renderDoc _ = \case
     CompressedFormIsNotSupported ->
       "Compressed form of BLS12-381 point is not supported by Tezos"
     UnexpectedLength (arg #expected -> expected) (arg #given -> given) ->
       "Unexpected length of BLS12-381 primitive: \
-      \expected " +| expected |+ ", but given " +| given |+ ""
+      \expected" <+> (int expected) <> ", but given" <+> (int given)
     TooLargeLength (arg #limit -> limit) (arg #given -> given) ->
       "Too large length of BLS12-381 primitive: \
-      \limit is " +| limit |+ ", but given " +| given |+ ""
+      \limit is" <+> (int limit) <+> ", but given" <+> (int given)
     ValueOutsideOfField v ->
-      "Value is too large for the given field of values: " +| v |+ ""
+      "Value is too large for the given field of values:" <+> (integer v)
     PointNotOnCurve bs ->
-      "Point is not on curve: 0x" +| encodeHex bs |+ ""
+      "Point is not on curve: 0x" <> (renderAnyBuildable $ encodeHex bs)
 
 {- Note on serialization:
 
diff --git a/src/Tezos/Crypto/Ed25519.hs b/src/Tezos/Crypto/Ed25519.hs
--- a/src/Tezos/Crypto/Ed25519.hs
+++ b/src/Tezos/Crypto/Ed25519.hs
@@ -135,7 +135,7 @@
 formatPublicKey = formatImpl publicKeyTag . unPublicKey
 
 mformatPublicKey :: PublicKey -> MText
-mformatPublicKey = mkMTextUnsafe . formatPublicKey
+mformatPublicKey = unsafeMkMText . formatPublicKey
 
 instance Buildable PublicKey where
   build = build . formatPublicKey
@@ -156,7 +156,7 @@
 formatSignature = formatImpl signatureTag . unSignature
 
 mformatSignature :: Signature -> MText
-mformatSignature = mkMTextUnsafe . formatSignature
+mformatSignature = unsafeMkMText . formatSignature
 
 instance Buildable Signature where
   build = build . formatSignature
diff --git a/src/Tezos/Crypto/P256.hs b/src/Tezos/Crypto/P256.hs
--- a/src/Tezos/Crypto/P256.hs
+++ b/src/Tezos/Crypto/P256.hs
@@ -157,7 +157,7 @@
 formatPublicKey = formatImpl @ByteString publicKeyTag . publicKeyToBytes
 
 mformatPublicKey :: PublicKey -> MText
-mformatPublicKey = mkMTextUnsafe . formatPublicKey
+mformatPublicKey = unsafeMkMText . formatPublicKey
 
 instance Buildable PublicKey where
   build = build . formatPublicKey
@@ -169,7 +169,7 @@
 formatSignature = formatImpl @ByteString signatureTag . signatureToBytes
 
 mformatSignature :: Signature -> MText
-mformatSignature = mkMTextUnsafe . formatSignature
+mformatSignature = unsafeMkMText . formatSignature
 
 instance Buildable Signature where
   build = build . formatSignature
diff --git a/src/Tezos/Crypto/Secp256k1.hs b/src/Tezos/Crypto/Secp256k1.hs
--- a/src/Tezos/Crypto/Secp256k1.hs
+++ b/src/Tezos/Crypto/Secp256k1.hs
@@ -157,7 +157,7 @@
 formatPublicKey = formatImpl @ByteString publicKeyTag . publicKeyToBytes
 
 mformatPublicKey :: PublicKey -> MText
-mformatPublicKey = mkMTextUnsafe . formatPublicKey
+mformatPublicKey = unsafeMkMText . formatPublicKey
 
 instance Buildable PublicKey where
   build = build . formatPublicKey
@@ -169,7 +169,7 @@
 formatSignature = formatImpl @ByteString signatureTag . signatureToBytes
 
 mformatSignature :: Signature -> MText
-mformatSignature = mkMTextUnsafe . formatSignature
+mformatSignature = unsafeMkMText . formatSignature
 
 instance Buildable Signature where
   build = build . formatSignature
diff --git a/src/Tezos/Crypto/Util.hs b/src/Tezos/Crypto/Util.hs
--- a/src/Tezos/Crypto/Util.hs
+++ b/src/Tezos/Crypto/Util.hs
@@ -40,11 +40,14 @@
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Base58 as Base58
 import qualified Data.ByteString.Lazy as LBS
-import Fmt (Buildable, Builder, build, fmt, hexF, (+|), (|+))
+import Fmt (Buildable, Builder, build, hexF)
+import Text.PrettyPrint.Leijen.Text ((<+>), int, textStrict)
 
 import Tezos.Crypto.Hash
 import Util.Binary (getRemainingByteStringCopy)
+import Michelson.Printer.Util (RenderDoc(..), renderAnyBuildable, buildRenderDocExtended)
 
+
 -- | Error that can happen during parsing of cryptographic primitive types.
 data CryptoParseError
   = CryptoParseWrongBase58Check
@@ -58,17 +61,21 @@
   rnf = rnf @String . show
 
 instance Buildable CryptoParseError where
-  build =
-    \case
-      CryptoParseWrongBase58Check -> "Wrong base58check encoding of bytes"
-      CryptoParseWrongTag tag -> "Prefix is wrong tag: " <> fmt (hexF tag)
-      CryptoParseCryptoError err ->
-        "Cryptographic library reported an error: " <>
-        build (displayException err)
-      CryptoParseUnexpectedLength what l ->
-        "Unexpected length of " <> what <> ": " <> build l
-      CryptoParseBinaryError err -> "" +| err |+ ""
+  build = buildRenderDocExtended
 
+instance RenderDoc CryptoParseError where
+  renderDoc _ = \case
+    CryptoParseWrongBase58Check -> "Wrong base58check encoding of bytes"
+    CryptoParseWrongTag tag -> "Prefix is wrong tag:" <+> (renderAnyBuildable $ hexF tag)
+    CryptoParseCryptoError err ->
+      "Cryptographic library reported an error: " <>
+        (renderAnyBuildable $ (displayException err))
+    CryptoParseUnexpectedLength what l ->
+      "Unexpected length of" <+> renderAnyBuildable what <> ":" <+> int l
+    CryptoParseBinaryError err -> textStrict err
+
+
+
 -- | Encode a bytestring in Base58Check format.
 encodeBase58Check :: ByteString -> Text
 encodeBase58Check =
@@ -79,8 +86,8 @@
 
 -- | Decode a bytestring from Base58Check format.
 decodeBase58Check :: Text -> Maybe ByteString
-decodeBase58Check text = do
-  bytes <- Base58.decodeBase58 Base58.bitcoinAlphabet (encodeUtf8 text)
+decodeBase58Check base58text = do
+  bytes <- Base58.decodeBase58 Base58.bitcoinAlphabet (encodeUtf8 base58text)
   let (payload, chk) = BS.splitAt (length bytes - 4) bytes
   guard $ chk == checkSum payload
   return payload
@@ -98,8 +105,8 @@
 -- resulting payload is returned.
 decodeBase58CheckWithPrefix ::
   ByteString -> Text -> Either B58CheckWithPrefixError ByteString
-decodeBase58CheckWithPrefix prefix text =
-  case decodeBase58Check text of
+decodeBase58CheckWithPrefix prefix base58text =
+  case decodeBase58Check base58text of
     Nothing -> Left B58CheckWithPrefixWrongEncoding
     Just bs ->
       let (actualPrefix, payload) = BS.splitAt (length prefix) bs
@@ -117,12 +124,12 @@
   -> (ByteString -> Either CryptoParseError res)
   -> Text
   -> Either CryptoParseError res
-parseImpl expectedTag constructor text = do
+parseImpl expectedTag constructor textToParse = do
   let convertErr :: B58CheckWithPrefixError -> CryptoParseError
       convertErr =
         \case B58CheckWithPrefixWrongPrefix prefix -> CryptoParseWrongTag prefix
               B58CheckWithPrefixWrongEncoding -> CryptoParseWrongBase58Check
-  payload <- first convertErr $ decodeBase58CheckWithPrefix expectedTag text
+  payload <- first convertErr $ decodeBase58CheckWithPrefix expectedTag textToParse
   constructor payload
 
 -- | Returns first encountered 'Right' in a list. If there are none,
diff --git a/src/Util/CLI.hs b/src/Util/CLI.hs
--- a/src/Util/CLI.hs
+++ b/src/Util/CLI.hs
@@ -20,11 +20,13 @@
   , mkCLOptionParserExt
   , mkCLArgumentParser
   , mkCLArgumentParserExt
+  , mkCommandParser
   , namedParser
 
   -- ** Helpers for defining 'HasCLReader'
   , eitherReader
   , readerError
+  , integralReader
   ) where
 
 import Data.Text.Manipulate (toSpinal)
@@ -37,6 +39,7 @@
 
 import Util.Instances ()
 import Util.Named
+import Util.Num
 
 -- | Maybe add the default value and make sure it will be shown in
 -- help message.
@@ -76,27 +79,54 @@
 -- else, but it still sounds a bit dangerous.
 
 instance HasCLReader Natural where
-  getReader = Opt.auto
+  getReader = integralReader
   getMetavar = "NATURAL NUMBER"
 
 instance HasCLReader Word64 where
-  getReader = Opt.auto
+  getReader = integralReader
   -- ↓ Same as for 'Natural', the user usually does not care whether
   -- the number is bounded (reasonable values should fit anyway).
+  -- We will apply the same rule for other numeric instances.
   getMetavar = "NATURAL NUMBER"
 
+instance HasCLReader Word32 where
+  getReader = integralReader
+  getMetavar = "NATURAL NUMBER"
+
 instance HasCLReader Word16 where
-  getReader = Opt.auto
-  -- ↓ Same as for 'Natural', the user usually does not care whether
-  -- the number is bounded (reasonable values should fit anyway).
+  getReader = integralReader
   getMetavar = "NATURAL NUMBER"
 
+instance HasCLReader Word8 where
+  getReader = integralReader
+  getMetavar = "NATURAL NUMBER"
+
+instance HasCLReader Word where
+  getReader = integralReader
+  getMetavar = "NATURAL NUMBER"
+
 instance HasCLReader Integer where
-  getReader = Opt.auto
+  getReader = integralReader
   getMetavar = "INTEGER"
 
+instance HasCLReader Int64 where
+  getReader = integralReader
+  getMetavar = "INTEGER"
+
+instance HasCLReader Int32 where
+  getReader = integralReader
+  getMetavar = "INTEGER"
+
+instance HasCLReader Int16 where
+  getReader = integralReader
+  getMetavar = "INTEGER"
+
+instance HasCLReader Int8 where
+  getReader = integralReader
+  getMetavar = "INTEGER"
+
 instance HasCLReader Int where
-  getReader = Opt.auto
+  getReader = integralReader
   getMetavar = "INTEGER"
 
 instance HasCLReader Text where
@@ -107,6 +137,15 @@
   getReader = Opt.str
   getMetavar = "STRING"
 
+-- | Parse a number, checking for overflows and other stuff.
+integralReader :: Integral a => Opt.ReadM a
+integralReader = do
+  int <- Opt.auto @Integer
+  fromIntegralChecked int
+    & either (readerError . addPrefix . toString) pure
+  where
+    addPrefix = ("failed to parse command-line numeric argument: " <>)
+
 -- | Create a 'Opt.Parser' for a value using 'HasCLReader' instance
 -- (hence @CL@ in the name). It uses reader and metavar from that
 -- class, the rest should be supplied as arguments.
@@ -160,6 +199,13 @@
     help hInfo :
     maybeAddDefault pretty defValue :
     mods
+
+-- | Parser for command options
+mkCommandParser :: String -> Opt.Parser a -> String -> Opt.Mod Opt.CommandFields a
+mkCommandParser commandName parser desc =
+  Opt.command commandName $
+  Opt.info (Opt.helper <*> parser) $
+  Opt.progDesc desc
 
 -- | Create a 'Opt.Parser' for a value using its type-level name.
 --
diff --git a/src/Util/Peano.hs b/src/Util/Peano.hs
--- a/src/Util/Peano.hs
+++ b/src/Util/Peano.hs
@@ -25,12 +25,10 @@
   , Nat (Z, S)
   , ToPeano
   , FromPeano
-  , KnownPeano (..)
   , SingNat (SZ, SS)
+
   , Decrement
   , type (>)
-  , peanoVal'
-  , peanoValSing
   , peanoSing
 
   -- * Peano Arithmetic
@@ -89,21 +87,6 @@
   FromPeano 'Z = 0
   FromPeano ('S a) = 1 + FromPeano a
 
-class KnownPeano (n :: Peano) where
-  peanoVal :: proxy n -> Natural
-
-instance KnownPeano 'Z where
-  peanoVal _ = 0
-instance KnownPeano a => KnownPeano ('S a) where
-  peanoVal _ = peanoVal' @a + 1
-
-peanoVal' :: forall n. KnownPeano n => Natural
-peanoVal' = peanoVal (Proxy @n)
-
--- | Get runtime value from singleton.
-peanoValSing :: forall n. KnownPeano n => Sing n -> Natural
-peanoValSing _ = peanoVal' @n
-
 -- | Get the peano singleton for a given type-level nat literal.
 --
 -- >>> peanoSing @2
@@ -111,12 +94,9 @@
 peanoSing :: forall (n :: GHC.Nat). SingI (ToPeano n) => SingNat (ToPeano n)
 peanoSing = sing @(ToPeano n)
 
-instance KnownPeano a => MockableConstraint (KnownPeano a) where
-  provideConstraintUnsafe = Dict
-
 data SingNat (n :: Nat) where
   SZ :: SingNat 'Z
-  SS :: (SingI n, KnownPeano n) => SingNat n -> SingNat ('S n)
+  SS :: !(SingNat n) -> SingNat ('S n)
 
 deriving stock instance Show (SingNat (n :: Nat))
 deriving stock instance Eq (SingNat (n :: Nat))
@@ -128,7 +108,7 @@
 
 instance SingI 'Z where
   sing = SZ
-instance (SingI n, KnownPeano n) => SingI ('S n) where
+instance SingI n => SingI ('S n) where
   sing = SS (sing @n)
 
 ----------------------------------------------------------------------------
@@ -288,10 +268,10 @@
   RequireLongerOrSameLength l a
 
 instance MockableConstraint (RequireLongerOrSameLength l a) where
-  provideConstraintUnsafe = unsafeCoerce $ Dict @(RequireLongerOrSameLength '[] 'Z)
+  unsafeProvideConstraint = unsafeCoerce $ Dict @(RequireLongerOrSameLength '[] 'Z)
 
 instance MockableConstraint (RequireLongerThan l a) where
-  provideConstraintUnsafe = unsafeCoerce $ Dict @(RequireLongerThan '[()] 'Z)
+  unsafeProvideConstraint = unsafeCoerce $ Dict @(RequireLongerThan '[()] 'Z)
 
 ----------------------------------------------------------------------------
 -- Length constraints 'Dict'ionaries
diff --git a/src/Util/PeanoNatural.hs b/src/Util/PeanoNatural.hs
new file mode 100644
--- /dev/null
+++ b/src/Util/PeanoNatural.hs
@@ -0,0 +1,84 @@
+-- SPDX-FileCopyrightText: 2021 Tocqueville Group
+--
+-- SPDX-License-Identifier: LicenseRef-MIT-TQ
+
+-- | Utility for 'PeanoNatural'
+--
+-- At the moment, we have no other libriaries with that would
+-- provide effective implementation of type-level natural
+-- numbers. So we define our own data type called @PeanoNatural@.
+-- Using this type one may extract a term-level natural number
+-- from a type-level one quite simply.
+module Util.PeanoNatural
+  ( PeanoNatural (Zero, Succ, One, Two)
+  , toPeanoNatural
+  , toPeanoNatural'
+  , fromPeanoNatural
+  , singPeanoVal
+  ) where
+
+import Data.Singletons (SingI (..))
+import Util.Peano (Nat (Z, S), SingNat(..), ToPeano)
+import qualified GHC.TypeNats as GHC (Nat)
+
+-- | PeanoNatural data type
+--
+-- The @PN@ constructor stores @s :: SingNat n@ and @k :: Natural@
+-- with the following invariant:
+-- if @PN s k :: PeanoNatural n@, then @k == n@.
+-- This definition allows extracting values of Natural
+-- without O(n) conversion from @SingNat n@.
+data PeanoNatural (n :: Nat) = PN !(SingNat n) !Natural
+
+deriving stock instance Show (PeanoNatural n)
+deriving stock instance Eq (PeanoNatural n)
+
+instance NFData (PeanoNatural n) where
+  rnf (PN s _) = rnf s
+
+data MatchPS n where
+  PS_Match :: PeanoNatural n -> MatchPS ('S n)
+  PS_Mismatch :: MatchPS n
+
+matchPS :: PeanoNatural n -> MatchPS n
+matchPS (PN (SS m) k) = PS_Match (PN m (k - 1))
+matchPS _ = PS_Mismatch
+
+-- | Patterns 'Zero' and 'Succ'
+-- We introduce pattern synonyms 'Zero' and 'Succ' assuming that
+-- 'Zero' and 'Succ' cover all possible cases that satisfy the invariant.
+-- Using these patterns, we also avoid cases when `k /= peanoValSing @n s`
+pattern Zero :: () => (n ~ 'Z) => PeanoNatural n
+pattern Zero = PN SZ 0
+
+pattern Succ :: () => (n ~ 'S m) => PeanoNatural m -> PeanoNatural n
+pattern Succ s <- (matchPS -> PS_Match s) where
+  Succ (PN n k) = PN (SS n) (k+1)
+{-# COMPLETE Zero, Succ #-}
+
+-- | The following patterns are introduced for convenience.
+-- This allow us to avoid writing @Succ (Succ Zero)@ in
+-- several places.
+pattern One :: () => (n ~ ('S 'Z)) => PeanoNatural n
+pattern One = Succ Zero
+
+pattern Two :: () => (n ~ ('S ('S 'Z))) => PeanoNatural n
+pattern Two = Succ One
+
+fromPeanoNatural :: forall n. PeanoNatural n -> Natural
+fromPeanoNatural (PN _ n) = n
+
+-- | toPeanoNatural and toPeanoNatural' connect PeanoNatural with
+-- natural numbers known at run-time.
+singPeanoVal :: forall (n :: Nat). SingNat n -> Natural
+singPeanoVal = \case
+  SZ   -> 0
+  SS a -> 1 + singPeanoVal a
+
+toPeanoNatural :: forall n. SingI n => PeanoNatural n
+toPeanoNatural = let pSing = sing @n in
+  PN pSing $ singPeanoVal pSing
+
+toPeanoNatural'
+  :: forall (n :: GHC.Nat). SingI (ToPeano n) => PeanoNatural (ToPeano n)
+toPeanoNatural' = toPeanoNatural @(ToPeano n)
diff --git a/src/Util/Positive.hs b/src/Util/Positive.hs
--- a/src/Util/Positive.hs
+++ b/src/Util/Positive.hs
@@ -20,7 +20,7 @@
 --
 -- We define our own datatype in order to have 'Data' instance for it,
 -- which can not be derived for third-party types without exported constructor.
-newtype Positive = PositiveUnsafe { unPositive :: Natural }
+newtype Positive = UnsafePositive { unPositive :: Natural }
   deriving stock (Eq, Ord, Data, Generic)
   deriving newtype (Show, Buildable, ToJSON, FromJSON)
 
@@ -28,13 +28,13 @@
 
 mkPositive :: (Integral i, Buildable i) => i -> Either Text Positive
 mkPositive a
-  | a > 0     = Right $ PositiveUnsafe (fromIntegral a)
+  | a > 0     = Right $ UnsafePositive (fromIntegral a)
   | otherwise = Left $ "Number is not positive: " <> pretty a
 
 -- | Count length of non-empty list.
 lengthNE :: NonEmpty a -> Positive
-lengthNE = PositiveUnsafe . fromIntegral . length
+lengthNE = UnsafePositive . fromIntegral . length
 
 -- | Produce a non empty list consisting of the given value.
 replicateNE :: Positive -> a -> NonEmpty a
-replicateNE (PositiveUnsafe i) a = a :| replicate (fromIntegral i - 1) a
+replicateNE (UnsafePositive i) a = a :| replicate (fromIntegral i - 1) a
diff --git a/src/Util/Sing.hs b/src/Util/Sing.hs
new file mode 100644
--- /dev/null
+++ b/src/Util/Sing.hs
@@ -0,0 +1,93 @@
+-- SPDX-FileCopyrightText: 2021 Tocqueville Group
+--
+-- SPDX-License-Identifier: LicenseRef-MIT-TQ
+
+module Util.Sing
+  ( eqI
+  , eqParamSing
+  , eqParamSing2
+  , eqParamSing3
+  , castSing
+  , SingI1(..)
+  ) where
+
+import Data.Type.Equality ((:~:)(..), TestEquality(..))
+import Data.Typeable (eqT)
+import Data.Singletons (KindOf, Sing, SingI, sing)
+import Data.Singletons.Decide (SDecide, decideEquality)
+
+-- | Version of 'testEquality' that uses 'SingI'
+eqI :: forall a b. (SingI a, SingI b, TestEquality (Sing @(KindOf a))) => Maybe (a :~: b)
+eqI = testEquality (sing @a) (sing @b)
+
+-- | Suppose you have a data type `X` with parameter `a` and you have
+-- two values: `x1 :: X a1` and `x2 :: X a2`. You can't compare them
+-- using '==', because they have different types. However, you can
+-- compare them using 'eqParamSing' as long as both parameters have
+-- SingI instances and their kind is `SDecide`.
+eqParamSing ::
+  forall a1 a2 t.
+  ( SingI a1
+  , SingI a2
+  , SDecide (KindOf a1)
+  , Eq (t a1)
+  )
+  => t a1
+  -> t a2
+  -> Bool
+eqParamSing t1 t2 = isJust @() $ do
+  Refl <- sing @a1 `decideEquality` sing @a2
+  guard (t1 == t2)
+
+-- | Version of 'eqParamSing' for types with 2 parameters.
+eqParamSing2 ::
+  forall a1 a2 b1 b2 t.
+  ( SingI a1
+  , SingI a2
+  , SingI b1
+  , SingI b2
+  , SDecide (KindOf a1)
+  , SDecide (KindOf b1)
+  , Eq (t a1 b2)
+  )
+  => t a1 b1
+  -> t a2 b2
+  -> Bool
+eqParamSing2 t1 t2 = isJust @() $ do
+  Refl <- sing @a1 `decideEquality` sing @a2
+  Refl <- sing @b1 `decideEquality` sing @b2
+  guard (t1 == t2)
+
+-- | Version of 'eqParamSing' for types with 3 parameters.
+eqParamSing3 ::
+  forall instr1 instr2 a1 a2 b1 b2 t.
+  ( Typeable instr1
+  , Typeable instr2
+  , SingI a1
+  , SingI a2
+  , SingI b1
+  , SingI b2
+  , SDecide (KindOf a1)
+  , SDecide (KindOf b1)
+  , Eq (t instr1 a1 b1)
+  )
+  => t instr1 a1 b1
+  -> t instr2 a2 b2
+  -> Bool
+eqParamSing3 t1 t2 = isJust @() $ do
+  Refl <- eqT @instr1 @instr2
+  Refl <- sing @a1 `decideEquality` sing @a2
+  Refl <- sing @b1 `decideEquality` sing @b2
+  guard (t1 == t2)
+
+castSing :: forall a b t.
+  (SingI a, SingI b, SDecide (KindOf a))
+  => t a
+  -> Maybe (t b)
+castSing ca = do
+  Refl <- sing @a `decideEquality` sing @b
+  return ca
+
+-- Second-order analogue of 'SingI'
+class SingI1 f where
+  withSingI1 :: forall x r. SingI x => (SingI (f x) => r) -> r
diff --git a/src/Util/Type.hs b/src/Util/Type.hs
--- a/src/Util/Type.hs
+++ b/src/Util/Type.hs
@@ -40,8 +40,8 @@
   , onFirst
   ) where
 
-import Data.Constraint ((:-)(..), Dict(..), (\\))
-import Data.Type.Bool (type (&&), If, Not)
+import Data.Constraint (Dict(..), (:-)(..), (\\))
+import Data.Type.Bool (If, Not, type (&&))
 import Data.Type.Equality (type (==))
 import Data.Vinyl.Core (Rec(..))
 import qualified Data.Vinyl.Functor as Vinyl
@@ -80,10 +80,10 @@
 
 -- | A natural conclusion from the fact that an error has not occurred.
 failUnlessEvi :: forall cond msg. FailUnless cond msg :- (cond ~ 'True)
-failUnlessEvi = Sub provideConstraintUnsafe
+failUnlessEvi = Sub unsafeProvideConstraint
 
 failWhenEvi :: forall cond msg. FailWhen cond msg :- (cond ~ 'False)
-failWhenEvi = Sub provideConstraintUnsafe
+failWhenEvi = Sub unsafeProvideConstraint
 
 type family AllUnique (l :: [k]) :: Bool where
   AllUnique '[] = 'True
@@ -126,7 +126,7 @@
 
 -- | Reify type equality from boolean equality.
 reifyTypeEquality :: forall a b x. (a == b) ~ 'True => (a ~ b => x) -> x
-reifyTypeEquality x = x \\ provideConstraintUnsafe @(a ~ b)
+reifyTypeEquality x = x \\ unsafeProvideConstraint @(a ~ b)
 
 -- | Similar to @SingI []@, but does not require individual elements to be also
 -- instance of @SingI@.
@@ -172,7 +172,7 @@
 -- especially if you have complex types.
 -- But (++) type family is associative, so let's define this small hack.
 listOfTypesConcatAssociativityAxiom :: forall a b c . Dict (ConcatListOfTypesAssociativity a b c)
-listOfTypesConcatAssociativityAxiom = provideConstraintUnsafe
+listOfTypesConcatAssociativityAxiom = unsafeProvideConstraint
 
 -- | Constaints that can be provided on demand.
 --
@@ -182,45 +182,45 @@
 -- proof would be too difficult.
 class MockableConstraint (c :: Constraint) where
   -- | Produce a constraint out of thin air.
-  provideConstraintUnsafe :: Dict c
+  unsafeProvideConstraint :: Dict c
 
 instance MockableConstraint (a ~ b) where
-  provideConstraintUnsafe = unsafeCoerce $ Dict @(Int ~ Int)
+  unsafeProvideConstraint = unsafeCoerce $ Dict @(Int ~ Int)
 
 -- | In majority of the cases we don't want to mock typeclass constraints
 -- since coercing instances of typeclasses with methods is utterly unsafe.
 instance {-# OVERLAPPABLE #-} c a => MockableConstraint (c a) where
-  provideConstraintUnsafe = Dict
+  unsafeProvideConstraint = Dict
 
 instance ( MockableConstraint c1
          , MockableConstraint c2
          ) => MockableConstraint (c1, c2) where
-  provideConstraintUnsafe = runIdentity $ do
-    Dict <- pure $ provideConstraintUnsafe @c1
-    Dict <- pure $ provideConstraintUnsafe @c2
+  unsafeProvideConstraint = runIdentity $ do
+    Dict <- pure $ unsafeProvideConstraint @c1
+    Dict <- pure $ unsafeProvideConstraint @c2
     return Dict
-  {-# INLINE provideConstraintUnsafe #-}
+  {-# INLINE unsafeProvideConstraint #-}
 
 instance ( MockableConstraint c1
          , MockableConstraint c2
          , MockableConstraint c3
          ) => MockableConstraint (c1, c2, c3) where
-  provideConstraintUnsafe = runIdentity $ do
-    Dict <- pure $ provideConstraintUnsafe @(c1, c2)
-    Dict <- pure $ provideConstraintUnsafe @c3
+  unsafeProvideConstraint = runIdentity $ do
+    Dict <- pure $ unsafeProvideConstraint @(c1, c2)
+    Dict <- pure $ unsafeProvideConstraint @c3
     return Dict
-  {-# INLINE provideConstraintUnsafe #-}
+  {-# INLINE unsafeProvideConstraint #-}
 
 instance ( MockableConstraint c1
          , MockableConstraint c2
          , MockableConstraint c3
          , MockableConstraint c4
          ) => MockableConstraint (c1, c2, c3, c4) where
-  provideConstraintUnsafe = runIdentity $ do
-    Dict <- pure $ provideConstraintUnsafe @(c1, c2, c3)
-    Dict <- pure $ provideConstraintUnsafe @c4
+  unsafeProvideConstraint = runIdentity $ do
+    Dict <- pure $ unsafeProvideConstraint @(c1, c2, c3)
+    Dict <- pure $ unsafeProvideConstraint @c4
     return Dict
-  {-# INLINE provideConstraintUnsafe #-}
+  {-# INLINE unsafeProvideConstraint #-}
 
 instance ( MockableConstraint c1
          , MockableConstraint c2
@@ -228,11 +228,11 @@
          , MockableConstraint c4
          , MockableConstraint c5
          ) => MockableConstraint (c1, c2, c3, c4, c5) where
-  provideConstraintUnsafe = runIdentity $ do
-    Dict <- pure $ provideConstraintUnsafe @(c1, c2, c3, c4)
-    Dict <- pure $ provideConstraintUnsafe @c5
+  unsafeProvideConstraint = runIdentity $ do
+    Dict <- pure $ unsafeProvideConstraint @(c1, c2, c3, c4)
+    Dict <- pure $ unsafeProvideConstraint @c5
     return Dict
-  {-# INLINE provideConstraintUnsafe #-}
+  {-# INLINE unsafeProvideConstraint #-}
 
 -- | Utility function to help transform the first argument of a binfunctor.
 onFirst :: Bifunctor p => p a c -> (a -> b) -> p b c
diff --git a/src/Util/TypeLits.hs b/src/Util/TypeLits.hs
--- a/src/Util/TypeLits.hs
+++ b/src/Util/TypeLits.hs
@@ -17,9 +17,11 @@
   , ErrorMessage (..)
 
   , TypeErrorUnless
+  , AssertTypesEqual
   ) where
 
 import GHC.TypeLits
+import Data.Type.Equality
 
 symbolValT :: forall s. KnownSymbol s => Proxy s -> Text
 symbolValT = toText . symbolVal
@@ -83,3 +85,18 @@
 type family TypeErrorUnlessHelper (cond :: Bool) (err :: ErrorMessage) :: Constraint where
   TypeErrorUnlessHelper 'True _ = ()
   TypeErrorUnlessHelper 'False err = TypeError err
+
+-- | Condition Error helper to check if two types are equal
+--
+-- >>> :k! AssertTypesEqual Int Int ('Text "This should not result in a failure")
+-- AssertTypesEqual Int Int ('Text "This should not result in a failure") :: Constraint
+-- = (() :: Constraint, Int ~ Int)
+--
+-- >>> :k! AssertTypesEqual Bool Int ('Text "This should result in a failure")
+-- AssertTypesEqual Bool Int ('Text "This should result in a failure") :: Constraint
+-- = ((TypeError ...), Bool ~ Int)
+type AssertTypesEqual a b (err :: ErrorMessage) =
+  ( TypeErrorUnlessHelper (a == b) err
+  -- The reasons for the constraint below are the same as those in @TypeErrorUnless@ constructor
+  , a ~ b
+  )
diff --git a/src/Util/Typeable.hs b/src/Util/Typeable.hs
--- a/src/Util/Typeable.hs
+++ b/src/Util/Typeable.hs
@@ -6,37 +6,21 @@
 
 -- | Utility for 'Typeable'.
 module Util.Typeable
-  ( gcastE
-  , eqP
-  , eqParam1
+  ( eqParam1
   , eqParam2
   , eqParam3
   , eqExt
   , compareExt
   , castIgnoringPhantom
   , eqTypeIgnoringPhantom
-
     -- * Re-exports
   , (:~:) (..)
   , eqT
   ) where
 
 import Data.Coerce (coerce)
-import Data.Typeable ((:~:)(..), eqT, gcast, typeRep)
-import Fmt ((+||), (||+))
+import Data.Typeable (eqT, typeRep, (:~:)(..))
 import qualified Type.Reflection as Refl
-
--- | Like 'gcast', casts some container's elements,
--- producing informative error on mismatch.
-gcastE :: forall a b t. (Typeable a, Typeable b) => t a -> Either Text (t b)
-gcastE = maybeToRight errMsg . gcast
-  where
-    errMsg = "Type mismatch: expected " +|| typeRep (Proxy @b) ||+
-                               ", got " +|| typeRep (Proxy @a) ||+ ""
-
--- | 'Proxy' version of 'eqT'.
-eqP :: (Typeable a, Typeable b) => Proxy a -> Proxy b -> Maybe (a :~: b)
-eqP (_ :: Proxy a) (_ :: Proxy b) = eqT @a @b
 
 -- | Suppose you have a data type `X` with parameter `a` and you have
 -- two values: `x1 :: X a1` and `x2 :: X a2`. You can't compare them