diff --git a/CHANGES.md b/CHANGES.md
--- a/CHANGES.md
+++ b/CHANGES.md
@@ -1,3 +1,22 @@
+1.11.0
+======
+* [!731](https://gitlab.com/morley-framework/morley/-/merge_requests/731)
+  + Added opportunity to reorder fields in `GenericStrategy`.
+  + Added `GenericStrategy`-ies for compatibility with LIGO.
+* [!724](https://gitlab.com/morley-framework/morley/-/merge_requests/724)
+  Fixed `UNPACK` to accept pairs of comparable types.
+* [!712](https://gitlab.com/morley-framework/morley/-/merge_requests/712)
+  + In optimizer, by default lambdas are now also handled.
+  + Field names in optimizer config are changed (prefix added).
+* [!726](https://gitlab.com/morley-framework/morley/-/merge_requests/726)
+  Added `Data` and `Plated` instances to `Morley.Micheline.Expression`.
+* [!723](https://gitlab.com/morley-framework/morley/-/merge_requests/723)
+  * Splitted `class ContainsDoc` into `ContainsDoc` and `ContainsUpdateableDoc`;
+  * Allow avoiding explicit `DName` call (now `docGroup "Title"` works).
+* [!684](https://gitlab.com/morley-framework/morley/-/merge_requests/684)
+  Simplify working with autodoc in contracts.
+  (follow the deprecation warnings in case this hits you).
+
 1.10.0
 ======
 * [!692](https://gitlab.com/morley-framework/morley/-/merge_requests/692)
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.10.0
+version:        1.11.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
@@ -87,6 +87,7 @@
       Michelson.Typed.Entrypoints
       Michelson.Typed.Extract
       Michelson.Typed.Haskell
+      Michelson.Typed.Haskell.Compatibility
       Michelson.Typed.Haskell.Doc
       Michelson.Typed.Haskell.Instr
       Michelson.Typed.Haskell.Instr.Helpers
diff --git a/src/Michelson/Doc.hs b/src/Michelson/Doc.hs
--- a/src/Michelson/Doc.hs
+++ b/src/Michelson/Doc.hs
@@ -37,6 +37,13 @@
   , docGroupContent
   , docDefinitionRef
   , mdTocFromRef
+  , WithFinalizedDoc (..)
+  , finalizedAsIs
+  , ContainsDoc (..)
+  , ContainsUpdateableDoc (..)
+  , buildDoc
+  , buildMarkdownDoc
+  , modifyDoc
 
   , DGeneralInfoSection (..)
   , DName (..)
@@ -49,6 +56,9 @@
   , DAnchor (..)
   , DToc (..)
   , DConversionInfo (..)
+  , attachGitInfo
+  , attachToc
+  , attachDocCommons
   ) where
 
 import qualified Data.Map as M
@@ -558,6 +568,56 @@
            SomeDocItem d -> docItemToBlockGeneral d (Just sub)
   }
 
+-- | Everything that contains doc items that can be used to render the
+-- documentation.
+class ContainsDoc a where
+  -- | Gather documentation.
+  --
+  -- Calling this method directly is discouraged in prod, see 'buildDoc' instead.
+  -- Using this method in tests is fine though.
+  buildDocUnfinalized :: a -> ContractDoc
+
+-- | Some contract languages may support documentation update.
+class ContainsDoc a => ContainsUpdateableDoc a where
+  -- | Modify all documentation items recursively.
+  modifyDocEntirely :: (SomeDocItem -> SomeDocItem) -> a -> a
+
+-- | Often there is some tuning recommended prior to rendering the contract,
+-- like attaching git revision info; this type designates that those last changes
+-- were applied.
+--
+-- For example, at Michelson level you may want to use 'attachDocCommons'.
+--
+-- If you want no special tuning (e.g. for tests), say that explicitly with
+-- 'finalizedAsIs'.
+newtype WithFinalizedDoc a = WithFinalizedDoc (Identity a)
+  deriving newtype (Functor, Applicative, Monad)
+
+-- | Mark the code with doc as finalized without any changes.
+finalizedAsIs :: a -> WithFinalizedDoc a
+finalizedAsIs = WithFinalizedDoc . Identity
+
+-- | Gather documenation.
+buildDoc :: ContainsDoc a => WithFinalizedDoc a -> ContractDoc
+buildDoc (WithFinalizedDoc (Identity a)) = buildDocUnfinalized a
+
+-- | Construct and format documentation in textual form.
+buildMarkdownDoc :: ContainsDoc a => WithFinalizedDoc a -> LText
+buildMarkdownDoc = contractDocToMarkdown . buildDoc
+
+-- | Recursevly traverse doc items and modify those that match given type.
+--
+-- If mapper returns 'Nothing', doc item will remain unmodified.
+modifyDoc
+  :: (ContainsUpdateableDoc a, DocItem i1, DocItem i2)
+  => (i1 -> Maybe i2) -> a -> a
+modifyDoc mapper = modifyDocEntirely untypedMapper
+  where
+  untypedMapper sdi@(SomeDocItem di) = fromMaybe sdi $ do
+    di' <- cast di
+    newDi <- mapper di'
+    return (SomeDocItem newDi)
+
 ----------------------------------------------------------------------------
 -- Basic doc items
 ----------------------------------------------------------------------------
@@ -588,6 +648,12 @@
   docItemToToc lvl (DName _ doc) =
     subDocToToc (nextHeaderLevel lvl) doc
 
+-- | This instance allows writing something like @docGroup "Title"@,
+-- this makes sense as the most primitive and basic use case for doc groups
+-- is putting a section under name.
+instance (di ~ DName) => IsString (SubDoc -> di) where
+  fromString = DName . fromString
+
 -- | Description of something.
 data DDescription = DDescription Markdown
 
@@ -726,3 +792,27 @@
     \[`Lorentz.Pack`](https://gitlab.com/morley-framework/morley/-/blob/2441e26bebd22ac4b30948e8facbb698d3b25c6d/code/lorentz/src/Lorentz/Pack.hs).\n\n\
     \* Construct values for this contract directly on Michelson level using types provided in the \
     \documentation."
+
+-- | Attach information about git revision.
+-- The code must contain git revision placeholder.
+--
+-- We do this in two stages because we use TH to deduce git revision information
+-- at compile time, and this is best to be done in the very end to recompile
+-- less modules.
+attachGitInfo :: ContainsUpdateableDoc a => DGitRevision -> a -> WithFinalizedDoc a
+attachGitInfo gitRev = finalizedAsIs ... modifyDoc $ \case
+  DGitRevisionUnknown -> Just gitRev
+  _ -> Nothing
+
+attachToc :: ContainsUpdateableDoc a => DToc -> a -> WithFinalizedDoc a
+attachToc toc = finalizedAsIs ... modifyDoc $ \case
+  DToc "" -> Just toc
+  _ -> Nothing
+
+-- | Attach common information that is available only in the end.
+attachDocCommons :: ContainsUpdateableDoc a => DGitRevision -> a -> WithFinalizedDoc a
+attachDocCommons gitRev code = do
+  let toc = DToc $ contractDocToToc (buildDocUnfinalized code)
+  pure code
+    >>= attachGitInfo gitRev
+    >>= attachToc toc
diff --git a/src/Michelson/Interpret.hs b/src/Michelson/Interpret.hs
--- a/src/Michelson/Interpret.hs
+++ b/src/Michelson/Interpret.hs
@@ -13,9 +13,11 @@
   , SomeItStack (..)
   , MorleyLogs (..)
   , noMorleyLogs
+  , pickMorleyLogs
 
   , interpret
   , interpretInstr
+  , interpretInstrAnnotated
   , ContractReturn
 
   , mkInitStack
@@ -24,6 +26,7 @@
   , InterpretResult (..)
   , EvalM
   , InterpreterStateMonad (..)
+  , StkEl (..)
   , InstrRunner
   , runInstr
   , runInstrNoGas
@@ -44,6 +47,7 @@
 import qualified Data.Set as Set
 import Data.Singletons (Sing)
 import Data.Vinyl (Rec(..), (<+>))
+import Data.Vinyl.Recursive (rmap)
 import Fmt (Buildable(build), Builder, blockListF, prettyLn)
 
 import Michelson.Interpret.Pack (packValue')
@@ -134,7 +138,7 @@
 deriving stock instance Show InterpretError
 
 instance Buildable InterpretError where
-  build (InterpretError (mf, logs)) = prettyLn mf <> "MorleyLogs are:\n" <> build logs
+  build (InterpretError (mf, _)) = prettyLn mf
 
 data InterpretResult where
   InterpretResult
@@ -158,15 +162,16 @@
   , iurNewState = st
   }
 
--- | Morley logs for interpreter state.
-newtype MorleyLogs = MorleyLogs
-  { unMorleyLogs :: [Text]
-    -- ^ Logs in reverse order.
-  } deriving stock (Eq, Show, Generic)
-    deriving newtype Default
+-- | Morley logs for interpreter state that are stored in reverse order.
+newtype MorleyLogs = MorleyLogs [Text]
+  deriving stock (Eq, Show, Generic)
+  deriving newtype Default
 
+pickMorleyLogs :: MorleyLogs -> [Text]
+pickMorleyLogs (MorleyLogs logs) = reverse logs
+
 instance Buildable MorleyLogs where
-  build (MorleyLogs logs) = blockListF $ reverse logs
+  build = blockListF . pickMorleyLogs
 
 instance NFData MorleyLogs
 
@@ -182,37 +187,57 @@
 handleContractReturn (ei, s) =
   bimap (InterpretError . (, isMorleyLogs s)) (constructIR . (, s)) ei
 
+-- | Function to change amount of remaining steps stored in State monad
+-- | Helper function to convert a record of @Value@ to @StkEl@. These will be
+-- created with @starNotes@.
+mapToStkEl :: Rec T.Value inp -> Rec StkEl inp
+mapToStkEl = rmap starNotesStkEl
+
+-- | Helper function to convert a record of @StkEl@ to @Value@. Any present
+-- notes will be discarded.
+mapToValue :: Rec StkEl inp -> Rec T.Value inp
+mapToValue = rmap seValue
+
 interpret'
   :: forall cp st arg.
-     ContractCode cp st
+     Contract cp st
   -> EntrypointCallT cp arg
   -> T.Value arg
   -> T.Value st
   -> ContractEnv
   -> InterpreterState
   -> ContractReturn st
-interpret' instr epc param initSt env ist = first (fmap fromFinalStack) $
+interpret' Contract{..} epc param initSt env ist = first (fmap fromFinalStack) $
   runEvalOp
-    (runInstr instr $ mkInitStack (liftCallArg epc param) initSt)
+    (runInstr cCode $ mkInitStack (liftCallArg epc param) cParamNotes initSt cStoreNotes)
     env
     ist
 
-mkInitStack :: T.Value param -> T.Value st -> Rec T.Value (ContractInp param st)
-mkInitStack param st = T.VPair (param, st) :& RNil
+mkInitStack
+  :: T.Value param
+  -> T.ParamNotes param
+  -> T.Value st
+  -> T.Notes st
+  -> Rec StkEl (ContractInp param st)
+mkInitStack param T.ParamNotesUnsafe{..} st stNotes = StkEl
+  (T.VPair (param, st))
+  U.noAnn
+  (T.NTPair U.noAnn (U.convAnn pnRootAnn) U.noAnn pnNotes stNotes)
+    :& RNil
 
-fromFinalStack :: Rec T.Value (ContractOut st) -> ([T.Operation], T.Value st)
-fromFinalStack (T.VPair (T.VList ops, st) :& RNil) =
+fromFinalStack :: Rec StkEl (ContractOut st) -> ([T.Operation], T.Value st)
+fromFinalStack (StkEl (T.VPair (T.VList ops, st)) _ _ :& RNil) =
   (map (\(T.VOp op) -> op) ops, st)
 
 interpret
-  :: ContractCode cp st
+  :: Contract cp st
   -> EntrypointCallT cp arg
   -> T.Value arg
   -> T.Value st
   -> ContractEnv
   -> ContractReturn st
-interpret instr epc param initSt env =
-  interpret' instr epc param initSt env (initInterpreterState env)
+interpret contract epc param initSt env =
+  interpret' contract epc param initSt env (initInterpreterState env)
 
 initInterpreterState :: ContractEnv -> InterpreterState
 initInterpreterState env = InterpreterState def (ceMaxSteps env) (OriginationIndex 0)
@@ -226,10 +251,21 @@
   -> Instr inp out
   -> Rec T.Value inp
   -> Either MichelsonFailed (Rec T.Value out)
-interpretInstr env instr inpSt =
+interpretInstr = fmap mapToValue ... interpretInstrAnnotated
+
+-- | Interpret an instruction in vacuum, putting no extra contraints on
+-- its execution while preserving its annotations.
+--
+-- Mostly for testing purposes.
+interpretInstrAnnotated
+  :: ContractEnv
+  -> Instr inp out
+  -> Rec T.Value inp
+  -> Either MichelsonFailed (Rec StkEl out)
+interpretInstrAnnotated env instr inpSt =
   fst $
   runEvalOp
-    (runInstr instr inpSt)
+    (runInstr instr $ mapToStkEl inpSt)
     env
     InterpreterState
       { isMorleyLogs = MorleyLogs []
@@ -238,7 +274,7 @@
       }
 
 data SomeItStack where
-  SomeItStack :: T.ExtInstr inp -> Rec T.Value inp -> SomeItStack
+  SomeItStack :: T.ExtInstr inp -> Rec StkEl inp -> SomeItStack
 
 newtype RemainingSteps = RemainingSteps Word64
   deriving stock (Show, Generic)
@@ -294,13 +330,22 @@
   , MonadError MichelsonFailed m
   )
 
+data StkEl t = StkEl
+  { seValue :: Value t
+  , seVarAnn :: U.VarAnn
+  , seNotes :: Notes t
+  } deriving stock (Eq, Show)
+
+starNotesStkEl :: forall t. Value t -> StkEl t
+starNotesStkEl v = StkEl v U.noAnn $ withValueTypeSanity v $ starNotes @t
+
 type InstrRunner m =
   forall inp out.
      Instr inp out
-  -> Rec (T.Value) inp
-  -> m (Rec (T.Value) out)
+  -> Rec StkEl inp
+  -> m (Rec StkEl out)
 
--- | Function to change amount of remaining steps stored in State monad
+-- | Function to change amount of remaining steps stored in State monad.
 runInstr :: EvalM m => InstrRunner m
 runInstr i@(Seq _i1 _i2) r = runInstrImpl runInstr i r
 runInstr i@(WithLoc _ _) r = runInstrImpl runInstr i r
@@ -311,7 +356,7 @@
 runInstr i r = do
   rs <- isRemainingSteps <$> getInterpreterState
   if rs == 0
-  then throwError $ MichelsonGasExhaustion
+  then throwError MichelsonGasExhaustion
   else do
     modifyInterpreterState (\s -> s {isRemainingSteps = rs - 1})
     runInstrImpl runInstr i r
@@ -323,15 +368,25 @@
 runInstrImpl :: EvalM m => InstrRunner m -> InstrRunner m
 runInstrImpl runner (Seq i1 i2) r = runner i1 r >>= \r' -> runner i2 r'
 runInstrImpl runner (WithLoc _ i) r = runner i r
-runInstrImpl runner (InstrWithNotes _ i) r = runner i r
-runInstrImpl runner (InstrWithVarNotes _ i) r = runner i r
+runInstrImpl runner (InstrWithNotes (PackedNotes n) i) inp =
+  runner i inp <&> \case
+    StkEl v vn _ :& r -> StkEl v vn n :& r
+runInstrImpl runner (InstrWithVarNotes (toList -> vns) i) inp = do
+  out <- runner i inp
+  let zipRec :: [U.VarAnn] -> Rec StkEl rs -> Rec StkEl rs
+      zipRec [] RNil = RNil
+      zipRec (vn : rs) stk = case stk of
+        StkEl v _ n :& r -> StkEl v vn n :& zipRec rs r
+        RNil -> error "Output stack is exhausted but there are still var annotations"
+      zipRec [] sm = sm
+  pure $ zipRec vns out
 runInstrImpl runner (FrameInstr (_ :: Proxy s) i) r = do
   let (inp, end) = rsplit @_ @_ @s r
   out <- runInstrImpl runner i inp
   return (out <+> end)
 runInstrImpl _ Nop r = pure $ r
-runInstrImpl _ (Ext nop) r = r <$ interpretExt (SomeItStack nop r)
-runInstrImpl runner (Nested sq) r = runInstrImpl runner sq r
+runInstrImpl runner (Ext nop) r = r <$ interpretExt runner (SomeItStack nop r)
+runInstrImpl runner (Nested sq) r = runner sq r
 runInstrImpl runner (DocGroup _ sq) r = runInstrImpl runner sq r
 runInstrImpl _ DROP (_ :& r) = pure $ r
 runInstrImpl runner (DROPN s) stack =
@@ -352,7 +407,7 @@
   pure $ go (nSing0, input0)
   where
     go :: forall (n :: Peano) inp out a. T.ConstraintDIG n inp out a =>
-      (Sing n, Rec T.Value inp) -> Rec T.Value out
+      (Sing n, Rec StkEl inp) -> Rec StkEl out
     go = \case
       (SZ, stack) ->  stack
       (SS nSing, b :& r) -> case go (nSing, r) of
@@ -361,75 +416,82 @@
   pure $ go (nSing0, input0)
   where
     go :: forall (n :: Peano) inp out a. T.ConstraintDUG n inp out a =>
-      (Sing n, Rec T.Value inp) -> Rec T.Value out
+      (Sing n, Rec StkEl inp) -> Rec StkEl out
     go = \case
       (SZ, stack) -> stack
       (SS s', a :& b :& r) -> b :& go (s', a :& r)
-runInstrImpl _ SOME (a :& r) =
+runInstrImpl _ SOME ((seValue -> a) :& r) =
   withValueTypeSanity a $
-    pure $ VOption (Just a) :& r
-runInstrImpl _ (PUSH v) r = pure $ v :& r
-runInstrImpl _ NONE r = pure $ VOption Nothing :& r
-runInstrImpl _ UNIT r = pure $ VUnit :& r
-runInstrImpl runner (IF_NONE _bNone bJust) (VOption (Just a) :& r) = runner bJust (a :& r)
-runInstrImpl runner (IF_NONE bNone _bJust) (VOption Nothing :& r) = runner bNone r
-runInstrImpl _ (AnnPAIR{}) (a :& b :& r) = pure $ VPair (a, b) :& r
-runInstrImpl _ (AnnCAR _) (VPair (a, _b) :& r) = pure $ a :& r
-runInstrImpl _ (AnnCDR _) (VPair (_a, b) :& r) = pure $ b :& r
-runInstrImpl _ LEFT (a :& r) =
+    pure $ starNotesStkEl (VOption (Just a)) :& r
+runInstrImpl _ (PUSH v) r = pure $ starNotesStkEl v :& r
+runInstrImpl _ NONE r = pure $ starNotesStkEl (VOption Nothing) :& r
+runInstrImpl _ UNIT r = pure $ starNotesStkEl VUnit :& r
+runInstrImpl runner (IF_NONE _bNone bJust) (StkEl (VOption (Just a)) _ _ :& r) =
+  runner bJust (starNotesStkEl a :& r)
+runInstrImpl runner (IF_NONE bNone _bJust) (StkEl (VOption Nothing) _ _ :& r) =
+  runner bNone r
+runInstrImpl _ (AnnPAIR nt nf1 nf2) ((StkEl a _ na) :& (StkEl b _ nb) :& r) =
+  pure $ StkEl (VPair (a, b)) U.noAnn (NTPair nt nf1 nf2 na nb) :& r
+runInstrImpl _ (AnnCAR _) (StkEl (VPair (a, _b)) _ _ :& r) = pure $ starNotesStkEl a :& r
+runInstrImpl _ (AnnCDR _) (StkEl (VPair (_a, b)) _ _ :& r) = pure $ starNotesStkEl b :& r
+runInstrImpl _ LEFT ((seValue -> a) :& r) =
   withValueTypeSanity a $
-    pure $ (VOr $ Left a) :& r
-runInstrImpl _ RIGHT (b :& r) =
+    pure $ starNotesStkEl (VOr $ Left a) :& r
+runInstrImpl _ RIGHT ((seValue -> b) :& r) =
   withValueTypeSanity b $
-    pure $ (VOr $ Right b) :& r
-runInstrImpl runner (IF_LEFT bLeft _) (VOr (Left a) :& r) = runner bLeft (a :& r)
-runInstrImpl runner (IF_LEFT _ bRight) (VOr (Right a) :& r) = runner bRight (a :& r)
+    pure $ starNotesStkEl (VOr $ Right b) :& r
+runInstrImpl runner (IF_LEFT bLeft _) (StkEl (VOr (Left a)) _ _ :& r) =
+  runner bLeft (starNotesStkEl a :& r)
+runInstrImpl runner (IF_LEFT _ bRight) (StkEl (VOr (Right a)) _ _ :& r) =
+  runner bRight (starNotesStkEl a :& r)
 -- More here
-runInstrImpl _ NIL r = pure $ VList [] :& r
-runInstrImpl _ CONS (a :& VList l :& r) = pure $ VList (a : l) :& r
-runInstrImpl runner (IF_CONS _ bNil) (VList [] :& r) = runner bNil r
-runInstrImpl runner (IF_CONS bCons _) (VList (lh : lr) :& r) = runner bCons (lh :& VList lr :& r)
-runInstrImpl _ SIZE (a :& r) = pure $ (VNat $ (fromInteger . toInteger) $ evalSize a) :& r
-runInstrImpl _ EMPTY_SET r = pure $ VSet Set.empty :& r
-runInstrImpl _ EMPTY_MAP r = pure $ VMap Map.empty :& r
-runInstrImpl _ EMPTY_BIG_MAP r = pure $ VBigMap Map.empty :& r
-runInstrImpl runner (MAP ops) (a :& r) =
+runInstrImpl _ NIL r = pure $ starNotesStkEl (VList []) :& r
+runInstrImpl _ CONS (a :& StkEl (VList l) _ _ :& r) = pure $ starNotesStkEl (VList (seValue a : l)) :& r
+runInstrImpl runner (IF_CONS _ bNil) (StkEl (VList []) _ _ :& r) = runner bNil r
+runInstrImpl runner (IF_CONS bCons _) (StkEl (VList (lh : lr)) _ _ :& r) =
+  runner bCons (starNotesStkEl lh :& starNotesStkEl (VList lr) :& r)
+runInstrImpl _ SIZE (a :& r) = pure $ starNotesStkEl (VNat $ (fromInteger . toInteger) $ evalSize $ seValue a) :& r
+runInstrImpl _ EMPTY_SET r = pure $ starNotesStkEl (VSet Set.empty) :& r
+runInstrImpl _ EMPTY_MAP r = pure $ starNotesStkEl (VMap Map.empty) :& r
+runInstrImpl _ EMPTY_BIG_MAP r = pure $ starNotesStkEl (VBigMap Map.empty) :& r
+runInstrImpl runner (MAP ops) ((seValue -> a) :& r) =
   case ops of
     (code :: Instr (MapOpInp c ': s) (b ': s)) -> do
       -- Evaluation must preserve all stack modifications that @MAP@'s does.
-      (newStack, newList) <- foldlM (\(curStack, curList) (val :: T.Value (MapOpInp c)) -> do
+      (newStack, newList) <- foldlM (\(curStack, curList) (val :: StkEl (MapOpInp c)) -> do
         res <- runner code (val :& curStack)
         case res of
-          ((nextVal :: T.Value b) :& nextStack) -> pure (nextStack, nextVal : curList))
-        (r, []) (mapOpToList @c a)
-      pure $ mapOpFromList a (reverse newList) :& newStack
+          ((seValue -> nextVal :: T.Value b) :& nextStack) -> pure (nextStack, nextVal : curList))
+        (r, []) (starNotesStkEl <$> mapOpToList @c a)
+      pure $ starNotesStkEl (mapOpFromList a (reverse newList)) :& newStack
 runInstrImpl runner (ITER ops) (a :& r) =
   case ops of
     (code :: Instr (IterOpEl c ': s) s) ->
-      case iterOpDetachOne @c a of
+      case iterOpDetachOne @c (seValue a) of
         (Just x, xs) -> do
-          res <- runner code (x :& r)
-          runner (ITER code) (xs :& res)
+          res <- runner code (starNotesStkEl x :& r)
+          runner (ITER code) (starNotesStkEl xs :& res)
         (Nothing, _) -> pure r
-runInstrImpl _ MEM (a :& b :& r) = pure $ (VBool (evalMem a b)) :& r
-runInstrImpl _ GET (a :& b :& r) = pure $ VOption (evalGet a b) :& r
-runInstrImpl _ UPDATE (a :& b :& c :& r) = pure $ evalUpd a b c :& r
-runInstrImpl runner (IF bTrue _) (VBool True :& r) = runner bTrue r
-runInstrImpl runner (IF _ bFalse) (VBool False :& r) = runner bFalse r
-runInstrImpl _ (LOOP _) (VBool False :& r) = pure $ r
-runInstrImpl runner (LOOP ops) (VBool True :& r) = do
+runInstrImpl _ MEM (a :& b :& r) = pure $ starNotesStkEl (VBool (evalMem (seValue a) (seValue b))) :& r
+runInstrImpl _ GET (a :& b :& r) = pure $ starNotesStkEl (VOption (evalGet (seValue a) (seValue b))) :& r
+runInstrImpl _ UPDATE (a :& b :& c :& r) =
+    pure $ starNotesStkEl (evalUpd (seValue a) (seValue b) (seValue c)) :& r
+runInstrImpl runner (IF bTrue _) (StkEl (VBool True) _ _ :& r) = runner bTrue r
+runInstrImpl runner (IF _ bFalse) (StkEl (VBool False) _ _ :& r) = runner bFalse r
+runInstrImpl _ (LOOP _) (StkEl (VBool False) _ _ :& r) = pure $ r
+runInstrImpl runner (LOOP ops) (StkEl (VBool True) _ _ :& r) = do
   res <- runner ops r
   runner (LOOP ops) res
-runInstrImpl _ (LOOP_LEFT _) (VOr (Right a) :&r) = pure $ a :& r
-runInstrImpl runner (LOOP_LEFT ops) (VOr (Left a) :& r) = do
-  res <- runner ops (a :& r)
-  runner  (LOOP_LEFT ops) res
-runInstrImpl _ (LAMBDA lam) r = pure $ lam :& r
-runInstrImpl runner EXEC (a :& VLam (T.rfAnyInstr -> lBody) :& r) = do
+runInstrImpl _ (LOOP_LEFT _) (StkEl (VOr (Right a)) _ _ :& r) = pure $ starNotesStkEl a :& r
+runInstrImpl runner (LOOP_LEFT ops) (StkEl (VOr (Left a)) _ _ :& r) = do
+  res <- runner ops (starNotesStkEl a :& r)
+  runner (LOOP_LEFT ops) res
+runInstrImpl _ (LAMBDA lam) r = pure $ starNotesStkEl lam :& r
+runInstrImpl runner EXEC (a :& StkEl (VLam (T.rfAnyInstr -> lBody)) _ _ :& r) = do
   res <- runner lBody (a :& RNil)
   pure $ res <+> r
-runInstrImpl _ APPLY ((a :: T.Value a) :& VLam lBody :& r) = do
-  pure $ VLam (T.rfMapAnyInstr doApply lBody) :& r
+runInstrImpl _ APPLY (StkEl (a :: T.Value a) _ _ :& StkEl (VLam lBody) _ _ :& r) = do
+  pure $ starNotesStkEl (VLam (T.rfMapAnyInstr doApply lBody)) :& r
   where
     doApply :: Instr ('TPair a i ': s) o -> Instr (i ': s) o
     doApply b = PUSH a `Seq` PAIR `Seq` Nested b
@@ -441,47 +503,56 @@
     SZ -> runner i stack
     SS s' -> case stack of
       (a :& r) -> (a :&) <$> runInstrImpl runner (DIPN s' i) r
-runInstrImpl _ FAILWITH (a :& _) = throwError $ MichelsonFailedWith a
-runInstrImpl _ CAST (a :& r) = pure $ a :& r
-runInstrImpl _ RENAME (a :& r) = pure $ a :& r
-runInstrImpl _ PACK (a :& r) = pure $ (VBytes $ packValue' a) :& r
-runInstrImpl _ UNPACK (VBytes a :& r) =
-  pure $ (VOption . rightToMaybe $ runUnpack a) :& r
-runInstrImpl _ CONCAT (a :& b :& r) = pure $ evalConcat a b :& r
-runInstrImpl _ CONCAT' (VList a :& r) = pure $ evalConcat' a :& r
-runInstrImpl _ SLICE (VNat o :& VNat l :& s :& r) =
-  pure $ VOption (evalSlice o l s) :& r
-runInstrImpl _ ISNAT (VInt i :& r) =
+runInstrImpl _ FAILWITH (a :& _) = throwError $ MichelsonFailedWith (seValue a)
+runInstrImpl _ CAST (StkEl a vn _ :& r) = pure $ StkEl a vn starNotes :& r
+runInstrImpl _ RENAME (StkEl a _ n :& r) = pure $ StkEl a U.noAnn n :& r
+runInstrImpl _ PACK ((seValue -> a) :& r) = pure $ starNotesStkEl (VBytes $ packValue' a) :& r
+runInstrImpl _ UNPACK (StkEl (VBytes a) _ _ :& r) =
+  pure $ starNotesStkEl (VOption . rightToMaybe $ runUnpack a) :& r
+runInstrImpl _ CONCAT (a :& b :& r) = pure $ starNotesStkEl (evalConcat (seValue a) (seValue b)) :& r
+runInstrImpl _ CONCAT' (StkEl (VList a) _ _ :& r) = pure $ starNotesStkEl (evalConcat' a) :& r
+runInstrImpl _ SLICE (StkEl (VNat o) _ _ :& StkEl (VNat l) _ _ :& StkEl s _ _ :& r) =
+  pure $ starNotesStkEl (VOption (evalSlice o l s)) :& r
+runInstrImpl _ ISNAT (StkEl (VInt i) _ _ :& r) =
   if i < 0
-  then pure $ VOption Nothing :& r
-  else pure $ VOption (Just (VNat $ fromInteger i)) :& r
-runInstrImpl _ ADD (l :& r :& rest) =
-  (:& rest) <$> runArithOp (Proxy @Add) l r
+  then pure $ starNotesStkEl (VOption Nothing) :& r
+  else pure $ starNotesStkEl (VOption (Just (VNat $ fromInteger i))) :& r
+runInstrImpl _ ADD (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @Add) l r
 runInstrImpl _ SUB (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @Sub) l r
 runInstrImpl _ MUL (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @Mul) l r
-runInstrImpl _ EDIV (l :& r :& rest) = pure $ evalEDivOp l r :& rest
-runInstrImpl _ ABS (a :& rest) = pure $ (evalUnaryArithOp (Proxy @Abs) a) :& rest
-runInstrImpl _ NEG (a :& rest) = pure $ (evalUnaryArithOp (Proxy @Neg) a) :& rest
+runInstrImpl _ EDIV (l :& r :& rest) = pure $ starNotesStkEl (evalEDivOp (seValue l) (seValue r)) :& rest
+runInstrImpl _ ABS ((seValue -> a) :& rest) =
+  pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Abs) a) :& rest
+runInstrImpl _ NEG ((seValue -> a) :& rest) =
+  pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Neg) a) :& rest
 runInstrImpl _ LSL (x :& s :& rest) = (:& rest) <$> runArithOp (Proxy @Lsl) x s
 runInstrImpl _ LSR (x :& s :& rest) = (:& rest) <$> runArithOp (Proxy @Lsr) x s
 runInstrImpl _ OR (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @Or) l r
 runInstrImpl _ AND (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @And) l r
 runInstrImpl _ XOR (l :& r :& rest) = (:& rest) <$> runArithOp (Proxy @Xor) l r
-runInstrImpl _ NOT (a :& rest) = pure $ (evalUnaryArithOp (Proxy @Not) a) :& rest
-runInstrImpl _ COMPARE (l :& r :& rest) = pure $ (T.VInt (compareOp l r)) :& rest
-runInstrImpl _ EQ (a :& rest) = pure $ (evalUnaryArithOp (Proxy @Eq') a) :& rest
-runInstrImpl _ NEQ (a :& rest) = pure $ (evalUnaryArithOp (Proxy @Neq) a) :& rest
-runInstrImpl _ LT (a :& rest) = pure $ (evalUnaryArithOp (Proxy @Lt) a) :& rest
-runInstrImpl _ GT (a :& rest) = pure $ (evalUnaryArithOp (Proxy @Gt) a) :& rest
-runInstrImpl _ LE (a :& rest) = pure $ (evalUnaryArithOp (Proxy @Le) a) :& rest
-runInstrImpl _ GE (a :& rest) = pure $ (evalUnaryArithOp (Proxy @Ge) a) :& rest
-runInstrImpl _ INT (VNat n :& r) = pure $ (VInt $ toInteger n) :& r
+runInstrImpl _ NOT ((seValue -> a) :& rest) =
+  pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Not) a) :& rest
+runInstrImpl _ COMPARE ((seValue -> l) :& (seValue -> r) :& rest) =
+  pure $ starNotesStkEl (T.VInt (compareOp l r)) :& rest
+runInstrImpl _ EQ ((seValue -> a) :& rest) =
+  pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Eq') a) :& rest
+runInstrImpl _ NEQ ((seValue -> a) :& rest) =
+  pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Neq) a) :& rest
+runInstrImpl _ LT ((seValue -> a) :& rest) =
+  pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Lt) a) :& rest
+runInstrImpl _ GT ((seValue -> a) :& rest) =
+  pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Gt) a) :& rest
+runInstrImpl _ LE ((seValue -> a) :& rest) =
+  pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Le) a) :& rest
+runInstrImpl _ GE ((seValue -> a) :& rest) =
+  pure $ starNotesStkEl (evalUnaryArithOp (Proxy @Ge) a) :& rest
+runInstrImpl _ INT (StkEl (VNat n) _ _ :& r) = pure $ starNotesStkEl (VInt $ toInteger n) :& r
 runInstrImpl _ (SELF sepc :: Instr inp out) r = do
   ContractEnv{..} <- ask
   case Proxy @out of
     (_ :: Proxy ('TContract cp ': s)) -> do
