diff --git a/CHANGES.md b/CHANGES.md
--- a/CHANGES.md
+++ b/CHANGES.md
@@ -1,6 +1,145 @@
 <!-- Unreleased: append new entries here -->
 
 
+1.19.0
+======
+* [!1273](https://gitlab.com/morley-framework/morley/-/merge_requests/1273)
+  Add LAMBDA_REC and Lambda_rec support
+  + Typed instructions `AnnLAMBDA` and newly introduced `AnnLAMBDA_REC` do not
+    carry `VLam` any more, instead they carry `RemFail` directly.
+  + New data type `LambdaCode'` introduced, with two constructors, for plain and
+    recursive lambdas, respecively.
+  + `VLam` now contains `LambdaCode'` instead of `RemFail`.
+  + New function `mkVLamRec` for constructing recursive lambda values
+    introduced.
+* [!1278](https://gitlab.com/morley-framework/morley/-/merge_requests/1278)
+  Deprecate `OPEN_CHEST`, related types and values
+* [!1281](https://gitlab.com/morley-framework/morley/-/merge_requests/1281)
+  Use the new binaries names, `octez-client` and `octez-node`
+* [!1270](https://gitlab.com/morley-framework/morley/-/merge_requests/1270)
+  Add lima protocol TICKET instruction, rename old one to TICKET_DEPRECATED
+  + The `TICKET` instruction was renamed to `TICKET_DEPRECATED`
+  + A new `TICKET` instruction was added which no longer allows zero amount
+    tickets. It now returns `Some Ticket` and `None` in case of zero amount
+    supplied.
+* [!1288](https://gitlab.com/morley-framework/morley/-/merge_requests/1288)
+  Fix toExpression in nested right pair combs with variable annotations
+  + Conversion to Micheline would lose variable annotations on nested right pair
+    combs. This issue has been fixed.
+* [!1271](https://gitlab.com/morley-framework/morley/-/merge_requests/1271)
+  Deprecate `AssertTypesEqual`
+  + Use `FailUnlessEqual` instead.
+* [!1193](https://gitlab.com/morley-framework/morley/-/merge_requests/1193)
+  Use `nest` from `Text.PrettyPrint.Leijen` in instructions rendering instead
+  of `Morley.Michelson.Printer.Util.spaces`
+* [!1265](https://gitlab.com/morley-framework/morley/-/merge_requests/1265)
+  Add parser for ConstrainedAddress `parseConstrainedAddress`
+  + Better address parser error reporting
+  + Added `FromJSON` instance for `ConstrainedAddress`
+* [!1248](https://gitlab.com/morley-framework/morley/-/merge_requests/1248)
+  Add `HasAnnotation` deriving to `deriveRPC`
+  + New datatype `Morley.AsRPC.DeriveRPCOptions`
+  + New helper `Morley.AsRPC.deriveRPCWithOptions`
+  + `deriveRPCWithStrategy`, `deriveManyRPC`, `deriveManyRPCWithStrategy` are
+    deprecated in favor of `deriveRPCWithOptions`
+  + `deriveRPC` now behaves as `deriveManyRPC`, and additionally tries to derive
+    `HasAnnotation`. It will error out if `HasAnnotation` is not in scope.
+* [!1258](https://gitlab.com/morley-framework/morley/-/merge_requests/1258)
+  Support implicit delegation in interpreter
+  + Reworked delegate tracking in morley interpreter.
+  + Added `unImplicitAddress :: ImplicitAddress -> KeyHash` utility to
+    `Morley.Tezos.Address`.
+* [!1188](https://gitlab.com/morley-framework/morley/-/merge_requests/1188)
+  Straighten out detSecretKey's behavior
+  + Add `Morley.Tezos.Crypto.KeyType` enum type encoding secret/public key type.
+  + Refactor `HashTag` to use `KeyType`.
+  + `detSecretKey` now chooses key type based on the seed, not seed _length_.
+  + Add `detSecretKey'` allowing to choose what key type to use.
+* [!1230](https://gitlab.com/morley-framework/morley/-/merge_requests/1230)
+  Fix secp256k1 signatures
+  + Roughly half of all secp256k1 created by Morley were rejected by network due
+    to an implementation mismatch. This has been fixed.
+* [!1260](https://gitlab.com/morley-framework/morley/-/merge_requests/1260)
+  Refactor `SomeAddressOrAlias`
+    + Changed the definition of `SomeAddressOrAlias` to be able to parse
+      address/aliases of a contract, implicit account, or both.
+      A prefix of `implicit:` or `contract:` can be used to disambiguate.
+    + Changed the parser of `AddressOrAlias kind` to accept the `implicit:`
+      and `contract:` prefixes.
+    + Replaced the `morley transfer --to-implicit` and `--to-contract` options
+      with a single `--to` option.
+* [!1255](https://gitlab.com/morley-framework/morley/-/merge_requests/1255)
+  Simplify some machinery using instances from `some`
+* [!1138](https://gitlab.com/morley-framework/morley/-/merge_requests/1138)
+  Generalize typechecking to work with arbitrary instruction wrapper instead of
+  `ExpandedOp`.
+  * Renames:
+    + `TcInstrHandler` to `TcInstr`;
+    + `typeCheckOpImpl` to `typeCheckExpandedOp`;
+    + `TCError` to `TcError` and `TCTypeError` to `TcTypeError`;
+    + `SomeInstr` to `SomeTcInstr`;
+  * Some functions/types (`TCError`, `typeCheck*`) now have primed (`'`)
+    versions that are generalized over `ExpandedOp`. Those functions now
+    accept the typechecker for `ExpandedOp`.
+* [!1240](https://gitlab.com/morley-framework/morley/-/merge_requests/1240)
+  Add `MichelsonExt` to `MichelsonFailed` to allow extensible failure.
+* [!1206](https://gitlab.com/morley-framework/morley/-/merge_requests/1206)
+  Add `tupleFromRec`
+* [!1243](https://gitlab.com/morley-framework/morley/-/merge_requests/1243)
+  Add `run_code` emulation to Morley
+  + `Morley.Michelson.Runtime` now provides `runCode` function, mimicing the
+    functionality of RPC `run_code` endpoint
+* [!1241](https://gitlab.com/morley-framework/morley/-/merge_requests/1241)
+  Add classified typed instruction machinery
+  + See `Morley.Michelson.Typed.ClassifiedInstr` haddocks for more information.
+* [!1242](https://gitlab.com/morley-framework/morley/-/merge_requests/1242)
+  Add `Constrained` utility existential
+  + New utility module `Morley.Util.Constrained` introduced, defining an
+    existential `Constrained`, similar to `Some` from `some`, but capturing
+    additional constraints on the GADT argument
+  + `ConstrainedAddress` reimplemented in terms of `Constrained`
+  + `MkConstrainedAddress` kept as a pattern synonym, but deprecated
+  + Types and pattern synonyms from `Morley.Michelson.Typed.Existential`
+    reimplemented in terms of `Constrained`
+* [!1245](https://gitlab.com/morley-framework/morley/-/merge_requests/1245)
+  Remove Guard from Morley.Util.Type
+  + See [#865](https://gitlab.com/morley-framework/morley/-/issues/865) for
+    an alternative
+* [!1237](https://gitlab.com/morley-framework/morley/-/merge_requests/1237)
+  Track delegate registration in interpreter
+* [!1178](https://gitlab.com/morley-framework/morley/-/merge_requests/1178)
+  Add `HasNoNestedBigMaps t` constraint to `WellTyped` requirement for `Contract t`.
+  + This is indirectly enforced by the network, but was missing. Useful to avoid
+    redundant checks.
+* [!1228](https://gitlab.com/morley-framework/morley/-/merge_requests/1228)
+  Handle implicit default entrypoint in `mkEntrypointsMap`
+  + Add a new enum type `HandleImplicitDefaultEp` to signal how to handle
+    implicit default entrypoint.
+  + Change `mkEntrypointsMap` to accept `HandleImplicitDefaultEp` as its first
+    argument. The old behaviour corresponds to calling it with
+    `WithoutImplicitDefaultEp`.
+  + Change `flattenEntrypoints` to accept `HandleImplicitDefaultEp`, similar to
+    `mkEntrypointsMap`.
+* [!1195](https://gitlab.com/morley-framework/morley/-/merge_requests/1195)
+  Improve `Forbid` constraints to carry type equality evidence
+* [!1222](https://gitlab.com/morley-framework/morley/-/merge_requests/1222)
+  Change the constraints on `instrCase` in
+  `Morley.Michelson.Typed.Haskell.Instr.Sum` and on `instrConstruct`,
+  `instrConstructStack`, and `instrDeconstruct` in
+  `Morley.Michelson.Typed.Haskell.Instr.Product`. Code using these functions
+  in surprisingly polymorphic ways may need minor adjustments. Applications of
+  these functions should now be faster to typecheck and also faster to run.
+* [!1216](https://gitlab.com/morley-framework/morley/-/merge_requests/1216)
+  Add `LazyTake`, a "lazier" version of `Take`
+  + Use `LazyTake` to improve type inference for various functions.
+  + Rearrange `ConstraintDIG'` and `ConstraintDUG'` to reveal a bidirectional
+    functional dependency.
+  + Remove the `KnownList inp` constraint from `ConstraintDig'`.
+* [!1215](https://gitlab.com/morley-framework/morley/-/merge_requests/1215)
+  Output values associated with operations in `emulate transfer` etc
+* [!1198](https://gitlab.com/morley-framework/morley/-/merge_requests/1198)
+  Add equalities to `ConstraintDIPN'` to offer more fundeps.
+
 1.18.0
 ======
 * [!1212](https://gitlab.com/morley-framework/morley/-/merge_requests/1212)
diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -10,6 +10,14 @@
 
 ## Morley executable
 
+### Dependencies
+
+To install using stack or cabal, you need to install [libsodium](https://doc.libsodium.org) first.
+
+If installing into a non-standard location, after its installation is complete, add
+the directory containing `libsodium.so` to your `LD_LIBRARY_PATH` environment
+variable. Otherwise, compilation with stack or cabal will fail.
+
 ### How to install
 
 There are three ways to get Morley executable:
diff --git a/app/Main.hs b/app/Main.hs
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -30,7 +30,6 @@
 import Morley.Michelson.Untyped qualified as U
 import Morley.Tezos.Address
 import Morley.Tezos.Address.Alias
-import Morley.Tezos.Address.Kinds
 import Morley.Tezos.Core (Mutez, Timestamp(..), tz)
 import Morley.Tezos.Crypto
 import Morley.Tezos.Crypto.Timelock (chestBytes, chestKeyBytes, createChestAndChestKey)
@@ -127,7 +126,7 @@
     typecheckSubCmd =
       mkCommandParser "typecheck"
         (TypeCheck <$> typeCheckOptions) $
-        ("Typecheck passed contract")
+        ("Typecheck passed contract.")
 
     printSubCmd =
       mkCommandParser "print"
@@ -135,35 +134,35 @@
              <*> (#output <:?> outputOption)
              <*> (#singleLine <:!> onelineOption))
       ("Parse a Morley contract and print corresponding Michelson " <>
-       "contract that can be parsed by the OCaml reference client: tezos-client")
+       "contract that can be parsed by the OCaml reference client: `octez-client`.")
 
     emulateSubCmd =
       mkCommandParser "emulate"
       (subparser $ runSubCmd
                 <> originateSubCmd
                 <> transferSubCmd)
-      ("Set of commands to run in an emulated environment")
+      ("Set of commands to run in an emulated environment.")
 
     runSubCmd =
       mkCommandParser "run"
       (Run <$> runOptions) $
       "Run passed contract. \
-      \It's originated first and then a transaction is sent to it"
+      \It's originated first and then a transaction is sent to it."
 
     replSubCmd =
       mkCommandParser "repl"
       (pure REPL)
-      "Start a Morley REPL"
+      "Start a Morley REPL."
 
     originateSubCmd =
       mkCommandParser "originate"
       (Originate <$> originateOptions)
-      "Originate passed contract. Add it to passed DB"
+      "Originate passed contract. Add it to passed DB."
 
     transferSubCmd =
       mkCommandParser "transfer"
       (Transfer <$> transferOptions)
-      "Transfer tokens to given address"
+      "Transfer tokens to given address."
 
     optimizeSubCmd =
       mkCommandParser "optimize"
@@ -184,25 +183,25 @@
     verboseFlag = switch $
       short 'v' <>
       long "verbose" <>
-      help "Whether output should be verbose"
+      help "Whether output should be verbose."
 
     writeFlag :: Opt.Parser Bool
     writeFlag = switch $
       long "write" <>
-      help "Whether updated DB should be written to DB file"
+      help "Whether updated DB should be written to DB file."
 
     dryRunFlag :: Opt.Parser Bool
     dryRunFlag = switch $
       long "dry-run" <>
-      help "Do not write updated DB to DB file"
+      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"
+        help "Whether actions permitted in `octez-client run` but forbidden in \
+             \e.g. `octez-client originate` should be allowed here."
       return TypeCheck.TypeCheckOptions{..}
 
     typeCheckOptions :: Opt.Parser TypeCheckOptions
@@ -232,7 +231,7 @@
         <*> dbPathOption
         <*> typeCheckOptionsOption
         <*> valueOption Nothing (#name :! "storage")
-            (#help :! "Initial storage of a running contract")
+            (#help :! "Initial storage of a running contract.")
         <*> txDataOption
         <*> verboseFlag
         <*> nowOption
@@ -240,7 +239,7 @@
         <*> minBlockTimeOption
         <*> maxStepsOption
         <*> mutezOption (Just defaultBalance)
-            (#name :! "balance") (#help :! "Initial balance of this contract")
+            (#name :! "balance") (#help :! "Initial balance of this contract.")
         <*> writeFlag
 
     originateOptions :: Opt.Parser OriginateOptions
@@ -250,16 +249,16 @@
         <*> dbPathOption
         <*> typeCheckOptionsOption
         <*> addressOption (Just genesisAddress)
-            (#name :! "originator") (#help :! "Contract's originator")
+            (#name :! "originator") (#help :! "Contract's originator.")
         <*> optional (aliasOption "alias")
         <*> optional
             (keyHashOption Nothing
-              (#name :! "delegate") (#help :! "Contract's optional delegate")
+              (#name :! "delegate") (#help :! "Contract's optional delegate.")
             )
         <*> valueOption Nothing
-            (#name :! "storage") (#help :! "Initial storage of an originating contract")
+            (#name :! "storage") (#help :! "Initial storage of an originating contract.")
         <*> mutezOption (Just defaultBalance)
-            (#name :! "balance") (#help :! "Initial balance of an originating contract")
+            (#name :! "balance") (#help :! "Initial balance of an originating contract.")
         <*> verboseFlag
 
     transferOptions :: Opt.Parser TransferOptions
@@ -267,14 +266,10 @@
       toDBPath <- dbPathOption
       toTcOptions <- typeCheckOptionsOption
       toDestination <-
-        SomeAddressOrAlias <$> addressOrAliasOption @'AddressKindImplicit
-          Nothing
-          (#name :! "to-implicit")
-          (#help :! "Address or alias of the transfer's destination implicit address (tz1/tz2/tz3)")
-        <|> SomeAddressOrAlias <$> addressOrAliasOption @'AddressKindContract
+        someAddressOrAliasOption
           Nothing
-          (#name :! "to-contract")
-          (#help :! "Address or alias of the transfer's destination contract (KT1)")
+          (#name :! "to")
+          (#help :! "Address or alias of the transfer's destination.")
       toTxData <- txDataOption
       toNow <- nowOption
       toLevel <- levelOption
@@ -359,7 +354,7 @@
             michelsonContract
             ! #verbose ooVerbose
         putTextLn $ "Originated contract " <> pretty addr
-      Transfer TransferOptions {toDestination=SomeAddressOrAlias toDestination, ..} -> do
+      Transfer TransferOptions {..} -> do
         transfer toNow toLevel toMinBlockTime toMaxSteps toDBPath toTcOptions toDestination toTxData
           ! #verbose toVerbose
           ! #dryRun toDryRun
diff --git a/app/REPL.hs b/app/REPL.hs
--- a/app/REPL.hs
+++ b/app/REPL.hs
@@ -39,7 +39,8 @@
 import Morley.Michelson.Runtime.Dummy
 import Morley.Michelson.Runtime.Import (readValue)
 import Morley.Michelson.TypeCheck
-  (SomeInstr(..), SomeInstrOut(..), TypeCheckOptions(..), runTypeCheckIsolated, typeCheckingWith)
+  (SomeTcInstr(..), SomeTcInstrOut(..), TypeCheckOptions(..), runTypeCheckIsolated,
+  typeCheckingWith)
 import Morley.Michelson.TypeCheck.Instr (typeCheckList, typeCheckParameter)
 import Morley.Michelson.TypeCheck.Types (HST(..))
 import Morley.Michelson.Typed qualified as T
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.18.0
+version:        1.19.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
@@ -69,6 +69,7 @@
       Morley.Michelson.Runtime.Dummy
       Morley.Michelson.Runtime.GState
       Morley.Michelson.Runtime.Import
+      Morley.Michelson.Runtime.RunCode
       Morley.Michelson.Runtime.TxData
       Morley.Michelson.Text
       Morley.Michelson.TypeCheck
@@ -86,6 +87,16 @@
       Morley.Michelson.Typed.AnnotatedValue
       Morley.Michelson.Typed.Annotation
       Morley.Michelson.Typed.Arith
+      Morley.Michelson.Typed.ClassifiedInstr
+      Morley.Michelson.Typed.ClassifiedInstr.Internal.Classifiers.HasAnns
+      Morley.Michelson.Typed.ClassifiedInstr.Internal.Classifiers.IsAlwaysFailing
+      Morley.Michelson.Typed.ClassifiedInstr.Internal.Classifiers.IsMichelson
+      Morley.Michelson.Typed.ClassifiedInstr.Internal.Classifiers.NumChildren
+      Morley.Michelson.Typed.ClassifiedInstr.Internal.InstrEnum
+      Morley.Michelson.Typed.ClassifiedInstr.Internal.MainImpl
+      Morley.Michelson.Typed.ClassifiedInstr.Internal.TH
+      Morley.Michelson.Typed.ClassifiedInstr.Internal.Types
+      Morley.Michelson.Typed.ClassifiedInstr.Internal.WithClassifiedInstr
       Morley.Michelson.Typed.Contract
       Morley.Michelson.Typed.Convert
       Morley.Michelson.Typed.Doc
@@ -139,6 +150,7 @@
       Morley.Util.Binary
       Morley.Util.ByteString
       Morley.Util.CLI
+      Morley.Util.Constrained
       Morley.Util.CustomGeneric
       Morley.Util.Default
       Morley.Util.Exception
@@ -223,7 +235,7 @@
       UndecidableInstances
       UndecidableSuperClasses
       ViewPatterns
-  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -Wno-prepositive-qualified-module -Wno-missing-safe-haskell-mode -Wno-unused-packages
+  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -Wno-prepositive-qualified-module -Wno-missing-safe-haskell-mode
   build-depends:
       Diff
     , MonadRandom
@@ -236,10 +248,12 @@
     , binary
     , bytestring
     , constraints >=0.11
+    , constraints-extras
     , containers
     , crypto-sodium >=0.0.5.0
     , cryptonite
     , data-default
+    , dependent-sum-template
     , elliptic-curve
     , first-class-families >=0.5.0.0
     , fmt >=0.6.3.0
@@ -261,6 +275,7 @@
     , show-type
     , singletons
     , singletons-base
+    , some
     , syb
     , template-haskell
     , text
@@ -269,6 +284,7 @@
     , th-reify-many
     , time
     , timerep
+    , type-errors
     , uncaught-exception
     , unordered-containers
     , vector
@@ -337,7 +353,7 @@
       UndecidableInstances
       UndecidableSuperClasses
       ViewPatterns
-  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -Wno-prepositive-qualified-module -Wno-missing-safe-haskell-mode -Wno-unused-packages
+  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -Wno-prepositive-qualified-module -Wno-missing-safe-haskell-mode
   build-depends:
       MonadRandom
     , aeson
@@ -350,7 +366,6 @@
     , megaparsec >=7.0.0
     , morley
     , morley-prelude
-    , named
     , optparse-applicative
     , singletons
     , text
diff --git a/src/Morley/AsRPC.hs b/src/Morley/AsRPC.hs
--- a/src/Morley/AsRPC.hs
+++ b/src/Morley/AsRPC.hs
@@ -6,6 +6,8 @@
 module Morley.AsRPC
   ( TAsRPC
   , HasRPCRepr(..)
+  , deriveRPCWithOptions
+  , DeriveRPCOptions(..)
   , deriveRPC
   , deriveRPCWithStrategy
   , deriveManyRPC
@@ -28,6 +30,7 @@
 
 import Control.Lens.Plated (universe)
 import Data.Constraint (Dict(..), (***), (:-)(Sub), (\\))
+import Data.Default (Default(..))
 import Data.Generics (everything, mkQ)
 import Data.List qualified as List ((\\))
 import Data.Map qualified as Map
@@ -37,8 +40,9 @@
 import Language.Haskell.TH
   (Con(InfixC, NormalC, RecC), Cxt, Dec(DataD, NewtypeD, TySynD, TySynInstD),
   DerivStrategy(AnyclassStrategy), Info(TyConI), Kind, Loc(loc_module), Name, Q, TyLit(StrTyLit),
-  TySynEqn(..), TyVarBndr(..), Type(..), cxt, instanceD, location, mkName, nameBase, ppr, reify,
-  reifyInstances, standaloneDerivWithStrategyD)
+  TySynEqn(..), TyVarBndr(..), Type(..), conT, cxt, instanceD, location, lookupTypeName, mkName,
+  nameBase, normalB, ppr, reify, reifyInstances, standaloneDerivWithStrategyD, valD, varE, varP)
+import Language.Haskell.TH qualified as TH
 import Language.Haskell.TH.ReifyMany (reifyManyTyCons)
 import Language.Haskell.TH.ReifyMany.Internal (decConcreteNames)
 
@@ -54,6 +58,7 @@
 import Morley.Util.CustomGeneric
   (GenericStrategy, customGeneric', deriveFullType, haskellBalanced,
   mangleGenericStrategyConstructors, mangleGenericStrategyFields, reifyDataType)
+import Morley.Util.Interpolate (itu)
 import Morley.Util.Named hiding (Name)
 import Morley.Util.TH (isTypeAlias, lookupTypeNameOrFail)
 
@@ -270,67 +275,134 @@
 -- Derive RPC repr
 ----------------------------------------------------------------------------
 
--- | Derive an RPC representation for a type, as well as instances for 'Generic', 'IsoValue' and 'HasRPCRepr'.
---
--- > data ExampleStorage a b = ExampleStorage
--- >   { esField1 :: Integer
--- >   , esField2 :: [BigMap Integer MText]
--- >   , esField3 :: a
--- >   }
--- >   deriving stock Generic
--- >   deriving anyclass IsoValue
--- >
--- > deriveRPC "ExampleStorage"
---
--- Will generate:
---
--- > data ExampleStorageRPC a b = ExampleStorageRPC
--- >   { esField1RPC :: AsRPC Integer
--- >   , esField2RPC :: AsRPC [BigMap Integer MText]
--- >   , esField3RPC :: AsRPC a
--- >   }
--- >
--- > instance HasRPCRepr a => HasRPCRepr (ExampleStorage a b) where
--- >   type AsRPC (ExampleStorage a b) = ExampleStorageRPC a b
--- > deriving anyclass instance (IsoValue (AsRPC a), IsoValue (AsRPC b)) => IsoValue (ExampleStorageRPC a b)
--- > instance Generic (ExampleStorageRPC a b) where
--- >   ...
+-- | 'deriveRPCWithOptions' using default 'DeriveRPCOptions'.
 deriveRPC :: String -> Q [Dec]
-deriveRPC typeStr = deriveRPCWithStrategy typeStr haskellBalanced
+deriveRPC typeStr = deriveRPCWithOptions typeStr def
 
--- | Recursively enumerate @data@, @newtype@ and @type@ declarations,
--- and derives an RPC representation for each type that doesn't yet have one.
---
--- You can also pass in a list of types for which you _don't_ want
--- an RPC representation to be derived.
---
--- In this example, 'deriveManyRPC' will generate an RPC
--- representation for @A@ and @B@,
--- but not for @C@ (because we explicitly said we don't want one)
--- or @D@ (because it already has one).
---
--- > data B = B
--- > data C = C
--- > data D = D
--- > deriveRPC "D"
--- >
--- > data A = A B C D
--- > deriveManyRPC "A" ["C"]
+-- | Options for 'deriveRPCWithOptions'.
+data DeriveRPCOptions = DeriveRPCOptions
+  { droRecursive :: Bool
+    -- ^ Recursively enumerate @data@, @newtype@ and @type@ declarations, and
+    -- derives an RPC representation for each type that doesn't yet have one.
+    -- @True@ by default.
+  , droRecursiveSkipTypes :: [String]
+    -- ^ List of types for which you _don't_ want an RPC representation to be
+    -- derived. This is ignored if @droRecursive@ is @False@.
+  , droHasAnnotation :: Bool
+    -- ^ Derive @HasAnnotation@. The class and its methods must be in scope,
+    -- otherwise a compilation error is raised. @True@ by default.
+  , droStrategy :: GenericStrategy
+    -- ^ Custom Generic deriving strategy. 'haskellBalanced' by default.
+  }
+
+instance Default DeriveRPCOptions where
+  def = DeriveRPCOptions
+    { droRecursive = True
+    , droRecursiveSkipTypes = []
+    , droHasAnnotation = True
+    , droStrategy = haskellBalanced
+    }
+
+{- | Derive an RPC representation for a type, as well as instances for
+'Generic', 'IsoValue', 'HasRPCRepr' and optionally @HasAnnotation@.
+
+> data ExampleStorage a b = ExampleStorage
+>   { esField1 :: Integer
+>   , esField2 :: [BigMap Integer MText]
+>   , esField3 :: a
+>   }
+>   deriving stock Generic
+>   deriving anyclass IsoValue
+>
+> deriveRPC "ExampleStorage"
+
+Will generate:
+
+> data ExampleStorageRPC a b = ExampleStorageRPC
+>   { esField1RPC :: AsRPC Integer
+>   , esField2RPC :: AsRPC [BigMap Integer MText]
+>   , esField3RPC :: AsRPC a
+>   }
+>
+> instance HasRPCRepr a => HasRPCRepr (ExampleStorage a b) where
+>   type AsRPC (ExampleStorage a b) = ExampleStorageRPC a b
+> deriving anyclass instance (IsoValue (AsRPC a), IsoValue (AsRPC b)) => IsoValue (ExampleStorageRPC a b)
+> instance Generic (ExampleStorageRPC a b) where
+>   ...
+
+When 'droHasAnnotation' is @True@, it will also generate a @HasAnnotation@ (from
+@Lorentz@) instance like:
+
+> instance With [HasAnnotation, HasRPCRepr] ExampleStorage
+>   => HasAnnotation ExampleStorageRPC where
+>   getAnnotation = notesAsRPC . getAnnotation @ExampleStorage
+>   annOptions = annOptions @ExampleStorage
+
+Note that if the type doesn't contain type variables or only contains phantom
+type variables, 'HasRPCRepr' constraint is omitted, as it would be redundant.
+
+@HasAnnotation@ and its methods must be in scope.
+
+When 'droRecursive' is @True@, recursively enumerate @data@, @newtype@ and
+@type@ declarations, and derive an RPC representation for each type that doesn't
+yet have one.
+
+You can also pass in a list of types for which you _don't_ want
+an RPC representation to be derived in 'droRecursiveSkipTypes'.
+
+In this example, this will generate an RPC representation for @A@ and @B@, but
+not for @C@ (because we explicitly said we don't want one) or @D@ (because it
+already has one).
+
+> data B = B
+> data C = C
+> data D = D
+> deriveRPC "D"
+>
+> data A = A B C D
+> deriveRPCWithOptions "A" def{droRecursive=True, droRecursiveSkipTypes=["C"]}
+-}
+deriveRPCWithOptions :: String -> DeriveRPCOptions -> Q [Dec]
+deriveRPCWithOptions typeStr opts@DeriveRPCOptions{droRecursive}
+  | droRecursive = deriveManyRPCWithStrategy' typeStr opts
+  | otherwise = do
+      typeName <- lookupTypeNameOrFail typeStr
+      whenM (isTypeAlias typeName) $ fail $ typeStr <> " is a 'type' alias but not 'data' or 'newtype'."
+      deriveRPCWithStrategy' typeName opts
+
+-- | Same as 'deriveRPCWithOptions' with 'droRecursive' set to @True@ and
+-- 'droHasAnnotation' set to @False@. Accepts 'droRecursiveSkipTypes' as second
+-- argument.
 deriveManyRPC :: String -> [String] -> Q [Dec]
-deriveManyRPC typeStr skipTypes =
-  deriveManyRPCWithStrategy typeStr skipTypes haskellBalanced
+deriveManyRPC typeStr droRecursiveSkipTypes = deriveRPCWithOptions typeStr DeriveRPCOptions
+  { droRecursive = True
+  , droHasAnnotation = False
+  , droStrategy = haskellBalanced
+  , droRecursiveSkipTypes
+  }
+{-# DEPRECATED deriveManyRPC "Use deriveRPCWithOptions instead" #-}
 
 -- | Same as 'deriveManyRPC', but uses a custom strategy for deriving a 'Generic' instance.
 deriveManyRPCWithStrategy :: String -> [String] -> GenericStrategy -> Q [Dec]
-deriveManyRPCWithStrategy typeStr skipTypes gs = do
-  skipTypeNames <- traverse lookupTypeNameOrFail skipTypes
+deriveManyRPCWithStrategy typeStr skipTypes strategy = deriveRPCWithOptions typeStr DeriveRPCOptions
+  { droRecursive = True
+  , droHasAnnotation = False
+  , droRecursiveSkipTypes=skipTypes
+  , droStrategy = strategy
+  }
+{-# DEPRECATED deriveManyRPCWithStrategy "Use deriveRPCWithOptions instead" #-}
+
+deriveManyRPCWithStrategy' :: String -> DeriveRPCOptions -> Q [Dec]
+deriveManyRPCWithStrategy' typeStr opts@DeriveRPCOptions{droRecursiveSkipTypes} = do
+  skipTypeNames <- traverse lookupTypeNameOrFail droRecursiveSkipTypes
   typeName <- lookupTypeNameOrFail typeStr
   whenM (isTypeAlias typeName) $ fail $ typeStr <> " is a 'type' alias but not 'data' or 'newtype'."
   allTypeNames <- findWithoutInstance typeName
-  join <$> forM (allTypeNames List.\\ skipTypeNames) \name -> deriveRPCWithStrategy' name gs
+  join <$> forM (allTypeNames List.\\ skipTypeNames) \name ->
+    deriveRPCWithStrategy' name opts
   where
 
-    -- | Recursively enumerate @data@, @newtype@ and @type@ declarations,
+    -- Recursively enumerate @data@, @newtype@ and @type@ declarations,
     -- and returns the names of only @data@ and @newtype@ of those that
     -- don't yet have an 'AsRPC' instance. Type aliases don't need instances
     -- and respectively there is no need to derive 'AsRPC' for them.
@@ -356,7 +428,7 @@
         Just typ ->
           not . null <$> reifyInstances ''AsRPC [typ]
 
-    -- | Given a type name, return the corresponding type expression
+    -- Given a type name, return the corresponding type expression
     -- (applied to any type variables, if necessary).
     --
     -- For example, assuming a data type like @data F a b = ...@ exists in the type environment,
@@ -374,13 +446,16 @@
 
 -- | Same as 'deriveRPC', but uses a custom strategy for deriving a 'Generic' instance.
 deriveRPCWithStrategy :: String -> GenericStrategy -> Q [Dec]
-deriveRPCWithStrategy typeStr gs = do
-  typeName <- lookupTypeNameOrFail typeStr
-  whenM (isTypeAlias typeName) $ fail $ typeStr <> " is a 'type' alias but not 'data' or 'newtype'."
-  deriveRPCWithStrategy' typeName gs
+deriveRPCWithStrategy name gs = deriveRPCWithOptions name DeriveRPCOptions
+  { droHasAnnotation = False
+  , droRecursive = False
+  , droRecursiveSkipTypes = []
+  , droStrategy = gs
+  }
+{-# DEPRECATED deriveRPCWithStrategy "Use deriveRPCWithOptions instead" #-}
 
-deriveRPCWithStrategy' :: Name -> GenericStrategy -> Q [Dec]
-deriveRPCWithStrategy' typeName gs = do
+deriveRPCWithStrategy' :: Name -> DeriveRPCOptions -> Q [Dec]
+deriveRPCWithStrategy' typeName DeriveRPCOptions{..} = do
   (_, decCxt, mKind, tyVars, constructors) <- reifyDataType typeName
 
   -- TODO [#722]: use `reifyInstances` to check that 'AsRPC' exists for `fieldType`
@@ -412,17 +487,18 @@
   -- RPC type after stripping RPC suffix. Fix for #811
   let
     gs' = mangleGenericStrategyFields dropRPCSuffix $
-            mangleGenericStrategyConstructors dropRPCSuffix gs
+            mangleGenericStrategyConstructors dropRPCSuffix droStrategy
 
   mconcat <$> sequence
     [ pure . one $ typeDecOfRPC
     , one <$> mkAsRPCInstance fieldTypes derivedType derivedTypeRPC
     , mkIsoValueInstance fieldTypesRPC derivedTypeRPC
     , customGeneric' (Just repTypeRPC) typeNameRPC derivedTypeRPC constructorsRPC gs'
+    , annotationInstance fieldTypes derivedType derivedTypeRPC
     ]
 
   where
-    -- | Given the field type @FieldType a b@, returns @AsRPC (FieldType a b)@.
+    -- Given the field type @FieldType a b@, returns @AsRPC (FieldType a b)@.
     convertFieldType :: Type -> Type
     convertFieldType tp = ConT ''AsRPC `AppT` tp
 
@@ -435,7 +511,7 @@
     convertName :: Name -> Name
     convertName = mkName . convertNameStr . nameBase
 
-    -- | Given the constructor
+    -- Given the constructor
     -- @C { f :: Int }@,
     -- returns the constructor
     -- @CRPC { fRPC :: AsRPC Int }@.
@@ -453,7 +529,7 @@
         InfixC (second convertFieldType fieldType1) (convertName conName) (second convertFieldType fieldType2)
       constr -> fail $ "Unsupported constructor for '" <> show typeName <> "': " <> show (ppr constr)
 
-    -- | Get a list of all the unique types of all the fields of all the given constructors.
+    -- Get a list of all the unique types of all the fields of all the given constructors.
     getFieldTypes :: [Con] -> Q [Type]
     getFieldTypes constrs = ordNub . join <$> forM constrs \case
       RecC _ fields -> pure $ fields <&> \(_, _, fieldType) -> fieldType
@@ -472,7 +548,7 @@
         _ -> fail $ "Only newtypes and data types are supported, but '" <>
           show tyName <> "' is:\n" <> show (ppr typeInfo)
 
-    -- | Traverse a 'Rep' type and:
+    -- Traverse a 'Rep' type and:
     --
     -- 1. Inspect its metadata and append @RPC@ to the type/constructor/field names.
     -- 2. Convert field types (e.g. @T@ becomes @AsRPC T@).
@@ -511,7 +587,7 @@
           VarT v -> VarT $ fromMaybe v $ Map.lookup v varMap
           x -> x
 
-    -- | Lookup the generic 'Rep' type instance for the given type.
+    -- Lookup the generic 'Rep' type instance for the given type.
     reifyRepInstance :: Name -> Type -> Q TySynEqn
     reifyRepInstance name tp =
       reifyInstances ''G.Rep [tp] >>= \case
@@ -519,7 +595,7 @@
         (_:_) -> fail $ "Found multiple instances of 'Generic' for '" <> show name <> "'."
         [] -> fail $ "Type '" <> show name <> "' must implement 'Generic'."
 
-    -- | Given the type @Foo a b = Foo (Bar a)@, generate an 'IsoValue' instance like:
+    -- Given the type @Foo a b = Foo (Bar a)@, generate an 'IsoValue' instance like:
     --
     -- > deriving anyclass instance IsoValue (AsRPC (Bar a)) => IsoValue (FooRPC a b)
     --
@@ -534,7 +610,7 @@
           cxt $ filter hasTyVar fieldTypes <&> \fieldType ->
             [t|IsoValue $(pure fieldType)|]
 
-    -- | Given the type @Foo a b = Foo (Bar a)@, generate an 'HasRPCRepr' instance like:
+    -- Given the type @Foo a b = Foo (Bar a)@, generate an 'HasRPCRepr' instance like:
     --
     -- > instance HasRPCRepr (Bar a) => HasRPCRepr (Foo a b) where
     -- >   type AsRPC (Foo a b) = FooRPC a b
@@ -552,7 +628,54 @@
           cxt $ filter hasTyVar fieldTypes <&> \fieldType ->
             [t|HasRPCRepr $(pure fieldType)|]
 
-    -- | Checks if the given type has any type variables.
+    -- When @HasAnnotation@ and its methods are in scope, given the type @ty@
+    -- where @AsRPC ty = tyRPC@, generate a @HasAnnotation@ instance like:
+    --
+    -- > instance With [HasAnnotation, HasRPCRepr] ty => HasAnnotation tyRPC where
+    -- >   getAnnotation = notesAsRPC . getAnnotation @ty
+    -- >   annOptions = annOptions @ty
+    --
+    -- Note that if @ty@ doesn't contain type variables or only contains phantom
+    -- type variables, 'HasRPCRepr' constraint is omitted, as it would be
+    -- redundant.
+    --
+    -- Will fail if @HasAnnotation@ or its methods are not in scope.
+    annotationInstance :: [Type] -> Type -> Type -> Q [Dec]
+    annotationInstance _ _ _ | not droHasAnnotation = pure []
+    annotationInstance fields (pure -> ty) (pure -> tyRPC) = pure <$> do
+      let noHasAnnError :: Text -> Q b
+          noHasAnnError reason =
+            -- NB: weird indentation is due to how GHC formats multiline TH
+            -- errors (it doesn't)
+            fail [itu|
+              #{reason}
+                  Did you mean to derive 'HasAnnotation' instances? If not, use:
+                      deriveRPCWithOptions "#{tyBase}" def{droHasAnnotation=False}
+              |]
+            where tyBase = nameBase typeName
+      hasAnnNm <- maybe (noHasAnnError "'HasAnnotation' is not in scope.") pure =<<
+        lookupTypeName "HasAnnotation"
+      methodNames <- reify hasAnnNm >>= \case
+        TH.ClassI (TH.ClassD _ _ _ _ decs) _ ->
+          pure $ flip mapMaybe decs \case
+            TH.SigD name _ -> Just name
+            _ -> Nothing
+        x -> noHasAnnError $
+          "Expected 'HasAnnotation' to be a class, but instead found " <> show (ppr x)
+      getAnnNm <- find (\nm -> nameBase nm == "getAnnotation") methodNames &
+        maybe (noHasAnnError "Did not find 'getAnnotation' method on 'HasAnnotation'") pure
+      annOptNm <- find (\nm -> nameBase nm == "annOptions") methodNames &
+        maybe (noHasAnnError "Did not find 'annOptions' method on 'HasAnnotation'") pure
+      let hasAnn = conT hasAnnNm
+          constraints
+            | any hasTyVar fields = [[t| With '[$hasAnn, HasRPCRepr] $ty |]]
+            | otherwise = [[t| $hasAnn $ty |]]
+      instanceD (sequence constraints) [t|$hasAnn $tyRPC|]
+          [ valD (varP getAnnNm) (normalB [|notesAsRPC . $(varE getAnnNm) @($ty)|]) []
+          , valD (varP annOptNm) (normalB [|$(varE annOptNm) @($ty)|]) []
+          ]
+
+    -- Checks if the given type has any type variables.
     hasTyVar :: Type -> Bool
     hasTyVar ty =
       flip any (universe ty) \case
diff --git a/src/Morley/CLI.hs b/src/Morley/CLI.hs
--- a/src/Morley/CLI.hs
+++ b/src/Morley/CLI.hs
@@ -23,6 +23,7 @@
   , addressOption
   , aliasOption
   , addressOrAliasOption
+  , someAddressOrAliasOption
   , onelineOption
   , entrypointOption
   , mTextOption
@@ -31,10 +32,12 @@
   ) where
 
 import Data.Singletons (SingI)
+import Fmt (pretty)
 import Options.Applicative
   (footerDoc, fullDesc, header, help, helper, info, long, metavar, option, progDesc, strOption,
   switch)
 import Options.Applicative qualified as Opt
+import Options.Applicative.Help qualified as Pretty
 import Options.Applicative.Help.Pretty (Doc)
 import Text.Read (read)
 
@@ -50,6 +53,7 @@
 import Morley.Tezos.Core (Mutez, Timestamp, parseTimestamp, timestampFromSeconds)
 import Morley.Tezos.Crypto
 import Morley.Util.CLI
+import Morley.Util.Interpolate (itu)
 import Morley.Util.Named
 
 ----------------------------------------------------------------------------
@@ -157,6 +161,28 @@
   -> Opt.Parser (AddressOrAlias kind)
 addressOrAliasOption = mkCLOptionParser
 
+-- | Generic parser to read an option of 'SomeAddressOrAlias' type.
+someAddressOrAliasOption
+  :: Maybe SomeAddressOrAlias
+  -> "name" :! String
+  -> "help" :! String
+  -> Opt.Parser SomeAddressOrAlias
+someAddressOrAliasOption defValue (arg #name -> name) (arg #help -> hInfo) =
+  Opt.option (getReader @SomeAddressOrAlias) $ mconcat
+    [ Opt.metavar (getMetavar @SomeAddressOrAlias)
+    , Opt.long name
+    -- Note: `Opt.help` ignores newlines, so we use `Opt.helpDoc` + `vsep` instead.
+    -- We use `paragraph` to word-wrap the help text.
+    , Opt.helpDoc $ Just $ Pretty.vsep $ (Pretty.extractChunk . Pretty.paragraph) <$>
+      [ hInfo
+      , [itu|
+        When using an alias that is assigned to both a contract and an implicit account,
+        use the prefix '#{contractPrefix}:' or '#{implicitPrefix}:' to disambiguate.
+        |]
+      ]
+    , maybeAddDefault pretty defValue
+    ]
+
 -- | Parser for transaction parameters.
 txDataOption :: Opt.Parser TxData
 txDataOption =
@@ -172,7 +198,7 @@
     mkTxData :: ImplicitAddress -> U.Value -> Mutez -> EpName -> TxData
     mkTxData addr param amount epName =
       TxData
-        { tdSenderAddress = MkConstrainedAddress addr
+        { tdSenderAddress = Constrained addr
         , tdParameter = TxUntypedParam param
         , tdEntrypoint = epName
         , tdAmount = amount
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
@@ -22,8 +22,8 @@
 import Morley.Michelson.TypeCheck (TypeCheckOptions(..), typeCheckingWith)
 import Morley.Michelson.TypeCheck.Instr (typeCheckValue)
 import Morley.Michelson.Typed
-  (Contract, HasNoOp, Instr, Notes(..), T(..), Value, Value'(..), fromUType, mkUType, rfAnyInstr,
-  toUType)
+  (Contract, HasNoOp, Instr, LambdaCode'(..), Notes(..), T(..), Value, Value'(..), fromUType,
+  mkUType, rfAnyInstr, toUType)
 import Morley.Michelson.Typed.Convert (convertContract, instrToOpsOptimized, untypeValueOptimized)
 import Morley.Michelson.Untyped qualified as Untyped
 import Morley.Michelson.Untyped.Annotation
@@ -63,6 +63,7 @@
     Untyped.ValueSeq vs -> toExpression vs
     Untyped.ValueMap elts -> toExpression $ eltToExpr <$> elts
     Untyped.ValueLambda ops -> toExpression ops
+    Untyped.ValueLamRec ops -> expressionPrim' "Lambda_rec" [toExpression ops] []
     where
       eltToExpr :: Untyped.Elt ExpandedOp -> Expression
       eltToExpr (Untyped.Elt l r) = expressionPrim' "Elt"
@@ -90,8 +91,7 @@
     Untyped.TOperation -> expressionPrim' "operation" [] []
     Untyped.TContract arg -> expressionPrim' "contract" [toExpression arg] []
     Untyped.TTicket arg -> expressionPrim' "ticket" [toExpression arg] []
-    t@Untyped.TPair{} -> expressionPrim' "pair"
-      (rightCombedPairToList (Ty t noAnn) (noAnn, noAnn)) []
+    t@Untyped.TPair{} -> expressionPrim' "pair" (rightCombedPairToList t) []
     Untyped.TOr fa1 fa2 l r ->
       let exprL = addTrimmedAnns (toExpression l) [] [fa1] []
           exprR = addTrimmedAnns (toExpression r) [] [fa2] []
@@ -126,15 +126,15 @@
       addAnns e anns =
         e & _ExpressionPrim . mpaAnnotsL <>~ anns
 
-      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
+      rightCombedPairToList :: Untyped.T -> [Expression]
+      rightCombedPairToList t =
+        let go ty (fa, va)
+              | Ty (Untyped.TPair faL faR vaL vaR l r) ta <- ty
+              , ta == noAnn, fa == noAnn, va == noAnn
+              = toExpression l `addAnns` mkAnns [] [faL] [vaL] : go r (faR, vaR)
+              | otherwise
+              = one $ toExpression ty `addAnns` mkAnns [] [fa] [va]
+        in go (Ty t noAnn) (noAnn, noAnn)
 
 instance ToExpression Ty where
   toExpression (Ty t ta) = addTrimmedAnns (toExpression t) [ta] [] []
@@ -157,6 +157,8 @@
 instance ToExpression ViewName where
   toExpression (ViewName s) = expressionString s
 
+-- Note: On adding new expressions here, you must also add the symmetric (reading) case
+-- to FromExp x (InstrAbstract op) as well.
 instance ToExpression ExpandedInstr where
   toExpression = \case
     PUSH va ty v -> expressionPrim' "PUSH" [toExpression ty, toExpression v] $
@@ -218,6 +220,11 @@
                             , toExpression tyout
                             , toExpression ops
                             ] $ mkAnns [] [] [va]
+    LAMBDA_REC va tyin tyout ops ->
+      expressionPrim' "LAMBDA_REC" [ toExpression tyin
+                            , toExpression tyout
+                            , toExpression ops
+                            ] $ mkAnns [] [] [va]
     EXEC va -> expressionPrim' "EXEC" [] $ mkAnns [] [] [va]
     APPLY va -> expressionPrim' "APPLY" [] $ mkAnns [] [] [va]
     DIP ops -> expressionPrim' "DIP" [toExpression ops] []
@@ -285,6 +292,7 @@
     LEVEL va -> expressionPrim' "LEVEL" [] $ mkAnns [] [] [va]
     SELF_ADDRESS va -> expressionPrim' "SELF_ADDRESS" [] $ mkAnns [] [] [va]
     TICKET va -> expressionPrim' "TICKET" [] $ mkAnns [] [] [va]
+    TICKET_DEPRECATED va -> expressionPrim' "TICKET_DEPRECATED" [] $ mkAnns [] [] [va]
     READ_TICKET va -> expressionPrim' "READ_TICKET" [] $ mkAnns [] [] [va]
     SPLIT_TICKET va -> expressionPrim' "SPLIT_TICKET" [] $ mkAnns [] [] [va]
     JOIN_TICKETS va -> expressionPrim' "JOIN_TICKETS" [] $ mkAnns [] [] [va]
@@ -393,6 +401,8 @@
       arg' <- fromExp arg
       pure $ Untyped.ValueSome arg'
     ExpPrim' _ "None" [] [] -> pure Untyped.ValueNone
+    ExpPrim' _ "Lambda_rec" [args] [] -> fmap Untyped.ValueLamRec $
+      fromExp args >>= maybeToRight (FromExpError e "Expected at least one instruction") . nonEmpty
     ExpSeq _ [] -> pure Untyped.ValueNil
     ExpSeq _ (h : t) ->
       case fromExp @x @op h of
@@ -433,6 +443,8 @@
     ExpSeq _ s -> SeqEx <$> traverse fromExp s
     e          -> PrimEx <$> fromExp e
 
+-- Note: On adding new expressions here, you must also add the symmetric (writing) case
+-- to ToExpression as well.
 instance FromExp x op =>
          FromExp x (InstrAbstract op) where
   fromExp e = let annSet = getAnnSet e in case e of
@@ -599,6 +611,13 @@
       ops' <- fromExp @x @[op] ops
       let va = firstAnn @VarTag annSet
       pure $ LAMBDA va inp' out' ops'
+    ExpPrim' _ "LAMBDA_REC" [inp, out, ops] _ -> do
+      checkAnnsCount e annSet (0, 0, 1)
+      inp' <- fromExp @x @Ty inp
+      out' <- fromExp @x @Ty out
+      ops' <- fromExp @x @[op] ops
+      let va = firstAnn @VarTag annSet
+      pure $ LAMBDA_REC va inp' out' ops'
     ExpPrim' _ "EXEC" [] anns -> mkInstrWithVarAnn EXEC anns
     ExpPrim' _ "APPLY" [] anns -> mkInstrWithVarAnn APPLY anns
     ExpPrim' _ "DIP" [ops] [] -> do
@@ -698,7 +717,10 @@
     ExpPrim' _ "SELF_ADDRESS" [] anns ->
       mkInstrWithVarAnn SELF_ADDRESS anns
     ExpPrim' _ "NEVER" [] [] -> pure NEVER
-    ExpPrim' _ "TICKET" [] anns -> mkInstrWithVarAnn TICKET anns
+    ExpPrim' _ "TICKET_DEPRECATED" [] anns ->
+      mkInstrWithVarAnn TICKET_DEPRECATED anns
+    ExpPrim' _ "TICKET" [] anns ->
+      mkInstrWithVarAnn TICKET anns
     ExpPrim' _ "READ_TICKET" [] anns ->
       mkInstrWithVarAnn READ_TICKET anns
     ExpPrim' _ "SPLIT_TICKET" [] anns ->
@@ -952,8 +974,10 @@
 -- not just lambdas (i.e. instructions with one input and one output).
 instance (SingI inp, SingI out) => FromExp RegularExp (Instr '[inp] '[out]) where
   fromExp expr =
-    fromExpression @(Value ('TLambda inp out)) expr <&> \case
-      VLam instr -> rfAnyInstr instr
+    fromExpression @(Value ('TLambda inp out)) expr >>= \case
+      VLam (LambdaCode instr) -> pure $ rfAnyInstr instr
+      VLam LambdaCodeRec{} -> Left $ FromExpError expr
+        "Expected block of code, found Lambda_rec"
 
 instance FromExp x ViewName where
   fromExp e = case e of
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
@@ -101,9 +101,9 @@
   --   * "parameter" is at index 0 on the list, so it gets packed to `0x0300`
   --   * "storage" is at index 1, so it gets packed to `0x0301`
   --
-  -- You can ask `tezos-client` which code corresponds to a given instruction/type/constructor.
+  -- You can ask `octez-client` which code corresponds to a given instruction/type/constructor.
   --
-  -- > tezos-client convert data 'storage' from michelson to binary
+  -- > octez-client convert data 'storage' from michelson to binary
   -- > 0x0301
   --
   -- Whenever new instructions/types/constructors are added to the protocol,
@@ -131,8 +131,8 @@
   "DIG", "DUG", "EMPTY_BIG_MAP", "APPLY", "chain_id", "CHAIN_ID", "LEVEL", "SELF_ADDRESS",
   "never", "NEVER", "UNPAIR", "VOTING_POWER", "TOTAL_VOTING_POWER", "KECCAK", "SHA3", "PAIRING_CHECK",
   "bls12_381_g1", "bls12_381_g2", "bls12_381_fr", "sapling_state", "sapling_transaction_deprecated", "SAPLING_EMPTY_STATE", "SAPLING_VERIFY_UPDATE", "ticket",
-  "TICKET", "READ_TICKET", "SPLIT_TICKET", "JOIN_TICKETS", "GET_AND_UPDATE", "chest", "chest_key", "OPEN_CHEST",
-  "VIEW", "view", "constant", "SUB_MUTEZ", "tx_rollup_l2_address", "MIN_BLOCK_TIME", "sapling_transaction", "EMIT"
+  "TICKET_DEPRECATED", "READ_TICKET", "SPLIT_TICKET", "JOIN_TICKETS", "GET_AND_UPDATE", "chest", "chest_key", "OPEN_CHEST",
+  "VIEW", "view", "constant", "SUB_MUTEZ", "tx_rollup_l2_address", "MIN_BLOCK_TIME", "sapling_transaction", "EMIT", "Lambda_rec", "LAMBDA_REC", "TICKET"
   ]
 
 -- | Type for Micheline Expression with extension points.
diff --git a/src/Morley/Michelson/Doc.hs b/src/Morley/Michelson/Doc.hs
--- a/src/Morley/Michelson/Doc.hs
+++ b/src/Morley/Michelson/Doc.hs
@@ -775,16 +775,16 @@
     \Michelson representation to make interactions outside of Haskell possible.\n\n\
     \There are multiple ways to interact with this contract:\n\n\
     \* Use this contract in your Haskell application, thus all operation submissions \
-    \should be handled separately, e.g. via calling `tezos-client`, which will communicate \
-    \with the `tezos-node`. In order to be able to call `tezos-client` you'll need to be able \
+    \should be handled separately, e.g. via calling `octez-client`, which will communicate \
+    \with the `octez-node`. In order to be able to call `octez-client` you'll need to be able \
     \to construct Michelson values from Haskell.\n\n\
     \  The easiest way to do that is to serialize Haskell value using `lPackValue` function \
     \from [`Lorentz.Pack`](https://gitlab.com/morley-framework/morley/-/blob/2441e26bebd22ac4b30948e8facbb698d3b25c6d/code/lorentz/src/Lorentz/Pack.hs) \
     \module, encode resulting bytestring to hexadecimal representation using `encodeHex` function. \
     \Resulting hexadecimal encoded bytes sequence can be decoded back to Michelson value via \
-    \`tezos-client unpack michelson data`.\n\n\
+    \`octez-client unpack michelson data`.\n\n\
     \  Reverse conversion from Michelson value to the \
-    \Haskell value can be done by serializing Michelson value using `tezos-client hash data` command, \
+    \Haskell value can be done by serializing Michelson value using `octez-client hash data` command, \
     \resulting `Raw packed data` should be decoded from the hexadecimal representation using `decodeHex` \
     \and deserialized to the Haskell value via `lUnpackValue` function from \
     \[`Lorentz.Pack`](https://gitlab.com/morley-framework/morley/-/blob/2441e26bebd22ac4b30948e8facbb698d3b25c6d/code/lorentz/src/Lorentz/Pack.hs).\n\n\
diff --git a/src/Morley/Michelson/Interpret.hs b/src/Morley/Michelson/Interpret.hs
--- a/src/Morley/Michelson/Interpret.hs
+++ b/src/Morley/Michelson/Interpret.hs
@@ -7,7 +7,7 @@
   ( ContractEnv (..)
   , InterpreterState (..)
   , MichelsonFailed (..)
-  , MichelsonFailureWithStack (..)
+  , MichelsonFailureWithStack(..)
   , RemainingSteps (..)
   , SomeItStack (..)
   , MorleyLogs (..)
@@ -76,7 +76,6 @@
 import Morley.Util.Peano (LongerThan, Peano)
 import Morley.Util.PeanoNatural (PeanoNatural(..))
 import Morley.Util.Sing (eqParamSing)
-import Morley.Util.TH
 import Morley.Util.Type
 import Morley.Util.Typeable
 
@@ -166,20 +165,23 @@
   -- ^ Minimum time between blocks
   }
 
--- | Represents @[FAILED]@ state of a Michelson program. Contains
--- value that was on top of the stack when @FAILWITH@ was called.
-data MichelsonFailed where
-  MichelsonFailedWith :: (SingI t, ConstantScope t) => T.Value t -> MichelsonFailed
+-- | Errors that can be thrown by the interpreter. The @ext@ type variable
+-- allow the downstreams consumer to add additional exceptions.
+data MichelsonFailed ext where
+  MichelsonFailedWith :: (SingI t, ConstantScope t) => T.Value t -> MichelsonFailed ext
+    -- ^ Represents @[FAILED]@ state of a Michelson program. Contains
+    -- value that was on top of the stack when @FAILWITH@ was called.
   MichelsonArithError
     :: (Typeable n, Typeable m)
-    => ArithError (Value n) (Value m) -> MichelsonFailed
-  MichelsonGasExhaustion :: MichelsonFailed
-  MichelsonFailedTestAssert :: Text -> MichelsonFailed
-  MichelsonUnsupported :: Text -> MichelsonFailed
+    => ArithError (Value n) (Value m) -> MichelsonFailed ext
+  MichelsonGasExhaustion :: MichelsonFailed ext
+  MichelsonFailedTestAssert :: Text -> MichelsonFailed ext
+  MichelsonUnsupported :: Text -> MichelsonFailed ext
+  MichelsonExt :: ext -> MichelsonFailed ext
 
-deriving stock instance Show MichelsonFailed
+deriving stock instance Show ext => Show (MichelsonFailed ext)
 
-instance Eq MichelsonFailed where
+instance Eq ext => Eq (MichelsonFailed ext) where
   MichelsonFailedWith v1 == MichelsonFailedWith v2 = v1 `eqParamSing` v2
   MichelsonFailedWith _ == _ = False
   MichelsonArithError ae1 == MichelsonArithError ae2 = ae1 `eqParam2` ae2
@@ -190,8 +192,10 @@
   MichelsonFailedTestAssert _ == _ = False
   MichelsonUnsupported i1 == MichelsonUnsupported i2 = i1 == i2
   MichelsonUnsupported _ == _ = False
+  MichelsonExt i1 == MichelsonExt i2 = i1 == i2
+  MichelsonExt _ == _ = False
 
-instance Buildable MichelsonFailed where
+instance Buildable ext => Buildable (MichelsonFailed ext) where
   build =
     \case
       MichelsonFailedWith v ->
@@ -202,22 +206,23 @@
       MichelsonFailedTestAssert t -> build t
       MichelsonUnsupported instr ->
         build instr <> " instruction is not supported."
+      MichelsonExt x -> build x
 
--- | Carries a 'MichelsonFailed' error and the 'ErrorSrcPos' at which it was raised
-data MichelsonFailureWithStack = MichelsonFailureWithStack
-  { mfwsFailed :: MichelsonFailed
+-- | Carries a 'MichelsonFailed' @ext@ error and the 'ErrorSrcPos' at which it was raised
+data MichelsonFailureWithStack ext = MichelsonFailureWithStack
+  { mfwsFailed :: MichelsonFailed ext
   , mfwsErrorSrcPos :: ErrorSrcPos
   } deriving stock (Show, Generic, Eq)
 
-instance Buildable MichelsonFailureWithStack where
+instance Buildable ext => Buildable (MichelsonFailureWithStack ext) where
   build (MichelsonFailureWithStack err loc) = build err <> " at " <> build loc
 
-newtype InterpretError = InterpretError (MichelsonFailureWithStack, MorleyLogs)
+newtype InterpretError ext = InterpretError (MichelsonFailureWithStack ext, MorleyLogs)
   deriving stock (Generic)
 
-deriving stock instance Show InterpretError
+deriving stock instance Show ext => Show (InterpretError ext)
 
-instance Buildable InterpretError where
+instance Buildable ext => Buildable (InterpretError ext) where
   build (InterpretError (mf, _)) = prettyLn mf
 
 data InterpretResult where
@@ -245,11 +250,11 @@
   }
 
 type ContractReturn st =
-  (Either MichelsonFailureWithStack ([Operation], T.Value st), (InterpreterState, MorleyLogs))
+  (Either (MichelsonFailureWithStack Void) ([Operation], T.Value st), (InterpreterState, MorleyLogs))
 
 handleContractReturn
   :: (StorageScope st)
-  => ContractReturn st -> Either InterpretError InterpretResult
+  => ContractReturn st -> Either (InterpretError Void) InterpretResult
 handleContractReturn (ei, (s, l)) =
   bimap (InterpretError . (, l)) (constructIR . (, s, l)) ei
 
@@ -314,7 +319,7 @@
   :: ContractEnv
   -> Instr inp out
   -> Rec T.Value inp
-  -> Either MichelsonFailureWithStack (Rec T.Value out)
+  -> Either (MichelsonFailureWithStack Void) (Rec T.Value out)
 interpretInstr = fmap mapToValue ... interpretInstrAnnotated
 
 -- | Interpret an instruction in vacuum, putting no extra constraints on
@@ -325,7 +330,7 @@
   :: ContractEnv
   -> Instr inp out
   -> Rec T.Value inp
-  -> Either MichelsonFailureWithStack (Rec StkEl out)
+  -> Either (MichelsonFailureWithStack Void) (Rec StkEl out)
 interpretInstrAnnotated env instr inpSt =
   fst $
   runEvalOp
@@ -341,14 +346,14 @@
   SomeItStack :: T.ExtInstr inp -> Rec StkEl inp -> SomeItStack
 
 type EvalOp =
-  ExceptT MichelsonFailureWithStack $
+  ExceptT (MichelsonFailureWithStack Void) $
   RWS ContractEnv MorleyLogsBuilder InterpreterState
 
 runEvalOp
   :: EvalOp a
   -> ContractEnv
   -> InterpreterState
-  -> (Either MichelsonFailureWithStack a, (InterpreterState, MorleyLogs))
+  -> (Either (MichelsonFailureWithStack Void) a, (InterpreterState, MorleyLogs))
 runEvalOp act env initSt =
   let (res, is, logs) = runRWS (runExceptT act) env initSt
   in (res, (is, buildMorleyLogs logs))
@@ -386,20 +391,22 @@
 instance InterpreterStateMonad m => InterpreterStateMonad (ExceptT e m) where
   stateInterpreterState = lift . stateInterpreterState
 
-type EvalM m =
+type EvalM' ext m =
   ( MonadReader ContractEnv m
   , InterpreterStateMonad m
   , MonadWriter MorleyLogsBuilder m
-  , MonadError MichelsonFailureWithStack m
+  , MonadError (MichelsonFailureWithStack ext) m
   )
 
+type EvalM m = EvalM' Void m
+
 type InstrRunner m =
   forall inp out.
      Instr inp out
   -> Rec StkEl inp
   -> m (Rec StkEl out)
 
-throwMichelson :: EvalM m => MichelsonFailed -> m a
+throwMichelson :: EvalM' ext m => MichelsonFailed ext -> m a
 throwMichelson mf = asks ceErrorSrcPos >>= throwError . MichelsonFailureWithStack mf
 
 -- | Function to change amount of remaining steps stored in State monad.
@@ -422,7 +429,10 @@
 runInstrNoGas = runInstrImpl runInstrNoGas
 
 -- | Function to interpret Michelson instruction(s) against given stack.
-runInstrImpl :: forall m. EvalM m => InstrRunner m -> InstrRunner m
+-- The @ext@ type variable specifies additional exceptions that can be thrown from the inner
+-- runner function (via 'MichelsonExt'). In Morley, it's set to 'Void', but downstream consumers
+-- may use other type here.
+runInstrImpl :: forall ext m. EvalM' ext m => InstrRunner m -> InstrRunner m
 runInstrImpl runner (Seq i1 i2) r = runner i1 r >>= \r' -> runner i2 r'
 runInstrImpl runner (WithLoc ics i) r = local (\env -> env{ceErrorSrcPos = ics}) $ runner i r
 runInstrImpl runner (Meta _ i) r = runner i r
@@ -470,9 +480,8 @@
        => PeanoNatural n -> Rec StkEl inp -> Rec StkEl out
     go Zero stack = stack
     go (Succ n') (b :& r) =
-      case klist @inp of
-        KCons _ Proxy -> case go n' r of
-          (a :& resTail) -> a :& b :& resTail
+      case go n' r of
+        a :& resTail -> a :& b :& resTail
 runInstrImpl _ (DUG s) input0 =
   pure $ go s input0
   where
@@ -599,12 +608,24 @@
 runInstrImpl runner (LOOP_LEFT ops) (StkEl (VOr (Left a)) :& r) = do
   res <- runner ops (StkEl a :& r)
   runner (LOOP_LEFT ops) res
-runInstrImpl _ (AnnLAMBDA _ lam) r = pure $ StkEl lam :& r
-runInstrImpl runner AnnEXEC{} (a :& StkEl (VLam (T.rfAnyInstr -> lBody)) :& r) = do
-  res <- runner lBody (a :& RNil)
-  pure $ res <+> r
-runInstrImpl _ AnnAPPLY{} (StkEl (a :: T.Value a) :& StkEl (VLam lBody) :& r) = do
-  pure $ StkEl (VLam (T.rfMapAnyInstr doApply lBody)) :& r
+runInstrImpl _ (AnnLAMBDA _ lam) r = pure $ StkEl (mkVLam lam) :& r
+runInstrImpl _ (AnnLAMBDA_REC _ lam) r = pure $ StkEl (mkVLamRec lam) :& r
+runInstrImpl runner AnnEXEC{} (a :& self@(StkEl (VLam code)) :& r) =
+  case code of
+    LambdaCode (T.rfAnyInstr -> lBody) -> do
+      res <- runner lBody (a :& RNil)
+      pure $ res <+> r
+    LambdaCodeRec (T.rfAnyInstr -> lBody) -> do
+      res <- runner lBody (a :& self :& RNil)
+      pure $ res <+> r
+runInstrImpl _ i@AnnAPPLY{} (StkEl (a :: T.Value a) :& StkEl (VLam code) :& r)
+  | _ :: Instr (a : 'TLambda ('TPair a b) c : s) ('TLambda b c : s) <- i
+  , _ :: LambdaCode' Instr ('TPair a b) c <- code
+  = case code of
+      LambdaCode lBody -> pure $ StkEl (VLam $ LambdaCode (T.rfMapAnyInstr doApply lBody)) :& r
+      LambdaCodeRec lBody ->
+        let res = RfNormal $ PUSH a `Seq` PAIR `Seq` LAMBDA_REC lBody `Seq` SWAP `Seq` EXEC
+        in pure $ StkEl (VLam $ LambdaCode res) :& r
   where
     doApply :: Instr ('TPair a i ': s) o -> Instr (i ': s) o
     doApply b = PUSH a `Seq` PAIR `Seq` Nested b
@@ -687,7 +708,7 @@
     mkViewEnv :: ContractAddress -> ContractState -> ContractEnv -> ContractEnv
     mkViewEnv calledAddr viewedContractState ContractEnv{..} = ContractEnv
       { ceBalance = csBalance viewedContractState
-      , ceSender = MkConstrainedAddress ceSelf
+      , ceSender = Constrained ceSelf
       , ceSelf = calledAddr
       , ceSource
       , ceAmount = zeroMutez
@@ -703,7 +724,7 @@
       pure $ StkEl (VContract (MkAddress ceSelf) sepc) :& r
 runInstrImpl _ (AnnCONTRACT (Anns2' _ (_ :: T.Notes a)) instrEpName) (StkEl (VAddress epAddr) :& r) = do
   ContractEnv{..} <- ask
-  T.EpAddress' (MkConstrainedAddress addr) addrEpName <- pure epAddr
+  T.EpAddress' (Constrained addr) addrEpName <- pure epAddr
   let mepName =
         case (instrEpName, addrEpName) of
           (DefEpName, DefEpName) -> Just DefEpName
@@ -765,7 +786,7 @@
               globalCounter
   let resEpAddr = EpAddress resAddr DefEpName
   let resOp = CreateContract
-        (MkConstrainedAddress originator) (unwrapMbKeyHash mbKeyHash) m g contract globalCounter
+        (Constrained originator) (unwrapMbKeyHash mbKeyHash) m g contract globalCounter
   pure $ StkEl (VOp (OpCreateContract resOp))
       :& StkEl (VAddress resEpAddr)
       :& r
@@ -805,10 +826,10 @@
   let pairs' = [ (g1, g2) | VPair (VBls12381G1 g1, VBls12381G2 g2) <- pairs ]
   pure $ StkEl (VBool $ checkPairing pairs') :& r
 runInstrImpl _ AnnSOURCE{} r = do
-  ContractEnv{ceSource=MkConstrainedAddress ceSource} <- ask
+  ContractEnv{ceSource=Constrained ceSource} <- ask
   pure $ StkEl (VAddress $ EpAddress ceSource DefEpName) :& r
 runInstrImpl _ AnnSENDER{} r = do
-  ContractEnv{ceSender=MkConstrainedAddress ceSender} <- ask
+  ContractEnv{ceSender=Constrained ceSender} <- ask
   pure $ StkEl (VAddress $ EpAddress ceSender DefEpName) :& r
 runInstrImpl _ AnnADDRESS{} (StkEl (VContract a sepc) :& r) =
   pure $ StkEl (VAddress $ EpAddress' a (sepcName sepc)) :& r
@@ -823,6 +844,12 @@
   pure $ StkEl (VAddress $ EpAddress ceSelf DefEpName) :& r
 runInstrImpl _ AnnTICKET{} (StkEl dat :& StkEl (VNat am) :& r) = do
   ContractEnv{..} <- ask
+  let result = VOption do
+        guard (am /= 0)
+        pure $ VTicket (MkAddress ceSelf) dat am
+  pure $ StkEl (result) :& r
+runInstrImpl _ AnnTICKET_DEPRECATED{} (StkEl dat :& StkEl (VNat am) :& r) = do
+  ContractEnv{..} <- ask
   pure $ StkEl (VTicket (MkAddress ceSelf) dat am) :& r
 runInstrImpl _ AnnREAD_TICKET{} (te@(StkEl (VTicket addr dat am)) :& r) = do
   pure $
@@ -865,7 +892,7 @@
 
 -- | Evaluates an arithmetic operation and either fails or proceeds.
 runArithOp
-  :: (ArithOp aop n m, EvalM monad)
+  :: (ArithOp aop n m, EvalM' ext monad)
   => proxy aop
   -> StkEl n
   -> StkEl m
@@ -909,7 +936,7 @@
 unwrapMbKeyHash :: Maybe (T.Value 'T.TKeyHash) -> Maybe KeyHash
 unwrapMbKeyHash mbKeyHash = mbKeyHash <&> \(VKeyHash keyHash) -> keyHash
 
-interpretExt :: EvalM m => InstrRunner m -> SomeItStack -> m ()
+interpretExt :: EvalM' ext m => InstrRunner m -> SomeItStack -> m ()
 interpretExt _ (SomeItStack (T.PRINT (T.PrintComment pc)) st) = do
   let getEl (Left l) = l
       getEl (Right str) = withStackElem str st (pretty . seValue)
@@ -943,7 +970,7 @@
       (e :& _, Zero) -> cont e
       (_ :& es, Succ n) -> loop (es, n)
 
-assignBigMapIds' :: EvalM m => Value t -> m (Value t)
+assignBigMapIds' :: EvalM' ext m => Value t -> m (Value t)
 assignBigMapIds' val = do
   bigMapCounter0 <- view isBigMapCounterL <$> getInterpreterState
   let (storageWithIds, bigMapCounter1) = runState (assignBigMapIds True val) bigMapCounter0
@@ -971,6 +998,13 @@
 incrementCounter = modifyInterpreterState $ \iState ->
       iState { isGlobalCounter = isGlobalCounter iState + 1 }
 
-(deriveGADTNFData ''MichelsonFailed)
+instance NFData ext => NFData (MichelsonFailed ext) where
+  rnf = \case
+    MichelsonFailedWith x -> rnf x
+    MichelsonArithError x -> rnf x
+    MichelsonGasExhaustion -> ()
+    MichelsonFailedTestAssert x -> rnf x
+    MichelsonUnsupported x -> rnf x
+    MichelsonExt x -> rnf x
 
-instance NFData MichelsonFailureWithStack
+instance NFData ext => NFData (MichelsonFailureWithStack ext)
diff --git a/src/Morley/Michelson/Optimizer.hs b/src/Morley/Michelson/Optimizer.hs
--- a/src/Morley/Michelson/Optimizer.hs
+++ b/src/Morley/Michelson/Optimizer.hs
@@ -27,11 +27,10 @@
 import Prelude hiding (EQ, GT, LT)
 
 import Control.Lens (makeLensesFor)
-import Data.Constraint (Dict(..), (\\))
+import Data.Constraint (Dict(..))
 import Data.Default (Default(def))
 import Data.Singletons (sing)
 import Data.Type.Equality ((:~:)(Refl))
-import Unsafe.Coerce (unsafeCoerce)
 
 import Morley.Michelson.Interpret.Pack (packValue')
 import Morley.Michelson.Typed.Aliases (Value)
@@ -42,9 +41,7 @@
 import Morley.Michelson.Typed.T
 import Morley.Michelson.Typed.Util (DfsSettings(..), dfsModifyInstr)
 import Morley.Michelson.Typed.Value
-import Morley.Util.Peano
 import Morley.Util.PeanoNatural
-import Morley.Util.Type
 
 ----------------------------------------------------------------------------
 -- High level
@@ -395,39 +392,11 @@
 digDug = Rule \case
   (DIG (x :: PeanoNatural n) :: Instr inp t) :# (DUG y :: Instr t out) :# xs
     | Just Refl <- eqPeanoNat x y
-    -> Just xs \\ digDugProof @inp @out @t @n (singPeanoNat x)
+    -> Just xs
   (DIG (x :: PeanoNatural n) :: Instr inp t) :# (DUG y :: Instr t out)
     | Just Refl <- eqPeanoNat x y
-    -> Just Nop \\ digDugProof @inp @out @t @n (singPeanoNat x)
+    -> Just Nop
   _ -> Nothing
-
-digDugProof
-  :: forall inp out t n a.
-     ( KnownList inp
-     , inp ~ (Take n inp ++ (a ': Drop ('S n) inp))
-     , t ~ (a ': Take n inp ++ Drop ('S n) inp)
-     , out ~ (Take n (Drop ('S 'Z) t) ++ (a ': Drop ('S n) t))
-     )
-  => SingNat n -> inp :~: out
-{-# RULES "digDugProof" forall n. digDugProof n = unsafeCoerce Refl #-}
-{-# INLINE[1] digDugProof #-}
-digDugProof n = Refl
-  \\ lemma1 n inpS
-  \\ lemma2 n inpS
-  where
-    inpS = klist @inp
-    lemma1 :: forall xs m. SingNat m -> KList xs -> Take m xs :~: Take m (Take m xs ++ Drop ('S m) xs)
-    lemma1 = \case
-      SZ -> const Refl
-      SS m -> \case
-        KNil -> Refl
-        KCons _ (Proxy :: Proxy ys) -> Refl \\ lemma1 m (klist @ys)
-    lemma2 :: forall xs m. SingNat m -> KList xs -> Drop ('S m) xs :~: Drop m (Take m xs ++ Drop ('S m) xs)
-    lemma2 = \case
-      SZ -> const Refl
-      SS m -> \case
-        KNil -> Refl
-        KCons _ (Proxy :: Proxy ys) -> lemma2 m (klist @ys)
 
 -- TODO [#299]: optimize sequences of more than 2 DROPs.
 -- | Sequences of @DROP@s can be turned into single @DROP n@.
diff --git a/src/Morley/Michelson/Parser.hs b/src/Morley/Michelson/Parser.hs
--- a/src/Morley/Michelson/Parser.hs
+++ b/src/Morley/Michelson/Parser.hs
@@ -146,7 +146,7 @@
     Nothing ->
       fail $ "Duplicate contract field: " <> pretty result
   where
-    -- | @ensureNotDuplicate@ provides a better message and point to the correct line
+    -- @ensureNotDuplicate@ provides a better message and point to the correct line
     -- when the parser fails.
     contractTuple = fmap reverse . executingStateT [] $ do
       (`sepEndBy` lift semicolon) $ do
diff --git a/src/Morley/Michelson/Parser/Instr.hs b/src/Morley/Michelson/Parser/Instr.hs
--- a/src/Morley/Michelson/Parser/Instr.hs
+++ b/src/Morley/Michelson/Parser/Instr.hs
@@ -49,10 +49,11 @@
   , sourceOp, senderOp, chainIdOp, sha3Op, keccakOp, neverOp
   , votingPowerOp, totalVotingPowerOp, try unpairNOp
   , unpairOp
-  , ticketOp, readTicketOp, splitTicketOp, joinTicketsOp
+  , ticketOp, ticketDeprecatedOp, readTicketOp, splitTicketOp, joinTicketsOp
   , openChestOp
   , saplingEmptyStateOp, saplingVerifyUpdateOp, minBlockTimeOp
   , emitOp
+  , lambdaRecOp opParser
   ]
 
 -- | Parse a sequence of instructions.
@@ -137,6 +138,10 @@
 lambdaOp opParser =
   word "LAMBDA" LAMBDA <*> noteDef <*> type_ <*> type_ <*> ops' opParser
 
+lambdaRecOp :: Parser ParsedOp -> Parser ParsedInstr
+lambdaRecOp opParser =
+  word "LAMBDA_REC" LAMBDA_REC <*> noteDef <*> type_ <*> type_ <*> ops' opParser
+
 neverOp :: Parser ParsedInstr
 neverOp = word "NEVER" NEVER
 -- Generic comparison
@@ -459,6 +464,9 @@
 
 ticketOp :: Parser ParsedInstr
 ticketOp = word "TICKET" TICKET <*> noteDef
+
+ticketDeprecatedOp :: Parser ParsedInstr
+ticketDeprecatedOp = word "TICKET_DEPRECATED" TICKET_DEPRECATED <*> noteDef
 
 readTicketOp :: Parser ParsedInstr
 readTicketOp = word "READ_TICKET" READ_TICKET <*> noteDef
diff --git a/src/Morley/Michelson/Parser/Value.hs b/src/Morley/Michelson/Parser/Value.hs
--- a/src/Morley/Michelson/Parser/Value.hs
+++ b/src/Morley/Michelson/Parser/Value.hs
@@ -42,7 +42,7 @@
   [ stringLiteral, bytesLiteral, intLiteral, unitValue
   , trueValue, falseValue, pairValueCore opParser, leftValue opParser
   , rightValue opParser, someValue opParser, noneValue, nilValue
-  , seqOrLambda opParser, mapValue opParser
+  , seqOrLambda opParser, mapValue opParser, lambdaRecValue opParser
   ]
 
 seqOrLambda :: Parser ParsedOp -> Parser ParsedValue
@@ -119,6 +119,12 @@
 
 lambdaValue :: Parser ParsedOp -> Parser ParsedValue
 lambdaValue opParser = U.ValueLambda <$> ops1
+  where
+    ops1 :: Parser (NonEmpty ParsedOp)
+    ops1 = braces $ sepEndBy1 opParser semicolon
+
+lambdaRecValue :: Parser ParsedOp -> Parser ParsedValue
+lambdaRecValue opParser = word "Lambda_rec" U.ValueLamRec <*> ops1
   where
     ops1 :: Parser (NonEmpty ParsedOp)
     ops1 = braces $ sepEndBy1 opParser semicolon
diff --git a/src/Morley/Michelson/Printer.hs b/src/Morley/Michelson/Printer.hs
--- a/src/Morley/Michelson/Printer.hs
+++ b/src/Morley/Michelson/Printer.hs
@@ -13,7 +13,6 @@
   , printUntypedValue
   ) where
 
-import Data.Constraint (withDict)
 import Data.Singletons (SingI)
 import Data.Text.Lazy qualified as TL
 
@@ -22,40 +21,39 @@
 import Morley.Michelson.Untyped qualified as U
 
 -- | Convert an untyped contract into a textual representation which
--- will be accepted by the OCaml reference client: tezos-client.
+-- will be accepted by the OCaml reference client: @octez-client@.
 printUntypedContract :: (RenderDoc op) => Bool -> U.Contract' op -> TL.Text
 printUntypedContract forceSingleLine = printDoc forceSingleLine . renderDoc doesntNeedParens
 
 -- | Convert a typed contract into a textual representation which
--- will be accepted by the OCaml reference client: tezos-client.
+-- will be accepted by the OCaml reference client: @octez-client@.
 printTypedContractCode :: (SingI p, SingI s) => Bool -> T.ContractCode p s -> TL.Text
 printTypedContractCode forceSingleLine =
   printUntypedContract forceSingleLine . T.convertContractCode
 
 -- | Convert typed contract into a textual representation which
--- will be accepted by the OCaml reference client: tezos-client.
+-- will be accepted by the OCaml reference client: @octez-client@.
 printTypedContract :: Bool -> T.Contract p s -> TL.Text
 printTypedContract forceSingleLine fc@T.Contract{} =
   printUntypedContract forceSingleLine $ T.convertContract fc
 
 -- | Convert typed value into a textual representation which
--- will be accepted by the OCaml reference client: tezos-client.
+-- will be accepted by the OCaml reference client: @octez-client@.
 printTypedValue
   :: forall t.
       (T.ProperUntypedValBetterErrors t)
   => Bool -> T.Value t -> TL.Text
 printTypedValue forceSingleLine =
-  withDict (T.properUntypedValEvi @t) $
   printUntypedValue forceSingleLine . T.untypeValue
 
 -- | Convert untyped value into a textual representation which
--- will be accepted by the OCaml reference client: tezos-client.
+-- will be accepted by the OCaml reference client: @octez-client@.
 printUntypedValue :: (RenderDoc op) => Bool -> U.Value' op -> TL.Text
 printUntypedValue forceSingleLine =
   printDoc forceSingleLine . renderDoc doesntNeedParens
 
 -- | Convert 'T.SomeContract' into a textual representation which
--- will be accepted by the OCaml reference client: tezos-client.
+-- will be accepted by the OCaml reference client: @octez-client@.
 printSomeContract :: Bool -> T.SomeContract -> TL.Text
 printSomeContract forceSingleLine (T.SomeContract fc) =
   printTypedContract forceSingleLine fc
diff --git a/src/Morley/Michelson/Printer/Util.hs b/src/Morley/Michelson/Printer/Util.hs
--- a/src/Morley/Michelson/Printer/Util.hs
+++ b/src/Morley/Michelson/Printer/Util.hs
@@ -2,7 +2,7 @@
 -- SPDX-License-Identifier: LicenseRef-MIT-OA
 
 -- | Utilities for rendering Michelson code in a format compatible with
--- Tezos software (e.g @tezos-client@)
+-- Octez software (e.g @octez-client@)
 module Morley.Michelson.Printer.Util
   ( RenderDoc(..)
   , Prettier(..)
@@ -13,7 +13,6 @@
   , renderOpsList
   , renderOpsListNoBraces
   , renderAnyBuildable
-  , spaces
   , wrapInParens
   , buildRenderDoc
   , buildRenderDocExtended
@@ -35,9 +34,9 @@
 import Data.Text.Lazy.Builder (Builder)
 import Fmt (Buildable, pretty)
 import Text.PrettyPrint.Leijen.Text
-  (Doc, SimpleDoc, align, braces, displayB, displayT, enclose, encloseSep, hcat, hsep, isEmpty,
-  lbracket, parens, punctuate, rbracket, renderOneLine, renderPretty, semi, sep, space, text, (<+>),
-  (<//>))
+  (Doc, SimpleDoc, align, braces, displayB, displayT, enclose, encloseSep, hsep, isEmpty, lbracket,
+  parens, punctuate, rbracket, renderOneLine, renderPretty, semi, sep, space, text, textStrict,
+  (<+>), (<//>))
 
 -- | Environment carried during recursive rendering.
 newtype RenderContext = RenderContext
@@ -64,6 +63,9 @@
   isRenderable :: a -> Bool
   isRenderable _ = True
 
+instance RenderDoc Text where
+  renderDoc _ = textStrict
+
 -- | Renders a list of 'RenderDoc' elements surrounded with square brackets,
 -- separated by a comma and a space.
 renderDocList :: RenderDoc a => RenderContext -> [a] -> Doc
@@ -105,10 +107,6 @@
 renderOpsListNoBraces oneLine =
   align . (if oneLine then hsep else sep) . punctuate semi .
     fmap (renderDoc doesntNeedParens) . filter isRenderable
-
--- | Create a specific number of spaces.
-spaces :: Int -> Doc
-spaces x = hcat $ replicate x space
 
 -- | Wrap documents in parentheses if there are two or more in the list.
 wrapInParens :: RenderContext -> NonEmpty Doc -> Doc
diff --git a/src/Morley/Michelson/Runtime.hs b/src/Morley/Michelson/Runtime.hs
--- a/src/Morley/Michelson/Runtime.hs
+++ b/src/Morley/Michelson/Runtime.hs
@@ -9,6 +9,11 @@
     originateContract
   , runContract
   , transfer
+  , runCode
+  , RunCodeParameters(..)
+  , runCodeParameters
+  , resolveRunCodeBigMaps
+  , mkBigMapFinder
 
   -- * Other helpers
   , parseContract
@@ -52,7 +57,7 @@
   , elUpdates
   ) where
 
-import Control.Lens (assign, at, makeLenses, (.=), (<>=))
+import Control.Lens (assign, at, each, ix, makeLenses, to, (.=), (<>=))
 import Control.Monad.Except (Except, liftEither, runExcept, throwError)
 import Data.Constraint (Dict(..), (\\))
 import Data.Default (def)
@@ -66,16 +71,17 @@
 import Text.Megaparsec (parse)
 
 import Morley.Michelson.Interpret
-  (ContractEnv(..), InterpretError(..), InterpretResult(..), InterpreterState(..), MorleyLogs(..),
+  (ContractEnv(..), InterpretError, InterpretResult(..), InterpreterState(..), MorleyLogs(..),
   RemainingSteps(..), assignBigMapIds, handleContractReturn, interpret)
 import Morley.Michelson.Macro (ParsedOp, expandContract)
 import Morley.Michelson.Parser qualified as P
 import Morley.Michelson.Runtime.Dummy
 import Morley.Michelson.Runtime.GState
+import Morley.Michelson.Runtime.RunCode
 import Morley.Michelson.Runtime.TxData
 import Morley.Michelson.TypeCheck
 import Morley.Michelson.Typed
-  (CreateContract(..), EntrypointCallT, EpName, Operation'(..), SomeConstrainedValue(..),
+  (Constrained(..), CreateContract(..), EntrypointCallT, EpName, Operation'(..),
   SomeContractAndStorage(..), SomeStorage, TransferTokens(..), untypeValue)
 import Morley.Michelson.Typed qualified as T
 import Morley.Michelson.Typed.Operation
@@ -87,6 +93,7 @@
 import Morley.Tezos.Core
   (Mutez, Timestamp(..), getCurrentTime, unsafeAddMutez, unsafeSubMutez, zeroMutez)
 import Morley.Tezos.Crypto (KeyHash, parseHash)
+import Morley.Util.Interpolate (itu)
 import Morley.Util.MismatchError
 import Morley.Util.Named
 
@@ -178,11 +185,17 @@
 data ExecutorError' a
   = EEUnknownContract a
   -- ^ The interpreted contract hasn't been originated.
-  | EEInterpreterFailed a
-                        InterpretError
+  | EEInterpreterFailed a (InterpretError Void)
   -- ^ Interpretation of Michelson contract failed.
   | EEUnknownAddressAlias SomeAlias
-  -- ^ Given alias doesn't refer to any address.
+  -- ^ The given alias isn't associated with any address
+  -- OR is associated with an address of an unexpected kind
+  -- (e.g. we expected an implicit address and found a contract address, or vice-versa).
+  | EEUnknownL1AddressAlias Text
+  -- ^ The given alias is not associated with any address.
+  | EEAmbiguousAlias Text ImplicitAddress ContractAddress
+  -- ^ The given alias is ambiguous, i.e. it is associated with __both__ an
+  -- implicit address and a contract address.
   | EEUnknownSender a
   -- ^ Sender address is unknown.
   | EEUnknownManager a
@@ -190,13 +203,13 @@
   | EENotEnoughFunds a Mutez
   -- ^ Sender doesn't have enough funds.
   | EEEmptyImplicitContract a
-  -- ^ Sender is an implicit address with the balance of 0. We mimic tezos-client in calling it
-  -- "Empty implicit contract".
+  -- ^ Sender is an implicit address with the balance of 0. We mimic
+  -- @octez-client@ in calling it "Empty implicit contract".
   | EEZeroTransaction a
   -- ^ Sending 0tz towards an address.
   | EEFailedToApplyUpdates GStateUpdateError
   -- ^ Failed to apply updates to GState.
-  | EEIllTypedParameter a TCError
+  | EEIllTypedParameter a TcError
   -- ^ Contract parameter is ill-typed.
   | EEUnexpectedParameterType a (MismatchError T.T)
   -- ^ Contract parameter is well-typed, but its type does
@@ -219,8 +232,18 @@
   build =
     \case
       EEUnknownAddressAlias (SomeAlias (alias :: Alias kind)) ->
-        ("The alias " +| alias |+ " doesn't have any associated " +| demote @kind |+ " addresses")
-        \\ aliasKindSanity alias
+        [itu|The alias '#{alias}' is not associated to a #{kind} address|]
+        where
+          kind = demote @kind \\ aliasKindSanity alias :: AddressKind
+      EEUnknownL1AddressAlias aliasText ->
+        [itu|The alias '#{aliasText}' is not associated with any address|]
+      EEAmbiguousAlias aliasText implicitAddr contractAddr ->
+        [itu|
+        The alias '#{aliasText}' is assigned to both:
+          * a contract address: #{contractAddr}
+          * and an implicit address: #{implicitAddr}
+        Use '#{contractPrefix}:#{aliasText}' or '#{implicitPrefix}:#{aliasText}' to disambiguate.
+        |]
       EEUnknownContract addr -> "The contract is not originated " +| addr |+ ""
       EEInterpreterFailed addr err ->
         "Michelson interpreter failed for contract " +| addr |+ ": " +| err |+ ""
@@ -375,6 +398,28 @@
         Nothing -> error $ pretty addr <> " is unknown"
         Just ContractState{..} -> return $ SomeStorage csStorage
 
+-- | Construct 'BigMapFinder' using the current executor context.
+mkBigMapFinder :: ExecutorM BigMapFinder
+mkBigMapFinder = do
+  pureState <- get
+
+  pure \bigMapId ->
+    pureState ^?
+      esGState . gsContractAddressesL . each . to getContractStorage .
+        to (getBigMapsWithId bigMapId) . each
+  where
+    getContractStorage :: ContractState -> T.SomeValue
+    getContractStorage (ContractState _ _ storage _) = T.SomeValue storage
+
+    getBigMapsWithId :: Natural -> T.SomeValue -> [T.SomeVBigMap]
+    getBigMapsWithId bigMapId (T.SomeValue val) =
+      T.dfsFoldMapValue
+        (\v -> case v of
+            T.VBigMap (Just bigMapId') _ | bigMapId' == bigMapId -> [T.SomeVBigMap v]
+            _ -> []
+        )
+        val
+
 -- | Send a transaction to given address with given parameters.
 transfer
   :: Maybe Timestamp
@@ -383,14 +428,14 @@
   -> Word64
   -> FilePath
   -> TypeCheckOptions
-  -> AddressOrAlias kind
+  -> SomeAddressOrAlias
   -> TxData
   -> "verbose" :! Bool
   -> "dryRun" :? Bool
   -> IO ()
 transfer maybeNow maybeLevel maybeMinBlockTime maxSteps dbPath tcOpts destination txData verbose dryRun = do
   void $ runExecutorMWithDB maybeNow maybeLevel maybeMinBlockTime dbPath (RemainingSteps maxSteps) verbose dryRun $ do
-    destAddr <- MkAddress <$> resolveAddress destination
+    destAddr <- resolveAddress destination
     executeGlobalOperations tcOpts [TransferOp $ TransferOperation destAddr txData 0]
 
 ----------------------------------------------------------------------------
@@ -496,19 +541,30 @@
         mapM_ putTextLn logs
       putTextLn "" -- extra break line to separate logs from two sequence contracts
 
--- | Resolves 'AddressOrAlias' type to 'KindedAddress' of the appropriate kind.
+-- | Resolves 'SomeAddressOrAlias' type to an address.
 resolveAddress
-  :: forall kind. AddressOrAlias kind
-  -> ExecutorM (KindedAddress kind)
-resolveAddress (AddressResolved addr) = pure addr
-resolveAddress (AddressAlias alias) = do
-  let s :: SingAddressKind kind = T.sing @kind \\ aliasKindSanity alias
-  addrMb <- use $ case s of
-    SAddressKindImplicit -> esGState . gsImplicitAddressAliasesL . at alias
-    SAddressKindContract -> esGState . gsContractAddressAliasesL . at alias
-  case addrMb of
-    Just addr -> pure addr
-    Nothing -> throwError $ EEUnknownAddressAlias $ SomeAlias alias
+  :: SomeAddressOrAlias
+  -- TODO [#905] or [#889]: Change the return type to `L1Address`
+  -> ExecutorM Address
+resolveAddress = \case
+  SAOAKindUnspecified aliasText -> do
+    implicitAddrMb <- preuse $ esGState . gsImplicitAddressAliasesL . ix (ImplicitAlias aliasText)
+    contractAddrMb <- preuse $ esGState . gsContractAddressAliasesL . ix (ContractAlias aliasText)
+    case (implicitAddrMb, contractAddrMb) of
+      (Nothing, Nothing) -> throwError $ EEUnknownL1AddressAlias aliasText
+      (Just implicitAddr, Nothing) -> pure $ Constrained implicitAddr
+      (Nothing, Just contractAddr) -> pure $ Constrained contractAddr
+      (Just implicitAddr, Just contractAddr) -> throwError $ EEAmbiguousAlias aliasText implicitAddr contractAddr
+  SAOAKindSpecified (AddressResolved (addr@ContractAddress{})) -> pure $ Constrained addr
+  SAOAKindSpecified (AddressResolved (addr@ImplicitAddress{})) -> pure $ Constrained addr
+  SAOAKindSpecified (AddressAlias alias) -> do
+    addrMb <- preuse $
+      case alias of
+        ImplicitAlias{} -> esGState . gsImplicitAddressAliasesL . ix alias . to Constrained
+        ContractAlias{} -> esGState . gsContractAddressAliasesL . ix alias . to Constrained
+    case addrMb of
+      Just addr -> pure addr
+      Nothing -> throwError $ EEUnknownAddressAlias $ SomeAlias alias
 
 -- | Execute a list of global operations, returning a list of generated events.
 executeGlobalOperations
@@ -517,7 +573,7 @@
   -> ExecutorM [EmitOperation]
 executeGlobalOperations tcOpts = concatMapM $ \op -> executeMany (#isGlobalOp :! True) [op]
   where
-    -- | Execute a list of operations and additional operations they return, until there are none.
+    -- Execute a list of operations and additional operations they return, until there are none.
     executeMany :: "isGlobalOp" :! Bool -> [ExecutorOp] -> ExecutorM [EmitOperation]
     executeMany isGlobalOp = \case
         [] -> pure []
@@ -530,7 +586,7 @@
               executeDelegation isGlobalOp operation
               executeMany (#isGlobalOp :! False) opsTail
             TransferOp transferOperation -> do
-              moreOps <- executeTransfer isGlobalOp Nothing tcOpts transferOperation
+              moreOps <- executeTransfer isGlobalOp tcOpts transferOperation
               executeMany (#isGlobalOp :! False) $ moreOps <> opsTail
             EmitOp emitOperation -> do
               liftM2 (:) (executeEmit isGlobalOp emitOperation) $
@@ -608,7 +664,9 @@
 
   gs <- use esGState
 
-  let updates = [GSSetDelegate sdoContract sdoDelegate]
+  Constrained address <- pure sdoContract
+
+  let updates = [GSSetDelegate address sdoDelegate]
   case applyUpdates updates gs of
     Left err -> throwError $ EEFailedToApplyUpdates err
     Right newGS -> do
@@ -630,20 +688,13 @@
 -- | Execute a transfer operation.
 executeTransfer
   :: "isGlobalOp" :! Bool
-  -> Maybe Mutez
-  -- ^ Whether to override the destination's balance.
-  --
-  -- When it's a `Just`, the destination's balance will be set to the given amount
-  -- and no tz will be debited from the sender's account.
-  -- This is useful to emulate the behaviour of the Tezos RPC's @/run_code@ endpoint.
   -> TypeCheckOptions
   -> TransferOperation
   -> ExecutorM [ExecutorOp]
-executeTransfer (arg #isGlobalOp -> isGlobalOp)
-  overrideBalanceMb tcOpts
+executeTransfer (arg #isGlobalOp -> isGlobalOp) tcOpts
     transferOperation@(
       TransferOperation (MkAddress (addr :: KindedAddress kind))
-        txData@TxData{tdSenderAddress=MkConstrainedAddress senderAddr,..} _) = do
+        txData@TxData{tdSenderAddress=Constrained senderAddr,..} _) = do
     when isGlobalOp $
       beginGlobalOperation
 
@@ -673,12 +724,11 @@
           throwError $ EETransactionFromContract (MkAddress senderAddr) tdAmount
 
       Just Refl -> do
-        when (isNothing overrideBalanceMb) $
-          case senderBalance of
-            Nothing -> throwError $ EEEmptyImplicitContract $ MkAddress senderAddr
-            Just balance | balance == zeroMutez ->
-              throwError $ EEEmptyImplicitContract $ MkAddress senderAddr
-            _ -> pass
+        case senderBalance of
+          Nothing -> throwError $ EEEmptyImplicitContract $ MkAddress senderAddr
+          Just balance | balance == zeroMutez ->
+            throwError $ EEEmptyImplicitContract $ MkAddress senderAddr
+          _ -> pass
 
     case isImplicitAddress addr of
       Nothing -> pass
@@ -690,19 +740,17 @@
         when (isZeroTransfer) $
           throwError $ EEZeroTransaction $ MkAddress addr
 
-    mDecreaseSenderBalance <-
-      if isNothing overrideBalanceMb && not isZeroTransfer
-        then case senderBalance of
-          Nothing -> throwError $ EEUnknownSender $ MkAddress senderAddr
-          Just balance
-            | balance < tdAmount ->
-              throwError $ EENotEnoughFunds (MkAddress senderAddr) balance
-            | otherwise -> do
-              -- Subtraction is safe because we have checked its
-              -- precondition in guard.
-              let newBal = balance `unsafeSubMutez` tdAmount
-              pure $ Just $ GSSetBalance senderAddr newBal
-        else pure Nothing
+    mDecreaseSenderBalance <- case senderBalance of
+      _ | isZeroTransfer -> pure Nothing
+      Nothing -> throwError $ EEUnknownSender $ MkAddress senderAddr
+      Just balance
+        | balance < tdAmount ->
+          throwError $ EENotEnoughFunds (MkAddress senderAddr) balance
+        | otherwise -> do
+          -- Subtraction is safe because we have checked its
+          -- precondition in guard.
+          let newBal = balance `unsafeSubMutez` tdAmount
+          pure $ Just $ GSSetBalance senderAddr newBal
 
     let commonFinishup
           :: Dict (L1AddressKind kind)
@@ -743,15 +791,13 @@
             upd = GSAddImplicitAddress addr addrState
 
           onlyUpdates Dict [upd]
-        Just oldBalance -> do
+        Just ImplicitState{..} -> do
           let
-            -- Calculate the account's new balance, unless `overrideBalanceMb` is used.
-            -- Note: `unsafeAddMutez` can't overflow if global state is correct (because we can't
-            -- create money out of nowhere)
-            newBalance =
-              fromMaybe
-                (oldBalance `unsafeAddMutez` tdAmount)
-                overrideBalanceMb
+            -- Calculate the account's new balance.
+            --
+            -- Note: `unsafeAddMutez` can't overflow if global state is correct
+            -- (because we can't create money out of nowhere)
+            newBalance = isBalance `unsafeAddMutez` tdAmount
             upd = GSSetBalance addr newBalance
           onlyUpdates Dict [upd]
       ContractAddress{} -> case addresses ^. at addr of
@@ -759,13 +805,11 @@
         Just ContractState{..} -> do
           let
             existingContracts = extractAllContracts gs
-            newBalance =
-              -- Calculate the contract's new balance, unless `overrideBalanceMb` is used.
-              -- Note: `unsafeAddMutez` can't overflow if global state is correct (because we can't
-              -- create money out of nowhere)
-              fromMaybe
-                (csBalance `unsafeAddMutez` tdAmount)
-                overrideBalanceMb
+            -- Calculate the contract's new balance.
+            --
+            -- Note: `unsafeAddMutez` can't overflow if global state is
+            -- correct (because we can't create money out of nowhere)
+            newBalance = csBalance `unsafeAddMutez` tdAmount
             epName = tdEntrypoint
 
           T.MkEntrypointCallRes _ (epc :: EntrypointCallT cp epArg)
@@ -812,7 +856,7 @@
               , ceContracts = gsContractAddresses gs
               , ceSelf = addr
               , ceSource = sourceAddr
-              , ceSender = MkConstrainedAddress senderAddr
+              , ceSender = Constrained senderAddr
               , ceAmount = tdAmount
               , ceVotingPowers = gsVotingPowers gs
               , ceChainId = gsChainId gs
@@ -859,7 +903,6 @@
               ]
           commonFinishup Dict updates sideEffects (Just iur) newRemainingSteps
 
-
 ----------------------------------------------------------------------------
 -- Simple helpers
 ----------------------------------------------------------------------------
@@ -886,7 +929,7 @@
         T.VContract destAddress sepc ->
           let txData =
                 TxData
-                  { tdSenderAddress = MkConstrainedAddress interpretedAddr
+                  { tdSenderAddress = Constrained interpretedAddr
                   , tdEntrypoint = T.sepcName sepc
                   , tdParameter = TxTypedParam (ttTransferArgument tt)
                   , tdAmount = ttAmount tt
@@ -898,14 +941,12 @@
                   , toCounter = ttCounter tt
                   }
           in TransferOp transferOperation
-    OpSetDelegate T.SetDelegate{..} -> case interpretedAddr of
-      addr@ContractAddress{} -> pure $ SetDelegateOp SetDelegateOperation
-        { sdoContract = addr
-        , sdoDelegate = sdMbKeyHash
-        , sdoCounter = sdCounter
-        }
-      _ -> throwError $ EEUnknownContract $ MkAddress interpretedAddr
-    OpCreateContract CreateContract{ccOriginator=MkConstrainedAddress ccOriginator, ..} ->
+    OpSetDelegate T.SetDelegate{..} -> pure $ SetDelegateOp SetDelegateOperation
+      { sdoContract = Constrained interpretedAddr
+      , sdoDelegate = sdMbKeyHash
+      , sdoCounter = sdCounter
+      }
+    OpCreateContract CreateContract{ccOriginator=Constrained ccOriginator, ..} ->
       pure $ OriginateOp OriginationOperation
         { ooOriginator = ccOriginator
         , ooDelegate = ccDelegate
diff --git a/src/Morley/Michelson/Runtime/Dummy.hs b/src/Morley/Michelson/Runtime/Dummy.hs
--- a/src/Morley/Michelson/Runtime/Dummy.hs
+++ b/src/Morley/Michelson/Runtime/Dummy.hs
@@ -14,12 +14,14 @@
   , dummyOrigination
   , dummyMinBlockTime
   , dummySelf
+  , dummyContractState
   ) where
 
 import Data.Default (def)
 
 import Morley.Michelson.Interpret (ContractEnv(..), RemainingSteps)
-import Morley.Michelson.Runtime.GState (BigMapCounter, dummyVotingPowers, genesisAddress)
+import Morley.Michelson.Runtime.GState
+  (BigMapCounter, ContractState(..), dummyVotingPowers, genesisAddress)
 import Morley.Michelson.Typed (ParameterScope, StorageScope)
 import Morley.Michelson.Typed qualified as T
 import Morley.Michelson.Typed.Operation (OriginationOperation(..))
@@ -64,8 +66,8 @@
   , ceBalance = [tz|100u|]
   , ceContracts = mempty
   , ceSelf = dummySelf
-  , ceSource = MkConstrainedAddress genesisAddress
-  , ceSender = MkConstrainedAddress genesisAddress
+  , ceSource = Constrained genesisAddress
+  , ceSender = Constrained genesisAddress
   , ceAmount = [tz|100u|]
   , ceVotingPowers = dummyVotingPowers
   , ceChainId = dummyChainId
@@ -92,4 +94,21 @@
   , ooContract = contract
   , ooCounter = counter
   , ooAlias = Nothing
+  }
+
+-- | Construct dummy 'ContractState' for the given parameter type. This can be
+-- useful with @runCode@. The state constructed doesn't have any views, and uses
+-- @unit@ for storage.
+dummyContractState :: T.ParameterScope t => T.ParamNotes t -> ContractState
+dummyContractState notes = ContractState
+  { csContract = T.Contract
+      { cCode = T.mkContractCode $ T.CDR T.:# T.NIL T.:# T.PAIR
+      , cParamNotes = notes
+      , cStoreNotes = T.starNotes
+      , cEntriesOrder = def
+      , cViews = def
+      }
+  , csDelegate = Nothing
+  , csBalance = [tz|100u|]
+  , csStorage = T.VUnit
   }
diff --git a/src/Morley/Michelson/Runtime/GState.hs b/src/Morley/Michelson/Runtime/GState.hs
--- a/src/Morley/Michelson/Runtime/GState.hs
+++ b/src/Morley/Michelson/Runtime/GState.hs
@@ -8,6 +8,9 @@
     -- * Auxiliary types
     ContractState (..)
   , VotingPowers (..)
+  , ImplicitState (..)
+  , isBalanceL
+  , isDelegateL
   , vpPick
   , vpTotal
   , mkVotingPowers
@@ -63,11 +66,12 @@
 import Data.Default (def)
 import Data.Map.Strict qualified as Map
 import Data.Type.Equality ((:~:)(..))
-import Fmt (Buildable(build), pretty, (+|), (|+))
+import Fmt (Buildable(build), nameF, pretty, unlinesF, (+|), (|+))
 import System.IO.Error (IOError, isDoesNotExistError)
 
 import Morley.Michelson.TypeCheck
-  (SomeParamType(..), TcOriginatedContracts, typeCheckContractAndStorage, typeCheckingWith)
+  (SomeParamType(..), TcOriginatedContracts, tcStrict, typeCheckContractAndStorage,
+  typeCheckingWith)
 import Morley.Michelson.Typed qualified as T
 import Morley.Michelson.Typed.Existential (SomeContractAndStorage(..))
 import Morley.Michelson.Typed.Scope
@@ -86,6 +90,25 @@
 import Morley.Util.SizedList qualified as SL
 import Morley.Util.SizedList.Types
 
+data ImplicitState = ImplicitState
+  { isBalance :: Mutez
+    -- ^ Implicit address balance.
+  , isDelegate :: Maybe KeyHash
+    -- ^ Delegate, if set. Implicit address can have a delegate set to itself,
+    -- then it's considered "registered delegate" and can be set as delegate for
+    -- other addresses. It's impossible to "unregister" a delegate, so once
+    -- delegate is set to the address itself, it can't be changed.
+  } deriving stock (Show, Eq)
+
+deriveJSON morleyAesonOptions ''ImplicitState
+makeLensesWith postfixLFields ''ImplicitState
+
+instance Buildable ImplicitState where
+  build ImplicitState{..} = nameF "Implicit state" $ unlinesF
+    [ nameF "Balance" $ build isBalance
+    , nameF "Delegate" $ build isDelegate
+    ]
+
 -- | State of a contract with code.
 data ContractState =
   forall cp st. (ParameterScope cp, StorageScope st) => ContractState
@@ -129,7 +152,7 @@
       (uStorage :: Value) <- o .: "storage"
       (uContract :: Contract) <- o .: "contract"
       (delegate :: Maybe KeyHash) <- o .:? "delegate"
-      case typeCheckingWith def $ typeCheckContractAndStorage uContract uStorage of
+      case typeCheckingWith def{ tcStrict=False } $ typeCheckContractAndStorage uContract uStorage of
         Right (SomeContractAndStorage contract storage) ->
           pure $ ContractState balance contract storage delegate
         Left err -> fail $ "Unable to parse `ContractState`: " <> pretty err
@@ -188,7 +211,7 @@
 data GState = GState
   { gsChainId :: ChainId
   -- ^ Identifier of chain.
-  , gsImplicitAddresses :: Map ImplicitAddress Mutez
+  , gsImplicitAddresses :: Map ImplicitAddress ImplicitState
   -- ^ All known implicit addresses and their state (i.e. balance)
   , gsContractAddresses :: Map ContractAddress ContractState
   -- ^ All known contract addresses and their state.
@@ -261,7 +284,7 @@
   => ImplicitAddress
 genesisAddressN = SL.index @n genesisAddresses
 
--- | Dummy 'VotingPowers'. We give all the voting power to two genesis addreses
+-- | Dummy 'VotingPowers'. We give all the voting power to two genesis addresses
 -- as the addresses holding lot of money. Only two addresses are involved for
 -- simplicity.
 dummyVotingPowers :: VotingPowers
@@ -275,7 +298,7 @@
   GState
   { gsChainId = dummyChainId
   , gsImplicitAddresses = Map.fromList
-    [ (genesis, money)
+    [ (genesis, ImplicitState money Nothing)
     | let (money, _) = maxBound @Mutez `divModMutezInt` genesisAddressesNum
                     ?: error "Number of genesis addresses is 0"
     , genesis <- toList genesisAddresses
@@ -329,7 +352,7 @@
   GSIncrementCounter :: GStateUpdate
   GSUpdateCounter :: GlobalCounter -> GStateUpdate
   GSSetBigMapCounter :: BigMapCounter -> GStateUpdate
-  GSSetDelegate :: ContractAddress -> Maybe KeyHash -> GStateUpdate
+  GSSetDelegate :: L1AddressKind kind => KindedAddress kind -> Maybe KeyHash -> GStateUpdate
 
 deriving stock instance Show GStateUpdate
 
@@ -354,25 +377,32 @@
       GSSetBigMapCounter inc ->
         "Increment internal big_map counter by: " +| build inc
       GSSetDelegate addr key ->
-        "Set delegate for contract " +| addr |+ " to " +| maybe "<nobody>" build key
+        "Set delegate for " +| addr |+ " to " +| maybe "<nobody>" build key
 
 data GStateUpdateError
   = GStateAddressExists Address
   | GStateUnknownAddress Address
   | GStateStorageNotMatch ContractAddress
   | GStateTxRollup TxRollupAddress GStateUpdate
+  | GStateNotDelegate ImplicitAddress
+  | GStateCantDeleteDelegate ImplicitAddress
+  | GStateAlreadySetDelegate L1Address (Maybe KeyHash)
   deriving stock (Show)
 
 instance Buildable GStateUpdateError where
-  build =
-    \case
-      GStateAddressExists addr -> "Address already exists: " <> build addr
-      GStateUnknownAddress addr -> "Unknown address: " <> build addr
-      GStateStorageNotMatch addr ->
-        "Storage type does not match the contract in run-time state\
-        \ when updating new storage value to address: " <> build addr
-      GStateTxRollup addr op ->
-        "Transaction rollup address " +| addr |+ " doesn't support this operation: " +| op |+ ""
+  build = \case
+    GStateAddressExists addr -> "Address already exists: " <> build addr
+    GStateUnknownAddress addr -> "Unknown address: " <> build addr
+    GStateStorageNotMatch addr ->
+      "Storage type does not match the contract in run-time state\
+      \ when updating new storage value to address: " <> build addr
+    GStateTxRollup addr op ->
+      "Transaction rollup address " +| addr |+ " doesn't support this operation: " +| op |+ ""
+    GStateNotDelegate addr -> "Address " +| addr |+ " is not registered as delegate."
+    GStateCantDeleteDelegate addr ->
+      "Delegate deletion is forbidden for " +| addr |+ ""
+    GStateAlreadySetDelegate addr kh ->
+      "Already set delegate for " +| addr |+ " to " <> maybe "<nothing>" build kh
 
 -- | Apply 'GStateUpdate' to 'GState'.
 applyUpdate :: GStateUpdate -> GState -> Either GStateUpdateError GState
@@ -397,7 +427,7 @@
 addImplicitAddress :: ImplicitAddress -> Mutez -> GState -> Either GStateUpdateError GState
 addImplicitAddress addr st gs
   | addr `Map.member` (gsImplicitAddresses gs) = Left $ GStateAddressExists (MkAddress addr)
-  | otherwise = Right $ gs & gsImplicitAddressesL . at addr ?~ st
+  | otherwise = Right $ gs & gsImplicitAddressesL . at addr ?~ ImplicitState st Nothing
 
 -- | Add an address if it hasn't been added before.
 addContractAddress :: ContractAddress -> ContractState -> GState -> Either GStateUpdateError GState
@@ -438,16 +468,46 @@
   => KindedAddress kind
   -> Lens' (AddressStateFam kind) Mutez
 balanceLens = \case
-  ImplicitAddress{} -> id
+  ImplicitAddress{} -> isBalanceL
   ContractAddress{} -> csBalanceL
   where _ = usingImplicitOrContractKind @kind ()
 
+-- | Check if address delegate is set to itself, i.e. it's "registered delegate"
+-- in network terms. "Registered delegates" can't change their delegate. On the
+-- other hand, those can be set as delegates for other addresses.
+isRegisteredDelegate :: ImplicitAddress -> GState -> Bool
+isRegisteredDelegate addr@(ImplicitAddress kh) gs =
+  gs ^? gsImplicitAddressesL . at addr . traverse . isDelegateL == Just (Just kh)
+
 -- | Set delegate for a given address
-setDelegate :: ContractAddress -> Maybe KeyHash -> GState -> Either GStateUpdateError GState
-setDelegate addr key = updateAddressState addr $ pure . (csDelegateL .~ key)
+setDelegate
+  :: forall kind. L1AddressKind kind
+  => KindedAddress kind -> Maybe KeyHash -> GState -> Either GStateUpdateError GState
+setDelegate addr newDelegate gs
+  | Just oldDelegate@Just{} <- gs ^? addressesL addr . at addr . traverse . delegateLens
+  , oldDelegate == newDelegate
+  -- network fails when new delegate == old delegate == Just kh, so we do likewise
+  -- note it _doesn't_ fail when new == old == Nothing
+  = Left $ GStateAlreadySetDelegate (Constrained addr) newDelegate
+  | ImplicitAddress{} <- addr
+  , isRegisteredDelegate addr gs
+  -- implicit addresses that are registered delegates can't change delegates
+  = Left $ GStateCantDeleteDelegate addr
+  | Just kh <- newDelegate
+  , let keyAddr = ImplicitAddress kh
+  , not $ isRegisteredDelegate keyAddr gs
+  -- can't set delegate to an address not registered as delegate
+  , MkAddress keyAddr /= MkAddress addr -- but implicit contract can set delegate to itself
+  = Left $ GStateNotDelegate keyAddr
+  | otherwise = updateAddressState addr (pure . (delegateLens .~ newDelegate)) gs
+  where
+    delegateLens :: Lens' (AddressStateFam kind) (Maybe KeyHash)
+    delegateLens = case addr of
+      ContractAddress{} -> csDelegateL
+      ImplicitAddress{} -> isDelegateL
 
 type family AddressStateFam kind where
-  AddressStateFam 'AddressKindImplicit = Mutez
+  AddressStateFam 'AddressKindImplicit = ImplicitState
   AddressStateFam 'AddressKindContract = ContractState
   -- TODO [#838]: support transaction rollups on the emulator
   AddressStateFam 'AddressKindTxRollup = ()
diff --git a/src/Morley/Michelson/Runtime/Import.hs b/src/Morley/Michelson/Runtime/Import.hs
--- a/src/Morley/Michelson/Runtime/Import.hs
+++ b/src/Morley/Michelson/Runtime/Import.hs
@@ -33,7 +33,7 @@
 import Morley.Michelson.Parser.Types (MichelsonSource(..))
 import Morley.Michelson.Runtime (parseExpandContract)
 import Morley.Michelson.TypeCheck
-  (TCError, typeCheckContract, typeCheckTopLevelType, typeCheckingWith, typeVerifyContract,
+  (TcError, typeCheckContract, typeCheckTopLevelType, typeCheckingWith, typeVerifyContract,
   typeVerifyTopLevelType)
 import Morley.Michelson.Typed (Contract, SingI, SomeContract(..), SomeValue, Value)
 import Morley.Michelson.Untyped qualified as U
@@ -112,7 +112,7 @@
 -- | Error type for 'importContract' function.
 data ContractReadError
   = CREParse MichelsonSource ParserException
-  | CRETypeCheck MichelsonSource TCError
+  | CRETypeCheck MichelsonSource TcError
   deriving stock (Show, Eq)
 
 instance Buildable ContractReadError where
@@ -189,7 +189,7 @@
 -- | Error type for 'importValue' function.
 data ValueReadError
   = VREParse MichelsonSource ParserException
-  | VRETypeCheck MichelsonSource TCError
+  | VRETypeCheck MichelsonSource TcError
   deriving stock (Show, Eq)
 
 instance Buildable ValueReadError where
diff --git a/src/Morley/Michelson/Runtime/RunCode.hs b/src/Morley/Michelson/Runtime/RunCode.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/Michelson/Runtime/RunCode.hs
@@ -0,0 +1,164 @@
+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha
+-- SPDX-License-Identifier: LicenseRef-MIT-OA
+
+-- | Emulation of @run_code@.
+
+module Morley.Michelson.Runtime.RunCode
+  ( runCode
+  , RunCodeParameters(..)
+  , runCodeParameters
+  , resolveRunCodeBigMaps
+  ) where
+
+import Data.Default (def)
+import Data.Map qualified as Map
+
+import Morley.Michelson.Interpret (ContractEnv(..), InterpretError(..), assignBigMapIds, interpret)
+import Morley.Michelson.Runtime.Dummy
+import Morley.Michelson.Runtime.GState
+import Morley.Michelson.TypeCheck
+import Morley.Michelson.Typed qualified as T
+import Morley.Michelson.Typed.Operation
+import Morley.Michelson.Untyped qualified as U
+import Morley.Tezos.Address
+import Morley.Tezos.Core (ChainId, Mutez, Timestamp(..), dummyChainId, zeroMutez)
+import Morley.Tezos.Crypto (KeyHash)
+
+----------------------------------------------------------------------------
+-- Auxiliary types
+----------------------------------------------------------------------------
+
+-- | Data required for calling 'runCode'.
+type RunCodeParameters :: T.T -> T.T -> T.T -> Type
+data RunCodeParameters cp epArg st = RunCodeParameters
+  { rcScript :: T.Contract cp st
+    -- ^ Contract code to run
+  , rcStorage :: T.Value st
+    -- ^ Initial contract storage
+  , rcInput :: T.Value epArg
+    -- ^ Parameter to call the contract
+  , rcEntryPoint :: T.EntrypointCallT cp epArg
+    -- ^ Entrypoint to call. Use 'T.mkEntrypointCall' to construct.
+  , rcAmount :: Mutez
+    -- ^ Transfer amount
+  , rcBalance :: Mutez
+    -- ^ Contract initial balance
+  , rcChainId :: ChainId
+    -- ^ Chain id
+  , rcNow :: Timestamp
+    -- ^ The result of @NOW@ instruction
+  , rcLevel :: Natural
+    -- ^ The result of @LEVEL@ instruction
+  , rcMinBlockTime :: Natural
+    -- ^ The result of @MIN_BLOCK_TIME@ instruction
+  , rcSource :: L1Address
+    -- ^ Transfer source
+  , rcSender :: L1Address
+    -- ^ Transfer sender
+  , rcKnownContracts :: Map ContractAddress ContractState
+    -- ^ Known contracts and their state. If you only know parameter types and
+    -- don't need to run contract's views, you can use 'dummyContractState' to
+    -- construct the state.
+  , rcSelf :: Maybe ContractAddress
+    -- ^ Address returned by the @SELF@ instruction, will be auto-generated if
+    -- 'Nothing'
+  , rcDelegate :: Maybe KeyHash
+    -- ^ Contract's delegate
+  , rcVotingPowers :: VotingPowers
+    -- ^ Voting powers
+  }
+
+-- | Construct 'RunCodeParameters' with some reasonable defaults.
+--
+-- Prepare untyped storage and parameter with 'resolveRunCodeBigMaps'.
+--
+-- Use 'T.mkEntrypointCall' or 'T.mkDefEntrypointCall' to construct the entrypoint
+-- call specification.
+runCodeParameters
+  :: T.Contract cp st -- ^ Contract to run
+  -> T.Value st -- ^ Contract storage
+  -> T.EntrypointCallT cp epArg -- ^ Entrypoint call specification
+  -> T.Value epArg -- ^ Entrypoint argument
+  -> RunCodeParameters cp epArg st
+runCodeParameters rcScript rcStorage rcEntryPoint rcInput = RunCodeParameters
+  { rcAmount = zeroMutez
+  , rcBalance = zeroMutez
+  , rcChainId = dummyChainId
+  , rcNow = dummyNow
+  , rcLevel = dummyLevel
+  , rcMinBlockTime = dummyMinBlockTime
+  , rcSource = Constrained genesisAddress
+  , rcSender = Constrained genesisAddress
+  , rcKnownContracts = mempty
+  , rcSelf = Nothing
+  , rcDelegate = Nothing
+  , rcVotingPowers = dummyVotingPowers
+  , ..
+  }
+
+-- | Emulate @run_code@ RPC endpoint to an extent. Unlike @runContract@, runs
+-- the contract through the emulator directly, without doing any operations.
+-- This includes not doing the origination operation, and not applying the
+-- operations produced by the transfer.
+runCode
+  :: RunCodeParameters cp epArg st
+  -> Either (InterpretError Void) ([T.Operation], T.Value st)
+runCode (RunCodeParameters
+  -- NB: explicit match to ensure all fields are consumed; ugly, but there are no real alternatives
+  rcScript@T.Contract{}
+  rcStorage
+  rcInput
+  rcEntryPoint
+  rcAmount
+  rcBalance
+  rcChainId
+  rcNow
+  rcLevel
+  rcMinBlockTime
+  rcSource
+  rcSender
+  rcKnownContracts
+  rcSelf
+  rcDelegate
+  rcVotingPowers
+  ) = toInterpreterRes $
+    interpret rcScript rcEntryPoint input storage dummyGlobalCounter bigMapCtr contractEnv
+  where
+    selfState = ContractState
+      { csBalance = rcBalance
+      , csContract = rcScript
+      , csStorage = rcStorage
+      , csDelegate = rcDelegate
+      }
+    dummyOriginationHash = mkOriginationOperationHash $
+      dummyOrigination rcStorage rcScript dummyGlobalCounter
+    self = fromMaybe
+      (mkContractAddress dummyOriginationHash dummyGlobalCounter)
+      rcSelf
+    ((input, storage), bigMapCtr) = usingState dummyBigMapCounter $
+      (,) <$> assignBigMapIds False rcInput <*> assignBigMapIds False rcStorage
+    toInterpreterRes (eith, (_, logs)) = first (InterpretError . (, logs)) eith
+    contractEnv = ContractEnv
+      { ceNow = rcNow
+      , ceBalance = rcBalance
+      , ceSelf = self
+      , ceAmount = rcAmount
+      , ceMinBlockTime = rcMinBlockTime
+      , ceContracts = Map.insert self selfState rcKnownContracts
+      , ceMaxSteps = dummyMaxSteps
+      , ceSource = rcSource
+      , ceSender = rcSender
+      , ceChainId = rcChainId
+      , ceOperationHash = Nothing
+      , ceLevel = rcLevel
+      , ceErrorSrcPos = def
+      , ceVotingPowers = rcVotingPowers
+      }
+
+-- | Given an untyped value, possibly containing @big_map@ ids, typecheck it,
+-- resolving ids to the corresponding @big_map@s.
+--
+-- 'BigMapFinder' can be constructed using 'Morley.Michelson.Runtime.mkBigMapFinder'.
+resolveRunCodeBigMaps
+  :: T.SingI t => BigMapFinder -> U.Value -> Either TcError (T.Value t)
+resolveRunCodeBigMaps = typeCheckingWith def{tcStrict=False} ... typeCheckValueRunCodeCompat
diff --git a/src/Morley/Michelson/Text.hs b/src/Morley/Michelson/Text.hs
--- a/src/Morley/Michelson/Text.hs
+++ b/src/Morley/Michelson/Text.hs
@@ -8,7 +8,7 @@
 --
 -- When writting a Michelson contract, you can only mention characters with
 -- codes from @[32 .. 126]@ range in string literals. Same restriction applies
--- to string literals passed to @tezos-client@.
+-- to string literals passed to @octez-client@.
 --
 -- However, Michelson allows some control sequences: @"\n"@. You have to write
 -- it exactly in this form, and internally it will be transformed to line feed
@@ -42,6 +42,7 @@
 import Fmt (Buildable)
 import Language.Haskell.TH qualified as TH
 import Language.Haskell.TH.Quote qualified as TH
+import Type.Errors (DelayError)
 
 import Morley.Util.CLI
 import Morley.Util.Label (Label(..), labelToText)
@@ -174,11 +175,10 @@
     [] -> Right []
 
 -- | A type error asking to use 'MText' instead of t'Text'.
-type family DoNotUseTextError where
-  DoNotUseTextError = TypeError
-    ( 'Text "`Text` is not isomorphic to Michelson strings," ':$$:
-      'Text "consider using `MText` type instead"
-    )
+type DoNotUseTextError = DelayError
+  ( 'Text "`Text` is not isomorphic to Michelson strings," ':$$:
+    'Text "consider using `MText` type instead"
+  )
 
 -- | Create a 'MText' from type-level string.
 --
diff --git a/src/Morley/Michelson/TypeCheck.hs b/src/Morley/Michelson/TypeCheck.hs
--- a/src/Morley/Michelson/TypeCheck.hs
+++ b/src/Morley/Michelson/TypeCheck.hs
@@ -13,6 +13,7 @@
   , typeCheckTopLevelType
   , typeCheckValue
   , typeCheckValueRunCodeCompat
+  , typeCheckExpandedOp
   , typeVerifyContract
   , typeVerifyParameter
   , typeVerifyStorage
diff --git a/src/Morley/Michelson/TypeCheck/Error.hs b/src/Morley/Michelson/TypeCheck/Error.hs
--- a/src/Morley/Michelson/TypeCheck/Error.hs
+++ b/src/Morley/Michelson/TypeCheck/Error.hs
@@ -6,8 +6,9 @@
 module Morley.Michelson.TypeCheck.Error
   ( TypeContext (..)
   , TopLevelType (..)
-  , TCTypeError (..)
-  , TCError (..)
+  , TcTypeError (..)
+  , TcError
+  , TcError' (..)
   , ExtError (..)
   , StackSize (..)
   , pairWithNodeIndex
@@ -35,7 +36,7 @@
 -- | Contexts where type error can occur.
 data TypeContext
   = LambdaArgument
-  | LambdaCode
+  | LambdaCodeCtx
   | DipCode
   | ConsArgument
   | ComparisonArguments
@@ -61,7 +62,7 @@
 instance RenderDoc TypeContext where
   renderDoc _ = \case
     LambdaArgument -> "argument to some lambda"
-    LambdaCode -> "code in LAMBDA"
+    LambdaCodeCtx -> "code in LAMBDA"
     DipCode -> "code in DIP"
     ConsArgument -> "argument to CONS"
     ComparisonArguments -> "arguments to comparison function"
@@ -102,8 +103,8 @@
 -- | Data type that represents various errors
 -- which are related to type system.
 -- These errors are used to specify info about type check errors
--- in @TCError@ data type.
-data TCTypeError
+-- in @TcError@ data type.
+data TcTypeError
   = TypeEqError (MismatchError T.T)
   -- ^ Type equality error
   | StackEqError (MismatchError [T.T])
@@ -123,10 +124,14 @@
   | UnexpectedTopLevelType TopLevelType (MismatchError T.T)
   -- ^ Error that happens when the caller expected one top-level type, but
   -- the contract has another type specified.
-  | InvalidInstruction U.ExpandedInstr Text
+  | InvalidInstruction (U.InstrAbstract ()) 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@.
+  --
   -- The 'Text' argument is a user-readable explanation of why this instruction is invalid.
+  --
+  -- Since this makes sense only for primitive instructions, we keep
+  -- @U.InstrAbstract@ with @()@ type argument.
   | InvalidValueType T.T
   -- ^ Error that happens when a `U.Value` is never a valid source for this type
   -- (e.g. @timestamp@ cannot be obtained from a `U.ValueTrue`)
@@ -172,10 +177,10 @@
   deriving stock (Show, Eq, Generic)
   deriving anyclass (NFData)
 
-instance Buildable TCTypeError where
+instance Buildable TcTypeError where
   build = buildRenderDocExtended
 
-instance RenderDoc TCTypeError where
+instance RenderDoc TcTypeError where
   renderDoc context = \case
     TypeEqError merr ->
       "Types not equal:" <$> renderDoc context merr
@@ -197,7 +202,7 @@
       "Unexpected" <+> renderDoc context tyDesc <+> "type."
       <$$> renderDoc doesntNeedParens mmerr
     InvalidInstruction instr reason ->
-      "Invalid instruction" <+> (renderDoc context instr)
+      "Invalid instruction" <+> (renderDoc context (instr $> ("..." :: Text)))
       <$$> "Reason:" <+> textStrict reason
     InvalidValueType t ->
       "Value type is never a valid" <+> enclose "`" "`" (renderDoc context t)
@@ -227,65 +232,72 @@
       "A big_map with the ID" <+> renderAnyBuildable bigMapId <+> "was found, but it does not have the expected type."
       <$$> renderDoc context mismatchError
 
+instance Exception TcTypeError
+
 -- | Type check error
-data TCError
-  = TCFailedOnInstr U.ExpandedInstr SomeHST ErrorSrcPos (Maybe TypeContext) (Maybe TCTypeError)
-  | TCFailedOnValue U.Value T.T Text ErrorSrcPos (Maybe TCTypeError)
-  | TCContractError Text (Maybe TCTypeError)
-  | TCViewError Text U.ViewName (Maybe TCTypeError)
-  | TCUnreachableCode ErrorSrcPos (NonEmpty U.ExpandedOp)
-  | TCExtError SomeHST ErrorSrcPos ExtError
-  | TCIncompletelyTyped TCError (U.Contract' TypeCheckedOp)
-  | TCIncompletelyTypedView TCError (U.View' TypeCheckedOp)
+data TcError' op
+  = TcFailedOnInstr (U.InstrAbstract op) SomeHST ErrorSrcPos (Maybe TypeContext) (Maybe TcTypeError)
+  | TcFailedOnValue (U.Value' op) T.T Text ErrorSrcPos (Maybe TcTypeError)
+  | TcContractError Text (Maybe TcTypeError)
+  | TcViewError Text U.ViewName (Maybe TcTypeError)
+  | TcUnreachableCode ErrorSrcPos (NonEmpty op)
+  | TcExtError SomeHST ErrorSrcPos ExtError
+  | TcIncompletelyTyped (TcError' op) (U.Contract' (TypeCheckedOp op))
+  | TcIncompletelyTypedView (TcError' op) (U.View' (TypeCheckedOp op))
+  | TcDeprecatedType Text T.T
   deriving stock (Show, Eq, Generic)
 
-instance NFData TCError
+type TcError = TcError' U.ExpandedOp
 
-instance Buildable TCError where
+instance (NFData op, NFData (TypeCheckedOp op)) => NFData (TcError' op)
+
+instance RenderDoc op => Buildable (TcError' op) where
   build = buildRenderDocExtended
 
-instance RenderDoc TCError where
+instance RenderDoc op => RenderDoc (TcError' op) where
   renderDoc context = \case
-    TCFailedOnInstr instr (SomeHST t) ics mbTCTypeContext mbTCTypeError -> line
+    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
+      <> maybe "" (\e -> ":" <+> (renderDoc context e) <> "." <$$> line) mbTcTypeError
       <> (renderDoc context ics)
-    TCFailedOnValue v t custom ics mbTCTypeError ->
+    TcFailedOnValue v t custom ics mbTcTypeError ->
       "Error checking value"
       <$$> (renderDoc context v) <+> "against type"
       <+> (renderDoc context t) <> (bool (":" <+> (renderAnyBuildable custom)) "." (null custom))
-      <+> (maybe "" (\e -> line <> (renderDoc context e) <> line) mbTCTypeError)
+      <+> (maybe "" (\e -> line <> (renderDoc context e) <> line) mbTcTypeError)
       <+> (renderDoc context ics)
-    TCContractError msg typeError ->
+    TcContractError msg typeError ->
       "Error occurred during contract typecheck:"
       <$$> (renderAnyBuildable msg) <> (maybe "" (\e -> " " <> (renderDoc context e)) typeError)
-    TCViewError msg viewName typeError ->
+    TcViewError msg viewName typeError ->
       "Error occurred during typecheck of view " <> renderDoc context viewName <> ":"
       <$$> (renderAnyBuildable msg) <> (maybe "" (\e -> " " <> (renderDoc context e)) typeError)
-    TCUnreachableCode ics instrs ->
+    TcUnreachableCode ics instrs ->
       "Unreachable code:" <$$> buildTruncated 3 (toList instrs) <> "."
       <+> (renderDoc context ics)
-    TCExtError (SomeHST t) ics e ->
+    TcExtError (SomeHST t) ics e ->
       "Error occurred during Morley extension typecheck:" <>
       (renderAnyBuildable e) <+> "on stack" <+> (renderDoc context t) <> "."
       <+> (renderDoc context ics)
-    TCIncompletelyTyped err contract ->
+    TcIncompletelyTyped err contract ->
       line
       <> renderDoc doesntNeedParens contract
       <$> renderDoc context err
-    TCIncompletelyTypedView err _view ->
+    TcIncompletelyTypedView err _view ->
       line
       <> renderDoc context err
+    TcDeprecatedType err ty ->
+      "Found deprecated type:" <+> renderDoc doesntNeedParens ty <$> renderDoc doesntNeedParens err
     where
     buildTruncated k l
       | 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,
+    -- 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 =
@@ -293,7 +305,7 @@
       <$$> indent 4 l
       <$$> line
 
-instance Exception TCError where
+instance Exception TcError where
   displayException = pretty
 
 newtype StackSize = StackSize Natural
@@ -307,8 +319,8 @@
 -- | Various type errors possible when checking Morley extension commands
 data ExtError =
     LengthMismatch U.StackTypePattern
-  | TypeMismatch U.StackTypePattern Int TCTypeError
-  | StkRestMismatch U.StackTypePattern SomeHST SomeHST TCTypeError
+  | TypeMismatch U.StackTypePattern Int TcTypeError
+  | StkRestMismatch U.StackTypePattern SomeHST SomeHST TcTypeError
   | TestAssertError Text
   | InvalidStackReference U.StackRef StackSize
   deriving stock (Show, Eq, Generic)
@@ -358,7 +370,7 @@
   0 -> "'a"
   ix -> pairWithElems (minPairLength ix)
   where
-    -- | Given a node index @ix@, calculates the minimum number of
+    -- Given a node index @ix@, calculates the minimum number of
     -- elements a pair must have for that index to be valid.
     minPairLength :: Word -> Word
     minPairLength = \case
diff --git a/src/Morley/Michelson/TypeCheck/Ext.hs b/src/Morley/Michelson/TypeCheck/Ext.hs
--- a/src/Morley/Michelson/TypeCheck/Ext.hs
+++ b/src/Morley/Michelson/TypeCheck/Ext.hs
@@ -27,22 +27,24 @@
 -- | Perform some, possibly throwing, action presumably making use of a supplied
 -- external instruction. In case of an error, return @IllTypedSeq@ wrapping the
 -- thrown error and the instruction. If the action successfully returns
--- @SomeInstr@, wrap it in a @WellTypedSeq@.
+-- @SomeTcInstr@, wrap it in a @WellTypedSeq@.
 workOnInstr
-  :: U.ExpandedExtInstr
-  -> TypeCheckInstr (SomeInstr s)
-  -> TypeCheckInstrNoExcept (TypeCheckedSeq s)
+  :: IsInstrOp op
+  => U.ExtInstrAbstract op
+  -> TypeCheckInstr op (SomeTcInstr s)
+  -> TypeCheckInstrNoExcept op (TypeCheckedSeq op s)
 workOnInstr ext = tcEither
-  (\err -> pure $ IllTypedSeq err [NonTypedInstr $ U.PrimEx $ U.EXT ext])
+  (\err -> pure $ IllTypedSeq err [NonTypedInstr $ liftInstr $ U.EXT ext])
   (pure . WellTypedSeq)
 
 typeCheckExt
-  :: forall s. SingI s
-  => TcInstrHandler
-  -> U.ExpandedExtInstr
+  :: forall s op.
+     (SingI s, IsInstrOp op)
+  => TcInstrBase op
+  -> U.ExtInstrAbstract op
   -> HST s
-  -> TypeCheckInstrNoExcept (TypeCheckedSeq s)
-typeCheckExt tcInstr ext hst = do
+  -> TypeCheckInstrNoExcept op (TypeCheckedSeq op s)
+typeCheckExt tcOp ext hst = do
   instrPos <- view tcieErrorPos
   case ext of
     U.STACKTYPE s -> workOnInstr ext $
@@ -51,24 +53,24 @@
       verifyPrint pc <&> \tpc -> toSomeInstr (T.PRINT tpc)
     U.UTEST_ASSERT U.TestAssert{..} -> do
       let cons = U.EXT . U.UTEST_ASSERT . U.TestAssert tassName tassComment
-      preserving (typeCheckImpl tcInstr tassInstrs hst) cons $ \(_ :/ si) -> case si of
-        AnyOutInstr _ -> throwError $ TCExtError (SomeHST hst) instrPos $ TestAssertError
+      preserving (typeCheckImpl tcOp tassInstrs hst) cons $ \(_ :/ si) -> case si of
+        AnyOutInstr _ -> throwError $ TcExtError (SomeHST hst) instrPos $ TestAssertError
                          "TEST_ASSERT has to return Bool, but it always fails"
         instr ::: (((_ :: (T.SingT b, Dict (T.WellTyped b))) ::& _)) -> do
           Refl <- liftEither $ first
-            (const $ TCExtError (SomeHST hst) instrPos $
+            (const $ TcExtError (SomeHST hst) instrPos $
               TestAssertError "TEST_ASSERT has to return Bool, but returned something else")
             (eqType @b @'T.TBool)
           tcom <- verifyPrint tassComment
           pure . toSomeInstr $ T.TEST_ASSERT $ T.TestAssert tassName tcom instr
         _ ->
-          throwError $ TCExtError (SomeHST hst) instrPos $
+          throwError $ TcExtError (SomeHST hst) instrPos $
             TestAssertError "TEST_ASSERT has to return Bool, but the stack is empty"
 
     U.UCOMMENT t ->
       pure $ WellTypedSeq $ toSomeInstr $ T.COMMENT_ITEM $ T.JustComment t
   where
-    verifyPrint :: U.PrintComment -> TypeCheckInstr (T.PrintComment s)
+    verifyPrint :: U.PrintComment -> TypeCheckInstr op (T.PrintComment s)
     verifyPrint (U.PrintComment pc) = do
       let checkStRef (Left txt)             = pure $ Left txt
           checkStRef (Right (U.StackRef i)) = Right <$> createStackRef i hst
@@ -77,10 +79,10 @@
     toSomeInstr ext' = hst :/ T.Ext ext' ::: hst
     stackTypeSomeInstr s = hst :/ T.Ext (T.STACKTYPE s) ::: hst
 
-liftExtError :: SingI s => HST s -> Either ExtError a -> TypeCheckInstr a
+liftExtError :: SingI s => HST s -> Either ExtError a -> TypeCheckInstr op a
 liftExtError hst ei = do
   instrPos <- view tcieErrorPos
-  liftEither $ first (TCExtError (SomeHST hst) instrPos) ei
+  liftEither $ first (TcExtError (SomeHST hst) instrPos) ei
 
 -- | Check that a @StackTypePattern@ matches the type of the current stack
 checkStackType
@@ -122,7 +124,7 @@
 --
 -- Fails when index is too large for the given stack.
 createStackRef
-  :: (MonadError TCError m, MonadReader TypeCheckInstrEnv m, SingI s)
+  :: (MonadError (TcError' op) m, MonadReader TypeCheckInstrEnv m, SingI s)
   => Natural -> HST s -> m (T.StackRef s)
 createStackRef idx hst =
   case doCreate (hst, idx) of
@@ -130,7 +132,7 @@
     Nothing -> do
       instrPos <- view tcieErrorPos
       throwError $
-        TCExtError (SomeHST hst) instrPos $
+        TcExtError (SomeHST hst) instrPos $
           InvalidStackReference (U.StackRef idx) (StackSize $ lengthHST hst)
   where
     doCreate :: forall s. (HST s, Natural) -> Maybe (T.StackRef s)
diff --git a/src/Morley/Michelson/TypeCheck/Helpers.hs b/src/Morley/Michelson/TypeCheck/Helpers.hs
--- a/src/Morley/Michelson/TypeCheck/Helpers.hs
+++ b/src/Morley/Michelson/TypeCheck/Helpers.hs
@@ -16,6 +16,8 @@
     , typeCheckInstrErr'
     , typeCheckImpl
     , typeCheckImplStripped
+    , mapSeq
+    , wrapWithLoc
 
     , memImpl
     , getImpl
@@ -40,12 +42,13 @@
 import Control.Monad.Except (MonadError, catchError, throwError)
 import Data.Constraint (Dict(..), withDict)
 import Data.Default (def)
+import Data.Generics (listify)
 import Data.Singletons (Sing, SingI(sing), demote, fromSing)
 import Data.Singletons.Decide ((:~:)(Refl))
 import Fmt (Buildable, (+|), (|+))
 
 import Morley.Michelson.ErrorPos (ErrorSrcPos)
-import Morley.Michelson.TypeCheck.Error (TCError(..), TCTypeError(..), TypeContext(..))
+import Morley.Michelson.TypeCheck.Error (TcError'(..), TcTypeError(..), TypeContext(..))
 import Morley.Michelson.TypeCheck.TypeCheck
 import Morley.Michelson.TypeCheck.TypeCheckedSeq (IllTypedInstr(..), TypeCheckedSeq(..))
 import Morley.Michelson.TypeCheck.Types
@@ -70,7 +73,7 @@
 -- | Check whether the given stack types are equal.
 eqHST
   :: forall as bs. (SingI as, SingI bs)
-  => HST as -> HST bs -> Either TCTypeError (as :~: bs)
+  => HST as -> HST bs -> Either TcTypeError (as :~: bs)
 eqHST (hst :: HST xs) (hst' :: HST ys) = do
   case eqI @as @bs of
     Nothing -> Left $ StackEqError MkMismatchError {meActual = hstToTs hst, meExpected = hstToTs hst'}
@@ -80,7 +83,7 @@
 -- given type. This function is a specialized version of `eqHST`.
 eqHST1
   :: forall t st. (SingI st, WellTyped t)
-  => HST st -> Either TCTypeError (st :~: '[t])
+  => HST st -> Either TcTypeError (st :~: '[t])
 eqHST1 hst = do
   let hst' = sing @t -:& SNil
   case eqI @'[t] @st of
@@ -110,52 +113,52 @@
 handleError = flip catchError
 
 -- | Function @eqType@ is a simple wrapper around @Data.Singletons.decideEquality@ suited
--- for use within @Either TCTypeError a@ applicative.
+-- for use within @Either TcTypeError a@ applicative.
 eqType
   :: forall (a :: T) (b :: T). (Each '[SingI] [a, b])
-  => Either TCTypeError (a :~: b)
+  => Either TcTypeError (a :~: b)
 eqType =
   requireEq @a @b $ Left ... TypeEqError
 
 onTypeCheckInstrErr
-  :: (MonadReader TypeCheckInstrEnv m, MonadError TCError m)
-  => Un.ExpandedInstr -> SomeHST -> Maybe TypeContext
-  -> Either TCTypeError a -> m a
+  :: (MonadReader TypeCheckInstrEnv m, MonadError (TcError' op) m)
+  => Un.InstrAbstract op -> SomeHST -> Maybe TypeContext
+  -> Either TcTypeError a -> m a
 onTypeCheckInstrErr instr hst mContext ei = do
   either (typeCheckInstrErr' instr hst mContext) return ei
 
 onScopeCheckInstrErr
-  :: forall (t :: T) m a.
-      (MonadReader TypeCheckInstrEnv m, MonadError TCError m, SingI t)
-  => Un.ExpandedInstr -> SomeHST -> Maybe TypeContext
+  :: forall (t :: T) op m a.
+      (MonadReader TypeCheckInstrEnv m, MonadError (TcError' op) m, SingI t)
+  => Un.InstrAbstract op -> SomeHST -> Maybe TypeContext
   -> Either BadTypeForScope a -> m a
 onScopeCheckInstrErr instr hst mContext = \case
   Right a -> return a
   Left e -> do
     pos <- view tcieErrorPos
-    throwError $ TCFailedOnInstr instr hst pos mContext $
+    throwError $ TcFailedOnInstr instr hst pos mContext $
       Just $ UnsupportedTypeForScope (demote @t) e
 
 typeCheckInstrErr
-  :: (MonadReader TypeCheckInstrEnv m, MonadError TCError m)
-  => Un.ExpandedInstr -> SomeHST -> Maybe TypeContext
+  :: (MonadReader TypeCheckInstrEnv m, MonadError (TcError' op) m)
+  => Un.InstrAbstract op -> SomeHST -> Maybe TypeContext
   -> m a
 typeCheckInstrErr instr hst mContext = do
   pos <- view tcieErrorPos
-  throwError $ TCFailedOnInstr instr hst pos mContext Nothing
+  throwError $ TcFailedOnInstr instr hst pos mContext Nothing
 
 typeCheckInstrErr'
-  :: (MonadReader TypeCheckInstrEnv m, MonadError TCError m)
-  => Un.ExpandedInstr -> SomeHST -> Maybe TypeContext
-  -> TCTypeError -> m a
+  :: (MonadReader TypeCheckInstrEnv m, MonadError (TcError' op) m)
+  => Un.InstrAbstract op -> SomeHST -> Maybe TypeContext
+  -> TcTypeError -> m a
 typeCheckInstrErr' instr hst mContext err = do
   pos <- view tcieErrorPos
-  throwError $ TCFailedOnInstr instr hst pos mContext (Just err)
+  throwError $ TcFailedOnInstr instr hst pos mContext (Just err)
 
 withCompareableCheck
-  :: forall a m v ts. (SingI ts, MonadReader TypeCheckInstrEnv m, MonadError TCError m)
+  :: forall a m v ts op. (SingI ts, MonadReader TypeCheckInstrEnv m, MonadError (TcError' op) m)
   => Sing a
-  -> Un.ExpandedInstr
+  -> Un.InstrAbstract op
   -> HST ts
   -> (Comparable a => v)
   -> m v
@@ -163,68 +166,38 @@
   Just d@Dict -> pure $ withDict d act
   Nothing -> typeCheckInstrErr instr (SomeHST i) $ Just ComparisonArguments
 
-typeCheckOpImpl
-  :: forall inp. SingI inp
-  => TcInstrHandler
-  -> Un.ExpandedOp
-  -> HST inp
-  -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)
-typeCheckOpImpl tcInstr op' hst = case op' of
-  Un.WithSrcEx _ op@Un.WithSrcEx{} -> typeCheckOpImpl tcInstr op hst
-  Un.WithSrcEx loc (Un.PrimEx op)  -> typeCheckPrimWithLoc loc op
-  Un.WithSrcEx loc (Un.SeqEx sq)   -> typeCheckSeqWithLoc loc sq
-  Un.PrimEx op                     -> typeCheckPrim op
-  Un.SeqEx sq                      -> typeCheckSeq sq
-  where
-    -- If we know source location from the untyped instruction, keep it in the typed one.
-    typeCheckPrimWithLoc :: ErrorSrcPos -> Un.ExpandedInstr -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)
-    typeCheckPrimWithLoc loc op = local (set tcieErrorPos loc)
-      (wrapWithLoc loc <$> typeCheckPrim op)
-
-    typeCheckPrim :: Un.ExpandedInstr -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)
-    typeCheckPrim op = tcInstr op hst
-
-    typeCheckSeqWithLoc :: ErrorSrcPos -> [Un.ExpandedOp] -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)
-    typeCheckSeqWithLoc loc = fmap (wrapWithLoc loc) . local (set tcieErrorPos loc) . typeCheckSeq
-
-    typeCheckSeq :: [Un.ExpandedOp] -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)
-    typeCheckSeq sq = typeCheckImpl tcInstr sq hst
-                  <&> mapSeq (mapSomeInstr Nested)
-
 -- | Like 'typeCheckImpl' but doesn't add a stack type comment after the
 -- sequence.
 typeCheckImplNoLastTypeComment
-  :: forall inp . SingI inp
-  => TcInstrHandler
-  -> [Un.ExpandedOp]
-  -> HST inp
-  -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)
+  :: IsInstrOp op
+  => TcInstrBase op
+  -> TcInstr op [op]
 typeCheckImplNoLastTypeComment _ [] inputStack
   = pure (WellTypedSeq (inputStack :/ Nop ::: inputStack))
-typeCheckImplNoLastTypeComment tcInstr [op] inputStack = do
-  typeCheckOpImpl tcInstr op inputStack
+typeCheckImplNoLastTypeComment tcOp [op] inputStack = do
+  tcOp op inputStack
       >>= mapMSeq prependStackTypeComment
-typeCheckImplNoLastTypeComment tcInstr (op : ops) inputStack = do
-  done <- typeCheckOpImpl tcInstr op inputStack
+typeCheckImplNoLastTypeComment tcOp (op : ops) inputStack = do
+  done <- tcOp op inputStack
       >>= mapMSeq prependStackTypeComment
-  continueTypeChecking tcInstr done ops
+  continueTypeChecking tcOp done ops
 
 continueTypeChecking
-  :: forall inp. ()
-  => TcInstrHandler
-  -> TypeCheckedSeq inp
-  -> [Un.ExpandedOp]
-  -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)
-continueTypeChecking tcInstr done rest = case done of
+  :: forall op inp. (IsInstrOp op)
+  => TcInstrBase op
+  -> TypeCheckedSeq op inp
+  -> [op]
+  -> TypeCheckInstrNoExcept op (TypeCheckedSeq op inp)
+continueTypeChecking tcOp done rest = case done of
   WellTypedSeq instr -> handleFirst instr
   MixedSeq i e left -> pure (MixedSeq i e (left <> map NonTypedInstr rest))
   IllTypedSeq e left -> pure (IllTypedSeq e (left <> map NonTypedInstr rest))
   where
-    handleFirst :: SomeInstr inp -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)
+    handleFirst :: SomeTcInstr inp -> TypeCheckInstrNoExcept op (TypeCheckedSeq op inp)
     handleFirst packedInstr@(inputStack :/ instrAndOutputStack) = do
       case instrAndOutputStack of
         instr ::: outputStack -> do
-          nextPiece <- typeCheckImplNoLastTypeComment tcInstr rest outputStack
+          nextPiece <- typeCheckImplNoLastTypeComment tcOp rest outputStack
           let combiner = combine inputStack instr
           pure case nextPiece of
             WellTypedSeq nextInstr -> WellTypedSeq (combiner nextInstr)
@@ -234,39 +207,35 @@
           [] -> WellTypedSeq packedInstr
           op : ops -> (MixedSeq
                         packedInstr
-                        (TCUnreachableCode (extractOpPos op) (op :| ops))
+                        (TcUnreachableCode (extractOpPos op) (op :| ops))
                         (map NonTypedInstr ops))
 
     combine inp Nop (_ :/ nextPart) = inp :/ nextPart
     combine inp i1 (_ :/ nextPart) = inp :/ mapSomeInstrOut (Seq i1) nextPart
 
-    extractOpPos :: Un.ExpandedOp -> ErrorSrcPos
-    extractOpPos (Un.WithSrcEx loc _) = loc
-    extractOpPos _ = def
+    extractOpPos :: op -> ErrorSrcPos
+    extractOpPos = fromMaybe def . pickErrorSrcPos
 
 -- | Like 'typeCheckImpl' but without the first and the last stack type
 -- comments. Useful to reduce duplication of stack type comments.
 typeCheckImplStripped
-  :: forall inp . SingI inp
-  => TcInstrHandler
-  -> [Un.ExpandedOp]
-  -> HST inp
-  -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)
-typeCheckImplStripped tcInstr [] inp
-  = typeCheckImplNoLastTypeComment tcInstr [] inp
-typeCheckImplStripped tcInstr (op : ops) inp = do
-  done <- typeCheckOpImpl tcInstr op inp
-  continueTypeChecking tcInstr done ops
+  :: IsInstrOp op
+  => TcInstrBase op
+  -> TcInstr op [op]
+typeCheckImplStripped tcOp [] inp
+  = typeCheckImplNoLastTypeComment tcOp [] inp
+typeCheckImplStripped tcOp (op : ops) inp = do
+  done <- tcOp op inp
+  continueTypeChecking tcOp done ops
 
 typeCheckImpl
-  :: forall inp . SingI inp
-  => TcInstrHandler
-  -> [Un.ExpandedOp]
-  -> HST inp
-  -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)
-typeCheckImpl tcInstr ops inputStack = do
-  tcSeq <- typeCheckImplNoLastTypeComment tcInstr ops inputStack
-  mapMSeq appendTypeComment tcSeq
+  :: forall op. IsInstrOp op
+  => TcInstrBase op
+  -> TcInstr op [op]
+typeCheckImpl tcOp ops inputStack = do
+  checkBadTypes inputStack & tcEither
+    (\err -> pure $ IllTypedSeq err $ NonTypedInstr <$> ops)
+    (\_ -> typeCheckImplNoLastTypeComment tcOp ops inputStack >>= mapMSeq appendTypeComment)
   where
     appendTypeComment packedI@(inp :/ iAndOut) = do
       verbose <- asks' tcVerbose
@@ -274,17 +243,34 @@
         (True, i ::: out) -> inp :/ Seq i (stackTypeComment out) ::: out
         (True, AnyOutInstr i) -> inp :/ AnyOutInstr (Seq i noStackTypeComment)
         _ -> packedI
+    checkBadTypes :: HST a -> TypeCheckInstr op' ()
+    checkBadTypes x = do
+      isStrict <- asks' tcStrict
+      when isStrict $ doCheckBadTypes x
+    doCheckBadTypes :: HST a -> TypeCheckInstr op' ()
+    doCheckBadTypes = \case
+      SNil -> pure ()
+      (_ :: Sing t, _) ::& _
+        | ty : _ <- listify isTimeLockTy (demote @t) -> timelockDeprecated ty
+      _ ::& xs -> doCheckBadTypes xs
+    isTimeLockTy :: T -> Bool
+    isTimeLockTy TChest = True
+    isTimeLockTy TChestKey = True
+    isTimeLockTy _ = False
+    timelockDeprecated :: T -> TypeCheckInstr op' a
+    timelockDeprecated = throwError . TcDeprecatedType
+      "Timelock mechanism is affected by a vulnerability."
 
 
 prependStackTypeComment
-  :: SomeInstr inp -> TypeCheckInstrNoExcept (SomeInstr inp)
+  :: SomeTcInstr inp -> TypeCheckInstrNoExcept op (SomeTcInstr inp)
 prependStackTypeComment packedInstr@(inp :/ _) = do
   verbose <- asks' tcVerbose
   pure if verbose && (not (isNop' packedInstr))
     then mapSomeInstr (Seq (stackTypeComment inp)) packedInstr
     else packedInstr
 
-isNop' :: SomeInstr inp -> Bool
+isNop' :: SomeTcInstr inp -> Bool
 isNop' (_ :/ i ::: _) = isNop i
 isNop' (_ :/ AnyOutInstr i) = isNop i
 
@@ -299,18 +285,18 @@
 
 mapMSeq
   :: Applicative f
-  => (SomeInstr inp -> f (SomeInstr inp'))
-  -> TypeCheckedSeq inp
-  -> f (TypeCheckedSeq inp')
+  => (SomeTcInstr inp -> f (SomeTcInstr inp'))
+  -> TypeCheckedSeq op inp
+  -> f (TypeCheckedSeq op inp')
 mapMSeq f v = case v of
   WellTypedSeq instr -> f instr <&> WellTypedSeq
   MixedSeq instr err tail' -> f instr <&> \instr' -> MixedSeq instr' err tail'
   IllTypedSeq err tail' -> pure $ IllTypedSeq err tail'
 
 mapSeq
-  :: (SomeInstr inp -> SomeInstr inp')
-  -> TypeCheckedSeq inp
-  -> TypeCheckedSeq inp'
+  :: (SomeTcInstr inp -> SomeTcInstr inp')
+  -> TypeCheckedSeq op inp
+  -> TypeCheckedSeq op inp'
 mapSeq f = runIdentity . mapMSeq (Identity . f)
 
 stackTypeComment :: HST st -> Instr st st
@@ -319,7 +305,7 @@
 noStackTypeComment :: Instr st st
 noStackTypeComment = Ext (COMMENT_ITEM (StackTypeComment Nothing))
 
-wrapWithLoc :: ErrorSrcPos -> TypeCheckedSeq inp -> TypeCheckedSeq inp
+wrapWithLoc :: ErrorSrcPos -> TypeCheckedSeq op inp -> TypeCheckedSeq op inp
 wrapWithLoc loc = mapSeq $ \someInstr -> case someInstr of
   (_ :/ WithLoc{} ::: _) -> someInstr
   (inp :/ instr ::: out) -> inp :/ WithLoc loc instr ::: out
@@ -331,17 +317,17 @@
 
 -- | Generic implementation for MEMeration
 memImpl
-  :: forall c memKey rs inp m .
+  :: forall c memKey rs inp m op .
     ( MemOp c
     , SingI (MemOpKey c)
     , inp ~ (memKey : c : rs)
     , SingI rs
     , MonadReader TypeCheckInstrEnv m
-    , MonadError TCError m
+    , MonadError (TcError' op) m
     )
   => HST inp
   -> VarAnn
-  -> m (SomeInstr inp)
+  -> m (SomeTcInstr inp)
 memImpl inputHST@(_ ::& _ ::& hstTail) varAnn =
   case eqType @memKey @(MemOpKey c) of
     Right Refl ->
@@ -353,18 +339,18 @@
     uInstr = Un.MEM varAnn
 
 getImpl
-  :: forall c getKey rs inp m .
+  :: forall c getKey rs inp m op .
     ( GetOp c, SingI (GetOpKey c)
     , WellTyped (GetOpVal c)
     , inp ~ (getKey : c : rs)
     , SingI rs
     , MonadReader TypeCheckInstrEnv m
-    , MonadError TCError m
+    , MonadError (TcError' op) m
     )
   => HST inp
   -> SingT (GetOpVal c)
   -> VarAnn
-  -> m (SomeInstr inp)
+  -> m (SomeTcInstr inp)
 getImpl inputHST@(_ ::& _ ::& hstTail) valueSing varAnn =
   case eqType @getKey @(GetOpKey c) of
     Right Refl ->
@@ -376,17 +362,17 @@
     uInstr = Un.GET varAnn
 
 updImpl
-  :: forall c updKey updParams rs inp m .
+  :: forall c updKey updParams rs inp m op .
     ( UpdOp c
     , SingI (UpdOpKey c), SingI (UpdOpParams c)
     , SingI rs
     , inp ~ (updKey : updParams : c : rs)
     , MonadReader TypeCheckInstrEnv m
-    , MonadError TCError m
+    , MonadError (TcError' op) m
     )
   => HST inp
   -> VarAnn
-  -> m (SomeInstr inp)
+  -> m (SomeTcInstr inp)
 updImpl inputHST@(_ ::& _ ::& cTuple ::& hstTail) varAnn =
   case (eqType @updKey @(UpdOpKey c), eqType @updParams @(UpdOpParams c)) of
     (Right Refl, Right Refl) ->
@@ -400,7 +386,7 @@
     uInstr = Un.UPDATE varAnn
 
 getUpdImpl
-  :: forall c updKey updParams rs inp m .
+  :: forall c updKey updParams rs inp m op .
     ( UpdOp c, GetOp c
     , SingI (UpdOpKey c)
     , SingI (GetOpVal c)
@@ -409,11 +395,11 @@
     , GetOpKey c ~ UpdOpKey c
     , UpdOpParams c ~ 'TOption (GetOpVal c)
     , MonadReader TypeCheckInstrEnv m
-    , MonadError TCError m
+    , MonadError (TcError' op) m
     )
   => HST inp
   -> VarAnn
-  -> m (SomeInstr inp)
+  -> m (SomeTcInstr inp)
 getUpdImpl inputHST@(_ ::& hst1 ::& cTuple ::& hstTail) varAnn =
   case (eqType @updKey @(UpdOpKey c), eqType @updParams @(UpdOpParams c)) of
     (Right Refl, Right Refl) ->
@@ -430,7 +416,7 @@
   :: (SizeOp c, inp ~ (c ': rs), Monad m)
   => HST inp
   -> VarAnn
-  -> m (SomeInstr inp)
+  -> m (SomeTcInstr inp)
 sizeImpl i@(_ ::& rs) vn =
   pure $ i :/ AnnSIZE (Anns1 vn) ::: ((sing, Dict) ::& rs)
 
@@ -438,7 +424,7 @@
   :: (SliceOp c, inp ~ ('TNat ': 'TNat ': c ': rs), Monad m)
   => HST inp
   -> Un.VarAnn
-  -> m (SomeInstr inp)
+  -> m (SomeTcInstr inp)
 sliceImpl i@(_ ::& _ ::& (cn, Dict) ::& rs) vn = do
   let rn = STOption cn
   pure $ i :/ AnnSLICE (Anns1 vn) ::: ((rn, Dict) ::& rs)
@@ -447,7 +433,7 @@
   :: (ConcatOp c, WellTyped c, inp ~ ('TList c : rs), Monad m)
   => HST inp
   -> Un.VarAnn
-  -> m (SomeInstr inp)
+  -> m (SomeTcInstr inp)
 concatImpl' i@((STList n, Dict) ::& rs) vn = do
   pure $ i :/ AnnCONCAT' (Anns1 vn) ::: ((n, Dict) ::& rs)
 
@@ -458,14 +444,14 @@
      )
   => HST inp
   -> Un.VarAnn
-  -> m (SomeInstr inp)
+  -> m (SomeTcInstr inp)
 concatImpl i@((cn1, _) ::& (_, _) ::& rs) vn = do
   pure $ i :/ AnnCONCAT (Anns1 vn) ::: ((cn1, Dict) ::& rs)
 
 -- | Helper function to construct instructions for binary arithmetic
 -- operations.
 arithImpl
-  :: forall aop inp m n s t.
+  :: forall aop inp m n s t op.
      ( WellTyped (ArithRes aop n m)
      , inp ~ (n ': m ': s)
      , MonadReader TypeCheckInstrEnv t
@@ -473,24 +459,24 @@
   => (Anns '[VarAnn] -> Instr inp (ArithRes aop n m ': s))
   -> HST inp
   -> VarAnn
-  -> Un.ExpandedInstr
-  -> t (SomeInstr inp)
+  -> Un.InstrAbstract op
+  -> t (SomeTcInstr inp)
 arithImpl mkInstr i@(_ ::& _ ::& rs) vn _ =
   pure $ i :/ mkInstr (Anns1 vn) ::: ((sing, Dict) ::& rs)
 
 addImpl
-  :: forall a b inp rs m.
+  :: forall a b inp rs m op.
      ( Each '[SingI] [a, b]
      , inp ~ (a ': b ': rs)
      , SingI rs
      , MonadReader TypeCheckInstrEnv m
-     , MonadError TCError m
+     , MonadError (TcError' op) m
      )
   => Sing a -> Sing b
   -> HST inp
   -> VarAnn
-  -> Un.ExpandedInstr
-  -> m (SomeInstr inp)
+  -> Un.InstrAbstract op
+  -> m (SomeTcInstr inp)
 addImpl t1 t2 = case (t1, t2) of
   (STInt, STInt) -> arithImpl @Add AnnADD
   (STInt, STNat) -> arithImpl @Add AnnADD
@@ -506,18 +492,18 @@
     NotNumericTypes (demote @a) (demote @b)
 
 edivImpl
-  :: forall a b inp rs m.
+  :: forall a b inp rs m op.
      ( SingI rs
      , Each '[SingI] [a, b]
      , inp ~ (a ': b ': rs)
      , MonadReader TypeCheckInstrEnv m
-     , MonadError TCError m
+     , MonadError (TcError' op) m
      )
   => Sing a -> Sing b
   -> HST inp
   -> VarAnn
-  -> Un.ExpandedInstr
-  -> m (SomeInstr inp)
+  -> Un.InstrAbstract op
+  -> m (SomeTcInstr inp)
 edivImpl t1 t2 = case (t1, t2) of
   (STInt, STInt) -> edivImplDo
   (STInt, STNat) -> edivImplDo
@@ -538,24 +524,24 @@
      )
   => HST inp
   -> VarAnn
-  -> Un.ExpandedInstr
-  -> t (SomeInstr inp)
+  -> Un.InstrAbstract op
+  -> t (SomeTcInstr inp)
 edivImplDo i@(_ ::& _ ::& rs) vn _ =
   pure $ i :/ AnnEDIV (Anns1 vn) ::: ((sing, Dict) ::& rs)
 
 subImpl
-  :: forall a b inp rs m.
+  :: forall a b inp rs m op.
      ( Each '[SingI] [a, b]
      , inp ~ (a ': b ': rs)
      , SingI rs
      , MonadReader TypeCheckInstrEnv m
-     , MonadError TCError m
+     , MonadError (TcError' op) m
      )
   => Sing a -> Sing b
   -> HST inp
   -> VarAnn
-  -> Un.ExpandedInstr
-  -> m (SomeInstr inp)
+  -> Un.InstrAbstract op
+  -> m (SomeTcInstr inp)
 subImpl t1 t2 = case (t1, t2) of
   (STInt, STInt) -> arithImpl @Sub AnnSUB
   (STInt, STNat) -> arithImpl @Sub AnnSUB
@@ -563,24 +549,24 @@
   (STNat, STNat) -> arithImpl @Sub AnnSUB
   (STTimestamp, STTimestamp) -> arithImpl @Sub AnnSUB
   (STMutez, STMutez) -> \i _ uInstr -> typeCheckInstrErr' uInstr (SomeHST i) (Just ArithmeticOperation) $
-    InvalidInstruction uInstr "Use of SUB on `mutez` operands is deprecated; use SUB_MUTEZ"
+    InvalidInstruction (uInstr $> ()) "Use of SUB on `mutez` operands is deprecated; use SUB_MUTEZ"
   (STTimestamp, STInt) -> arithImpl @Sub AnnSUB
   _ -> \i _ uInstr -> typeCheckInstrErr' uInstr (SomeHST i) (Just ArithmeticOperation) $
     NotNumericTypes (demote @a) (demote @b)
 
 mulImpl
-  :: forall a b inp rs m.
+  :: forall a b inp rs m op.
      ( Each '[SingI] [a, b]
      , inp ~ (a ': b ': rs)
      , SingI rs
      , MonadReader TypeCheckInstrEnv m
-     , MonadError TCError m
+     , MonadError (TcError' op) m
      )
   => Sing a -> Sing b
   -> HST inp
   -> VarAnn
-  -> Un.ExpandedInstr
-  -> m (SomeInstr inp)
+  -> Un.InstrAbstract op
+  -> m (SomeTcInstr inp)
 mulImpl t1 t2 = case (t1, t2) of
   (STInt, STInt) -> arithImpl @Mul AnnMUL
   (STInt, STNat) -> arithImpl @Mul AnnMUL
@@ -607,7 +593,7 @@
      )
   => Instr inp (UnaryArithRes aop n ': s)
   -> HST inp
-  -> t (SomeInstr inp)
+  -> t (SomeTcInstr inp)
 unaryArithImpl mkInstr i@(_ ::& rs) = do
   pure $ i :/ mkInstr ::: ((sing, Dict) ::& rs)
 
@@ -621,6 +607,6 @@
      )
   => Instr inp (UnaryArithRes aop n ': s)
   -> HST inp
-  -> t (SomeInstr inp)
+  -> t (SomeTcInstr inp)
 unaryArithImplAnnotated mkInstr i@((n, _) ::& rs) = do
   pure $ i :/ mkInstr ::: ((n, Dict) ::& rs)
diff --git a/src/Morley/Michelson/TypeCheck/Instr.hs b/src/Morley/Michelson/TypeCheck/Instr.hs
--- a/src/Morley/Michelson/TypeCheck/Instr.hs
+++ b/src/Morley/Michelson/TypeCheck/Instr.hs
@@ -18,18 +18,20 @@
 --
 -- Function @typeCheck@ takes list of instructions and returns value of type
 -- @Instr inp out@ along with @HST inp@ and @HST out@ all wrapped into
--- @SomeInstr@ data type. This wrapping is done to satisfy Haskell type
+-- @SomeTcInstr@ data type. This wrapping is done to satisfy Haskell type
 -- system (which has no support for dependent types).
 -- Functions @typeCheckInstr@, @typeCheckValue@ behave similarly.
 --
 -- When a recursive call is made within @typeCheck@, @typeCheckInstr@ or
--- @typeCheckValue@, result of a call is unwrapped from @SomeInstr@ and type
+-- @typeCheckValue@, result of a call is unwrapped from @SomeTcInstr@ and type
 -- information from @HST inp@ and @HST out@ is being used to assert that
 -- recursive call returned instruction of expected type
 -- (error is thrown otherwise).
 module Morley.Michelson.TypeCheck.Instr
     ( typeCheckContract
+    , typeCheckContract'
     , typeCheckContractAndStorage
+    , typeCheckContractAndStorage'
     , typeCheckInstr
     , typeCheckList
     , tcList
@@ -37,13 +39,20 @@
     , typeCheckParameter
     , typeCheckStorage
     , typeCheckTopLevelType
+    , typeCheckTopLevelType'
+    , typeCheckViews
+    , typeCheckView'
+    , typeCheckViews'
     , typeCheckValue
     , typeCheckValueRunCodeCompat
+    , typeCheckExpandedOp
     , typeVerifyContract
+    , typeVerifyContract'
     , typeVerifyParameter
     , typeVerifyStorage
     , typeVerifyTopLevelType
     , typeVerifyView
+    , typeVerifyView'
     ) where
 
 import Prelude hiding (EQ, GT, LT)
@@ -54,11 +63,12 @@
 import Data.Generics (everything, mkQ)
 import Data.Sequence ((|>))
 import Data.Sequence qualified as Seq
-import Data.Singletons (Sing, SomeSing(..), demote, withSingI, withSomeSing)
+import Data.Singletons (Sing, SomeSing(..), demote, withSingI)
 import Data.Type.Equality (TestEquality(..))
 import Data.Typeable ((:~:)(..))
 import Fmt (pretty)
 
+import Morley.Michelson.ErrorPos (ErrorSrcPos)
 import Morley.Michelson.TypeCheck.Error
 import Morley.Michelson.TypeCheck.Ext
 import Morley.Michelson.TypeCheck.Helpers
@@ -84,66 +94,87 @@
 -- | Type check a contract and verify that the given storage
 -- is of the type expected by the contract.
 typeCheckContractAndStorage
-  :: U.Contract -> U.Value -> TypeCheckResult SomeContractAndStorage
-typeCheckContractAndStorage uContract uStorage = do
-  SomeContract (contract@Contract{} :: Contract cp st) <- typeCheckContract uContract
-  storage <- typeVerifyStorage @st uStorage
+  :: U.Contract -> U.Value -> TypeCheckResult U.ExpandedOp SomeContractAndStorage
+typeCheckContractAndStorage = typeCheckContractAndStorage' typeCheckExpandedOp
+
+typeCheckContractAndStorage'
+  :: IsInstrOp op
+  => TcInstrBase op -> U.Contract' op -> U.Value' op -> TypeCheckResult op SomeContractAndStorage
+typeCheckContractAndStorage' tcOp uContract uStorage = do
+  SomeContract (contract@Contract{} :: Contract cp st) <- typeCheckContract' tcOp uContract
+  storage <- typeVerifyStorage' @st tcOp uStorage
   pure $ SomeContractAndStorage contract storage
 
 typeCheckContract
   :: U.Contract
-  -> TypeCheckResult SomeContract
-typeCheckContract c = do
-  paramType <- liftEither $ mkSomeParamType (U.contractParameter c)
-  runTypeCheck (TypeCheckContract paramType) $ typeCheckContractImpl c
+  -> TypeCheckResult U.ExpandedOp SomeContract
+typeCheckContract = typeCheckContract' typeCheckExpandedOp
 
+typeCheckContract'
+  :: IsInstrOp op
+  => TcInstrBase op
+  -> U.Contract' op
+  -> TypeCheckResult op SomeContract
+typeCheckContract' tcOp c = do
+  paramType <- liftEither $ first (TcContractError "illegal parameter declaration: " . Just ) $
+    mkSomeParamType (U.contractParameter c)
+  runTypeCheck (TypeCheckContract paramType) $ doTypeCheckContract' tcOp c
+
 typeVerifyContract
   :: forall cp st.
      (SingI cp, SingI st)
-  => U.Contract -> TypeCheckResult (Contract cp st)
-typeVerifyContract uContract = do
+  => U.Contract -> TypeCheckResult U.ExpandedOp (Contract cp st)
+typeVerifyContract = typeVerifyContract' typeCheckExpandedOp
+
+typeVerifyContract'
+  :: forall cp st op.
+     (SingI cp, SingI st, IsInstrOp op)
+  => TcInstrBase op -> U.Contract' op -> TypeCheckResult op (Contract cp st)
+typeVerifyContract' tcOp uContract = do
   SomeContract tContract@(Contract{} :: Contract cp' st') <-
-    typeCheckContract uContract
+    typeCheckContract' tcOp uContract
   Refl <- requireEq @cp' @cp (mkErr TltParameterType)
   Refl <- requireEq @st' @st (mkErr TltStorageType)
   return tContract
   where
-    mkErr :: TopLevelType -> MismatchError T -> TypeCheckResult any
+    mkErr :: TopLevelType -> MismatchError T -> TypeCheckResult op any
     mkErr tyDesc merr =
-      throwError $ TCContractError "error in contract type" $ Just $
+      throwError $ TcContractError "error in contract type" $ Just $
           UnexpectedTopLevelType tyDesc merr
 
-withWTP :: forall t a. SingI t => (WellTyped t => TypeCheck a) -> TypeCheck a
+withWTP :: forall t a op. SingI t => (WellTyped t => TypeCheck op a) -> TypeCheck op a
 withWTP fn = case getWTP @t of
   Right Dict -> fn
-  Left err -> throwError $ TCContractError (pretty err) Nothing
+  Left err -> throwError $ TcContractError (pretty err) Nothing
 
-withWTPInstr_ :: forall t a. SingI t => U.ExpandedInstr -> SomeHST -> (WellTyped t => TypeCheckInstr a) -> TypeCheckInstr a
+withWTPInstr_ :: forall t op a. SingI t => U.InstrAbstract op -> SomeHST -> (WellTyped t => TypeCheckInstr op a) -> TypeCheckInstr op a
 withWTPInstr_ v t fn = case getWTP @t of
   Right Dict -> fn
   Left (NotWellTyped badType cause) -> do
     loc <- view tcieErrorPos
-    throwError $ TCFailedOnInstr v t loc Nothing (Just $ UnsupportedTypeForScope badType cause)
+    throwError $ TcFailedOnInstr v t loc Nothing (Just $ UnsupportedTypeForScope badType cause)
 
 withWTPInstr'_
-  :: forall t inp. SingI t
-  => U.ExpandedInstr
+  :: forall t op inp. (SingI t, IsInstrOp op)
+  => U.InstrAbstract op
   -> SomeHST
-  -> (WellTyped t => TypeCheckInstrNoExcept (TypeCheckedSeq inp))
-  -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)
+  -> (WellTyped t => TypeCheckInstrNoExcept op (TypeCheckedSeq op inp))
+  -> TypeCheckInstrNoExcept op (TypeCheckedSeq op inp)
 withWTPInstr'_ v t fn = case getWTP @t of
   Right Dict -> fn
   Left (NotWellTyped badType cause) -> do
     loc <- view tcieErrorPos
-    let err = TCFailedOnInstr v t loc Nothing
+    let err = TcFailedOnInstr v t loc Nothing
               (Just $ UnsupportedTypeForScope badType cause)
-    pure $ IllTypedSeq err [NonTypedInstr $ U.PrimEx v]
+    pure $ IllTypedSeq err [NonTypedInstr $ liftInstr v]
 
-typeCheckContractImpl
-  :: U.Contract
-  -> TypeCheck SomeContract
-typeCheckContractImpl uContract@(U.Contract wholeParam@(U.ParameterType mParam rootAnn) mStorage pCode entriesOrder uViews) = do
-  _ <- maybe (throwError $ TCContractError "no instructions in contract code" $ Just EmptyCode)
+doTypeCheckContract'
+  :: IsInstrOp op
+  => TcInstrBase op
+  -> U.Contract' op
+  -> TypeCheck op SomeContract
+doTypeCheckContract' tcOp uContract@(U.Contract wholeParam@(U.ParameterType mParam rootAnn) mStorage pCode entriesOrder uViews) = do
+  _ <- maybe (throwError $ TcContractError "no instructions in contract code" $ Just EmptyCode)
                 pure (nonEmpty pCode)
   withUType mParam $ \(paramNote :: Notes param) ->
     withUType mStorage $ \(storageNote :: Notes st) -> do
@@ -160,14 +191,14 @@
             usingReaderT def $
             liftNoExcept $
             typeCheckImpl
-              (giveNotInView $ local (set tcieNotInView $ Just Dict) ... typeCheckInstr)
+              (giveNotInView $ local (set tcieNotInView $ Just Dict) ... tcOp)
               pCode
               inp
           instr@(_ :/ instrOut) <-
             tcsEither onFailedCodeTypeCheck pure codeRes
 
           -- typecheck views
-          views <- typeCheckViewsImpl
+          views <- typeCheckViews' tcOp
             uContract{ U.contractCode = [someInstrToOp instr], U.contractViews = [] }
             storageNote uViews
 
@@ -177,31 +208,31 @@
             cParamNotes <-
               liftEither $
               mkParamNotes paramNote rootAnn `onFirst`
-                  (TCContractError "invalid parameter declaration: " . Just . IllegalParamDecl)
+                  (TcContractError "invalid parameter declaration: " . Just . IllegalParamDecl)
             let cEntriesOrder = entriesOrder
             cViews <- liftEither $
-              mkViewsSet views `onFirst` \e -> TCContractError (pretty e) Nothing
+              mkViewsSet views `onFirst` \e -> TcContractError (pretty e) Nothing
             case instrOut of
               instr' ::: out -> liftEither $ do
                 case eqHST1 @('TPair ('TList 'TOperation) st) out of
                   Right Refl ->
                     pure $ SomeContract Contract{ cCode = ContractCode instr', .. }
                   Left err ->
-                    Left $ TCContractError "contract output type violates convention:" $ Just err
+                    Left $ TcContractError "contract output type violates convention:" $ Just err
               AnyOutInstr instr' ->
                 pure $ SomeContract Contract{ cCode = ContractCode instr', .. }
 
   where
-    hasTypeError :: forall (t :: T) a. SingI t => Text -> BadTypeForScope -> TypeCheck a
+    hasTypeError :: forall (t :: T) a op. SingI t => Text -> BadTypeForScope -> TypeCheck op a
     hasTypeError name reason = throwError $
-      TCContractError ("contract " <> name <> " type error") $
+      TcContractError ("contract " <> name <> " type error") $
       Just $ UnsupportedTypeForScope (demote @t) reason
 
-    onFailedCodeTypeCheck :: [TypeCheckedOp] -> TCError -> TypeCheck a
+    onFailedCodeTypeCheck :: [TypeCheckedOp op] -> TcError' op -> TypeCheck op a
     onFailedCodeTypeCheck ops err = do
       verbose <- asks' tcVerbose
       throwError if verbose
-        then TCIncompletelyTyped err U.Contract
+        then TcIncompletelyTyped err U.Contract
              { contractParameter = wholeParam
              , contractStorage = mStorage
              , contractCode = ops
@@ -210,11 +241,11 @@
              }
         else err
 
-    onFailedFullTypeCheck :: [TypeCheckedOp] -> [U.View' TypeCheckedOp] -> TCError -> TypeCheck a
+    onFailedFullTypeCheck :: [TypeCheckedOp op] -> [U.View' (TypeCheckedOp op)] -> TcError' op -> TypeCheck op a
     onFailedFullTypeCheck ops views err = do
       verbose <- asks' tcVerbose
       throwError if verbose
-        then TCIncompletelyTyped err U.Contract
+        then TcIncompletelyTyped err U.Contract
              { contractParameter = wholeParam
              , contractStorage = mStorage
              , contractCode = ops
@@ -226,22 +257,33 @@
 typeVerifyView
   :: forall arg ret st.
      (SingI arg, SingI ret, WellTyped st)
-  => Notes st -> U.View -> TypeCheckResult (View arg st ret)
-typeVerifyView notes v = do
+  => Notes st -> U.View -> TypeCheckResult U.ExpandedOp (View arg st ret)
+typeVerifyView = typeVerifyView' typeCheckExpandedOp
+
+typeVerifyView'
+  :: forall arg ret st op.
+     (SingI arg, SingI ret, WellTyped st, IsInstrOp op)
+  => TcInstrBase op -> Notes st -> U.View' op -> TypeCheckResult op (View arg st ret)
+typeVerifyView' tcOp notes v = do
   SomeView (tcView@View{} :: View arg' st' ret') <-
-    runTypeCheck TypeCheckTest $ typeCheckViewImpl notes v
+    runTypeCheck TypeCheckTest $ typeCheckView' tcOp notes v
   Refl <- requireEq @arg' @arg (mkErr TltParameterType)
   Refl <- requireEq @st' @st (mkErr TltStorageType)
   Refl <- requireEq @ret' @ret (mkErr TltParameterType)
   return tcView
   where
-    mkErr :: TopLevelType -> MismatchError T -> TypeCheckResult any
+    mkErr :: TopLevelType -> MismatchError T -> TypeCheckResult op any
     mkErr tyDesc merr =
-      throwError $ TCContractError "error in view type" $ Just $
+      throwError $ TcContractError "error in view type" $ Just $
           UnexpectedTopLevelType tyDesc merr
 
-typeCheckViewImpl :: WellTyped st => Notes st -> U.View -> TypeCheck (SomeView st)
-typeCheckViewImpl storageNote
+typeCheckView'
+  :: (WellTyped st, IsInstrOp op)
+  => TcInstrBase op
+  -> Notes st
+  -> U.View' op
+  -> TypeCheck op (SomeView st)
+typeCheckView' tcOp storageNote
   uView@U.View
   { U.viewArgument = AsUType (argNote :: Notes param)
   , U.viewReturn = AsUType (returnNote :: Notes ret)
@@ -259,7 +301,7 @@
     codeRes <-
       usingReaderT def $
       liftNoExcept $
-      typeCheckImpl typeCheckInstr uInstr inp
+      typeCheckImpl tcOp uInstr inp
     _ :/ instrOut <-
       tcsEither (onFailedViewsTypeCheck uView) pure codeRes
 
@@ -269,50 +311,63 @@
     case instrOut of
       instr ::: out -> liftEither do
         Refl <- eqHST1 @ret out
-          `onFirst` (TCViewError "view return type mismatch:" viewName . Just)
+          `onFirst` (TcViewError "view return type mismatch:" viewName . Just)
         return $ SomeView View{ vCode = instr, .. }
       AnyOutInstr instr ->
         return $ SomeView View{ vCode = instr, .. }
 
   where
     onFailedViewsTypeCheck
-      :: U.View -> [TypeCheckedOp] -> TCError -> TypeCheck a
+      :: U.View' op -> [TypeCheckedOp op] -> TcError' op -> TypeCheck op a
     onFailedViewsTypeCheck v viewOps err = do
       verbose <- asks' tcVerbose
       throwError if verbose
-        then TCIncompletelyTypedView err v{ U.viewCode = viewOps }
+        then TcIncompletelyTypedView err v{ U.viewCode = viewOps }
         else err
 
-    hasTypeError :: forall (t :: T) a. SingI t => Text -> BadTypeForScope -> TypeCheck a
+    hasTypeError :: forall (t :: T) a op. SingI t => Text -> BadTypeForScope -> TypeCheck op a
     hasTypeError desc reason = throwError $
-      TCViewError (desc <> " type error in view") viewName $
+      TcViewError (desc <> " type error in view") viewName $
       Just $ UnsupportedTypeForScope (demote @t) reason
 
-typeCheckViewsImpl
-  :: (WellTyped st)
-  => U.Contract' TypeCheckedOp -> Notes st -> [U.View] -> TypeCheck [SomeView st]
-typeCheckViewsImpl tcCotract storageNote cViews =
+typeCheckViews'
+  :: forall st op.
+     (WellTyped st, IsInstrOp op)
+  => TcInstrBase op
+  -> U.Contract' (TypeCheckedOp op)
+  -> Notes st
+  -> [U.View' op]
+  -> TypeCheck op [SomeView st]
+typeCheckViews' doTypeCheckOp tcContract storageNote cViews =
   let myfoldM l acc f = foldM f acc l in
-  fmap (map snd . toList) $ myfoldM cViews (Seq.Empty :: Seq (U.View, SomeView st))
+  fmap (map snd . toList) $ myfoldM cViews (Seq.Empty :: Seq (U.View' op, SomeView st))
     \processedViews uView -> do
-      resView <- typeCheckViewImpl storageNote uView
+      resView <- typeCheckView' doTypeCheckOp storageNote uView
       pure $ processedViews |> (uView, resView)
       `catchError` \case
-        TCIncompletelyTypedView err view' ->
+        TcIncompletelyTypedView err view' ->
           let tcViews = map (uncurry someViewToOp) processedViews
           in onFailedViewsTypeCheck tcViews view' err
         err -> throwError err
   where
     onFailedViewsTypeCheck
-      :: Seq (U.View' TypeCheckedOp) -> U.View' TypeCheckedOp -> TCError -> TypeCheck a
+      :: Seq (U.View' (TypeCheckedOp op)) -> U.View' (TypeCheckedOp op) -> TcError' op -> TypeCheck op a
     onFailedViewsTypeCheck processedViews v err = do
       verbose <- asks' tcVerbose
       throwError if verbose
-        then TCIncompletelyTyped err tcCotract
+        then TcIncompletelyTyped err tcContract
              { U.contractViews = toList (processedViews |> v)
              }
         else err
 
+typeCheckViews
+  :: WellTyped st
+  => U.Contract' (TypeCheckedOp U.ExpandedOp)
+  -> Notes st
+  -> [U.View]
+  -> TypeCheck U.ExpandedOp [SomeView st]
+typeCheckViews = typeCheckViews' typeCheckExpandedOp
+
 -- | Function @typeCheckList@ converts list of Michelson instructions
 -- given in representation from @Morley.Michelson.Type@ module to representation
 -- in strictly typed GADT.
@@ -325,8 +380,8 @@
   :: (SingI inp)
   => [U.ExpandedOp]
   -> HST inp
-  -> TypeCheck (SomeInstr inp)
-typeCheckList = throwingTCError ... typeCheckListNoExcept
+  -> TypeCheck U.ExpandedOp (SomeTcInstr inp)
+typeCheckList = throwingTcError ... typeCheckListNoExcept typeCheckExpandedOp
 
 -- | Function @typeCheckListNoExcept@ converts list of Michelson instructions
 -- given in representation from @Morley.Michelson.Type@ module to representation in a
@@ -335,9 +390,9 @@
 -- Types are checked along the way. It is necessary to embed well typed node as
 -- well as type checking errors into the tree.
 typeCheckListNoExcept
-  :: (SingI inp)
-  => [U.ExpandedOp] -> HST inp -> TypeCheckNoExcept (TypeCheckedSeq inp)
-typeCheckListNoExcept = usingReaderT def ... typeCheckImpl typeCheckInstr
+  :: (SingI inp, IsInstrOp op)
+  => TcInstrBase op -> [op] -> HST inp -> TypeCheckNoExcept op (TypeCheckedSeq op inp)
+typeCheckListNoExcept tcOp = usingReaderT def ... typeCheckImpl tcOp
 
 -- | Function @typeCheckValue@ converts a single Michelson value
 -- given in representation from @Morley.Michelson.Untyped@ module hierarchy to
@@ -354,11 +409,11 @@
 typeCheckValue
   :: forall t. SingI t
   => U.Value
-  -> TypeCheckResult (Value t)
+  -> TypeCheckResult U.ExpandedOp (Value t)
 typeCheckValue value = do
   runTypeCheck (TypeCheckValue (value, demote @t) Nothing) $
     usingReaderT def $
-      typeCheckValImpl Nothing typeCheckInstr value
+      typeCheckValImpl Nothing typeCheckExpandedOp value
 
 -- | Simulates the typechecking behavior of the RPC's @/run_code@ endpoint.
 --
@@ -366,48 +421,62 @@
 -- we check if a big_map exists with that ID.
 -- If it does, and if the big_map's value and key have the expected types, we replace the
 -- big_map ID with the corresponding big_map value.
-typeCheckValueRunCodeCompat :: forall t. SingI t => BigMapFinder -> U.Value -> TypeCheckResult (Value t)
+typeCheckValueRunCodeCompat :: forall t. SingI t => BigMapFinder -> U.Value -> TypeCheckResult U.ExpandedOp (Value t)
 typeCheckValueRunCodeCompat bigMapFinder val =
   runTypeCheck (TypeCheckValue (val, demote @t) (Just bigMapFinder)) $
     usingReaderT def $
-      typeCheckValImpl Nothing typeCheckInstr val
+      typeCheckValImpl Nothing typeCheckExpandedOp val
 
 typeVerifyParameter
   :: SingI t
-  => TcOriginatedContracts -> U.Value -> TypeCheckResult (Value t)
+  => TcOriginatedContracts -> U.Value -> TypeCheckResult U.ExpandedOp (Value t)
 typeVerifyParameter originatedContracts = typeVerifyTopLevelType (Just originatedContracts)
 
 typeVerifyStorage
   :: SingI t
-  => U.Value -> TypeCheckResult (Value t)
-typeVerifyStorage = typeVerifyTopLevelType Nothing
+  => U.Value -> TypeCheckResult U.ExpandedOp (Value t)
+typeVerifyStorage = typeVerifyStorage' typeCheckExpandedOp
 
+typeVerifyStorage'
+  :: (SingI t, IsInstrOp op)
+  => TcInstrBase op -> U.Value' op -> TypeCheckResult op (Value t)
+typeVerifyStorage' tcOp = typeVerifyTopLevelType' tcOp Nothing
+
 typeVerifyTopLevelType
   :: forall t. SingI t
-  => Maybe TcOriginatedContracts -> U.Value -> TypeCheckResult (Value t)
-typeVerifyTopLevelType mOriginatedContracts valueU =
+  => Maybe TcOriginatedContracts -> U.Value -> TypeCheckResult U.ExpandedOp (Value t)
+typeVerifyTopLevelType = typeVerifyTopLevelType' typeCheckExpandedOp
+
+typeVerifyTopLevelType'
+  :: forall t op. (SingI t, IsInstrOp op)
+  => TcInstrBase op -> Maybe TcOriginatedContracts -> U.Value' op -> TypeCheckResult op (Value t)
+typeVerifyTopLevelType' tcOp mOriginatedContracts valueU =
   runTypeCheck (TypeCheckValue (valueU, demote @t) Nothing) $ usingReaderT def $
-    typeCheckValImpl mOriginatedContracts typeCheckInstr valueU
+    typeCheckValImpl mOriginatedContracts tcOp valueU
 
 -- | Like 'typeCheckValue', but for values to be used as parameter.
 --
 -- 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 -> TypeCheckResult SomeValue
+  :: TcOriginatedContracts -> U.Ty -> U.Value -> TypeCheckResult U.ExpandedOp SomeValue
 typeCheckParameter originatedContracts = typeCheckTopLevelType (Just originatedContracts)
 
 -- | Like 'typeCheckValue', but for values to be used as storage.
 typeCheckStorage
-  :: U.Ty -> U.Value -> TypeCheckResult SomeValue
+  :: U.Ty -> U.Value -> TypeCheckResult U.ExpandedOp SomeValue
 typeCheckStorage = typeCheckTopLevelType Nothing
 
 typeCheckTopLevelType
-  :: Maybe TcOriginatedContracts -> U.Ty -> U.Value -> TypeCheckResult SomeValue
-typeCheckTopLevelType mOriginatedContracts typeU valueU =
-  withSomeSing (fromUType typeU) $ \(s :: Sing t) ->
-    withSingI s $ SomeValue <$> typeVerifyTopLevelType @t mOriginatedContracts valueU
+  :: Maybe TcOriginatedContracts -> U.Ty -> U.Value -> TypeCheckResult U.ExpandedOp SomeValue
+typeCheckTopLevelType = typeCheckTopLevelType' typeCheckExpandedOp
 
+typeCheckTopLevelType'
+  :: IsInstrOp op
+  => TcInstrBase op -> Maybe TcOriginatedContracts -> U.Ty -> U.Value' op -> TypeCheckResult op SomeValue
+typeCheckTopLevelType' tcOp mOriginatedContracts (AsUType (_ :: Notes t)) valueU =
+  SomeValue <$> typeVerifyTopLevelType' @t tcOp mOriginatedContracts valueU
+
 -- | Helper data type we use to typecheck DUPN.
 data TCDupNHelper inp where
   TCDupNHelper ::
@@ -479,18 +548,17 @@
 -- | Helper function to convert a simple throwing typechecking action into a
 -- non-throwing one, embedding possible errors into the type checking tree.
 workOnInstr
-  :: U.ExpandedInstr
-  -> TypeCheckInstr (SomeInstr s)
-  -> TypeCheckInstrNoExcept (TypeCheckedSeq s)
+  :: IsInstrOp op
+  => U.InstrAbstract op
+  -> TypeCheckInstr op (SomeTcInstr s)
+  -> TypeCheckInstrNoExcept op (TypeCheckedSeq op s)
 workOnInstr instr = tcEither
-  (\err -> pure $ IllTypedSeq err [NonTypedInstr $ U.PrimEx instr])
+  (\err -> pure $ IllTypedSeq err [NonTypedInstr $ liftInstr instr])
   (pure . WellTypedSeq)
 
--- | Less verbose version of `typeCheckImpl typeCheckInstr`.
-tcList
-  :: (SingI inp)
-  => [U.ExpandedOp] -> HST inp -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)
-tcList = typeCheckImpl typeCheckInstr
+-- | Alias for 'typeCheckImpl'.
+tcList :: IsInstrOp op => TcInstrBase op -> TcInstr op [op]
+tcList = typeCheckImpl
 
 -- | Function @typeCheckInstr@ converts a single Michelson instruction
 -- given in representation from @Morley.Michelson.Type@ module to representation
@@ -505,10 +573,10 @@
 -- If there was no match on a given pair of instruction and input stack,
 -- that is interpreted as input of wrong type and type check finishes with
 -- error.
-typeCheckInstr :: TcInstrHandler
-typeCheckInstr uInstr inp = case (uInstr, inp) of
+typeCheckInstr :: forall op. IsInstrOp op => TcInstrBase op -> TcInstr op (U.InstrAbstract op)
+typeCheckInstr tcOp uInstr inp = case (uInstr, inp) of
   (U.EXT ext, si) ->
-    typeCheckExt typeCheckInstr ext si
+    typeCheckExt tcOp ext si
 
   (U.DROP, _ ::& rs) -> workOnInstr uInstr $ pure $ inp :/ DROP ::: rs
 
@@ -521,7 +589,7 @@
       go :: forall inp. SingI inp
         => Word
         -> HST inp
-        -> TypeCheckInstr (TCDropHelper inp)
+        -> TypeCheckInstr op (TCDropHelper inp)
       go = curry \case
         (0, i) -> pure (TCDropHelper Zero i)
 
@@ -544,15 +612,15 @@
       go :: forall inp. SingI inp
         => Word
         -> HST inp
-        -> TypeCheckInstr (TCDupNHelper inp)
+        -> TypeCheckInstr op (TCDupNHelper inp)
       go = curry \case
         (_, SNil) -> notEnoughItemsOnStack'
 
         (0, _) ->
-          typeCheckInstrErr' uInstr (SomeHST inp) Nothing (InvalidInstruction uInstr "'DUP n' expects n > 0")
+          typeCheckInstrErr' uInstr (SomeHST inp) Nothing (InvalidInstruction (void uInstr) "'DUP n' expects n > 0")
 
         -- Don't bind whatever variable annotation is here because DUP n doesn't
-        -- duplicate variable annotations. This is consistent with tezos-client.
+        -- duplicate variable annotations. This is consistent with @octez-client@.
         (1, i@((an :: SingT a, dict) ::& _)) -> do
           Dict <-
             onScopeCheckInstrErr @a uInstr (SomeHST inp) Nothing $
@@ -574,7 +642,7 @@
       go :: forall inp. SingI inp
         => Word
         -> HST inp
-        -> TypeCheckInstr (TCDigHelper inp)
+        -> TypeCheckInstr op (TCDigHelper inp)
       go = curry \case
         -- Even 'DIG 0' is invalid on empty stack (so it is not strictly `Nop`).
         (_, SNil) -> notEnoughItemsOnStack'
@@ -591,7 +659,7 @@
       go :: forall inp. SingI inp
         => Word
         -> HST inp
-        -> TypeCheckInstr (TCDugHelper inp)
+        -> TypeCheckInstr op (TCDugHelper inp)
       go = curry \case
         (0, i@(_ ::& _)) -> pure (TCDugHelper Zero i)
 
@@ -608,7 +676,7 @@
     withUType mt $ \(nt :: Notes t) -> do
       -- Locally switch 'TypeCheckMode' to 'TypeCheckValue'.
       val <- local' (tcModeL .~ TypeCheckValue (mval, demote @t) Nothing) $
-        typeCheckValImpl @t Nothing typeCheckInstr mval
+        typeCheckValImpl @t Nothing tcOp mval
 
       proofScope <- onScopeCheckInstrErr @t uInstr (SomeHST i) Nothing
         $ checkScope @(ConstantScope t)
@@ -634,7 +702,7 @@
 
   (U.IF_NONE mp mq, (STOption (asing :: SingT a), Dict) ::& rs) ->
     withWTPInstr' @a $
-      genericIf IF_NONE U.IF_NONE mp mq rs ((asing, Dict) ::& rs) inp
+      genericIf tcOp IF_NONE U.IF_NONE mp mq rs ((asing, Dict) ::& rs) inp
 
   (U.IF_NONE _ _, _ ::& _) ->
     failWithErr $ UnexpectedType $ ("option 'a" :| []) :| []
@@ -663,11 +731,11 @@
     go nTotal inp <&> \case
       TCPairNHelper s out -> inp :/ AnnPAIRN (Anns1 varAnn) s ::: out
     where
-      go :: forall inp. Word -> HST inp -> TypeCheckInstr (TCPairNHelper inp)
+      go :: forall inp. Word -> HST inp -> TypeCheckInstr op (TCPairNHelper inp)
       go n hst
         | n < 2 =
             typeCheckInstrErr' uInstr (SomeHST inp) Nothing
-              (InvalidInstruction uInstr "'PAIR n' expects n ≥ 2")
+              (InvalidInstruction (void uInstr) "'PAIR n' expects n ≥ 2")
         | n == 2 =
             case hst of
               (an :: SingT a, _) ::& (bn :: SingT b, _) ::& hstTail -> do
@@ -691,11 +759,11 @@
       TCUnpairNHelper s out ->
         inp :/ UNPAIRN s ::: out
     where
-      go :: forall x xs. Word -> HST (x : xs) -> TypeCheckInstr (TCUnpairNHelper (x : xs))
+      go :: forall x xs. Word -> HST (x : xs) -> TypeCheckInstr op (TCUnpairNHelper (x : xs))
       go n hst
         | n < 2 =
             typeCheckInstrErr' uInstr (SomeHST inp) Nothing
-              (InvalidInstruction uInstr "UNPAIR expects an argument of at least 2.")
+              (InvalidInstruction (void uInstr) "UNPAIR expects an argument of at least 2.")
         | n == 2 =
             case hst of
               (STPair aT bT, Dict) ::& rest -> do
@@ -713,7 +781,7 @@
                       (aT, Dict) ::& out
               _ -> unexpectedType
 
-      unexpectedType :: TypeCheckInstr a
+      unexpectedType :: TypeCheckInstr op a
       unexpectedType = failWithErr' $ UnexpectedType $ (pairWithElems nTotal :| []) :| []
 
   (U.CAR vn fn, (STPair lt _, Dict) ::& rs) -> workOnInstr uInstr $
@@ -755,7 +823,7 @@
           let
             ait = (lt, Dict) ::& rs
             bit = (rt, Dict) ::& rs
-          genericIf IF_LEFT U.IF_LEFT mp mq ait bit inp
+          genericIf tcOp IF_LEFT U.IF_LEFT mp mq ait bit inp
 
   (U.IF_LEFT _ _, _ ::& _) ->
     failWithErr $ UnexpectedType $ ("or 'a 'b" :| []) :| []
@@ -779,7 +847,7 @@
   (U.IF_CONS mp mq, (ns@(STList (an :: SingT t1)), Dict) ::& rs) -> do
     withWTPInstr' @t1 $ do
       let ait = (an, Dict) ::& (ns, Dict) ::& rs
-      genericIf IF_CONS U.IF_CONS mp mq ait rs inp
+      genericIf tcOp IF_CONS U.IF_CONS mp mq ait rs inp
 
   (U.IF_CONS _ _, _ ::& _) ->
     failWithErr $ UnexpectedType $ ("list 'a" :| []) :| []
@@ -824,17 +892,17 @@
 
   (U.MAP vn mp, (STList (vns :: SingT t1), Dict) ::& _) -> withSingI vns $ do
     withWTPInstr' @t1 $
-      mapImpl (U.MAP vn) vns vn uInstr mp inp
+      mapImpl tcOp (U.MAP vn) vns vn uInstr mp inp
         (\(rn :: SingT t) hst -> withWTPInstr @t $ pure $ (STList rn, Dict) ::& hst)
 
   (U.MAP vn mp, (STOption (vns :: SingT t1), Dict) ::& _) -> withSingI vns $ do
     withWTPInstr' @t1 $
-      mapImpl (U.MAP vn) vns vn uInstr mp inp
+      mapImpl tcOp (U.MAP vn) vns vn uInstr mp inp
         (\(rn :: SingT t) hst -> withWTPInstr @t $ pure $ (STOption rn, Dict) ::& hst)
 
   (U.MAP vn mp, (STMap (k :: SingT k) (v :: SingT v1), Dict) ::& _) -> withSingI k $ withSingI v $ do
     withWTPInstr' @('TPair k v1) $
-      mapImpl (U.MAP vn) (STPair k v) vn uInstr mp inp
+      mapImpl tcOp (U.MAP vn) (STPair k v) vn uInstr mp inp
           (\(rn :: SingT v) hst -> withWTPInstr @('TMap k v) $ pure $ (STMap k rn, Dict) ::& hst)
 
   (U.MAP _ _, _ ::& _) ->
@@ -848,14 +916,14 @@
 
   (U.ITER is, (STSet (s :: Sing t1), _) ::& _) -> withSingI s $ do
     withWTPInstr' @t1 $
-      iterImpl s uInstr is inp
+      iterImpl tcOp s uInstr is inp
 
   (U.ITER is, (STList (l :: Sing t1), _) ::& _) -> withSingI l $ do
     withWTPInstr' @t1 $
-      iterImpl l uInstr is inp
+      iterImpl tcOp l uInstr is inp
 
   (U.ITER is, (STMap (k :: SingT a) (v :: SingT b), _) ::& _) -> withSingI k $ withSingI v $ do
-    withWTPInstr' @('TPair a b) $ iterImpl (STPair k v) uInstr is inp
+    withWTPInstr' @('TPair a b) $ iterImpl tcOp (STPair k v) uInstr is inp
 
   (U.ITER _, _ ::& _) ->
     failWithErr $ UnexpectedType
@@ -909,7 +977,7 @@
       TCGetNHelper s out ->
         inp :/ AnnGETN (Anns1 getNVarAnn) s ::: out
     where
-      go :: forall x xs. Word -> HST (x : xs) -> TypeCheckInstr (TCGetNHelper (x : xs))
+      go :: forall x xs. Word -> HST (x : xs) -> TypeCheckInstr op (TCGetNHelper (x : xs))
       go 0 ((a, Dict) ::& rest) =
         pure $ TCGetNHelper Zero ((a, Dict) ::& rest)
       go 1 ((STPair leftNotes _, Dict) ::& rest) =
@@ -943,7 +1011,7 @@
       TCUpdateNHelper s out ->
         inp :/ AnnUPDATEN (Anns1 updateNVarAnn) s ::: out
     where
-      go :: forall val pair rest. Word -> HST (val : pair : rest) -> TypeCheckInstr (TCUpdateNHelper (val : pair : rest))
+      go :: forall val pair rest. Word -> HST (val : pair : rest) -> TypeCheckInstr op (TCUpdateNHelper (val : pair : rest))
       go 0 ((valNotes, Dict) ::& (_, _) ::& rest) =
         pure $ TCUpdateNHelper Zero $
           (valNotes, Dict) ::& rest
@@ -976,7 +1044,7 @@
   (U.GET_AND_UPDATE _, _) -> notEnoughItemsOnStack
 
   (U.IF mp mq, (STBool{}, _) ::& rs) ->
-    genericIf IF U.IF mp mq rs rs inp
+    genericIf tcOp IF U.IF mp mq rs rs inp
 
   (U.IF _ _, _ ::& _) ->
     failWithErr $ UnexpectedType $ ("bool" :| []) :| []
@@ -984,7 +1052,7 @@
   (U.IF _ _, SNil) -> notEnoughItemsOnStack
 
   (U.LOOP is, (STBool{}, _) ::& (rs :: HST rs)) -> do
-    preserving (tcList is rs) U.LOOP $ \(_ :/ tp) ->
+    preserving (tcList tcOp is rs) U.LOOP $ \(_ :/ tp) ->
       case tp of
         subI ::: (o :: HST o) -> do
           case eqHST o (sing @'TBool -:& rs) of
@@ -1002,7 +1070,7 @@
   (U.LOOP_LEFT is, (os@(STOr (an :: SingT t) (bn :: SingT b)), Dict) ::& rs) -> do
     withWTPInstr' @t $ withWTPInstr' @b $ do
       let ait = (an, Dict) ::& rs
-      preserving (tcList is ait) U.LOOP_LEFT $ \(_ :/ tp) ->
+      preserving (tcList tcOp is ait) U.LOOP_LEFT $ \(_ :/ tp) ->
         case tp of
           subI ::: o -> do
             case (eqHST o (os -:& rs), o) of
@@ -1024,15 +1092,24 @@
     -- litter our main typechecking logic
     withWTPInstr' @t $
       withWTPInstr' @u $
-        lamImpl (U.LAMBDA vn p1 p2) (Anns3'' vn ins ons) uInstr is (notesSing ins) (notesSing ons) i
+        lamImpl tcOp is (notesSing ins) (notesSing ons)
+          (U.LAMBDA vn p1 p2) (Anns3'' vn ins ons) uInstr i
 
+  (U.LAMBDA_REC vn p1@(AsUType (ins :: Notes t)) p2@(AsUType (ons :: Notes u)) is, i) -> do
+    -- further processing is extracted into another function just not to
+    -- litter our main typechecking logic
+    withWTPInstr' @t $
+      withWTPInstr' @u $
+        lamRecImpl tcOp is (notesSing ins) (notesSing ons)
+          (U.LAMBDA_REC vn p1 p2) (Anns3'' vn ins ons) uInstr i
+
   (U.EXEC vn, ((_ :: SingT t1), _)
                               ::& ( STLambda (v :: SingT t1') (b :: SingT t2'), _)
                               ::& rs) -> withSingI v $ withSingI b $ workOnInstr uInstr $ do
     Refl <- errM $ eqType @t1 @t1'
     withWTPInstr @t2' $ pure $ inp :/ AnnEXEC (Anns1 vn) ::: ((b, Dict) ::& rs)
       where
-        errM :: (MonadReader TypeCheckInstrEnv m, MonadError TCError m) => Either TCTypeError a -> m a
+        errM :: (MonadReader TypeCheckInstrEnv m, MonadError (TcError' op) m) => Either TcTypeError a -> m a
         errM = onTypeCheckInstrErr uInstr (SomeHST inp) (Just LambdaArgument)
 
   (U.EXEC _, _ ::& _ ::& _) ->
@@ -1060,7 +1137,7 @@
   (U.APPLY _, _) -> notEnoughItemsOnStack
 
   (U.DIP is, a ::& s) -> do
-    typeCheckDipBody U.DIP uInstr is s
+    typeCheckDipBody tcOp U.DIP uInstr is s
       (IllTypedSeq)
       (\subI t -> WellTypedSeq $ inp :/ DIP subI ::: (a ::& t))
 
@@ -1074,15 +1151,15 @@
       go :: forall inp. SingI inp
         => Word
         -> HST inp
-        -> TypeCheckInstrNoExcept (TCDipHelper inp)
+        -> TypeCheckInstrNoExcept op (TCDipHelper op inp)
       go n curHST = case (n, curHST) of
-        (0, _) -> typeCheckDipBody (U.DIPN nTotal) uInstr instructions curHST
+        (0, _) -> typeCheckDipBody tcOp (U.DIPN nTotal) uInstr instructions curHST
           (TCDipHelperErr)
           (TCDipHelperOk Zero)
         (_, SNil) -> do
           pos <- view tcieErrorPos
-          let err = TCFailedOnInstr uInstr (SomeHST inp) pos Nothing (Just NotEnoughItemsOnStack)
-          pure $ TCDipHelperErr err [NonTypedInstr $ U.PrimEx uInstr]
+          let err = TcFailedOnInstr uInstr (SomeHST inp) pos Nothing (Just NotEnoughItemsOnStack)
+          pure $ TCDipHelperErr err [NonTypedInstr $ liftInstr uInstr]
         (_, hstHead ::& hstTail) ->
           go (n - 1) hstTail <&> \case
           TCDipHelperOk s subI out -> TCDipHelperOk (Succ s) subI (hstHead ::& out)
@@ -1101,7 +1178,7 @@
       withWTPInstr @t $
         pure $ inp :/ AnnCAST (Anns2' vn castToNotes) ::: ((notesSing castToNotes, Dict) ::& rs)
     where
-      errM :: (MonadReader TypeCheckInstrEnv m, MonadError TCError m) => Either TCTypeError a -> m a
+      errM :: (MonadReader TypeCheckInstrEnv m, MonadError (TcError' op) m) => Either TcTypeError a -> m a
       errM = onTypeCheckInstrErr uInstr (SomeHST inp) (Just Cast)
 
   (U.CAST _ _, _) -> notEnoughItemsOnStack
@@ -1385,7 +1462,7 @@
                   withWTPInstr @('TContract t1) $
                     pure $ inp :/ AnnSELF @arg (Anns1 vn) (SomeEpc epc) ::: ((notesSing ntRes, Dict) ::& inp)
       TypeCheckTest ->
-        failWithErr' $ InvalidInstruction uInstr "'SELF' appears in test typechecking"
+        failWithErr' $ InvalidInstruction (void uInstr) "'SELF' appears in test typechecking"
   (U.CONTRACT vn fn mt, (STAddress{}, _) ::& rs) -> workOnInstr uInstr $
     withUType mt $ \(tns :: Notes t) -> do
       proofScope <- onScopeCheckInstrErr @t uInstr (SomeHST inp) (Just ContractParameter)
@@ -1433,7 +1510,7 @@
     ::& (STMutez{}, _)
     ::& (_ :: SingT g, Dict) ::& rs) -> workOnInstr uInstr $ withNotInView uInstr do
       (SomeContract contr@(Contract _ _ (_ :: Notes st) _ _))
-        <- lift $ typeCheckContractImpl contract
+        <- lift $ doTypeCheckContract' tcOp contract
       Refl <- onTypeCheckInstrErr uInstr (SomeHST inp) (Just ContractStorage) $
         eqType @g @st
       pure
@@ -1559,6 +1636,14 @@
     failWithErr $ UnexpectedType $ ("a'" :| ["nat"]) :| []
   (U.TICKET _, _) -> notEnoughItemsOnStack
 
+  (U.TICKET_DEPRECATED vn, (stVal :: Sing v, _) ::& (STNat{}, _) ::& rs) -> workOnInstr uInstr $
+    withWTPInstr @v $
+    withCompareableCheck stVal uInstr inp $
+      inp :/ AnnTICKET_DEPRECATED (Anns1 vn) ::: ((sing, Dict) ::& rs)
+  (U.TICKET_DEPRECATED _, _ ::& _ ::& _) ->
+    failWithErr $ UnexpectedType $ ("a'" :| ["nat"]) :| []
+  (U.TICKET_DEPRECATED _, _) -> notEnoughItemsOnStack
+
   (U.READ_TICKET vn, ticket@(STTicket{}, Dict) ::& rs) -> workOnInstr uInstr $
       pure $ inp :/ AnnREAD_TICKET (Anns1 vn) ::: ((sing, Dict) ::& ticket ::& rs)
   (U.READ_TICKET _, _ ::& _) ->
@@ -1589,6 +1674,10 @@
       ::& (STNat, Dict)
       ::& rs) ->
       workOnInstr uInstr $ do
+        isStrict <- asks' tcStrict
+        when isStrict $
+          typeCheckInstrErr' uInstr (SomeHST inp) Nothing $
+            InvalidInstruction (void uInstr) "OPEN_CHEST temporarily deprecated"
         pure $ inp :/ AnnOPEN_CHEST (Anns1 vn) ::: (
           (STOr STBytes STBool, Dict)
           ::& rs)
@@ -1611,7 +1700,7 @@
             pure $ inp :/ AnnSAPLING_VERIFY_UPDATE (Anns1 vn) ::: (
               (STOption (STPair STBytes (STPair STInt (STSaplingState s1))), Dict)
               ::& rs)
-          Nothing -> failWithErr' $ InvalidInstruction uInstr
+          Nothing -> failWithErr' $ InvalidInstruction (void uInstr)
             "Memo sizes of two sapling states or transactions do not match."
 
   (U.SAPLING_VERIFY_UPDATE _, _ ::& _ ::& _) ->
@@ -1631,63 +1720,64 @@
         Nothing ->
           pure $ inp :/ AnnEMIT (Anns1 va) tag Nothing ::: ((sing, Dict) ::& rs)
       where
-        errM :: (MonadReader TypeCheckInstrEnv m, MonadError TCError m) => Either TCTypeError a -> m a
+        errM :: (MonadReader TypeCheckInstrEnv m, MonadError (TcError' op) m) => Either TcTypeError a -> m a
         errM = onTypeCheckInstrErr uInstr (SomeHST inp) (Just EmitArgument)
 
   where
     withWTPInstr'
       :: forall t inp. SingI t
-      => (WellTyped t => TypeCheckInstrNoExcept (TypeCheckedSeq inp))
-      -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)
+      => (WellTyped t => TypeCheckInstrNoExcept op (TypeCheckedSeq op inp))
+      -> TypeCheckInstrNoExcept op (TypeCheckedSeq op inp)
     withWTPInstr' = withWTPInstr'_ @t uInstr (SomeHST inp)
 
     withWTPInstr
-      :: forall t a. SingI t => (WellTyped t => TypeCheckInstr a) -> TypeCheckInstr a
+      :: forall t a. SingI t => (WellTyped t => TypeCheckInstr op a) -> TypeCheckInstr op a
     withWTPInstr = withWTPInstr_ @t uInstr (SomeHST inp)
 
-    failWithErr :: TCTypeError -> TypeCheckInstrNoExcept (TypeCheckedSeq a)
+    failWithErr :: TcTypeError -> TypeCheckInstrNoExcept op (TypeCheckedSeq op a)
     failWithErr = workOnInstr uInstr . failWithErr'
 
-    failWithErr' :: TCTypeError -> TypeCheckInstr a
+    failWithErr' :: TcTypeError -> TypeCheckInstr op a
     failWithErr' = typeCheckInstrErr' uInstr (SomeHST inp) Nothing
 
-    notEnoughItemsOnStack :: TypeCheckInstrNoExcept (TypeCheckedSeq a)
+    notEnoughItemsOnStack :: TypeCheckInstrNoExcept op (TypeCheckedSeq op a)
     notEnoughItemsOnStack = failWithErr NotEnoughItemsOnStack
 
-    notEnoughItemsOnStack' :: TypeCheckInstr a
+    notEnoughItemsOnStack' :: TypeCheckInstr op a
     notEnoughItemsOnStack' = failWithErr' NotEnoughItemsOnStack
 
-    withNotInView :: U.ExpandedInstr -> (IsNotInView => TypeCheckInstr r) -> TypeCheckInstr r
-    withNotInView instr act = asks' tcMode >>= \case
+    withNotInView :: U.InstrAbstract op -> (IsNotInView => TypeCheckInstr op r) -> TypeCheckInstr op r
+    withNotInView instr act = asks' (tcMode @op) >>= \case
       -- we provide the not-in-view constraint in the isolated mode
       TypeCheckTest -> giveNotInView act
       _ -> view tcieNotInView >>= \case
         Just Dict -> act
         Nothing -> failWithErr' $
-          InvalidInstruction instr "This instruction cannot be used on the top level of a view"
+          InvalidInstruction (void instr) "This instruction cannot be used on the top level of a view"
 
 -- | Helper function for two-branch if where each branch is given a single
 -- value.
 genericIf
-  :: forall bti bfi cond rs .
-    (SingI bti, SingI bfi)
-  => (forall s'.
+  :: forall bti bfi cond rs op .
+    (SingI bti, SingI bfi, IsInstrOp op)
+  => TcInstrBase op
+  -> (forall s'.
         Instr bti s' ->
         Instr bfi s' ->
         Instr (cond ': rs) s'
      )
-  -> (forall op. [op] -> [op] -> U.InstrAbstract op)
-  -> [U.ExpandedOp]
-  -> [U.ExpandedOp]
+  -> (forall op1. [op1] -> [op1] -> U.InstrAbstract op1)
+  -> [op]
+  -> [op]
   -> HST bti
   -> HST bfi
   -> HST (cond ': rs)
-  -> TypeCheckInstrNoExcept (TypeCheckedSeq (cond ': rs))
-genericIf cons mCons mbt mbf bti bfi i@(_ ::& _) = do
+  -> TypeCheckInstrNoExcept op (TypeCheckedSeq op (cond ': rs))
+genericIf tcOp cons mCons mbt mbf bti bfi i@(_ ::& _) = do
   let cons1 opsT = mCons opsT (map (IllTypedOp . NonTypedInstr) mbf)
-  preserving' (tcList mbt bti) cons1 $ \tInstr@(_ :/ pinstr) -> do
+  preserving' (tcList tcOp mbt bti) cons1 $ \tInstr@(_ :/ pinstr) -> do
     let cons2 opsF = mCons [someInstrToOp tInstr] opsF
-    preserving (tcList mbf bfi) cons2 $ \(_ :/ qinstr) -> do
+    preserving (tcList tcOp mbf bfi) cons2 $ \(_ :/ qinstr) -> do
       fmap (i :/) $ case (pinstr, qinstr) of
         (p ::: po, q ::: qo) -> do
           let instr = mCons mbt mbf
@@ -1702,22 +1792,24 @@
           pure $ AnyOutInstr (cons p q)
 
 mapImpl
-  :: forall c rs.
+  :: forall c rs op.
     ( MapOp c
     , WellTyped (MapOpInp c)
     , SingIOne (MapOpRes c)
+    , IsInstrOp op
     )
-  => ([TypeCheckedOp] -> TypeCheckedInstr)
+  => TcInstrBase op
+  -> ([TypeCheckedOp op] -> TypeCheckedInstr op)
   -> SingT (MapOpInp c)
   -> VarAnn
-  -> U.ExpandedInstr
-  -> [U.ExpandedOp]
+  -> U.InstrAbstract op
+  -> [op]
   -> HST (c ': rs)
   -> (forall v'. (SingI v') =>
-        SingT v' -> HST rs -> TypeCheckInstr (HST (MapOpRes c v' ': rs)))
-  -> TypeCheckInstrNoExcept (TypeCheckedSeq (c ': rs))
-mapImpl cons vn anns instr mp i@(_ ::& rs) mkRes = do
-  preserving (tcList mp ((vn, Dict) ::& rs)) cons $ \(_ :/ subp) ->
+        SingT v' -> HST rs -> TypeCheckInstr op (HST (MapOpRes c v' ': rs)))
+  -> TypeCheckInstrNoExcept op (TypeCheckedSeq op (c ': rs))
+mapImpl tcOp cons vn anns instr mp i@(_ ::& rs) mkRes = do
+  preserving (tcList tcOp mp ((vn, Dict) ::& rs)) cons $ \(_ :/ subp) ->
     case subp of
       sub ::: subo ->
         case subo of
@@ -1731,20 +1823,22 @@
         typeCheckInstrErr' instr (SomeHST i) (Just Iteration) CodeAlwaysFails
 
 iterImpl
-  :: forall c rs .
+  :: forall c rs op .
     ( IterOp c
     , WellTyped (IterOpEl c)
+    , IsInstrOp op
     )
-  => SingT (IterOpEl c)
-  -> U.ExpandedInstr
-  -> [U.ExpandedOp]
+  => TcInstrBase op
+  -> SingT (IterOpEl c)
+  -> U.InstrAbstract op
+  -> [op]
   -> HST (c ': rs)
-  -> TypeCheckInstrNoExcept (TypeCheckedSeq (c ': rs))
-iterImpl en instr mp i@((_, _) ::& rs) = do
+  -> TypeCheckInstrNoExcept op (TypeCheckedSeq op (c ': rs))
+iterImpl tcOp en instr mp i@((_, _) ::& rs) = do
   let tcAction = case mp of
         [] -> workOnInstr instr
           (typeCheckInstrErr' instr (SomeHST i) (Just Iteration) EmptyCode)
-        _ -> typeCheckImpl typeCheckInstr mp ((en, Dict) ::& rs)
+        _ -> typeCheckImpl tcOp mp ((en, Dict) ::& rs)
   preserving tcAction U.ITER $ \(_ :/ subp) -> case subp of
     subI ::: o -> do
       Refl <- onTypeCheckInstrErr instr (SomeHST i) (Just Iteration) $ eqHST o rs
@@ -1752,24 +1846,56 @@
     AnyOutInstr subI ->
       pure $ i :/ ITER subI ::: rs
 
+type LamTC it ot ts op
+  =  [op]
+  -> SingT it
+  -> SingT ot
+  ->  ([TypeCheckedOp op] -> TypeCheckedInstr op)
+  -> Anns '[VarAnn, Notes it, Notes ot]
+  -> U.InstrAbstract op
+  -> HST ts
+  -> TypeCheckInstrNoExcept op (TypeCheckedSeq op ts)
+
 lamImpl
-  :: forall it ot ts .
+  :: forall it ot ts op .
     ( WellTyped it, WellTyped ot
     , SingI ts
+    , IsInstrOp op
     )
-  => ([TypeCheckedOp] -> TypeCheckedInstr)
-  -> Anns '[VarAnn, Notes it, Notes ot]
-  -> U.ExpandedInstr
-  -> [U.ExpandedOp]
-  -> SingT it
-  -> SingT ot
-  -> HST ts
-  -> TypeCheckInstrNoExcept (TypeCheckedSeq ts)
-lamImpl cons anns instr is ins ons i =
+  => TcInstrBase op
+  -> LamTC it ot ts op
+lamImpl tcOp is ins = lamCommon AnnLAMBDA
+  (giveNotInView $ local (set tcieNotInView $ Just Dict) $ tcList tcOp is ((ins, Dict) ::& SNil))
+  is ins
+
+lamRecImpl
+  :: forall it ot ts op .
+    ( WellTyped it, WellTyped ot
+    , SingI ts
+    , IsInstrOp op
+    )
+  => TcInstrBase op
+  -> LamTC it ot ts op
+lamRecImpl tcOp is ins ons = lamCommon AnnLAMBDA_REC
+  (giveNotInView $
+      local (set tcieNotInView $ Just Dict) $
+        tcList tcOp is ((ins, Dict) ::& (STLambda ins ons, Dict) ::& SNil))
+  is ins ons
+
+lamCommon
+  :: forall it ot ts op inp .
+    ( WellTyped it, WellTyped ot
+    , SingI ts
+    , IsInstrOp op
+    )
+  => (Anns '[VarAnn, Notes it, Notes ot] -> RemFail Instr inp '[ot] -> Instr ts ('TLambda it ot : ts))
+  -> TypeCheckInstrNoExcept op (TypeCheckedSeq op inp)
+  -> LamTC it ot ts op
+lamCommon tyCon tcInstr is ins ons cons anns instr i =
   guarding_ instr
     (whenJust (getFirst $ foldMap hasSelf is) $ \selfInstr -> do
-      let err = InvalidInstruction selfInstr "SELF instruction cannot be used in a LAMBDA"
-      typeCheckInstrErr' instr (SomeHST i) (Just LambdaCode) err) $
+      let err = InvalidInstruction (void selfInstr) "SELF instruction cannot be used in a LAMBDA"
+      typeCheckInstrErr' instr (SomeHST i) (Just LambdaCodeCtx) err) $
     preserving tcInstr cons $ \(_ :/ lamI) -> do
       let lamNotes onsr = STLambda ins onsr
       let lamSt onsr = (lamNotes onsr, Dict) ::& i
@@ -1777,44 +1903,67 @@
         lam ::: lo -> do
           case eqHST1 @ot lo of
             Right Refl -> do
-                pure (AnnLAMBDA anns (VLam $ RfNormal lam) ::: lamSt ons)
-            Left m -> typeCheckInstrErr' instr (SomeHST i) (Just LambdaCode) m
+                pure (tyCon anns (RfNormal lam) ::: lamSt ons)
+            Left m -> typeCheckInstrErr' instr (SomeHST i) (Just LambdaCodeCtx) m
         AnyOutInstr lam ->
-          pure (AnnLAMBDA anns (VLam $ RfAlwaysFails lam) ::: lamSt ons)
+          pure (tyCon anns (RfAlwaysFails lam) ::: lamSt ons)
   where
-    tcInstr = giveNotInView $ local (set tcieNotInView $ Just Dict) $ tcList is ((ins, Dict) ::& SNil)
-    hasSelf :: U.ExpandedOp -> First U.ExpandedInstr
+    hasSelf :: op -> First (U.InstrAbstract op)
     hasSelf = everything (<>)
       (mkQ (First Nothing)
        (\case
-           selfInstr@(U.SELF{} :: U.InstrAbstract U.ExpandedOp) -> First $ Just selfInstr
+           selfInstr@(U.SELF{} :: U.InstrAbstract op) -> First $ Just selfInstr
            _ -> First Nothing
        )
       )
 
+typeCheckExpandedOp :: TcInstrBase U.ExpandedOp
+typeCheckExpandedOp = \case
+  U.WithSrcEx _ op@U.WithSrcEx{} -> typeCheckExpandedOp op
+  U.WithSrcEx loc (U.PrimEx op)  -> typeCheckPrimWithLoc loc op
+  U.WithSrcEx loc (U.SeqEx sq)   -> typeCheckSeqWithLoc loc sq
+  U.PrimEx op                    -> typeCheckPrim op
+  U.SeqEx sq                     -> typeCheckSeq sq
+  where
+    -- If we know source location from the untyped instruction, keep it in the typed one.
+    typeCheckPrimWithLoc :: ErrorSrcPos -> TcInstr U.ExpandedOp U.ExpandedInstr
+    typeCheckPrimWithLoc loc op hst = local (set tcieErrorPos loc)
+      (wrapWithLoc loc <$> typeCheckPrim op hst)
+
+    typeCheckPrim :: TcInstr U.ExpandedOp U.ExpandedInstr
+    typeCheckPrim = typeCheckInstr typeCheckExpandedOp
+
+    typeCheckSeqWithLoc :: ErrorSrcPos -> TcInstr U.ExpandedOp [U.ExpandedOp]
+    typeCheckSeqWithLoc loc op = fmap (wrapWithLoc loc) . local (set tcieErrorPos loc) . typeCheckSeq op
+
+    typeCheckSeq :: TcInstr U.ExpandedOp [U.ExpandedOp]
+    typeCheckSeq sq hst = typeCheckImpl typeCheckExpandedOp sq hst
+                      <&> mapSeq (mapSomeInstr Nested)
+
 ----------------------------------------------------------------------------
 -- Helpers for DIP (n) typechecking
 ----------------------------------------------------------------------------
 
 -- Helper data type we use to typecheck DIPN.
-data TCDipHelper inp where
+data TCDipHelper op inp where
   TCDipHelperOk ::
-    forall (n :: Peano) inp out s s'.
+    forall (n :: Peano) inp out s s' op.
     (SingI out, ConstraintDIPN n inp out s s') =>
-    PeanoNatural n -> Instr s s' -> HST out -> TCDipHelper inp
-  TCDipHelperErr :: TCError -> [IllTypedInstr] -> TCDipHelper inp
+    PeanoNatural n -> Instr s s' -> HST out -> TCDipHelper op inp
+  TCDipHelperErr :: TcError' op -> [IllTypedInstr op] -> TCDipHelper op inp
 
 typeCheckDipBody
-  :: SingI inp
-  => ([TypeCheckedOp] -> TypeCheckedInstr)
-  -> U.ExpandedInstr
-  -> [U.ExpandedOp]
+  :: (SingI inp, IsInstrOp op)
+  => TcInstrBase op
+  -> ([TypeCheckedOp op] -> TypeCheckedInstr op)
+  -> U.InstrAbstract op
+  -> [op]
   -> HST inp
-  -> (TCError -> [IllTypedInstr] -> r)
+  -> (TcError' op -> [IllTypedInstr op] -> r)
   -> (forall out. SingI out => Instr inp out -> HST out -> r)
-  -> TypeCheckInstrNoExcept r
-typeCheckDipBody cons mainInstr instructions inputHST onErr onOk = do
-  listRes <- tcList instructions inputHST
+  -> TypeCheckInstrNoExcept op r
+typeCheckDipBody tcOp cons mainInstr instructions inputHST onErr onOk = do
+  listRes <- tcList tcOp instructions inputHST
   pos <- view tcieErrorPos
   pure $ listRes & tcsEither
     (\tcOps err -> onErr err [SemiTypedInstr $ cons tcOps])
@@ -1825,7 +1974,7 @@
         -- if output stack of code block within @DIP@ occurs to be any, an
         -- error "FAILWITH must be at tail position" is raised.
         -- It is not allowed even in `DIP 0`.
-          let err = TCFailedOnInstr mainInstr
+          let err = TcFailedOnInstr mainInstr
                                     (SomeHST inputHST)
                                     pos
                                     (Just DipCode)
diff --git a/src/Morley/Michelson/TypeCheck/TypeCheck.hs b/src/Morley/Michelson/TypeCheck/TypeCheck.hs
--- a/src/Morley/Michelson/TypeCheck/TypeCheck.hs
+++ b/src/Morley/Michelson/TypeCheck/TypeCheck.hs
@@ -2,7 +2,8 @@
 -- SPDX-License-Identifier: LicenseRef-MIT-OA
 
 module Morley.Michelson.TypeCheck.TypeCheck
-  ( TcInstrHandler
+  ( TcInstr
+  , TcInstrBase
   , TcOriginatedContracts
   , TypeCheckEnv(..)
   , BigMapFinder
@@ -16,7 +17,8 @@
   , runTypeCheckIsolated
   , typeCheckingWith
   , liftNoExcept
-  , throwingTCError
+  , throwingTcError
+  , IsInstrOp (..)
   , preserving
   , preserving'
   , guarding
@@ -38,11 +40,13 @@
 import Control.Lens (makeLenses)
 import Control.Monad.Except (Except, MonadError, runExcept, throwError)
 import Data.Constraint (Dict)
+import Data.Data (Data)
 import Data.Default (Default(..))
-import Fmt (Buildable, build, pretty)
+import Data.Singletons (demote)
+import Fmt (Buildable, build)
 
 import Morley.Michelson.ErrorPos (ErrorSrcPos)
-import Morley.Michelson.TypeCheck.Error (TCError(..), TCTypeError(..))
+import Morley.Michelson.TypeCheck.Error (TcError'(..), TcTypeError(..))
 import Morley.Michelson.TypeCheck.TypeCheckedSeq
   (IllTypedInstr(..), TypeCheckedInstr, TypeCheckedOp(..), TypeCheckedSeq(..), someInstrToOp,
   tcsEither)
@@ -55,32 +59,32 @@
 import Morley.Util.MultiReader
 
 -- | Environments avaliable during typecheck.
-type TCEnvs = '[TypeCheckEnv, TypeCheckOptions]
+type TCEnvs op = '[TypeCheckEnv op, TypeCheckOptions]
 
 -- | A full type-check monad carrying intermediary context (via 'TypeCheckEnv'),
--- general 'TypeCheckOptions' and throwing 'TCError'.
-type TypeCheck = MultiReaderT TCEnvs (Except TCError)
+-- general 'TypeCheckOptions' and throwing 'TcError\''.
+type TypeCheck op = MultiReaderT (TCEnvs op) (Except (TcError' op))
 
 -- | A non-throwing alternative for 'TypeCheck'. Mainly meant to be used for
 -- construction of a partially typed tree (see 'TypeCheckedSeq').
-type TypeCheckNoExcept = MultiReaderT TCEnvs Identity
+type TypeCheckNoExcept op = MultiReaderT (TCEnvs op) Identity
 
 -- | 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.
-type TypeCheckResult = ReaderT TypeCheckOptions (Except TCError)
+type TypeCheckResult op = ReaderT TypeCheckOptions (Except (TcError' op))
 
 -- | Environments available during instr typecheck
-type TCInstrEnvs = TypeCheckInstrEnv ': TCEnvs
+type TCInstrEnvs op = TypeCheckInstrEnv ': TCEnvs op
 
 -- | Version of 'TypeCheck' additionally carrying instruction-specific
 -- 'TypeCheckInstrEnv'
-type TypeCheckInstr = MultiReaderT TCInstrEnvs (Except TCError)
+type TypeCheckInstr op = MultiReaderT (TCInstrEnvs op) (Except (TcError' op))
 
 -- | Version of 'TypeCheckNoExcept' additionally carrying instruction-specific
 -- 'TypeCheckInstrEnv'
-type TypeCheckInstrNoExcept = MultiReaderT TCInstrEnvs Identity
+type TypeCheckInstrNoExcept op = MultiReaderT (TCInstrEnvs op) Identity
 
 data SomeParamType = forall t. (T.ParameterScope t) =>
   SomeParamType (T.ParamNotes t)
@@ -102,25 +106,22 @@
 someParamToParameterType (SomeParamType T.UnsafeParamNotes{..}) =
   U.ParameterType (T.AsUType pnNotes) pnRootAnn
 
-mkSomeParamType :: U.ParameterType -> Either TCError SomeParamType
-mkSomeParamType (U.ParameterType t ann) =
-  T.withUType t $ \(notescp :: T.Notes t) -> do
-    case T.checkScope @(T.ParameterScope t) of
-      Right T.Dict ->
-        case T.mkParamNotes notescp ann of
-          Right paramNotes -> Right $ SomeParamType paramNotes
-          Left err ->
-            Left $ TCContractError "invalid parameter declaration: " $ Just $ IllegalParamDecl err
-      Left err -> Left $ TCContractError ("Parameter type is invalid: " <> pretty err) Nothing
+mkSomeParamType :: U.ParameterType -> Either TcTypeError SomeParamType
+mkSomeParamType (U.ParameterType (T.AsUType (notescp :: T.Notes t)) ann) = do
+  T.Dict <- T.checkScope @(T.ParameterScope t)
+    & first (UnsupportedTypeForScope (demote @t))
+  paramNotes <- T.mkParamNotes notescp ann
+    & first IllegalParamDecl
+  return $ SomeParamType paramNotes
 
 type TcOriginatedContracts = Map ContractHash SomeParamType
 
 -- | Typechecking mode that tells the type checker whether it is typechecking
 -- contract code in actual contract, lambda, or test.
-data TypeCheckMode
+data TypeCheckMode op
   = TypeCheckValue
     -- ^ We're typechecking a value.
-      (U.Value, T.T)
+      (U.Value' op, T.T)
       (Maybe BigMapFinder)
       -- ^ When this is a `Just`, we simulate the typechecking behavior of the RPC's @/run_code@ endpoint.
       --
@@ -135,8 +136,8 @@
     -- where the instruction @SELF@ would not make sense.
 
 -- | The typechecking state
-data TypeCheckEnv = TypeCheckEnv
-  { tcMode :: ~TypeCheckMode
+data TypeCheckEnv op = TypeCheckEnv
+  { tcMode :: ~(TypeCheckMode op)
   }
 
 type BigMapFinder = Natural -> Maybe SomeVBigMap
@@ -144,13 +145,13 @@
 data TypeCheckOptions = TypeCheckOptions
   { tcVerbose :: Bool
     -- ^ Whether to add stack type comments after every
-    -- instruction a la tezos-client.
+    -- instruction a la @octez-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,
+    -- @octez-client run@'s behaviour can slightly differ from the behaviour
+    -- of @octez-client originate@ and @octez-client transfer@. For instance,
     -- some values can be "forged" in test run, but not in a real one,
     -- see: Note [Tickets forging].
     --
@@ -170,7 +171,7 @@
 makeLensesWith postfixLFields ''TypeCheckEnv
 makeLenses ''TypeCheckInstrEnv
 
-runTypeCheck :: TypeCheckMode -> TypeCheck a -> TypeCheckResult a
+runTypeCheck :: TypeCheckMode op -> TypeCheck op a -> TypeCheckResult op a
 runTypeCheck = usingReaderT . TypeCheckEnv
 
 -- | Run type checker as if it worked isolated from other world -
@@ -181,10 +182,10 @@
 -- 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 (SomeInstr t) -> TypeCheckResult (SomeInstr t)
+runTypeCheckIsolated :: TypeCheck op (SomeTcInstr t) -> TypeCheckResult op (SomeTcInstr t)
 runTypeCheckIsolated = runTypeCheck TypeCheckTest
 
-typeCheckingWith :: TypeCheckOptions -> TypeCheckResult a -> Either TCError a
+typeCheckingWith :: TypeCheckOptions -> TypeCheckResult op a -> Either (TcError' op) a
 typeCheckingWith options = runExcept . usingReaderT options
 
 instance Default TypeCheckInstrEnv where
@@ -196,32 +197,82 @@
   -> ChangeMultiReaderBase m (Except e) a
 liftNoExcept action = mapMultiReaderT (pure @(Except e) . runIdentity) action
 
-throwingTCError
-  :: ( MonadMultiReaderT m Identity
-     , m' ~ ChangeMultiReaderBase m (Except TCError)
-     , MonadError TCError m'
+throwingTcError
+  :: forall op inp m m'.
+     ( MonadMultiReaderT m Identity
+     , m' ~ ChangeMultiReaderBase m (Except (TcError' op))
+     , MonadError (TcError' op) m'
      )
-  => m (TypeCheckedSeq inp) -> m' (SomeInstr inp)
-throwingTCError action = liftNoExcept @_ @TCError action >>= tcsEither (const throwError) (pure)
+  => m (TypeCheckedSeq op inp) -> m' (SomeTcInstr inp)
+throwingTcError action = liftNoExcept @_ @(TcError' op) action >>= tcsEither (const throwError) (pure)
 
 tcEither
-  :: (TCError -> TypeCheckInstrNoExcept a) -- ^ Call this if the action throws
-  -> (b -> TypeCheckInstrNoExcept a) -- ^ Call this if it doesn't
-  -> TypeCheckInstr b -- ^ The action to perform
-  -> TypeCheckInstrNoExcept a -- ^ A non-throwing action
+  :: (TcError' op -> TypeCheckInstrNoExcept op a) -- ^ Call this if the action throws
+  -> (b -> TypeCheckInstrNoExcept op a) -- ^ Call this if it doesn't
+  -> TypeCheckInstr op b -- ^ The action to perform
+  -> TypeCheckInstrNoExcept op a -- ^ A non-throwing action
 tcEither onErr onOk action = either onErr onOk =<< mapMultiReaderT (pure . runExcept) action
 
+-- | Operation types that appear in @AbstractInstr@.
+--
+-- 'Data' superclass constraint is used to search for particular sub-instructions.
+class Data op => IsInstrOp op where
+  -- | Lift a single instruction to operation.
+  --
+  -- This is used only in error messages.
+  liftInstr :: U.InstrAbstract op -> op
+
+  -- | Get callstack at this instruction, if any given.
+  --
+  -- This is used only in error messages.
+  pickErrorSrcPos :: op -> Maybe ErrorSrcPos
+
+  -- | Do our best to re-interpret an instruction as a value.
+  --
+  -- For instance, @{ {}, {} }@ may turn out to be represented both as nested
+  -- @SeqEx@s and as nested @ValueList@ & @ValueNil@s.
+  -- This function, along with 'tryValToOp', let us convert between these
+  -- two forms.
+  --
+  -- TODO [#785]: try to remove these two functions
+  tryOpToVal :: op -> Maybe (U.Value' op)
+
+  -- | Do our best to re-interpret a value as an instruction.
+  --
+  -- This does the opposite to 'tryOpToVal'.
+  --
+  -- If a value is already a lambda, this can return 'Nothing'.
+  tryValToOp :: U.Value' op -> Maybe op
+
+instance IsInstrOp U.ExpandedOp where
+  liftInstr = U.PrimEx
+
+  pickErrorSrcPos = \case
+    U.WithSrcEx cs _ -> Just cs
+    _ -> Nothing
+
+  tryOpToVal = \case
+    U.SeqEx []      -> Just U.ValueNil
+    U.SeqEx xs      -> U.ValueSeq . fromList <$> traverse tryOpToVal xs
+    U.PrimEx {}     -> Nothing
+    U.WithSrcEx _ i -> tryOpToVal i
+
+  tryValToOp = \case
+    U.ValueNil      -> Just $ U.SeqEx []
+    U.ValueSeq xs   -> U.SeqEx . toList <$> traverse tryValToOp xs
+    _               -> Nothing
+
 -- | Perform a throwing action on an acquired instruction. Preserve the acquired
 -- result by embedding it into a type checking tree with a specified parent
 -- instruction.
 preserving
-  :: TypeCheckInstrNoExcept (TypeCheckedSeq inp)
+  :: TypeCheckInstrNoExcept op (TypeCheckedSeq op inp)
   -- ^ Acquiring computation
-  -> ([TypeCheckedOp] -> TypeCheckedInstr)
+  -> ([TypeCheckedOp op] -> TypeCheckedInstr op)
   -- ^ The parent instruction constructor
-  -> (SomeInstr inp -> TypeCheckInstr (SomeInstr inp'))
+  -> (SomeTcInstr inp -> TypeCheckInstr op (SomeTcInstr inp'))
   -- ^ The throwing action
-  -> TypeCheckInstrNoExcept (TypeCheckedSeq inp')
+  -> TypeCheckInstrNoExcept op (TypeCheckedSeq op inp')
 preserving acquire con action = preserving' acquire con
   (\instr -> action instr & tcEither
     (\err -> pure $ IllTypedSeq err [SemiTypedInstr $ con [someInstrToOp instr]])
@@ -231,13 +282,13 @@
 -- acquired result even if the action does not succeed. Embed the result into a
 -- type checking tree with a specified parent instruction.
 preserving'
-  :: TypeCheckInstrNoExcept (TypeCheckedSeq inp)
+  :: TypeCheckInstrNoExcept op (TypeCheckedSeq op inp)
   -- ^ Acquiring computation
-  -> ([TypeCheckedOp] -> TypeCheckedInstr)
+  -> ([TypeCheckedOp op] -> TypeCheckedInstr op)
   -- ^ The parent instruction constructor
-  -> (SomeInstr inp -> TypeCheckInstrNoExcept (TypeCheckedSeq inp'))
+  -> (SomeTcInstr inp -> TypeCheckInstrNoExcept op (TypeCheckedSeq op inp'))
   -- ^ The action
-  -> TypeCheckInstrNoExcept (TypeCheckedSeq inp')
+  -> TypeCheckInstrNoExcept op (TypeCheckedSeq op inp')
 preserving' acquire con action =
   acquire >>= tcsEither
     (\tcOps err -> pure $ IllTypedSeq err [SemiTypedInstr $ con tcOps])
@@ -247,31 +298,37 @@
 -- otherwise embed the error into a type checking tree along with a specified
 -- untyped instruction.
 guarding
-  :: U.ExpandedInstr -- ^ Untyped instruction
-  -> TypeCheckInstr a -- ^ Acquiring computation
-  -> (a -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)) -- ^ Follow-up action
-  -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)
+  :: IsInstrOp op
+  => U.InstrAbstract op -- ^ Untyped instruction
+  -> TypeCheckInstr op a -- ^ Acquiring computation
+  -> (a -> TypeCheckInstrNoExcept op (TypeCheckedSeq op inp)) -- ^ Follow-up action
+  -> TypeCheckInstrNoExcept op (TypeCheckedSeq op inp)
 guarding instr cond action = do
   cond & tcEither
-    (\err -> pure $ IllTypedSeq err [NonTypedInstr $ U.PrimEx instr])
+    (\err -> pure $ IllTypedSeq err [NonTypedInstr $ liftInstr instr])
     (action)
 
 -- | Same as @guarding@ but doesn't pass an acquired result to a follow-up
 -- action.
 guarding_
-  :: U.ExpandedInstr
-  -> TypeCheckInstr a
-  -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)
-  -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)
+  :: IsInstrOp op
+  => U.InstrAbstract op
+  -> TypeCheckInstr op a
+  -> TypeCheckInstrNoExcept op (TypeCheckedSeq op inp)
+  -> TypeCheckInstrNoExcept op (TypeCheckedSeq op inp)
 guarding_ instr cond action = guarding instr cond (const action)
 
--- pva701: it's really painful to add arguments to TcInstrHandler
--- due to necessity to refactor @typeCheckInstr@.
--- Also functions which are being called from @typeCheckInstr@ would
--- have to be refactored too.
--- Therefore, I am using ReaderT over TypeCheck.
-type TcInstrHandler
+-- | Some type checker function.
+--
+-- It accepts untyped instructions to typecheck as @instr@ value, and @op@ type
+-- stands for the basic operation type like @ExpandedOp@.
+type TcInstr op instr
    = forall inp. (T.SingI inp)
-      => U.ExpandedInstr
+      => instr
       -> HST inp
-      -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)
+      -> TypeCheckInstrNoExcept op (TypeCheckedSeq op inp)
+
+-- | Type checker function for the operation like @ExpandedOp@.
+-- Function of this type we carry in most of the other functions to let
+-- them recurse.
+type TcInstrBase op = TcInstr op op
diff --git a/src/Morley/Michelson/TypeCheck/TypeCheckedOp.hs b/src/Morley/Michelson/TypeCheck/TypeCheckedOp.hs
--- a/src/Morley/Michelson/TypeCheck/TypeCheckedOp.hs
+++ b/src/Morley/Michelson/TypeCheck/TypeCheckedOp.hs
@@ -14,58 +14,59 @@
 import Data.Singletons (SingI)
 
 import Morley.Michelson.Printer.Util (RenderDoc(..), renderOpsListNoBraces)
-import Morley.Michelson.TypeCheck.Types (HST(..), SomeInstr(..), SomeInstrOut(..))
+import Morley.Michelson.TypeCheck.Types (HST(..), SomeTcInstr(..), SomeTcInstrOut(..))
 import Morley.Michelson.Typed.Aliases
 import Morley.Michelson.Typed.Convert (instrToOps)
 import Morley.Michelson.Typed.Instr (Instr, castInstr)
 import Morley.Michelson.Typed.View (SomeView'(..), View'(..))
 import Morley.Michelson.Untyped qualified as U
-import Morley.Michelson.Untyped.Instr (ExpandedOp, InstrAbstract(..))
+import Morley.Michelson.Untyped.Instr (InstrAbstract(..))
 import Morley.Util.TH (deriveGADTNFData)
 
 -- | Represents a root of a partially typed operation tree.
-type TypeCheckedInstr = InstrAbstract TypeCheckedOp
+type TypeCheckedInstr op = InstrAbstract (TypeCheckedOp op)
 
 -- | Represents nodes of a partially typed operation tree.
-data TypeCheckedOp where
+data TypeCheckedOp op where
   -- | Constructs well-typed node.
-  WellTypedOp :: (SingI inp, SingI out) => Instr inp out -> TypeCheckedOp
+  WellTypedOp :: (SingI inp, SingI out) => Instr inp out -> TypeCheckedOp op
   -- | Constructs ill-typed node which might in turn contain well-typed and
   -- non-typed operations.
-  IllTypedOp :: IllTypedInstr -> TypeCheckedOp
+  IllTypedOp :: IllTypedInstr op -> TypeCheckedOp op
 
-deriving stock instance Show TypeCheckedOp
+deriving stock instance Show op => Show (TypeCheckedOp op)
+deriving stock instance Functor TypeCheckedOp
 
-instance Eq TypeCheckedOp where
+instance Eq op => Eq (TypeCheckedOp op) where
   WellTypedOp i1 == WellTypedOp i2 = castInstr i1 == Just i2
   IllTypedOp i1 == IllTypedOp i2 = i1 == i2
   _ == _ = False
 
 -- | Represents a non-well-typed operation
-data IllTypedInstr
-  = SemiTypedInstr TypeCheckedInstr -- ^ Constructs a partialy typed operation.
-  | NonTypedInstr ExpandedOp  -- ^ Constructs a completely untyped operation.
-  deriving stock (Show, Eq, Generic)
+data IllTypedInstr op
+  = SemiTypedInstr (TypeCheckedInstr op) -- ^ Constructs a partialy typed operation.
+  | NonTypedInstr op  -- ^ Constructs a completely untyped operation.
+  deriving stock (Show, Eq, Generic, Functor)
 
-deriving anyclass instance NFData TypeCheckedOp => NFData IllTypedInstr
+deriving anyclass instance (NFData (TypeCheckedOp op), NFData op) => NFData (IllTypedInstr op)
 
-instance RenderDoc TypeCheckedOp where
+instance RenderDoc op => RenderDoc (TypeCheckedOp op) where
   renderDoc _ (WellTypedOp instr) = renderOpsListNoBraces False (instrToOps instr)
   renderDoc pn (IllTypedOp (SemiTypedInstr instr)) = renderDoc pn instr
   renderDoc pn (IllTypedOp (NonTypedInstr op)) = renderDoc pn op
 
--- | Makes a well-typed node out of `SomeInstr`
-someInstrToOp :: SomeInstr inp -> TypeCheckedOp
+-- | Makes a well-typed node out of `SomeTcInstr`
+someInstrToOp :: SomeTcInstr inp -> TypeCheckedOp op
 someInstrToOp (hst :/ rest) = case hst of
   SNil -> go rest
   (::&){} -> go rest
   where
-    go :: forall inp. SingI inp => SomeInstrOut inp -> TypeCheckedOp
+    go :: SingI inp => SomeTcInstrOut inp -> TypeCheckedOp op
     go (i ::: _) = WellTypedOp i
     go (AnyOutInstr i) = WellTypedOp (i @'[])
 
 -- | Makes a view with well-typed code, taking the untyped and typechecked view.
-someViewToOp :: U.View' op -> SomeView st -> U.View' TypeCheckedOp
+someViewToOp :: U.View' op -> SomeView st -> U.View' (TypeCheckedOp op)
 someViewToOp U.View{..} (SomeView View{..}) = U.View
   { U.viewCode = [WellTypedOp vCode]
   , ..
diff --git a/src/Morley/Michelson/TypeCheck/TypeCheckedSeq.hs b/src/Morley/Michelson/TypeCheck/TypeCheckedSeq.hs
--- a/src/Morley/Michelson/TypeCheck/TypeCheckedSeq.hs
+++ b/src/Morley/Michelson/TypeCheck/TypeCheckedSeq.hs
@@ -6,7 +6,7 @@
 --
 -- It is needed to represent the fact that there can only be one well-typed node
 -- in a sequence and it is the first one. Also, it serves its role to remove
--- @TCError@ usage from @TypeCheckedOp@.
+-- @TcError@ usage from @TypeCheckedOp@.
 module Morley.Michelson.TypeCheck.TypeCheckedSeq
   ( TypeCheckedInstr
   , TypeCheckedOp(..)
@@ -18,21 +18,21 @@
   , someViewToOp
   ) where
 
-import Morley.Michelson.TypeCheck.Error (TCError)
+import Morley.Michelson.TypeCheck.Error (TcError')
 import Morley.Michelson.TypeCheck.TypeCheckedOp
   (IllTypedInstr(..), TypeCheckedInstr, TypeCheckedOp(..), someInstrToOp, someViewToOp)
-import Morley.Michelson.TypeCheck.Types (SomeInstr(..))
+import Morley.Michelson.TypeCheck.Types (SomeTcInstr(..))
 
 -- | Represents a partiall typed sequence of instructions.
-data TypeCheckedSeq inp
+data TypeCheckedSeq op inp
   -- | A fully well-typed sequence.
-  = WellTypedSeq (SomeInstr inp)
+  = WellTypedSeq (SomeTcInstr inp)
   -- | A well-typed prefix followed by some error and semi-typed instructions.
-  | MixedSeq (SomeInstr inp) TCError [IllTypedInstr]
+  | MixedSeq (SomeTcInstr inp) (TcError' op) [IllTypedInstr op]
   -- | There is no well-typed prefix, only an error and semi-typed instructions.
-  | IllTypedSeq TCError [IllTypedInstr]
+  | IllTypedSeq (TcError' op) [IllTypedInstr op]
 
-seqToOps :: TypeCheckedSeq inp -> [TypeCheckedOp]
+seqToOps :: TypeCheckedSeq op inp -> [TypeCheckedOp op]
 seqToOps = \case
   WellTypedSeq instr -> [someInstrToOp instr]
   MixedSeq instr _ tail' -> someInstrToOp instr : map IllTypedOp tail'
@@ -40,10 +40,10 @@
 
 -- | Case analysis for @TypeCheckedSeq@.
 tcsEither
-  :: ([TypeCheckedOp] -> TCError -> a)
+  :: ([TypeCheckedOp op] -> TcError' op -> a)
      -- ^ On error, with all already typechecked operations
-  -> (SomeInstr inp -> a) -- ^ On well-typed instruction
-  -> TypeCheckedSeq inp -- ^ The sequence to dispatch on
+  -> (SomeTcInstr inp -> a) -- ^ On well-typed instruction
+  -> TypeCheckedSeq op inp -- ^ The sequence to dispatch on
   -> a
 tcsEither onErr onInstr v = case v of
   WellTypedSeq instr -> onInstr instr
diff --git a/src/Morley/Michelson/TypeCheck/Types.hs b/src/Morley/Michelson/TypeCheck/Types.hs
--- a/src/Morley/Michelson/TypeCheck/Types.hs
+++ b/src/Morley/Michelson/TypeCheck/Types.hs
@@ -5,8 +5,8 @@
     ( HST (..)
     , (-:&)
     , SomeHST (..)
-    , SomeInstrOut (..)
-    , SomeInstr (..)
+    , SomeTcInstrOut (..)
+    , SomeTcInstr (..)
     , BoundVars (..)
     , withWTPm
     , unsafeWithWTP
@@ -109,7 +109,7 @@
 
 -- | This data type keeps part of type check result - instruction and
 -- corresponding output stack.
-data SomeInstrOut inp where
+data SomeTcInstrOut inp where
   -- | Type-check result with concrete output stack, most common case.
   --
   -- Output stack type is wrapped inside the type and @Typeable@
@@ -118,7 +118,7 @@
     :: SingI out
     => Instr inp out
     -> HST out
-    -> SomeInstrOut inp
+    -> SomeTcInstrOut inp
 
   -- | Type-check result which matches against arbitrary output stack.
   -- Information about annotations in the output stack is absent.
@@ -129,37 +129,37 @@
   -- lambda and immediatelly execute it - stack type is known).
   AnyOutInstr
     :: (forall out. Instr inp out)
-    -> SomeInstrOut inp
+    -> SomeTcInstrOut inp
 infix 9 :::
 
-deriving stock instance Show (SomeInstrOut inp)
+deriving stock instance Show (SomeTcInstrOut inp)
 
-instance Buildable (SomeInstrOut inp) where
+instance Buildable (SomeTcInstrOut inp) where
   build (i ::: out) = i |+ " :: " +| build out
   build (AnyOutInstr i) = i |+ " :: *"
 
 -- | Data type keeping the whole type check result: instruction and
 -- type representations of instruction's input and output.
-data SomeInstr inp where
-  (:/) :: HST inp -> SomeInstrOut inp -> SomeInstr inp
+data SomeTcInstr inp where
+  (:/) :: HST inp -> SomeTcInstrOut inp -> SomeTcInstr inp
 infix 8 :/
 
-deriving stock instance Show (SomeInstr inp)
+deriving stock instance Show (SomeTcInstr inp)
 
 mapSomeInstrOut
   :: (forall out. Instr inp out -> Instr inp' out)
-  -> SomeInstrOut inp
-  -> SomeInstrOut inp'
+  -> SomeTcInstrOut inp
+  -> SomeTcInstrOut inp'
 mapSomeInstrOut f (i ::: out) = f i ::: out
 mapSomeInstrOut f (AnyOutInstr i) = AnyOutInstr (f i)
 
 mapSomeInstr
   :: (forall out. Instr inp out -> Instr inp out)
-  -> SomeInstr inp
-  -> SomeInstr inp
+  -> SomeTcInstr inp
+  -> SomeTcInstr inp
 mapSomeInstr f (inp :/ instrAndOut) = inp :/ mapSomeInstrOut f instrAndOut
 
-instance Buildable (SomeInstr inp) where
+instance Buildable (SomeTcInstr inp) where
   build (inp :/ out) = inp |+ " -> " +| build out
 
 mapSomeContract ::
diff --git a/src/Morley/Michelson/TypeCheck/Value.hs b/src/Morley/Michelson/TypeCheck/Value.hs
--- a/src/Morley/Michelson/TypeCheck/Value.hs
+++ b/src/Morley/Michelson/TypeCheck/Value.hs
@@ -17,7 +17,7 @@
 import Prelude hiding (EQ, GT, LT)
 
 import Morley.Michelson.Text
-import Morley.Michelson.TypeCheck.Error (TCError(..), TCTypeError(..))
+import Morley.Michelson.TypeCheck.Error (TcError'(..), TcTypeError(..))
 import Morley.Michelson.TypeCheck.Helpers
 import Morley.Michelson.TypeCheck.TypeCheck
 import Morley.Michelson.TypeCheck.Types
@@ -33,10 +33,10 @@
 import Morley.Tezos.Crypto.Timelock (chestFromBytes, chestKeyFromBytes)
 import Morley.Util.Type (onFirst)
 
-tcFailedOnValue :: U.Value -> T.T -> Text -> Maybe TCTypeError -> TypeCheckInstr a
+tcFailedOnValue :: U.Value' op -> T.T -> Text -> Maybe TcTypeError -> TypeCheckInstr op a
 tcFailedOnValue v t msg err = do
   loc <- view tcieErrorPos
-  throwError $ TCFailedOnValue v t msg loc err
+  throwError $ TcFailedOnValue v t msg loc err
 
 -- | Function @typeCheckValImpl@ converts a single Michelson value
 -- given in representation from @Morley.Michelson.Type@ module to representation
@@ -55,17 +55,17 @@
 -- should contain the originated contracts when typechecking a parameter and
 -- 'Nothing' otherwise.
 typeCheckValImpl
-  :: forall ty.
-     SingI ty
+  :: forall ty op.
+     (SingI ty, IsInstrOp op)
   => Maybe TcOriginatedContracts
-  -> TcInstrHandler
-  -> U.Value
-  -> TypeCheckInstr (T.Value ty)
+  -> TcInstrBase op
+  -> U.Value' op
+  -> TypeCheckInstr op (T.Value ty)
 typeCheckValImpl mOriginatedContracts tcDo uv = doTypeCheckVal (uv, sing @ty)
   where
-    doTypeCheckVal :: forall tz. (U.Value, Sing tz) -> TypeCheckInstr (T.Value tz)
+    doTypeCheckVal :: forall tz. (U.Value' op, Sing tz) -> TypeCheckInstr op (T.Value tz)
     doTypeCheckVal (uvalue, sng) = do
-      typeCheckMode <- asks' tcMode
+      typeCheckMode <- asks' (tcMode @op)
       case (uvalue, sng) of
         (U.ValueInt i, STInt) -> pure $ T.VInt i
         (v@(U.ValueInt i), t@STNat)
@@ -157,8 +157,11 @@
           -- 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
+          -- However @octez-client run@ adds an exception, it allows passing a
           -- manually constructed ticket value as parameter or initial storage.
+          --
+          -- Since protocol lima zero amount tickets are no longer allowed
+          -- event in "lax" mode, so we forbid them here is well. (see !1270)
           True ->
             tcFailedOnValue cv (fromSing sng)
               "ticket values cannot be forged in real operations"
@@ -169,6 +172,9 @@
               dat <- doTypeCheckVal (datV, vt)
               amountValue <- doTypeCheckVal (amV, STNat)
               case (addrValue, amountValue) of
+                (_, VNat 0) ->
+                  tcFailedOnValue cv (fromSing sng) "ticket amount of 0 is not allowed"
+                  Nothing
                 (VAddress (EpAddress' addr ep), VNat am) -> do
                   unless (U.isDefEpName ep) $
                     tcFailedOnValue cv (fromSing sng)
@@ -218,7 +224,7 @@
           instrPos <- view tcieErrorPos
           case T.getComparableProofS s of
             Just Dict -> withSingI s $ pure (T.VSet S.empty)
-            Nothing -> throwError $ TCFailedOnValue uvalue (fromSing s) "Non comparable types are not allowed in Sets"
+            Nothing -> throwError $ TcFailedOnValue uvalue (fromSing s) "Non comparable types are not allowed in Sets"
               instrPos (Just $ UnsupportedTypeForScope (fromSing s) T.BtNotComparable)
 
         (sq@(U.ValueSeq (toList -> mels)), s@(STSet vt)) -> withComparable vt sq s $ do
@@ -226,7 +232,7 @@
 
           els <- typeCheckValsImpl (mels, vt)
           elsS <- liftEither $ S.fromDistinctAscList <$> ensureDistinctAsc id els
-                    `onFirst` \msg -> TCFailedOnValue sq (fromSing vt) msg instrPos Nothing
+                    `onFirst` \msg -> TcFailedOnValue sq (fromSing vt) msg instrPos Nothing
           withSingI vt $ pure $ VSet elsS
 
         (v@U.ValueNil, s@(STMap st vt)) ->
@@ -250,12 +256,12 @@
 
         -- `{ {} }` can be typechecked either as `VLam` or `VList`.
         (U.ValueLambda s, STList l) ->
-          case emptyLambdaAsList s of
-            Just xs -> doTypeCheckVal (xs, sng)
+          case traverse tryOpToVal s of
+            Just xs -> doTypeCheckVal (U.ValueSeq xs, sng)
             Nothing -> tcFailedOnValue uvalue (fromSing l) "" Nothing
 
-        (U.ValueSeq s, STLambda _ _) -> case emptyListAsLambda s of
-          Just xs -> doTypeCheckVal (xs, sng)
+        (U.ValueSeq s, STLambda _ _) -> case traverse tryValToOp s of
+          Just xs -> doTypeCheckVal (U.ValueLambda xs, sng)
           Nothing -> tcFailedOnValue uvalue (fromSing sng) "" Nothing
 
         (v, STLambda (var :: Sing it) (b :: Sing ot)) -> withSingI var $ withSingI b $ do
@@ -264,7 +270,7 @@
             U.ValueLambda mp -> pure $ toList mp
             _ -> tcFailedOnValue v (demote @ty) "unexpected value" Nothing
           _ :/ instr <-
-            withWTP @it uvalue $ throwingTCError $
+            withWTP @it uvalue $ throwingTcError $
               typeCheckImpl
                 -- lambdas can contain operations forbidden inside views, hence
                 -- we invent a "not in view" constraint here.
@@ -282,12 +288,17 @@
             AnyOutInstr lam ->
               pure $ T.mkVLam (T.RfAlwaysFails lam)
 
-        (v@(U.ValueBytes (U.InternalByteString bs)), STChest) ->
+        (v@(U.ValueBytes (U.InternalByteString bs)), STChest) -> do
+          isStrict <- asks' tcStrict
+          when isStrict $ tcFailedOnValue v T.TChest "chest type temporarily deprecated" Nothing
           case chestFromBytes bs of
             Right res -> pure $ VChest res
             Left err -> tcFailedOnValue v T.TChest err Nothing
 
-        (v@(U.ValueBytes (U.InternalByteString bs)), STChestKey) ->
+        (v@(U.ValueBytes (U.InternalByteString bs)), STChestKey) -> do
+          isStrict <- asks' tcStrict
+          when isStrict $
+            tcFailedOnValue v T.TChestKey "chest_key type temporarily deprecated" Nothing
           case chestKeyFromBytes bs of
             Right res -> pure $ VChestKey res
             Left err -> tcFailedOnValue v T.TChestKey err Nothing
@@ -300,49 +311,22 @@
 
         (v, t) -> tcFailedOnValue v (fromSing t) "unknown value" Nothing
 
-    seqToRightCombedPair :: (NonEmpty $ U.Value) -> U.Value
+    seqToRightCombedPair :: (NonEmpty $ U.Value' op) -> U.Value' op
     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
-      -> (T.WellTyped t => TypeCheckInstr a)
-      -> TypeCheckInstr a
+      => U.Value' op
+      -> (T.WellTyped t => TypeCheckInstr op a)
+      -> TypeCheckInstr op a
     withWTP uvalue fn = case T.getWTP @t of
       Right Dict -> fn
       Left err -> tcFailedOnValue uvalue (demote @ty) (pretty err) Nothing
 
     typeCheckValsImpl
-      :: ([U.Value], Sing t)
-      -> TypeCheckInstr [T.Value t]
+      :: ([U.Value' op], Sing t)
+      -> TypeCheckInstr op [T.Value t]
     typeCheckValsImpl (mvs, sng) =
       fmap reverse $ foldM (\res mv -> (: res) <$> (doTypeCheckVal (mv, sng))) [] mvs
 
@@ -351,31 +335,31 @@
     -- It return list of pairs (key, value) with keys in ascending order
     -- so it is safe to call @fromDistinctAscList@ on returned list
     typeCheckMapVal
-      :: [U.Elt U.ExpandedOp]
-      -> U.Value
+      :: [U.Elt op]
+      -> U.Value' op
       -> Sing kt
       -> Sing vt
-      -> TypeCheckInstr [(T.Value kt, T.Value vt)]
+      -> TypeCheckInstr op [(T.Value kt, T.Value vt)]
     typeCheckMapVal mels sq kt vt = withComparable kt sq kt $ do
       instrPos <- view tcieErrorPos
       ks <- typeCheckValsImpl (map (\(U.Elt k _) -> k) mels, kt)
       vals <- typeCheckValsImpl (map (\(U.Elt _ v) -> v) mels, vt)
       ksS <- liftEither $ ensureDistinctAsc id ks
-            `onFirst` \msg -> TCFailedOnValue sq (fromSing kt) msg instrPos Nothing
+            `onFirst` \msg -> TcFailedOnValue sq (fromSing kt) msg instrPos Nothing
       pure $ zip ksS vals
 
     typecheckContractValue
       :: forall cp tz. (tz ~ 'T.TContract cp)
-      => U.Value -> EpAddress -> Sing cp -> TypeCheckInstr (T.Value tz)
+      => U.Value' op -> EpAddress -> Sing cp -> TypeCheckInstr op (T.Value tz)
     typecheckContractValue cv (EpAddress addr epName) pc = do
 
       instrPos <- view tcieErrorPos
-      let ensureTypeMatches :: forall t'. SingI t' => TypeCheckInstr (cp :~: t')
-          ensureTypeMatches = liftEither @_ @TypeCheckInstr $
-            first (TCFailedOnValue cv (demote @ty) "wrong contract parameter" instrPos . Just) $
+      let ensureTypeMatches :: forall t'. SingI t' => TypeCheckInstr op (cp :~: t')
+          ensureTypeMatches = liftEither @_ @(TypeCheckInstr op) $
+            first (TcFailedOnValue cv (demote @ty) "wrong contract parameter" instrPos . Just) $
               (withSingI pc $ eqType @cp @t')
-      let unsupportedType :: T.BadTypeForScope -> TCError
-          unsupportedType reason = TCFailedOnValue cv (fromSing pc)
+      let unsupportedType :: T.BadTypeForScope -> TcError' op
+          unsupportedType reason = TcFailedOnValue cv (fromSing pc)
             "Unsupported type in type argument of 'contract' type" instrPos $
               Just $ UnsupportedTypeForScope (fromSing pc) reason
       case addr of
@@ -389,41 +373,41 @@
               case T.mkEntrypointCall epName paramNotes of
                 Nothing ->
                   throwError $
-                  TCFailedOnValue cv (demote @ty) "unknown entrypoint" instrPos . Just $
+                  TcFailedOnValue cv (demote @ty) "unknown entrypoint" instrPos . Just $
                   EntrypointNotFound epName
                 Just (T.MkEntrypointCallRes (_ :: Notes t') epc) -> do
                   Refl <- ensureTypeMatches @t'
                   pure $ VContract (MkAddress addr) (T.SomeEpc epc)
             Nothing ->
-              throwError $ TCFailedOnValue cv (demote @ty) "Contract literal unknown"
+              throwError $ TcFailedOnValue cv (demote @ty) "Contract literal unknown"
                 instrPos (Just $ UnknownContract addr)
         TxRollupAddress _ ->
-          throwError $ TCFailedOnValue cv (demote @ty) "txr1 address passed as contract"
+          throwError $ TcFailedOnValue cv (demote @ty) "txr1 address passed as contract"
                 instrPos (Just $ TxRollupContract addr)
 
 withComparable
-  :: forall a (t :: T.T) ty. Sing a
-  -> U.Value
+  :: forall a (t :: T.T) ty op. Sing a
+  -> U.Value' op
   -> Sing t
-  -> (T.Comparable a => TypeCheckInstr ty)
-  -> TypeCheckInstr ty
+  -> (T.Comparable a => TypeCheckInstr op ty)
+  -> TypeCheckInstr op ty
 withComparable s uv t act = case T.getComparableProofS s of
   Just Dict -> act
   Nothing -> do
     instrPos <- view tcieErrorPos
     liftEither . Left $
-      TCFailedOnValue uv (fromSing 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
+  :: forall a (t :: T.T) ty op. Sing a
+  -> U.Value' op
   -> Sing t
-  -> (T.HasNoBigMap a => TypeCheckInstr ty)
-  -> TypeCheckInstr ty
+  -> (T.HasNoBigMap a => TypeCheckInstr op ty)
+  -> TypeCheckInstr op ty
 withBigMapAbsence s uv t act = case T.bigMapAbsense s of
   Just Dict -> act
   Nothing -> do
     instrPos <- view tcieErrorPos
     liftEither . Left $
-      TCFailedOnValue uv (fromSing t) "Require a type which doesn't contain `big_map` here"
+      TcFailedOnValue uv (fromSing t) "Require a type which doesn't contain `big_map` here"
         instrPos Nothing
diff --git a/src/Morley/Michelson/Typed/Arith.hs b/src/Morley/Michelson/Typed/Arith.hs
--- a/src/Morley/Michelson/Typed/Arith.hs
+++ b/src/Morley/Michelson/Typed/Arith.hs
@@ -38,8 +38,9 @@
   ) where
 
 import Data.Bits (complement, shift, (.&.), (.|.))
-import Data.Constraint (Dict(..))
+import Data.Constraint (Bottom(..), Dict(..))
 import Fmt (Buildable(build), (+|), (|+))
+import Type.Errors (DelayError)
 import Unsafe qualified (fromIntegral)
 
 import Morley.Michelson.Typed.Polymorphic
@@ -272,16 +273,16 @@
   type ArithRes Mul 'TBls12381G2 'TBls12381Fr = 'TBls12381G2
   evalOp _ (VBls12381G2 i) (VBls12381Fr j) = Right $ VBls12381G2 (BLS.multiply j i)
   commutativityProof = Nothing
-instance Bls12381MulBadOrder BLS.Bls12381Fr BLS.Bls12381G1 =>
+instance (Bottom, Bls12381MulBadOrder BLS.Bls12381Fr BLS.Bls12381G1) =>
          ArithOp Mul 'TBls12381Fr 'TBls12381G1 where
   type ArithRes Mul 'TBls12381Fr 'TBls12381G1 = 'TBls12381G1
-  evalOp = error "impossible"
-  commutativityProof = error "impossible"
-instance Bls12381MulBadOrder BLS.Bls12381Fr BLS.Bls12381G2 =>
+  evalOp = no
+  commutativityProof = no
+instance (Bottom, Bls12381MulBadOrder BLS.Bls12381Fr BLS.Bls12381G2) =>
          ArithOp Mul 'TBls12381Fr 'TBls12381G2 where
   type ArithRes Mul 'TBls12381Fr 'TBls12381G2 = 'TBls12381G2
-  evalOp = error "impossible"
-  commutativityProof = error "impossible"
+  evalOp = no
+  commutativityProof = no
 
 instance ArithOp EDiv 'TNat 'TInt where
   type ArithRes EDiv 'TNat 'TInt = 'TOption ('TPair (EDivOpRes 'TNat 'TInt) (EModOpRes 'TNat 'TInt))
@@ -302,12 +303,11 @@
   type ArithRes EDiv 'TMutez 'TNat = 'TOption ('TPair (EDivOpRes 'TMutez 'TNat) (EModOpRes 'TMutez 'TNat))
   evalOp _ i j = Right $ evalEDivOp i j
 
-type family Bls12381MulBadOrder a1 a2 where
-  Bls12381MulBadOrder a1 a2 = TypeError
-    ('Text "Multiplication of "
-       ':<>: 'ShowType a2 ':<>: 'Text " and "
-       ':<>: 'ShowType a1 ':<>: 'Text " works only other way around"
-    )
+type Bls12381MulBadOrder a1 a2 = DelayError
+  ('Text "Multiplication of "
+      ':<>: 'ShowType a2 ':<>: 'Text " and "
+      ':<>: 'ShowType a1 ':<>: 'Text " works only other way around"
+  )
 
 instance UnaryArithOp Abs 'TInt where
   type UnaryArithRes Abs 'TInt = 'TNat
diff --git a/src/Morley/Michelson/Typed/ClassifiedInstr.hs b/src/Morley/Michelson/Typed/ClassifiedInstr.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/Michelson/Typed/ClassifiedInstr.hs
@@ -0,0 +1,24 @@
+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha
+-- SPDX-License-Identifier: LicenseRef-MIT-OA
+
+-- | Machinery for typed instruction classification.
+module Morley.Michelson.Typed.ClassifiedInstr
+  ( withClassifiedInstr
+  , ClassifiedInstr(..)
+
+    -- * Classifications
+  , NumChildren (..)
+  , FailureType (..)
+  , IsMichelson (..)
+  , HasAnns (..)
+
+    -- * Singletons
+  , SingNumChildren (..)
+  , SingFailureType (..)
+  , SingIsMichelson (..)
+  , SingHasAnns (..)
+  ) where
+
+import Morley.Michelson.Typed.ClassifiedInstr.Internal.MainImpl
+import Morley.Michelson.Typed.ClassifiedInstr.Internal.Types
+import Morley.Michelson.Typed.ClassifiedInstr.Internal.WithClassifiedInstr
diff --git a/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/Classifiers/HasAnns.hs b/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/Classifiers/HasAnns.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/Classifiers/HasAnns.hs
@@ -0,0 +1,139 @@
+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha
+-- SPDX-License-Identifier: LicenseRef-MIT-OA
+
+{-# OPTIONS_HADDOCK not-home #-}
+
+-- | Actual decision implementation for 'HasAnns'.
+module Morley.Michelson.Typed.ClassifiedInstr.Internal.Classifiers.HasAnns
+  ( module Morley.Michelson.Typed.ClassifiedInstr.Internal.Classifiers.HasAnns
+  ) where
+
+import Morley.Michelson.Typed.ClassifiedInstr.Internal.InstrEnum
+import Morley.Michelson.Typed.ClassifiedInstr.Internal.Types
+
+-- | Decide whether instruction has annotations or not. All annotated
+-- instructions should have @Ann@ prefix.
+hasAnns :: InstrEnum -> HasAnns
+hasAnns = \case
+  WithLoc -> DoesNotHaveAnns
+  Meta -> DoesNotHaveAnns
+  FrameInstr -> DoesNotHaveAnns
+  DocGroup -> DoesNotHaveAnns
+  Nop -> DoesNotHaveAnns
+  Ext -> DoesNotHaveAnns
+  Seq -> DoesNotHaveAnns
+  Nested -> DoesNotHaveAnns
+  IF_NONE -> DoesNotHaveAnns
+  IF_LEFT -> DoesNotHaveAnns
+  IF_CONS -> DoesNotHaveAnns
+  ITER -> DoesNotHaveAnns
+  IF -> DoesNotHaveAnns
+  LOOP -> DoesNotHaveAnns
+  LOOP_LEFT -> DoesNotHaveAnns
+  DIP  -> DoesNotHaveAnns
+  DIPN  -> DoesNotHaveAnns
+  FAILWITH  -> DoesNotHaveAnns
+  NEVER  -> DoesNotHaveAnns
+  DROP -> DoesNotHaveAnns
+  DROPN -> DoesNotHaveAnns
+  SWAP -> DoesNotHaveAnns
+  DIG -> DoesNotHaveAnns
+  DUG -> DoesNotHaveAnns
+  UNPAIRN -> DoesNotHaveAnns
+  ------------------------
+  AnnMAP -> DoesHaveStandardAnns
+  AnnCAR -> DoesHaveStandardAnns
+  AnnCDR -> DoesHaveStandardAnns
+  AnnDUP -> DoesHaveStandardAnns
+  AnnDUPN -> DoesHaveStandardAnns
+  AnnPUSH -> DoesHaveStandardAnns
+  AnnSOME -> DoesHaveStandardAnns
+  AnnNONE -> DoesHaveStandardAnns
+  AnnUNIT -> DoesHaveStandardAnns
+  AnnPAIR -> DoesHaveStandardAnns
+  AnnUNPAIR -> DoesHaveStandardAnns
+  AnnPAIRN -> DoesHaveStandardAnns
+  AnnLEFT -> DoesHaveStandardAnns
+  AnnRIGHT -> DoesHaveStandardAnns
+  AnnNIL -> DoesHaveStandardAnns
+  AnnCONS -> DoesHaveStandardAnns
+  AnnSIZE -> DoesHaveStandardAnns
+  AnnEMPTY_SET -> DoesHaveStandardAnns
+  AnnEMPTY_MAP -> DoesHaveStandardAnns
+  AnnEMPTY_BIG_MAP -> DoesHaveStandardAnns
+  AnnMEM -> DoesHaveStandardAnns
+  AnnGET -> DoesHaveStandardAnns
+  AnnGETN -> DoesHaveStandardAnns
+  AnnUPDATE -> DoesHaveStandardAnns
+  AnnUPDATEN -> DoesHaveStandardAnns
+  AnnGET_AND_UPDATE -> DoesHaveStandardAnns
+  AnnLAMBDA -> DoesHaveStandardAnns
+  AnnLAMBDA_REC -> DoesHaveStandardAnns
+  AnnEXEC -> DoesHaveStandardAnns
+  AnnAPPLY -> DoesHaveStandardAnns
+  AnnCAST -> DoesHaveStandardAnns
+  AnnRENAME -> DoesHaveStandardAnns
+  AnnPACK -> DoesHaveStandardAnns
+  AnnUNPACK -> DoesHaveStandardAnns
+  AnnCONCAT -> DoesHaveStandardAnns
+  AnnCONCAT' -> DoesHaveStandardAnns
+  AnnSLICE -> DoesHaveStandardAnns
+  AnnISNAT -> DoesHaveStandardAnns
+  AnnADD -> DoesHaveStandardAnns
+  AnnSUB -> DoesHaveStandardAnns
+  AnnSUB_MUTEZ -> DoesHaveStandardAnns
+  AnnMUL -> DoesHaveStandardAnns
+  AnnEDIV -> DoesHaveStandardAnns
+  AnnABS -> DoesHaveStandardAnns
+  AnnNEG -> DoesHaveStandardAnns
+  AnnLSL -> DoesHaveStandardAnns
+  AnnLSR -> DoesHaveStandardAnns
+  AnnOR -> DoesHaveStandardAnns
+  AnnAND -> DoesHaveStandardAnns
+  AnnXOR -> DoesHaveStandardAnns
+  AnnNOT -> DoesHaveStandardAnns
+  AnnCOMPARE -> DoesHaveStandardAnns
+  AnnEQ -> DoesHaveStandardAnns
+  AnnNEQ -> DoesHaveStandardAnns
+  AnnLT -> DoesHaveStandardAnns
+  AnnGT -> DoesHaveStandardAnns
+  AnnLE -> DoesHaveStandardAnns
+  AnnGE -> DoesHaveStandardAnns
+  AnnINT -> DoesHaveStandardAnns
+  AnnVIEW -> DoesHaveStandardAnns
+  AnnSELF -> DoesHaveStandardAnns
+  AnnCONTRACT -> DoesHaveStandardAnns
+  AnnTRANSFER_TOKENS -> DoesHaveStandardAnns
+  AnnSET_DELEGATE -> DoesHaveStandardAnns
+  AnnCREATE_CONTRACT -> DoesHaveStandardAnns
+  AnnIMPLICIT_ACCOUNT -> DoesHaveStandardAnns
+  AnnNOW -> DoesHaveStandardAnns
+  AnnAMOUNT -> DoesHaveStandardAnns
+  AnnBALANCE -> DoesHaveStandardAnns
+  AnnVOTING_POWER -> DoesHaveStandardAnns
+  AnnTOTAL_VOTING_POWER -> DoesHaveStandardAnns
+  AnnCHECK_SIGNATURE -> DoesHaveStandardAnns
+  AnnSHA256 -> DoesHaveStandardAnns
+  AnnSHA512 -> DoesHaveStandardAnns
+  AnnBLAKE2B -> DoesHaveStandardAnns
+  AnnSHA3 -> DoesHaveStandardAnns
+  AnnKECCAK -> DoesHaveStandardAnns
+  AnnHASH_KEY -> DoesHaveStandardAnns
+  AnnPAIRING_CHECK -> DoesHaveStandardAnns
+  AnnSOURCE -> DoesHaveStandardAnns
+  AnnSENDER -> DoesHaveStandardAnns
+  AnnADDRESS -> DoesHaveStandardAnns
+  AnnCHAIN_ID -> DoesHaveStandardAnns
+  AnnLEVEL -> DoesHaveStandardAnns
+  AnnSELF_ADDRESS -> DoesHaveStandardAnns
+  AnnTICKET -> DoesHaveStandardAnns
+  AnnTICKET_DEPRECATED -> DoesHaveStandardAnns
+  AnnREAD_TICKET -> DoesHaveStandardAnns
+  AnnSPLIT_TICKET -> DoesHaveStandardAnns
+  AnnJOIN_TICKETS -> DoesHaveStandardAnns
+  AnnOPEN_CHEST -> DoesHaveStandardAnns
+  AnnSAPLING_EMPTY_STATE -> DoesHaveStandardAnns
+  AnnSAPLING_VERIFY_UPDATE -> DoesHaveStandardAnns
+  ------------------------
+  AnnMIN_BLOCK_TIME -> DoesHaveNonStandardAnns
+  AnnEMIT -> DoesHaveNonStandardAnns
diff --git a/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/Classifiers/IsAlwaysFailing.hs b/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/Classifiers/IsAlwaysFailing.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/Classifiers/IsAlwaysFailing.hs
@@ -0,0 +1,138 @@
+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha
+-- SPDX-License-Identifier: LicenseRef-MIT-OA
+
+{-# OPTIONS_HADDOCK not-home #-}
+
+-- | Actual decision implementation for 'FailureType'.
+module Morley.Michelson.Typed.ClassifiedInstr.Internal.Classifiers.IsAlwaysFailing
+  ( module Morley.Michelson.Typed.ClassifiedInstr.Internal.Classifiers.IsAlwaysFailing
+  ) where
+
+import Morley.Michelson.Typed.ClassifiedInstr.Internal.InstrEnum
+import Morley.Michelson.Typed.ClassifiedInstr.Internal.Types
+
+-- | Decide whether an instruction is always failing. Only 'NEVER' and
+-- 'FAILWITH' are considered always failing.
+isAlwaysFailing :: InstrEnum -> FailureType
+isAlwaysFailing = \case
+  NEVER -> AlwaysFailing
+  FAILWITH -> AlwaysFailing
+  --------------------
+  WithLoc -> FailingNormal
+  Meta -> FailingNormal
+  FrameInstr -> FailingNormal
+  DocGroup -> FailingNormal
+  Nop -> FailingNormal
+  Ext -> FailingNormal
+  Seq -> FailingNormal
+  Nested -> FailingNormal
+  IF_NONE -> FailingNormal
+  IF_LEFT -> FailingNormal
+  IF_CONS -> FailingNormal
+  AnnMAP -> FailingNormal
+  ITER -> FailingNormal
+  IF -> FailingNormal
+  LOOP -> FailingNormal
+  LOOP_LEFT -> FailingNormal
+  DIP  -> FailingNormal
+  DIPN  -> FailingNormal
+  DROP -> FailingNormal
+  DROPN -> FailingNormal
+  SWAP -> FailingNormal
+  DIG -> FailingNormal
+  DUG -> FailingNormal
+  UNPAIRN -> FailingNormal
+  AnnCAR -> FailingNormal
+  AnnCDR -> FailingNormal
+  AnnDUP -> FailingNormal
+  AnnDUPN -> FailingNormal
+  AnnPUSH -> FailingNormal
+  AnnSOME -> FailingNormal
+  AnnNONE -> FailingNormal
+  AnnUNIT -> FailingNormal
+  AnnPAIR -> FailingNormal
+  AnnUNPAIR -> FailingNormal
+  AnnPAIRN -> FailingNormal
+  AnnLEFT -> FailingNormal
+  AnnRIGHT -> FailingNormal
+  AnnNIL -> FailingNormal
+  AnnCONS -> FailingNormal
+  AnnSIZE -> FailingNormal
+  AnnEMPTY_SET -> FailingNormal
+  AnnEMPTY_MAP -> FailingNormal
+  AnnEMPTY_BIG_MAP -> FailingNormal
+  AnnMEM -> FailingNormal
+  AnnGET -> FailingNormal
+  AnnGETN -> FailingNormal
+  AnnUPDATE -> FailingNormal
+  AnnUPDATEN -> FailingNormal
+  AnnGET_AND_UPDATE -> FailingNormal
+  AnnLAMBDA -> FailingNormal
+  AnnLAMBDA_REC -> FailingNormal
+  AnnEXEC -> FailingNormal
+  AnnAPPLY -> FailingNormal
+  AnnCAST -> FailingNormal
+  AnnRENAME -> FailingNormal
+  AnnPACK -> FailingNormal
+  AnnUNPACK -> FailingNormal
+  AnnCONCAT -> FailingNormal
+  AnnCONCAT' -> FailingNormal
+  AnnSLICE -> FailingNormal
+  AnnISNAT -> FailingNormal
+  AnnADD -> FailingNormal
+  AnnSUB -> FailingNormal
+  AnnSUB_MUTEZ -> FailingNormal
+  AnnMUL -> FailingNormal
+  AnnEDIV -> FailingNormal
+  AnnABS -> FailingNormal
+  AnnNEG -> FailingNormal
+  AnnLSL -> FailingNormal
+  AnnLSR -> FailingNormal
+  AnnOR -> FailingNormal
+  AnnAND -> FailingNormal
+  AnnXOR -> FailingNormal
+  AnnNOT -> FailingNormal
+  AnnCOMPARE -> FailingNormal
+  AnnEQ -> FailingNormal
+  AnnNEQ -> FailingNormal
+  AnnLT -> FailingNormal
+  AnnGT -> FailingNormal
+  AnnLE -> FailingNormal
+  AnnGE -> FailingNormal
+  AnnINT -> FailingNormal
+  AnnVIEW -> FailingNormal
+  AnnSELF -> FailingNormal
+  AnnCONTRACT -> FailingNormal
+  AnnTRANSFER_TOKENS -> FailingNormal
+  AnnSET_DELEGATE -> FailingNormal
+  AnnCREATE_CONTRACT -> FailingNormal
+  AnnIMPLICIT_ACCOUNT -> FailingNormal
+  AnnNOW -> FailingNormal
+  AnnAMOUNT -> FailingNormal
+  AnnBALANCE -> FailingNormal
+  AnnVOTING_POWER -> FailingNormal
+  AnnTOTAL_VOTING_POWER -> FailingNormal
+  AnnCHECK_SIGNATURE -> FailingNormal
+  AnnSHA256 -> FailingNormal
+  AnnSHA512 -> FailingNormal
+  AnnBLAKE2B -> FailingNormal
+  AnnSHA3 -> FailingNormal
+  AnnKECCAK -> FailingNormal
+  AnnHASH_KEY -> FailingNormal
+  AnnPAIRING_CHECK -> FailingNormal
+  AnnSOURCE -> FailingNormal
+  AnnSENDER -> FailingNormal
+  AnnADDRESS -> FailingNormal
+  AnnCHAIN_ID -> FailingNormal
+  AnnLEVEL -> FailingNormal
+  AnnSELF_ADDRESS -> FailingNormal
+  AnnTICKET -> FailingNormal
+  AnnTICKET_DEPRECATED -> FailingNormal
+  AnnREAD_TICKET -> FailingNormal
+  AnnSPLIT_TICKET -> FailingNormal
+  AnnJOIN_TICKETS -> FailingNormal
+  AnnOPEN_CHEST -> FailingNormal
+  AnnSAPLING_EMPTY_STATE -> FailingNormal
+  AnnSAPLING_VERIFY_UPDATE -> FailingNormal
+  AnnMIN_BLOCK_TIME -> FailingNormal
+  AnnEMIT -> FailingNormal
diff --git a/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/Classifiers/IsMichelson.hs b/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/Classifiers/IsMichelson.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/Classifiers/IsMichelson.hs
@@ -0,0 +1,137 @@
+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha
+-- SPDX-License-Identifier: LicenseRef-MIT-OA
+
+{-# OPTIONS_HADDOCK not-home #-}
+
+-- | Actual decision implementation for 'IsMichelson'.
+module Morley.Michelson.Typed.ClassifiedInstr.Internal.Classifiers.IsMichelson
+  ( module Morley.Michelson.Typed.ClassifiedInstr.Internal.Classifiers.IsMichelson
+  ) where
+
+import Morley.Michelson.Typed.ClassifiedInstr.Internal.InstrEnum
+import Morley.Michelson.Typed.ClassifiedInstr.Internal.Types
+
+-- | Decide whether an instruction is coming from Michelson and whether it affects execution.
+isMichelson :: InstrEnum -> IsMichelson
+isMichelson = \case
+  WithLoc -> Phantom
+  Meta -> Phantom
+  FrameInstr -> Phantom
+  DocGroup -> Phantom
+  Nop -> Additional
+  Ext -> Additional
+  Seq -> Structural
+  Nested -> Structural
+  --------------------
+  IF_NONE -> FromMichelson
+  IF_LEFT -> FromMichelson
+  IF_CONS -> FromMichelson
+  AnnMAP -> FromMichelson
+  ITER -> FromMichelson
+  IF -> FromMichelson
+  LOOP -> FromMichelson
+  LOOP_LEFT -> FromMichelson
+  DIP  -> FromMichelson
+  DIPN  -> FromMichelson
+  FAILWITH  -> FromMichelson
+  NEVER  -> FromMichelson
+  DROP -> FromMichelson
+  DROPN -> FromMichelson
+  SWAP -> FromMichelson
+  DIG -> FromMichelson
+  DUG -> FromMichelson
+  UNPAIRN -> FromMichelson
+  AnnCAR -> FromMichelson
+  AnnCDR -> FromMichelson
+  AnnDUP -> FromMichelson
+  AnnDUPN -> FromMichelson
+  AnnPUSH -> FromMichelson
+  AnnSOME -> FromMichelson
+  AnnNONE -> FromMichelson
+  AnnUNIT -> FromMichelson
+  AnnPAIR -> FromMichelson
+  AnnUNPAIR -> FromMichelson
+  AnnPAIRN -> FromMichelson
+  AnnLEFT -> FromMichelson
+  AnnRIGHT -> FromMichelson
+  AnnNIL -> FromMichelson
+  AnnCONS -> FromMichelson
+  AnnSIZE -> FromMichelson
+  AnnEMPTY_SET -> FromMichelson
+  AnnEMPTY_MAP -> FromMichelson
+  AnnEMPTY_BIG_MAP -> FromMichelson
+  AnnMEM -> FromMichelson
+  AnnGET -> FromMichelson
+  AnnGETN -> FromMichelson
+  AnnUPDATE -> FromMichelson
+  AnnUPDATEN -> FromMichelson
+  AnnGET_AND_UPDATE -> FromMichelson
+  AnnLAMBDA -> FromMichelson
+  AnnLAMBDA_REC -> FromMichelson
+  AnnEXEC -> FromMichelson
+  AnnAPPLY -> FromMichelson
+  AnnCAST -> FromMichelson
+  AnnRENAME -> FromMichelson
+  AnnPACK -> FromMichelson
+  AnnUNPACK -> FromMichelson
+  AnnCONCAT -> FromMichelson
+  AnnCONCAT' -> FromMichelson
+  AnnSLICE -> FromMichelson
+  AnnISNAT -> FromMichelson
+  AnnADD -> FromMichelson
+  AnnSUB -> FromMichelson
+  AnnSUB_MUTEZ -> FromMichelson
+  AnnMUL -> FromMichelson
+  AnnEDIV -> FromMichelson
+  AnnABS -> FromMichelson
+  AnnNEG -> FromMichelson
+  AnnLSL -> FromMichelson
+  AnnLSR -> FromMichelson
+  AnnOR -> FromMichelson
+  AnnAND -> FromMichelson
+  AnnXOR -> FromMichelson
+  AnnNOT -> FromMichelson
+  AnnCOMPARE -> FromMichelson
+  AnnEQ -> FromMichelson
+  AnnNEQ -> FromMichelson
+  AnnLT -> FromMichelson
+  AnnGT -> FromMichelson
+  AnnLE -> FromMichelson
+  AnnGE -> FromMichelson
+  AnnINT -> FromMichelson
+  AnnVIEW -> FromMichelson
+  AnnSELF -> FromMichelson
+  AnnCONTRACT -> FromMichelson
+  AnnTRANSFER_TOKENS -> FromMichelson
+  AnnSET_DELEGATE -> FromMichelson
+  AnnCREATE_CONTRACT -> FromMichelson
+  AnnIMPLICIT_ACCOUNT -> FromMichelson
+  AnnNOW -> FromMichelson
+  AnnAMOUNT -> FromMichelson
+  AnnBALANCE -> FromMichelson
+  AnnVOTING_POWER -> FromMichelson
+  AnnTOTAL_VOTING_POWER -> FromMichelson
+  AnnCHECK_SIGNATURE -> FromMichelson
+  AnnSHA256 -> FromMichelson
+  AnnSHA512 -> FromMichelson
+  AnnBLAKE2B -> FromMichelson
+  AnnSHA3 -> FromMichelson
+  AnnKECCAK -> FromMichelson
+  AnnHASH_KEY -> FromMichelson
+  AnnPAIRING_CHECK -> FromMichelson
+  AnnSOURCE -> FromMichelson
+  AnnSENDER -> FromMichelson
+  AnnADDRESS -> FromMichelson
+  AnnCHAIN_ID -> FromMichelson
+  AnnLEVEL -> FromMichelson
+  AnnSELF_ADDRESS -> FromMichelson
+  AnnTICKET -> FromMichelson
+  AnnTICKET_DEPRECATED -> FromMichelson
+  AnnREAD_TICKET -> FromMichelson
+  AnnSPLIT_TICKET -> FromMichelson
+  AnnJOIN_TICKETS -> FromMichelson
+  AnnOPEN_CHEST -> FromMichelson
+  AnnSAPLING_EMPTY_STATE -> FromMichelson
+  AnnSAPLING_VERIFY_UPDATE -> FromMichelson
+  AnnMIN_BLOCK_TIME -> FromMichelson
+  AnnEMIT -> FromMichelson
diff --git a/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/Classifiers/NumChildren.hs b/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/Classifiers/NumChildren.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/Classifiers/NumChildren.hs
@@ -0,0 +1,58 @@
+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha
+-- SPDX-License-Identifier: LicenseRef-MIT-OA
+
+{-# OPTIONS_HADDOCK not-home #-}
+
+-- | Actual decision implementation for 'NumChildren'.
+module Morley.Michelson.Typed.ClassifiedInstr.Internal.Classifiers.NumChildren
+  ( module Morley.Michelson.Typed.ClassifiedInstr.Internal.Classifiers.NumChildren
+  ) where
+
+import Prelude hiding (Type)
+
+import Language.Haskell.TH (Type(..))
+
+import Morley.Michelson.Typed.ClassifiedInstr.Internal.Types
+import Morley.Michelson.Typed.Instr (ExtInstr, Instr)
+
+-- | Given a list of constructor arguments, count how many of those arguments
+-- are instructions (i.e. 'Instr'), and return the corresponding classification.
+-- There is one unfortunate case of ambiguity in 'ExtInstr' we have to handle
+-- manually. If arguments mention 'Instr' indirectly, e.g. @Value' Instr t@
+-- 'HasIndirectChildren' is returned instead.
+numChildren :: [Type] -> NumChildren
+numChildren args
+  | any isExtInstr args = MayHaveChildren
+  | any (isAppToInstr && not . isInstr) args = HasIndirectChildren
+  | otherwise = case countInstrArgs args of
+      0 -> NoChildren
+      1 -> OneChild
+      2 -> TwoChildren
+      x -> error $ "Instruction has too many children: " <> show x
+
+countInstrArgs :: [Type] -> Int
+countInstrArgs = go 0
+  where
+    go !n = \case
+      [] -> n
+      (x:xs)
+        | isInstr x -> go (n+1) xs
+        | otherwise -> go n xs
+
+isExtInstr :: Type -> Bool
+isExtInstr = \case
+  AppT x _ -> isExtInstr x
+  ConT n | n == ''ExtInstr -> True
+  _ -> False
+
+isInstr :: Type -> Bool
+isInstr = \case
+  AppT x _ -> isInstr x
+  ConT n | n == ''Instr -> True
+  _ -> False
+
+isAppToInstr :: Type -> Bool
+isAppToInstr = \case
+  AppT x y -> isAppToInstr x || isAppToInstr y
+  ConT n | n == ''Instr -> True
+  _ -> False
diff --git a/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/InstrEnum.hs b/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/InstrEnum.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/InstrEnum.hs
@@ -0,0 +1,47 @@
+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha
+-- SPDX-License-Identifier: LicenseRef-MIT-OA
+
+{-# OPTIONS_HADDOCK not-home #-}
+
+-- | A 'Enum' type that has constructors matching those of typed 'Instr'.
+module Morley.Michelson.Typed.ClassifiedInstr.Internal.InstrEnum
+  ( module Morley.Michelson.Typed.ClassifiedInstr.Internal.InstrEnum
+  ) where
+
+import Prelude hiding (Type)
+
+import Language.Haskell.TH
+
+import Morley.Michelson.Typed.Instr (Instr)
+
+{-# ANN module ("HLint: ignore Language.Haskell.TH should be imported post-qualified or with an explicit import list" :: Text) #-}
+
+-- | A enum type with the same constructors as 'Instr'. Used to specify
+-- classifications a little more safely.
+do
+  TyConI (DataD _ _ _ _ cons _) <- reify ''Instr
+  [DataD cxt' name tvb mk _ ders] <-
+    [d|data InstrEnum deriving stock (Eq, Ord, Enum, Bounded, Show)|]
+  let substOne :: Con -> Q Con
+      substOne = \case
+        GadtC [nm] _ _ -> normalC (mkName $ nameBase nm) []
+        ForallC _ _ con -> substOne con
+        c -> error $ "unsupported " <> show (ppr c)
+
+  cons'' <- mapM substOne cons
+  pure [DataD cxt' name tvb mk cons'' ders]
+
+-- | Turn a 'Name' into its corresponding 'InstrEnum'. NB: partial function!
+fromName :: Name -> InstrEnum
+fromName (nameBase -> inputName) = $(do
+  TyConI (DataD _ _ _ _ cons _) <- reify ''Instr
+  let substOne :: Con -> Q Match
+      substOne = \case
+        GadtC [nm] _ _ ->
+          match
+            (litP $ StringL $ nameBase nm)
+            (normalB $ conE (mkName $ nameBase nm)) []
+        ForallC _ _ con -> substOne con
+        c -> error $ "unsupported " <> show (ppr c)
+  caseE [|inputName|] $ map substOne cons
+  )
diff --git a/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/MainImpl.hs b/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/MainImpl.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/MainImpl.hs
@@ -0,0 +1,47 @@
+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha
+-- SPDX-License-Identifier: LicenseRef-MIT-OA
+
+{-# OPTIONS_HADDOCK not-home #-}
+
+-- | Main implementation of the classifier machinery.
+module Morley.Michelson.Typed.ClassifiedInstr.Internal.MainImpl
+  ( module Morley.Michelson.Typed.ClassifiedInstr.Internal.MainImpl
+  ) where
+
+import Data.Singletons (Sing, SingI(..))
+
+import Morley.Michelson.Typed.ClassifiedInstr.Internal.TH
+import Morley.Michelson.Typed.ClassifiedInstr.Internal.Types
+
+-- | Classified instruction. Has the same shape as typed @Instr@, but its type
+-- also carries information about the classes of the constructor.
+generateClassifiedInstr
+
+{- | Given a well-classified instruction, get a particular classification for
+it. The general use pattern is:
+
+@
+case 'classifyInstr' i of
+  'WCI' instr -> case 'getInstrClass' instr of
+    'SMayHaveChildren' -> case instr of
+      'C_Ext' _ -> _
+      -- ...
+    -- ...
+@
+
+You should use @withClassifiedInstr@, as it provides a less verbose interface.
+-}
+getInstrClass
+  :: forall t c inp out. (SingI c, ClassifyInstr t)
+  => ClassifiedInstr c inp out
+  -> Sing (GetClassified c :: t)
+getInstrClass _ = getClassified (sing @c)
+
+-- | Existential for 'ClassifiedInstr' hiding the class. Use 'classifyInstr' to
+-- get it.
+data WellClassifiedInstr inp out =
+  forall cls. (SingI cls) =>
+  WCI { pickClassifiedInstr :: ClassifiedInstr cls inp out }
+
+-- | Convert typed @Instr@ to 'WellClassifiedInstr'.
+generateInstrToWCI ''WellClassifiedInstr
diff --git a/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/TH.hs b/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/TH.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/TH.hs
@@ -0,0 +1,85 @@
+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha
+-- SPDX-License-Identifier: LicenseRef-MIT-OA
+
+{-# OPTIONS_HADDOCK not-home #-}
+
+-- | TH code for generating classification boilerplate.
+module Morley.Michelson.Typed.ClassifiedInstr.Internal.TH
+  ( module Morley.Michelson.Typed.ClassifiedInstr.Internal.TH
+  ) where
+
+import Prelude hiding (Type)
+import Prelude qualified
+
+import Data.Constraint (Dict(..))
+import Language.Haskell.TH
+import Text.Show qualified as Show (show)
+
+import Morley.Michelson.Typed.ClassifiedInstr.Internal.Classifiers.HasAnns
+import Morley.Michelson.Typed.ClassifiedInstr.Internal.Classifiers.IsAlwaysFailing
+import Morley.Michelson.Typed.ClassifiedInstr.Internal.Classifiers.IsMichelson
+import Morley.Michelson.Typed.ClassifiedInstr.Internal.Classifiers.NumChildren
+import Morley.Michelson.Typed.ClassifiedInstr.Internal.InstrEnum
+import Morley.Michelson.Typed.ClassifiedInstr.Internal.Types
+import Morley.Michelson.Typed.Instr (Instr)
+import Morley.Michelson.Typed.T
+
+{-# ANN module ("HLint: ignore Language.Haskell.TH should be imported post-qualified or with an explicit import list" :: Text) #-}
+
+-- | Generate @ClassifiedInstr@ from @Instr@.
+generateClassifiedInstr :: DecsQ
+generateClassifiedInstr = do
+  TyConI (DataD _ _ _ _ cons _) <- reify ''Instr
+  [DataD cxt' name tvb mk _ ders] <-
+    [d|data ClassifiedInstr :: InstrClass -> [T] -> [T] -> Prelude.Type|]
+  let substOne :: Con -> Q Con
+      substOne = \case
+        GadtC [nm] args res -> GadtC [mkName $ "C_" <> nameBase nm] args <$> mangleRes nm args res
+        ForallC vars cxt'' con -> ForallC vars cxt'' <$> substOne con
+        c -> error $ "unsupported " <> show (ppr c)
+      mangleRes nm args = \case
+        (ConT cn `AppT` inp `AppT` out) | cn == ''Instr ->
+          [t|$(conT $ mkName "ClassifiedInstr") $cls $(pure inp) $(pure out)|]
+          where cls = classifyInstrTH nm (snd <$> args)
+        t -> error $ "unexpected Instr return type " <> show (ppr t)
+
+  cons'' <- mapM substOne cons
+  pure [DataD cxt' name tvb mk cons'' ders]
+
+-- | A dirty hack to turn a enum value into its corresponding 'Name'
+toName :: forall a. (Enum a, Show a) => a -> Name
+toName = mkName . Show.show
+  where _ = Dict @(Enum a) -- silence redundant constraint warning
+
+-- | Based on instruction constructor name and types of its arguments, generate
+-- its classification.
+classifyInstrTH :: Name -> [Type] -> TypeQ
+classifyInstrTH nm args = [t|'InstrClass $numc $ft $mich $anns|]
+  where
+    numc = promotedT $ toName numc'
+    numc' = numChildren args
+    ft = promotedT . toName @FailureType $ isAlwaysFailing someEnum
+    mich = promotedT . toName $ isMichelson someEnum
+    anns = promotedT . toName $ hasAnns someEnum
+    someEnum = fromName nm
+
+-- | Generate the function converting from 'Instr' to @WellClassifiedInstr@ existential.
+generateInstrToWCI :: Name -> DecsQ
+generateInstrToWCI wellClassifiedInstrName = do
+  TyConI (DataD _ _ _ _ cons _) <- reify ''Instr
+  let expr = lamCaseE $ go <$> cons
+      go = \case
+        GadtC [nm] args _ -> do
+          names <- mapM (\_ -> newName "x") args
+          let pat = conP nm varsP
+              varsP = varP <$> names
+              varsE = varE <$> names
+              con = foldl' appE (conE $ mkName $ "C_" <> nameBase nm) varsE
+          match pat (normalB [|WCI $ $con|]) []
+        ForallC _ _ con -> go con
+        c -> error $ "unsupported " <> show (ppr c)
+      wellClassifiedInstr = conT wellClassifiedInstrName
+  [d|
+    classifyInstr :: Instr inp out -> $wellClassifiedInstr inp out
+    classifyInstr = $expr
+    |]
diff --git a/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/Types.hs b/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/Types.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/Types.hs
@@ -0,0 +1,86 @@
+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha
+-- SPDX-License-Identifier: LicenseRef-MIT-OA
+
+{-# OPTIONS_HADDOCK not-home #-}
+
+-- Required due to 'genSingletonsType' producing those.
+{-# OPTIONS_GHC -Wno-redundant-constraints #-}
+
+-- | Data kinds plus singletons defining possible classifications for instructions.
+module Morley.Michelson.Typed.ClassifiedInstr.Internal.Types
+  ( module Morley.Michelson.Typed.ClassifiedInstr.Internal.Types
+  ) where
+
+import Data.Singletons (Sing)
+
+import Morley.Util.Sing
+
+-- | Number of children instructions a given instruction constructor has.
+data NumChildren
+  = MayHaveChildren
+    -- ^ It is unknown at compile-time whether the instruction has children or
+    -- not.
+  | HasIndirectChildren
+    -- ^ The instruction has children indirectly, as values.
+  | NoChildren
+    -- ^ The instruction has no children.
+  | OneChild
+    -- ^ The instruction has one child.
+  | TwoChildren
+    -- ^ The instruction has two children.
+  deriving stock (Show, Enum)
+
+-- | Whether an instruction always fails. An example of always-failing
+-- instruction is @NEVER@.
+data FailureType
+  = AlwaysFailing
+    -- ^ Instruction always fails.
+  | FailingNormal
+    -- ^ Instruction might fail if inputs are incorrect, but will generally
+    -- work.
+  deriving stock (Show, Enum)
+
+data IsMichelson
+  = FromMichelson
+    -- ^ There is corresponding instruction in the Michelson spec.
+  | Additional
+    -- ^ "Extended instructions". Don't affect execution on chain, but may
+    -- affect execution on the morley emulator.
+  | Phantom
+    -- ^ Wrappers that don't affect execution.
+  | Structural
+    -- ^ Michelson structures that are not instructions, e.g. a nested code block.
+  deriving stock (Show, Enum)
+
+-- | Whether an instruction carries Michelson annotations.
+data HasAnns
+  = DoesNotHaveAnns
+  | DoesHaveStandardAnns
+    -- ^ "Standard" means that the first constructor argument contains all
+    -- annotations as @Anns@ type, which is true for most annotated
+    -- instructions. There are a couple exceptions, however.
+  | DoesHaveNonStandardAnns
+  deriving stock (Show, Enum)
+
+-- | A product type of all classifications.
+data InstrClass = InstrClass NumChildren FailureType IsMichelson HasAnns
+
+concatMapM genSingletonsType
+  [''InstrClass,''NumChildren,''FailureType,''IsMichelson,''HasAnns]
+
+class ClassifyInstr k where
+  type GetClassified (c :: InstrClass) :: k
+  getClassified :: SingInstrClass c -> Sing (GetClassified c :: k)
+
+instance ClassifyInstr NumChildren where
+  type GetClassified ('InstrClass a _ _ _) = a
+  getClassified (SInstrClass a _ _ _) = a
+instance ClassifyInstr FailureType where
+  type GetClassified ('InstrClass _ a _ _) = a
+  getClassified (SInstrClass _ a _ _) = a
+instance ClassifyInstr IsMichelson where
+  type GetClassified ('InstrClass _ _ a _) = a
+  getClassified (SInstrClass _ _ a _) = a
+instance ClassifyInstr HasAnns where
+  type GetClassified ('InstrClass _ _ _ a) = a
+  getClassified (SInstrClass _ _ _ a) = a
diff --git a/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/WithClassifiedInstr.hs b/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/WithClassifiedInstr.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/Michelson/Typed/ClassifiedInstr/Internal/WithClassifiedInstr.hs
@@ -0,0 +1,67 @@
+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha
+-- SPDX-License-Identifier: LicenseRef-MIT-OA
+
+{-# OPTIONS_HADDOCK not-home #-}
+
+-- | A more ergonomic way of matching on classified instructions.
+module Morley.Michelson.Typed.ClassifiedInstr.Internal.WithClassifiedInstr
+  ( module Morley.Michelson.Typed.ClassifiedInstr.Internal.WithClassifiedInstr
+  ) where
+
+import Data.Singletons (Sing, SingI(..))
+
+import Morley.Michelson.Typed.ClassifiedInstr.Internal.MainImpl
+import Morley.Michelson.Typed.ClassifiedInstr.Internal.Types
+import Morley.Michelson.Typed.Instr (Instr)
+
+class WithClassifiedInstr instr where
+  type WCIConstraint instr (cls' :: InstrClass) :: Constraint
+  {- | Perform a computation with a classified instruction.
+
+  Intended to be used with @LambdaCase@, e.g.
+
+  @
+  isRealInstr :: T.Instr a b -> Bool
+  isRealInstr = withClassifiedInstr \\case
+    'SFromMichelson' -> True
+    'SStructural' -> False
+    'SAdditional' -> \\case
+      'C_Nop' -> False
+      'C_Ext'{} -> True
+    'SPhantom' -> False
+  @
+
+  You can use 'withClassifiedInstr' again to obtain a different classification:
+
+  @
+  go = 'withClassifiedInstr' \\case
+    'SFailingNormal' -> 'withClassifiedInstr' \\case
+      'SNoChildren' -> _
+  @
+
+  If you need to reference the original instruction, consider using '&' for
+  convenient pointful syntax:
+
+  @
+  go i = i & 'withClassifiedInstr' \\case
+    'SFailingNormal' -> 'withClassifiedInstr' \\case
+      'SNoChildren' -> doStuffWith i
+  @
+  -}
+  withClassifiedInstr
+    :: forall t inp out r. ClassifyInstr t
+    => (forall cls. (SingI cls, WCIConstraint instr cls)
+        => Sing (GetClassified cls :: t)
+        -> ClassifiedInstr cls inp out
+        -> r)
+    -> instr inp out
+    -> r
+
+instance WithClassifiedInstr Instr where
+  type WCIConstraint Instr _ = ()
+  withClassifiedInstr f instr = case classifyInstr instr of
+    WCI cinstr -> f (getInstrClass cinstr) cinstr
+
+instance SingI cls => WithClassifiedInstr (ClassifiedInstr cls) where
+  type WCIConstraint (ClassifiedInstr cls) cls' = cls ~ cls'
+  withClassifiedInstr f cinstr = f (getInstrClass cinstr) cinstr
diff --git a/src/Morley/Michelson/Typed/Convert.hs b/src/Morley/Michelson/Typed/Convert.hs
--- a/src/Morley/Michelson/Typed/Convert.hs
+++ b/src/Morley/Michelson/Typed/Convert.hs
@@ -21,6 +21,7 @@
 
   -- * Misc
   , flattenEntrypoints
+  , U.HandleImplicitDefaultEp(..)
   , eqInstrExt
   ) where
 
@@ -109,7 +110,7 @@
   -- ^ 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.
+  -- Created to match @octez-client hash data@ behavior for typed values.
   -- See https://gitlab.com/morley-framework/morley/-/issues/611
   deriving stock (Eq, Show)
 
@@ -119,7 +120,7 @@
 
 -- | Like 'untypeValueOptimized', but without list notation for pairs.
 --
--- Created to match @tezos-client hash data@ behaviour for typed values.
+-- Created to match @octez-client hash data@ behaviour for typed values.
 untypeValueHashable :: HasNoOp t => Value' Instr t -> U.Value
 untypeValueHashable = untypeValueImpl' Hashable
 
@@ -232,9 +233,12 @@
     case checkOpPresence lt of
       OpAbsent -> U.ValueRight (untypeValueImpl opts rt x)
 
-  (VLam (rfAnyInstr -> ops), _) ->
+  (VLam (LambdaCode (rfAnyInstr -> ops)), _) ->
     vList U.ValueLambda $ instrToOpsImpl opts ops
 
+  (VLam (LambdaCodeRec (rfAnyInstr -> ops)), _) ->
+    vList U.ValueLamRec $ instrToOpsImpl opts ops
+
   (VMap m, STMap kt vt) ->
     case (checkOpPresence kt, checkOpPresence vt) of
       (OpAbsent, OpAbsent) ->
@@ -260,9 +264,9 @@
     hashToBytes :: Hash kind -> ByteString
     hashToBytes Hash{..} = (<> hBytes) $
       case hTag of
-        HashEd25519 -> "\x00"
-        HashSecp256k1 -> "\x01"
-        HashP256 -> "\x02"
+        HashKey KeyTypeEd25519 -> "\x00"
+        HashKey KeyTypeSecp256k1 -> "\x01"
+        HashKey KeyTypeP256 -> "\x02"
         HashContract -> ""
         HashBLS -> ""
         HashTXR -> ""
@@ -323,154 +327,144 @@
   -- this place should be updated to pass it from typed to untyped ASTs.
   WithLoc _ i -> instrToOpsImpl opts i
   Meta _ i -> instrToOpsImpl opts i
-  i -> [U.PrimEx $ handleInstr i]
-  where
-    handleInstr :: HasCallStack => Instr inp out -> U.ExpandedInstr
-    handleInstr = \case
-      WithLoc _ _ -> error "impossible"
-      FrameInstr _ _ -> error "impossible"
-      Seq _ _ -> error "impossible"
-      Nop -> error "impossible"
-      Ext _ -> error "impossible"
-      Nested _ -> error "impossible"
-      DocGroup{} -> error "impossible"
-      Meta _ i -> handleInstr i
-      DROP -> U.DROP
-      DROPN s -> U.DROPN (Unsafe.fromIntegral @Natural @Word $ fromPeanoNatural s)
-      AnnDUP ann -> annotateInstr ann U.DUP
-      AnnDUPN ann s -> annotateInstr ann U.DUPN (Unsafe.fromIntegral @Natural @Word $ fromPeanoNatural s)
-      SWAP -> U.SWAP
-      DIG s -> U.DIG (Unsafe.fromIntegral @Natural @Word $ fromPeanoNatural s)
-      DUG s -> U.DUG (Unsafe.fromIntegral @Natural @Word $ fromPeanoNatural s)
-      i@(AnnPUSH ann val) | _ :: Instr inp1 (t ': s) <- i ->
-        let value = untypeValueImpl opts (sing @t) val
-        in annotateInstr ann U.PUSH value
-      i@(AnnNONE ann) | _ :: Instr inp1 ('TOption a ': inp1) <- i ->
-        annotateInstr ann U.NONE
-      AnnSOME ann -> annotateInstr ann U.SOME
-      AnnUNIT ann -> annotateInstr ann U.UNIT
-      (IF_NONE i1 i2) -> U.IF_NONE (instrToOpsImpl opts i1) (instrToOpsImpl opts i2)
-      AnnPAIR ann -> annotateInstr ann U.PAIR
-      AnnUNPAIR ann -> annotateInstr ann U.UNPAIR
-      AnnPAIRN ann n -> annotateInstr ann U.PAIRN (Unsafe.fromIntegral @Natural @Word $ fromPeanoNatural n)
-      UNPAIRN n -> U.UNPAIRN (Unsafe.fromIntegral @Natural @Word $ fromPeanoNatural n)
-      AnnCAR ann -> annotateInstr ann U.CAR
-      AnnCDR ann -> annotateInstr ann U.CDR
-      i@(AnnLEFT ann) | _ :: Instr (a ': s) ('TOr a b ': s) <- i ->
-        annotateInstr ann U.LEFT
-      i@(AnnRIGHT ann) | _ :: Instr (b ': s) ('TOr a b ': s) <- i ->
-        annotateInstr ann U.RIGHT
-      (IF_LEFT i1 i2) -> U.IF_LEFT (instrToOpsImpl opts i1) (instrToOpsImpl opts i2)
-      i@(AnnNIL ann) | _ :: Instr s ('TList p ': s) <- i ->
-        annotateInstr ann U.NIL
-      AnnCONS ann -> annotateInstr ann U.CONS
-      (IF_CONS i1 i2) -> U.IF_CONS (instrToOpsImpl opts i1) (instrToOpsImpl opts i2)
-      AnnSIZE ann -> annotateInstr ann U.SIZE
-      i@(AnnEMPTY_SET ann) | _ :: Instr s ('TSet e ': s) <- i ->
-        annotateInstr ann U.EMPTY_SET
-      i@(AnnEMPTY_MAP ann) | _ :: Instr s ('TMap a b ': s) <- i ->
-        annotateInstr ann U.EMPTY_MAP
-      i@(AnnEMPTY_BIG_MAP ann) | _ :: Instr s ('TBigMap a b ': s) <- i ->
-        annotateInstr ann U.EMPTY_BIG_MAP
-      (AnnMAP ann op) -> annotateInstr ann U.MAP $ instrToOpsImpl opts op
-      (ITER op) -> U.ITER $ instrToOpsImpl opts op
-      AnnMEM ann -> annotateInstr ann U.MEM
-      AnnGET ann -> annotateInstr ann U.GET
-      AnnGETN ann n -> annotateInstr ann U.GETN (Unsafe.fromIntegral @Natural @Word $ fromPeanoNatural n)
-      AnnUPDATE ann -> annotateInstr ann U.UPDATE
-      AnnUPDATEN ann n -> annotateInstr ann U.UPDATEN (Unsafe.fromIntegral @Natural @Word $ fromPeanoNatural n)
-      AnnGET_AND_UPDATE ann -> annotateInstr ann U.GET_AND_UPDATE
-      (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)
-      AnnLAMBDA ann l'@(VLam l) | VLam _ :: Value ('TLambda i o) <- l' ->
-        annotateInstr ann U.LAMBDA (instrToOpsImpl opts $ rfAnyInstr l)
-      AnnEXEC ann -> annotateInstr ann U.EXEC
-      AnnAPPLY ann -> annotateInstr ann U.APPLY
-      DIP op -> U.DIP (instrToOpsImpl opts op)
-      DIPN s op ->
-        U.DIPN (Unsafe.fromIntegral @Natural @Word $ fromPeanoNatural s) (instrToOpsImpl opts op)
-      FAILWITH -> U.FAILWITH
-      i@(AnnCAST ann) | _ :: Instr (a ': s) (a ': s) <- i ->
-        annotateInstr ann U.CAST
-      AnnRENAME ann -> annotateInstr ann U.RENAME
-      AnnPACK ann -> annotateInstr ann U.PACK
-      i@(AnnUNPACK ann)
-        | _ :: Instr ('TBytes ': s) ('TOption a ': s) <- i ->
-            annotateInstr ann U.UNPACK
-      AnnCONCAT ann -> annotateInstr ann U.CONCAT
-      AnnCONCAT' ann -> annotateInstr ann U.CONCAT
-      AnnSLICE ann -> annotateInstr ann U.SLICE
-      AnnISNAT ann -> annotateInstr ann U.ISNAT
-      AnnADD ann -> annotateInstr ann U.ADD
-      AnnSUB ann -> annotateInstr ann U.SUB
-      AnnSUB_MUTEZ ann -> annotateInstr ann U.SUB_MUTEZ
-      AnnMUL ann -> annotateInstr ann U.MUL
-      AnnEDIV ann -> annotateInstr ann U.EDIV
-      AnnABS ann -> annotateInstr ann U.ABS
-      AnnNEG ann -> annotateInstr ann U.NEG
-      AnnLSL ann -> annotateInstr ann U.LSL
-      AnnLSR ann -> annotateInstr ann U.LSR
-      AnnOR ann -> annotateInstr ann U.OR
-      AnnAND ann -> annotateInstr ann U.AND
-      AnnXOR ann -> annotateInstr ann U.XOR
-      AnnNOT ann -> annotateInstr ann U.NOT
-      AnnCOMPARE ann -> annotateInstr ann U.COMPARE
-      AnnEQ ann -> annotateInstr ann U.EQ
-      AnnNEQ ann -> annotateInstr ann U.NEQ
-      AnnLT ann -> annotateInstr ann U.LT
-      AnnGT ann -> annotateInstr ann U.GT
-      AnnLE ann -> annotateInstr ann U.LE
-      AnnGE ann -> annotateInstr ann U.GE
-      AnnINT ann -> annotateInstr ann U.INT
-      AnnVIEW ann viewName -> annotateInstr ann (flip U.VIEW viewName)
-      AnnSELF ann sepc ->
-        annotateInstr ann U.SELF (epNameToRefAnn $ sepcName sepc)
-      i@(AnnCONTRACT ann epName)
-        | _ :: Instr ('TAddress ': s) ('TOption ('TContract p) ': s) <- i ->
-            let fa = epNameToRefAnn epName
-            in annotateInstr ann (flip U.CONTRACT fa)
-      AnnTRANSFER_TOKENS ann -> annotateInstr ann U.TRANSFER_TOKENS
-      AnnSET_DELEGATE ann -> annotateInstr ann U.SET_DELEGATE
-      i@(AnnCREATE_CONTRACT ann contract)
-        | _ :: Instr
-            (  'TOption ('TKeyHash)
-            ': 'TMutez
-            ': g
-            ': s)
-            ('TOperation ': 'TAddress ': s) <- i ->
-          annotateInstr ann U.CREATE_CONTRACT (convertContract contract)
-      AnnIMPLICIT_ACCOUNT ann -> annotateInstr ann U.IMPLICIT_ACCOUNT
-      AnnNOW ann -> annotateInstr ann U.NOW
-      AnnAMOUNT ann -> annotateInstr ann U.AMOUNT
-      AnnBALANCE ann -> annotateInstr ann U.BALANCE
-      AnnVOTING_POWER ann -> annotateInstr ann U.VOTING_POWER
-      AnnTOTAL_VOTING_POWER ann -> annotateInstr ann U.TOTAL_VOTING_POWER
-      AnnCHECK_SIGNATURE ann -> annotateInstr ann U.CHECK_SIGNATURE
-      AnnSHA256 ann -> annotateInstr ann U.SHA256
-      AnnSHA512 ann -> annotateInstr ann U.SHA512
-      AnnBLAKE2B ann -> annotateInstr ann U.BLAKE2B
-      AnnSHA3 ann -> annotateInstr ann U.SHA3
-      AnnKECCAK ann -> annotateInstr ann U.KECCAK
-      AnnHASH_KEY ann -> annotateInstr ann U.HASH_KEY
-      AnnPAIRING_CHECK ann -> annotateInstr ann U.PAIRING_CHECK
-      AnnSOURCE ann -> annotateInstr ann U.SOURCE
-      AnnSENDER ann -> annotateInstr ann U.SENDER
-      AnnADDRESS ann -> annotateInstr ann U.ADDRESS
-      AnnCHAIN_ID ann -> annotateInstr ann U.CHAIN_ID
-      AnnLEVEL ann -> annotateInstr ann U.LEVEL
-      AnnSELF_ADDRESS ann -> annotateInstr ann U.SELF_ADDRESS
-      NEVER -> U.NEVER
-      AnnTICKET ann -> annotateInstr ann U.TICKET
-      AnnREAD_TICKET ann -> annotateInstr ann U.READ_TICKET
-      AnnSPLIT_TICKET ann -> annotateInstr ann U.SPLIT_TICKET
-      AnnJOIN_TICKETS ann -> annotateInstr ann U.JOIN_TICKETS
-      AnnOPEN_CHEST ann -> annotateInstr ann U.OPEN_CHEST
-      AnnSAPLING_EMPTY_STATE ann s ->
-        annotateInstr ann U.SAPLING_EMPTY_STATE (singPeanoVal s)
-      AnnSAPLING_VERIFY_UPDATE ann -> annotateInstr ann U.SAPLING_VERIFY_UPDATE
-      AnnMIN_BLOCK_TIME ann -> U.MIN_BLOCK_TIME ann
-      AnnEMIT va tag ty -> annotateInstr va U.EMIT tag $ mkUType <$> ty
+  i -> pure $ U.PrimEx $ case i of
+    DROP -> U.DROP
+    DROPN s -> U.DROPN (Unsafe.fromIntegral @Natural @Word $ fromPeanoNatural s)
+    AnnDUP ann -> annotateInstr ann U.DUP
+    AnnDUPN ann s -> annotateInstr ann U.DUPN (Unsafe.fromIntegral @Natural @Word $ fromPeanoNatural s)
+    SWAP -> U.SWAP
+    DIG s -> U.DIG (Unsafe.fromIntegral @Natural @Word $ fromPeanoNatural s)
+    DUG s -> U.DUG (Unsafe.fromIntegral @Natural @Word $ fromPeanoNatural s)
+    AnnPUSH ann val | _ :: Instr inp1 (t ': s) <- i ->
+      let value = untypeValueImpl opts (sing @t) val
+      in annotateInstr ann U.PUSH value
+    AnnNONE ann | _ :: Instr inp1 ('TOption a ': inp1) <- i ->
+      annotateInstr ann U.NONE
+    AnnSOME ann -> annotateInstr ann U.SOME
+    AnnUNIT ann -> annotateInstr ann U.UNIT
+    IF_NONE i1 i2 -> U.IF_NONE (instrToOpsImpl opts i1) (instrToOpsImpl opts i2)
+    AnnPAIR ann -> annotateInstr ann U.PAIR
+    AnnUNPAIR ann -> annotateInstr ann U.UNPAIR
+    AnnPAIRN ann n -> annotateInstr ann U.PAIRN (Unsafe.fromIntegral @Natural @Word $ fromPeanoNatural n)
+    UNPAIRN n -> U.UNPAIRN (Unsafe.fromIntegral @Natural @Word $ fromPeanoNatural n)
+    AnnCAR ann -> annotateInstr ann U.CAR
+    AnnCDR ann -> annotateInstr ann U.CDR
+    AnnLEFT ann | _ :: Instr (a ': s) ('TOr a b ': s) <- i ->
+      annotateInstr ann U.LEFT
+    AnnRIGHT ann | _ :: Instr (b ': s) ('TOr a b ': s) <- i ->
+      annotateInstr ann U.RIGHT
+    IF_LEFT i1 i2 -> U.IF_LEFT (instrToOpsImpl opts i1) (instrToOpsImpl opts i2)
+    AnnNIL ann | _ :: Instr s ('TList p ': s) <- i ->
+      annotateInstr ann U.NIL
+    AnnCONS ann -> annotateInstr ann U.CONS
+    IF_CONS i1 i2 -> U.IF_CONS (instrToOpsImpl opts i1) (instrToOpsImpl opts i2)
+    AnnSIZE ann -> annotateInstr ann U.SIZE
+    AnnEMPTY_SET ann | _ :: Instr s ('TSet e ': s) <- i ->
+      annotateInstr ann U.EMPTY_SET
+    AnnEMPTY_MAP ann | _ :: Instr s ('TMap a b ': s) <- i ->
+      annotateInstr ann U.EMPTY_MAP
+    AnnEMPTY_BIG_MAP ann | _ :: Instr s ('TBigMap a b ': s) <- i ->
+      annotateInstr ann U.EMPTY_BIG_MAP
+    AnnMAP ann op -> annotateInstr ann U.MAP $ instrToOpsImpl opts op
+    ITER op -> U.ITER $ instrToOpsImpl opts op
+    AnnMEM ann -> annotateInstr ann U.MEM
+    AnnGET ann -> annotateInstr ann U.GET
+    AnnGETN ann n -> annotateInstr ann U.GETN (Unsafe.fromIntegral @Natural @Word $ fromPeanoNatural n)
+    AnnUPDATE ann -> annotateInstr ann U.UPDATE
+    AnnUPDATEN ann n -> annotateInstr ann U.UPDATEN (Unsafe.fromIntegral @Natural @Word $ fromPeanoNatural n)
+    AnnGET_AND_UPDATE ann -> annotateInstr ann U.GET_AND_UPDATE
+    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)
+    AnnLAMBDA ann l -> annotateInstr ann U.LAMBDA (instrToOpsImpl opts $ rfAnyInstr l)
+    AnnLAMBDA_REC ann l -> annotateInstr ann U.LAMBDA_REC (instrToOpsImpl opts $ rfAnyInstr l)
+    AnnEXEC ann -> annotateInstr ann U.EXEC
+    AnnAPPLY ann -> annotateInstr ann U.APPLY
+    DIP op -> U.DIP (instrToOpsImpl opts op)
+    DIPN s op ->
+      U.DIPN (Unsafe.fromIntegral @Natural @Word $ fromPeanoNatural s) (instrToOpsImpl opts op)
+    FAILWITH -> U.FAILWITH
+    AnnCAST ann | _ :: Instr (a ': s) (a ': s) <- i ->
+      annotateInstr ann U.CAST
+    AnnRENAME ann -> annotateInstr ann U.RENAME
+    AnnPACK ann -> annotateInstr ann U.PACK
+    AnnUNPACK ann
+      | _ :: Instr ('TBytes ': s) ('TOption a ': s) <- i ->
+          annotateInstr ann U.UNPACK
+    AnnCONCAT ann -> annotateInstr ann U.CONCAT
+    AnnCONCAT' ann -> annotateInstr ann U.CONCAT
+    AnnSLICE ann -> annotateInstr ann U.SLICE
+    AnnISNAT ann -> annotateInstr ann U.ISNAT
+    AnnADD ann -> annotateInstr ann U.ADD
+    AnnSUB ann -> annotateInstr ann U.SUB
+    AnnSUB_MUTEZ ann -> annotateInstr ann U.SUB_MUTEZ
+    AnnMUL ann -> annotateInstr ann U.MUL
+    AnnEDIV ann -> annotateInstr ann U.EDIV
+    AnnABS ann -> annotateInstr ann U.ABS
+    AnnNEG ann -> annotateInstr ann U.NEG
+    AnnLSL ann -> annotateInstr ann U.LSL
+    AnnLSR ann -> annotateInstr ann U.LSR
+    AnnOR ann -> annotateInstr ann U.OR
+    AnnAND ann -> annotateInstr ann U.AND
+    AnnXOR ann -> annotateInstr ann U.XOR
+    AnnNOT ann -> annotateInstr ann U.NOT
+    AnnCOMPARE ann -> annotateInstr ann U.COMPARE
+    AnnEQ ann -> annotateInstr ann U.EQ
+    AnnNEQ ann -> annotateInstr ann U.NEQ
+    AnnLT ann -> annotateInstr ann U.LT
+    AnnGT ann -> annotateInstr ann U.GT
+    AnnLE ann -> annotateInstr ann U.LE
+    AnnGE ann -> annotateInstr ann U.GE
+    AnnINT ann -> annotateInstr ann U.INT
+    AnnVIEW ann viewName -> annotateInstr ann (flip U.VIEW viewName)
+    AnnSELF ann sepc ->
+      annotateInstr ann U.SELF (epNameToRefAnn $ sepcName sepc)
+    AnnCONTRACT ann epName
+      | _ :: Instr ('TAddress ': s) ('TOption ('TContract p) ': s) <- i ->
+          let fa = epNameToRefAnn epName
+          in annotateInstr ann (flip U.CONTRACT fa)
+    AnnTRANSFER_TOKENS ann -> annotateInstr ann U.TRANSFER_TOKENS
+    AnnSET_DELEGATE ann -> annotateInstr ann U.SET_DELEGATE
+    AnnCREATE_CONTRACT ann contract
+      | _ :: Instr
+          (  'TOption ('TKeyHash)
+          ': 'TMutez
+          ': g
+          ': s)
+          ('TOperation ': 'TAddress ': s) <- i ->
+        annotateInstr ann U.CREATE_CONTRACT (convertContract contract)
+    AnnIMPLICIT_ACCOUNT ann -> annotateInstr ann U.IMPLICIT_ACCOUNT
+    AnnNOW ann -> annotateInstr ann U.NOW
+    AnnAMOUNT ann -> annotateInstr ann U.AMOUNT
+    AnnBALANCE ann -> annotateInstr ann U.BALANCE
+    AnnVOTING_POWER ann -> annotateInstr ann U.VOTING_POWER
+    AnnTOTAL_VOTING_POWER ann -> annotateInstr ann U.TOTAL_VOTING_POWER
+    AnnCHECK_SIGNATURE ann -> annotateInstr ann U.CHECK_SIGNATURE
+    AnnSHA256 ann -> annotateInstr ann U.SHA256
+    AnnSHA512 ann -> annotateInstr ann U.SHA512
+    AnnBLAKE2B ann -> annotateInstr ann U.BLAKE2B
+    AnnSHA3 ann -> annotateInstr ann U.SHA3
+    AnnKECCAK ann -> annotateInstr ann U.KECCAK
+    AnnHASH_KEY ann -> annotateInstr ann U.HASH_KEY
+    AnnPAIRING_CHECK ann -> annotateInstr ann U.PAIRING_CHECK
+    AnnSOURCE ann -> annotateInstr ann U.SOURCE
+    AnnSENDER ann -> annotateInstr ann U.SENDER
+    AnnADDRESS ann -> annotateInstr ann U.ADDRESS
+    AnnCHAIN_ID ann -> annotateInstr ann U.CHAIN_ID
+    AnnLEVEL ann -> annotateInstr ann U.LEVEL
+    AnnSELF_ADDRESS ann -> annotateInstr ann U.SELF_ADDRESS
+    NEVER -> U.NEVER
+    AnnTICKET ann -> annotateInstr ann U.TICKET
+    AnnTICKET_DEPRECATED ann -> annotateInstr ann U.TICKET_DEPRECATED
+    AnnREAD_TICKET ann -> annotateInstr ann U.READ_TICKET
+    AnnSPLIT_TICKET ann -> annotateInstr ann U.SPLIT_TICKET
+    AnnJOIN_TICKETS ann -> annotateInstr ann U.JOIN_TICKETS
+    AnnOPEN_CHEST ann -> annotateInstr ann U.OPEN_CHEST
+    AnnSAPLING_EMPTY_STATE ann s ->
+      annotateInstr ann U.SAPLING_EMPTY_STATE (singPeanoVal s)
+    AnnSAPLING_VERIFY_UPDATE ann -> annotateInstr ann U.SAPLING_VERIFY_UPDATE
+    AnnMIN_BLOCK_TIME ann -> U.MIN_BLOCK_TIME ann
+    AnnEMIT va tag ty -> annotateInstr va U.EMIT tag $ mkUType <$> ty
 
 untypeStackRef :: StackRef s -> U.StackRef
 untypeStackRef (StackRef n) = U.StackRef (fromPeanoNatural n)
@@ -625,8 +619,8 @@
 -- | Flatten a provided list of notes to a map of its entrypoints and its
 -- corresponding utype. Please refer to 'U.mkEntrypointsMap' in regards to how
 -- duplicate entrypoints are handled.
-flattenEntrypoints :: ParamNotes t -> Map EpName U.Ty
-flattenEntrypoints = U.mkEntrypointsMap . convertParamNotes
+flattenEntrypoints :: U.HandleImplicitDefaultEp ->  ParamNotes t -> Map EpName U.Ty
+flattenEntrypoints hide = U.mkEntrypointsMap hide . convertParamNotes
 
 -------------------------------------------------------------------------------
 -- Rendering helpers
diff --git a/src/Morley/Michelson/Typed/Entrypoints.hs b/src/Morley/Michelson/Typed/Entrypoints.hs
--- a/src/Morley/Michelson/Typed/Entrypoints.hs
+++ b/src/Morley/Michelson/Typed/Entrypoints.hs
@@ -28,6 +28,7 @@
   , ForbidOr
   , MkEntrypointCallRes (..)
   , mkEntrypointCall
+  , mkDefEntrypointCall
 
   , tyImplicitAccountParam
 
@@ -459,12 +460,39 @@
 -- of target contract.
 --
 -- Returns 'Nothing' if entrypoint is not found.
+--
+-- Prefer using 'mkDefEntrypointCall' for the default entrypoint.
 mkEntrypointCall
   :: (ParameterScope param)
   => EpName
   -> ParamNotes param
   -> Maybe (MkEntrypointCallRes param)
-mkEntrypointCall epName (ParamNotes paramNotes root) =
+mkEntrypointCall epName
+  | isDefEpName epName = Just . mkDefEntrypointCall
+  | otherwise = mkNamedEntrypointCall epName
+
+-- | Build 'EntrypointCallT' calling the default entrypoint. Unlike
+-- 'mkEntrypointCall', always succeeds.
+mkDefEntrypointCall :: ParameterScope param => ParamNotes param -> MkEntrypointCallRes param
+mkDefEntrypointCall notes@(ParamNotes paramNotes _) = fromMaybe rootCall $
+  mkNamedEntrypointCall DefEpName notes
+  where
+    rootCall = MkEntrypointCallRes paramNotes EntrypointCall
+      { epcName = DefEpName
+      , epcParamProxy = Proxy
+      , epcLiftSequence = EplArgHere
+      }
+
+-- | Make entrypoint call explicitly for the named entrypoint, without
+-- defaulting to default entrypoint.
+--
+-- Intended to be internal.
+mkNamedEntrypointCall
+  :: (ParameterScope param)
+  => EpName
+  -> ParamNotes param
+  -> Maybe (MkEntrypointCallRes param)
+mkNamedEntrypointCall epName (ParamNotes paramNotes root) =
   asum
   [ do
       epName' <- epNameFromParamAnn root
@@ -481,12 +509,6 @@
         { epcName = epName
         , epcParamProxy = Proxy
         , epcLiftSequence = liftSeq
-        }
-  , guard (isDefEpName epName) $>
-      MkEntrypointCallRes paramNotes EntrypointCall
-        { epcName = epName
-        , epcParamProxy = Proxy
-        , epcLiftSequence = EplArgHere
         }
   ]
 
diff --git a/src/Morley/Michelson/Typed/Existential.hs b/src/Morley/Michelson/Typed/Existential.hs
--- a/src/Morley/Michelson/Typed/Existential.hs
+++ b/src/Morley/Michelson/Typed/Existential.hs
@@ -2,10 +2,12 @@
 -- SPDX-License-Identifier: LicenseRef-MIT-OA
 
 {-# LANGUAGE QuantifiedConstraints #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
 
 module Morley.Michelson.Typed.Existential
   ( -- * SomeConstrainedValue and derivatives
-    SomeConstrainedValue (.., SomeValue, SomeConstant, SomeStorage, SomePackedVal)
+    Constrained (SomeConstrainedValue, SomeValue, SomeConstant, SomeStorage, SomePackedVal)
+  , SomeConstrainedValue
   , SomeConstant
   , SomeValue
   , SomeStorage
@@ -17,33 +19,26 @@
   , SomeVBigMap(..)
   ) where
 
-import Fmt (Buildable(..))
-
 import Morley.Michelson.Printer.Util (RenderDoc(..))
 import Morley.Michelson.Typed.Aliases
 import Morley.Michelson.Typed.Convert ()
 import Morley.Michelson.Typed.Haskell.Value (KnownIsoT)
 import Morley.Michelson.Typed.Scope
 import Morley.Michelson.Typed.T (T(..))
-import Morley.Util.Sing (eqParamSing)
+import Morley.Util.Constrained
 
 ----------------------------------------------------------------------------
 -- SomeConstrainedValue
 ----------------------------------------------------------------------------
 
-data SomeConstrainedValue (c :: T -> Constraint) where
-  SomeConstrainedValue :: forall t c. (c t) => Value t -> SomeConstrainedValue c
-
-deriving stock instance Show (SomeConstrainedValue c)
-
-instance Buildable (SomeConstrainedValue c) where
-  build (SomeConstrainedValue v) = build v
+type SomeConstrainedValue c = Constrained c Value
 
-instance (forall t. cs t => SingI t) => Eq (SomeConstrainedValue cs) where
-  SomeConstrainedValue v1 == SomeConstrainedValue v2 = v1 `eqParamSing` v2
+pattern SomeConstrainedValue :: forall c. () => forall a. c a => Value a -> SomeConstrainedValue c
+pattern SomeConstrainedValue v = Constrained v
+{-# COMPLETE SomeConstrainedValue #-}
 
 instance (forall t. cs t => HasNoOp t) => RenderDoc (SomeConstrainedValue cs) where
-  renderDoc pn (SomeConstrainedValue v) = renderDoc pn v
+  renderDoc pn (Constrained v) = renderDoc pn v
 
 ----------------------------------------------------------------------------
 -- SomeConstrainedValue synonyms
@@ -51,22 +46,22 @@
 
 type SomeValue = SomeConstrainedValue SingI
 pattern SomeValue :: () => SingI t => Value t -> SomeValue
-pattern SomeValue x = SomeConstrainedValue x
+pattern SomeValue x = Constrained x
 {-# COMPLETE SomeValue #-}
 
 type SomeConstant = SomeConstrainedValue ConstantScope
 pattern SomeConstant :: () => ConstantScope t => Value t -> SomeConstant
-pattern SomeConstant x = SomeConstrainedValue x
+pattern SomeConstant x = Constrained x
 {-# COMPLETE SomeConstant #-}
 
 type SomeStorage = SomeConstrainedValue StorageScope
 pattern SomeStorage :: () => StorageScope t => Value t -> SomeStorage
-pattern SomeStorage x = SomeConstrainedValue x
+pattern SomeStorage x = Constrained x
 {-# COMPLETE SomeStorage #-}
 
 type SomePackedVal = SomeConstrainedValue PackedValScope
 pattern SomePackedVal :: () => PackedValScope t => Value t -> SomePackedVal
-pattern SomePackedVal x = SomeConstrainedValue x
+pattern SomePackedVal x = Constrained x
 {-# COMPLETE SomePackedVal #-}
 
 -- other synonyms should be easy to add by analogy, if needed.
diff --git a/src/Morley/Michelson/Typed/Haskell/Instr/Product.hs b/src/Morley/Michelson/Typed/Haskell/Instr/Product.hs
--- a/src/Morley/Michelson/Typed/Haskell/Instr/Product.hs
+++ b/src/Morley/Michelson/Typed/Haskell/Instr/Product.hs
@@ -1,6 +1,7 @@
 -- SPDX-FileCopyrightText: 2021 Oxhead Alpha
 -- SPDX-License-Identifier: LicenseRef-MIT-OA
 
+{-# LANGUAGE MagicHash #-}
 {-# OPTIONS_GHC -Wno-redundant-constraints #-}
 
 -- | Instructions working on product types derived from Haskell ones.
@@ -19,6 +20,7 @@
   , InstrDeconstructC
 
   , GetFieldType
+  , GFieldTypes
   , GLookupNamed
   , ConstructorFieldTypes
   , ConstructorFieldNames
@@ -26,7 +28,9 @@
   , CastFieldConstructors (..)
   ) where
 
+import Data.Constraint (Bottom(..))
 import Data.Vinyl.Core (Rec(..))
+import GHC.Exts (Proxy#, proxy#)
 import GHC.Generics ((:*:)(..), (:+:)(..))
 import GHC.Generics qualified as G
 import GHC.TypeLits (ErrorMessage(..), Symbol, TypeError)
@@ -36,6 +40,7 @@
 import Morley.Michelson.Typed.Haskell.Value
 import Morley.Michelson.Typed.Instr
 import Morley.Michelson.Typed.Scope
+import Morley.Michelson.Typed.T (T)
 import Morley.Util.Label (Label)
 import Morley.Util.Named
 import Morley.Util.Type
@@ -191,11 +196,9 @@
     (path :: Path)
     (fieldTy :: Type) where
   gInstrToField
-    :: GIsoValue x
-    => Instr (GValueType x ': s) (ToT fieldTy ': s)
+    :: Instr (GValueType x ': s) (ToT fieldTy ': s)
   gInstrGetFieldOpen
-    :: (GIsoValue x)
-    => Instr '[ToT fieldTy] '[res, ToT fieldTy]
+    :: Instr '[ToT fieldTy] '[res, ToT fieldTy]
     -> Instr '[ToT fieldTy] '[res]
     -> Instr (GValueType x ': s) (res ': GValueType x ': s)
 
@@ -360,26 +363,24 @@
   :: forall dt st. InstrConstructC dt
   => Rec (FieldConstructor st) (ConstructorFieldTypes dt)
   -> Instr st (ToT dt ': st)
-instrConstruct = gInstrConstruct @(G.Rep dt)
+instrConstruct = fst . gInstrConstruct @(G.Rep dt) @'[]
 
 instrConstructStack
   :: forall dt stack st .
   ( InstrConstructC dt
   , stack ~ ToTs (ConstructorFieldTypes dt)
-  , KnownList stack
   )
   => Instr (stack ++ st) (ToT dt ': st)
-instrConstructStack =
-  FrameInstr (Proxy @st) (gInstrConstructStack @(G.Rep dt))
+instrConstructStack = gInstrConstructStack @(G.Rep dt) @'[] (proxy# @st)
 
 -- | Types of all fields in a datatype.
-type ConstructorFieldTypes dt = GFieldTypes (G.Rep dt)
+type ConstructorFieldTypes dt = GFieldTypes (G.Rep dt) '[]
 
 -- | Names of all fields in a datatype.
 type ConstructorFieldNames dt = GFieldNames (G.Rep dt)
 
 -- | Constraint for 'instrConstruct' and 'gInstrConstructStack'.
-type InstrConstructC dt = (GenericIsoValue dt, GInstrConstruct (G.Rep dt))
+type InstrConstructC dt = (GenericIsoValue dt, GInstrConstruct (G.Rep dt) '[])
 
 -- | Retrieve field names of a constructor.
 type family GFieldNames x :: [Symbol] where
@@ -394,55 +395,60 @@
   GFieldNames G.V1 = TypeError ('Text "Must be at least one constructor")
 
 -- | Generic traversal for 'instrConstruct'.
-class GIsoValue x => GInstrConstruct (x :: Type -> Type) where
-  type GFieldTypes x :: [Type]
-  gInstrConstruct :: Rec (FieldConstructor st) (GFieldTypes x) -> Instr st (GValueType x ': st)
-  gInstrConstructStack :: Instr (ToTs (GFieldTypes x)) '[GValueType x]
+class GInstrConstruct (x :: Type -> Type) (rest :: [Type]) where
+  type GFieldTypes x rest :: [Type]
+  -- We return the remaining, unprocessed, portion of the record along
+  -- with the instruction.
+  gInstrConstruct
+    :: Rec (FieldConstructor st) (GFieldTypes x rest)
+    -> (Instr st (GValueType x ': st), Rec (FieldConstructor st) rest)
 
-instance GInstrConstruct x => GInstrConstruct (G.M1 t i x) where
-  type GFieldTypes (G.M1 t i x) = GFieldTypes x
-  gInstrConstruct = gInstrConstruct @x
-  gInstrConstructStack = gInstrConstructStack @x
+  -- Why do we need a proxy? Without it, there doesn't seem to be any way to
+  -- access the @end@ type variable in method implementations, and we need to.
+  gInstrConstructStack :: Proxy# end -> Instr (ToTs (GFieldTypes x rest) ++ end)
+                                              (GValueType x ': ToTs rest ++ end)
 
-instance ( GInstrConstruct x, GInstrConstruct y
-         , RSplit (GFieldTypes x) (GFieldTypes y)
-         , KnownList (ToTs (GFieldTypes x)), KnownList (ToTs (GFieldTypes y))
-         , ToTs (GFieldTypes x) ++ ToTs (GFieldTypes y) ~ ToTs (GFieldTypes x ++ GFieldTypes y)
-         ) => GInstrConstruct (x :*: y) where
-  type GFieldTypes (x :*: y) = GFieldTypes x ++ GFieldTypes y
-  gInstrConstruct fs =
-    let (lfs, rfs) = rsplit fs
-        linstr = gInstrConstruct @x lfs
-        rinstr = gInstrConstruct @y rfs
-    in linstr `Seq` DIP rinstr `Seq` PAIR
+instance GInstrConstruct x rest => GInstrConstruct (G.M1 t i x) rest where
+  type GFieldTypes (G.M1 t i x) rest = GFieldTypes x rest
+  gInstrConstruct = gInstrConstruct @x @rest
+  gInstrConstructStack p = gInstrConstructStack @x @rest p
 
-  gInstrConstructStack =
-    let linstr = gInstrConstructStack @x
-        rinstr = gInstrConstructStack @y
-    in FrameInstr (Proxy @(ToTs (GFieldTypes y))) linstr `Seq` DIP rinstr `Seq` PAIR
+instance ( GInstrConstruct x (GFieldTypes y rest), GInstrConstruct y rest
+         ) => GInstrConstruct (x :*: y) rest where
+  type GFieldTypes (x :*: y) rest = GFieldTypes x (GFieldTypes y rest)
+  gInstrConstruct fs
+    | (linstr, rest) <- gInstrConstruct @x @(GFieldTypes y rest) fs
+    , (rinstr, rest') <- gInstrConstruct @y @rest rest
+    = (linstr `Seq` DIP rinstr `Seq` PAIR, rest')
 
-instance GInstrConstruct G.U1 where
-  type GFieldTypes G.U1 = '[]
-  gInstrConstruct RNil = UNIT
-  gInstrConstructStack = UNIT
+  gInstrConstructStack p =
+    let linstr = gInstrConstructStack @x @(GFieldTypes y rest) p
+        rinstr = gInstrConstructStack @y @rest p
+    in linstr `Seq` DIP rinstr `Seq` PAIR
 
+instance GInstrConstruct G.U1 rest where
+  type GFieldTypes G.U1 rest = rest
+  gInstrConstruct rest = (UNIT, rest)
+  gInstrConstructStack _ = UNIT
+
 instance ( TypeError ('Text "Cannot construct sum type")
-         , GIsoValue x, GIsoValue y
-         ) => GInstrConstruct (x :+: y) where
-  type GFieldTypes (x :+: y) = '[]
-  gInstrConstruct = error "impossible"
-  gInstrConstructStack = error "impossible"
+         , Bottom
+         ) => GInstrConstruct (x :+: y) rest where
+  type GFieldTypes (x :+: y) rest = '[]
+  gInstrConstruct = no
+  gInstrConstructStack _ = no
 
 instance ( TypeError ('Text "Cannot construct void-like type")
-         ) => GInstrConstruct G.V1 where
-  type GFieldTypes G.V1 = '[]
-  gInstrConstruct = error "impossible"
-  gInstrConstructStack = error "impossible"
+         , Bottom
+         ) => GInstrConstruct G.V1 rest where
+  type GFieldTypes G.V1 rest = '[]
+  gInstrConstruct = no
+  gInstrConstructStack _ = no
 
-instance IsoValue a => GInstrConstruct (G.Rec0 a) where
-  type GFieldTypes (G.Rec0 a) = '[a]
-  gInstrConstruct (FieldConstructor i :& RNil) = i
-  gInstrConstructStack = Nop
+instance GInstrConstruct (G.Rec0 a) rest where
+  type GFieldTypes (G.Rec0 a) rest = a ': rest
+  gInstrConstruct (FieldConstructor i :& rest) = (i, rest)
+  gInstrConstructStack _ = Nop
 
 -- Examples
 ----------------------------------------------------------------------------
@@ -469,46 +475,45 @@
 ----------------------------------------------------------------------------
 
 -- | Constraint for 'instrConstruct'.
-type InstrDeconstructC dt = (GenericIsoValue dt, GInstrDeconstruct (G.Rep dt))
+type InstrDeconstructC dt st = ( GenericIsoValue dt, GInstrDeconstruct (G.Rep dt) '[] st)
 
 -- | For given complex type @dt@ deconstruct it to its field types.
 instrDeconstruct
-  :: forall dt stack st .
-  (InstrDeconstructC dt
-  , stack ~ ToTs (ConstructorFieldTypes dt)
-  , KnownList stack
+  :: forall dt stack (st :: [T]) .
+  (InstrDeconstructC dt st
+  , stack ~ ToTs (GFieldTypes (G.Rep dt) '[])
   )
   => Instr (ToT dt ': st) (stack ++ st)
-instrDeconstruct = FrameInstr (Proxy @st) $ gInstrDeconstruct @(G.Rep dt)
+instrDeconstruct = gInstrDeconstruct @(G.Rep dt) @'[] @st
 
 -- | Generic traversal for 'instrDeconstruct'.
-class GIsoValue x => GInstrDeconstruct (x :: Type -> Type) where
-  gInstrDeconstruct :: Instr '[GValueType x] (ToTs (GFieldTypes x))
+class GInstrDeconstruct (x :: Type -> Type) (rest :: [Type]) (st :: [T]) where
+  gInstrDeconstruct :: Instr (GValueType x ': ToTs rest ++ st)
+                             (ToTs (GFieldTypes x rest) ++ st)
 
-instance GInstrDeconstruct x => GInstrDeconstruct (G.M1 t i x) where
-  gInstrDeconstruct = gInstrDeconstruct @x
+instance GInstrDeconstruct x rest st => GInstrDeconstruct (G.M1 t i x) rest st where
+  gInstrDeconstruct = gInstrDeconstruct @x @rest @st
 
-instance ( GInstrDeconstruct x, GInstrDeconstruct y
-         , t ~ (x :*: y)
-         , KnownList (ToTs (GFieldTypes x)), KnownList (ToTs (GFieldTypes y))
-         , ToTs (GFieldTypes x) ++ ToTs (GFieldTypes y) ~ ToTs (GFieldTypes x ++ GFieldTypes y)
-         ) => GInstrDeconstruct (x :*: y) where
+instance ( GInstrDeconstruct x (GFieldTypes y rest) st
+         , GInstrDeconstruct y rest st
+         ) => GInstrDeconstruct (x :*: y) rest st where
   gInstrDeconstruct =
-    let linstr = gInstrDeconstruct @x
-        rinstr = gInstrDeconstruct @y
-    in UNPAIR `Seq` DIP rinstr `Seq` FrameInstr (Proxy @(ToTs (GFieldTypes y))) linstr
+    let linstr = gInstrDeconstruct @x @(GFieldTypes y rest) @st
+        rinstr = gInstrDeconstruct @y @rest @st
+    in UNPAIR `Seq` DIP rinstr `Seq` linstr
 
-instance GInstrDeconstruct G.U1 where
+instance GInstrDeconstruct G.U1 rest st where
   gInstrDeconstruct = DROP
 
 instance ( TypeError ('Text "Cannot deconstruct sum type")
-         , GIsoValue x, GIsoValue y
-         ) => GInstrDeconstruct (x :+: y) where
-  gInstrDeconstruct = error "impossible"
+         , Bottom
+         ) => GInstrDeconstruct (x :+: y) rest st where
+  gInstrDeconstruct = no
 
 instance ( TypeError ('Text "Cannot deconstruct void-like type")
-         ) => GInstrDeconstruct G.V1 where
-  gInstrDeconstruct = error "impossible"
+         , Bottom
+         ) => GInstrDeconstruct G.V1 rest st where
+  gInstrDeconstruct = no
 
-instance IsoValue a => GInstrDeconstruct (G.Rec0 a) where
+instance GInstrDeconstruct (G.Rec0 a) rest st where
   gInstrDeconstruct = Nop
diff --git a/src/Morley/Michelson/Typed/Haskell/Instr/Sum.hs b/src/Morley/Michelson/Typed/Haskell/Instr/Sum.hs
--- a/src/Morley/Michelson/Typed/Haskell/Instr/Sum.hs
+++ b/src/Morley/Michelson/Typed/Haskell/Instr/Sum.hs
@@ -39,6 +39,7 @@
   , IsPrimitiveValue
   ) where
 
+import Data.Constraint (Bottom(..))
 import Data.Singletons (SingI(..))
 import Data.Type.Bool (type (||))
 import Data.Vinyl.Core (Rec(..))
@@ -328,34 +329,31 @@
                              @(LnrFieldType (GetNamed name dt))
 
 -- | Generic traversal for 'instrWrap'.
-class GIsoValue x =>
+class
   GInstrWrap
     (x :: Type -> Type)
     (path :: Path)
     (entryTy :: CtorField) where
   gInstrWrap
-    :: GIsoValue x
-    => Instr (AppendCtorField entryTy s) (GValueType x ': s)
+    :: Instr (AppendCtorField entryTy s) (GValueType x ': s)
   gHsWrap
-    :: GIsoValue x
-    => ExtractCtorField entryTy -> x p
+    :: ExtractCtorField entryTy -> x p
 
 instance GInstrWrap x path e => GInstrWrap (G.D1 i x) path e where
   gInstrWrap = gInstrWrap @x @path @e
   gHsWrap = G.M1 . gHsWrap @x @path @e
 
-instance (GInstrWrap x path e, GIsoValue y, SingI (GValueType y)) =>
+instance (GInstrWrap x path e, SingI (GValueType y)) =>
          GInstrWrap (x :+: y) ('L ': path) e where
   gInstrWrap = gInstrWrap @x @path @e `Seq` LEFT
   gHsWrap = G.L1 . gHsWrap @x @path @e
 
-instance (GInstrWrap y path e, GIsoValue x, SingI (GValueType x)) =>
+instance (GInstrWrap y path e, SingI (GValueType x)) =>
          GInstrWrap (x :+: y) ('R ': path) e where
   gInstrWrap = gInstrWrap @y @path @e `Seq` RIGHT
   gHsWrap = G.R1 . gHsWrap @y @path @e
 
-instance (IsoValue e) =>
-         GInstrWrap (G.C1 c (G.S1 i (G.Rec0 e))) '[ 'S] ('OneField e) where
+instance GInstrWrap (G.C1 c (G.S1 i (G.Rec0 e))) '[ 'S] ('OneField e) where
   gInstrWrap = Nop
   gHsWrap = G.M1 . G.M1 . G.K1
 
@@ -364,7 +362,6 @@
 instance ( path ~ (x ': xs)
          , GInstrWrap (G.Rep sub) path e
          , GenericIsoValue sub
-         , GIsoValue (G.Rep sub)
          ) =>
          GInstrWrap (G.C1 c (G.S1 i (G.Rec0 sub))) ('S ': x ': xs) e where
   gInstrWrap = gInstrWrap @(G.Rep sub) @path @e
@@ -488,9 +485,9 @@
   :: forall dt out inp.
      InstrCaseC dt
   => Rec (CaseClause inp out) (CaseClauses dt) -> RemFail Instr (ToT dt ': inp) out
-instrCase = gInstrCase @(G.Rep dt)
+instrCase = fst . gInstrCase @(G.Rep dt) @'[]
 
-type InstrCaseC dt = (GenericIsoValue dt, GInstrCase (G.Rep dt))
+type InstrCaseC dt = (GenericIsoValue dt, GInstrCase (G.Rep dt) '[])
 
 -- | In what different case branches differ - related constructor name and
 -- input stack type which the branch starts with.
@@ -518,39 +515,40 @@
 infixr 8 //->
 
 -- | List of 'CaseClauseParam's required to pattern match on the given type.
-type CaseClauses a = GCaseClauses (G.Rep a)
+type CaseClauses a = GCaseClauses (G.Rep a) '[]
 
--- | Generic traversal for 'instrWrap'.
-class GIsoValue x => GInstrCase (x :: Type -> Type) where
 
-  type GCaseClauses x :: [CaseClauseParam]
+-- | Generic traversal for 'instrWrap'.
+class GInstrCase (x :: Type -> Type) (rest :: [CaseClauseParam]) where
+  type GCaseClauses x rest :: [CaseClauseParam]
 
   gInstrCase
-    :: GIsoValue x
-    => Rec (CaseClause inp out) (GCaseClauses x) -> RemFail Instr (GValueType x ': inp) out
+    :: forall inp out.
+       Rec (CaseClause inp out) (GCaseClauses x rest)
+    -> (RemFail Instr (GValueType x ': inp) out, Rec (CaseClause inp out) rest)
 
-instance GInstrCase x => GInstrCase (G.D1 i x) where
-  type GCaseClauses (G.D1 i x) = GCaseClauses x
-  gInstrCase = gInstrCase @x
+instance GInstrCase x rest => GInstrCase (G.D1 i x) rest where
+  type GCaseClauses (G.D1 i x) rest = GCaseClauses x rest
+  gInstrCase = gInstrCase @x @rest
 
-instance (GInstrCase x, GInstrCase y, RSplit (GCaseClauses x) (GCaseClauses y)) =>
-         GInstrCase (x :+: y) where
-  type GCaseClauses (x :+: y) = GCaseClauses x ++ GCaseClauses y
-  gInstrCase clauses =
-    let (leftClauses, rightClauses) = rsplit clauses
-    in rfMerge IF_LEFT (gInstrCase @x leftClauses) (gInstrCase @y rightClauses)
+instance (GInstrCase x (GCaseClauses y rest), GInstrCase y rest) =>
+         GInstrCase (x :+: y) rest where
+  type GCaseClauses (x :+: y) rest = GCaseClauses x (GCaseClauses y rest)
+  gInstrCase clauses
+    | (lres, rest) <- gInstrCase @x clauses
+    , (rres, rest') <- gInstrCase @y rest
+    = (rfMerge IF_LEFT lres rres, rest')
 
-instance GInstrCase G.V1 where
-  type GCaseClauses G.V1 = '[]
-  gInstrCase RNil = RfAlwaysFails NEVER
+instance GInstrCase G.V1 rest where
+  type GCaseClauses G.V1 rest = rest
+  gInstrCase rest = (RfAlwaysFails NEVER, rest)
 
-instance GInstrCaseBranch ctor x => GInstrCase (G.C1 ('G.MetaCons ctor _1 _2) x) where
-  type GCaseClauses (G.C1 ('G.MetaCons ctor _1 _2) x) = '[GCaseBranchInput ctor x]
-  gInstrCase (clause :& RNil) = gInstrCaseBranch @ctor @x clause
+instance GInstrCaseBranch ctor x => GInstrCase (G.C1 ('G.MetaCons ctor _1 _2) x) rest where
+  type GCaseClauses (G.C1 ('G.MetaCons ctor _1 _2) x) rest = GCaseBranchInput ctor x ': rest
+  gInstrCase (clause :& rest) = (gInstrCaseBranch @ctor @x clause, rest)
 
 -- | Traverse a single contructor and supply its field to instruction in case clause.
-class GIsoValue x =>
-      GInstrCaseBranch (ctor :: Symbol) (x :: Type -> Type) where
+class GInstrCaseBranch (ctor :: Symbol) (x :: Type -> Type) where
 
   type GCaseBranchInput ctor x :: CaseClauseParam
 
@@ -559,19 +557,18 @@
     -> RemFail Instr (GValueType x ': inp) out
 
 instance
-  ( GIsoValue x, GIsoValue y
-  , TypeError ('Text "Cannot pattern match on constructors with more than 1 field"
+  ( TypeError ('Text "Cannot pattern match on constructors with more than 1 field"
                ':$$: 'Text "Consider using tuples instead")
+  , Bottom
   ) => GInstrCaseBranch ctor (x :*: y) where
-
   type GCaseBranchInput ctor (x :*: y) = 'CaseClauseParam ctor 'NoFields
-  gInstrCaseBranch = error "impossible"
+  gInstrCaseBranch = no
 
 instance GInstrCaseBranch ctor x => GInstrCaseBranch ctor (G.S1 i x) where
   type GCaseBranchInput ctor (G.S1 i x) = GCaseBranchInput ctor x
   gInstrCaseBranch = gInstrCaseBranch @ctor @x
 
-instance IsoValue a => GInstrCaseBranch ctor (G.Rec0 a) where
+instance GInstrCaseBranch ctor (G.Rec0 a) where
   type GCaseBranchInput ctor (G.Rec0 a) = 'CaseClauseParam ctor ('OneField a)
   gInstrCaseBranch (CaseClause i) = i
 
@@ -646,14 +643,12 @@
             @(CtorOnlyField name dt) .
   G.from
 
-class GIsoValue x =>
-  GInstrUnwrap
+class GInstrUnwrap
     (x :: Type -> Type)
     (path :: Path)
     (entryTy :: Type) where
   unsafeGInstrUnwrap
-    :: GIsoValue x
-    => Instr (GValueType x ': s) (ToT entryTy ': s)
+    :: Instr (GValueType x ': s) (ToT entryTy ': s)
   gHsUnwrap
     :: x p -> Maybe entryTy
 
@@ -661,14 +656,14 @@
   unsafeGInstrUnwrap = unsafeGInstrUnwrap @x @path @e
   gHsUnwrap = gHsUnwrap @x @path @e . G.unM1
 
-instance (GInstrUnwrap x path e, GIsoValue y, SingI (GValueType y)) =>
+instance (GInstrUnwrap x path e, SingI (GValueType y)) =>
          GInstrUnwrap (x :+: y) ('L ': path) e where
   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)) =>
+instance (GInstrUnwrap y path e, SingI (GValueType x)) =>
          GInstrUnwrap (x :+: y) ('R ': path) e where
   unsafeGInstrUnwrap = IF_LEFT failWithWrongCtor (unsafeGInstrUnwrap @y @path @e)
   gHsUnwrap = \case
@@ -685,7 +680,6 @@
 instance ( path ~ (x ': xs)
          , GInstrUnwrap (G.Rep sub) path e
          , GenericIsoValue sub
-         , GIsoValue (G.Rep sub)
          ) =>
          GInstrUnwrap (G.C1 c (G.S1 i (G.Rec0 sub))) ('S ': x ': xs) e where
   unsafeGInstrUnwrap = unsafeGInstrUnwrap @(G.Rep sub) @path @e
diff --git a/src/Morley/Michelson/Typed/Haskell/LooseSum.hs b/src/Morley/Michelson/Typed/Haskell/LooseSum.hs
--- a/src/Morley/Michelson/Typed/Haskell/LooseSum.hs
+++ b/src/Morley/Michelson/Typed/Haskell/LooseSum.hs
@@ -18,6 +18,7 @@
   , LooseSumC
   ) where
 
+import Data.Constraint (Bottom(..))
 import Data.Singletons (SingI(..), demote)
 import GHC.Generics ((:*:), (:+:))
 import GHC.Generics qualified as G
@@ -120,9 +121,10 @@
     Just b -> ComposeOk b
 
 instance
-  TypeError ('Text "Cannot compose/decompose constructors with more \
-             \than one field" ':$$:
-             'Text "Consider using tuple instead") =>
+  ( Bottom
+  , TypeError ('Text "Cannot compose/decompose constructors with more \
+                     \than one field" ':$$:
+               'Text "Consider using tuple instead")) =>
   GAccessField (x :*: y) where
-  gExtractField = error "impossible"
-  gMakeField = error "impossible"
+  gExtractField = no
+  gMakeField = no
diff --git a/src/Morley/Michelson/Typed/Haskell/ValidateDescription.hs b/src/Morley/Michelson/Typed/Haskell/ValidateDescription.hs
--- a/src/Morley/Michelson/Typed/Haskell/ValidateDescription.hs
+++ b/src/Morley/Michelson/Typed/Haskell/ValidateDescription.hs
@@ -11,8 +11,10 @@
 
 import Data.Singletons (Demote)
 import Data.Type.Bool (type (||))
+import Fcf qualified
 import GHC.Generics qualified as G
-import GHC.TypeLits (ErrorMessage(..), Symbol, TypeError)
+import GHC.TypeLits (ErrorMessage(..), Symbol)
+import Type.Errors (DelayError, IfStuck)
 
 import Morley.Util.Type (FailUnless, FailUnlessElse)
 
@@ -54,20 +56,21 @@
 -- When @descr@ is empty this family does nothing, to avoid breaking for built-in, non-ADT types.
 --
 -- When @descr@ is not empty, this family will demand 'G.Generic' instance for @typ@ and fail with a
--- 'TypeError' if there none.
-type family FieldDescriptionsValid (descr :: FieldDescriptions) (typ :: Type) :: Constraint where
+-- @TypeError@ if there none.
+type FieldDescriptionsValid :: FieldDescriptions -> Type -> Constraint
+type family FieldDescriptionsValid descr typ where
   FieldDescriptionsValid '[] _ = ()
   FieldDescriptionsValid descr typ =
-    Assert
-      (TypeError
+    IfStuck (G.Rep typ)
+      (DelayError
         ('Text "No Generic instance for " ':<>: 'ShowType typ ':<>: 'Text "." ':$$:
          'Text "Generic is needed to validate TypeDocFieldDescriptions.")
       )
-      (G.Rep typ)
-      (FieldDescriptionsValidImpl descr typ)
+      (Fcf.Pure (FieldDescriptionsValidImpl descr typ))
 
 -- | Actual recursive implementation for 'FieldDescriptionsValid'.
-type family FieldDescriptionsValidImpl (descr :: FieldDescriptions) (typ :: Type) :: Constraint where
+type FieldDescriptionsValidImpl :: FieldDescriptions -> Type -> Constraint
+type family FieldDescriptionsValidImpl descr typ where
   FieldDescriptionsValidImpl '[] _ = ()
   FieldDescriptionsValidImpl ( '(conName, '(_, fields)) ': rest ) typ =
     ( HasAllFields conName fields typ
@@ -75,7 +78,8 @@
     )
 
 -- | Check whether given constructor name @conName@ is present in 'G.Rep' of a datatype.
-type family HasConstructor (conName :: Symbol) (g :: Type -> Type) :: Bool where
+type HasConstructor :: Symbol -> (Type -> Type) -> Bool
+type family HasConstructor conName g where
   HasConstructor conName (G.D1 _ cs) = HasConstructor conName cs
   HasConstructor conName (G.C1 ('G.MetaCons conName _ _) _) = 'True
   HasConstructor conName (l G.:+: r) = HasConstructor conName l || HasConstructor conName r
@@ -83,9 +87,10 @@
 
 -- | Check whether all fields described for given constructor @conName@ are present in the datatype.
 --
--- This family also checks whether the constructor is present and fails with a 'TypeError'
+-- This family also checks whether the constructor is present and fails with a @TypeError@
 -- otherwise.
-type family HasAllFields (conName :: Symbol) (fields :: [(Symbol, Symbol)]) (typ :: Type) :: Constraint where
+type HasAllFields :: Symbol -> [(Symbol, Symbol)] -> Type -> Constraint
+type family HasAllFields conName fields typ where
   HasAllFields conName fields typ =
     FailUnlessElse
       (HasConstructor conName (G.Rep typ))
@@ -95,7 +100,8 @@
       (HasAllFieldsImpl conName fields typ)
 
 -- | Actual recursive implementation of 'HasAllFields'.
-type family HasAllFieldsImpl (conName :: Symbol) (fields :: [(Symbol, Symbol)]) (typ :: Type) :: Constraint where
+type HasAllFieldsImpl :: Symbol -> [(Symbol, Symbol)] -> Type -> Constraint
+type family HasAllFieldsImpl conName fields typ where
   HasAllFieldsImpl _ '[] _ = ()
   HasAllFieldsImpl conName ( '(fieldName, _) ': rest ) typ =
     ( FailUnless
@@ -107,28 +113,16 @@
     )
 
 -- | Check that Generic 'G.Rep' has given field @fieldName@ in a given constructor @conName@.
-type family HasField (conName :: Symbol) (fieldName :: Symbol) (g :: Type -> Type) :: Bool where
+type HasField :: Symbol -> Symbol -> (Type -> Type) -> Bool
+type family HasField conName fieldName g where
   HasField conName fieldName (G.D1 _ cs) = HasField conName fieldName cs
   HasField conName fieldName (G.C1 ('G.MetaCons conName _ _) c) = ConHasField fieldName c
   HasField conName fieldName (l G.:+: r) = HasField conName fieldName l || HasField conName fieldName r
   HasField _ _ _ = 'False
 
 -- | Check that Generic representation for a constructor has given field @fieldName@.
-type family ConHasField (fieldName :: Symbol) (g :: Type -> Type) :: Bool where
+type ConHasField :: Symbol -> (Type -> Type) -> Bool
+type family ConHasField fieldName g where
   ConHasField fieldName (G.S1 ('G.MetaSel ('Just fieldName) _ _ _) _) = 'True
   ConHasField fieldName (l G.:*: r) = ConHasField fieldName l || ConHasField fieldName r
   ConHasField _ _ = 'False
-
--- A trick by Csongor Kiss: https://kcsongor.github.io/report-stuck-families/
---
--- 'T1' is a dummy type and 'Assert' will get stuck whenever its argument @break@ is stuck.
---
--- This happens because for stuck argument GHC can't check whether it is equal to 'T1' and therefore
--- can't select one of 'Assert's equations.
-
-data T1 a
-
-type Assert :: Constraint -> (Type -> Type) -> k -> k
-type family Assert err break v where
-  Assert _ T1 _ = Any
-  Assert _ _ k = k
diff --git a/src/Morley/Michelson/Typed/Haskell/Value.hs b/src/Morley/Michelson/Typed/Haskell/Value.hs
--- a/src/Morley/Michelson/Typed/Haskell/Value.hs
+++ b/src/Morley/Michelson/Typed/Haskell/Value.hs
@@ -36,7 +36,7 @@
   , totsAppendLemma
   ) where
 import Control.Lens (At(..), Index, Iso, IxValue, Ixed(..), iso)
-import Data.Constraint (Dict(..))
+import Data.Constraint (Bottom(..), Dict(..))
 import Data.Data (Data)
 import Data.Default (Default(..))
 import Data.Fixed (Fixed(..))
@@ -125,10 +125,10 @@
   toVal = VString
   fromVal (VString x) = x
 
-instance DoNotUseTextError => IsoValue Text where
+instance (Bottom, DoNotUseTextError) => IsoValue Text where
   type ToT Text = ToT MText
-  toVal = error "impossible"
-  fromVal = error "impossible"
+  toVal = no
+  fromVal = no
 
 instance IsoValue Bool where
   type ToT Bool = 'TBool
@@ -290,7 +290,8 @@
 instance (IsoValue (ContractRef arg)) => Buildable (ContractRef arg) where
   build = buildVContract . toVal
 
-instance (HasNoOpToT arg, WellTypedToT arg) => IsoValue (ContractRef arg) where
+instance (HasNoOpToT arg, HasNoNestedBigMaps (ToT 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
diff --git a/src/Morley/Michelson/Typed/Instr.hs b/src/Morley/Michelson/Typed/Instr.hs
--- a/src/Morley/Michelson/Typed/Instr.hs
+++ b/src/Morley/Michelson/Typed/Instr.hs
@@ -33,6 +33,7 @@
           , UPDATEN
           , GET_AND_UPDATE
           , LAMBDA
+          , LAMBDA_REC
           , EXEC
           , APPLY
           , CAST
@@ -91,6 +92,7 @@
           , LEVEL
           , SELF_ADDRESS
           , TICKET
+          , TICKET_DEPRECATED
           , READ_TICKET
           , SPLIT_TICKET
           , JOIN_TICKETS
@@ -153,7 +155,7 @@
 import Morley.Michelson.Typed.TypeLevel
   (CombedPairLeafCount, CombedPairLeafCountIsAtLeast, CombedPairNodeCount,
   CombedPairNodeIndexIsValid, IsPair)
-import Morley.Michelson.Typed.Value (Value'(..))
+import Morley.Michelson.Typed.Value (RemFail(..), Value'(..))
 import Morley.Michelson.Typed.View
 import Morley.Michelson.Untyped (AnyAnn, FieldAnn, StackTypePattern, TypeAnn, VarAnn)
 import Morley.Util.Peano
@@ -176,7 +178,7 @@
 -- typechecking code and eDSL code.
 type ConstraintDUPN' kind (n :: Peano) (inp :: [kind]) (out :: [kind]) (a :: kind) =
   ( RequireLongerOrSameLength inp n, n > 'Z ~ 'True
-  , inp ~ (Take (Decrement n) inp ++ (a ': Drop n inp))
+  , inp ~ (LazyTake (Decrement n) inp ++ (a ': Drop n inp))
   , out ~ (a ': inp)
   )
 
@@ -187,8 +189,10 @@
 type ConstraintDIPN' kind (n :: Peano) (inp :: [kind])
   (out :: [kind]) (s :: [kind]) (s' :: [kind]) =
   ( RequireLongerOrSameLength inp n
-  , ((Take n inp) ++ s) ~ inp
-  , ((Take n inp) ++ s') ~ out
+  , LazyTake n inp ++ s ~ inp
+  , LazyTake n inp ++ s' ~ out
+  , s ~ Drop n inp
+  , s' ~ Drop n out
   )
 
 type ConstraintDIPN n inp out s s' = ConstraintDIPN' T n inp out s s'
@@ -197,10 +201,9 @@
 -- typechecking code and eDSL code.
 type ConstraintDIG' kind (n :: Peano) (inp :: [kind])
   (out :: [kind]) (a :: kind) =
-  ( KnownList inp
-  , RequireLongerThan inp n
-  , inp ~ (Take n inp ++ (a ': Drop ('S n) inp))
-  , out ~ (a ': Take n inp ++ Drop ('S n) inp)
+  ( RequireLongerThan inp n
+  , out ~ a ': LazyTake n inp ++ Drop ('S n) inp
+  , inp ~ LazyTake n (Drop ('S 'Z) out) ++ (a ': Drop ('S n) out)
   )
 
 type ConstraintDIG n inp out a = ConstraintDIG' T n inp out a
@@ -209,10 +212,7 @@
 -- typechecking code and eDSL code.
 type ConstraintDUG' kind (n :: Peano) (inp :: [kind])
   (out :: [kind]) (a :: kind) =
-  ( RequireLongerThan out n
-  , inp ~ (a ': Drop ('S 'Z) inp)
-  , out ~ (Take n (Drop ('S 'Z) inp) ++ (a ': Drop ('S n) inp))
-  )
+  ConstraintDIG' kind n out inp a
 
 type ConstraintDUG n inp out a = ConstraintDUG' T n inp out a
 
@@ -221,7 +221,7 @@
   , FailUnless (n >= ToPeano 2) ('Text "'PAIR n' expects n ≥ 2")
   )
 
-type PairN (n :: Peano) (s :: [T]) = (RightComb (Take n s) ': Drop n s)
+type PairN (n :: Peano) (s :: [T]) = RightComb (LazyTake n s) ': Drop n s
 
 -- | Folds a stack into a right-combed pair.
 --
@@ -380,7 +380,7 @@
   -- this for future work.
   FrameInstr
     :: forall a b s.
-       (KnownList a, KnownList b)
+       KnownList a
     => Proxy s -> Instr a b -> Instr (a ++ s) (b ++ s)
 
   Seq :: Instr a b -> Instr b c -> Instr a c
@@ -604,9 +604,16 @@
   LOOP_LEFT
     :: Instr (a ': s) ('TOr a b ': s)
     -> Instr ('TOr a b ': s) (b ': s)
-  AnnLAMBDA :: forall i o s . (SingI i, SingI o)
-         => Anns '[VarAnn, Notes i, Notes o]
-         -> Value' Instr ('TLambda i o) -> Instr s ('TLambda i o ': s)
+  AnnLAMBDA
+    :: forall i o s . (SingI i, SingI o)
+    => Anns '[VarAnn, Notes i, Notes o]
+    -> RemFail Instr '[i] '[o]
+    -> Instr s ('TLambda i o ': s)
+  AnnLAMBDA_REC
+    :: forall i o s . (SingI i, SingI o)
+    => Anns '[VarAnn, Notes i, Notes o]
+    -> RemFail Instr '[i, 'TLambda i o] '[o]
+    -> Instr s ('TLambda i o ': s)
   AnnEXEC :: AnnVar -> Instr (t1 ': 'TLambda t1 t2 ': s) (t2 ': s)
   AnnAPPLY
     :: forall a b c s . (ConstantScope a, SingI b)
@@ -782,10 +789,14 @@
   AnnLEVEL :: AnnVar -> Instr s ('TNat ': s)
   AnnSELF_ADDRESS :: AnnVar -> Instr s ('TAddress ': s)
   NEVER :: Instr ('TNever ': s) t
-  AnnTICKET
+  AnnTICKET_DEPRECATED
     :: (Comparable a)
     => AnnVar
     -> Instr (a ': 'TNat ': s) ('TTicket a ': s)
+  AnnTICKET
+    :: (Comparable a)
+    => AnnVar
+    -> Instr (a ': 'TNat ': s) ('TOption ('TTicket a) ': s)
   AnnREAD_TICKET
     :: AnnVar
     -> Instr ('TTicket a ': s) (RightComb ['TAddress, a, 'TNat] ': 'TTicket a ': s)
@@ -817,6 +828,10 @@
     -> FieldAnn
     -> Maybe (Notes t)
     -> Instr (t ': s) ('TOperation : s)
+  -- NB: In EMIT we need to differentiate between "has no type annotation" and
+  -- "has type annotation, but it doesn't have any additional annotations on
+  -- it", because these cases are represented and interpreted differently. We
+  -- also don't want FieldAnn to be hidden, as it has semantic meaning.
 
 castInstr
   :: forall inp1 out1 inp2 out2.
@@ -938,6 +953,22 @@
 pattern ConcreteMeta :: Typeable meta => meta -> Instr i o -> Instr i o
 pattern ConcreteMeta meta instr <- Meta (SomeMeta (cast -> Just meta)) instr
 
+pattern LAMBDA
+  :: forall s r . ()
+  => forall i o. (SingI i, SingI o, r ~ ('TLambda i o ': s))
+  => (IsNotInView => RemFail Instr '[i] '[o])
+  -> Instr s r
+pattern LAMBDA code <- AnnLAMBDA _ code
+  where LAMBDA code = AnnLAMBDA def $ giveNotInView code
+
+pattern LAMBDA_REC
+  :: forall s r . ()
+  => forall i o. (SingI i, SingI o, r ~ ('TLambda i o ': s))
+  => (IsNotInView => RemFail Instr '[i, 'TLambda i o] '[o])
+  -> Instr s r
+pattern LAMBDA_REC code <- AnnLAMBDA_REC _ code
+  where LAMBDA_REC code = AnnLAMBDA_REC def $ giveNotInView code
+
 deriveGADTNFData ''Instr
 
 instance NFData (ExtInstr s)
@@ -945,18 +976,19 @@
 instance NFData (TestAssert s) where
   rnf (TestAssert a b c) = rnf (a, b, c)
 
-$(
-  -- This TH splice generates pattern synonyms for @AnnX@ data constructors
-  -- without the @Ann@ prefix, ignoring annotations. Matching simply ignores
-  -- the first argument (containing the list of annotations), and construction
-  -- uses @def@.
-  do
-    TyConI (DataD _ _ _ _ cons _) <- reify ''Instr
-    let go forallSig = \case
-          ForallC varbndrs cxt'' con -> go (Just (varbndrs, cxt'')) con
-          GadtC nms btys (AppT (AppT _ inpT) outT) -> concatForM nms \nm -> do
-            case "Ann" `stripPrefix` nameBase nm of
-              Just base -> do
+-- This TH splice generates pattern synonyms for @AnnX@ data constructors
+-- without the @Ann@ prefix, ignoring annotations. Matching simply ignores
+-- the first argument (containing the list of annotations), and construction
+-- uses @def@.
+do
+  TyConI (DataD _ _ _ _ cons _) <- reify ''Instr
+  let go forallSig = \case
+        ForallC varbndrs cxt'' con -> go (Just (varbndrs, cxt'')) con
+        GadtC nms btys (AppT (AppT _ inpT) outT) -> concatForM nms \nm -> do
+          case "Ann" `stripPrefix` nameBase nm of
+            Just base -> lookupValueName base >>= \case
+              Just{} -> pure [] -- skip if already defined
+              Nothing -> do
                 let btys' = drop 1 btys
                 args <- forM btys' \_ -> newName "arg"
                 inpV <- newName "inp"
@@ -965,7 +997,7 @@
                       (ConP nm $ WildP:(VarP <$> args))
                     baseName = mkName base
                     cl = Clause (VarP <$> args) (NormalB body) []
-                    body = foldl' AppE (ConE nm) $ (VarE $ mkName "def"):(VarE <$> args)
+                    body = foldl' AppE (ConE nm) $ (VarE $ 'def):(VarE <$> args)
                     inpout = [PlainTV inpV InferredSpec, PlainTV outV InferredSpec]
                     eqT x y = AppT (AppT EqualityT x) y
                     forallc
@@ -975,17 +1007,20 @@
                     patsig = forallc $
                       foldr (AppT . AppT ArrowT . snd) (AppT (AppT (ConT ''Instr) (VarT inpV)) (VarT outV)) btys'
                 pure [PatSynSigD baseName patsig, pat]
-              Nothing -> pure []
-          _ -> pure []
-        conName = \case
-          ForallC _ _ con -> conName con
-          GadtC nms _ _ -> nameBase <$> nms
-          NormalC nm _ -> [nameBase nm]
-          RecC nm _ -> [nameBase nm]
-          InfixC _ nm _ -> [nameBase nm]
-          RecGadtC nms _ _ -> nameBase <$> nms
-        stripAnn x = fromMaybe x $ "Ann" `stripPrefix` x
+            Nothing -> pure []
+        _ -> pure []
+      conName = \case
+        ForallC _ _ con -> conName con
+        GadtC nms _ _ -> nameBase <$> nms
+        NormalC nm _ -> [nameBase nm]
+        RecC nm _ -> [nameBase nm]
+        InfixC _ nm _ -> [nameBase nm]
+        RecGadtC nms _ _ -> nameBase <$> nms
+      stripAnn x = fromMaybe x $ "Ann" `stripPrefix` x
 
-    pats <- concat <$> traverse (go Nothing) cons
-    pure $ (PragmaD $ CompleteP (mkName . stripAnn <$> concatMap conName cons) Nothing) : pats
-  )
+  pats <- concat <$> traverse (go Nothing) cons
+  pure $ (PragmaD $ CompleteP (mkName . stripAnn <$> concatMap conName cons) Nothing) : pats
+
+{-# DEPRECATED OPEN_CHEST
+  "Due to a vulnerability discovered in time-lock protocol, \
+  \OPEN_CHEST is temporarily deprecated since Lima" #-}
diff --git a/src/Morley/Michelson/Typed/Operation.hs b/src/Morley/Michelson/Typed/Operation.hs
--- a/src/Morley/Michelson/Typed/Operation.hs
+++ b/src/Morley/Michelson/Typed/Operation.hs
@@ -158,7 +158,7 @@
 
 -- | Set contract's delegate
 data SetDelegateOperation = SetDelegateOperation
-  { sdoContract :: ContractAddress
+  { sdoContract :: L1Address
   -- ^ The contract we're setting delegate of
   , sdoDelegate :: Maybe KeyHash
   -- ^ The delegate we're setting
diff --git a/src/Morley/Michelson/Typed/Scope.hs b/src/Morley/Michelson/Typed/Scope.hs
--- a/src/Morley/Michelson/Typed/Scope.hs
+++ b/src/Morley/Michelson/Typed/Scope.hs
@@ -133,7 +133,7 @@
   ) where
 
 import Data.Bool.Singletons (SBool(..))
-import Data.Constraint (Dict(..), withDict, (:-)(..), (\\))
+import Data.Constraint (Dict(..), withDict, (:-)(..))
 import Data.Singletons
   (SLambda(..), Sing, SingI(..), fromSing, type (@@), type (~>), type Apply, withSingI, (@@))
 import Data.Type.Bool (Not, type (&&), type (||))
@@ -144,6 +144,7 @@
 import Morley.Michelson.Printer.Util (RenderDoc(..), buildRenderDoc)
 import Morley.Michelson.Typed.Sing (SingT(..))
 import Morley.Michelson.Typed.T (T(..))
+import Morley.Util.Type (FailUnless, FailWhen)
 import Unsafe.Coerce (unsafeCoerce)
 
 ----------------------------------------------------------------------------
@@ -307,6 +308,15 @@
 class (ContainsNestedBigMaps t ~ 'False) => HasNoNestedBigMaps t
 instance (ContainsNestedBigMaps t ~ 'False) => HasNoNestedBigMaps t
 
+{-# DEPRECATED
+   FailOnOperationFound
+ , FailOnContractFound
+ , FailOnTicketFound
+ , FailOnBigMapFound
+ , FailOnNestedBigMapsFound
+ , FailOnNonComparableFound
+ "Use a Forbid* constraint instead"
+ #-}
 -- | Report a human-readable error about 'TOperation' at a wrong place.
 type family FailOnOperationFound (enabled :: Bool) :: Constraint where
   FailOnOperationFound 'True =
@@ -325,12 +335,6 @@
     TypeError ('Text "Type `ticket` is not allowed in this scope")
   FailOnTicketFound 'False = ()
 
--- | Report a human-readable error about 'TSaplingState' at a wrong place.
-type family FailOnSaplingStateFound (enabled :: Bool) :: Constraint where
-  FailOnSaplingStateFound 'True =
-    TypeError ('Text "Type `sapling_state` is not allowed in this scope")
-  FailOnSaplingStateFound 'False = ()
-
 -- | Report a human-readable error about 'TBigMap' at a wrong place.
 type family FailOnBigMapFound (enabled :: Bool) :: Constraint where
   FailOnBigMapFound 'True =
@@ -350,105 +354,81 @@
     TypeError ('Text "Only comparable types are allowed here")
 
 -- | This is like 'HasNoOp', it raises a more human-readable error
--- when @t@ type is concrete, but GHC cannot make any conclusions
--- from such constraint as it can for 'HasNoOp'.
--- Though, hopefully, it will someday:
--- <https://gitlab.haskell.org/ghc/ghc/issues/11503 #11503>.
+-- when @t@ type is concrete, and also imposes an equality constraint.
 --
 -- Use this constraint in our eDSL.
-type ForbidOp t = FailOnOperationFound (ContainsOp t)
+type ForbidOp t =
+  FailWhen
+    (ContainsOp t)
+    ('Text "Operations are not allowed in this scope")
 
-type ForbidContract t = FailOnContractFound (ContainsContract t)
+type ForbidContract t =
+  FailWhen
+    (ContainsContract t)
+    ('Text "Type `contract` is not allowed in this scope")
 
-type ForbidTicket t = FailOnTicketFound (ContainsTicket t)
+type ForbidTicket t =
+  FailWhen
+    (ContainsTicket t)
+    ('Text "Type `ticket` is not allowed in this scope")
 
-type ForbidSaplingState t = FailOnSaplingStateFound (ContainsSaplingState t)
+type ForbidSaplingState t =
+  FailWhen
+    (ContainsSaplingState t)
+    ('Text "Type `sapling_state` is not allowed in this scope")
 
-type ForbidBigMap t = FailOnBigMapFound (ContainsBigMap t)
+type ForbidBigMap t =
+  FailWhen
+    (ContainsBigMap t)
+    ('Text "BigMaps are not allowed in this scope")
 
-type ForbidNestedBigMaps t = FailOnNestedBigMapsFound (ContainsNestedBigMaps t)
+type ForbidNestedBigMaps t =
+  FailWhen
+    (ContainsNestedBigMaps t)
+    ('Text "Nested BigMaps are not allowed")
 
 -- | Constraint that rises human-readable error message, in case given value
 -- can't be compared
-type ForbidNonComparable t = FailOnNonComparableFound (IsComparable t)
+type ForbidNonComparable t =
+  FailUnless
+    (IsComparable t)
+    ('Text "Only comparable types are allowed here")
 
--- | Evidence of that 'HasNoOp' is deducable from 'ForbidOp'.
-forbiddenOpEvi :: forall t. (SingI t, ForbidOp t) :- HasNoOp t
-forbiddenOpEvi = Sub $
-  -- It's not clear now to proof GHC that @HasNoOp t@ is implication of
-  -- @ForbidOp t@, so we use @error@ below and also disable
-  -- "-Wredundant-constraints" extension.
-  case checkOpPresence (sing @t) of
-    OpAbsent -> Dict
-    OpPresent -> error "impossible"
+{-# DEPRECATED forbiddenOp, forbiddenBigMap, forbiddenNestedBigMaps, forbiddenContractType
+ "Simply delete this function wherever it occurs. It is no longer needed."
+ #-}
 
--- | Reify 'HasNoOp' contraint from 'ForbidOp'.
---
--- Left for backward compatibility.
+-- | Deprecated and unused
 forbiddenOp
   :: forall t a.
-     (SingI t, ForbidOp t)
+     ForbidOp t
   => (HasNoOp t => a)
   -> a
-forbiddenOp = withDict $ forbiddenOpEvi @t
-
-forbiddenBigMapEvi :: forall t. (SingI t, ForbidBigMap t) :- HasNoBigMap t
-forbiddenBigMapEvi = Sub $
-  case checkBigMapPresence (sing @t) of
-    BigMapAbsent -> Dict
-    BigMapPresent -> error "impossible"
-
-forbiddenNestedBigMapsEvi :: forall t. (SingI t, ForbidNestedBigMaps t) :- HasNoNestedBigMaps t
-forbiddenNestedBigMapsEvi = Sub $
-  case checkNestedBigMapsPresence (sing @t) of
-    NestedBigMapsAbsent -> Dict
-    NestedBigMapsPresent -> error "impossible"
+forbiddenOp a = a
 
+-- | Deprecated and unused
 forbiddenBigMap
   :: forall t a.
-     (SingI t, ForbidBigMap t)
+     ForbidBigMap t
   => (HasNoBigMap t => a)
   -> a
-forbiddenBigMap = withDict $ forbiddenBigMapEvi @t
+forbiddenBigMap a = a
 
+-- | Deprecated and unused
 forbiddenNestedBigMaps
   :: forall t a.
-     (SingI t, ForbidNestedBigMaps t)
+     ForbidNestedBigMaps t
   => (HasNoNestedBigMaps t => a)
   -> a
-forbiddenNestedBigMaps = withDict $ forbiddenNestedBigMapsEvi @t
-
--- | Reify 'HasNoContract' contraint from 'ForbidContract'.
-forbiddenContractTypeEvi
-  :: forall t. (SingI t, ForbidContract t) :- HasNoContract t
-forbiddenContractTypeEvi = Sub $
-  case checkContractTypePresence (sing @t) of
-    ContractAbsent -> Dict
-    ContractPresent -> error "impossible"
+forbiddenNestedBigMaps a = a
 
--- | Reify 'HasNoContract' contraint from 'ForbidContract'.
+-- | Deprecated and unused
 forbiddenContractType
   :: forall t a.
-     (SingI t, ForbidContract t)
+     ForbidContract t
   => (HasNoContract t => a)
   -> a
-forbiddenContractType = withDict $ forbiddenContractTypeEvi @t
-
--- | 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"
-
--- | Reify 'HasNoSaplingState' contraint from 'ForbidSaplingState'.
-forbiddenSaplingStateTypeEvi
-  :: forall t. (SingI t, ForbidSaplingState t) :- HasNoSaplingState t
-forbiddenSaplingStateTypeEvi = Sub $
-  case checkSaplingStatePresence (sing @t) of
-    SaplingStateAbsent -> Dict
-    SaplingStatePresent -> error "impossible"
+forbiddenContractType a = a
 
 -- | Whether a value of this type _may_ contain an operation.
 data OpPresence (t :: T)
@@ -963,7 +943,7 @@
 type ComparabilityScope t =
   (SingI t, Comparable t)
 
-comparabilityPresence :: Sing t -> Maybe (Dict $ (Comparable t))
+comparabilityPresence :: Sing t -> Maybe (Dict (Comparable t))
 comparabilityPresence s = case checkComparability s of
   CanBeCompared -> Just Dict
   CannotBeCompared -> Nothing
@@ -1231,50 +1211,34 @@
 type ProperNonComparableValBetterErrors t =
   (SingI t, ForbidNonComparable t)
 
+{-# DEPRECATED properParameterEvi, properStorageEvi, properConstantEvi
+ , properDupableEvi, properPackedValEvi, properUnpackedValEvi
+ , properViewableEvi, properUntypedValEvi
+ "This entailment is now trivial; there is no need to introduce evidence for it."
+ #-}
 properParameterEvi :: forall t. ProperParameterBetterErrors t :- ParameterScope t
-properParameterEvi = Sub $
-  Dict \\ forbiddenOpEvi @t \\ forbiddenNestedBigMapsEvi @t
+properParameterEvi = Sub Dict
 
 properStorageEvi :: forall t. ProperStorageBetterErrors t :- StorageScope t
-properStorageEvi = Sub $
-  Dict \\ forbiddenOpEvi @t
-       \\ forbiddenContractTypeEvi @t
-       \\ forbiddenNestedBigMapsEvi @t
-       \\ forbiddenContractTypeEvi @t
+properStorageEvi = Sub Dict
 
 properConstantEvi :: forall t. ProperConstantBetterErrors t :- ConstantScope t
-properConstantEvi = Sub $
-  Dict \\ forbiddenOpEvi @t
-       \\ forbiddenBigMapEvi @t
-       \\ forbiddenContractTypeEvi @t
-       \\ forbiddenTicketTypeEvi @t
-       \\ forbiddenSaplingStateTypeEvi @t
+properConstantEvi = Sub Dict
 
 properDupableEvi :: forall t. ProperDupableBetterErrors t :- DupableScope t
-properDupableEvi = Sub $
-  Dict \\ forbiddenTicketTypeEvi @t
+properDupableEvi = Sub Dict
 
 properPackedValEvi :: forall t. ProperPackedValBetterErrors t :- PackedValScope t
-properPackedValEvi = Sub $
-  Dict \\ forbiddenOpEvi @t
-       \\ forbiddenBigMapEvi @t
-       \\ forbiddenTicketTypeEvi @t
-       \\ forbiddenSaplingStateTypeEvi @t
+properPackedValEvi = Sub Dict
 
 properUnpackedValEvi :: forall t. ProperUnpackedValBetterErrors t :- UnpackedValScope t
-properUnpackedValEvi = Sub $
-  Dict \\ properPackedValEvi @t
-       \\ properConstantEvi @t
+properUnpackedValEvi = Sub Dict
 
 properViewableEvi :: forall t. ProperViewableBetterErrors t :- ViewableScope t
-properViewableEvi = Sub $
-  Dict \\ forbiddenOpEvi @t
-       \\ forbiddenBigMapEvi @t
-       \\ forbiddenTicketTypeEvi @t
+properViewableEvi = Sub Dict
 
 properUntypedValEvi :: forall t. ProperUntypedValBetterErrors t :- UntypedValScope t
-properUntypedValEvi = Sub $
-  Dict \\ forbiddenOpEvi @t
+properUntypedValEvi = Sub Dict
 
 class (IsComparable t ~ 'True, SingI t, ComparableSuperC t) => Comparable t where
   -- | Constraints required for instance of a given type.
@@ -1341,7 +1305,7 @@
 instance WellTyped 'TOperation
 
 instance WellTypedSuperC ('TContract t) => WellTyped ('TContract t) where
-  type WellTypedSuperC ('TContract t) = (WellTyped t, HasNoOp t)
+  type WellTypedSuperC ('TContract t) = (WellTyped t, HasNoOp t, HasNoNestedBigMaps t)
 
 instance WellTypedSuperC ('TTicket t) => WellTyped ('TTicket t) where
   type WellTypedSuperC ('TTicket t) = (WellTyped t, Comparable t)
@@ -1421,6 +1385,7 @@
   STContract s -> do
     Dict <- getWTP' s
     Dict <- eitherWellTyped BtIsOperation opAbsense s
+    Dict <- eitherWellTyped BtHasNestedBigMap nestedBigMapsAbsense s
     pure Dict
   STTicket s -> do
     Dict <- getWTP' s
diff --git a/src/Morley/Michelson/Typed/T.hs b/src/Morley/Michelson/Typed/T.hs
--- a/src/Morley/Michelson/Typed/T.hs
+++ b/src/Morley/Michelson/Typed/T.hs
@@ -9,6 +9,7 @@
   , buildStack
   ) where
 
+import Data.Data (Data)
 import Fmt (Buildable(..), Builder, listF)
 
 import Morley.Michelson.Printer.Util (Prettier(..), RenderDoc(..), buildRenderDocExtended)
@@ -52,7 +53,7 @@
   | TSaplingTransaction Peano.Peano
   | TTxRollupL2Address
   | TNever
-  deriving stock (Eq, Show, Generic)
+  deriving stock (Eq, Show, Generic, Data)
 
 instance NFData T
 
diff --git a/src/Morley/Michelson/Typed/Util.hs b/src/Morley/Michelson/Typed/Util.hs
--- a/src/Morley/Michelson/Typed/Util.hs
+++ b/src/Morley/Michelson/Typed/Util.hs
@@ -44,14 +44,17 @@
 import Control.Monad.Writer.Strict (Writer, execWriterT, runWriter, tell, writer)
 import Data.Constraint (Dict(..))
 import Data.Default (Default(..))
+import Data.Generics (listify)
 import Data.Map qualified as M
 import Data.Set qualified as S
 import Data.Text.Internal.Builder (fromText)
 import Fmt (Buildable(..))
+import Language.Haskell.TH qualified as TH
 
 import Morley.Michelson.Text (MText)
 import Morley.Michelson.Typed.Aliases
 import Morley.Michelson.Typed.Annotation
+import Morley.Michelson.Typed.ClassifiedInstr
 import Morley.Michelson.Typed.Contract
 import Morley.Michelson.Typed.Instr
 import Morley.Michelson.Typed.Scope
@@ -114,154 +117,56 @@
   => DfsSettings m
   -> Instr inp out
   -> m (Instr inp out)
-dfsTraverseInstr settings@DfsSettings{..} i =
-  case i of
-    Seq i1 i2 -> recursion2 Seq i1 i2
-    WithLoc loc i1 -> recursion1 (WithLoc loc) i1
-    Meta meta i1 -> recursion1 (Meta meta) i1
-    FrameInstr p i1 -> recursion1 (FrameInstr p) i1
-    Nested i1 -> recursion1 Nested i1
-    DocGroup dg i1 -> recursion1 (DocGroup dg) 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
-    IF i1 i2 -> recursion2 IF i1 i2
-    AnnMAP ann i1 -> recursion1 (AnnMAP ann) i1
-    ITER i1 -> recursion1 ITER i1
-    LOOP i1 -> recursion1 LOOP i1
-    LOOP_LEFT i1 -> recursion1 LOOP_LEFT i1
-    DIP i1 -> recursion1 DIP i1
-    DIPN s i1 -> recursion1 (DIPN s) i1
-
-    -- This case is more complex so we duplicate @recursion1@ a bit.
-    -- We have to traverse the pushed value because a lambda can be
-    -- somewhere inside of it (e. g. one item of a pair).
-    AnnPUSH ann v
-      | dsGoToValues -> ceaPostStep dsCtorEffectsApp i do
-        innerV <- dfsTraverseValue settings v
-        dsInstrStep $ AnnPUSH ann innerV
-     | otherwise -> recursion0 i
-
-    AnnLAMBDA ann (VLam i1)
-      | dsGoToValues ->
-          recursion1 (AnnLAMBDA ann . VLam . analyzeInstrFailure) (rfAnyInstr i1)
-      | otherwise -> recursion0 i
-    AnnCREATE_CONTRACT ann contract
-      | dsGoToValues ->
-          ceaPostStep dsCtorEffectsApp i
-            case cCode contract of
-              ContractCode c -> do
-                codeI <- dfsTraverseInstr settings c
-                viewsI <- forM (toList $ cViews contract) \(SomeView v) -> do
-                    code <- dfsTraverseInstr settings $ vCode v
-                    return $ SomeView v{ vCode = code }
-                dsInstrStep $ AnnCREATE_CONTRACT ann $ contract
-                  { cCode = ContractCode codeI
-                  , cViews = UnsafeViewsSet $ fromList viewsI
-                  }
-      | otherwise -> recursion0 i
-
-    Nop{} -> recursion0 i
-    Ext (TEST_ASSERT (TestAssert nm pc i1)) ->
+dfsTraverseInstr settings@DfsSettings{..} i = i & withClassifiedInstr \case
+  SMayHaveChildren -> \case
+    C_Ext (TEST_ASSERT (TestAssert nm pc i1)) ->
       recursion1 (Ext . TEST_ASSERT . TestAssert nm pc) i1
-    Ext{} -> recursion0 i
-    AnnCAR{} -> recursion0 i
-    AnnCDR{} -> recursion0 i
-    DROP{} -> recursion0 i
-    DROPN{} -> recursion0 i
-    AnnDUP{} -> recursion0 i
-    AnnDUPN{} -> recursion0 i
-    SWAP{} -> recursion0 i
-    DIG{} -> recursion0 i
-    DUG{} -> recursion0 i
-    AnnSOME{} -> recursion0 i
-    AnnNONE{} -> recursion0 i
-    AnnUNIT{} -> recursion0 i
-    AnnPAIR{} -> recursion0 i
-    AnnUNPAIR{} -> recursion0 i
-    AnnPAIRN{} -> recursion0 i
-    UNPAIRN{} -> recursion0 i
-    AnnLEFT{} -> recursion0 i
-    AnnRIGHT{} -> recursion0 i
-    AnnNIL{} -> recursion0 i
-    AnnCONS{} -> recursion0 i
-    AnnSIZE{} -> recursion0 i
-    AnnEMPTY_SET{} -> recursion0 i
-    AnnEMPTY_MAP{} -> recursion0 i
-    AnnEMPTY_BIG_MAP{} -> recursion0 i
-    AnnMEM{} -> recursion0 i
-    AnnGET{} -> recursion0 i
-    AnnGETN{} -> recursion0 i
-    AnnUPDATE{} -> recursion0 i
-    AnnUPDATEN{} -> recursion0 i
-    AnnGET_AND_UPDATE{} -> recursion0 i
-    AnnEXEC{} -> recursion0 i
-    AnnAPPLY{} -> recursion0 i
-    FAILWITH{} -> recursion0 i
-    AnnCAST{} -> recursion0 i
-    AnnRENAME{} -> recursion0 i
-    AnnPACK{} -> recursion0 i
-    AnnUNPACK{} -> recursion0 i
-    AnnCONCAT{} -> recursion0 i
-    AnnCONCAT'{} -> recursion0 i
-    AnnSLICE{} -> recursion0 i
-    AnnISNAT{} -> recursion0 i
-    AnnADD{} -> recursion0 i
-    AnnSUB{} -> recursion0 i
-    AnnSUB_MUTEZ{} -> recursion0 i
-    AnnMUL{} -> recursion0 i
-    AnnEDIV{} -> recursion0 i
-    AnnABS{} -> recursion0 i
-    AnnNEG{} -> recursion0 i
-    AnnLSL{} -> recursion0 i
-    AnnLSR{} -> recursion0 i
-    AnnOR{} -> recursion0 i
-    AnnAND{} -> recursion0 i
-    AnnXOR{} -> recursion0 i
-    AnnNOT{} -> recursion0 i
-    AnnCOMPARE{} -> recursion0 i
-    AnnEQ{} -> recursion0 i
-    AnnNEQ{} -> recursion0 i
-    AnnLT{} -> recursion0 i
-    AnnGT{} -> recursion0 i
-    AnnLE{} -> recursion0 i
-    AnnGE{} -> recursion0 i
-    AnnINT{} -> recursion0 i
-    AnnVIEW{} -> recursion0 i
-    AnnSELF{} -> recursion0 i
-    AnnCONTRACT{} -> recursion0 i
-    AnnTRANSFER_TOKENS{} -> recursion0 i
-    AnnSET_DELEGATE{} -> recursion0 i
-    AnnIMPLICIT_ACCOUNT{} -> recursion0 i
-    AnnNOW{} -> recursion0 i
-    AnnAMOUNT{} -> recursion0 i
-    AnnBALANCE{} -> recursion0 i
-    AnnVOTING_POWER{} -> recursion0 i
-    AnnTOTAL_VOTING_POWER{} -> recursion0 i
-    AnnCHECK_SIGNATURE{} -> recursion0 i
-    AnnSHA256{} -> recursion0 i
-    AnnSHA512{} -> recursion0 i
-    AnnBLAKE2B{} -> recursion0 i
-    AnnSHA3{} -> recursion0 i
-    AnnKECCAK{} -> recursion0 i
-    AnnHASH_KEY{} -> recursion0 i
-    AnnPAIRING_CHECK{} -> recursion0 i
-    AnnSOURCE{} -> recursion0 i
-    AnnSENDER{} -> recursion0 i
-    AnnADDRESS{} -> recursion0 i
-    AnnCHAIN_ID{} -> recursion0 i
-    AnnLEVEL{} -> recursion0 i
-    AnnSELF_ADDRESS{} -> recursion0 i
-    NEVER{} -> recursion0 i
-    AnnTICKET{} -> recursion0 i
-    AnnREAD_TICKET{} -> recursion0 i
-    AnnSPLIT_TICKET{} -> recursion0 i
-    AnnJOIN_TICKETS{} -> recursion0 i
-    AnnOPEN_CHEST{} -> recursion0 i
-    AnnSAPLING_EMPTY_STATE{} -> recursion0 i
-    AnnSAPLING_VERIFY_UPDATE{} -> recursion0 i
-    AnnMIN_BLOCK_TIME{} -> recursion0 i
-    AnnEMIT{} -> recursion0 i
+    C_Ext _ -> recursion0 i
+  STwoChildren -> \case
+    C_Seq i1 i2 -> recursion2 Seq i1 i2
+    C_IF_NONE i1 i2 -> recursion2 IF_NONE i1 i2
+    C_IF_LEFT i1 i2 -> recursion2 IF_LEFT i1 i2
+    C_IF_CONS i1 i2 -> recursion2 IF_CONS i1 i2
+    C_IF i1 i2 -> recursion2 IF i1 i2
+  SOneChild -> \case
+    C_WithLoc loc i1 -> recursion1 (WithLoc loc) i1
+    C_Meta meta i1 -> recursion1 (Meta meta) i1
+    C_FrameInstr p i1 -> recursion1 (FrameInstr p) i1
+    C_Nested i1 -> recursion1 Nested i1
+    C_DocGroup dg i1 -> recursion1 (DocGroup dg) i1
+    C_AnnMAP ann i1 -> recursion1 (AnnMAP ann) i1
+    C_ITER i1 -> recursion1 ITER i1
+    C_LOOP i1 -> recursion1 LOOP i1
+    C_LOOP_LEFT i1 -> recursion1 LOOP_LEFT i1
+    C_DIP i1 -> recursion1 DIP i1
+    C_DIPN s i1 -> recursion1 (DIPN s) i1
+  SHasIndirectChildren
+    | dsGoToValues -> \case
+      -- This case is more complex so we duplicate @recursion1@ a bit.
+      -- We have to traverse the pushed value because a lambda can be
+      -- somewhere inside of it (e. g. one item of a pair).
+      C_AnnPUSH ann v -> ceaPostStep dsCtorEffectsApp i do
+          innerV <- dfsTraverseValue settings v
+          dsInstrStep $ AnnPUSH ann innerV
+
+      C_AnnLAMBDA ann i1 ->
+            recursion1 (AnnLAMBDA ann . analyzeInstrFailure) (rfAnyInstr i1)
+      C_AnnLAMBDA_REC ann i1 ->
+            recursion1 (AnnLAMBDA_REC ann . analyzeInstrFailure) (rfAnyInstr i1)
+      C_AnnCREATE_CONTRACT ann contract ->
+            ceaPostStep dsCtorEffectsApp i
+              case cCode contract of
+                ContractCode c -> do
+                  codeI <- dfsTraverseInstr settings c
+                  viewsI <- forM (toList $ cViews contract) \(SomeView v) -> do
+                      code <- dfsTraverseInstr settings $ vCode v
+                      return $ SomeView v{ vCode = code }
+                  dsInstrStep $ AnnCREATE_CONTRACT ann $ contract
+                    { cCode = ContractCode codeI
+                    , cViews = UnsafeViewsSet $ fromList viewsI
+                    }
+    | otherwise -> const $ recursion0 i
+  SNoChildren -> const $ recursion0 i
   where
     recursion0 ::
       forall a b. Instr a b -> m (Instr a b)
@@ -324,138 +229,33 @@
 analyzeInstrFailure = go
   where
   go :: Instr i o -> RemFail Instr i o
-  go = \case
-    WithLoc loc i -> case go i of
-      RfNormal i0 ->
-        RfNormal (WithLoc loc i0)
-      r -> r
-    Meta meta i -> case go i of
-      RfNormal i0 ->
-        RfNormal (Meta meta i0)
-      r -> r
-    FrameInstr s i -> case go i of
-      RfNormal i0 ->
-        RfNormal (FrameInstr s i0)
-      RfAlwaysFails i0 ->
-        error $ "FrameInstr wraps always-failing instruction: " <> Debug.show i0
-    Seq a b -> Seq a `rfMapAnyInstr` go b
-    Nop -> RfNormal Nop
-    Ext e -> RfNormal (Ext e)
-    Nested i -> Nested `rfMapAnyInstr` go i
-    DocGroup g i -> DocGroup g `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)
-    IF_CONS l r -> rfMerge IF_CONS (go l) (go r)
-    IF l r -> rfMerge IF (go l) (go r)
-
-    i@AnnMAP{} -> RfNormal i
-    i@ITER{} -> RfNormal i
-    i@LOOP{} -> RfNormal i
-    i@LOOP_LEFT{} -> RfNormal i
-    i@AnnLAMBDA{} -> RfNormal i
-    i@DIP{} -> RfNormal i
-    i@DIPN{} -> RfNormal i
-
-    i@AnnCAR{} -> RfNormal i
-    i@AnnCDR{} -> RfNormal i
-    i@DROP{} -> RfNormal i
-    i@DROPN{} -> RfNormal i
-    i@AnnDUP{} -> RfNormal i
-    i@AnnDUPN{} -> RfNormal i
-    i@SWAP{} -> RfNormal i
-    i@DIG{} -> RfNormal i
-    i@DUG{} -> RfNormal i
-    i@AnnPUSH{} -> RfNormal i
-    i@AnnSOME{} -> RfNormal i
-    i@AnnNONE{} -> RfNormal i
-    i@AnnUNIT{} -> RfNormal i
-    i@AnnPAIR{} -> RfNormal i
-    i@AnnUNPAIR{} -> RfNormal i
-    i@AnnPAIRN{} -> RfNormal i
-    i@UNPAIRN{} -> RfNormal i
-    i@AnnLEFT{} -> RfNormal i
-    i@AnnRIGHT{} -> RfNormal i
-    i@AnnNIL{} -> RfNormal i
-    i@AnnCONS{} -> RfNormal i
-    i@AnnSIZE{} -> RfNormal i
-    i@AnnEMPTY_SET{} -> RfNormal i
-    i@AnnEMPTY_MAP{} -> RfNormal i
-    i@AnnEMPTY_BIG_MAP{} -> RfNormal i
-    i@AnnMEM{} -> RfNormal i
-    i@AnnGET{} -> RfNormal i
-    i@AnnGETN{} -> RfNormal i
-    i@AnnUPDATE{} -> RfNormal i
-    i@AnnUPDATEN{} -> RfNormal i
-    i@AnnGET_AND_UPDATE{} -> RfNormal i
-    i@AnnEXEC{} -> RfNormal i
-    i@AnnAPPLY{} -> RfNormal i
-    FAILWITH -> RfAlwaysFails FAILWITH
-    i@AnnCAST{} -> RfNormal i
-    i@AnnRENAME{} -> RfNormal i
-    i@AnnPACK{} -> RfNormal i
-    i@AnnUNPACK{} -> RfNormal i
-    i@AnnCONCAT{} -> RfNormal i
-    i@AnnCONCAT'{} -> RfNormal i
-    i@AnnSLICE{} -> RfNormal i
-    i@AnnISNAT{} -> RfNormal i
-    i@AnnADD{} -> RfNormal i
-    i@AnnSUB{} -> RfNormal i
-    i@AnnSUB_MUTEZ{} -> RfNormal i
-    i@AnnMUL{} -> RfNormal i
-    i@AnnEDIV{} -> RfNormal i
-    i@AnnABS{} -> RfNormal i
-    i@AnnNEG{} -> RfNormal i
-    i@AnnLSL{} -> RfNormal i
-    i@AnnLSR{} -> RfNormal i
-    i@AnnOR{} -> RfNormal i
-    i@AnnAND{} -> RfNormal i
-    i@AnnXOR{} -> RfNormal i
-    i@AnnNOT{} -> RfNormal i
-    i@AnnCOMPARE{} -> RfNormal i
-    i@AnnEQ{} -> RfNormal i
-    i@AnnNEQ{} -> RfNormal i
-    i@AnnLT{} -> RfNormal i
-    i@AnnGT{} -> RfNormal i
-    i@AnnLE{} -> RfNormal i
-    i@AnnGE{} -> RfNormal i
-    i@AnnINT{} -> RfNormal i
-    i@AnnVIEW{} -> RfNormal i
-    i@AnnSELF{} -> RfNormal i
-    i@AnnCONTRACT{} -> RfNormal i
-    i@AnnTRANSFER_TOKENS{} -> RfNormal i
-    i@AnnSET_DELEGATE{} -> RfNormal i
-    i@AnnCREATE_CONTRACT{} -> RfNormal i
-    i@AnnIMPLICIT_ACCOUNT{} -> RfNormal i
-    i@AnnNOW{} -> RfNormal i
-    i@AnnAMOUNT{} -> RfNormal i
-    i@AnnBALANCE{} -> RfNormal i
-    i@AnnVOTING_POWER{} -> RfNormal i
-    i@AnnTOTAL_VOTING_POWER{} -> RfNormal i
-    i@AnnCHECK_SIGNATURE{} -> RfNormal i
-    i@AnnSHA256{} -> RfNormal i
-    i@AnnSHA512{} -> RfNormal i
-    i@AnnBLAKE2B{} -> RfNormal i
-    i@AnnSHA3{} -> RfNormal i
-    i@AnnKECCAK{} -> RfNormal i
-    i@AnnHASH_KEY{} -> RfNormal i
-    i@AnnPAIRING_CHECK{} -> RfNormal i
-    i@AnnSOURCE{} -> RfNormal i
-    i@AnnSENDER{} -> RfNormal i
-    i@AnnADDRESS{} -> RfNormal i
-    i@AnnCHAIN_ID{} -> RfNormal i
-    i@AnnLEVEL{} -> RfNormal i
-    i@AnnSELF_ADDRESS{} -> RfNormal i
-    NEVER -> RfAlwaysFails NEVER
-    i@AnnTICKET{} -> RfNormal i
-    i@AnnREAD_TICKET{} -> RfNormal i
-    i@AnnSPLIT_TICKET{} -> RfNormal i
-    i@AnnJOIN_TICKETS{} -> RfNormal i
-    i@AnnOPEN_CHEST{} -> RfNormal i
-    i@AnnSAPLING_EMPTY_STATE{} -> RfNormal i
-    i@AnnSAPLING_VERIFY_UPDATE{} -> RfNormal i
-    i@AnnMIN_BLOCK_TIME{} -> RfNormal i
-    i@AnnEMIT{} -> RfNormal i
+  go i' = i' & withClassifiedInstr \case
+    SAlwaysFailing -> \case
+      C_FAILWITH -> RfAlwaysFails FAILWITH
+      C_NEVER -> RfAlwaysFails NEVER
+    SFailingNormal -> withClassifiedInstr \case
+      SNoChildren -> const $ RfNormal i'
+      SHasIndirectChildren -> const $ RfNormal i'
+      SMayHaveChildren -> \case
+        C_Ext _ -> RfNormal i'
+      STwoChildren -> \case
+        C_Seq a b -> Seq a `rfMapAnyInstr` go b
+        C_IF_NONE l r -> rfMerge IF_NONE (go l) (go r)
+        C_IF_LEFT l r -> rfMerge IF_LEFT (go l) (go r)
+        C_IF_CONS l r -> rfMerge IF_CONS (go l) (go r)
+        C_IF l r -> rfMerge IF (go l) (go r)
+      SOneChild -> withClassifiedInstr \case
+        SFromMichelson -> const $ RfNormal i'
+        _ -> \case
+          C_WithLoc loc i -> WithLoc loc `rfMapAnyInstr` go i
+          C_Meta meta i -> Meta meta `rfMapAnyInstr` go i
+          C_FrameInstr s i -> case go i of
+            RfNormal i0 ->
+              RfNormal (FrameInstr s i0)
+            RfAlwaysFails i0 ->
+              error $ "FrameInstr wraps always-failing instruction: " <> Debug.show i0
+          C_Nested i -> Nested `rfMapAnyInstr` go i
+          C_DocGroup g i -> DocGroup g `rfMapAnyInstr` go 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@.
@@ -520,9 +320,13 @@
   VOp{} -> dsValueStep i
   VContract{} -> dsValueStep i
   VTicket{} -> dsValueStep i  -- cannot appear as constant in a contract
-  VLam lambda -> do
-    v <- fmap (VLam . analyzeInstrFailure) $ dfsTraverseInstr settings (rfAnyInstr lambda)
-    dsValueStep v
+  VLam code -> case code of
+    LambdaCode lambda -> do
+      v <- fmap (VLam . LambdaCode . analyzeInstrFailure) $ dfsTraverseInstr settings (rfAnyInstr lambda)
+      dsValueStep v
+    LambdaCodeRec lambda -> do
+      v <- fmap (VLam . LambdaCodeRec . analyzeInstrFailure) $ dfsTraverseInstr settings (rfAnyInstr lambda)
+      dsValueStep v
   VInt{} -> dsValueStep i
   VNat{} -> dsValueStep i
   VString{} -> dsValueStep i
@@ -822,125 +626,11 @@
 --
 -- This function is helpful e.g. in debugger.
 isMichelsonInstr :: Instr i o -> Bool
-isMichelsonInstr = \case
-  WithLoc{} -> False
-  Meta{} -> False
-  FrameInstr{} -> False
-  Seq{} -> True
-  Nop -> False
-  Ext{} -> False
-  Nested{} -> True
-  DocGroup{} -> False
-  AnnCAR{} -> True
-  AnnCDR{} -> True
-  DROP{} -> True
-  DROPN{} -> True
-  AnnDUP{} -> True
-  AnnDUPN{} -> True
-  SWAP{} -> True
-  DIG{} -> True
-  DUG{} -> True
-  AnnPUSH{} -> True
-  AnnSOME{} -> True
-  AnnNONE{} -> True
-  AnnUNIT{} -> True
-  IF_NONE{} -> True
-  AnnPAIR{} -> True
-  AnnUNPAIR{} -> True
-  AnnPAIRN{} -> True
-  UNPAIRN{} -> True
-  AnnLEFT{} -> True
-  AnnRIGHT{} -> True
-  IF_LEFT{} -> True
-  AnnNIL{} -> True
-  AnnCONS{} -> True
-  IF_CONS{} -> True
-  AnnSIZE{} -> True
-  AnnEMPTY_SET{} -> True
-  AnnEMPTY_MAP{} -> True
-  AnnEMPTY_BIG_MAP{} -> True
-  AnnMAP{} -> True
-  ITER{} -> True
-  AnnMEM{} -> True
-  AnnGET{} -> True
-  AnnGETN{} -> True
-  AnnUPDATE{} -> True
-  AnnUPDATEN{} -> True
-  AnnGET_AND_UPDATE{} -> True
-  IF{} -> True
-  LOOP{} -> True
-  LOOP_LEFT{} -> True
-  AnnLAMBDA{} -> True
-  AnnEXEC{} -> True
-  AnnAPPLY{} -> True
-  DIP{} -> True
-  DIPN{} -> True
-  FAILWITH{} -> True
-  AnnCAST{} -> True
-  AnnRENAME{} -> True
-  AnnPACK{} -> True
-  AnnUNPACK{} -> True
-  AnnCONCAT{} -> True
-  AnnCONCAT'{} -> True
-  AnnSLICE{} -> True
-  AnnISNAT{} -> True
-  AnnADD{} -> True
-  AnnSUB{} -> True
-  AnnSUB_MUTEZ{} -> True
-  AnnMUL{} -> True
-  AnnEDIV{} -> True
-  AnnABS{} -> True
-  AnnNEG{} -> True
-  AnnLSL{} -> True
-  AnnLSR{} -> True
-  AnnOR{} -> True
-  AnnAND{} -> True
-  AnnXOR{} -> True
-  AnnNOT{} -> True
-  AnnCOMPARE{} -> True
-  AnnEQ{} -> True
-  AnnNEQ{} -> True
-  AnnLT{} -> True
-  AnnGT{} -> True
-  AnnLE{} -> True
-  AnnGE{} -> True
-  AnnINT{} -> True
-  AnnVIEW{} -> True
-  AnnSELF{} -> True
-  AnnCONTRACT{} -> True
-  AnnTRANSFER_TOKENS{} -> True
-  AnnSET_DELEGATE{} -> True
-  AnnCREATE_CONTRACT{} -> True
-  AnnIMPLICIT_ACCOUNT{} -> True
-  AnnNOW{} -> True
-  AnnAMOUNT{} -> True
-  AnnBALANCE{} -> True
-  AnnVOTING_POWER{} -> True
-  AnnTOTAL_VOTING_POWER{} -> True
-  AnnCHECK_SIGNATURE{} -> True
-  AnnSHA256{} -> True
-  AnnSHA512{} -> True
-  AnnBLAKE2B{} -> True
-  AnnSHA3{} -> True
-  AnnKECCAK{} -> True
-  AnnHASH_KEY{} -> True
-  AnnPAIRING_CHECK{} -> True
-  AnnSOURCE{} -> True
-  AnnSENDER{} -> True
-  AnnADDRESS{} -> True
-  AnnCHAIN_ID{} -> True
-  AnnLEVEL{} -> True
-  AnnSELF_ADDRESS{} -> True
-  NEVER{} -> True
-  AnnTICKET{} -> True
-  AnnREAD_TICKET{} -> True
-  AnnSPLIT_TICKET{} -> True
-  AnnJOIN_TICKETS{} -> True
-  AnnOPEN_CHEST{} -> True
-  AnnSAPLING_EMPTY_STATE{} -> True
-  AnnSAPLING_VERIFY_UPDATE{} -> True
-  AnnMIN_BLOCK_TIME{} -> True
-  AnnEMIT{} -> True
+isMichelsonInstr = withClassifiedInstr $ const . \case
+  SFromMichelson -> True
+  SStructural -> True
+  SAdditional -> False
+  SPhantom -> False
 
 -- | A wrapper around either typechecked 'Anns' or unchecked 'NonEmpty' of
 -- 'AnyAnn'. Annotations on some instructions aren't typechecked, hence these
@@ -954,125 +644,25 @@
 -- | Get annotations from a typed 'Instr'. This doesn't recurse, use with
 -- 'dfsFoldInstr' to collect all annotations in a tree/sequence.
 instrAnns :: Instr i o -> Maybe SomeAnns
-instrAnns = \case
-  WithLoc{} -> mzero
-  Meta{} -> mzero
-  FrameInstr{} -> mzero
-  Seq{} -> mzero
-  Nop -> mzero
-  Ext{} -> mzero
-  Nested{} -> mzero
-  DocGroup{} -> mzero
-  AnnCAR anns -> pure $ SomeAnns anns
-  AnnCDR anns -> pure $ SomeAnns anns
-  DROP -> mzero
-  DROPN _ -> mzero
-  AnnDUP anns -> pure $ SomeAnns anns
-  AnnDUPN anns _ -> pure $ SomeAnns anns
-  SWAP -> mzero
-  DIG _ -> mzero
-  DUG _ -> mzero
-  AnnPUSH anns _ -> pure $ SomeAnns anns
-  AnnSOME anns -> pure $ SomeAnns anns
-  AnnNONE anns -> pure $ SomeAnns anns
-  AnnUNIT anns -> pure $ SomeAnns anns
-  IF_NONE _ _ -> mzero
-  AnnPAIR anns -> pure $ SomeAnns anns
-  AnnUNPAIR anns -> pure $ SomeAnns anns
-  AnnPAIRN anns _ -> pure $ SomeAnns anns
-  UNPAIRN _ -> mzero
-  AnnLEFT anns -> pure $ SomeAnns anns
-  AnnRIGHT anns -> pure $ SomeAnns anns
-  IF_LEFT _ _ -> mzero
-  AnnNIL anns -> pure $ SomeAnns anns
-  AnnCONS anns -> pure $ SomeAnns anns
-  IF_CONS _ _ -> mzero
-  AnnSIZE anns -> pure $ SomeAnns anns
-  AnnEMPTY_SET anns -> pure $ SomeAnns anns
-  AnnEMPTY_MAP anns -> pure $ SomeAnns anns
-  AnnEMPTY_BIG_MAP anns -> pure $ SomeAnns anns
-  AnnMAP anns _ -> pure $ SomeAnns anns
-  ITER _ -> mzero
-  AnnMEM anns -> pure $ SomeAnns anns
-  AnnGET anns -> pure $ SomeAnns anns
-  AnnGETN anns _ -> pure $ SomeAnns anns
-  AnnUPDATE anns -> pure $ SomeAnns anns
-  AnnUPDATEN anns _ -> pure $ SomeAnns anns
-  AnnGET_AND_UPDATE anns -> pure $ SomeAnns anns
-  IF _ _ -> mzero
-  LOOP _ -> mzero
-  LOOP_LEFT _ -> mzero
-  AnnLAMBDA anns _ -> pure $ SomeAnns anns
-  AnnEXEC anns -> pure $ SomeAnns anns
-  AnnAPPLY anns -> pure $ SomeAnns anns
-  DIP _ -> mzero
-  DIPN _ _ -> mzero
-  FAILWITH -> mzero
-  AnnCAST anns -> pure $ SomeAnns anns
-  AnnRENAME anns -> pure $ SomeAnns anns
-  AnnPACK anns -> pure $ SomeAnns anns
-  AnnUNPACK anns -> pure $ SomeAnns anns
-  AnnCONCAT anns -> pure $ SomeAnns anns
-  AnnCONCAT' anns -> pure $ SomeAnns anns
-  AnnSLICE anns -> pure $ SomeAnns anns
-  AnnISNAT anns -> pure $ SomeAnns anns
-  AnnADD anns -> pure $ SomeAnns anns
-  AnnSUB anns -> pure $ SomeAnns anns
-  AnnSUB_MUTEZ anns -> pure $ SomeAnns anns
-  AnnMUL anns -> pure $ SomeAnns anns
-  AnnEDIV anns -> pure $ SomeAnns anns
-  AnnABS anns -> pure $ SomeAnns anns
-  AnnNEG anns -> pure $ SomeAnns anns
-  AnnLSL anns -> pure $ SomeAnns anns
-  AnnLSR anns -> pure $ SomeAnns anns
-  AnnOR anns -> pure $ SomeAnns anns
-  AnnAND anns -> pure $ SomeAnns anns
-  AnnXOR anns -> pure $ SomeAnns anns
-  AnnNOT anns -> pure $ SomeAnns anns
-  AnnCOMPARE anns -> pure $ SomeAnns anns
-  AnnEQ anns -> pure $ SomeAnns anns
-  AnnNEQ anns -> pure $ SomeAnns anns
-  AnnLT anns -> pure $ SomeAnns anns
-  AnnGT anns -> pure $ SomeAnns anns
-  AnnLE anns -> pure $ SomeAnns anns
-  AnnGE anns -> pure $ SomeAnns anns
-  AnnINT anns -> pure $ SomeAnns anns
-  AnnVIEW anns _ -> pure $ SomeAnns anns
-  AnnSELF anns _ -> pure $ SomeAnns anns
-  AnnCONTRACT anns _ -> pure $ SomeAnns anns
-  AnnTRANSFER_TOKENS anns -> pure $ SomeAnns anns
-  AnnSET_DELEGATE anns -> pure $ SomeAnns anns
-  AnnCREATE_CONTRACT anns _ -> pure $ SomeAnns anns
-  AnnIMPLICIT_ACCOUNT anns -> pure $ SomeAnns anns
-  AnnNOW anns -> pure $ SomeAnns anns
-  AnnAMOUNT anns -> pure $ SomeAnns anns
-  AnnBALANCE anns -> pure $ SomeAnns anns
-  AnnVOTING_POWER anns -> pure $ SomeAnns anns
-  AnnTOTAL_VOTING_POWER anns -> pure $ SomeAnns anns
-  AnnCHECK_SIGNATURE anns -> pure $ SomeAnns anns
-  AnnSHA256 anns -> pure $ SomeAnns anns
-  AnnSHA512 anns -> pure $ SomeAnns anns
-  AnnBLAKE2B anns -> pure $ SomeAnns anns
-  AnnSHA3 anns -> pure $ SomeAnns anns
-  AnnKECCAK anns -> pure $ SomeAnns anns
-  AnnHASH_KEY anns -> pure $ SomeAnns anns
-  AnnPAIRING_CHECK anns -> pure $ SomeAnns anns
-  AnnSOURCE anns -> pure $ SomeAnns anns
-  AnnSENDER anns -> pure $ SomeAnns anns
-  AnnADDRESS anns -> pure $ SomeAnns anns
-  AnnCHAIN_ID anns -> pure $ SomeAnns anns
-  AnnLEVEL anns -> pure $ SomeAnns anns
-  AnnSELF_ADDRESS anns -> pure $ SomeAnns anns
-  NEVER -> mzero
-  AnnTICKET anns -> pure $ SomeAnns anns
-  AnnREAD_TICKET anns -> pure $ SomeAnns anns
-  AnnSPLIT_TICKET anns -> pure $ SomeAnns anns
-  AnnJOIN_TICKETS anns -> pure $ SomeAnns anns
-  AnnOPEN_CHEST anns -> pure $ SomeAnns anns
-  AnnSAPLING_EMPTY_STATE anns _ -> pure $ SomeAnns anns
-  AnnSAPLING_VERIFY_UPDATE anns -> pure $ SomeAnns anns
-  AnnMIN_BLOCK_TIME anns -> SomeUncheckedAnns <$> nonEmpty anns
-  AnnEMIT anns tag ty -> pure $
-    case ty of
-      Just ty' -> SomeAnns $ tag `AnnsCons` ty' `AnnsTyCons` anns
-      Nothing -> SomeAnns $ tag `AnnsCons` anns
+instrAnns = withClassifiedInstr \case
+  SDoesNotHaveAnns -> const mzero
+  SDoesHaveStandardAnns -> $(do
+    TH.TyConI (TH.DataD _ _ _ _ cons _) <- TH.reify ''ClassifiedInstr
+    let mkMatch = \case
+          TH.ForallC _ _ con -> mkMatch con
+          TH.GadtC [nm] tys res
+            | null $ listify (== 'DoesHaveStandardAnns) res
+            -> Nothing
+            | otherwise
+            -> Just $ TH.match
+              (TH.conP nm ([p|anns|] : replicate (length $ drop 1 tys) TH.wildP))
+              (TH.normalB [|pure $ SomeAnns anns|]) []
+          x -> error $ "Unexpected constructor " <> show (TH.ppr x)
+    TH.lamCaseE $ mapMaybe mkMatch cons
+    )
+  SDoesHaveNonStandardAnns -> \case
+    C_AnnMIN_BLOCK_TIME anns -> SomeUncheckedAnns <$> nonEmpty anns
+    C_AnnEMIT anns' tag ty ->
+      pure $ case ty of
+        Just ty' -> SomeAnns $ tag `AnnsCons` ty' `AnnsTyCons` anns'
+        Nothing -> SomeAnns $ tag `AnnsCons` anns'
diff --git a/src/Morley/Michelson/Typed/Value.hs b/src/Morley/Michelson/Typed/Value.hs
--- a/src/Morley/Michelson/Typed/Value.hs
+++ b/src/Morley/Michelson/Typed/Value.hs
@@ -12,7 +12,9 @@
   , Emit(..)
   , Value' (..)
   , RemFail (..)
+  , LambdaCode' (..)
   , mkVLam
+  , mkVLamRec
   , rfMerge
   , rfAnyInstr
   , rfMapAnyInstr
@@ -29,6 +31,7 @@
 
 import Control.Lens (At(..), Index, IxValue, Ixed(..))
 import Data.Constraint (Dict(..), (\\))
+import Data.GADT.Compare (GEq(..))
 import Fmt (Buildable(build), Builder, (+|), (|+))
 
 import Morley.Michelson.Text (MText)
@@ -41,7 +44,7 @@
 import Morley.Tezos.Core (ChainId, Mutez, Timestamp)
 import Morley.Tezos.Crypto
   (Bls12381Fr, Bls12381G1, Bls12381G2, Chest, ChestKey, KeyHash, PublicKey, Signature)
-import Morley.Util.Sing (eqParamMixed3, eqParamSing)
+import Morley.Util.Sing (eqParamMixed3, eqParamSing, geqI)
 import Morley.Util.TH
 
 -- | Data type, representing operation, list of which is returned
@@ -62,7 +65,7 @@
     -> Operation' instr
   OpEmit :: PackedValScope t => Emit instr t -> Operation' instr
 
-instance Buildable (Operation' instr) where
+instance (forall t. Buildable (Value' instr t)) => Buildable (Operation' instr) where
   build =
     \case
       OpTransferTokens tt -> build tt
@@ -90,9 +93,10 @@
   , ttCounter :: GlobalCounter
   } deriving stock (Show, Eq, Generic)
 
-instance Buildable (TransferTokens instr p) where
+instance Buildable (Value' instr p) => Buildable (TransferTokens instr p) where
   build TransferTokens {..} =
-    "Transfer " +| ttAmount |+ " tokens to " +| buildVContract ttContract |+ ""
+    "Transfer " +| ttAmount |+ " tokens to " +| buildVContract ttContract |+
+      " with parameter " +| ttTransferArgument |+ ""
 
 data SetDelegate = SetDelegate
   { sdMbKeyHash :: Maybe KeyHash
@@ -118,11 +122,12 @@
   , ccCounter :: GlobalCounter
   }
 
-instance Buildable (CreateContract instr cp st) where
+instance Buildable (Value' instr st) => Buildable (CreateContract instr cp st) where
   build CreateContract {..} =
     "Create a new contract with" <>
     " delegate " +| maybe "<nobody>" build ccDelegate |+
-    " and balance = " +| ccBalance |+ ""
+    ", balance = " +| ccBalance |+
+    " and storage =" +| ccStorageVal |+ ""
 
 deriving stock instance Show (CreateContract instr cp st)
 deriving stock instance Eq (CreateContract instr cp st)
@@ -137,8 +142,9 @@
 deriving stock instance Show (Emit instr t)
 deriving stock instance Eq (Emit instr t)
 
-instance Buildable (Emit instr t) where
-  build Emit{..} = "Emit contract event with tag " +| emTag |+ " and type " +| emNotes |+ ""
+instance Buildable (Value' instr t) => Buildable (Emit instr t) where
+  build Emit{..} = "Emit contract event with tag " +| emTag |+ ", type " +| emNotes |+
+    " and payload " +| emValue |+ ""
 
 -- | Wrapper over instruction which remembers whether this instruction
 -- always fails or not.
@@ -251,7 +257,7 @@
        , forall i o. Eq (instr i o)
        , forall i o. NFData (instr i o)
        )
-    => RemFail instr (inp ': '[]) (out ': '[])
+    => LambdaCode' instr inp out
     -> Value' instr ('TLambda inp out)
   VMap
     :: forall k v instr.
@@ -282,6 +288,26 @@
 deriving stock instance Show (Value' instr t)
 deriving stock instance Eq (Value' instr t)
 
+data LambdaCode' instr inp out where
+  LambdaCode
+    :: ( forall i o. Show (instr i o)
+       , forall i o. Eq (instr i o)
+       , forall i o. NFData (instr i o))
+    => RemFail instr (inp ': '[]) (out ': '[])
+    -> LambdaCode' instr inp out
+  LambdaCodeRec
+    :: ( forall i o. Show (instr i o)
+       , forall i o. Eq (instr i o)
+       , forall i o. NFData (instr i o))
+    => RemFail instr (inp ': 'TLambda inp out ': '[]) (out ': '[])
+    -> LambdaCode' instr inp out
+
+deriving stock instance Show (LambdaCode' instr inp out)
+deriving stock instance Eq (LambdaCode' instr inp out)
+
+instance GEq (Value' instr) where
+  geq l r = geqI l r \\ valueTypeSanity l \\ valueTypeSanity r
+
 -- | Make value of @contract@ type which refers to the given address and
 -- does not call any entrypoint.
 addressToVContract
@@ -355,13 +381,26 @@
   VChestKey{} -> Dict
   VTxRollupL2Address{} -> Dict
 
-mkVLam :: (t ~ 'TLambda inp 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)) =>
-          (IsNotInView => RemFail instr '[inp] '[out]) -> Value' instr t
-mkVLam rf = VLam $ giveNotInView rf
+mkVLam
+  :: ( 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)
+     )
+  => (IsNotInView => RemFail instr '[inp] '[out])
+  -> Value' instr ('TLambda inp out)
+mkVLam rf = VLam . LambdaCode $ giveNotInView rf
 
+mkVLamRec
+  :: ( 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)
+     )
+  => (IsNotInView => RemFail instr '[inp, 'TLambda inp out] '[out])
+  -> Value' instr ('TLambda inp out)
+mkVLamRec rf = VLam . LambdaCodeRec $ giveNotInView rf
+
 -- | Provide a witness of that value's type is known.
 withValueTypeSanity :: Value' instr t -> (SingI t => a) -> a
 withValueTypeSanity v a = case valueTypeSanity v of Dict -> a
@@ -382,6 +421,7 @@
   |]
   , deriveGADTNFData ''Operation'
   , deriveGADTNFData ''Value'
+  , deriveGADTNFData ''LambdaCode'
   ]
 
 instance NFData (Emit instr t) where
diff --git a/src/Morley/Michelson/Untyped/Entrypoints.hs b/src/Morley/Michelson/Untyped/Entrypoints.hs
--- a/src/Morley/Michelson/Untyped/Entrypoints.hs
+++ b/src/Morley/Michelson/Untyped/Entrypoints.hs
@@ -13,6 +13,7 @@
   , EpNameFromRefAnnError (..)
   , buildEpName
   , mkEntrypointsMap
+  , HandleImplicitDefaultEp(..)
   ) where
 
 import Data.Aeson.TH (deriveJSON)
@@ -155,14 +156,29 @@
   getReader = eitherReader (buildEpName . toText)
   getMetavar = "ENTRYPOINT"
 
+-- | A simple enum flag to choose how to handle implicit default entrypoint in
+-- 'mkEntrypointsMap'.
+data HandleImplicitDefaultEp
+  = WithoutImplicitDefaultEp
+    -- ^ Omit the default entrypoint unless it's specified explicitly.
+  | WithImplicitDefaultEp
+    -- ^ Include the default entrypoint even if it's not specified explicitly.
+    -- This produces exactly the full set of entrypoints as per Michelson spec.
+  deriving stock (Show, Eq, Ord, Enum)
+
 -- | Given an untyped parameter type, extract a map that maps entrypoint names
 -- to the their parameter types. If there are duplicate entrypoints in the
 -- given Type then the duplicate entrypoints at a deeper nesting level will get
 -- overwritten with the ones that are on top.
-mkEntrypointsMap :: ParameterType -> Map EpName Ty
-mkEntrypointsMap (ParameterType ty rootAnn) = mkEntrypointsMapRec rootAnn ty
+mkEntrypointsMap :: HandleImplicitDefaultEp -> ParameterType -> Map EpName Ty
+mkEntrypointsMap hide (ParameterType ty rootAnn) = mkEntrypointsMapRec rootAnn ty & case hide of
+  WithImplicitDefaultEp -> Map.insertWith (flip const) DefEpName ty
+  WithoutImplicitDefaultEp -> id
 
 -- | Version of 'mkEntrypointsMap' for plain untyped type.
+--
+-- Note that this function does not handle implicit default entrypoint, in all
+-- likelihood you want to use 'mkEntrypointsMap'.
 mkEntrypointsMapRec :: FieldAnn -> Ty -> Map EpName Ty
 mkEntrypointsMapRec curRootAnn ty =
   accountRoot curRootAnn <> accountTree ty
diff --git a/src/Morley/Michelson/Untyped/Instr.hs b/src/Morley/Michelson/Untyped/Instr.hs
--- a/src/Morley/Michelson/Untyped/Instr.hs
+++ b/src/Morley/Michelson/Untyped/Instr.hs
@@ -22,7 +22,7 @@
 
 import Morley.Michelson.ErrorPos (ErrorSrcPos)
 import Morley.Michelson.Printer.Util
-  (RenderDoc(..), buildRenderDoc, doesntNeedParens, needsParens, renderOpsList, spaces)
+  (RenderDoc(..), buildRenderDoc, doesntNeedParens, needsParens, renderOpsList)
 import Morley.Michelson.Untyped.Annotation
   (Annotation, AnyAnn, FieldAnn, KnownAnnTag, TypeAnn, VarAnn, fullAnnSet, renderAnyAnns,
   singleAnnSet)
@@ -145,6 +145,7 @@
   | LOOP              [op]
   | LOOP_LEFT         [op]
   | LAMBDA            VarAnn Ty Ty [op]
+  | LAMBDA_REC        VarAnn Ty Ty [op]
   | EXEC              VarAnn
   | APPLY             VarAnn
   | DIP               [op]
@@ -206,6 +207,7 @@
   | SELF_ADDRESS      VarAnn
   | NEVER
   | TICKET            VarAnn
+  | TICKET_DEPRECATED VarAnn
   | READ_TICKET       VarAnn
   | SPLIT_TICKET      VarAnn
   | JOIN_TICKETS      VarAnn
@@ -236,7 +238,7 @@
     SOME ta va              -> "SOME" <+> renderAnnots [ta] [] [va]
     NONE ta va t            -> "NONE" <+> renderAnnots [ta] [] [va] <+> renderTy t
     UNIT ta va              -> "UNIT" <+> renderAnnots [ta] [] [va]
-    IF_NONE x y             -> "IF_NONE" <+> nest 9 (renderOps x) <$$> spaces 8 <> nest 9 (renderOps y)
+    IF_NONE x y             -> "IF_NONE" <+> PP.align (renderOps x PP.<$> 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)
@@ -245,30 +247,39 @@
     CDR va fa               -> "CDR" <+> renderAnnots [] [fa] [va]
     LEFT ta va fa1 fa2 t    -> "LEFT" <+> renderAnnots [ta] [fa1, fa2] [va] <+> renderTy t
     RIGHT ta va fa1 fa2 t   -> "RIGHT" <+> renderAnnots [ta] [fa1, fa2] [va] <+> renderTy t
-    IF_LEFT x y             -> "IF_LEFT" <+> nest 9 (renderOps x) <$$> spaces 8 <> nest 9 (renderOps y)
+    IF_LEFT x y             -> "IF_LEFT" <+> PP.align (renderOps x PP.<$> renderOps y)
     NIL ta va t             -> "NIL" <+> renderAnnots [ta] [] [va] <+> renderTy t
     CONS va                 -> "CONS" <+> renderAnnot va
-    IF_CONS x y             -> "IF_CONS" <+> nest 9 (renderOps x) <$$> spaces 8 <> nest 9 (renderOps y)
+    IF_CONS x y             -> "IF_CONS" <+> PP.align (renderOps x PP.<$> renderOps y)
     SIZE va                 -> "SIZE" <+> renderAnnot va
     EMPTY_SET ta va t       -> "EMPTY_SET" <+> renderAnnots [ta] [] [va] <+> renderComp t
     EMPTY_MAP ta va c t     -> "EMPTY_MAP" <+> renderAnnots [ta] [] [va] <+> renderComp c <+> renderTy t
     EMPTY_BIG_MAP ta va c t -> "EMPTY_BIG_MAP" <+> renderAnnots [ta] [] [va] <+> renderComp c <+> renderTy t
-    MAP va s                -> "MAP" <+> renderAnnot va <$$> spaces 4 <> nest 5 (renderOps s)
-    ITER s                  -> "ITER" <+> nest 6 (renderOps s)
+    MAP va s                -> "MAP" <+> PP.align (renderAnnot va PP.<$> renderOps s)
+    ITER s                  -> "ITER" <+> PP.align (renderOps s)
     MEM va                  -> "MEM" <+> renderAnnot va
     GET va                  -> "GET" <+> renderAnnot va
     GETN va n               -> "GET" <+> renderAnnot va <+> text (show n)
     UPDATE va               -> "UPDATE" <+> renderAnnot va
     UPDATEN va n            -> "UPDATE" <+> renderAnnot va <+> text (show n)
     GET_AND_UPDATE va       -> "GET_AND_UPDATE" <+> renderAnnot va
-    IF x y                  -> "IF" <+> nest 4 (renderOps x) <$$> spaces 3 <> nest 4 (renderOps y)
-    LOOP s                  -> "LOOP" <+> nest 6 (renderOps s)
-    LOOP_LEFT s             -> "LOOP_LEFT" <+> nest 11 (renderOps s)
-    LAMBDA va t r s         -> "LAMBDA" <+> renderAnnot va <$$> (spaces 2 <> renderTy t) <$$> (spaces 2 <> renderTy r) <$$> spaces 2 <> nest 3 (renderOps s)
+    IF x y                  -> "IF" <+> PP.align (renderOps x PP.<$> renderOps y)
+    LOOP s                  -> "LOOP" <+> PP.align (renderOps s)
+    LOOP_LEFT s             -> "LOOP_LEFT" <+> PP.align (renderOps s)
+    LAMBDA va t r s         ->
+      nest 2 $ "LAMBDA" <+> renderAnnot va
+        PP.<$> renderTy t
+        PP.<$> renderTy r
+        PP.<$> renderOps s
+    LAMBDA_REC va t r s     ->
+      nest 2 $ "LAMBDA_REC" <+> renderAnnot va
+        PP.<$> renderTy t
+        PP.<$> renderTy r
+        PP.<$> renderOps s
     EXEC va                 -> "EXEC" <+> renderAnnot va
     APPLY va                -> "APPLY" <+> renderAnnot va
-    DIP s                   -> "DIP" <+> nest 5 (renderOps s)
-    DIPN n s                -> "DIP" <+> text (show n) PP.<$> indent 4 (renderOps s)
+    DIP s                   -> "DIP" <+> PP.align (renderOps s)
+    DIPN n s                -> "DIP" <+> PP.align (text (show n) PP.<$> renderOps s)
     FAILWITH                -> "FAILWITH"
     CAST va t               -> "CAST" <+> renderAnnot va <+> renderTy t
     RENAME va               -> "RENAME" <+> renderAnnot va
@@ -328,6 +339,7 @@
     SELF_ADDRESS va          -> "SELF_ADDRESS" <+> renderAnnot va
     NEVER                    -> "NEVER"
     TICKET va                -> "TICKET" <+> renderAnnot va
+    TICKET_DEPRECATED va     -> "TICKET_DEPRECATED" <+> renderAnnot va
     READ_TICKET va           -> "READ_TICKET" <+> renderAnnot va
     SPLIT_TICKET va          -> "SPLIT_TICKET" <+> renderAnnot va
     JOIN_TICKETS va          -> "JOIN_TICKETS" <+> renderAnnot va
diff --git a/src/Morley/Michelson/Untyped/Value.hs b/src/Morley/Michelson/Untyped/Value.hs
--- a/src/Morley/Michelson/Untyped/Value.hs
+++ b/src/Morley/Michelson/Untyped/Value.hs
@@ -56,6 +56,7 @@
   -- We can't distinguish lists and sets during parsing.
   | ValueMap     (NonEmpty $ Elt op)
   | ValueLambda  (NonEmpty op)
+  | ValueLamRec  (NonEmpty op)
   deriving stock (Eq, Show, Functor, Data, Generic)
 
 instance NFData op => NFData (Value' op)
@@ -96,6 +97,7 @@
       ValueSeq xs    -> renderValuesList (renderDoc doesntNeedParens) xs
       ValueMap xs    -> renderValuesList renderElt xs
       ValueLambda xs -> renderOps False xs
+      ValueLamRec xs -> "Lambda_rec" <+> PP.align (renderOps False xs)
 
 -- | Helper function to render @None@ @Value@
 renderNone :: Doc
diff --git a/src/Morley/Tezos/Address.hs b/src/Morley/Tezos/Address.hs
--- a/src/Morley/Tezos/Address.hs
+++ b/src/Morley/Tezos/Address.hs
@@ -19,10 +19,14 @@
   , L1AddressKind
   , ConstrainAddressKind
   , Address
-  , ConstrainedAddress(.., MkAddress)
+  , ConstrainedAddress
+  , AnyParsableAddress(..)
+  , Constrained(.., MkConstrainedAddress, MkAddress)
 
   , GlobalCounter(..)
   , mkContractHashHack
+  , parseConstrainedAddress
+  , parseAnyAddress
 
   -- * Formatting
   , ParseAddressError (..)
@@ -37,6 +41,7 @@
   -- * Utilities
   , addressKindSanity
   , usingImplicitOrContractKind
+  , unImplicitAddress
   ) where
 
 import Control.Monad.Except (mapExceptT, throwError)
@@ -47,10 +52,15 @@
 import Data.Binary.Get qualified as Get
 import Data.ByteString qualified as BS
 import Data.ByteString.Lazy qualified as LBS
-import Data.Constraint (Dict(..), (\\))
-import Data.Singletons (SingI(..))
+import Data.Constraint (Bottom(..), Dict(..), (\\))
+import Data.Constraint.Extras (has)
+import Data.Constraint.Extras.TH (deriveArgDict)
+import Data.GADT.Compare.TH (deriveGCompare, deriveGEq)
+import Data.List.Singletons (SList(..))
+import Data.Singletons (Sing, SingI(..), demote)
+import Data.Some (Some(..))
 import Data.Text (strip)
-import Data.Type.Equality ((:~:)(..))
+import Data.Type.Equality (testEquality, (:~:)(..))
 import Fmt (Buildable(build), hexF, pretty)
 import Instances.TH.Lift ()
 import Language.Haskell.TH.Quote qualified as TH
@@ -64,7 +74,9 @@
 import Morley.Tezos.Crypto
 import Morley.Util.Binary
 import Morley.Util.CLI
+import Morley.Util.Constrained
 import Morley.Util.Sing
+import Morley.Util.TH
 import Morley.Util.TypeLits
 
 -- | A "kinded" address. This type carries 'AddressKind' on the type-level.
@@ -84,11 +96,10 @@
 deriving stock instance Ord (KindedAddress kind)
 deriving stock instance Lift (KindedAddress kind)
 
-instance NFData (KindedAddress kind) where
-  rnf = \case
-    ImplicitAddress x -> rnf x
-    ContractAddress x -> rnf x
-    TxRollupAddress x -> rnf x
+deriveGADTNFData ''KindedAddress
+deriveGEq ''KindedAddress
+deriveGCompare ''KindedAddress
+deriveArgDict ''KindedAddress
 
 -- | A type only allowing v'ImplicitAddress'
 type ImplicitAddress = KindedAddress 'AddressKindImplicit
@@ -100,9 +111,13 @@
 type TxRollupAddress = KindedAddress 'AddressKindTxRollup
 
 -- | Data type corresponding to @address@ structure in Tezos.
-type Address =
-  ConstrainedAddress '[ 'AddressKindImplicit, 'AddressKindContract, 'AddressKindTxRollup ]
+type Address = Constrained NullConstraint KindedAddress
 
+-- | 'Constrained' specialized to 'Address'
+pattern MkAddress :: KindedAddress kind -> Address
+pattern MkAddress x = Constrained x
+{-# COMPLETE MkAddress #-}
+
 type family ConstrainAddressKindHelper (ks :: [AddressKind]) kind where
   ConstrainAddressKindHelper (x ': _) x = 'True
   ConstrainAddressKindHelper (_ ': xs) x = ConstrainAddressKindHelper xs x
@@ -111,17 +126,27 @@
 type family CheckConstrainAddressKindError k b :: Constraint where
   CheckConstrainAddressKindError _ 'True = ()
   CheckConstrainAddressKindError k 'False =
-    TypeError ('ShowType k ':<>: 'Text "is forbidden in this context")
+    TypeError ('ShowType k ':<>: 'Text " is forbidden in this context")
 
 -- | Constrain address kind to be one of the kinds in the list.
-type ConstrainAddressKind ks k =
-  ( CheckConstrainAddressKindError k (ConstrainAddressKindHelper ks k)
-  , ConstrainAddressKindHelper ks k ~ 'True)
+type ConstrainAddressKind :: [AddressKind] -> AddressKind -> Constraint
+class ( CheckConstrainAddressKindError k (ConstrainAddressKindHelper ks k)
+  , ConstrainAddressKindHelper ks k ~ 'True) => ConstrainAddressKind ks k
+instance ( CheckConstrainAddressKindError k (ConstrainAddressKindHelper ks k)
+  , ConstrainAddressKindHelper ks k ~ 'True) => ConstrainAddressKind ks k
 
 -- | An existential of 'KindedAddress' constrained by its type argument.
-data ConstrainedAddress (ks :: [AddressKind]) =
-  forall kind. ConstrainAddressKind ks kind => MkConstrainedAddress (KindedAddress kind)
+type ConstrainedAddress (ks :: [AddressKind]) =
+  Constrained (ConstrainAddressKind ks) KindedAddress
 
+pattern MkConstrainedAddress
+  :: forall ks. ()
+  => forall kind. ConstrainAddressKind ks kind
+  => KindedAddress kind -> ConstrainedAddress ks
+pattern MkConstrainedAddress a = Constrained a
+{-# COMPLETE MkConstrainedAddress #-}
+{-# DEPRECATED MkConstrainedAddress "Use Constrained instead" #-}
+
 -- | A convenience synonym for 'ConstrainedAddress' allowing only implicit and
 -- contract addresses.
 --
@@ -146,51 +171,10 @@
 usingImplicitOrContractKind = id
   where _ = Dict :: Dict (L1AddressKind kind)
 
--- | 'MkConstrainedAddress' specialized to 'Address'
-pattern MkAddress :: KindedAddress kind -> Address
-pattern MkAddress x <- MkConstrainedAddress x
-  where MkAddress x = case x of
-          ImplicitAddress{} -> MkConstrainedAddress x
-          ContractAddress{} -> MkConstrainedAddress x
-          TxRollupAddress{} -> MkConstrainedAddress x
-
-{-# COMPLETE MkAddress #-}
-
-deriving stock instance Show (ConstrainedAddress c)
-instance Eq (ConstrainedAddress c) where
-  MkConstrainedAddress (addr1 :: KindedAddress kind1)
-    == MkConstrainedAddress (addr2 :: KindedAddress kind2) =
-    case eqI @kind1 @kind2 \\ addressKindSanity addr1 \\ addressKindSanity addr2 of
-      Just Refl -> addr1 == addr2
-      Nothing -> False
-instance Ord (ConstrainedAddress c) where
-  compare (MkConstrainedAddress (a1 :: KindedAddress kind1))
-          (MkConstrainedAddress (a2 :: KindedAddress kind2)) =
-    case (a1, a2) of
-      (k1, k2)
-        | Just Refl <- eqI @kind1 @kind2 \\ addressKindSanity k1 \\ addressKindSanity k2
-        -> compare k1 k2
-      (ImplicitAddress{}, _) -> LT
-      (ContractAddress{}, ImplicitAddress{}) -> GT
-      (ContractAddress{}, _) -> LT
-      (TxRollupAddress{}, ImplicitAddress{}) -> GT
-      (TxRollupAddress{}, ContractAddress{}) -> GT
-      (TxRollupAddress{}, _) -> LT
-deriving stock instance Lift (ConstrainedAddress c)
-
-instance NFData (ConstrainedAddress c) where
-  rnf (MkConstrainedAddress x) = rnf x
-
-instance Buildable (ConstrainedAddress c) where
-  build (MkConstrainedAddress x) = build x
-
 -- | Given any (non-bottom) 'KindedAddress', prove that @kind@ is well-defined
 -- (i.e. has a 'SingI' instance)
 addressKindSanity :: KindedAddress kind -> Dict (SingI kind)
-addressKindSanity = \case
-  ImplicitAddress{} -> Dict
-  ContractAddress{} -> Dict
-  TxRollupAddress{} -> Dict
+addressKindSanity a = has @SingI a Dict
 
 -- | @tz4@ level-2 public key hash address, used with transaction rollups, corresponds
 -- to @tx_rollup_l2_address@ Michelson type.
@@ -198,6 +182,14 @@
   deriving stock (Show, Eq, Ord, Generic, Lift)
   deriving newtype NFData
 
+-- | A sum type for any known parsable address (@tz1@ - @tz4@, @KT1@, @txr1@)
+data AnyParsableAddress
+  = AnyParsableL2Address TxRollupL2Address
+  | AnyParsableAddress Address
+  deriving stock (Show, Eq, Generic)
+
+instance NFData AnyParsableAddress
+
 -- | Checks if the provided 'KindedAddress' is an implicit address and returns
 -- proof of the fact if it is.
 isImplicitAddress :: KindedAddress kind -> Maybe (kind :~: 'AddressKindImplicit)
@@ -209,6 +201,9 @@
 mkKeyAddress :: PublicKey -> ImplicitAddress
 mkKeyAddress = ImplicitAddress . hashKey
 
+unImplicitAddress :: ImplicitAddress -> KeyHash
+unImplicitAddress (ImplicitAddress kh) = kh
+
 -- | Deterministically generate a random t'ImplicitAddress' and discard its
 -- secret key.
 detGenKeyAddress :: ByteString -> ImplicitAddress
@@ -263,17 +258,12 @@
 
 -- | Errors that can happen during address parsing.
 data ParseAddressError
-  = ParseAddressWrongBase58Check
-  -- ^ Address is not in Base58Check format.
-  | ParseAddressAllFailed (NonEmpty CryptoParseError)
-  -- ^ All address parsers failed with some error.
+  = ParseAddressCryptoError CryptoParseError
+  -- ^ The address parsers failed with some error.
+  | ParseAddressWrongKind [AddressKind] AnyParsableAddress
+  -- ^ The parsed address is of wrong kind
   deriving stock (Show, Eq, Generic)
 
-instance Semigroup ParseAddressError where
-  ParseAddressWrongBase58Check <> _ =  ParseAddressWrongBase58Check
-  _ <> ParseAddressWrongBase58Check =  ParseAddressWrongBase58Check
-  ParseAddressAllFailed xs <> ParseAddressAllFailed ys = ParseAddressAllFailed $ xs <> ys
-
 instance NFData ParseAddressError
 
 instance Buildable ParseAddressError where
@@ -282,39 +272,92 @@
 instance RenderDoc ParseAddressError where
   renderDoc context =
     \case
-      ParseAddressWrongBase58Check -> "Wrong base58check format"
-      ParseAddressAllFailed pkErr ->
-        mconcat $ "Address failed to parse: " : intersperse ", "
-          (toList $ renderDoc context <$> pkErr)
+      ParseAddressCryptoError pkErr -> "Address failed to parse: " <> renderDoc context pkErr
+      ParseAddressWrongKind expected (AnyParsableAddress (Constrained a)) -> mconcat
+        [ "Expected address of kind ", renderAddressKinds expected
+        , ", but got ", renderAnyBuildable a
+        ]
+      ParseAddressWrongKind expected (AnyParsableL2Address a) -> mconcat
+        [ "Expected address of kind ", renderAddressKinds expected
+        , ", but got unexpected TxRollupL2Address ", renderAnyBuildable a
+        ]
+    where
+      renderAddressKinds as = mconcat $ intersperse ", " (renderAnyBuildable <$> as)
 
 -- | Parse an address of a particular kind from its human-readable textual
 -- representation used by Tezos (e. g. "tz1faswCTDciRzE4oJ9jn2Vm2dvjeyA9fUzU").
 -- Or fail if it's invalid.
-parseKindedAddress :: forall kind. SingI kind => Text -> Either ParseAddressError (KindedAddress kind)
-parseKindedAddress addressText = case sing @kind of
-  SAddressKindContract -> tryParse ContractAddress
-  SAddressKindImplicit -> tryParse ImplicitAddress
-  SAddressKindTxRollup -> tryParse TxRollupAddress
-  where
-    handleCrypto = \case
-      CryptoParseWrongBase58Check -> ParseAddressWrongBase58Check
-      x -> ParseAddressAllFailed $ pure x
-    tryParse :: AllHashTags hkind => (Hash hkind -> b) -> Either ParseAddressError b
-    tryParse ctor = bimap handleCrypto ctor $ parseHash addressText
+parseKindedAddress
+  :: forall kind. SingI kind
+  => Text -> Either ParseAddressError (KindedAddress kind)
+parseKindedAddress addressText = do
+  Constrained a <- parseConstrainedAddress @'[kind] addressText
+  castSing a \\ addressKindSanity a &
+    maybeToRight (ParseAddressWrongKind [demote @kind] . AnyParsableAddress $ Constrained a)
 
+-- | Parse an 'ConstrainedAddress' of the given kinds from its human-readable textual
+--  representation. Maybe fail with a 'ParseAddressWrongKind' in case the address parsed
+--  is of wrong kind.
+parseConstrainedAddress
+  :: forall kinds . (SingI kinds)
+  => Text -> Either ParseAddressError (ConstrainedAddress kinds)
+parseConstrainedAddress addressText =
+  parseAddress addressText >>= castConstrainedAddress (demote @kinds) (sing @kinds)
+
+castConstrainedAddress
+  :: [AddressKind]
+  -> SList kinds
+  -> Address
+  -> Either ParseAddressError (ConstrainedAddress kinds)
+castConstrainedAddress allowed = \case
+  SNil -> Left . ParseAddressWrongKind allowed . AnyParsableAddress
+  SCons kind ks -> \case
+    Constrained (a :: KindedAddress kind')
+      | Just Refl <- testEquality kind (sing @kind') \\ addressKindSanity a
+      -> Right (Constrained a)
+    a -> recastAddress kind <$> castConstrainedAddress allowed ks a
+
+recastAddress
+  :: forall xs x. Sing x -> ConstrainedAddress xs -> ConstrainedAddress (x ': xs)
+recastAddress sx (Constrained (x :: KindedAddress k)) =
+  Constrained x \\ proofAddressCast @xs (sing @k) sx \\ addressKindSanity x
+
+proofAddressCast
+  :: ConstrainAddressKind ks k
+  => Sing k -> Sing x -> Dict (ConstrainAddressKind (x ': ks) k)
+proofAddressCast k x = case x of
+  SAddressKindImplicit -> case k of
+    SAddressKindImplicit -> Dict
+    SAddressKindContract -> Dict
+    SAddressKindTxRollup -> Dict
+  SAddressKindContract -> case k of
+    SAddressKindImplicit -> Dict
+    SAddressKindContract -> Dict
+    SAddressKindTxRollup -> Dict
+  SAddressKindTxRollup -> case k of
+    SAddressKindImplicit -> Dict
+    SAddressKindContract -> Dict
+    SAddressKindTxRollup -> Dict
+
 -- | Parse an address of arbitrary kind from its human-readable textual
 -- representation, or fail if it's invalid.
 parseAddress :: Text -> Either ParseAddressError Address
-parseAddress x =
-          (MkAddress <$> parseKindedAddress @'AddressKindImplicit x)
-  `merge` (MkAddress <$> parseKindedAddress @'AddressKindContract x)
-  `merge` (MkAddress <$> parseKindedAddress @'AddressKindTxRollup x)
-  where
-    merge :: Semigroup a => Either a b -> Either a b -> Either a b
-    merge (Left xs) (Left ys) = Left $ xs <> ys
-    merge r@Right{} _ = r
-    merge _ r@Right{} = r
+parseAddress x = parseAnyAddress x >>= \case
+  a@AnyParsableL2Address{} -> Left $ ParseAddressWrongKind [minBound..] a
+  AnyParsableAddress a -> Right a
 
+-- | Parse any kind of known address from it's human-readable textual
+-- representation, or fail if it's invalid.
+parseAnyAddress :: Text -> Either ParseAddressError AnyParsableAddress
+parseAnyAddress a = first ParseAddressCryptoError $ parseSomeHashBase58 a <&> \case
+  Some h@(Hash HashBLS _) -> AnyParsableL2Address $ TxRollupL2Address h
+  Some h@(Hash hk _) -> AnyParsableAddress $ case hk of
+    HashKey KeyTypeEd25519   -> Constrained $ ImplicitAddress h
+    HashKey KeyTypeSecp256k1 -> Constrained $ ImplicitAddress h
+    HashKey KeyTypeP256      -> Constrained $ ImplicitAddress h
+    HashContract  -> Constrained $ ContractAddress h
+    HashTXR       -> Constrained $ TxRollupAddress h
+
 data ParseAddressRawError
   = ParseAddressRawWrongSize ByteString
   -- ^ Raw bytes representation of an address has invalid length.
@@ -324,7 +367,7 @@
   -- ^ Raw bytes representation of an address does not end with "\00".
   | ParseAddressRawBinaryError Text
   -- ^ General binary decoding error.
-  | ParseAddressCryptoError CryptoParseError
+  | ParseAddressRawCryptoError CryptoParseError
   -- ^ Crypto error in parsing key hash.
   deriving stock (Eq, Show, Generic)
 
@@ -340,7 +383,7 @@
       ParseAddressRawMalformedSeparator addr -> "Given raw address" <+> (renderAnyBuildable $ hexF addr) <+>
         "does not end with" <+> dquotes (backslash <> "00")
       ParseAddressRawBinaryError err -> "Binary error during decoding address:" <+> renderAnyBuildable err
-      ParseAddressCryptoError err -> "Key hash decoding error:" <+> renderAnyBuildable err
+      ParseAddressRawCryptoError err -> "Key hash decoding error:" <+> renderAnyBuildable err
 
 instance Buildable ParseAddressRawError where
   build = buildRenderDoc
@@ -367,7 +410,7 @@
     sep = lift Get.getWord8 >>= \case
       0x00 -> pass
       x -> throwError $ ParseAddressRawMalformedSeparator x
-    keyHash = mapExceptT (fmap $ first ParseAddressCryptoError) decodeKeyHash
+    keyHash = mapExceptT (fmap $ first ParseAddressRawCryptoError) decodeKeyHash
     sepHash :: HashTag kind -> ExceptT ParseAddressRawError Get.Get (Hash kind)
     sepHash kind = Hash kind <$> lift (getByteStringCopy hashLengthBytes) <* sep
 
@@ -390,11 +433,12 @@
 
 
 instance
-    TypeError ('Text "There is no instance defined for (IsString Address)" ':$$:
-               'Text "Consider using QuasiQuotes: `[ta|some text...|]`"
-              ) =>
+    ( Bottom
+    , TypeError ('Text "There is no instance defined for (IsString Address)" ':$$:
+                 'Text "Consider using QuasiQuotes: `[ta|some text...|]`"
+                )) =>
     IsString (KindedAddress kind) where
-  fromString = error "impossible"
+  fromString = no
 
 
 ----------------------------------------------------------------------------
@@ -413,6 +457,10 @@
 -- Aeson instances
 ----------------------------------------------------------------------------
 
+instance SingI kinds => FromJSON (ConstrainedAddress kinds) where
+  parseJSON = Aeson.withText "Address" $
+    either (fail . pretty) pure . parseConstrainedAddress
+
 instance ToJSON (KindedAddress kind) where
   toJSON = Aeson.String . formatAddress
   toEncoding = Aeson.text . formatAddress
@@ -430,12 +478,12 @@
     AesonTypes.FromJSONKeyTextParser
       (either (fail . pretty) pure . parseKindedAddress)
 
-instance ToJSON (ConstrainedAddress c) where
-  toJSON (MkConstrainedAddress addr) = toJSON addr
-  toEncoding (MkConstrainedAddress addr) = toEncoding addr
+instance ToJSON (Constrained c KindedAddress) where
+  toJSON = foldConstrained toJSON
+  toEncoding = foldConstrained toEncoding
 
-instance ToJSONKey (ConstrainedAddress c) where
-  toJSONKey = AesonTypes.toJSONKeyText \(MkConstrainedAddress addr) -> formatAddress addr
+instance ToJSONKey (Constrained c KindedAddress) where
+  toJSONKey = AesonTypes.toJSONKeyText $ foldConstrained formatAddress
 
 instance FromJSON Address where
   parseJSON =
diff --git a/src/Morley/Tezos/Address/Alias.hs b/src/Morley/Tezos/Address/Alias.hs
--- a/src/Morley/Tezos/Address/Alias.hs
+++ b/src/Morley/Tezos/Address/Alias.hs
@@ -3,9 +3,10 @@
 
 module Morley.Tezos.Address.Alias
   ( AddressOrAlias(..)
+  , addressOrAliasKindSanity
   , Alias(..)
-  , SomeAlias(..)
-  , SomeAddressOrAlias(..)
+  , SomeAlias
+  , pattern SomeAlias
   , ImplicitAlias
   , ContractAlias
   , ImplicitAddressOrAlias
@@ -13,22 +14,33 @@
   , unAlias
   , mkAlias
   , aliasKindSanity
+  , SomeAddressOrAlias(..)
+  , aliasPrefix
+  , contractPrefix
+  , implicitPrefix
   )
   where
 
 import Data.Aeson (FromJSON(..), ToJSON(..))
 import Data.Constraint (Dict(..), (\\))
+import Data.Constraint.Extras (has)
+import Data.Constraint.Extras.TH (deriveArgDict)
+import Data.GADT.Compare.TH (deriveGCompare, deriveGEq)
 import Data.Singletons (SingI(..), demote)
-import Data.Type.Equality ((:~:)(..))
-import Fmt (Buildable(..), nameF, pretty, (+|), (|+))
+import Data.Text qualified as T
+import Fmt (Buildable(..), Builder, pretty)
 import Options.Applicative qualified as Opt
 
+import Data.Char qualified as Char
 import Morley.Tezos.Address
 import Morley.Tezos.Address.Kinds
 import Morley.Util.CLI (HasCLReader(..))
+import Morley.Util.Constrained
+import Morley.Util.Interpolate (itu)
 import Morley.Util.Sing
+import Morley.Util.TH
 
--- | @tezos-client@ can associate addresses with textual aliases.
+-- | @octez-client@ can associate addresses with textual aliases.
 -- This type denotes such an alias.
 data Alias (kind :: AddressKind) where
   ImplicitAlias :: Text -> Alias 'AddressKindImplicit
@@ -44,6 +56,11 @@
 deriving stock instance Eq (Alias kind)
 deriving stock instance Ord (Alias kind)
 
+deriveGADTNFData ''Alias
+deriveGEq ''Alias
+deriveGCompare ''Alias
+deriveArgDict ''Alias
+
 -- | Get raw alias text from 'Alias'
 unAlias :: Alias kind -> Text
 unAlias = \case
@@ -66,56 +83,166 @@
   parseJSON = fmap mkAlias . parseJSON
 
 -- | Existential wrapper over 'Alias'.
-data SomeAlias = forall kind. SomeAlias (Alias kind)
-
-deriving stock instance Show SomeAlias
+type SomeAlias = Constrained NullConstraint Alias
 
-instance Buildable SomeAlias where
-  build (SomeAlias x) = build x
+pattern SomeAlias :: Alias a -> SomeAlias
+pattern SomeAlias x = Constrained x
+{-# COMPLETE SomeAlias #-}
 
 -- | Given an 'Alias', prove it's @kind@ is well-defined (i.e. it has a 'SingI'
 -- instance and satisfies 'L1AddressKind' constraint)
 aliasKindSanity :: Alias kind -> Dict (L1AddressKind kind, SingI kind)
-aliasKindSanity = \case
-  ImplicitAlias{} -> Dict
-  ContractAlias{} -> Dict
+aliasKindSanity x = has @AliasKindSanityHelper x Dict
 
--- | Representation of an address that @tezos-client@ uses. It can be
--- an address itself or a textual alias.
-data AddressOrAlias kind
-  = AddressResolved (KindedAddress kind)
+class (L1AddressKind kind, SingI kind) => AliasKindSanityHelper kind
+instance (L1AddressKind kind, SingI kind) => AliasKindSanityHelper kind
+
+{- | This type is meant to be used to parse CLI options where either an address or an alias
+of an implicit account or a contract can be accepted.
+
+This can be later converted to an address using @Morley.Client.resolveAddress@
+or an alias using @Morley.Client.getAlias@.
+
+This polymorphic type can be instantiated with 'AddressKindImplicit' or 'AddressKindContract'
+(see 'ImplicitAddressOrAlias' and 'ContractAddressOrAlias'),
+but not 'AddressKindTxRollup'.
+There is no @octez-client@ command to list tx rollup aliases,
+unlike @octez-client list known addresses/contracts@, therefore:
+
+1. It wouldn't be possible to implement @Morley.Client.resolveAddress@ for @AddressAlias _ :: AddressOrAlias 'AddressKindTxRollup@.
+2. It wouldn't be possible to implement @Morley.Client.getAlias@ for @AddressResolved _ :: AddressOrAlias 'AddressKindTxRollup@.
+
+This should be revisited if/when @octez-client@ adds support for tx rollup aliases.
+-}
+data AddressOrAlias kind where
+  AddressResolved :: L1AddressKind kind => KindedAddress kind -> AddressOrAlias kind
   -- ^ Address itself, can be used as is.
-  | AddressAlias (Alias kind)
-  -- ^ Address alias, should be resolved by @tezos-client@.
-  deriving stock (Show, Eq, Ord)
+  AddressAlias :: Alias kind -> AddressOrAlias kind
+  -- ^ Address alias, should be resolved by @octez-client@.
 
+deriving stock instance Show (AddressOrAlias kind)
+deriving stock instance Eq (AddressOrAlias kind)
+deriving stock instance Ord (AddressOrAlias kind)
+
 instance (SingI kind, L1AddressKind kind) => HasCLReader (AddressOrAlias kind) where
   getReader =
-    Opt.str >>= \addrOrAlias ->
-      case parseAddress addrOrAlias of
-        Right (MkAddress (addr :: KindedAddress kind')) ->
-          case eqI @kind @kind' \\ addressKindSanity addr of
-            Just Refl -> pure $ AddressResolved addr
-            Nothing -> Opt.readerError $ pretty $ nameF "Unexpected address kind" $
-              "expected " +| demote @kind |+ " address, but got " +| addr |+ ""
-        Left _ -> pure $ AddressAlias (mkAlias addrOrAlias)
-  getMetavar = "ADDRESS OR ALIAS"
+    getReader @SomeAddressOrAlias >>= \case
+      SAOAKindSpecified aoa ->
+        case castSing @_ @kind aoa \\ addressOrAliasKindSanity aoa of
+          Just aoa' -> pure aoa'
+          Nothing -> Opt.readerError
+            let expectedKind = demote @kind in
+            [itu|Unexpected address kind: expected #{expectedKind} address or alias, but got: '#{aoa}'|]
+      SAOAKindUnspecified aliasText ->
+        pure $ AddressAlias $ mkAlias aliasText
+  getMetavar = (fmap Char.toUpper $ pretty $ demote @kind) <> " ADDRESS OR ALIAS"
 
 instance Buildable (AddressOrAlias kind) where
   build = \case
     AddressResolved addr -> build addr
-    AddressAlias alias -> build alias
+    AddressAlias alias -> aliasPrefix @kind <> ":" <> build alias \\ aliasKindSanity alias
 
--- | Convenience type synonym.
+{- This type is meant to be used to parse CLI options where either an address or an alias
+of an implicit account can be accepted.
+
+Example inputs:
+  * "tz1hZ7o4bhFTo6AXpWZsXzbnddEK3dSCv1S8": an address belonging to an implicit account.
+  * "implicit:some-alias" or "some-alias": an alias that is expected to be associated with an implicit account.
+      * If it's associated with a contract, @Morley.Client.resolveAddress@ will fail.
+      * If it's associated with __both__ a contract and an implicit account,
+        @Morley.Client.resolveAddress@ will return the implicit account address.
+
+Parsing will fail on these inputs:
+  * "KT1STb2aG7NpoBBNRggvummqsxNQZmuAVFvG"
+  * "contract:some-alias"
+
+Refer to the 'HasCLReader' and @Morley.Client.Resolve@ instances for implementation details.
+-}
 type ImplicitAddressOrAlias = AddressOrAlias 'AddressKindImplicit
 
--- | Convenience type synonym.
+{- This type is meant to be used to parse CLI options where either an address or an alias
+of a contract can be accepted.
+
+Example inputs:
+  * "KT1STb2aG7NpoBBNRggvummqsxNQZmuAVFvG": an address belonging to a contract.
+  * "contract:some-alias" or "some-alias": an alias that is expected to be associated with a contract.
+      * If it's associated with an implicit account, @Morley.Client.resolveAddress@ will fail.
+      * If it's associated with __both__ a contract and an implicit account,
+        @Morley.Client.resolveAddress@ will return the contract address.
+
+Parsing will fail on these inputs:
+  * "tz1hZ7o4bhFTo6AXpWZsXzbnddEK3dSCv1S8"
+  * "implicit:some-alias"
+
+Refer to the 'HasCLReader' and @Morley.Client.Resolve@ instances for implementation details.
+-}
 type ContractAddressOrAlias = AddressOrAlias 'AddressKindContract
 
--- | Existential over 'AddressOrAlias'.
-data SomeAddressOrAlias = forall kind. SomeAddressOrAlias (AddressOrAlias kind)
+-- | Given an 'AddressOrAlias', prove it's @kind@ is well-defined (i.e. it has a 'SingI'
+-- instance and satisfies 'L1AddressKind' constraint)
+addressOrAliasKindSanity :: forall kind. AddressOrAlias kind -> Dict (L1AddressKind kind, SingI kind)
+addressOrAliasKindSanity = \case
+  AddressResolved addr -> Dict \\ addressKindSanity addr
+  AddressAlias alias -> aliasKindSanity alias
 
-instance Buildable SomeAddressOrAlias where
-  build (SomeAddressOrAlias x) = build x
+{- This type is meant to be used to parse CLI options where either an address or an alias
+of either a contract or an implicit account can be accepted.
 
+Example inputs:
+  * "KT1STb2aG7NpoBBNRggvummqsxNQZmuAVFvG": an address belonging to a contract
+  * "tz1hZ7o4bhFTo6AXpWZsXzbnddEK3dSCv1S8": an address belonging to an implicit account
+  * "contract:some-alias": an alias that is expected to be associated with a contract.
+      * If it's associated with an implicit account, @Morley.Client.resolveAddress@ will fail.
+  * "implicit:some-alias": an alias that is expected to be associated with an implicit account.
+      * If it's associated with a contract, @Morley.Client.resolveAddress@ will fail.
+  * "some-alias": an alias that is expected to be associated with either a contract or an implicit account.
+      * If it's associated with __both__ a contract and an implicit account,
+        @Morley.Client.resolveAddress@ will fail.
+
+Refer to the 'HasCLReader' and @Morley.Client.Resolve@ instances for implementation details.
+-}
+data SomeAddressOrAlias where
+  SAOAKindSpecified :: AddressOrAlias kind -> SomeAddressOrAlias
+  SAOAKindUnspecified :: Text -> SomeAddressOrAlias
+
 deriving stock instance Show SomeAddressOrAlias
+
+-- | The output of 'build' should be parseable by the 'HasCLReader' instance.
+instance Buildable SomeAddressOrAlias where
+  build = \case
+    SAOAKindUnspecified alias -> build alias
+    SAOAKindSpecified aoa -> build aoa
+
+instance HasCLReader SomeAddressOrAlias where
+  getMetavar = "CONTRACT OR IMPLICIT ADDRESS OR ALIAS"
+  getReader =
+    Opt.str >>= \str ->
+      case parseAddress str of
+        Right (Constrained addr) ->
+          case addr of
+            ImplicitAddress{} -> pure $ SAOAKindSpecified $ AddressResolved addr
+            ContractAddress{} -> pure $ SAOAKindSpecified $ AddressResolved addr
+            TxRollupAddress{} -> Opt.readerError $ "Unexpected transaction rollup address: " <> pretty addr
+        Left _ ->
+          pure $
+            parseAliasWithPrefix @'AddressKindImplicit str <|> parseAliasWithPrefix @'AddressKindContract str
+              & fromMaybe (SAOAKindUnspecified str)
+      where
+        -- Try parsing an alias with an explicit kind prefix.
+        parseAliasWithPrefix
+          :: forall kind. (L1AddressKind kind, SingI kind)
+          => Text
+          -> Maybe SomeAddressOrAlias
+        parseAliasWithPrefix str =
+          T.stripPrefix (pretty $ aliasPrefix @kind <> ":") str <&> \alias ->
+            SAOAKindSpecified $ AddressAlias $ mkAlias @kind alias
+
+-- | The prefix used to specify whether an alias belongs to a contract or an implicit account.
+aliasPrefix :: forall addressKind. (L1AddressKind addressKind, SingI addressKind) => Builder
+aliasPrefix =
+  usingImplicitOrContractKind @addressKind $
+    build $ demote @addressKind
+
+contractPrefix, implicitPrefix :: Builder
+contractPrefix = aliasPrefix @'AddressKindContract
+implicitPrefix = aliasPrefix @'AddressKindImplicit
diff --git a/src/Morley/Tezos/Address/Kinds.hs b/src/Morley/Tezos/Address/Kinds.hs
--- a/src/Morley/Tezos/Address/Kinds.hs
+++ b/src/Morley/Tezos/Address/Kinds.hs
@@ -23,6 +23,9 @@
   -- ^ a contract address, @KT1@
   | AddressKindTxRollup
   -- ^ a transaction rollup address, @txr1@
+  deriving stock (Eq, Bounded, Enum, Ord, Show, Generic)
+
+instance NFData AddressKind
 
 instance Buildable AddressKind where
   build = \case
diff --git a/src/Morley/Tezos/Core.hs b/src/Morley/Tezos/Core.hs
--- a/src/Morley/Tezos/Core.hs
+++ b/src/Morley/Tezos/Core.hs
@@ -427,7 +427,7 @@
 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.
+-- @octez-client rpc get /chains/main/chain_id@ call.
 --
 -- Example of produced value: @NetXUdfLh6Gm88t@.
 formatChainId :: ChainId -> Text
diff --git a/src/Morley/Tezos/Crypto.hs b/src/Morley/Tezos/Crypto.hs
--- a/src/Morley/Tezos/Crypto.hs
+++ b/src/Morley/Tezos/Crypto.hs
@@ -9,7 +9,7 @@
 -- We provide 'SecretKey' type and (limited) signing functionality only
 -- for testing.
 -- If you need to sign something in production, use something else
--- (e. g. `tezos-client`).
+-- (e. g. @octez-client@).
 --
 -- Tezos supports multiple cryptographic curves that are denoted by the
 -- number after tz in the public key hash:
@@ -57,6 +57,8 @@
 
   -- * Public/secret key functions
   , detSecretKey
+  , detSecretKey'
+  , KeyType(..)
   , toPublic
 
   -- * Signature
@@ -109,12 +111,14 @@
   , decodeBase58Check
   , B58CheckWithPrefixError (..)
   , decodeBase58CheckWithPrefix
+  , parseSomeHashBase58
   , keyDecoders
   , keyHashDecoders
   , AllHashTags(..)
   ) where
 
 import Control.Monad.Except (throwError)
+import Crypto.Number.Serialize (os2ip)
 import Crypto.Random (MonadRandom)
 import Data.Aeson (FromJSON(..), FromJSONKey, ToJSON(..), ToJSONKey)
 import Data.Aeson qualified as Aeson
@@ -124,6 +128,7 @@
 import Data.ByteArray qualified as BA
 import Data.ByteString qualified as BS
 import Data.ByteString.Lazy qualified as LBS
+import Data.Some (Some(..), mapSome)
 import Data.Text qualified as T
 import Data.Text.Internal.Builder (Builder)
 import Fmt (Buildable, build, hexF, pretty)
@@ -147,21 +152,24 @@
 -- Types, instances, conversions
 ----------------------------------------------------------------------------
 
--- | A kind of a hash: it may be a public key hash for @tz1@, @tz2@ and @tz3@
--- addresses, it may be a level-2 public key hash for @tz4@ addresses, it may be
--- a contract hash for contract addresses, or it may be a transaction rollup
--- hash for @txr1@ addresses.
+-- | A kind of a hash.
 data HashKind
-  = HashKindPublicKey
-  | HashKindL2PublicKey
-  | HashKindContract
-  | HashKindTxRollup
+  = HashKindPublicKey -- ^ Public key hash for @tz1@, @tz2@, @tz3@ addresses.
+  | HashKindL2PublicKey -- ^ Level-2 public key hash for @tz4@ addresses.
+  | HashKindContract -- ^ Contract hash for @KT1@ smart contract addresses.
+  | HashKindTxRollup -- ^ Transaction rollup hash for @txr1@ addresses.
 
+-- | Type of public/secret key as enum.
+data KeyType
+  = KeyTypeEd25519
+  | KeyTypeSecp256k1
+  | KeyTypeP256
+  deriving stock (Show, Eq, Enum, Bounded, Ord, Lift, Generic)
+  deriving anyclass NFData
+
 -- | What specific type of hash is used for the 'Hash'.
 data HashTag (kind :: HashKind) where
-  HashEd25519 :: HashTag 'HashKindPublicKey
-  HashSecp256k1 :: HashTag 'HashKindPublicKey
-  HashP256 :: HashTag 'HashKindPublicKey
+  HashKey :: KeyType -> HashTag 'HashKindPublicKey
   HashContract :: HashTag 'HashKindContract
   HashBLS :: HashTag 'HashKindL2PublicKey
   HashTXR :: HashTag 'HashKindTxRollup
@@ -205,15 +213,21 @@
   getReader = eitherReader (first pretty . parseSecretKey . toText)
   getMetavar = "SECRET_KEY"
 
--- | Deterministicaly generate a secret key from seed.
--- Type of the key depends on seed length.
-detSecretKey :: HasCallStack => ByteString -> SecretKey
-detSecretKey seed = seed & case (length seed + 2) `mod` 3 of
-  0 -> SecretKeyEd25519 . Ed25519.detSecretKey
-  1 -> SecretKeySecp256k1 . Secp256k1.detSecretKey
-  2 -> SecretKeyP256 . P256.detSecretKey
-  _ -> error "detSecretKey: unexpected happened"
+-- | Deterministically generate a secret key from seed. Key type is specified
+-- explicitly.
+detSecretKey' :: KeyType -> ByteString -> SecretKey
+detSecretKey' = \case
+  KeyTypeEd25519   -> SecretKeyEd25519   . Ed25519.detSecretKey
+  KeyTypeSecp256k1 -> SecretKeySecp256k1 . Secp256k1.detSecretKey
+  KeyTypeP256      -> SecretKeyP256      . P256.detSecretKey
 
+-- | Deterministically generate a secret key from seed. Type of the key depends
+-- on seed value.
+detSecretKey :: ByteString -> SecretKey
+detSecretKey seed = detSecretKey'
+  (toEnum $ fromIntegralOverflowing (os2ip seed) `mod` (fromEnum (maxBound :: KeyType) + 1))
+  seed
+
 -- | Create a public key from a secret key.
 toPublic :: SecretKey -> PublicKey
 toPublic = \case
@@ -492,7 +506,7 @@
   allHashTags :: NonEmpty (HashTag kind)
 
 instance AllHashTags 'HashKindPublicKey where
-  allHashTags = HashEd25519 :| [HashSecp256k1, HashP256]
+  allHashTags = HashKey <$> minBound :| [succ minBound .. maxBound]
 
 instance AllHashTags 'HashKindContract where
   allHashTags = pure HashContract
@@ -535,11 +549,11 @@
 hashKey =
   \case
     PublicKeyEd25519 pk ->
-      Hash HashEd25519 (blake2b160 $ Ed25519.publicKeyToBytes pk)
+      Hash (HashKey KeyTypeEd25519) (blake2b160 $ Ed25519.publicKeyToBytes pk)
     PublicKeySecp256k1 pk ->
-      Hash HashSecp256k1 (blake2b160 $ Secp256k1.publicKeyToBytes pk)
+      Hash (HashKey KeyTypeSecp256k1) (blake2b160 $ Secp256k1.publicKeyToBytes pk)
     PublicKeyP256 pk ->
-      Hash HashP256 (blake2b160 $ P256.publicKeyToBytes pk)
+      Hash (HashKey KeyTypeP256) (blake2b160 $ P256.publicKeyToBytes pk)
 
 formatHash :: (Hash kind) -> Text
 formatHash (Hash tag bytes) = formatImpl (hashTagBytes tag) bytes
@@ -566,6 +580,17 @@
 
   in firstRight $ map parse allHashTags
 
+-- | Parse a 'Hash' of any known kind from its its human-readable textual representation.
+parseSomeHashBase58 :: Text -> Either CryptoParseError (Some Hash)
+parseSomeHashBase58 = maybe (Left CryptoParseWrongBase58Check) parseSomeHash .  decodeBase58Check
+
+parseSomeHash :: ByteString -> Either CryptoParseError (Some Hash)
+parseSomeHash a = do
+  (sometag, bs) <- parseSomeHashTag a
+  when (BS.length bs /= hashLengthBytes) $
+    Left (CryptoParseUnexpectedLength "KeyHash" (length bs))
+  return $ mapSome (flip Hash bs) sometag
+
 parseKeyHashHelper
   :: Int
   -> Builder
@@ -590,19 +615,32 @@
 hashTagBytes :: HashTag kind -> ByteString
 hashTagBytes =
   \case
-    HashEd25519 -> "\006\161\159"
+    HashKey KeyTypeEd25519 -> "\006\161\159" -- tz1
     -- https://gitlab.com/tezos/tezos/-/blob/0ca82c9dc361a6f223e81221c86bdb95d1a8d91c/src/lib_crypto/base58.ml#L379
-    HashSecp256k1 -> "\006\161\161"
+    HashKey KeyTypeSecp256k1 -> "\006\161\161" -- tz2
     -- https://gitlab.com/tezos/tezos/-/blob/0ca82c9dc361a6f223e81221c86bdb95d1a8d91c/src/lib_crypto/base58.ml#L381
-    HashP256 -> "\006\161\164"
+    HashKey KeyTypeP256 -> "\006\161\164" -- tz3
     -- https://gitlab.com/tezos/tezos/-/blob/0ca82c9dc361a6f223e81221c86bdb95d1a8d91c/src/lib_crypto/base58.ml#L383
-    HashContract -> "\2\90\121"
+    HashContract -> "\2\90\121" -- KT1
     -- https://gitlab.com/tezos/tezos/-/blob/0ca82c9dc361a6f223e81221c86bdb95d1a8d91c/src/proto_alpha/lib_protocol/contract_hash.ml#L27
-    HashBLS -> "\006\161\166"
+    HashBLS -> "\006\161\166" -- tz4
     -- https://gitlab.com/tezos/tezos/-/blob/0ca82c9dc361a6f223e81221c86bdb95d1a8d91c/src/proto_014_PtKathma/lib_protocol/tx_rollup_prefixes.ml#L43
-    HashTXR -> "\001\128\120\031"
+    HashTXR -> "\001\128\120\031" -- txr1
     -- https://gitlab.com/tezos/tezos/-/blob/0ca82c9dc361a6f223e81221c86bdb95d1a8d91c/src/proto_014_PtKathma/lib_protocol/tx_rollup_prefixes.ml#L35
 
+parseSomeHashTag :: ByteString -> Either CryptoParseError (Some HashTag, ByteString)
+parseSomeHashTag bs = maybeToRight (CryptoParseWrongTag bs) $ asum
+  [ tryHash (HashKey KeyTypeEd25519)
+  , tryHash (HashKey KeyTypeSecp256k1)
+  , tryHash (HashKey KeyTypeP256)
+  , tryHash HashContract
+  , tryHash HashBLS
+  , tryHash HashTXR
+  ]
+  where
+    tryHash :: HashTag kind -> Maybe (Some HashTag, ByteString)
+    tryHash hashKind = (Some hashKind,) <$> BS.stripPrefix (hashTagBytes hashKind) bs
+
 instance AllHashTags kind => HasCLReader (Hash kind) where
   getReader = eitherReader (first pretty . parseHash . toText)
   getMetavar = "KEY_HASH"
@@ -619,9 +657,9 @@
 
 keyHashDecoders :: (Monad (t Get.Get), MonadTrans t) => [TaggedDecoderM t KeyHash]
 keyHashDecoders =
-  [ 0x00 ##: Hash HashEd25519 <$> getPayload
-  , 0x01 ##: Hash HashSecp256k1 <$> getPayload
-  , 0x02 ##: Hash HashP256 <$> getPayload
+  [ 0x00 ##: Hash (HashKey KeyTypeEd25519) <$> getPayload
+  , 0x01 ##: Hash (HashKey KeyTypeSecp256k1) <$> getPayload
+  , 0x02 ##: Hash (HashKey KeyTypeP256) <$> getPayload
   ]
   where
     getPayload = lift $ getByteStringCopy hashLengthBytes
diff --git a/src/Morley/Tezos/Crypto/Secp256k1.hs b/src/Morley/Tezos/Crypto/Secp256k1.hs
--- a/src/Morley/Tezos/Crypto/Secp256k1.hs
+++ b/src/Morley/Tezos/Crypto/Secp256k1.hs
@@ -39,6 +39,7 @@
 import Crypto.PubKey.ECC.ECDSA qualified as ECDSA
 import Crypto.PubKey.ECC.Generate qualified as ECC.Generate
 import Crypto.PubKey.ECC.Types (Curve(..), CurveName(..), getCurveByName)
+import Crypto.PubKey.ECC.Types qualified as ECDSA
 import Crypto.Random (MonadRandom)
 import Data.ByteArray (ByteArray, ByteArrayAccess)
 import Fmt (Buildable, build)
@@ -191,8 +192,26 @@
 
 -- | Sign a message using the secret key.
 sign :: MonadRandom m => SecretKey -> ByteString -> m Signature
-sign (SecretKey keyPair) =
-  fmap Signature . ECDSA.sign (ECDSA.toPrivateKey keyPair) Blake2b_256
+sign (SecretKey keyPair) msg = fmap Signature $ do
+  let pk = ECDSA.toPrivateKey keyPair
+  ECDSA.Signature r s' <- ECDSA.sign pk Blake2b_256 msg
+  let n = ECDSA.ecc_n . ECDSA.common_curve $ ECDSA.private_curve pk
+      -- Tezos uses bitcoin-core implementation of secp256k1, or, more
+      -- accurately, nomadic-labs OCaml bindings to bitcoin-core implementation,
+      -- see [tezos dependencies] and [C implementation]. It does this thing for
+      -- some reason. The signature is valid either way, but the network will
+      -- refuse to accept @s > n/2@. note that @s' < n@ due to modular
+      -- arithmetic.
+      --
+      -- [tezos dependencies]: https://gitlab.com/tezos/tezos/-/blob/e9a9b61969b7a44749bed9bd9cdbcb4f2283220f/src/lib_crypto/dune#L16
+      -- [C implementation]: https://gitlab.com/nomadic-labs/ocaml-secp256k1-internal/-/blob/1b51aefb3ae579a24529b18cf9da6991b4ff17c2/src/ecdsa_impl.h#L305
+      --
+      -- Original code for C implementation:
+      -- https://github.com/bitcoin/bitcoin/blob/c06cda3e48e9826043ebc5790a7bb505bfbf368c/src/secp256k1/src/ecdsa_impl.h#L305
+      s | s' > n `div` 2 = n - s'
+        | otherwise = s'
+  pure $ ECDSA.Signature r s
+
 
 -- | Check that a sequence of bytes has been signed with a given key.
 checkSignature :: PublicKey -> Signature -> ByteString -> Bool
diff --git a/src/Morley/Tezos/Crypto/Timelock.hs b/src/Morley/Tezos/Crypto/Timelock.hs
--- a/src/Morley/Tezos/Crypto/Timelock.hs
+++ b/src/Morley/Tezos/Crypto/Timelock.hs
@@ -3,6 +3,10 @@
 
 {- | Timelock puzzle algorithms implementation.
 
+__WARNING__: the timelock mechanism described and implemented here is
+vulnerable. At the time of writing, no details were released, but creation of
+smart contracts using this functionality is disabled since Lima.
+
 This module follows the reference implementation for the most part,
 which you can find in the
 [tezos repository](https://gitlab.com/tezos/tezos/-/blob/b1a2ff0334405cafd7465bfa991d23844f0b4e70/src/lib_crypto/timelock.ml).
diff --git a/src/Morley/Util/Constrained.hs b/src/Morley/Util/Constrained.hs
new file mode 100644
--- /dev/null
+++ b/src/Morley/Util/Constrained.hs
@@ -0,0 +1,70 @@
+-- SPDX-FileCopyrightText: 2022 Oxhead Alpha
+-- SPDX-License-Identifier: LicenseRef-MIT-OA
+
+{-# LANGUAGE QuantifiedConstraints, DeriveLift #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Morley.Util.Constrained
+  ( Constrained(..)
+  , NullConstraint
+  , mapConstrained
+  , traverseConstrained
+  , withConstrained
+  , withConstrainedM
+  , foldConstrained
+  , foldConstrainedM
+  ) where
+
+import Data.GADT.Compare (GCompare, GEq, defaultCompare, defaultEq)
+import Fmt (Buildable(..))
+import Language.Haskell.TH.Syntax (Lift)
+
+-- | Always truthful unary constraint. Can be used to essentially turn
+-- 'Constrained' into a somewhat inefficient @Some@.
+type NullConstraint :: forall k. k -> Constraint
+class NullConstraint any
+instance NullConstraint any
+
+type Constrained :: (k -> Constraint) -> (k -> Type) -> Type
+data Constrained c f where
+  Constrained :: forall c f a. c a => f a -> Constrained c f
+
+-- | Map over argument.
+mapConstrained :: (forall t. c t => f t -> g t) -> Constrained c f -> Constrained c g
+mapConstrained f = foldConstrained $ Constrained . f
+
+-- | Traverse over argument.
+traverseConstrained :: Functor m => (forall a. c a => f a -> m (g a)) -> Constrained c f -> m (Constrained c g)
+traverseConstrained f = foldConstrained $ fmap Constrained . f
+
+-- | Apply function to constrained value
+withConstrained :: Constrained c f -> (forall t. c t => f t -> r) -> r
+withConstrained (Constrained x) f = f x
+
+-- | Monadic 'withConstrained'
+withConstrainedM :: Monad m => m (Constrained c f) -> (forall t. f t -> m r) -> m r
+withConstrainedM m f = m >>= foldConstrained f
+
+-- | Flipped version of 'withConstrained'
+foldConstrained :: (forall t. c t => f t -> r) -> Constrained c f -> r
+foldConstrained f (Constrained x) = f x
+
+-- | Flipped version of 'withConstrainedM'
+foldConstrainedM :: Monad m => (forall t. c t => f t -> m r) -> m (Constrained c f) -> m r
+foldConstrainedM f m = m >>= foldConstrained f
+
+deriving stock instance (forall a. c a => Show (f a)) => Show (Constrained c f)
+
+instance (forall a. c a => NFData (f a)) => NFData (Constrained c f) where
+  rnf (Constrained x) = rnf x
+
+deriving stock instance (forall a. c a => Lift (f a)) => Lift (Constrained c f)
+
+instance (forall a. c a => Buildable (f a)) => Buildable (Constrained c f) where
+  build (Constrained a) = build a
+
+instance GEq f => Eq (Constrained c f) where
+  (Constrained a) == (Constrained b) = defaultEq a b
+
+instance GCompare f => Ord (Constrained c f) where
+  compare (Constrained a) (Constrained b) = defaultCompare a b
diff --git a/src/Morley/Util/MismatchError.hs b/src/Morley/Util/MismatchError.hs
--- a/src/Morley/Util/MismatchError.hs
+++ b/src/Morley/Util/MismatchError.hs
@@ -102,8 +102,8 @@
     errText = fmap (renderList' . map (align . renderDoc doesntNeedParens)) err
     -- "simple" here means that at least one is true:
     --
-    -- * one of the lists is empty
-    -- * rendered representation for both expected and actual types are single-line
+    --  * one of the lists is empty
+    --  * rendered representation for both expected and actual types are single-line
     simple = any null err || all (null . drop 1 . LT.lines . printDoc False) errText
     renderList' ds
       = case ds of
diff --git a/src/Morley/Util/Peano.hs b/src/Morley/Util/Peano.hs
--- a/src/Morley/Util/Peano.hs
+++ b/src/Morley/Util/Peano.hs
@@ -52,7 +52,10 @@
   , Length
   , At
   , Drop
+  , LazyTake
   , Take
+  , Head
+  , Tail
 
     -- * Morley-specific utils
   , IsLongerThan
@@ -84,9 +87,11 @@
   ) where
 
 import Data.Constraint (Dict(..), (\\))
+import Data.Data (Data(..))
 import Data.Singletons (Sing, SingI(..), SomeSing(..))
 import Data.Type.Equality (gcastWith, type (:~:)(..))
 import Data.Vinyl (Rec(..))
+import Data.Vinyl.Core (Head, Tail)
 import Data.Vinyl.TypeLevel (Nat(..), RLength)
 import GHC.TypeLits (ErrorMessage(..), TypeError)
 import GHC.TypeNats (type (+), type (-))
@@ -114,6 +119,7 @@
 deriving stock instance Eq Nat
 deriving stock instance Show Nat
 deriving stock instance Generic Nat
+deriving stock instance Data Nat
 deriving anyclass instance NFData Nat
 
 $(genSingletonsType ''Nat)
@@ -259,10 +265,48 @@
   Drop ('S _) '[] = '[]
   Drop ('S n) (_ ': s) = Drop n s
 
+-- | A type-level version of 'Data.List.take'. Note that in many cases,
+-- using 'LazyTake' instead will improve type inference.
 type family Take (n :: Peano) (s :: [k]) :: [k] where
   Take  'Z _ = '[]
   Take _ '[] = '[]
   Take ('S n) (a ': s) = a ': Take n s
+
+-- | A "lazier" version of 'Take'. @LazyTake n xs@ will always produce
+-- a list of exactly @n@ elements. If @xs@ has less than @n@ elements, then
+-- some of the elements of the result will be stuck. Similarly, if some tail
+-- of @xs@ is stuck or ambiguous, then elements of the result past that point
+-- will be stuck.
+--
+-- @
+-- LazyTake ('ToPeano' 4) '[1,2,3,4,5] ~ '[1,2,3,4]
+-- LazyTake (ToPeano 4) (1 ': 2 ': 3 ': 4 ': Any) ~ '[1,2,3,4]
+-- LazyTake (ToPeano 4) '[1,2] ~
+--   '[1, 2, Head '[], Head (Tail '[])]
+-- @
+--
+-- @LazyTake@ is often better than @Take@ for driving type inference.
+-- For example, given the constraint
+--
+-- @
+-- xs ~ Take (ToPeano 3) xs ++ q ': Drop (ToPeano 4) xs
+-- @
+--
+-- GHC can't infer anything about the shape of @xs@. However, the constraint
+--
+-- @
+-- xs ~ LazyTake (ToPeano 3) xs ++ q ': Drop (ToPeano 4) xs
+-- @
+--
+-- will allow GHC to infer
+--
+-- @
+-- xs ~ x1 ': x2 ': x3 ': q ': Drop (ToPeano 4) xs
+-- @
+type LazyTake :: Peano -> [k] -> [k]
+type family LazyTake n xs where
+  LazyTake 'Z _ = '[]
+  LazyTake ('S n) xs = Head xs ': LazyTake n (Tail xs)
 
 ----------------------------------------------------------------------------
 -- Morley-specific utils
diff --git a/src/Morley/Util/Sing.hs b/src/Morley/Util/Sing.hs
--- a/src/Morley/Util/Sing.hs
+++ b/src/Morley/Util/Sing.hs
@@ -3,6 +3,7 @@
 
 module Morley.Util.Sing
   ( eqI
+  , geqI
   , eqParamSing
   , eqParamSing2
   , eqParamSing3
@@ -139,3 +140,11 @@
     withOptions defaultOptions{singledDataConName = sPrefix, singledDataTypeName = singPrefix} $
     concat <$> sequence
       [ genSingletons [name], singDecideInstance name]
+
+-- | Singleton-based implementation of @geq@
+geqI
+  :: forall f a b. (SingI a, SingI b, TestEquality (Sing @(KindOf a)), Eq (f b))
+  => f a -> f b -> Maybe (a :~: b)
+geqI l r = case eqI @a @b of
+  Just Refl | l == r -> Just Refl
+  _ -> Nothing
diff --git a/src/Morley/Util/TH.hs b/src/Morley/Util/TH.hs
--- a/src/Morley/Util/TH.hs
+++ b/src/Morley/Util/TH.hs
@@ -6,20 +6,31 @@
   , lookupTypeNameOrFail
   , isTypeAlias
   , addTypeVariables
+  , tupT
   ) where
 
+import Control.Monad.Fix (mfix)
 import Language.Haskell.TH
+import Prelude hiding (Type)
 
 {-# ANN module ("HLint: ignore Language.Haskell.TH should be imported post-qualified or with an explicit import list" :: Text) #-}
 
--- | Generates an NFData instance for a GADT. /Note:/ This will not generate
--- additional constraints to the generated instance if those are required.
+-- | Generates an 'NFData' instance for a GADT.
+--
+-- On superclass constraints for type arguments:
+-- we use heuristics to guess for which type arguments
+-- we need to add @NFData@ instance.
+-- If this behaves not as you want, probably it's just worth
+-- starting passing the necessary constraints to this function manually.
 deriveGADTNFData :: Name -> Q [Dec]
 deriveGADTNFData name = do
   seqQ <- [| seq |]
   unit <- [| () |]
   (TyConI (DataD _ dataName vars _ cons _)) <- reify name
+  tyArgRoles <- reifyRoles name
   let
+    nfDataC = ConT $ mkName "NFData"
+
     getNameFromVar (PlainTV n _) = n
     getNameFromVar (KindedTV n _ _) = n
 
@@ -43,13 +54,31 @@
           )
 
     nfDataT =
-      AppT (ConT $ mkName "NFData") . foldl' AppT (ConT dataName) $
+      AppT nfDataC . foldl' AppT (ConT dataName) $
         map (VarT . getNameFromVar) vars
 
-    makeInstance clauses =
-      InstanceD Nothing [] nfDataT [FunD (mkName "rnf") clauses]
+    nfDataConstr = do
+      (var, role) <- zip vars tyArgRoles
 
+      -- Phantom type arguments do not require constraints
+      case role of
+        NominalR -> mzero
+        RepresentationalR -> pass
+        PhantomR -> mzero
+        InferR -> error "unexpected InferR returned by reifyRole"
 
+      -- Only types of 'Type' kind may require 'NFData' constraint
+      varTy <- case var of
+        PlainTV v _ -> pure v
+        KindedTV v _ k -> do
+          guard (k == StarT)
+          pure v
+
+      return $ nfDataC `AppT` VarT varTy
+
+    makeInstance clauses =
+      InstanceD Nothing nfDataConstr nfDataT [FunD (mkName "rnf") clauses]
+
   clauses <- traverse makeClauses $ cons >>= unfoldConstructor
   return [makeInstance clauses]
 
@@ -77,3 +106,26 @@
         PlainTV vName _ -> vName
         KindedTV vName _ _ -> vName
   return $ foldl (\acc var -> acc `AppT` VarT var) (ConT tyCtor) vars
+
+-- | Given a list of types, produce the type of a tuple of
+-- those types. This is analogous to 'tupE' and 'tupP'.
+--
+-- @
+-- tupT [[t|Int|], [t|Char|], [t|Bool]] = [t| (Int, Char, Bool) |]
+-- @
+tupT :: [Q Type] -> Q Type
+tupT ts = do
+  -- We build the expression with a thunk inside that will be filled in with
+  -- the length of the list once that's been determined. This works
+  -- efficiently (in one pass) because TH.Type is rather lazy. Why isn't this
+  -- just a left fold? A left fold will produce a big Q action that, when run,
+  -- will produce the expression. We want to produce the expression incrementally
+  -- as we run the Q action. foldM lets us do that, and mfix gives us the thunk
+  -- for the tuple size. The irrefutable pattern is required as usual because the
+  -- function passed to mfix must never force its argument.
+  (res, !_n) <- mfix (\ ~(_res, n) -> foldM go (TupleT n, 0) ts)
+  pure res
+  where
+    go (acc, !k) ty = do
+      ty' <- ty
+      pure (acc `AppT` ty', k + 1)
diff --git a/src/Morley/Util/Type.hs b/src/Morley/Util/Type.hs
--- a/src/Morley/Util/Type.hs
+++ b/src/Morley/Util/Type.hs
@@ -1,8 +1,6 @@
 -- SPDX-FileCopyrightText: 2021 Oxhead Alpha
 -- SPDX-License-Identifier: LicenseRef-MIT-OA
 
-{-# OPTIONS_GHC -Wno-redundant-constraints #-}
-
 -- | General type utilities.
 module Morley.Util.Type
   ( IsEq
@@ -15,7 +13,6 @@
   , AssertTypesEqual
   , FailUnlessEqual
   , FailUnlessEqualElse
-  , Guard
   , FailWhen
   , FailWhenElse
   , FailWhenElsePoly
@@ -53,18 +50,31 @@
 import Data.Vinyl.Core (Rec(..))
 import Data.Vinyl.Functor qualified as Vinyl
 import Data.Vinyl.Recursive (recordToList, rmap)
-import Data.Vinyl.TypeLevel (type (++))
+import Data.Vinyl.TypeLevel qualified as Vinyl
 import GHC.TypeLits (ErrorMessage(..), Symbol, TypeError)
 import Prelude.Singletons (SList(..))
 import Unsafe.Coerce (unsafeCoerce)
 
 -- $setup
--- >>> import GHC.TypeLits (ErrorMessage (..))
+-- >>> import GHC.TypeLits (TypeError, ErrorMessage (..))
+-- >>> import Type.Errors (DelayError)
+-- >>> import Morley.Util.Peano (Peano, pattern S, pattern Z)
+-- >>> import Data.Constraint ((:-)(..), Dict(..))
 
 -- | Equality constraint in form of a typeclass.
 class a ~ b => IsEq a b
 instance a ~ b => IsEq a b
 
+infixr 5 ++
+
+-- | Append for type-level lists. We use this synonym instead of using the one
+-- from "Data.Vinyl.TypeLevel" directly because the latter is missing a fixity
+-- declaration. See the
+-- [vinyl pull request](https://github.com/VinylRecords/Vinyl/pull/165).
+
+type (++) :: [k] -> [k] -> [k]
+type as ++ bs = as Vinyl.++ bs
+
 type family IsElem (a :: k) (l :: [k]) :: Bool where
   IsElem _ '[] = 'False
   IsElem a (a ': _) = 'True
@@ -81,62 +91,59 @@
   l // '[] = l
   l // (x ': xs) = (l / x) // xs
 
-type family Guard (cond :: Bool) (a :: k) :: Maybe k where
-  Guard 'False _ = 'Nothing
-  Guard 'True a = 'Just a
+{- | Constrain two types to be equal. If they are found not to be, produce
+an error message. If they are shown to be equal, impose an additional
+given constraint.
 
--- | Constrain two types to be equal. If they are found not to be, produce
--- an error message. If they are shown to be equal, impose an additional
--- given constraint.
---
--- >>> :k! FailUnlessEqualElse Int Int ('Text "This should not result in a failure") ()
--- FailUnlessEqualElse Int Int ('Text "This should not result in a failure") () :: Constraint
--- = (() :: Constraint, Int ~ Int)
---
--- >>> :k! FailUnlessEqualElse Bool Int ('Text "This should result in a failure") ()
--- FailUnlessEqualElse Bool Int ('Text "This should result in a failure") () :: Constraint
--- = ((TypeError ...), Bool ~ Int)
---
--- the @~@ constraint might seem redundant, but, without it, GHC would reject
---
--- @
--- foo :: FailUnlessEqualElse a b MyError () => a -> b
--- foo = id
--- @
---
--- GHC needs to \"see\" the type equality @~@ in order to actually \"learn\"
--- something from a type family's result.
---
--- We use 'DefaultEq' here, rather than 'Data.Type.Equality.==', so this will
--- work with type variables known to be equal, even if nothing is known about
--- them concretely. For example, the following will compile:
---
--- @
--- foo :: FailUnlessEqualElse a b MyError () => a -> b
--- foo x = x
---
--- bar :: a -> a
--- bar = foo
--- @
---
--- If we used @(==)@, then bar would be rejected.
---
--- @(==)@ has its place (see the comments below it in "Data.Type.Equality")
--- but I don't think it has anything to offer us here. In particular, the equality
--- constraint we bundle up seems to win us all the reasoning power that @(==)@ would
--- provide and more. The following adaptation of the example in the
--- @Data.Type.Equality@ comments compiles:
---
--- @
--- foo :: FailUnlessEqualElse (Maybe a) (Maybe b) ('Text "yo") ()
---          :- FailUnlessEqualElse a b ('Text "heya") ()
--- foo = Sub Dict
--- @
+>>> :k! FailUnlessEqualElse Int Int ('Text "This should not result in a failure") ()
+FailUnlessEqualElse Int Int ('Text "This should not result in a failure") () :: Constraint
+= (() :: Constraint, Int ~ Int)
+
+>>> :k! FailUnlessEqualElse Bool Int ('Text "This should result in a failure") ()
+FailUnlessEqualElse Bool Int ('Text "This should result in a failure") () :: Constraint
+= ((TypeError ...), Bool ~ Int)
+
+the @~@ constraint might seem redundant, but, without it, GHC would reject
+
+>>> :{
+foo :: FailUnlessEqualElse a b ('Text "MyError") () => a -> b
+foo = id
+:}
+
+GHC needs to \"see\" the type equality @~@ in order to actually \"learn\"
+something from a type family's result.
+
+We use 'DefaultEq' here, rather than 'Data.Type.Equality.==', so this will
+work with type variables known to be equal, even if nothing is known about
+them concretely. For example, the following will compile:
+
+>>> :{
+foo :: FailUnlessEqualElse a b ('Text "MyError") () => a -> b
+foo x = x
 --
--- In this example, the entire consequent follows from the equality constraint
--- in the antecedent; the `FailUnlessElsePoly` part of it is irrelevant, so we
--- don't need to be able to reason from it. If we /were/ reasoning solely using
--- @(==)@, @foo@ would be rejected because the error messages are different.
+bar :: a -> a
+bar = foo
+:}
+
+If we used @(==)@, then bar would be rejected.
+
+@(==)@ has its place (see the comments below it in "Data.Type.Equality")
+but I don't think it has anything to offer us here. In particular, the equality
+constraint we bundle up seems to win us all the reasoning power that @(==)@ would
+provide and more. The following adaptation of the example in the
+@Data.Type.Equality@ comments compiles:
+
+>>> :{
+foo :: FailUnlessEqualElse (Maybe a) (Maybe b) ('Text "yo") ()
+       :- FailUnlessEqualElse a b ('Text "heya") ()
+foo = Sub Dict
+:}
+
+In this example, the entire consequent follows from the equality constraint
+in the antecedent; the `FailUnlessElsePoly` part of it is irrelevant, so we
+don't need to be able to reason from it. If we /were/ reasoning solely using
+@(==)@, @foo@ would be rejected because the error messages are different.
+-}
 type FailUnlessEqualElse :: forall k. k -> k -> ErrorMessage -> Constraint -> Constraint
 type FailUnlessEqualElse a b err els =
   ( FailUnlessElsePoly (a `DefaultEq` b) err els
@@ -159,57 +166,65 @@
 -- | An old name for 'FailUnlessEqual'.
 type AssertTypesEqual :: forall k. k -> k -> ErrorMessage -> Constraint
 type AssertTypesEqual a b err = FailUnlessEqual a b err
+{-# DEPRECATED AssertTypesEqual "Use FailUnlessEqual instead" #-}
 
 -- | A version of 'FailWhenElsePoly' that imposes an equality constraint on its
 -- 'Bool' argument.
 type FailWhenElse :: Bool -> ErrorMessage -> Constraint -> Constraint
 type FailWhenElse cond msg els = FailUnlessEqualElse cond 'False msg els
 
--- | Fail with given error if the condition does not hold.
--- Otherwise, return the third argument.
---
--- There is a subtle difference between @FailWhenElsePoly@ and the
--- following type definition:
---
--- @
--- type FailWhenElsePolyAlternative cond msg els =
---   If cond
---      (TypeError msg)
---      els
--- @
---
--- If @cond@ cannot be fully reduced (e.g., it's a stuck type family
--- application or an ambiguous type) then:
---
--- * @FailWhenElsePoly@ will state that the constraint cannot be deduced (and
---   this error message will be suppressed if there are also custom type
---   errors).
---
--- * @FailWhenElsePolyAlternative@ will fail with the given error message,
---   @err@.
---
--- For example:
---
--- @
--- -- Partial function
--- type family IsZero (n :: Peano) :: Bool where
---   IsZero ('S _) = 'False
---
--- f1 :: (IsZero n ~ 'True, FailWhenElsePoly (IsZero n) ('Text "Expected zero") (() :: Constraint)) => ()
--- f1 = ()
---
--- f1 :: (IsZero n ~ 'True, FailWhenElsePolyAlternative (IsZero n) ('Text "Expected zero") (() :: Constraint)) => ()
--- f1 = ()
---
--- f1res == f1 @'Z
--- --  • Couldn't match type ‘IsZero 'Z’ with ‘'True’
+{- | Fail with given error if the condition does not hold. Otherwise, return the
+third argument.
+
+There is a subtle difference between @FailWhenElsePoly@ and the following type
+definition:
+
+>>> :{
+type FailWhenElsePolyAlternative cond msg els =
+  If cond
+    (DelayError msg)
+    els
+:}
+
+If @cond@ cannot be fully reduced (e.g., it's a stuck type family
+application or an ambiguous type) then:
+
+* @FailWhenElsePoly@ will state that the constraint cannot be deduced (and this
+error message will be suppressed if there are also custom type errors).
+
+* @FailWhenElsePolyAlternative@ will fail with the given error message, @err@.
+
+For example:
+
+>>> :{
+-- Partial function
+type family IsZero (n :: Peano) :: Bool where
+  IsZero ('S _) = 'False
 --
--- f2res == f2 @'Z
--- --  • Expected zero
--- @
+f1 :: ( IsZero n ~ 'True
+      , FailWhenElsePoly (IsZero n) ('Text "Expected zero") (() :: Constraint))
+   => ()
+f1 = ()
 --
--- As you can see, the error message in @f2res@ is misleading (because the type argument
--- actually _is_ zero), so it's preferable to fail with the standard GHC error message.
+f2 :: ( IsZero n ~ 'True
+      , FailWhenElsePolyAlternative (IsZero n) ('Text "Expected zero") (() :: Constraint))
+   => ()
+f2 = ()
+:}
+
+>>> f1 @'Z
+...
+... • Couldn't match type ‘IsZero 'Z’ with ‘'True’
+...
+
+>>> f2 @'Z
+...
+... • Expected zero
+...
+
+As you can see, the error message in @f2res@ is misleading (because the type argument
+actually _is_ zero), so it's preferable to fail with the standard GHC error message.
+-}
 type FailWhenElsePoly :: forall k. Bool -> ErrorMessage -> k -> k
 type family FailWhenElsePoly cond msg els where
   FailWhenElsePoly 'True msg _els = TypeError msg
diff --git a/src/Morley/Util/TypeTuple/Class.hs b/src/Morley/Util/TypeTuple/Class.hs
--- a/src/Morley/Util/TypeTuple/Class.hs
+++ b/src/Morley/Util/TypeTuple/Class.hs
@@ -14,3 +14,4 @@
 class RecFromTuple r where
   type IsoRecTuple r :: Type
   recFromTuple :: IsoRecTuple r -> r
+  tupleFromRec :: r -> IsoRecTuple r
diff --git a/src/Morley/Util/TypeTuple/Instances.hs b/src/Morley/Util/TypeTuple/Instances.hs
--- a/src/Morley/Util/TypeTuple/Instances.hs
+++ b/src/Morley/Util/TypeTuple/Instances.hs
@@ -10,9 +10,20 @@
 import Morley.Util.TypeTuple.Class
 import Morley.Util.TypeTuple.TH
 
+-- $setup
+-- >>> import Morley.Util.TypeTuple.Class
+-- >>> import Data.Vinyl.Core (Rec(..))
+
 concatMapM deriveRecFromTuple (0 : [2..25])
 -- ↑ We skip 1-ary tuple because it is GHC.Tuple.Unit, and we don't want it.
 
 instance RecFromTuple (Rec f '[a]) where
   type IsoRecTuple (Rec f '[a]) = f a
   recFromTuple a = a :& RNil
+  tupleFromRec (a :& RNil) = a
+
+-- $
+-- >>> tupleFromRec (recFromTuple (Just 3) :: Rec Maybe '[Int]) == Just 3
+-- True
+-- >>> tupleFromRec (recFromTuple (Just 3, Just "a", Nothing) :: Rec Maybe '[Int, String, Bool]) == (Just 3, Just "a", Nothing)
+-- True
diff --git a/src/Morley/Util/TypeTuple/TH.hs b/src/Morley/Util/TypeTuple/TH.hs
--- a/src/Morley/Util/TypeTuple/TH.hs
+++ b/src/Morley/Util/TypeTuple/TH.hs
@@ -12,27 +12,35 @@
 import Data.Vinyl.Core (Rec(..))
 import Language.Haskell.TH qualified as TH
 
+import Morley.Util.TH (tupT)
 import Morley.Util.TypeTuple.Class
 
 -- | Produce 'RecFromTuple' instance for tuple of the given length.
 deriveRecFromTuple :: Word16 -> TH.Q [TH.Dec]
 deriveRecFromTuple (fromIntegral -> n) = do
-  fVar <- TH.VarT <$> TH.newName "f"
-  tyVars <- replicateM n $ TH.VarT <$> TH.newName "x"
+  -- The `f` type variable
+  fVar <- TH.varT <$> TH.newName "f"
+  -- The argument type variables
+  tyVars <- replicateM n $ TH.varT <$> TH.newName "x"
 
-  let consTy ty lty = TH.promotedConsT `TH.appT` pure ty `TH.appT` lty
-  let tyList = foldr consTy TH.promotedNilT tyVars
+  -- A type level list of the argument type variables
+  let tyList = foldr (\ty lty -> [t| $ty ': $lty |]) [t| '[] |] tyVars
 
-  let tupleConsTy acc ty = acc `TH.appT` (pure fVar `TH.appT` pure ty)
-  let tyTuple = foldl tupleConsTy (TH.tupleT n) tyVars
+  -- A tuple type of `f` applied to the argument type variables
+  let tyTuple = tupT . map (\ty -> [t| $fVar $ty |]) $ tyVars
 
+  -- Term variable names for the fields
   vars <- replicateM n $ TH.newName "a"
-  let tyPat = pure . TH.TupP $ map TH.VarP vars
+  -- Pattern and expression variables for the fields
+  let varPats = map TH.varP vars
+  let varExps = map TH.varE vars
 
-  let consRec var acc = [e|(:&)|] `TH.appE` TH.varE var `TH.appE` acc
-  let recRes = foldr consRec [e|RNil|] vars
+  -- Terms and patterns for the records
+  let recRes = foldr (\var acc -> [e| $var :& $acc |]) [e|RNil|] varExps
+  let recPat = foldr (\var acc -> [p| $var :& $acc |]) [p|RNil|] varPats
 
-  [d| instance RecFromTuple (Rec ($(pure fVar) :: u -> Type) $tyList) where
-        type IsoRecTuple (Rec $(pure fVar) $tyList) = $tyTuple
-        recFromTuple $tyPat = $recRes
+  [d| instance RecFromTuple (Rec ($fVar :: u -> Type) $tyList) where
+        type IsoRecTuple (Rec $fVar $tyList) = $tyTuple
+        recFromTuple $(TH.tupP varPats) = $recRes
+        tupleFromRec $recPat = $(TH.tupE varExps)
     |]