-      pure $ VContract ceSelf sepc :& r
-runInstrImpl _ (CONTRACT (nt :: T.Notes a) instrEpName) (VAddress epAddr :& r) = do
+      pure $ starNotesStkEl (VContract ceSelf sepc) :& r
+runInstrImpl _ (CONTRACT (nt :: T.Notes a) instrEpName) (StkEl (VAddress epAddr) _ _ :& r) = do
   ContractEnv{..} <- ask
   let T.EpAddress addr addrEpName = epAddr
   let mepName =
@@ -491,18 +562,16 @@
           (en, DefEpName) -> Just en
           _ -> Nothing
 
-  pure $ case mepName of
-    Nothing ->
-      VOption Nothing :& r
+  let withNotes v = StkEl v U.noAnn (NTOption U.noAnn $ NTContract U.noAnn nt) :& r
+  pure $ withNotes $ case mepName of
+    Nothing -> VOption Nothing
     Just epName ->
       case addr of
-        KeyAddress _ ->
-          castContract addr epName T.tyImplicitAccountParam :& r
+        KeyAddress _ -> castContract addr epName T.tyImplicitAccountParam
         ContractAddress ca ->
           case Map.lookup ca ceContracts of
-            Just (SomeParamType _ paramNotes) ->
-              castContract addr epName paramNotes :& r
-            Nothing -> VOption Nothing :& r
+            Just (SomeParamType _ paramNotes) -> castContract addr epName paramNotes
+            Nothing -> VOption Nothing
   where
   castContract
     :: forall p. T.ParameterScope p
@@ -513,14 +582,15 @@
     Right (Refl, _) <- pure $ matchTypes nt na
     return $ VContract addr (T.SomeEpc epc)
 
-runInstrImpl _ TRANSFER_TOKENS (p :& VMutez mutez :& contract :& r) =
-  pure $ VOp (OpTransferTokens $ TransferTokens p mutez contract) :& r
-runInstrImpl _ SET_DELEGATE (VOption mbKeyHash :& r) =
+runInstrImpl _ TRANSFER_TOKENS
+  (StkEl p _ _ :& StkEl (VMutez mutez) _ _ :& StkEl contract _ _ :& r) =
+  pure $ starNotesStkEl (VOp (OpTransferTokens $ TransferTokens p mutez contract)) :& r
+runInstrImpl _ SET_DELEGATE (StkEl (VOption mbKeyHash) _ _ :& r) =
   case mbKeyHash of
-    Just (VKeyHash k) -> pure $ VOp (OpSetDelegate $ SetDelegate $ Just k) :& r
-    Nothing -> pure $ VOp (OpSetDelegate $ SetDelegate $ Nothing) :& r
+    Just (VKeyHash k) -> pure $ starNotesStkEl (VOp (OpSetDelegate $ SetDelegate $ Just k)) :& r
+    Nothing -> pure $ starNotesStkEl (VOp (OpSetDelegate $ SetDelegate $ Nothing)) :& r
 runInstrImpl _ (CREATE_CONTRACT contract)
-  (VOption mbKeyHash :& VMutez m :& g :& r) = do
+  (StkEl (VOption mbKeyHash) _ _ :& StkEl (VMutez m) _ _ :& StkEl g _ _ :& r) = do
   originator <- ceSelf <$> ask
 
   originationNonce <- isOriginationNonce <$> getInterpreterState
@@ -542,48 +612,53 @@
               globalCounter
   let resEpAddr = EpAddress resAddr DefEpName
   let resOp = CreateContract originator (unwrapMbKeyHash mbKeyHash) m g ops
-  pure $ VOp (OpCreateContract resOp)
-      :& (VAddress resEpAddr)
+  pure $ starNotesStkEl (VOp (OpCreateContract resOp))
+      :& starNotesStkEl (VAddress resEpAddr)
       :& r
-runInstrImpl _ IMPLICIT_ACCOUNT (VKeyHash k :& r) =
-  pure $ VContract (KeyAddress k) sepcPrimitive :& r
+runInstrImpl _ IMPLICIT_ACCOUNT (StkEl (VKeyHash k) _ _ :& r) =
+  pure $ (starNotesStkEl (VContract (KeyAddress k) sepcPrimitive)) :& r
 runInstrImpl _ NOW r = do
   ContractEnv{..} <- ask
-  pure $ (VTimestamp ceNow) :& r
+  pure $ starNotesStkEl (VTimestamp ceNow) :& r
 runInstrImpl _ AMOUNT r = do
   ContractEnv{..} <- ask
-  pure $ (VMutez ceAmount) :& r
+  pure $ starNotesStkEl (VMutez ceAmount) :& r
 runInstrImpl _ BALANCE r = do
   ContractEnv{..} <- ask
-  pure $ (VMutez ceBalance) :& r
-runInstrImpl _ CHECK_SIGNATURE (VKey k :& VSignature v :&
-  VBytes b :& r) = pure $ (VBool $ checkSignature k v b) :& r
-runInstrImpl _ SHA256 (VBytes b :& r) = pure $ (VBytes $ sha256 b) :& r
-runInstrImpl _ SHA512 (VBytes b :& r) = pure $ (VBytes $ sha512 b) :& r
-runInstrImpl _ BLAKE2B (VBytes b :& r) = pure $ (VBytes $ blake2b b) :& r
-runInstrImpl _ HASH_KEY (VKey k :& r) = pure $ (VKeyHash $ hashKey k) :& r
+  pure $ starNotesStkEl (VMutez ceBalance) :& r
+runInstrImpl _ CHECK_SIGNATURE
+  (StkEl (VKey k) _ _ :& StkEl (VSignature v) _ _ :& StkEl (VBytes b) _ _ :& r) =
+  pure $ starNotesStkEl (VBool $ checkSignature k v b) :& r
+runInstrImpl _ SHA256 (StkEl (VBytes b) _ _ :& r) =
+  pure $ starNotesStkEl (VBytes $ sha256 b) :& r
+runInstrImpl _ SHA512 (StkEl (VBytes b) _ _ :& r) =
+  pure $ starNotesStkEl (VBytes $ sha512 b) :& r
+runInstrImpl _ BLAKE2B (StkEl (VBytes b) _ _ :& r) =
+  pure $ starNotesStkEl (VBytes $ blake2b b) :& r
+runInstrImpl _ HASH_KEY (StkEl (VKey k) _ _ :& r) =
+  pure $ starNotesStkEl (VKeyHash $ hashKey k) :& r
 runInstrImpl _ SOURCE r = do
   ContractEnv{..} <- ask
-  pure $ (VAddress $ EpAddress ceSource DefEpName) :& r
+  pure $ starNotesStkEl (VAddress $ EpAddress ceSource DefEpName) :& r
 runInstrImpl _ SENDER r = do
   ContractEnv{..} <- ask
-  pure $ (VAddress $ EpAddress ceSender DefEpName) :& r
-runInstrImpl _ ADDRESS (VContract a sepc :& r) =
-  pure $ (VAddress $ EpAddress a (sepcName sepc)) :& r
+  pure $ starNotesStkEl (VAddress $ EpAddress ceSender DefEpName) :& r
+runInstrImpl _ ADDRESS (StkEl (VContract a sepc) _ _ :& r) =
+  pure $ starNotesStkEl (VAddress $ EpAddress a (sepcName sepc)) :& r
 runInstrImpl _ CHAIN_ID r = do
   ContractEnv{..} <- ask
-  pure $ VChainId ceChainId :& r
+  pure $ starNotesStkEl (VChainId ceChainId) :& r
 
 -- | Evaluates an arithmetic operation and either fails or proceeds.
 runArithOp
   :: (ArithOp aop n m, Typeable n, Typeable m, EvalM monad)
   => proxy aop
-  -> Value n
-  -> Value m
-  -> monad (Value (ArithRes aop n m))
-runArithOp op l r = case evalOp op l r of
+  -> StkEl n
+  -> StkEl m
+  -> monad (StkEl (ArithRes aop n m))
+runArithOp op l r = case evalOp op (seValue l) (seValue r) of
   Left  err -> throwError (MichelsonArithError err)
-  Right res -> pure res
+  Right res -> pure $ starNotesStkEl res
 
 -- | Unpacks given raw data into a typed value.
 runUnpack
@@ -616,35 +691,36 @@
 unwrapMbKeyHash :: Maybe (T.Value 'T.TKeyHash) -> Maybe KeyHash
 unwrapMbKeyHash mbKeyHash = mbKeyHash <&> \(VKeyHash keyHash) -> keyHash
 
-interpretExt :: EvalM m => SomeItStack -> m ()
-interpretExt (SomeItStack (T.PRINT (T.PrintComment pc)) st) = do
+interpretExt :: EvalM 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 show
-  modifyInterpreterState (\s -> s {isMorleyLogs = MorleyLogs $ mconcat (map getEl pc) : unMorleyLogs (isMorleyLogs s)})
+      getEl (Right str) = withStackElem str st (show . seValue)
+      getMorleyLogs (MorleyLogs logs) = logs
+  modifyInterpreterState (\s -> s {isMorleyLogs = MorleyLogs $ mconcat (map getEl pc) : getMorleyLogs (isMorleyLogs s)})
 
-interpretExt (SomeItStack (T.TEST_ASSERT (T.TestAssert nm pc instr)) st) = do
-  ost <- runInstrNoGas instr st
-  let ((T.fromVal -> succeeded) :& _) = ost
+interpretExt runner (SomeItStack (T.TEST_ASSERT (T.TestAssert nm pc instr)) st) = do
+  ost <- runInstrImpl runner instr st
+  let ((seValue -> T.fromVal -> succeeded) :& _) = ost
   unless succeeded $ do
-    interpretExt (SomeItStack (T.PRINT pc) st)
+    interpretExt runner (SomeItStack (T.PRINT pc) st)
     throwError $ MichelsonFailedTestAssert $ "TEST_ASSERT " <> nm <> " failed"
 
-interpretExt (SomeItStack T.DOC_ITEM{} _) = pass
-interpretExt (SomeItStack T.COMMENT_ITEM{} _) = pass
+interpretExt _ (SomeItStack T.DOC_ITEM{} _) = pass
+interpretExt _ (SomeItStack T.COMMENT_ITEM{} _) = pass
 
 -- | Access given stack reference (in CPS style).
 withStackElem
   :: forall st a.
      T.StackRef st
-  -> Rec T.Value st
-  -> (forall t. T.Value t -> a)
+  -> Rec StkEl st
+  -> (forall t. StkEl t -> a)
   -> a
 withStackElem (T.StackRef sn) vals cont =
   loop (vals, sn)
   where
     loop
       :: forall s (n :: Peano). (LongerThan s n)
-      => (Rec T.Value s, Sing n) -> a
+      => (Rec StkEl s, Sing n) -> a
     loop = \case
       (e :& _, SZ) -> cont e
       (_ :& es, SS n) -> loop (es, n)
diff --git a/src/Michelson/Interpret/Unpack.hs b/src/Michelson/Interpret/Unpack.hs
--- a/src/Michelson/Interpret/Unpack.hs
+++ b/src/Michelson/Interpret/Unpack.hs
@@ -688,20 +688,19 @@
     0x5D -> pure TKeyHash
     0x6B -> pure TTimestamp
     0x6E -> pure TAddress
+    0x65 -> decodeTPair
     _ -> fail failMessage
   case pretag of
     0x03 -> (ct,,) <$> decodeNoAnn <*> decodeNoAnn
     0x04 -> decodeWithTFAnns (ct,,)
     0x05 -> decodeWithTFAnns (ct,,)
+    0x07 -> (ct,,) <$> decodeNoAnn <*> decodeNoAnn
     _ -> fail failMessage
 
 {-# ANN decodeTWithAnns ("HLint: ignore Redundant <$>" :: Text) #-}
 decodeTWithAnns :: Get (T, TypeAnn, FieldAnn)
-decodeTWithAnns = doDecode <|> decodeTc ? "Type"
+decodeTWithAnns = doDecode <|> decodeCTWithAnns ? "Type"
   where
-    decodeTc = do
-      (ct, tAnn, fAnn) <- decodeCTWithAnns
-      pure (ct, tAnn, fAnn)
     doDecode = do
       pretag <- Get.getWord8 ? "Pre complex type tag"
       tag <- Get.getWord8 ? "Complex type tag"
diff --git a/src/Michelson/Optimizer.hs b/src/Michelson/Optimizer.hs
--- a/src/Michelson/Optimizer.hs
+++ b/src/Michelson/Optimizer.hs
@@ -20,16 +20,19 @@
 module Michelson.Optimizer
   ( optimize
   , optimizeWithConf
+  , defaultOptimizerConf
   , defaultRules
   , defaultRulesAndPushPack
   , orRule
   , orSimpleRule
   , Rule
   , OptimizerConf (..)
+  , ocGotoValuesL
   ) where
 
 import Prelude hiding (EQ)
 
+import Control.Lens (makeLensesFor)
 import Data.Constraint (Dict(..))
 import Data.Default (Default(def))
 import Data.Singletons (sing)
@@ -50,15 +53,19 @@
 ----------------------------------------------------------------------------
 
 data OptimizerConf = OptimizerConf
-  { gotoValues :: Bool
-  , ruleset    :: Rule -> Rule
+  { ocGotoValues :: Bool
+  , ocRuleset    :: Rule -> Rule
   }
 
+-- | Default config - all commonly useful rules will be applied to all the code.
+defaultOptimizerConf :: OptimizerConf
+defaultOptimizerConf = OptimizerConf
+  { ocGotoValues = True
+  , ocRuleset    = defaultRules
+  }
+
 instance Default OptimizerConf where
-  def = OptimizerConf
-    { gotoValues = False
-    , ruleset    = defaultRules
-    }
+  def = defaultOptimizerConf
 
 -- | Optimize a typed instruction by replacing some sequences of
 -- instructions with smaller equivalent sequences.
@@ -68,14 +75,14 @@
 
 -- | Optimize a typed instruction using a custom set of rules.
 optimizeWithConf :: OptimizerConf -> Instr inp out -> Instr inp out
-optimizeWithConf (OptimizerConf gotoValues rules)
+optimizeWithConf (OptimizerConf ocGotoValues rules)
   = (fst .)
   $ dfsInstr dfsSettings
   $ (adapter .)
   $ applyOnce
   $ fixpoint rules
   where
-    dfsSettings = def{ dsGoToValues = gotoValues }
+    dfsSettings = def{ dsGoToValues = ocGotoValues }
 
 ----------------------------------------------------------------------------
 -- Rewrite rules
@@ -362,15 +369,15 @@
     pushPacked :: PackedValScope t => Value t -> Instr s ('TBytes ': s)
     pushPacked = PUSH . VBytes . packValue'
 
--- | Append LHS of 'Seq' to RHS and re-run pointwise ruleset at each point.
+-- | Append LHS of 'Seq' to RHS and re-run pointwise ocRuleset at each point.
 --   That might cause reinvocation of this function (see 'defaultRules'),
 --   but productivity ensures it will flatten any 'Seq'-tree right-to-left,
 --   while evaling no more than once on each node.
 --
---   The reason this function invokes ruleset is when you append an instr
+--   The reason this function invokes ocRuleset is when you append an instr
 --   to already-optimised RHS of 'Seq', you might get an optimisable tree.
 --
---   The argument is a local, non-structurally-recursive ruleset.
+--   The argument is a local, non-structurally-recursive ocRuleset.
 linearizeAndReapply :: Rule -> Instr inp out -> Instr inp out
 linearizeAndReapply restart = \case
   Seq (Seq a b) c ->
@@ -410,3 +417,9 @@
 whileApplies r = go
   where
     go i = maybe (Just i) go (r i)
+
+----------------------------------------------------------------------------
+-- TH
+----------------------------------------------------------------------------
+
+makeLensesFor [("ocGotoValues", "ocGotoValuesL")] ''OptimizerConf
diff --git a/src/Michelson/Runtime.hs b/src/Michelson/Runtime.hs
--- a/src/Michelson/Runtime.hs
+++ b/src/Michelson/Runtime.hs
@@ -599,7 +599,7 @@
           }
           <- liftEither $ first (EEInterpreterFailed addr) $
              handleContractReturn $
-                interpret (T.cCode csContract) epc
+                interpret csContract epc
                 typedParameter csStorage contractEnv
         let
           updBalance
diff --git a/src/Michelson/TypeCheck/Helpers.hs b/src/Michelson/TypeCheck/Helpers.hs
--- a/src/Michelson/TypeCheck/Helpers.hs
+++ b/src/Michelson/TypeCheck/Helpers.hs
@@ -3,8 +3,7 @@
 -- SPDX-License-Identifier: LicenseRef-MIT-TQ
 
 module Michelson.TypeCheck.Helpers
-    ( onLeft
-    , deriveSpecialVN
+    ( deriveSpecialVN
     , deriveSpecialFNs
     , deriveVN
     , deriveNsOr
@@ -40,6 +39,7 @@
     , mulImpl
     , edivImpl
     , unaryArithImpl
+    , unaryArithImplAnnotated
     , withCompareableCheck
     ) where
 
@@ -69,6 +69,7 @@
 
 import qualified Michelson.Untyped as Un
 import Michelson.Untyped.Annotation (Annotation(..), FieldAnn, VarAnn, ann)
+import Util.Type (onFirst)
 
 -- | Function which derives special annotations
 -- for PAIR instruction.
@@ -144,10 +145,6 @@
 convergeHST (a ::& as) (b ::& bs) =
     liftA2 (::&) (convergeHSTEl a b) (convergeHST as bs)
 
--- TODO move to Util module
-onLeft :: Either a c -> (a -> b) -> Either b c
-onLeft = flip first
-
 -- | Extract singleton for each single type of the given stack.
 hstToTs :: HST st -> [T]
 hstToTs = \case
@@ -163,7 +160,7 @@
   case eqT @as @bs of
     Nothing -> Left $ StackEqError (hstToTs hst) (hstToTs hst')
     Just Refl -> do
-      void $ convergeHST hst hst' `onLeft` AnnError
+      void $ convergeHST hst hst' `onFirst` AnnError
       return Refl
 
 -- | Check whether the given stack has size 1 and its only element matches the
@@ -244,7 +241,7 @@
   => Un.ExpandedInstr -> HST ts -> Maybe TypeContext
   -> Either AnnConvergeError a -> m a
 onTypeCheckInstrAnnErr instr i mContext ei =
-  onTypeCheckInstrErr instr (SomeHST i) mContext (ei `onLeft` AnnError)
+  onTypeCheckInstrErr instr (SomeHST i) mContext (ei `onFirst` AnnError)
 
 withCompareableCheck
   :: forall a m v ts. (Typeable ts, MonadReader InstrCallStack m, MonadError TCError m)
@@ -353,6 +350,9 @@
   -> TypeCheckInstrNoExcept (TypeCheckedSeq inp)
 typeCheckImplNoLastTypeComment _ [] inputStack
   = pure (WellTypedSeq (inputStack :/ Nop ::: inputStack))
+typeCheckImplNoLastTypeComment tcInstr [op] inputStack = do
+  typeCheckOpImpl tcInstr op inputStack
+      >>= mapMSeq prependStackTypeComment
 typeCheckImplNoLastTypeComment tcInstr (op : ops) inputStack = do
   done <- typeCheckOpImpl tcInstr op inputStack
       >>= mapMSeq prependStackTypeComment
@@ -386,6 +386,7 @@
                         (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 -> InstrCallStack
@@ -482,7 +483,7 @@
   => Notes t1 -> Notes t2 -> Either TCTypeError (t1 :~: t2, Notes t1)
 matchTypes n1 n2 = do
   Refl <- eqType @t1 @t2
-  nr <- converge n1 n2 `onLeft` AnnError
+  nr <- converge n1 n2 `onFirst` AnnError
   return (Refl, nr)
 
 --------------------------------------------
@@ -747,7 +748,7 @@
   _ -> \i _ uInstr -> typeCheckInstrErr' uInstr (SomeHST i) (Just ArithmeticOperation) $
     NotNumericTypes (demote @a) (demote @b)
 
--- | Helper function to construct instructions for binary arithmetic
+-- | Helper function to construct instructions for unary arithmetic
 -- operations.
 unaryArithImpl
   :: ( Typeable (UnaryArithRes aop n ': s)
@@ -761,3 +762,19 @@
   -> t (SomeInstr inp)
 unaryArithImpl mkInstr i@(_ ::& rs) vn = do
   pure $ i :/ mkInstr ::: ((starNotes, Dict, vn) ::& rs)
+
+-- | Helper function to construct instructions for unary arithmetic
+-- operations that should preserve annotations.
+unaryArithImplAnnotated
+  :: ( Typeable (UnaryArithRes aop n ': s)
+     , WellTyped (UnaryArithRes aop n)
+     , inp ~ (n ': s)
+     , Monad t
+     , n ~ UnaryArithRes aop n
+     )
+  => Instr inp (UnaryArithRes aop n ': s)
+  -> HST inp
+  -> VarAnn
+  -> t (SomeInstr inp)
+unaryArithImplAnnotated mkInstr i@((n, _, _) ::& rs) vn = do
+  pure $ i :/ mkInstr ::: ((n, Dict, vn) ::& rs)
diff --git a/src/Michelson/TypeCheck/Instr.hs b/src/Michelson/TypeCheck/Instr.hs
--- a/src/Michelson/TypeCheck/Instr.hs
+++ b/src/Michelson/TypeCheck/Instr.hs
@@ -62,6 +62,7 @@
 
 import Michelson.Typed
 import Util.Peano
+import Util.Type (onFirst)
 
 import qualified Michelson.Untyped as U
 import Michelson.Untyped.Annotation (VarAnn)
@@ -160,7 +161,7 @@
             (NTPair _ _ _ cpNotes stNotes, _, _) ::& SNil -> (cpNotes, stNotes)
       cParamNotes <-
         liftEither $
-        mkParamNotes paramNotesRaw rootAnn `onLeft`
+        mkParamNotes paramNotesRaw rootAnn `onFirst`
             (TCContractError "invalid parameter declaration: " . Just . IllegalParamDecl)
       case instrOut of
         instr ::: out -> liftEither $ do
@@ -168,7 +169,7 @@
             Right Refl -> do
               let (outN, _, _) ::& SNil = out
               _ <- converge outN outNote
-                      `onLeft`
+                      `onFirst`
                   ((TCContractError "contract output type violates convention:") . Just . AnnError)
               pure $ SomeContract Contract
                 { cCode = instr
@@ -705,16 +706,20 @@
       withWTPInstr' @u $
         lamImpl (U.LAMBDA vn p1 p2) uInstr is vn ins ons i
 
-  (U.EXEC vn, ((_ :: Notes t1), _, _)
+  (U.EXEC vn, ((tn :: Notes t1), _, _)
                               ::& ( STLambda _ _
-                                  , NTLambda _ (_ :: Notes t1') (t2n :: Notes t2')
+                                  , NTLambda _ (t1n :: Notes t1') (t2n :: Notes t2')
                                   , _
                                   , _
                                   )
                               ::&+ rs) -> workOnInstr uInstr $ do
     Refl <- onTypeCheckInstrErr uInstr (SomeHST inp) (Just LambdaArgument)
                   (eqType @t1 @t1')
+    (Refl, _) <- errM $ matchTypes tn t1n
     withWTPInstr @t2' $ pure $ inp :/ EXEC ::: ((t2n, Dict, vn) ::& rs)
+      where
+        errM :: (MonadReader InstrCallStack m, MonadError TCError m) => Either TCTypeError a -> m a
+        errM = onTypeCheckInstrErr uInstr (SomeHST inp) (Just LambdaArgument)
 
   (U.EXEC _, _ ::& _ ::& _) ->
     failWithErr $ UnexpectedType
@@ -888,7 +893,7 @@
     (U.ABS _, SNil) -> notEnoughItemsOnStack
 
     (U.NEG vn, (STInt, _, _, _) ::&+ _) -> workOnInstr uInstr $
-      unaryArithImpl @Neg NEG inp vn
+      unaryArithImplAnnotated @Neg NEG inp vn
     (U.NEG vn, (STNat, _, _, _) ::&+ _) -> workOnInstr uInstr $
       unaryArithImpl @Neg NEG inp vn
     (U.NEG _, _ ::& _) ->
@@ -958,9 +963,9 @@
     (U.NOT vn, (STNat, _, _, _) ::&+ _) -> workOnInstr uInstr $
       unaryArithImpl @Not NOT inp vn
     (U.NOT vn, (STBool, _, _, _) ::&+ _) -> workOnInstr uInstr $
-      unaryArithImpl @Not NOT inp vn
+      unaryArithImplAnnotated @Not NOT inp vn
     (U.NOT vn, (STInt, _, _, _) ::&+ _) -> workOnInstr uInstr $
-      unaryArithImpl @Not NOT inp vn
+      unaryArithImplAnnotated @Not NOT inp vn
     (U.NOT _, _ ::& _) ->
       failWithErr $ UnexpectedType
         $ (ExpectNat :| []) :|
@@ -1060,7 +1065,7 @@
           $ checkScope @(ParameterScope t)
         let ns = NTOption def $ NTContract def tns
         epName <- onTypeCheckInstrErr uInstr (SomeHST inp) Nothing
-          $ epNameFromRefAnn fn `onLeft` IllegalEntrypoint
+          $ epNameFromRefAnn fn `onFirst` IllegalEntrypoint
         case proofScope of
           Dict ->
             withWTPInstr @t $ pure $ inp :/ CONTRACT tns epName ::: ((ns, Dict, vn) ::& rs)
diff --git a/src/Michelson/TypeCheck/Value.hs b/src/Michelson/TypeCheck/Value.hs
--- a/src/Michelson/TypeCheck/Value.hs
+++ b/src/Michelson/TypeCheck/Value.hs
@@ -29,6 +29,7 @@
 import Tezos.Address (Address(..))
 import Tezos.Core
 import Tezos.Crypto
+import Util.Type (onFirst)
 
 tcFailedOnValue :: U.Value -> T.T -> Text -> Maybe TCTypeError -> TypeCheckInstr a
 tcFailedOnValue v t msg err = do
@@ -147,7 +148,7 @@
 
         els <- typeCheckValsImpl mels
         elsS <- liftEither $ S.fromDistinctAscList <$> ensureDistinctAsc id els
-                  `onLeft` \msg -> TCFailedOnValue sq (fromSingT vt) msg instrPos Nothing
+                  `onFirst` \msg -> TCFailedOnValue sq (fromSingT vt) msg instrPos Nothing
         pure $ VSet elsS
 
       (v@U.ValueNil, s@(STMap (st :: Sing st) _)) -> withComparable st v s $ pure $ T.VMap M.empty
@@ -216,7 +217,7 @@
       ks <- typeCheckValsImpl @kt (map (\(U.Elt k _) -> k) mels)
       vals <- typeCheckValsImpl @vt (map (\(U.Elt _ v) -> v) mels)
       ksS <- liftEither $ ensureDistinctAsc id ks
-            `onLeft` \msg -> TCFailedOnValue sq (fromSingT kt) msg instrPos Nothing
+            `onFirst` \msg -> TCFailedOnValue sq (fromSingT kt) msg instrPos Nothing
       pure $ zip ksS vals
 
     typecheckContractValue
diff --git a/src/Michelson/Typed/Doc.hs b/src/Michelson/Typed/Doc.hs
--- a/src/Michelson/Typed/Doc.hs
+++ b/src/Michelson/Typed/Doc.hs
@@ -2,6 +2,8 @@
 --
 -- SPDX-License-Identifier: LicenseRef-MIT-TQ
 
+{-# OPTIONS_GHC -Wno-orphans #-}
+
 -- | Extracting documentation from instructions set.
 module Michelson.Typed.Doc
   ( buildInstrDoc
@@ -54,26 +56,20 @@
 docInstr :: DocItem di => di -> Instr s s
 docInstr = Ext . DOC_ITEM . SomeDocItem
 
-attachGitInfo :: DGitRevision -> Instr inp out -> Instr inp out
-attachGitInfo gitRev = modifyInstrDoc $ \case
-  DGitRevisionUnknown -> Just gitRev
-  _ -> Nothing
-
-attachToc :: DToc -> Instr inp out -> Instr inp out
-attachToc toc = modifyInstrDoc $ \case
-  DToc "" -> Just $ toc
-  _ -> Nothing
-
 -- | Assemble contract documentation with the revision of the contract.
+{-# DEPRECATED buildInstrDocWithGitRev
+    "Use `buildDoc . attachDocCommons gitRev` instead."
+#-}
 buildInstrDocWithGitRev :: DGitRevision -> Instr inp out -> ContractDoc
 buildInstrDocWithGitRev gitRev contract =
   let toc = DToc $ contractDocToToc $ buildInstrDoc contract
-      c = contract
-            & attachGitInfo gitRev
-            & attachToc toc
-  in buildInstrDoc c
+      c = pure contract
+            >>= attachGitInfo gitRev
+            >>= attachToc toc
+  in buildDoc c
 
 -- | Assemble contract documentation.
+{-# DEPRECATED buildInstrDoc "Use 'buildDoc' instead." #-}
 buildInstrDoc :: Instr inp out -> ContractDoc
 buildInstrDoc = dfsFoldInstr dfsSettings $ \case
   Ext ext -> case ext of
@@ -94,6 +90,7 @@
     }
 
 -- | Modify all documentation items recursively.
+{-# DEPRECATED modifyInstrAllDoc "Use 'modifyDocEntirely' instead." #-}
 modifyInstrAllDoc
   :: (SomeDocItem -> SomeDocItem)
   -> Instr inp out
@@ -109,6 +106,7 @@
 -- matching given type.
 --
 -- If mapper returns 'Nothing', doc item will remain unmodified.
+{-# DEPRECATED modifyInstrDoc "Use 'modifyDoc' instead." #-}
 modifyInstrDoc
   :: (DocItem i1, DocItem i2)
   => (i1 -> Maybe i2)
@@ -120,6 +118,12 @@
     di' <- cast di
     newDi <- mapper di'
     return (SomeDocItem newDi)
+
+instance ContainsDoc (Instr inp out) where
+  buildDocUnfinalized = buildInstrDoc
+
+instance ContainsUpdateableDoc (Instr inp out) where
+  modifyDocEntirely = modifyInstrAllDoc
 
 -- | Leave only instructions related to documentation.
 --
diff --git a/src/Michelson/Typed/Haskell.hs b/src/Michelson/Typed/Haskell.hs
--- a/src/Michelson/Typed/Haskell.hs
+++ b/src/Michelson/Typed/Haskell.hs
@@ -7,6 +7,7 @@
   ( module Exports
   ) where
 
+import Michelson.Typed.Haskell.Compatibility as Exports
 import Michelson.Typed.Haskell.Doc as Exports
 import Michelson.Typed.Haskell.Instr as Exports
 import Michelson.Typed.Haskell.LooseSum as Exports
diff --git a/src/Michelson/Typed/Haskell/Compatibility.hs b/src/Michelson/Typed/Haskell/Compatibility.hs
new file mode 100644
--- /dev/null
+++ b/src/Michelson/Typed/Haskell/Compatibility.hs
@@ -0,0 +1,40 @@
+-- SPDX-FileCopyrightText: 2020 Tocqueville Group
+--
+-- SPDX-License-Identifier: LicenseRef-MIT-TQ
+
+-- | Compatibility of Haskell values representation in Michelson.
+module Michelson.Typed.Haskell.Compatibility
+  ( ligoLayout
+  , ligoCombLayout
+  ) where
+
+import Util.CustomGeneric
+
+-- | Default layout in LIGO.
+--
+-- To be used with 'customGeneric', see this method for more info.
+--
+-- This is similar to 'leftBalanced', but
+--
+-- * fields are sorted alphabetically;
+-- * always puts as large complete binary subtrees as possible at left.
+ligoLayout :: GenericStrategy
+ligoLayout =
+  reorderingData forbidUnnamedFields alphabetically $
+    fromDepthsStrategy ligoDepths
+  where
+    ligoDepths n =
+      case fmap last . nonEmpty $ takeWhile (\(_, p) -> p <= n) powersOfTwo of
+        Nothing -> []
+        Just (depth, power) ->
+          let leftSub = replicate power depth
+              rightSub = ligoDepths (n - power)
+          in if null rightSub then leftSub else map succ $ leftSub ++ rightSub
+
+    powersOfTwo = [0..] <&> \i -> (i, 2 ^ i)
+
+-- | Comb layout in LIGO (@ [\@layout:comb] @).
+--
+-- To be used with 'customGeneric'.
+ligoCombLayout :: GenericStrategy
+ligoCombLayout = rightComb
diff --git a/src/Michelson/Typed/Haskell/Doc.hs b/src/Michelson/Typed/Haskell/Doc.hs
--- a/src/Michelson/Typed/Haskell/Doc.hs
+++ b/src/Michelson/Typed/Haskell/Doc.hs
@@ -39,6 +39,7 @@
 
   , DType (..)
   , DStorageType (..)
+  , dStorage
   , GTypeHasDoc
   , GProductHasDoc
   , dTypeDep
@@ -105,7 +106,7 @@
 -- | Show given 'ADTRep' in a neat way.
 buildADTRep :: forall a. (WithinParens -> a -> Markdown) -> ADTRep a -> Markdown
 buildADTRep buildField = \case
-  ConstructorRep{..} :| [] -> renderProduct (WithinParens False) crFields
+  ctor@ConstructorRep{..} :| [] -> renderProduct (WithinParens False) ctor crFields
   ps -> (mappend (mdItalic "one of" <> " \n")) $
         foldMap
         (toListItem . renderNamedProduct (WithinParens True)) (toList ps)
@@ -113,26 +114,29 @@
     toListItem item = "+ " <> item <> "\n"
 
     renderNamedProduct :: WithinParens -> ConstructorRep a -> Markdown
-    renderNamedProduct wp ConstructorRep{..} =
+    renderNamedProduct wp ctor@ConstructorRep{..} =
       mdBold (build crName) <>
       if hasFieldNames
-         then maybe "" (\d -> ": " <> build d <> " ") crDescription <> renderProduct wp crFields
-         else renderProduct wp crFields <> maybe "" (\d -> ": " <> build d) crDescription
+         then maybe "" (\d -> ": " <> build d <> " ") crDescription <>
+              renderProduct wp ctor crFields
+         else renderProduct wp ctor crFields <>
+              maybe "" (\d -> ": " <> build d) crDescription
       where
         hasFieldNames = any (isJust . frName) crFields
 
-    renderProduct :: WithinParens -> [FieldRep a] -> Markdown
-    renderProduct wp = \case
+    renderProduct :: WithinParens -> ConstructorRep a -> [FieldRep a] -> Markdown
+    renderProduct wp ctor = \case
       [] -> "()"
-      [t] -> "\n" <> renderNamedField wp t
-      ts -> "\n" <> (mconcat . intersperse "\n" $ map (renderNamedField wp) ts)
+      [t@FieldRep{ frDescription = Nothing }]
+        | Nothing <- crDescription ctor -> renderNamedField wp t
+      ts -> mconcat $ map (("\n  * " <>) . renderNamedField wp) ts
 
     renderNamedField :: WithinParens -> FieldRep a -> Markdown
-    renderNamedField wp FieldRep{frName = Just fieldName, ..} =
-      "  * " <> buildFieldName fieldName <> buildField wp frTypeRep <>
-      maybe "" (mappend "    " . mappend "\n" . build) frDescription
-
-    renderNamedField wp FieldRep{frName = Nothing, ..} = buildField wp frTypeRep
+    renderNamedField wp FieldRep{..} = mconcat
+      [ maybe "" buildFieldName frName
+      , buildField wp frTypeRep
+      , maybe "" (mappend "    " . mappend "\n" . build) frDescription
+      ]
 
 -- | Map field names in a 'ADTRep', with the possibility to remove some names by
 -- mapping them to 'Nothing'.
@@ -377,6 +381,10 @@
 -- | Doc element with description of contract storage type.
 newtype DStorageType = DStorageType DType
   deriving stock (Generic, Eq, Ord)
+
+-- | Shortcut for 'DStorageType'.
+dStorage :: forall store. TypeHasDoc store => DStorageType
+dStorage = DStorageType $ DType (Proxy @store)
 
 instance DocItem DStorageType where
   type DocItemPlacement DStorageType = 'DocItemInlined
diff --git a/src/Michelson/Typed/Instr.hs b/src/Michelson/Typed/Instr.hs
--- a/src/Michelson/Typed/Instr.hs
+++ b/src/Michelson/Typed/Instr.hs
@@ -16,6 +16,7 @@
   , TestAssert (..)
   , ContractCode
   , Contract (..)
+  , defaultContract
   , mapContractCode
   , mapEntriesOrdered
   , pattern CAR
@@ -31,6 +32,7 @@
   , ConstraintDUG'
   ) where
 
+import Data.Default
 import Data.Singletons (Sing)
 import Fmt (Buildable(..), (+||), (||+))
 import qualified GHC.TypeNats as GHC (Nat)
@@ -39,7 +41,7 @@
 import Michelson.Doc
 import Michelson.ErrorPos
 import Michelson.Printer.Util (RenderDoc(..), buildRenderDoc, needsParens, printDocS)
-import Michelson.Typed.Annotation (Notes(..))
+import Michelson.Typed.Annotation (Notes(..), starNotes)
 import Michelson.Typed.Arith
 import Michelson.Typed.Entrypoints
 import Michelson.Typed.Polymorphic
@@ -476,6 +478,14 @@
 deriving stock instance Eq (ContractCode cp st) => Eq (Contract cp st)
 instance NFData (Contract cp st) where
   rnf (Contract a b c d) = rnf (a, b, c, d)
+
+defaultContract :: (ParameterScope cp, StorageScope st) => ContractCode cp st -> Contract cp st
+defaultContract code = Contract
+  { cCode = code
+  , cParamNotes = starParamNotes
+  , cStoreNotes = starNotes
+  , cEntriesOrder = def
+  }
 
 mapContractCode
   :: (ContractCode cp st -> ContractCode cp st)
diff --git a/src/Michelson/Typed/Util.hs b/src/Michelson/Typed/Util.hs
--- a/src/Michelson/Typed/Util.hs
+++ b/src/Michelson/Typed/Util.hs
@@ -144,6 +144,8 @@
       | otherwise -> step i
 
     Nop{} -> step i
+    Ext (TEST_ASSERT (TestAssert nm pc i1)) ->
+      recursion1 (Ext . TEST_ASSERT . TestAssert nm pc) i1
     Ext{} -> step i
     AnnCAR{} -> step i
     AnnCDR{} -> step i
diff --git a/src/Michelson/Untyped/Instr.hs b/src/Michelson/Untyped/Instr.hs
--- a/src/Michelson/Untyped/Instr.hs
+++ b/src/Michelson/Untyped/Instr.hs
@@ -126,7 +126,7 @@
   | RIGHT             TypeAnn VarAnn FieldAnn FieldAnn Type
   | IF_LEFT           [op] [op]
   | NIL               TypeAnn VarAnn Type
-  | CONS              VarAnn -- TODO add TypeNote param
+  | CONS              VarAnn
   | IF_CONS           [op] [op]
   | SIZE              VarAnn
   | EMPTY_SET         TypeAnn VarAnn Type
@@ -141,7 +141,6 @@
   | LOOP              [op]
   | LOOP_LEFT         [op]
   | LAMBDA            VarAnn Type Type [op]
-  -- TODO check on alphanet whether we can pass TypeNote
   | EXEC              VarAnn
   | APPLY             VarAnn
   | DIP               [op]
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
@@ -16,11 +16,13 @@
   , annotFromText
   ) where
 
+import Control.Lens (Plated)
 import Data.Aeson
   (FromJSON, ToJSON, object, parseJSON, toEncoding, toJSON, withObject, withText, (.!=), (.:),
   (.:?), (.=))
 import qualified Data.Aeson.Encoding.Internal as Aeson
 import qualified Data.Aeson.Types as Aeson
+import Data.Data (Data)
 import qualified Data.HashMap.Strict as HashMap
 import qualified Data.Sequence as Seq
 import qualified Data.Text as T (uncons)
@@ -29,13 +31,13 @@
 import Michelson.Untyped.Annotation
   (FieldAnn, FieldTag, KnownAnnTag(..), TypeAnn, TypeTag, VarAnn, VarTag, ann, annPrefix)
 import qualified Michelson.Untyped.Annotation as MUA (Annotation)
-import Morley.Micheline.Json
+import Morley.Micheline.Json (StringEncode(StringEncode, unStringEncode))
 import Tezos.Crypto (encodeBase58Check)
 import Util.ByteString (HexJSONByteString(..))
 
 newtype MichelinePrimitive = MichelinePrimitive Text
   deriving newtype (Eq, Ord, ToJSON, FromJSON)
-  deriving stock (Show)
+  deriving stock (Show, Data)
 
 michelsonPrimitive :: Seq Text
 michelsonPrimitive = Seq.fromList [
@@ -69,8 +71,10 @@
   | ExpressionBytes ByteString
   | ExpressionSeq (Seq Expression)
   | ExpressionPrim MichelinePrimAp
-  deriving stock (Eq, Show)
+  deriving stock (Eq, Show, Data)
 
+instance Plated Expression
+
 instance Buildable Expression where
   build = \case
     ExpressionInt i -> build $ i
@@ -91,13 +95,13 @@
   = AnnotationType TypeAnn
   | AnnotationVariable VarAnn
   | AnnotationField FieldAnn
-  deriving stock (Eq, Show)
+  deriving stock (Eq, Show, Data)
 
 data MichelinePrimAp = MichelinePrimAp
   { mpaPrim :: MichelinePrimitive
   , mpaArgs :: Seq Expression
   , mpaAnnots :: Seq Annotation
-  } deriving stock (Eq, Show)
+  } deriving stock (Eq, Show, Data)
 
 instance FromJSON MichelinePrimAp where
   parseJSON = withObject "Prim" $ \v -> MichelinePrimAp
diff --git a/src/Morley/Micheline/Json.hs b/src/Morley/Micheline/Json.hs
--- a/src/Morley/Micheline/Json.hs
+++ b/src/Morley/Micheline/Json.hs
@@ -20,8 +20,11 @@
 import Fmt (Buildable(..))
 import qualified Text.Show as T
 
-import Tezos.Core (Mutez, mkMutez')
+import Tezos.Core (Mutez, mkMutez', mutezToInt64)
 
+printAsString :: Show a => a -> Aeson.Value
+printAsString a = Aeson.String $ show a
+
 parseAsString :: forall a. (Read a, Typeable a) => Aeson.Value -> Aeson.Parser a
 parseAsString = Aeson.withText (T.show $ typeRep (Proxy :: Proxy a)) $ \txt ->
   maybe (fail "Failed to parse string") pure $ readMaybe (toString txt)
@@ -55,9 +58,12 @@
   toEncoding (StringEncode x) = AE.int64Text x
 
 newtype TezosMutez = TezosMutez { unTezosMutez :: Mutez }
-  deriving stock (Show)
+  deriving stock (Show, Eq, Ord)
 
+instance ToJSON TezosMutez where
+  toJSON = printAsString . mutezToInt64 . unTezosMutez
+
 instance FromJSON TezosMutez where
   parseJSON v = do
-    StringEncode i <- parseStringEncodedIntegral @Int64 v
+    i <- parseAsString @Int64 v
     either (fail . toString) (pure . TezosMutez) $ mkMutez' i
diff --git a/src/Tezos/Core.hs b/src/Tezos/Core.hs
--- a/src/Tezos/Core.hs
+++ b/src/Tezos/Core.hs
@@ -19,6 +19,7 @@
   , mulMutez
   , divModMutez
   , divModMutezInt
+  , mutezToInt64
   , zeroMutez
   , oneMutez
   , prettyTez
@@ -175,6 +176,12 @@
   where
     toMutez' :: Integer -> Mutez
     toMutez' = Mutez . fromInteger
+
+-- | Convert mutez to signed number.
+--
+-- TODO [#423]: try to provide a generic safe conversion method
+mutezToInt64 :: Mutez -> Int64
+mutezToInt64 = fromIntegral . unMutez
 
 zeroMutez :: Mutez
 zeroMutez = Mutez minBound
diff --git a/src/Util/CustomGeneric.hs b/src/Util/CustomGeneric.hs
--- a/src/Util/CustomGeneric.hs
+++ b/src/Util/CustomGeneric.hs
@@ -6,21 +6,35 @@
 
 module Util.CustomGeneric
   ( -- * Custom Generic strategies
-    withDepths
+    GenericStrategy
+  , withDepths
   , rightBalanced
   , leftBalanced
   , rightComb
   , leftComb
+  , haskellBalanced
+    -- ** Entries reordering
+  , reorderingConstrs
+  , reorderingFields
+  , reorderingData
+  , alphabetically
+  , leaveUnnamedFields
+  , forbidUnnamedFields
     -- * Depth usage helpers
   , cstr
   , fld
     -- * Instance derivation
   , customGeneric
+
+    -- * Helpers
+  , fromDepthsStrategy
   ) where
 
-import qualified GHC.Generics as G
+import Control.Lens (traversed)
 import Generics.Deriving.TH (makeRep0Inline)
+import qualified GHC.Generics as G
 import Language.Haskell.TH
+import Util.Generic
 
 ----------------------------------------------------------------------------
 -- Simple type synonyms
@@ -37,25 +51,58 @@
 -- of fields. Used only in this module.
 type CstrShape = (Name, Int)
 
--- | Type of a strategy to derive 'G.Generic' instances, it will be given the actual
--- 'CstrShape's for a data-type and needs to return the 'CstrDepth's for it.
--- It should when possible make checks and 'fail', using the constructors' 'Name'
--- provided by the 'CstrShape'.
-type GenericStrategy = [CstrShape] -> Q [CstrDepth]
+-- | Simple tuple that carries basic info about a constructor: it's name,
+-- number of its fields and their names. Used only in this module.
+type CstrNames = (Name, Int, Maybe [Name])
 
+-- | Type of a strategy to derive 'G.Generic' instances.
+data GenericStrategy = GenericStrategy
+  { gsEvalDepths :: [CstrShape] -> Q [CstrDepth]
+    -- ^ Given the 'CstrShape's for given datatype,
+    -- return the 'CstrDepth's for it.
+    -- This function should when possible make checks and 'fail', using the
+    -- constructors' 'Name' provided by the 'CstrShape'.
+  , gsReorderCstrsOn :: forall a. [(Text, a)] -> Q [a]
+    -- ^ Reorder constructors given their names.
+  , gsReorderFieldsOn :: forall a. Either [a] [(Text, a)] -> Q [a]
+    -- ^ Reorder fields given their names, the argument depends on whether
+    -- fields are part of record (and thus named) or not (unnamed).
+  }
+
+-- | Defines how to reorder fields or constructors.
+type EntriesReorder = forall a. [(Text, a)] -> Q [a]
+
+-- | Defines how to reorder fields when their names are unknown.
+type UnnamedEntriesReorder = forall a. [a] -> Q [a]
+
 -- | Simple type synonym used (internally) between functions, basically extending
 -- 'CstrDepth' with the 'Name's of the constructor and its fields.
-type NamedCstrDepths = (Natural, Name, [(Natural, Name)])
+-- For fields it carries both names in the original order and in the order specified
+-- by the strategy (and the latter is paired with depths).
+data NamedCstrDepths = NCD
+  { ncdCstrDepth :: Natural
+    -- ^ Constructor's depth
+  , ncdCstrName :: Name
+    -- ^ Constructor's name
+  , ncdOrigFieldNames :: [Name]
+    -- ^ Names of constructor fields in the original order.
+  , ncdFields :: [(Natural, Name)]
+    -- ^ Names and depths of constructor fields after the reordering.
+  }
 
+-- | Reorders entries corresponding to constructors (@a@) and fields (@b@)
+-- according to some rule.
+type EntriesTransp = forall a b. [a] -> Q [([b] -> Q [b], a)]
+
 ----------------------------------------------------------------------------
--- Custom Generic strategies
+-- Generic strategies
 ----------------------------------------------------------------------------
 
 -- | In this strategy the desired depths of contructors (in the type tree) and
 -- fields (in each constructor's tree) are provided manually and simply checked
 -- against the number of actual constructors and fields.
 withDepths :: [CstrDepth] -> GenericStrategy
-withDepths treeDepths cstrShape = do
+withDepths treeDepths = simpleGenericStrategy $ \cstrShape -> do
   when (length treeDepths /= length cstrShape) $ fail
     "Number of contructors' depths does not match number of data contructors."
   forM_ (zip (map snd treeDepths) cstrShape) $ \(fDepths, (constrName, fldNum)) ->
@@ -65,10 +112,17 @@
   return treeDepths
 
 -- | Strategy to make right-balanced instances (both in constructors and fields).
+--
+-- This will try its best to produce a flat tree:
+--
+-- * the balances of all leaves differ no more than by 1;
+-- * leaves at left will have equal or lesser depth than leaves at right.
 rightBalanced :: GenericStrategy
 rightBalanced = fromDepthsStrategy makeRightBalDepths
 
 -- | Strategy to make left-balanced instances (both in constructors and fields).
+--
+-- This is the same as symmetrically mapped 'rightBalanced'.
 leftBalanced :: GenericStrategy
 leftBalanced = fromDepthsStrategy (reverse . makeRightBalDepths)
 
@@ -80,15 +134,99 @@
 leftComb :: GenericStrategy
 leftComb = fromDepthsStrategy makeLeftCombDepths
 
+-- | Strategy to make Haskell's Generics-like instances
+-- (both in constructors and fields).
+--
+-- This is similar to 'rightBalanced', except for the "flat" part:
+--
+-- * for each node, size of the left subtree is equal or less by one than
+-- size of the right subtree.
+--
+-- This strategy matches A1.1.
+--
+-- @customGeneric "T" haskellBalanced@ is equivalent to mere
+-- @deriving stock Generic T@.
+haskellBalanced :: GenericStrategy
+haskellBalanced = fromDepthsStrategy makeHaskellDepths
+
+-- Order modifiers
 ----------------------------------------------------------------------------
+
+-- | Modify given strategy to reorder constructors.
+--
+-- The reordering will take place before depths are evaluated and structure
+-- of generic representation is formed.
+--
+-- Example: @reorderingConstrs alphabetically rightBalanced@.
+reorderingConstrs :: EntriesReorder -> GenericStrategy -> GenericStrategy
+reorderingConstrs reorder gs = gs
+  { gsReorderCstrsOn = reorder
+  }
+
+-- | Modify given strategy to reorder fields.
+--
+-- Same notes as for 'reorderingConstrs' apply here.
+--
+-- Example: @reorderingFields forbidUnnamedFields alphabetically rightBalanced@.
+reorderingFields
+  :: UnnamedEntriesReorder
+  -> EntriesReorder
+  -> GenericStrategy -> GenericStrategy
+reorderingFields reorderUnnamed reorder gs = gs
+  { gsReorderFieldsOn = either reorderUnnamed reorder
+  }
+
+-- | Modify given strategy to reorder constructors and fields.
+--
+-- Same notes as for 'reorderingConstrs' apply here.
+--
+-- Example: @reorderingData forbidUnnamedFields alphabetically rightBalanced@.
+reorderingData
+  :: UnnamedEntriesReorder
+  -> EntriesReorder
+  -> GenericStrategy -> GenericStrategy
+reorderingData reorderUnnamed reorder =
+  reorderingFields reorderUnnamed reorder . reorderingConstrs reorder
+
+-- | Sort entries by name alphabetically.
+alphabetically :: EntriesReorder
+alphabetically = pure . map snd . sortWith fst
+
+-- | Leave unnamed fields intact, without any reordering.
+leaveUnnamedFields :: UnnamedEntriesReorder
+leaveUnnamedFields = pure
+
+-- | Fail in case records are unnamed and we cannot figure
+-- out the necessary reordering.
+forbidUnnamedFields :: UnnamedEntriesReorder
+forbidUnnamedFields fields =
+  if length fields <= 1
+  then return fields
+  else fail "Encountered unnamed fields, cannot apply reordering"
+
+----------------------------------------------------------------------------
 -- Generic strategies' builders
 ----------------------------------------------------------------------------
 
+-- | Construct a strategy that only constructs Generic instance of given
+-- form, without e.g. changing the order of entries.
+simpleGenericStrategy :: ([CstrShape] -> Q [CstrDepth]) -> GenericStrategy
+simpleGenericStrategy mkDepths = GenericStrategy
+  { gsEvalDepths = mkDepths
+  , gsReorderCstrsOn = pure . map snd
+  , gsReorderFieldsOn = pure . either id (map snd)
+  }
+
 -- | Helper to make a strategy that created depths for constructor and fields
 -- in the same way, just from their number.
+--
+-- The provided function @f@ must satisfy the following rules:
+--
+-- * @length (f n) ≡ n@
+-- * @sum $ (\x -> 2 ^^ (-x)) <$> f n ≡ 1@ (unless @n = 0@)
 fromDepthsStrategy :: (Int -> [Natural]) -> GenericStrategy
-fromDepthsStrategy dStrategy cShapes = return $
-  zip (dStrategy $ length cShapes) $ map (dStrategy . snd) cShapes
+fromDepthsStrategy dStrategy = simpleGenericStrategy $ \cShapes -> return $
+  zip (dStrategy $ length cShapes) $ map (dStrategy . view _2) cShapes
 
 makeRightBalDepths :: Int -> [Natural]
 makeRightBalDepths n = foldr (const addRightBalDepth) [] [1..n]
@@ -104,6 +242,12 @@
 makeLeftCombDepths 0 = []
 makeLeftCombDepths n = map fromIntegral $ (n - 1) : [n - 1, n - 2..1]
 
+makeHaskellDepths :: Int -> [Natural]
+makeHaskellDepths n =
+  case nonEmpty (replicate n [0]) of
+    Nothing -> []
+    Just leaves -> mkGenericTree (\_ l r -> map succ (l ++ r)) leaves
+
 ----------------------------------------------------------------------------
 -- Depth usage helpers
 ----------------------------------------------------------------------------
@@ -128,6 +272,8 @@
 -- Instance derivation
 ----------------------------------------------------------------------------
 
+{-# ANN module ("HLint: ignore Use snd" :: Text) #-}
+
 -- | Derives the 'G.Generic' instance for a type given its name and a
 -- 'GenericStrategy' to use.
 --
@@ -177,24 +323,47 @@
 -- $(customGeneric "CustomType" leftComb)
 -- @@@
 --
+-- Developers are welcome to provide their own derivation strategies,
+-- and some useful strategies can be found outside of this module by
+-- 'GenericStrategy' signature.
 customGeneric :: String -> GenericStrategy -> Q [Dec]
 customGeneric typeStr genStrategy = do
   -- reify the data type
   (typeName, mKind, vars, constructors) <- reifyDataType typeStr
   -- obtain info about its constructor and desired tree
   let derivedType = deriveFullType typeName mKind vars
-  cShapes <- cstrShapes constructors
-  treeDepths <- genStrategy cShapes
-  weightedConstrs <- makeWeightedConstrs treeDepths cShapes
+  cNames <- cstrNames constructors
+  let cReordering :: EntriesTransp
+      cReordering = reorderCstrs genStrategy cNames
+  let cShapes = cNames <&> \(name, fNum, _) -> (name, fNum)
+  cShapesSorted <- cReordering cShapes <&> map \(_fReorder, cShape) -> cShape
+  treeDepths <- gsEvalDepths genStrategy cShapesSorted
+  weightedConstrs <- makeWeightedConstrs cReordering treeDepths cShapesSorted
   -- produce the Generic instance
   res <- instanceD (pure []) (appT (conT ''G.Generic) derivedType)
     [ tySynInstD . tySynEqn Nothing (appT (conT ''G.Rep) derivedType) $
-        makeUnbalancedRep typeName treeDepths derivedType
+        makeUnbalancedRep typeName treeDepths cReordering derivedType
     , makeUnbalancedFrom weightedConstrs
     , makeUnbalancedTo weightedConstrs
     ]
   return [res]
 
+-- | Apply a reordering strategy.
+--
+-- This uses given @[CstrNames]@ to understand how constructors and their
+-- fields should be reordered, and applies the same transposition to entries
+-- within 'EntriesTransp'.
+reorderCstrs :: GenericStrategy -> [CstrNames] -> EntriesTransp
+reorderCstrs GenericStrategy{..} cNames = \cstrEntries ->
+  gsReorderCstrsOn $
+    zip cNames cstrEntries <&> \(cstrName@(name, _, _), cstrEntry) ->
+      (origName name, (fieldsReorder cstrName, cstrEntry))
+  where
+    fieldsReorder :: CstrNames -> [b] -> Q [b]
+    fieldsReorder (_, _, mFieldNames) = \fieldEntries -> do
+      gsReorderFieldsOn $
+        maybe Left (Right ... zip . map origName) mFieldNames fieldEntries
+
 -- | Reifies info from a type name (given as a 'String').
 -- The lookup happens from the current splice's scope (see 'lookupTypeName') and
 -- the only accepted result is a "plain" data type (no GADTs).
@@ -223,22 +392,30 @@
       PlainTV vName       -> varT vName
       KindedTV vName kind -> sigT (varT vName) kind
 
--- | Calculate the "shape" for each of the given constructors.
--- The shape is simply the 'Name' of the constructor and the number of its args.
-cstrShapes :: [Con] -> Q [CstrShape]
-cstrShapes constructors = forM constructors $ \case
-  NormalC name lst -> return (name, length lst)
-  RecC name lst    -> return (name, length lst)
-  InfixC _ name _  -> return (name, 2)
+-- | Extract the info for each of the given constructors.
+cstrNames :: [Con] -> Q [CstrNames]
+cstrNames constructors = forM constructors $ \case
+  NormalC name lst -> return (name, length lst, Nothing)
+  RecC name lst    -> return (name, length lst, Just $ lst ^.. traversed . _1)
+  InfixC _ name _  -> return (name, 2, Nothing)
   constr           -> fail $ "Unsupported constructor: " <> show constr
 
 -- | Combines depths with constructors, 'fail'ing in case of mismatches, and
 -- generates 'Name's for the constructors' arguments.
-makeWeightedConstrs :: [CstrDepth] -> [CstrShape] -> Q [NamedCstrDepths]
-makeWeightedConstrs treeDepths cSizes = do
-  forM (zip treeDepths cSizes) $ \((cDepth, fDepths), (cName, fNum)) -> do
-    constrVarsNames <- replicateM fNum $ newName "v"
-    return (cDepth, cName, zip fDepths constrVarsNames)
+makeWeightedConstrs
+  :: EntriesTransp -> [CstrDepth] -> [CstrShape] -> Q [NamedCstrDepths]
+makeWeightedConstrs cReorder treeDepths cShapes = do
+  reorderedShapes <- cReorder cShapes
+  forM (zip treeDepths reorderedShapes) $
+    \((cDepth, fDepths), (fReorder, (cName, fNum))) -> do
+      fieldVarsNames <- replicateM fNum (newName "v")
+      reorderedFieldVarNames <- fReorder fieldVarsNames
+      return NCD
+        { ncdCstrDepth = cDepth
+        , ncdCstrName = cName
+        , ncdOrigFieldNames = fieldVarsNames
+        , ncdFields = zip fDepths reorderedFieldVarNames
+        }
 
 -- | Creates the 'G.Rep' type for an unbalanced 'G.Generic' instance, for a type
 -- given its name, constructors' depths and derived full type.
@@ -246,23 +423,27 @@
 -- Note: given that these types definition can be very complex to generate,
 -- especially in the metadata, here we let @generic-deriving@ make a balanced
 -- value first (see 'makeRep0Inline') and then de-balance the result.
-makeUnbalancedRep :: Name -> [CstrDepth] -> TypeQ -> TypeQ
-makeUnbalancedRep typeName treeDepths derivedType = do
+makeUnbalancedRep :: Name -> [CstrDepth] -> EntriesTransp -> TypeQ -> TypeQ
+makeUnbalancedRep typeName treeDepths reorderConstrs derivedType = do
   -- let generic-deriving create the balanced type first
   balRep <- makeRep0Inline typeName derivedType
   -- separate the top-most type metadata from the constructors' trees
   (typeMd, constrTypes) <- dismantleGenericTree [t| (G.:+:) |] [t| G.C1 |] balRep
   -- for each of the constructor's trees
-  unbalConstrs <- forM (zip constrTypes treeDepths) $ \(constrType, treeDepth) ->
+  reorderedConstrTypes <- reorderConstrs constrTypes
+  unbalConstrs <- forM (zip reorderedConstrTypes treeDepths) $
+    \((reorderFields, constrType), treeDepth) ->
     case treeDepth of
       (n, []) ->
         -- when there are no fields there is no tree to unbalance
         return (n, constrType)
-      (n, fields) -> do
+      (n, fieldDepths) -> do
         -- separate the top-most constructor metadata from the fields' trees
         (constrMd, fieldTypes) <- dismantleGenericTree [t| (G.:*:) |] [t| G.S1 |] constrType
         -- build the unbalanced tree of fields
-        unbalConstRes <- unbalancedFold (zip fields fieldTypes) (appT . appT (conT ''(G.:*:)))
+        reorderedFieldTypes <- reorderFields fieldTypes
+        unbalConstRes <- unbalancedFold (zip fieldDepths reorderedFieldTypes)
+                                        (appT . appT (conT ''(G.:*:)))
         -- return the new unbalanced constructor
         return (n, AppT constrMd unbalConstRes)
   -- build the unbalanced tree of constructors and rebuild the type
@@ -293,14 +474,13 @@
 -- its list of weighted constructors.
 makeUnbalancedFrom :: [NamedCstrDepths] -> DecQ
 makeUnbalancedFrom wConstrs = do
-  (cPatts, cDepthExp) <- fmap unzip . forM wConstrs $ \(cDepth, cName, wFields) -> do
-    (fPatts, fDepthExp) <- fmap unzip . forM wFields $ \(fDepth, fName) -> do
-      -- make pattern for field variable
-      fPat <- varP fName
+  (cPatts, cDepthExp) <- fmap unzip . forM wConstrs $ \(NCD cDepth cName wOrigFields wFields) -> do
+    fDepthExp <- forM wFields $ \(fDepth, fName) -> do
       -- make expression to asseble a Generic Field from its variable
       fExpr <- appE [| G.M1 |] . appE [| G.K1 |] $ varE fName
-      return (fPat, (fDepth, fExpr))
+      return (fDepth, fExpr)
     -- make pattern for this constructor
+    fPatts <- mapM varP wOrigFields
     let cPatt = ConP cName fPatts
     -- make expression to assemble its fields as an isolated Generic Constructor
     cExp <- appE [| G.M1 |] $ case fDepthExp of
@@ -317,18 +497,17 @@
 -- its list of weighted constructors.
 makeUnbalancedTo :: [NamedCstrDepths] -> DecQ
 makeUnbalancedTo wConstrs = do
-  (cExps, cDepthPat) <- fmap unzip . forM wConstrs $ \(cDepth, cName, wFields) -> do
-    (fExps, fDepthPat) <- fmap unzip . forM wFields $ \(fDepth, fName) -> do
-      -- make expression for field variable
-      fExp <- varE fName
+  (cExps, cDepthPat) <- fmap unzip . forM wConstrs $ \(NCD cDepth cName wOrigFields wFields) -> do
+    fDepthPat <- forM wFields $ \(fDepth, fName) -> do
       -- make pattern for a Generic Field from its variable
       fPatt <- conP1 'G.M1 . conP1 'G.K1 $ varP fName
-      return (fExp, (fDepth, fPatt))
+      return (fDepth, fPatt)
     -- make pattern for this isolated Generic Constructor
     cPatt <- conP1 'G.M1 $ case fDepthPat of
       [] -> conP 'G.U1 []
       _  -> unbalancedFold fDepthPat (conP2 '(G.:*:))
     -- make expression to assemble this constructor
+    fExps <- mapM varE wOrigFields
     let cExp = foldl AppE (ConE cName) fExps
     return (cExp, (cDepth, [cPatt]))
   -- make patterns for all Generic Constructors
@@ -379,3 +558,7 @@
 
 mapQ :: (Q a -> Q a) -> Q [a] -> Q [a]
 mapQ f qlst = qlst >>= mapM (f . pure)
+
+-- | Original name of a constructor or field.
+origName :: Name -> Text
+origName = toText . nameBase
diff --git a/src/Util/Type.hs b/src/Util/Type.hs
--- a/src/Util/Type.hs
+++ b/src/Util/Type.hs
@@ -36,6 +36,8 @@
   , listOfTypesConcatAssociativityAxiom
 
   , MockableConstraint (..)
+
+  , onFirst
   ) where
 
 import Data.Constraint ((:-)(..), Dict(..), (\\))
@@ -232,3 +234,7 @@
     Dict <- pure $ provideConstraintUnsafe @c5
     return Dict
   {-# INLINE provideConstraintUnsafe #-}
+
+-- | Utility function to help transform the first argument of a binfunctor.
+onFirst :: Bifunctor p => p a c -> (a -> b) -> p b c
+onFirst = flip first